%
% (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 $
%
%********************************************************
%* *
(\ 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
wordTy,
wordTyCon,
- isFFIArgumentTy, -- :: Type -> Bool
+ isFFIArgumentTy, -- :: Bool -> Type -> Bool
isFFIResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
isAddrTy, -- :: Type -> Bool
+ isForeignObjTy -- :: Type -> Bool
) where
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
-- (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}
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
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.
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
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
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) $
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))
\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 ()
projects / ghc-hetmet.git / commitdiff