diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 2dce3d063..1b7f571cf 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -125,7 +125,7 @@ struct PgfPGF : DB { { u = unmarshaller; }; PGF_INTERNAL_DECL ~PgfPGF() - { u->free_me(u); }; + { u->free_me(); }; PgfUnmarshaller *u; }; diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 018194d89..9b16999c4 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -76,26 +76,52 @@ typedef struct { * actually be a stable pointer, while for Python that would be * a PyObject pointer. */ +#ifdef __cplusplus typedef struct PgfUnmarshaller PgfUnmarshaller; struct PgfUnmarshaller { - uintptr_t (*eabs)(PgfBindType btype, PgfText *name, uintptr_t body); - uintptr_t (*eapp)(uintptr_t fun, uintptr_t arg); - uintptr_t (*elit)(uintptr_t lit); - uintptr_t (*emeta)(PgfMetaId meta); - uintptr_t (*efun)(PgfText *name); - uintptr_t (*evar)(int index); - uintptr_t (*etyped)(uintptr_t expr, uintptr_t typ); - uintptr_t (*eimplarg)(uintptr_t expr); - uintptr_t (*lint)(int v); - uintptr_t (*lflt)(double v); - uintptr_t (*lstr)(PgfText *v); - uintptr_t (*dtyp)(int n_hypos, PgfTypeHypo *hypos, + virtual uintptr_t eabs(PgfBindType btype, PgfText *name, uintptr_t body)=0; + virtual uintptr_t eapp(uintptr_t fun, uintptr_t arg)=0; + virtual uintptr_t elit(uintptr_t lit)=0; + virtual uintptr_t emeta(PgfMetaId meta)=0; + virtual uintptr_t efun(PgfText *name)=0; + virtual uintptr_t evar(int index)=0; + virtual uintptr_t etyped(uintptr_t expr, uintptr_t typ)=0; + virtual uintptr_t eimplarg(uintptr_t expr)=0; + virtual uintptr_t lint(int v)=0; + virtual uintptr_t lflt(double v)=0; + virtual uintptr_t lstr(PgfText *v)=0; + virtual uintptr_t dtyp(int n_hypos, PgfTypeHypo *hypos, + PgfText *cat, + int n_exprs, uintptr_t *exprs)=0; + virtual void free_ref(uintptr_t x)=0; + virtual void free_me()=0; +}; +#else +typedef struct PgfUnmarshaller PgfUnmarshaller; +typedef struct PgfUnmarshallerVtbl PgfUnmarshallerVtbl; +struct PgfUnmarshallerVtbl { + uintptr_t (*eabs)(PgfUnmarshaller *this, PgfBindType btype, PgfText *name, uintptr_t body); + uintptr_t (*eapp)(PgfUnmarshaller *this, uintptr_t fun, uintptr_t arg); + uintptr_t (*elit)(PgfUnmarshaller *this, uintptr_t lit); + uintptr_t (*emeta)(PgfUnmarshaller *this, PgfMetaId meta); + uintptr_t (*efun)(PgfUnmarshaller *this, PgfText *name); + uintptr_t (*evar)(PgfUnmarshaller *this, int index); + uintptr_t (*etyped)(PgfUnmarshaller *this, uintptr_t expr, uintptr_t typ); + uintptr_t (*eimplarg)(PgfUnmarshaller *this, uintptr_t expr); + uintptr_t (*lint)(PgfUnmarshaller *this, int v); + uintptr_t (*lflt)(PgfUnmarshaller *this, double v); + uintptr_t (*lstr)(PgfUnmarshaller *this, PgfText *v); + uintptr_t (*dtyp)(PgfUnmarshaller *this, + int n_hypos, PgfTypeHypo *hypos, PgfText *cat, int n_exprs, uintptr_t *exprs); - void (*free_ref)(uintptr_t x); - void (*free_me)(PgfUnmarshaller *unmarshaller); + void (*free_ref)(PgfUnmarshaller *this, uintptr_t x); + void (*free_me)(PgfUnmarshaller *this); }; - +struct PgfUnmarshaller { + PgfUnmarshallerVtbl *vtbl; +}; +#endif typedef float prob_t; typedef struct PgfPGF PgfPGF; diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index d085a8e98..df85df005 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -138,147 +138,137 @@ withText s fn = type CBindType = (#type PgfBindType) -type EAbsUnmarshaller = (#type PgfBindType) -> Ptr PgfText -> StablePtr Expr -> IO (StablePtr Expr) +type EAbsFun = Ptr PgfUnmarshaller -> (#type PgfBindType) -> Ptr PgfText -> StablePtr Expr -> IO (StablePtr Expr) foreign import ccall "wrapper" - wrapEAbsUnmarshaller :: EAbsUnmarshaller -> IO (FunPtr EAbsUnmarshaller) + wrapEAbsFun :: EAbsFun -> IO (FunPtr EAbsFun) -type EAppUnmarshaller = StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr) +type EAppFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr) foreign import ccall "wrapper" - wrapEAppUnmarshaller :: EAppUnmarshaller -> IO (FunPtr EAppUnmarshaller) + wrapEAppFun :: EAppFun -> IO (FunPtr EAppFun) -type ELitUnmarshaller = StablePtr Literal -> IO (StablePtr Expr) +type ELitFun = Ptr PgfUnmarshaller -> StablePtr Literal -> IO (StablePtr Expr) foreign import ccall "wrapper" - wrapELitUnmarshaller :: ELitUnmarshaller -> IO (FunPtr ELitUnmarshaller) + wrapELitFun :: ELitFun -> IO (FunPtr ELitFun) -type EMetaUnmarshaller = (#type PgfMetaId) -> IO (StablePtr Expr) +type EMetaFun = Ptr PgfUnmarshaller -> (#type PgfMetaId) -> IO (StablePtr Expr) foreign import ccall "wrapper" - wrapEMetaUnmarshaller :: EMetaUnmarshaller -> IO (FunPtr EMetaUnmarshaller) + wrapEMetaFun :: EMetaFun -> IO (FunPtr EMetaFun) -type EFunUnmarshaller = Ptr PgfText -> IO (StablePtr Expr) +type EFunFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Expr) foreign import ccall "wrapper" - wrapEFunUnmarshaller :: EFunUnmarshaller -> IO (FunPtr EFunUnmarshaller) + wrapEFunFun :: EFunFun -> IO (FunPtr EFunFun) -type EVarUnmarshaller = CInt -> IO (StablePtr Expr) +type EVarFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Expr) foreign import ccall "wrapper" - wrapEVarUnmarshaller :: EVarUnmarshaller -> IO (FunPtr EVarUnmarshaller) + wrapEVarFun :: EVarFun -> IO (FunPtr EVarFun) -type ETypedUnmarshaller = StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr) +type ETypedFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr) foreign import ccall "wrapper" - wrapETypedUnmarshaller :: ETypedUnmarshaller -> IO (FunPtr ETypedUnmarshaller) + wrapETypedFun :: ETypedFun -> IO (FunPtr ETypedFun) -type EImplArgUnmarshaller = StablePtr Expr -> IO (StablePtr Expr) +type EImplArgFun = Ptr PgfUnmarshaller -> StablePtr Expr -> IO (StablePtr Expr) foreign import ccall "wrapper" - wrapEImplArgUnmarshaller :: EImplArgUnmarshaller -> IO (FunPtr EImplArgUnmarshaller) + wrapEImplArgFun :: EImplArgFun -> IO (FunPtr EImplArgFun) -type LIntUnmarshaller = CInt -> IO (StablePtr Literal) +type LIntFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Literal) foreign import ccall "wrapper" - wrapLIntUnmarshaller :: LIntUnmarshaller -> IO (FunPtr LIntUnmarshaller) + wrapLIntFun :: LIntFun -> IO (FunPtr LIntFun) -type LFltUnmarshaller = CDouble -> IO (StablePtr Literal) +type LFltFun = Ptr PgfUnmarshaller -> CDouble -> IO (StablePtr Literal) foreign import ccall "wrapper" - wrapLFltUnmarshaller :: LFltUnmarshaller -> IO (FunPtr LFltUnmarshaller) + wrapLFltFun :: LFltFun -> IO (FunPtr LFltFun) -type LStrUnmarshaller = Ptr PgfText -> IO (StablePtr Literal) +type LStrFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Literal) foreign import ccall "wrapper" - wrapLStrUnmarshaller :: LStrUnmarshaller -> IO (FunPtr LStrUnmarshaller) + wrapLStrFun :: LStrFun -> IO (FunPtr LStrFun) -type TypeUnmarshaller = CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type) +type DTypFun = Ptr PgfUnmarshaller -> CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type) foreign import ccall "wrapper" - wrapTypeUnmarshaller :: TypeUnmarshaller -> IO (FunPtr TypeUnmarshaller) + wrapTypeFun :: DTypFun -> IO (FunPtr DTypFun) -foreign import ccall "&hs_free_stable_ptr" hs_free_stable_ptr :: FunPtr (StablePtr a -> IO ()) +foreign import ccall "&hs_free_reference" hs_free_reference :: FunPtr (Ptr PgfUnmarshaller -> StablePtr a -> IO ()) foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FunPtr (Ptr PgfUnmarshaller -> IO ()) foreign import ccall "hs_free_unmarshaller" freeUnmarshaller :: Ptr PgfUnmarshaller -> IO () mkUnmarshaller = do - eabs <- wrapEAbsUnmarshaller unmarshalEAbs - eapp <- wrapEAppUnmarshaller unmarshalEApp - elit <- wrapELitUnmarshaller unmarshalELit - emeta <- wrapEMetaUnmarshaller unmarshalEMeta - efun <- wrapEFunUnmarshaller unmarshalEFun - evar <- wrapEVarUnmarshaller unmarshalEVar - etyped <- wrapETypedUnmarshaller unmarshalETyped - eimplarg<- wrapEImplArgUnmarshaller unmarshalEImplArg - lint <- wrapLIntUnmarshaller unmarshalLInt - lflt <- wrapLFltUnmarshaller unmarshalLFlt - lstr <- wrapLStrUnmarshaller unmarshalLStr - dtyp <- wrapTypeUnmarshaller unmarshalType + 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 + wrapTypeFun unmarshalType >>= (#poke PgfUnmarshallerVtbl, dtyp) vtbl + (#poke PgfUnmarshallerVtbl, free_ref) vtbl hs_free_reference + (#poke PgfUnmarshallerVtbl, free_me) vtbl hs_free_unmarshaller ptr <- mallocBytes (#size PgfUnmarshaller) - (#poke PgfUnmarshaller, eabs) ptr eabs - (#poke PgfUnmarshaller, eapp) ptr eapp - (#poke PgfUnmarshaller, elit) ptr elit - (#poke PgfUnmarshaller, emeta) ptr emeta - (#poke PgfUnmarshaller, efun) ptr efun - (#poke PgfUnmarshaller, evar) ptr evar - (#poke PgfUnmarshaller, etyped) ptr etyped - (#poke PgfUnmarshaller, eimplarg) ptr eimplarg - (#poke PgfUnmarshaller, lint) ptr lint - (#poke PgfUnmarshaller, lflt) ptr lflt - (#poke PgfUnmarshaller, lstr) ptr lstr - (#poke PgfUnmarshaller, dtyp) ptr dtyp - (#poke PgfUnmarshaller, free_ref) ptr hs_free_stable_ptr - (#poke PgfUnmarshaller, free_me) ptr hs_free_unmarshaller + (#poke PgfUnmarshaller, vtbl) ptr vtbl return ptr where - unmarshalEAbs c_btype c_var c_body = do + 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 c_fun c_arg = do + unmarshalEApp this c_fun c_arg = do fun <- deRefStablePtr c_fun arg <- deRefStablePtr c_arg newStablePtr (EApp fun arg) - unmarshalELit c_lit = do + unmarshalELit this c_lit = do lit <- deRefStablePtr c_lit newStablePtr (ELit lit) - unmarshalEMeta c_metaid = do + unmarshalEMeta this c_metaid = do newStablePtr (EMeta (fromIntegral c_metaid)) - unmarshalEFun c_name = do + unmarshalEFun this c_name = do name <- peekText c_name newStablePtr (EFun name) - unmarshalEVar c_var = do + unmarshalEVar this c_var = do newStablePtr (EVar (fromIntegral c_var)) - unmarshalETyped c_expr c_typ = do + unmarshalETyped this c_expr c_typ = do expr <- deRefStablePtr c_expr typ <- deRefStablePtr c_typ newStablePtr (ETyped expr typ) - unmarshalEImplArg c_expr = do + unmarshalEImplArg this c_expr = do expr <- deRefStablePtr c_expr newStablePtr (EImplArg expr) - unmarshalLInt c_v = do + unmarshalLInt this c_v = do newStablePtr (LInt (fromIntegral c_v)) - unmarshalLFlt c_v = do + unmarshalLFlt this c_v = do newStablePtr (LFlt (realToFrac c_v)) - unmarshalLStr c_v = do + unmarshalLStr this c_v = do s <- peekText c_v newStablePtr (LStr s) - unmarshalType n_hypos hypos c_cat n_exprs exprs = do + unmarshalType this n_hypos hypos c_cat n_exprs exprs = do hypos <- peekHypos n_hypos hypos cat <- peekText c_cat exprs <- peekExprs n_exprs exprs diff --git a/src/runtime/haskell/utils.c b/src/runtime/haskell/utils.c index 858b73782..12ed5dbc8 100644 --- a/src/runtime/haskell/utils.c +++ b/src/runtime/haskell/utils.c @@ -4,17 +4,23 @@ void hs_free_unmarshaller(PgfUnmarshaller *unmarshaller) { - hs_free_fun_ptr((HsFunPtr) unmarshaller->eabs); - hs_free_fun_ptr((HsFunPtr) unmarshaller->eapp); - hs_free_fun_ptr((HsFunPtr) unmarshaller->elit); - hs_free_fun_ptr((HsFunPtr) unmarshaller->emeta); - hs_free_fun_ptr((HsFunPtr) unmarshaller->efun); - hs_free_fun_ptr((HsFunPtr) unmarshaller->evar); - hs_free_fun_ptr((HsFunPtr) unmarshaller->etyped); - hs_free_fun_ptr((HsFunPtr) unmarshaller->eimplarg); - hs_free_fun_ptr((HsFunPtr) unmarshaller->lint); - hs_free_fun_ptr((HsFunPtr) unmarshaller->lflt); - hs_free_fun_ptr((HsFunPtr) unmarshaller->lstr); - hs_free_fun_ptr((HsFunPtr) unmarshaller->dtyp); + 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 *unmarshaller, uintptr_t ref) +{ + hs_free_stable_ptr((HsStablePtr) ref); +}