From 5c0ef5c4ed2fa9f91f6d50642bd2a3216fa41272 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Wed, 10 Sep 2014 15:41:53 +0000 Subject: [PATCH] now release the FunPtr:s that are allocated for each literal callback --- src/runtime/haskell-bind/PGF2.hsc | 5 ++-- src/runtime/haskell-bind/PGF2/FFI.hs | 9 ++++---- src/runtime/haskell-bind/pgf2-bind.cabal | 1 + src/runtime/haskell-bind/utils.c | 29 ++++++++++++++++++++++++ 4 files changed, 37 insertions(+), 7 deletions(-) create mode 100644 src/runtime/haskell-bind/utils.c diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 7910ece81..ad7deb1b1 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -267,8 +267,7 @@ addLiteral :: Concr -> String -> (Int -> String -> Int -> Maybe (Expr,Float,Int) addLiteral lang cat match = withCString cat $ \ccat -> withGuPool $ \tmp_pool -> do - pool <- pgf_concr_get_pool (concr lang) - callback <- gu_malloc pool (#size PgfLiteralCallback) + callback <- hspgf_new_literal_callback (concr lang) match <- wrapLiteralMatchCallback match_callback predict <- wrapLiteralPredictCallback predict_callback (#poke PgfLiteralCallback, match) callback match @@ -283,7 +282,7 @@ addLiteral lang cat match = msg <- peekCString c_msg throwIO (PGFError msg) else throwIO (PGFError "The literal cannot be added") - else do return () + else return () where match_callback _ clin_idx csentence poffset out_pool = do sentence <- peekCString csentence diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 9b0f9961e..a467f7ddc 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -97,6 +97,7 @@ data PgfFullFormEntry data PgfMorphoCallback data PgfPrintContext data PgfType +data PgfLiteralCallback foreign import ccall "pgf/pgf.h pgf_read" pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF) @@ -146,9 +147,6 @@ foreign import ccall "pgf/pgf.h pgf_linearize" foreign import ccall "pgf/pgf.h pgf_parse" pgf_parse :: Ptr PgfConcr -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) -foreign import ccall "pgf/pgf.h pgf_concr_get_pool" - pgf_concr_get_pool :: Ptr PgfConcr -> IO (Ptr GuPool) - type LiteralMatchCallback = Ptr () -> CInt -> CString -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" @@ -159,8 +157,11 @@ type LiteralPredictCallback = Ptr () -> CInt -> CString -> Ptr GuPool -> IO (Ptr foreign import ccall "wrapper" wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback) +foreign import ccall + hspgf_new_literal_callback :: Ptr PgfConcr -> IO (Ptr PgfLiteralCallback) + foreign import ccall "pgf/pgf.h pgf_concr_add_literal" - pgf_concr_add_literal :: Ptr PgfConcr -> CString -> Ptr () -> Ptr GuExn -> IO () + pgf_concr_add_literal :: Ptr PgfConcr -> CString -> Ptr PgfLiteralCallback -> Ptr GuExn -> IO () foreign import ccall "pgf/pgf.h pgf_lookup_morpho" pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO () diff --git a/src/runtime/haskell-bind/pgf2-bind.cabal b/src/runtime/haskell-bind/pgf2-bind.cabal index f2496e7eb..3d505de35 100644 --- a/src/runtime/haskell-bind/pgf2-bind.cabal +++ b/src/runtime/haskell-bind/pgf2-bind.cabal @@ -28,6 +28,7 @@ library extra-libraries: gu pgf cc-options: -std=c99 default-language: Haskell2010 + c-sources: utils.c executable pgf-shell main-is: pgf-shell.hs diff --git a/src/runtime/haskell-bind/utils.c b/src/runtime/haskell-bind/utils.c new file mode 100644 index 000000000..8ab1e53e3 --- /dev/null +++ b/src/runtime/haskell-bind/utils.c @@ -0,0 +1,29 @@ +#include +#include + +typedef struct { + PgfLiteralCallback callback; + GuFinalizer fin; +} HSPgfLiteralCallback; + +static void +hspgf_literal_callback_fin(GuFinalizer* self) +{ + HSPgfLiteralCallback* callback = gu_container(self, HSPgfLiteralCallback, fin); + + if (callback->callback.match != NULL) + hs_free_fun_ptr((HsFunPtr) callback->callback.match); + if (callback->callback.predict != NULL) + hs_free_fun_ptr((HsFunPtr) callback->callback.predict); +} + +PgfLiteralCallback* +hspgf_new_literal_callback(PgfConcr* concr) { + GuPool* pool = pgf_concr_get_pool(concr); + HSPgfLiteralCallback* callback = gu_new(HSPgfLiteralCallback, pool); + callback->callback.match = NULL; + callback->callback.predict = NULL; + callback->fin.fn = hspgf_literal_callback_fin; + gu_pool_finally(pool, &callback->fin); + return &callback->callback; +}