safer memory management in the Haskell binding

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
+     pgfFPtr <- newForeignPtr gu_pool_finalizer pool
-     return PGF {pgf = pgf, pgfMaster = master}
+     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 :: Ptr GuEnum -> ForeignPtr GuPool -> IO () -> IO [(Expr, Float)]
-fromPgfExprEnum enum fpl master =
+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

src/runtime/haskell-bind/PGF2/Expr.hsc

@@ -1,4 +1,3 @@
-{-# LANGUAGE ExistentialQuantification #-}
 #include <pgf/pgf.h>
 
 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
 

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 PGF = PGF {pgf :: Ptr PgfPGF, touchPGF :: Touch}
-data Concr = Concr {concr :: Ptr PgfConcr, concrMaster :: PGF}
+data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch}
 
 ------------------------------------------------------------------
 -- libgu API

src/runtime/haskell-bind/PGF2/Type.hsc

@@ -1,4 +1,3 @@
-{-# LANGUAGE ExistentialQuantification #-}
 #include <pgf/pgf.h>
 
 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 []

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
+               return (Just (Expr c_expr1 touch
-                            ,Expr c_expr2 exprFPl
+                            ,Expr c_expr2 touch
-                            ,Expr c_expr3 exprFPl
+                            ,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 touch Nothing  = Expr c_expr touch
-    fromCExpr c_expr exprFPl (Just e) = e
+    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
+                           return ((key,fromCExpr c_expr1 touch mb_expr1
-                                       ,fromCExpr c_expr2 exprFPl mb_expr2
+                                       ,fromCExpr c_expr2 touch mb_expr2
-                                       ,fromCExpr c_expr3 exprFPl mb_expr3) : rest)
+                                       ,fromCExpr c_expr3 touch mb_expr3) : rest)
-
 
 data Query = forall a . Query {query :: Ptr SgQuery, queryMaster :: a}