GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-14 07:19:31 -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,
-- * 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)