msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

the Haskell marshaller/unmarshaller are now statically allocated

Browse Source
This commit is contained in:
Krasimir Angelov
2023-03-10 23:34:28 +01:00
parent 4863ab0ec9
commit 62d24b9431
5 changed files with 261 additions and 316 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/runtime/haskell/PGF.hsc
View File

@@ -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

95
src/runtime/haskell/PGF2.hsc
View File

@@ -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

396
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -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)

24
src/runtime/haskell/PGF2/Transactions.hsc
View File

@@ -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

59
src/runtime/haskell/utils.c
View File

@@ -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)
{
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
};