upgrade template TH code generation with FFISafety

wavewave · Aug 28, 2023 · 83d21f4 · 83d21f4
1 parent 2f9ca3d
commit 83d21f4
Show file tree

Hide file tree

Showing 15 changed files with 138 additions and 107 deletions.
diff --git 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
@@ -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
@@ -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,15 +156,15 @@ toplevels :: [TopLevel]
 toplevels =
   [ TLOrdinary
       TopLevelFunction
-        { toplevelfunc_safety = Unsafe,
+        { toplevelfunc_safety = FFIUnsafe,
           toplevelfunc_ret = Void,
           toplevelfunc_name = "ordinary",
           toplevelfunc_args = [],
           toplevelfunc_alias = Nothing
         },
     TLTemplate
       ( TopLevelTemplateFunction
-          { topleveltfunc_safety = Unsafe,
+          { topleveltfunc_safety = FFIUnsafe,
             topleveltfunc_params = ["t1"],
             topleveltfunc_ret =
               TemplateAppMove (TemplateAppInfo t_vector [TArg_TypeParam "t1"] "std::vector<t1>"),

diff --git 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
@@ -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,25 +54,25 @@ 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
     let fn' = "c_" <> fn
     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
@@ -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
@@ -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
@@ -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
@@ -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