From 573ef10b2afd99d3c6a36370a9367609716c97d2 Mon Sep 17 00:00:00 2001
From: partain <unknown>
Date: Mon, 15 Jul 1996 11:34:07 +0000
Subject: [PATCH] [project @ 1996-07-15 11:32:34 by partain] partain changes to
960714
---
ghc/compiler/Jmakefile | 49 +++++++-----
ghc/compiler/basicTypes/Id.lhs | 10 +--
ghc/compiler/basicTypes/IdInfo.lhs | 2 +-
ghc/compiler/basicTypes/Name.lhs | 12 +--
ghc/compiler/basicTypes/SrcLoc.lhs | 2 +-
ghc/compiler/basicTypes/Unique.lhs | 4 -
ghc/compiler/codeGen/CgClosure.lhs | 55 +++++++------
ghc/compiler/codeGen/CgMonad.lhs | 8 +-
ghc/compiler/codeGen/ClosureInfo.lhs | 4 +-
ghc/compiler/coreSyn/CoreUnfold.lhs | 3 +-
ghc/compiler/coreSyn/PprCore.lhs | 36 ++++++++-
ghc/compiler/deSugar/DsBinds.lhs | 4 +-
ghc/compiler/hsSyn/HsCore.lhs | 2 +-
ghc/compiler/hsSyn/HsSyn.lhs | 71 -----------------
ghc/compiler/main/CmdLineOpts.lhs | 4 -
ghc/compiler/main/Main.lhs | 4 +-
ghc/compiler/main/MkIface.lhs | 114 +++++++++++++--------------
ghc/compiler/nativeGen/MachCode.lhs | 2 +-
ghc/compiler/nativeGen/PprMach.lhs | 36 ++++-----
ghc/compiler/parser/UgenAll.lhs | 45 -----------
ghc/compiler/parser/hschooks.c | 30 ++-----
ghc/compiler/prelude/PrelInfo.lhs | 78 ++++--------------
ghc/compiler/reader/ReadPrefix.lhs | 30 ++++++-
ghc/compiler/rename/ParseUtils.lhs | 4 +-
ghc/compiler/rename/Rename.lhs | 54 ++++++++-----
ghc/compiler/rename/RnBinds.lhs | 14 ++--
ghc/compiler/rename/RnIfaces.lhs | 22 ++----
ghc/compiler/rename/RnMonad.lhs | 5 +-
ghc/compiler/rename/RnNames.lhs | 109 +++++++++++++------------
ghc/compiler/rename/RnSource.lhs | 45 ++++++++---
ghc/compiler/rename/RnUtils.lhs | 83 ++++++++++++-------
ghc/compiler/simplCore/OccurAnal.lhs | 2 +-
ghc/compiler/simplCore/SimplVar.lhs | 2 +-
ghc/compiler/stgSyn/CoreToStg.lhs | 17 +++-
ghc/compiler/stranal/SaAbsInt.lhs | 2 +-
ghc/compiler/stranal/StrictAnal.lhs | 7 +-
ghc/compiler/stranal/WorkWrap.lhs | 11 +--
ghc/compiler/typecheck/TcModule.lhs | 56 +------------
ghc/compiler/typecheck/Unify.lhs | 8 +-
ghc/compiler/types/PprType.lhs | 30 ++++++-
ghc/compiler/types/TyCon.lhs | 10 +--
ghc/compiler/types/TyVar.lhs | 2 +-
ghc/compiler/types/Type.lhs | 24 +++---
ghc/compiler/utils/FiniteMap.lhs | 2 -
ghc/compiler/utils/Ubiq.lhi | 8 ++
ghc/compiler/utils/Ubiq_1_3.lhi | 2 +
ghc/compiler/utils/UniqFM.lhs | 4 -
ghc/compiler/utils/UniqSet.lhs | 3 -
ghc/compiler/utils/Unpretty.lhs | 2 +-
ghc/compiler/utils/Util.lhs | 1 +
50 files changed, 527 insertions(+), 607 deletions(-)
diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index 766582e6f209..aa105780b78a 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -37,7 +37,7 @@ SuffixRule_c_o()
*/
SUBDIR_LIST = \ /* here they are, colon separated (for mkdependHS) */
-utils:basicTypes:types:hsSyn:prelude:envs:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:parser
+utils:basicTypes:types:hsSyn:prelude:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:parser
#ifdef MainIncludeDir
MAIN_INCLUDE_DIR=MainIncludeDir
@@ -365,21 +365,21 @@ BACKSRCS_LHS NATIVEGEN_SRCS_LHS
# define loop_hi(f) CAT2(f,.hi)
#endif
-DELOOP_HIs = \
-utils/Ubiq.hi \
-absCSyn/AbsCLoop.hi \
-basicTypes/IdLoop.hi \
-codeGen/CgLoop1.hi \
-codeGen/CgLoop2.hi \
-deSugar/DsLoop.hi \
-hsSyn/HsLoop.hi \
-nativeGen/NcgLoop.hi \
-prelude/PrelLoop.hi \
-rename/RnLoop.hi \
-simplCore/SmplLoop.hi \
-typecheck/TcMLoop.hi \
-typecheck/TcLoop.hi \
-types/TyLoop.hi
+DELOOP_HIs = \
+loop_hi(utils/Ubiq) \
+loop_hi(absCSyn/AbsCLoop) \
+loop_hi(basicTypes/IdLoop) \
+loop_hi(codeGen/CgLoop1) \
+loop_hi(codeGen/CgLoop2) \
+loop_hi(deSugar/DsLoop) \
+loop_hi(hsSyn/HsLoop) \
+loop_hi(nativeGen/NcgLoop) \
+loop_hi(prelude/PrelLoop) \
+loop_hi(rename/RnLoop) \
+loop_hi(simplCore/SmplLoop) \
+loop_hi(typecheck/TcMLoop) \
+loop_hi(typecheck/TcLoop) \
+loop_hi(types/TyLoop)
/*
\
@@ -441,6 +441,10 @@ HC = $(GHC) /* uses the driver herein */
BuildPgmFromHaskellModules(hsc,$(ALLOBJS) parser/hsclink.o parser/hschooks.o,,libhsp.a)
+parser/hschooks.o : parser/hschooks.c
+ $(RM) $@
+ $(HC) -c -o $@ $(HCFLAGS) parser/hschooks.c
+
#if DoInstallGHCSystem == YES
MakeDirectories(install, $(INSTLIBDIR_GHC))
InstallBinaryTarget(hsc,$(INSTLIBDIR_GHC))
@@ -512,7 +516,7 @@ compile(absCSyn/AbsCSyn,lhs,if_ghc(-fno-omit-reexported-instances))
compile(hsSyn/HsBinds,lhs,)
compile(hsSyn/HsCore,lhs,)
compile(hsSyn/HsDecls,lhs,)
-compile(hsSyn/HsExpr,lhs,)
+compile(hsSyn/HsExpr,lhs,if_ghc(-K2m))
compile(hsSyn/HsImpExp,lhs,)
compile(hsSyn/HsLit,lhs,)
compile(hsSyn/HsMatches,lhs,)
@@ -586,7 +590,7 @@ compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR))
compile(nativeGen/MachCode,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/MachMisc,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/MachRegs,lhs,-I$(NATIVEGEN_DIR))
-compile(nativeGen/PprMach,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/PprMach,lhs,-I$(NATIVEGEN_DIR) if_ghc(-K2m))
compile(nativeGen/RegAllocInfo,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/Stix,lhs,)
compile(nativeGen/StixInfo,lhs,)
@@ -617,7 +621,7 @@ compile(rename/RnHsSyn,lhs,)
compile(rename/RnMonad,lhs,if_ghc(-fvia-C))
compile(rename/Rename,lhs,)
compile(rename/RnNames,lhs,)
-compile(rename/RnSource,lhs,)
+compile(rename/RnSource,lhs,-H12m)
compile(rename/RnBinds,lhs,)
compile(rename/RnExpr,lhs,)
compile(rename/RnIfaces,lhs,)
@@ -807,7 +811,7 @@ UgenNeededHere(all depend)
NormalLibraryTarget(hsp,$(HSP_OBJS_O))
/* We need the hsp program for hstags to work! */
-BuildPgmFromCFiles(hsp,parser/printtree.o parser/main.o,,libhsp.a)
+/* BuildPgmFromCFiles(hsp,parser/printtree.o parser/main.o,,libhsp.a) */
#if DoInstallGHCSystem == YES
MakeDirectories(install, $(INSTLIBDIR_GHC))
@@ -874,6 +878,11 @@ compile(parser/U_ttype,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS)
+#if GhcBuilderVersion < 200
+/* this will go away soon enough... (once 1.3 is settled in) */
+MKDEPENDHS = mkdependHS-1.2
+#endif
+
#if GhcWithHscBuiltViaC == NO
MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
#else /* booting from .hc */
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 7fc750583404..85914c98750f 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -75,6 +75,7 @@ module Id (
isTopLevId,
isTupleCon,
isWorkerId,
+ isWrapperId,
toplevelishId,
unfoldingUnfriendlyId,
@@ -101,6 +102,7 @@ module Id (
getIdUnfolding,
getIdUpdateInfo,
getPragmaInfo,
+ replaceIdInfo,
-- IdEnvs AND IdSets
SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
@@ -606,9 +608,7 @@ isSuperDictSelId_maybe other_id = Nothing
isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
isWorkerId other = False
-{-LATER:
isWrapperId id = workerExists (getIdStrictness id)
--}
\end{code}
\begin{code}
@@ -778,7 +778,7 @@ unfoldingUnfriendlyId -- return True iff it is definitely a bad
-> Bool -- mentions this Id. Reason: it cannot
-- possibly be seen in another module.
-unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
+unfoldingUnfriendlyId id = True -- ToDo:panic "Id.unfoldingUnfriendlyId"
{-LATER:
unfoldingUnfriendlyId id
@@ -1213,11 +1213,11 @@ getPragmaInfo :: GenId ty -> PragmaInfo
getIdInfo (Id _ _ _ _ _ info) = info
getPragmaInfo (Id _ _ _ _ info _) = info
-{-LATER:
replaceIdInfo :: Id -> IdInfo -> Id
-replaceIdInfo (Id u n ty _ details) info = Id u n ty info details
+replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
+{-LATER:
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index ad761add83f5..a0538b439fe2 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -567,7 +567,7 @@ or an Absent {\em that we accept}.
indicatesWorker :: [Demand] -> Bool
indicatesWorker dems
- = fake_mk_ww (trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
+ = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
where
fake_mk_ww _ [] = False
fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 4a2b799acbaf..d3eb0d5541b8 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -71,8 +71,6 @@ import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
pprUnique, Unique
)
import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic, pprTrace{-ToDo:rm-} )
-import {-hide from mkdependHS-}
- RnHsSyn ( RnName ) -- instance for specializing only
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
@@ -269,7 +267,9 @@ mkCompoundName :: Unique
-> Name -- from which we get provenance, etc....
-> Name -- result!
-mkCompoundName u m str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
+mkCompoundName u m str ns (Local _ _ _ locn) -- these arise for workers...
+ = Local u str True{-emph uniq-} locn
+
mkCompoundName u m str ns (Global _ _ _ prov exp _)
= Global u m (Right (Right str : ns)) prov exp []
@@ -304,9 +304,9 @@ mkTupleTyConName arity
mkTupNameStr 0 = SLIT("()")
mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary
-mkTupNameStr 3 = SLIT("(,,)") -- ditto
-mkTupNameStr 4 = SLIT("(,,,)") -- ditto
+mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary
+mkTupNameStr 3 = _PK_ "(,,)" -- ditto
+mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
mkTupNameStr n
= _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs
index 03fb6c236431..e12b0db105af 100644
--- a/ghc/compiler/basicTypes/SrcLoc.lhs
+++ b/ghc/compiler/basicTypes/SrcLoc.lhs
@@ -77,7 +77,7 @@ unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line))
\begin{code}
instance Outputable SrcLoc where
ppr PprForUser (SrcLoc src_file src_line)
- = ppBesides [ ppChar '"', ppPStr src_file, ppPStr SLIT("\", line "), ppPStr src_line ]
+ = ppBesides [ ppChar '"', ppPStr src_file, ppStr "\", line ", ppPStr src_line ]
ppr sty (SrcLoc src_file src_line)
= ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP,
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 953f435214b4..104953adca0c 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -112,8 +112,6 @@ module Unique (
liftTyConKey,
listTyConKey,
ltDataConKey,
- mainIdKey,
- mainPrimIOIdKey,
monadClassKey,
monadPlusClassKey,
monadZeroClassKey,
@@ -615,8 +613,6 @@ integerPlusTwoIdKey = mkPreludeMiscIdUnique 14
integerZeroIdKey = mkPreludeMiscIdUnique 15
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16
lexIdKey = mkPreludeMiscIdUnique 17
-mainIdKey = mkPreludeMiscIdUnique 18
-mainPrimIOIdKey = mkPreludeMiscIdUnique 19
noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21
nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 8bf533fcc40e..d0f9bf808c41 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgClosure]{Code generation for closures}
@@ -49,7 +49,7 @@ import ClosureInfo -- lots and lots of stuff
import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
noCostCentreAttached, costsAreSubsumed,
- isCafCC, isDictCC, overheadCostCentre
+ isCafCC, isDictCC, overheadCostCentre, showCostCentre
)
import HeapOffs ( SYN_IE(VirtualHeapOffset) )
import Id ( idType, idPrimRep,
@@ -59,13 +59,14 @@ import Id ( idType, idPrimRep,
)
import ListSetOps ( minusList )
import Maybes ( maybeToBool )
+import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
-import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr )
+import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
import PrimRep ( isFollowableRep, PrimRep(..) )
import TyCon ( isPrimTyCon, tyConDataCons )
import Unpretty ( uppShow )
-import Util ( isIn, panic, pprPanic, assertPanic )
+import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
@@ -409,8 +410,12 @@ closureCodeBody binder_info closure_info cc [] body
body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
body_code = profCtrC SLIT("ENT_THK") [] `thenC`
- enterCostCentreCode closure_info cc IsThunk `thenC`
- thunkWrapper closure_info (cgExpr body)
+ thunkWrapper closure_info (
+ -- We only enter cc after setting up update so that cc
+ -- of enclosing scope will be recorded in update frame
+ -- CAF/DICT functions will be subsumed by this enclosing cc
+ enterCostCentreCode closure_info cc IsThunk `thenC`
+ cgExpr body)
stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
\end{code}
@@ -580,9 +585,9 @@ Node is guaranteed to point to it, if profiling and not inherited.
\begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local
-#ifdef DEBUG
+--#ifdef DEBUG
deriving Eq
-#endif
+--#endif
enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
@@ -594,8 +599,9 @@ enterCostCentreCode closure_info cc is_thunk
ASSERT(not (noCostCentreAttached cc))
if costsAreSubsumed cc then
- ASSERT(isToplevClosure closure_info)
- ASSERT(is_thunk == IsFunction)
+ --ASSERT(isToplevClosure closure_info)
+ --ASSERT(is_thunk == IsFunction)
+ (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
costCentresC SLIT("ENTER_CC_FSUB") []
else if currentOrSubsumedCosts cc then
@@ -704,8 +710,8 @@ thunkWrapper closure_info thunk_code
let
emit_gran_macros = opt_GranMacros
in
- -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
- -- (we prefer fetchAndReschedule-style context switches to yield ones)
+ -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+ -- (we prefer fetchAndReschedule-style context switches to yield ones)
(if emit_gran_macros
then if node_points
then fetchAndReschedule [] node_points
@@ -714,19 +720,20 @@ thunkWrapper closure_info thunk_code
stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
- -- Must be after stackCheck: if stchk fails new stack
- -- space has to be allocated from the heap
+ -- heapCheck must be after stackCheck: if stchk fails
+ -- new stack space is allocated from the heap which
+ -- would violate any previous heapCheck
- heapCheck [] node_points (
- -- heapCheck *encloses* the rest
- -- The "[]" says there are no live argument registers
+ heapCheck [] node_points ( -- heapCheck *encloses* the rest
+ -- The "[]" says there are no live argument registers
-- Overwrite with black hole if necessary
- blackHoleIt closure_info `thenC`
+ blackHoleIt closure_info `thenC`
- -- Push update frame if necessary
- setupUpdate closure_info ( -- setupUpdate *encloses* the rest
- thunk_code
+ setupUpdate closure_info ( -- setupUpdate *encloses* the rest
+
+ -- Finally, do the business
+ thunk_code
)))
funWrapper :: ClosureInfo -- Closure whose code body this is
@@ -744,11 +751,11 @@ funWrapper closure_info arg_regs fun_body
then yield arg_regs node_points
else absC AbsCNop) `thenC`
- stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest
+ stackCheck closure_info arg_regs node_points (
+ -- stackCheck *encloses* the rest
- -- Heap overflow check
heapCheck arg_regs node_points (
- -- heapCheck *encloses* the rest
+ -- heapCheck *encloses* the rest
-- Finally, do the business
fun_body
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index 8e9ae24a8528..dff65e54467b 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -10,22 +10,22 @@ monadic stuff fits into the Big Picture.
#include "HsVersions.h"
module CgMonad (
- Code(..), -- type
- FCode(..), -- type
+ SYN_IE(Code), -- type
+ SYN_IE(FCode), -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, absC, nopC, getAbsC,
forkClosureBody, forkStatics, forkAlts, forkEval,
forkEvalHelp, forkAbsC,
- SemiTaggingStuff(..),
+ SYN_IE(SemiTaggingStuff),
addBindC, addBindsC, modifyBindC, lookupBindC,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- AStackUsage(..), BStackUsage(..), HeapUsage(..),
+ SYN_IE(AStackUsage), SYN_IE(BStackUsage), SYN_IE(HeapUsage),
StubFlag,
isStubbed,
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 1c3d61a6ab48..1d4afc3ab692 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -90,7 +90,7 @@ import IdInfo ( arityMaybe )
import Maybes ( assocMaybe, maybeToBool )
import Name ( isLocallyDefined, nameOf, origName )
import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
+import PprType ( getTyDescription, GenType{-instance Outputable-} )
import Pretty--ToDo:rm
import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
import PrimRep ( getPrimRepSize, separateByPtrFollowness )
@@ -100,8 +100,6 @@ import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking,
mkFunTys, maybeAppSpecDataTyConExpandingDicts
)
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
-
-getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
\end{code}
The ``wrapper'' data type for closure information:
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 06f4be493742..9090e7702ec3 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -316,7 +316,8 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
- (tycon, _, _) = trace "CoreUnfold.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts scrut_ty
+ (tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $
+ getAppDataTyConExpandingDicts scrut_ty
size_up_alts _ (PrimAlts alts deflt)
= foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 309d62df3fef..fba4be237498 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -265,6 +265,28 @@ ppr_expr pe expr@(App _ _)
])
ppr_expr pe (Case expr alts)
+ | only_one_alt alts
+ -- johan thinks that single case patterns should be on same line as case,
+ -- and no indent; all sane persons agree with him.
+ = let
+ ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
+ ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
+ ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
+ ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
+ = ppCat [ppr_alt_con con (pCon pe con),
+ ppInterleave ppSP (map (pMinBndr pe) params),
+ ppStr "->"]
+
+ ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
+ ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
+ ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
+ ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
+ in
+ ppSep
+ [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
+ ppBeside (ppr_rhs alts) (ppStr "}")]
+
+ | otherwise -- default "case" printing
= ppSep
[ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
ppNest 2 (ppr_alts pe alts),
@@ -303,6 +325,15 @@ ppr_expr pe (Coerce c ty expr)
where
pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v)
pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
+
+only_one_alt (AlgAlts [] (BindDefault _ _)) = True
+only_one_alt (AlgAlts (_:[]) NoDefault) = True
+only_one_alt (PrimAlts [] (BindDefault _ _)) = True
+only_one_alt (PrimAlts (_:[]) NoDefault) = True
+only_one_alt _ = False
+
+ppr_alt_con con pp_con
+ = if isSymLexeme con then ppParens pp_con else pp_con
\end{code}
\begin{code}
@@ -314,14 +345,11 @@ ppr_alts pe (AlgAlts alts deflt)
ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
ppStr "->"]
else
- ppCat [ppr_con con (pCon pe con),
+ ppCat [ppr_alt_con con (pCon pe con),
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
)
4 (ppr_expr pe expr)
- where
- ppr_con con pp_con
- = if isSymLexeme con then ppParens pp_con else pp_con
ppr_alts pe (PrimAlts alts deflt)
= ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 250c98ec2825..a8f41bd8e3a7 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -38,7 +38,7 @@ import PprType ( GenType )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
- tyVarsOfType, tyVarsOfTypes
+ tyVarsOfType, tyVarsOfTypes, isDictTy
)
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
@@ -46,8 +46,6 @@ import PprCore--ToDo:rm
import PprType ( GenTyVar ) --ToDo:rm
import Usage--ToDo:rm
import Unique--ToDo:rm
-
-isDictTy = panic "DsBinds.isDictTy"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 6dd80c18f25d..f59bb89093c2 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -16,7 +16,7 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
module HsCore (
UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
- UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
+ UnfoldingCoreAtom(..), UfId(..), SYN_IE(UnfoldingType),
UnfoldingPrimOp(..), UfCostCentre(..)
) where
diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
index 08537bc48dd2..e165b3ca75ed 100644
--- a/ghc/compiler/hsSyn/HsSyn.lhs
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -16,7 +16,6 @@ module HsSyn (
-- this module tells about "real Haskell"
EXP_MODULE(HsSyn) ,
-#if (! defined(REALLY_HASKELL_1_3)) || PATRICK_FIXES_MODULE_DOTDOT_THING
EXP_MODULE(HsBinds) ,
EXP_MODULE(HsDecls) ,
EXP_MODULE(HsExpr) ,
@@ -25,76 +24,6 @@ module HsSyn (
EXP_MODULE(HsMatches) ,
EXP_MODULE(HsPat) ,
EXP_MODULE(HsTypes)
-#else
- ArithSeqInfo(..),
- BangType(..),
- Bind(..),
- ClassDecl(..),
- ConDecl(..),
- DefaultDecl(..),
- FixityDecl(..),
- GRHS(..),
- GRHSsAndBinds(..),
- HsBinds(..),
- HsExpr(..),
- HsLit(..),
- IE(..),
- ImportDecl(..),
- InPat(..),
- InstDecl(..),
- Match(..),
- MonoBinds(..),
- MonoType(..),
- OutPat(..),
- PolyType(..),
- Qualifier(..),
- Sig(..),
- SpecDataSig(..),
- SpecInstSig(..),
- Stmt(..),
- TyDecl(..),
- bindIsRecursive,
- cmpContext,
- cmpMonoType,
- cmpPolyType,
- collectBinders,
- collectMonoBinders,
- collectMonoBindersAndLocs,
- collectPatBinders,
- collectTopLevelBinders,
- extractCtxtTyNames,
- extractMonoTyNames,
- failureFreePat,
- irrefutablePat,
- irrefutablePats,
- isConPat,
- isLitPat,
- negLiteral,
- nullBind,
- nullBinds,
- nullMonoBinds,
- patsAreAllCons,
- patsAreAllLits,
- pp_condecls,
- pp_decl_head,
- pp_dotdot,
- pp_rbinds,
- pp_tydecl,
- pprContext,
- pprExpr,
- pprGRHS,
- pprGRHSsAndBinds,
- pprMatch,
- pprMatches,
- pprParendExpr,
- pprParendMonoType,
- pprParendPolyType,
- ppr_bang,
- print_it,
- SYN_IE(ClassAssertion),
- SYN_IE(Context),
- SYN_IE(HsRecordBinds)
-#endif
) where
IMP_Ubiq()
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 99169c1a5cf9..50eed96fed95 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -55,8 +55,6 @@ module CmdLineOpts (
opt_GranMacros,
opt_Haskell_1_3,
opt_HiMap,
- opt_HideBuiltinNames,
- opt_HideMostBuiltinNames,
opt_IgnoreIfacePragmas,
opt_IgnoreStrictnessPragmas,
opt_IrrefutableEverything,
@@ -274,8 +272,6 @@ opt_ForConcurrent = lookUp SLIT("-fconcurrent")
opt_GranMacros = lookUp SLIT("-fgransim")
opt_GlasgowExts = lookUp SLIT("-fglasgow-exts")
opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3")
-opt_HideBuiltinNames = lookUp SLIT("-fhide-builtin-names")
-opt_HideMostBuiltinNames = lookUp SLIT("-fmin-builtin-names")
opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas")
opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything")
opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 5afed2e89749..54a67834293f 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -94,7 +94,7 @@ doIt (core_cmds, stg_cmds) input_pgm
renameModule rn_uniqs rdr_module >>=
\ (rn_mod, rn_env, import_names,
- export_fn, usage_stuff,
+ export_stuff, usage_stuff,
rn_errs_bag, rn_warns_bag) ->
if (not (isEmptyBag rn_errs_bag)) then
@@ -126,7 +126,7 @@ doIt (core_cmds, stg_cmds) input_pgm
startIface mod_name >>= \ if_handle ->
ifaceUsages if_handle usages_map >>
ifaceVersions if_handle version_info >>
- ifaceExportList if_handle export_fn rn_mod >>
+ ifaceExportList if_handle export_stuff rn_env >>
ifaceFixities if_handle rn_mod >>
ifaceInstanceModules if_handle instance_modules >>
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index e5604554deef..43d1ebb86730 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -27,14 +27,14 @@ import CmdLineOpts ( opt_ProduceHi )
import FieldLabel ( FieldLabel{-instance NamedThing-} )
import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
import HsSyn
-import Id ( idType, dataConRawArgTys, dataConFieldLabels,
+import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
import Maybes ( maybeToBool )
import Name ( origName, nameOf, moduleOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
- isLexSym, isLocallyDefined, isWiredInName,
+ isLexSym, isLexCon, isLocallyDefined, isWiredInName,
RdrName(..){-instance Outputable-},
OrigName(..){-instance Ord-},
Name{-instance NamedThing-}
@@ -44,10 +44,11 @@ import PprEnv -- not sure how much...
import PprStyle ( PprStyle(..) )
import PprType -- most of it (??)
--import PrelMods ( modulesWithBuiltins )
-import PrelInfo ( builtinNameInfo )
+import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
import Pretty ( prettyToUn )
import Unpretty -- ditto
-import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName{-instance NamedThing-} )
+import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
+import RnUtils ( SYN_IE(RnEnv), pprRnEnv{-ToDo:rm-} )
import TcModule ( SYN_IE(TcIfaceInfo) )
import TcInstUtil ( InstInfo(..) )
import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
@@ -84,8 +85,8 @@ ifaceVersions
-> IO ()
ifaceExportList
:: Maybe Handle
- -> (Name -> ExportFlag)
- -> RenamedHsModule
+ -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)]))
+ -> RnEnv
-> IO ()
ifaceFixities
:: Maybe Handle
@@ -177,58 +178,74 @@ ifaceInstanceModules (Just if_hdl) imods
Export list: grab the Names of things that are marked Exported, sort
(so the interface file doesn't ``wobble'' from one compilation to the
-next...), and print. Note that the ``module'' now contains all the
-imported things that we are dealing with, thus including any entities
-that we are re-exporting from somewhere else.
+next...), and print. We work from the renamer's final ``RnEnv'',
+which has all the names we might possibly be interested in.
+(Note that the ``module X'' export items can cause a lot of grief.)
\begin{code}
ifaceExportList Nothing{-no iface handle-} _ _ = return ()
ifaceExportList (Just if_hdl)
- export_fn -- sadly, just the HsModule isn't enough,
- -- because it will have no record of exported
- -- wired-in names.
- (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
+ (export_fn, (dotdot_vals, dotdot_tcs))
+ rn_env@((qual, unqual, tc_qual, tc_unqual), _)
= let
- (vals_wired, tcs_wired)
- = case builtinNameInfo of { ((vals_fm,tcs_fm), _, _) ->
- (eltsFM vals_fm, eltsFM tcs_fm) }
-
name_flag_pairs :: FiniteMap OrigName ExportFlag
name_flag_pairs
- = foldr (from_wired True{-val-ish-})
- (foldr (from_wired False{-tycon-ish-})
- (foldr from_ty
- (foldr from_cls
- (foldr from_sig
- (from_binds binds emptyFM{-init accum-})
- sigs)
- classdecls)
- typedecls)
- tcs_wired)
- vals_wired
+ = foldr (from_wired True{-val-ish-})
+ (foldr (from_wired False{-tycon-ish-})
+ (foldr (from_dotdot True{-val-ish-})
+ (foldr (from_dotdot False{-tycon-ish-})
+ (foldr from_val
+ (foldr from_val
+ (foldr from_tc
+ (foldr from_tc emptyFM{-init accum-}
+ (eltsFM tc_unqual))
+ (eltsFM tc_qual))
+ (eltsFM unqual))
+ (eltsFM qual))
+ dotdot_tcs)
+ dotdot_vals)
+ (eltsFM builtinTcNamesMap))
+ (eltsFM builtinValNamesMap)
sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
in
+ --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $
hPutStr if_hdl "\n__exports__\n" >>
hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
where
- from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
- from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n
- from_ty (TySynonym n _ _ _) acc = maybe_add acc n
+ from_val rn acc
+ | fun_looking rn && exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ ef = export_fn n -- NB: using the export fn!
+ n = getName rn
+ on = origName "from_val" n
- from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
+ -- fun_looking: must avoid class ops and data constructors
+ -- and record fieldnames
+ fun_looking (RnName _) = True
+ fun_looking (WiredInId i) = not (isDataCon i)
+ fun_looking _ = False
- from_sig (Sig n _ _ _) acc = maybe_add acc n
+ from_tc rn acc
+ | exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ ef = export_fn n -- NB: using the export fn!
+ n = getName rn
+ on = origName "from_tc" n
- from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
+ from_dotdot is_valish (n,ef) acc
+ | is_valish && isLexCon str = acc
+ | exportFlagOn ef = addToFM acc on ef
+ | otherwise = acc
+ where
+ on = origName "from_dotdot" n
+ (OrigName _ str) = on
- --------------
from_wired is_val_ish rn acc
- | on_in_acc = acc -- if already in acc (presumably from real decl),
- -- don't take the dubious export flag from the
- -- wired-in chappy
- | is_val_ish && isRnConstr rn
+ | is_val_ish && not (fun_looking rn)
= acc -- these things don't cause export-ery
| exportFlagOn ef = addToFM acc on ef
| otherwise = acc
@@ -236,25 +253,6 @@ ifaceExportList (Just if_hdl)
n = getName rn
ef = export_fn n
on = origName "from_wired" n
- (OrigName _ str) = on
- on_in_acc = maybeToBool (lookupFM acc on)
-
- --------------
- maybe_add :: FiniteMap OrigName ExportFlag -> RnName -> FiniteMap OrigName ExportFlag
-
- maybe_add acc rn
- | on_in_acc = trace "maybe_add?" acc -- surprising!
- | exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- ef = nameExportFlag n
- n = getName rn
- on = origName "maybe_add" n
- on_in_acc = maybeToBool (lookupFM acc on)
-
- --------------
- maybe_add_list acc [] = acc
- maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
--------------
lexical_lt (n1,_) (n2,_) = n1 < n2
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 6a51d9c22d70..de2bb9047448 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -2232,7 +2232,7 @@ genCCall fn kind [StInt i]
MOV L (OpImm (ImmCLbl lbl))
-- this is hardwired
(OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
+ JMP (OpImm (ImmLit (uppPStr (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
LABEL lbl]
in
returnInstrs call
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index be9b18d7b131..3d1665b59893 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -16,11 +16,6 @@ module PprMach ( pprInstr ) where
IMP_Ubiq(){-uitious-}
IMPORT_1_3(Char(isPrint,isDigit))
IMPORT_1_3(qualified GHCbase(Addr(..))) -- to see innards
-#if __GLASGOW_HASKELL__ >= 200
-# define A_HASH GHCbase.A#
-#else
-# define A_HASH A#
-#endif
import MachRegs -- may differ per-platform
import MachMisc
@@ -32,6 +27,14 @@ import Maybes ( maybeToBool )
import OrdList ( OrdList )
import Stix ( CodeSegment(..), StixTree )
import Unpretty -- all of it
+
+#if __GLASGOW_HASKELL__ >= 200
+a_HASH x = GHCbase.A# x
+pACK_STR x = packCString x
+#else
+a_HASH x = A# x
+pACK_STR x = _packCString x
+#endif
\end{code}
%************************************************************************
@@ -296,12 +299,12 @@ pprImm (ImmLab s) | underscorePrefix = uppBeside (uppChar '_') s
pprImm (LO i)
= uppBesides [ pp_lo, pprImm i, uppRparen ]
where
- pp_lo = uppPStr (_packCString (A_HASH "%lo("#))
+ pp_lo = uppPStr (pACK_STR (a_HASH "%lo("#))
pprImm (HI i)
= uppBesides [ pp_hi, pprImm i, uppRparen ]
where
- pp_hi = uppPStr (_packCString (A_HASH "%hi("#))
+ pp_hi = uppPStr (pACK_STR (a_HASH "%hi("#))
#endif
\end{code}
@@ -396,7 +399,7 @@ pprInstr (SEGMENT TextSegment)
= uppPStr
IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-}
- ,IF_ARCH_i386(SLIT(".text\n\t.align 2,0x90") {-needs per-OS variation!-}
+ ,IF_ARCH_i386((_PK_ ".text\n\t.align 2\x2c\&0x90") {-needs per-OS variation!-}
,)))
pprInstr (SEGMENT DataSegment)
@@ -816,13 +819,8 @@ pprInstr (FUNBEGIN clab)
where
pp_lab = pprCLabel_asm clab
-#if __GLASGOW_HASKELL__ >= 200
-# define PACK_STR packCString
-#else
-# define PACK_STR _packCString
-#endif
- pp_ldgp = uppPStr (PACK_STR (A_HASH ":\n\tldgp $29,0($27)\n"#))
- pp_frame = uppPStr (PACK_STR (A_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
+ pp_ldgp = uppPStr (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#))
+ pp_frame = uppPStr (pACK_STR (a_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
pprInstr (FUNEND clab)
= uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
@@ -1331,10 +1329,10 @@ pprRIReg name b ri reg1
pprReg reg1
]
-pp_ld_lbracket = uppPStr (PACK_STR (A_HASH "\tld\t["#))
-pp_rbracket_comma = uppPStr (PACK_STR (A_HASH "],"#))
-pp_comma_lbracket = uppPStr (PACK_STR (A_HASH ",["#))
-pp_comma_a = uppPStr (PACK_STR (A_HASH ",a"#))
+pp_ld_lbracket = uppPStr (pACK_STR (a_HASH "\tld\t["#))
+pp_rbracket_comma = uppPStr (pACK_STR (a_HASH "],"#))
+pp_comma_lbracket = uppPStr (pACK_STR (a_HASH ",["#))
+pp_comma_a = uppPStr (pACK_STR (a_HASH ",a"#))
#endif {-sparc_TARGET_ARCH-}
\end{code}
diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs
index 3a5f86c95410..b9edb427d767 100644
--- a/ghc/compiler/parser/UgenAll.lhs
+++ b/ghc/compiler/parser/UgenAll.lhs
@@ -8,7 +8,6 @@ module UgenAll (
returnUgn, thenUgn,
-- stuff defined in utils module
-#if (! defined(REALLY_HASKELL_1_3)) || PATRICK_FIXES_MODULE_DOTDOT_THING
EXP_MODULE(UgenUtil) ,
-- re-exported ugen-generated stuff
@@ -23,50 +22,6 @@ module UgenAll (
EXP_MODULE(U_qid) ,
EXP_MODULE(U_tree) ,
EXP_MODULE(U_ttype)
-#else
- SYN_IE(ParseTree),
- SYN_IE(U_VOID_STAR),
- U_binding (..),
- U_constr (..),
- U_either (..),
- U_entidt (..),
- SYN_IE(U_hstring),
- U_list (..),
- U_literal (..),
- SYN_IE(U_long),
- U_maybe (..),
- SYN_IE(U_numId),
- U_pbinding (..),
- U_qid (..),
- SYN_IE(U_stringId),
- U_tree (..),
- U_ttype (..),
- SYN_IE(UgnM),
- getSrcFileUgn,
- getSrcLocUgn,
- getSrcModUgn,
- initUgn,
- ioToUgnM,
- mkSrcLocUgn,
- rdU_VOID_STAR,
- rdU_binding,
- rdU_constr,
- rdU_either,
- rdU_entidt,
- rdU_hstring,
- rdU_list,
- rdU_literal,
- rdU_long,
- rdU_maybe,
- rdU_numId,
- rdU_pbinding,
- rdU_qid,
- rdU_stringId,
- rdU_tree,
- rdU_ttype,
- setSrcFileUgn,
- setSrcModUgn
-#endif
) where
import PreludeGlaST
diff --git a/ghc/compiler/parser/hschooks.c b/ghc/compiler/parser/hschooks.c
index 27008397128d..b63019125611 100644
--- a/ghc/compiler/parser/hschooks.c
+++ b/ghc/compiler/parser/hschooks.c
@@ -9,17 +9,14 @@ in instead of the defaults.
#define I_ long int
void
-ErrorHdrHook (where)
- FILE *where;
+ErrorHdrHook (FILE *where)
{
fprintf(where, "\n"); /* no "Fail: " */
}
void
-OutOfHeapHook (request_size, heap_size)
- W_ request_size; /* in bytes */
- W_ heap_size; /* in bytes */
+OutOfHeapHook (W_ request_size, W_ heap_size) /* both in bytes */
{
fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
request_size,
@@ -27,40 +24,25 @@ OutOfHeapHook (request_size, heap_size)
}
void
-StackOverflowHook (stack_size)
- I_ stack_size; /* in bytes */
+StackOverflowHook (I_ stack_size) /* in bytes */
{
fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
}
-#if 0
-/* nothing to add here, really */
void
-MallocFailHook (request_size, msg)
- I_ request_size; /* in bytes */
- char *msg;
-{
- fprintf(stderr, "malloc: failed on request for %lu bytes\n", request_size);
-}
-#endif /* 0 */
-
-void
-PatErrorHdrHook (where)
- FILE *where;
+PatErrorHdrHook (FILE *where)
{
fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\nFail: ");
}
void
-PreTraceHook (where)
- FILE *where;
+PreTraceHook (FILE *where)
{
fprintf(where, "\n"); /* not "Trace On" */
}
void
-PostTraceHook (where)
- FILE *where;
+PostTraceHook (FILE *where)
{
fprintf(where, "\n"); /* not "Trace Off" */
}
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 8096274c7b1f..f659a9b7b926 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -9,7 +9,10 @@
module PrelInfo (
-- finite maps for built-in things (for the renamer and typechecker):
- builtinNameInfo, SYN_IE(BuiltinNames),
+ builtinNameInfo, builtinNameMaps,
+ builtinValNamesMap, builtinTcNamesMap,
+ builtinKeysMap,
+ SYN_IE(BuiltinNames),
SYN_IE(BuiltinKeys), SYN_IE(BuiltinIdInfos),
maybeCharLikeTyCon, maybeIntLikeTyCon
@@ -27,10 +30,6 @@ import TysPrim -- TYPES
import TysWiredIn
-- others:
-import CmdLineOpts ( opt_HideBuiltinNames,
- opt_HideMostBuiltinNames,
- opt_ForConcurrent
- )
import FiniteMap ( FiniteMap, emptyFM, listToFM )
import Id ( mkTupleCon, GenId, SYN_IE(Id) )
import Maybes ( catMaybes )
@@ -64,45 +63,17 @@ type BuiltinKeys = FiniteMap OrigName (Unique, Name -> RnName)
type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids
-builtinNameInfo
- = if opt_HideBuiltinNames then
- (
- (emptyFM, emptyFM),
- emptyFM,
- emptyUFM
- )
- else if opt_HideMostBuiltinNames then
- (
- (listToFM min_assoc_val_wired, listToFM min_assoc_tc_wired),
- emptyFM,
- emptyUFM
- )
- else
- (
- (listToFM assoc_val_wired, listToFM assoc_tc_wired),
- listToFM assoc_keys,
- listToUFM assoc_id_infos
- )
+builtinNameMaps = case builtinNameInfo of { (x,_,_) -> x }
+builtinKeysMap = case builtinNameInfo of { (_,x,_) -> x }
+builtinValNamesMap = fst builtinNameMaps
+builtinTcNamesMap = snd builtinNameMaps
+builtinNameInfo
+ = ( (listToFM assoc_val_wired, listToFM assoc_tc_wired)
+ , listToFM assoc_keys
+ , listToUFM assoc_id_infos
+ )
where
- min_assoc_val_wired -- min needed when compiling bits of Prelude
- = concat [
- -- data constrs
- concat (map pcDataConWiredInInfo g_con_tycons),
- concat (map pcDataConWiredInInfo min_nonprim_tycon_list),
-
- -- values
- map pcIdWiredInInfo wired_in_ids,
- primop_ids
- ]
- min_assoc_tc_wired
- = concat [
- -- tycons
- map pcTyConWiredInInfo prim_tycons,
- map pcTyConWiredInInfo g_tycons,
- map pcTyConWiredInInfo min_nonprim_tycon_list
- ]
-
assoc_val_wired
= concat [
-- data constrs
@@ -168,20 +139,7 @@ g_tycons
= mkFunTyCon : g_con_tycons
g_con_tycons
- = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..32] ]
-
-min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
- = [ boolTyCon
- , charTyCon
- , intTyCon
- , floatTyCon
- , doubleTyCon
- , integerTyCon
- , liftTyCon
- , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11)
- , returnIntAndGMPTyCon
- ]
-
+ = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..37] ]
data_tycons
= [ addrTyCon
@@ -311,12 +269,8 @@ For the Ids we may also have some builtin IdInfo.
\begin{code}
id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)]
id_keys_infos
- = [ -- here so we can check the type of main/mainPrimIO
- (OrigName SLIT("Main") SLIT("main"), mainIdKey, Nothing)
- , (OrigName SLIT("GHCmain") SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing)
-
- -- here because we use them in derived instances
- , (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing)
+ = [ -- here because we use them in derived instances
+ (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing)
, (OrigName pRELUDE SLIT("."), composeIdKey, Nothing)
, (OrigName gHC__ SLIT("lex"), lexIdKey, Nothing)
, (OrigName pRELUDE SLIT("not"), notIdKey, Nothing)
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 3e3fb44415fa..90732706f15e 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -15,7 +15,7 @@ IMPORT_1_3(GHCio(stThen))
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
import HsSyn
-import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas )
+import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
import RdrHsSyn
import PrefixToHs
@@ -25,7 +25,7 @@ import Name ( RdrName(..), isRdrLexConOrSpecial, preludeQual )
import PprStyle ( PprStyle(..) )
import PrelMods ( pRELUDE )
import Pretty
-import SrcLoc ( SrcLoc )
+import SrcLoc ( mkBuiltinSrcLoc, SrcLoc )
import Util ( nOfThem, pprError, panic )
\end{code}
@@ -118,15 +118,37 @@ rdModule
imports
fixities
tydecls
- tysigs
+ tysigs
classdecls
instdecls
instsigs
defaultdecls
- (cvSepdBinds srcfile cvValSig binds)
+ (add_main_sig modname (cvSepdBinds srcfile cvValSig binds))
[{-no interface sigs yet-}]
src_loc
)
+ where
+ add_main_sig modname binds
+ = if modname == SLIT("Main") then
+ let
+ s = Sig (Unqual SLIT("main")) (io_ty SLIT("IO")) noGenPragmas mkBuiltinSrcLoc
+ in
+ add_sig binds s
+
+ else if modname == SLIT("GHCmain") then
+ let
+ s = Sig (Unqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) noGenPragmas mkBuiltinSrcLoc
+ in
+ add_sig binds s
+
+ else -- add nothing
+ binds
+ where
+ add_sig (SingleBind b) s = BindWith b [s]
+ add_sig (BindWith b ss) s = BindWith b (s:ss)
+ add_sig _ _ = panic "rdModule:add_sig"
+
+ io_ty t = HsForAllTy [] [] (MonoTyApp (Unqual t) [MonoTupleTy []])
\end{code}
%************************************************************************
diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs
index 04d4302e917b..08266c601620 100644
--- a/ghc/compiler/rename/ParseUtils.lhs
+++ b/ghc/compiler/rename/ParseUtils.lhs
@@ -313,11 +313,11 @@ lexIface input
Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
where
in_the_club [] = panic "lex_word:in_the_club"
- in_the_club (x:_) | isAlpha x = is_var_sym
+ in_the_club (x:y) | isAlpha x = is_var_sym
| is_sym_sym x = is_sym_sym
| x == '[' = is_list_sym
| x == '(' = is_tuple_sym
- | otherwise = panic ("lex_word:in_the_club="++[x])
+ | otherwise = panic ("lex_word:in_the_club="++(x:y))
module_dot (c:cs)
= if not (isUpper c) || c == '\'' then
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 02194ae2ec63..3c827c16db77 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -46,7 +46,7 @@ import Name ( isLocallyDefined, mkWiredInName, getLocalName, isLocalName,
Name, RdrName(..), ExportFlag(..)
)
import PprStyle -- ToDo:rm
-import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import Pretty -- ToDo:rm
import Unique ( ixClassKey )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
@@ -62,7 +62,10 @@ renameModule :: UniqSupply
RnEnv, -- final env (for renaming derivings)
[Module], -- imported modules; for profiling
- Name -> ExportFlag, -- export info
+ (Name -> ExportFlag, -- export info
+ ([(Name,ExportFlag)],
+ [(Name,ExportFlag)])),
+
(UsagesMap,
VersionsMap, -- version info; for usage
[Module]), -- instance modules; for iface
@@ -77,29 +80,29 @@ ToDo: Deal with instances (instance version, this module on instance list ???)
\begin{code}
renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
- = let
- (b_names, b_keys, _) = builtinNameInfo
+ = {-
+ let
pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n]
in
- {-
- pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
+ pprTrace "builtins:\n" (case builtinNameMaps of { (builtin_ids, builtin_tcs) ->
ppAboves [ ppCat (map pp_pair (keysFM builtin_ids))
, ppCat (map pp_pair (keysFM builtin_tcs))
- , ppCat (map pp_pair (keysFM b_keys))
+ , ppCat (map pp_pair (keysFM builtinKeysMap))
]}) $
-}
+-- _scc_ "rnGlobalNames"
makeHiMap opt_HiMap >>= \ hi_files ->
-- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
initIfaceCache modname hi_files >>= \ iface_cache ->
- fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
+ fixIO ( \ ~(_, _, _, _, rec_occ_fm, ~(rec_export_fn,_)) ->
let
rec_occ_fn :: Name -> [RdrName]
rec_occ_fn n = case lookupUFM rec_occ_fm n of
Nothing -> []
Just (rn,occs) -> occs
- global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
+ global_name_info = (builtinNameMaps, builtinKeysMap, rec_export_fn, rec_occ_fn)
in
getGlobalNames iface_cache global_name_info us1 input >>=
\ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
@@ -109,12 +112,12 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
else
-- No top-level name errors so rename source ...
+-- _scc_ "rnSource"
case initRn True modname occ_env us2
(rnSource imp_mods unqual_imps imp_fixes input) of {
- ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
+ ((rn_module, export_fn, module_dotdots, src_occs), src_errs, src_warns) ->
--pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
-
let
occ_fm :: UniqFM (RnName, [RdrName])
@@ -129,21 +132,25 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
GT__ -> x : insert new xs
occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
- multiple_occs (rn, (o1:o2:_)) = True
+
+ multiple_occs (rn, (o1:o2:_)) = getLocalName o1 /= SLIT("negate")
+ -- the user is rarely responsible if
+ -- "negate" is mentioned in multiple ways
multiple_occs _ = False
in
return (rn_module, imp_mods,
top_errs `unionBags` src_errs,
top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
- occ_fm, export_fn)
+ occ_fm, (export_fn, module_dotdots))
- }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_fn) ->
+ }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_stuff) ->
if not (isEmptyBag errs_so_far) then
return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
else
-- No errors renaming source so rename the interfaces ...
+-- _scc_ "preRnIfaces"
let
-- split up all names that occurred in the source; between
-- those that are defined therein and those merely mentioned.
@@ -189,16 +196,16 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
= [{-no Prelude.hi, no point looking-}]
| otherwise
= [ name_fn (mkWiredInName u orig ExportAll)
- | (orig@(OrigName mod str), (u, name_fn)) <- fmToList b_keys,
- str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
+ | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
in
-- ASSERT (isEmptyBag orig_occ_dups)
(if (isEmptyBag orig_occ_dups) then \x->x
else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
ASSERT (isEmptyBag orig_def_dups)
+-- _scc_ "rnIfaces"
rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
- rn_module (must_haves ++ imports_used) >>=
+ rn_module (must_haves {-initMustHaves-} ++ imports_used) >>=
\ (rn_module_with_imports, final_env,
(implicit_val_fm, implicit_tc_fm),
usage_stuff,
@@ -207,7 +214,7 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
return (rn_module_with_imports,
final_env,
imp_mods,
- export_fn,
+ export_stuff,
usage_stuff,
errs_so_far `unionBags` iface_errs,
warns_so_far `unionBags` iface_warns)
@@ -216,6 +223,17 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
(us1, us') = splitUniqSupply us
(us2, us3) = splitUniqSupply us'
+
+initMustHaves :: [RnName]
+ -- things we *must* find declarations for, because the
+ -- compiler may eventually make reference to them (e.g.,
+ -- class Eq)
+initMustHaves
+ | opt_NoImplicitPrelude
+ = [{-no Prelude.hi, no point looking-}]
+ | otherwise
+ = [ name_fn (mkWiredInName u orig ExportAll)
+ | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
\end{code}
\begin{code}
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index f1618ad2dbee..ac8dc51be0e7 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -15,8 +15,8 @@ module RnBinds (
rnTopBinds,
rnMethodBinds,
rnBinds,
- FreeVars(..),
- DefinedVars(..)
+ SYN_IE(FreeVars),
+ SYN_IE(DefinedVars)
) where
IMP_Ubiq()
@@ -32,7 +32,7 @@ import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
import CmdLineOpts ( opt_SigsRequired )
import Digraph ( stronglyConnComp )
import ErrUtils ( addErrLoc, addShortErrLocLine )
-import Name ( RdrName )
+import Name ( getLocalName, RdrName )
import Maybes ( catMaybes )
import PprStyle--ToDo:rm
import Pretty
@@ -524,7 +524,7 @@ rnBindSigs is_toplev binder_occnames sigs
-- Discard unbound ones we've already complained about, so we
-- complain about duplicate ones.
- (goodies, dups) = removeDups compare (filter not_unbound sigs')
+ (goodies, dups) = removeDups compare (filter (\ x -> not_unbound x && not_main x) sigs')
in
mapRn (addErrRn . dupSigDeclErr) dups `thenRn_`
@@ -598,7 +598,7 @@ rnBindSigs is_toplev binder_occnames sigs
lookupValue v `thenRn` \ new_v ->
returnRn (Just (MagicUnfoldingSig new_v str src_loc))
- not_unbound :: RenamedSig -> Bool
+ not_unbound, not_main :: RenamedSig -> Bool
not_unbound (Sig n _ _ _) = not (isRnUnbound n)
not_unbound (SpecSig n _ _ _) = not (isRnUnbound n)
@@ -606,6 +606,10 @@ rnBindSigs is_toplev binder_occnames sigs
not_unbound (DeforestSig n _) = not (isRnUnbound n)
not_unbound (MagicUnfoldingSig n _ _) = not (isRnUnbound n)
+ not_main (Sig n _ _ _) = let str = getLocalName n in
+ not (str == SLIT("main") || str == SLIT("mainPrimIO"))
+ not_main _ = True
+
-------------------------------------
sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
-- Return "Just x" if "x" has no type signature in
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 51366dbcf701..f805e312e9b6 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -50,7 +50,7 @@ import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
isLexCon, RdrName(..), Name{-instance NamedThing-} )
import PprStyle -- ToDo:rm
import Outputable -- ToDo:rm
-import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames) )
+import PrelInfo ( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) )
import Pretty
import UniqFM ( emptyUFM )
import UniqSupply ( splitUniqSupply )
@@ -81,9 +81,7 @@ data IfaceCache
initIfaceCache mod hi_files
= newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var ->
- return (IfaceCache mod b_names iface_var)
- where
- b_names = case builtinNameInfo of (b_names,_,_) -> b_names
+ return (IfaceCache mod builtinNameMaps iface_var)
\end{code}
*********************************************************
@@ -749,19 +747,9 @@ rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_
Just _ -> True
Nothing -> -- maybe it's builtin
let orig = qualToOrigName nm in
- case (lookupFM b_tc_names orig) of
+ case (lookupFM builtinTcNamesMap orig) of
Just _ -> True
- Nothing -> maybeToBool (lookupFM b_keys orig)
-
- (b_tc_names, b_keys) -- pretty UGLY ...
- = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
-{-
- ppr_insts insts
- = ppAboves (map ppr_inst insts)
- where
- ppr_inst (InstSig c t _ inst_decl)
- = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
--}
+ Nothing -> maybeToBool (lookupFM builtinKeysMap orig)
\end{code}
\begin{code}
@@ -877,7 +865,7 @@ ifaceLookupWiredErr msg n sty
= ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
badIfaceLookupErr msg name decl sty
- = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
+ = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"]
ifaceIoErr io_msg rn sty
= ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index e6b7c93dd256..0f668bf06b1b 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -57,7 +57,7 @@ import Name ( SYN_IE(Module), RdrName(..), isQual,
OrigName(..), Name, mkLocalName, mkImplicitName,
getOccName, pprNonSym
)
-import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import PrelMods ( pRELUDE )
import PprStyle{-ToDo:rm-}
import Outputable{-ToDo:rm-}
@@ -127,8 +127,7 @@ initRn source mod env us do_rn
mode = if source then
RnSource occ_var
else
- case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
- RnIface wiredin_fm key_fm imp_var }
+ RnIface builtinNameMaps builtinKeysMap imp_var
rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
in
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index b94dd7fb3a1d..759848942437 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -21,14 +21,14 @@ import RnHsSyn
import RnMonad
import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) )
-import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr
+import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, initRnEnv, extendGlobalRnEnv,
+ lubExportFlag, qualNameErr, dupNamesErr, pprRnEnv
)
import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
- unionManyBags, mapBag, filterBag, listToBag, bagToList )
+ unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-}, FiniteMap )
@@ -39,7 +39,7 @@ import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
nameExportFlag, nameImportFlag,
getLocalName, getSrcLoc, getImpLocs,
moduleNamePair, pprNonSym,
- isLexCon, ExportFlag(..), OrigName(..)
+ isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
)
import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
@@ -93,7 +93,7 @@ getGlobalNames iface_cache info us
unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
- (src_env, src_dups) = extendGlobalRnEnv emptyRnEnv unqual_vals unqual_tcs
+ (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs
(all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
-- remove dups of the same imported thing
@@ -108,6 +108,9 @@ getGlobalNames iface_cache info us
all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
in
+-- pprTrace "initRnEnv:" (pprRnEnv PprDebug initRnEnv) $
+-- pprTrace "src_env:" (pprRnEnv PprDebug src_env) $
+-- pprTrace "all_env:" (pprRnEnv PprDebug all_env) $
return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
\end{code}
@@ -406,25 +409,19 @@ doImportDecls iface_cache g_info us src_imps
imp_errs `unionBags` errs,
imp_warns `unionBags` warns)
where
- the_imps = implicit_prel ++ src_imps
- all_imps = implicit_qprel ++ the_imps
+ all_imps = implicit_prel ++ src_imps
+-- all_imps = implicit_qprel ++ the_imps
- implicit_qprel = ImportDecl gHC_BUILTINS True Nothing Nothing prel_loc
- : (if opt_NoImplicitPrelude
- then [{- no "import qualified Prelude" -}]
- else [ImportDecl pRELUDE True Nothing Nothing prel_loc])
+ explicit_prelude_imp
+ = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
- explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
- mod == pRELUDE ])
-
- implicit_prel = ImportDecl gHC_BUILTINS False Nothing Nothing prel_loc
- : (if explicit_prelude_imp || opt_NoImplicitPrelude
- then [{- no "import Prelude" -}]
- else [ImportDecl pRELUDE False Nothing Nothing prel_loc])
+ implicit_prel | opt_NoImplicitPrelude = []
+ | explicit_prelude_imp = [ImportDecl pRELUDE True Nothing Nothing prel_loc]
+ | otherwise = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
prel_loc = mkBuiltinSrcLoc
- (uniq_imps, imp_dups) = removeDups cmp_mod the_imps
+ (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
@@ -443,7 +440,7 @@ doImportDecls iface_cache g_info us src_imps
where
has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= gHC_BUILTINS ]
+ imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
imp_warns = listToBag (map dupImportWarn imp_dups)
`unionBags`
@@ -513,17 +510,14 @@ doImport :: IfaceCache
Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
- = let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec -- NB: a no-op ToDo:rm
- in
- (if mod == gHC_BUILTINS then
- return (Succeeded (panic "doImport:GHC fake import!"),
- \ iface -> ([], [], emptyBag))
- else
- --pprTrace "doImport:" (ppPStr mod) $
- cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
- return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec')
- ) >>= \ (maybe_iface, do_ies) ->
+ = --let
+ -- (b_vals, b_tcs, maybe_spec')
+ -- = (emptyBag, emptyBag, maybe_spec)
+ --in
+ --pprTrace "doImport:" (ppPStr mod) $
+ cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
+ return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec)
+ >>= \ (maybe_iface, do_ies) ->
case maybe_iface of
Failed err ->
@@ -538,15 +532,14 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
accumulate (map (checkOrigIE iface_cache) chk_ies)
>>= \ chk_errs_warns ->
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
+ fold_ies = foldBag unionBags pair_occ emptyBag
+
+ final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
+ final_tcs = {-OLD:mapBag fst_occ b_tcs `unionBags`-} fold_ies ie_tcs
final_vals_list = bagToList final_vals
in
- (if mod == gHC_BUILTINS then
- return [ (Nothing, emptyBag) | _ <- final_vals_list ]
- else
- accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
- ) >>= \ fix_maybes_errs ->
+ accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
+ >>= \ fix_maybes_errs ->
let
(chk_errs, chk_warns) = unzip chk_errs_warns
(fix_maybes, fix_errs) = unzip fix_maybes_errs
@@ -575,13 +568,23 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
fst_occ (str, rn) = (mk_occ str, rn)
- pair_occ :: RnName -> (RdrName, RnName)
- pair_occ rn = (mk_occ (getLocalName rn), rn)
+ pair_occ :: RnName -> Bag (RdrName, RnName)
+ pair_occ rn
+ = let
+ str = getLocalName rn
+ qual_bag = unitBag (Qual as_mod str, rn)
+ in
+ if qual
+ then qual_bag
+ else qual_bag -- the qualified name is *also* visible
+ `snocBag` (Unqual str, rn)
+
pair_as :: RnName -> (Module, RnName)
pair_as rn = (as_mod, rn)
-----------------------------
+{-
getBuiltins :: ImportNameInfo
-> Module
-> Maybe (Bool, [RdrNameIE])
@@ -591,10 +594,9 @@ getBuiltins :: ImportNameInfo
)
getBuiltins _ modname maybe_spec
---OLD: | modname `notElem` modulesWithBuiltins
+-- | modname `notElem` modulesWithBuiltins
= (emptyBag, emptyBag, maybe_spec)
-{-
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
= case maybe_spec of
Nothing -> (all_vals, all_tcs, Nothing)
@@ -677,13 +679,18 @@ getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- imp
mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
mkAllIE (orig,ExportAbs)
- = ASSERT(isLexCon (nameOf orig))
+ = --ASSERT(isLexCon (nameOf orig))
+ -- the ASSERT is correct, but it is too easy to
+ -- trigger when writing .hi files by hand (e.g.
+ -- when hackily breaking a module loop)
IEThingAbs orig
mkAllIE (orig, ExportAll)
- | isLexCon (nameOf orig)
+ | isLexCon name_orig || isLexSpecialSym name_orig
= IEThingAll orig
| otherwise
= IEVar orig
+ where
+ name_orig = nameOf orig
------------
lookupIEs :: ExportsMap
@@ -761,11 +768,13 @@ doOrigIE iface_cache info mod src_loc us ie
where
avoided_fn Nothing -- the thing should be in the source
= (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
- avoided_fn (Just (Left rn)) -- a builtin value brought into scope
+ avoided_fn (Just (Left rn@(WiredInId _))) -- a builtin value brought into scope
= (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
- avoided_fn (Just (Right rn)) -- a builtin tc/class brought into scope
- = --pprTrace "avoided:Right:" (ppr PprShowAll rn) $
- (emptyBag, unitBag rn, emptyBag, emptyBag, emptyBag)
+ avoided_fn (Just (Right rn@(WiredInTyCon tc)))
+ -- a builtin tc brought into scope; we also must bring its
+ -- data constructors into scope
+ = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
+ (listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
-------------------------
checkOrigIE :: IfaceCache
@@ -810,11 +819,13 @@ with_decl :: IfaceCache
-> IO something
with_decl iface_cache n do_avoid do_err do_decl
- = cachedDecl iface_cache (isLexCon (nameOf n)) n >>= \ maybe_decl ->
+ = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n >>= \ maybe_decl ->
case maybe_decl of
CachingAvoided info -> return (do_avoid info)
CachingFail err -> return (do_err err)
CachingHit decl -> return (do_decl decl)
+ where
+ n_name = nameOf n
-------------
getFixityDecl :: IfaceCache
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 3829b51be665..277862f3bf0e 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -25,7 +25,7 @@ import Class ( derivableClassKeys )
import CmdLineOpts ( opt_CompilingGhcInternals )
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
-import Id ( GenId{-instance NamedThing-} )
+import Id ( isDataCon, GenId{-instance NamedThing-} )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
@@ -63,6 +63,8 @@ rnSource :: [Module] -- imported modules
-> RdrNameHsModule
-> RnM s (RenamedHsModule,
Name -> ExportFlag, -- export info
+ ([(Name, ExportFlag)], -- export module X stuff
+ [(Name, ExportFlag)]),
Bag (RnName, RdrName)) -- occurrence info
rnSource imp_mods unqual_imps imp_fixes
@@ -73,7 +75,7 @@ rnSource imp_mods unqual_imps imp_fixes
= pushSrcLocRn src_loc $
- rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
+ rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ (exported_fn, module_dotdots) ->
rnFixes fixes `thenRn` \ src_fixes ->
let
all_fixes = src_fixes ++ bagToList imp_fixes
@@ -99,7 +101,7 @@ rnSource imp_mods unqual_imps imp_fixes
new_ty_decls new_specdata_sigs new_class_decls
new_inst_decls new_specinst_sigs new_defaults
new_binds [] src_loc,
- exported_fn,
+ exported_fn, module_dotdots,
occ_info
)
where
@@ -118,10 +120,15 @@ rnSource imp_mods unqual_imps imp_fixes
rnExports :: [Module]
-> Bag (Module,RnName)
-> Maybe [RdrNameIE]
- -> RnM s (Name -> ExportFlag)
+ -> RnM s (Name -> ExportFlag, -- main export-flag fun
+ ([(Name,ExportFlag)], -- info about "module X" exports
+ [(Name,ExportFlag)])
+ )
rnExports mods unqual_imps Nothing
- = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
+ = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported
+ , ([], [])
+ )
rnExports mods unqual_imps (Just exps)
= getModuleRn `thenRn` \ this_mod ->
@@ -141,7 +148,7 @@ rnExports mods unqual_imps (Just exps)
(uniq_mods, dup_mods) = removeDups cmpPString exp_mods
(expmods_this, expmods_imps) = partition (== this_mod) uniq_mods
- -- Get names for module This_Mod export
+ -- Get names for "module This_Mod" export
(this_tcs, this_vals)
= if null expmods_this
then ([], [])
@@ -155,16 +162,23 @@ rnExports mods unqual_imps (Just exps)
(unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
get_mod_names mod
- = (tcs, vals, empty_mod)
+ = --pprTrace "get_mod_names" (ppAboves [ppPStr mod, interpp'SP PprDebug (map fst tcs), interpp'SP PprDebug (map fst vals)]) $
+ (tcs, vals, empty_mod)
where
tcs = [(getName rn, nameImportFlag (getName rn))
| (mod',rn) <- unqual_tcs, mod == mod']
vals = [(getName rn, nameImportFlag (getName rn))
- | (mod',rn) <- unqual_vals, mod == mod']
+ | (mod',rn) <- unqual_vals, mod == mod', fun_looking rn]
empty_mod = if null tcs && null vals
then Just mod
else Nothing
+ -- fun_looking: must avoid class ops and data constructors
+ -- and record fieldnames
+ fun_looking (RnName _) = True
+ fun_looking (WiredInId i) = not (isDataCon i)
+ fun_looking _ = False
+
-- Build finite map of exported names to export flag
tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
tc_map1 = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs)
@@ -198,8 +212,17 @@ rnExports mods unqual_imps (Just exps)
mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_`
mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_`
- returnRn exp_fn
+ returnRn (exp_fn, (mod_vals, mod_tcs))
+
+------------------------------------
+-- rename an "IE" in the export list
+rnIE :: [Module] -- this module and all the (directly?) imported modules
+ -> RdrNameIE
+ -> RnM s (
+ Maybe Module, -- Just m => a "module X" export item
+ (Bag (Name, ExportFlag), -- Exported tycons/classes
+ Bag (Name, ExportFlag))) -- Exported values
rnIE mods (IEVar name)
= lookupValue name `thenRn` \ rn ->
@@ -249,7 +272,7 @@ rnIE mods (IEThingAll name)
warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
(synAllExportErr False{-warning-} rn src_loc)
- checkIEAll rn = pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
+ checkIEAll rn = --pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
returnRn (emptyBag, emptyBag)
exp_all n = (n, ExportAll)
@@ -622,7 +645,7 @@ rnFixes fixities
rn_fixity_pieces mk_fixity name i fix
= getRnEnv `thenRn` \ env ->
case lookupGlobalRnEnv env name of
- Just res | isLocallyDefined res || opt_CompilingGhcInternals
+ Just res | isLocallyDefined res -- || opt_CompilingGhcInternals
-- the opt_CompilingGhcInternals thing is a *HACK* to get (:)'s
-- fixity decl to go through. It has a builtin name, which
-- doesn't respond to isLocallyDefined... sigh.
diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs
index 781aa8bcf85a..acf64f71ac39 100644
--- a/ghc/compiler/rename/RnUtils.lhs
+++ b/ghc/compiler/rename/RnUtils.lhs
@@ -9,28 +9,31 @@
module RnUtils (
SYN_IE(RnEnv), SYN_IE(QualNames),
SYN_IE(UnqualNames), SYN_IE(ScopeStack),
- emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
+ emptyRnEnv, initRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
getLocalsFromRnEnv,
lubExportFlag,
qualNameErr,
- dupNamesErr
+ dupNamesErr,
+ pprRnEnv -- debugging only
) where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(List(partition))
import Bag ( Bag, emptyBag, snocBag, unionBags )
-import CmdLineOpts ( opt_CompilingGhcInternals )
+import CmdLineOpts ( opt_GlasgowExts )
import ErrUtils ( addShortErrLocLine )
-import FiniteMap ( FiniteMap, emptyFM, isEmptyFM,
- lookupFM, addListToFM, addToFM, eltsFM )
+import FiniteMap ( emptyFM, isEmptyFM, fmToList, listToFM, keysFM,
+ lookupFM, addListToFM, addToFM, eltsFM, FiniteMap )
import Maybes ( maybeToBool )
import Name ( RdrName(..), ExportFlag(..),
isQual, pprNonSym, getLocalName, isLocallyDefined )
import PprStyle ( PprStyle(..) )
+import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
+import PrelMods ( gHC_BUILTINS )
import Pretty
import RnHsSyn ( RnName )
import Util ( assertPanic )
@@ -53,6 +56,7 @@ type UnqualNames = FiniteMap FAST_STRING RnName
type ScopeStack = FiniteMap FAST_STRING RnName
emptyRnEnv :: RnEnv
+initRnEnv :: RnEnv
extendGlobalRnEnv :: RnEnv -> [(RdrName,RnName)] -> [(RdrName,RnName)]
-> (RnEnv, Bag (RdrName, RnName, RnName))
extendLocalRnEnv :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName])
@@ -80,8 +84,28 @@ seperately.
It optionally reports any shadowed names.
\begin{code}
-emptyRnEnv
- = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
+emptyRnEnv = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
+
+ -- an emptyRnEnv is empty; the initRnEnv may have
+ -- primitive names already in it (both unqual and qual),
+ -- and quals for all the other wired-in dudes.
+
+initRnEnv
+ = if (not opt_GlasgowExts) then
+ emptyRnEnv
+ else
+ ((listToFM qual, listToFM unqual, listToFM tc_qual, listToFM tc_unqual), emptyFM)
+ where
+ qual = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinValNamesMap ]
+ tc_qual = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinTcNamesMap ]
+
+ builtin_qual = filter (\ ((_,m),_) -> m == gHC_BUILTINS) qual
+ builtin_tc_qual = filter (\ ((_,m),_) -> m == gHC_BUILTINS) tc_qual
+
+ unqual = map (\ ((n,_),rn) -> (n,rn)) builtin_qual
+ tc_unqual = map (\ ((n,_),rn) -> (n,rn)) builtin_tc_qual
+
+-----------------
extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list
= ASSERT(isEmptyFM stack)
@@ -129,16 +153,13 @@ extendLocalRnEnv report_shadows (global, stack) new_local
ext_dups = if maybeToBool (lookupFM stack str)
then name:dups
else dups
+\end{code}
-
+\begin{code}
lookupRnEnv ((qual, unqual, _, _), stack) rdr
= case rdr of
- Unqual str -> lookup stack str (lookup unqual str Nothing)
- Qual mod str -> lookup qual (str,mod)
- (if not opt_CompilingGhcInternals -- see below
- then -- pprTrace "lookupRnEnv:" (ppAboves (ppCat [ppPStr mod, ppPStr str] : [ ppCat [ppPStr m, ppPStr s] | (s,m) <- keysFM qual ])) $
- Nothing
- else lookup unqual str Nothing)
+ Unqual str -> lookup stack str (lookupFM unqual str)
+ Qual mod str -> lookupFM qual (str,mod)
where
lookup fm thing do_on_fail
= case lookupFM fm thing of
@@ -148,25 +169,12 @@ lookupRnEnv ((qual, unqual, _, _), stack) rdr
lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr
= case rdr of
Unqual str -> lookupFM unqual str
- Qual mod str -> case (lookupFM qual (str,mod)) of
- Just xx -> Just xx
- Nothing -> if not opt_CompilingGhcInternals then
- Nothing
- else -- "[]" may have turned into "Prelude.[]" and
- -- we are actually compiling "data [] a = ...";
- -- maybe the right thing is to get "Prelude.[]"
- -- into the "qual" table...
- lookupFM unqual str
+ Qual mod str -> lookupFM qual (str,mod)
lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
= case rdr of
Unqual str -> lookupFM tc_unqual str
- Qual mod str -> case (lookupFM tc_qual (str,mod)) of -- as above
- Just xx -> Just xx
- Nothing -> if not opt_CompilingGhcInternals then
- Nothing
- else
- lookupFM tc_unqual str
+ Qual mod str -> lookupFM tc_qual (str,mod)
getLocalsFromRnEnv ((_, vals, _, tcs), _)
= (filter isLocallyDefined (eltsFM vals),
@@ -209,5 +217,20 @@ dupNamesErr descriptor ((name1,locn1) : dup_things) sty
= addShortErrLocLine locn (\ sty ->
ppBesides [ppStr "here was another declaration of `",
pprNonSym sty name, ppStr "'" ]) sty
-\end{code}
+-----------------
+pprRnEnv :: PprStyle -> RnEnv -> Pretty
+
+pprRnEnv sty ((qual, unqual, tc_qual, tc_unqual), stack)
+ = ppAboves [ ppStr "Stack:"
+ , ppCat (map ppPStr (keysFM stack))
+ , ppStr "Val qual:"
+ , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM qual]
+ , ppStr "Val unqual:"
+ , ppCat (map ppPStr (keysFM unqual))
+ , ppStr "Tc qual:"
+ , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM tc_qual]
+ , ppStr "Tc unqual:"
+ , ppCat (map ppPStr (keysFM tc_unqual))
+ ]
+\end{code}
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 8a9187163bb7..aed02576fad1 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -44,7 +44,7 @@ import TyVar ( GenTyVar{-instance Eq-} )
import Unique ( Unique{-instance Eq-} )
import Util ( assoc, zipEqual, pprTrace, panic )
-isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
+isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
\end{code}
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index be0ac4849a81..03401ce5d689 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -83,7 +83,7 @@ completeVar env var args
GenForm form_summary template guidance
-> considerUnfolding env var args
- (panic "completeVar"{-txt_occ-}) form_summary template guidance
+ (False{-ToDo:!-}{-txt_occ-}) form_summary template guidance
MagicForm str magic_fun
-> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 7d7f5e33d9f1..c3a8d4b2882a 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -476,14 +476,19 @@ coreExprToStg env expr@(Lam _ _)
\begin{code}
coreExprToStg env expr@(App _ _)
= let
- (fun, _, _, args) = collectArgs expr
+ (fun,args) = collect_args expr []
in
-- Deal with the arguments
coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
-- Now deal with the function
- case fun of
- Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
+ case (fun, args) of
+ (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
+ -- there are no arguments.
+ returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
+
+ (non_var_fun, []) -> -- No value args, so recurse into the function
+ coreExprToStg env non_var_fun
other -> -- A non-variable applied to things; better let-bind it.
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
@@ -499,6 +504,12 @@ coreExprToStg env expr@(App _ _)
returnUs (StgLet (StgNonRec fun_id fun_rhs)
(StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
arg_binds `unionBags` fun_binds)
+ where
+ -- Collect arguments, discarding type/usage applications
+ collect_args (App e (TyArg _)) args = collect_args e args
+ collect_args (App e (UsageArg _)) args = collect_args e args
+ collect_args (App fun arg) args = collect_args fun (arg:args)
+ collect_args fun args = (fun, args)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 10f5e4221a81..11adf777a533 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -44,7 +44,7 @@ import Util ( isIn, isn'tIn, nOfThem, zipWithEqual,
pprTrace, panic, pprPanic, assertPanic
)
-returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)"
+returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index fd4445b6511c..34685fb43c1f 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -17,7 +17,7 @@ import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict,
opt_D_dump_stranal, opt_D_simplifier_stats
)
import CoreSyn
-import Id ( idType, addIdStrictness,
+import Id ( idType, addIdStrictness, isWrapperId,
getIdDemandInfo, addIdDemandInfo,
GenId{-instance Outputable-}
)
@@ -33,12 +33,9 @@ import SaLib
import TyVar ( GenTyVar{-instance Eq-} )
import WorkWrap -- "back-end" of strictness analyser
import Unique ( Unique{-instance Eq -} )
-import Util ( zipWith4Equal, pprTrace, panic{-ToDo:rm-} )
-
-isWrapperId = panic "StrictAnal.isWrapperId (ToDo)"
+import Util ( zipWith4Equal, pprTrace, panic )
\end{code}
-
%************************************************************************
%* *
\subsection[Thoughts]{Random thoughts}
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index e433e94346f5..3df667f37a7c 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -11,10 +11,12 @@ module WorkWrap ( workersAndWrappers ) where
IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( UnfoldingGuidance(..) )
+import CoreUnfold ( UnfoldingDetails(..){-ToDo:rm-}, UnfoldingGuidance(..) )
+IMPORT_DELOOPER(IdLoop) -- ToDo:rm when iWantToBeINLINEd goes
+
import CoreUtils ( coreExprType )
import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId,
- getIdInfo, GenId
+ getIdInfo, replaceIdInfo, GenId
)
import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker,
mkStrictnessInfo, StrictnessInfo(..)
@@ -22,10 +24,9 @@ import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker,
import SaLib
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
import WwLib
-import Util ( panic{-ToDo:rm-} )
-replaceIdInfo = panic "WorkWrap.replaceIdInfo (ToDo)"
-iWantToBeINLINEd = panic "WorkWrap.iWantToBeINLINEd (ToDo)"
+iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
+iWantToBeINLINEd x = NoUnfoldingDetails --ToDo:panic "WorkWrap.iWantToBeINLINEd (ToDo)"
\end{code}
We take Core bindings whose binders have their strictness attached (by
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 091ce48d7f58..9d7b16d83e27 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -56,7 +56,7 @@ import TyVar ( SYN_IE(TyVarEnv), nullTyVarEnv )
import Unify ( unifyTauTy )
import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
filterUFM, eltsUFM )
-import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
+import Unique ( iOTyConKey )
import Util
import FiniteMap ( emptyFM, FiniteMap )
@@ -205,8 +205,6 @@ tcModule rn_env
`thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
- checkTopLevelIds mod_name final_env `thenTc_`
-
-- Deal with constant or ambiguous InstIds. How could
-- there be ambiguous ones? They can only arise if a
-- top-level decl falls under the monomorphism
@@ -260,55 +258,3 @@ tcModule rn_env
cls_decls_bag = listToBag cls_decls
inst_decls_bag = listToBag inst_decls
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Error checking code}
-%* *
-%************************************************************************
-
-
-checkTopLevelIds checks that Main.main or GHCmain.mainPrimIO has correct type.
-
-\begin{code}
-checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
-
-checkTopLevelIds mod final_env
- | mod /= SLIT("Main") && mod /= SLIT("GHCmain")
- = returnTc ()
-
- | mod == SLIT("Main")
- = tcSetEnv final_env (
- tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main ->
- tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc ->
-
- case maybe_main of
- Just main -> tcAddErrCtxt mainCtxt $
- unifyTauTy (applyTyCon io_tc [unitTy])
- (idType main)
-
- Nothing -> failTc (mainNoneIdErr "Main" "main")
- )
-
- | mod == SLIT("GHCmain")
- = tcSetEnv final_env (
- tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim ->
-
- case maybe_prim of
- Just prim -> tcAddErrCtxt primCtxt $
- unifyTauTy (mkPrimIoTy unitTy)
- (idType prim)
-
- Nothing -> failTc (mainNoneIdErr "GHCmain" "mainPrimIO")
- )
-
-mainCtxt sty
- = ppStr "Main.main should have type IO ()"
-
-primCtxt sty
- = ppStr "GHCmain.mainPrimIO should have type PrimIO ()"
-
-mainNoneIdErr mod n sty
- = ppCat [ppPStr SLIT("module"), ppStr mod, ppPStr SLIT("does not contain a definition for"), ppStr n]
-\end{code}
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index 638058718bdc..9fba979300f6 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -44,7 +44,7 @@ Unify two @TauType@s. Dead straightforward.
\begin{code}
unifyTauTy :: TcTauType s -> TcTauType s -> TcM s ()
-unifyTauTy ty1 ty2
+unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred
= tcAddErrCtxtM (unifyCtxt ty1 ty2) $
uTys ty1 ty1 ty2 ty2
\end{code}
@@ -327,14 +327,14 @@ Errors
~~~~~~
\begin{code}
-unifyCtxt ty1 ty2
+unifyCtxt ty1 ty2 -- ty1 expected, ty2 inferred
= zonkTcType ty1 `thenNF_Tc` \ ty1' ->
zonkTcType ty2 `thenNF_Tc` \ ty2' ->
returnNF_Tc (err ty1' ty2')
where
err ty1' ty2' sty = ppAboves [
- ppCat [ppStr "When matching:", ppr sty ty1'],
- ppCat [ppStr " against:", ppr sty ty2']
+ ppCat [ppStr "Expected:", ppr sty ty1'],
+ ppCat [ppStr "Inferred:", ppr sty ty2']
]
unifyMisMatch ty1 ty2 sty
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 5c34749de82a..fd203292bd2f 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -16,6 +16,7 @@ module PprType(
getTypeString,
typeMaybeString,
specMaybeTysSuffix,
+ getTyDescription,
GenClass,
GenClassOp, pprGenClassOp,
@@ -25,8 +26,8 @@ module PprType(
) where
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-IMPORT_DELOOPER(TyLoop) -- for paranoia checking
+IMPORT_DELOOPER(IdLoop)
+--IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-- friends:
-- (PprType can see all the representations it's trying to print)
@@ -391,13 +392,13 @@ getTypeString ty
where
do_tc (TyConTy tc _) = Left (origName "do_tc" tc)
do_tc (SynTy _ _ ty) = do_tc ty
- do_tc other = pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
+ do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
Right (_PK_ (ppShow 1000 (pprType PprForC other)))
do_arg_ty (TyConTy tc _) = Left (origName "do_arg_ty" tc)
do_arg_ty (TyVarTy tv) = Right (_PK_ (ppShow 80 (ppr PprForC tv)))
do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
- do_arg_ty other = pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
+ do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
Right (_PK_ (ppShow 1000 (pprType PprForC other)))
-- PprForC expands type synonyms as it goes;
@@ -439,6 +440,27 @@ specMaybeTysSuffix ty_maybes
-}
\end{code}
+Grab a name for the type. This is used to determine the type
+description for profiling.
+\begin{code}
+getTyDescription :: Type -> String
+
+getTyDescription ty
+ = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
+ case tau_ty of
+ TyVarTy _ -> "*"
+ AppTy fun _ -> getTyDescription fun
+ FunTy _ res _ -> '-' : '>' : fun_result res
+ TyConTy tycon _ -> _UNPK_ (getLocalName tycon)
+ SynTy tycon _ _ -> _UNPK_ (getLocalName tycon)
+ DictTy _ _ _ -> "dict"
+ _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
+ }
+ where
+ fun_result (FunTy _ res _) = '>' : fun_result res
+ fun_result other = getTyDescription other
+\end{code}
+
ToDo: possibly move:
\begin{code}
nmbrType :: Type -> NmbrM Type
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index d79ce4d1997f..a6b4730cc462 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -61,10 +61,10 @@ import Pretty ( SYN_IE(Pretty), PrettyRep )
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic, pprPanic{-ToDo:rm-} )
-import {-hide me-}
- PprType (pprTyCon)
-import {-hide me-}
- PprStyle--ToDo:rm
+--import {-hide me-}
+-- PprType (pprTyCon)
+--import {-hide me-}
+-- PprStyle--ToDo:rm
\end{code}
\begin{code}
@@ -238,7 +238,7 @@ tyConDataCons other = []
tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
tyConFamilySize (TupleTyCon _ _ _) = 1
#ifdef DEBUG
-tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
+--tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
#endif
tyConPrimRep :: TyCon -> PrimRep
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index 913a7b29e171..b7fc8b7d581e 100644
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -24,7 +24,7 @@ module TyVar (
) where
CHK_Ubiq() -- debugging consistency check
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+--IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-- friends
import Usage ( GenUsage, SYN_IE(Usage), usageOmega )
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 581167995510..588c8b4cbfdd 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -21,7 +21,7 @@ module Type (
SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
mkDictTy,
- mkRhoTy, splitRhoTy, mkTheta,
+ mkRhoTy, splitRhoTy, mkTheta, isDictTy,
mkSigmaTy, splitSigmaTy,
maybeAppTyCon, getAppTyCon,
@@ -41,9 +41,9 @@ module Type (
) where
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
+--IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop)
+--IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
-- friends:
import Class ( classSig, classOpLocalType, GenClass{-instances-} )
@@ -72,8 +72,8 @@ import {-mumble-}
Pretty
import {-mumble-}
PprStyle
-import {-mumble-}
- PprType --(pprType )
+--import {-mumble-}
+-- PprType --(pprType )
import {-mumble-}
UniqFM (ufmToList )
import {-mumble-}
@@ -281,8 +281,8 @@ mkTyConTy tycon
applyTyCon :: TyCon -> [GenType t u] -> GenType t u
applyTyCon tycon tys
- = --ASSERT (not (isSynTyCon tycon))
- (if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
+ = ASSERT (not (isSynTyCon tycon))
+ --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
foldl AppTy (TyConTy tycon usageOmega) tys
getTyCon_maybe :: GenType t u -> Maybe TyCon
@@ -348,7 +348,11 @@ mkTheta dict_tys
= map cvt dict_tys
where
cvt (DictTy clas ty _) = (clas, ty)
- cvt other = pprPanic "mkTheta:" (pprType PprDebug other)
+ cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
+
+isDictTy (DictTy _ _ _) = True
+isDictTy (SynTy _ _ t) = isDictTy t
+isDictTy _ = False
\end{code}
@@ -686,7 +690,7 @@ typePrimRep (AppTy ty _) = typePrimRep ty
typePrimRep (TyConTy tc _)
| isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
Just xx -> xx
- Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
+ Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
| otherwise = case maybeNewTyCon tc of
Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index 3eab99e875fb..c95f0b4626f0 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -73,8 +73,6 @@ IMP_Ubiq(){-uitous-}
import Pretty
# endif
import Bag ( foldBag )
-import {-hide from mkdependHS-}
- Name ( RdrName, OrigName ) -- specialising only
# if ! OMIT_NATIVE_CODEGEN
# define IF_NCG(a) a
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
index 1632c4bf96be..97c7b3193fa0 100644
--- a/ghc/compiler/utils/Ubiq.lhi
+++ b/ghc/compiler/utils/Ubiq.lhi
@@ -150,11 +150,19 @@ type Usage = GenUsage Unique
-- These are here only for SPECIALIZing in FiniteMap (ToDo:move?)
instance Ord Reg
+instance Ord OrigName
instance Ord RdrName
instance Ord CLabel
instance Ord TyCon
instance Eq Reg
+instance Eq OrigName
instance Eq RdrName
instance Eq CLabel
instance Eq TyCon
+-- specializing in UniqFM, UniqSet
+instance Uniquable Unique
+instance Uniquable RnName
+instance Uniquable Name
+-- specializing in Name
+instance NamedThing RnName
\end{code}
diff --git a/ghc/compiler/utils/Ubiq_1_3.lhi b/ghc/compiler/utils/Ubiq_1_3.lhi
index f0995efe0b72..2636612961cb 100644
--- a/ghc/compiler/utils/Ubiq_1_3.lhi
+++ b/ghc/compiler/utils/Ubiq_1_3.lhi
@@ -44,6 +44,7 @@ Literal Literal
Maybes MaybeErr
Name ExportFlag
Name Module
+Name Name
Name NamedThing (..)
Name OrigName (..)
Name RdrName (..)
@@ -52,6 +53,7 @@ PprStyle PprStyle
PragmaInfo PragmaInfo
PrimOp PrimOp
PrimRep PrimRep
+RnHsSyn RnName
SrcLoc SrcLoc
TyCon Arity
TyCon TyCon
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index f7f1cbabebd8..09723c824e0d 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -55,10 +55,6 @@ module UniqFM (
#if defined(COMPILING_GHC)
IMP_Ubiq(){-uitous-}
-import {-hide from mkdependHS-}
- Name ( Name ) -- specialising only
-import {-hide from mkdependHS-}
- RnHsSyn ( RnName ) -- specialising only
#endif
import Unique ( Unique, u2i, mkUniqueGrimily )
diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs
index 5216e14bb301..5d892fb2e848 100644
--- a/ghc/compiler/utils/UniqSet.lhs
+++ b/ghc/compiler/utils/UniqSet.lhs
@@ -30,9 +30,6 @@ import Pretty ( SYN_IE(Pretty), PrettyRep )
import PprStyle ( PprStyle )
import Util ( Ord3(..) )
-import {-hide from mkdependHS-}
- RnHsSyn ( RnName ) -- specialising only
-
#if ! OMIT_NATIVE_CODEGEN
#define IF_NCG(a) a
#else
diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs
index 8e35e3c1956b..aa0f7536ed05 100644
--- a/ghc/compiler/utils/Unpretty.lhs
+++ b/ghc/compiler/utils/Unpretty.lhs
@@ -93,7 +93,7 @@ uppInt n = cInt n
uppInteger n = cStr (show n)
uppSP = cCh ' '
-upp'SP{-'-} = cPStr SLIT(", ")
+upp'SP{-'-} = uppBeside uppComma uppSP
uppLbrack = cCh '['
uppRbrack = cCh ']'
uppLparen = cCh '('
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 1b92fff6f0df..c3f503942d48 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -85,6 +85,7 @@ module Util (
#if defined(COMPILING_GHC)
CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(List(zipWith4))
import Pretty
#endif
--
GitLab