From 1da7b45d4cf8c70dae8525a00eb2cd68160cf813 Mon Sep 17 00:00:00 2001 From: simonmar 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 44fd702..64cd16d 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 55bb445..e132166 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 6999107..883103d 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_` -- 1.7.10.4