From 57d07fb8c739fb50f957c25e8987632d04da3969 Mon Sep 17 00:00:00 2001 From: sof Date: Sun, 8 Nov 1998 17:10:41 +0000 Subject: [PATCH] [project @ 1998-11-08 17:10:35 by sof] First take at 'foreign label's --- ghc/compiler/deSugar/DsForeign.lhs | 36 ++++++++++++++++++++++++++++++---- ghc/compiler/hsSyn/HsDecls.lhs | 14 ++++++++++--- ghc/compiler/hsSyn/HsSyn.lhs | 4 ++-- ghc/compiler/reader/PrefixToHs.lhs | 1 - ghc/compiler/reader/ReadPrefix.lhs | 10 ++++++---- ghc/compiler/rename/RnNames.lhs | 11 ++++++++--- ghc/compiler/rename/RnSource.lhs | 15 +++++++++++--- ghc/compiler/typecheck/TcForeign.lhs | 31 +++++++++++++++++++++-------- 8 files changed, 94 insertions(+), 28 deletions(-) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index f495cd2..be886a4 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 944c274..9de522d 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 22dcc54..ea10362 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 ce3e2fd..1d5b008 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 16946c2..33ef93b 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 3c1b0e8..7fad74c 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 89e484d..10a7fd8 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 4a2e4a2..6382472 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 $ -- 1.7.10.4