import DsMonad
import DsUtils
-import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic )
+import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
import CallConv
import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl )
import CoreUtils ( coreExprType )
realWorldStateTy, stateDataCon,
isFFIArgumentTy, unitTy,
addrTy, stablePtrTyCon,
- stateAndPtrPrimDataCon
+ stateAndPtrPrimDataCon,
+ addrDataCon
)
import Outputable
\end{code}
| 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)
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}
\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.
data ForeignDecl name =
ForeignDecl
name
- (Maybe Bool) -- Nothing => foreign export; Just unsafe => foreign import unsafe
+ ForKind
(HsType name)
ExtName
CallConv
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
-- 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
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
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}
import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..),
IE(..), ieName,
- ForeignDecl(..), ExtName(..),
+ ForeignDecl(..), ExtName(..), ForKind(..),
FixityDecl(..),
collectTopBinders
)
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)
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
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}
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
ExtName(..), isDynamic, MonoBinds(..),
- OutPat(..)
+ OutPat(..), ForKind(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
-- 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 ->
(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 $
projects / ghc-hetmet.git / commitdiff