From: sof Date: Sat, 5 Jul 1997 03:01:39 +0000 (+0000) Subject: [project @ 1997-07-05 02:55:34 by sof] X-Git-Tag: Approximately_1000_patches_recorded~258 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5f34bb74bf3c7e051bce8ad343ac4bbbc11f62cd;p=ghc-hetmet.git [project @ 1997-07-05 02:55:34 by sof] --- diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index f28f218..0dab797 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 f223311..2095524 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 52e0a18..53e81c7 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 b66a9e6..c808a8e 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 3e3a71b..f9cd0c9 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 3632ed3..e70cbbf 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 d91c711..ad57265 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 a984397..3536af8 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 9f4aa00..0539152 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 c14fa70..18ec5b6 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 9d26262..7bfff2a 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 850f042..9c8392e 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 56330d9..be2d3d1 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 28afe6e..86b2d4b 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 43abb70..a2534f3 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 362a810..9768563 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 d9812cd..43ed0fd 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 dcdc718..c824df5 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 4e745f1..c6ca482 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 a40921f..817b3a6 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 a05f907..8bde1c9 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