[project @ 2001-05-21 09:19:14 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsForeign.lhs

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 7e1f46d..46ea86c 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -30,7 +30,7 @@ import Name           ( mkGlobalName, nameModule, nameOccName, getOccString,
                          NamedThing(..),
                        )
 import Type            ( repType, splitTyConApp_maybe,
-                         tyConAppTyCon, splitFunTys, splitForAllTys,
+                         splitFunTys, splitForAllTys,
                          Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkFunTy, splitAppTy, applyTy, funResultTy
                        )
@@ -125,30 +125,39 @@ because it exposes the boxing to the call site.
 \begin{code}
 dsFImport :: Id
          -> Type               -- Type of foreign import.
-         -> Bool               -- True <=> might cause Haskell GC
+         -> Bool               -- True <=> cannot re-enter the Haskell RTS
          -> ExtName
          -> CallConv
          -> DsM [Binding]
-dsFImport fn_id ty may_not_gc ext_name cconv 
+dsFImport fn_id ty unsafe ext_name cconv 
   = let
        (tvs, fun_ty)        = splitForAllTys ty
        (arg_tys, io_res_ty) = splitFunTys fun_ty
     in
     newSysLocalsDs arg_tys                     `thenDs` \ args ->
     mapAndUnzipDs unboxArg (map Var args)      `thenDs` \ (val_args, arg_wrappers) ->
-    boxResult io_res_ty                                `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
-    getUniqueDs                                                `thenDs` \ ccall_uniq ->
-    getUniqueDs                                                `thenDs` \ work_uniq ->
+    let
+       work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
+
+       -- these are the ids we pass to boxResult, which are used to decide
+       -- whether to touch# an argument after the call (used to keep
+       -- ForeignObj#s live across a 'safe' foreign import).
+       maybe_arg_ids | unsafe    = []
+                     | otherwise = work_arg_ids
+    in
+    boxResult maybe_arg_ids io_res_ty                  `thenDs` \ (ccall_result_ty, res_wrapper) ->
+
+    getUniqueDs                                        `thenDs` \ ccall_uniq ->
+    getUniqueDs                                        `thenDs` \ work_uniq ->
     let
        lbl = case ext_name of
                Dynamic      -> dynamicTarget
                ExtName fs _ -> StaticTarget fs
 
        -- Build the worker
-       work_arg_ids  = [v | Var v <- val_args]         -- All guaranteed to be vars
        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
-       the_ccall     = CCall lbl False (not may_not_gc) cconv
+       the_ccall     = CCall lbl False (not unsafe) cconv
        the_ccall_app = mkCCall ccall_uniq the_ccall val_args ccall_result_ty
        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
        work_id       = mkSysLocal SLIT("$wccall") work_uniq worker_ty