GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 19:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

fixed some memory leaks

Browse Source
This commit is contained in:
inari
2014-02-06 10:50:59 +00:00
parent f23bcb8a47
commit 957dfb83b6
1 changed files with 110 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

198
src/runtime/haskell-bind/CRuntimeFFI.hsc
View File

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