From 957dfb83b6f7ee0835d32b5930d47b133e678592 Mon Sep 17 00:00:00 2001 From: inari Date: Thu, 6 Feb 2014 10:50:59 +0000 Subject: [PATCH] fixed some memory leaks --- src/runtime/haskell-bind/CRuntimeFFI.hsc | 198 +++++++++++++---------- 1 file 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 + +-} + -- 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