diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index f28f21827209c9196ae1663a68ae4dbba79cbf11..0dab7976b5966c68af76e29d08035e5e96a7c1cc 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -52,8 +52,9 @@ import TysWiredIn
-- others:
import SpecEnv ( SpecEnv )
import RdrHsSyn ( RdrName(..), varQual, tcQual, qual )
+import BasicTypes ( IfaceFlavour )
import Id ( GenId, SYN_IE(Id) )
-import Name ( Name, OccName(..), DefnInfo(..), Provenance(..),
+import Name ( Name, OccName(..), Provenance(..),
getName, mkGlobalName, modAndOcc )
import Class ( Class(..), GenClass, classKey )
import TyCon ( tyConDataCons, mkFunTyCon, TyCon )
@@ -250,7 +251,8 @@ Ids, Synonyms, Classes and ClassOps with builtin keys.
\begin{code}
mkKnownKeyGlobal :: (RdrName, Unique) -> Name
-mkKnownKeyGlobal (Qual mod occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit
+mkKnownKeyGlobal (Qual mod occ hif, uniq)
+ = mkGlobalName uniq mod occ (Implicit hif)
allClass_NAME = mkKnownKeyGlobal (allClass_RDR, allClassKey)
main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index f223311cf6ed99528546af47d715cc20cc77a34a..20955245502c082ecb4b16302f9522efbb6c6860 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -525,7 +525,7 @@ runSTId
id_info
= noIdInfo
`addArityInfo` exactArity 1
- `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict] False
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
-- ABSOLUTELY NO UNFOLDING, e.g.: (mk_inline_unfolding run_ST_template)
-- see example below
@@ -601,7 +601,7 @@ buildId
= pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
((((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
`addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
-- cheating, but since _build never actually exists ...
@@ -646,7 +646,7 @@ augmentId
= pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
(((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
-- cheating, but since _augment never actually exists ...
where
@@ -669,7 +669,7 @@ foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
idInfo = (((((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
`addArityInfo` exactArity 3)
`addUpdateInfo` mkUpdateInfo [2,2,1])
`addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
@@ -683,7 +683,7 @@ foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
idInfo = (((((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
`addArityInfo` exactArity 3)
`addUpdateInfo` mkUpdateInfo [2,2,1])
`addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
@@ -709,7 +709,7 @@ appendId
(mkSigmaTy [alphaTyVar] []
(mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
idInfo = (((noIdInfo
- `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
`addArityInfo` exactArity 2)
`addUpdateInfo` mkUpdateInfo [1,2])
-}
diff --git a/ghc/compiler/prelude/StdIdInfo.lhs b/ghc/compiler/prelude/StdIdInfo.lhs
index 52e0a18664913a3e57c670b28bd6cf1798b0bef6..53e81c7c742bdd6993b021801354ad20afe63ead 100644
--- a/ghc/compiler/prelude/StdIdInfo.lhs
+++ b/ghc/compiler/prelude/StdIdInfo.lhs
@@ -21,6 +21,7 @@ module StdIdInfo (
IMP_Ubiq()
import Type
+import TyVar ( alphaTyVar )
import CmdLineOpts ( opt_PprUserLength )
import CoreSyn
import Literal
@@ -36,7 +37,7 @@ import Id ( GenId, mkTemplateLocals, idType,
SYN_IE(Id)
)
import IdInfo ( ArityInfo, exactArity )
-import Class ( GenClass, GenClassOp, classSig, classOpLocalType )
+import Class ( GenClass, classBigSig, classDictArgTys )
import TyCon ( isNewTyCon, isDataTyCon, isAlgTyCon )
import FieldLabel ( FieldLabel )
import PrelVals ( pAT_ERROR_ID )
@@ -187,41 +188,17 @@ addStandardIdInfo sel_id
\begin{code}
addStandardIdInfo sel_id
| maybeToBool maybe_sc_sel_id
- = sel_id `addIdUnfolding` unfolding
- -- The always-inline thing means we don't need any other IdInfo
+ = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
where
maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
- Just (cls, the_sc) = maybe_sc_sel_id
-
- unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
- rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
-
- (tyvar, scs, ops) = classSig cls
- tyvar_ty = mkTyVarTy tyvar
- [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
- arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
- map classOpLocalType ops)
- the_arg_id = assoc "StdIdInfoSC" (scs `zip` arg_ids) the_sc
+ Just (cls, _) = maybe_sc_sel_id
addStandardIdInfo sel_id
| maybeToBool maybe_meth_sel_id
- = sel_id `addIdUnfolding` unfolding
- -- The always-inline thing means we don't need any other IdInfo
+ = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
where
maybe_meth_sel_id = isMethodSelId_maybe sel_id
- Just (cls, the_op) = maybe_meth_sel_id
-
- unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
- rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
-
- (tyvar, scs, ops) = classSig cls
- n_scs = length scs
- tyvar_ty = mkTyVarTy tyvar
- [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
- arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
- map classOpLocalType ops)
-
- the_arg_id = assoc "StdIdInfoMeth" (ops `zip` (drop n_scs arg_ids)) the_op
+ Just cls = maybe_meth_sel_id
\end{code}
@@ -275,6 +252,19 @@ Selecting a field for a dictionary. If there is just one field, then
there's nothing to do.
\begin{code}
+mk_selector_unfolding clas sel_id
+ = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
+ -- The always-inline thing means we don't need any other IdInfo
+ where
+ rhs = mk_dict_selector [alphaTyVar] dict_id arg_ids the_arg_id
+ tyvar_ty = mkTyVarTy alphaTyVar
+ [dict_id] = mkTemplateLocals [mkDictTy clas tyvar_ty]
+ arg_tys = classDictArgTys clas tyvar_ty
+ arg_ids = mkTemplateLocals arg_tys
+ the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
+
+ (_, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
+
mk_dict_selector tyvars dict_id [arg_id] the_arg_id
= mkLam tyvars [dict_id] (Var dict_id)
diff --git a/ghc/compiler/prelude/TysWiredIn.hi-boot b/ghc/compiler/prelude/TysWiredIn.hi-boot
index b66a9e65a36b3948ba9eb0fe45bf4ff8b27ff683..c808a8e7390c7b7bfc54220be969b18e08a5048f 100644
--- a/ghc/compiler/prelude/TysWiredIn.hi-boot
+++ b/ghc/compiler/prelude/TysWiredIn.hi-boot
@@ -2,5 +2,5 @@ _interface_ TysWiredIn 1
_exports_
TysWiredIn tupleCon tupleTyCon;
_declarations_
-1 tupleCon _:_ PrelBase.Int -> Id.Id ;;
-1 tupleTyCon _:_ PrelBase.Int -> TyCon.TyCon ;;
+1 tupleCon _:_ BasicTypes.Arity -> Id.Id ;;
+1 tupleTyCon _:_ BasicTypes.Arity -> TyCon.TyCon ;;
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 3e3a71bf579add58395f5bfd8da39e527c081f21..f9cd0c9ff5b850994f902506f247f56c731b763f 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -94,8 +94,6 @@ IMPORT_DELOOPER(IdLoop) ( SpecEnv, nullSpecEnv,
#else
import {-# SOURCE #-} Id ( Id, mkDataCon, mkTupleCon, StrictnessMark(..) )
import {-# SOURCE #-} SpecEnv ( SpecEnv, nullSpecEnv )
-import {-# SOURCE #-} Type ( Type )
-import {-# SOURCE #-} TyVar ( TyVar )
#endif
-- friends:
@@ -103,16 +101,17 @@ import PrelMods
import TysPrim
-- others:
+import FieldLabel () --
import Kind ( mkBoxedTypeKind, mkArrowKind )
-import Name --( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr )
+import Name ( mkWiredInTyConName, mkWiredInIdName )
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
TyCon, SYN_IE(Arity)
)
-import BasicTypes ( NewOrData(..) )
-import Type ( mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys,
+import BasicTypes ( SYN_IE(Module), NewOrData(..) )
+import Type ( SYN_IE(Type), mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys,
mkFunTy, mkFunTys, maybeAppTyCon,
GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) )
-import TyVar ( tyVarKind, alphaTyVars, alphaTyVar, betaTyVar )
+import TyVar ( SYN_IE(TyVar), tyVarKind, alphaTyVars, alphaTyVar, betaTyVar )
import Lex ( mkTupNameStr )
import Unique
import Util ( assoc, panic )
diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
index 3632ed30a07ac27a5c5fb90a01133882761bcaee..e70cbbf0f8e68afe075f38dacf4a8bcbbb6d481d 100644
--- a/ghc/compiler/reader/Lex.lhs
+++ b/ghc/compiler/reader/Lex.lhs
@@ -34,7 +34,7 @@ import PrelBase ( Char(..) )
import CmdLineOpts ( opt_IgnoreIfacePragmas )
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( UniqFM, listToUFM, lookupUFM)
-import BasicTypes ( NewOrData(..) )
+import BasicTypes ( NewOrData(..), IfaceFlavour(..) )
#if __GLASGOW_HASKELL__ >= 202
import Maybes ( MaybeErr(..) )
@@ -205,10 +205,10 @@ data IfaceToken
| ITconid FAST_STRING
| ITvarsym FAST_STRING
| ITconsym FAST_STRING
- | ITqvarid (FAST_STRING,FAST_STRING)
- | ITqconid (FAST_STRING,FAST_STRING)
- | ITqvarsym (FAST_STRING,FAST_STRING)
- | ITqconsym (FAST_STRING,FAST_STRING)
+ | ITqvarid (FAST_STRING,FAST_STRING,IfaceFlavour)
+ | ITqconid (FAST_STRING,FAST_STRING,IfaceFlavour)
+ | ITqvarsym (FAST_STRING,FAST_STRING,IfaceFlavour)
+ | ITqconsym (FAST_STRING,FAST_STRING,IfaceFlavour)
| ITidinfo [IfaceToken] -- lazily return the stream of tokens for
-- the info attached to an id.
@@ -624,15 +624,19 @@ lex_id buf =
case expandWhile (is_mod_char) buf of
buf' ->
case currentChar# buf' of
- '.'# ->
+ '.'# -> munch buf' HiFile
+ '!'# -> munch buf' HiBootFile
+ _ -> lex_id2 Nothing buf'
+ where
+ munch buf' hif =
if not (emptyLexeme buf') then
-- _trace ("lex_id: "++(C# (currentChar# (stepOverLexeme buf'))):show (lexemeToFastString buf')) $
case lexemeToFastString buf' of
- l@(FastString u# l# ba#) -> lex_id2 (Just (FastString u# l# ba#))
+ l@(FastString u# l# ba#) -> lex_id2 (Just (FastString u# l# ba#, hif))
(stepOn (stepOverLexeme buf'))
else
lex_id2 Nothing buf'
- _ -> lex_id2 Nothing buf'
+
-- Dealt with the Module.part
lex_id2 module_dot buf =
@@ -719,14 +723,14 @@ mk_var_token pk_str =
-}
end_lex_id Nothing token buf = token : lexIface buf
-end_lex_id (Just m) token buf =
+end_lex_id (Just (m,hif)) token buf =
case token of
- ITconid n -> ITqconid (m,n) : lexIface buf
- ITvarid n -> ITqvarid (m,n) : lexIface buf
- ITconsym n -> ITqconsym (m,n) : lexIface buf
- ITvarsym n -> ITqvarsym (m,n) : lexIface buf
- ITbang -> ITqvarsym (m,SLIT("!")) : lexIface buf
- _ -> ITunknown (show token) : lexIface buf
+ ITconid n -> ITqconid (m,n,hif) : lexIface buf
+ ITvarid n -> ITqvarid (m,n,hif) : lexIface buf
+ ITconsym n -> ITqconsym (m,n,hif) : lexIface buf
+ ITvarsym n -> ITqvarsym (m,n,hif) : lexIface buf
+ ITbang -> ITqvarsym (m,SLIT("!"),hif) : lexIface buf
+ _ -> ITunknown (show token) : lexIface buf
------------
ifaceKeywordsFM :: UniqFM IfaceToken
diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs
index d91c711e4659e52a5c2ab8fc4864cdfb6c0b4538..ad57265f23b3faa84d1ea7bfb0402e27ab385376 100644
--- a/ghc/compiler/reader/PrefixSyn.lhs
+++ b/ghc/compiler/reader/PrefixSyn.lhs
@@ -27,6 +27,7 @@ IMPORT_1_3(Char(isDigit))
import HsSyn
import RdrHsSyn
+import BasicTypes ( IfaceFlavour )
import Util ( panic )
import SrcLoc ( SrcLoc )
diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index a984397d11b640d994ee6efc0818fcb9ca1d3605..3536af82ad10f2488f8054d3e364e54e6b116b96 100644
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -45,7 +45,7 @@ cvValSig (RdrTySig vars poly_ty src_loc)
= [ Sig v poly_ty src_loc | v <- vars ]
cvClassOpSig (RdrTySig vars poly_ty src_loc)
- = [ ClassOpSig v v poly_ty src_loc | v <- vars ]
+ = [ ClassOpSig v Nothing poly_ty src_loc | v <- vars ]
cvInstDeclSig (RdrSpecValSig sigs) = sigs
cvInstDeclSig (RdrInlineValSig sig) = [ sig ]
diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index 9f4aa00549929a717732f4f048ebe957f13eda33..053915204f13f7d30060ee5e696053339dea3859 100644
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -46,7 +46,7 @@ module RdrHsSyn (
extractHsTyVars,
RdrName(..),
- qual, varQual, tcQual, varUnqual,
+ qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
showRdr, rdrNameOcc, ieOcc,
@@ -60,7 +60,7 @@ IMP_Ubiq()
import HsSyn
import Lex
import PrelMods ( pRELUDE )
-import BasicTypes ( Module(..), NewOrData )
+import BasicTypes ( Module(..), NewOrData, IfaceFlavour(..) )
import Name ( ExportFlag(..), pprModule,
OccName(..), pprOccName,
prefixOccName, SYN_IE(NamedThing) )
@@ -138,7 +138,7 @@ extractHsTyVars ty
where
locals = map getTyVarName tvs
- insert (Qual _ _) acc = acc
+ insert (Qual _ _ _) acc = acc
insert (Unqual (TCOcc _)) acc = acc
insert other acc | other `elem` acc = acc
| otherwise = other : acc
@@ -162,11 +162,15 @@ mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
\begin{code}
data RdrName
= Unqual OccName
- | Qual Module OccName
+ | Qual Module OccName IfaceFlavour -- HiBootFile for M!.t (interface files only),
+ -- HiFile for the common M.t
-qual (m,n) = Qual m n
-tcQual (m,n) = Qual m (TCOcc n)
-varQual (m,n) = Qual m (VarOcc n)
+qual (m,n) = Qual m n HiFile
+tcQual (m,n) = Qual m (TCOcc n) HiFile
+varQual (m,n) = Qual m (VarOcc n) HiFile
+
+lexTcQual (m,n,hif) = Qual m (TCOcc n) hif
+lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
-- This guy is used by the reader when HsSyn has a slot for
-- an implicit name that's going to be filled in by
@@ -178,26 +182,26 @@ dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
varUnqual n = Unqual (VarOcc n)
-isUnqual (Unqual _) = True
-isUnqual (Qual _ _) = False
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _ _) = False
-isQual (Unqual _) = False
-isQual (Qual _ _) = True
+isQual (Unqual _) = False
+isQual (Qual _ _ _) = True
-- Used for adding a prefix to a RdrName
prefixRdrName :: FAST_STRING -> RdrName -> RdrName
-prefixRdrName prefix (Qual m n) = Qual m (prefixOccName prefix n)
-prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n)
+prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif
+prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n)
-cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2
-cmpRdr (Unqual n1) (Qual m2 n2) = LT_
-cmpRdr (Qual m1 n1) (Unqual n2) = GT_
-cmpRdr (Qual m1 n1) (Qual m2 n2) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2)
+cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2
+cmpRdr (Unqual n1) (Qual m2 n2 _) = LT_
+cmpRdr (Qual m1 n1 _) (Unqual n2) = GT_
+cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2)
-- always compare module-names *second*
rdrNameOcc :: RdrName -> OccName
-rdrNameOcc (Unqual occ) = occ
-rdrNameOcc (Qual _ occ) = occ
+rdrNameOcc (Unqual occ) = occ
+rdrNameOcc (Qual _ occ _) = occ
ieOcc :: RdrNameIE -> OccName
ieOcc ie = rdrNameOcc (ieName ie)
@@ -219,8 +223,8 @@ instance Ord3 RdrName where
cmp = cmpRdr
instance Outputable RdrName where
- ppr sty (Unqual n) = pprQuote sty $ \ sty -> pprOccName sty n
- ppr sty (Qual m n) = pprQuote sty $ \ sty -> hcat [pprModule sty m, char '.', pprOccName sty n]
+ ppr sty (Unqual n) = pprQuote sty $ \ sty -> pprOccName sty n
+ ppr sty (Qual m n _) = pprQuote sty $ \ sty -> hcat [pprModule sty m, char '.', pprOccName sty n]
instance NamedThing RdrName where -- Just so that pretty-printing of expressions works
getOccName = rdrNameOcc
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index c14fa70cf130b76aa5cb5ec75d6e81662e9f28f7..18ec5b610e6e022c366fb6adfabaf41a996097df 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -24,7 +24,7 @@ import HsSyn
import HsTypes ( HsTyVar(..) )
import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
import RdrHsSyn
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
import PrefixToHs
import CmdLineOpts ( opt_PprUserLength )
@@ -78,7 +78,7 @@ wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
wlkQid mk_occ_name (U_noqual name)
= returnUgn (Unqual (mk_occ_name name))
wlkQid mk_occ_name (U_aqual mod name)
- = returnUgn (Qual mod (mk_occ_name name))
+ = returnUgn (Qual mod (mk_occ_name name) HiFile)
-- I don't understand this one! It is what shows up when we meet (), [], or (,,,).
wlkQid mk_occ_name (U_gid n name)
@@ -905,7 +905,7 @@ rdImport pt
mkSrcLocUgn srcline $ \ src_loc ->
wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
- returnUgn (ImportDecl imod (cvFlag iqual) (cvFlag isrc) maybe_as maybe_spec src_loc)
+ returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
where
rd_spec pt = rdU_either pt `thenUgn` \ spec ->
case spec of
@@ -913,6 +913,9 @@ rdImport pt
returnUgn (False, ents)
U_right pt -> rdEntities pt `thenUgn` \ ents ->
returnUgn (True, ents)
+
+cvIfaceFlavour 0 = HiFile -- No pragam
+cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
\end{code}
\begin{code}
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 9d2626230d9e8310c0a8fd7efb031cce3db7487a..7bfff2a461a782f6cd91ee8e84d984fc86b86647 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -6,18 +6,18 @@ IMP_Ubiq(){-uitous-}
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo )
import HsTypes ( mkHsForAllTy )
import HsCore
import Literal
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), Version(..) )
+import BasicTypes ( IfaceFlavour(..), Fixity(..), FixityDirection(..), NewOrData(..), Version(..) )
import HsPragmas ( noDataPragmas, noClassPragmas )
import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
import IdInfo ( ArgUsageInfo, FBTypeInfo )
import Lex
import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
- SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem), SYN_IE(RdrAvailInfo), GenAvailInfo(..)
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
@@ -149,8 +149,8 @@ module_stuff_pairs : { [] }
| module_stuff_pair module_stuff_pairs { $1 : $2 }
module_stuff_pair :: { ImportVersion OccName }
-module_stuff_pair : mod_name INTEGER DCOLON name_version_pairs SEMI
- { ($1, fromInteger $2, $4) }
+module_stuff_pair : mod_name opt_bang INTEGER DCOLON name_version_pairs SEMI
+ { ($1, $2, fromInteger $3, $5) }
versions_part :: { [LocalVersion OccName] }
versions_part : VERSIONS_PART name_version_pairs { $2 }
@@ -171,23 +171,27 @@ exports_part : EXPORTS_PART export_items { $2 }
export_items :: { [ExportItem] }
export_items : { [] }
- | mod_name entities SEMI export_items { ($1,$2) : $4 }
+ | opt_bang mod_name entities SEMI export_items { ($2,$1,$3) : $5 }
-entities :: { [(OccName, [OccName])] }
+opt_bang :: { IfaceFlavour }
+opt_bang : { HiFile }
+ | BANG { HiBootFile }
+
+entities :: { [RdrAvailInfo] }
entities : { [] }
| entity entities { $1 : $2 }
-entity :: { (OccName, [OccName]) }
-entity : entity_occ { ($1, if isTCOcc $1
- then [$1] {- AvailTC -}
- else []) {- Avail -} }
- | entity_occ stuff_inside { ($1, ($1 : $2)) {- TyCls exported too -} }
- | entity_occ BANG stuff_inside { ($1, $3) {- TyCls not exported -} }
+entity :: { RdrAvailInfo }
+entity : entity_occ { if isTCOcc $1
+ then AvailTC $1 [$1]
+ else Avail $1 }
+ | entity_occ stuff_inside { AvailTC $1 ($1:$2) }
+ | entity_occ VBAR stuff_inside { AvailTC $1 $3 }
stuff_inside :: { [OccName] }
-stuff_inside : OPAREN val_occs1 CPAREN { $2
+stuff_inside : OPAREN val_occs1 CPAREN { $2
--------------------------------------------------------------------------
- }
+ }
inst_modules_part :: { [Module] }
inst_modules_part : { [] }
@@ -259,7 +263,9 @@ csigs1 : csig { [$1] }
| csig SEMI csigs1 { $1 : $3 }
csig :: { RdrNameSig }
-csig : var_name DCOLON type { ClassOpSig $1 $1 $3 mkIfaceSrcLoc
+csig : var_name DCOLON type { ClassOpSig $1 Nothing $3 mkIfaceSrcLoc }
+ | var_name EQUAL DCOLON type { ClassOpSig $1 (Just (error "Un-filled-in default method"))
+ $4 mkIfaceSrcLoc
----------------------------------------------------------------
}
@@ -371,8 +377,8 @@ val_occs1 :: { [OccName] }
qvar_name :: { RdrName }
- : QVARID { varQual $1 }
- | QVARSYM { varQual $1 }
+ : QVARID { lexVarQual $1 }
+ | QVARSYM { lexVarQual $1 }
var_name :: { RdrName }
var_name : var_occ { Unqual $1 }
@@ -386,8 +392,8 @@ any_var_name : var_name { $1 }
| qvar_name { $1 }
qdata_name :: { RdrName }
-qdata_name : QCONID { varQual $1 }
- | QCONSYM { varQual $1 }
+qdata_name : QCONID { lexVarQual $1 }
+ | QCONSYM { lexVarQual $1 }
data_name :: { RdrName }
data_name : CONID { Unqual (VarOcc $1) }
@@ -400,10 +406,11 @@ tc_names1 :: { [RdrName] }
tc_name :: { RdrName }
tc_name : tc_occ { Unqual $1 }
- | QCONID { tcQual $1 }
+ | QCONID { lexTcQual $1 }
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
+ | VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} }
tv_names :: { [RdrName] }
: { [] }
diff --git a/ghc/compiler/rename/ParseType.y b/ghc/compiler/rename/ParseType.y
index 850f042d4b3be594aeedbcb1212e0038985140be..9c8392e029df49251a7e337652ab03ae7249f02b 100644
--- a/ghc/compiler/rename/ParseType.y
+++ b/ghc/compiler/rename/ParseType.y
@@ -6,7 +6,7 @@ IMP_Ubiq(){-uitous-}
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo )
import HsTypes ( mkHsForAllTy )
import HsCore
import Literal
@@ -18,7 +18,7 @@ import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
import Lex
import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
- SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem), GenAvailInfo
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
@@ -128,13 +128,14 @@ akind :: { Kind }
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
+ | VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} }
tv_names :: { [RdrName] }
: { [] }
| tv_name tv_names { $1 : $2 }
tc_name :: { RdrName }
-tc_name : QCONID { tcQual $1 }
+tc_name : QCONID { lexTcQual $1 }
| CONID { Unqual (TCOcc $1) }
| CONSYM { Unqual (TCOcc $1) }
| OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }
diff --git a/ghc/compiler/rename/ParseUnfolding.y b/ghc/compiler/rename/ParseUnfolding.y
index 56330d93d254103e5c8c3bb35e5b06343b304644..be2d3d14d3431b1b82ceba49e14d46b7207bdc4f 100644
--- a/ghc/compiler/rename/ParseUnfolding.y
+++ b/ghc/compiler/rename/ParseUnfolding.y
@@ -6,7 +6,7 @@ IMP_Ubiq(){-uitous-}
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import HsTypes ( mkHsForAllTy )
import HsCore
import Literal
@@ -19,7 +19,7 @@ import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
import Lex
import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
- SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem), GenAvailInfo
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
@@ -123,16 +123,16 @@ id_info : { [] }
id_info_item :: { HsIdInfo RdrName }
id_info_item : ARITY_PART arity_info { HsArity $2 }
| STRICT_PART strict_info { HsStrictness $2 }
- | BOTTOM { HsStrictness mkBottomStrictnessInfo }
+ | BOTTOM { HsStrictness HsBottom }
| UNFOLD_PART core_expr { HsUnfold $1 $2 }
arity_info :: { ArityInfo }
arity_info : INTEGER { exactArity (fromInteger $1) }
-strict_info :: { StrictnessInfo RdrName }
-strict_info : DEMAND any_var_name OCURLY data_names CCURLY { mkStrictnessInfo $1 (Just ($2,$4)) }
- | DEMAND any_var_name { mkStrictnessInfo $1 (Just ($2,[])) }
- | DEMAND { mkStrictnessInfo $1 Nothing }
+strict_info :: { HsStrictnessInfo RdrName }
+strict_info : DEMAND any_var_name OCURLY data_names CCURLY { HsStrictnessInfo $1 (Just ($2,$4)) }
+ | DEMAND any_var_name { HsStrictnessInfo $1 (Just ($2,[])) }
+ | DEMAND { HsStrictnessInfo $1 Nothing }
core_expr :: { UfExpr RdrName }
core_expr : any_var_name { UfVar $1 }
@@ -255,14 +255,14 @@ var_occ : VARID { VarOcc $1 }
| BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
data_name :: { RdrName }
-data_name : QCONID { varQual $1 }
- | QCONSYM { varQual $1 }
+data_name : QCONID { lexVarQual $1 }
+ | QCONSYM { lexVarQual $1 }
| CONID { Unqual (VarOcc $1) }
| CONSYM { Unqual (VarOcc $1) }
qvar_name :: { RdrName }
- : QVARID { varQual $1 }
- | QVARSYM { varQual $1 }
+ : QVARID { lexVarQual $1 }
+ | QVARSYM { lexVarQual $1 }
var_name :: { RdrName }
var_name : var_occ { Unqual $1 }
@@ -339,13 +339,14 @@ akind :: { Kind }
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
+ | VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} }
tv_names :: { [RdrName] }
: { [] }
| tv_name tv_names { $1 : $2 }
tc_name :: { RdrName }
-tc_name : QCONID { tcQual $1 }
+tc_name : QCONID { lexTcQual $1 }
| CONID { Unqual (TCOcc $1) }
| CONSYM { Unqual (TCOcc $1) }
| OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 28afe6e2b989ebb9952c2fd0fc0c1829ed5faa96..86b2d4bc61a307154934599c8c2c3321e9795fc8 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -220,7 +220,7 @@ closeDecls necessity decls
-- An unresolved name
Just name
-> -- Slurp its declaration, if any
- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_`
+-- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_`
importDecl name necessity `thenRn` \ maybe_decl ->
case maybe_decl of
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 43abb70edc039595aa7360ca5210188320aaed60..a2534f36ea5027cc2e917e9452517c5271324e9d 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -17,9 +17,9 @@ import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE),
rdrNameOcc, ieOcc, isQual, qual
)
import HsTypes ( getTyVarName, replaceTyVarName )
-import BasicTypes ( Fixity(..), FixityDirection(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..), pprModule )
import RnMonad
-import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..), NamedThing(..),
+import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
occNameString, occNameFlavour,
SYN_IE(NameSet), emptyNameSet, addListToNameSet,
mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName,
@@ -29,15 +29,14 @@ import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..),
import TyCon ( TyCon )
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
import FiniteMap
-import Outputable
import Unique ( Unique, Uniquable(..), unboundKey )
import UniqFM ( listToUFM, plusUFM_C )
import Maybes ( maybeToBool )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Pretty
-import Outputable ( PprStyle(..) )
-import Util --( panic, removeDups, pprTrace, assertPanic )
+import Outputable ( Outputable(..), PprStyle(..) )
+import Util ( Ord3(..), panic, removeDups, pprTrace, assertPanic )
\end{code}
@@ -50,8 +49,8 @@ import Util --( panic, removeDups, pprTrace, assertPanic )
%*********************************************************
\begin{code}
-newGlobalName :: Module -> OccName -> RnM s d Name
-newGlobalName mod occ
+newGlobalName :: Module -> OccName -> IfaceFlavour -> RnM s d Name
+newGlobalName mod occ iface_flavour
= -- First check the cache
getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
let key = (mod,occ) in
@@ -63,12 +62,12 @@ newGlobalName mod occ
Just name -> returnRn name
-- Miss in the cache, so build a new original name,
- -- and put it in the cache
+ -- And put it in the cache
Nothing ->
let
(us', us1) = splitUniqSupply us
uniq = getUnique us1
- name = mkGlobalName uniq mod occ VanillaDefn Implicit
+ name = mkGlobalName uniq mod occ (Implicit iface_flavour)
cache' = addToFM cache key name
in
setNameSupplyRn (us', inst_ns, cache') `thenRn_`
@@ -110,30 +109,12 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc
key = (mod,occ)
new_name = case lookupFM cache key of
Just name -> setNameProvenance name provenance
- other -> mkGlobalName uniq mod occ VanillaDefn provenance
+ other -> mkGlobalName uniq mod occ provenance
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
returnRn new_name
--- newSysName is used to create the names for
--- a) default methods
--- These are never mentioned explicitly in source code (hence no point in looking
--- them up in the NameEnv), but when reading an interface file
--- we may want to slurp in their pragma info. In the source file itself we
--- need to create these names too so that we export them into the inferface file for this module.
-
-newSysName :: OccName -> ExportFlag -> SrcLoc -> RnMS s Name
-newSysName occ export_flag loc
- = getModeRn `thenRn` \ mode ->
- getModuleRn `thenRn` \ mod_name ->
- case mode of
- SourceMode -> newLocallyDefinedGlobalName
- mod_name occ
- (\_ -> export_flag)
- loc
- InterfaceMode _ -> newGlobalName mod_name occ
-
-- newDfunName is a variant, specially for dfuns.
-- When renaming derived definitions we are in *interface* mode (because we can trip
-- over original names), but we still want to make the Dfun locally-defined.
@@ -150,7 +131,7 @@ newDfunName Nothing src_loc -- Local instance decls have a "Nothing"
newDfunName (Just n) src_loc -- Imported ones have "Just n"
= getModuleRn `thenRn` \ mod_name ->
- newGlobalName mod_name (rdrNameOcc n)
+ newGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
@@ -236,6 +217,13 @@ checkDupNames doc_str rdr_names_w_loc
returnRn ()
where
(_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc
+
+
+-- Yuk!
+ifaceFlavour name = case getNameProvenance name of
+ Imported _ _ hif -> hif
+ Implicit hif -> hif
+ other -> HiFile -- Shouldn't happen
\end{code}
@@ -267,13 +255,13 @@ lookupRn name_env rdr_name
InterfaceMode _ ->
case rdr_name of
- Qual mod_name occ -> newGlobalName mod_name occ
+ Qual mod_name occ hif -> newGlobalName mod_name occ hif
-- An Unqual is allowed; interface files contain
-- unqualified names for locally-defined things, such as
-- constructors of a data type.
Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
- newGlobalName mod_name occ
+ newGlobalName mod_name occ HiFile
lookupBndrRn rdr_name
@@ -317,8 +305,8 @@ lookupGlobalOccRn rdr_name
-- The name cache should have the correct provenance, though.
lookupImplicitOccRn :: RdrName -> RnMS s Name
-lookupImplicitOccRn (Qual mod occ)
- = newGlobalName mod occ `thenRn` \ name ->
+lookupImplicitOccRn (Qual mod occ hif)
+ = newGlobalName mod occ hif `thenRn` \ name ->
addOccurrenceName name
addImplicitOccRn :: Name -> RnMS s Name
@@ -372,9 +360,10 @@ addOneToNameEnv env rdr_name name
-> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
returnRn env
- Nothing -> returnRn (addToFM env rdr_name name)
+ other -> returnRn (addToFM env rdr_name name)
-conflicting_name n1 n2 = (n1 /= n2) || (isLocallyDefinedName n1 && isLocallyDefinedName n2)
+conflicting_name n1 n2 = (n1 /= n2) ||
+ (isLocallyDefinedName n1 && isLocallyDefinedName n2)
-- We complain of a conflict if one RdrName maps to two different Names,
-- OR if one RdrName maps to the same *locally-defined* Name. The latter
-- case is to catch two separate, local definitions of the same thing.
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 362a810c8d8b2286750345e17202eb2a2405e97f..9768563c88ec444ca2e02fadfe92b2020bbe1621 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -16,7 +16,7 @@ import HsPragmas
#endif
import Id ( GenId, SYN_IE(Id) )
-import BasicTypes ( NewOrData )
+import BasicTypes ( NewOrData, IfaceFlavour )
import Name ( Name )
import Outputable ( PprStyle(..), Outputable(..){-instance * []-} )
import PprType ( GenType, GenTyVar, TyCon )
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index d9812cdc4d46876b88a2c9d95130c1f1e51422d8..43ed0fd25db7af846393773c8fda07135041d3a1 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -35,11 +35,11 @@ import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, HsExpr, Sig(..),
IE(..), hsDeclName
)
import HsPragmas ( noGenPragmas )
-import BasicTypes ( SYN_IE(Version), NewOrData(..) )
+import BasicTypes ( SYN_IE(Version), NewOrData(..), IfaceFlavour(..) )
import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameTyDecl),
RdrName, rdrNameOcc
)
-import RnEnv ( newGlobalName, addImplicitOccsRn,
+import RnEnv ( newGlobalName, addImplicitOccsRn, ifaceFlavour,
availName, availNames, addAvailToNameSet, pprAvail
)
import RnSource ( rnHsSigType )
@@ -93,8 +93,8 @@ getRnStats :: [RenamedHsDecl] -> RnMG Doc
getRnStats all_decls
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names (unslurped_insts,_) deferred_data_decls inst_mods = ifaces
- n_mods = sizeFM mod_vers_map
+ Ifaces this_mod mod_map decls_fm all_names imp_names (unslurped_insts,_) deferred_data_decls inst_mods = ifaces
+ n_mods = sizeFM mod_map
decls_imported = filter is_imported_decl all_decls
decls_read = [decl | (name, (_, avail, decl)) <- fmToList decls_fm,
@@ -166,31 +166,32 @@ count_decls decls
%*********************************************************
\begin{code}
-loadInterface :: Doc -> Module -> Bool -> RnMG Ifaces
+loadInterface :: Doc -> Module -> IfaceFlavour -> RnMG Ifaces
loadInterface doc_str load_mod as_source
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls
+ Ifaces this_mod mod_map decls
all_names imp_names (insts, tycls_names)
deferred_data_decls inst_mods = ifaces
in
-- CHECK WHETHER WE HAVE IT ALREADY
- if maybeToBool (lookupFM export_envs load_mod)
- then
- returnRn ifaces -- Already in the cache; don't re-read it
- else
+ case lookupFM mod_map load_mod of {
+ Just (hif, _, _, _) | hif `as_good_as` as_source
+ -> -- Already in the cache; don't re-read it
+ returnRn ifaces ;
+ other ->
-- READ THE MODULE IN
- findAndReadIface doc_str load_mod `thenRn` \ read_result ->
+ findAndReadIface doc_str load_mod as_source `thenRn` \ read_result ->
case read_result of {
-- Check for not found
Nothing -> -- Not found, so add an empty export env to the Ifaces map
-- so that we don't look again
let
- new_export_envs = addToFM export_envs load_mod ([],[])
- new_ifaces = Ifaces this_mod mod_vers_map
- new_export_envs
- decls all_names imp_names (insts, tycls_names) deferred_data_decls inst_mods
+ new_mod_map = addToFM mod_map load_mod (HiFile, 0, [],[])
+ new_ifaces = Ifaces this_mod new_mod_map
+ decls all_names imp_names (insts, tycls_names)
+ deferred_data_decls inst_mods
in
setIfacesRn new_ifaces `thenRn_`
failWithRn new_ifaces (noIfaceErr load_mod) ;
@@ -199,18 +200,17 @@ loadInterface doc_str load_mod as_source
Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) ->
-- LOAD IT INTO Ifaces
- mapRn loadExport exports `thenRn` \ avails_s ->
+ mapRn (loadExport as_source) exports `thenRn` \ avails_s ->
foldlRn (loadDecl load_mod as_source) decls rd_decls `thenRn` \ new_decls ->
foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts ->
let
- export_env = (concat avails_s, fixs)
+ mod_details = (as_source, mod_vers, concat avails_s, fixs)
-- Exclude this module from the "special-inst" modules
new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
new_ifaces = Ifaces this_mod
- (addToFM mod_vers_map load_mod mod_vers)
- (addToFM export_envs load_mod export_env)
+ (addToFM mod_map load_mod mod_details)
new_decls
all_names imp_names
(new_insts, tycls_names)
@@ -219,29 +219,29 @@ loadInterface doc_str load_mod as_source
in
setIfacesRn new_ifaces `thenRn_`
returnRn new_ifaces
- }
+ }}
+
+as_good_as HiFile any = True
+as_good_as any HiBootFile = True
+as_good_as _ _ = False
+
-loadExport :: ExportItem -> RnMG [AvailInfo]
-loadExport (mod, entities)
+loadExport :: IfaceFlavour -> ExportItem -> RnMG [AvailInfo]
+loadExport as_source (mod, hif, entities)
= mapRn load_entity entities
where
- new_name occ = newGlobalName mod occ
+ new_name occ = newGlobalName mod occ hif
--- The communcation between this little code fragment and the "entity" rule
--- in ParseIface.y is a bit gruesome. The idea is that things which are
--- destined to be AvailTCs show up as (occ, [non-empty-list]), whereas
--- things destined to be Avails show up as (occ, [])
-
- load_entity (occ, occs)
+ load_entity (Avail occ)
+ = new_name occ `thenRn` \ name ->
+ returnRn (Avail name)
+ load_entity (AvailTC occ occs)
= new_name occ `thenRn` \ name ->
- if null occs then
- returnRn (Avail name)
- else
- mapRn new_name occs `thenRn` \ names ->
- returnRn (AvailTC name names)
+ mapRn new_name occs `thenRn` \ names ->
+ returnRn (AvailTC name names)
loadDecl :: Module
- -> Bool
+ -> IfaceFlavour
-> DeclsMap
-> (Version, RdrNameHsDecl)
-> RnMG DeclsMap
@@ -265,11 +265,14 @@ loadDecl mod as_source decls_map (version, decl)
-}
decl' =
case decl of
- SigD (IfaceSig name tp ls loc) | as_source || opt_IgnoreIfacePragmas ->
+ SigD (IfaceSig name tp ls loc) | from_hi_boot || opt_IgnoreIfacePragmas ->
SigD (IfaceSig name tp [] loc)
_ -> decl
- new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)
+ new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name) as_source
+ from_hi_boot = case as_source of
+ HiBootFile -> True
+ other -> False
loadInstDecl :: Module
-> Bag IfaceInst
@@ -310,7 +313,9 @@ loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_lo
\begin{code}
checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile
checkUpToDate mod_name
- = findAndReadIface doc_str mod_name `thenRn` \ read_result ->
+ = findAndReadIface doc_str mod_name HiFile `thenRn` \ read_result ->
+
+ -- CHECK WHETHER WE HAVE IT ALREADY
case read_result of
Nothing -> -- Old interface file not found, so we'd better bail out
traceRn (sep [ptext SLIT("Didnt find old iface"),
@@ -326,16 +331,17 @@ checkUpToDate mod_name
checkModUsage [] = returnRn True -- Yes! Everything is up to date!
-checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
- = loadInterface doc_str mod False{-not as source-} `thenRn` \ ifaces ->
+checkModUsage ((mod, hif, old_mod_vers, old_local_vers) : rest)
+ = loadInterface doc_str mod hif `thenRn` \ ifaces ->
let
- Ifaces _ mod_vers _ decls _ _ _ _ _ = ifaces
- maybe_new_mod_vers = lookupFM mod_vers mod
- Just new_mod_vers = maybe_new_mod_vers
+ Ifaces _ mod_map decls _ _ _ _ _ = ifaces
+ maybe_new_mod_vers = lookupFM mod_map mod
+ Just (_, new_mod_vers, _, _) = maybe_new_mod_vers
in
-- If we can't find a version number for the old module then
-- bail out saying things aren't up to date
if not (maybeToBool maybe_new_mod_vers) then
+ traceRn (sep [ptext SLIT("Can't find version number for module"), pprModule PprDebug mod]) `thenRn_`
returnRn False
else
@@ -361,7 +367,7 @@ checkEntityUsage mod decls []
= returnRn True -- Yes! All up to date!
checkEntityUsage mod decls ((occ_name,old_vers) : rest)
- = newGlobalName mod occ_name `thenRn` \ name ->
+ = newGlobalName mod occ_name HiFile {- ?? -} `thenRn` \ name ->
case lookupFM decls name of
Nothing -> -- We used it before, but it ain't there now
@@ -393,7 +399,7 @@ importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
importDecl name necessity
= checkSlurped name `thenRn` \ already_slurped ->
if already_slurped then
- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_`
+-- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_`
returnRn Nothing -- Already dealt with
else
if isWiredInName name then
@@ -401,7 +407,7 @@ importDecl name necessity
else
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces
+ Ifaces this_mod _ _ _ _ _ _ _ = ifaces
mod = nameModule name
in
if mod == this_mod then -- Don't bring in decls from
@@ -415,8 +421,8 @@ importDecl name necessity
\begin{code}
getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
getNonWiredInDecl needed_name necessity
- = traceRn doc_str `thenRn_`
- loadInterface doc_str mod False{-not as source -} `thenRn` \ (Ifaces _ _ _ decls _ _ _ _ _) ->
+ = traceRn doc_str `thenRn_`
+ loadInterface doc_str mod (ifaceFlavour needed_name) `thenRn` \ (Ifaces _ _ decls _ _ _ _ _) ->
case lookupFM decls needed_name of
-- Special case for data/newtype type declarations
@@ -441,6 +447,7 @@ getNonWiredInDecl needed_name necessity
is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
is_data_or_newtype other = False
+
\end{code}
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
@@ -495,7 +502,7 @@ getWiredInDecl name necessity
(if not main_is_tc || mod == gHC__ then
returnRn ()
else
- loadInterface doc_str mod False{-not as source-} `thenRn_`
+ loadInterface doc_str mod (ifaceFlavour main_name) `thenRn_`
returnRn ()
) `thenRn_`
@@ -520,10 +527,11 @@ getWiredInDecl name necessity
get_wired_id id
- = addImplicitOccsRn (nameSetToList id_mentioned) `thenRn_`
+ = addImplicitOccsRn id_mentions `thenRn_`
returnRn (Avail (getName id))
where
- id_mentioned = namesOfType (idType id)
+ id_mentions = nameSetToList (namesOfType ty)
+ ty = idType id
get_wired_tycon tycon
| isSynTyCon tycon
@@ -553,17 +561,17 @@ get_wired_tycon tycon
%*********************************************************
\begin{code}
-getInterfaceExports :: Module -> Bool -> RnMG (Avails, [(OccName,Fixity)])
+getInterfaceExports :: Module -> IfaceFlavour -> RnMG (Avails, [(OccName,Fixity)])
getInterfaceExports mod as_source
- = loadInterface doc_str mod as_source `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _ _) ->
- case lookupFM export_envs mod of
+ = loadInterface doc_str mod as_source `thenRn` \ (Ifaces _ mod_map _ _ _ _ _ _) ->
+ case lookupFM mod_map mod of
Nothing -> -- Not there; it must be that the interface file wasn't found;
-- the error will have been reported already.
-- (Actually loadInterface should put the empty export env in there
-- anyway, but this does no harm.)
returnRn ([],[])
- Just stuff -> returnRn stuff
+ Just (_, _, avails, fixities) -> returnRn (avails, fixities)
where
doc_str = sep [pprModule PprDebug mod, ptext SLIT("is directly imported")]
\end{code}
@@ -603,8 +611,8 @@ getNonWiredDataDecl needed_name
= -- Need the type constructor; so put it in the deferred set for now
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
- new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
+ Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
no_constr_ty_decl = TyData new_or_data [] tycon tyvars [] derivings pragmas src_loc
new_deferred_data_decls = addToFM deferred_data_decls tycon_name no_constr_ty_decl
@@ -621,8 +629,8 @@ getNonWiredDataDecl needed_name
= -- Need a data constructor, so delete the data decl from the deferred set if it's there
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
- new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
+ Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
new_deferred_data_decls = delFromFM deferred_data_decls tycon_name
in
@@ -633,7 +641,7 @@ getNonWiredDataDecl needed_name
\begin{code}
getDeferredDataDecls :: RnMG [(Name, RdrNameTyDecl)]
getDeferredDataDecls
- = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ _ _ _ deferred_data_decls _) ->
+ = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ _ _ deferred_data_decls _) ->
let
deferred_list = fmToList deferred_data_decls
trace_msg = hang (text "Slurping abstract data/newtype decls for: ")
@@ -662,7 +670,7 @@ getImportedInstDecls
-- removing them from the bag kept in Ifaces
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
+ Ifaces this_mod mod_map decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
-- An instance decl is ungated if all its gates have been slurped
select_ungated :: IfaceInst -- A gated inst decl
@@ -682,7 +690,7 @@ getImportedInstDecls
(un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts
- new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names
+ new_ifaces = Ifaces this_mod mod_map decls slurped_names imp_names
((listToBag still_gated_insts), tycls_names)
-- NB: don't throw away tycls_names; we may comre across more instance decls
deferred_data_decls
@@ -692,7 +700,7 @@ getImportedInstDecls
setIfacesRn new_ifaces `thenRn_`
returnRn un_gated_insts
where
- load_it mod = loadInterface (doc_str mod) mod False{- not as source-}
+ load_it mod = loadInterface (doc_str mod) mod HiFile
doc_str mod = sep [pprModule PprDebug mod, ptext SLIT("is a special-instance module")]
@@ -700,7 +708,7 @@ getSpecialInstModules :: RnMG [Module]
getSpecialInstModules
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ _ _ _ _ _ _ _ inst_mods = ifaces
+ Ifaces _ _ _ _ _ _ _ inst_mods = ifaces
in
returnRn inst_mods
\end{code}
@@ -757,8 +765,7 @@ getImportVersions :: Module -- Name of this module
getImportVersions this_mod exports
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ mod_versions_map _ _ _ imp_names _ _ _ = ifaces
- mod_version mod = expectJust "import_versions" (lookupFM mod_versions_map mod)
+ Ifaces _ mod_map _ _ imp_names _ _ _ = ifaces
-- mv_map groups together all the things imported from a particular module.
mv_map, mv_map_mod :: FiniteMap Module [LocalVersion Name]
@@ -769,11 +776,12 @@ getImportVersions this_mod exports
mv_map = foldl add_mv mv_map_mod imp_names
-- mv_map adds the version numbers of things exported individually
- in
- returnRn [ (mod, mod_version mod, local_versions)
- | (mod, local_versions) <- fmToList mv_map
- ]
+ mk_version_info (mod, local_versions)
+ = case lookupFM mod_map mod of
+ Just (hif, version, _, _) -> (mod, hif, version, local_versions)
+ in
+ returnRn (map mk_version_info (fmToList mv_map))
where
export_mods = case exports of
Nothing -> []
@@ -789,25 +797,26 @@ getImportVersions this_mod exports
\begin{code}
checkSlurped name
- = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _ _) ->
+ = getIfacesRn `thenRn` \ (Ifaces _ _ _ slurped_names _ _ _ _) ->
returnRn (name `elemNameSet` slurped_names)
getSlurpedNames :: RnMG NameSet
getSlurpedNames
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ _ _ _ slurped_names _ _ _ _ = ifaces
+ Ifaces _ _ _ slurped_names _ _ _ _ = ifaces
in
returnRn slurped_names
recordSlurp maybe_version necessity avail
- = traceRn (hsep [text "Record slurp:", pprAvail (PprForUser opt_PprUserLength) avail,
+ = {- traceRn (hsep [text "Record slurp:", pprAvail (PprForUser opt_PprUserLength) avail,
-- NB PprForDebug prints export flag, which is too
-- strict; it's a knot-tied thing in RnNames
- case necessity of {Compulsory -> text "comp"; Optional -> text "opt"}]) `thenRn_`
+ case necessity of {Compulsory -> text "comp"; Optional -> text "opt" } ]) `thenRn_`
+ -}
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
+ Ifaces this_mod mod_map decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
new_slurped_names = addAvailToNameSet slurped_names avail
new_imp_names = case maybe_version of
@@ -823,7 +832,7 @@ recordSlurp maybe_version necessity avail
-> tycls_names `addOneToNameSet` tc
otherwise -> tycls_names
- new_ifaces = Ifaces this_mod mod_vers export_envs decls
+ new_ifaces = Ifaces this_mod mod_map decls
new_slurped_names
new_imp_names
(insts, new_tycls_names)
@@ -901,17 +910,29 @@ getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
%*********************************************************
\begin{code}
-findAndReadIface :: Doc -> Module -> RnMG (Maybe ParsedIface)
+findAndReadIface :: Doc -> Module
+ -> IfaceFlavour
+ -> RnMG (Maybe ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-findAndReadIface doc_str filename
+findAndReadIface doc_str mod_name as_source
= traceRn trace_msg `thenRn_`
getSearchPathRn `thenRn` \ dirs ->
try dirs dirs
where
- trace_msg = hang (hcat [ptext SLIT("Reading interface for "),
- ptext filename, semi])
- 4 (hcat [ptext SLIT("reason: "), doc_str])
+ trace_msg = sep [hsep [ptext SLIT("Reading"),
+ case as_source of { HiBootFile -> ptext SLIT("[boot]"); other -> empty},
+ ptext SLIT("interface for"),
+ ptext mod_name,
+ semi],
+ nest 4 (ptext SLIT("reason:") <> doc_str)]
+
+ -- For import {-# SOURCE #-} Foo, "as_source" will be True
+ -- and we read Foo.hi-boot, not Foo.hi. This is used to break
+ -- loops among modules.
+ boot_suffix = case as_source of
+ HiBootFile -> "-boot"
+ HiFile -> ""
try all_dirs [] = traceRn (ptext SLIT("...failed")) `thenRn_`
returnRn Nothing
@@ -923,7 +944,7 @@ findAndReadIface doc_str filename
Just iface -> traceRn (ptext SLIT("...done")) `thenRn_`
returnRn (Just iface)
where
- file_path = dir ++ '/':moduleString filename ++ hisuf
+ file_path = dir ++ '/' : moduleString mod_name ++ hisuf ++ boot_suffix
\end{code}
@readIface@ trys just one file.
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index dcdc7186fecc2ee6adb81c0f16f0d307eb2685e0..c824df5b2575114aab1987acdca10392f12bbcf8 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -196,12 +196,14 @@ type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" e
-- not constructors (see defn of availEntityNames)
-data AvailInfo = NotAvailable
- | Avail Name -- An ordinary identifier
- | AvailTC Name -- The name of the type or class
- [Name] -- The available pieces of type/class. NB: If the type or
+data GenAvailInfo name = NotAvailable
+ | Avail name -- An ordinary identifier
+ | AvailTC name -- The name of the type or class
+ [name] -- The available pieces of type/class. NB: If the type or
-- class is itself to be in scope, it must be in this list.
-- Thus, typically: AvailTC Eq [Eq, ==, /=]
+type AvailInfo = GenAvailInfo Name
+type RdrAvailInfo = GenAvailInfo OccName
\end{code}
===================================================
@@ -209,9 +211,9 @@ data AvailInfo = NotAvailable
===================================================
\begin{code}
-type ExportItem = (Module, [(OccName, [OccName])])
+type ExportItem = (Module, IfaceFlavour, [RdrAvailInfo])
type VersionInfo name = [ImportVersion name]
-type ImportVersion name = (Module, Version, [LocalVersion name])
+type ImportVersion name = (Module, IfaceFlavour, Version, [LocalVersion name])
type LocalVersion name = (name, Version)
data ParsedIface
@@ -233,9 +235,11 @@ type RdrNamePragma = () -- Fudge for now
-------------------
data Ifaces = Ifaces
- Module -- Name of this module
- (FiniteMap Module Version)
- (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports
+ Module -- Name of this module
+ (FiniteMap Module (IfaceFlavour, -- Exports
+ Version,
+ Avails,
+ [(OccName,Fixity)]))
DeclsMap
NameSet -- All the names (whether "big" or "small", whether wired-in or not,
@@ -308,7 +312,7 @@ initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
emptyIfaces :: Module -> Ifaces
-emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM []
+emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM []
builtins :: FiniteMap (Module,OccName) Name
builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 4e745f192a523f80739c7f1a7da433c88a62d9f5..c6ca4822ae145723c9827b54980d79e7e924a8bc 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -24,6 +24,7 @@ import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), SYN_IE(RdrNameI
)
import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate, recordSlurp )
+import BasicTypes ( IfaceFlavour(..) )
import RnEnv
import RnMonad
import FiniteMap
@@ -110,7 +111,7 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
| otherwise = [ImportDecl pRELUDE
False {- Not qualified -}
- False {- Not source imported -}
+ HiFile {- Not source imported -}
Nothing {- No "as" -}
Nothing {- No import list -}
mod_loc]
@@ -129,7 +130,7 @@ checkEarlyExit mod
traceRn (text "Considering whether compilation is required...") `thenRn_`
(if not opt_SourceUnchanged then
-- Source code changed and no errors yet... carry on
- traceRn (nest 4 (text "source file changed")) `thenRn_`
+ traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_`
returnRn False
else
-- Unchanged source, and no errors yet; see if usage info
@@ -167,8 +168,9 @@ importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc
set_avail_prov NotAvailable = NotAvailable
set_avail_prov (Avail n) = Avail (set_name_prov n)
set_avail_prov (AvailTC n ns) = AvailTC (set_name_prov n) (map set_name_prov ns)
- set_name_prov name = setNameProvenance name provenance
- provenance = Imported mod loc
+ set_name_prov name | isWiredInName name = name
+ | otherwise = setNameProvenance name provenance
+ provenance = Imported mod loc as_source
\end{code}
@@ -302,7 +304,7 @@ qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) h
Just another_name -> another_name
add_avail env avail = foldlRn add_name env (availNames avail)
- add_name env name = add qual_imp env (Qual qual_mod occ) `thenRn` \ env1 ->
+ add_name env name = add qual_imp env (Qual qual_mod occ err_hif) `thenRn` \ env1 ->
add unqual_imp env1 (Unqual occ)
where
add False env rdr_name = returnRn env
@@ -316,20 +318,22 @@ qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) h
add_fixity name_env fix_env (occ_name, (fixity, provenance))
= add qual $ add unqual $ fix_env
where
- qual = Qual qual_mod occ_name
+ qual = Qual qual_mod occ_name err_hif
unqual = Unqual occ_name
add rdr_name fix_env | maybeToBool (lookupFM name_env rdr_name)
= addOneToFixityEnv fix_env rdr_name (fixity,provenance)
| otherwise
= fix_env
+
+err_hif = error "qualifyImports: hif" -- Not needed in key to mapping
\end{code}
unQualify adds an Unqual binding for every existing Qual binding.
\begin{code}
unQualify :: FiniteMap RdrName elt -> FiniteMap RdrName elt
-unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ, elt) <- fmToList fm]
+unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ _, elt) <- fmToList fm]
\end{code}
%************************************************************************
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index a40921fb38cca489e74ef26b4713ab73502199f4..817b3a6de8e215d9cb2d5b79827897bd7d0ac4ed 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -14,11 +14,12 @@ IMP_Ubiq()
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
#else
-import {-# SOURCE #-} RnExpr
+import RnExpr
+--import {-# SOURCE #-} RnExpr
#endif
import HsSyn
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import HsPragmas
import HsTypes ( getTyVarName )
import RdrHsSyn
@@ -28,14 +29,15 @@ import CmdLineOpts ( opt_IgnoreIfacePragmas )
import RnBinds ( rnTopBinds, rnMethodBinds )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
- newSysName, newDfunName, checkDupOrQualNames, checkDupNames,
+ newDfunName, checkDupOrQualNames, checkDupNames,
+ newLocallyDefinedGlobalName, newGlobalName, ifaceFlavour,
listType_RDR, tupleType_RDR )
import RnMonad
import Name ( Name, isLocallyDefined,
OccName(..), occNameString, prefixOccName,
ExportFlag(..),
- Provenance,
+ Provenance(..), getNameProvenance,
SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
elemNameSet
)
@@ -156,18 +158,19 @@ original names, reporting any unknown names.
\begin{code}
rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
= pushSrcLocRn src_loc $
+
bindTyVarsRn cls_doc [tyvar] ( \ [tyvar'] ->
rnContext context `thenRn` \ context' ->
lookupBndrRn cname `thenRn` \ cname' ->
-- Check the signatures
- checkDupOrQualNames sig_doc sig_names `thenRn_`
- mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
+ mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
returnRn (tyvar', context', cname', sigs')
) `thenRn` \ (tyvar', context', cname', sigs') ->
-- Check the methods
- checkDupOrQualNames meth_doc meth_names `thenRn_`
+ checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
-- Typechecker is responsible for checking that we only
@@ -182,22 +185,36 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
sig_doc sty = text "the signatures for class" <+> ppr sty cname
meth_doc sty = text "the default-methods for class" <+> ppr sty cname
- sig_names = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
- meth_names = bagToList (collectMonoBinders mbinds)
+ sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
+ meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
+ meth_rdr_names = map fst meth_rdr_names_w_locs
- rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn)
+ rn_op clas clas_tyvar sig@(ClassOpSig op maybe_dm ty locn)
= pushSrcLocRn locn $
lookupBndrRn op `thenRn` \ op_name ->
rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty ->
- -- Call up interface info for default method, if such info exists
+ -- Make the default-method name
let
dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
in
- newSysName dm_occ Exported locn `thenRn` \ dm_name ->
- setModeRn (InterfaceMode Optional) (
- addOccurrenceName dm_name
- ) `thenRn_`
+ getModuleRn `thenRn` \ mod_name ->
+ getModeRn `thenRn` \ mode ->
+ (case (mode, maybe_dm) of
+ (SourceMode, _) | op `elem` meth_rdr_names
+ -> -- There's an explicit method decl
+ newLocallyDefinedGlobalName mod_name dm_occ
+ (\_ -> Exported) locn `thenRn` \ dm_name ->
+ returnRn (Just dm_name)
+
+ (InterfaceMode _, Just _)
+ -> -- Imported class that has a default method decl
+ newGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name ->
+ addOccurrenceName dm_name `thenRn_`
+ returnRn (Just dm_name)
+
+ other -> returnRn Nothing
+ ) `thenRn` \ maybe_dm_name ->
-- Checks.....
let
@@ -213,7 +230,7 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
(classTyVarNotInOpTyErr clas_tyvar sig)
`thenRn_`
- returnRn (ClassOpSig op_name dm_name new_ty locn)
+ returnRn (ClassOpSig op_name maybe_dm_name new_ty locn)
\end{code}
@@ -547,18 +564,17 @@ rnIdInfo (HsFBType fb) = returnRn (HsFBType fb)
rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
rnIdInfo (HsDeforest df) = returnRn (HsDeforest df)
-rnStrict (StrictnessInfo demands (Just (worker,cons)))
+rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-- The sole purpose of the "cons" field is so that we can mark the constructors
-- needed to build the wrapper as "needed", so that their data type decl will be
-- slurped in. After that their usefulness is o'er, so we just put in the empty list.
= lookupOccRn worker `thenRn` \ worker' ->
mapRn lookupOccRn cons `thenRn_`
- returnRn (StrictnessInfo demands (Just (worker',[])))
+ returnRn (HsStrictnessInfo demands (Just (worker',[])))
-- Boring, but necessary for the type checker.
-rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing)
-rnStrict BottomGuaranteed = returnRn BottomGuaranteed
-rnStrict NoStrictnessInfo = returnRn NoStrictnessInfo
+rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
+rnStrict HsBottom = returnRn HsBottom
\end{code}
UfCore expressions.
@@ -706,10 +722,10 @@ classTyVarNotInOpTyErr clas_tyvar sig sty
4 (ppr sty sig)
dupClassAssertWarn ctxt ((clas,ty) : dups) sty
- = hang (hcat [ptext SLIT("Duplicated class assertion"),
- pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty,
- ptext SLIT("in context:")])
- 4 (pprContext sty ctxt)
+ = sep [hsep [ptext SLIT("Duplicated class assertion"),
+ pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty,
+ ptext SLIT("in context:")],
+ nest 4 (pprQuote sty $ \ sty -> pprContext sty ctxt)]
badDataCon name sty
= hsep [ptext SLIT("Illegal data constructor name"), ppr sty name]
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index a05f907e820c6b721812f25276eaf67b95fa61cc..8bde1c9df868cbb0ccedda8eb6e7166106671a3e 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -26,7 +26,6 @@ import CoreSyn
import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) )
import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
idType, idUnique, SYN_IE(Id),
- isConstMethodId,
emptyIdSet, unionIdSets, mkIdSet,
unitIdSet, elementOfIdSet,
addOneToIdSet, SYN_IE(IdSet),
@@ -112,7 +111,8 @@ keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
keepBecauseConjurable :: OccEnv -> Id -> Bool
keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
- = keep_conjurable && isConstMethodId binder
+ = False
+ {- keep_conjurable && isConstMethodId binder -}
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage