From 72fc90d13eb8519f6b4a87870dec510bc7d5e30d Mon Sep 17 00:00:00 2001 From: krasimir Date: Fri, 10 Feb 2017 17:10:37 +0000 Subject: [PATCH] safer memory management in the Haskell binding --- src/runtime/haskell-bind/PGF2.hsc | 57 ++++++++++++++++---------- src/runtime/haskell-bind/PGF2/Expr.hsc | 40 ++++++++++-------- src/runtime/haskell-bind/PGF2/FFI.hs | 6 ++- src/runtime/haskell-bind/PGF2/Type.hsc | 18 ++++---- src/runtime/haskell-bind/SG.hsc | 39 ++++++++++-------- 5 files changed, 94 insertions(+), 66 deletions(-) diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 0c976db37..b022d06fe 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -124,8 +124,8 @@ readPGF fpath = else do gu_pool_free pool throwIO (PGFError "The grammar cannot be loaded") else return pgf - master <- newForeignPtr gu_pool_finalizer pool - return PGF {pgf = pgf, pgfMaster = master} + pgfFPtr <- newForeignPtr gu_pool_finalizer pool + return (PGF pgf (touchForeignPtr pgfFPtr)) -- | List of all languages available in the grammar. languages :: PGF -> Map.Map ConcName Concr @@ -143,7 +143,7 @@ languages p = getLanguages ref itor key value exn = do langs <- readIORef ref name <- peekUtf8CString (castPtr key) - concr <- fmap (\ptr -> Concr ptr p) $ peek (castPtr value) + concr <- fmap (\ptr -> Concr ptr (touchPGF p)) $ peek (castPtr value) writeIORef ref $! Map.insert name concr langs -- | Generates an exhaustive possibly infinite list of @@ -158,7 +158,7 @@ generateAll p (Type ctype _) = enum <- pgf_generate_all (pgf p) ctype exn genPl exprPl genFPl <- newForeignPtr gu_pool_finalizer genPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - fromPgfExprEnum enum genFPl (p,exprFPl) + fromPgfExprEnum enum genFPl (touchPGF p >> touchForeignPtr exprFPl) -- | The abstract language name is the name of the top-level -- abstract module @@ -174,7 +174,8 @@ startCat :: PGF -> Type startCat p = unsafePerformIO $ do typPl <- gu_new_pool c_type <- pgf_start_cat (pgf p) typPl - return (Type c_type typPl) + typeFPl <- newForeignPtr gu_pool_finalizer typPl + return (Type c_type (touchForeignPtr typeFPl)) loadConcr :: Concr -> FilePath -> IO () loadConcr c fpath = @@ -207,11 +208,11 @@ functionType p fn = c_type <- pgf_function_type (pgf p) c_fn if c_type == nullPtr then throwIO (PGFError ("Function '"++fn++"' is not defined")) - else return (Type c_type (pgfMaster p)) + else return (Type c_type (touchPGF p)) -- | Checks an expression against a specified type. checkExpr :: PGF -> Expr -> Type -> Either String Expr -checkExpr (PGF p _) (Expr c_expr _) (Type c_ty _) = +checkExpr (PGF p _) (Expr c_expr touch1) (Type c_ty touch2) = unsafePerformIO $ alloca $ \pexpr -> withGuPool $ \tmpPl -> do @@ -219,11 +220,12 @@ checkExpr (PGF p _) (Expr c_expr _) (Type c_ty _) = exprPl <- gu_new_pool poke pexpr c_expr pgf_check_expr p pexpr c_ty exn exprPl + touch1 >> touch2 status <- gu_exn_is_raised exn if not status then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl c_expr <- peek pexpr - return (Right (Expr c_expr exprFPl)) + return (Right (Expr c_expr (touchForeignPtr exprFPl))) else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError c_msg <- (#peek GuExn, data.data) exn msg <- peekUtf8CString c_msg @@ -237,7 +239,7 @@ checkExpr (PGF p _) (Expr c_expr _) (Type c_ty _) = -- possible to infer its type in the GF type system. -- In this case the function returns an error. inferExpr :: PGF -> Expr -> Either String (Expr, Type) -inferExpr (PGF p _) (Expr c_expr _) = +inferExpr (PGF p _) (Expr c_expr touch1) = unsafePerformIO $ alloca $ \pexpr -> withGuPool $ \tmpPl -> do @@ -245,11 +247,13 @@ inferExpr (PGF p _) (Expr c_expr _) = exprPl <- gu_new_pool poke pexpr c_expr c_ty <- pgf_infer_expr p pexpr exn exprPl + touch1 status <- gu_exn_is_raised exn if not status then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl + let touch = touchForeignPtr exprFPl c_expr <- peek pexpr - return (Right (Expr c_expr exprFPl, Type c_ty exprFPl)) + return (Right (Expr c_expr touch, Type c_ty touch)) else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError c_msg <- (#peek GuExn, data.data) exn msg <- peekUtf8CString c_msg @@ -261,7 +265,7 @@ inferExpr (PGF p _) (Expr c_expr _) = -- | Check whether a type is consistent with the abstract -- syntax of the grammar. checkType :: PGF -> Type -> Either String Type -checkType (PGF p _) (Type c_ty _) = +checkType (PGF p _) (Type c_ty touch1) = unsafePerformIO $ alloca $ \pty -> withGuPool $ \tmpPl -> do @@ -269,11 +273,12 @@ checkType (PGF p _) (Type c_ty _) = typePl <- gu_new_pool poke pty c_ty pgf_check_type p pty exn typePl + touch1 status <- gu_exn_is_raised exn if not status then do typeFPl <- newForeignPtr gu_pool_finalizer typePl c_ty <- peek pty - return (Right (Type c_ty typeFPl)) + return (Right (Type c_ty (touchForeignPtr typeFPl))) else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError c_msg <- (#peek GuExn, data.data) exn msg <- peekUtf8CString c_msg @@ -283,16 +288,17 @@ checkType (PGF p _) (Type c_ty _) = else throwIO (PGFError msg) compute :: PGF -> Expr -> Expr -compute (PGF p _) (Expr c_expr _) = +compute (PGF p _) (Expr c_expr touch1) = unsafePerformIO $ withGuPool $ \tmpPl -> do exn <- gu_new_exn tmpPl exprPl <- gu_new_pool c_expr <- pgf_compute p c_expr exn tmpPl exprPl + touch1 status <- gu_exn_is_raised exn if not status then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr exprFPl) + return (Expr c_expr (touchForeignPtr exprFPl)) else do c_msg <- (#peek GuExn, data.data) exn msg <- peekUtf8CString c_msg gu_pool_free exprPl @@ -309,6 +315,7 @@ graphvizAbstractTree p e = do (sb,out) <- newOut tmpPl exn <- gu_new_exn tmpPl pgf_graphviz_abstract_tree (pgf p) (expr e) out exn + touchExpr e s <- gu_string_buf_freeze sb tmpPl peekUtf8CString s @@ -320,6 +327,7 @@ graphvizParseTree c e = do (sb,out) <- newOut tmpPl exn <- gu_new_exn tmpPl pgf_graphviz_parse_tree (concr c) (expr e) out exn + touchExpr e s <- gu_string_buf_freeze sb tmpPl peekUtf8CString s @@ -358,6 +366,7 @@ fullFormLexicon lang = peek ptr if ffEntry == nullPtr then do finalizeForeignPtr fpl + touchConcr lang return [] else do tok <- peekUtf8CString =<< pgf_fullform_get_string ffEntry ref <- newIORef [] @@ -423,7 +432,7 @@ parseWithHeuristics lang (Type ctype _) sent heuristic callbacks = throwIO (PGFError "Parsing failed") else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - exprs <- fromPgfExprEnum enum parseFPl (lang,exprFPl) + exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) return (Right exprs) mkCallbacksMap :: Ptr PgfConcr -> [(String, Int -> Int -> Maybe (Expr,Float,Int))] -> Ptr GuPool -> IO (Ptr PgfCallbacksMap) @@ -509,7 +518,7 @@ parseWithOracle lang cat sent (predict,complete,literal) = throwIO (PGFError "Parsing failed") else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - exprs <- fromPgfExprEnum enum parseFPl (lang,exprFPl) + exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) return (Right exprs) where oracleWrapper oracle catPtr lblPtr offset = do @@ -556,6 +565,7 @@ linearize lang e = unsafePerformIO $ do (sb,out) <- newOut pl exn <- gu_new_exn pl pgf_linearize (concr lang) (expr e) out exn + touchExpr e failed <- gu_exn_is_raised exn if failed then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist @@ -586,6 +596,7 @@ linearizeAll lang e = unsafePerformIO $ peek ptr if ctree == nullPtr then do gu_pool_free pl + touchExpr e return [] else do (sb,out) <- newOut tmpPl ctree <- pgf_lzr_wrap_linref ctree tmpPl @@ -598,7 +609,7 @@ linearizeAll lang e = unsafePerformIO $ else throwExn exn pl else do lin <- gu_string_buf_freeze sb tmpPl s <- peekUtf8CString lin - ss <- unsafeInterleaveIO (collect cts exn pl) + ss <- collect cts exn pl return (s:ss) throwExn exn pl = do @@ -653,6 +664,7 @@ alignWords lang e = unsafePerformIO $ withGuPool $ \pl -> do exn <- gu_new_exn pl seq <- pgf_align_words (concr lang) (expr e) exn pl + touchExpr e failed <- gu_exn_is_raised exn if failed then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist @@ -687,6 +699,7 @@ functions p = fptr <- wrapMapItorCallback (getFunctions ref) (#poke GuMapItor, fn) itor fptr pgf_iter_functions (pgf p) itor exn + touchPGF p freeHaskellFunPtr fptr fs <- readIORef ref return (reverse fs) @@ -709,6 +722,7 @@ functionsByCat p cat = (#poke GuMapItor, fn) itor fptr ccat <- newUtf8CString cat tmpPl pgf_iter_functions_by_cat (pgf p) ccat itor exn + touchPGF p freeHaskellFunPtr fptr fs <- readIORef ref return (reverse fs) @@ -732,6 +746,7 @@ categories p = fptr <- wrapMapItorCallback (getCategories ref) (#poke GuMapItor, fn) itor fptr pgf_iter_categories (pgf p) itor exn + touchPGF p freeHaskellFunPtr fptr cs <- readIORef ref return (reverse cs) @@ -748,8 +763,8 @@ categoryContext pgf cat = Nothing -- !!! not implemented yet TODO ----------------------------------------------------------------------------- -- Helper functions -fromPgfExprEnum :: Ptr GuEnum -> ForeignPtr GuPool -> a -> IO [(Expr, Float)] -fromPgfExprEnum enum fpl master = +fromPgfExprEnum :: Ptr GuEnum -> ForeignPtr GuPool -> IO () -> IO [(Expr, Float)] +fromPgfExprEnum enum fpl touch = do pgfExprProb <- alloca $ \ptr -> withForeignPtr fpl $ \pl -> do gu_enum_next enum ptr pl @@ -758,9 +773,9 @@ fromPgfExprEnum enum fpl master = then do finalizeForeignPtr fpl return [] else do expr <- (#peek PgfExprProb, expr) pgfExprProb - ts <- unsafeInterleaveIO (fromPgfExprEnum enum fpl master) + ts <- unsafeInterleaveIO (fromPgfExprEnum enum fpl touch) prob <- (#peek PgfExprProb, prob) pgfExprProb - return ((Expr expr master,prob) : ts) + return ((Expr expr touch,prob) : ts) ----------------------------------------------------------------------- -- Exceptions diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index 84559e5a0..5b67ba097 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -1,4 +1,3 @@ -{-# LANGUAGE ExistentialQuantification #-} #include module PGF2.Expr where @@ -30,20 +29,20 @@ data BindType = -- they are not released prematurely we use the exprMaster to -- store references to other Haskell objects -data Expr = forall a . Expr {expr :: PgfExpr, exprMaster :: a} +data Expr = Expr {expr :: PgfExpr, touchExpr :: Touch} instance Show Expr where show = showExpr [] -- | Constructs an expression by lambda abstraction mkAbs :: BindType -> CId -> Expr -> Expr -mkAbs bind_type var (Expr body master) = +mkAbs bind_type var (Expr body bodyTouch) = unsafePerformIO $ do exprPl <- gu_new_pool cvar <- newUtf8CString var exprPl c_expr <- pgf_expr_abs cbind_type cvar body exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (exprFPl,body)) + return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl)) where cbind_type = case bind_type of @@ -52,7 +51,7 @@ mkAbs bind_type var (Expr body master) = -- | Decomposes an expression into an abstraction and a body unAbs :: Expr -> Maybe (BindType, CId, Expr) -unAbs (Expr expr master) = +unAbs (Expr expr touch) = unsafePerformIO $ do c_abs <- pgf_expr_unabs expr if c_abs == nullPtr @@ -60,7 +59,7 @@ unAbs (Expr expr master) = else do bt <- fmap toBindType ((#peek PgfExprAbs, bind_type) c_abs) var <- (#peek PgfExprAbs, id) c_abs >>= peekUtf8CString c_body <- (#peek PgfExprAbs, body) c_abs - return (Just (bt, var, Expr c_body master)) + return (Just (bt, var, Expr c_body touch)) where toBindType :: CInt -> BindType toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit @@ -78,13 +77,13 @@ mkApp fun args = exprPl <- gu_new_pool c_expr <- pgf_expr_apply papp exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (exprFPl,args)) + return (Expr c_expr (mapM_ touchExpr args >> touchForeignPtr exprFPl)) where len = length args -- | Decomposes an expression into an application of a function unApp :: Expr -> Maybe (Fun,[Expr]) -unApp (Expr expr master) = +unApp (Expr expr touch) = unsafePerformIO $ withGuPool $ \pl -> do appl <- pgf_expr_unapply expr pl @@ -94,7 +93,7 @@ unApp (Expr expr master) = fun <- peekCString =<< (#peek PgfApplication, fun) appl arity <- (#peek PgfApplication, n_args) appl :: IO CInt c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args)) - return $ Just (fun, [Expr c_arg master | c_arg <- c_args]) + return $ Just (fun, [Expr c_arg touch | c_arg <- c_args]) -- | Constructs an expression from a string literal mkStr :: String -> Expr @@ -104,16 +103,17 @@ mkStr str = exprPl <- gu_new_pool c_expr <- pgf_expr_string cstr exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr exprFPl) + return (Expr c_expr (touchForeignPtr exprFPl)) -- | Decomposes an expression into a string literal unStr :: Expr -> Maybe String -unStr (Expr expr master) = +unStr (Expr expr touch) = unsafePerformIO $ do plit <- pgf_expr_unlit expr (#const PGF_LITERAL_STR) if plit == nullPtr then return Nothing else do s <- peekUtf8CString (plit `plusPtr` (#offset PgfLiteralStr, val)) + touch return (Just s) -- | Constructs an expression from an integer literal @@ -123,16 +123,17 @@ mkInt val = exprPl <- gu_new_pool c_expr <- pgf_expr_int (fromIntegral val) exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr exprFPl) + return (Expr c_expr (touchForeignPtr exprFPl)) -- | Decomposes an expression into an integer literal unInt :: Expr -> Maybe Int -unInt (Expr expr master) = +unInt (Expr expr touch) = unsafePerformIO $ do plit <- pgf_expr_unlit expr (#const PGF_LITERAL_INT) if plit == nullPtr then return Nothing else do n <- peek (plit `plusPtr` (#offset PgfLiteralInt, val)) + touch return (Just (fromIntegral (n :: CInt))) -- | Constructs an expression from a real number @@ -142,16 +143,17 @@ mkFloat val = exprPl <- gu_new_pool c_expr <- pgf_expr_float (realToFrac val) exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr exprFPl) + return (Expr c_expr (touchForeignPtr exprFPl)) -- | Decomposes an expression into a real number literal unFloat :: Expr -> Maybe Double -unFloat (Expr expr master) = +unFloat (Expr expr touch) = unsafePerformIO $ do plit <- pgf_expr_unlit expr (#const PGF_LITERAL_FLT) if plit == nullPtr then return Nothing else do n <- peek (plit `plusPtr` (#offset PgfLiteralFlt, val)) + touch return (Just (realToFrac (n :: CDouble))) -- | Constructs a meta variable as an expression @@ -161,16 +163,17 @@ mkMeta id = exprPl <- gu_new_pool c_expr <- pgf_expr_meta (fromIntegral id) exprPl exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr exprFPl) + return (Expr c_expr (touchForeignPtr exprFPl)) -- | Decomposes an expression into a meta variable unMeta :: Expr -> Maybe Int -unMeta (Expr expr master) = +unMeta (Expr expr touch) = unsafePerformIO $ do c_meta <- pgf_expr_unmeta expr if c_meta == nullPtr then return Nothing else do id <- (#peek PgfExprMeta, id) c_meta + touch return (Just (fromIntegral (id :: CInt))) -- | parses a 'String' as an expression @@ -186,7 +189,7 @@ readExpr str = status <- gu_exn_is_raised exn if (not status && c_expr /= nullPtr) then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return $ Just (Expr c_expr exprFPl) + return $ Just (Expr c_expr (touchForeignPtr exprFPl)) else do gu_pool_free exprPl return Nothing @@ -202,6 +205,7 @@ showExpr scope e = printCtxt <- newPrintCtxt scope tmpPl exn <- gu_new_exn tmpPl pgf_print_expr (expr e) printCtxt 1 out exn + touchExpr e s <- gu_string_buf_freeze sb tmpPl peekUtf8CString s diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 35aa7fa84..d2b5d5365 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -10,10 +10,12 @@ import Control.Exception import GHC.Ptr import Data.Int(Int32) +type Touch = IO () + -- | An abstract data type representing multilingual grammar -- in Portable Grammar Format. -data PGF = PGF {pgf :: Ptr PgfPGF, pgfMaster :: ForeignPtr GuPool} -data Concr = Concr {concr :: Ptr PgfConcr, concrMaster :: PGF} +data PGF = PGF {pgf :: Ptr PgfPGF, touchPGF :: Touch} +data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch} ------------------------------------------------------------------ -- libgu API diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc index bca318dab..7b4560abe 100644 --- a/src/runtime/haskell-bind/PGF2/Type.hsc +++ b/src/runtime/haskell-bind/PGF2/Type.hsc @@ -1,4 +1,3 @@ -{-# LANGUAGE ExistentialQuantification #-} #include module PGF2.Type where @@ -15,7 +14,7 @@ import PGF2.FFI -- which are allocated from other pools. In order to ensure that -- they are not released prematurely we use the exprMaster to -- store references to other Haskell objects -data Type = forall a . Type {typ :: PgfExpr, typMaster :: a} +data Type = Type {typ :: PgfExpr, touchType :: Touch} -- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis type Hypo = (BindType,CId,Type) @@ -36,7 +35,7 @@ readType str = status <- gu_exn_is_raised exn if (not status && c_type /= nullPtr) then do typFPl <- newForeignPtr gu_pool_finalizer typPl - return $ Just (Type c_type typFPl) + return $ Just (Type c_type (touchForeignPtr typFPl)) else do gu_pool_free typPl return Nothing @@ -45,13 +44,14 @@ readType str = -- in the type in order reverse to the order -- of binding. showType :: [CId] -> Type -> String -showType scope (Type ty master) = +showType scope (Type ty touch) = unsafePerformIO $ withGuPool $ \tmpPl -> do (sb,out) <- newOut tmpPl printCtxt <- newPrintCtxt scope tmpPl exn <- gu_new_exn tmpPl pgf_print_type ty printCtxt 1 out exn + touch s <- gu_string_buf_freeze sb tmpPl peekUtf8CString s @@ -72,7 +72,7 @@ mkType hypos cat exprs = unsafePerformIO $ do (#poke PgfType, n_exprs) c_type n_exprs pokeExprs (c_type `plusPtr` (#offset PgfType, exprs)) exprs typFPl <- newForeignPtr gu_pool_finalizer typPl - return (Type c_type (typFPl,hypos,exprs)) + return (Type c_type (mapM_ touchHypo hypos >> mapM_ touchExpr exprs >> touchForeignPtr typFPl)) where pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO () pokeHypos c_hypo [] typPl = return () @@ -93,10 +93,12 @@ mkType hypos cat exprs = unsafePerformIO $ do poke ptr e pokeExprs (plusPtr ptr (#size PgfExpr)) es + touchHypo (_,_,ty) = touchType ty + -- | Decomposes a type into a list of hypothesises, a category and -- a list of arguments for the category. unType :: Type -> ([Hypo],CId,[Expr]) -unType (Type c_type master) = unsafePerformIO $ do +unType (Type c_type touch) = unsafePerformIO $ do cid <- (#peek PgfType, cid) c_type >>= peekUtf8CString c_hypos <- (#peek PgfType, hypos) c_type n_hypos <- (#peek GuSeq, len) c_hypos @@ -111,7 +113,7 @@ unType (Type c_type master) = unsafePerformIO $ do c_ty <- (#peek PgfHypo, type) c_hypo bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo) hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n - return ((bt,cid,Type c_ty master) : hs) + return ((bt,cid,Type c_ty touch) : hs) | otherwise = return [] toBindType :: CInt -> BindType @@ -121,5 +123,5 @@ unType (Type c_type master) = unsafePerformIO $ do peekExprs ptr i n | i < n = do e <- peekElemOff ptr i es <- peekExprs ptr (i+1) n - return (Expr e master : es) + return (Expr e touch : es) | otherwise = return [] diff --git a/src/runtime/haskell-bind/SG.hsc b/src/runtime/haskell-bind/SG.hsc index c7600841c..e2833926a 100644 --- a/src/runtime/haskell-bind/SG.hsc +++ b/src/runtime/haskell-bind/SG.hsc @@ -89,10 +89,11 @@ inTransaction sg f = -- Expressions insertExpr :: SG -> Expr -> IO SgId -insertExpr (SG sg) (Expr expr _) = +insertExpr (SG sg) (Expr expr touch) = withGuPool $ \tmpPl -> do exn <- gu_new_exn tmpPl id <- sg_insert_expr sg expr 1 exn + touch handle_sg_exn exn return id @@ -107,13 +108,14 @@ getExpr (SG sg) id = do if c_expr == nullPtr then do touchForeignPtr exprFPl return Nothing - else do return $ Just (Expr c_expr exprFPl) + else do return $ Just (Expr c_expr (touchForeignPtr exprFPl)) queryExpr :: SG -> Expr -> IO [(SgId,Expr)] -queryExpr (SG sg) (Expr query _) = +queryExpr (SG sg) (Expr query touch) = withGuPool $ \tmpPl -> do exn <- gu_new_exn tmpPl res <- sg_query_expr sg query tmpPl exn + touch handle_sg_exn exn fetchResults res exn where @@ -135,7 +137,7 @@ queryExpr (SG sg) (Expr query _) = return [] else do exprFPl <- newForeignPtr gu_pool_finalizer exprPl rest <- fetchResults res exn - return ((key,Expr c_expr exprFPl) : rest) + return ((key,Expr c_expr (touchForeignPtr exprFPl)) : rest) updateFtsIndex :: SG -> PGF -> IO () updateFtsIndex (SG sg) p = do @@ -163,7 +165,7 @@ queryLinearization (SG sg) query = do handle_sg_exn exn if c_expr == nullPtr then getExprs exprFPl exprPl exn ids - else do let e = Expr c_expr exprFPl + else do let e = Expr c_expr (touchForeignPtr exprFPl) es <- getExprs exprFPl exprPl exn ids return (e:es) @@ -191,7 +193,7 @@ readTriple str = return Nothing showTriple :: Expr -> Expr -> Expr -> String -showTriple (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) = +showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) = unsafePerformIO $ withGuPool $ \tmpPl -> withTriple $ \triple -> do @@ -202,11 +204,12 @@ showTriple (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) = pokeElemOff triple 1 expr2 pokeElemOff triple 2 expr3 pgf_print_expr_tuple 3 triple printCtxt out exn + touch1 >> touch2 >> touch3 s <- gu_string_buf_freeze sb tmpPl peekCString s insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId -insertTriple (SG sg) (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) = +insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) = withGuPool $ \tmpPl -> withTriple $ \triple -> do exn <- gu_new_exn tmpPl @@ -214,6 +217,7 @@ insertTriple (SG sg) (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) = pokeElemOff triple 1 expr2 pokeElemOff triple 2 expr3 id <- sg_insert_triple sg triple exn + touch1 >> touch2 >> touch3 handle_sg_exn exn return id @@ -221,6 +225,7 @@ getTriple :: SG -> SgId -> IO (Maybe (Expr,Expr,Expr)) getTriple (SG sg) id = do exprPl <- gu_new_pool exprFPl <- newForeignPtr gu_pool_finalizer exprPl + let touch = touchForeignPtr exprFPl withGuPool $ \tmpPl -> withTriple $ \triple -> do exn <- gu_new_exn tmpPl @@ -230,11 +235,11 @@ getTriple (SG sg) id = do then do c_expr1 <- peekElemOff triple 0 c_expr2 <- peekElemOff triple 1 c_expr3 <- peekElemOff triple 2 - return (Just (Expr c_expr1 exprFPl - ,Expr c_expr2 exprFPl - ,Expr c_expr3 exprFPl + return (Just (Expr c_expr1 touch + ,Expr c_expr2 touch + ,Expr c_expr3 touch )) - else do touchForeignPtr exprFPl + else do touch return Nothing queryTriple :: SG -> Maybe Expr -> Maybe Expr -> Maybe Expr -> IO [(SgId,Expr,Expr,Expr)] @@ -252,8 +257,8 @@ queryTriple (SG sg) mb_expr1 mb_expr2 mb_expr3 = toCExpr Nothing = nullPtr toCExpr (Just (Expr expr _)) = expr - fromCExpr c_expr exprFPl Nothing = Expr c_expr exprFPl - fromCExpr c_expr exprFPl (Just e) = e + fromCExpr c_expr touch Nothing = Expr c_expr touch + fromCExpr c_expr touch (Just e) = e fetchResults res = do exprPl <- gu_new_pool @@ -273,15 +278,15 @@ queryTriple (SG sg) mb_expr1 mb_expr2 mb_expr3 = sg_triple_result_close res exn return [] else do exprFPl <- newForeignPtr gu_pool_finalizer exprPl + let touch = touchForeignPtr exprFPl c_expr1 <- peekElemOff triple 0 c_expr2 <- peekElemOff triple 1 c_expr3 <- peekElemOff triple 2 key <- peek pKey rest <- unsafeInterleaveIO (fetchResults res) - return ((key,fromCExpr c_expr1 exprFPl mb_expr1 - ,fromCExpr c_expr2 exprFPl mb_expr2 - ,fromCExpr c_expr3 exprFPl mb_expr3) : rest) - + return ((key,fromCExpr c_expr1 touch mb_expr1 + ,fromCExpr c_expr2 touch mb_expr2 + ,fromCExpr c_expr3 touch mb_expr3) : rest) data Query = forall a . Query {query :: Ptr SgQuery, queryMaster :: a}