[project @ 1999-10-25 13:20:57 by sof]

FFI wibble:

* disallow the use of {Mutable}ByteArrays in 'safe' foreign imports.
* ensure that ForeignObjs live across a _ccall_GC_.

ghc/compiler/codeGen/CgExpr.lhs

 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgExpr.lhs,v 1.29 1999/06/28 16:29:45 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.30 1999/10/25 13:21:16 sof Exp $
 %
 %********************************************************
 %*							*
@@ -139,6 +139,14 @@ cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
 	    (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
    where
         dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
+	  --
+	  -- if you're reading this code in the attempt to figure
+	  -- out why the compiler panic'ed here, it is probably because
+	  -- you used tagToEnum# in a non-monomorphic setting, e.g., 
+	  --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
+          --
+	  -- That won't work.
+          --
 	(Just (tycon,_)) = splitTyConApp_maybe res_ty
 
 

ghc/compiler/prelude/TysWiredIn.lhs

@@ -65,10 +65,11 @@ module TysWiredIn (
 	wordTy,
 	wordTyCon,
 
-	isFFIArgumentTy,  -- :: Type -> Bool
+	isFFIArgumentTy,  -- :: Bool -> Type -> Bool
 	isFFIResultTy,    -- :: Type -> Bool
 	isFFIExternalTy,  -- :: Type -> Bool
 	isAddrTy,	  -- :: Type -> Bool
+	isForeignObjTy    -- :: Type -> Bool
 
     ) where
 
@@ -399,11 +400,16 @@ restricted set of types as arguments and results (the restricting factor
 being the )
 
 \begin{code}
-isFFIArgumentTy :: Type -> Bool
-isFFIArgumentTy ty =
-  (opt_GlasgowExts && isUnLiftedType ty) || --leave out for now: maybeToBool (maybeBoxedPrimType ty))) ||
+isFFIArgumentTy :: Bool -> Type -> Bool
+isFFIArgumentTy forASafeCall ty =
+  (opt_GlasgowExts && isUnLiftedType ty) ||
   case (splitAlgTyConApp_maybe ty) of
-    Just (tycon, _, _) -> (getUnique tycon) `elem` primArgTyConKeys
+    Just (tycon, _, _) -> 
+    		let
+		 u = getUnique tycon
+		in
+		u `elem` primArgTyConKeys &&   -- it has a suitable prim type, and
+		(not forASafeCall || not ( u `elem` notSafeExternalTyCons)) -- it is safe to pass out.
     _		       -> False
 
 -- types that can be passed as arguments to "foreign" functions
@@ -449,6 +455,18 @@ isFFIResultTy ty =
 -- (or be passed them as arguments in foreign exported functions).
 notLegalExternalTyCons =
   [ foreignObjTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ]
+
+-- it's really unsafe to pass out references to objects in the heap,
+-- so for safe call-outs we simply disallow it.
+notSafeExternalTyCons =
+  [ byteArrayTyConKey, mutableByteArrayTyConKey ]
+
+
+isForeignObjTy :: Type -> Bool
+isForeignObjTy ty =
+  case (splitAlgTyConApp_maybe ty) of
+    Just (tycon, _, _) -> (getUnique tycon) == foreignObjTyConKey
+    _		       -> False
     
 \end{code}
 

ghc/compiler/simplStg/StgVarInfo.lhs

@@ -17,9 +17,12 @@ import Id		( setIdArity, getIdArity, Id )
 import VarSet
 import VarEnv
 import Var
+import Const		( Con(..) )
 import IdInfo		( ArityInfo(..), InlinePragInfo(..), 
 			  setInlinePragInfo )
-import Maybes		( maybeToBool )
+import PrimOp		( PrimOp(..) )
+import TysWiredIn       ( isForeignObjTy )
+import Maybes		( maybeToBool, orElse )
 import Name		( isLocallyDefined )
 import BasicTypes       ( Arity )
 import Outputable
@@ -294,11 +297,21 @@ varsExpr (StgCase scrut _ _ bndr srt alts)
 		  then modifyIdInfo (`setInlinePragInfo` NoInlinePragInfo) bndr
 		  else modifyIdInfo (`setInlinePragInfo` IAmDead)	   bndr
 
+	 -- for a _ccall_GC_, some of the *arguments* need to live across the
+	 -- call (see findLiveArgs comments.), so we annotate them as being live
+	 -- in the alts to achieve the desired effect.
+	mb_live_across_case =
+	  case scrut of
+	    StgCon (PrimOp (CCallOp _ _ True{- _ccall_GC_ -} _)) args _ ->
+	         Just (foldl findLiveArgs emptyVarSet args)
+	    _ -> Nothing
+
 	-- don't consider the default binder as being 'live in alts',
 	-- since this is from the point of view of the case expr, where
 	-- the default binder is not free.
-	live_in_alts = live_in_cont `unionVarSet` 
-				(alts_lvs `minusVarSet` unitVarSet bndr)
+	live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $
+		       live_in_cont `unionVarSet` 
+		       (alts_lvs `minusVarSet` unitVarSet bndr)
     in
 	-- we tell the scrutinee that everything live in the alts
 	-- is live in it, too.
@@ -394,6 +407,19 @@ varsExpr (StgLet bind body)
     returnLne (new_let, fvs, escs)
 \end{code}
 
+If we've got a case containing a _ccall_GC_ primop, we need to
+ensure that the arguments are kept live for the duration of the
+call. This only an issue
+
+\begin{code}
+findLiveArgs :: StgLiveVars -> StgArg -> StgLiveVars
+findLiveArgs lvs (StgConArg _) = lvs
+findLiveArgs lvs (StgVarArg x) 
+   | isForeignObjTy (idType x) = extendVarSet lvs x
+   | otherwise		       = lvs
+\end{code}
+
+
 Applications:
 \begin{code}
 varsApp :: Maybe UpdateFlag		-- Just upd <=> this application is

ghc/compiler/stgSyn/CoreToStg.lhs

@@ -273,8 +273,8 @@ exprToRhs dem _ (StgLam _ bndrs body)
   We reject the following candidates for 'static constructor'dom:
   
     - any dcon that takes a lit-lit as an arg.
-    - [Win32 DLLs only]: any dcon that is (or takes as arg)
-      that's living in a DLL.
+    - [Win32 DLLs only]: any dcon that resides in a DLL
+      (or takes as arg something that is.)
 
   These constraints are necessary to ensure that the code
   generated in the end for the static constructors, which

ghc/compiler/typecheck/TcForeign.lhs

@@ -117,7 +117,7 @@ tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
    let i = (mkVanillaId nm sig_ty) in
    returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
 
-tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
+tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc		     $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
@@ -131,7 +131,7 @@ tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    in
    case splitFunTys t_ty of
      (arg_tys, res_ty) ->
-        checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
+        checkForeignImport (isDynamic ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_`
 	let i = (mkVanillaId nm ty) in
 	returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
 
@@ -168,18 +168,18 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
 
 
 \begin{code}
-checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s ()
-checkForeignImport is_dynamic ty args res
+checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignImport is_dynamic is_safe ty args res
  | is_dynamic =
     -- * first arg has got to be an Addr
    case args of
      []     -> check False (illegalForeignTyErr True{-Arg-} ty)
      (x:xs) ->
         check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
-        mapTc (checkForeignArg isFFIArgumentTy) xs		`thenTc_`
+        mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs	`thenTc_`
 	checkForeignRes (isFFIResultTy) res
  | otherwise =
-     mapTc (checkForeignArg isFFIArgumentTy) args	        `thenTc_`
+     mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args     `thenTc_`
      checkForeignRes (isFFIResultTy) res
 
 checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()