From 68afb16743cafd5b7495771d359891c6dfc5a186 Mon Sep 17 00:00:00 2001
From: partain <unknown>
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 a6df00937bfb..74d214424385 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 8c5814a7adba..534fa9499b76 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 c816aa1881ee..49e66879a54f 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 41813e44c5b7..a4d6dda09e6a 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 db63f509582b..9030f94c3499 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 7b6651a14e38..123a8f28f992 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 5f1b90d4a215..5437929a7bb0 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 1ae29da52d98..da0392e5c203 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 489183777ac3..796d51d0cbb8 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 033ed415f3fa..c638ca2f5239 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 3d40da13d287..d095ce9d434c 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 c5d18119d6e0..780017a985f2 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 805a1dc813c8..5f6790e11782 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 0f0949765ce6..97445c9c62e1 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 e106696413d2..53d04e1d0808 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 dffde6b86d62..a58f126ae8b2 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 4335884ad201..f0aa84fa3414 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 0b1e3d9f8bbf..384a7d122a64 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,
--
GitLab