From d28c5a03774fe72c2d5fc1d4224eea172c0a1d45 Mon Sep 17 00:00:00 2001 From: krangelov Date: Sat, 14 Aug 2021 21:13:31 +0200 Subject: [PATCH] a hopefully better error management in the marshaller --- src/runtime/c/pgf/pgf.h | 1 - src/runtime/haskell/PGF2/FFI.hsc | 60 +++++++++++++++++++------------- src/runtime/haskell/utils.c | 2 +- 3 files changed, 37 insertions(+), 26 deletions(-) diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 5948b0f57..2ae50e3b4 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -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 { diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 1f22b9946..55c445764 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -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 diff --git a/src/runtime/haskell/utils.c b/src/runtime/haskell/utils.c index cf1065fb9..ada1be3cf 100644 --- a/src/runtime/haskell/utils.c +++ b/src/runtime/haskell/utils.c @@ -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); }