From: simonmar Date: Tue, 5 Mar 2002 14:18:56 +0000 (+0000) Subject: [project @ 2002-03-05 14:18:53 by simonmar] X-Git-Tag: Approx_11550_changesets_converted~2305 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=caac75c6a454396dadff0323162ed14adb4893cd;p=ghc-hetmet.git [project @ 2002-03-05 14:18:53 by simonmar] Generate the contents of the GHC.Prim interface file automatically from the list of available PrimOps and various other wired-in things. Two main benefits from this: - There's one fewer places to edit when adding a new primop. - It's one less reason to need the interface file parser, and now we no longer need the (short-lived) --compile-iface option so I've removed it. --- diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index acf6d19..11dcc39 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -21,11 +21,12 @@ module MkId ( mkPrimOpId, mkFCallId, -- And some particular Ids; see below for why they are wired in - wiredInIds, + wiredInIds, ghcPrimIds, unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, - eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID, - rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, - nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID + eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, + rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, + aBSENT_ERROR_ID, pAR_ERROR_ID ) where #include "HsVersions.h" @@ -111,24 +112,27 @@ wiredInIds -- error-reporting functions that they have an 'open' -- result type. -- sof 1/99] - aBSENT_ERROR_ID - , eRROR_ID - , eRROR_CSTRING_ID - , iRREFUT_PAT_ERROR_ID - , nON_EXHAUSTIVE_GUARDS_ERROR_ID - , nO_METHOD_BINDING_ERROR_ID - , pAR_ERROR_ID - , pAT_ERROR_ID - , rEC_CON_ERROR_ID - , rEC_UPD_ERROR_ID - - -- These can't be defined in Haskell, but they have + aBSENT_ERROR_ID, + eRROR_ID, + eRROR_CSTRING_ID, + iRREFUT_PAT_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, + nO_METHOD_BINDING_ERROR_ID, + pAR_ERROR_ID, + pAT_ERROR_ID, + rEC_CON_ERROR_ID, + rEC_UPD_ERROR_ID + ] ++ ghcPrimIds + +-- These Ids are exported from GHC.Prim +ghcPrimIds + = [ -- These can't be defined in Haskell, but they have -- perfectly reasonable unfoldings in Core - , realWorldPrimId - , unsafeCoerceId - , nullAddrId - , getTagId - , seqId + realWorldPrimId, + unsafeCoerceId, + nullAddrId, + getTagId, + seqId ] \end{code} @@ -787,7 +791,7 @@ another gun with which to shoot yourself in the foot. \begin{code} -- unsafeCoerce# :: forall a b. a -> b unsafeCoerceId - = pcMiscPrelId unsafeCoerceIdKey pREL_GHC FSLIT("unsafeCoerce#") ty info + = pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info where info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -802,13 +806,13 @@ unsafeCoerceId -- The reason is is here is because we don't provide -- a way to write this literal in Haskell. nullAddrId - = pcMiscPrelId nullAddrIdKey pREL_GHC FSLIT("nullAddr#") addrPrimTy info + = pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info where info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) seqId - = pcMiscPrelId seqIdKey pREL_GHC FSLIT("seq") ty info + = pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info where info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -824,7 +828,7 @@ evaluate its argument and call the dataToTag# primitive. \begin{code} getTagId - = pcMiscPrelId getTagIdKey pREL_GHC FSLIT("getTag#") ty info + = pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info where info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs -- We don't provide a defn for this; you must inline it @@ -849,7 +853,7 @@ This comes up in strictness analysis \begin{code} realWorldPrimId -- :: State# RealWorld - = pcMiscPrelId realWorldPrimIdKey pREL_GHC FSLIT("realWorld#") + = pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#") realWorldStatePrimTy (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon []) -- The mkOtherCon makes it look that realWorld# is evaluated diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs index 50d465d..799ce15 100644 --- a/ghc/compiler/main/BinIface.hs +++ b/ghc/compiler/main/BinIface.hs @@ -5,7 +5,7 @@ -- -- Binary interface file support. -module BinIface ( writeBinIface, compileIface ) where +module BinIface ( writeBinIface ) where import HscTypes import BasicTypes @@ -18,19 +18,14 @@ import TyCon import Class import VarEnv import CostCentre -import Module ( mkHomeModule ) import Name ( Name, nameOccName ) import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts ) import OccName ( OccName ) import RnMonad ( ParsedIface(..) ) import RnHsSyn import DriverState ( v_Build_tag ) -import DriverUtil ( newsuf ) -import Lex import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion ) import StringBuffer ( hGetStringBuffer ) -import ParseIface ( parseIface ) -import Outputable import Panic import SrcLoc @@ -377,21 +372,6 @@ writeBinIface hi_path mod_iface = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface -- ---------------------------------------------------------------------------- --- Compile an interface from text into binary - -compileIface :: FilePath -> IO () -compileIface infile = do - let outfile = newsuf "hi" infile -- make it a .hi file - buf <- hGetStringBuffer False infile - case parseIface buf (mkPState loc exts) of - PFailed err -> throwDyn (ProgramError (showSDoc err)) - POk _ iface -> - putBinFileWithDict outfile (mkHomeModule (pi_mod iface)) iface - where - exts = ExtFlags {glasgowExtsEF = True, - parrEF = True} - loc = mkSrcLoc (FastString.mkFastString infile) 1 - {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} -- Imported from other files :- diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index ec885f9..6084d6f 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.87 2002/03/04 17:01:30 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.88 2002/03/05 14:18:55 simonmar Exp $ -- -- Driver flags -- @@ -19,7 +19,6 @@ module DriverFlags ( #include "HsVersions.h" #include "../includes/config.h" -import BinIface ( compileIface ) import MkIface ( showIface ) import DriverState import DriverPhases @@ -168,8 +167,6 @@ static_flags = ------- interfaces ---------------------------------------------------- , ( "-show-iface" , HasArg (\f -> do showIface f exitWith ExitSuccess)) - , ( "-compile-iface" , HasArg (\f -> do compileIface f - exitWith ExitSuccess)) ------- verbosity ---------------------------------------------------- , ( "n" , NoArg setDryRun ) diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 34e049f..e97d288 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -10,6 +10,8 @@ module PrelInfo ( wiredInThings, -- Names of wired in things wiredInThingEnv, + ghcPrimExports, + cCallableClassDecl, cReturnableClassDecl, assertDecl, -- Primop RdrNames eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, @@ -28,20 +30,26 @@ module PrelInfo ( #include "HsVersions.h" --- friends: import PrelNames -- Prelude module names -import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName ) +import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName, primOpOcc ) import DataCon ( DataCon ) +import Id ( idName ) import MkId ( mkPrimOpId, wiredInIds ) import MkId -- All of it, for re-export +import Name ( nameOccName, nameRdrName ) +import RdrName ( mkRdrUnqual ) +import HsSyn ( HsTyVarBndr(..), TyClDecl(..), HsType(..) ) +import OccName ( mkVarOcc ) import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) -import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv ) - --- others: +import RdrHsSyn ( mkClassDecl ) +import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv, + GenAvailInfo(..), RdrAvailInfo ) import Class ( Class, classKey ) -import Type ( funTyCon ) +import Type ( funTyCon, openTypeKind, liftedTypeKind ) +import TyCon ( tyConName ) +import SrcLoc ( noSrcLoc ) import Util ( isIn ) \end{code} @@ -79,6 +87,57 @@ We let a lot of "non-standard" values be visible, so that we can make sense of them in interface pragmas. It's cool, though they all have "non-standard" names, so they won't get past the parser in user code. +%************************************************************************ +%* * +\subsection{Export lists for pseudo-modules (GHC.Prim)} +%* * +%************************************************************************ + +GHC.Prim "exports" all the primops and primitive types, some +wired-in Ids, and the CCallable & CReturnable classes. + +\begin{code} +ghcPrimExports :: [RdrAvailInfo] + = AvailTC cCallableOcc [ cCallableOcc ] : + AvailTC cReturnableOcc [ cReturnableOcc ] : + Avail (nameOccName assertName) : -- doesn't have an Id + map (Avail . nameOccName . idName) ghcPrimIds ++ + map (Avail . primOpOcc) allThePrimOps ++ + [ AvailTC occ [occ] | + n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n) + ] + where + cCallableOcc = nameOccName cCallableClassName + cReturnableOcc = nameOccName cReturnableClassName + +assertDecl + = IfaceSig { + tcdName = nameRdrName assertName, + tcdType = HsForAllTy (Just [liftedAlpha]) [] (HsTyVar alpha), + tcdIdInfo = [], + tcdLoc = noSrcLoc + } + +cCallableClassDecl + = mkClassDecl + ([], nameRdrName cCallableClassName, [openAlpha]) + [] -- no fds + [] -- no sigs + Nothing -- no mbinds + noSrcLoc + +cReturnableClassDecl + = mkClassDecl + ([], nameRdrName cReturnableClassName, [openAlpha]) + [] -- no fds + [] -- no sigs + Nothing -- no mbinds + noSrcLoc + +alpha = mkRdrUnqual (mkVarOcc FSLIT("a")) +openAlpha = IfaceTyVar alpha openTypeKind +liftedAlpha = IfaceTyVar alpha liftedTypeKind +\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index c385d25..f83e04a 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -224,7 +224,7 @@ knownKeyNames \begin{code} pRELUDE_Name = mkModuleName "Prelude" -pREL_GHC_Name = mkModuleName "GHC.Prim" -- Primitive types and values +gHC_PRIM_Name = mkModuleName "GHC.Prim" -- Primitive types and values pREL_BASE_Name = mkModuleName "GHC.Base" pREL_ENUM_Name = mkModuleName "GHC.Enum" pREL_SHOW_Name = mkModuleName "GHC.Show" @@ -259,7 +259,7 @@ aDDR_Name = mkModuleName "Addr" gLA_EXTS_Name = mkModuleName "GlaExts" -pREL_GHC = mkPrelModule pREL_GHC_Name +gHC_PRIM = mkPrelModule gHC_PRIM_Name pREL_BASE = mkPrelModule pREL_BASE_Name pREL_ADDR = mkPrelModule pREL_ADDR_Name pREL_PTR = mkPrelModule pREL_PTR_Name @@ -292,11 +292,11 @@ mkTupNameStr Boxed 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto mkTupNameStr Boxed n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")) mkTupNameStr Unboxed 0 = panic "Name.mkUbxTupNameStr: 0 ???" -mkTupNameStr Unboxed 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!! -mkTupNameStr Unboxed 2 = (pREL_GHC_Name, _PK_ "(#,#)") -mkTupNameStr Unboxed 3 = (pREL_GHC_Name, _PK_ "(#,,#)") -mkTupNameStr Unboxed 4 = (pREL_GHC_Name, _PK_ "(#,,,#)") -mkTupNameStr Unboxed n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)")) +mkTupNameStr Unboxed 1 = (gHC_PRIM_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!! +mkTupNameStr Unboxed 2 = (gHC_PRIM_Name, _PK_ "(#,#)") +mkTupNameStr Unboxed 3 = (gHC_PRIM_Name, _PK_ "(#,,#)") +mkTupNameStr Unboxed 4 = (gHC_PRIM_Name, _PK_ "(#,,,#)") +mkTupNameStr Unboxed n = (gHC_PRIM_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)")) mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of @@ -344,33 +344,33 @@ openKindConName = kindQual FSLIT("?") anyBoxConKey usageKindConName = kindQual FSLIT("$") usageConKey typeConName = kindQual FSLIT("Type") typeConKey -funTyConName = tcQual pREL_GHC_Name FSLIT("(->)") funTyConKey -charPrimTyConName = tcQual pREL_GHC_Name FSLIT("Char#") charPrimTyConKey -intPrimTyConName = tcQual pREL_GHC_Name FSLIT("Int#") intPrimTyConKey -int32PrimTyConName = tcQual pREL_GHC_Name FSLIT("Int32#") int32PrimTyConKey -int64PrimTyConName = tcQual pREL_GHC_Name FSLIT("Int64#") int64PrimTyConKey -wordPrimTyConName = tcQual pREL_GHC_Name FSLIT("Word#") wordPrimTyConKey -word32PrimTyConName = tcQual pREL_GHC_Name FSLIT("Word32#") word32PrimTyConKey -word64PrimTyConName = tcQual pREL_GHC_Name FSLIT("Word64#") word64PrimTyConKey -addrPrimTyConName = tcQual pREL_GHC_Name FSLIT("Addr#") addrPrimTyConKey -floatPrimTyConName = tcQual pREL_GHC_Name FSLIT("Float#") floatPrimTyConKey -doublePrimTyConName = tcQual pREL_GHC_Name FSLIT("Double#") doublePrimTyConKey -statePrimTyConName = tcQual pREL_GHC_Name FSLIT("State#") statePrimTyConKey -realWorldTyConName = tcQual pREL_GHC_Name FSLIT("RealWorld") realWorldTyConKey -arrayPrimTyConName = tcQual pREL_GHC_Name FSLIT("Array#") arrayPrimTyConKey -byteArrayPrimTyConName = tcQual pREL_GHC_Name FSLIT("ByteArray#") byteArrayPrimTyConKey -mutableArrayPrimTyConName = tcQual pREL_GHC_Name FSLIT("MutableArray#") mutableArrayPrimTyConKey -mutableByteArrayPrimTyConName = tcQual pREL_GHC_Name FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey -mutVarPrimTyConName = tcQual pREL_GHC_Name FSLIT("MutVar#") mutVarPrimTyConKey -mVarPrimTyConName = tcQual pREL_GHC_Name FSLIT("MVar#") mVarPrimTyConKey -stablePtrPrimTyConName = tcQual pREL_GHC_Name FSLIT("StablePtr#") stablePtrPrimTyConKey -stableNamePrimTyConName = tcQual pREL_GHC_Name FSLIT("StableName#") stableNamePrimTyConKey -foreignObjPrimTyConName = tcQual pREL_GHC_Name FSLIT("ForeignObj#") foreignObjPrimTyConKey -bcoPrimTyConName = tcQual pREL_GHC_Name FSLIT("BCO#") bcoPrimTyConKey -weakPrimTyConName = tcQual pREL_GHC_Name FSLIT("Weak#") weakPrimTyConKey -threadIdPrimTyConName = tcQual pREL_GHC_Name FSLIT("ThreadId#") threadIdPrimTyConKey -cCallableClassName = clsQual pREL_GHC_Name FSLIT("CCallable") cCallableClassKey -cReturnableClassName = clsQual pREL_GHC_Name FSLIT("CReturnable") cReturnableClassKey +funTyConName = tcQual gHC_PRIM_Name FSLIT("(->)") funTyConKey +charPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Char#") charPrimTyConKey +intPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int#") intPrimTyConKey +int32PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int32#") int32PrimTyConKey +int64PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int64#") int64PrimTyConKey +wordPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word#") wordPrimTyConKey +word32PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word32#") word32PrimTyConKey +word64PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word64#") word64PrimTyConKey +addrPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Addr#") addrPrimTyConKey +floatPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Float#") floatPrimTyConKey +doublePrimTyConName = tcQual gHC_PRIM_Name FSLIT("Double#") doublePrimTyConKey +statePrimTyConName = tcQual gHC_PRIM_Name FSLIT("State#") statePrimTyConKey +realWorldTyConName = tcQual gHC_PRIM_Name FSLIT("RealWorld") realWorldTyConKey +arrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Array#") arrayPrimTyConKey +byteArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ByteArray#") byteArrayPrimTyConKey +mutableArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutableArray#") mutableArrayPrimTyConKey +mutableByteArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey +mutVarPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutVar#") mutVarPrimTyConKey +mVarPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MVar#") mVarPrimTyConKey +stablePtrPrimTyConName = tcQual gHC_PRIM_Name FSLIT("StablePtr#") stablePtrPrimTyConKey +stableNamePrimTyConName = tcQual gHC_PRIM_Name FSLIT("StableName#") stableNamePrimTyConKey +foreignObjPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ForeignObj#") foreignObjPrimTyConKey +bcoPrimTyConName = tcQual gHC_PRIM_Name FSLIT("BCO#") bcoPrimTyConKey +weakPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Weak#") weakPrimTyConKey +threadIdPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ThreadId#") threadIdPrimTyConKey +cCallableClassName = clsQual gHC_PRIM_Name FSLIT("CCallable") cCallableClassKey +cReturnableClassName = clsQual gHC_PRIM_Name FSLIT("CReturnable") cReturnableClassKey -- PrelBase data types and constructors charTyConName = tcQual pREL_BASE_Name FSLIT("Char") charTyConKey @@ -555,9 +555,10 @@ stablePtrDataConName = dataQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrDa deRefStablePtrName = varQual pREL_STABLE_Name FSLIT("deRefStablePtr") deRefStablePtrIdKey newStablePtrName = varQual pREL_STABLE_Name FSLIT("newStablePtr") newStablePtrIdKey +assertName = varQual gHC_PRIM_Name FSLIT("assert") assertIdKey +getTagName = varQual gHC_PRIM_Name FSLIT("getTag#") getTagIdKey + errorName = varQual pREL_ERR_Name FSLIT("error") errorIdKey -assertName = varQual pREL_GHC_Name FSLIT("assert") assertIdKey -getTagName = varQual pREL_GHC_Name FSLIT("getTag#") getTagIdKey runSTRepName = varQual pREL_ST_Name FSLIT("runSTRep") runSTRepIdKey -- The "split" Id for splittable implicit parameters diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index c087f39..82a60e0 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -36,7 +36,7 @@ import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, tyConAppTyCon import PprType () -- get at Outputable Type instance. import Unique ( mkPrimOpIdUnique ) import BasicTypes ( Arity, Boxity(..) ) -import PrelNames ( pREL_GHC, pREL_GHC_Name ) +import PrelNames ( gHC_PRIM, gHC_PRIM_Name ) import Outputable import FastTypes \end{code} @@ -397,10 +397,10 @@ mkPrimOpIdName :: PrimOp -> Name -- We have to pass in the Id itself because it's a WiredInId -- and hence recursive mkPrimOpIdName op - = mkWiredInName pREL_GHC (primOpOcc op) (mkPrimOpIdUnique (primOpTag op)) + = mkWiredInName gHC_PRIM (primOpOcc op) (mkPrimOpIdUnique (primOpTag op)) primOpRdrName :: PrimOp -> RdrName -primOpRdrName op = mkRdrOrig pREL_GHC_Name (primOpOcc op) +primOpRdrName op = mkRdrOrig gHC_PRIM_Name (primOpOcc op) primOpOcc :: PrimOp -> OccName primOpOcc op = case (primOpInfo op) of @@ -469,14 +469,7 @@ compare_fun_ty ty = mkFunTys [ty, ty] boolTy Output stuff: \begin{code} pprPrimOp :: PrimOp -> SDoc -pprPrimOp other_op - = getPprStyle $ \ sty -> - if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC. - ptext SLIT("PrelGHC.") <> pprOccName occ - else - pprOccName occ - where - occ = primOpOcc other_op +pprPrimOp other_op = pprOccName (primOpOcc other_op) \end{code} Names for some primops (for ndpFlatten/FlattenMonad.lhs) diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 87bbbeb..d9fec6e 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -39,6 +39,7 @@ import RnEnv import RnMonad import ParseIface ( parseIface ) +import PrelNames ( gHC_PRIM_Name, gHC_PRIM ) import Name ( Name {-instance NamedThing-}, nameModule, isLocalName, nameIsLocalOrFrom ) @@ -498,6 +499,11 @@ findAndReadIface :: SDoc -> ModuleName findAndReadIface doc_str mod_name hi_boot_file = traceRn trace_msg `thenRn_` + -- Check for GHC.Prim, and return its static interface + if mod_name == gHC_PRIM_Name + then returnRn (Right (gHC_PRIM, ghcPrimIface)) + else + -- In interactive or --make mode, we are *not allowed* to demand-load -- a home package .hi file. So don't even look for them. -- This helps in the case where you are sitting in eg. ghc/lib/std diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 5fff141..2eb8003 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -23,16 +23,6 @@ module RnMonad( #include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 405 -import IOExts ( fixIO ) -#elif defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 302 -import PrelIOBase ( fixIO ) -- Should be in GlaExts -#else -import IOBase ( fixIO ) -#endif -import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) -import IO ( hPutStr, stderr ) - import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig ) @@ -58,8 +48,13 @@ import Name ( Name, OccName, NamedThing(..), nameOccName, decode, mkLocalName, mkKnownKeyGlobal ) -import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, extendNameEnvList ) -import Module ( Module, ModuleName, ModuleSet, emptyModuleSet, PackageName ) +import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, + extendNameEnvList ) +import Module ( Module, ModuleName, ModuleSet, emptyModuleSet, + PackageName ) +import PrelInfo ( ghcPrimExports, + cCallableClassDecl, cReturnableClassDecl, assertDecl ) +import PrelNames ( mkUnboundName, gHC_PRIM_Name ) import NameSet import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc ) @@ -69,8 +64,11 @@ import Maybes ( seqMaybe ) import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable -import PrelNames ( mkUnboundName ) +import IOExts ( IORef, newIORef, readIORef, writeIORef, + fixIO, unsafePerformIO ) +import IO ( hPutStr, stderr ) + infixr 9 `thenRn`, `thenRn_` \end{code} @@ -232,6 +230,31 @@ data ParsedIface %************************************************************************ %* * +\subsection{Wired-in interfaces} +%* * +%************************************************************************ + +\begin{code} +ghcPrimIface :: ParsedIface +ghcPrimIface = ParsedIface { + pi_mod = gHC_PRIM_Name, + pi_pkg = FSLIT("base"), + pi_vers = 1, + pi_orphan = False, + pi_usages = [], + pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), + pi_decls = [(1,cCallableClassDecl), + (1,cReturnableClassDecl), + (1,assertDecl)], + pi_fixity = [], + pi_insts = [], + pi_rules = (1,[]), + pi_deprecs = Nothing + } +\end{code} + +%************************************************************************ +%* * \subsection{The renamer state} %* * %************************************************************************