diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index f495cd2c237539d53b9f17d566a0e9ea4c9f27e9..be886a470549ce6c2bad1d959f1f599062b47d77 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -19,7 +19,7 @@ import DsCCall ( getIoOkDataCon, boxResult, unboxArg,
import DsMonad
import DsUtils
-import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic )
+import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
import CallConv
import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl )
import CoreUtils ( coreExprType )
@@ -51,7 +51,8 @@ import TysWiredIn ( getStatePairingConInfo,
realWorldStateTy, stateDataCon,
isFFIArgumentTy, unitTy,
addrTy, stablePtrTyCon,
- stateAndPtrPrimDataCon
+ stateAndPtrPrimDataCon,
+ addrDataCon
)
import Outputable
\end{code}
@@ -83,6 +84,9 @@ dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
| isForeignImport =
dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b ->
returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
+ | isForeignLabel =
+ dsFLabel i ext_nm `thenDs` \ b ->
+ returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
| isDynamic ext_nm =
dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,hc,h,c) ->
returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
@@ -91,8 +95,17 @@ dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
where
- isForeignImport = maybeToBool imp_exp
- (Just uns) = imp_exp
+ isForeignImport =
+ case imp_exp of
+ FoImport _ -> True
+ _ -> False
+
+ isForeignLabel =
+ case imp_exp of
+ FoLabel -> True
+ _ -> False
+
+ (FoImport uns) = imp_exp
\end{code}
@@ -149,6 +162,21 @@ mkArgs ty =
\end{code}
+
+\begin{code}
+dsFLabel :: Id -> ExtName -> DsM CoreBinding
+dsFLabel nm ext_name =
+ returnDs (NonRec nm fo_rhs)
+ where
+ fo_rhs = mkCon addrDataCon [] [LitArg (MachLitLit enm AddrRep)]
+ enm =
+ case ext_name of
+ ExtName f _ -> f
+
+\end{code}
+
+
+
\begin{code}
dsFExport :: Id
-> Type -- Type of foreign export.
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 944c2743c657d7987434769619c03a64b4e495ea..9de522df97126f2960c2eb20c8accd83b8a72b1c 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -354,7 +354,7 @@ instance (NamedThing name, Outputable name)
data ForeignDecl name =
ForeignDecl
name
- (Maybe Bool) -- Nothing => foreign export; Just unsafe => foreign import unsafe
+ ForKind
(HsType name)
ExtName
CallConv
@@ -369,8 +369,16 @@ instance (NamedThing name, Outputable name)
where
(ppr_imp_exp, ppr_unsafe) =
case imp_exp of
- Nothing -> (ptext SLIT("export"), empty)
- Just us -> (ptext SLIT("import"), ptext SLIT("unsafe"))
+ FoLabel -> (ptext SLIT("label"), empty)
+ FoExport -> (ptext SLIT("export"), empty)
+ FoImport us
+ | us -> (ptext SLIT("import"), ptext SLIT("unsafe"))
+ | otherwise -> (ptext SLIT("import"), empty)
+
+data ForKind
+ = FoLabel
+ | FoExport
+ | FoImport Bool -- True => unsafe call.
data ExtName
= Dynamic
diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
index 22dcc544fdf5fef1cd18d6f1cc17d87b24df0085..ea103620c7359e0a2e686cc2c79f0104c971acee 100644
--- a/ghc/compiler/hsSyn/HsSyn.lhs
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -32,8 +32,8 @@ module HsSyn (
-- friends:
import HsBinds
import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..),
- DefaultDecl(..), ForeignDecl(..), ExtName(..), isDynamic,
- FixityDecl(..),
+ DefaultDecl(..), ForeignDecl(..), ForKind(..),
+ ExtName(..), isDynamic, FixityDecl(..),
ConDecl(..), ConDetails(..), BangType(..),
IfaceSig(..), HsIdInfo, SpecDataSig(..),
hsDeclName
diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index ce3e2fdde12c5fc5321deeca82f94e9bd6a38c60..1d5b008548e0eec7d5651e344527c1a27385ec92 100644
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -197,7 +197,6 @@ cvOtherDecls b
go acc (RdrClassDecl d) = ClD d : acc
go acc (RdrInstDecl d) = InstD d : acc
go acc (RdrDefaultDecl d) = DefD d : acc
--- go acc (RdrForeignDecl d) = ForD d : acc
go acc other = acc
-- Ignore value bindings
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 16946c2e6fccf81adaad1ac65307793a951821c9..33ef93b7c0e31d81166bf36e6eecef2ae58aabda 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -964,9 +964,11 @@ wlkExtName (U_just pt)
rdCallConv :: Int -> UgnM CallConv
rdCallConv x = returnUgn x
-rdImpExp :: Int -> Bool -> UgnM (Maybe Bool)
-rdImpExp 0 isUnsafe = -- foreign import
- returnUgn (Just isUnsafe)
+rdForKind :: Int -> Bool -> UgnM ForKind
+rdForKind 0 isUnsafe = -- foreign import
+ returnUgn (FoImport isUnsafe)
rdImpExp 1 _ = -- foreign export
- returnUgn Nothing
+ returnUgn FoExport
+rdImpExp 2 _ = -- foreign label
+ returnUgn FoLabel
\end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 3c1b0e89722d8e07d0c2adcd7d19f27182d67b83..7fad74c375000383d81872dc57b8623662394a3c 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -16,7 +16,7 @@ import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..),
IE(..), ieName,
- ForeignDecl(..), ExtName(..),
+ ForeignDecl(..), ExtName(..), ForKind(..),
FixityDecl(..),
collectTopBinders
)
@@ -226,12 +226,17 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _)
returnRn (val_avails ++ avails)
-- foreign import declaration
- getLocalDeclBinders avails (ForD (ForeignDecl nm (Just _) _ _ _ loc))
+ getLocalDeclBinders avails (ForD (ForeignDecl nm (FoImport _) _ _ _ loc))
+ = do_one (nm,loc) `thenRn` \ for_avail ->
+ returnRn (for_avail : avails)
+
+ -- foreign import declaration
+ getLocalDeclBinders avails (ForD (ForeignDecl nm FoLabel _ _ _ loc))
= do_one (nm,loc) `thenRn` \ for_avail ->
returnRn (for_avail : avails)
-- foreign export dynamic declaration
- getLocalDeclBinders avails (ForD (ForeignDecl nm Nothing _ Dynamic _ loc))
+ getLocalDeclBinders avails (ForD (ForeignDecl nm FoExport _ Dynamic _ loc))
= do_one (nm,loc) `thenRn` \ for_avail ->
returnRn (for_avail : avails)
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 89e484d98e072a559439aa8f7345ba5045444d44..10a7fd89861b093cfbd67a2f5122267eea528564 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -35,7 +35,9 @@ import FiniteMap ( lookupFM )
import Id ( GenId{-instance NamedThing-} )
import IdInfo ( FBTypeInfo, ArgUsageInfo )
import Lex ( isLexCon )
-import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME )
+import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME,
+ ioOkDataCon_NAME
+ )
import Maybes ( maybeToBool )
import Bag ( bagToList )
import Outputable
@@ -309,15 +311,22 @@ rnDecl (DefD (DefaultDecl tys src_loc))
rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn name `thenRn` \ name' ->
- (if is_export then
+ (if is_import then
addImplicitOccRn name'
else
returnRn name') `thenRn_`
rnHsSigType fo_decl_msg ty `thenRn` \ ty' ->
+ -- hack: force the constructors of IO to be slurped in,
+ -- since we need 'em when desugaring a foreign decl.
+ addImplicitOccRn ioOkDataCon_NAME `thenRn_`
returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc))
where
fo_decl_msg = ptext SLIT("a foreign declaration")
- is_export = not (maybeToBool imp_exp) && not (isDynamic ext_nm)
+ is_import =
+ not (isDynamic ext_nm) &&
+ case imp_exp of
+ FoImport _ -> True
+ _ -> False
\end{code}
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 4a2e4a21add4aae802b5f1f027b07ca57f455216..638247200344378b4c969978443542c4f357db25 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -21,7 +21,7 @@ module TcForeign
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
ExtName(..), isDynamic, MonoBinds(..),
- OutPat(..)
+ OutPat(..), ForKind(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
@@ -79,20 +79,22 @@ tcForeignExports decls =
-- defines a binding
isForeignImport :: ForeignDecl name -> Bool
-isForeignImport (ForeignDecl _ (Just _) _ _ _ _) = True
-isForeignImport (ForeignDecl _ Nothing _ Dynamic _ _) = True
-isForeignImport _ = False
+isForeignImport (ForeignDecl _ k _ dyn _ _) =
+ case k of
+ FoImport _ -> True
+ FoExport -> case dyn of { Dynamic -> True ; _ -> False }
+ FoLabel -> True
-- exports a binding
isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignDecl _ Nothing _ ext_nm _ _) = not (isDynamic ext_nm)
-isForeignExport _ = False
+isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm)
+isForeignExport _ = False
\end{code}
\begin{code}
tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
-tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
+tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsType hs_ty `thenTc` \ sig_ty ->
@@ -105,7 +107,20 @@ tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
(arg_tys, res_ty) ->
checkForeignExport True t_ty arg_tys res_ty `thenTc_`
let i = (mkUserId nm sig_ty) in
- returnTc (i, (ForeignDecl i Nothing undefined Dynamic cconv src_loc))
+ returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
+
+tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
+ tcAddSrcLoc src_loc $
+ tcAddErrCtxt (foreignDeclCtxt fo) $
+ tcHsType hs_ty `thenTc` \ sig_ty ->
+ let
+ -- drop the foralls before inspecting the structure
+ -- of the foreign type.
+ (_, t_ty) = splitForAllTys sig_ty
+ in
+ check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
+ let i = (mkUserId 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) =
tcAddSrcLoc src_loc $