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

PgfUnmarshaller now mimics a C++ class. Allows for keeping state

Browse Source
This commit is contained in:
krangelov
2021-08-13 18:14:56 +02:00
parent 08bcd2f0b5
commit 221f0b7853
4 changed files with 113 additions and 91 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/runtime/c/pgf/data.h
View File

@@ -125,7 +125,7 @@ struct PgfPGF : DB {
{ u = unmarshaller; }; { u = unmarshaller; };
PGF_INTERNAL_DECL ~PgfPGF() PGF_INTERNAL_DECL ~PgfPGF()
{ u->free_me(u); }; { u->free_me(); };
PgfUnmarshaller *u; PgfUnmarshaller *u;
}; };

56
src/runtime/c/pgf/pgf.h
View File

@@ -76,26 +76,52 @@ typedef struct {
* actually be a stable pointer, while for Python that would be * actually be a stable pointer, while for Python that would be
* a PyObject pointer. * a PyObject pointer.
*/ */
#ifdef __cplusplus
typedef struct PgfUnmarshaller PgfUnmarshaller; typedef struct PgfUnmarshaller PgfUnmarshaller;
struct PgfUnmarshaller { struct PgfUnmarshaller {
uintptr_t (*eabs)(PgfBindType btype, PgfText *name, uintptr_t body); virtual uintptr_t eabs(PgfBindType btype, PgfText *name, uintptr_t body)=0;
uintptr_t (*eapp)(uintptr_t fun, uintptr_t arg); virtual uintptr_t eapp(uintptr_t fun, uintptr_t arg)=0;
uintptr_t (*elit)(uintptr_t lit); virtual uintptr_t elit(uintptr_t lit)=0;
uintptr_t (*emeta)(PgfMetaId meta); virtual uintptr_t emeta(PgfMetaId meta)=0;
uintptr_t (*efun)(PgfText *name); virtual uintptr_t efun(PgfText *name)=0;
uintptr_t (*evar)(int index); virtual uintptr_t evar(int index)=0;
uintptr_t (*etyped)(uintptr_t expr, uintptr_t typ); virtual uintptr_t etyped(uintptr_t expr, uintptr_t typ)=0;
uintptr_t (*eimplarg)(uintptr_t expr); virtual uintptr_t eimplarg(uintptr_t expr)=0;
uintptr_t (*lint)(int v); virtual uintptr_t lint(int v)=0;
uintptr_t (*lflt)(double v); virtual uintptr_t lflt(double v)=0;
uintptr_t (*lstr)(PgfText *v); virtual uintptr_t lstr(PgfText *v)=0;
uintptr_t (*dtyp)(int n_hypos, PgfTypeHypo *hypos, 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, PgfText *cat,
int n_exprs, uintptr_t *exprs); int n_exprs, uintptr_t *exprs);
void (*free_ref)(uintptr_t x); void (*free_ref)(PgfUnmarshaller *this, uintptr_t x);
void (*free_me)(PgfUnmarshaller *unmarshaller); void (*free_me)(PgfUnmarshaller *this);
}; };
struct PgfUnmarshaller {
PgfUnmarshallerVtbl *vtbl;
};
#endif
typedef float prob_t; typedef float prob_t;
typedef struct PgfPGF PgfPGF; typedef struct PgfPGF PgfPGF;

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

@@ -138,147 +138,137 @@ withText s fn =
type CBindType = (#type PgfBindType) 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" 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" 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" 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" 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" 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" 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" 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" 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" 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" 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" 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" 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" hs_free_unmarshaller :: FunPtr (Ptr PgfUnmarshaller -> IO ())
foreign import ccall "hs_free_unmarshaller" freeUnmarshaller :: Ptr PgfUnmarshaller -> IO () foreign import ccall "hs_free_unmarshaller" freeUnmarshaller :: Ptr PgfUnmarshaller -> IO ()
mkUnmarshaller = do mkUnmarshaller = do
eabs <- wrapEAbsUnmarshaller unmarshalEAbs vtbl <- mallocBytes (#size PgfUnmarshallerVtbl)
eapp <- wrapEAppUnmarshaller unmarshalEApp wrapEAbsFun unmarshalEAbs >>= (#poke PgfUnmarshallerVtbl, eabs) vtbl
elit <- wrapELitUnmarshaller unmarshalELit wrapEAppFun unmarshalEApp >>= (#poke PgfUnmarshallerVtbl, eapp) vtbl
emeta <- wrapEMetaUnmarshaller unmarshalEMeta wrapELitFun unmarshalELit >>= (#poke PgfUnmarshallerVtbl, elit) vtbl
efun <- wrapEFunUnmarshaller unmarshalEFun wrapEMetaFun unmarshalEMeta >>= (#poke PgfUnmarshallerVtbl, emeta) vtbl
evar <- wrapEVarUnmarshaller unmarshalEVar wrapEFunFun unmarshalEFun >>= (#poke PgfUnmarshallerVtbl, efun) vtbl
etyped <- wrapETypedUnmarshaller unmarshalETyped wrapEVarFun unmarshalEVar >>= (#poke PgfUnmarshallerVtbl, evar) vtbl
eimplarg<- wrapEImplArgUnmarshaller unmarshalEImplArg wrapETypedFun unmarshalETyped >>= (#poke PgfUnmarshallerVtbl, etyped) vtbl
lint <- wrapLIntUnmarshaller unmarshalLInt wrapEImplArgFun unmarshalEImplArg >>= (#poke PgfUnmarshallerVtbl, eimplarg) vtbl
lflt <- wrapLFltUnmarshaller unmarshalLFlt wrapLIntFun unmarshalLInt >>= (#poke PgfUnmarshallerVtbl, lint) vtbl
lstr <- wrapLStrUnmarshaller unmarshalLStr wrapLFltFun unmarshalLFlt >>= (#poke PgfUnmarshallerVtbl, lflt) vtbl
dtyp <- wrapTypeUnmarshaller unmarshalType 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) ptr <- mallocBytes (#size PgfUnmarshaller)
(#poke PgfUnmarshaller, eabs) ptr eabs (#poke PgfUnmarshaller, vtbl) ptr vtbl
(#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
return ptr return ptr
where where
unmarshalEAbs c_btype c_var c_body = do unmarshalEAbs this c_btype c_var c_body = do
let btype = unmarshalBindType c_btype let btype = unmarshalBindType c_btype
var <- peekText c_var var <- peekText c_var
body <- deRefStablePtr c_body body <- deRefStablePtr c_body
newStablePtr (EAbs btype var body) newStablePtr (EAbs btype var body)
unmarshalEApp c_fun c_arg = do unmarshalEApp this c_fun c_arg = do
fun <- deRefStablePtr c_fun fun <- deRefStablePtr c_fun
arg <- deRefStablePtr c_arg arg <- deRefStablePtr c_arg
newStablePtr (EApp fun arg) newStablePtr (EApp fun arg)
unmarshalELit c_lit = do unmarshalELit this c_lit = do
lit <- deRefStablePtr c_lit lit <- deRefStablePtr c_lit
newStablePtr (ELit lit) newStablePtr (ELit lit)
unmarshalEMeta c_metaid = do unmarshalEMeta this c_metaid = do
newStablePtr (EMeta (fromIntegral c_metaid)) newStablePtr (EMeta (fromIntegral c_metaid))
unmarshalEFun c_name = do unmarshalEFun this c_name = do
name <- peekText c_name name <- peekText c_name
newStablePtr (EFun name) newStablePtr (EFun name)
unmarshalEVar c_var = do unmarshalEVar this c_var = do
newStablePtr (EVar (fromIntegral c_var)) newStablePtr (EVar (fromIntegral c_var))
unmarshalETyped c_expr c_typ = do unmarshalETyped this c_expr c_typ = do
expr <- deRefStablePtr c_expr expr <- deRefStablePtr c_expr
typ <- deRefStablePtr c_typ typ <- deRefStablePtr c_typ
newStablePtr (ETyped expr typ) newStablePtr (ETyped expr typ)
unmarshalEImplArg c_expr = do unmarshalEImplArg this c_expr = do
expr <- deRefStablePtr c_expr expr <- deRefStablePtr c_expr
newStablePtr (EImplArg expr) newStablePtr (EImplArg expr)
unmarshalLInt c_v = do unmarshalLInt this c_v = do
newStablePtr (LInt (fromIntegral c_v)) newStablePtr (LInt (fromIntegral c_v))
unmarshalLFlt c_v = do unmarshalLFlt this c_v = do
newStablePtr (LFlt (realToFrac c_v)) newStablePtr (LFlt (realToFrac c_v))
unmarshalLStr c_v = do unmarshalLStr this c_v = do
s <- peekText c_v s <- peekText c_v
newStablePtr (LStr s) 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 hypos <- peekHypos n_hypos hypos
cat <- peekText c_cat cat <- peekText c_cat
exprs <- peekExprs n_exprs exprs exprs <- peekExprs n_exprs exprs

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

@@ -4,17 +4,23 @@
void hs_free_unmarshaller(PgfUnmarshaller *unmarshaller) void hs_free_unmarshaller(PgfUnmarshaller *unmarshaller)
{ {
hs_free_fun_ptr((HsFunPtr) unmarshaller->eabs); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->eabs);
hs_free_fun_ptr((HsFunPtr) unmarshaller->eapp); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->eapp);
hs_free_fun_ptr((HsFunPtr) unmarshaller->elit); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->elit);
hs_free_fun_ptr((HsFunPtr) unmarshaller->emeta); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->emeta);
hs_free_fun_ptr((HsFunPtr) unmarshaller->efun); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->efun);
hs_free_fun_ptr((HsFunPtr) unmarshaller->evar); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->evar);
hs_free_fun_ptr((HsFunPtr) unmarshaller->etyped); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->etyped);
hs_free_fun_ptr((HsFunPtr) unmarshaller->eimplarg); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->eimplarg);
hs_free_fun_ptr((HsFunPtr) unmarshaller->lint); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->lint);
hs_free_fun_ptr((HsFunPtr) unmarshaller->lflt); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->lflt);
hs_free_fun_ptr((HsFunPtr) unmarshaller->lstr); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->lstr);
hs_free_fun_ptr((HsFunPtr) unmarshaller->dtyp); hs_free_fun_ptr((HsFunPtr) unmarshaller->vtbl->dtyp);
free(unmarshaller->vtbl);
free(unmarshaller); free(unmarshaller);
} }
void hs_free_reference(PgfUnmarshaller *unmarshaller, uintptr_t ref)
{
hs_free_stable_ptr((HsStablePtr) ref);
}