[project @ 2001-05-03 14:31:58 by simonmar]

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

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 189672a..79e7076 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -20,17 +20,17 @@ import HsDecls              ( extNameStatic )
 import CallConv
 import TcHsSyn         ( TypecheckedForeignDecl )
 import CoreUtils       ( exprType, mkInlineMe )
-import Id              ( Id, idType, idName, mkVanillaId, mkSysLocal,
+import Id              ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
                          setInlinePragma )
-import IdInfo          ( neverInlinePrag )
+import IdInfo          ( neverInlinePrag, vanillaIdInfo )
 import Literal         ( Literal(..) )
 import Module          ( Module, moduleUserString )
 import Name            ( mkGlobalName, nameModule, nameOccName, getOccString, 
                          mkForeignExportOcc, isLocalName,
                          NamedThing(..),
                        )
-import Type            ( repType,
-                         splitTyConApp_maybe, tyConAppTyCon, splitFunTys, splitForAllTys,
+import Type            ( repType, splitTyConApp_maybe,
+                         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 work_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
@@ -259,7 +268,7 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn
        helper_ty =  mkForAllTys tvs $
                     mkFunTys wrapper_arg_tys io_res_ty
 
-       f_helper_glob = mkVanillaId helper_name helper_ty
+       f_helper_glob = mkVanillaGlobal helper_name helper_ty vanillaIdInfo
                      where
                        name                = idName fn_id
                        mod     
@@ -487,5 +496,9 @@ showStgType :: Type -> SDoc
 showStgType t = text "Hs" <> text (showFFIType t)
 
 showFFIType :: Type -> String
-showFFIType t = getOccString (getName (tyConAppTyCon t))
+showFFIType t = getOccString (getName tc)
+ where
+  tc = case splitTyConApp_maybe (repType t) of
+           Just (tc,_) -> tc
+           Nothing     -> pprPanic "showFFIType" (ppr t)
 \end{code}