From bd3fdabc98a87e7ebf124e9c26f6a7f89cb214e1 Mon Sep 17 00:00:00 2001 From: sof Date: Mon, 25 Oct 1999 13:21:16 +0000 Subject: [PATCH] [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 | 10 +++++++++- ghc/compiler/prelude/TysWiredIn.lhs | 28 +++++++++++++++++++++++----- ghc/compiler/simplStg/StgVarInfo.lhs | 32 +++++++++++++++++++++++++++++--- ghc/compiler/stgSyn/CoreToStg.lhs | 4 ++-- ghc/compiler/typecheck/TcForeign.lhs | 12 ++++++------ 5 files changed, 69 insertions(+), 17 deletions(-) diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index e762898..0fca2d3 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (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 diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index acfba4a..894fd7d 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/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} diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index f185c19..6e93773 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/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 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 10cb1ce..4ff2d3a 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/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 diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 8ea02f7..b1fd17e 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/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 () -- 1.7.10.4