Skip to content

H
haskell-igraph
Commit 2183f77c authored by Kai Zhang's avatar Kai Zhang
Browse files
Options

fix memory leaks for more foreign structs

parent 174692fe
Hide whitespace changes
Inline Side-by-side
Showing with 114 additions and 100 deletions
cbits/haskell_attributes.c
View file @ 2183f77c
......@@ -466,6 +466,8 @@ int igraph_haskell_attribute_add_edges(igraph_t *graph, const igraph_vector_t *e
}
if (oldrec->type == IGRAPH_ATTRIBUTE_STRING) {
if (ne != bsvector_size(newstr)) {
printf("number of edges: %d\n", ne);
printf("number of attributes: %d\n", bsvector_size(newstr));
IGRAPH_ERROR("Invalid string attribute length", IGRAPH_EINVAL);
}
IGRAPH_CHECK(bsvector_append(oldstr, newstr));
......
cbits/haskell_igraph.c
View file @ 2183f77c
#include <igraph/igraph.h>
#include "haskell_attributes.h"
void my_igraph_vector_destroy(igraph_vector_t* v) {
printf("free vector\n");
igraph_vector_destroy(v);
}
const igraph_attribute_table_t igraph_haskell_attribute_table={
&igraph_haskell_attribute_init, &igraph_haskell_attribute_destroy,
&igraph_haskell_attribute_copy, &igraph_haskell_attribute_add_vertices,
......
include/haskell_igraph.h
View file @ 2183f77c
......@@ -5,4 +5,6 @@
void haskelligraph_init();
void my_igraph_vector_destroy(igraph_vector_t* v);
#endif
src/IGraph.hs
View file @ 2183f77c
......@@ -37,6 +37,7 @@ import Control.Monad.Primitive
import Control.Monad.ST (runST)
import qualified Data.ByteString as B
import Data.Conduit.Cereal
import Data.Either (fromRight)
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as S
......@@ -92,7 +93,8 @@ class MGraph d => Graph d where
-- | Return the label of given node.
nodeLab :: Serialize v => LGraph d v e -> Node -> v
nodeLab (LGraph g _) i = unsafePerformIO $
igraphHaskellAttributeVAS g vertexAttr i >>= fromBS
igraphHaskellAttributeVAS g vertexAttr i >>= bsToByteString >>=
return . fromRight (error "decode failed") . decode
{-# INLINE nodeLab #-}
-- | Return all nodes that are associated with given label.
......@@ -104,7 +106,8 @@ class MGraph d => Graph d where
edgeLab :: Serialize e => LGraph d v e -> Edge -> e
edgeLab (LGraph g _) (fr,to) = unsafePerformIO $
igraphGetEid g fr to True True >>=
igraphHaskellAttributeEAS g edgeAttr >>= fromBS
igraphHaskellAttributeEAS g edgeAttr >>= bsToByteString >>=
return . fromRight (error "decode failed") . decode
{-# INLINE edgeLab #-}
-- | Find the edge by edge ID.
......@@ -115,7 +118,8 @@ class MGraph d => Graph d where
-- | Find the edge label by edge ID.
edgeLabByEid :: Serialize e => LGraph d v e -> Int -> e
edgeLabByEid (LGraph g _) i = unsafePerformIO $
igraphHaskellAttributeEAS g edgeAttr i >>= fromBS
igraphHaskellAttributeEAS g edgeAttr i >>= bsToByteString >>=
return . fromRight (error "decode failed") . decode
{-# INLINE edgeLabByEid #-}
instance Graph U where
......@@ -220,12 +224,12 @@ deserializeGraph nds ne = do
let f i ((fr, to), attr) = unsafePrimToPrim $ do
igraphVectorSet evec (i*2) $ fromIntegral fr
igraphVectorSet evec (i*2+1) $ fromIntegral to
asBS attr $ \bs -> with bs $ \ptr -> bsvectorSet bsvec i $ castPtr ptr
bsvectorSet bsvec i $ encode attr
return $ i + 1
foldMC f 0
gr@(MLGraph g) <- new 0
addLNodes nds gr
unsafePrimToPrim $ withEdgeAttr $ \eattr -> with (mkStrRec eattr bsvec) $ \ptr -> do
unsafePrimToPrim $ withAttr edgeAttr bsvec $ \ptr -> do
vptr <- fromPtrs [castPtr ptr]
withVectorPtr vptr (igraphAddEdges g evec . castPtr)
unsafeFreeze gr
......@@ -245,7 +249,8 @@ unsafeFreeze :: (Hashable v, Eq v, Serialize v, PrimMonad m)
unsafeFreeze (MLGraph g) = unsafePrimToPrim $ do
nV <- igraphVcount g
labels <- forM [0 .. nV - 1] $ \i ->
igraphHaskellAttributeVAS g vertexAttr i >>= fromBS
igraphHaskellAttributeVAS g vertexAttr i >>= bsToByteString >>=
return . fromRight (error "decode failed") . decode
return $ LGraph g $ M.fromListWith (++) $ zip labels $ map return [0..nV-1]
where
......@@ -323,8 +328,7 @@ nmap fn gr = unsafePerformIO $ do
(MLGraph g) <- thaw gr
forM_ (nodes gr) $ \i -> do
let label = fn (i, nodeLab gr i)
asBS label $ \bs ->
with bs (igraphHaskellAttributeVASSet g vertexAttr i)
asBS (encode label) (igraphHaskellAttributeVASSet g vertexAttr i)
unsafeFreeze (MLGraph g)
-- | Map a function over the edge labels in a graph.
......@@ -335,6 +339,5 @@ emap fn gr = unsafePerformIO $ do
forM_ (edges gr) $ \(fr, to) -> do
i <- igraphGetEid g fr to True True
let label = fn ((fr,to), edgeLabByEid gr i)
asBS label $ \bs ->
with bs (igraphHaskellAttributeEASSet g edgeAttr i)
asBS (encode label) (igraphHaskellAttributeEASSet g edgeAttr i)
unsafeFreeze (MLGraph g)
src/IGraph/Internal/Attribute.chs
View file @ 2183f77c
......@@ -18,51 +18,18 @@ import System.IO.Unsafe (unsafePerformIO)
#include "igraph/igraph.h"
#include "haskell_attributes.h"
-- The returned object will not be trackced by Haskell's GC. It should be freed
-- by foreign codes.
asBS :: Serialize a => a -> (BSLen -> IO b) -> IO b
asBS x fn = unsafeUseAsCStringLen (encode x) (fn . BSLen)
{-# INLINE asBS #-}
asBSVector :: Serialize a => [a] -> (BSVector -> IO b) -> IO b
asBSVector values fn = loop [] values
where
loop acc (x:xs) = unsafeUseAsCStringLen (encode x) $ \ptr ->
loop (BSLen ptr : acc) xs
loop acc _ = toBSVector (reverse acc) >>= fn
{-# INLINE asBSVector #-}
fromBS :: Serialize a => Ptr BSLen -> IO a
fromBS ptr = do
BSLen x <- peek ptr
result <- decode <$> packCStringLen x
case result of
Left msg -> error msg
Right r -> return r
{-# INLINE fromBS #-}
mkStrRec :: CString -- ^ name of the attribute
-> BSVector -- ^ values of the attribute
-> AttributeRecord
mkStrRec name xs = AttributeRecord name 2 xs
{-# INLINE mkStrRec #-}
data AttributeRecord = AttributeRecord CString Int BSVector
instance Storable AttributeRecord where
sizeOf _ = {#sizeof igraph_attribute_record_t #}
alignment _ = {#alignof igraph_attribute_record_t #}
peek p = AttributeRecord
<$> ({#get igraph_attribute_record_t->name #} p)
<*> liftM fromIntegral ({#get igraph_attribute_record_t->type #} p)
<*> ( do ptr <- {#get igraph_attribute_record_t->value #} p
fptr <- newForeignPtr_ . castPtr $ ptr
return $ BSVector fptr )
poke p (AttributeRecord name t vptr) = do
{#set igraph_attribute_record_t.name #} p name
{#set igraph_attribute_record_t.type #} p $ fromIntegral t
withBSVector vptr $ \ptr ->
{#set igraph_attribute_record_t.value #} p $ castPtr ptr
{#pointer *igraph_attribute_record_t as AttributeRecord foreign newtype#}
withAttr :: String
-> BSVector -> (Ptr AttributeRecord -> IO a) -> IO a
withAttr name bs f = withBSVector bs $ \ptr -> do
fptr <- mallocForeignPtrBytes {#sizeof igraph_attribute_record_t #}
withForeignPtr fptr $ \attr -> withCString name $ \name' -> do
{#set igraph_attribute_record_t.name #} attr name'
{#set igraph_attribute_record_t.type #} attr 2
{#set igraph_attribute_record_t.value #} attr $ castPtr ptr
f attr
{-# INLINE withAttr #-}
{#fun igraph_haskell_attribute_has_attr as ^ { `IGraph', `AttributeElemtype', `String' } -> `Bool' #}
......
src/IGraph/Internal/Data.chs
View file @ 2183f77c
......@@ -26,6 +26,8 @@ module IGraph.Internal.Data
, toStrVector
, BSLen(..)
, asBS
, bsToByteString
, BSVector(..)
, withBSVector
, bsvectorNew
......@@ -49,6 +51,8 @@ module IGraph.Internal.Data
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.ByteString (packCStringLen)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Foreign
import Foreign.C.Types
import Foreign.C.String
......@@ -64,17 +68,19 @@ import Data.List.Split (chunksOf)
--------------------------------------------------------------------------------
{#pointer *igraph_vector_t as Vector foreign finalizer
igraph_vector_destroy newtype#}
my_igraph_vector_destroy newtype#}
-- Construtors and destructors
allocaVector :: (Ptr Vector -> IO a) -> IO a
allocaVector f = mallocBytes {# sizeof igraph_vector_t #} >>= f
{-# INLINE allocaVector #-}
addVectorFinalizer :: Ptr Vector -> IO Vector
addVectorFinalizer ptr = do
vec <- newForeignPtr igraph_vector_destroy ptr
vec <- newForeignPtr my_igraph_vector_destroy ptr
return $ Vector vec
{-# INLINE addVectorFinalizer #-}
{#fun igraph_vector_init as igraphVectorNew
{ allocaVector- `Vector' addVectorFinalizer*
......@@ -182,42 +188,55 @@ toStrVector xs = do
-- Customized string vector
--------------------------------------------------------------------------------
newtype BSLen = BSLen CStringLen
{#pointer *bytestring_t as BSLen foreign newtype#}
instance Storable BSLen where
sizeOf _ = {#sizeof bytestring_t #}
alignment _ = {#alignof bytestring_t #}
peek p = do
n <- ({#get bytestring_t->len #} p)
ptr <- {#get bytestring_t->value #} p
return $ BSLen (ptr, fromIntegral n)
poke p (BSLen (ptr, n)) = {#set bytestring_t.len #} p (fromIntegral n) >>
{#set bytestring_t.value #} p ptr
bsToByteString :: Ptr BSLen -> IO B.ByteString
bsToByteString ptr = do
n <- {#get bytestring_t->len #} ptr
str <- {#get bytestring_t->value #} ptr
packCStringLen (str, fromIntegral n)
{-# INLINE bsToByteString #-}
asBS :: B.ByteString -> (Ptr BSLen -> IO a) -> IO a
asBS x f = unsafeUseAsCStringLen x $ \(str, n) -> do
fptr <- mallocForeignPtrBytes {#sizeof bytestring_t #}
withForeignPtr fptr $ \ptr -> do
{#set bytestring_t.len #} ptr (fromIntegral n)
{#set bytestring_t.value #} ptr str
f ptr
{-# INLINE asBS #-}
{#pointer *bsvector_t as BSVector foreign finalizer bsvector_destroy newtype#}
{#fun bsvector_init as bsvectorNew { +, `Int' } -> `BSVector' #}
allocaBSVector :: (Ptr BSVector -> IO a) -> IO a
allocaBSVector f = mallocBytes {# sizeof bsvector_t #} >>= f
{-# INLINE allocaBSVector #-}
addBSVectorFinalizer :: Ptr BSVector -> IO BSVector
addBSVectorFinalizer ptr = do
vec <- newForeignPtr bsvector_destroy ptr
return $ BSVector vec
{-# INLINE addBSVectorFinalizer #-}
--{#fun bsvector_get as bsVectorGet { `BSVectorPtr', `Int', + } -> `Ptr (Ptr BSLen)' id #}
{#fun bsvector_init as bsvectorNew
{ allocaBSVector- `BSVector' addBSVectorFinalizer*
, `Int'
} -> `CInt' void- #}
{-
bsVectorGet :: BSVectorPtr -> Int -> BSLen
bsVectorGet vec i = unsafePerformIO $ do
ptrptr <- bsVectorGet vec i
peek ptrptr >>= peek
-}
{#fun bsvector_set as bsvectorSet' { `BSVector', `Int', castPtr `Ptr BSLen' } -> `()' #}
{#fun bsvector_set as ^ { `BSVector', `Int', `Ptr ()'} -> `()' #}
bsvectorSet :: BSVector -> Int -> B.ByteString -> IO ()
bsvectorSet vec i bs = asBS bs (bsvectorSet' vec i)
{-# INLINE bsvectorSet #-}
toBSVector :: [BSLen] -> IO BSVector
toBSVector :: [B.ByteString] -> IO BSVector
toBSVector xs = do
vec <- bsvectorNew n
forM_ (zip [0..] xs) $ \(i, x) -> with x $ \ptr -> bsvectorSet vec i $ castPtr ptr
foldM_ (\i x -> bsvectorSet vec i x >> return (i+1)) 0 xs
return vec
where
n = length xs
{#pointer *igraph_matrix_t as Matrix foreign finalizer igraph_matrix_destroy newtype#}
{#fun igraph_matrix_init as igraphMatrixNew { +, `Int', `Int' } -> `Matrix' #}
......
src/IGraph/Internal/Graph.chs
View file @ 2183f77c
......@@ -19,9 +19,23 @@ import IGraph.Internal.C2HS
{#pointer *igraph_t as IGraph foreign finalizer igraph_destroy newtype#}
{#fun igraph_empty as igraphNew' { +, `Int', `Bool' } -> `IGraph' #}
{#fun igraph_copy as ^ { +, `IGraph' } -> `IGraph' #}
allocaIGraph :: (Ptr IGraph -> IO a) -> IO a
allocaIGraph f = mallocBytes {# sizeof igraph_t #} >>= f
addIGraphFinalizer :: Ptr IGraph -> IO IGraph
addIGraphFinalizer ptr = do
vec <- newForeignPtr igraph_destroy ptr
return $ IGraph vec
{#fun igraph_empty as igraphNew'
{ allocaIGraph- `IGraph' addIGraphFinalizer*
, `Int', `Bool'
} -> `CInt' void- #}
{#fun igraph_copy as ^
{ allocaIGraph- `IGraph' addIGraphFinalizer*
, `IGraph'
} -> `CInt' void- #}
-- | Create a igraph object and attach a finalizer
igraphNew :: Int -> Bool -> HasInit -> IO IGraph
......
src/IGraph/Mutable.hs
View file @ 2183f77c
......@@ -13,7 +13,7 @@ module IGraph.Mutable
import Control.Monad (when, forM)
import Control.Monad.Primitive
import qualified Data.ByteString.Char8 as B
import Data.Serialize (Serialize)
import Data.Serialize (Serialize, encode)
import Foreign
import Foreign.C.String (CString, withCString)
......@@ -55,10 +55,11 @@ class MGraph d where
addLNodes :: (Serialize v, PrimMonad m)
=> [v] -- ^ vertices' labels
-> MLGraph (PrimState m) d v e -> m ()
addLNodes labels (MLGraph g) = unsafePrimToPrim $ withVertexAttr $
\vattr -> asBSVector labels $ \bsvec -> with (mkStrRec vattr bsvec) $
\ptr -> do vptr <- fromPtrs [castPtr ptr]
withVectorPtr vptr (igraphAddVertices g n . castPtr)
addLNodes labels (MLGraph g) = unsafePrimToPrim $ do
bsvec <- toBSVector $ map encode labels
withAttr vertexAttr bsvec $ \attr -> do
vptr <- fromPtrs [castPtr attr]
withVectorPtr vptr (igraphAddVertices g n . castPtr)
where
n = length labels
......@@ -80,10 +81,11 @@ class MGraph d where
-- | Add edges with labels to the graph.
addLEdges :: (PrimMonad m, Serialize e) => [LEdge e] -> MLGraph (PrimState m) d v e -> m ()
addLEdges es (MLGraph g) = unsafePrimToPrim $ withEdgeAttr $ \eattr ->
asBSVector vs $ \bsvec -> with (mkStrRec eattr bsvec) $ \ptr -> do
addLEdges es (MLGraph g) = unsafePrimToPrim $ do
bsvec <- toBSVector $ map encode vs
withAttr edgeAttr bsvec $ \attr -> do
vec <- fromList $ concat xs
vptr <- fromPtrs [castPtr ptr]
vptr <- fromPtrs [castPtr attr]
withVectorPtr vptr (igraphAddEdges g vec . castPtr)
where
(xs, vs) = unzip $ map ( \((a,b),v) -> ([fromIntegral a, fromIntegral b], v) ) es
......@@ -117,10 +119,9 @@ setNodeAttr :: (PrimMonad m, Serialize v)
-> v
-> MLGraph (PrimState m) d v e
-> m ()
setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $ asBS x $ \bs ->
with bs $ \bsptr -> do
err <- igraphHaskellAttributeVASSet gr vertexAttr nodeId bsptr
when (err /= 0) $ error "Fail to set node attribute!"
setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $ asBS (encode x) $ \bs -> do
err <- igraphHaskellAttributeVASSet gr vertexAttr nodeId bs
when (err /= 0) $ error "Fail to set node attribute!"
-- | Set edge attribute.
setEdgeAttr :: (PrimMonad m, Serialize e)
......@@ -128,7 +129,6 @@ setEdgeAttr :: (PrimMonad m, Serialize e)
-> e
-> MLGraph (PrimState m) d v e
-> m ()
setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $ asBS x $ \bs ->
with bs $ \bsptr -> do
err <- igraphHaskellAttributeEASSet gr edgeAttr edgeId bsptr
when (err /= 0) $ error "Fail to set edge attribute!"
setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $ asBS (encode x) $ \bs -> do
err <- igraphHaskellAttributeEASSet gr edgeAttr edgeId bs
when (err /= 0) $ error "Fail to set edge attribute!"
src/IGraph/Structure.hs
View file @ 2183f77c
......@@ -8,9 +8,10 @@ module IGraph.Structure
) where
import Control.Monad
import Data.Either (fromRight)
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as M
import Data.Serialize (Serialize)
import Data.Serialize (Serialize, decode)
import Foreign
import Foreign.C.Types
import System.IO.Unsafe (unsafePerformIO)
......@@ -32,7 +33,8 @@ inducedSubgraph gr vs = unsafePerformIO $ do
g' <- igraphInducedSubgraph (_graph gr) vsptr IgraphSubgraphCreateFromScratch
nV <- igraphVcount g'
labels <- forM [0 .. nV - 1] $ \i ->
igraphHaskellAttributeVAS g' vertexAttr i >>= fromBS
igraphHaskellAttributeVAS g' vertexAttr i >>= bsToByteString >>=
return . fromRight (error "decode failed") . decode
return $ LGraph g' $ M.fromListWith (++) $ zip labels $ map return [0..nV-1]
-- | Closeness centrality
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment