fix memory leaks for more foreign structs

cbits/haskell_attributes.c

@@ -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

 #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

@@ -5,4 +5,6 @@
 
 void haskelligraph_init();
 
+void my_igraph_vector_destroy(igraph_vector_t* v);
+
 #endif

src/IGraph.hs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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