From: partain Date: Mon, 15 Jul 1996 11:34:07 +0000 (+0000) Subject: [project @ 1996-07-15 11:32:34 by partain] X-Git-Tag: Approximately_1000_patches_recorded~897 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=573ef10b2afd99d3c6a36370a9367609716c97d2;p=ghc-hetmet.git [project @ 1996-07-15 11:32:34 by partain] partain changes to 960714 --- diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index 766582e..aa10578 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 7fc7505..85914c9 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 ad761ad..a0538b4 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 4a2b799..d3eb0d5 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 03fb6c2..e12b0db 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 953f435..104953a 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 8bf533f..d0f9bf8 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 8e9ae24..dff65e5 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 1c3d61a..1d4afc3 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 06f4be4..9090e77 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 309d62d..fba4be2 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 250c98e..a8f41bd 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 6dd80c1..f59bb89 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 08537bc..e165b3c 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 99169c1..50eed96 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 5afed2e..54a6783 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 e560455..43d1ebb 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 6a51d9c..de2bb90 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 be9b18d..3d1665b 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 3a5f86c..b9edb42 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 2700839..b630191 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' 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' 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 8096274..f659a9b 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 3e3fb44..9073270 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 04d4302..08266c6 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 02194ae..3c827c1 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 f1618ad..ac8dc51 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 51366db..f805e31 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 e6b7c93..0f668bf 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 b94dd7f..7598489 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 3829b51..277862f 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 781aa8b..acf64f7 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 8a91871..aed0257 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 be0ac48..03401ce 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 7d7f5e3..c3a8d4b 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 10f5e42..11adf77 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 fd4445b..34685fb 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 e433e94..3df667f 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 091ce48..9d7b16d 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 6380587..9fba979 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 5c34749..fd20329 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 d79ce4d..a6b4730 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 913a7b2..b7fc8b7 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 5811679..588c8b4 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 3eab99e..c95f0b4 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 1632c4b..97c7b31 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 f0995ef..2636612 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 f7f1cba..09723c8 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 5216e14..5d892fb 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 8e35e3c..aa0f753 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 1b92fff..c3f5039 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