From 6beac742652e9e8f91d84aa53fecb3a7fec57276 Mon Sep 17 00:00:00 2001 From: krangelov Date: Fri, 13 Aug 2021 19:25:12 +0200 Subject: [PATCH] a draft for the marshaller. still not in use --- src/runtime/c/pgf/pgf.h | 19 +++- src/runtime/haskell/PGF2/FFI.hsc | 176 +++++++++++++++++++++++++++---- 2 files changed, 171 insertions(+), 24 deletions(-) diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 9b16999c4..a66e1315e 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -77,7 +77,6 @@ typedef struct { * a PyObject pointer. */ #ifdef __cplusplus -typedef struct PgfUnmarshaller PgfUnmarshaller; struct PgfUnmarshaller { virtual uintptr_t eabs(PgfBindType btype, PgfText *name, uintptr_t body)=0; virtual uintptr_t eapp(uintptr_t fun, uintptr_t arg)=0; @@ -96,6 +95,12 @@ struct PgfUnmarshaller { virtual void free_ref(uintptr_t x)=0; virtual void free_me()=0; }; + +struct PgfMarshaller { + virtual uintptr_t match_lit(PgfUnmarshaller *u, uintptr_t lit)=0; + virtual uintptr_t match_expr(PgfUnmarshaller *u, uintptr_t expr)=0; + virtual uintptr_t match_type(PgfUnmarshaller *u, uintptr_t *ty)=0; +}; #else typedef struct PgfUnmarshaller PgfUnmarshaller; typedef struct PgfUnmarshallerVtbl PgfUnmarshallerVtbl; @@ -121,7 +126,19 @@ struct PgfUnmarshallerVtbl { struct PgfUnmarshaller { PgfUnmarshallerVtbl *vtbl; }; + +typedef struct PgfMarshaller PgfMarshaller; +typedef struct PgfMarshallerVtbl PgfMarshallerVtbl; +struct PgfMarshallerVtbl { + uintptr_t (*match_lit)(PgfUnmarshaller *u, uintptr_t lit); + uintptr_t (*match_expr)(PgfUnmarshaller *u, uintptr_t expr); + uintptr_t (*match_type)(PgfUnmarshaller *u, uintptr_t *ty); +}; +struct PgfMarshaller { + PgfMarshallerVtbl *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 df85df005..81ddc71d5 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -26,6 +26,7 @@ data PgfItor data PgfPGF data PgfConcr data PgfTypeHypo +data PgfMarshaller data PgfUnmarshaller foreign import ccall unsafe "pgf_utf8_decode" @@ -103,6 +104,15 @@ peekText ptr = cs <- decode pptr end return (((toEnum . fromEnum) x) : cs) +newText :: String -> IO (Ptr PgfText) +newText s = do + ptr <- mallocBytes ((#size PgfText) + size + 1) + (#poke PgfText, size) ptr (fromIntegral size :: CSize) + pokeUtf8CString s (ptr `plusPtr` (#const offsetof(PgfText, text))) + return ptr + where + size = utf8Length s + withText :: String -> (Ptr PgfText -> IO a) -> IO a withText s fn = allocaBytes ((#size PgfText) + size + 1) $ \ptr -> do @@ -112,91 +122,127 @@ withText s fn = where size = utf8Length s - pokeUtf8CString s ptr = - alloca $ \pptr -> - poke pptr ptr >> encode s pptr - where - encode [] pptr = do - pgf_utf8_encode 0 pptr - encode (c:cs) pptr = do - pgf_utf8_encode ((toEnum . fromEnum) c) pptr - encode cs pptr +pokeUtf8CString s ptr = + alloca $ \pptr -> + poke pptr ptr >> encode s pptr + where + encode [] pptr = do + pgf_utf8_encode 0 pptr + encode (c:cs) pptr = do + pgf_utf8_encode ((toEnum . fromEnum) c) pptr + encode cs pptr - utf8Length s = count 0 s +utf8Length s = count 0 s + where + count !c [] = c + count !c (x:xs) + | ucs < 0x80 = count (c+1) xs + | ucs < 0x800 = count (c+2) xs + | ucs < 0x10000 = count (c+3) xs + | ucs < 0x200000 = count (c+4) xs + | ucs < 0x4000000 = count (c+5) xs + | otherwise = count (c+6) xs where - count !c [] = c - count !c (x:xs) - | ucs < 0x80 = count (c+1) xs - | ucs < 0x800 = count (c+2) xs - | ucs < 0x10000 = count (c+3) xs - | ucs < 0x200000 = count (c+4) xs - | ucs < 0x4000000 = count (c+5) xs - | otherwise = count (c+6) xs - where - ucs = fromEnum x + ucs = fromEnum x type CBindType = (#type PgfBindType) type EAbsFun = Ptr PgfUnmarshaller -> (#type PgfBindType) -> Ptr PgfText -> StablePtr Expr -> IO (StablePtr Expr) +foreign import ccall "dynamic" + callEAbsFun :: FunPtr EAbsFun -> EAbsFun + foreign import ccall "wrapper" wrapEAbsFun :: EAbsFun -> IO (FunPtr EAbsFun) type EAppFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr) +foreign import ccall "dynamic" + callEAppFun :: FunPtr EAppFun -> EAppFun + foreign import ccall "wrapper" wrapEAppFun :: EAppFun -> IO (FunPtr EAppFun) type ELitFun = Ptr PgfUnmarshaller -> StablePtr Literal -> IO (StablePtr Expr) +foreign import ccall "dynamic" + callELitFun :: FunPtr ELitFun -> ELitFun + foreign import ccall "wrapper" wrapELitFun :: ELitFun -> IO (FunPtr ELitFun) type EMetaFun = Ptr PgfUnmarshaller -> (#type PgfMetaId) -> IO (StablePtr Expr) +foreign import ccall "dynamic" + callEMetaFun :: FunPtr EMetaFun -> EMetaFun + foreign import ccall "wrapper" wrapEMetaFun :: EMetaFun -> IO (FunPtr EMetaFun) type EFunFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Expr) +foreign import ccall "dynamic" + callEFunFun :: FunPtr EFunFun -> EFunFun + foreign import ccall "wrapper" wrapEFunFun :: EFunFun -> IO (FunPtr EFunFun) type EVarFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Expr) +foreign import ccall "dynamic" + callEVarFun :: FunPtr EVarFun -> EVarFun + foreign import ccall "wrapper" wrapEVarFun :: EVarFun -> IO (FunPtr EVarFun) type ETypedFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr) +foreign import ccall "dynamic" + callETypedFun :: FunPtr ETypedFun -> ETypedFun + foreign import ccall "wrapper" wrapETypedFun :: ETypedFun -> IO (FunPtr ETypedFun) type EImplArgFun = Ptr PgfUnmarshaller -> StablePtr Expr -> IO (StablePtr Expr) +foreign import ccall "dynamic" + callEImplArgFun :: FunPtr EImplArgFun -> EImplArgFun + foreign import ccall "wrapper" wrapEImplArgFun :: EImplArgFun -> IO (FunPtr EImplArgFun) type LIntFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Literal) +foreign import ccall "dynamic" + callLIntFun :: FunPtr LIntFun -> LIntFun + foreign import ccall "wrapper" wrapLIntFun :: LIntFun -> IO (FunPtr LIntFun) type LFltFun = Ptr PgfUnmarshaller -> CDouble -> IO (StablePtr Literal) +foreign import ccall "dynamic" + callLFltFun :: FunPtr LFltFun -> LFltFun + foreign import ccall "wrapper" wrapLFltFun :: LFltFun -> IO (FunPtr LFltFun) type LStrFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Literal) +foreign import ccall "dynamic" + callLStrFun :: FunPtr LStrFun -> LStrFun + foreign import ccall "wrapper" wrapLStrFun :: LStrFun -> IO (FunPtr LStrFun) type DTypFun = Ptr PgfUnmarshaller -> CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type) +foreign import ccall "dynamic" + callDTypFun :: FunPtr DTypFun -> DTypFun + foreign import ccall "wrapper" - wrapTypeFun :: DTypFun -> IO (FunPtr DTypFun) + wrapDTypFun :: DTypFun -> IO (FunPtr DTypFun) foreign import ccall "&hs_free_reference" hs_free_reference :: FunPtr (Ptr PgfUnmarshaller -> StablePtr a -> IO ()) @@ -204,6 +250,86 @@ foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FunPtr (Ptr foreign import ccall "hs_free_unmarshaller" freeUnmarshaller :: Ptr PgfUnmarshaller -> IO () +type MatchFun a = Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr a -> IO (StablePtr a) + +foreign import ccall "wrapper" + wrapMatchFun :: MatchFun a -> IO (FunPtr (MatchFun a)) + +mkMarshaller = 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 + return ptr + where + matchLit this u c_lit = do + vtbl <- (#peek PgfUnmarshaller, vtbl) u + lit <- deRefStablePtr c_lit + case lit of + LStr s -> do fun <- (#peek PgfUnmarshallerVtbl, lstr) vtbl + c_s <- newText s + callLStrFun fun u c_s + LInt n -> do fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl + callLIntFun fun u (fromIntegral n) + LFlt d -> do fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl + callLFltFun fun u (realToFrac d) + + matchExpr this u c_expr = do + vtbl <- (#peek PgfUnmarshaller, vtbl) u + expr <- deRefStablePtr c_expr + case expr of + EAbs bt var e-> do c_e <- newStablePtr e + fun <- (#peek PgfUnmarshallerVtbl, eabs) vtbl + c_var <- newText var + callEAbsFun fun u (marshalBindType bt) c_var c_e + EApp fun arg -> do c_fun <- newStablePtr fun + c_arg <- newStablePtr arg + fun <- (#peek PgfUnmarshallerVtbl, eapp) vtbl + callEAppFun fun u c_fun c_arg + ELit lit -> do c_lit <- newStablePtr lit + 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 -> do fun <- (#peek PgfUnmarshallerVtbl, efun) vtbl + c_name <- newText name + callEFunFun fun u c_name + EVar index -> do fun <- (#peek PgfUnmarshallerVtbl, evar) vtbl + callEVarFun fun u (fromIntegral index) + ETyped e ty -> do c_e <- newStablePtr e + c_ty <- newStablePtr ty + fun <- (#peek PgfUnmarshallerVtbl, etyped) vtbl + callETypedFun fun u c_e c_ty + EImplArg arg -> do c_arg <- newStablePtr arg + fun <- (#peek PgfUnmarshallerVtbl, eimplarg) vtbl + callEImplArgFun fun u c_arg + + matchType this u c_ty = do + vtbl <- (#peek PgfUnmarshaller, vtbl) u + ty <- deRefStablePtr c_ty + case ty of + DTyp hypos cat es -> do fun <- (#peek PgfUnmarshallerVtbl, dtyp) vtbl + let n_hypos = length hypos + c_hypos <- mallocBytes (n_hypos * (#size PgfTypeHypo)) + marshalHypos c_hypos hypos + c_cat <- newText cat + c_es <- mapM newStablePtr es >>= newArray + callDTypFun fun u + (fromIntegral n_hypos) + c_hypos + c_cat + (fromIntegral (length es)) + c_es + 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 + mkUnmarshaller = do vtbl <- mallocBytes (#size PgfUnmarshallerVtbl) wrapEAbsFun unmarshalEAbs >>= (#poke PgfUnmarshallerVtbl, eabs) vtbl @@ -217,7 +343,7 @@ mkUnmarshaller = do wrapLIntFun unmarshalLInt >>= (#poke PgfUnmarshallerVtbl, lint) vtbl wrapLFltFun unmarshalLFlt >>= (#poke PgfUnmarshallerVtbl, lflt) vtbl wrapLStrFun unmarshalLStr >>= (#poke PgfUnmarshallerVtbl, lstr) vtbl - wrapTypeFun unmarshalType >>= (#poke PgfUnmarshallerVtbl, dtyp) vtbl + wrapDTypFun unmarshalDTyp >>= (#poke PgfUnmarshallerVtbl, dtyp) vtbl (#poke PgfUnmarshallerVtbl, free_ref) vtbl hs_free_reference (#poke PgfUnmarshallerVtbl, free_me) vtbl hs_free_unmarshaller ptr <- mallocBytes (#size PgfUnmarshaller) @@ -268,7 +394,7 @@ mkUnmarshaller = do s <- peekText c_v newStablePtr (LStr s) - unmarshalType this n_hypos hypos c_cat n_exprs exprs = do + 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 @@ -289,6 +415,10 @@ mkUnmarshaller = do return (e:es) +marshalBindType :: BindType -> (#type PgfBindType) +marshalBindType Explicit = (#const PGF_BIND_TYPE_EXPLICIT) +marshalBindType Implicit = (#const PGF_BIND_TYPE_IMPLICIT) + unmarshalBindType :: (#type PgfBindType) -> BindType unmarshalBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit unmarshalBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit