fixed some memory leaks

1 files changed, 110 insertions, 88 deletions

diff --git a/src/runtime/haskell-bind/CRuntimeFFI.hsc b/src/runtime/haskell-bind/CRuntimeFFI.hsc
index d3923840f..24329c319 100644
--- a/src/runtime/haskell-bind/CRuntimeFFI.hsc
+++ b/src/runtime/haskell-bind/CRuntimeFFI.hsc
@@ -11,12 +11,14 @@ module CRuntimeFFI(-- * PGF
                    Expr,Tree,readExpr,showExpr,unApp,
                    -- * Morphology
                    MorphoAnalysis,lookupMorpho,fullFormLexicon,
-                   printLexEntry
+                   printLexEntry,
+                   -- * Don't export these for real, just for testing
+                   generateAll, printGrammar
                    ) where
 
 import Prelude hiding (fromEnum)
---import Control.Monad
---import System.IO
+import Control.Exception
+import System.IO
 import System.IO.Unsafe
 import CId (CId(..), 
             mkCId, wildCId,
@@ -26,12 +28,11 @@ import PgfLow
 
 import Foreign hiding ( Pool, newPool, unsafePerformIO )
 import Foreign.C
-import Control.Exception
---import Foreign.C.String
---import Foreign.Ptr
+import Foreign.C.String
+import Foreign.Ptr
 
 
---import Data.Char
+import Data.Char
 import qualified Data.ByteString as BS
 import Data.IORef
 
@@ -49,20 +50,32 @@ type Pool = ForeignPtr GuPool
 type Out = (Ptr GuStringBuf, Ptr GuOut)
 
      
+--Not used anymore, see withGuPool in Gu.hsc
 newPool :: IO Pool
 newPool =
   do pl <- gu_new_pool
-     newForeignPtr_ pl --newForeignPtr gu_pool_free_ptr pl
+     newForeignPtr_ pl --gu_pool_free_ptr pl
 
 --when you create a GuOut, you create also a GuStringBuf
 --and when you give GuOut to a function that outputs something,
 --the result goes into that GuStringBuf
-newOut :: IO Out 
-newOut =
-   do sb <- withGuPool $ \pl -> gu_string_buf pl
+newOut :: Ptr GuPool -> IO Out 
+newOut pool =
+   do sb <- gu_string_buf pool
       out <- gu_string_buf_out sb
       return (sb,out)
---  gu_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf)
+--Don't create newOut using withGuPool inside
+--Rather do like this:
+{-
+withGuPool $ \pl ->
+  do out <- newOut pl
+     <other stuff>
+-}
+  -- withGuPool $ \pl -> 
+  --   do sb <- gu_string_buf pl
+  --      out <- gu_string_buf_out sb
+  --      return (sb,out)
+
 
 -----------------------------------------------------------------------------
 -- Functions that take a PGF.
@@ -75,15 +88,10 @@ type Language = CId
 
 readPGF :: FilePath -> IO PGF
 readPGF filepath =
-  do pool <- gu_new_pool
+  do pl <- gu_new_pool
      pgf <- withCString filepath $ \file -> 
-              pgf_read file pool nullPtr
-     return PGF {pgfPool = pool, pgf = pgf}
-    -- withGuPool $ \pl ->
-    --   do pgf <- withCString filepath $ \file ->
-    --                pgf_read file pl nullPtr
-    --      return PGF {pgfPool = pl, pgf = pgf}       
-
+              pgf_read file pl nullPtr
+     return PGF {pgfPool = pl, pgf = pgf}
 
 
 getConcr :: PGF -> Language -> Maybe Concr
@@ -104,10 +112,13 @@ getConcr p (CId lang) = unsafePerformIO $
 
 generateAll :: PGF -> CId -> [(Tree,Float)]
 generateAll p (CId cat) = unsafePerformIO $
-  do pgfExprs <- BS.useAsCString cat $ \cat ->
-                    withGuPool $ \pl ->
-                      pgf_generate_all (pgf p) cat pl
-     fromPgfExprEnum pgfExprs p
+  withGuPool $ \iterPl ->
+--    withGuPool $ \exprPl -> --segfaults if I use this
+      do exprPl <- gu_new_pool
+         pgfExprs <- BS.useAsCString cat $ \cat ->
+                     pgf_generate_all (pgf p) cat exprPl --this pool isn't freed. segfaults if I try.
+         fromPgfExprEnum pgfExprs iterPl p --this pool is freed afterwards. it's used in fromPgfExprEnum, and I imagine it makes more sense to give a pool as an argument, rather than in that function create and free new pools in its body (it calls itself recursively)
+         
 
 abstractName :: PGF -> Language
 abstractName p = unsafePerformIO $ fmap CId (BS.packCString =<< pgf_abstract_name (pgf p))
@@ -115,14 +126,15 @@ abstractName p = unsafePerformIO $ fmap CId (BS.packCString =<< pgf_abstract_nam
 startCat :: PGF -> CId
 startCat p = unsafePerformIO $ fmap CId (BS.packCString =<< pgf_start_cat (pgf p))
 
-printGrammar :: PGF -> Pool -> String
-printGrammar p pool = unsafePerformIO $
-  do (sb,out) <- newOut
-     pgf_print (pgf p) out nullPtr
-     withGuPool $ \pl ->
-         do grammar <- gu_string_buf_freeze sb pl
-            peekCString grammar
-
+printGrammar :: PGF -> String
+printGrammar p = unsafePerformIO $
+  withGuPool $ \outPl ->
+    withGuPool $ \printPl ->
+      do (sb,out) <- newOut outPl
+         pgf_print (pgf p) out nullPtr --nullPtr is for exception
+         grammar <- gu_string_buf_freeze sb printPl
+         peekCString grammar
+ 
 
 -----------------------------------------------------------------------------
 -- Expressions
@@ -164,32 +176,33 @@ unApp (Expr expr master) = unsafePerformIO $
 --C coding to make the C library nicer.
 
 
-
 readExpr :: String -> Maybe Expr
 readExpr str = unsafePerformIO $
- do pool <- gu_new_pool  --we return this pool with the Expr
-    withCString str $ \str ->
-     withGuPool $ \pl1 ->   --these pools are freed right after
-       withGuPool $ \pl2 ->
-         do guin <- gu_string_in str pl1
-            exn <- gu_new_exn nullPtr gu_type__type pl2
-            pgfExpr <- pgf_read_expr guin pool exn
+ do exprPl <- gu_new_pool  --we return this pool with the Expr
+    withGuPool $ \inPl ->   --these pools are freed right after
+      withGuPool $ \exnPl ->
+        withCString str $ \str ->
+         do guin <- gu_string_in str inPl
+            exn <- gu_new_exn nullPtr gu_type__type exnPl
+            pgfExpr <- pgf_read_expr guin exprPl exn
             status <- gu_exn_is_raised exn
             if (status==False && pgfExpr /= nullPtr)
-              then return $ Just (Expr pgfExpr pool)
+              then return $ Just (Expr pgfExpr exprPl)
               else do
-                   gu_pool_free pool --if Expr is not returned, free pool
+                   gu_pool_free exprPl --if Expr is not returned, free pool
                    return Nothing
 
+-- TODO: do we need 3 different pools for this?
 showExpr :: Expr -> String
 showExpr e = unsafePerformIO $
- do (sb,out) <- newOut
-    let printCtxt = nullPtr
-    exn <- withGuPool $ \pl ->
-        gu_new_exn nullPtr gu_type__type pl
-    pgf_print_expr (expr e) printCtxt 1 out exn
-    withGuPool $ \pl ->
-       do abstree <- gu_string_buf_freeze sb pl
+  withGuPool $ \outPl ->
+   withGuPool $ \exnPl ->
+     withGuPool $ \printPl ->
+       do (sb,out) <- newOut outPl
+          let printCtxt = nullPtr
+          exn <- gu_new_exn nullPtr gu_type__type exnPl
+          pgf_print_expr (expr e) printCtxt 1 out exn
+          abstree <- gu_string_buf_freeze sb printPl
           peekCString abstree
 
 
@@ -219,7 +232,6 @@ lookupMorpho (Concr concr master) sent = unsafePerformIO $
       anal  <- peekCString canal
       writeIORef ref ((lemma, anal, prob):ans)
 
-
 fullFormLexicon :: Concr -> [(String, [MorphoAnalysis])]
 fullFormLexicon lang = 
   let lexicon  = fullformLexicon' lang
@@ -227,10 +239,11 @@ fullFormLexicon lang =
   in  zip lexicon analyses
   where fullformLexicon' :: Concr -> [String]
         fullformLexicon' lang = unsafePerformIO $
-          do pool <- newPool
-             lexEnum <- withGuPool $ \pl -> 
-                 pgf_fullform_lexicon (concr lang) pl
-             fromFullFormEntry lexEnum (concrMaster lang)
+          withGuPool $ \iterPl -> 
+            do pl <- gu_new_pool
+               lexEnum <- pgf_fullform_lexicon (concr lang) pl
+               fromFullFormEntry lexEnum pl (concrMaster lang)
+--Something weird happens if I use iterPl ^- here
 
 printLexEntry :: (String, [MorphoAnalysis]) -> String
 printLexEntry (lemma, anals) = 
@@ -243,62 +256,71 @@ printLexEntry (lemma, anals) =
 --Also this returns a list of tuples (tree,prob) instead of just trees
 parse :: Concr -> CId -> String -> [(Tree,Float)]
 parse (Concr lang master) (CId cat) sent = unsafePerformIO $
-  do treesEnum <- parse_ lang cat sent
-     fromPgfExprEnum treesEnum master
-  where 
-    parse_ :: Ptr PgfConcr -> BS.ByteString -> String -> IO (Ptr PgfExprEnum)
-    parse_ pgfcnc cat sent =
-      do putStrLn "foo"
-         inpool <- gu_new_pool
-         outpool <- gu_new_pool
-         BS.useAsCString cat $ \cat ->
-                   withCString sent $ \sent ->
-                     pgf_parse pgfcnc cat sent nullPtr inpool outpool 
-                           -- `finally` do (gu_pool_free inpool)
-                           --              (gu_pool_free outpool)
-         -- gu_pool_free inpool
-         -- gu_pool_free outpool
-         -- return enum
+   withGuPool $ \iterPl ->   -- this pool will get freed eventually
+     do inpool <- gu_new_pool  --these pools not ???
+        outpool <- gu_new_pool --if I add them into withGuPool, I get segfault
+        treesEnum <- parse_ lang cat sent inpool outpool
+        fromPgfExprEnum treesEnum iterPl master --see previous fromPgfExprEnum comment, why giving a pool as an argument here instead of creating them in fromPgfExprEnum
+  where  
+    --tried adding withGuPool stuff inside here, segfaults as well
+    parse_ :: Ptr PgfConcr -> BS.ByteString -> String -> Ptr GuPool -> Ptr GuPool -> IO (Ptr PgfExprEnum)
+    parse_ pgfcnc cat sent inpool outpool =
+      do BS.useAsCString cat $ \cat ->
+           withCString sent $ \sent ->
+             pgf_parse pgfcnc cat sent nullPtr inpool outpool
+
 
 --In Haskell library, this function has type signature PGF -> Language -> Tree -> String
 --Here we replace PGF -> Language with Concr
 linearize :: Concr -> Tree -> String
 linearize lang tree = unsafePerformIO $
-  do pool <- newPool
-     (sb,out) <- newOut
-     pgf_linearize (concr lang) (expr tree) out nullPtr --linearization goes to stringbuf
-     withGuPool $ \pl ->
-         do lin <- gu_string_buf_freeze sb pl
-            peekCString lin
-
+  withGuPool $ \outPl ->
+    withGuPool $ \linPl ->
+     do (sb,out) <- newOut outPl
+        pgf_linearize (concr lang) (expr tree) out nullPtr --linearization goes to stringbuf
+        lin <- gu_string_buf_freeze sb linPl
+        peekCString lin
 
 
 -----------------------------------------------------------------------------
 -- Helper functions
 
 -- # syntax: http://www.haskell.org/ghc/docs/7.2.1/html/users_guide/hsc2hs.html
-fromPgfExprEnum :: Ptr PgfExprEnum -> a -> IO [(Tree, Float)]
-fromPgfExprEnum enum master = 
+fromPgfExprEnum :: Ptr PgfExprEnum -> Ptr GuPool -> a -> IO [(Tree, Float)]
+fromPgfExprEnum enum pl master = 
   do pgfExprProb <- alloca $ \ptr -> 
-                      withGuPool $ \pl -> 
+--                      withGuPool $ \pl -> 
                         do gu_enum_next enum ptr pl
                            peek ptr
      if pgfExprProb == nullPtr
        then return []
        else do expr <- (#peek PgfExprProb, expr) pgfExprProb
                prob <- (#peek PgfExprProb, prob) pgfExprProb
-               ts <- unsafeInterleaveIO (fromPgfExprEnum enum master)
-               return ((Expr expr master, prob) : ts)
+               ts <- unsafeInterleaveIO (fromPgfExprEnum enum pl master)
+               return ((Expr expr master,prob) : ts)
 
-fromFullFormEntry :: Ptr GuEnum -> PGF -> IO [String]
-fromFullFormEntry enum master = 
+--TODO
+fromFullFormEntry :: Ptr GuEnum -> Ptr GuPool -> PGF -> IO [String]
+fromFullFormEntry enum pl master = 
   do ffEntry <- alloca $ \ptr ->
-                  withGuPool $ \pl ->
-                    do gu_enum_next enum ptr pl
-                       peek ptr 
+                  do gu_enum_next enum ptr pl
+                     peek ptr 
 --   ffEntry :: Ptr PgfFullFormEntry
      if ffEntry == nullPtr
        then return []
        else do tok <- peekCString =<< pgf_fullform_get_string ffEntry
-               toks <- unsafeInterleaveIO (fromFullFormEntry enum master)
+               toks <- unsafeInterleaveIO (fromFullFormEntry enum pl master)
                return (tok : toks)
+
+-- fromFullFormEntry :: Ptr GuEnum -> PGF -> IO [String]
+-- fromFullFormEntry enum master = 
+--   do ffEntry <- alloca $ \ptr ->
+--                   withGuPool $ \pl ->
+--                     do gu_enum_next enum ptr pl
+--                        peek ptr 
+-- --   ffEntry :: Ptr PgfFullFormEntry
+--      if ffEntry == nullPtr
+--        then return []
+--        else do tok <- peekCString =<< pgf_fullform_get_string ffEntry
+--                toks <- unsafeInterleaveIO (fromFullFormEntry enum master)
+--                return (tok : toks)
\ No newline at end of file