From 68afb16743cafd5b7495771d359891c6dfc5a186 Mon Sep 17 00:00:00 2001 From: partain Date: Mon, 6 May 1996 11:02:12 +0000 Subject: [PATCH] [project @ 1996-05-06 11:01:29 by partain] SLPJ 1.3 changes through 960505 --- ghc/compiler/absCSyn/CLabel.lhs | 9 ++++- ghc/compiler/codeGen/CgBindery.lhs | 2 + ghc/compiler/coreSyn/CoreSyn.lhs | 6 +-- ghc/compiler/deSugar/DsBinds.lhs | 7 +++- ghc/compiler/deSugar/DsExpr.lhs | 6 ++- ghc/compiler/deSugar/DsListComp.lhs | 2 +- ghc/compiler/deSugar/Match.lhs | 2 +- ghc/compiler/deSugar/MatchLit.lhs | 6 ++- ghc/compiler/main/MkIface.lhs | 26 ++++++++++-- ghc/compiler/reader/PrefixToHs.lhs | 4 +- ghc/compiler/rename/ParseUtils.lhs | 3 +- ghc/compiler/rename/Rename.lhs | 4 +- ghc/compiler/rename/RnExpr.lhs | 7 +++- ghc/compiler/rename/RnIfaces.lhs | 73 ++++++++++++++++++++++++++-------- ghc/compiler/rename/RnNames.lhs | 26 +++++++----- ghc/compiler/simplCore/SimplCore.lhs | 3 +- ghc/compiler/simplStg/SimplStg.lhs | 3 +- ghc/compiler/utils/FiniteMap.lhs | 3 +- 18 files changed, 137 insertions(+), 55 deletions(-) diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index a6df009..74d2144 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -39,7 +39,10 @@ module CLabel ( needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel, - pprCLabel, pprCLabel_asm + pprCLabel +#if ! OMIT_NATIVE_CODEGEN + , pprCLabel_asm +#endif #ifdef GRAN , isSlowEntryCCodeBlock @@ -50,7 +53,9 @@ import Ubiq{-uitous-} import AbsCLoop ( CtrlReturnConvention(..), ctrlReturnConvAlg ) +#if ! OMIT_NATIVE_CODEGEN import NcgLoop ( underscorePrefix, fmtAsmLbl ) +#endif import CStrings ( pp_cSEP ) import Id ( externallyVisibleId, cmpId_withSpecDataCon, @@ -314,7 +319,9 @@ duplicate declarations in generating C (see @labelSeenTE@ in \begin{code} -- specialised for PprAsm: saves lots of arg passing in NCG +#if ! OMIT_NATIVE_CODEGEN pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) +#endif pprCLabel :: PprStyle -> CLabel -> Unpretty diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 8c5814a..534fa94 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -45,7 +45,9 @@ import Id ( idPrimRep, toplevelishId, isDataCon, ) import Maybes ( catMaybes ) import Name ( isLocallyDefined ) +#ifdef DEBUG import PprAbsC ( pprAmode ) +#endif import PprStyle ( PprStyle(..) ) import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) ) import Unpretty ( uppShow ) diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index c816aa1..49e6687 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -259,9 +259,9 @@ mkCoLetNoUnboxed bind@(NonRec binder rhs) body mkCoLetsNoUnboxed [] expr = expr mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds ---mkCoLetrecNoUnboxed :: [(Id, CoreExpr)] -- bindings --- -> CoreExpr -- body --- -> CoreExpr -- result +mkCoLetrecNoUnboxed :: [(GenId (GenType a b), GenCoreExpr (GenId (GenType a b)) c d e)] + -> GenCoreExpr (GenId (GenType a b)) c d e + -> GenCoreExpr (GenId (GenType a b)) c d e mkCoLetrecNoUnboxed [] body = body mkCoLetrecNoUnboxed binds body diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 41813e4..a4d6dda 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -16,9 +16,12 @@ import Ubiq import DsLoop -- break dsExpr-ish loop import HsSyn -- lots of things + hiding ( collectBinders{-also in CoreSyn-} ) import CoreSyn -- lots of things import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..), - TypecheckedBind(..), TypecheckedMonoBinds(..) ) + TypecheckedBind(..), TypecheckedMonoBinds(..), + TypecheckedPat(..) + ) import DsHsSyn ( collectTypedBinders, collectTypedPatBinders ) import DsMonad @@ -39,7 +42,7 @@ import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy, import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} ) import Util ( isIn, panic, pprTrace{-ToDo:rm-} ) import PprCore--ToDo:rm -import PprType--ToDo:rm +import PprType ( GenTyVar ) --ToDo:rm import Usage--ToDo:rm import Unique--ToDo:rm diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index db63f50..9030f94 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -14,7 +14,7 @@ import DsLoop -- partly to get dsBinds, partly to chk dsExpr import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), Match, Qual, HsBinds, Stmt, PolyType ) import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), - TypecheckedRecordBinds(..) + TypecheckedRecordBinds(..), TypecheckedPat(..) ) import CoreSyn @@ -22,7 +22,8 @@ import DsMonad import DsCCall ( dsCCall ) import DsListComp ( dsListComp ) import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, - mkErrorAppDs, showForErr + mkErrorAppDs, showForErr, EquationInfo, + MatchResult ) import Match ( matchWrapper ) @@ -38,6 +39,7 @@ import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv, ) import Literal ( mkMachInt, Literal(..) ) import MagicUFs ( MagicUnfoldingFun ) +import Name ( Name{--O only-} ) import PprStyle ( PprStyle(..) ) import PprType ( GenType ) import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon, diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 7b6651a..123a8f2 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -10,7 +10,7 @@ import Ubiq import DsLoop -- break dsExpr-ish loop import HsSyn ( Qual(..), HsExpr, HsBinds ) -import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) ) +import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) ) import DsHsSyn ( outPatType ) import CoreSyn diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 5f1b90d..5437929 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -12,7 +12,7 @@ import Ubiq import DsLoop -- here for paranoia-checking reasons -- and to break dsExpr/dsBinds-ish loop -import HsSyn +import HsSyn hiding ( collectBinders{-also from CoreSyn-} ) import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..), TypecheckedHsBinds(..), TypecheckedHsExpr(..) ) import DsHsSyn ( outPatType, collectTypedPatBinders ) diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 1ae29da..da0392e 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -13,8 +13,10 @@ import DsLoop -- break match-ish and dsExpr-ish loops import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo ) -import TcHsSyn ( TypecheckedHsExpr(..) ) -import CoreSyn ( CoreExpr(..) ) +import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), + TypecheckedPat(..) + ) +import CoreSyn ( CoreExpr(..), CoreBinding(..) ) import DsMonad import DsUtils diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 4891837..796d51d 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -24,6 +24,7 @@ import Bag ( emptyBag, snocBag, bagToList ) import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) ) import CmdLineOpts ( opt_ProduceHi ) import FieldLabel ( FieldLabel{-instance NamedThing-} ) +import FiniteMap ( fmToList ) import HsSyn import Id ( idType, dataConSig, dataConFieldLabels, dataConStrictMarks, StrictnessMark(..), @@ -128,15 +129,34 @@ endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl \begin{code} ifaceUsages Nothing{-no iface handle-} _ = return () -ifaceUsages (Just if_hdl) version_info - = hPutStr if_hdl "__usages__\nFoo 1" -- a stub, obviously +ifaceUsages (Just if_hdl) usages + | null usages_list + = return () + | otherwise + = hPutStr if_hdl "__usages__\n" >> + hPutStr if_hdl (ppShow 10000 (ppAboves (map pp_uses usages_list))) + where + usages_list = fmToList usages + + pp_uses (m, (mv, versions)) + = ppBesides [ppPStr m, ppSP, ppInt mv, ppPStr SLIT(" :: "), + pp_versions (fmToList versions), ppSemi] \end{code} \begin{code} ifaceVersions Nothing{-no iface handle-} _ = return () ifaceVersions (Just if_hdl) version_info - = hPutStr if_hdl "\n__versions__\nFoo 1" -- a stub, obviously + | null version_list + = return () + | otherwise + = hPutStr if_hdl "\n__versions__\n" >> + hPutStr if_hdl (ppShow 10000 (pp_versions version_list)) + where + version_list = fmToList version_info + +pp_versions nvs + = ppInterleave ppComma [ ppCat [ppPStr n, ppInt v] | (n,v) <- nvs ] \end{code} \begin{code} diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index 033ed41..c638ca2 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -28,7 +28,7 @@ import RdrHsSyn import HsPragmas ( noGenPragmas, noClassOpPragmas ) import SrcLoc ( mkSrcLoc2 ) -import Util ( panic, assertPanic ) +import Util ( mapAndUnzip, panic, assertPanic ) \end{code} %************************************************************************ @@ -154,7 +154,7 @@ cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn cvFunMonoBind sf matches = (head srcfuns, head infixdefs, cvMatches sf False matches) where - (srcfuns, infixdefs) = unzip (map get_mdef matches) + (srcfuns, infixdefs) = mapAndUnzip get_mdef matches -- ToDo: Check for consistent srcfun and infixdef get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs index 3d40da1..d095ce9 100644 --- a/ghc/compiler/rename/ParseUtils.lhs +++ b/ghc/compiler/rename/ParseUtils.lhs @@ -228,7 +228,8 @@ mk_inst ctxt clas mono_ty lexIface :: String -> [IfaceToken] lexIface str - = case str of + = _scc_ "Lexer" + case str of [] -> [] -- whitespace and comments diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c5d1811..780017a 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -81,7 +81,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) -- ]}) $ findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files -> - newVar (emptyFM, hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> + newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> let @@ -196,7 +196,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) \begin{code} {- TESTING: -pprPIface (ParsedIface m v mv usgs lcm exm ims lfx ltdm lvdm lids ldp) +pprPIface (ParsedIface m ?? v mv usgs lcm exm ims lfx ltdm lvdm lids ldp) = ppAboves [ ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v, case mv of { Nothing -> ppNil; Just n -> ppInt n }], diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 805a1dc..5f6790e 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -28,10 +28,11 @@ import RnMonad import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name ( isLocallyDefinedName, pprSym, Name, RdrName ) import Pretty -import UniqFM ( lookupUFM ) +import UniqFM ( lookupUFM, ufmToList{-ToDo:rm-} ) import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, - UniqSet(..) ) + UniqSet(..) + ) import Util ( Ord3(..), removeDups, panic ) \end{code} @@ -485,6 +486,7 @@ precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2) precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2) = lookupFixity op `thenRn` \ (op_fix, op_prec) -> lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) -> + -- pprTrace "precParse:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $ case cmp op1_prec op_prec of LT_ -> rearrange EQ_ -> case (op1_fix, op_fix) of @@ -534,6 +536,7 @@ data INFIX = INFIXL | INFIXR | INFIXN deriving Eq lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int) lookupFixity op = getExtraRn `thenRn` \ fixity_fm -> + -- pprTrace "lookupFixity:" (ppAboves [ppCat [pprUnique u, ppr PprDebug i_f] | (u,i_f) <- ufmToList fixity_fm]) $ case lookupUFM fixity_fm op of Nothing -> returnRn (INFIXL, 9) Just (InfixL _ n) -> returnRn (INFIXL, n) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 0f09497..97445c9 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -37,8 +37,9 @@ import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix ) import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, plusFM_C, eltsFM, - fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} +import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, + fmToList, delListFromFM, sizeFM, foldFM, unitFM, + plusFM_C, keysFM{-ToDo:rm-} ) import Maybes ( maybeToBool ) import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..) ) @@ -77,9 +78,9 @@ absolute-filename-for-that-interface. findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath) findHiFiles dirs sysdirs - = hPutStr stderr " findHiFiles " >> + = --hPutStr stderr " findHiFiles " >> do_dirs emptyFM (dirs ++ sysdirs) >>= \ result -> - hPutStr stderr " done\n" >> + --hPutStr stderr " done\n" >> return result where do_dirs env [] = return env @@ -88,7 +89,7 @@ findHiFiles dirs sysdirs do_dirs new_env dirs ------- do_dir env dir - = hPutStr stderr "D" >> + = --hPutStr stderr "D" >> getDirectoryContents dir >>= \ entries -> do_entries env entries where @@ -100,7 +101,7 @@ findHiFiles dirs sysdirs do_entry env e = case (acceptable_hi (reverse e)) of Nothing -> --trace ("Deemed uncool:"++e) $ - hPutStr stderr "." >> + --hPutStr stderr "." >> return env Just mod -> let @@ -108,12 +109,12 @@ findHiFiles dirs sysdirs in case (lookupFM env pmod) of Nothing -> --trace ("Adding "++mod++" -> "++e) $ - hPutStr stderr "!" >> + --hPutStr stderr "!" >> return (addToFM env pmod (dir ++ '/':e)) -- ToDo: use DIR_SEP, not / Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $ - hPutStr stderr "." >> + --hPutStr stderr "." >> return env ------- acceptable_hi rev_e -- looking at pathname *backwards* @@ -194,7 +195,7 @@ cachedIface want_orig_iface iface_cache mod where want_iface iface orig_fm | want_orig_iface - = case lookupFM orig_fm of + = case lookupFM orig_fm mod of Nothing -> Failed (noOrigIfaceErr mod) Just orig_iface -> Succeeded orig_iface | otherwise @@ -224,7 +225,7 @@ mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs where dup_merge str ppr_dup dup1 dup2 = pprTrace "mergeIfaces:" - (ppCat [ppPStr mod, ppPStr mod1, ppStr ": dup", ppStr str, ppStr "decl", + (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl", ppr_dup dup1, ppr_dup dup2]) $ dup2 @@ -312,14 +313,18 @@ readIface :: FilePath -> Module -> IO (MaybeErr ParsedIface Error) readIface file mod - = hPutStr stderr (" reading "++file) >> + = --hPutStr stderr (" reading "++file) >> readFile file `thenPrimIO` \ read_result -> case read_result of Left err -> return (Failed (cannaeReadErr file err)) - Right contents -> hPutStr stderr " parsing" >> + Right contents -> --hPutStr stderr " parsing" >> let parsed = parseIface contents in - hPutStr stderr " done\n" >> - return (Succeeded (init_merge mod parsed)) + --hPutStr stderr " done\n" >> + return ( + case parsed of + Failed _ -> parsed + Succeeded p -> Succeeded (init_merge mod p) + ) where init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags) = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags @@ -374,7 +379,7 @@ rnIfaces iface_cache imp_mods us -- finalize what we want to say we learned about the -- things we used - finalIfaceInfo iface_cache if_final_env if_instdecls {-all_imports_used imp_mods-} >>= + finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>= \ usage_stuff@(usage_info, version_info, instance_mods) -> return (HsModule modname iface_version exports imports fixities @@ -779,6 +784,7 @@ rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl \begin{code} finalIfaceInfo :: IfaceCache -- iface cache + -> Module -- this module's name -> RnEnv -> [RenamedInstDecl] -- -> [RnName] -- all imported names required @@ -787,14 +793,47 @@ finalIfaceInfo :: VersionsMap, -- info about version numbers [Module]) -- special instance modules -finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls +finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls = pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ -- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ -- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ + let + val_stuff@(val_usages, val_versions) + = foldFM process_item (emptyFM, emptyFM){-init-} qual - return (emptyFM, emptyFM, []) + (all_usages, all_versions) + = foldFM process_item val_stuff{-keep going-} tc_qual + in + return (all_usages, all_versions, []) + where + process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components + -> (UsagesMap, VersionsMap) -- input + -> (UsagesMap, VersionsMap) -- output + + process_item (n,m) rn as_before@(usages, versions) + | irrelevant rn + = as_before + | m == modname -- this module => add to "versions" + = (usages, addToFM versions n 1{-stub-}) + | otherwise -- from another module => add to "usages" + = (add_to_usages usages m n 1{-stub-}, versions) + + irrelevant (RnConstr _ _) = True -- We don't report these in their + irrelevant (RnField _ _) = True -- own right in usages/etc. + irrelevant (RnClassOp _ _) = True + irrelevant _ = False + + add_to_usages usages m n version + = addToFM usages m ( + case (lookupFM usages m) of + Nothing -> -- nothing for this module yet... + (1{-stub-}, unitFM n version) + + Just (mversion, mstuff) -> -- the "new" stuff will shadow the old + (mversion, addToFM mstuff n version) + ) \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index e106696..53d04e1 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -289,7 +289,7 @@ newGlobalName locn maybe_exp rdr Just exp -> exp Nothing -> exp_fn n - n = mkTopLevName uniq orig locn exp (occ_fn n) + n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s in addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_` addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_` @@ -363,6 +363,9 @@ doImportDecls iface_cache g_info us src_imps then [{- no "import Prelude" -}] else [ImportDecl pRELUDE False Nothing Nothing prel_loc] + prel_imps -- WDP: Just guessing on this defn... ToDo + = [ imp | imp@(ImportDecl mod _ _ _ _) <- the_imps, fromPrelude mod ] + prel_loc = mkBuiltinSrcLoc (uniq_imps, imp_dups) = removeDups cmp_mod the_imps @@ -431,15 +434,16 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) -> accumulate (map (checkOrigIE iface_cache) chk_ies) >>= \ chk_errs_warns -> - accumulate (map (getFixityDecl iface_cache) (bagToList ie_vals)) + let + final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals + final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs + in + accumulate (map (getFixityDecl iface_cache) (bagToList final_vals)) >>= \ fix_maybes_errs -> let (chk_errs, chk_warns) = unzip chk_errs_warns (fix_maybes, fix_errs) = unzip fix_maybes_errs - final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals - final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs - unquals = if qual then emptyBag else mapBag pair_as (ie_vals `unionBags` ie_tcs) @@ -511,16 +515,16 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec (vals, tcs, ies_left) = do_builtin ies -getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all +getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all = (map mkAllIE (eltsFM exps), [], emptyBag) -getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding +getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding = (map mkAllIE (eltsFM exps_left), found_ies, errs) where (found_ies, errs) = lookupIEs exps ies exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies) -getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these +getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these = (map fst found_ies, found_ies, errs) where (found_ies, errs) = lookupIEs exps ies @@ -617,7 +621,7 @@ with_decl iface_cache n do_err do_decl Succeeded decl -> return (do_decl decl) -getFixityDecl iface_cache rn +getFixityDecl iface_cache (_,rn) = let (mod, str) = moduleNamePair rn in @@ -625,7 +629,7 @@ getFixityDecl iface_cache rn case maybe_iface of Failed err -> return (Nothing, unitBag err) - Succeeded (ParsedIface _ _ _ _ _ _ _ fixes _ _ _ _) -> + Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) -> case lookupFM fixes str of Nothing -> return (Nothing, emptyBag) Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag) @@ -761,7 +765,7 @@ newImportedName tycon_or_class locn maybe_exp maybe_imp rdr (imp_flag, imp_locs) = imp_fn n - n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) + n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) -- NB: two "n"s in returnRn n \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index dffde6b..a58f126 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -89,8 +89,7 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do SpecialiseData) -- specialisation data core2core core_todos module_name ppr_style us local_tycons tycon_specs binds - = _scc_ "Core2Core" - if null core_todos then -- very rare, I suspect... + = if null core_todos then -- very rare, I suspect... -- well, we still must do some renumbering return ( (substCoreBindings nullIdEnv nullTyVarEnv binds us, diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 4335884..f0aa84f 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -53,8 +53,7 @@ stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do [CostCentre])) -- "extern" cost-centres stg2stg stg_todos module_name ppr_style us binds - = _scc_ "Stg2Stg" - case (splitUniqSupply us) of { (us4now, us4later) -> + = case (splitUniqSupply us) of { (us4now, us4later) -> (if do_verbose_stg2stg then hPutStr stderr "VERBOSE STG-TO-STG:\n" >> diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index 0b1e3d9..384a7d1 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -48,10 +48,11 @@ module FiniteMap ( plusFM, plusFM_C, minusFM, + foldFM, IF_NOT_GHC(intersectFM COMMA) IF_NOT_GHC(intersectFM_C COMMA) - IF_NOT_GHC(mapFM COMMA foldFM COMMA filterFM COMMA) + IF_NOT_GHC(mapFM COMMA filterFM COMMA) sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, -- 1.7.10.4