Commit 1da7b45d authored by simonmar's avatar simonmar
Browse files

[project @ 2000-07-24 14:29:55 by simonmar]

Some changes to the way FFI decls are handled:

  - a foreign export dynamic which returns a newtype of
    an Addr now works correctly.  Similarly for foreign label.

  - unlifted types are not allowed in the arguments of a foreign
    export.  Previously we generated incorrect code for these cases.

Newtypes in FFI declarations now work everywhere they should, as far
as I can see.

These changes will be backported into 4.08.1.
parent c8a6996a
......@@ -12,7 +12,7 @@ module DsForeign ( dsForeigns ) where
import CoreSyn
import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg )
import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg, resultWrapper )
import DsMonad
import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
......@@ -39,11 +39,14 @@ import PrimOp ( PrimOp(..), CCall(..),
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon,
addrDataCon
)
import TysPrim ( addrPrimTy )
import Unique ( Uniquable(..), hasKey,
ioTyConKey, deRefStablePtrIdKey, returnIOIdKey,
bindIOIdKey, makeStablePtrIdKey
)
import Outputable
import Maybe ( fromJust )
\end{code}
Desugaring of @foreign@ declarations is naturally split up into
......@@ -76,7 +79,7 @@ dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos
dsFImport i (idType i) uns ext_nm cconv `thenDs` \ bs ->
returnDs (bs ++ acc_fi, acc_fe, acc_h, acc_c)
| isForeignLabel =
dsFLabel i ext_nm `thenDs` \ b ->
dsFLabel i (idType i) ext_nm `thenDs` \ b ->
returnDs (b:acc_fi, acc_fe, acc_h, acc_c)
| isDynamicExtName ext_nm =
dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (fi,fe,h,c) ->
......@@ -161,10 +164,12 @@ dsFImport fn_id ty may_not_gc ext_name cconv
Foreign labels
\begin{code}
dsFLabel :: Id -> ExtName -> DsM CoreBind
dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs)
dsFLabel :: Id -> Type -> ExtName -> DsM CoreBind
dsFLabel nm ty ext_name =
ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
returnDs (NonRec nm (fo_rhs (mkLit (MachLabel enm))))
where
fo_rhs = mkConApp addrDataCon [mkLit (MachLabel enm)]
(res_ty, fo_rhs) = resultWrapper ty
enm = extNameStatic ext_name
\end{code}
......@@ -325,7 +330,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
fe_ext_name = ExtName (_PK_ fe_nm) Nothing
in
dsFExport i export_ty mod_name fe_ext_name cconv True
`thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
`thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
newSysLocalDs arg_ty `thenDs` \ cback ->
dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId ->
let
......@@ -357,7 +362,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
-- (probably in the RTS.)
adjustor = SLIT("createAdjustor")
in
dsCCall adjustor adj_args False False ioAddrTy `thenDs` \ ccall_adj ->
dsCCall adjustor adj_args False False io_res_ty `thenDs` \ ccall_adj ->
let ccall_adj_ty = exprType ccall_adj
ccall_io_adj = mkLams [stbl_value] $
Note (Coerce io_res_ty (unUsgTy ccall_adj_ty))
......@@ -365,7 +370,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
in
let io_app = mkLams tvs $
mkLams [cback] $
stbl_app ccall_io_adj addrTy
stbl_app ccall_io_adj res_ty
in
-- Never inline the f.e.d. function, because the litlit might not be in scope
-- in other modules.
......
......@@ -65,6 +65,8 @@ module TysWiredIn (
isFFIArgumentTy, -- :: Bool -> Type -> Bool
isFFIResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFILabelTy, -- :: Type -> Bool
isAddrTy, -- :: Type -> Bool
isForeignObjTy -- :: Type -> Bool
......@@ -359,6 +361,14 @@ isFFIResultTy :: Type -> Bool
-- But we allow () as well
isFFIResultTy ty = checkRepTyCon (\tc -> tc == unitTyCon || legalIncomingTyCon tc) ty
-- The result type of a foreign export dynamic must be either Addr, or
-- a newtype of Addr.
isFFIDynResultTy = checkRepTyCon (== addrTyCon)
-- The type of a foreign label must be either Addr, or
-- a newtype of Addr.
isFFILabelTy = checkRepTyCon (== addrTyCon)
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-- look through newtypes
checkRepTyCon check_tc ty = checkTyCon check_tc (repType ty)
......@@ -384,8 +394,10 @@ legalIncomingTyCon :: TyCon -> Bool
legalIncomingTyCon tc
| getUnique tc `elem` [ foreignObjTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ]
= False
-- It's also illegal to make foreign exports that take unboxed
-- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
| otherwise
= marshalableTyCon tc
= boxedMarshalableTyCon tc
legalOutgoingTyCon :: Bool -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
......@@ -399,7 +411,10 @@ legalOutgoingTyCon be_safe tc
marshalableTyCon tc
= (opt_GlasgowExts && isUnLiftedTyCon tc)
|| getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
|| boxedMarshalableTyCon tc
boxedMarshalableTyCon tc
= getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
, wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
, addrTyConKey, charTyConKey, foreignObjTyConKey
......
......@@ -28,7 +28,7 @@ import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
import TcEnv ( newLocalId )
import TcType ( tcSplitRhoTy, zonkTcTypeToType )
import TcMonoType ( tcHsBoxedSigType )
import TcMonoType ( tcHsSigType, tcHsBoxedSigType )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcExpr ( tcId, tcPolyExpr )
......@@ -42,7 +42,8 @@ import Type ( splitFunTys
, splitForAllTys
)
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
isFFIExternalTy, isAddrTy
isFFIExternalTy, isAddrTy,
isFFIDynResultTy, isFFILabelTy
)
import Type ( Type )
import Unique
......@@ -105,7 +106,8 @@ tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
-- of the foreign type.
(_, t_ty) = splitForAllTys sig_ty
in
check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
check (isFFILabelTy t_ty)
(illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
let i = (mkVanillaId nm sig_ty) in
returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
......@@ -113,7 +115,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsBoxedSigType hs_ty `thenTc` \ ty ->
tcHsSigType hs_ty `thenTc` \ ty ->
-- Check that the type has the right shape
-- and that the argument and result types are acceptable.
let
......@@ -183,9 +185,9 @@ checkForeignExport is_dynamic ty args res
[arg] ->
case splitFunTys arg of
(arg_tys, res_ty) ->
mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_`
checkForeignRes False {-Must be IO-} isAddrTy res
mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_`
checkForeignRes False {-Must be IO-} isFFIDynResultTy res
_ -> check False (illegalForeignTyErr True{-Arg-} ty)
| otherwise =
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
......
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