From 62d24b9431f94f206eb01bd4f52b14aac0191591 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Fri, 10 Mar 2023 23:34:28 +0100 Subject: [PATCH] the Haskell marshaller/unmarshaller are now statically allocated --- src/runtime/haskell/PGF.hsc | 3 +- src/runtime/haskell/PGF2.hsc | 95 ++---- src/runtime/haskell/PGF2/FFI.hsc | 396 ++++++++++------------ src/runtime/haskell/PGF2/Transactions.hsc | 24 +- src/runtime/haskell/utils.c | 59 ++-- 5 files changed, 261 insertions(+), 316 deletions(-) diff --git a/src/runtime/haskell/PGF.hsc b/src/runtime/haskell/PGF.hsc index d75b7482c..745473649 100644 --- a/src/runtime/haskell/PGF.hsc +++ b/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 diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 21406aa3c..031e88d15 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/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 m) + withPgfExn "exprProbability" (pgf_expr_prob (a_db p) c_revision c_e marshaller) 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 unmarshaller $ \u -> do - c_lit <- withPgfExn "concreteFlag" (pgf_get_concrete_flag (c_db c) c_revision c_name u) + withForeignPtr (c_revision c) $ \c_revision -> do + c_lit <- withPgfExn "concreteFlag" (pgf_get_concrete_flag (c_db c) c_revision c_name unmarshaller) 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 m)) free $ \c_text -> + bracket (withPgfExn "linearize" (pgf_linearize (c_db c) c_revision c_e nullPtr marshaller)) 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 m)) free $ \c_texts -> do + bracket (withPgfExn "tabularLinearize" (pgf_tabular_linearize (c_db c) c_revision c_e nullPtr marshaller)) 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 m)) free peekTables + bracket (withPgfExn "tabularLinearizeAll" (pgf_tabular_linearize_all (c_db c) c_revision c_e nullPtr marshaller)) 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 unmarshaller $ \u -> do - c_lit <- withPgfExn "globalFlag" (pgf_get_global_flag (a_db p) c_revision c_name u) + withForeignPtr (a_revision p) $ \c_revision -> do + c_lit <- withPgfExn "globalFlag" (pgf_get_global_flag (a_db p) c_revision c_name unmarshaller) 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 unmarshaller $ \u -> do - c_lit <- withPgfExn "abstractFlag" (pgf_get_abstract_flag (a_db p) c_revision c_name u) + withForeignPtr (a_revision p) $ \c_revision -> do + c_lit <- withPgfExn "abstractFlag" (pgf_get_abstract_flag (a_db p) c_revision c_name unmarshaller) 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 m) free $ \c_text -> + bracket (pgf_print_context n_hypos c_hypos pctxt 0 marshaller) free $ \c_text -> peekText c_text -- | parses a 'String' as a type readType :: String -> Maybe Type readType str = unsafePerformIO $ - withText str $ \c_str -> - withForeignPtr unmarshaller $ \u -> do - c_ty <- pgf_read_type c_str u + withText str $ \c_str -> do + c_ty <- pgf_read_type c_str unmarshaller 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 diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index d3b2b2959..54b3b2995 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/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 - -foreign import ccall "&hs_free_reference" hs_free_reference :: FunPtr (Ptr a -> StablePtr a -> IO ()) - -foreign import ccall "&hs_free_marshaller" hs_free_marshaller :: FinalizerPtr PgfMarshaller - -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 +haskell_dtyp 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 - matchLit 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 + 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) - matchExpr 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 + 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) - 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 () - 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) +foreign import ccall "&haskell_unmarshaller" unmarshaller :: Ptr PgfUnmarshaller marshalBindType :: BindType -> (#type PgfBindType) diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 6d99bfe94..c40ea793c 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/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 -> - withForeignPtr marshaller $ \m -> do - c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob m c_exn + (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode -> do + c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob marshaller 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 -> - withForeignPtr marshaller $ \m -> do - pgf_create_category c_db c_revision c_name n_hypos c_hypos prob m c_exn + withHypos hypos $ \n_hypos c_hypos -> do + pgf_create_category c_db c_revision c_name n_hypos c_hypos prob marshaller 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 m c_exn + pgf_set_global_flag c_db c_revision c_name c_value marshaller 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 m c_exn + pgf_set_abstract_flag c_db c_revision c_name c_value marshaller 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 m c_exn + pgf_set_concrete_flag c_db c_revision c_name c_value marshaller 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 -> - withText fun $ \c_fun -> - pgf_function_type c_db c_revision c_fun u c_exn + c_typ <- withText fun $ \c_fun -> + pgf_function_type c_db c_revision c_fun unmarshaller c_exn ex_type <- (#peek PgfExn, type) c_exn if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE) then if c_typ == castPtrToStablePtr nullPtr diff --git a/src/runtime/haskell/utils.c b/src/runtime/haskell/utils.c index ada1be3cf..f90c38009 100644 --- a/src/runtime/haskell/utils.c +++ b/src/runtime/haskell/utils.c @@ -1,35 +1,42 @@ #include #include #include +#include "PGF2/FFI_stub.h" -void hs_free_marshaller(PgfMarshaller *marshaller) -{ - hs_free_fun_ptr((HsFunPtr) marshaller->vtbl->match_lit); - hs_free_fun_ptr((HsFunPtr) marshaller->vtbl->match_expr); - hs_free_fun_ptr((HsFunPtr) marshaller->vtbl->match_type); - free(marshaller->vtbl); - free(marshaller); -} +static +PgfMarshallerVtbl haskell_marshaller_vtbl = { + (void*)haskell_match_lit, + (void*)haskell_match_expr, + (void*)haskell_match_type +}; -void hs_free_unmarshaller(PgfUnmarshaller *unmarshaller) -{ - 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); -} +PgfMarshaller haskell_marshaller = { + &haskell_marshaller_vtbl +}; -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 +};