From 1da7b45d4cf8c70dae8525a00eb2cd68160cf813 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 24 Jul 2000 14:29:55 +0000
Subject: [PATCH] [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.
---
ghc/compiler/deSugar/DsForeign.lhs | 21 +++++++++++++--------
ghc/compiler/prelude/TysWiredIn.lhs | 19 +++++++++++++++++--
ghc/compiler/typecheck/TcForeign.lhs | 16 +++++++++-------
3 files changed, 39 insertions(+), 17 deletions(-)
diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 44fd7025f227..64cd16dd19b8 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -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.
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 55bb4453c3d0..e132166a8e21 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -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
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 69991070609a..883103dbe7e8 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -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_`
--
GitLab