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

a hopefully better error management in the marshaller

Browse Source
This commit is contained in:
krangelov
2021-08-14 21:13:31 +02:00
parent 8b8028bdfe
commit d28c5a0377
3 changed files with 37 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -135,7 +135,6 @@ 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);
void (*free_ref)(PgfUnmarshaller *this, uintptr_t x);
void (*free_me)(PgfUnmarshaller *this);
};
struct PgfMarshaller {

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

@@ -7,6 +7,7 @@ import Foreign
import Foreign.C
import Foreign.Ptr
import qualified Data.Map as Map
import Control.Exception(bracket,mask_)
import PGF2.Expr
@@ -274,8 +275,8 @@ mkMarshaller = 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
LStr s -> withText s $ \c_s -> do
fun <- (#peek PgfUnmarshallerVtbl, lstr) vtbl
callLStrFun fun u c_s
LInt n -> do fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl
callLIntFun fun u (fromIntegral n)
@@ -286,29 +287,29 @@ mkMarshaller = do
vtbl <- (#peek PgfUnmarshaller, vtbl) u
expr <- deRefStablePtr c_expr
case expr of
EAbs bt var e-> do c_e <- newStablePtr e
EAbs bt var e-> withText var $ \c_var ->
bracket (newStablePtr e) freeStablePtr $ \c_e -> do
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
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 -> do c_lit <- newStablePtr lit
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 -> do fun <- (#peek PgfUnmarshallerVtbl, efun) vtbl
c_name <- newText name
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 -> do c_e <- newStablePtr e
c_ty <- newStablePtr ty
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 -> do c_arg <- newStablePtr arg
EImplArg arg -> bracket (newStablePtr arg) freeStablePtr $ \c_arg -> do
fun <- (#peek PgfUnmarshallerVtbl, eimplarg) vtbl
callEImplArgFun fun u c_arg
@@ -316,18 +317,23 @@ mkMarshaller = 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
DTyp hypos cat es -> let n_hypos = length hypos
in allocaBytes (n_hypos * (#size PgfTypeHypo)) $ \c_hypos ->
withText cat $ \c_cat ->
mask_ $ do
marshalHypos c_hypos hypos
c_es <- mapM newStablePtr es
res <- withArray c_es $ \c_exprs -> do
fun <- (#peek PgfUnmarshallerVtbl, dtyp) vtbl
callDTypFun fun u
(fromIntegral n_hypos)
c_hypos
c_cat
(fromIntegral (length es))
c_exprs
mapM_ freeStablePtr c_es
freeHypos c_hypos n_hypos
return res
where
marshalHypos _ [] = return ()
marshalHypos ptr ((bt,var,ty):hs) = do
@@ -336,6 +342,12 @@ mkMarshaller = do
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)
mkUnmarshaller = do
vtbl <- mallocBytes (#size PgfUnmarshallerVtbl)
wrapEAbsFun unmarshalEAbs >>= (#poke PgfUnmarshallerVtbl, eabs) vtbl

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

@@ -29,7 +29,7 @@ void hs_free_unmarshaller(PgfUnmarshaller *unmarshaller)
free(unmarshaller);
}
void hs_free_reference(void *self, uintptr_t ref)
void hs_free_reference(PgfUnmarshaller *self, uintptr_t ref)
{
hs_free_stable_ptr((HsStablePtr) ref);
}