Commit bd3fdabc authored by sof's avatar sof
Browse files

[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_.
parent 148227dc
%
% (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
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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 ()
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment