From 83d21f4e02b0af7bc803b19475a0fd278275a4e6 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Sun, 27 Aug 2023 19:19:45 -0700 Subject: [PATCH] upgrade template TH code generation with FFISafety --- fficxx-multipkg-test/template-dep/Gen.hs | 6 +-- fficxx-multipkg-test/template-member/Gen.hs | 32 +++++++------ fficxx-multipkg-test/template-toplevel/Gen.hs | 14 +++--- .../src/FFICXX/Runtime/Function/TH.hs | 10 ++-- fficxx-runtime/src/FFICXX/Runtime/TH.hs | 18 +++---- fficxx-runtime/src/FFICXX/Runtime/Types.hs | 4 +- fficxx/src/FFICXX/Generate/Code/HsEnum.hs | 4 +- fficxx/src/FFICXX/Generate/Code/HsFFI.hs | 10 ++-- .../FFICXX/Generate/Code/HsImplementation.hs | 15 ++++-- fficxx/src/FFICXX/Generate/Code/HsTH.hs | 17 +++++-- fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs | 11 ++++- fficxx/src/FFICXX/Generate/Code/Primitive.hs | 16 ++++--- fficxx/src/FFICXX/Generate/ContentMaker.hs | 9 ++-- fficxx/src/FFICXX/Generate/Type/Class.hs | 31 +++++++----- stdcxx-gen/Gen.hs | 48 +++++++++---------- 15 files changed, 138 insertions(+), 107 deletions(-) diff --git a/fficxx-multipkg-test/template-dep/Gen.hs b/fficxx-multipkg-test/template-dep/Gen.hs index 73ef83a2..81bf3e6f 100644 --- a/fficxx-multipkg-test/template-dep/Gen.hs +++ b/fficxx-multipkg-test/template-dep/Gen.hs @@ -58,7 +58,7 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.FilePath (()) @@ -105,7 +105,7 @@ tT1 cabal = tfun_new_alias = Nothing }, TFun - { tfun_safety = Unsafe, + { tfun_safety = FFIUnsafe, tfun_ret = Void, tfun_name = "method", tfun_oname = "method", @@ -128,7 +128,7 @@ tT2 cabal = tfun_new_alias = Nothing }, TFun - { tfun_safety = Unsafe, + { tfun_safety = FFIUnsafe, tfun_ret = Void, tfun_name = "callT1", tfun_oname = "callT1", diff --git a/fficxx-multipkg-test/template-member/Gen.hs b/fficxx-multipkg-test/template-member/Gen.hs index dc0a1642..2078fe81 100644 --- a/fficxx-multipkg-test/template-member/Gen.hs +++ b/fficxx-multipkg-test/template-member/Gen.hs @@ -58,7 +58,7 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.FilePath (()) @@ -110,9 +110,9 @@ string = mempty (Just (ClassAlias {caHaskellName = "CppString", caFFIName = "string"})) [ Constructor [cstring "p"] Nothing, - NonVirtual Unsafe cstring_ "c_str" [] Nothing, - NonVirtual Unsafe (cppclassref_ string) "append" [cppclassref string "str"] Nothing, - NonVirtual Unsafe (cppclassref_ string) "erase" [] Nothing + NonVirtual FFIUnsafe cstring_ "c_str" [] Nothing, + NonVirtual FFIUnsafe (cppclassref_ string) "append" [cppclassref string "str"] Nothing, + NonVirtual FFIUnsafe (cppclassref_ string) "erase" [] Nothing ] [] [] @@ -126,10 +126,10 @@ t_vector = (FormSimple "std::vector") ["tp1"] [ TFunNew [] Nothing, - TFun Unsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], - TFun Unsafe void_ "pop_back" "pop_back" [], - TFun Unsafe (TemplateParam "tp1") "at" "at" [int "n"], - TFun Unsafe int_ "size" "size" [], + TFun FFIUnsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], + TFun FFIUnsafe void_ "pop_back" "pop_back" [], + TFun FFIUnsafe (TemplateParam "tp1") "at" "at" [int "n"], + TFun FFIUnsafe int_ "size" "size" [], TFunDelete ] [] @@ -143,9 +143,9 @@ t_unique_ptr = ["tp1"] [ TFunNew [] (Just "newUniquePtr0"), TFunNew [Arg (TemplateParamPointer "tp1") "p"] Nothing, - TFun Unsafe (TemplateParamPointer "tp1") "get" "get" [], - TFun Unsafe (TemplateParamPointer "tp1") "release" "release" [], - TFun Unsafe void_ "reset" "reset" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "get" "get" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "release" "release" [], + TFun FFIUnsafe void_ "reset" "reset" [], TFunDelete ] [] @@ -191,14 +191,16 @@ classA cabal = class_vars = [], class_tmpl_funcs = [ TemplateMemberFunction - { tmf_params = ["tp1"], + { tmf_safety = FFIUnsafe, + tmf_params = ["tp1"], tmf_ret = void_, tmf_name = "method", tmf_args = [Arg (TemplateParamPointer "tp1") "x"], tmf_alias = Nothing }, TemplateMemberFunction - { tmf_params = ["tp1"], + { tmf_safety = FFIUnsafe, + tmf_params = ["tp1"], tmf_ret = void_, tmf_name = "method2", tmf_args = @@ -228,7 +230,7 @@ classT1 cabal = class_alias = Nothing, class_funcs = [ Constructor [] Nothing, - NonVirtual Unsafe void_ "print" [] Nothing + NonVirtual FFIUnsafe void_ "print" [] Nothing ], class_vars = [], class_tmpl_funcs = [], @@ -245,7 +247,7 @@ classT2 cabal = class_alias = Nothing, class_funcs = [ Constructor [] Nothing, - NonVirtual Unsafe void_ "print" [] Nothing + NonVirtual FFIUnsafe void_ "print" [] Nothing ], class_vars = [], class_tmpl_funcs = [], diff --git a/fficxx-multipkg-test/template-toplevel/Gen.hs b/fficxx-multipkg-test/template-toplevel/Gen.hs index 8e15288a..fe8b74a2 100644 --- a/fficxx-multipkg-test/template-toplevel/Gen.hs +++ b/fficxx-multipkg-test/template-toplevel/Gen.hs @@ -58,7 +58,7 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.FilePath (()) @@ -112,10 +112,10 @@ t_vector = (FormSimple "std::vector") ["tp1"] [ TFunNew [] Nothing, - TFun Unsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], - TFun Unsafe void_ "pop_back" "pop_back" [], - TFun Unsafe (TemplateParam "tp1") "at" "at" [int "n"], - TFun Unsafe int_ "size" "size" [], + TFun FFIUnsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], + TFun FFIUnsafe void_ "pop_back" "pop_back" [], + TFun FFIUnsafe (TemplateParam "tp1") "at" "at" [int "n"], + TFun FFIUnsafe int_ "size" "size" [], TFunDelete ] [] @@ -156,7 +156,7 @@ toplevels :: [TopLevel] toplevels = [ TLOrdinary TopLevelFunction - { toplevelfunc_safety = Unsafe, + { toplevelfunc_safety = FFIUnsafe, toplevelfunc_ret = Void, toplevelfunc_name = "ordinary", toplevelfunc_args = [], @@ -164,7 +164,7 @@ toplevels = }, TLTemplate ( TopLevelTemplateFunction - { topleveltfunc_safety = Unsafe, + { topleveltfunc_safety = FFIUnsafe, topleveltfunc_params = ["t1"], topleveltfunc_ret = TemplateAppMove (TemplateAppInfo t_vector [TArg_TypeParam "t1"] "std::vector"), diff --git a/fficxx-runtime/src/FFICXX/Runtime/Function/TH.hs b/fficxx-runtime/src/FFICXX/Runtime/Function/TH.hs index 149e6626..e331799f 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/Function/TH.hs +++ b/fficxx-runtime/src/FFICXX/Runtime/Function/TH.hs @@ -16,7 +16,7 @@ import FFICXX.Runtime.TH mkNew, mkTFunc, ) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import Foreign.Ptr (FunPtr) import Language.Haskell.TH (forImpD, safe) import Language.Haskell.TH.Syntax @@ -47,13 +47,13 @@ mkWrapper (typ, suffix) = t_newFunction :: Type -> String -> Q Exp t_newFunction typ suffix = - mkTFunc Unsafe (typ, suffix, \n -> "Function_new_" <> n, tyf) + mkTFunc FFIUnsafe (typ, suffix, \n -> "Function_new_" <> n, tyf) where tyf _n = let t = pure typ in [t|FunPtr $(t) -> IO (Function $(t))|] -t_call :: Safety -> Type -> String -> Q Exp +t_call :: FFISafety -> Type -> String -> Q Exp t_call safety typ suffix = mkTFunc safety (typ, suffix, \n -> "Function_call_" <> n, tyf) where @@ -63,7 +63,7 @@ t_call safety typ suffix = t_deleteFunction :: Type -> String -> Q Exp t_deleteFunction typ suffix = - mkTFunc Unsafe (typ, suffix, \n -> "Function_delete_" <> n, tyf) + mkTFunc FFIUnsafe (typ, suffix, \n -> "Function_delete_" <> n, tyf) where tyf _n = let t = pure typ @@ -76,7 +76,7 @@ genFunctionInstanceFor qtyp param = typ <- qtyp f1 <- mkNew "newFunction" t_newFunction typ suffix -- TODO: handle safety correctly - f2 <- mkMember Unsafe "call" t_call typ suffix + f2 <- mkMember "call" (t_call FFIUnsafe) typ suffix f3 <- mkDelete "deleteFunction" t_deleteFunction typ suffix wrap <- mkWrapper (typ, suffix) addModFinalizer diff --git a/fficxx-runtime/src/FFICXX/Runtime/TH.hs b/fficxx-runtime/src/FFICXX/Runtime/TH.hs index 9bf7c31b..c86aef8a 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/TH.hs +++ b/fficxx-runtime/src/FFICXX/Runtime/TH.hs @@ -3,7 +3,7 @@ module FFICXX.Runtime.TH where import FFICXX.Runtime.CodeGen.Cxx (HeaderName, Namespace) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import Language.Haskell.TH (forImpD, interruptible, safe, unsafe, varE) import Language.Haskell.TH.Syntax ( Body (NormalB), @@ -54,7 +54,7 @@ con = ConT . mkNameS mkInstance :: Cxt -> Type -> [Dec] -> Dec mkInstance = InstanceD Nothing -mkTFunc :: Safety -> (types, String, String -> String, types -> Q Type) -> Q Exp +mkTFunc :: FFISafety -> (types, String, String -> String, types -> Q Type) -> Q Exp mkTFunc safety (typs, suffix, nf, tyf) = do let fn = nf suffix @@ -62,17 +62,17 @@ mkTFunc safety (typs, suffix, nf, tyf) = n <- newName fn' let safety_modifier = case safety of - Unsafe -> unsafe - Safe -> safe - Interruptible -> interruptible + FFIUnsafe -> unsafe + FFISafe -> safe + FFIInterruptible -> interruptible d <- forImpD CCall safety_modifier fn n (tyf typs) addTopDecls [d] [|$(varE n)|] -mkMember :: Safety -> String -> (Safety -> types -> String -> Q Exp) -> types -> String -> Q Dec -mkMember safety fname f typ suffix = do +mkMember :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec +mkMember fname f typ suffix = do let x = mkNameS "x" - e <- f safety typ suffix + e <- f typ suffix pure $ FunD (mkNameS fname) [Clause [VarP x] (NormalB (AppE e (VarE x))) []] @@ -85,7 +85,7 @@ mkNew fname f typ suffix = do [Clause [] (NormalB e) []] mkDelete :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec -mkDelete fname f = mkMember Unsafe fname (const f) +mkDelete = mkMember mkFunc :: String -> (types -> String -> Q Exp) -> types -> String -> Q Dec mkFunc fname f typ suffix = do diff --git a/fficxx-runtime/src/FFICXX/Runtime/Types.hs b/fficxx-runtime/src/FFICXX/Runtime/Types.hs index 5722ab76..eacff8df 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/Types.hs +++ b/fficxx-runtime/src/FFICXX/Runtime/Types.hs @@ -1,7 +1,7 @@ module FFICXX.Runtime.Types - ( Safety (..), + ( FFISafety (..), ) where -data Safety = Unsafe | Safe | Interruptible +data FFISafety = FFIUnsafe | FFISafe | FFIInterruptible deriving (Show) diff --git a/fficxx/src/FFICXX/Generate/Code/HsEnum.hs b/fficxx/src/FFICXX/Generate/Code/HsEnum.hs index 2a5e1b1d..3eaa690b 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsEnum.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsEnum.hs @@ -4,12 +4,10 @@ module FFICXX.Generate.Code.HsEnum ) where -import Control.Monad.Reader (Reader) import FFICXX.Generate.Name ( enumDataConstructorNames, enumDataTypeName, ) -import FFICXX.Generate.Type.Annotate (AnnotateMap) import FFICXX.Generate.Type.Class (EnumType (..)) import FFICXX.Generate.Util.GHCExactPrint ( DeclGroup, @@ -31,7 +29,7 @@ import FFICXX.Generate.Util.GHCExactPrint import GHC.Hs (GhcPs) import GHC.Parser.Annotation (DeltaPos (..)) import Language.Haskell.Syntax - ( HsDecl (DocD, TyClD), + ( HsDecl (TyClD), HsLocalBindsLR (..), noExtField, ) diff --git a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs index 0904c16b..d21ded53 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs @@ -30,7 +30,7 @@ import FFICXX.Generate.Type.Class Selfness (NoSelf, Self), TLOrdinary (..), Variable (unVariable), - getSafety, + getFunSafety, isAbstractClass, isNewFunc, isStaticFunc, @@ -47,7 +47,7 @@ import FFICXX.Generate.Util.GHCExactPrint mkImport, ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) -import FFICXX.Runtime.Types (Safety (Unsafe)) +import FFICXX.Runtime.Types (FFISafety (FFIUnsafe)) import GHC.Hs (GhcPs) import Language.Haskell.Syntax ( ForeignDecl, @@ -81,7 +81,7 @@ hsFFIClassFunc headerfilename c f = then Nothing else let hfile = unHdrName headerfilename - safety = getSafety f + safety = getFunSafety f -- TODO: Make this a separate function cname = ffiClassName c <> "_" <> aliasedFuncName c f csig = CFunSig (genericFuncArgs f) (genericFuncRet f) @@ -99,7 +99,7 @@ hsFFIAccessor c v a = hsFFIFunType (Just (Self, c)) (accessorCFunSig (arg_type (unVariable v)) a) - in mkForImpCcall (toGHCSafety Unsafe) cname (hscAccessorName c v a) typ + in mkForImpCcall (toGHCSafety FFIUnsafe) cname (hscAccessorName c v a) typ -- import for FFI genImportInFFI :: ClassModule -> [ImportDecl GhcPs] @@ -122,7 +122,7 @@ genTopLevelFFI header tfn = toplevelfunc_ret ) TopLevelVariable {..} -> - ( Unsafe, + ( FFIUnsafe, fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret diff --git a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs index 0e536146..651abe87 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs @@ -94,6 +94,7 @@ import FFICXX.Generate.Util.GHCExactPrint ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.Types (FFISafety (..)) import GHC.Hs (GhcPs) import Language.Haskell.Syntax (HsDecl, ImportDecl) @@ -186,12 +187,18 @@ genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs bstmts | otherwise = [pTuple (fmap p tvars)] lit' = strE (hsTemplateMemberFunctionName c f <> "_") lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") + safety = + case tmf_safety f of + FFIUnsafe -> "FFIUnsafe" + FFISafe -> "FFISafe" + FFIInterruptible -> "FFIInterruptible" rhs = app (v "mkTFunc") $ - let typs - | nparams == 1 = fmap v tvars - | otherwise = [tupleE (map v tvars)] - in tupleE (typs ++ [v "suffix", lam, v "tyf"]) + app (v safety) $ + let typs + | nparams == 1 = fmap v tvars + | otherwise = [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = functionSignatureTMF c f tassgns = fmap diff --git a/fficxx/src/FFICXX/Generate/Code/HsTH.hs b/fficxx/src/FFICXX/Generate/Code/HsTH.hs index 71c47075..61d35e24 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTH.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTH.hs @@ -34,6 +34,7 @@ import FFICXX.Generate.Type.Class TemplateFunction (..), Types (Void), Variable (..), + getTFunSafety, ) import FFICXX.Generate.Type.Module ( TemplateClassImportHeader (..), @@ -78,7 +79,7 @@ import FFICXX.Generate.Util.GHCExactPrint import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import GHC.Hs (GhcPs) import Language.Haskell.Syntax ( HsDecl, @@ -112,10 +113,16 @@ genTmplImplementation t = nc = ffiTmplFuncName f lit' = strE (prefix <> "_" <> nc) lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") + safety = + case getTFunSafety f of + FFIUnsafe -> "FFIUnsafe" + FFISafe -> "FFISafe" + FFIInterruptible -> "FFIInterruptible" rhs = app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] - in tupleE (typs ++ [v "suffix", lam, v "tyf"]) + app (v safety) $ + let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = functionSignatureTT t f tassgns = fmap @@ -222,7 +229,7 @@ genTmplInstance tcih = let Variable (Arg {..}) = vf f_g = TFun - { tfun_safety = Unsafe, + { tfun_safety = FFIUnsafe, tfun_ret = arg_type, tfun_name = tmplAccessorName vf Getter, tfun_oname = tmplAccessorName vf Getter, @@ -230,7 +237,7 @@ genTmplInstance tcih = } f_s = TFun - { tfun_safety = Unsafe, + { tfun_safety = FFIUnsafe, tfun_ret = Void, tfun_name = tmplAccessorName vf Setter, tfun_oname = tmplAccessorName vf Setter, diff --git a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs index 91607e61..4a79059f 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTopLevel.hs @@ -118,6 +118,7 @@ import FFICXX.Generate.Util.GHCExactPrint import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import FFICXX.Runtime.Types (FFISafety (..)) import GHC.Hs (GhcPs) import Language.Haskell.Syntax ( HsDecl (TyClD), @@ -272,10 +273,16 @@ genTLTemplateImplementation t = nc = topleveltfunc_name t lit' = strE (prefix <> "_" <> nc) lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n") + safety = + case topleveltfunc_safety t of + FFIUnsafe -> "FFIUnsafe" + FFISafe -> "FFISafe" + FFIInterruptible -> "FFIInterruptible" rhs = app (v "mkTFunc") $ - let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] - in tupleE (typs ++ [v "suffix", lam, v "tyf"]) + app (v safety) $ + let typs = if nparams == 1 then map v tvars else [tupleE (map v tvars)] + in tupleE (typs ++ [v "suffix", lam, v "tyf"]) sig' = let e = error "genTLTemplateImplementation" spls = map (tySplice . parenSplice . mkVar) $ topleveltfunc_params t diff --git a/fficxx/src/FFICXX/Generate/Code/Primitive.hs b/fficxx/src/FFICXX/Generate/Code/Primitive.hs index 751d678f..ce9855c6 100644 --- a/fficxx/src/FFICXX/Generate/Code/Primitive.hs +++ b/fficxx/src/FFICXX/Generate/Code/Primitive.hs @@ -39,7 +39,7 @@ import FFICXX.Generate.Type.Class import qualified FFICXX.Generate.Util.GHCExactPrint as Ex import qualified FFICXX.Runtime.CodeGen.Cxx as R import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import GHC.Hs (GhcPs) import qualified GHC.Types.ForeignCall as GHC (Safety (..)) import Language.Haskell.Syntax @@ -47,10 +47,10 @@ import Language.Haskell.Syntax HsType, ) -toGHCSafety :: Safety -> GHC.Safety -toGHCSafety Unsafe = GHC.PlayRisky -toGHCSafety Safe = GHC.PlaySafe -toGHCSafety Interruptible = GHC.PlayInterruptible +toGHCSafety :: FFISafety -> GHC.Safety +toGHCSafety FFIUnsafe = GHC.PlayRisky +toGHCSafety FFISafe = GHC.PlaySafe +toGHCSafety FFIInterruptible = GHC.PlayInterruptible data CFunSig = CFunSig { cArgTypes :: [Arg], @@ -944,14 +944,16 @@ tmplAccessorToTFun v@(Variable (Arg {..})) a = case a of Getter -> TFun - { tfun_ret = arg_type, + { tfun_safety = FFIUnsafe, + tfun_ret = arg_type, tfun_name = tmplAccessorName v Getter, tfun_oname = tmplAccessorName v Getter, tfun_args = [] } Setter -> TFun - { tfun_ret = Void, + { tfun_safety = FFIUnsafe, + tfun_ret = Void, tfun_name = tmplAccessorName v Setter, tfun_oname = tmplAccessorName v Setter, tfun_args = [Arg arg_type "value"] diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index c9210441..6026fa7d 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -499,7 +499,8 @@ buildImplementationHs amap m = Ex.mkImport "System.IO.Unsafe", Ex.mkImport "FFICXX.Runtime.Cast", Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", -- for template member - Ex.mkImport "FFICXX.Runtime.TH" -- for template member + Ex.mkImport "FFICXX.Runtime.TH", -- for template member + Ex.mkImport "FFICXX.Runtime.Types" -- for template member ] <> genImportInImplementation m <> genExtraImport m @@ -567,7 +568,8 @@ buildTHHs m = Ex.mkImport "Language.Haskell.TH", Ex.mkImport "Language.Haskell.TH.Syntax", Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", - Ex.mkImport "FFICXX.Runtime.TH" + Ex.mkImport "FFICXX.Runtime.TH", + Ex.mkImport "FFICXX.Runtime.Types" ] <> imports ) @@ -720,7 +722,8 @@ buildTopLevelTHHs modname tih = Ex.mkImport "Language.Haskell.TH", Ex.mkImport "Language.Haskell.TH.Syntax", Ex.mkImport "FFICXX.Runtime.CodeGen.Cxx", - Ex.mkImport "FFICXX.Runtime.TH" + Ex.mkImport "FFICXX.Runtime.TH", + Ex.mkImport "FFICXX.Runtime.Types" ] ++ concatMap genImportForTLTemplate tfns pkgBody = diff --git a/fficxx/src/FFICXX/Generate/Type/Class.hs b/fficxx/src/FFICXX/Generate/Type/Class.hs index b0e6757a..07046e3e 100644 --- a/fficxx/src/FFICXX/Generate/Type/Class.hs +++ b/fficxx/src/FFICXX/Generate/Type/Class.hs @@ -9,7 +9,7 @@ import Data.List (intercalate) import qualified Data.Map as M import Data.Maybe (mapMaybe) import FFICXX.Generate.Type.Cabal (Cabal) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) -- | C types data CTypes @@ -129,21 +129,21 @@ data Function func_alias :: Maybe String } | Virtual - { func_safety :: Safety, + { func_safety :: FFISafety, func_ret :: Types, func_name :: String, func_args :: [Arg], func_alias :: Maybe String } | NonVirtual - { func_safety :: Safety, + { func_safety :: FFISafety, func_ret :: Types, func_name :: String, func_args :: [Arg], func_alias :: Maybe String } | Static - { func_safety :: Safety, + { func_safety :: FFISafety, func_ret :: Types, func_name :: String, func_args :: [Arg], @@ -160,7 +160,7 @@ newtype Variable = Variable {unVariable :: Arg} -- | Member functions of a template class. data TemplateMemberFunction = TemplateMemberFunction - { tmf_safety :: Safety, + { tmf_safety :: FFISafety, tmf_params :: [String], tmf_ret :: Types, tmf_name :: String, @@ -184,7 +184,7 @@ filterTLTemplate = mapMaybe (\case TLTemplate f -> Just f; _ -> Nothing) data TLOrdinary = TopLevelFunction - { toplevelfunc_safety :: Safety, + { toplevelfunc_safety :: FFISafety, toplevelfunc_ret :: Types, toplevelfunc_name :: String, toplevelfunc_args :: [Arg], @@ -198,7 +198,7 @@ data TLOrdinary deriving (Show) data TLTemplate = TopLevelTemplateFunction - { topleveltfunc_safety :: Safety, + { topleveltfunc_safety :: FFISafety, topleveltfunc_params :: [String], topleveltfunc_ret :: Types, topleveltfunc_name :: String, @@ -207,10 +207,10 @@ data TLTemplate = TopLevelTemplateFunction } deriving (Show) -getSafety :: Function -> Safety -getSafety (Constructor {}) = Unsafe -getSafety (Destructor {}) = Unsafe -getSafety f = func_safety f +getFunSafety :: Function -> FFISafety +getFunSafety (Constructor {}) = FFIUnsafe +getFunSafety (Destructor {}) = FFIUnsafe +getFunSafety f = func_safety f isNewFunc :: Function -> Bool isNewFunc (Constructor {}) = True @@ -302,7 +302,7 @@ data OpExp data TemplateFunction = TFun - { tfun_safety :: Safety, + { tfun_safety :: FFISafety, tfun_ret :: Types, tfun_name :: String, tfun_oname :: String, @@ -314,13 +314,18 @@ data TemplateFunction } | TFunDelete | TFunOp - { tfun_safety :: Safety, + { tfun_safety :: FFISafety, tfun_ret :: Types, -- | haskell alias for the operator tfun_name :: String, tfun_opexp :: OpExp } +getTFunSafety :: TemplateFunction -> FFISafety +getTFunSafety TFunNew {} = FFIUnsafe +getTFunSafety TFunDelete {} = FFIUnsafe +getTFunSafety f = tfun_safety f + argsFromOpExp :: OpExp -> [Arg] argsFromOpExp OpStar = [] argsFromOpExp OpFPPlus = [] diff --git a/stdcxx-gen/Gen.hs b/stdcxx-gen/Gen.hs index 557207a4..5c3549ef 100644 --- a/stdcxx-gen/Gen.hs +++ b/stdcxx-gen/Gen.hs @@ -51,7 +51,7 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module (TemplateClassImportHeader (..)) import FFICXX.Generate.Type.PackageInterface () import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) -import FFICXX.Runtime.Types (Safety (..)) +import FFICXX.Runtime.Types (FFISafety (..)) import System.Directory (getCurrentDirectory) import System.FilePath (()) @@ -98,9 +98,9 @@ string = mempty (Just (ClassAlias {caHaskellName = "CppString", caFFIName = "string"})) [ Constructor [cstring "p"] Nothing, - NonVirtual Unsafe cstring_ "c_str" [] Nothing, - NonVirtual Unsafe (cppclassref_ string) "append" [cppclassref string "str"] Nothing, - NonVirtual Unsafe (cppclassref_ string) "erase" [] Nothing + NonVirtual FFIUnsafe cstring_ "c_str" [] Nothing, + NonVirtual FFIUnsafe (cppclassref_ string) "append" [cppclassref string "str"] Nothing, + NonVirtual FFIUnsafe (cppclassref_ string) "erase" [] Nothing ] [] [] @@ -156,7 +156,7 @@ t_map = ["tpk", "tpv"] [ TFunNew [] Nothing, TFun - Unsafe + FFIUnsafe ( TemplateAppRef TemplateAppInfo { tapp_tclass = t_map_iterator, @@ -168,7 +168,7 @@ t_map = "begin" [], TFun - Unsafe + FFIUnsafe ( TemplateAppRef TemplateAppInfo { tapp_tclass = t_map_iterator, @@ -180,7 +180,7 @@ t_map = "end" [], TFun - Unsafe + FFIUnsafe void_ -- until pair is allowed "insert" "insert" @@ -194,7 +194,7 @@ t_map = ) "val" ], - TFun Unsafe int_ "size" "size" [], + TFun FFIUnsafe int_ "size" "size" [], TFunDelete ] [] @@ -207,7 +207,7 @@ t_map_iterator = (FormNested "std::map" "iterator") ["tpk", "tpv"] [ TFunOp - { tfun_safety = Unsafe, + { tfun_safety = FFIUnsafe, tfun_ret = TemplateApp TemplateAppInfo @@ -219,7 +219,7 @@ t_map_iterator = tfun_opexp = OpStar }, TFunOp - { tfun_safety = Unsafe, + { tfun_safety = FFIUnsafe, tfun_ret -- TODO: this should be handled with self = TemplateApp @@ -243,7 +243,7 @@ t_vector = ["tp1"] [ TFunNew [] Nothing, TFun - Unsafe + FFIUnsafe ( TemplateAppRef TemplateAppInfo { tapp_tclass = t_vector_iterator, @@ -255,7 +255,7 @@ t_vector = "begin" [], TFun - Unsafe + FFIUnsafe ( TemplateAppRef TemplateAppInfo { tapp_tclass = t_vector_iterator, @@ -266,10 +266,10 @@ t_vector = "end" "end" [], - TFun Unsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], - TFun Unsafe void_ "pop_back" "pop_back" [], - TFun Unsafe (TemplateParam "tp1") "at" "at" [int "n"], - TFun Unsafe int_ "size" "size" [], + TFun FFIUnsafe void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"], + TFun FFIUnsafe void_ "pop_back" "pop_back" [], + TFun FFIUnsafe (TemplateParam "tp1") "at" "at" [int "n"], + TFun FFIUnsafe int_ "size" "size" [], TFunDelete ] [] @@ -282,13 +282,13 @@ t_vector_iterator = (FormNested "std::vector" "iterator") ["tp1"] [ TFunOp - { tfun_safety = Unsafe, + { tfun_safety = FFIUnsafe, tfun_ret = TemplateParam "tp1", tfun_name = "deRef", tfun_opexp = OpStar }, TFunOp - { tfun_safety = Unsafe, + { tfun_safety = FFIUnsafe, tfun_ret -- TODO: this should be handled with self = TemplateApp @@ -312,9 +312,9 @@ t_unique_ptr = ["tp1"] [ TFunNew [] (Just "newUniquePtr0"), TFunNew [Arg (TemplateParamPointer "tp1") "p"] Nothing, - TFun Unsafe (TemplateParamPointer "tp1") "get" "get" [], - TFun Unsafe (TemplateParamPointer "tp1") "release" "release" [], - TFun Unsafe void_ "reset" "reset" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "get" "get" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "release" "release" [], + TFun FFIUnsafe void_ "reset" "reset" [], TFunDelete ] [] @@ -328,9 +328,9 @@ t_shared_ptr = ["tp1"] [ TFunNew [] (Just "newSharedPtr0"), TFunNew [Arg (TemplateParamPointer "tp1") "p"] Nothing, - TFun Unsafe (TemplateParamPointer "tp1") "get" "get" [], - TFun Unsafe void_ "reset" "reset" [], - TFun Unsafe int_ "use_count" "use_count" [], + TFun FFIUnsafe (TemplateParamPointer "tp1") "get" "get" [], + TFun FFIUnsafe void_ "reset" "reset" [], + TFun FFIUnsafe int_ "use_count" "use_count" [], TFunDelete ] []