The unmarshaller is no longer stored in the PGF object but is passed explicitly to each function that needs it.

src/runtime/haskell/PGF2.hsc

@@ -67,8 +67,7 @@ readPGF fpath =
   withCString fpath $ \c_fpath ->
   allocaBytes (#size PgfExn) $ \c_exn ->
   mask_ $ do
-    u <- mkUnmarshaller
-    c_pgf <- pgf_read_pgf c_fpath u c_exn
+    c_pgf <- pgf_read_pgf c_fpath c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     if ex_type == (#const PGF_EXN_NONE)
       then do fptr <- newForeignPtr pgf_free_fptr c_pgf
@@ -91,8 +90,7 @@ bootNGF pgf_path ngf_path =
   withCString ngf_path $ \c_ngf_path ->
   allocaBytes (#size PgfExn) $ \c_exn ->
   mask_ $ do
-    u <- mkUnmarshaller
-    c_pgf <- pgf_boot_ngf c_pgf_path c_ngf_path u c_exn
+    c_pgf <- pgf_boot_ngf c_pgf_path c_ngf_path c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     if ex_type == (#const PGF_EXN_NONE)
       then do fptr <- newForeignPtr pgf_free_fptr c_pgf
@@ -114,8 +112,7 @@ readNGF fpath =
   withCString fpath $ \c_fpath ->
   allocaBytes (#size PgfExn) $ \c_exn ->
   mask_ $ do
-    u <- mkUnmarshaller
-    c_pgf <- pgf_read_ngf c_fpath u c_exn
+    c_pgf <- pgf_read_ngf c_fpath c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     if ex_type == (#const PGF_EXN_NONE)
       then do fptr <- newForeignPtr pgf_free_fptr c_pgf
@@ -145,8 +142,9 @@ abstractName p =
 startCat :: PGF -> Type
 startCat p =
   unsafePerformIO $
+  withForeignPtr unmarshaller $ \u ->
   withForeignPtr (a_pgf p) $ \c_pgf -> do
-    c_typ <- pgf_start_cat c_pgf
+    c_typ <- pgf_start_cat c_pgf u
     typ <- deRefStablePtr c_typ
     freeStablePtr c_typ
     return typ
@@ -155,9 +153,10 @@ startCat p =
 functionType :: PGF -> Fun -> Maybe Type
 functionType p fn =
   unsafePerformIO $
+  withForeignPtr unmarshaller $ \u ->
   withForeignPtr (a_pgf p) $ \p_pgf ->
   withText fn $ \c_fn -> do
-    c_typ <- pgf_function_type p_pgf c_fn
+    c_typ <- pgf_function_type p_pgf c_fn u
     if c_typ == castPtrToStablePtr nullPtr
       then return Nothing
       else do typ <- deRefStablePtr c_typ
@@ -204,9 +203,10 @@ categoryContext p cat =
   unsafePerformIO $
   withText cat $ \c_cat ->
   alloca $ \p_n_hypos ->
+  withForeignPtr unmarshaller $ \u ->
   withForeignPtr (a_pgf p) $ \c_pgf ->
   mask_ $ do
-    c_hypos <- pgf_category_context c_pgf c_cat p_n_hypos
+    c_hypos <- pgf_category_context c_pgf c_cat p_n_hypos u
     if c_hypos == nullPtr
       then return []
       else do n_hypos <- peek p_n_hypos
@@ -284,7 +284,7 @@ functionsByCat p cat =
 showExpr :: [Var] -> Expr -> String
 showExpr scope e =
   unsafePerformIO $
-  bracket mkMarshaller freeMarshaller $ \m ->
+  withForeignPtr marshaller $ \m ->
   bracket (newPrintCtxt scope) freePrintCtxt $ \pctxt ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
   bracket (pgf_print_expr c_e pctxt 1 m) free $ \c_text ->
@@ -309,7 +309,7 @@ readExpr :: String -> Maybe Expr
 readExpr str =
   unsafePerformIO $
   withText str $ \c_str ->
-  bracket mkUnmarshaller freeUnmarshaller $ \u -> do
+  withForeignPtr unmarshaller $ \u -> do
     c_expr <- pgf_read_expr c_str u
     if c_expr == castPtrToStablePtr nullPtr
       then return Nothing
@@ -324,7 +324,7 @@ readExpr str =
 showType :: [Var] -> Type -> String
 showType scope ty =
   unsafePerformIO $
-  bracket mkMarshaller freeMarshaller $ \m ->
+  withForeignPtr marshaller $ \m ->
   bracket (newPrintCtxt scope) freePrintCtxt $ \pctxt ->
   bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
   bracket (pgf_print_type c_ty pctxt 0 m) free $ \c_text ->
@@ -335,7 +335,7 @@ readType :: String -> Maybe Type
 readType str =
   unsafePerformIO $
   withText str $ \c_str ->
-  bracket mkUnmarshaller freeUnmarshaller $ \u -> do
+  withForeignPtr unmarshaller $ \u -> do
     c_ty <- pgf_read_type c_str u
     if c_ty == castPtrToStablePtr nullPtr
       then return Nothing

src/runtime/haskell/PGF2/FFI.hsc

@@ -8,6 +8,7 @@ import Foreign.C
 import Foreign.Ptr
 import qualified Data.Map as Map
 import Control.Exception(bracket,mask_)
+import System.IO.Unsafe(unsafePerformIO)
 
 import PGF2.Expr
 
@@ -38,13 +39,13 @@ foreign import ccall unsafe "pgf_utf8_encode"
   pgf_utf8_encode :: Word32 -> Ptr CString -> IO ()
 
 foreign import ccall "pgf_read_pgf"
-  pgf_read_pgf :: CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF)
+  pgf_read_pgf :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
 
 foreign import ccall "pgf_boot_ngf"
-  pgf_boot_ngf :: CString -> CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF)
+  pgf_boot_ngf :: CString -> CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
 
 foreign import ccall "pgf_read_ngf"
-  pgf_read_ngf :: CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF)
+  pgf_read_ngf :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
 
 foreign import ccall "&pgf_free"
   pgf_free_fptr :: FinalizerPtr PgfPGF
@@ -73,10 +74,10 @@ foreign import ccall "pgf_iter_categories"
   pgf_iter_categories :: Ptr PgfPGF -> Ptr PgfItor -> IO ()
 
 foreign import ccall "pgf_start_cat"
-  pgf_start_cat :: Ptr PgfPGF -> IO (StablePtr Type)
+  pgf_start_cat :: Ptr PgfPGF -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
 
 foreign import ccall "pgf/pgf.h pgf_category_context"
-  pgf_category_context :: Ptr PgfPGF -> Ptr PgfText -> Ptr CSize -> IO (Ptr PgfTypeHypo)
+  pgf_category_context :: Ptr PgfPGF -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> IO (Ptr PgfTypeHypo)
 
 foreign import ccall "pgf/pgf.h pgf_category_prob"
   pgf_category_prob :: Ptr PgfPGF -> Ptr PgfText -> IO (#type prob_t)
@@ -88,7 +89,7 @@ foreign import ccall "pgf_iter_functions_by_cat"
   pgf_iter_functions_by_cat :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfItor -> IO ()
 
 foreign import ccall "pgf/pgf.h pgf_function_type"
-   pgf_function_type :: Ptr PgfPGF -> Ptr PgfText -> IO (StablePtr Type)
+   pgf_function_type :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
 
 foreign import ccall "pgf/expr.h pgf_function_is_constructor"
    pgf_function_is_constructor :: Ptr PgfPGF -> Ptr PgfText -> IO (#type int)
@@ -266,26 +267,22 @@ foreign import ccall "&hs_free_reference" hs_free_reference :: FunPtr (Ptr a ->
 
 foreign import ccall "&hs_free_marshaller" hs_free_marshaller :: FinalizerPtr PgfMarshaller
 
-foreign import ccall "hs_free_marshaller" freeMarshaller :: Ptr PgfMarshaller -> IO ()
-
 foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FinalizerPtr PgfUnmarshaller
 
-foreign import ccall "hs_free_unmarshaller" freeUnmarshaller :: Ptr PgfUnmarshaller -> IO ()
-
 type MatchFun a = Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr a -> IO (StablePtr a)
 
 foreign import ccall "wrapper"
   wrapMatchFun :: MatchFun a -> IO (FunPtr (MatchFun a))
 
-mkMarshaller = do
+{-# NOINLINE marshaller #-}
+marshaller = unsafePerformIO $ do
   vtbl <- mallocBytes (#size PgfMarshallerVtbl)
   wrapMatchFun matchLit  >>= (#poke PgfMarshallerVtbl, match_lit)  vtbl
   wrapMatchFun matchExpr >>= (#poke PgfMarshallerVtbl, match_expr) vtbl
   wrapMatchFun matchType >>= (#poke PgfMarshallerVtbl, match_type) vtbl
-  (#poke PgfMarshallerVtbl, free_me)  vtbl hs_free_marshaller
   ptr <- mallocBytes (#size PgfMarshaller)
   (#poke PgfMarshaller, vtbl) ptr vtbl
-  return ptr
+  newForeignPtr hs_free_marshaller ptr
   where
     matchLit this u c_lit = do
       vtbl <- (#peek PgfUnmarshaller, vtbl) u
@@ -364,7 +361,8 @@ mkMarshaller = do
           (#peek PgfTypeHypo, type) ptr >>= freeStablePtr
           freeHypos (ptr `plusPtr` (#size PgfTypeHypo)) (n-1)
 
-mkUnmarshaller = do
+{-# NOINLINE unmarshaller #-}
+unmarshaller = unsafePerformIO $ do
   vtbl <- mallocBytes (#size PgfUnmarshallerVtbl)
   wrapEAbsFun     unmarshalEAbs     >>= (#poke PgfUnmarshallerVtbl, eabs)     vtbl
   wrapEAppFun     unmarshalEApp     >>= (#poke PgfUnmarshallerVtbl, eapp)     vtbl
@@ -379,10 +377,9 @@ mkUnmarshaller = do
   wrapLStrFun     unmarshalLStr     >>= (#poke PgfUnmarshallerVtbl, lstr)     vtbl
   wrapDTypFun     unmarshalDTyp     >>= (#poke PgfUnmarshallerVtbl, dtyp)     vtbl
   (#poke PgfUnmarshallerVtbl, free_ref) vtbl hs_free_reference
-  (#poke PgfUnmarshallerVtbl, free_me)  vtbl hs_free_unmarshaller
   ptr <- mallocBytes (#size PgfUnmarshaller)
   (#poke PgfUnmarshaller, vtbl) ptr vtbl
-  return ptr
+  newForeignPtr hs_free_unmarshaller ptr
   where
     unmarshalEAbs this c_btype c_var c_body = do
       let btype = unmarshalBindType c_btype