the Haskell marshaller/unmarshaller are now statically allocated

src/runtime/haskell/PGF.hsc

@@ -103,9 +103,8 @@ pExpr =
   unsafePerformIO $
   withText str $ \c_str ->
   alloca  $ \c_pos ->
-  withForeignPtr unmarshaller $ \u ->
   mask_ $ do
-    c_expr <- pgf_read_expr_ex c_str c_pos u
+    c_expr <- pgf_read_expr_ex c_str c_pos unmarshaller
     if c_expr == castPtrToStablePtr nullPtr
       then return []
       else do expr <- deRefStablePtr c_expr

src/runtime/haskell/PGF2.hsc

@@ -354,9 +354,8 @@ abstractName p =
 startCat :: PGF -> Type
 startCat p =
   unsafePerformIO $
-  withForeignPtr unmarshaller $ \u ->
   withForeignPtr (a_revision p) $ \c_revision -> do
-    c_typ <- withPgfExn "startCat" (pgf_start_cat (a_db p) c_revision u)
+    c_typ <- withPgfExn "startCat" (pgf_start_cat (a_db p) c_revision unmarshaller)
     typ <- deRefStablePtr c_typ
     freeStablePtr c_typ
     return typ
@@ -365,10 +364,9 @@ startCat p =
 functionType :: PGF -> Fun -> Maybe Type
 functionType p fn =
   unsafePerformIO $
-  withForeignPtr unmarshaller $ \u ->
   withForeignPtr (a_revision p) $ \c_revision ->
   withText fn $ \c_fn -> do
-    c_typ <- withPgfExn "functionType" (pgf_function_type (a_db p) c_revision c_fn u)
+    c_typ <- withPgfExn "functionType" (pgf_function_type (a_db p) c_revision c_fn unmarshaller)
     if c_typ == castPtrToStablePtr nullPtr
       then return Nothing
       else do typ <- deRefStablePtr c_typ
@@ -395,8 +393,7 @@ exprProbability p e =
   unsafePerformIO $
   withForeignPtr (a_revision p) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
+    withPgfExn "exprProbability" (pgf_expr_prob (a_db p) c_revision c_e marshaller)
-    withPgfExn "exprProbability" (pgf_expr_prob (a_db p) c_revision c_e m)
 
 checkExpr :: PGF -> Expr -> Type -> Either String Expr
 checkExpr = error "TODO: checkExpr"
@@ -408,14 +405,12 @@ checkExpr = error "TODO: checkExpr"
 inferExpr :: PGF -> Expr -> Either String (Expr, Type)
 inferExpr p e =
   unsafePerformIO $
-  withForeignPtr marshaller $ \m ->
-  withForeignPtr unmarshaller $ \u ->
   withForeignPtr (a_revision p) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
   alloca $ \p_e ->
   allocaBytes (#size PgfExn) $ \c_exn -> do
     poke p_e c_e
-    c_ty <- pgf_infer_expr (a_db p) c_revision p_e m u c_exn
+    c_ty <- pgf_infer_expr (a_db p) c_revision p_e marshaller unmarshaller c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     case ex_type of
       (#const PGF_EXN_NONE) -> do
@@ -472,9 +467,8 @@ concreteFlag :: Concr -> String -> Maybe Literal
 concreteFlag c name =
   unsafePerformIO $
   withText name $ \c_name ->
-  withForeignPtr (c_revision c) $ \c_revision ->
+  withForeignPtr (c_revision c) $ \c_revision -> do
-  withForeignPtr unmarshaller $ \u -> do
+    c_lit <- withPgfExn "concreteFlag" (pgf_get_concrete_flag (c_db c) c_revision c_name unmarshaller)
-    c_lit <- withPgfExn "concreteFlag" (pgf_get_concrete_flag (c_db c) c_revision c_name u)
     if c_lit == castPtrToStablePtr nullPtr
       then return Nothing
       else do lit <- deRefStablePtr c_lit
@@ -495,9 +489,8 @@ alignWords :: Concr -> Expr -> [(String, [Int])]
 alignWords c e = unsafePerformIO $
   withForeignPtr (c_revision c) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
   alloca $ \p_n_phrases -> do
-    c_phrases <-  withPgfExn "alignWords" (pgf_align_words (c_db c) c_revision c_e nullPtr m p_n_phrases)
+    c_phrases <-  withPgfExn "alignWords" (pgf_align_words (c_db c) c_revision c_e nullPtr marshaller p_n_phrases)
     n_phrases <- peek p_n_phrases
     arr <- peekArray (fromIntegral n_phrases) c_phrases
     free c_phrases
@@ -702,19 +695,17 @@ parse :: Concr -> Type -> String -> ParseOutput [(Expr,Float)]
 parse c ty sent =
   unsafePerformIO $
   withForeignPtr (c_revision c) $ \c_revision ->
-  withForeignPtr marshaller $ \m ->
   bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
   withText sent $ \c_sent -> do
-    c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision c_ty m c_sent)
+    c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision c_ty marshaller c_sent)
     c_fetch <- (#peek PgfExprEnumVtbl, fetch) =<< (#peek PgfExprEnum, vtbl) c_enum
     exprs <- unsafeInterleaveIO (fetchLazy c_fetch c_enum)
     return (ParseOk exprs)
   where
     fetchLazy c_fetch c_enum =
       withForeignPtr (c_revision c) $ \c_revision ->
-      withForeignPtr unmarshaller $ \u -> 
       alloca $ \p_prob -> do
-        c_expr <- callFetch c_fetch c_enum (c_db c) u p_prob
+        c_expr <- callFetch c_fetch c_enum (c_db c) unmarshaller p_prob
         if c_expr == castPtrToStablePtr nullPtr
           then do pgf_free_expr_enum c_enum
                   return []
@@ -785,8 +776,7 @@ linearize c e =
   unsafePerformIO $
   withForeignPtr (c_revision c) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
+  bracket (withPgfExn "linearize" (pgf_linearize (c_db c) c_revision c_e nullPtr marshaller)) free $ \c_text ->
-  bracket (withPgfExn "linearize" (pgf_linearize (c_db c) c_revision c_e nullPtr m)) free $ \c_text ->
     if c_text == nullPtr
       then return ""
       else peekText c_text
@@ -797,9 +787,8 @@ linearizeAll c e =
   unsafePerformIO $
   withForeignPtr (c_revision c) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
   alloca $ \p_n_fields ->
-  bracket (withPgfExn "linearizeAll" (pgf_linearize_all (c_db c) c_revision c_e nullPtr m p_n_fields)) free $ \c_texts -> do
+  bracket (withPgfExn "linearizeAll" (pgf_linearize_all (c_db c) c_revision c_e nullPtr marshaller p_n_fields)) free $ \c_texts -> do
     n_fields <- peek p_n_fields
     peekTexts n_fields c_texts
   where
@@ -817,8 +806,7 @@ tabularLinearize c e =
   unsafePerformIO $
   withForeignPtr (c_revision c) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
+  bracket (withPgfExn "tabularLinearize" (pgf_tabular_linearize (c_db c) c_revision c_e nullPtr marshaller)) free $ \c_texts -> do
-  bracket (withPgfExn "tabularLinearize" (pgf_tabular_linearize (c_db c) c_revision c_e nullPtr m)) free $ \c_texts -> do
     if c_texts == nullPtr
       then return []
       else peekTable c_texts
@@ -841,8 +829,7 @@ tabularLinearizeAll c e =
   unsafePerformIO $
   withForeignPtr (c_revision c) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
+  bracket (withPgfExn "tabularLinearizeAll" (pgf_tabular_linearize_all (c_db c) c_revision c_e nullPtr marshaller)) free peekTables
-  bracket (withPgfExn "tabularLinearizeAll" (pgf_tabular_linearize_all (c_db c) c_revision c_e nullPtr m)) free peekTables
   where
     peekTables c_texts = do
       c_field <- peekElemOff c_texts 0
@@ -902,7 +889,6 @@ bracketedLinearize c e = unsafePerformIO $ do
   ref <- newIORef (False,[],[])
   (withForeignPtr (c_revision c) $ \c_revision ->
    bracket (newStablePtr e) freeStablePtr $ \c_e ->
-   withForeignPtr marshaller $ \m ->
    allocaBytes (#size PgfLinearizationOutputIface) $ \c_out ->
    allocaBytes (#size PgfLinearizationOutputIfaceVtbl) $ \vtbl ->
    bracket (wrapSymbol1 (symbol_token ref)) freeHaskellFunPtr $ \c_symbol_token ->
@@ -918,7 +904,7 @@ bracketedLinearize c e = unsafePerformIO $ do
      (#poke PgfLinearizationOutputIfaceVtbl, symbol_ne) vtbl c_symbol_ne
      (#poke PgfLinearizationOutputIfaceVtbl, flush) vtbl c_flush
      (#poke PgfLinearizationOutputIface, vtbl) c_out vtbl
-     withPgfExn "bracketedLinearize" (pgf_bracketed_linearize (c_db c) c_revision c_e nullPtr m c_out))
+     withPgfExn "bracketedLinearize" (pgf_bracketed_linearize (c_db c) c_revision c_e nullPtr marshaller c_out))
   (ne,_,bs) <- readIORef ref
   (if ne
      then return []
@@ -958,7 +944,6 @@ bracketedLinearizeAll c e = unsafePerformIO $ do
   ref <- newIORef (False,[],[],[])
   (withForeignPtr (c_revision c) $ \c_revision ->
    bracket (newStablePtr e) freeStablePtr $ \c_e ->
-   withForeignPtr marshaller $ \m ->
    allocaBytes (#size PgfLinearizationOutputIface) $ \c_out ->
    allocaBytes (#size PgfLinearizationOutputIfaceVtbl) $ \vtbl ->
    bracket (wrapSymbol1 (symbol_token ref)) freeHaskellFunPtr $ \c_symbol_token ->
@@ -974,7 +959,7 @@ bracketedLinearizeAll c e = unsafePerformIO $ do
      (#poke PgfLinearizationOutputIfaceVtbl, symbol_ne) vtbl c_symbol_ne
      (#poke PgfLinearizationOutputIfaceVtbl, flush) vtbl c_flush
      (#poke PgfLinearizationOutputIface, vtbl) c_out vtbl
-     withPgfExn "bracketedLinearizeAll" (pgf_bracketed_linearize_all (c_db c) c_revision c_e nullPtr m c_out))
+     withPgfExn "bracketedLinearizeAll" (pgf_bracketed_linearize_all (c_db c) c_revision c_e nullPtr marshaller c_out))
   (_,_,_,all) <- readIORef ref
   return all
   where
@@ -1037,14 +1022,12 @@ generateRandomDepth g p ty dp =
     generate seed =
       unsafePerformIO $
       bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
-      withForeignPtr marshaller $ \m ->
-      withForeignPtr unmarshaller $ \u ->
       withForeignPtr (a_revision p) $ \c_revision ->
       alloca $ \p_seed ->
       alloca $ \p_prob ->
       mask_ $ do
         poke p_seed seed
-        c_expr <- withPgfExn "generateRandomDepth" (pgf_generate_random (a_db p) c_revision c_ty (fromIntegral dp) p_seed p_prob m u)
+        c_expr <- withPgfExn "generateRandomDepth" (pgf_generate_random (a_db p) c_revision c_ty (fromIntegral dp) p_seed p_prob marshaller unmarshaller)
         if castStablePtrToPtr c_expr == nullPtr
           then return []
           else do expr <- deRefStablePtr c_expr
@@ -1064,14 +1047,12 @@ generateRandomFromDepth g p e dp =
     generate seed =
       unsafePerformIO $
       bracket (newStablePtr e) freeStablePtr $ \c_e ->
-      withForeignPtr marshaller $ \m ->
-      withForeignPtr unmarshaller $ \u ->
       withForeignPtr (a_revision p) $ \c_revision ->
       alloca $ \p_seed ->
       alloca $ \p_prob ->
       mask_ $ do
         poke p_seed seed
-        c_expr <- withPgfExn "generateRandomFromDepth" (pgf_generate_random_from (a_db p) c_revision c_e (fromIntegral dp) p_seed p_prob m u)
+        c_expr <- withPgfExn "generateRandomFromDepth" (pgf_generate_random_from (a_db p) c_revision c_e (fromIntegral dp) p_seed p_prob marshaller unmarshaller)
         if castStablePtrToPtr c_expr == nullPtr
           then return []
           else do expr <- deRefStablePtr c_expr
@@ -1104,10 +1085,9 @@ categoryContext p cat =
   unsafePerformIO $
   withText cat $ \c_cat ->
   alloca $ \p_n_hypos ->
-  withForeignPtr unmarshaller $ \u ->
   withForeignPtr (a_revision p) $ \c_revision ->
   mask_ $ do
-    c_hypos <- withPgfExn "categoryContext" (pgf_category_context (a_db p) c_revision c_cat p_n_hypos u)
+    c_hypos <- withPgfExn "categoryContext" (pgf_category_context (a_db p) c_revision c_cat p_n_hypos unmarshaller)
     if c_hypos == nullPtr
       then return Nothing
       else do n_hypos <- peek p_n_hypos
@@ -1198,9 +1178,8 @@ globalFlag :: PGF -> String -> Maybe Literal
 globalFlag p name =
   unsafePerformIO $
   withText name $ \c_name ->
-  withForeignPtr (a_revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision -> do
-  withForeignPtr unmarshaller $ \u -> do
+    c_lit <- withPgfExn "globalFlag" (pgf_get_global_flag (a_db p) c_revision c_name unmarshaller)
-    c_lit <- withPgfExn "globalFlag" (pgf_get_global_flag (a_db p) c_revision c_name u)
     if c_lit == castPtrToStablePtr nullPtr
       then return Nothing
       else do lit <- deRefStablePtr c_lit
@@ -1211,9 +1190,8 @@ abstractFlag :: PGF -> String -> Maybe Literal
 abstractFlag p name =
   unsafePerformIO $
   withText name $ \c_name ->
-  withForeignPtr (a_revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision -> do
-  withForeignPtr unmarshaller $ \u -> do
+    c_lit <- withPgfExn "abstractFlag" (pgf_get_abstract_flag (a_db p) c_revision c_name unmarshaller)
-    c_lit <- withPgfExn "abstractFlag" (pgf_get_abstract_flag (a_db p) c_revision c_name u)
     if c_lit == castPtrToStablePtr nullPtr
       then return Nothing
       else do lit <- deRefStablePtr c_lit
@@ -1264,9 +1242,8 @@ graphvizAbstractTree p opts e =
   unsafePerformIO $
   withForeignPtr (a_revision p) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
   withGraphvizOptions opts $ \c_opts ->
-  bracket (withPgfExn "graphvizAbstractTree" (pgf_graphviz_abstract_tree (a_db p) c_revision c_e m c_opts)) free $ \c_text ->
+  bracket (withPgfExn "graphvizAbstractTree" (pgf_graphviz_abstract_tree (a_db p) c_revision c_e marshaller c_opts)) free $ \c_text ->
     peekText c_text
 
 graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String
@@ -1274,9 +1251,8 @@ graphvizParseTree c opts e =
   unsafePerformIO $
   withForeignPtr (c_revision c) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
   withGraphvizOptions opts $ \c_opts ->
-  bracket (withPgfExn "graphvizParseTree" (pgf_graphviz_parse_tree  (c_db c) c_revision c_e nullPtr m c_opts)) free $ \c_text ->
+  bracket (withPgfExn "graphvizParseTree" (pgf_graphviz_parse_tree  (c_db c) c_revision c_e nullPtr marshaller c_opts)) free $ \c_text ->
     if c_text == nullPtr
       then return ""
       else peekText c_text
@@ -1287,9 +1263,8 @@ graphvizWordAlignment cs opts e =
   unsafePerformIO $
   withPgfConcrs cs $ \c_db c_revisions n_revisions ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
-  withForeignPtr marshaller $ \m ->
   withGraphvizOptions opts $ \c_opts ->
-  bracket (withPgfExn "graphvizWordAlignment" (pgf_graphviz_word_alignment c_db c_revisions n_revisions c_e nullPtr m c_opts)) free $ \c_text ->
+  bracket (withPgfExn "graphvizWordAlignment" (pgf_graphviz_word_alignment c_db c_revisions n_revisions c_e nullPtr marshaller c_opts)) free $ \c_text ->
     if c_text == nullPtr
       then return ""
       else peekText c_text
@@ -1542,10 +1517,9 @@ printCoNLL = unlines . map (concat . intersperse "\t")
 showExpr :: [Var] -> Expr -> String
 showExpr scope e =
   unsafePerformIO $
-  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 ->
+  bracket (pgf_print_expr c_e pctxt 1 marshaller) free $ \c_text ->
     peekText c_text
 
 newPrintCtxt :: [Var] -> IO (Ptr PgfPrintContext)
@@ -1567,9 +1541,8 @@ readExpr :: String -> Maybe Expr
 readExpr str =
   unsafePerformIO $
   withText str $ \c_str ->
-  withForeignPtr unmarshaller $ \u ->
   mask_ $ do
-    c_expr <- pgf_read_expr c_str u
+    c_expr <- pgf_read_expr c_str unmarshaller
     if c_expr == castPtrToStablePtr nullPtr
       then return Nothing
       else do expr <- deRefStablePtr c_expr
@@ -1583,10 +1556,9 @@ readExpr str =
 showType :: [Var] -> Type -> String
 showType scope ty =
   unsafePerformIO $
-  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 ->
+  bracket (pgf_print_type c_ty pctxt 0 marshaller) free $ \c_text ->
     peekText c_text
 
 showContext :: [Var] -> [(BindType,Var,Type)] -> String
@@ -1594,17 +1566,15 @@ showContext scope hypos =
   unsafePerformIO $
   withHypos hypos $ \n_hypos c_hypos ->
   bracket (newPrintCtxt scope) freePrintCtxt $ \pctxt ->
-  withForeignPtr marshaller $ \m ->
+  bracket (pgf_print_context n_hypos c_hypos pctxt 0 marshaller) free $ \c_text ->
-  bracket (pgf_print_context n_hypos c_hypos pctxt 0 m) free $ \c_text ->
     peekText c_text
 
 -- | parses a 'String' as a type
 readType :: String -> Maybe Type
 readType str =
   unsafePerformIO $
-  withText str $ \c_str ->
+  withText str $ \c_str -> do
-  withForeignPtr unmarshaller $ \u -> do
+    c_ty <- pgf_read_type c_str unmarshaller
-    c_ty <- pgf_read_type c_str u
     if c_ty == castPtrToStablePtr nullPtr
       then return Nothing
       else do ty <- deRefStablePtr c_ty
@@ -1615,9 +1585,8 @@ readContext :: String -> Maybe [Hypo]
 readContext str =
   unsafePerformIO $
   withText str $ \c_str ->
-  withForeignPtr unmarshaller $ \u ->
   alloca $ \p_n_hypos -> do
-    c_hypos <- pgf_read_context c_str u p_n_hypos
+    c_hypos <- pgf_read_context c_str unmarshaller p_n_hypos
     n_hypos <- peek p_n_hypos
     if c_hypos == nullPtr && n_hypos /= 0
       then return Nothing

src/runtime/haskell/PGF2/FFI.hsc

@@ -411,279 +411,255 @@ withPgfExn loc f =
 
 type CBindType = (#type PgfBindType)
 
+foreign export ccall haskell_match_lit :: Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr Literal -> IO (StablePtr Literal)
+
+haskell_match_lit this u c_lit = do
+  vtbl <- (#peek PgfUnmarshaller, vtbl) u
+  lit <- deRefStablePtr c_lit
+  case lit of
+    LStr s -> withText s $ \c_s -> do
+                 fun <- (#peek PgfUnmarshallerVtbl, lstr) vtbl
+                 callLStrFun fun u c_s
+    LInt n -> let abs_n = abs n
+                  size  = I## (integerLogBase## (#const LINT_BASE) abs_n +## 1##)
+              in allocaArray size $ \c_v -> do
+                   pokeValue c_v (c_v `plusPtr` ((#size uintmax_t) * (size - 1)))
+                             (fromIntegral (signum n)) abs_n
+                   fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl
+                   callLIntFun fun u (fromIntegral size) c_v
+    LFlt d -> do fun <- (#peek PgfUnmarshallerVtbl, lflt) vtbl
+                 callLFltFun fun u (realToFrac d)
+  where
+    pokeValue c_v p sign abs_n
+      | c_v == p  = poke p (sign * fromIntegral abs_n)
+      | otherwise = do let (q,r) = quotRem abs_n (#const LINT_BASE)
+                       poke p (fromIntegral r)
+                       pokeValue c_v (p `plusPtr` (- #size uintmax_t)) sign q
+
+
+foreign export ccall haskell_match_expr :: Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr Expr -> IO (StablePtr Expr)
+
+haskell_match_expr this u c_expr = do
+  vtbl <- (#peek PgfUnmarshaller, vtbl) u
+  expr <- deRefStablePtr c_expr
+  case expr of
+    EAbs bt var e-> withText var $ \c_var ->
+                    bracket (newStablePtr e) freeStablePtr $ \c_e -> do
+                       fun <- (#peek PgfUnmarshallerVtbl, eabs) vtbl
+                       callEAbsFun fun u (marshalBindType bt) c_var c_e
+    EApp fun arg -> bracket (newStablePtr fun) freeStablePtr $ \c_fun ->
+                    bracket (newStablePtr arg) freeStablePtr $ \c_arg -> do
+                       fun <- (#peek PgfUnmarshallerVtbl, eapp) vtbl
+                       callEAppFun fun u c_fun c_arg
+    ELit lit     -> bracket (newStablePtr lit) freeStablePtr $ \c_lit -> do
+                       fun <- (#peek PgfUnmarshallerVtbl, elit) vtbl
+                       callELitFun fun u c_lit
+    EMeta id     -> do fun <- (#peek PgfUnmarshallerVtbl, emeta) vtbl
+                       callEMetaFun fun u (fromIntegral id)
+    EFun name    -> withText name $ \c_name -> do
+                       fun <- (#peek PgfUnmarshallerVtbl, efun) vtbl
+                       callEFunFun fun u c_name
+    EVar index   -> do fun <- (#peek PgfUnmarshallerVtbl, evar) vtbl
+                       callEVarFun fun u (fromIntegral index)
+    ETyped e ty  -> bracket (newStablePtr e)  freeStablePtr $ \c_e  ->
+                    bracket (newStablePtr ty) freeStablePtr $ \c_ty -> do
+                       fun <- (#peek PgfUnmarshallerVtbl, etyped) vtbl
+                       callETypedFun fun u c_e c_ty
+    EImplArg arg -> bracket (newStablePtr arg) freeStablePtr $ \c_arg -> do
+                       fun <- (#peek PgfUnmarshallerVtbl, eimplarg) vtbl
+                       callEImplArgFun fun u c_arg
+
+
+foreign export ccall haskell_match_type :: Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr Type -> IO (StablePtr Type)
+
+haskell_match_type this u c_ty = do
+  vtbl <- (#peek PgfUnmarshaller, vtbl) u
+  ty   <- deRefStablePtr c_ty
+  case ty of
+    DTyp hypos cat es -> let n_hypos = length hypos
+                         in withHypos hypos $ \n_hypos c_hypos ->
+                            withText cat $ \c_cat ->
+                            mask_ $ do
+                              c_es <- mapM newStablePtr es
+                              res <- withArray c_es $ \c_exprs -> do
+                                       fun <- (#peek PgfUnmarshallerVtbl, dtyp) vtbl
+                                       callDTypFun fun u
+                                                   n_hypos
+                                                   c_hypos
+                                                   c_cat
+                                                   (fromIntegral (length es))
+                                                   c_exprs
+                              mapM_ freeStablePtr c_es
+                              return res
+  where
+    marshalHypos _   []               = return ()
+    marshalHypos ptr ((bt,var,ty):hs) = do
+      (#poke PgfTypeHypo, bind_type) ptr (marshalBindType bt)
+      newText var     >>= (#poke PgfTypeHypo, cid)  ptr
+      newStablePtr ty >>= (#poke PgfTypeHypo, type) ptr
+      marshalHypos (ptr `plusPtr` (#size PgfTypeHypo)) hs
+
+    freeHypos ptr 0 = return ()
+    freeHypos ptr n = do
+      (#peek PgfTypeHypo, cid)  ptr >>= free
+      (#peek PgfTypeHypo, type) ptr >>= freeStablePtr
+      freeHypos (ptr `plusPtr` (#size PgfTypeHypo)) (n-1)
+
+
+foreign import ccall "&haskell_marshaller" marshaller :: Ptr PgfMarshaller
+
+
 type EAbsFun = Ptr PgfUnmarshaller -> (#type PgfBindType) -> Ptr PgfText -> StablePtr Expr -> IO (StablePtr Expr)
 
 foreign import ccall "dynamic" callEAbsFun :: Dynamic EAbsFun
+foreign export ccall haskell_eabs :: EAbsFun
+
+haskell_eabs this c_btype c_var c_body = do
+  let btype = unmarshalBindType c_btype
+  var <- peekText c_var
+  body <- deRefStablePtr c_body
+  newStablePtr (EAbs btype var body)
 
-foreign import ccall "wrapper" wrapEAbsFun :: Wrapper EAbsFun
 
 type EAppFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr)
 
 foreign import ccall "dynamic" callEAppFun :: Dynamic EAppFun
+foreign export ccall haskell_eapp :: EAppFun
+
+haskell_eapp this c_fun c_arg = do
+  fun <- deRefStablePtr c_fun
+  arg <- deRefStablePtr c_arg
+  newStablePtr (EApp fun arg)
 
-foreign import ccall "wrapper" wrapEAppFun :: Wrapper EAppFun
 
 type ELitFun = Ptr PgfUnmarshaller -> StablePtr Literal -> IO (StablePtr Expr)
 
 foreign import ccall "dynamic" callELitFun :: Dynamic ELitFun
+foreign export ccall haskell_elit :: ELitFun
+
+haskell_elit this c_lit = do
+  lit <- deRefStablePtr c_lit
+  newStablePtr (ELit lit)
 
-foreign import ccall "wrapper" wrapELitFun :: Wrapper ELitFun
 
 type EMetaFun = Ptr PgfUnmarshaller -> (#type PgfMetaId) -> IO (StablePtr Expr)
 
 foreign import ccall "dynamic" callEMetaFun :: Dynamic EMetaFun
+foreign export ccall haskell_emeta :: EMetaFun
+
+haskell_emeta this c_metaid = do
+  newStablePtr (EMeta (fromIntegral c_metaid))
 
-foreign import ccall "wrapper" wrapEMetaFun :: Wrapper EMetaFun
 
 type EFunFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Expr)
 
 foreign import ccall "dynamic" callEFunFun :: Dynamic EFunFun
+foreign export ccall haskell_efun :: EFunFun
+
+haskell_efun this c_name = do
+  name <- peekText c_name
+  newStablePtr (EFun name)
 
-foreign import ccall "wrapper" wrapEFunFun :: Wrapper EFunFun
 
 type EVarFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Expr)
 
 foreign import ccall "dynamic" callEVarFun :: Dynamic EVarFun
+foreign export ccall haskell_evar :: EVarFun
+
+haskell_evar this c_var = do
+  newStablePtr (EVar (fromIntegral c_var))
 
-foreign import ccall "wrapper" wrapEVarFun :: Wrapper EVarFun
 
 type ETypedFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr)
 
 foreign import ccall "dynamic" callETypedFun :: Dynamic ETypedFun
+foreign export ccall haskell_etyped :: ETypedFun
+
+haskell_etyped this c_expr c_typ = do
+  expr <- deRefStablePtr c_expr
+  typ  <- deRefStablePtr c_typ
+  newStablePtr (ETyped expr typ)
 
-foreign import ccall "wrapper" wrapETypedFun :: Wrapper ETypedFun
 
 type EImplArgFun = Ptr PgfUnmarshaller -> StablePtr Expr -> IO (StablePtr Expr)
 
 foreign import ccall "dynamic" callEImplArgFun :: Dynamic EImplArgFun
+foreign export ccall haskell_eimplarg :: EImplArgFun
+
+haskell_eimplarg this c_expr = do
+  expr <- deRefStablePtr c_expr
+  newStablePtr (EImplArg expr)
 
-foreign import ccall "wrapper" wrapEImplArgFun :: Wrapper EImplArgFun
 
 type LIntFun = Ptr PgfUnmarshaller -> (#type size_t) -> Ptr (#type uintmax_t) -> IO (StablePtr Literal)
 
 foreign import ccall "dynamic" callLIntFun :: Dynamic LIntFun
+foreign export ccall haskell_lint :: LIntFun
+
+haskell_lint this c_size c_v = do
+  n <- if c_size == 0
+         then return 0
+         else do v     <- peek (castPtr c_v :: Ptr (#type intmax_t))
+                 abs_n <- peekValue (c_size-1)
+                                    (c_v `plusPtr` (#size uintmax_t))
+                                    (fromIntegral (abs v))
+                 return (fromIntegral (signum v) * abs_n)
+  newStablePtr (LInt n)
+  where
+    peekValue 0      c_v value = return value
+    peekValue c_size c_v value = do
+      v <- peek (castPtr c_v :: Ptr (#type uintmax_t))
+      peekValue (c_size-1)
+                (c_v `plusPtr` (#size uintmax_t))
+                (value*(#const LINT_BASE)+fromIntegral v)
 
-foreign import ccall "wrapper" wrapLIntFun :: Wrapper LIntFun
 
 type LFltFun = Ptr PgfUnmarshaller -> CDouble -> IO (StablePtr Literal)
 
 foreign import ccall "dynamic" callLFltFun :: Dynamic LFltFun
+foreign export ccall haskell_lflt :: LFltFun
+
+haskell_lflt this c_v = do
+  newStablePtr (LFlt (realToFrac c_v))
 
-foreign import ccall "wrapper" wrapLFltFun :: Wrapper LFltFun
 
 type LStrFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Literal)
 
 foreign import ccall "dynamic" callLStrFun :: Dynamic LStrFun
+foreign export ccall haskell_lstr :: LStrFun
+
+haskell_lstr this c_v = do
+  s <- peekText c_v
+  newStablePtr (LStr s)
 
-foreign import ccall "wrapper" wrapLStrFun :: Wrapper LStrFun
 
 type DTypFun = Ptr PgfUnmarshaller -> CSize -> Ptr PgfTypeHypo -> Ptr PgfText -> CSize -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
 
 foreign import ccall "dynamic" callDTypFun :: Dynamic DTypFun
+foreign export ccall haskell_dtyp :: DTypFun
 
-foreign import ccall "wrapper" wrapDTypFun :: Wrapper DTypFun
+haskell_dtyp this n_hypos hypos c_cat n_exprs exprs = do
-
+  hypos <- peekHypos n_hypos hypos
-foreign import ccall "&hs_free_reference" hs_free_reference :: FunPtr (Ptr a -> StablePtr a -> IO ())
+  cat <- peekText c_cat
-
+  exprs <- peekExprs n_exprs exprs
-foreign import ccall "&hs_free_marshaller" hs_free_marshaller :: FinalizerPtr PgfMarshaller
+  newStablePtr (DTyp hypos cat exprs)
-
-foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FinalizerPtr PgfUnmarshaller
-
-foreign import ccall "wrapper" wrapMatchFun :: Wrapper (Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr a -> IO (StablePtr a))
-
-{-# 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
-  ptr <- mallocBytes (#size PgfMarshaller)
-  (#poke PgfMarshaller, vtbl) ptr vtbl
-  newForeignPtr hs_free_marshaller ptr
   where
-    matchLit this u c_lit = do
+    peekHypos 0       p_hypo = return []
-      vtbl <- (#peek PgfUnmarshaller, vtbl) u
+    peekHypos n_hypos p_hypo = do
-      lit <- deRefStablePtr c_lit
+      bt  <- fmap unmarshalBindType ((#peek PgfTypeHypo, bind_type) p_hypo)
-      case lit of
+      cid <- (#peek PgfTypeHypo, cid) p_hypo >>= peekText
-        LStr s -> withText s $ \c_s -> do
+      ty  <- (#peek PgfTypeHypo, type) p_hypo >>= deRefStablePtr
-                     fun <- (#peek PgfUnmarshallerVtbl, lstr) vtbl
+      hs  <- peekHypos (n_hypos-1) (p_hypo `plusPtr` (#size PgfTypeHypo))
-                     callLStrFun fun u c_s
+      return ((bt,cid,ty):hs)
-        LInt n -> let abs_n = abs n
-                      size  = I## (integerLogBase## (#const LINT_BASE) abs_n +## 1##)
-                  in allocaArray size $ \c_v -> do
-                       pokeValue c_v (c_v `plusPtr` ((#size uintmax_t) * (size - 1)))
-                                 (fromIntegral (signum n)) abs_n
-                       fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl
-                       callLIntFun fun u (fromIntegral size) c_v
-        LFlt d -> do fun <- (#peek PgfUnmarshallerVtbl, lflt) vtbl
-                     callLFltFun fun u (realToFrac d)
-      where
-        pokeValue c_v p sign abs_n
-          | c_v == p  = poke p (sign * fromIntegral abs_n)
-          | otherwise = do let (q,r) = quotRem abs_n (#const LINT_BASE)
-                           poke p (fromIntegral r)
-                           pokeValue c_v (p `plusPtr` (- #size uintmax_t)) sign q
 
-    matchExpr this u c_expr = do
+    peekExprs 0       p_expr = return []
-      vtbl <- (#peek PgfUnmarshaller, vtbl) u
+    peekExprs n_exprs p_expr = do
-      expr <- deRefStablePtr c_expr
+      e  <- peek p_expr >>= deRefStablePtr
-      case expr of
+      es <- peekExprs (n_exprs-1) (p_expr `plusPtr` (#size uintptr_t))
-        EAbs bt var e-> withText var $ \c_var ->
+      return (e:es)
-                        bracket (newStablePtr e) freeStablePtr $ \c_e -> do
-                           fun <- (#peek PgfUnmarshallerVtbl, eabs) vtbl
-                           callEAbsFun fun u (marshalBindType bt) c_var c_e
-        EApp fun arg -> bracket (newStablePtr fun) freeStablePtr $ \c_fun ->
-                        bracket (newStablePtr arg) freeStablePtr $ \c_arg -> do
-                           fun <- (#peek PgfUnmarshallerVtbl, eapp) vtbl
-                           callEAppFun fun u c_fun c_arg
-        ELit lit     -> bracket (newStablePtr lit) freeStablePtr $ \c_lit -> do
-                           fun <- (#peek PgfUnmarshallerVtbl, elit) vtbl
-                           callELitFun fun u c_lit
-        EMeta id     -> do fun <- (#peek PgfUnmarshallerVtbl, emeta) vtbl
-                           callEMetaFun fun u (fromIntegral id)
-        EFun name    -> withText name $ \c_name -> do
-                           fun <- (#peek PgfUnmarshallerVtbl, efun) vtbl
-                           callEFunFun fun u c_name
-        EVar index   -> do fun <- (#peek PgfUnmarshallerVtbl, evar) vtbl
-                           callEVarFun fun u (fromIntegral index)
-        ETyped e ty  -> bracket (newStablePtr e)  freeStablePtr $ \c_e  ->
-                        bracket (newStablePtr ty) freeStablePtr $ \c_ty -> do
-                           fun <- (#peek PgfUnmarshallerVtbl, etyped) vtbl
-                           callETypedFun fun u c_e c_ty
-        EImplArg arg -> bracket (newStablePtr arg) freeStablePtr $ \c_arg -> do
-                           fun <- (#peek PgfUnmarshallerVtbl, eimplarg) vtbl
-                           callEImplArgFun fun u c_arg
 
-    matchType this u c_ty = do
-      vtbl <- (#peek PgfUnmarshaller, vtbl) u
-      ty   <- deRefStablePtr c_ty
-      case ty of
-        DTyp hypos cat es -> let n_hypos = length hypos
-                             in withHypos hypos $ \n_hypos c_hypos ->
-                                withText cat $ \c_cat ->
-                                mask_ $ do
-                                  c_es <- mapM newStablePtr es
-                                  res <- withArray c_es $ \c_exprs -> do
-                                           fun <- (#peek PgfUnmarshallerVtbl, dtyp) vtbl
-                                           callDTypFun fun u
-                                                       n_hypos
-                                                       c_hypos
-                                                       c_cat
-                                                       (fromIntegral (length es))
-                                                       c_exprs
-                                  mapM_ freeStablePtr c_es
-                                  return res
-      where
-        marshalHypos _   []               = return ()
-        marshalHypos ptr ((bt,var,ty):hs) = do
-          (#poke PgfTypeHypo, bind_type) ptr (marshalBindType bt)
-          newText var     >>= (#poke PgfTypeHypo, cid)  ptr
-          newStablePtr ty >>= (#poke PgfTypeHypo, type) ptr
-          marshalHypos (ptr `plusPtr` (#size PgfTypeHypo)) hs
 
-        freeHypos ptr 0 = return ()
+foreign import ccall "&haskell_unmarshaller" unmarshaller :: Ptr PgfUnmarshaller
-        freeHypos ptr n = do
-          (#peek PgfTypeHypo, cid)  ptr >>= free
-          (#peek PgfTypeHypo, type) ptr >>= freeStablePtr
-          freeHypos (ptr `plusPtr` (#size PgfTypeHypo)) (n-1)
-
-{-# NOINLINE unmarshaller #-}
-unmarshaller = unsafePerformIO $ do
-  vtbl <- mallocBytes (#size PgfUnmarshallerVtbl)
-  wrapEAbsFun     unmarshalEAbs     >>= (#poke PgfUnmarshallerVtbl, eabs)     vtbl
-  wrapEAppFun     unmarshalEApp     >>= (#poke PgfUnmarshallerVtbl, eapp)     vtbl
-  wrapELitFun     unmarshalELit     >>= (#poke PgfUnmarshallerVtbl, elit)     vtbl
-  wrapEMetaFun    unmarshalEMeta    >>= (#poke PgfUnmarshallerVtbl, emeta)    vtbl
-  wrapEFunFun     unmarshalEFun     >>= (#poke PgfUnmarshallerVtbl, efun)     vtbl
-  wrapEVarFun     unmarshalEVar     >>= (#poke PgfUnmarshallerVtbl, evar)     vtbl
-  wrapETypedFun   unmarshalETyped   >>= (#poke PgfUnmarshallerVtbl, etyped)   vtbl
-  wrapEImplArgFun unmarshalEImplArg >>= (#poke PgfUnmarshallerVtbl, eimplarg) vtbl
-  wrapLIntFun     unmarshalLInt     >>= (#poke PgfUnmarshallerVtbl, lint)     vtbl
-  wrapLFltFun     unmarshalLFlt     >>= (#poke PgfUnmarshallerVtbl, lflt)     vtbl
-  wrapLStrFun     unmarshalLStr     >>= (#poke PgfUnmarshallerVtbl, lstr)     vtbl
-  wrapDTypFun     unmarshalDTyp     >>= (#poke PgfUnmarshallerVtbl, dtyp)     vtbl
-  (#poke PgfUnmarshallerVtbl, free_ref) vtbl hs_free_reference
-  ptr <- mallocBytes (#size PgfUnmarshaller)
-  (#poke PgfUnmarshaller, vtbl) ptr vtbl
-  newForeignPtr hs_free_unmarshaller ptr
-  where
-    unmarshalEAbs this c_btype c_var c_body = do
-      let btype = unmarshalBindType c_btype
-      var <- peekText c_var
-      body <- deRefStablePtr c_body
-      newStablePtr (EAbs btype var body)
-
-    unmarshalEApp this c_fun c_arg = do
-      fun <- deRefStablePtr c_fun
-      arg <- deRefStablePtr c_arg
-      newStablePtr (EApp fun arg)
-
-    unmarshalELit this c_lit = do
-      lit <- deRefStablePtr c_lit
-      newStablePtr (ELit lit)
-
-    unmarshalEMeta this c_metaid = do
-      newStablePtr (EMeta (fromIntegral c_metaid))
-
-    unmarshalEFun this c_name = do
-      name <- peekText c_name
-      newStablePtr (EFun name)
-
-    unmarshalEVar this c_var = do
-      newStablePtr (EVar (fromIntegral c_var))
-
-    unmarshalETyped this c_expr c_typ = do
-      expr <- deRefStablePtr c_expr
-      typ  <- deRefStablePtr c_typ
-      newStablePtr (ETyped expr typ)
-
-    unmarshalEImplArg this c_expr = do
-      expr <- deRefStablePtr c_expr
-      newStablePtr (EImplArg expr)
-
-    unmarshalLInt this c_size c_v = do
-      n <- if c_size == 0
-             then return 0
-             else do v     <- peek (castPtr c_v :: Ptr (#type intmax_t))
-                     abs_n <- peekValue (c_size-1)
-                                        (c_v `plusPtr` (#size uintmax_t))
-                                        (fromIntegral (abs v))
-                     return (fromIntegral (signum v) * abs_n)
-      newStablePtr (LInt n)
-      where
-        peekValue 0      c_v value = return value
-        peekValue c_size c_v value = do
-          v <- peek (castPtr c_v :: Ptr (#type uintmax_t))
-          peekValue (c_size-1)
-                    (c_v `plusPtr` (#size uintmax_t))
-                    (value*(#const LINT_BASE)+fromIntegral v)
-
-    unmarshalLFlt this c_v = do
-      newStablePtr (LFlt (realToFrac c_v))
-
-    unmarshalLStr this c_v = do
-      s <- peekText c_v
-      newStablePtr (LStr s)
-
-    unmarshalDTyp this n_hypos hypos c_cat n_exprs exprs = do
-      hypos <- peekHypos n_hypos hypos
-      cat <- peekText c_cat
-      exprs <- peekExprs n_exprs exprs
-      newStablePtr (DTyp hypos cat exprs)
-      where
-        peekHypos 0       p_hypo = return []
-        peekHypos n_hypos p_hypo = do
-          bt  <- fmap unmarshalBindType ((#peek PgfTypeHypo, bind_type) p_hypo)
-          cid <- (#peek PgfTypeHypo, cid) p_hypo >>= peekText
-          ty  <- (#peek PgfTypeHypo, type) p_hypo >>= deRefStablePtr
-          hs  <- peekHypos (n_hypos-1) (p_hypo `plusPtr` (#size PgfTypeHypo))
-          return ((bt,cid,ty):hs)
-
-        peekExprs 0       p_expr = return []
-        peekExprs n_exprs p_expr = do
-          e  <- peek p_expr >>= deRefStablePtr
-          es <- peekExprs (n_exprs-1) (p_expr `plusPtr` (#size uintptr_t))
-          return (e:es)
 
 
 marshalBindType :: BindType -> (#type PgfBindType)

src/runtime/haskell/PGF2/Transactions.hsc

@@ -157,9 +157,8 @@ createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF Fu
 createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
-  (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode ->
+  (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode -> do
-  withForeignPtr marshaller $ \m -> do
+    c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn
-    c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob m c_exn
     if c_name == nullPtr
       then return ""
       else do name  <- peekText c_name
@@ -174,9 +173,8 @@ dropFunction name = Transaction $ \c_db _ c_revision c_exn ->
 createCategory :: Cat -> [Hypo] -> Float -> Transaction PGF ()
 createCategory name hypos prob = Transaction $ \c_db _ c_revision c_exn ->
   withText name $ \c_name ->
-  withHypos hypos $ \n_hypos c_hypos ->
+  withHypos hypos $ \n_hypos c_hypos -> do
-  withForeignPtr marshaller $ \m -> do
+    pgf_create_category c_db c_revision c_name n_hypos c_hypos prob marshaller c_exn
-    pgf_create_category c_db c_revision c_name n_hypos c_hypos prob m c_exn
 
 dropCategory :: Cat -> Transaction PGF ()
 dropCategory name = Transaction $ \c_db _ c_revision c_exn ->
@@ -220,22 +218,19 @@ setGlobalFlag :: String -> Literal -> Transaction PGF ()
 setGlobalFlag name value = Transaction $ \c_db _ c_revision c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
-  withForeignPtr marshaller $ \m ->
+    pgf_set_global_flag c_db c_revision c_name c_value marshaller c_exn
-    pgf_set_global_flag c_db c_revision c_name c_value m c_exn
 
 setAbstractFlag :: String -> Literal -> Transaction PGF ()
 setAbstractFlag name value = Transaction $ \c_db _ c_revision c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
-  withForeignPtr marshaller $ \m ->
+    pgf_set_abstract_flag c_db c_revision c_name c_value marshaller c_exn
-    pgf_set_abstract_flag c_db c_revision c_name c_value m c_exn
 
 setConcreteFlag :: String -> Literal -> Transaction Concr ()
 setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
-  withForeignPtr marshaller $ \m ->
+    pgf_set_concrete_flag c_db c_revision c_name c_value marshaller c_exn
-    pgf_set_concrete_flag c_db c_revision c_name c_value m c_exn
 
 type Token  = String
 
@@ -428,9 +423,8 @@ setPrintName fun name = Transaction $ \c_db _ c_revision c_exn ->
 -- the function in the current transaction.
 getFunctionType :: Fun -> Transaction PGF (Maybe Type)
 getFunctionType fun = Transaction $ \c_db c_revision _ c_exn -> do
-  c_typ <- withForeignPtr unmarshaller $ \u ->
+  c_typ <- withText fun $ \c_fun ->
-           withText fun $ \c_fun ->
+             pgf_function_type c_db c_revision c_fun unmarshaller c_exn
-             pgf_function_type c_db c_revision c_fun u c_exn
   ex_type <- (#peek PgfExn, type) c_exn
   if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
     then if c_typ == castPtrToStablePtr nullPtr

src/runtime/haskell/utils.c

@@ -1,35 +1,42 @@
 #include <HsFFI.h>
 #include <pgf/pgf.h>
 #include <stdlib.h>
+#include "PGF2/FFI_stub.h"
 
-void hs_free_marshaller(PgfMarshaller *marshaller)
+static
-{
+PgfMarshallerVtbl haskell_marshaller_vtbl = {
-    hs_free_fun_ptr((HsFunPtr) marshaller->vtbl->match_lit);
+    (void*)haskell_match_lit,
-    hs_free_fun_ptr((HsFunPtr) marshaller->vtbl->match_expr);
+    (void*)haskell_match_expr,
-    hs_free_fun_ptr((HsFunPtr) marshaller->vtbl->match_type);
+    (void*)haskell_match_type
-    free(marshaller->vtbl);
+};
-    free(marshaller);
-}
 
-void hs_free_unmarshaller(PgfUnmarshaller *unmarshaller)
+PgfMarshaller haskell_marshaller = {
-{
+    &haskell_marshaller_vtbl
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->eabs);
+};
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->eapp);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->elit);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->emeta);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->efun);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->evar);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->etyped);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->eimplarg);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->lint);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->lflt);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->lstr);
-    hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->dtyp);
-    free(unmarshaller->vtbl);
-    free(unmarshaller);
-}
 
-void hs_free_reference(PgfUnmarshaller *self, uintptr_t ref)
+static
+void haskell_free_ref(PgfUnmarshaller *self, uintptr_t ref)
 {
     hs_free_stable_ptr((HsStablePtr) ref);
 }
+
+static
+PgfUnmarshallerVtbl haskell_unmarshaller_vtbl = {
+    (void*)haskell_eabs,
+    (void*)haskell_eapp,
+    (void*)haskell_elit,
+    (void*)haskell_emeta,
+    (void*)haskell_efun,
+    (void*)haskell_evar,
+    (void*)haskell_etyped,
+    (void*)haskell_eimplarg,
+    (void*)haskell_lint,
+    (void*)haskell_lflt,
+    (void*)haskell_lstr,
+    (void*)haskell_dtyp,
+    haskell_free_ref
+};
+
+PgfUnmarshaller haskell_unmarshaller = {
+    &haskell_unmarshaller_vtbl
+};