X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FdeSugar%2FDsForeign.lhs;h=46ea86c286100f9f897cac02303bacb396696358;hb=52bcee1fa452a898b3d23a2d2d89ad35605f978f;hp=189672a97880df22fe7a36295bbe3aeaefc78e08;hpb=ea659be5faea43df1b2c113d2f22947dff23367e;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 189672a..46ea86c 100644
--- 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 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
@@ -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}