From 7a3bd641457666e10d0a47be9f22762e03defbf0 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 19 Dec 1996 09:14:20 +0000 Subject: [PATCH] [project @ 1996-12-19 09:10:02 by simonpj] SLPJ new renamer and lots more --- ghc/compiler/HsVersions.h | 1 + ghc/compiler/Makefile | 26 +- ghc/compiler/absCSyn/AbsCSyn.lhs | 2 +- ghc/compiler/absCSyn/CLabel.lhs | 16 +- ghc/compiler/absCSyn/CStrings.lhs | 2 +- ghc/compiler/absCSyn/PprAbsC.lhs | 2 +- ghc/compiler/basicTypes/FieldLabel.lhs | 5 +- ghc/compiler/basicTypes/Id.lhs | 755 ++++---------- ghc/compiler/basicTypes/IdInfo.lhs | 654 +++--------- ghc/compiler/basicTypes/IdLoop.lhi | 25 +- ghc/compiler/basicTypes/IdUtils.lhs | 59 +- ghc/compiler/basicTypes/Name.lhs | 840 +++++++-------- ghc/compiler/basicTypes/PprEnv.lhs | 43 +- ghc/compiler/basicTypes/SrcLoc.lhs | 49 +- ghc/compiler/basicTypes/UniqSupply.lhs | 6 +- ghc/compiler/basicTypes/Unique.lhs | 5 + ghc/compiler/codeGen/CgBindery.lhs | 6 +- ghc/compiler/codeGen/CgClosure.lhs | 75 +- ghc/compiler/codeGen/CgCompInfo.lhs | 15 +- ghc/compiler/codeGen/CgCon.lhs | 4 +- ghc/compiler/codeGen/CgConTbls.lhs | 8 +- ghc/compiler/codeGen/CgExpr.lhs | 140 ++- ghc/compiler/codeGen/CgRetConv.lhs | 2 +- ghc/compiler/codeGen/CgUpdate.lhs | 2 +- ghc/compiler/codeGen/ClosureInfo.lhs | 160 +-- ghc/compiler/codeGen/CodeGen.lhs | 4 +- ghc/compiler/coreSyn/CoreLift.lhs | 7 +- ghc/compiler/coreSyn/CoreSyn.lhs | 1 + ghc/compiler/coreSyn/CoreUnfold.lhs | 517 ++-------- ghc/compiler/coreSyn/CoreUtils.lhs | 101 +- ghc/compiler/coreSyn/FreeVars.lhs | 11 +- ghc/compiler/coreSyn/PprCore.lhs | 82 +- ghc/compiler/deSugar/DsBinds.lhs | 4 + ghc/compiler/deSugar/DsCCall.lhs | 32 +- ghc/compiler/deSugar/DsExpr.lhs | 18 +- ghc/compiler/deSugar/DsHsSyn.lhs | 1 + ghc/compiler/deSugar/DsListComp.lhs | 5 +- ghc/compiler/deSugar/DsMonad.lhs | 9 +- ghc/compiler/deSugar/DsUtils.lhs | 22 +- ghc/compiler/deSugar/Match.lhs | 6 +- ghc/compiler/deSugar/MatchLit.lhs | 2 +- ghc/compiler/deforest/Cyclic.lhs | 4 +- ghc/compiler/deforest/DefExpr.lhs | 2 +- ghc/compiler/deforest/DefUtils.lhs | 8 +- ghc/compiler/deforest/TreelessForm.lhs | 2 +- ghc/compiler/hsSyn/HsBinds.lhs | 88 +- ghc/compiler/hsSyn/HsCore.lhs | 214 ++-- ghc/compiler/hsSyn/HsDecls.lhs | 250 +++-- ghc/compiler/hsSyn/HsExpr.lhs | 8 +- ghc/compiler/hsSyn/HsImpExp.lhs | 10 + ghc/compiler/hsSyn/HsPat.lhs | 9 +- ghc/compiler/hsSyn/HsPragmas.lhs | 60 +- ghc/compiler/hsSyn/HsSyn.lhs | 31 +- ghc/compiler/hsSyn/HsTypes.lhs | 266 +++-- ghc/compiler/main/CmdLineOpts.lhs | 88 +- ghc/compiler/main/ErrUtils.lhs | 2 +- ghc/compiler/main/Main.lhs | 202 ++-- ghc/compiler/main/MkIface.lhs | 736 +++++++------ ghc/compiler/nativeGen/AbsCStixGen.lhs | 2 +- ghc/compiler/nativeGen/StixInteger.lhs | 2 +- ghc/compiler/nativeGen/StixMacro.lhs | 2 +- ghc/compiler/nativeGen/StixPrim.lhs | 2 +- ghc/compiler/parser/UgenUtil.lhs | 8 +- ghc/compiler/parser/hslexer.flex | 4 +- ghc/compiler/prelude/PrelInfo.lhs | 546 ++++++---- ghc/compiler/prelude/PrelLoop.lhi | 8 +- ghc/compiler/prelude/PrelMods.lhs | 28 +- ghc/compiler/prelude/PrelVals.lhs | 163 +-- ghc/compiler/prelude/PrimOp.lhs | 42 +- ghc/compiler/prelude/TysPrim.lhs | 47 +- ghc/compiler/prelude/TysWiredIn.lhs | 201 ++-- ghc/compiler/profiling/CostCentre.lhs | 8 +- ghc/compiler/profiling/SCCfinal.lhs | 4 +- ghc/compiler/reader/PrefixSyn.lhs | 2 +- ghc/compiler/reader/PrefixToHs.lhs | 171 +-- ghc/compiler/reader/RdrHsSyn.lhs | 135 ++- ghc/compiler/reader/ReadPrefix.lhs | 225 ++-- ghc/compiler/rename/ParseIface.y | 670 +++++++----- ghc/compiler/rename/ParseUtils.lhs | 427 -------- ghc/compiler/rename/Rename.lhs | 366 +++---- ghc/compiler/rename/RnBinds.lhs | 665 ++++++------ ghc/compiler/rename/RnEnv.lhs | 469 +++++++++ ghc/compiler/rename/RnExpr.lhs | 533 +++++----- ghc/compiler/rename/RnHsSyn.lhs | 225 +--- ghc/compiler/rename/RnIfaces.lhs | 1261 +++++++++------------- ghc/compiler/rename/RnLoop.lhi | 22 +- ghc/compiler/rename/RnMonad.lhs | 876 ++++++++-------- ghc/compiler/rename/RnNames.lhs | 1377 +++++++------------------ ghc/compiler/rename/RnSource.lhs | 1078 ++++++++----------- ghc/compiler/rename/RnUtils.lhs | 236 ----- ghc/compiler/simplCore/BinderInfo.lhs | 57 +- ghc/compiler/simplCore/ConFold.lhs | 4 +- ghc/compiler/simplCore/FoldrBuildWW.lhs | 6 +- ghc/compiler/simplCore/LiberateCase.lhs | 16 +- ghc/compiler/simplCore/OccurAnal.lhs | 4 +- ghc/compiler/simplCore/SATMonad.lhs | 8 +- ghc/compiler/simplCore/SetLevels.lhs | 49 +- ghc/compiler/simplCore/SimplCase.lhs | 4 +- ghc/compiler/simplCore/SimplCore.lhs | 806 +++++++++------ ghc/compiler/simplCore/SimplEnv.lhs | 62 +- ghc/compiler/simplCore/SimplMonad.lhs | 6 +- ghc/compiler/simplCore/SimplPgm.lhs | 107 +- ghc/compiler/simplCore/SimplUtils.lhs | 19 +- ghc/compiler/simplCore/SimplVar.lhs | 27 +- ghc/compiler/simplCore/Simplify.lhs | 97 +- ghc/compiler/simplStg/LambdaLift.lhs | 9 +- ghc/compiler/simplStg/SatStgRhs.lhs | 11 +- ghc/compiler/simplStg/SimplStg.lhs | 217 +--- ghc/compiler/simplStg/StgSAT.lhs | 178 ---- ghc/compiler/simplStg/StgSATMonad.lhs | 167 --- ghc/compiler/simplStg/UpdAnal.lhs | 4 +- ghc/compiler/specialise/SpecUtils.lhs | 34 +- ghc/compiler/specialise/Specialise.lhs | 2 +- ghc/compiler/stgSyn/CoreToStg.lhs | 447 ++------ ghc/compiler/stgSyn/StgSyn.lhs | 44 +- ghc/compiler/stgSyn/StgUtils.lhs | 8 +- ghc/compiler/stranal/SaAbsInt.lhs | 7 +- ghc/compiler/stranal/SaLib.lhs | 5 +- ghc/compiler/stranal/StrictAnal.lhs | 7 - ghc/compiler/stranal/WorkWrap.lhs | 30 +- ghc/compiler/stranal/WwLib.lhs | 41 +- ghc/compiler/typecheck/GenSpecEtc.lhs | 6 +- ghc/compiler/typecheck/Inst.lhs | 26 +- ghc/compiler/typecheck/TcBinds.lhs | 63 +- ghc/compiler/typecheck/TcClassDcl.lhs | 254 +---- ghc/compiler/typecheck/TcDefaults.lhs | 38 +- ghc/compiler/typecheck/TcDeriv.lhs | 256 ++--- ghc/compiler/typecheck/TcEnv.lhs | 142 ++- ghc/compiler/typecheck/TcExpr.lhs | 13 +- ghc/compiler/typecheck/TcGRHSs.lhs | 2 +- ghc/compiler/typecheck/TcGenDeriv.lhs | 570 +++++----- ghc/compiler/typecheck/TcHsSyn.lhs | 11 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 276 ++++- ghc/compiler/typecheck/TcInstDcls.lhs | 258 +++-- ghc/compiler/typecheck/TcInstUtil.lhs | 121 +-- ghc/compiler/typecheck/TcKind.lhs | 2 +- ghc/compiler/typecheck/TcLoop.lhi | 4 +- ghc/compiler/typecheck/TcMatches.lhs | 9 +- ghc/compiler/typecheck/TcModule.lhs | 85 +- ghc/compiler/typecheck/TcMonad.lhs | 102 +- ghc/compiler/typecheck/TcMonoType.lhs | 152 +-- ghc/compiler/typecheck/TcPat.lhs | 9 +- ghc/compiler/typecheck/TcSimplify.lhs | 49 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 148 +-- ghc/compiler/typecheck/TcTyDecls.lhs | 227 ++-- ghc/compiler/typecheck/TcType.lhs | 2 +- ghc/compiler/typecheck/Unify.lhs | 2 +- ghc/compiler/types/Class.lhs | 112 +- ghc/compiler/types/Kind.lhs | 26 +- ghc/compiler/types/PprType.lhs | 234 ++--- ghc/compiler/types/TyCon.lhs | 26 +- ghc/compiler/types/TyLoop.lhi | 7 +- ghc/compiler/types/TyVar.lhs | 6 +- ghc/compiler/types/Type.lhs | 33 +- ghc/compiler/utils/FiniteMap.lhs | 21 +- ghc/compiler/utils/Maybes.lhs | 6 +- ghc/compiler/utils/PprStyle.lhs | 9 +- ghc/compiler/utils/Pretty.lhs | 3 +- ghc/compiler/utils/SST.lhs | 6 + ghc/compiler/utils/Ubiq.lhi | 29 +- ghc/compiler/utils/UniqFM.lhs | 10 +- ghc/compiler/utils/UniqSet.lhs | 24 +- ghc/docs/state_interface/state-interface.verb | 105 +- ghc/driver/ghc-iface.lprl | 207 ++-- ghc/driver/ghc.lprl | 226 ++-- ghc/includes/CostCentre.lh | 9 + ghc/includes/SMInfoTables.lh | 6 +- ghc/includes/StgMacros.lh | 45 +- ghc/lib/.depend | 756 ++++++++++++-- ghc/lib/Jmakefile | 269 +++++ ghc/lib/Makefile | 6 +- ghc/lib/Makefile.libHS | 54 +- ghc/runtime/main/StgStartup.lhc | 4 +- ghc/runtime/prims/PrimMisc.lc | 10 +- ghc/runtime/storage/SMstatic.lc | 8 +- 175 files changed, 10329 insertions(+), 12747 deletions(-) delete mode 100644 ghc/compiler/rename/ParseUtils.lhs create mode 100644 ghc/compiler/rename/RnEnv.lhs delete mode 100644 ghc/compiler/rename/RnUtils.lhs delete mode 100644 ghc/compiler/simplStg/StgSAT.lhs delete mode 100644 ghc/compiler/simplStg/StgSATMonad.lhs create mode 100644 ghc/lib/Jmakefile diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index d64c74b..c630c8d 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -110,6 +110,7 @@ you will screw up the layout where they are used in case expressions! # define FAST_STRING _PackedString # define SLIT(x) (_packCString (A# x#)) # define _CMP_STRING_ cmpPString + /* cmpPString defined in utils/Util.lhs */ # define _NULL_ _nullPS # define _NIL_ _nilPS # define _CONS_ _consPS diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index cafc24a..b59469c 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.4 1996/12/18 18:42:48 dnt Exp $ +# $Id: Makefile,v 1.5 1996/12/19 09:10:03 simonpj Exp $ TOP = ../.. FlexSuffixRules = YES @@ -100,12 +100,26 @@ endif INCLUDEDIRS = $(foreach dir,$(DIRS),-i$(dir)) SRCS = \ $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \ - $(UGNHS) rename/ParseIface.hs + $(UGNHS) rename/ParseIface.hs \ + main/LoopHack.hc + +# LoopHack.lhc is an SLPJ addition to fix a profiling problem. See comments +# inside it. + LOOPS = $(patsubst %.lhi, %.hi, $(wildcard */*.lhi)) HCS = $(patsubst %.hs, %.hc, $(patsubst %.lhs, %.hc, $(SRCS))) OBJS = \ $(patsubst %.hc, %.o, $(HCS)) rename/ParseIface.o \ - parser/hsclink.o parser/hschooks.o libhsp.a + parser/hsclink.o parser/hschooks.o libhsp.a \ + main/LoopHack.o + +main/LoopHack.hc : main/LoopHack.lhc + $(RM) $@ + $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) + @chmod 444 $@ + +main/LoopHack.o : main/LoopHack.hc + $(HC) -v -c $(HC_OPTS) $< # ----------------------------------------------------------------------------- # options for the Haskell compiler @@ -141,7 +155,9 @@ endif all :: hsc libhsp.a hsc : $(OBJS) - $(HC) $(HC_OPTS) -o $@ $^ +# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) -o $@ $^ + $(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) -o $@ $^ +# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) -o $@ $^ parser/hschooks.o : parser/hschooks.c @$(RM) $@ @@ -149,7 +165,7 @@ parser/hschooks.o : parser/hschooks.c rename/ParseIface.hs : rename/ParseIface.y @$(RM) rename/ParseIface.hs rename/ParseIface.hinfo - happy -g rename/ParseIface.y + happy +RTS -K2m -RTS -g rename/ParseIface.y @chmod 444 rename/ParseIface.hs # ---------------------------------------------------------------------------- diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 61d17ac..be099d0 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -37,7 +37,7 @@ module AbsCSyn {- ( IMP_Ubiq(){-uitous-} -import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG, +import Constants ( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG, lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4, lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8 diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 1ecd2e1..98464fa 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -290,22 +290,16 @@ isAsmTemp _ = False \end{code} C ``static'' or not... +From the point of view of the code generator, a name is +externally visible if it should be given put in the .o file's +symbol table; that is, made static. + \begin{code} externallyVisibleCLabel (TyConLabel tc _) = True externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (AsmTempLabel _) = False externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (IdLabel (CLabelId id) _) - | isDataCon id = True - | is_ConstMethodId id = True -- These are here to ensure splitting works - | isDictFunId id = True -- when these values have not been exported - | is_DefaultMethodId id = True - | is_SuperDictSelId id = True - | otherwise = externallyVisibleId id - where - is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id) - is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id) - is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id) +externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id \end{code} OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs index 4697911..720e143 100644 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ b/ghc/compiler/absCSyn/CStrings.lhs @@ -126,7 +126,7 @@ identToC ps char_to_c '<' = ppPStr SLIT("Zl") char_to_c '-' = ppPStr SLIT("Zm") char_to_c '!' = ppPStr SLIT("Zn") - char_to_c '.' = ppPStr SLIT("Zo") + char_to_c '.' = ppPStr SLIT("_") char_to_c '+' = ppPStr SLIT("Zp") char_to_c '\'' = ppPStr SLIT("Zq") char_to_c '*' = ppPStr SLIT("Zt") diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 2f11f1a..e73bf15 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -29,7 +29,7 @@ import AbsCSyn import AbsCUtils ( getAmodeRep, nonemptyAbsC, mixedPtrLocn, mixedTypeLocn ) -import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE ) +import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE ) import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel, isReadOnly, needsCDecl, pprCLabel, CLabel{-instance Ord-} diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index 7e3b67c..ea2ee94 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -10,7 +10,7 @@ module FieldLabel where IMP_Ubiq(){-uitous-} -import Name ( Name{-instance Eq/Outputable-} ) +import Name ( Name{-instance Eq/Outputable-}, nameUnique ) import Type ( SYN_IE(Type) ) \end{code} @@ -42,4 +42,7 @@ instance Outputable FieldLabel where instance NamedThing FieldLabel where getName (FieldLabel n _ _) = n + +instance Uniquable FieldLabel where + uniqueOf (FieldLabel n _ _) = nameUnique n \end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 79313ba..201c4ac 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -31,9 +31,8 @@ module Id ( mkUserId, mkUserLocal, mkWorkerId, - - -- MANGLING - unsafeGenId2Id, + mkPrimitiveId, + setIdVisibility, -- DESTRUCTION (excluding pragmatic info) idPrimRep, @@ -54,12 +53,14 @@ module Id ( recordSelectorFieldLabel, -- PREDICATES + wantIdSigInIface, cmpEqDataCon, cmpId, cmpId_withSpecDataCon, externallyVisibleId, idHasNoFreeTyVars, idWantsToBeINLINEd, + idMustBeINLINEd, isBottomingId, isConstMethodId, isConstMethodId_maybe, @@ -68,12 +69,13 @@ module Id ( isDefaultMethodId_maybe, isDictFunId, isImportedId, - isMethodSelId, + isRecordSelector, + isMethodSelId_maybe, isNullaryDataCon, isSpecPragmaId, isSuperDictSelId_maybe, + isPrimitiveId_maybe, isSysLocalId, - isTopLevId, isTupleCon, isWorkerId, isWrapperId, @@ -96,6 +98,7 @@ module Id ( addIdSpecialisation, -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc) + addIdUnfolding, addIdArity, addIdDemandInfo, addIdStrictness, @@ -149,19 +152,20 @@ import Bag import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp ) import IdInfo import Maybes ( maybeToBool ) -import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, - isLocallyDefinedName, - mkTupleDataConName, mkCompoundName, mkCompoundName2, - isLexSym, isLexSpecialSym, - isLocallyDefined, changeUnique, - getOccName, origName, moduleOf, - isExported, ExportFlag(..), - RdrName(..), Name +import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, + mkCompoundName, mkInstDeclName, mkWiredInIdName, mkGlobalName, + isLocallyDefinedName, occNameString, modAndOcc, + isLocallyDefined, changeUnique, isWiredInName, + nameString, getOccString, setNameVisibility, + isExported, ExportFlag(..), DefnInfo, Provenance, + OccName(..), Name ) +import PrelMods ( pREL_TUP, pREL_BASE ) +import Lex ( mkTupNameStr ) import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} ) import PragmaInfo ( PragmaInfo(..) ) import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) ) -import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix, +import PprType ( getTypeString, specMaybeTysSuffix, nmbrType, nmbrTyVar, GenType, GenTyVar ) @@ -169,20 +173,22 @@ import PprStyle import Pretty import MatchEnv ( MatchEnv ) import SrcLoc ( mkBuiltinSrcLoc ) -import TyCon ( TyCon, mkTupleTyCon, tyConDataCons ) +import TysWiredIn ( tupleTyCon ) +import TyCon ( TyCon, tyConDataCons ) import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, applyTyCon, instantiateTy, mkForAllTys, tyVarsOfType, applyTypeEnvToTy, typePrimRep, GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type) ) import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) ) +import Usage ( SYN_IE(UVar) ) import UniqFM import UniqSet -- practically all of it import Unique ( getBuiltinUniques, pprUnique, showUnique, - incrUnique, + incrUnique, Unique{-instance Ord3-} ) -import Util ( mapAccumL, nOfThem, zipEqual, +import Util ( mapAccumL, nOfThem, zipEqual, assoc, panic, panic#, pprPanic, assertPanic ) \end{code} @@ -207,7 +213,7 @@ data GenId ty = Id -- eg specialise-me, inline-me IdInfo -- Properties of this Id deduced by compiler -type Id = GenId Type +type Id = GenId Type data StrictnessMark = MarkedStrict | NotMarkedStrict @@ -221,6 +227,8 @@ data IdDetails | SysLocalId Bool -- Local name; made up by the compiler -- as for LocalId + | PrimitiveId PrimOp -- The Id for a primitive operation + | SpecPragmaId -- Local name; introduced by the compiler (Maybe Id) -- for explicit specid in pragma Bool -- as for LocalId @@ -229,12 +237,6 @@ data IdDetails | ImportedId -- Global name (Imported or Implicit); Id imported from an interface - | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm - -- (not moved there by transformations). - - -- a TopLevId's type may contain free type variables, if - -- the monomorphism restriction applies. - ---------------- Data constructors | DataConId ConTag @@ -281,7 +283,6 @@ data IdDetails -- The "a" is irrelevant. As it is too painful to -- actually do comparisons that way, we kindly supply -- a Unique for that purpose. - Module -- module where instance came from -- see below | ConstMethodId -- A method which depends only on the type of the @@ -304,6 +305,8 @@ data IdDetails -- we may specialise to a type w/ free tyvars -- (i.e., in one of the "Maybe Type" dudes). +-- Scheduled for deletion: SLPJ Nov 96 +-- Nobody seems to depend on knowing this. | WorkerId -- A "worker" for some other Id Id -- Id for which this is a worker @@ -402,24 +405,6 @@ the infinite family of tuples. their @IdInfo@). %---------------------------------------------------------------------- -\item[@TopLevId@:] These are values defined at the top-level in this -module; i.e., those which {\em might} be exported (hence, a -@Name@). It does {\em not} include those which are moved to the -top-level through program transformations. - -We also guarantee that @TopLevIds@ will {\em stay} at top-level. -Theoretically, they could be floated inwards, but there's no known -advantage in doing so. This way, we can keep them with the same -@Unique@ throughout (no cloning), and, in general, we don't have to be -so paranoid about them. - -In particular, we had the following problem generating an interface: -We have to ``stitch together'' info (1)~from the typechecker-produced -global-values list (GVE) and (2)~from the STG code [which @Ids@ have -what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change} -between (1) and (2), you're sunk! - -%---------------------------------------------------------------------- \item[@MethodSelId@:] A selector from a dictionary; it may select either a method or a dictionary for one of the class's superclasses. @@ -469,7 +454,7 @@ Further remarks: %---------------------------------------------------------------------- \item -@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@, +@DataCons@ @TupleCons@, @Importeds@, @SuperDictSelIds@, @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following properties: \begin{itemize} @@ -492,22 +477,14 @@ properties, but they may not. %************************************************************************ \begin{code} -unsafeGenId2Id :: GenId ty -> Id -unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i - -isDataCon id = is_data (unsafeGenId2Id id) - where - is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True - is_data (Id _ _ _ (TupleConId _) _ _) = True - is_data (Id _ _ _ (SpecId unspec _ _) _ _) = is_data unspec - is_data other = False +isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True +isDataCon (Id _ _ _ (TupleConId _) _ _) = True +isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec +isDataCon other = False - -isTupleCon id = is_tuple (unsafeGenId2Id id) - where - is_tuple (Id _ _ _ (TupleConId _) _ _) = True - is_tuple (Id _ _ _ (SpecId unspec _ _) _ _) = is_tuple unspec - is_tuple other = False +isTupleCon (Id _ _ _ (TupleConId _) _ _) = True +isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _) = isTupleCon unspec +isTupleCon other = False {-LATER: isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _) @@ -540,11 +517,10 @@ toplevelishId (Id _ _ _ details _ _) chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True - chk TopLevId = True -- NB: see notes chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True chk (DefaultMethodId _ _ _) = True - chk (DictFunId _ _ _) = True + chk (DictFunId _ _) = True chk (ConstMethodId _ _ _ _) = True chk (SpecId unspec _ _) = toplevelishId unspec -- depends what the unspecialised thing is @@ -553,6 +529,7 @@ toplevelishId (Id _ _ _ details _ _) chk (LocalId _) = False chk (SysLocalId _) = False chk (SpecPragmaId _ _) = False + chk (PrimitiveId _) = True idHasNoFreeTyVars (Id _ _ _ details _ info) = chk details @@ -561,11 +538,10 @@ idHasNoFreeTyVars (Id _ _ _ details _ info) chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True - chk TopLevId = True chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True chk (DefaultMethodId _ _ _) = True - chk (DictFunId _ _ _) = True + chk (DictFunId _ _) = True chk (ConstMethodId _ _ _ _) = True chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr chk (SpecId _ _ no_free_tvs) = no_free_tvs @@ -573,16 +549,53 @@ idHasNoFreeTyVars (Id _ _ _ details _ info) chk (LocalId no_free_tvs) = no_free_tvs chk (SysLocalId no_free_tvs) = no_free_tvs chk (SpecPragmaId _ no_free_tvs) = no_free_tvs + chk (PrimitiveId _) = True + +-- wantIdSigInIface decides whether to put an Id's type signature and +-- IdInfo in an interface file +wantIdSigInIface + :: Bool -- True <=> the thing is mentioned somewhere else in the + -- interface file + -> Bool -- True <=> omit anything that doesn't *have* to go + -> Id + -> Bool + +wantIdSigInIface mentioned_already omit_iface_prags (Id _ name _ details _ _) + = chk details + where + chk (LocalId _) = isExported name && + not (isWiredInName name) -- User-declared thing! + chk ImportedId = False -- Never put imports in interface file + chk (PrimitiveId _) = False -- Ditto, for primitives + + -- This group is Ids that are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file + chk (DataConId _ _ _ _ _ _ _) = False + chk (TupleConId _) = False -- Ditto + chk (RecordSelId _) = False -- Ditto + chk (SuperDictSelId _ _) = False -- Ditto + chk (MethodSelId _ _) = False -- Ditto + chk (ConstMethodId _ _ _ _) = False -- Scheduled for nuking + chk (DefaultMethodId _ _ _) = False -- Hmm. No, for now + + -- DictFunIds are more interesting, they may have IdInfo we can't + -- get from the instance declaration. We emit them if we're gung ho. + -- No need to check the export flag; instance decls are always exposed + chk (DictFunId _ _) = not omit_iface_prags + + -- This group are only called out by being mentioned somewhere else + chk (WorkerId unwrkr) = mentioned_already + chk (SpecId _ _ _) = mentioned_already + chk (InstId _) = mentioned_already + chk (SysLocalId _) = mentioned_already + chk (SpecPragmaId _ _) = mentioned_already \end{code} \begin{code} -isTopLevId (Id _ _ _ TopLevId _ _) = True -isTopLevId other = False - isImportedId (Id _ _ _ ImportedId _ _) = True isImportedId other = False -isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info) +isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (strictnessInfo info) isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True isSysLocalId other = False @@ -590,8 +603,8 @@ isSysLocalId other = False isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True isSpecPragmaId other = False -isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True -isMethodSelId _ = False +isMethodSelId_maybe (Id _ _ _ (MethodSelId cls op) _ _) = Just (cls,op) +isMethodSelId_maybe _ = Nothing isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True isDefaultMethodId other = False @@ -600,8 +613,8 @@ isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _) = Just (cls, clsop, err) isDefaultMethodId_maybe other = Nothing -isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True -isDictFunId other = False +isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True +isDictFunId other = False isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True isConstMethodId other = False @@ -617,157 +630,9 @@ isWorkerId (Id _ _ _ (WorkerId _) _ _) = True isWorkerId other = False isWrapperId id = workerExists (getIdStrictness id) -\end{code} - -\begin{code} -{-LATER: -pprIdInUnfolding :: IdSet -> Id -> Pretty - -pprIdInUnfolding in_scopes v - = let - v_ty = idType v - in - -- local vars first: - if v `elementOfUniqSet` in_scopes then - pprUnique (idUnique v) - - -- ubiquitous Ids with special syntax: - else if v == nilDataCon then - ppPStr SLIT("_NIL_") - else if isTupleCon v then - ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v)) - - -- ones to think about: - else - let - (Id _ _ _ v_details _ _) = v - in - case v_details of - -- these ones must have been exported by their original module - ImportedId -> pp_full_name - - -- these ones' exportedness checked later... - TopLevId -> pp_full_name - DataConId _ _ _ _ _ _ _ -> pp_full_name - - RecordSelId lbl -> ppr sty lbl - - -- class-ish things: class already recorded as "mentioned" - SuperDictSelId c sc - -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc] - MethodSelId c o - -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o] - DefaultMethodId c o _ - -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o] - - -- instance-ish things: should we try to figure out - -- *exactly* which extra instances have to be exported? (ToDo) - DictFunId c t _ - -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t] - ConstMethodId c t o _ - -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t] - - -- specialisations and workers - SpecId unspec ty_maybes _ - -> let - pp = pprIdInUnfolding in_scopes unspec - in - ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack, - ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes), - ppRbrack] - - WorkerId unwrkr - -> let - pp = pprIdInUnfolding in_scopes unwrkr - in - ppBeside (ppPStr SLIT("_WRKR_ ")) pp - - -- anything else? we're nae interested - other_id -> panic "pprIdInUnfolding:mystery Id" - where - ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding") - - pp_full_name - = let - (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v - - pp_n = - if isLexSym n_str && not (isLexSpecialSym n_str) then - ppBesides [ppLparen, ppPStr n_str, ppRparen] - else - ppPStr n_str - in - if isPreludeDefined v then - pp_n - else - ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n] - - pp_class :: Class -> Pretty - pp_class_op :: ClassOp -> Pretty - pp_type :: Type -> Pretty - pp_ty_maybe :: Maybe Type -> Pretty - - pp_class clas = ppr ppr_Unfolding clas - pp_class_op op = ppr ppr_Unfolding op - - pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen] - pp_ty_maybe Nothing = ppPStr SLIT("_N_") - pp_ty_maybe (Just t) = pp_type t --} -\end{code} - -@whatsMentionedInId@ ferrets out the types/classes/instances on which -this @Id@ depends. If this Id is to appear in an interface, then -those entities had Jolly Well be in scope. Someone else up the -call-tree decides that. - -\begin{code} -{-LATER: -whatsMentionedInId - :: IdSet -- Ids known to be in scope - -> Id -- Id being processed - -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc. - -whatsMentionedInId in_scopes v - = let - v_ty = idType v - - (tycons, clss) - = getMentionedTyConsAndClassesFromType v_ty - - result0 id_bag = (id_bag, tycons, clss) - - result1 ids tcs cs - = (ids `unionBags` unitBag v, -- we add v to "mentioned"... - tcs `unionBags` tycons, - cs `unionBags` clss) - in - -- local vars first: - if v `elementOfUniqSet` in_scopes then - result0 emptyBag -- v not added to "mentioned" - - -- ones to think about: - else - let - (Id _ _ _ v_details _ _) = v - in - case v_details of - -- specialisations and workers - SpecId unspec ty_maybes _ - -> let - (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec - in - result1 ids2 tcs2 cs2 - - WorkerId unwrkr - -> let - (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr - in - result1 ids2 tcs2 cs2 - - anything_else -> result0 (unitBag v) -- v is added to "mentioned" --} +isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop +isPrimitiveId_maybe other = Nothing \end{code} Tell them who my wrapper function is. @@ -790,105 +655,16 @@ unfoldingUnfriendlyId id = not (externallyVisibleId id) \end{code} @externallyVisibleId@: is it true that another module might be -able to ``see'' this Id? +able to ``see'' this Id in a code generation sense. That +is, another .o file might refer to this Id. -We need the @toplevelishId@ check as well as @isExported@ for when we -compile instance declarations in the prelude. @DictFunIds@ are -``exported'' if either their class or tycon is exported, but, in -compiling the prelude, the compiler may not recognise that as true. +In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's +local-ness precisely so that the test here would be easy \begin{code} externallyVisibleId :: Id -> Bool - -externallyVisibleId id@(Id _ _ _ details _ _) - = if isLocallyDefined id then - toplevelishId id && (isExported id || isDataCon id) - -- NB: the use of "isExported" is most dodgy; - -- We may eventually move to a situation where - -- every Id is "externallyVisible", even if the - -- module system's namespace control renders it - -- "not exported". - else - True - -- if visible here, it must be visible elsewhere, too. -\end{code} - -\begin{code} -idWantsToBeINLINEd :: Id -> Bool - -idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True -idWantsToBeINLINEd _ = False - -addInlinePragma :: Id -> Id -addInlinePragma (Id u sn ty details _ info) - = Id u sn ty details IWantToBeINLINEd info -\end{code} - -For @unlocaliseId@: See the brief commentary in -\tr{simplStg/SimplStg.lhs}. - -\begin{code} -{-LATER: -unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id - -unlocaliseId mod (Id u fn ty info TopLevId) - = Just (Id u (unlocaliseFullName fn) ty info TopLevId) - -unlocaliseId mod (Id u sn ty info (LocalId no_ftvs)) - = --false?: ASSERT(no_ftvs) - let - full_name = unlocaliseShortName mod u sn - in - Just (Id u full_name ty info TopLevId) - -unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs)) - = --false?: on PreludeGlaST: ASSERT(no_ftvs) - let - full_name = unlocaliseShortName mod u sn - in - Just (Id u full_name ty info TopLevId) - -unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs)) - = case unlocalise_parent mod u unspec of - Nothing -> Nothing - Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs)) - -unlocaliseId mod (Id u n ty info (WorkerId unwrkr)) - = case unlocalise_parent mod u unwrkr of - Nothing -> Nothing - Just xx -> Just (Id u n ty info (WorkerId xx)) - -unlocaliseId mod (Id u name ty info (InstId no_ftvs)) - = Just (Id u full_name ty info TopLevId) - -- type might be wrong, but it hardly matters - -- at this stage (just before printing C) ToDo - where - name = nameOf (origName "Id.unlocaliseId" name) - full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc - -unlocaliseId mod other_id = Nothing - --------------------- --- we have to be Very Careful for workers/specs of --- local functions! - -unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs)) - = --false?: ASSERT(no_ftvs) - let - full_name = unlocaliseShortName mod uniq sn - in - Just (Id uniq full_name ty info TopLevId) - -unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs)) - = --false?: ASSERT(no_ftvs) - let - full_name = unlocaliseShortName mod uniq sn - in - Just (Id uniq full_name ty info TopLevId) - -unlocalise_parent mod uniq other_id = unlocaliseId mod other_id - -- we're OK otherwise --} +externallyVisibleId id@(Id _ name _ _ _ _) = not (isLocalName name) + -- not local => global => externally visible \end{code} CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@: @@ -1008,14 +784,6 @@ getMentionedTyConsAndClassesFromId id idPrimRep i = typePrimRep (idType i) \end{code} -\begin{code} -{-LATER: -getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod -getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod -getInstIdModule other = panic "Id:getInstIdModule" --} -\end{code} - %************************************************************************ %* * \subsection[Id-overloading]{Functions related to overloading} @@ -1023,51 +791,50 @@ getInstIdModule other = panic "Id:getInstIdModule" %************************************************************************ \begin{code} -mkSuperDictSelId u c sc ty info - = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info - -mkMethodSelId u rec_c op ty info - = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info - -mkDefaultMethodId u rec_c op gen ty info - = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info - -mk_classy_id details str op_str u rec_c ty info - = Id u n ty details NoPragmaInfo info +mkSuperDictSelId u clas sc ty + = addStandardIdInfo $ + Id u name ty details NoPragmaInfo noIdInfo where - cname = getName rec_c -- we get other info out of here - cname_orig = origName "mk_classy_id" cname - cmod = moduleOf cname_orig - - n = mkCompoundName u cmod str [Left cname_orig, op_str] cname - -mkDictFunId u c ity full_ty from_here locn mod info - = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info + name = mkCompoundName name_fn u (getName clas) + details = SuperDictSelId clas sc + name_fn clas_str = SLIT("scsel_") _APPEND_ clas_str _APPEND_ mod _APPEND_ occNameString occ + (mod,occ) = modAndOcc sc + + -- For method selectors the clean thing to do is + -- to give the method selector the same name as the class op itself. +mkMethodSelId op_name rec_c op ty + = addStandardIdInfo $ + Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo + +mkDefaultMethodId op_name uniq rec_c op gen ty + = Id uniq dm_name ty details NoPragmaInfo noIdInfo where - n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : renum_type_string full_ty ity) from_here locn + dm_name = mkCompoundName name_fn uniq op_name + details = DefaultMethodId rec_c op gen + name_fn op_str = SLIT("dm_") _APPEND_ op_str -mkConstMethodId u c op ity full_ty from_here locn mod info - = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info +mkDictFunId dfun_name full_ty clas ity + = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo where - n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : renum_type_string full_ty ity) from_here locn + details = DictFunId clas ity -renum_type_string full_ty ity - = initNmbr ( - nmbrType full_ty `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering... - nmbrType ity `thenNmbr` \ rn_ity -> - returnNmbr (getTypeString rn_ity) - ) +mkConstMethodId uniq clas op ity full_ty from_here locn mod info + = Id uniq name full_ty details NoPragmaInfo info + where + name = mkInstDeclName uniq mod (VarOcc occ_name) locn from_here + details = ConstMethodId clas ity op mod + occ_name = classOpString op _APPEND_ + SLIT("_cm_") _APPEND_ renum_type_string full_ty ity mkWorkerId u unwrkr ty info - = Id u n ty (WorkerId unwrkr) NoPragmaInfo info + = Id u name ty details NoPragmaInfo info where - unwrkr_name = getName unwrkr - unwrkr_orig = origName "mkWorkerId" unwrkr_name - umod = moduleOf unwrkr_orig - - n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name + name = mkCompoundName name_fn u (getName unwrkr) + details = WorkerId unwrkr + name_fn wkr_str = wkr_str _APPEND_ SLIT("_wrk") -mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo +mkInstId u ty name + = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo {-LATER: getConstMethodId clas op ty @@ -1086,6 +853,14 @@ getConstMethodId clas op ty ppStr "The info above, however ugly, should indicate what else you need to import." ]) -} + + +renum_type_string full_ty ity + = initNmbr ( + nmbrType full_ty `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering... + nmbrType ity `thenNmbr` \ rn_ity -> + returnNmbr (getTypeString rn_ity) + ) \end{code} %************************************************************************ @@ -1097,10 +872,9 @@ getConstMethodId clas op ty \begin{code} mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info -{-LATER: -updateIdType :: Id -> Type -> Id -updateIdType (Id u n _ info details) ty = Id u n ty info details --} +mkPrimitiveId n ty primop + = addStandardIdInfo $ + Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo \end{code} \begin{code} @@ -1111,23 +885,18 @@ no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty) -- SysLocal: for an Id being created by the compiler out of thin air... -- UserLocal: an Id with a name the user might recognize... -mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b +mkSysLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b +mkUserLocal :: OccName -> Unique -> MyTy a b -> SrcLoc -> MyId a b mkSysLocal str uniq ty loc - = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo + = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo -mkUserLocal str uniq ty loc - = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo +mkUserLocal occ uniq ty loc + = Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo --- mkUserId builds a local or top-level Id, depending on the name given mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b mkUserId name ty pragma_info - | isLocalName name = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo - | otherwise - = Id (nameUnique name) name ty - (if isLocallyDefinedName name then TopLevId else ImportedId) - pragma_info noIdInfo \end{code} @@ -1135,7 +904,7 @@ mkUserId name ty pragma_info {-LATER: -- for a SpecPragmaId being created by the compiler out of thin air... -mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id +mkSpecPragmaId :: OccName -> Unique -> Type -> Maybe Id -> SrcLoc -> Id mkSpecPragmaId str uniq ty specid loc = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty)) @@ -1162,8 +931,12 @@ localiseId id@(Id u n ty info details) loc = getSrcLoc id -} -mkIdWithNewUniq :: Id -> Unique -> Id +-- See notes with setNameVisibility (Name.lhs) +setIdVisibility :: Module -> Id -> Id +setIdVisibility mod (Id uniq name ty details prag info) + = Id uniq (setNameVisibility mod name) ty details prag info +mkIdWithNewUniq :: Id -> Unique -> Id mkIdWithNewUniq (Id _ n ty details prag info) u = Id u (changeUnique n u) ty details prag info \end{code} @@ -1194,7 +967,7 @@ replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info selectIdInfoForSpecId :: Id -> IdInfo selectIdInfoForSpecId unspec = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - noIdInfo `addInfo_UF` getIdUnfolding unspec + noIdInfo `addUnfoldInfo` getIdUnfolding unspec -} \end{code} @@ -1212,15 +985,15 @@ besides the code-generator need arity info!) getIdArity :: Id -> ArityInfo getIdArity id@(Id _ _ _ _ _ id_info) = --ASSERT( not (isDataCon id)) - getInfo id_info + arityInfo id_info dataConArity, dataConNumFields :: DataCon -> Int dataConArity id@(Id _ _ _ _ _ id_info) = ASSERT(isDataCon id) - case (arityMaybe (getInfo id_info)) of - Just i -> i - Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) + case arityInfo id_info of + ArityExactly a -> a + other -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) dataConNumFields id = ASSERT(isDataCon id) @@ -1229,9 +1002,9 @@ dataConNumFields id isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience -addIdArity :: Id -> Int -> Id +addIdArity :: Id -> ArityInfo -> Id addIdArity (Id u n ty details pinfo info) arity - = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity)) + = Id u n ty details pinfo (info `addArityInfo` arity) \end{code} %************************************************************************ @@ -1244,133 +1017,39 @@ addIdArity (Id u n ty details pinfo info) arity mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] -> [TyVar] -> ThetaType -> [TauType] -> TyCon ---ToDo: -> SpecEnv -> Id -- can get the tag and all the pieces of the type from the Type mkDataCon n stricts fields tvs ctxt args_tys tycon = ASSERT(length stricts == length args_tys) - data_con + addStandardIdInfo data_con where -- NB: data_con self-recursion; should be OK as tags are not -- looked at until late in the game. data_con = Id (nameUnique n) n - type_of_constructor + data_con_ty (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon) IWantToBeINLINEd -- Always inline constructors if possible - datacon_info - - data_con_tag = position_within fIRST_TAG data_con_family + noIdInfo + data_con_tag = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con data_con_family = tyConDataCons tycon - position_within :: Int -> [Id] -> Int - - position_within acc (c:cs) - = if c == data_con then acc else position_within (acc+1) cs -#ifdef DEBUG - position_within acc [] - = panic "mkDataCon: con not found in family" -#endif - - type_of_constructor + data_con_ty = mkSigmaTy tvs ctxt (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs))) - datacon_info = noIdInfo `addInfo_UF` unfolding - `addInfo` mkArityInfo arity ---ToDo: `addInfo` specenv - - arity = length ctxt + length args_tys - - unfolding - = noInfo_UF -{- LATER: - = -- if arity == 0 - -- then noIdInfo - -- else -- do some business... - let - (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon - tyvar_tys = mkTyVarTys tyvars - in - case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con -> - - mkUnfolding EssentialUnfolding -- for data constructors - (mkLam tyvars (dict_vars ++ vars) plain_Con) - } - mk_uf_bits tvs ctxt arg_tys tycon - = let - (inst_env, tyvars, tyvar_tys) - = instantiateTyVarTemplates tvs - (map uniqueOf tvs) - in - -- the "context" and "arg_tys" have TyVarTemplates in them, so - -- we instantiate those types to have the right TyVars in them - -- instead. - case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt)) - of { inst_dict_tys -> - case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys -> - - -- We can only have **ONE** call to mkTemplateLocals here; - -- otherwise, we get two blobs of locals w/ mixed-up Uniques - -- (Mega-Sigh) [ToDo] - case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars -> - - case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) -> - - (tyvars, dict_vars, vars) - }}}} - where - -- these are really dubious Types, but they are only to make the - -- binders for the lambdas for tossed-away dicts. - ctxt_ty (clas, ty) = mkDictTy clas ty --} -\end{code} - -\begin{code} -mkTupleCon :: Arity -> Id - -mkTupleCon arity - = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info +mkTupleCon :: Arity -> Name -> Type -> Id +mkTupleCon arity name ty + = addStandardIdInfo tuple_id where - n = mkTupleDataConName arity - unique = uniqueOf n - ty = mkSigmaTy tyvars [] - (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys)) - tycon = mkTupleTyCon arity - tyvars = take arity alphaTyVars - tyvar_tys = mkTyVarTys tyvars - - tuplecon_info - = noIdInfo `addInfo_UF` unfolding - `addInfo` mkArityInfo arity ---LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty" - - unfolding - = noInfo_UF -{- LATER: - = -- if arity == 0 - -- then noIdInfo - -- else -- do some business... - let - (tyvars, dict_vars, vars) = mk_uf_bits arity - tyvar_tys = mkTyVarTys tyvars - in - case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con -> - mkUnfolding - EssentialUnfolding -- data constructors - (mkLam tyvars (dict_vars ++ vars) plain_Con) } - - mk_uf_bits arity - = case (mkTemplateLocals tyvar_tys) of { vars -> - (tyvars, [], vars) } - where - tyvar_tmpls = take arity alphaTyVars - (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls) --} + tuple_id = Id (nameUnique name) name ty + (TupleConId arity) + IWantToBeINLINEd -- Always inline constructors if possible + noIdInfo fIRST_TAG :: ConTag fIRST_TAG = 1 -- Tags allocated from here for real constructors @@ -1384,7 +1063,7 @@ dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon -dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a +dataConTyCon (Id _ _ _ (TupleConId a) _ _) = tupleTyCon a dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon @@ -1393,7 +1072,7 @@ dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _) = (tyvars, theta_ty, arg_tys, tycon) dataConSig (Id _ _ _ (TupleConId arity) _ _) - = (tyvars, [], tyvar_tys, mkTupleTyCon arity) + = (tyvars, [], tyvar_tys, tupleTyCon arity) where tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars @@ -1441,7 +1120,8 @@ dataConArgTys con_id inst_tys \begin{code} mkRecordSelId field_label selector_ty - = Id (nameUnique name) + = addStandardIdInfo $ -- Record selectors have a standard unfolding + Id (nameUnique name) name selector_ty (RecordSelId field_label) @@ -1452,6 +1132,9 @@ mkRecordSelId field_label selector_ty recordSelectorFieldLabel :: Id -> FieldLabel recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl + +isRecordSelector (Id _ _ _ (RecordSelId lbl) _ _) = True +isRecordSelector other = False \end{code} @@ -1473,50 +1156,39 @@ Notice the ``big lambdas'' and type arguments to @Con@---we are producing %* * %************************************************************************ -@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case) -and generates an @Unfolding@. The @Ids@ and @TyVars@ don't really -have to be new, because we are only producing a template. +\begin{code} +getIdUnfolding :: Id -> Unfolding -ToDo: what if @DataConId@'s type has a context (haven't thought about it ---WDP)? +getIdUnfolding (Id _ _ _ _ _ info) = unfoldInfo info -Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT -EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the -example above: a, b, and x, y, z], which is enough (in the important -\tr{DsExpr} case). (The middle set of @Ids@ is binders for any -dictionaries, in the even of an overloaded data-constructor---none at -present.) +addIdUnfolding :: Id -> Unfolding -> Id +addIdUnfolding id@(Id u n ty details prag info) unfolding + = Id u n ty details prag (info `addUnfoldInfo` unfolding) +\end{code} + +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. \begin{code} -getIdUnfolding :: Id -> Unfolding +idWantsToBeINLINEd :: Id -> Bool -getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info +idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True +idWantsToBeINLINEd _ = False -{-LATER: -addIdUnfolding :: Id -> Unfolding -> Id -addIdUnfolding id@(Id u n ty info details) unfold_details - = ASSERT( - case (isLocallyDefined id, unfold_details) of - (_, NoUnfolding) -> True - (True, IWantToBeINLINEd _) -> True - (False, IWantToBeINLINEd _) -> False -- v bad - (False, _) -> True - _ -> False -- v bad - ) - Id u n ty (info `addInfo_UF` unfold_details) details --} +addInlinePragma :: Id -> Id +addInlinePragma (Id u sn ty details _ info) + = Id u sn ty details IWantToBeINLINEd info \end{code} -In generating selector functions (take a dictionary, give back one -component...), we need to what out for the nothing-to-select cases (in -which case the ``selector'' is just an identity function): -\begin{verbatim} -class Eq a => Foo a { } # the superdict selector for "Eq" -class Foo a { op :: Complex b => c -> b -> a } - # the method selector for "op"; - # note local polymorphism... -\end{verbatim} +The predicate @idMustBeINLINEd@ says that this Id absolutely must be inlined. +It's only true for primitives, because we don't want to make a closure for each of them. + +\begin{code} +idMustBeINLINEd (Id _ _ _ (PrimitiveId primop) _ _) = True +idMustBeINLINEd other = False +\end{code} + %************************************************************************ %* * @@ -1526,64 +1198,63 @@ class Foo a { op :: Complex b => c -> b -> a } \begin{code} getIdDemandInfo :: Id -> DemandInfo -getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info +getIdDemandInfo (Id _ _ _ _ _ info) = demandInfo info addIdDemandInfo :: Id -> DemandInfo -> Id addIdDemandInfo (Id u n ty details prags info) demand_info - = Id u n ty details prags (info `addInfo` demand_info) + = Id u n ty details prags (info `addDemandInfo` demand_info) \end{code} \begin{code} getIdUpdateInfo :: Id -> UpdateInfo -getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info +getIdUpdateInfo (Id _ _ _ _ _ info) = updateInfo info addIdUpdateInfo :: Id -> UpdateInfo -> Id addIdUpdateInfo (Id u n ty details prags info) upd_info - = Id u n ty details prags (info `addInfo` upd_info) + = Id u n ty details prags (info `addUpdateInfo` upd_info) \end{code} \begin{code} {- LATER: getIdArgUsageInfo :: Id -> ArgUsageInfo -getIdArgUsageInfo (Id u n ty info details) = getInfo info +getIdArgUsageInfo (Id u n ty info details) = argUsageInfo info addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id addIdArgUsageInfo (Id u n ty info details) au_info - = Id u n ty (info `addInfo` au_info) details + = Id u n ty (info `addArgusageInfo` au_info) details -} \end{code} \begin{code} {- LATER: getIdFBTypeInfo :: Id -> FBTypeInfo -getIdFBTypeInfo (Id u n ty info details) = getInfo info +getIdFBTypeInfo (Id u n ty info details) = fbTypeInfo info addIdFBTypeInfo :: Id -> FBTypeInfo -> Id addIdFBTypeInfo (Id u n ty info details) upd_info - = Id u n ty (info `addInfo` upd_info) details + = Id u n ty (info `addFBTypeInfo` upd_info) details -} \end{code} \begin{code} getIdSpecialisation :: Id -> SpecEnv -getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info +getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info addIdSpecialisation :: Id -> SpecEnv -> Id addIdSpecialisation (Id u n ty details prags info) spec_info - = Id u n ty details prags (info `addInfo` spec_info) + = Id u n ty details prags (info `addSpecInfo` spec_info) \end{code} Strictness: we snaffle the info out of the IdInfo. \begin{code} -getIdStrictness :: Id -> StrictnessInfo - -getIdStrictness (Id _ _ _ _ _ info) = getInfo info +getIdStrictness :: Id -> StrictnessInfo Id -addIdStrictness :: Id -> StrictnessInfo -> Id +getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info +addIdStrictness :: Id -> StrictnessInfo Id -> Id addIdStrictness (Id u n ty details prags info) strict_info - = Id u n ty details prags (info `addInfo` strict_info) + = Id u n ty details prags (info `addStrictnessInfo` strict_info) \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 4bfc2c8..40b3c1f 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -10,60 +10,43 @@ Haskell. [WDP 94/11]) #include "HsVersions.h" module IdInfo ( - IdInfo, -- abstract + IdInfo, -- Abstract + noIdInfo, - boringIdInfo, ppIdInfo, applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please - OptIdInfo(..), -- class; for convenience only - -- all the *Infos herein are instances of it - - -- component "id infos"; also abstract: - SrcLoc, - getSrcLocIdInfo, - - ArityInfo, - mkArityInfo, unknownArity, arityMaybe, + ArityInfo(..), + exactArity, atLeastArity, unknownArity, + arityInfo, addArityInfo, ppArityInfo, DemandInfo, - mkDemandInfo, - willBeDemanded, - - StrictnessInfo(..), -- non-abstract - Demand(..), -- non-abstract + noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, addDemandInfo, willBeDemanded, + StrictnessInfo(..), -- Non-abstract + Demand(..), -- Non-abstract wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, - indicatesWorker, nonAbsentArgs, - mkStrictnessInfo, mkBottomStrictnessInfo, - getWrapperArgTypeCategories, - getWorkerId, + + getWorkerId_maybe, workerExists, - bottomIsGuaranteed, + mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed, + strictnessInfo, ppStrictnessInfo, addStrictnessInfo, - mkUnfolding, - noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus + unfoldInfo, addUnfoldInfo, - UpdateInfo, - mkUpdateInfo, - SYN_IE(UpdateSpec), - updateInfoMaybe, + specInfo, addSpecInfo, - DeforestInfo(..), + UpdateInfo, SYN_IE(UpdateSpec), + mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo, - ArgUsageInfo, - ArgUsage(..), - SYN_IE(ArgUsageType), - mkArgUsageInfo, - getArgUsage, + DeforestInfo(..), + deforestInfo, ppDeforestInfo, addDeforestInfo, - FBTypeInfo, - FBType(..), - FBConsum(..), - FBProd(..), - mkFBTypeInfo, - getFBType + ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType), + mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage, + FBTypeInfo, FBType(..), FBConsum(..), FBProd(..), + fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType ) where IMP_Ubiq() @@ -74,13 +57,14 @@ IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and -- *not* importing much of anything else, -- except from the very general "utils". +import Type ( eqSimpleTy, splitFunTyExpandingDicts ) import CmdLineOpts ( opt_OmitInterfacePragmas ) + +import Demand import Maybes ( firstJust ) import Outputable ( ifPprInterface, Outputable(..){-instances-} ) import PprStyle ( PprStyle(..) ) import Pretty -import SrcLoc ( mkUnknownSrcLoc ) -import Type ( eqSimpleTy, splitFunTyExpandingDicts ) import Unique ( pprUnique ) import Util ( mapAccumL, panic, assertPanic, pprPanic ) @@ -90,9 +74,6 @@ ord = fromEnum :: Char -> Int applySubstToTy = panic "IdInfo.applySubstToTy" showTypeCategory = panic "IdInfo.showTypeCategory" -mkFormSummary = panic "IdInfo.mkFormSummary" -isWrapperFor = panic "IdInfo.isWrapperFor" -pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding" \end{code} An @IdInfo@ gives {\em optional} information about an @Id@. If @@ -115,12 +96,15 @@ data IdInfo DemandInfo -- Whether or not it is definitely -- demanded - SpecEnv -- Specialisations of this function which exist + SpecEnv + -- Specialisations of this function which exist - StrictnessInfo -- Strictness properties, notably + (StrictnessInfo Id) + -- Strictness properties, notably -- how to conjure up "worker" functions - Unfolding -- Its unfolding; for locally-defined + Unfolding + -- Its unfolding; for locally-defined -- things, this can *only* be NoUnfolding UpdateInfo -- Which args should be updated @@ -131,47 +115,11 @@ data IdInfo ArgUsageInfo -- how this Id uses its arguments FBTypeInfo -- the Foldr/Build W/W property of this function. - - SrcLoc -- Source location of definition - - -- ToDo: SrcLoc is in FullNames too (could rm?) but it - -- is needed here too for things like ConstMethodIds and the - -- like, which don't have full-names of their own Mind you, - -- perhaps the Name for a constant method could give the - -- class/type involved? \end{code} \begin{code} -noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF - noInfo noInfo noInfo noInfo mkUnknownSrcLoc - --- "boring" means: nothing to put in interface -boringIdInfo (IdInfo UnknownArity - UnknownDemand - specenv - strictness - unfolding - NoUpdateInfo - Don'tDeforest - _ {- arg_usage: currently no interface effect -} - _ {- no f/b w/w -} - _ {- src_loc: no effect on interfaces-} - ) - | isNullSpecEnv specenv - && boring_strictness strictness - && boring_unfolding unfolding - = True - where - boring_strictness NoStrictnessInfo = True - boring_strictness BottomGuaranteed = False - boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args - - boring_unfolding NoUnfolding = True - boring_unfolding _ = False - -boringIdInfo _ = False - -pp_NONE = ppPStr SLIT("_N_") +noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding + NoUpdateInfo Don'tDeforest NoArgUsageInfo NoFBTypeInfo \end{code} Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@ @@ -179,7 +127,7 @@ will in turn @apply_to_IdInfo@ of the self-same @IdInfo@. (A very nasty loop, friends...) \begin{code} apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold - update deforest arg_usage fb_ww srcloc) + update deforest arg_usage fb_ww) | isNullSpecEnv spec = idinfo | otherwise @@ -193,7 +141,7 @@ apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold -- apply_wrap wrap `thenLft` \ new_wrap -> in IdInfo arity demand new_spec strictness unfold - update deforest arg_usage fb_ww srcloc + update deforest arg_usage fb_ww where apply_spec (SpecEnv is) = SpecEnv (map do_one is) @@ -222,11 +170,11 @@ apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold Variant of the same thing for the typechecker. \begin{code} applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold - update deforest arg_usage fb_ww srcloc) + update deforest arg_usage fb_ww) = panic "IdInfo:applySubstToIdInfo" {- LATER: case (apply_spec s0 spec) of { (s1, new_spec) -> - (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) } + (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww) } where apply_spec s0 (SpecEnv is) = case (mapAccumL do_one s0 is) of { (s1, new_is) -> @@ -245,77 +193,29 @@ applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold \begin{code} ppIdInfo :: PprStyle - -> Id -- The Id for which we're printing this IdInfo -> Bool -- True <=> print specialisations, please - -> (Id -> Id) -- to look up "better Ids" w/ better IdInfos; - -> IdEnv Unfolding - -- inlining info for top-level fns in this module - -> IdInfo -- see MkIface notes + -> IdInfo -> Pretty -ppIdInfo sty for_this_id specs_please better_id_fn inline_env - i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc) - | boringIdInfo i - = ppPStr SLIT("_NI_") - - | otherwise - = let - stuff = ppCat [ +ppIdInfo sty specs_please + (IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype) + = ppCat [ -- order is important!: - ppInfo sty better_id_fn arity, - ppInfo sty better_id_fn update, - ppInfo sty better_id_fn deforest, - - pp_strictness sty (Just for_this_id) - better_id_fn inline_env strictness, + ppArityInfo sty arity, + ppUpdateInfo sty update, + ppDeforestInfo sty deforest, - if bottomIsGuaranteed strictness - then pp_NONE - else pp_unfolding sty for_this_id inline_env unfold, + ppStrictnessInfo sty strictness, if specs_please - then pp_NONE -- ToDo -- sty (not (isDataCon for_this_id)) + then ppNil -- ToDo -- sty (not (isDataCon for_this_id)) -- better_id_fn inline_env (mEnvToList specenv) - else pp_NONE, + else ppNil, -- DemandInfo needn't be printed since it has no effect on interfaces - ppInfo sty better_id_fn demand, - ppInfo sty better_id_fn fbtype - ] - in - case sty of - PprInterface -> if opt_OmitInterfacePragmas - then ppNil - else stuff - _ -> stuff -\end{code} - -%************************************************************************ -%* * -\subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)} -%* * -%************************************************************************ - -\begin{code} -class OptIdInfo a where - noInfo :: a - getInfo :: IdInfo -> a - addInfo :: IdInfo -> a -> IdInfo - -- By default, "addInfo" will not overwrite - -- "info" with "non-info"; look at any instance - -- to see an example. - ppInfo :: PprStyle -> (Id -> Id) -> a -> Pretty -\end{code} - -%************************************************************************ -%* * -\subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@} -%* * -%************************************************************************ - -Not used much, but... -\begin{code} -getSrcLocIdInfo (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc + ppDemandInfo sty demand, + ppFBTypeInfo sty fbtype + ] \end{code} %************************************************************************ @@ -326,31 +226,24 @@ getSrcLocIdInfo (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc \begin{code} data ArityInfo - = UnknownArity -- no idea - | ArityExactly Int -- arity is exactly this + = UnknownArity -- No idea + | ArityExactly Int -- Arity is exactly this + | ArityAtLeast Int -- Arity is this or greater \end{code} \begin{code} -mkArityInfo = ArityExactly +exactArity = ArityExactly +atLeastArity = ArityAtLeast unknownArity = UnknownArity -arityMaybe :: ArityInfo -> Maybe Int +arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity -arityMaybe UnknownArity = Nothing -arityMaybe (ArityExactly i) = Just i -\end{code} +addArityInfo id_info UnknownArity = id_info +addArityInfo (IdInfo _ a c d e f g h i) arity = IdInfo arity a c d e f g h i -\begin{code} -instance OptIdInfo ArityInfo where - noInfo = UnknownArity - - getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity - - addInfo id_info UnknownArity = id_info - addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j - - ppInfo sty _ UnknownArity = ifPprInterface sty pp_NONE - ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity] +ppArityInfo sty UnknownArity = ppNil +ppArityInfo sty (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity] +ppArityInfo sty (ArityAtLeast arity) = ppCat [ppPStr SLIT("_A>_"), ppInt arity] \end{code} %************************************************************************ @@ -373,6 +266,8 @@ data DemandInfo \end{code} \begin{code} +noDemandInfo = UnknownDemand + mkDemandInfo :: Demand -> DemandInfo mkDemandInfo demand = DemandedAsPer demand @@ -382,22 +277,13 @@ willBeDemanded _ = False \end{code} \begin{code} -instance OptIdInfo DemandInfo where - noInfo = UnknownDemand - - getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand +demandInfo (IdInfo _ demand _ _ _ _ _ _ _) = demand -{- DELETED! If this line is in, there is no way to - nuke a DemandInfo, and we have to be able to do that - when floating let-bindings around - addInfo id_info UnknownDemand = id_info --} - addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j +addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i - ppInfo PprInterface _ _ = ppNil - ppInfo sty _ UnknownDemand = ppStr "{-# L #-}" - ppInfo sty _ (DemandedAsPer info) - = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"] +ppDemandInfo PprInterface _ = ppNil +ppDemandInfo sty UnknownDemand = ppStr "{-# L #-}" +ppDemandInfo sty (DemandedAsPer info) = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"] \end{code} %************************************************************************ @@ -409,16 +295,10 @@ instance OptIdInfo DemandInfo where See SpecEnv.lhs \begin{code} -instance OptIdInfo SpecEnv where - noInfo = nullSpecEnv +specInfo (IdInfo _ _ spec _ _ _ _ _ _) = spec - getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec - - addInfo id_info spec | isNullSpecEnv spec = id_info - addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j - - ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs" --- = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec) +addSpecInfo id_info spec | isNullSpecEnv spec = id_info +addSpecInfo (IdInfo a b _ d e f g h i) spec = IdInfo a b spec d e f g h i \end{code} %************************************************************************ @@ -438,7 +318,7 @@ version of the function; and (c)~the type signature of that worker (if it exists); i.e. its calling convention. \begin{code} -data StrictnessInfo +data StrictnessInfo bdee = NoStrictnessInfo | BottomGuaranteed -- This Id guarantees never to return; @@ -446,280 +326,55 @@ data StrictnessInfo -- Useful for "error" and other disguised -- variants thereof. - | StrictnessInfo [Demand] -- the main stuff; see below. - (Maybe Id) -- worker's Id, if applicable. -\end{code} - -This type is also actually used in the strictness analyser: -\begin{code} -data Demand - = WwLazy -- Argument is lazy as far as we know - MaybeAbsent -- (does not imply worker's existence [etc]). - -- If MaybeAbsent == True, then it is - -- *definitely* lazy. (NB: Absence implies - -- a worker...) - - | WwStrict -- Argument is strict but that's all we know - -- (does not imply worker's existence or any - -- calling-convention magic) - - | WwUnpack -- Argument is strict & a single-constructor - [Demand] -- type; its constituent parts (whose StrictInfos - -- are in the list) should be passed - -- as arguments to the worker. - - | WwPrim -- Argument is of primitive type, therefore - -- strict; doesn't imply existence of a worker; - -- argument should be passed as is to worker. - - | WwEnum -- Argument is strict & an enumeration type; - -- an Int# representing the tag (start counting - -- at zero) should be passed to the worker. - deriving (Eq, Ord) - -- we need Eq/Ord to cross-chk update infos in interfaces - -type MaybeAbsent = Bool -- True <=> not even used - --- versions that don't worry about Absence: -wwLazy = WwLazy False -wwStrict = WwStrict -wwUnpack xs = WwUnpack xs -wwPrim = WwPrim -wwEnum = WwEnum + | StrictnessInfo [Demand] -- The main stuff; see below. + (Maybe bdee) -- Worker's Id, if applicable. + -- (It may not be applicable because the strictness info + -- might say just "SSS" or something; so there's no w/w split.) \end{code} \begin{code} -mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo +mkStrictnessInfo :: [Demand] -> Maybe bdee -> StrictnessInfo bdee -mkStrictnessInfo [] _ = NoStrictnessInfo -mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr +mkStrictnessInfo xs wrkr + | all is_lazy xs = NoStrictnessInfo -- Uninteresting + | otherwise = StrictnessInfo xs wrkr + where + is_lazy (WwLazy False) = True -- NB "Absent" args do *not* count! + is_lazy _ = False -- (as they imply a worker) +noStrictnessInfo = NoStrictnessInfo mkBottomStrictnessInfo = BottomGuaranteed bottomIsGuaranteed BottomGuaranteed = True bottomIsGuaranteed other = False -getWrapperArgTypeCategories - :: Type -- wrapper's type - -> StrictnessInfo -- strictness info about its args - -> Maybe String - -getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing -getWrapperArgTypeCategories _ BottomGuaranteed - = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong -getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing - -getWrapperArgTypeCategories ty (StrictnessInfo arg_info _) - = Just (mkWrapperArgTypeCategories ty arg_info) - -workerExists :: StrictnessInfo -> Bool -workerExists (StrictnessInfo _ (Just worker_id)) = True -workerExists other = False - -getWorkerId :: StrictnessInfo -> Id - -getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id -#ifdef DEBUG -getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk) -#endif -\end{code} - -\begin{code} -isStrict :: Demand -> Bool +strictnessInfo (IdInfo _ _ _ strict _ _ _ _ _) = strict -isStrict WwStrict = True -isStrict (WwUnpack _) = True -isStrict WwPrim = True -isStrict WwEnum = True -isStrict _ = False +addStrictnessInfo id_info NoStrictnessInfo = id_info +addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i -nonAbsentArgs :: [Demand] -> Int +ppStrictnessInfo sty NoStrictnessInfo = ppNil +ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_S_ _!_") -nonAbsentArgs cmpts - = foldr tick_non 0 cmpts +ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe) + = ppCat [ppPStr SLIT("_S_"), ppStr (showList wrapper_args ""), pp_wrkr] where - tick_non (WwLazy True) acc = acc - tick_non other acc = acc + 1 - -all_present_WwLazies :: [Demand] -> Bool -all_present_WwLazies infos - = and (map is_L infos) - where - is_L (WwLazy False) = True -- False <=> "Absent" args do *not* count! - is_L _ = False -- (as they imply a worker) + pp_wrkr = case wrkr_maybe of + Nothing -> ppNil + Just wrkr -> ppr sty wrkr \end{code} -WDP 95/04: It is no longer enough to look at a list of @Demands@ for -an ``Unpack'' or an ``Absent'' and declare a worker. We also have to -check that @mAX_WORKER_ARGS@ hasn't been exceeded. Therefore, -@indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@ -in \tr{WwLib.lhs}. A worker is ``indicated'' when we hit an Unpack -or an Absent {\em that we accept}. -\begin{code} -indicatesWorker :: [Demand] -> Bool - -indicatesWorker 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 - fake_mk_ww extra_args (WwUnpack cmpnts : dems) - | extra_args_now > 0 = True -- we accepted an Unpack - where - extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts - - fake_mk_ww extra_args (_ : dems) - = fake_mk_ww extra_args dems -\end{code} \begin{code} -mkWrapperArgTypeCategories - :: Type -- wrapper's type - -> [Demand] -- info about its arguments - -> String -- a string saying lots about the args - -mkWrapperArgTypeCategories wrapper_ty wrap_info - = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) -> - map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) } - where - -- ToDo: this needs FIXING UP (it was a hack anyway...) - do_one (WwPrim, _) = 'P' - do_one (WwEnum, _) = 'E' - do_one (WwStrict, arg_ty_char) = arg_ty_char - do_one (WwUnpack _, arg_ty_char) - = if arg_ty_char `elem` "CIJFDTS" - then toLower arg_ty_char - else if arg_ty_char == '+' then 't' - else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-' - do_one (other_wrap_info, _) = '-' -\end{code} - -Whether a worker exists depends on whether the worker has an -absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments. - -If a @WwUnpack@ argument is for an {\em abstract} type (or one that -will be abstract outside this module), which might happen for an -imported function, then we can't (or don't want to...) unpack the arg -as the worker requires. Hence we have to give up altogether, and call -the wrapper only; so under these circumstances we return \tr{False}. - -\begin{code} -#ifdef REALLY_HASKELL_1_3 -instance Read Demand where -#else -instance Text Demand where -#endif - readList str = read_em [{-acc-}] str - where - read_em acc [] = [(reverse acc, "")] - -- lower case indicates absence... - read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs - read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs - read_em acc ('S' : xs) = read_em (WwStrict : acc) xs - read_em acc ('P' : xs) = read_em (WwPrim : acc) xs - read_em acc ('E' : xs) = read_em (WwEnum : acc) xs - - read_em acc (')' : xs) = [(reverse acc, xs)] - read_em acc ( 'U' : '(' : xs) - = case (read_em [] xs) of - [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest - _ -> panic ("Text.Demand:"++str++"::"++xs) - - read_em acc other = panic ("IdInfo.readem:"++other) - -#ifdef REALLY_HASKELL_1_3 -instance Show Demand where -#endif - showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest - where - show1 (WwLazy False) = "L" - show1 (WwLazy True) = "A" - show1 WwStrict = "S" - show1 WwPrim = "P" - show1 WwEnum = "E" - show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")" - -instance Outputable Demand where - ppr sty si = ppStr (showList [si] "") - -instance OptIdInfo StrictnessInfo where - noInfo = NoStrictnessInfo - - getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict - - addInfo id_info NoStrictnessInfo = id_info - addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j +workerExists :: StrictnessInfo bdee -> Bool +workerExists (StrictnessInfo _ (Just worker_id)) = True +workerExists other = False - ppInfo sty better_id_fn strictness_info - = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info +getWorkerId_maybe :: StrictnessInfo bdee -> Maybe bdee +getWorkerId_maybe (StrictnessInfo _ maybe_worker_id) = maybe_worker_id +getWorkerId_maybe other = Nothing \end{code} -We'll omit the worker info if the thing has an explicit unfolding -already. -\begin{code} -pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE - -pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_") - -pp_strictness sty for_this_id_maybe better_id_fn inline_env - info@(StrictnessInfo wrapper_args wrkr_maybe) - = let - (have_wrkr, wrkr_id) = case wrkr_maybe of - Nothing -> (False, panic "ppInfo(Strictness)") - Just xx -> (True, xx) - - wrkr_to_print = better_id_fn wrkr_id - wrkr_info = getIdInfo wrkr_to_print - - -- if we aren't going to be able to *read* the strictness info - -- in TcPragmas, we need not even print it. - wrapper_args_to_use - = if not (indicatesWorker wrapper_args) then - wrapper_args -- no worker/wrappering in any case - else - case for_this_id_maybe of - Nothing -> wrapper_args - Just id -> if externallyVisibleId id - && (unfoldingUnfriendlyId id || not have_wrkr) then - -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $ - map un_workerise wrapper_args - else - wrapper_args - - id_is_worker - = case for_this_id_maybe of - Nothing -> False - Just id -> isWorkerId id - - am_printing_iface = case sty of { PprInterface -> True ; _ -> False } - - pp_basic_info - = ppBesides [ppStr "_S_ \"", - ppStr (showList wrapper_args_to_use ""), ppStr "\""] - - pp_with_worker - = ppBesides [ ppSP, ppChar '{', - ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info, - ppChar '}' ] - in - if all_present_WwLazies wrapper_args_to_use then -- too boring - ifPprInterface sty pp_NONE - - else if id_is_worker && am_printing_iface then - pp_NONE -- we don't put worker strictness in interfaces - -- (it can be deduced) - - else if not (indicatesWorker wrapper_args_to_use) - || not have_wrkr - || boringIdInfo wrkr_info then - ppBeside pp_basic_info ppNil - else - ppBeside pp_basic_info pp_with_worker - where - un_workerise (WwLazy _) = WwLazy False -- avoid absence - un_workerise (WwUnpack _) = WwStrict - un_workerise other = other -\end{code} %************************************************************************ %* * @@ -728,41 +383,9 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env %************************************************************************ \begin{code} -mkUnfolding guide expr - = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) - guide - (occurAnalyseGlobalExpr expr)) -\end{code} - -\begin{code} -noInfo_UF = NoUnfolding - -getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding - -addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfolding = id_info -addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j -\end{code} - -\begin{code} -pp_unfolding sty for_this_id inline_env uf_details - = case (lookupIdEnv inline_env for_this_id) of - Nothing -> pp uf_details - Just dt -> pp dt - where - pp NoUnfolding = pp_NONE - - pp (MagicUnfolding tag _) - = ppCat [ppPStr SLIT("_MF_"), pprUnique tag] - - pp (CoreUnfolding (SimpleUnfolding _ guide template)) - = let - untagged = unTagBinders template - in - if untagged `isWrapperFor` for_this_id - then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged)) - pp_NONE - else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged] +unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _ _) = unfolding +addUnfoldInfo (IdInfo a b d e _ f g h i) uf = IdInfo a b d e uf f g h i \end{code} %************************************************************************ @@ -804,18 +427,14 @@ instance Text UpdateInfo where ok_digit c | c >= '0' && c <= '2' = ord c - ord '0' | otherwise = panic "IdInfo: not a digit while reading update pragma" -instance OptIdInfo UpdateInfo where - noInfo = NoUpdateInfo - - getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update +updateInfo (IdInfo _ _ _ _ _ update _ _ _) = update - addInfo id_info NoUpdateInfo = id_info - addInfo (IdInfo a b d e f _ g h i j) upd_info = IdInfo a b d e f upd_info g h i j +addUpdateInfo id_info NoUpdateInfo = id_info +addUpdateInfo (IdInfo a b d e f _ g h i) upd_info = IdInfo a b d e f upd_info g h i - ppInfo sty better_id_fn NoUpdateInfo = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeUpdateInfo spec) - = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec)) +ppUpdateInfo sty NoUpdateInfo = ppNil +ppUpdateInfo sty (SomeUpdateInfo []) = ppNil +ppUpdateInfo sty (SomeUpdateInfo spec) = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec)) \end{code} %************************************************************************ @@ -836,19 +455,13 @@ data DeforestInfo \end{code} \begin{code} -instance OptIdInfo DeforestInfo where - noInfo = Don'tDeforest +deforestInfo (IdInfo _ _ _ _ _ _ deforest _ _) = deforest - getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest +addDeforestInfo id_info Don'tDeforest = id_info +addDeforestInfo (IdInfo a b d e f g _ h i) deforest = IdInfo a b d e f g deforest h i - addInfo id_info Don'tDeforest = id_info - addInfo (IdInfo a b d e f g _ h i j) deforest = - IdInfo a b d e f g deforest h i j - - ppInfo sty better_id_fn Don'tDeforest - = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn DoDeforest - = ppPStr SLIT("_DEFOREST_") +ppDeforestInfo sty Don'tDeforest = ppNil +ppDeforestInfo sty DoDeforest = ppPStr SLIT("_DEFOREST_") \end{code} %************************************************************************ @@ -869,27 +482,22 @@ type ArgUsageType = [ArgUsage] -- c_1 -> ... -> BLOB \end{code} \begin{code} -mkArgUsageInfo = SomeArgUsageInfo +mkArgUsageInfo [] = NoArgUsageInfo +mkArgUsageInfo au = SomeArgUsageInfo au getArgUsage :: ArgUsageInfo -> ArgUsageType -getArgUsage NoArgUsageInfo = [] +getArgUsage NoArgUsageInfo = [] getArgUsage (SomeArgUsageInfo u) = u \end{code} \begin{code} -instance OptIdInfo ArgUsageInfo where - noInfo = NoArgUsageInfo - - getInfo (IdInfo _ _ _ _ _ _ _ au _ _) = au +argUsageInfo (IdInfo _ _ _ _ _ _ _ au _) = au - addInfo id_info NoArgUsageInfo = id_info - addInfo (IdInfo a b d e f g h _ i j) au_info = IdInfo a b d e f g h au_info i j - - ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeArgUsageInfo aut) - = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut) +addArgUsageInfo id_info NoArgUsageInfo = id_info +addArgUsageInfo (IdInfo a b d e f g h _ i) au_info = IdInfo a b d e f g h au_info i +ppArgUsageInfo sty NoArgUsageInfo = ppNil +ppArgUsageInfo sty (SomeArgUsageInfo aut) = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut) ppArgUsage (ArgUsage n) = ppInt n ppArgUsage (UnknownArgUsage) = ppChar '-' @@ -899,6 +507,7 @@ ppArgUsageType aut = ppBesides ppIntersperse ppComma (map ppArgUsage aut), ppChar '"' ] \end{code} + %************************************************************************ %* * \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes} @@ -909,7 +518,6 @@ ppArgUsageType aut = ppBesides data FBTypeInfo = NoFBTypeInfo | SomeFBTypeInfo FBType - -- ??? deriving (Eq, Ord) data FBType = FBType [FBConsum] FBProd deriving (Eq) @@ -926,23 +534,15 @@ getFBType (SomeFBTypeInfo u) = Just u \end{code} \begin{code} -instance OptIdInfo FBTypeInfo where - noInfo = NoFBTypeInfo - - getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb +fbTypeInfo (IdInfo _ _ _ _ _ _ _ _ fb) = fb - addInfo id_info NoFBTypeInfo = id_info - addInfo (IdInfo a b d e f g h i _ j) fb_info = IdInfo a b d e f g h i fb_info j +addFBTypeInfo id_info NoFBTypeInfo = id_info +addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info - ppInfo PprInterface _ NoFBTypeInfo = ppNil - ppInfo sty _ NoFBTypeInfo = ifPprInterface sty pp_NONE - ppInfo sty _ (SomeFBTypeInfo (FBType cons prod)) +ppFBTypeInfo sty NoFBTypeInfo = ppNil +ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod)) = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod) ---ppFBType (FBType n) = ppBesides [ppInt n] ---ppFBType (UnknownFBType) = ppBesides [ppStr "-"] --- - ppFBType cons prod = ppBesides ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ]) where diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi index 3a766f0..86680a8 100644 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ b/ghc/compiler/basicTypes/IdLoop.lhi @@ -9,7 +9,7 @@ import PreludeStdIO ( Maybe ) import BinderInfo ( BinderInfo ) import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg ) import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), - SimpleUnfolding(..), FormSummary(..) ) + SimpleUnfolding(..), FormSummary(..), noUnfolding ) import CoreUtils ( unTagBinders ) import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, unfoldingUnfriendlyId, getIdInfo, nmbrId, @@ -34,11 +34,16 @@ import Unique ( Unique ) import Usage ( GenUsage ) import Util ( Ord3(..) ) import WwLib ( mAX_WORKER_ARGS ) +import StdIdInfo ( addStandardIdInfo ) -- Used in Id, but StdIdInfo needs lots of stuff from Id + +addStandardIdInfo :: Id -> Id nullSpecEnv :: SpecEnv isNullSpecEnv :: SpecEnv -> Bool -occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique +-- occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique +-- unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d + externallyVisibleId :: Id -> Bool isDataCon :: GenId ty -> Bool isWorkerId :: GenId ty -> Bool @@ -49,9 +54,7 @@ nullIdEnv :: UniqFM a lookupIdEnv :: UniqFM b -> GenId a -> Maybe b mAX_WORKER_ARGS :: Int nmbrId :: Id -> NmbrEnv -> (NmbrEnv, Id) -pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep -unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d - +pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun type IdEnv a = UniqFM a @@ -73,13 +76,15 @@ data NmbrEnv data MagicUnfoldingFun data FormSummary = VarForm | ValueForm | BottomForm | OtherForm -data Unfolding - = NoUnfolding - | CoreUnfolding SimpleUnfolding - | MagicUnfolding Unique MagicUnfoldingFun +-- data Unfolding +-- = NoUnfolding +-- | CoreUnfolding SimpleUnfolding +-- | MagicUnfolding Unique MagicUnfoldingFun +data Unfolding +noUnfolding :: Unfolding -data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) +-- data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) data UnfoldingGuidance diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs index 94703c3..a9ae815 100644 --- a/ghc/compiler/basicTypes/IdUtils.lhs +++ b/ghc/compiler/basicTypes/IdUtils.lhs @@ -6,21 +6,21 @@ \begin{code} #include "HsVersions.h" -module IdUtils ( primOpNameInfo, primOpId ) where +module IdUtils ( primOpName ) where IMP_Ubiq() IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking IMPORT_DELOOPER(IdLoop) (SpecEnv) import CoreSyn -import CoreUnfold ( UnfoldingGuidance(..), Unfolding ) -import Id ( mkImported, mkTemplateLocals ) +import CoreUnfold ( UnfoldingGuidance(..), Unfolding, mkUnfolding ) +import Id ( mkPrimitiveId, mkTemplateLocals ) import IdInfo -- quite a few things -import Name ( mkPrimitiveName, OrigName(..) ) -import PrelMods ( gHC_BUILTINS ) +import StdIdInfo +import Name ( mkWiredInIdName ) import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str, PrimOpInfo(..), PrimOpResultInfo(..) ) -import RnHsSyn ( RnName(..) ) +import PrelMods ( gHC__ ) import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon ) import TysWiredIn ( boolTy ) import Unique ( mkPrimOpIdUnique ) @@ -28,66 +28,45 @@ import Util ( panic ) \end{code} \begin{code} -primOpNameInfo :: PrimOp -> (FAST_STRING, RnName) -primOpId :: PrimOp -> Id - -primOpNameInfo op = (primOp_str op, WiredInId (primOpId op)) - -primOpId op +primOpName :: PrimOp -> Name +primOpName op = case (primOpInfo op) of Dyadic str ty -> - mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2 + mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2 Monadic str ty -> - mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1 + mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1 Compare str ty -> - mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2 + mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2 Coercing str ty1 ty2 -> - mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1 + mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1 PrimResult str tyvars arg_tys prim_tycon kind res_tys -> - mk_prim_Id op str + mk_prim_name op str tyvars arg_tys (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))) (length arg_tys) -- arity AlgResult str tyvars arg_tys tycon res_tys -> - mk_prim_Id op str + mk_prim_name op str tyvars arg_tys (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys))) (length arg_tys) -- arity where - mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity - = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty - (noIdInfo `addInfo` (mkArityInfo arity) - `addInfo_UF` (mkUnfolding UnfoldAlways - (mk_prim_unfold prim_op tyvar_tmpls arg_tys))) + mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity + = name where - key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op)) + key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op)) + name = mkWiredInIdName key gHC__ occ_name the_id + the_id = mkPrimitiveId name ty prim_op \end{code} - \begin{code} dyadic_fun_ty ty = mkFunTys [ty, ty] ty monadic_fun_ty ty = ty `mkFunTy` ty compare_fun_ty ty = mkFunTys [ty, ty] boolTy \end{code} - -The functions to make common unfoldings are tedious. - -\begin{code} -mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-} - -mk_prim_unfold prim_op tyvars arg_tys - = let - vars = mkTemplateLocals arg_tys - in - mkLam tyvars vars $ - Prim prim_op - ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars]) -\end{code} - diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 3fdedfb..d4b56e0 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -7,327 +7,352 @@ #include "HsVersions.h" module Name ( + -- The Module type SYN_IE(Module), + pprModule, moduleString, - OrigName(..), -- glorified pair - qualToOrigName, -- a Qual to an OrigName - - RdrName(..), - preludeQual, - moduleNamePair, - isUnqual, - isQual, - isRdrLexCon, isRdrLexConOrSpecial, - appendRdr, - showRdr, - cmpRdr, - - Name, - Provenance, - mkLocalName, isLocalName, - mkTopLevName, mkImportedName, oddlyImportedName, - mkImplicitName, isImplicitName, - mkPrimitiveName, mkWiredInName, - mkCompoundName, mkCompoundName2, - - mkFunTyConName, mkTupleDataConName, mkTupleTyConName, - mkTupNameStr, - - NamedThing(..), -- class - ExportFlag(..), - isExported{-overloaded-}, exportFlagOn{-not-}, - - nameUnique, changeUnique, - nameOccName, --- nameOrigName, : not exported - nameExportFlag, - nameSrcLoc, - nameImpLocs, - nameImportFlag, - isLocallyDefinedName, isWiredInName, - - origName, moduleOf, nameOf, - getOccName, getExportFlag, - getSrcLoc, getImpLocs, - isLocallyDefined, - getLocalName, - - isSymLexeme, pprSym, pprNonSym, - isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym - ) where + -- The OccName type + OccName(..), + pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour, isTvOcc, + quoteInText, parenInCode, -IMP_Ubiq() -IMPORT_1_3(Char(isUpper,isLower)) + -- The Name type + Name, -- Abstract + mkLocalName, mkSysLocalName, -import CmdLineOpts ( maybe_CompilingGhcInternals ) -import CStrings ( identToC, modnameToC, cSEP ) -import Outputable ( Outputable(..) ) -import PprStyle ( PprStyle(..), codeStyle ) -import PrelMods ( pRELUDE ) -import Pretty -import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc ) -import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, - pprUnique, Unique - ) -import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic{-, pprTrace ToDo:rm-} ) - -#ifdef REALLY_HASKELL_1_3 -ord = fromEnum :: Char -> Int -#endif -\end{code} + mkCompoundName, mkGlobalName, mkInstDeclName, -%************************************************************************ -%* * -\subsection[RdrName]{The @RdrName@ datatype; names read from files} -%* * -%************************************************************************ - -\begin{code} -type Module = FAST_STRING + mkWiredInIdName, mkWiredInTyConName, + maybeWiredInIdName, maybeWiredInTyConName, + isWiredInName, -data OrigName = OrigName Module FAST_STRING + nameUnique, changeUnique, setNameProvenance, setNameVisibility, + nameOccName, nameString, + isExportedName, nameSrcLoc, + isLocallyDefinedName, -qualToOrigName (Qual m n) = OrigName m n + isLocalName, -data RdrName - = Unqual FAST_STRING - | Qual Module FAST_STRING + pprNameProvenance, -preludeQual n = Qual pRELUDE n + -- Sets of Names + NameSet(..), + emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, + minusNameSet, elemNameSet, nameSetToList, addListToNameSet, -moduleNamePair (Qual m n) = (m, n) -- we make *no* claim whether this - -- constitutes an original name or - -- an occurrence name, or anything else - -isUnqual (Unqual _) = True -isUnqual (Qual _ _) = False + -- Misc + DefnInfo(..), + Provenance(..), pprProvenance, + ExportFlag(..), -isQual (Unqual _) = False -isQual (Qual _ _) = True + -- Class NamedThing and overloaded friends + NamedThing(..), + modAndOcc, isExported, + getSrcLoc, isLocallyDefined, getOccString, -isRdrLexCon (Unqual n) = isLexCon n -isRdrLexCon (Qual m n) = isLexCon n + pprSym, pprNonSym + ) where -isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n -isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n +IMP_Ubiq() +import TyLoop ( GenId, Id(..), TyCon ) -- Used inside Names +import CStrings ( identToC, modnameToC, cSEP ) +import CmdLineOpts ( opt_OmitInterfacePragmas, opt_EnsureSplittableC ) -appendRdr (Unqual n) str = Unqual (n _APPEND_ str) -appendRdr (Qual m n) str = Qual m (n _APPEND_ str) +import Outputable ( Outputable(..) ) +import PprStyle ( PprStyle(..), codeStyle, ifaceStyle ) +import PrelMods ( gHC__ ) +import Pretty +import Lex ( isLexSym, isLexConId ) +import SrcLoc ( noSrcLoc, SrcLoc ) +import Unique ( pprUnique, showUnique, Unique ) +import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, + unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet ) +import UniqFM ( UniqFM ) +import Util ( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} ) +\end{code} -cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2 -cmpRdr (Unqual n1) (Qual m2 n2) = LT_ -cmpRdr (Qual m1 n1) (Unqual n2) = GT_ -cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 - -- always compare module-names *second* -cmpOrig (OrigName m1 n1) (OrigName m2 n2) - = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second* +%************************************************************************ +%* * +\subsection[Name-pieces-datatypes]{The @Module@, @OccName@ datatypes} +%* * +%************************************************************************ -instance Eq RdrName where +\begin{code} +type Module = FAST_STRING + +data OccName = VarOcc FAST_STRING -- Variables and data constructors + | TvOcc FAST_STRING -- Type variables + | TCOcc FAST_STRING -- Type constructors and classes + +moduleString :: Module -> String +moduleString mod = _UNPK_ mod + +pprModule :: PprStyle -> Module -> Pretty +pprModule sty m = ppPStr m + +pprOccName :: PprStyle -> OccName -> Pretty +pprOccName PprDebug n = ppCat [ppPStr (occNameString n), ppBracket (ppStr (occNameFlavour n))] +pprOccName sty n = if codeStyle sty + then identToC (occNameString n) + else ppPStr (occNameString n) + +occNameString :: OccName -> FAST_STRING +occNameString (VarOcc s) = s +occNameString (TvOcc s) = s +occNameString (TCOcc s) = s + +-- occNameFlavour is used only to generate good error messages, so it doesn't matter +-- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for +-- data constructors and values, but that makes everything else a bit more complicated. +occNameFlavour :: OccName -> String +occNameFlavour (VarOcc s) | isLexConId s = "data constructor" + | otherwise = "value" +occNameFlavour (TvOcc s) = "type variable" +occNameFlavour (TCOcc s) = "type constructor or class" + +isTvOcc :: OccName -> Bool +isTvOcc (TvOcc s) = True +isTvOcc other = False + +instance Eq OccName where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } -instance Ord RdrName where +instance Ord OccName where a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } -instance Ord3 RdrName where - cmp = cmpRdr - -instance NamedThing RdrName where - -- We're sorta faking it here - getName (Unqual n) - = Local u n True locn - where - u = panic "NamedThing.RdrName:Unique1" - locn = panic "NamedThing.RdrName:locn" - - getName rdr_name@(Qual m n) - = Global u m (Left n) prov ex [rdr_name] - where - u = panic "NamedThing.RdrName:Unique" - prov = panic "NamedThing.RdrName:Provenance" - ex = panic "NamedThing.RdrName:ExportFlag" - -instance Outputable RdrName where - ppr sty (Unqual n) = pp_name sty n - ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n) - -pp_mod sty m - = case sty of - PprForC -> pp_code - PprForAsm False _ -> pp_code - PprForAsm True _ -> ppBeside (ppPStr cSEP) pp_code - _ -> ppBeside (ppPStr m) (ppChar '.') - where - pp_code = ppBeside (ppPStr (modnameToC m)) (ppPStr cSEP) +instance Ord3 OccName where + cmp = cmpOcc -pp_name sty n = (if codeStyle sty then identToC else ppPStr) n +(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `_CMP_STRING_` s2 +(VarOcc s1) `cmpOcc` other2 = LT_ -pp_name2 sty pieces - = ppIntersperse sep (map pp_piece pieces) - where - sep = if codeStyle sty then ppPStr cSEP else ppChar '.' +(TvOcc s1) `cmpOcc` (VarOcc s2) = GT_ +(TvOcc s1) `cmpOcc` (TvOcc s2) = s1 `_CMP_STRING_` s2 +(TvOcc s1) `cmpOcc` other = LT_ - pp_piece (Left (OrigName m n)) = ppBeside (pp_mod sty m) (pp_name sty n) - pp_piece (Right n) = pp_name sty n +(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `_CMP_STRING_` s2 +(TCOcc s1) `cmpOcc` other = GT_ -showRdr sty rdr = ppShow 100 (ppr sty rdr) +instance Outputable OccName where + ppr = pprOccName +\end{code} -------------------------- -instance Eq OrigName where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } -instance Ord OrigName where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } +\begin{code} +parenInCode, quoteInText :: OccName -> Bool +parenInCode occ = isLexSym (occNameString occ) -instance Ord3 OrigName where - cmp = cmpOrig +quoteInText occ = not (isLexSym (occNameString occ)) + +-- print `vars`, (op) correctly +pprSymOcc, pprNonSymOcc :: PprStyle -> OccName -> Pretty -instance NamedThing OrigName where -- faking it - getName (OrigName m n) = getName (Qual m n) +pprSymOcc sty var + = if quoteInText var + then ppQuote (pprOccName sty var) + else pprOccName sty var -instance Outputable OrigName where -- ditto - ppr sty (OrigName m n) = ppr sty (Qual m n) +pprNonSymOcc sty var + = if parenInCode var + then ppParens (pprOccName sty var) + else pprOccName sty var \end{code} %************************************************************************ %* * -\subsection[Name-datatype]{The @Name@ datatype} +\subsection[Name-datatype]{The @Name@ datatype, and name construction} %* * %************************************************************************ - + \begin{code} data Name = Local Unique - FAST_STRING - Bool -- True <=> emphasize Unique when - -- printing; this is just an esthetic thing... + OccName SrcLoc | Global Unique - Module -- original name - (Either - FAST_STRING -- just an ordinary M.n name... or... - ([Either OrigName FAST_STRING])) - -- "dot" these bits of name together... - Provenance -- where it came from - ExportFlag -- is it exported? - [RdrName] -- ordered occurrence names (usually just one); - -- first may be *un*qual. + Module -- The defining module + OccName -- Its name in that module + DefnInfo -- How it is defined + Provenance -- How it was brought into scope +\end{code} + +Things with a @Global@ name are given C static labels, so they finally +appear in the .o file's symbol table. They appear in the symbol table +in the form M.n. If originally-local things have this property they +must be made @Global@ first. + +\begin{code} +data DefnInfo = VanillaDefn + | WiredInTyCon TyCon -- There's a wired-in version + | WiredInId Id -- ...ditto... data Provenance - = LocalDef SrcLoc -- locally defined; give its source location - - | Imported ExportFlag -- how it was imported - SrcLoc -- *original* source location - [SrcLoc] -- any import source location(s) - - | Implicit - | Primitive -- really and truly primitive thing (not - -- definable in Haskell) - | WiredIn Bool -- something defined in Haskell; True <=> - -- definition is in the module in question; - -- this probably comes from the -fcompiling-prelude=... - -- flag. + = LocalDef ExportFlag SrcLoc -- Locally defined + | Imported Module SrcLoc -- Directly imported from M; gives locn of import statement + | Implicit -- Implicitly imported +\end{code} + +Something is "Exported" if it may be mentioned by another module without +warning. The crucial thing about Exported things is that they must +never be dropped as dead code, even if they aren't used in this module. +Furthermore, being Exported means that we can't see all call sites of the thing. + +Exported things include: + - explicitly exported Ids, including data constructors, class method selectors + - dfuns from instance decls + +Being Exported is *not* the same as finally appearing in the .o file's +symbol table. For example, a local Id may be mentioned in an Exported +Id's unfolding in the interface file, in which case the local Id goes +out too. + +\begin{code} +data ExportFlag = Exported | NotExported \end{code} \begin{code} +mkLocalName :: Unique -> OccName -> SrcLoc -> Name mkLocalName = Local -mkTopLevName u (OrigName m n) locn exp occs = Global u m (Left n) (LocalDef locn) exp occs -mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m (Left n) (Imported imp locn imp_locs) exp occs +mkGlobalName :: Unique -> Module -> OccName -> DefnInfo -> Provenance -> Name +mkGlobalName = Global + +mkSysLocalName :: Unique -> FAST_STRING -> SrcLoc -> Name +mkSysLocalName uniq str loc = Local uniq (VarOcc str) loc -mkImplicitName :: Unique -> OrigName -> Name -mkImplicitName u (OrigName m n) = Global u m (Left n) Implicit NotExported [] +mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name +mkWiredInIdName uniq mod occ id + = Global uniq mod (VarOcc occ) (WiredInId id) Implicit -mkPrimitiveName :: Unique -> OrigName -> Name -mkPrimitiveName u (OrigName m n) = Global u m (Left n) Primitive NotExported [] +mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name +mkWiredInTyConName uniq mod occ tycon + = Global uniq mod (TCOcc occ) (WiredInTyCon tycon) Implicit -mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name -mkWiredInName u (OrigName m n) exp - = Global u m (Left n) (WiredIn from_here) exp [] + +mkCompoundName :: (FAST_STRING -> FAST_STRING) -- Occurrence-name modifier + -> Unique -- New unique + -> Name -- Base name (must be a Global) + -> Name -- Result is always a value name + +mkCompoundName str_fn uniq (Global _ mod occ defn prov) + = Global uniq mod new_occ defn prov + where + new_occ = VarOcc (str_fn (occNameString occ)) -- Always a VarOcc + +mkCompoundName str_fn uniq (Local _ occ loc) + = Local uniq (VarOcc (str_fn (occNameString occ))) loc + + -- Rather a wierd one that's used for names generated for instance decls +mkInstDeclName :: Unique -> Module -> OccName -> SrcLoc -> Bool -> Name +mkInstDeclName uniq mod occ loc from_here + = Global uniq mod occ VanillaDefn prov where - from_here - = case maybe_CompilingGhcInternals of - Nothing -> False - Just mod -> mod == _UNPK_ m - -mkCompoundName :: Unique - -> Module - -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel") - -> [Either OrigName FAST_STRING] -- "dot" these names together - -> Name -- from which we get provenance, etc.... - -> Name -- result! - -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 [] - -glue = glue1 -glue1 (Left (OrigName m n):ns) = m : _CONS_ '.' n : glue2 ns -glue1 (Right n :ns) = n : glue2 ns -glue2 [] = [] -glue2 (Left (OrigName m n):ns) = _CONS_ '.' m : _CONS_ '.' n : glue2 ns -glue2 (Right n :ns) = _CONS_ '.' n : glue2 ns - --- this ugly one is used for instance-y things -mkCompoundName2 :: Unique - -> Module - -> FAST_STRING -- indicates what kind of compound thing it is - -> [Either OrigName FAST_STRING] -- "dot" these names together - -> Bool -- True <=> defined in this module - -> SrcLoc - -> Name -- result! - -mkCompoundName2 u m str ns from_here locn - = Global u m (Right (Right str : ns)) - (if from_here then LocalDef locn else Imported ExportAll locn []) - ExportAll{-instances-} - [] - -mkFunTyConName - = mkPrimitiveName funTyConKey (OrigName pRELUDE SLIT("->")) -mkTupleDataConName arity - = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll -mkTupleTyConName arity - = mkWiredInName (mkTupleTyConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll - -mkTupNameStr 0 = SLIT("()") -mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary -mkTupNameStr 3 = _PK_ "(,,)" -- ditto -mkTupNameStr 4 = _PK_ "(,,,)" -- ditto -mkTupNameStr n - = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") - - -- ToDo: what about module ??? - -- ToDo: exported when compiling builtin ??? - -isLocalName (Local _ _ _ _) = True -isLocalName _ = False - --- things the compiler "knows about" are in some sense + prov | from_here = LocalDef Exported loc + | otherwise = Implicit + + +setNameProvenance :: Name -> Provenance -> Name -- Globals only +setNameProvenance (Global uniq mod occ def _) prov = Global uniq mod occ def prov + +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +changeUnique (Local _ n l) u = Local u n l +changeUnique (Global _ mod occ def prov) u = Global u mod occ def prov + +setNameVisibility :: Module -> Name -> Name +-- setNameVisibility is applied to top-level names in the final program +-- The "visibility" here concerns whether the .o file's symbol table +-- mentions the thing; if so, it needs a module name in its symbol, +-- otherwise we just use its unique. The Global things are "visible" +-- and the local ones are not + +setNameVisibility _ (Global uniq mod occ def (LocalDef NotExported loc)) + | not all_toplev_ids_visible + = Local uniq occ loc + +setNameVisibility mod (Local uniq occ loc) + | all_toplev_ids_visible + = Global uniq mod + (VarOcc (showUnique uniq)) -- It's local name must be unique! + VanillaDefn (LocalDef NotExported loc) + +setNameVisibility mod name = name + +all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible + opt_EnsureSplittableC -- Splitting requires visiblilty +\end{code} + +%************************************************************************ +%* * +\subsection{Predicates and selectors} +%* * +%************************************************************************ + +\begin{code} +nameUnique :: Name -> Unique +nameModAndOcc :: Name -> (Module, OccName) -- Globals only +nameOccName :: Name -> OccName +nameString :: Name -> FAST_STRING -- A.b form +nameSrcLoc :: Name -> SrcLoc +isLocallyDefinedName :: Name -> Bool +isExportedName :: Name -> Bool +isWiredInName :: Name -> Bool +isLocalName :: Name -> Bool + + + +nameUnique (Local u _ _) = u +nameUnique (Global u _ _ _ _) = u + +nameOccName (Local _ occ _) = occ +nameOccName (Global _ _ occ _ _) = occ + +nameModAndOcc (Global _ mod occ _ _) = (mod,occ) + +nameString (Local _ occ _) = occNameString occ +nameString (Global _ mod occ _ _) = mod _APPEND_ SLIT(".") _APPEND_ occNameString occ + +isExportedName (Global _ _ _ _ (LocalDef Exported _)) = True +isExportedName other = False + +nameSrcLoc (Local _ _ loc) = loc +nameSrcLoc (Global _ _ _ _ (LocalDef _ loc)) = loc +nameSrcLoc (Global _ _ _ _ (Imported _ loc)) = loc +nameSrcLoc other = noSrcLoc + +isLocallyDefinedName (Local _ _ _) = True +isLocallyDefinedName (Global _ _ _ _ (LocalDef _ _)) = True +isLocallyDefinedName other = False + +-- Things the compiler "knows about" are in some sense -- "imported". When we are compiling the module where -- the entities are defined, we need to be able to pick -- them out, often in combination with isLocallyDefined. -oddlyImportedName (Global _ _ _ Primitive _ _) = True -oddlyImportedName (Global _ _ _ (WiredIn _) _ _) = True -oddlyImportedName _ = False +isWiredInName (Global _ _ _ (WiredInTyCon _) _) = True +isWiredInName (Global _ _ _ (WiredInId _) _) = True +isWiredInName _ = False + +maybeWiredInIdName :: Name -> Maybe Id +maybeWiredInIdName (Global _ _ _ (WiredInId id) _) = Just id +maybeWiredInIdName other = Nothing + +maybeWiredInTyConName :: Name -> Maybe TyCon +maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc) _) = Just tc +maybeWiredInTyConName other = Nothing -isImplicitName (Global _ _ _ Implicit _ _) = True -isImplicitName _ = False + +isLocalName (Local _ _ _) = True +isLocalName _ = False \end{code} + %************************************************************************ %* * \subsection[Name-instances]{Instance declarations} @@ -337,10 +362,10 @@ isImplicitName _ = False \begin{code} cmpName n1 n2 = c n1 n2 where - c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2 - c (Local _ _ _ _) _ = LT_ - c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2 - c (Global _ _ _ _ _ _) _ = GT_ + c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2 + c (Local _ _ _) _ = LT_ + c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2 + c (Global _ _ _ _ _) _ = GT_ \end{code} \begin{code} @@ -364,123 +389,74 @@ instance NamedThing Name where getName n = n \end{code} -\begin{code} -nameUnique (Local u _ _ _) = u -nameUnique (Global u _ _ _ _ _) = u --- when we renumber/rename things, we need to be --- able to change a Name's Unique to match the cached --- one in the thing it's the name of. If you know what I mean. -changeUnique (Local _ n b l) u = Local u n b l -changeUnique (Global _ m n p e os) u = Global u m n p e os - -nameOrigName msg (Global _ m (Left n) _ _ _) = OrigName m n -nameOrigName msg (Global _ m (Right n) _ _ _) = let str = _CONCAT_ (glue n) in - --pprTrace ("nameOrigName:"++msg) (ppPStr str) $ - OrigName m str -#ifdef DEBUG -nameOrigName msg (Local _ n _ _) = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n) -#endif - -nameOccName (Local _ n _ _) = Unqual n -nameOccName (Global _ m (Left n) _ _ [] ) = Qual m n -nameOccName (Global _ m (Right n) _ _ [] ) = let str = _CONCAT_ (glue n) in - --pprTrace "nameOccName:" (ppPStr str) $ - Qual m str -nameOccName (Global _ m (Left _) _ _ (o:_)) = o -nameOccName (Global _ m (Right _) _ _ (o:_)) = panic "nameOccName:compound name" - -nameExportFlag (Local _ _ _ _) = NotExported -nameExportFlag (Global _ _ _ _ exp _) = exp - -nameSrcLoc (Local _ _ _ loc) = loc -nameSrcLoc (Global _ _ _ (LocalDef loc) _ _) = loc -nameSrcLoc (Global _ _ _ (Imported _ loc _) _ _) = loc -nameSrcLoc (Global _ _ _ Implicit _ _) = mkUnknownSrcLoc -nameSrcLoc (Global _ _ _ Primitive _ _) = mkBuiltinSrcLoc -nameSrcLoc (Global _ _ _ (WiredIn _) _ _) = mkBuiltinSrcLoc - -nameImpLocs (Global _ _ _ (Imported _ _ locs) _ _) = locs -nameImpLocs _ = [] - -nameImportFlag (Local _ _ _ _) = NotExported -nameImportFlag (Global _ _ _ (LocalDef _) _ _) = ExportAll -nameImportFlag (Global _ _ _ (Imported exp _ _) _ _) = exp -nameImportFlag (Global _ _ _ Implicit _ _) = ExportAll -nameImportFlag (Global _ _ _ Primitive _ _) = ExportAll -nameImportFlag (Global _ _ _ (WiredIn _) _ _) = ExportAll - -isLocallyDefinedName (Local _ _ _ _) = True -isLocallyDefinedName (Global _ _ _ (LocalDef _) _ _) = True -isLocallyDefinedName (Global _ _ _ (Imported _ _ _) _ _) = False -isLocallyDefinedName (Global _ _ _ Implicit _ _) = False -isLocallyDefinedName (Global _ _ _ Primitive _ _) = False -isLocallyDefinedName (Global _ _ _ (WiredIn from_here) _ _) = from_here - -isWiredInName (Global _ _ _ (WiredIn _) _ _) = True -isWiredInName _ = False -\end{code} + +%************************************************************************ +%* * +\subsection{Pretty printing} +%* * +%************************************************************************ \begin{code} instance Outputable Name where - ppr sty (Local u n emph_uniq _) - | codeStyle sty = pprUnique u - | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"] - | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"] - - ppr PprDebug (Global u m (Left n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"] - ppr PprDebug (Global u m (Right n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name2 PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"] - - ppr PprForUser (Global u m (Left n) _ _ [] ) = ppBeside (pp_mod PprForUser m) (pp_name PprForUser n) - ppr PprForUser (Global u m (Right n) _ _ [] ) = ppBeside (pp_mod PprForUser m) (pp_name2 PprForUser n) - ppr PprForUser (Global u m (Left _) _ _ occs) = ppr PprForUser (head occs) - --- LATER:? --- ppr PprShowAll (Global u m n prov exp occs) = pp_all (Qual m n) prov exp occs - - ppr sty (Global u m (Left n) _ _ _) = ppBeside (pp_mod sty m) (pp_name sty n) - ppr sty (Global u m (Right n) _ _ _) = ppBeside (pp_mod sty m) (pp_name2 sty n) - -pp_all orig prov exp occs - = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp] - -pp_exp NotExported = ppNil -pp_exp ExportAll = ppPStr SLIT("/EXP(..)") -pp_exp ExportAbs = ppPStr SLIT("/EXP") - -pp_prov Implicit = ppPStr SLIT("/IMPLICIT") -pp_prov Primitive = ppPStr SLIT("/PRIMITIVE") -pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN") -pp_prov _ = ppNil + ppr sty (Local u n _) | codeStyle sty || + ifaceStyle sty = pprUnique u + | otherwise = ppBesides [ppPStr (occNameString n), ppPStr SLIT("_"), pprUnique u] + + ppr sty (Global u m n _ _) = ppBesides [pp_name, pp_uniq sty u] + where + pp_name | codeStyle sty = identToC qual_name + | otherwise = ppPStr qual_name + qual_name = m _APPEND_ SLIT(".") _APPEND_ occNameString n + +pp_uniq PprDebug uniq = ppBesides [ppStr "{-", pprUnique uniq, ppStr "-}"] +pp_uniq other uniq = ppNil + +-- pprNameProvenance is used in error messages to say where a name came from +pprNameProvenance :: PprStyle -> Name -> Pretty +pprNameProvenance sty (Local _ _ loc) = pprProvenance sty (LocalDef NotExported loc) +pprNameProvenance sty (Global _ _ _ _ prov) = pprProvenance sty prov + +pprProvenance :: PprStyle -> Provenance -> Pretty +pprProvenance sty (Imported mod loc) + = ppSep [ppStr "Imported from", pprModule sty mod, ppStr "at", ppr sty loc] +pprProvenance sty (LocalDef _ loc) + = ppSep [ppStr "Defined at", ppr sty loc] +pprProvenance sty Implicit + = panic "pprNameProvenance: Implicit" \end{code} + %************************************************************************ %* * -\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype} +\subsection[Sets of names} %* * %************************************************************************ -The export flag @ExportAll@ means `export all there is', so there are -times when it is attached to a class or data type which has no -ops/constructors (if the class/type was imported abstractly). In -fact, @ExportAll@ is attached to everything except to classes/types -which are being {\em exported} abstractly, regardless of how they were -imported. - \begin{code} -data ExportFlag - = ExportAll -- export with all constructors/methods - | ExportAbs -- export abstractly (tycons/classes only) - | NotExported +type NameSet = UniqSet Name +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +addListToNameSet :: NameSet -> [Name] -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSets :: NameSet -> NameSet -> NameSet +unionManyNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +nameSetToList :: NameSet -> [Name] + +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +addListToNameSet = addListToUniqSet +unionNameSets = unionUniqSets +unionManyNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +nameSetToList = uniqSetToList +\end{code} -exportFlagOn NotExported = False -exportFlagOn _ = True --- Be very wary about using "isExported"; perhaps you --- really mean "externallyVisibleId"? - -isExported a = exportFlagOn (getExportFlag a) -\end{code} %************************************************************************ %* * @@ -490,140 +466,30 @@ isExported a = exportFlagOn (getExportFlag a) \begin{code} class NamedThing a where - getName :: a -> Name + getOccName :: a -> OccName -- Even RdrNames can do this! + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method \end{code} \begin{code} -origName :: NamedThing a => String -> a -> OrigName -moduleOf :: OrigName -> Module -nameOf :: OrigName -> FAST_STRING - -getOccName :: NamedThing a => a -> RdrName -getLocalName :: NamedThing a => a -> FAST_STRING -getExportFlag :: NamedThing a => a -> ExportFlag +modAndOcc :: NamedThing a => a -> (Module, OccName) getSrcLoc :: NamedThing a => a -> SrcLoc -getImpLocs :: NamedThing a => a -> [SrcLoc] isLocallyDefined :: NamedThing a => a -> Bool +isExported :: NamedThing a => a -> Bool +getOccString :: NamedThing a => a -> String -origName str n = nameOrigName str (getName n) - -moduleOf (OrigName m n) = m -nameOf (OrigName m n) = n - -getLocalName n - = case (getName n) of - Local _ n _ _ -> n - Global _ m (Left n) _ _ _ -> n - Global _ m (Right n) _ _ _ -> let str = _CONCAT_ (glue n) in - -- pprTrace "getLocalName:" (ppPStr str) $ - str - -getOccName = nameOccName . getName -getExportFlag = nameExportFlag . getName +modAndOcc = nameModAndOcc . getName +isExported = isExportedName . getName getSrcLoc = nameSrcLoc . getName -getImpLocs = nameImpLocs . getName isLocallyDefined = isLocallyDefinedName . getName +pprSym sty = pprSymOcc sty . getOccName +pprNonSym sty = pprNonSymOcc sty . getOccName +getOccString x = _UNPK_ (occNameString (getOccName x)) \end{code} \begin{code} -{-# SPECIALIZE getLocalName - :: Name -> FAST_STRING - , OrigName -> FAST_STRING - , RdrName -> FAST_STRING - , RnName -> FAST_STRING - #-} {-# SPECIALIZE isLocallyDefined :: Name -> Bool - , RnName -> Bool - #-} -{-# SPECIALIZE origName - :: String -> Name -> OrigName - , String -> RdrName -> OrigName - , String -> RnName -> OrigName #-} \end{code} - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. Normally applied as in e.g. @isCon -(getLocalName foo)@. - -\begin{code} -isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, - isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- - -isLexConId cs - | _NULL_ cs = False - | otherwise = isUpper c || isUpperISO c - where - c = _HEAD_ cs - -isLexVarId cs - | _NULL_ cs = False - | otherwise = isLower c || isLowerISO c - where - c = _HEAD_ cs - -isLexConSym cs - | _NULL_ cs = False - | otherwise = c == ':' --- || c == '(' -- (), (,), (,,), ... - || cs == SLIT("->") --- || cs == SLIT("[]") - where - c = _HEAD_ cs - -isLexVarSym cs - | _NULL_ cs = False - | otherwise = isSymbolASCII c - || isSymbolISO c --- || c == '(' -- (), (,), (,,), ... --- || cs == SLIT("[]") - where - c = _HEAD_ cs - -isLexSpecialSym cs - | _NULL_ cs = False - | otherwise = c == '(' -- (), (,), (,,), ... - || cs == SLIT("[]") - where - c = _HEAD_ cs - -------------- -isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" -isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) -isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c -\end{code} - -And one ``higher-level'' interface to those: - -\begin{code} -isSymLexeme :: NamedThing a => a -> Bool - -isSymLexeme v - = let str = getLocalName v in isLexSym str - --- print `vars`, (op) correctly -pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty - -pprSym sty var - = let - str = getLocalName var - in - if isLexSym str && not (isLexSpecialSym str) - then ppr sty var - else ppBesides [ppChar '`', ppr sty var, ppChar '`'] - -pprNonSym sty var - = if isSymLexeme var - then ppParens (ppr sty var) - else ppr sty var -\end{code} diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs index a2af9ac..eee6ee9 100644 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -12,7 +12,7 @@ module PprEnv ( initPprEnv, pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle, - pTy, pTyVar, pUVar, pUse, + pTy, pTyVarB, pTyVarO, pUVar, pUse, NmbrEnv(..), SYN_IE(NmbrM), initNmbr, @@ -45,7 +45,9 @@ data PprEnv tyvar uvar bndr occ (PrimOp -> Pretty) (CostCentre -> Pretty) - (tyvar -> Pretty) -- to print tyvars + (tyvar -> Pretty) -- to print tyvar binders + (tyvar -> Pretty) -- to print tyvar occurrences + (uvar -> Pretty) -- to print usage vars (bndr -> Pretty) -- to print "major" val_bdrs @@ -64,6 +66,7 @@ initPprEnv -> Maybe (PrimOp -> Pretty) -> Maybe (CostCentre -> Pretty) -> Maybe (tyvar -> Pretty) + -> Maybe (tyvar -> Pretty) -> Maybe (uvar -> Pretty) -> Maybe (bndr -> Pretty) -> Maybe (bndr -> Pretty) @@ -75,13 +78,14 @@ initPprEnv -- you can specify all the printers individually; if -- you don't specify one, you get bottom -initPprEnv sty l d p c tv uv maj_bndr min_bndr occ ty use +initPprEnv sty l d p c tvb tvo uv maj_bndr min_bndr occ ty use = PE sty (demaybe l) (demaybe d) (demaybe p) (demaybe c) - (demaybe tv) + (demaybe tvb) + (demaybe tvo) (demaybe uv) (demaybe maj_bndr) (demaybe min_bndr) @@ -112,21 +116,22 @@ initPprEnv sty pmaj pmin pocc \end{code} \begin{code} -pStyle (PE s _ _ _ _ _ _ _ _ _ _ _) = s -pLit (PE _ pp _ _ _ _ _ _ _ _ _ _) = pp -pCon (PE _ _ pp _ _ _ _ _ _ _ _ _) = pp -pPrim (PE _ _ _ pp _ _ _ _ _ _ _ _) = pp -pSCC (PE _ _ _ _ pp _ _ _ _ _ _ _) = pp - -pTyVar (PE _ _ _ _ _ pp _ _ _ _ _ _) = pp -pUVar (PE _ _ _ _ _ _ pp _ _ _ _ _) = pp - -pMajBndr (PE _ _ _ _ _ _ _ pp _ _ _ _) = pp -pMinBndr (PE _ _ _ _ _ _ _ _ pp _ _ _) = pp -pOcc (PE _ _ _ _ _ _ _ _ _ pp _ _) = pp - -pTy (PE _ _ _ _ _ _ _ _ _ _ pp _) = pp -pUse (PE _ _ _ _ _ _ _ _ _ _ _ pp) = pp +pStyle (PE s _ _ _ _ _ _ _ _ _ _ _ _) = s +pLit (PE _ pp _ _ _ _ _ _ _ _ _ _ _) = pp +pCon (PE _ _ pp _ _ _ _ _ _ _ _ _ _) = pp +pPrim (PE _ _ _ pp _ _ _ _ _ _ _ _ _) = pp +pSCC (PE _ _ _ _ pp _ _ _ _ _ _ _ _) = pp + +pTyVarB (PE _ _ _ _ _ pp _ _ _ _ _ _ _) = pp +pTyVarO (PE _ _ _ _ _ _ pp _ _ _ _ _ _) = pp +pUVar (PE _ _ _ _ _ _ _ pp _ _ _ _ _) = pp + +pMajBndr (PE _ _ _ _ _ _ _ _ pp _ _ _ _) = pp +pMinBndr (PE _ _ _ _ _ _ _ _ _ pp _ _ _) = pp +pOcc (PE _ _ _ _ _ _ _ _ _ _ pp _ _) = pp + +pTy (PE _ _ _ _ _ _ _ _ _ _ _ pp _) = pp +pUse (PE _ _ _ _ _ _ _ _ _ _ _ _ pp) = pp \end{code} We tend to {\em renumber} everything before printing, so that diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index e12b0db..f4a3b2b 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -11,15 +11,17 @@ #include "HsVersions.h" module SrcLoc ( - SrcLoc, -- abstract + SrcLoc, -- Abstract + + mkSrcLoc, + noSrcLoc, isNoSrcLoc, -- "I'm sorry, I haven't a clue" - mkSrcLoc, mkSrcLoc2, -- the usual - mkUnknownSrcLoc, -- "I'm sorry, I haven't a clue" mkIfaceSrcLoc, -- Unknown place in an interface -- (this one can die eventually ToDo) - mkBuiltinSrcLoc, -- something wired into the compiler - mkGeneratedSrcLoc, -- code generated within the compiler - unpackSrcLoc + + mkBuiltinSrcLoc, -- Something wired into the compiler + + mkGeneratedSrcLoc -- Code generated within the compiler ) where IMP_Ubiq() @@ -38,10 +40,12 @@ We keep information about the {\em definition} point for each entity; this is the obvious stuff: \begin{code} data SrcLoc - = SrcLoc FAST_STRING -- source file name - FAST_STRING -- line number in source file - | SrcLoc2 FAST_STRING -- same, but w/ an Int line# + = NoSrcLoc + + | SrcLoc FAST_STRING -- A precise location FAST_INT + + | UnhelpfulSrcLoc FAST_STRING -- Just a general indication \end{code} Note that an entity might be imported via more than one route, and @@ -57,15 +61,15 @@ rare case. Things to make 'em: \begin{code} -mkSrcLoc = SrcLoc -mkSrcLoc2 x IBOX(y) = SrcLoc2 x y -mkUnknownSrcLoc = SrcLoc SLIT("") SLIT("") -mkIfaceSrcLoc = SrcLoc SLIT("") SLIT("") -mkBuiltinSrcLoc = SrcLoc SLIT("") SLIT("") -mkGeneratedSrcLoc = SrcLoc SLIT("") SLIT("") - -unpackSrcLoc (SrcLoc src_file src_line) = (src_file, src_line) -unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line))) +noSrcLoc = NoSrcLoc +mkSrcLoc x IBOX(y) = SrcLoc x y + +mkIfaceSrcLoc = UnhelpfulSrcLoc SLIT("") +mkBuiltinSrcLoc = UnhelpfulSrcLoc SLIT("") +mkGeneratedSrcLoc = UnhelpfulSrcLoc SLIT("") + +isNoSrcLoc NoSrcLoc = True +isNoSrcLoc other = False \end{code} %************************************************************************ @@ -77,12 +81,13 @@ 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, ppStr "\", line ", ppPStr src_line ] + = ppBesides [ ppPStr src_file, ppStr ": ", ppStr (show IBOX(src_line)) ] ppr sty (SrcLoc src_file src_line) - = ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP, + = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP, ppChar '"', ppPStr src_file, ppPStr SLIT("\" #-}")] - ppr sty (SrcLoc2 src_file src_line) - = ppr sty (SrcLoc src_file (_PK_ (show IBOX(src_line)))) + ppr sty (UnhelpfulSrcLoc s) = ppPStr s + + ppr sty NoSrcLoc = ppStr "" \end{code} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 3cb2ca7..5641107 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -13,7 +13,7 @@ module UniqSupply ( getUnique, getUniques, -- basic ops SYN_IE(UniqSM), -- type: unique supply monad - initUs, thenUs, returnUs, + initUs, thenUs, returnUs, fixUs, mapUs, mapAndUnzipUs, mapAndUnzip3Us, thenMaybeUs, mapAccumLUs, @@ -147,6 +147,10 @@ initUs init_us m @thenUs@ is where we split the @UniqSupply@. \begin{code} +fixUs :: (a -> UniqSM a) -> UniqSM a +fixUs m us + = r where r = m r us + thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b thenUs expr cont us diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 104953a..0d4fb49 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -87,6 +87,7 @@ module Unique ( foreignObjTyConKey, forkIdKey, fractionalClassKey, + fromEnumClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey, fromRationalClassOpKey, @@ -212,6 +213,7 @@ module Unique ( , parAtRelIdKey , parGlobalIdKey , parLocalIdKey + , unboundKey ) where import PreludeGlaST @@ -664,4 +666,7 @@ eqClassOpKey = mkPreludeMiscIdUnique 60 geClassOpKey = mkPreludeMiscIdUnique 61 zeroClassOpKey = mkPreludeMiscIdUnique 62 thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=) +unboundKey = mkPreludeMiscIdUnique 64 -- Just a place holder for unbound + -- variables produced by the renamer +fromEnumClassOpKey = mkPreludeMiscIdUnique 65 \end{code} diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 6e0c8bd..684e2bc 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -44,7 +44,7 @@ import Id ( idPrimRep, toplevelishId, isDataCon, GenId{-instance NamedThing-} ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, oddlyImportedName, Name{-instance NamedThing-} ) +import Name ( isLocallyDefined, isWiredInName, Name{-instance NamedThing-} ) #ifdef DEBUG import PprAbsC ( pprAmode ) #endif @@ -195,8 +195,8 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@. getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id - | not (isLocallyDefined name) || oddlyImportedName name - {- Why the "oddlyImported"? + | not (isLocallyDefined name) || isWiredInName name + {- Why the "isWiredInName"? Imagine you are compiling GHCbase.hs (a module that supplies some of the wired-in values). What can happen is that the compiler will inject calls to diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index d0f9bf8..5d06570 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -26,7 +26,7 @@ import CgBindery ( getCAddrMode, getArgAmodes, bindNewToReg, bindArgsToRegs, stableAmodeIdInfo, heapIdInfo, CgIdInfo ) -import CgCompInfo ( spARelToInt, spBRelToInt ) +import Constants ( spARelToInt, spBRelToInt ) import CgUpdate ( pushUpdateFrame ) import CgHeapery ( allocDynClosure, heapCheck , heapCheckOnly, fetchAndReschedule, yield -- HWL @@ -41,7 +41,7 @@ import CgUsages ( getVirtSps, setRealAndVirtualSps, getSpARelOffset, getSpBRelOffset, getHpRelOffset ) -import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, +import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel, mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel, mkErrorStdEntryLabel, mkRednCountsLabel ) @@ -313,7 +313,8 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info -- If f is not top-level, then f is one of the free variables too, -- hence "payload_ids" isn't the same as "arg_ids". -- - vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet + stg_args = map StgVarArg args + vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet -- Empty live vars arg_ids_w_info = [(name,mkLFArgument) | name <- args] @@ -323,8 +324,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo | otherwise = args - vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids - upd_flag [] vap_entry_rhs + vap_lf_info = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload -- It's not top level, even if we're currently compiling a top-level -- function, because any VAP *use* of this function will be for a -- local thunk, thus @@ -434,10 +434,6 @@ closureCodeBody binder_info closure_info cc all_args body = getEntryConvention id lf_info (map idPrimRep all_args) `thenFC` \ entry_conv -> let - is_concurrent = opt_ForConcurrent - - stg_arity = length all_args - -- Arg mapping for standard (slow) entry point; all args on stack (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets) = mkVirtStkOffsets @@ -510,8 +506,12 @@ closureCodeBody binder_info closure_info cc all_args body mkIntCLit spA_stk_args, -- # passed on A stk mkIntCLit spB_stk_args, -- B stk (rest in regs) CString (_PK_ (map (showTypeCategory . idType) all_args)), - CString (_PK_ (show_wrapper_name wrapper_maybe)), - CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe)) + CString SLIT(""), CString SLIT("") + +-- Nuked for now; see comment at end of file +-- CString (_PK_ (show_wrapper_name wrapper_maybe)), +-- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe)) + ] `thenC` -- Bind args to regs/stack as appropriate, and @@ -544,6 +544,8 @@ closureCodeBody binder_info closure_info cc all_args body CCodeBlock fast_label fast_abs_c ) where + is_concurrent = opt_ForConcurrent + stg_arity = length all_args lf_info = closureLFInfo closure_info cl_descr mod_name = closureDescription mod_name id all_args body @@ -554,11 +556,10 @@ closureCodeBody binder_info closure_info cc all_args body -- Manufacture labels id = closureId closure_info + fast_label = mkFastEntryLabel id stg_arity + stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep - fast_label = fastLabelFromCI closure_info - - stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep - +{- OLD... see note at end of file wrapper_maybe = get_ultimate_wrapper Nothing id where get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain" @@ -574,6 +575,7 @@ closureCodeBody binder_info closure_info cc all_args body = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of Nothing -> "" Just str -> str +-} \end{code} For lexically scoped profiling we have to load the cost centre from @@ -943,3 +945,46 @@ chooseDynCostCentres cc args fvs body in (use_cc, blame_cc) \end{code} + + + +======================================================================== +OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS + +It's pretty wierd, so I've nuked it for now. SLPJ Nov 96 + +\begin{pseudocode} +getWrapperArgTypeCategories + :: Type -- wrapper's type + -> StrictnessInfo bdee -- strictness info about its args + -> Maybe String + +getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing +getWrapperArgTypeCategories _ BottomGuaranteed + = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong +getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing + +getWrapperArgTypeCategories ty (StrictnessInfo arg_info _) + = Just (mkWrapperArgTypeCategories ty arg_info) + +mkWrapperArgTypeCategories + :: Type -- wrapper's type + -> [Demand] -- info about its arguments + -> String -- a string saying lots about the args + +mkWrapperArgTypeCategories wrapper_ty wrap_info + = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) -> + map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) } + where + -- ToDo: this needs FIXING UP (it was a hack anyway...) + do_one (WwPrim, _) = 'P' + do_one (WwEnum, _) = 'E' + do_one (WwStrict, arg_ty_char) = arg_ty_char + do_one (WwUnpack _, arg_ty_char) + = if arg_ty_char `elem` "CIJFDTS" + then toLower arg_ty_char + else if arg_ty_char == '+' then 't' + else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-' + do_one (other_wrap_info, _) = '-' +\end{pseudocode} + diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs index 561f8bf..a7e72a0 100644 --- a/ghc/compiler/codeGen/CgCompInfo.lhs +++ b/ghc/compiler/codeGen/CgCompInfo.lhs @@ -11,9 +11,10 @@ #include "HsVersions.h" module CgCompInfo ( - uNFOLDING_USE_THRESHOLD, - uNFOLDING_CREATION_THRESHOLD, - uNFOLDING_OVERRIDE_THRESHOLD, +-- uNFOLDING_USE_THRESHOLD, +-- uNFOLDING_CREATION_THRESHOLD, +-- uNFOLDING_OVERRIDE_THRESHOLD, + iNTERFACE_UNFOLD_THRESHOLD, uNFOLDING_CHEAP_OP_COST, uNFOLDING_DEAR_OP_COST, uNFOLDING_NOREP_LIT_COST, @@ -79,9 +80,11 @@ import Util All pretty arbitrary: \begin{code} -uNFOLDING_USE_THRESHOLD = ( 3 :: Int) -uNFOLDING_CREATION_THRESHOLD = (30 :: Int) -uNFOLDING_OVERRIDE_THRESHOLD = ( 8 :: Int) +-- uNFOLDING_USE_THRESHOLD = ( 3 :: Int) +-- uNFOLDING_CREATION_THRESHOLD = (30 :: Int) +-- uNFOLDING_OVERRIDE_THRESHOLD = ( 8 :: Int) + +iNTERFACE_UNFOLD_THRESHOLD = (30 :: Int) uNFOLDING_CHEAP_OP_COST = ( 1 :: Int) uNFOLDING_DEAR_OP_COST = ( 4 :: Int) uNFOLDING_NOREP_LIT_COST = ( 4 :: Int) diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 21507e3..2ae485e 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -29,7 +29,7 @@ import CgBindery ( getArgAmodes, bindNewToNode, heapIdInfo, CgIdInfo ) import CgClosure ( cgTopRhsClosure ) -import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE ) +import Constants ( mAX_INTLIKE, mIN_INTLIKE ) import CgHeapery ( allocDynClosure ) import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) @@ -124,7 +124,7 @@ cgTopRhsCon name con args all_zero_size_args = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info where body = StgCon con args emptyIdSet{-emptyLiveVarSet-} - lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body + lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] \end{code} OK, so now we have the general case. diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index ea53371..c970c9f 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -14,7 +14,7 @@ import AbsCSyn import CgMonad import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep ) -import CgCompInfo ( uF_UPDATEE ) +import Constants ( uF_UPDATEE ) import CgHeapery ( heapCheck, allocDynClosure ) import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg, CtrlReturnConvention(..), @@ -39,7 +39,7 @@ import Id ( dataConTag, dataConRawArgTys, emptyIdSet, GenId{-instance NamedThing-} ) -import Name ( nameOf, origName ) +import Name ( getOccString ) import PrelInfo ( maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, mkSpecTyCon ) @@ -208,7 +208,7 @@ genConInfo comp_info tycon data_con body_code)) entry_addr = CLbl entry_label CodePtrRep - con_descr = _UNPK_ (nameOf (origName "con_descr" data_con)) + con_descr = getOccString data_con closure_code = CClosureInfoAndCode closure_info body Nothing stdUpd con_descr @@ -335,7 +335,7 @@ genPhantomUpdInfo comp_info tycon data_con phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con) - con_descr = _UNPK_ (nameOf (origName "con_descr2" data_con)) + con_descr = getOccString data_con con_arity = dataConNumFields data_con diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 05264e6..c9a6dc7 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -15,12 +15,13 @@ module CgExpr ( cgExpr, getPrimOpArgAmodes ) where IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking +import Constants ( mAX_SPEC_SELECTEE_SIZE ) import StgSyn import CgMonad import AbsCSyn import AbsCUtils ( mkAbsCStmts, mkAbstractCs ) -import CgBindery ( getArgAmodes, CgIdInfo ) +import CgBindery ( getArgAmodes, getCAddrModeAndInfo, CgIdInfo ) import CgCase ( cgCase, saveVolatileVarsAndRegs ) import CgClosure ( cgRhsClosure ) import CgCon ( buildDynCon, cgReturnDataCon ) @@ -34,17 +35,23 @@ import CgTailCall ( cgTailCall, performReturn, mkDynamicAlgReturnCode, mkPrimReturnCode ) import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel ) -import ClosureInfo ( mkClosureLFInfo ) +import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo, lfArity_maybe, + layOutDynCon ) import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre ) -import HeapOffs ( SYN_IE(VirtualSpBOffset) ) -import Id ( mkIdSet, unionIdSets, GenId{-instance Outputable-} ) +import HeapOffs ( SYN_IE(VirtualSpBOffset), intOffsetIntoGoods ) +import Id ( dataConTyCon, idPrimRep, getIdArity, + mkIdSet, unionIdSets, GenId{-instance Outputable-} + ) +import IdInfo ( ArityInfo(..) ) +import Name ( isLocallyDefined ) import PprStyle ( PprStyle(..) ) import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..), getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) ) import PrimRep ( getPrimRepSize, PrimRep(..) ) -import TyCon ( tyConDataCons ) -import Util ( panic, pprPanic, assertPanic ) +import TyCon ( tyConDataCons, maybeTyConSingleCon ) +import Maybes ( assocMaybe, maybeToBool ) +import Util ( panic, isIn, pprPanic, assertPanic ) \end{code} This module provides the support code for @StgToAbstractC@ to deal @@ -289,9 +296,6 @@ ToDo: counting of dict sccs ... %******************************************************** \subsection[non-top-level-bindings]{Converting non-top-level bindings} -@cgBinding@ is only used for let/letrec, not for unboxed bindings. -So the kind should always be @PtrRep@. - We rely on the support code in @CgCon@ (to do constructors) and in @CgClosure@ (to do closures). @@ -308,11 +312,125 @@ cgRhs name (StgRhsCon maybe_cc con args) zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 cgRhs name (StgRhsClosure cc bi fvs upd_flag args body) - = cgRhsClosure name cc bi fvs args body lf_info + = mkRhsLFInfo fvs upd_flag args body `thenFC` \ lf_info -> + cgRhsClosure name cc bi fvs args body lf_info +\end{code} + +mkRhsLFInfo looks for two special forms of the right-hand side: + a) selector thunks. + b) VAP thunks + +If neither happens, it just calls mkClosureLFInfo. You might think +that mkClosureLFInfo should do all this, but + (a) it seems wrong for the latter to look at the structure + of an expression + (b) mkRhsLFInfo has to be in the monad since it looks up in + the environment, and it's very tiresome for mkClosureLFInfo to + be. Apart from anything else it would make a loop between + CgBindery and ClosureInfo. + +Selectors +~~~~~~~~~ +We look at the body of the closure to see if it's a selector---turgid, +but nothing deep. We are looking for a closure of {\em exactly} the +form: +\begin{verbatim} +... = [the_fv] \ u [] -> + case the_fv of + con a_1 ... a_n -> a_i +\end{verbatim} + +\begin{code} +mkRhsLFInfo [the_fv] -- Just one free var + Updatable -- Updatable thunk + [] -- A thunk + (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _) + _ _ _ -- ignore live vars and uniq... + (StgAlgAlts case_ty + [(con, params, use_mask, + (StgApp (StgVarArg selectee) [{-no args-}] _))] + StgNoDefault)) + | the_fv == scrutinee -- Scrutinee is the only free variable + && maybeToBool maybe_offset -- Selectee is a component of the tuple + && maybeToBool offset_into_int_maybe + && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough + = -- ASSERT(is_single_constructor) -- Should be true, but causes error for SpecTyCon + returnFC (mkSelectorLFInfo scrutinee con offset_into_int) where - lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body + (_, params_w_offsets) = layOutDynCon con idPrimRep params + maybe_offset = assocMaybe params_w_offsets selectee + Just the_offset = maybe_offset + offset_into_int_maybe = intOffsetIntoGoods the_offset + Just offset_into_int = offset_into_int_maybe + is_single_constructor = maybeToBool (maybeTyConSingleCon tycon) + tycon = dataConTyCon con \end{code} + +Vap thunks +~~~~~~~~~~ +Same kind of thing, looking for vector-apply thunks, of the form: + + x = [...] \ .. [] -> f a1 .. an + +where f has arity n. We rely on the arity info inside the Id being correct. + +\begin{code} +mkRhsLFInfo fvs + upd_flag + [] -- No args; a thunk + (StgApp (StgVarArg fun_id) args _) + | isLocallyDefined fun_id -- Must be defined in this module + = -- Get the arity of the fun_id. We could find out from the + -- looking in the Id, but it's more certain just to look in the code + -- generator's environment. + +---------------------------------------------- +-- Sadly, looking in the environment, as suggested above, +-- causes a black hole (because cgRhsClosure depends on the LFInfo +-- returned here to determine its control flow. +-- So I wimped out and went back to looking at the arity inside the Id. +-- That means beefing up Core2Stg to propagate it. Sigh. +-- getCAddrModeAndInfo fun_id `thenFC` \ (_, fun_lf_info) -> +-- let arity_maybe = lfArity_maybe fun_lf_info +---------------------------------------------- + + let + arity_maybe = case getIdArity fun_id of + ArityExactly n -> Just n + other -> Nothing + in + returnFC (case arity_maybe of + Just arity + | arity > 0 && -- It'd better be a function! + arity == length args -- Saturated application + -> -- Ha! A VAP thunk + mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap + + other -> mkClosureLFInfo False{-not top level-} fvs upd_flag [] + ) + + where + -- If the function is a free variable then it must be stored + -- in the thunk too; if it isn't a free variable it must be + -- because it's constant, so it doesn't need to be stored in the thunk + store_fun_in_vap = fun_id `is_elem` fvs + is_elem = isIn "mkClosureLFInfo" +\end{code} + +The default case +~~~~~~~~~~~~~~~~ +\begin{code} +mkRhsLFInfo fvs upd_flag args body + = returnFC (mkClosureLFInfo False{-not top level-} fvs upd_flag args) +\end{code} + + +%******************************************************** +%* * +%* Let-no-escape bindings +%* * +%******************************************************** \begin{code} cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs) = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 5768b2d..6b773f9 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -29,7 +29,7 @@ import AbsCSyn -- quite a few things import AbsCUtils ( mkAbstractCs, getAmodeRep, amodeCanSurviveGC ) -import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, +import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG ) diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs index 70e344b..5c0accd 100644 --- a/ghc/compiler/codeGen/CgUpdate.lhs +++ b/ghc/compiler/codeGen/CgUpdate.lhs @@ -13,7 +13,7 @@ IMP_Ubiq(){-uitous-} import CgMonad import AbsCSyn -import CgCompInfo ( sTD_UF_SIZE, sCC_STD_UF_SIZE ) +import Constants ( sTD_UF_SIZE, sCC_STD_UF_SIZE ) import CgStackery ( allocUpdateFrame ) import CmdLineOpts ( opt_SccProfilingOn ) import Util ( assertPanic ) diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 73f9e6f..186209f 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -15,7 +15,7 @@ module ClosureInfo ( EntryConvention(..), - mkClosureLFInfo, mkConLFInfo, + mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, closureSize, closureHdrSize, @@ -28,15 +28,15 @@ module ClosureInfo ( mkVirtHeapOffsets, nodeMustPointToIt, getEntryConvention, - blackHoleOnEntry, + blackHoleOnEntry, lfArity_maybe, staticClosureRequired, slowFunEntryCodeRequired, funInfoTableRequired, stdVapRequired, noUpdVapRequired, - closureId, infoTableLabelFromCI, + closureId, infoTableLabelFromCI, fastLabelFromCI, closureLabelFromCI, - entryLabelFromCI, fastLabelFromCI, + entryLabelFromCI, closureLFInfo, closureSMRep, closureUpdReqd, closureSingleEntry, closureSemiTag, closureType, closureReturnsUnboxedType, getStandardFormThunkInfo, @@ -58,8 +58,7 @@ import AbsCSyn import StgSyn import CgMonad -import CgCompInfo ( mAX_SPEC_SELECTEE_SIZE, - mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject, +import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject, mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS, mAX_SPEC_ALL_NONPTRS, oTHER_TAG @@ -76,27 +75,26 @@ import CLabel ( mkStdEntryLabel, mkFastEntryLabel, ) import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent ) import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize, - intOffsetIntoGoods, SYN_IE(VirtualHeapOffset) ) -import Id ( idType, idPrimRep, getIdArity, +import Id ( idType, getIdArity, externallyVisibleId, dataConTag, fIRST_TAG, - isDataCon, isNullaryDataCon, dataConTyCon, + isDataCon, isNullaryDataCon, dataConTyCon, dataConArity, isTupleCon, SYN_IE(DataCon), GenId{-instance Eq-} ) -import IdInfo ( arityMaybe ) -import Maybes ( assocMaybe, maybeToBool ) -import Name ( isLocallyDefined, nameOf, origName ) +import IdInfo ( ArityInfo(..) ) +import Maybes ( maybeToBool ) +import Name ( getOccString ) import PprStyle ( PprStyle(..) ) import PprType ( getTyDescription, GenType{-instance Outputable-} ) ---import Pretty--ToDo:rm +import Pretty --ToDo:rm import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, separateByPtrFollowness ) import SMRep -- all of it -import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} ) -import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking, +import TyCon ( TyCon{-instance NamedThing-} ) +import Type ( isPrimType, expandTy, splitForAllTy, splitFunTyExpandingDictsAndPeeking, mkFunTys, maybeAppSpecDataTyConExpandingDicts ) import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic ) @@ -361,11 +359,11 @@ mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo mkLFImported id - = case arityMaybe (getIdArity id) of - Nothing -> LFImported - Just 0 -> LFThunk True{-top-lev-} True{-no fvs-} - True{-updatable-} NonStandardThunk - Just n -> LFReEntrant True n True -- n > 0 + = case getIdArity id of + ArityExactly 0 -> LFThunk True{-top-lev-} True{-no fvs-} + True{-updatable-} NonStandardThunk + ArityExactly n -> LFReEntrant True n True -- n > 0 + other -> LFImported -- Not sure of exact arity \end{code} %************************************************************************ @@ -381,90 +379,15 @@ mkClosureLFInfo :: Bool -- True of top level -> [Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args - -> StgExpr -- Body of closure: passed so we - -- can look for selector thunks! -> LambdaFormInfo -mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args +mkClosureLFInfo top fvs upd_flag args@(_:_) -- Non-empty args = LFReEntrant top (length args) (null fvs) -mkClosureLFInfo top fvs ReEntrant [] body +mkClosureLFInfo top fvs ReEntrant [] = LFReEntrant top 0 (null fvs) -\end{code} - -OK, this is where we look at the body of the closure to see if it's a -selector---turgid, but nothing deep. We are looking for a closure of -{\em exactly} the form: -\begin{verbatim} -... = [the_fv] \ u [] -> - case the_fv of - con a_1 ... a_n -> a_i -\end{verbatim} -Here we go: -\begin{code} -mkClosureLFInfo False -- don't bother if at top-level - [the_fv] -- just one... - Updatable - [] -- no args (a thunk) - (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _) - _ _ _ -- ignore live vars and uniq... - (StgAlgAlts case_ty - [(con, params, use_mask, - (StgApp (StgVarArg selectee) [{-no args-}] _))] - StgNoDefault)) - | the_fv == scrutinee -- Scrutinee is the only free variable - && maybeToBool maybe_offset -- Selectee is a component of the tuple - && maybeToBool offset_into_int_maybe - && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough - = - -- ASSERT(is_single_constructor) -- Should be true, by causes error for SpecTyCon - LFThunk False False True (SelectorThunk scrutinee con offset_into_int) - where - (_, params_w_offsets) = layOutDynCon con idPrimRep params - maybe_offset = assocMaybe params_w_offsets selectee - Just the_offset = maybe_offset - offset_into_int_maybe = intOffsetIntoGoods the_offset - Just offset_into_int = offset_into_int_maybe - is_single_constructor = maybeToBool (maybeTyConSingleCon tycon) - tycon = dataConTyCon con -\end{code} - -Same kind of thing, looking for vector-apply thunks, of the form: - x = [...] \ .. [] -> f a1 .. an - -where f has arity n. We rely on the arity info inside the Id being correct. - -\begin{code} -mkClosureLFInfo top_level - fvs - upd_flag - [] -- No args; a thunk - (StgApp (StgVarArg fun_id) args _) - | not top_level -- A top-level thunk would require a static - -- vap_info table, which we don't generate just - -- now; so top-level thunks are never standard - -- form. - && isLocallyDefined fun_id -- Must be defined in this module - && maybeToBool arity_maybe -- A known function with known arity - && fun_arity > 0 -- It'd better be a function! - && fun_arity == length args -- Saturated application - = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap) - where - arity_maybe = arityMaybe (getIdArity fun_id) - Just fun_arity = arity_maybe - - -- If the function is a free variable then it must be stored - -- in the thunk too; if it isn't a free variable it must be - -- because it's constant, so it doesn't need to be stored in the thunk - store_fun_in_vap = fun_id `is_elem` fvs - - is_elem = isIn "mkClosureLFInfo" -\end{code} - -Finally, the general updatable-thing case: -\begin{code} -mkClosureLFInfo top fvs upd_flag [] body +mkClosureLFInfo top fvs upd_flag [] = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk isUpdatable ReEntrant = False @@ -480,6 +403,12 @@ mkConLFInfo :: DataCon -> LambdaFormInfo mkConLFInfo con = -- the isNullaryDataCon will do this: ASSERT(isDataCon con) (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con) + +mkSelectorLFInfo scrutinee con offset + = LFThunk False False True (SelectorThunk scrutinee con offset) + +mkVapLFInfo fvs upd_flag fun_id args fun_in_vap + = LFThunk False (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args fun_in_vap) \end{code} @@ -1086,6 +1015,15 @@ noUpdVapRequired binder_info _ -> False \end{code} +@lfArity@ extracts the arity of a function from its LFInfo + +\begin{code} +lfArity_maybe (LFReEntrant _ arity _) = Just arity +lfArity_maybe (LFCon con _) = Just (dataConArity con) +lfArity_maybe (LFTuple con _) = Just (dataConArity con) +lfArity_maybe other = Nothing +\end{code} + %************************************************************************ %* * \subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.} @@ -1158,11 +1096,10 @@ closureReturnsUnboxedType other_closure = False -- ToDo: need anything like this in Type.lhs? fun_result_ty arity id = let - (_, de_foralld_ty) = splitForAllTy (idType id) - (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking de_foralld_ty + (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking (idType id) in - ASSERT(arity >= 0 && length arg_tys >= arity) --- (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $ +-- ASSERT(arity >= 0 && length arg_tys >= arity) + (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $ mkFunTys (drop arity arg_tys) res_ty \end{code} @@ -1189,8 +1126,13 @@ isToplevClosure (MkClosureInfo _ lf_info _) Label generation. \begin{code} -infoTableLabelFromCI :: ClosureInfo -> CLabel +fastLabelFromCI :: ClosureInfo -> CLabel +fastLabelFromCI (MkClosureInfo id lf_info _) + = case lfArity_maybe lf_info of + Just arity -> mkFastEntryLabel id arity + other -> pprPanic "fastLabelFromCI" (ppr PprDebug id) +infoTableLabelFromCI :: ClosureInfo -> CLabel infoTableLabelFromCI (MkClosureInfo id lf_info rep) = case lf_info of LFCon con _ -> mkConInfoPtr con rep @@ -1254,14 +1196,6 @@ thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable = mkVapEntryLabel fun_id is_updatable thunkEntryLabel thunk_id _ is_updatable = mkStdEntryLabel thunk_id - -fastLabelFromCI :: ClosureInfo -> CLabel -fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity - where - arity_maybe = arityMaybe (getIdArity id) - fun_arity = case arity_maybe of - Just x -> x - _ -> panic "fastLabelFromCI:no arity:" --(ppr PprShowAll id) \end{code} \begin{code} @@ -1331,8 +1265,8 @@ closureKind (MkClosureInfo _ lf _) closureTypeDescr :: ClosureInfo -> String closureTypeDescr (MkClosureInfo id lf _) - = if (isDataCon id) then -- DataCon has function types - _UNPK_ (nameOf (origName "closureTypeDescr" (dataConTyCon id))) -- We want the TyCon not the -> + = if (isDataCon id) then -- DataCon has function types + getOccString (dataConTyCon id) -- We want the TyCon not the -> else getTyDescription (idType id) \end{code} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 5879c0f..a786145 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -57,7 +57,7 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg = let doing_profiling = opt_SccProfilingOn compiling_prelude = opt_CompilingGhcInternals - maybe_split = if maybeToBool (opt_EnsureSplittableC) + maybe_split = if opt_EnsureSplittableC then CSplitMarker else AbsCNop @@ -167,5 +167,5 @@ cgTopRhs name (StgRhsClosure cc bi fvs upd_flag args body) = ASSERT(null fvs) -- There should be no free variables forkStatics (cgTopRhsClosure name cc bi args body lf_info) where - lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args body + lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args \end{code} diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index 59c655a..2310d02 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -24,7 +24,7 @@ import Id ( idType, mkSysLocal, nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv), GenId{-instances-} ) -import Name ( isLocallyDefined, getSrcLoc ) +import Name ( isLocallyDefined, getSrcLoc, getOccString ) import TyCon ( isBoxedTyCon, TyCon{-instance-} ) import Type ( maybeAppDataTyConExpandingDicts, eqTy ) import TysPrim ( statePrimTyCon ) @@ -213,8 +213,7 @@ liftDeflt (BindDefault binder rhs) type LiftM a = IdEnv (Id, Id) -- lifted Ids are mapped to: -- * lifted Id with the same Unique - -- (top-level bindings must keep their - -- unique (see TopLevId in Id.lhs)) + -- (top-level bindings must keep their unique -- * unlifted version with a new Unique -> UniqSupply -- unique supply -> a -- result @@ -279,7 +278,7 @@ mkLiftedId id u = ASSERT (isUnboxedButNotState unlifted_ty) (lifted_id, unlifted_id) where - id_name = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id + id_name = _PK_ (getOccString id) -- yuk! lifted_id = updateIdType id lifted_ty unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id) diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 42830e9..4b25be3 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -133,6 +133,7 @@ desugarer sets up constructors as applications of global @Vars@s. | Prim PrimOp [GenCoreArg val_occ tyvar uvar] -- saturated primitive operation; + -- comment on Cons applies here, too. \end{code} diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 247e969..386ef41 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -17,15 +17,16 @@ find, unsurprisingly, a Core expression. module CoreUnfold ( SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types + UfExpr, RdrName, -- For closure (delete in 1.3) FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, - smallEnoughToInline, couldBeSmallEnoughToInline, + noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate, - mkSimpleUnfolding, - mkMagicUnfolding, - calcUnfoldingGuidance, - mentionedInUnfolding + smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline, + okToInline, + + calcUnfoldingGuidance ) where IMP_Ubiq() @@ -34,17 +35,27 @@ IMPORT_DELOOPER(IdLoop) -- for paranoia checking; IMPORT_DELOOPER(PrelLoop) -- for paranoia checking import Bag ( emptyBag, unitBag, unionBags, Bag ) -import CgCompInfo ( uNFOLDING_CHEAP_OP_COST, + +import CmdLineOpts ( opt_UnfoldingCreationThreshold, + opt_UnfoldingUseThreshold, + opt_UnfoldingConDiscount + ) +import Constants ( uNFOLDING_CHEAP_OP_COST, uNFOLDING_DEAR_OP_COST, uNFOLDING_NOREP_LIT_COST ) +import BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger ) import CoreSyn +import CoreUtils ( unTagBinders ) +import HsCore ( UfExpr ) +import RdrHsSyn ( RdrName ) +import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( coreExprType ) import CostCentre ( ccMentionsId ) import Id ( idType, getIdArity, isBottomingId, SYN_IE(IdSet), GenId{-instances-} ) import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) ) -import IdInfo ( arityMaybe, bottomIsGuaranteed ) +import IdInfo ( ArityInfo(..), bottomIsGuaranteed ) import Literal ( isNoRepLit, isLitLitLit ) import Pretty import TyCon ( tyConFamilySize ) @@ -55,8 +66,6 @@ import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, import Usage ( SYN_IE(UVar) ) import Util ( isIn, panic, assertPanic ) -whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)" -getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)" \end{code} %************************************************************************ @@ -68,28 +77,37 @@ getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromTy \begin{code} data Unfolding = NoUnfolding + | CoreUnfolding SimpleUnfolding + | MagicUnfolding - Unique -- of the Id whose magic unfolding this is + Unique -- Unique of the Id whose magic unfolding this is MagicUnfoldingFun data SimpleUnfolding - = SimpleUnfolding FormSummary -- Tells whether the template is a WHNF or bottom - UnfoldingGuidance -- Tells about the *size* of the template. - TemplateOutExpr -- The template + = SimpleUnfolding -- An unfolding with redundant cached information + FormSummary -- Tells whether the template is a WHNF or bottom + UnfoldingGuidance -- Tells about the *size* of the template. + SimplifiableCoreExpr -- Template -type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar - -- An OutExpr with occurrence info attached. This is used as - -- a template in GeneralForms. +noUnfolding = NoUnfolding -mkSimpleUnfolding form guidance template - = SimpleUnfolding form guidance template +mkUnfolding inline_me expr + = CoreUnfolding (SimpleUnfolding + (mkFormSummary expr) + (calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr) + (occurAnalyseGlobalExpr expr)) mkMagicUnfolding :: Unique -> Unfolding mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag) +getUnfoldingTemplate :: Unfolding -> CoreExpr +getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr)) + = unTagBinders expr +getUnfoldingTemplate other = panic "getUnfoldingTemplate" + data UnfoldingGuidance = UnfoldNever @@ -162,8 +180,9 @@ mkFormSummary expr go n (Var f) | isBottomingId f = BottomForm go 0 (Var f) = VarForm - go n (Var f) = case (arityMaybe (getIdArity f)) of - Just arity | n < arity -> ValueForm + go n (Var f) = case getIdArity f of + ArityExactly a | n < a -> ValueForm + ArityAtLeast a | n < a -> ValueForm other -> OtherForm whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool @@ -209,16 +228,18 @@ enough? \begin{code} calcUnfoldingGuidance - :: Bool -- True <=> OK if _scc_s appear in expr + :: Bool -- True <=> there's an INLINE pragma on this thing -> Int -- bomb out if size gets bigger than this -> CoreExpr -- expression to look at -> UnfoldingGuidance -calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr +calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so + +calcUnfoldingGuidance False bOMB_OUT_SIZE expr = let (use_binders, ty_binders, val_binders, body) = collectBinders expr in - case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of + case (sizeExpr bOMB_OUT_SIZE val_binders body) of Nothing -> UnfoldNever @@ -247,8 +268,7 @@ calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr \end{code} \begin{code} -sizeExpr :: Bool -- True <=> _scc_s OK - -> Int -- Bomb out if it gets bigger than this +sizeExpr :: Int -- Bomb out if it gets bigger than this -> [Id] -- Arguments; we're interested in which of these -- get case'd -> CoreExpr @@ -256,19 +276,19 @@ sizeExpr :: Bool -- True <=> _scc_s OK [Id] -- Subset of args which are cased ) -sizeExpr scc_s_OK bOMB_OUT_SIZE args expr +sizeExpr bOMB_OUT_SIZE args expr = size_up expr where size_up (Var v) = sizeOne size_up (App fun arg) = size_up fun `addSize` size_up_arg arg size_up (Lit lit) = if isNoRepLit lit - then sizeN uNFOLDING_NOREP_LIT_COST - else sizeOne + then sizeN uNFOLDING_NOREP_LIT_COST + else sizeOne - size_up (SCC _ (Con _ _)) = Nothing -- **** HACK ***** - size_up (SCC lbl body) - = if scc_s_OK then size_up body else Nothing +-- I don't understand this hack so I'm removing it! SLPJ Nov 96 +-- size_up (SCC _ (Con _ _)) = Nothing -- **** HACK ***** + size_up (SCC lbl body) = size_up body -- SCCs cost nothing size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing size_up (Con con args) = -- 1 + # of val args @@ -394,23 +414,27 @@ hands, we get a (again, semi-arbitrary) discount [proportion to the number of constructors in the type being scrutinized]. \begin{code} -smallEnoughToInline :: Int -> Int -- Constructor discount and size threshold - -> [Bool] -- Evaluated-ness of value arguments - -> UnfoldingGuidance - -> Bool -- True => unfold it - -smallEnoughToInline con_discount size_threshold _ UnfoldAlways = True -smallEnoughToInline con_discount size_threshold _ UnfoldNever = False -smallEnoughToInline con_discount size_threshold arg_is_evald_s - (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size) - = n_vals_wanted <= length arg_is_evald_s && - discounted_size <= size_threshold +smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments + -> UnfoldingGuidance + -> Bool -- True => unfold it +smallEnoughToInline _ UnfoldAlways = True +smallEnoughToInline _ UnfoldNever = False +smallEnoughToInline arg_is_evald_s + (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size) + = enough_args n_vals_wanted arg_is_evald_s && + discounted_size <= opt_UnfoldingUseThreshold where + enough_args 0 evals = True + enough_args n [] = False + enough_args n (e:es) = enough_args (n-1) es + -- NB: don't take the length of arg_is_evald_s because when + -- called from couldBeSmallEnoughToInline it is infinite! + discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s) arg_discount no_of_constrs is_evald - | is_evald = 1 + no_of_constrs * con_discount + | is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount | otherwise = 1 \end{code} @@ -419,379 +443,48 @@ use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code} -couldBeSmallEnoughToInline :: Int -> Int -- Constructor discount and size threshold - -> UnfoldingGuidance - -> Bool -- True => unfold it - -couldBeSmallEnoughToInline con_discount size_threshold guidance - = smallEnoughToInline con_discount size_threshold (repeat True) guidance -\end{code} - -%************************************************************************ -%* * -\subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces} -%* * -%************************************************************************ - -Of course, the main thing we do to unfoldings-for-interfaces is {\em -print} them. But, while we're at it, we collect info about -``mentioned'' Ids, etc., etc.---we're going to need this stuff anyway. - -%************************************************************************ -%* * -\subsubsection{Monad stuff for the unfolding-generation game} -%* * -%************************************************************************ - -\begin{code} -type UnfoldM bndr thing - = IdSet -- in-scope Ids (passed downwards only) - -> (bndr -> Id) -- to extract an Id from a binder (down only) - - -> (Bag Id, -- mentioned global vars (ditto) - Bag TyCon, -- ditto, tycons - Bag Class, -- ditto, classes - Bool) -- True <=> mentions something litlit-ish - - -> (thing, (Bag Id, Bag TyCon, Bag Class, Bool)) -- accumulated... -\end{code} - -A little stuff for in-scopery: -\begin{code} -no_in_scopes :: IdSet -add1 :: IdSet -> Id -> IdSet -add_some :: IdSet -> [Id] -> IdSet - -no_in_scopes = emptyUniqSet -in_scopes `add1` x = addOneToUniqSet in_scopes x -in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs -\end{code} - -The can-see-inside-monad functions are the usual sorts of things. - -\begin{code} -thenUf :: UnfoldM bndr a -> (a -> UnfoldM bndr b) -> UnfoldM bndr b -thenUf m k in_scopes get_id mentioneds - = case m in_scopes get_id mentioneds of { (v, mentioneds1) -> - k v in_scopes get_id mentioneds1 } - -thenUf_ :: UnfoldM bndr a -> UnfoldM bndr b -> UnfoldM bndr b -thenUf_ m k in_scopes get_id mentioneds - = case m in_scopes get_id mentioneds of { (_, mentioneds1) -> - k in_scopes get_id mentioneds1 } - -mapUf :: (a -> UnfoldM bndr b) -> [a] -> UnfoldM bndr [b] -mapUf f [] = returnUf [] -mapUf f (x:xs) - = f x `thenUf` \ r -> - mapUf f xs `thenUf` \ rs -> - returnUf (r:rs) - -returnUf :: a -> UnfoldM bndr a -returnUf v in_scopes get_id mentioneds = (v, mentioneds) - -addInScopesUf :: [Id] -> UnfoldM bndr a -> UnfoldM bndr a -addInScopesUf more_in_scopes m in_scopes get_id mentioneds - = m (in_scopes `add_some` more_in_scopes) get_id mentioneds - -getInScopesUf :: UnfoldM bndr IdSet -getInScopesUf in_scopes get_id mentioneds = (in_scopes, mentioneds) - -extractIdsUf :: [bndr] -> UnfoldM bndr [Id] -extractIdsUf binders in_scopes get_id mentioneds - = (map get_id binders, mentioneds) - -consider_Id :: Id -> UnfoldM bndr () -consider_Id var in_scopes get_id (ids, tcs, clss, has_litlit) - = let - (ids2, tcs2, clss2) = whatsMentionedInId in_scopes var - in - ((), (ids `unionBags` ids2, - tcs `unionBags` tcs2, - clss `unionBags`clss2, - has_litlit)) -\end{code} - -\begin{code} -addToMentionedIdsUf :: Id -> UnfoldM bndr () -addToMentionedTyConsUf :: Bag TyCon -> UnfoldM bndr () -addToMentionedClassesUf :: Bag Class -> UnfoldM bndr () -litlit_oops :: UnfoldM bndr () - -addToMentionedIdsUf add_me in_scopes get_id (ids, tcs, clss, has_litlit) - = ((), (ids `unionBags` unitBag add_me, tcs, clss, has_litlit)) - -addToMentionedTyConsUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit) - = ((), (ids, tcs `unionBags` add_mes, clss, has_litlit)) - -addToMentionedClassesUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit) - = ((), (ids, tcs, clss `unionBags` add_mes, has_litlit)) - -litlit_oops in_scopes get_id (ids, tcs, clss, _) - = ((), (ids, tcs, clss, True)) -\end{code} - - -%************************************************************************ -%* * -\subsubsection{Gathering up info for an interface-unfolding} -%* * -%************************************************************************ - -\begin{code} -{- -mentionedInUnfolding - :: (bndr -> Id) -- so we can get Ids out of binders - -> GenCoreExpr bndr Id -- input expression - -> (Bag Id, Bag TyCon, Bag Class, - -- what we found mentioned in the expr - Bool -- True <=> mentions a ``litlit''-ish thing - -- (the guy on the other side of an interface - -- may not be able to handle it) - ) --} - -mentionedInUnfolding get_id expr - = case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of - (_, (ids_bag, tcs_bag, clss_bag, has_litlit)) -> - (ids_bag, tcs_bag, clss_bag, has_litlit) -\end{code} - -\begin{code} ---ment_expr :: GenCoreExpr bndr Id -> UnfoldM bndr () - -ment_expr (Var v) = consider_Id v -ment_expr (Lit l) = consider_lit l - -ment_expr expr@(Lam _ _) - = let - (uvars, tyvars, args, body) = collectBinders expr - in - extractIdsUf args `thenUf` \ bs_ids -> - addInScopesUf bs_ids ( - -- this considering is just to extract any mentioned types/classes - mapUf consider_Id bs_ids `thenUf_` - ment_expr body - ) - -ment_expr (App fun arg) - = ment_expr fun `thenUf_` - ment_arg arg - -ment_expr (Con c as) - = consider_Id c `thenUf_` - mapUf ment_arg as `thenUf_` - returnUf () - -ment_expr (Prim op as) - = ment_op op `thenUf_` - mapUf ment_arg as `thenUf_` - returnUf () - where - ment_op (CCallOp str is_asm may_gc arg_tys res_ty) - = mapUf ment_ty arg_tys `thenUf_` - ment_ty res_ty - ment_op other_op = returnUf () - -ment_expr (Case scrutinee alts) - = ment_expr scrutinee `thenUf_` - ment_alts alts - -ment_expr (Let (NonRec bind rhs) body) - = ment_expr rhs `thenUf_` - extractIdsUf [bind] `thenUf` \ bi@[bind_id] -> - addInScopesUf bi ( - ment_expr body `thenUf_` - consider_Id bind_id ) - -ment_expr (Let (Rec pairs) body) - = let - binders = map fst pairs - rhss = map snd pairs - in - extractIdsUf binders `thenUf` \ binder_ids -> - addInScopesUf binder_ids ( - mapUf ment_expr rhss `thenUf_` - mapUf consider_Id binder_ids `thenUf_` - ment_expr body ) - -ment_expr (SCC cc expr) - = (case (ccMentionsId cc) of - Just id -> consider_Id id - Nothing -> returnUf () - ) - `thenUf_` ment_expr expr - -ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce" - -------------- -ment_ty ty - = let - (tycons, clss) = getMentionedTyConsAndClassesFromType ty - in - addToMentionedTyConsUf tycons `thenUf_` - addToMentionedClassesUf clss - -------------- +couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool +couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) guidance -ment_alts alg_alts@(AlgAlts alts deflt) - = mapUf ment_alt alts `thenUf_` - ment_deflt deflt - where - ment_alt alt@(con, params, rhs) - = consider_Id con `thenUf_` - extractIdsUf params `thenUf` \ param_ids -> - addInScopesUf param_ids ( - -- "consider" them so we can chk out their types... - mapUf consider_Id param_ids `thenUf_` - ment_expr rhs ) - -ment_alts (PrimAlts alts deflt) - = mapUf ment_alt alts `thenUf_` - ment_deflt deflt - where - ment_alt alt@(lit, rhs) = ment_expr rhs - ----------------- -ment_deflt NoDefault - = returnUf () - -ment_deflt d@(BindDefault b rhs) - = extractIdsUf [b] `thenUf` \ bi@[b_id] -> - addInScopesUf bi ( - consider_Id b_id `thenUf_` - ment_expr rhs ) - ------------ -ment_arg (VarArg v) = consider_Id v -ment_arg (LitArg l) = consider_lit l -ment_arg (TyArg ty) = ment_ty ty -ment_arg (UsageArg _) = returnUf () - ------------ -consider_lit lit - | isLitLitLit lit = litlit_oops `thenUf_` returnUf () - | otherwise = returnUf () +certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool +certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) guidance \end{code} -%************************************************************************ -%* * -\subsubsection{Printing unfoldings in interfaces} -%* * -%************************************************************************ - -Printing Core-expression unfoldings is sufficiently delicate that we -give it its own function. -\begin{code} -{- OLD: -pprCoreUnfolding - :: CoreExpr - -> Pretty - -pprCoreUnfolding expr - = let - (_, renamed) = instCoreExpr uniqSupply_u expr - -- We rename every unfolding with a "steady" unique supply, - -- so that the names won't constantly change. - -- One place we *MUST NOT* use a splittable UniqueSupply! - in - ppr_uf_Expr emptyUniqSet renamed - -ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding") -\end{code} +Predicates +~~~~~~~~~~ \begin{code} -ppr_uf_Expr in_scopes (Var v) = pprIdInUnfolding in_scopes v -ppr_uf_Expr in_scopes (Lit l) = ppr ppr_Unfolding l - -ppr_uf_Expr in_scopes (Con c as) - = ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP, - ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack, - ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack] -ppr_uf_Expr in_scopes (Prim op as) - = ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP, - ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack, - ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack] - -ppr_uf_Expr in_scopes (Lam binder body) - = ppCat [ppChar '\\', ppr_uf_Binder binder, - ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add1` binder) body] - -ppr_uf_Expr in_scopes (CoTyLam tyvar expr) - = ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->", - ppr_uf_Expr in_scopes body] - where - (tyvars, body) = collect_tyvars expr - - collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, e_after ) - where (tyvs, e_after) = collect_tyvars e - collect_tyvars other_e = ( [], other_e ) - -ppr_uf_Expr in_scopes expr@(App fun_expr atom) - = let - (fun, args) = collect_args expr [] - in - ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack, - ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack] - where - collect_args (App fun arg) args = collect_args fun (arg:args) - collect_args fun args = (fun, args) - -ppr_uf_Expr in_scopes (CoTyApp expr ty) - = ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr, - ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}'] - -ppr_uf_Expr in_scopes (Case scrutinee alts) - = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {", - pp_alts alts, ppChar '}'] - where - pp_alts (AlgAlts alts deflt) - = ppCat [ppPStr SLIT("_ALG_"), ppCat (map pp_alg alts), pp_deflt deflt] - pp_alts (PrimAlts alts deflt) - = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt] - - pp_alg (con, params, rhs) - = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP, - ppIntersperse ppSP (map ppr_uf_Binder params), - ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi] - - pp_prim (lit, rhs) - = ppBesides [ppr ppr_Unfolding lit, - ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi] - - pp_deflt NoDefault = ppPStr SLIT("_NO_DEFLT_") - pp_deflt (BindDefault binder rhs) - = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "), - ppr_uf_Expr (in_scopes `add1` binder) rhs] - -ppr_uf_Expr in_scopes (Let (NonRec binder rhs) body) - = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs, - ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body] - -ppr_uf_Expr in_scopes (Let (Rec pairs) body) - = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs), - ppStr "} in ", ppr_uf_Expr new_in_scopes body] - where - sep = ppBeside ppSemi ppSP - new_in_scopes = in_scopes `add_some` map fst pairs - - pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs] - -ppr_uf_Expr in_scopes (SCC cc body) - = ASSERT(not (noCostCentreAttached cc)) - ASSERT(not (currentOrSubsumedCosts cc)) - ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ", ppr_uf_Expr in_scopes body] - -ppr_uf_Expr in_scopes (Coerce _ _ _) = panic "ppr_uf_Expr:Coerce" +okToInline + :: FormSummary -- What the thing to be inlined is like + -> BinderInfo -- How the thing to be inlined occurs + -> Bool -- True => it's small enough to inline + -> Bool -- True => yes, inline it + +-- Always inline bottoms +okToInline BottomForm occ_info small_enough + = True -- Unless one of the type args is unboxed?? + -- This used to be checked for, but I can't + -- see why so I've left it out. + +-- A WHNF can be inlined if it occurs once, or is small +okToInline form occ_info small_enough + | is_whnf_form form + = small_enough || one_occ + where + one_occ = case occ_info of + OneOcc _ _ _ n_alts _ -> n_alts <= 1 + other -> False + + is_whnf_form VarForm = True + is_whnf_form ValueForm = True + is_whnf_form other = False + +-- A non-WHNF can be inlined if it doesn't occur inside a lambda, +-- and occurs exactly once or +-- occurs once in each branch of a case and is small +okToInline OtherForm (OneOcc _ dup_danger _ n_alts _) small_enough + = not (isDupDanger dup_danger) && (n_alts <= 1 || small_enough) + +okToInline form any_occ small_enough = False \end{code} -\begin{code} -ppr_uf_Binder :: Id -> Pretty -ppr_uf_Binder v - = ppBesides [ppLparen, pprIdInUnfolding (unitUniqSet v) v, ppPStr SLIT(" :: "), - ppr ppr_Unfolding (idType v), ppRparen] - -ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l -ppr_uf_Atom in_scopes (VarArg v) = pprIdInUnfolding in_scopes v -END OLD -} -\end{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index de0d323..f4cbb53 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -18,11 +18,7 @@ module CoreUtils ( , maybeErrorApp , nonErrorRHSs , squashableDictishCcExpr -{- - coreExprArity, - isWrapperFor, - --} ) where + ) where IMP_Ubiq() IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes @@ -30,14 +26,13 @@ IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes import CoreSyn import CostCentre ( isDictCC, CostCentre, noCostCentre ) -import Id ( idType, mkSysLocal, getIdArity, isBottomingId, +import Id ( idType, mkSysLocal, isBottomingId, toplevelishId, mkIdWithNewUniq, applyTypeEnvToId, dataConRepType, addOneToIdEnv, growIdEnvList, lookupIdEnv, isNullIdEnv, SYN_IE(IdEnv), GenId{-instances-} ) -import IdInfo ( arityMaybe ) import Literal ( literalType, isNoRepLit, Literal(..) ) import Maybes ( catMaybes, maybeToBool ) import PprCore @@ -46,7 +41,7 @@ import PprType ( GenType{-instances-} ) import Pretty ( ppAboves, ppStr ) import PrelVals ( augmentId, buildId ) import PrimOp ( primOpType, PrimOp(..) ) -import SrcLoc ( mkUnknownSrcLoc ) +import SrcLoc ( noSrcLoc ) import TyVar ( cloneTyVar, isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv) ) @@ -209,7 +204,7 @@ co_thing thing arg_exprs in getUnique `thenUs` \ uniq -> let - new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc + new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc in returnUs (VarArg new_var, Just (NonRec new_var other_expr)) \end{code} @@ -222,94 +217,6 @@ argToExpr (VarArg v) = Var v argToExpr (LitArg lit) = Lit lit \end{code} -\begin{code} -{-LATER: -coreExprArity - :: (Id -> Maybe (GenCoreExpr bndr Id)) - -> GenCoreExpr bndr Id - -> Int -coreExprArity f (Lam _ expr) = coreExprArity f expr + 1 -coreExprArity f (CoTyLam _ expr) = coreExprArity f expr -coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0 -coreExprArity f (CoTyApp expr _) = coreExprArity f expr -coreExprArity f (Var v) = max further info - where - further - = case f v of - Nothing -> 0 - Just expr -> coreExprArity f expr - info = case (arityMaybe (getIdArity v)) of - Nothing -> 0 - Just arity -> arity -coreExprArity f _ = 0 -\end{code} - -@isWrapperFor@: we want to see exactly: -\begin{verbatim} -/\ ... \ args -> case of ... -> case of ... -> wrkr -\end{verbatim} - -Probably a little too HACKY [WDP]. - -\begin{code} -isWrapperFor :: CoreExpr -> Id -> Bool - -expr `isWrapperFor` var - = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front - unravel_casing args body - --NO, THANKS: && not (null args) - } - where - var's_worker = getWorkerId (getIdStrictness var) - - is_elem = isIn "isWrapperFor" - - -------------- - unravel_casing case_ables (Case scrut alts) - = case (collectArgs scrut) of { (fun, _, _, vargs) -> - case fun of - Var scrut_var -> let - answer = - scrut_var /= var && all (doesn't_mention var) vargs - && scrut_var `is_elem` case_ables - && unravel_alts case_ables alts - in - answer - - _ -> False - } - - unravel_casing case_ables other_expr - = case (collectArgs other_expr) of { (fun, _, _, vargs) -> - case fun of - Var wrkr -> let - answer = - -- DOESN'T WORK: wrkr == var's_worker - wrkr /= var - && isWorkerId wrkr - && all (doesn't_mention var) vargs - && all (only_from case_ables) vargs - in - answer - - _ -> False - } - - -------------- - unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault) - = unravel_casing (params ++ case_ables) rhs - unravel_alts case_ables other = False - - ------------------------- - doesn't_mention var (ValArg (VarArg v)) = v /= var - doesn't_mention var other = True - - ------------------------- - only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables - only_from case_ables other = True --} -\end{code} - All the following functions operate on binders, perform a uniform transformation on them; ie. the function @(\ x -> (x,False))@ annotates all binders with False. diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index 979fd67..6a83c06 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -10,7 +10,7 @@ module FreeVars ( freeVars, -- cheap and cheerful variant... - addTopBindsFVs, + addTopBindsFVs, addExprFVs, freeVarsOf, freeTyVarsOf, SYN_IE(FVCoreExpr), SYN_IE(FVCoreBinding), @@ -30,7 +30,7 @@ import Id ( idType, getIdArity, isBottomingId, elementOfIdSet, minusIdSet, unionManyIdSets, SYN_IE(IdSet) ) -import IdInfo ( arityMaybe ) +import IdInfo ( ArityInfo(..) ) import PrimOp ( PrimOp(..) ) import Type ( tyVarsOfType ) import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet, @@ -144,9 +144,10 @@ fvExpr id_cands tyvar_cands (Var v) where leakiness | isBottomingId v = lEAK_FREE_BIG -- Hack - | otherwise = case arityMaybe (getIdArity v) of - Nothing -> lEAK_FREE_0 - Just arity -> LeakFree arity + | otherwise = case getIdArity v of + UnknownArity -> lEAK_FREE_0 + ArityAtLeast arity -> LeakFree arity + ArityExactly arity -> LeakFree arity fvExpr id_cands tyvar_cands (Lit k) = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k) diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 57945cb..6c5ea90 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -11,7 +11,7 @@ #include "HsVersions.h" module PprCore ( - pprCoreExpr, + pprCoreExpr, pprIfaceUnfolding, pprCoreBinding, pprBigCoreBinder, pprTypedCoreBinder @@ -32,10 +32,10 @@ import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, ) import IdInfo ( ppIdInfo, StrictnessInfo(..) ) import Literal ( Literal{-instances-} ) -import Name ( isSymLexeme ) +import Name ( OccName, parenInCode ) import Outputable -- quite a few things import PprEnv -import PprType ( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} ) +import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} ) import PprStyle ( PprStyle(..) ) import Pretty import PrimOp ( PrimOp{-instances-} ) @@ -68,7 +68,7 @@ print something. pprCoreBinding :: PprStyle -> CoreBinding -> Pretty pprGenCoreBinding - :: (Eq tyvar, Outputable tyvar, + :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable bndr, Outputable occ) @@ -80,15 +80,16 @@ pprGenCoreBinding -> Pretty pprGenCoreBinding sty pbdr1 pbdr2 pocc bind - = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind + = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind -init_ppr_env sty pbdr1 pbdr2 pocc +init_ppr_env sty tvbndr pbdr1 pbdr2 pocc = initPprEnv sty (Just (ppr sty)) -- literals (Just (ppr sty)) -- data cons (Just (ppr sty)) -- primops (Just (\ cc -> ppStr (showCostCentre sty True cc))) - (Just (ppr sty)) -- tyvars + (Just tvbndr) -- tyvar binders + (Just (ppr sty)) -- tyvar occs (Just (ppr sty)) -- usage vars (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars (Just (pprParendGenType sty)) -- types @@ -120,7 +121,8 @@ pprCoreExpr pprCoreExpr = pprGenCoreExpr pprGenCoreExpr, pprParendCoreExpr - :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, + :: (Eq tyvar, Outputable tyvar, + Eq uvar, Outputable uvar, Outputable bndr, Outputable occ) => PprStyle @@ -131,7 +133,7 @@ pprGenCoreExpr, pprParendCoreExpr -> Pretty pprGenCoreExpr sty pbdr1 pbdr2 pocc expr - = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr + = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr pprParendCoreExpr sty pbdr1 pbdr2 pocc expr = let @@ -143,14 +145,23 @@ pprParendCoreExpr sty pbdr1 pbdr2 pocc expr in parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr) +-- Printer for unfoldings in interfaces +pprIfaceUnfolding :: CoreExpr -> Pretty +pprIfaceUnfolding = ppr_expr env + where + env = init_ppr_env PprInterface (pprTyVarBndr PprInterface) + (pprTypedCoreBinder PprInterface) + (pprTypedCoreBinder PprInterface) + (ppr PprInterface) + ppr_core_arg sty pocc arg - = ppr_arg (init_ppr_env sty pocc pocc pocc) arg + = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg ppr_core_alts sty pbdr1 pbdr2 pocc alts - = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts + = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts ppr_core_default sty pbdr1 pbdr2 pocc deflt - = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt + = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt \end{code} %************************************************************************ @@ -207,13 +218,11 @@ ppr_bind pe (NonRec val_bdr expr) 4 (ppr_expr pe expr) ppr_bind pe (Rec binds) - = ppAboves [ ppStr "{- Rec -}", - ppAboves (map ppr_pair binds), - ppStr "{- end Rec -}" ] + = ppAboves (map ppr_pair binds) where ppr_pair (val_bdr, expr) = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) - 4 (ppr_expr pe expr) + 4 (ppr_expr pe expr `ppBeside` ppSemi) \end{code} \begin{code} @@ -245,9 +254,9 @@ ppr_expr pe expr@(Lam _ _) = let (uvars, tyvars, vars, body) = collectBinders expr in - ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar pe) uvars, - pp_vars SLIT("_/\\_") (pTyVar pe) tyvars, - pp_vars SLIT("\\") (pMinBndr pe) vars]) + ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars, + pp_vars SLIT("/\\") (pTyVarB pe) tyvars, + pp_vars SLIT("\\") (pMinBndr pe) vars]) 4 (ppr_expr pe body) where pp_vars lam pp [] = ppNil @@ -283,12 +292,12 @@ ppr_expr pe (Case expr alts) 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 "}")] + [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_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 {"], + [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {"], ppNest 2 (ppr_alts pe alts), ppStr "}"] @@ -312,19 +321,22 @@ ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) -- general case (recursive case, too) ppr_expr pe (Let bind expr) - = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind), + = ppSep [ppHang (ppStr keyword) 2 (ppr_bind pe bind), ppHang (ppStr "} in ") 2 (ppr_expr pe expr)] + where + keyword = case bind of + Rec _ -> "letrec {" + NonRec _ _ -> "let {" ppr_expr pe (SCC cc expr) = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc], ppr_parend_expr pe expr ] ppr_expr pe (Coerce c ty expr) - = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c], - pTy pe ty, ppr_parend_expr pe expr ] + = ppSep [pp_coerce c, pTy pe ty, ppr_parend_expr pe expr ] where - pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v) + pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_") (ppr (pStyle pe) v) + pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_") (ppr (pStyle pe) v) only_one_alt (AlgAlts [] (BindDefault _ _)) = True only_one_alt (AlgAlts (_:[]) NoDefault) = True @@ -332,8 +344,7 @@ 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 +ppr_alt_con con pp_con = if parenInCode (getOccName con) then ppParens pp_con else pp_con \end{code} \begin{code} @@ -349,14 +360,14 @@ ppr_alts pe (AlgAlts alts deflt) ppInterleave ppSP (map (pMinBndr pe) params), ppStr "->"] ) - 4 (ppr_expr pe expr) + 4 (ppr_expr pe expr `ppBeside` ppSemi) ppr_alts pe (PrimAlts alts deflt) = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] where ppr_alt (lit, expr) = ppHang (ppCat [pLit pe lit, ppStr "->"]) - 4 (ppr_expr pe expr) + 4 (ppr_expr pe expr `ppBeside` ppSemi) \end{code} \begin{code} @@ -364,7 +375,7 @@ ppr_default pe NoDefault = ppNil ppr_default pe (BindDefault val_bdr expr) = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"]) - 4 (ppr_expr pe expr) + 4 (ppr_expr pe expr `ppBeside` ppSemi) \end{code} \begin{code} @@ -387,8 +398,7 @@ pprBigCoreBinder sty binder pragmas = ifnotPprForUser sty - (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv - (getIdInfo binder)) + (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder)) pprBabyCoreBinder sty binder = ppCat [ppr sty binder, pp_strictness] @@ -402,7 +412,5 @@ pprBabyCoreBinder sty binder -- ppStr ("{- " ++ (showList xx "") ++ " -}") pprTypedCoreBinder sty binder - = ppBesides [ppLparen, ppCat [ppr sty binder, - ppStr "::", ppr sty (idType binder)], - ppRparen] + = ppBesides [ppr sty binder, ppStr "::", pprParendGenType sty (idType binder)] \end{code} diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 0331a37..657e265 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -452,6 +452,10 @@ dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 bin %============================================== \begin{code} +dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr) + = doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> + returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)] + dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr) = dsExpr expr `thenDs` \ core_expr -> doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index c8644dc..e8f20fa 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -16,17 +16,19 @@ import DsMonad import DsUtils import CoreUtils ( coreExprType ) -import Id ( dataConArgTys, mkTupleCon ) +import Id ( dataConArgTys ) import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instances-} ) import Pretty import PrelVals ( packStringForCId ) import PrimOp ( PrimOp(..) ) -import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy, maybeBoxedPrimType ) -import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy ) +import Type ( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon, + eqTy, maybeBoxedPrimType ) +import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( getStatePairingConInfo, - realWorldStateTy, stateDataCon, + realWorldStateTy, stateDataCon, pairDataCon, unitDataCon, stringTy ) import Util ( pprPanic, pprError, panic ) @@ -121,15 +123,13 @@ unboxArg arg -- oops: we can't see the data constructors!!! = can't_see_datacons_error "argument" arg_ty - -- Byte-arrays, both mutable and otherwise - -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10] + -- Byte-arrays, both mutable and otherwise; hack warning | is_data_type && length data_con_arg_tys == 2 && - not (isPrimType data_con_arg_ty1) && - isPrimType data_con_arg_ty2 + maybeToBool maybe_arg2_tycon && + (arg2_tycon == byteArrayPrimTyCon || + arg2_tycon == mutableByteArrayPrimTyCon) -- and, of course, it is an instance of CCallable --- ( tycon == byteArrayTyCon || --- tycon == mutableByteArrayTyCon ) = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] -> returnDs (Var arr_cts_var, \ body -> Case arg (AlgAlts [(the_data_con,vars,body)] @@ -160,6 +160,9 @@ unboxArg arg data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys + maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2 + Just (arg2_tycon,_) = maybe_arg2_tycon + can't_see_datacons_error thing ty = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ " (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty]) @@ -167,9 +170,6 @@ can't_see_datacons_error thing ty \begin{code} -tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh) -covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto - boxResult :: Type -- Type of desired result -> DsM (Type, -- Type of the result of the ccall itself CoreExpr -> CoreExpr) -- Wrapper for the ccall @@ -191,7 +191,7 @@ boxResult result_ty mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)] `thenDs` \ new_state -> mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result -> - mkConDs tuple_con_2 + mkConDs pairDataCon [TyArg result_ty, TyArg realWorldStateTy, VarArg the_result, VarArg new_state] `thenDs` \ the_pair -> let @@ -210,8 +210,8 @@ boxResult result_ty mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)] `thenDs` \ new_state -> - mkConDs tuple_con_2 - [TyArg result_ty, TyArg realWorldStateTy, VarArg covar_tuple_con_0, VarArg new_state] + mkConDs pairDataCon + [TyArg result_ty, TyArg realWorldStateTy, VarArg (Var unitDataCon), VarArg new_state] `thenDs` \ the_pair -> let diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index cf1cf58..169fd50 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,7 +13,7 @@ IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr import HsSyn ( failureFreePat, HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), - Stmt(..), Match(..), Qualifier, HsBinds, PolyType, + Stmt(..), Match(..), Qualifier, HsBinds, HsType, GRHSsAndBinds ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), @@ -32,17 +32,15 @@ import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, ) import Match ( matchWrapper ) -import CoreUnfold ( Unfolding ) import CoreUtils ( coreExprType, substCoreExpr, argToExpr, mkCoreIfThenElse, unTagBinders ) import CostCentre ( mkUserCC ) import FieldLabel ( fieldLabelType, FieldLabel ) -import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv, - getIdUnfolding, dataConArgTys, dataConFieldLabels, +import Id ( idType, nullIdEnv, addOneToIdEnv, + dataConArgTys, dataConFieldLabels, recordSelectorFieldLabel ) import Literal ( mkMachInt, Literal(..) ) -import MagicUFs ( MagicUnfoldingFun ) import Name ( Name{--O only-} ) import PprStyle ( PprStyle(..) ) import PprType ( GenType ) @@ -54,7 +52,7 @@ import Type ( splitSigmaTy, splitFunTy, typePrimRep, maybeBoxedPrimType ) import TysPrim ( voidTy ) -import TysWiredIn ( mkTupleTy, nilDataCon, consDataCon, +import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, charDataCon, charTy ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) @@ -309,7 +307,7 @@ dsExpr (ExplicitListOut ty xs) dsExpr (ExplicitTuple expr_list) = mapDs dsExpr expr_list `thenDs` \ core_exprs -> - mkConDs (mkTupleCon (length expr_list)) + mkConDs (tupleCon (length expr_list)) (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs) -- Two cases, one for ordinary constructors and one for newtype constructors @@ -505,7 +503,7 @@ dsExpr (Dictionary dicts methods) 1 -> returnDs (head core_d_and_ms) -- just a single Id _ -> -- tuple 'em up - mkConDs (mkTupleCon num_of_d_and_ms) + mkConDs (tupleCon num_of_d_and_ms) (map (TyArg . coreExprType) core_d_and_ms ++ map VarArg core_d_and_ms) ) where @@ -533,8 +531,8 @@ dsExpr (ClassDictLam dicts methods expr) where num_of_d_and_ms = length dicts + length methods dicts_and_methods = dicts ++ methods - tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods) - tuple_con = mkTupleCon num_of_d_and_ms + tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods) + tuple_con = tupleCon num_of_d_and_ms #ifdef DEBUG -- HsSyn constructs that just shouldn't be here: diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 08288bd..d7e54ef 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -62,6 +62,7 @@ collectTypedMonoBinders EmptyMonoBinds = [] collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat collectTypedMonoBinders (FunMonoBind f _ _ _) = [f] collectTypedMonoBinders (VarMonoBind v _) = [v] +collectTypedMonoBinders (CoreMonoBind v _) = [v] collectTypedMonoBinders (AndMonoBinds bs1 bs2) = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2 diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 8be75c1..6f51268 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -129,8 +129,11 @@ deListComp expr (FilterQual filt : quals) list -- rule B above deListComp expr quals list `thenDs` \ core_rest -> returnDs ( mkCoreIfThenElse core_filt core_rest list ) +-- [e | let B, qs] = let B in [e | qs] deListComp expr (LetQual binds : quals) list - = panic "deListComp:LetQual" + = dsBinds False binds `thenDs` \ core_binds -> + deListComp expr quals list `thenDs` \ core_rest -> + returnDs (mkCoLetsAny core_binds core_rest) deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above = dsExpr list1 `thenDs` \ core_list1 -> diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 3ea0bc2..bf3f5f0 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -37,7 +37,7 @@ import Id ( mkSysLocal, mkIdWithNewUniq, import PprType ( GenType, GenTyVar ) import PprStyle ( PprStyle(..) ) import Pretty -import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc ) +import SrcLoc ( noSrcLoc, SrcLoc ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} ) import Unique ( Unique{-instances-} ) @@ -75,7 +75,7 @@ initDs :: UniqSupply -> (a, DsWarnings) initDs init_us env mod_name action - = action init_us mkUnknownSrcLoc module_and_group env emptyBag + = action init_us noSrcLoc module_and_group env emptyBag where module_and_group = (mod_name, grp_name) grp_name = case opt_SccGroup of @@ -173,10 +173,9 @@ uniqSMtoDsM :: UniqSM a -> DsM a uniqSMtoDsM u_action us loc mod_and_grp env warns = (u_action us, warns) -getSrcLocDs :: DsM (String, String) +getSrcLocDs :: DsM SrcLoc getSrcLocDs us loc mod_and_grp env warns - = case (unpackSrcLoc loc) of { (x,y) -> - ((_UNPK_ x, _UNPK_ y), warns) } + = (loc, warns) putSrcLocDs :: SrcLoc -> DsM a -> DsM a putSrcLocDs new_loc expr us old_loc mod_and_grp env warns diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 66472b7..3b767bb 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -31,7 +31,7 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), - Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo ) + Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -41,19 +41,21 @@ import DsMonad import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PprStyle ( PprStyle(..) ) import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId ) -import Pretty ( ppShow ) -import Id ( idType, dataConArgTys, mkTupleCon, +import Pretty ( ppShow, ppBesides, ppStr ) +import Id ( idType, dataConArgTys, -- pprId{-ToDo:rm-}, SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) import Literal ( Literal(..) ) -import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons ) +import TyCon ( isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, mkTheta, isUnboxedType, applyTyCon, getAppTyCon ) import TysPrim ( voidTy ) +import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) import Usage ( SYN_IE(UVar) ) +import SrcLoc ( SrcLoc {- instance Outputable -} ) --import PprCore{-ToDo:rm-} --import PprType--ToDo:rm --import Pretty--ToDo:rm @@ -312,9 +314,9 @@ mkErrorAppDs :: Id -- The error function -> DsM CoreExpr mkErrorAppDs err_id ty msg - = getSrcLocDs `thenDs` \ (file, line) -> + = getSrcLocDs `thenDs` \ src_loc -> let - full_msg = file ++ "|" ++ line ++ "|" ++msg + full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr ": ", ppStr msg]) msg_lit = NoRepStr (_PK_ full_msg) in returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit]) @@ -449,7 +451,7 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr tuple_var_ty = mkForAllTys tyvars $ mkRhoTy theta $ - applyTyCon (mkTupleTyCon no_of_binders) + applyTyCon (tupleTyCon no_of_binders) (map idType locals) where theta = mkTheta (map idType dicts) @@ -477,9 +479,9 @@ has only one element, it is the identity function. \begin{code} mkTupleExpr :: [Id] -> CoreExpr -mkTupleExpr [] = Con (mkTupleCon 0) [] +mkTupleExpr [] = Con unitDataCon [] mkTupleExpr [id] = Var id -mkTupleExpr ids = mkCon (mkTupleCon (length ids)) +mkTupleExpr ids = mkCon (tupleCon (length ids)) [{-usages-}] (map idType ids) [ VarArg i | i <- ids ] @@ -508,7 +510,7 @@ mkTupleSelector expr [var] should_be_the_same_var expr mkTupleSelector expr vars the_var - = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)] + = Case expr (AlgAlts [(tupleCon arity, vars, Var the_var)] NoDefault) where arity = length vars diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 72a4b85..c822765 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -26,7 +26,7 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import FieldLabel ( FieldLabel {- Eq instance -} ) -import Id ( idType, mkTupleCon, dataConFieldLabels, +import Id ( idType, dataConFieldLabels, dataConArgTys, recordSelectorFieldLabel, GenId{-instance-} ) @@ -43,7 +43,7 @@ import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, ) import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, charTy, charDataCon, intTy, intDataCon, - floatTy, floatDataCon, doubleTy, + floatTy, floatDataCon, doubleTy, tupleCon, doubleDataCon, stringTy, addrTy, addrDataCon, wordTy, wordDataCon ) @@ -363,7 +363,7 @@ tidy1 v (TuplePat pats) match_result where arity = length pats tuple_ConPat - = ConPat (mkTupleCon arity) + = ConPat (tupleCon arity) (mkTupleTy arity (map outPatType pats)) pats diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 26206ff..53ef74d 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -12,7 +12,7 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), - Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo ) + Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedPat) ) diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs index fa1fbcf..f3818df 100644 --- a/ghc/compiler/deforest/Cyclic.lhs +++ b/ghc/compiler/deforest/Cyclic.lhs @@ -17,7 +17,7 @@ > TyVarTemplate > ) > import Digraph ( dfs ) -> import Id ( idType, toplevelishId, updateIdType, +> import Id ( idType, updateIdType, > getIdInfo, replaceIdInfo, eqId, Id > ) > import IdInfo @@ -145,7 +145,7 @@ type of the expression itself. > newDefId type_of_f `thenUs` \f' -> > let > f = replaceIdInfo f' -> (addInfo (getIdInfo f') DoDeforest) +> (addDeforestInfo (getIdInfo f') DoDeforest) > in > loop ((f,e,val_args,ty_args):ls) e1 > `thenUs` \res@(ls',bs,bls,e') -> diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs index 0c99fc4..d5cd03c 100644 --- a/ghc/compiler/deforest/DefExpr.lhs +++ b/ghc/compiler/deforest/DefExpr.lhs @@ -22,7 +22,7 @@ > import CmdLineOpts ( SwitchResult, switchIsOn ) > import CoreUnfold ( Unfolding(..) ) > import CoreUtils ( mkValLam, unTagBinders, coreExprType ) -> import Id ( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id, +> import Id ( applyTypeEnvToId, getIdUnfolding, Id, > isInstId_maybe > ) > import Inst -- Inst(..) diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs index 24570b9..62ab803 100644 --- a/ghc/compiler/deforest/DefUtils.lhs +++ b/ghc/compiler/deforest/DefUtils.lhs @@ -32,7 +32,7 @@ > import Pretty > import PrimOp ( PrimOp ) -- for Eq PrimOp > import UniqSupply -> import SrcLoc ( mkUnknownSrcLoc ) +> import SrcLoc ( noSrcLoc ) > import Util ----------------------------------------------------------------------------- @@ -492,19 +492,19 @@ Grab a new Id and tag it as coming from the Deforester. > newDefId :: Type -> UniqSM Id > newDefId t = > getUnique `thenUs` \u -> -> returnUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc) +> returnUs (mkSysLocal SLIT("def") u t noSrcLoc) > newTmpId :: Type -> UniqSM Id > newTmpId t = > getUnique `thenUs` \u -> -> returnUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc) +> returnUs (mkSysLocal SLIT("tmp") u t noSrcLoc) ----------------------------------------------------------------------------- Check whether an Id was given a `DEFOREST' annotation by the programmer. > deforestable :: Id -> Bool > deforestable id = -> case getInfo (getIdInfo id) of +> case getDeforestInfo (getIdInfo id) of > DoDeforest -> True > Don'tDeforest -> False diff --git a/ghc/compiler/deforest/TreelessForm.lhs b/ghc/compiler/deforest/TreelessForm.lhs index c690fe2..bb01baa 100644 --- a/ghc/compiler/deforest/TreelessForm.lhs +++ b/ghc/compiler/deforest/TreelessForm.lhs @@ -136,7 +136,7 @@ dictionary deconstruction. > (vs,es) = unzip bs > vs' = map mkDeforestable vs > s = zip vs (map (Var . DefArgVar) vs') -> mkDeforestable v = replaceIdInfo v (addInfo (getIdInfo v) DoDeforest) +> mkDeforestable v = replaceIdInfo v (addDeforestInfo (getIdInfo v) DoDeforest) > convAtom :: DefAtom -> UniqSM DefAtom > diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index fce12aa..2c2a687 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -18,17 +18,22 @@ import HsMatches ( pprMatches, pprGRHSsAndBinds, Match, GRHSsAndBinds ) import HsPat ( collectPatBinders, InPat ) import HsPragmas ( GenPragmas, ClassOpPragmas ) -import HsTypes ( PolyType ) +import HsTypes ( HsType ) +import CoreSyn ( SYN_IE(CoreExpr) ) --others: import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId ) -import Name ( pprNonSym ) +import Name ( pprNonSym, getOccName, OccName ) import Outputable ( interpp'SP, ifnotPprForUser, Outputable(..){-instance * (,)-} ) +import PprCore ( GenCoreExpr {- instance Outputable -} ) +import PprType ( GenTyVar {- instance Outputable -} ) import Pretty +import Bag import SrcLoc ( SrcLoc{-instances-} ) ---import TyVar ( GenTyVar{-instances-} ) +import TyVar ( GenTyVar{-instances-} ) +import Unique ( Unique {- instance Eq -} ) \end{code} %************************************************************************ @@ -56,7 +61,7 @@ data HsBinds tyvar uvar id pat -- binders and bindees | BindWith -- Bind with a type signature. -- These appear only on typechecker input - -- (PolyType [in Sigs] can't appear on output) + -- (HsType [in Sigs] can't appear on output) (Bind tyvar uvar id pat) [Sig id] @@ -121,24 +126,22 @@ serves for both. \begin{code} data Sig name = Sig name -- a bog-std type signature - (PolyType name) - (GenPragmas name) -- only interface ones have pragmas + (HsType name) SrcLoc | ClassOpSig name -- class-op sigs have different pragmas - (PolyType name) + (HsType name) (ClassOpPragmas name) -- only interface ones have pragmas SrcLoc | SpecSig name -- specialise a function or datatype ... - (PolyType name) -- ... to these types + (HsType name) -- ... to these types (Maybe name) -- ... maybe using this as the code for it SrcLoc | InlineSig name -- INLINE f SrcLoc - -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER | DeforestSig name -- Deforest using this function definition SrcLoc @@ -150,13 +153,12 @@ data Sig name \begin{code} instance (NamedThing name, Outputable name) => Outputable (Sig name) where - ppr sty (Sig var ty pragmas _) + ppr sty (Sig var ty _) = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")]) - 4 (ppHang (ppr sty ty) - 4 (ifnotPprForUser sty (ppr sty pragmas))) + 4 (ppr sty ty) ppr sty (ClassOpSig var ty pragmas _) - = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")]) + = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")]) 4 (ppHang (ppr sty ty) 4 (ifnotPprForUser sty (ppr sty pragmas))) @@ -240,8 +242,12 @@ data MonoBinds tyvar uvar id pat Bool -- True => infix declaration [Match tyvar uvar id pat] -- must have at least one Match SrcLoc + | VarMonoBind id -- TRANSLATION (HsExpr tyvar uvar id pat) + + | CoreMonoBind id -- TRANSLATION + CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types! \end{code} \begin{code} @@ -269,6 +275,9 @@ instance (NamedThing id, Outputable id, Outputable pat, ppr sty (VarMonoBind name expr) = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr) + + ppr sty (CoreMonoBind name expr) + = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr) \end{code} %************************************************************************ @@ -289,45 +298,24 @@ where it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} -collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name] -collectTopLevelBinders EmptyBinds = [] -collectTopLevelBinders (SingleBind b) = collectBinders b -collectTopLevelBinders (BindWith b _) = collectBinders b -collectTopLevelBinders (ThenBinds b1 b2) - = collectTopLevelBinders b1 ++ collectTopLevelBinders b2 - -collectBinders :: Bind tyvar uvar name (InPat name) -> [name] -collectBinders EmptyBind = [] +collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) +collectTopBinders EmptyBinds = emptyBag +collectTopBinders (SingleBind b) = collectBinders b +collectTopBinders (BindWith b _) = collectBinders b +collectTopBinders (ThenBinds b1 b2) + = collectTopBinders b1 `unionBags` collectTopBinders b2 + +collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc) +collectBinders EmptyBind = emptyBag collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds collectBinders (RecBind monobinds) = collectMonoBinders monobinds -collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name] -collectMonoBinders EmptyMonoBinds = [] -collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat -collectMonoBinders (FunMonoBind f _ matches _) = [f] -collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders" +collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) +collectMonoBinders EmptyMonoBinds = emptyBag +collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat)) +collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc) +collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders" +collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders" collectMonoBinders (AndMonoBinds bs1 bs2) - = collectMonoBinders bs1 ++ collectMonoBinders bs2 - --- We'd like the binders -- and where they came from -- --- so we can make new ones with equally-useful origin info. - -collectMonoBindersAndLocs - :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)] - -collectMonoBindersAndLocs EmptyMonoBinds = [] - -collectMonoBindersAndLocs (AndMonoBinds bs1 bs2) - = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2 - -collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn) - = collectPatBinders pat `zip` repeat locn - -collectMonoBindersAndLocs (FunMonoBind f _ matches locn) = [(f, locn)] - -#ifdef DEBUG -collectMonoBindersAndLocs (VarMonoBind v expr) - = trace "collectMonoBindersAndLocs:VarMonoBind" [] - -- ToDo: this is dubious, i.e., wrong, but harmless? -#endif + = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2 \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index f59bb89..0154c84 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -8,23 +8,24 @@ %************************************************************************ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and -@TyVars@ as well. Currently trying the former. +@TyVars@ as well. Currently trying the former... MEGA SIGH. \begin{code} #include "HsVersions.h" module HsCore ( - UnfoldingCoreExpr(..), UnfoldingCoreAlts(..), - UnfoldingCoreDefault(..), UnfoldingCoreBinding(..), - UnfoldingCoreAtom(..), UfId(..), SYN_IE(UnfoldingType), - UnfoldingPrimOp(..), UfCostCentre(..) + UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..), + UfDefault(..), UfBinding(..), + UfArg(..), UfPrimOp(..) ) where IMP_Ubiq() -- friends: -import HsTypes ( MonoType, PolyType ) +import HsTypes ( HsType, pprParendHsType ) import PrimOp ( PrimOp, tagOf_PrimOp ) +import Kind ( Kind {- instance Outputable -} ) +import Type ( GenType {- instance Outputable -} ) -- others: import Literal ( Literal ) @@ -40,89 +41,56 @@ import Util ( panic ) %************************************************************************ \begin{code} -data UnfoldingCoreExpr name - = UfVar (UfId name) +data UfExpr name + = UfVar name | UfLit Literal - | UfCon name -- must be a "BoringUfId"... - [UnfoldingType name] - [UnfoldingCoreAtom name] - | UfPrim (UnfoldingPrimOp name) - [UnfoldingType name] - [UnfoldingCoreAtom name] - | UfLam (UfBinder name) - (UnfoldingCoreExpr name) - | UfApp (UnfoldingCoreExpr name) - (UnfoldingCoreAtom name) - | UfCase (UnfoldingCoreExpr name) - (UnfoldingCoreAlts name) - | UfLet (UnfoldingCoreBinding name) - (UnfoldingCoreExpr name) - | UfSCC (UfCostCentre name) - (UnfoldingCoreExpr name) - -data UnfoldingPrimOp name + | UfCon name [UfArg name] + | UfPrim (UfPrimOp name) [UfArg name] + | UfLam (UfBinder name) (UfExpr name) + | UfApp (UfExpr name) (UfArg name) + | UfCase (UfExpr name) (UfAlts name) + | UfLet (UfBinding name) (UfExpr name) + | UfSCC CostCentre (UfExpr name) + | UfCoerce (UfCoercion name) (HsType name) (UfExpr name) + +data UfPrimOp name = UfCCallOp FAST_STRING -- callee Bool -- True <=> casm, rather than ccall Bool -- True <=> might cause GC - [UnfoldingType name] -- arg types, incl state token + [HsType name] -- arg types, incl state token -- (which will be first) - (UnfoldingType name) -- return type - | UfOtherOp PrimOp - -data UnfoldingCoreAlts name - = UfCoAlgAlts [(name, [UfBinder name], UnfoldingCoreExpr name)] - (UnfoldingCoreDefault name) - | UfCoPrimAlts [(Literal, UnfoldingCoreExpr name)] - (UnfoldingCoreDefault name) - -data UnfoldingCoreDefault name - = UfCoNoDefault - | UfCoBindDefault (UfBinder name) - (UnfoldingCoreExpr name) - -data UnfoldingCoreBinding name - = UfCoNonRec (UfBinder name) - (UnfoldingCoreExpr name) - | UfCoRec [(UfBinder name, UnfoldingCoreExpr name)] - -data UnfoldingCoreAtom name - = UfCoVarAtom (UfId name) - | UfCoLitAtom Literal - -data UfCostCentre name - = UfPreludeDictsCC - Bool -- True <=> is dupd - | UfAllDictsCC FAST_STRING -- module and group - FAST_STRING - Bool -- True <=> is dupd - | UfUserCC FAST_STRING - FAST_STRING FAST_STRING -- module and group - Bool -- True <=> is dupd - Bool -- True <=> is CAF - | UfAutoCC (UfId name) - FAST_STRING FAST_STRING -- module and group - Bool Bool -- as above - | UfDictCC (UfId name) - FAST_STRING FAST_STRING -- module and group - Bool Bool -- as above - -type UfBinder name = (name, UnfoldingType name) - -data UfId name - = BoringUfId name - | SuperDictSelUfId name name -- class and superclass - | ClassOpUfId name name -- class and class op - | DictFunUfId name -- class and type - (UnfoldingType name) - | ConstMethodUfId name name -- class, class op, and type - (UnfoldingType name) - | DefaultMethodUfId name name -- class and class op - | SpecUfId (UfId name) -- its unspecialised "parent" - [Maybe (MonoType name)] - | WorkerUfId (UfId name) -- its non-working "parent" - -- more to come? - -type UnfoldingType name = PolyType name + (HsType name) -- return type + + | UfOtherOp name + +data UfCoercion name = UfIn name | UfOut name + +data UfAlts name + = UfAlgAlts [(name, [UfBinder name], UfExpr name)] + (UfDefault name) + | UfPrimAlts [(Literal, UfExpr name)] + (UfDefault name) + +data UfDefault name + = UfNoDefault + | UfBindDefault (UfBinder name) + (UfExpr name) + +data UfBinding name + = UfNonRec (UfBinder name) + (UfExpr name) + | UfRec [(UfBinder name, UfExpr name)] + +data UfBinder name + = UfValBinder name (HsType name) + | UfTyBinder name Kind + | UfUsageBinder name + +data UfArg name + = UfVarArg name + | UfLitArg Literal + | UfTyArg (HsType name) + | UfUsageArg name \end{code} %************************************************************************ @@ -132,39 +100,45 @@ type UnfoldingType name = PolyType name %************************************************************************ \begin{code} -instance Outputable name => Outputable (UnfoldingCoreExpr name) where - ppr sty (UfVar v) = pprUfId sty v +instance Outputable name => Outputable (UfExpr name) where + ppr sty (UfVar v) = ppr sty v ppr sty (UfLit l) = ppr sty l - ppr sty (UfCon c tys as) - = ppCat [ppStr "(UfCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"] - ppr sty (UfPrim o tys as) - = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"] + ppr sty (UfCon c as) + = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"] + ppr sty (UfPrim o as) + = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"] - ppr sty (UfLam bs body) - = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body] + ppr sty (UfLam b body) + = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body] - ppr sty (UfApp fun arg) - = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"] + ppr sty (UfApp fun (UfTyArg ty)) + = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty] + + ppr sty (UfApp fun (UfLitArg lit)) + = ppCat [ppr sty fun, ppr sty lit] + + ppr sty (UfApp fun (UfVarArg var)) + = ppCat [ppr sty fun, ppr sty var] ppr sty (UfCase scrut alts) = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"] where - pp_alts (UfCoAlgAlts alts deflt) + pp_alts (UfAlgAlts alts deflt) = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] where pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs] - pp_alts (UfCoPrimAlts alts deflt) + pp_alts (UfPrimAlts alts deflt) = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] where pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs] - pp_deflt UfCoNoDefault = ppNil - pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs] + pp_deflt UfNoDefault = ppNil + pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs] - ppr sty (UfLet (UfCoNonRec b rhs) body) + ppr sty (UfLet (UfNonRec b rhs) body) = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body] - ppr sty (UfLet (UfCoRec pairs) body) + ppr sty (UfLet (UfRec pairs) body) = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body] where pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs] @@ -172,41 +146,27 @@ instance Outputable name => Outputable (UnfoldingCoreExpr name) where ppr sty (UfSCC uf_cc body) = ppCat [ppStr "_scc_ ", ppr sty body] -instance Outputable name => Outputable (UnfoldingPrimOp name) where +instance Outputable name => Outputable (UfPrimOp name) where ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty) = let before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ") after = if is_casm then ppStr "'' " else ppSP in ppBesides [before, ppPStr str, after, - ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty] + ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty] + ppr sty (UfOtherOp op) = ppr sty op -instance Outputable name => Outputable (UnfoldingCoreAtom name) where - ppr sty (UfCoVarAtom v) = pprUfId sty v - ppr sty (UfCoLitAtom l) = ppr sty l - -pprUfId sty (BoringUfId v) = ppr sty v -pprUfId sty (SuperDictSelUfId c sc) - = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"] -pprUfId sty (ClassOpUfId c op) - = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"] -pprUfId sty (DictFunUfId c ty) - = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"] -pprUfId sty (ConstMethodUfId c op ty) - = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"] -pprUfId sty (DefaultMethodUfId c ty) - = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"] - -pprUfId sty (SpecUfId unspec ty_maybes) - = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec, - ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"] - where - pp_ty_maybe Nothing = ppStr "_N_" - pp_ty_maybe (Just t) = ppr sty t - -pprUfId sty (WorkerUfId unwrkr) - = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"] +instance Outputable name => Outputable (UfArg name) where + ppr sty (UfVarArg v) = ppr sty v + ppr sty (UfLitArg l) = ppr sty l + ppr sty (UfTyArg ty) = pprParendHsType sty ty + ppr sty (UfUsageArg name) = ppr sty name + +instance Outputable name => Outputable (UfBinder name) where + ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppStr "::", ppr sty ty] + ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind] + ppr sty (UfUsageBinder name) = ppr sty name \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 6341f66..1e1cc3e 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -14,22 +14,65 @@ module HsDecls where IMP_Ubiq() -- friends: -IMPORT_DELOOPER(HsLoop) ( nullMonoBinds, MonoBinds, Sig ) +import HsBinds ( HsBinds, MonoBinds, Sig, nullMonoBinds ) import HsPragmas ( DataPragmas, ClassPragmas, InstancePragmas, ClassOpPragmas ) import HsTypes +import IdInfo +import SpecEnv ( SpecEnv ) +import HsCore ( UfExpr ) -- others: -import Name ( pprSym, pprNonSym ) +import Name ( pprSym, pprNonSym, getOccName, OccName ) import Outputable ( interppSP, interpp'SP, Outputable(..){-instance * []-} ) import Pretty import SrcLoc ( SrcLoc ) ---import Util ( panic#{-ToDo:rm eventually-} ) +import PprStyle ( PprStyle(..) ) \end{code} + +%************************************************************************ +%* * +\subsection[HsDecl]{Declarations} +%* * +%************************************************************************ + +\begin{code} +data HsDecl tyvar uvar name pat + = TyD (TyDecl name) + | ClD (ClassDecl tyvar uvar name pat) + | InstD (InstDecl tyvar uvar name pat) + | DefD (DefaultDecl name) + | ValD (HsBinds tyvar uvar name pat) + | SigD (IfaceSig name) +\end{code} + +\begin{code} +hsDeclName (TyD (TyData _ name _ _ _ _ _)) = name +hsDeclName (TyD (TyNew _ name _ _ _ _ _)) = name +hsDeclName (TyD (TySynonym name _ _ _)) = name +hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name +hsDeclName (SigD (IfaceSig name _ _ _)) = name +-- Others don't make sense +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name, Outputable pat, + Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) + => Outputable (HsDecl tyvar uvar name pat) where + + ppr sty (TyD td) = ppr sty td + ppr sty (ClD cd) = ppr sty cd + ppr sty (SigD sig) = ppr sty sig + ppr sty (ValD binds) = ppr sty binds + ppr sty (DefD def) = ppr sty def + ppr sty (InstD inst) = ppr sty inst +\end{code} + + %************************************************************************ %* * \subsection[FixityDecl]{A fixity declaration} @@ -37,23 +80,33 @@ import SrcLoc ( SrcLoc ) %************************************************************************ \begin{code} -data FixityDecl name - = InfixL name Int - | InfixR name Int - | InfixN name Int +data FixityDecl name = FixityDecl name Fixity SrcLoc + +instance Outputable name => Outputable (FixityDecl name) where + ppr sty (FixityDecl name fixity loc) = ppSep [ppr sty fixity, ppr sty name] \end{code} +It's convenient to keep the source location in the @Fixity@; it makes error reporting +in the renamer easier. + \begin{code} -instance (NamedThing name, Outputable name) - => Outputable (FixityDecl name) where - ppr sty (InfixL var prec) = print_it sty "l" prec var - ppr sty (InfixR var prec) = print_it sty "r" prec var - ppr sty (InfixN var prec) = print_it sty "" prec var +data Fixity = Fixity Int FixityDirection +data FixityDirection = InfixL | InfixR | InfixN + deriving(Eq) -print_it sty suff prec var - = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprSym sty var] +instance Outputable Fixity where + ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec] + +instance Outputable FixityDirection where + ppr sty InfixL = ppStr "infixl" + ppr sty InfixR = ppStr "infixr" + ppr sty InfixN = ppStr "infix" + +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 \end{code} + %************************************************************************ %* * \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration} @@ -64,7 +117,7 @@ print_it sty suff prec var data TyDecl name = TyData (Context name) -- context name -- type constructor - [name] -- type variables + [HsTyVar name] -- type variables [ConDecl name] -- data constructors (empty if abstract) (Maybe [name]) -- derivings; Nothing => not specified -- (i.e., derive default); Just [] => derive @@ -75,15 +128,15 @@ data TyDecl name | TyNew (Context name) -- context name -- type constructor - [name] -- type variables - [ConDecl name] -- data constructor (empty if abstract) + [HsTyVar name] -- type variables + (ConDecl name) -- data constructor (Maybe [name]) -- derivings; as above (DataPragmas name) SrcLoc | TySynonym name -- type constructor - [name] -- type variables - (MonoType name) -- synonym expansion + [HsTyVar name] -- type variables + (HsType name) -- synonym expansion SrcLoc \end{code} @@ -94,35 +147,40 @@ instance (NamedThing name, Outputable name) ppr sty (TySynonym tycon tyvars mono_ty src_loc) = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars) - 4 (ppCat [ppEquals, ppr sty mono_ty]) + 4 (ppr sty mono_ty) ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc) = pp_tydecl sty - (pp_decl_head sty SLIT("data") (pprContext sty context) tycon tyvars) + (pp_decl_head sty SLIT("data") (pp_context_and_arrow sty context) tycon tyvars) (pp_condecls sty condecls) derivings ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc) = pp_tydecl sty - (pp_decl_head sty SLIT("newtype") (pprContext sty context) tycon tyvars) - (pp_condecls sty condecl) + (pp_decl_head sty SLIT("newtype") (pp_context_and_arrow sty context) tycon tyvars) + (ppr sty condecl) derivings pp_decl_head sty str pp_context tycon tyvars - = ppCat [ppPStr str, pp_context, ppr sty tycon, interppSP sty tyvars] + = ppCat [ppPStr str, pp_context, ppr sty (getOccName tycon), + interppSP sty tyvars, ppPStr SLIT("=")] -pp_condecls sty [] = ppNil -- abstract datatype +pp_condecls sty [] = ppNil -- Curious! pp_condecls sty (c:cs) - = ppSep (ppBeside (ppStr "= ") (ppr sty c) - : map (\ x -> ppBeside (ppStr "| ") (ppr sty x)) cs) + = ppSep (ppr sty c : map (\ c -> ppBeside (ppStr "| ") (ppr sty c)) cs) pp_tydecl sty pp_head pp_decl_rhs derivings = ppHang pp_head 4 (ppSep [ pp_decl_rhs, - case derivings of - Nothing -> ppNil - Just ds -> ppBeside (ppPStr SLIT("deriving ")) - (ppParens (ppInterleave ppComma (map (ppr sty) ds)))]) + case (derivings, sty) of + (Nothing,_) -> ppNil + (_,PprInterface) -> ppNil -- No derivings in interfaces + (Just ds,_) -> ppCat [ppPStr SLIT("deriving"), ppParens (interpp'SP sty ds)] + ]) + +pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Pretty +pp_context_and_arrow sty [] = ppNil +pp_context_and_arrow sty theta = ppCat [pprContext sty theta, ppPStr SLIT("=>")] \end{code} A type for recording what types a datatype should be specialised to. @@ -132,7 +190,7 @@ for an datatype declaration. \begin{code} data SpecDataSig name = SpecDataSig name -- tycon to specialise - (MonoType name) + (HsType name) SrcLoc instance (NamedThing name, Outputable name) @@ -164,31 +222,37 @@ data ConDecl name SrcLoc | NewConDecl name -- newtype con decl - (MonoType name) + (HsType name) SrcLoc data BangType name - = Banged (PolyType name) -- PolyType: to allow Haskell extensions - | Unbanged (PolyType name) -- (MonoType only needed for straight Haskell) + = Banged (HsType name) -- HsType: to allow Haskell extensions + | Unbanged (HsType name) -- (MonoType only needed for straight Haskell) \end{code} \begin{code} instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where ppr sty (ConDecl con tys _) - = ppCat [pprNonSym sty con, ppInterleave ppNil (map (ppr_bang sty) tys)] + = ppCat [ppr sty (getOccName con), ppInterleave ppNil (map (ppr_bang sty) tys)] + + -- We print ConOpDecls in prefix form in interface files + ppr PprInterface (ConOpDecl ty1 op ty2 _) + = ppCat [ppr PprInterface (getOccName op), ppr_bang PprInterface ty1, ppr_bang PprInterface ty2] ppr sty (ConOpDecl ty1 op ty2 _) - = ppCat [ppr_bang sty ty1, pprSym sty op, ppr_bang sty ty2] + = ppCat [ppr_bang sty ty1, ppr sty (getOccName op), ppr_bang sty ty2] + ppr sty (NewConDecl con ty _) - = ppCat [pprNonSym sty con, pprParendMonoType sty ty] + = ppCat [ppr sty (getOccName con), pprParendHsType sty ty] ppr sty (RecConDecl con fields _) - = ppCat [pprNonSym sty con, ppChar '{', - ppInterleave pp'SP (map pp_field fields), ppChar '}'] + = ppCat [ppr sty (getOccName con), + ppCurlies (ppInterleave pp'SP (map pp_field fields)) + ] where pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty] -ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty) -ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty +ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendHsType sty ty) +ppr_bang sty (Unbanged ty) = pprParendHsType sty ty \end{code} %************************************************************************ @@ -201,7 +265,7 @@ ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty data ClassDecl tyvar uvar name pat = ClassDecl (Context name) -- context... name -- name of the class - name -- the class type variable + (HsTyVar name) -- the class type variable [Sig name] -- methods' signatures (MonoBinds tyvar uvar name pat) -- default methods (ClassPragmas name) @@ -214,17 +278,23 @@ instance (NamedThing name, Outputable name, Outputable pat, => Outputable (ClassDecl tyvar uvar name pat) where ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc) - = let - top_matter = ppCat [ppStr "class", pprContext sty context, - ppr sty clas, ppr sty tyvar] - in - if null sigs && nullMonoBinds methods then - ppAbove top_matter (ppNest 4 (ppr sty pragmas)) - else - ppAboves [ppCat [top_matter, ppStr "where"], - ppNest 4 (ppAboves (map (ppr sty) sigs)), - ppNest 4 (ppr sty methods), - ppNest 4 (ppr sty pragmas) ] + | null sigs -- No "where" part + = top_matter + + | iface_style -- All on one line (for now at least) + = ppCat [top_matter, ppStr "where", + ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)] + + | otherwise -- Laid out + = ppSep [ppCat [top_matter, ppStr "where {"], + ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods) + `ppBeside` ppStr "}")] + where + top_matter = ppCat [ppStr "class", pp_context_and_arrow sty context, + ppr sty (getOccName clas), ppr sty tyvar] + pp_sigs = map (ppr sty) sigs + pp_methods = ppr sty methods + iface_style = case sty of {PprInterface -> True; other -> False} \end{code} %************************************************************************ @@ -235,23 +305,16 @@ instance (NamedThing name, Outputable name, Outputable pat, \begin{code} data InstDecl tyvar uvar name pat - = InstDecl name -- Class - - (PolyType name) -- Context => Instance-type + = InstDecl (HsType name) -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. (MonoBinds tyvar uvar name pat) - Bool -- True <=> This instance decl is from the - -- module being compiled; False <=> It is from - -- an imported interface. + [Sig name] -- User-supplied pragmatic info - Module -- The name of the module where the instance decl - -- originally came from + (Maybe name) -- Name for the dictionary function - [Sig name] -- actually user-supplied pragmatic info - (InstancePragmas name) -- interface-supplied pragmatic info SrcLoc \end{code} @@ -260,23 +323,15 @@ instance (NamedThing name, Outputable name, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (InstDecl tyvar uvar name pat) where - ppr sty (InstDecl clas ty binds from_here modname uprags pragmas src_loc) - = let - (context, inst_ty) - = case ty of - HsPreForAllTy c t -> (c, t) - HsForAllTy _ c t -> (c, t) - - top_matter = ppCat [ppStr "instance", pprContext sty context, - ppr sty clas, pprParendMonoType sty inst_ty] - in - if nullMonoBinds binds && null uprags then - ppAbove top_matter (ppNest 4 (ppr sty pragmas)) - else - ppAboves [ppCat [top_matter, ppStr "where"], - if null uprags then ppNil else ppNest 4 (ppr sty uprags), - ppNest 4 (ppr sty binds), - ppNest 4 (ppr sty pragmas) ] + ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc) + | case sty of { PprInterface -> True; other -> False} || + nullMonoBinds binds && null uprags + = ppCat [ppStr "instance", ppr sty inst_ty] + + | otherwise + = ppAboves [ppCat [ppStr "instance", ppr sty inst_ty, ppStr "where"], + ppNest 4 (ppr sty uprags), + ppNest 4 (ppr sty binds) ] \end{code} A type for recording what instances the user wants to specialise; @@ -285,7 +340,7 @@ instance. \begin{code} data SpecInstSig name = SpecInstSig name -- class - (MonoType name) -- type to specialise to + (HsType name) -- type to specialise to SrcLoc instance (NamedThing name, Outputable name) @@ -307,7 +362,7 @@ syntax, and that restriction must be checked in the front end. \begin{code} data DefaultDecl name - = DefaultDecl [MonoType name] + = DefaultDecl [HsType name] SrcLoc instance (NamedThing name, Outputable name) @@ -316,3 +371,32 @@ instance (NamedThing name, Outputable name) ppr sty (DefaultDecl tys src_loc) = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys)) \end{code} + +%************************************************************************ +%* * +\subsection{Signatures in interface files} +%* * +%************************************************************************ + +\begin{code} +data IfaceSig name + = IfaceSig name + (HsType name) + [HsIdInfo name] + SrcLoc + +instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where + ppr sty (IfaceSig var ty _ _) + = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")]) + 4 (ppr sty ty) + +data HsIdInfo name + = HsArity ArityInfo + | HsStrictness (StrictnessInfo name) + | HsUnfold (UfExpr name) + | HsUpdate UpdateInfo + | HsDeforest DeforestInfo + | HsArgUsage ArgUsageInfo + | HsFBType FBTypeInfo + -- ToDo: specialisations +\end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 56ad5d2..42fd926 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -15,7 +15,7 @@ IMPORT_DELOOPER(HsLoop) -- for paranoia checking import HsBinds ( HsBinds ) import HsLit ( HsLit ) import HsMatches ( pprMatches, pprMatch, Match ) -import HsTypes ( PolyType ) +import HsTypes ( HsType ) -- others: import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) ) @@ -119,7 +119,7 @@ data HsExpr tyvar uvar id pat | ExprWithTySig -- signature binding (HsExpr tyvar uvar id pat) - (PolyType id) + (HsType id) | ArithSeqIn -- arithmetic sequence (ArithSeqInfo tyvar uvar id pat) | ArithSeqOut @@ -401,8 +401,8 @@ pp_rbinds :: (NamedThing id, Outputable id, Outputable pat, -> HsRecordBinds tyvar uvar id pat -> Pretty pp_rbinds sty thing rbinds - = ppHang thing 4 - (ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}']) + = ppHang thing + 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds))) where pp_rbind PprForUser (v, _, True) = ppr PprForUser v pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e] diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 7bdf830..0305911 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -57,6 +57,7 @@ instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) wher \subsection{Imported and exported entities} %* * %************************************************************************ + \begin{code} data IE name = IEVar name @@ -67,6 +68,14 @@ data IE name \end{code} \begin{code} +ieName :: IE name -> name +ieName (IEVar n) = n +ieName (IEThingAbs n) = n +ieName (IEThingWith n _) = n +ieName (IEThingAll n) = n +\end{code} + +\begin{code} instance (NamedThing name, Outputable name) => Outputable (IE name) where ppr sty (IEVar var) = pprNonSym sty var ppr sty (IEThingAbs thing) = ppr sty thing @@ -78,3 +87,4 @@ instance (NamedThing name, Outputable name) => Outputable (IE name) where ppr sty (IEModuleContents mod) = ppBeside (ppPStr SLIT("module ")) (ppPStr mod) \end{code} + diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 5cb26fa..4f6e457 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -152,22 +152,21 @@ pprInPat sty (TuplePatIn pats) = ppParens (interpp'SP sty pats) pprInPat sty (RecPatIn con rpats) - = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}'] + = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))] where pp_rpat PprForUser (v, _, True) = ppr PprForUser v pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] \end{code} \begin{code} -instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, - NamedThing id, Outputable id) +instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id) => Outputable (OutPat tyvar uvar id) where ppr = pprOutPat \end{code} \begin{code} pprOutPat sty (WildPat ty) = ppChar '_' -pprOutPat sty (VarPat var) = pprNonSym sty var +pprOutPat sty (VarPat var) = ppr sty var pprOutPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat] pprOutPat sty (AsPat name pat) = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] @@ -190,7 +189,7 @@ pprOutPat sty (TuplePat pats) = ppParens (interpp'SP sty pats) pprOutPat sty (RecPat con ty rpats) - = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}'] + = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))] where pp_rpat PprForUser (v, _, True) = ppr PprForUser v pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index fcbc6d9..1337b4d 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -19,8 +19,7 @@ module HsPragmas where IMP_Ubiq() -- friends: -import HsCore ( UnfoldingCoreExpr ) -import HsTypes ( MonoType ) +import HsTypes ( HsType ) -- others: import IdInfo @@ -29,6 +28,48 @@ import Outputable ( Outputable(..) ) import Pretty \end{code} +All the pragma stuff has changed. Here are some placeholders! + +\begin{code} +data GenPragmas name = NoGenPragmas +data DataPragmas name = NoDataPragmas +data InstancePragmas name = NoInstancePragmas +data ClassOpPragmas name = NoClassOpPragmas +data ClassPragmas name = NoClassPragmas + +noClassPragmas = NoClassPragmas +isNoClassPragmas NoClassPragmas = True + +noDataPragmas = NoDataPragmas +isNoDataPragmas NoDataPragmas = True + +noGenPragmas = NoGenPragmas +isNoGenPragmas NoGenPragmas = True + +noInstancePragmas = NoInstancePragmas +isNoInstancePragmas NoInstancePragmas = True + +noClassOpPragmas = NoClassOpPragmas +isNoClassOpPragmas NoClassOpPragmas = True + +instance Outputable name => Outputable (ClassPragmas name) where + ppr sty NoClassPragmas = ppNil + +instance Outputable name => Outputable (ClassOpPragmas name) where + ppr sty NoClassOpPragmas = ppNil + +instance Outputable name => Outputable (InstancePragmas name) where + ppr sty NoInstancePragmas = ppNil + +instance Outputable name => Outputable (GenPragmas name) where + ppr sty NoGenPragmas = ppNil +\end{code} + +========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ============== + +\begin{code} +{- COMMENTED OUT + Certain pragmas expect to be pinned onto certain constructs. Pragma types may be parameterised, just as with any other @@ -38,12 +79,10 @@ For a @data@ declaration---indicates which specialisations exist. \begin{code} data DataPragmas name = NoDataPragmas - | DataPragmas [[Maybe (MonoType name)]] -- types to which specialised + | DataPragmas [[Maybe (HsType name)]] -- types to which specialised noDataPragmas = NoDataPragmas - isNoDataPragmas NoDataPragmas = True -isNoDataPragmas _ = False \end{code} These are {\em general} things you can know about any value: @@ -55,7 +94,7 @@ data GenPragmas name DeforestInfo -- deforest info (ImpStrictness name) -- strictness, worker-wrapper (ImpUnfolding name) -- unfolding (maybe) - [([Maybe (MonoType name)], -- Specialisations: types to which spec'd; + [([Maybe (HsType name)], -- Specialisations: types to which spec'd; Int, -- # dicts to ignore GenPragmas name)] -- Gen info about the spec'd version @@ -119,7 +158,7 @@ data InstancePragmas name | SpecialisedInstancePragma (GenPragmas name) -- for its "dfun" - [([Maybe (MonoType name)], -- specialised instance; type... + [([Maybe (HsType name)], -- specialised instance; type... Int, -- #dicts to ignore InstancePragmas name)] -- (no SpecialisedInstancePragma please!) @@ -175,7 +214,7 @@ instance Outputable name => Outputable (GenPragmas name) where pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i) pp_upd Nothing = ppNil - pp_upd (Just u) = ppInfo sty id u + pp_upd (Just u) = ppUpdateInfo sty u pp_str NoImpStrictness = ppNil pp_str (ImpStrictness is_bot demands wrkr_prags) @@ -197,3 +236,8 @@ instance Outputable name => Outputable (GenPragmas name) where pp_MaB Nothing = ppStr "_N_" pp_MaB (Just x) = ppr sty x \end{code} + + +\begin{code} +-} +\end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index e165b3c..9e57b8d 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -30,7 +30,13 @@ IMP_Ubiq() -- friends: import HsBinds -import HsDecls +import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..), + DefaultDecl(..), + FixityDecl(..), Fixity(..), FixityDirection(..), + ConDecl(..), BangType(..), + IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..), + hsDeclName + ) import HsExpr import HsImpExp import HsLit @@ -39,6 +45,8 @@ import HsPat import HsTypes import HsPragmas ( ClassPragmas, ClassOpPragmas, DataPragmas, GenPragmas, InstancePragmas ) +import HsCore + -- others: import FiniteMap ( FiniteMap ) import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) ) @@ -69,14 +77,7 @@ data HsModule tyvar uvar name pat -- info to TyDecls/etc; so this list is -- often empty, downstream. [FixityDecl name] - [TyDecl name] - [SpecDataSig name] -- user pragmas that modify TyDecls - [ClassDecl tyvar uvar name pat] - [InstDecl tyvar uvar name pat] - [SpecInstSig name] -- user pragmas that modify InstDecls - [DefaultDecl name] - (HsBinds tyvar uvar name pat) -- the main stuff, includes source sigs - [Sig name] -- interface sigs + [HsDecl tyvar uvar name pat] -- Type, class, value, and interface signature decls SrcLoc \end{code} @@ -86,8 +87,7 @@ instance (NamedThing name, Outputable name, Outputable pat, => Outputable (HsModule tyvar uvar name pat) where ppr sty (HsModule name iface_version exports imports fixities - typedecls typesigs classdecls instdecls instsigs - defdecls binds sigs src_loc) + decls src_loc) = ppAboves [ ifPprShowAll sty (ppr sty src_loc), ifnotPprForUser sty (pp_iface_version iface_version), @@ -100,14 +100,7 @@ instance (NamedThing name, Outputable name, Outputable pat, ], pp_nonnull imports, pp_nonnull fixities, - pp_nonnull typedecls, - pp_nonnull typesigs, - pp_nonnull classdecls, - pp_nonnull instdecls, - pp_nonnull instsigs, - pp_nonnull defdecls, - ppr sty binds, - pp_nonnull sigs + pp_nonnull decls ] where pp_nonnull [] = ppNil diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 239a627..e558d4d 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -11,33 +11,36 @@ you get part of GHC. #include "HsVersions.h" module HsTypes ( - PolyType(..), MonoType(..), + HsType(..), HsTyVar(..), SYN_IE(Context), SYN_IE(ClassAssertion) -#ifdef COMPILING_GHC - , pprParendPolyType - , pprParendMonoType, pprContext - , extractMonoTyNames, extractCtxtTyNames - , cmpPolyType, cmpMonoType, cmpContext -#endif + , mkHsForAllTy + , getTyVarName, replaceTyVarName + , pprParendHsType + , pprContext + , cmpHsType, cmpContext ) where -#ifdef COMPILING_GHC IMP_Ubiq() import Outputable ( interppSP, ifnotPprForUser ) +import Kind ( Kind {- instance Outputable -} ) import Pretty import Util ( thenCmp, cmpList, isIn, panic# ) - -#endif {- COMPILING_GHC -} \end{code} This is the syntax for types as seen in type signatures. \begin{code} -data PolyType name +type Context name = [ClassAssertion name] + +type ClassAssertion name = (name, HsType name) + -- The type is usually a type variable, but it + -- doesn't have to be when reading interface files + +data HsType name = HsPreForAllTy (Context name) - (MonoType name) + (HsType name) -- The renamer turns HsPreForAllTys into HsForAllTys when they -- occur in signatures, to make the binding of variables @@ -45,90 +48,99 @@ data PolyType name -- non-COMPILING_GHC code, because you probably want to do the -- same thing. - | HsForAllTy [name] + | HsForAllTy [HsTyVar name] (Context name) - (MonoType name) + (HsType name) -type Context name = [ClassAssertion name] - -type ClassAssertion name = (name, name) - -data MonoType name - = MonoTyVar name -- Type variable + | MonoTyVar name -- Type variable | MonoTyApp name -- Type constructor or variable - [MonoType name] + [HsType name] -- We *could* have a "MonoTyCon name" equiv to "MonoTyApp name []" -- (for efficiency, what?) WDP 96/02/18 - | MonoFunTy (MonoType name) -- function type - (MonoType name) + | MonoFunTy (HsType name) -- function type + (HsType name) - | MonoListTy (MonoType name) -- list type - | MonoTupleTy [MonoType name] -- tuple type (length gives arity) + | MonoListTy name -- The list TyCon name + (HsType name) -- Element type + + | MonoTupleTy name -- The tuple TyCon name + [HsType name] -- Element types (length gives arity) -#ifdef COMPILING_GHC -- these next two are only used in unfoldings in interfaces | MonoDictTy name -- Class - (MonoType name) + (HsType name) + +mkHsForAllTy [] [] ty = ty +mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty - | MonoForAllTy [(name, Kind)] - (MonoType name) +data HsTyVar name + = UserTyVar name + | IfaceTyVar name Kind -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. -#endif {- COMPILING_GHC -} +getTyVarName (UserTyVar n) = n +getTyVarName (IfaceTyVar n _) = n + +replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2 +replaceTyVarName (UserTyVar n) n' = UserTyVar n' +replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \end{code} -This is used in various places: + +%************************************************************************ +%* * +\subsection{Pretty printing} +%* * +%************************************************************************ + \begin{code} -#ifdef COMPILING_GHC -pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty -pprContext sty [] = ppNil -pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"] +instance (Outputable name) => Outputable (HsType name) where + ppr = pprHsType + +instance (Outputable name) => Outputable (HsTyVar name) where + ppr sty (UserTyVar name) = ppr sty name + ppr sty (IfaceTyVar name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind] + + +ppr_forall sty ctxt_prec [] [] ty + = ppr_mono_ty sty ctxt_prec ty +ppr_forall sty ctxt_prec tvs ctxt ty + = ppSep [ppStr "_forall_", ppBracket (interppSP sty tvs), + pprContext sty ctxt, ppStr "=>", + pprHsType sty ty] + +pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty +pprContext sty [] = ppNil pprContext sty context - = ppBesides [ppLparen, - ppInterleave ppComma (map pp_assert context), - ppRparen, ppStr " =>"] + = ppCat [ppCurlies (ppIntersperse pp'SP (map ppr_assert context))] where - pp_assert (clas, ty) - = ppCat [ppr sty clas, ppr sty ty] + ppr_assert (clas, ty) = ppCat [ppr sty clas, ppr sty ty] \end{code} \begin{code} -instance (Outputable name) => Outputable (PolyType name) where - ppr sty (HsPreForAllTy ctxt ty) - = print_it sty ppNil ctxt ty - ppr sty (HsForAllTy [] ctxt ty) - = print_it sty ppNil ctxt ty - ppr sty (HsForAllTy tvs ctxt ty) - = print_it sty - (ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "]) - ctxt ty - -print_it sty pp_forall ctxt ty - = ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser - pprContext sty ctxt, ppr sty ty] - -pprParendPolyType :: Outputable name => PprStyle -> PolyType name -> Pretty -pprParendPolyType sty ty = ppr sty ty -- ToDo: more later - -instance (Outputable name) => Outputable (MonoType name) where - ppr = pprMonoType - pREC_TOP = (0 :: Int) pREC_FUN = (1 :: Int) pREC_CON = (2 :: Int) +maybeParen :: Bool -> Pretty -> Pretty +maybeParen True p = ppParens p +maybeParen False p = p + -- printing works more-or-less as for Types -pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty +pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Pretty -pprMonoType sty ty = ppr_mono_ty sty pREC_TOP ty -pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty +pprHsType sty ty = ppr_mono_ty sty pREC_TOP ty +pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty + +ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty) = ppr_forall sty ctxt_prec [] ctxt ty +ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty) = ppr_forall sty ctxt_prec tvs ctxt ty ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name @@ -136,130 +148,98 @@ ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2) = let p1 = ppr_mono_ty sty pREC_FUN ty1 p2 = ppr_mono_ty sty pREC_TOP ty2 in - if ctxt_prec < pREC_FUN then -- no parens needed - ppSep [p1, ppBeside (ppStr "-> ") p2] - else - ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]] + maybeParen (ctxt_prec >= pREC_FUN) + (ppSep [p1, ppBeside (ppStr "-> ") p2]) -ppr_mono_ty sty ctxt_prec (MonoTupleTy tys) - = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen] +ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) + = ppParens (ppInterleave ppComma (map (ppr sty) tys)) -ppr_mono_ty sty ctxt_prec (MonoListTy ty) +ppr_mono_ty sty ctxt_prec (MonoListTy _ ty) = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack] ppr_mono_ty sty ctxt_prec (MonoTyApp tycon tys) = let pp_tycon = ppr sty tycon in if null tys then pp_tycon - else if ctxt_prec < pREC_CON then -- no parens needed - ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)] - else - ppBesides [ ppLparen, pp_tycon, ppSP, - ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ] + else + maybeParen (ctxt_prec >= pREC_CON) + (ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]) --- unfoldings only ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty) - = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"] - -#endif {- COMPILING_GHC -} + = ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty]) + -- Curlies are temporary \end{code} -\begin{code} -#ifdef COMPILING_GHC - -extractCtxtTyNames :: Eq name => Context name -> [name] -extractMonoTyNames :: Eq name => (name -> Bool) -> MonoType name -> [name] - -extractCtxtTyNames ctxt - = foldr get [] ctxt - where - get (clas, tv) acc - | tv `is_elem` acc = acc - | otherwise = tv : acc - - is_elem = isIn "extractCtxtTyNames" -extractMonoTyNames is_tyvar_name ty - = get ty [] - where - get (MonoTyApp con tys) acc = let - rest = foldr get acc tys - in - if is_tyvar_name con && not (con `is_elem` rest) - then con : rest - else rest - get (MonoListTy ty) acc = get ty acc - get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc) - get (MonoDictTy _ ty) acc = get ty acc - get (MonoTupleTy tys) acc = foldr get acc tys - get (MonoTyVar tv) acc - | tv `is_elem` acc = acc - | otherwise = tv : acc - - is_elem = isIn "extractMonoTyNames" - -#endif {- COMPILING_GHC -} -\end{code} +%************************************************************************ +%* * +\subsection{Comparison} +%* * +%************************************************************************ We do define a specialised equality for these \tr{*Type} types; used in checking interfaces. Most any other use is likely to be {\em wrong}, so be careful! -\begin{code} -#ifdef COMPILING_GHC -cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_ -cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_ +\begin{code} +cmpHsTyVar :: (a -> a -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_ +cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_ cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_ +cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2 +cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2 +cmpHsTyVar cmp (UserTyVar _) other = LT_ +cmpHsTyVar cmp other1 other2 = GT_ + + -- We assume that HsPreForAllTys have been smashed by now. # ifdef DEBUG -cmpPolyType _ (HsPreForAllTy _ _) _ = panic# "cmpPolyType:HsPreForAllTy:1st arg" -cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg" +cmpHsType _ (HsPreForAllTy _ _) _ = panic# "cmpHsType:HsPreForAllTy:1st arg" +cmpHsType _ _ (HsPreForAllTy _ _) = panic# "cmpHsType:HsPreForAllTy:2nd arg" # endif -cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) - = cmpList cmp tvs1 tvs2 `thenCmp` - cmpContext cmp c1 c2 `thenCmp` - cmpMonoType cmp t1 t2 +cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) + = cmpList (cmpHsTyVar cmp) tvs1 tvs2 `thenCmp` + cmpContext cmp c1 c2 `thenCmp` + cmpHsType cmp t1 t2 ------------ -cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2) +cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2) = cmp n1 n2 -cmpMonoType cmp (MonoTupleTy tys1) (MonoTupleTy tys2) - = cmpList (cmpMonoType cmp) tys1 tys2 -cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2) - = cmpMonoType cmp ty1 ty2 +cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ tys2) + = cmpList (cmpHsType cmp) tys1 tys2 +cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2) + = cmpHsType cmp ty1 ty2 -cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2) +cmpHsType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2) = cmp tc1 tc2 `thenCmp` - cmpList (cmpMonoType cmp) tys1 tys2 + cmpList (cmpHsType cmp) tys1 tys2 -cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2) - = cmpMonoType cmp a1 a2 `thenCmp` cmpMonoType cmp b1 b2 +cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2) + = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2 -cmpMonoType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2) - = cmp c1 c2 `thenCmp` cmpMonoType cmp ty1 ty2 +cmpHsType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2) + = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2 -cmpMonoType cmp ty1 ty2 -- tags must be different +cmpHsType cmp ty1 ty2 -- tags must be different = let tag1 = tag ty1 tag2 = tag ty2 in if tag1 _LT_ tag2 then LT_ else GT_ where tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT) - tag (MonoTupleTy tys1) = ILIT(2) - tag (MonoListTy ty1) = ILIT(3) + tag (MonoTupleTy _ tys1) = ILIT(2) + tag (MonoListTy _ ty1) = ILIT(3) tag (MonoTyApp tc1 tys1) = ILIT(4) tag (MonoFunTy a1 b1) = ILIT(5) tag (MonoDictTy c1 ty1) = ILIT(7) + tag (HsForAllTy _ _ _) = ILIT(8) + tag (HsPreForAllTy _ _) = ILIT(9) ------------------- cmpContext cmp a b = cmpList cmp_ctxt a b where - cmp_ctxt (c1, tv1) (c2, tv2) - = cmp c1 c2 `thenCmp` cmp tv1 tv2 - -#endif {- COMPILING_GHC -} + cmp_ctxt (c1, ty1) (c2, ty2) + = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2 \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 13abecb..001cd61 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -23,7 +23,6 @@ module CmdLineOpts ( opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnIndividualCafs, opt_CompilingGhcInternals, - opt_UsingGhcInternals, opt_D_dump_absC, opt_D_dump_asm, opt_D_dump_deforest, @@ -40,6 +39,7 @@ module CmdLineOpts ( opt_D_dump_stranal, opt_D_dump_tc, opt_D_show_passes, + opt_D_show_rn_trace, opt_D_simplifier_stats, opt_D_source_stats, opt_D_verbose_core2core, @@ -59,7 +59,7 @@ module CmdLineOpts ( opt_IgnoreStrictnessPragmas, opt_IrrefutableEverything, opt_IrrefutableTuples, - opt_NoImplicitPrelude, + opt_LiberateCaseThreshold, opt_NumbersStrict, opt_OmitBlackHoling, opt_OmitDefaultInstanceMethods, @@ -77,15 +77,19 @@ module CmdLineOpts ( opt_ShowImportSpecs, opt_ShowPragmaNameErrs, opt_SigsRequired, + opt_SourceUnchanged, opt_SpecialiseAll, opt_SpecialiseImports, opt_SpecialiseOverloaded, opt_SpecialiseTrace, opt_SpecialiseUnboxed, opt_StgDoLetNoEscapes, + + opt_InterfaceUnfoldThreshold, opt_UnfoldingCreationThreshold, - opt_UnfoldingOverrideThreshold, + opt_UnfoldingConDiscount, opt_UnfoldingUseThreshold, + opt_Verbose, opt_WarnNameShadowing ) where @@ -96,7 +100,7 @@ import Argv CHK_Ubiq() -- debugging consistency check -import CgCompInfo -- Default values for some flags +import Constants -- Default values for some flags import Maybes ( assocMaybe, firstJust, maybeToBool ) import Util ( startsWith, panic, panic#, assertPanic ) @@ -194,10 +198,6 @@ data SimplifierSwitch | MaxSimplifierIterations Int - | SimplUnfoldingUseThreshold Int -- per-simplification variants - | SimplUnfoldingConDiscount Int - | SimplUnfoldingCreationThreshold Int - | KeepSpecPragmaIds -- We normally *toss* Ids we can do without | KeepUnusedBindings @@ -226,9 +226,10 @@ data SimplifierSwitch %************************************************************************ \begin{code} -lookUp :: FAST_STRING -> Bool -lookup_int :: String -> Maybe Int -lookup_str :: String -> Maybe String +lookUp :: FAST_STRING -> Bool +lookup_int :: String -> Maybe Int +lookup_def_int :: String -> Int -> Int +lookup_str :: String -> Maybe String lookUp sw = maybeToBool (assoc_opts sw) @@ -238,6 +239,10 @@ lookup_int sw = case (lookup_str sw) of Nothing -> Nothing Just xx -> Just (read xx) +lookup_def_int sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> read xx + assoc_opts = assocMaybe [ (a, True) | a <- argv ] unpacked_opts = map _UNPK_ argv \end{code} @@ -248,6 +253,8 @@ opt_AllStrict = lookUp SLIT("-fall-strict") opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs") opt_AutoSccsOnExportedToplevs = lookUp SLIT("-fauto-sccs-on-exported-toplevs") opt_AutoSccsOnIndividualCafs = lookUp SLIT("-fauto-sccs-on-individual-cafs") +opt_CompilingGhcInternals = maybeToBool maybe_CompilingGhcInternals +maybe_CompilingGhcInternals = lookup_str "-fcompiling-ghc-internals=" opt_D_dump_absC = lookUp SLIT("-ddump-absC") opt_D_dump_asm = lookUp SLIT("-ddump-asm") opt_D_dump_deforest = lookUp SLIT("-ddump-deforest") @@ -264,6 +271,7 @@ opt_D_dump_stg = lookUp SLIT("-ddump-stg") opt_D_dump_stranal = lookUp SLIT("-ddump-stranal") opt_D_dump_tc = lookUp SLIT("-ddump-tc") opt_D_show_passes = lookUp SLIT("-dshow-passes") +opt_D_show_rn_trace = lookUp SLIT("-dshow-rn-trace") opt_D_simplifier_stats = lookUp SLIT("-dsimplifier-stats") opt_D_source_stats = lookUp SLIT("-dsource-stats") opt_D_verbose_core2core = lookUp SLIT("-dverbose-simpl") @@ -271,16 +279,18 @@ opt_D_verbose_stg2stg = lookUp SLIT("-dverbose-stg") opt_DoCoreLinting = lookUp SLIT("-dcore-lint") opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging") opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky") +opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names") opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on") opt_FoldrBuildTrace = lookUp SLIT("-ffoldr-build-trace") 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_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files +opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") -opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") opt_NumbersStrict = lookUp SLIT("-fnumbers-strict") opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") opt_OmitDefaultInstanceMethods = lookUp SLIT("-fomit-default-instance-methods") @@ -288,34 +298,35 @@ opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas") opt_PprStyle_All = lookUp SLIT("-dppr-all") opt_PprStyle_Debug = lookUp SLIT("-dppr-debug") opt_PprStyle_User = lookUp SLIT("-dppr-user") +opt_ProduceC = lookup_str "-C=" +opt_ProduceS = lookup_str "-S=" +opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time opt_ReportWhyUnfoldingsDisallowed= lookUp SLIT("-freport-disallowed-unfoldings") opt_SccProfilingOn = lookUp SLIT("-fscc-profiling") opt_ShowImportSpecs = lookUp SLIT("-fshow-import-specs") opt_ShowPragmaNameErrs = lookUp SLIT("-fshow-pragma-name-errs") opt_SigsRequired = lookUp SLIT("-fsignatures-required") +opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged") opt_SpecialiseAll = lookUp SLIT("-fspecialise-all") opt_SpecialiseImports = lookUp SLIT("-fspecialise-imports") opt_SpecialiseOverloaded = lookUp SLIT("-fspecialise-overloaded") opt_SpecialiseTrace = lookUp SLIT("-ftrace-specialisation") opt_SpecialiseUnboxed = lookUp SLIT("-fspecialise-unboxed") opt_StgDoLetNoEscapes = lookUp SLIT("-flet-no-escape") -opt_Verbose = lookUp SLIT("-v") -opt_UsingGhcInternals = lookUp SLIT("-fusing-ghc-internals") -opt_CompilingGhcInternals = maybeToBool maybe_CompilingGhcInternals -maybe_CompilingGhcInternals = lookup_str "-fcompiling-ghc-internals=" -opt_SccGroup = lookup_str "-G=" -opt_ProduceC = lookup_str "-C=" -opt_ProduceS = lookup_str "-S=" -opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time -opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files -opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names=" -opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold" -opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold" -opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold" +opt_SccGroup = lookup_str "-G=" +opt_Verbose = lookUp SLIT("-v") -opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") -opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") +opt_InterfaceUnfoldThreshold = lookup_def_int "-funfolding-interface-threshold" iNTERFACE_UNFOLD_THRESHOLD +opt_UnfoldingCreationThreshold = lookup_def_int "-funfolding-creation-threshold" uNFOLDING_CREATION_THRESHOLD +opt_UnfoldingUseThreshold = lookup_def_int "-funfolding-use-threshold" uNFOLDING_USE_THRESHOLD +opt_UnfoldingConDiscount = lookup_def_int "-funfolding-con-discount" uNFOLDING_CON_DISCOUNT_WEIGHT + +opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" lIBERATE_CASE_THRESHOLD +opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") + +-- opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold" +-- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" \end{code} \begin{code} @@ -421,21 +432,9 @@ classifyOpts = sep argv [] [] -- accumulators... "-fno-let-from-strict-let" -> SIMPL_SW(SimplNoLetFromStrictLet) o | starts_with_msi -> SIMPL_SW(MaxSimplifierIterations (read after_msi)) - | starts_with_suut -> SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut)) - | starts_with_suct -> SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct)) - | starts_with_sucd -> SIMPL_SW(SimplUnfoldingConDiscount (read after_sucd)) where - maybe_suut = startsWith "-fsimpl-uf-use-threshold" o - maybe_suct = startsWith "-fsimpl-uf-creation-threshold" o - maybe_sucd = startsWith "-fsimpl-uf-con-discount" o maybe_msi = startsWith "-fmax-simplifier-iterations" o - starts_with_suut = maybeToBool maybe_suut - starts_with_suct = maybeToBool maybe_suct - starts_with_sucd = maybeToBool maybe_sucd starts_with_msi = maybeToBool maybe_msi - (Just after_suut) = maybe_suut - (Just after_suct) = maybe_suct - (Just after_sucd) = maybe_sucd (Just after_msi) = maybe_msi _ -> -- NB: the driver is really supposed to handle bad options @@ -478,9 +477,6 @@ tagOf_SimplSwitch SimplDoEtaReduction = ILIT(18) tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19) tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20) tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21) -tagOf_SimplSwitch (SimplUnfoldingUseThreshold _) = ILIT(22) -tagOf_SimplSwitch (SimplUnfoldingConDiscount _) = ILIT(23) -tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(24) tagOf_SimplSwitch KeepSpecPragmaIds = ILIT(25) tagOf_SimplSwitch KeepUnusedBindings = ILIT(26) tagOf_SimplSwitch SimplNoLetFromCase = ILIT(27) @@ -540,9 +536,6 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* } where mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt lvl - mk_assoc_elem k@(SimplUnfoldingUseThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i - mk_assoc_elem k@(SimplUnfoldingConDiscount i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i - mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO SwBool True -- I'm here, Mom! @@ -560,10 +553,7 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* Default settings for simplifier switches \begin{code} -defaultSimplSwitches = [SimplUnfoldingCreationThreshold uNFOLDING_CREATION_THRESHOLD, - SimplUnfoldingUseThreshold uNFOLDING_USE_THRESHOLD, - SimplUnfoldingConDiscount uNFOLDING_CON_DISCOUNT_WEIGHT, - MaxSimplifierIterations 1 +defaultSimplSwitches = [MaxSimplifierIterations 1 ] \end{code} diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index c0d0e71..5918cf6 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -20,7 +20,7 @@ IMP_Ubiq(){-uitous-} import Bag ( bagToList ) import PprStyle ( PprStyle(..) ) import Pretty -import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instance-} ) +import SrcLoc ( noSrcLoc, SrcLoc{-instance-} ) \end{code} \begin{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 0db5364..cb893f7 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -12,14 +12,18 @@ IMP_Ubiq(){-uitous-} IMPORT_1_3(IO(hGetContents,stdin,stderr,hPutStr,hClose,openFile,IOMode(..))) import HsSyn +import RdrHsSyn ( RdrName ) import ReadPrefix ( rdModule ) import Rename ( renameModule ) +import RnMonad ( ExportEnv ) + import MkIface -- several functions import TcModule ( typecheckModule ) import Desugar ( deSugar, DsMatchContext, pprDsWarnings ) import SimplCore ( core2core ) import CoreToStg ( topCoreBindsToStg ) +import StgSyn ( collectFinalStgBinders ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) #if ! OMIT_NATIVE_CODEGEN @@ -33,7 +37,6 @@ import Bag ( emptyBag, isEmptyBag ) import CmdLineOpts import ErrUtils ( pprBagOfErrors, ghcExit ) import Maybes ( maybeToBool, MaybeErr(..) ) -import RdrHsSyn ( getRawExportees ) import Specialise ( SpecialiseData(..) ) import StgSyn ( pprPlainStgBinding, GenStgBinding ) import TcInstUtil ( InstInfo ) @@ -46,9 +49,8 @@ import PprStyle ( PprStyle(..) ) import Pretty import Id ( GenId ) -- instances -import Name ( Name, RdrName ) -- instances +import Name ( Name ) -- instances import PprType ( GenType, GenTyVar ) -- instances -import RnHsSyn ( RnName ) -- instances import TyVar ( GenTyVar ) -- instances import Unique ( Unique ) -- instances \end{code} @@ -66,7 +68,7 @@ main doIt :: ([CoreToDo], [StgToDo]) -> String -> IO () doIt (core_cmds, stg_cmds) input_pgm - = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >> + = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.02, for Haskell 1.3" "" >> -- ******* READER show_pass "Reader" >> @@ -94,25 +96,19 @@ doIt (core_cmds, stg_cmds) input_pgm _scc_ "Renamer" renameModule rn_uniqs rdr_module >>= - \ (rn_mod, rn_env, import_names, - export_stuff, usage_stuff, - rn_errs_bag, rn_warns_bag) -> + \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) -> - if (not (isEmptyBag rn_errs_bag)) then - hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag)) - >> hPutStr stderr "\n" >> - hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) - >> hPutStr stderr "\n" >> - ghcExit 1 + checkErrors rn_errs_bag rn_warns_bag >> + case maybe_rn_stuff of { + Nothing -> -- Hurrah! Renamer reckons that there's no need to + -- go any further + hPutStr stderr "No recompilation required!\n" >> + ghcExit 0 ; + + -- Oh well, we've got to recompile for real + Just (rn_mod, iface_file_stuff, rn_name_supply, imported_modules) -> - else -- No renaming errors ... - (if (isEmptyBag rn_warns_bag) then - return () - else - hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) - >> hPutStr stderr "\n" - ) >> doDump opt_D_dump_rn "Renamer:" (pp_show (ppr pprStyle rn_mod)) >> @@ -121,20 +117,14 @@ doIt (core_cmds, stg_cmds) input_pgm -- (the iface file is produced incrementally, as we have -- the information that we need...; we use "iface") -- "endIface" finishes the job. - let - (usages_map, version_info, instance_modules) = usage_stuff - in - startIface mod_name >>= \ if_handle -> - ifaceUsages if_handle usages_map >> - ifaceVersions if_handle version_info >> - ifaceExportList if_handle export_stuff rn_env >> - ifaceFixities if_handle rn_mod >> - ifaceInstanceModules if_handle instance_modules >> + startIface mod_name >>= \ if_handle -> + ifaceMain if_handle iface_file_stuff >> + -- ******* TYPECHECKER show_pass "TypeCheck" >> _scc_ "TypeCheck" - case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of + case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_name_supply rn_mod) of Succeeded (stuff, warns) -> (emptyBag, warns, stuff) Failed (errs, warns) @@ -142,26 +132,12 @@ doIt (core_cmds, stg_cmds) input_pgm of { (tc_errs_bag, tc_warns_bag, tc_results) -> - if (not (isEmptyBag tc_errs_bag)) then - hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag)) - >> hPutStr stderr "\n" >> - hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) - >> hPutStr stderr "\n" >> - ghcExit 1 - - else ( -- No typechecking errors ... - - (if (isEmptyBag tc_warns_bag) then - return () - else - hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) - >> hPutStr stderr "\n" - ) >> + checkErrors tc_errs_bag tc_warns_bag >> case tc_results of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds), - interface_stuff@(_,local_tycons,_,_), - pragma_tycon_specs, ddump_deriv) -> + local_tycons, inst_info, pragma_tycon_specs, + ddump_deriv) -> doDump opt_D_dump_tc "Typechecked:" (pp_show (ppAboves [ @@ -174,12 +150,12 @@ doIt (core_cmds, stg_cmds) input_pgm doDump opt_D_dump_deriv "Derived instances:" (pp_show (ddump_deriv pprStyle)) >> - -- OK, now do the interface stuff that relies on typechecker output: - ifaceDecls if_handle interface_stuff >> - ifaceInstances if_handle interface_stuff >> + -- Now (and alas only now) we have the derived-instance information + -- so we can put instance information in the interface file + ifaceInstances if_handle inst_info >> -- ******* DESUGARER - show_pass "DeSugar" >> + show_pass "DeSugar " >> _scc_ "DeSugar" let (desugared,ds_warnings) @@ -206,7 +182,7 @@ doIt (core_cmds, stg_cmds) input_pgm sm_uniqs local_data_tycons pragma_tycon_specs desugared >>= - \ (simplified, inlinings_env, + \ (simplified, SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) -> doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves @@ -231,19 +207,25 @@ doIt (core_cmds, stg_cmds) input_pgm (pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2))) >> + -- Dump type signatures into the interface file + let + final_ids = collectFinalStgBinders stg_binds2 + in + ifaceDecls if_handle rn_mod final_ids simplified >> + endIface if_handle >> -- We are definitely done w/ interface-file stuff at this point: -- (See comments near call to "startIface".) - endIface if_handle >> + -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C! show_pass "CodeGen" >> _scc_ "CodeGen" let - abstractC = codeGen mod_name -- module name for CC labelling + abstractC = codeGen mod_name -- module name for CC labelling cost_centre_info - import_names -- import names for CC registering - gen_tycons -- type constructors generated locally - all_tycon_specs -- tycon specialisations + imported_modules -- import names for CC registering + gen_tycons -- type constructors generated locally + all_tycon_specs -- tycon specialisations stg_binds2 flat_abstractC = flattenAbsC fl_uniqs abstractC @@ -285,24 +267,11 @@ doIt (core_cmds, stg_cmds) input_pgm doOutput opt_ProduceC c_output_w >> ghcExit 0 - } ) } + } } } where ------------------------------------------------------------- -- ****** printing styles and column width: - pprCols = (80 :: Int) -- could make configurable - - (pprStyle, pprErrorsStyle) - = if opt_PprStyle_All then - (PprShowAll, PprShowAll) - else if opt_PprStyle_Debug then - (PprDebug, PprDebug) - else if opt_PprStyle_User then - (PprForUser, PprForUser) - else -- defaults... - (PprDebug, PprForUser) - - pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p ------------------------------------------------------------- -- ****** help functions: @@ -328,9 +297,32 @@ doIt (core_cmds, stg_cmds) input_pgm else return () -ppSourceStats (HsModule name version exports imports fixities typedecls typesigs - classdecls instdecls instsigs defdecls binds - [{-no sigs-}] src_loc) +pprCols = (80 :: Int) -- could make configurable + +(pprStyle, pprErrorsStyle) + | opt_PprStyle_All = (PprShowAll, PprShowAll) + | opt_PprStyle_Debug = (PprDebug, PprDebug) + | opt_PprStyle_User = (PprForUser, PprForUser) + | otherwise = (PprDebug, PprForUser) + +pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p + +checkErrors errs_bag warns_bag + | not (isEmptyBag errs_bag) + = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle errs_bag)) + >> hPutStr stderr "\n" >> + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag)) + >> hPutStr stderr "\n" >> + ghcExit 1 + + | not (isEmptyBag warns_bag) + = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag)) >> + hPutStr stderr "\n" + + | otherwise = return () + + +ppSourceStats (HsModule name version exports imports fixities decls src_loc) = ppAboves (map pp_val [("ExportAll ", export_all), -- 1 if no export list ("ExportDecls ", export_ds), @@ -342,7 +334,7 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs (" ImpPartial ", import_partial), (" ImpHiding ", import_hiding), ("FixityDecls ", fixity_ds), - ("DefaultDecls ", defalut_ds), + ("DefaultDecls ", default_ds), ("TypeDecls ", type_ds), ("DataDecls ", data_ds), ("NewTypeDecls ", newt_ds), @@ -358,8 +350,8 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs ("FunBinds ", fn_bind_ds), ("InlineMeths ", method_inlines), ("InlineBinds ", bind_inlines), - ("SpecialisedData ", data_specs), - ("SpecialisedInsts ", inst_specs), +-- ("SpecialisedData ", data_specs), +-- ("SpecialisedInsts ", inst_specs), ("SpecialisedMeths ", method_specs), ("SpecialisedBinds ", bind_specs) ]) @@ -367,37 +359,38 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs pp_val (str, 0) = ppNil pp_val (str, n) = ppBesides [ppStr str, ppInt n] - (export_decls, export_mods) = getRawExportees exports - type_decls = filter is_type_decl typedecls - data_decls = filter is_data_decl typedecls - newt_decls = filter is_newt_decl typedecls - - export_ds = length export_decls - export_ms = length export_mods - export_all = if export_ds == 0 && export_ms == 0 then 1 else 0 - - fixity_ds = length fixities - defalut_ds = length defdecls - type_ds = length type_decls - data_ds = length data_decls - newt_ds = length newt_decls - class_ds = length classdecls - inst_ds = length instdecls + fixity_ds = length fixities + type_decls = [d | TyD d@(TySynonym _ _ _ _) <- decls] + data_decls = [d | TyD d@(TyData _ _ _ _ _ _ _) <- decls] + newt_decls = [d | TyD d@(TyNew _ _ _ _ _ _ _) <- decls] + type_ds = length type_decls + data_ds = length data_decls + newt_ds = length newt_decls + class_decls = [d | ClD d <- decls] + class_ds = length class_decls + inst_decls = [d | InstD d <- decls] + inst_ds = length inst_decls + default_ds = length [() | DefD _ <- decls] + val_decls = [d | ValD d <- decls] + + real_exports = case exports of { Nothing -> []; Just es -> es } + n_exports = length real_exports + export_ms = length [() | IEModuleContents _ <- real_exports] + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; other -> 0 } (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines) - = count_binds binds + = count_binds (foldr ThenBinds EmptyBinds val_decls) (import_no, import_qual, import_as, import_all, import_partial, import_hiding) = foldr add6 (0,0,0,0,0,0) (map import_info imports) (data_constrs, data_derivs) = foldr add2 (0,0) (map data_info (newt_decls ++ data_decls)) (class_method_ds, default_method_ds) - = foldr add2 (0,0) (map class_info classdecls) + = foldr add2 (0,0) (map class_info class_decls) (inst_method_ds, method_specs, method_inlines) - = foldr add3 (0,0,0) (map inst_info instdecls) + = foldr add3 (0,0,0) (map inst_info inst_decls) - data_specs = length typesigs - inst_specs = length instsigs count_binds EmptyBinds = (0,0,0,0,0) count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2 @@ -418,7 +411,7 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) - sig_info (Sig _ _ _ _) = (1,0,0,0) + sig_info (Sig _ _ _) = (1,0,0,0) sig_info (ClassOpSig _ _ _ _) = (0,1,0,0) sig_info (SpecSig _ _ _ _) = (0,0,1,0) sig_info (InlineSig _ _) = (0,0,0,1) @@ -437,25 +430,18 @@ ppSourceStats (HsModule name version exports imports fixities typedecls typesigs data_info (TyData _ _ _ constrs derivs _ _) = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info (TyNew _ _ _ constr derivs _ _) - = (length constr, case derivs of {Nothing -> 0; Just ds -> length ds}) + = (1, case derivs of {Nothing -> 0; Just ds -> length ds}) class_info (ClassDecl _ _ _ meth_sigs def_meths _ _) = case count_sigs meth_sigs of (_,classops,_,_) -> (classops, addpr (count_monobinds def_meths)) - inst_info (InstDecl _ _ inst_meths _ _ inst_sigs _ _) + inst_info (InstDecl _ inst_meths inst_sigs _ _) = case count_sigs inst_sigs of (_,_,ss,is) -> (addpr (count_monobinds inst_meths), ss, is) - is_type_decl (TySynonym _ _ _ _) = True - is_type_decl _ = False - is_data_decl (TyData _ _ _ _ _ _ _) = True - is_data_decl _ = False - is_newt_decl (TyNew _ _ _ _ _ _ _) = True - is_newt_decl _ = False - addpr (x,y) = x+y add1 x1 y1 = x1+y1 add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index d8ead0b..3129d80 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -8,59 +8,61 @@ module MkIface ( startIface, endIface, - ifaceUsages, - ifaceVersions, - ifaceExportList, - ifaceFixities, - ifaceInstanceModules, - ifaceDecls, - ifaceInstances, - ifacePragmas + ifaceMain, ifaceInstances, + ifaceDecls ) where IMP_Ubiq(){-uitous-} IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..))) -import Bag ( bagToList ) -import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) ) -import CmdLineOpts ( opt_ProduceHi ) -import FieldLabel ( FieldLabel{-instance NamedThing-} ) -import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap ) import HsSyn +import RdrHsSyn ( RdrName(..) ) +import RnHsSyn ( SYN_IE(RenamedHsModule) ) +import RnMonad + +import TcInstUtil ( InstInfo(..) ) + +import CmdLineOpts import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon, - dataConStrictMarks, StrictnessMark(..), + getIdInfo, idWantsToBeINLINEd, wantIdSigInIface, + dataConStrictMarks, StrictnessMark(..), + SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet, + isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, GenId{-instance NamedThing/Outputable-} ) -import Maybes ( maybeToBool ) -import Name ( origName, nameOf, moduleOf, - exportFlagOn, nameExportFlag, ExportFlag(..), - isLexSym, isLexCon, isLocallyDefined, isWiredInName, - RdrName(..){-instance Outputable-}, - OrigName(..){-instance Ord-}, - Name{-instance NamedThing-} +import IdInfo ( StrictnessInfo, ArityInfo, Unfolding, + arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, + getWorkerId_maybe, bottomIsGuaranteed ) -import ParseUtils ( UsagesMap(..), VersionsMap(..) ) +import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) ) +import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) ) +import FreeVars ( addExprFVs ) +import Name ( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName, + OccName, occNameString, nameOccName, nameString, isExported, pprNonSym, + Name {-instance NamedThing-}, Provenance + ) +import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) ) +import Class ( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType ) +import FieldLabel ( FieldLabel{-instance NamedThing-} ) +import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy ) +import TyVar ( GenTyVar {- instance Eq -} ) +import Unique ( Unique {- instance Eq -} ) + import PprEnv -- not sure how much... import PprStyle ( PprStyle(..) ) -import PprType -- most of it (??) ---import PrelMods ( modulesWithBuiltins ) -import PrelInfo ( builtinValNamesMap, builtinTcNamesMap ) -import Pretty ( prettyToUn ) +import PprType +import PprCore ( pprIfaceUnfolding ) +import Pretty import Unpretty -- ditto -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(..) ) -import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy ) -import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}{-, pprTrace ToDo:rm-} ) -uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util -ppr_ty ty = prettyToUn (pprType PprInterface ty) -ppr_tyvar tv = prettyToUn (ppr PprInterface tv) -ppr_name n - = case (origName "ppr_name" n) of { OrigName m s -> - uppBesides [uppPStr m, uppChar '.', uppPStr s] } + +import Bag ( bagToList ) +import Maybes ( catMaybes, maybeToBool ) +import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap ) +import UniqFM ( UniqFM, lookupUFM, listToUFM ) +import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL, + assertPanic, panic{-ToDo:rm-}, pprTrace ) + \end{code} We have a function @startIface@ to open the output file and put @@ -74,39 +76,20 @@ to the handle provided by @startIface@. \begin{code} startIface :: Module -> IO (Maybe Handle) -- Nothing <=> don't do an interface -endIface :: Maybe Handle -> IO () -ifaceUsages - :: Maybe Handle - -> UsagesMap - -> IO () -ifaceVersions - :: Maybe Handle - -> VersionsMap - -> IO () -ifaceExportList - :: Maybe Handle - -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)])) - -> RnEnv - -> IO () -ifaceFixities - :: Maybe Handle - -> RenamedHsModule - -> IO () -ifaceInstanceModules - :: Maybe Handle - -> [Module] - -> IO () -ifaceDecls :: Maybe Handle - -> TcIfaceInfo -- info produced by typechecker, for interfaces - -> IO () -ifaceInstances - :: Maybe Handle - -> TcIfaceInfo -- as above - -> IO () -ifacePragmas - :: Maybe Handle + +ifaceMain :: Maybe Handle + -> InterfaceDetails -> IO () -ifacePragmas = panic "ifacePragmas" -- stub + +ifaceInstances :: Maybe Handle -> Bag InstInfo -> IO () + +ifaceDecls :: Maybe Handle + -> RenamedHsModule + -> [Id] -- Ids used at code-gen time; they have better pragma info! + -> [CoreBinding] -- In dependency order, later depend on earlier + -> IO () + +endIface :: Maybe Handle -> IO () \end{code} \begin{code} @@ -115,370 +98,341 @@ startIface mod Nothing -> return Nothing -- not producing any .hi file Just fn -> openFile fn WriteMode >>= \ if_hdl -> - hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\ninterface "++ _UNPK_ mod) >> + hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\n_interface_ "++ _UNPK_ mod ++ "\n") >> return (Just if_hdl) endIface Nothing = return () endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl \end{code} -\begin{code} -ifaceUsages Nothing{-no iface handle-} _ = return () -ifaceUsages (Just if_hdl) usages - | null usages_list - = return () +\begin{code} +ifaceMain Nothing iface_stuff = return () +ifaceMain (Just if_hdl) + (import_usages, ExportEnv avails fixities, instance_modules) + = + ifaceInstanceModules if_hdl instance_modules >> + ifaceUsages if_hdl import_usages >> + ifaceExports if_hdl avails >> + ifaceFixities if_hdl fixities >> + return () + +ifaceDecls Nothing rn_mod final_ids simplified = return () +ifaceDecls (Just hdl) + (HsModule _ _ _ _ _ decls _) + final_ids binds + | null decls = return () + -- You could have a module with just (re-)exports/instances in it | otherwise - = hPutStr if_hdl "\n__usages__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list))) + = hPutStr hdl "_declarations_\n" >> + ifaceTCDecls hdl decls >> + ifaceBinds hdl final_ids binds >> + return () +\end{code} + +\begin{code} +ifaceUsages if_hdl import_usages + = hPutStr if_hdl "_usages_\n" >> + hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where - usages_list = fmToList usages -- NO: filter has_no_builtins (...) + upp_uses (m, mv, versions) + = uppBesides [upp_module m, uppSP, uppInt mv, uppPStr SLIT(" :: "), + upp_import_versions (sort_versions versions), uppSemi] --- has_no_builtins (m, _) --- = m `notElem` modulesWithBuiltins --- -- Don't *have* to do this; save gratuitous spillage in --- -- every interface. Could be flag-controlled... + -- For imported versions we do print the version number + upp_import_versions nvs + = uppIntersperse uppSP [ uppCat [ppr_unqual_name n, uppInt v] | (n,v) <- nvs ] - upp_uses (m, (mv, versions)) - = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "), - upp_versions (fmToList versions), uppSemi] - upp_versions nvs - = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ] -\end{code} +ifaceInstanceModules if_hdl [] = return () +ifaceInstanceModules if_hdl imods + = hPutStr if_hdl "_instance_modules_\n" >> + hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) >> + hPutStr if_hdl "\n" -\begin{code} -ifaceVersions Nothing{-no iface handle-} _ = return () +ifaceExports if_hdl [] = return () +ifaceExports if_hdl avails + = hPutStr if_hdl "_exports_\n" >> + hPutCol if_hdl upp_avail (sortLt lt_avail avails) -ifaceVersions (Just if_hdl) version_info - | null version_list - = return () - | otherwise - = hPutStr if_hdl "\n__versions__\n" >> - hPutStr if_hdl (uppShow 0 (upp_versions version_list)) - -- NB: when compiling Prelude.hs, this will spew out - -- stuff for [], (), (,), etc. [i.e., builtins], which - -- we'd rather it didn't. The version-mangling in - -- the driver will ignore them. +ifaceFixities if_hdl [] = return () +ifaceFixities if_hdl fixities + = hPutStr if_hdl "_fixities_\n" >> + hPutCol if_hdl upp_fixity fixities + +ifaceTCDecls if_hdl decls + = hPutCol if_hdl ppr_decl tc_decls_for_iface where - version_list = fmToList version_info + tc_decls_for_iface = sortLt lt_decl (filter for_iface decls) + for_iface decl@(ClD _) = for_iface_name (hsDeclName decl) + for_iface decl@(TyD _) = for_iface_name (hsDeclName decl) + for_iface other_decl = False - upp_versions nvs - = uppAboves [ uppPStr n | (n,v) <- nvs ] -\end{code} + for_iface_name name = isLocallyDefined name && + not (isWiredInName name) -\begin{code} -ifaceInstanceModules Nothing{-no iface handle-} _ = return () -ifaceInstanceModules (Just _) [] = return () + lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2 +\end{code} + +%************************************************************************ +%* * +\subsection{Instance declarations} +%* * +%************************************************************************ -ifaceInstanceModules (Just if_hdl) imods - = hPutStr if_hdl "\n__instance_modules__\n" >> - hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) + +\begin{code} +ifaceInstances Nothing{-no iface handle-} _ = return () + +ifaceInstances (Just if_hdl) inst_infos + | null togo_insts = return () + | otherwise = hPutStr if_hdl "_instances_\n" >> + hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) + where + togo_insts = filter is_togo_inst (bagToList inst_infos) + is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id + + ------- + lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _) + (InstInfo _ _ _ _ _ dfun_id2 _ _ _) + = getOccName dfun_id1 < getOccName dfun_id2 + -- The dfuns are assigned names df1, df2, etc, in order of original textual + -- occurrence, and this makes as good a sort order as any + + ------- + pp_inst (InstInfo clas tvs ty theta _ dfun_id _ _ _) + = let + forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) + renumbered_ty = renumber_ty forall_ty + in + uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, + uppPStr SLIT(" = "), ppr_unqual_name dfun_id, uppSemi] \end{code} -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. 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.) + +%************************************************************************ +%* * +\subsection{Printing values} +%* * +%************************************************************************ + \begin{code} -ifaceExportList Nothing{-no iface handle-} _ _ = return () - -ifaceExportList (Just if_hdl) - (export_fn, (dotdot_vals, dotdot_tcs)) - rn_env@((qual, unqual, tc_qual, tc_unqual), _) - = let - name_flag_pairs :: FiniteMap OrigName ExportFlag - name_flag_pairs - = 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))) +ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added + -- by the STG passes. Sigh + + -> IdSet -- Set of Ids that are needed by earlier interface + -- file emissions. If the Id isn't in this set, and isn't + -- exported, there's no need to emit anything + -> Id + -> CoreExpr -- The Id's right hand side + -> Maybe (Pretty, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids + +ifaceId get_idinfo needed_ids id rhs + | not (wantIdSigInIface (id `elementOfIdSet` needed_ids) + opt_OmitInterfacePragmas + id) + = Nothing -- Well, that was easy! + +ifaceId get_idinfo needed_ids id rhs + = Just (ppCat [sig_pretty, prag_pretty, ppSemi], new_needed_ids) where - 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 - - -- 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_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_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 - | is_val_ish && not (fun_looking rn) - = acc -- these things don't cause export-ery - | exportFlagOn ef = addToFM acc on ef - | otherwise = acc - where - n = getName rn - ef = export_fn n - on = origName "from_wired" n - - -------------- - lexical_lt (n1,_) (n2,_) = n1 < n2 - - -------------- - upp_pair (OrigName m n, ef) - = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef] - where - upp_export ExportAll = uppPStr SLIT("(..)") - upp_export ExportAbs = uppNil + idinfo = get_idinfo id + ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id))) + sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty] + + prag_pretty | opt_OmitInterfacePragmas = ppNil + | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty] + + ------------ Arity -------------- + arity_pretty = ppArityInfo PprInterface (arityInfo idinfo) + + ------------ Strictness -------------- + strict_info = strictnessInfo idinfo + maybe_worker = getWorkerId_maybe strict_info + strict_pretty = ppStrictnessInfo PprInterface strict_info + + ------------ Unfolding -------------- + unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs] + | otherwise = ppNil + + show_unfold = not (maybeToBool maybe_worker) && -- Unfolding is implicit + not (bottomIsGuaranteed strict_info) && -- Ditto + case guidance of -- Small enough to show + UnfoldNever -> False + other -> True + + guidance = calcUnfoldingGuidance (idWantsToBeINLINEd id) + opt_InterfaceUnfoldThreshold + rhs + + + ------------ Extra free Ids -------------- + new_needed_ids = (needed_ids `minusIdSet` unitIdSet id) `unionIdSets` + extra_ids + + extra_ids | opt_OmitInterfacePragmas = emptyIdSet + | otherwise = worker_ids `unionIdSets` + unfold_ids + + worker_ids = case maybe_worker of + Just wkr -> unitIdSet wkr + Nothing -> emptyIdSet + + unfold_ids | show_unfold = free_vars + | otherwise = emptyIdSet + where + (_,free_vars) = addExprFVs interesting emptyIdSet rhs + interesting bound id = not (id `elementOfIdSet` bound) && + not (isDataCon id) && + not (isWiredInName (getName id)) && + isLocallyDefined id \end{code} \begin{code} -ifaceFixities Nothing{-no iface handle-} _ = return () - -ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) - = let - pp_fixities = foldr go [] fixities - in - if null pp_fixities then - return () - else - hPutStr if_hdl "\n__fixities__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities)) +ifaceBinds :: Handle + -> [Id] -- Ids used at code-gen time; they have better pragma info! + -> [CoreBinding] -- In dependency order, later depend on earlier + -> IO () + +ifaceBinds hdl final_ids binds + = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties))) >> + hPutStr hdl "\n" where - go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc - go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc - go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix "" i v) else id) acc - - print_fix suff prec var - = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi] + final_id_map = listToUFM [(id,id) | id <- final_ids] + get_idinfo id = case lookupUFM final_id_map id of + Just id' -> getIdInfo id' + Nothing -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $ + getIdInfo id + + pretties = go emptyIdSet (reverse binds) -- Reverse so that later things will + -- provoke earlier ones to be emitted + go needed [] = if not (isEmptyIdSet needed) then + pprTrace "ifaceBinds: free vars:" + (ppSep (map (ppr PprDebug) (idSetToList needed))) $ + [] + else + [] + + go needed (NonRec id rhs : binds) + = case ifaceId get_idinfo needed id rhs of + Nothing -> go needed binds + Just (pretty, needed') -> pretty : go needed' binds + + -- Recursive groups are a bit more of a pain. We may only need one to + -- start with, but it may call out the next one, and so on. So we + -- have to look for a fixed point. + go needed (Rec pairs : binds) + = pretties ++ go needed'' binds + where + (needed', pretties) = go_rec needed pairs + needed'' = needed' `minusIdSet` mkIdSet (map fst pairs) + -- Later ones may spuriously cause earlier ones to be "needed" again + + go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Pretty]) + go_rec needed pairs + | null pretties = (needed, []) + | otherwise = (final_needed, more_pretties ++ pretties) + where + reduced_pairs = [pair | (pair,Nothing) <- pairs `zip` maybes] + pretties = catMaybes maybes + (needed', maybes) = mapAccumL do_one needed pairs + (final_needed, more_pretties) = go_rec needed' reduced_pairs + + do_one needed (id,rhs) = case ifaceId get_idinfo needed id rhs of + Nothing -> (needed, Nothing) + Just (pretty, needed') -> (needed', Just pretty) \end{code} -\begin{code} -non_wired x = not (isWiredInName (getName x)) --ToDo:move? - -ifaceDecls Nothing{-no iface handle-} _ = return () - -ifaceDecls (Just if_hdl) (vals, tycons, classes, _) - = ASSERT(all isLocallyDefined vals) - ASSERT(all isLocallyDefined tycons) - ASSERT(all isLocallyDefined classes) - let - nonwired_classes = filter non_wired classes - nonwired_tycons = filter non_wired tycons - nonwired_vals = filter non_wired vals - - lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b - - sorted_classes = sortLt lt_lexical nonwired_classes - sorted_tycons = sortLt lt_lexical nonwired_tycons - sorted_vals = sortLt lt_lexical nonwired_vals - in - if (null sorted_classes && null sorted_tycons && null sorted_vals) then - -- You could have a module with just (re-)exports/instances in it - return () - else - hPutStr if_hdl "\n__declarations__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves [ - uppAboves (map ppr_class sorted_classes), - uppAboves (map ppr_tycon sorted_tycons), - uppAboves [ppr_val v (idType v) | v <- sorted_vals]])) -\end{code} +%************************************************************************ +%* * +\subsection{Random small things} +%* * +%************************************************************************ + \begin{code} -ifaceInstances Nothing{-no iface handle-} _ = return () +upp_avail NotAvailable = uppNil +upp_avail (Avail name ns) = uppBesides [upp_module mod, uppSP, + upp_occname occ, uppSP, + upp_export ns] + where + (mod,occ) = modAndOcc name -ifaceInstances (Just if_hdl) (_, _, _, insts) - = let - togo_insts = filter is_togo_inst (bagToList insts) - - sorted_insts = sortLt lt_inst togo_insts - in - if null togo_insts then - return () - else - hPutStr if_hdl "\n__instances__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts))) - where - is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _) - = from_here -- && ... - - ------- - lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _) - (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _) - = let - tycon1 = fst (getAppTyCon ty1) - tycon2 = fst (getAppTyCon ty2) - in - case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of - LT_ -> True - GT_ -> False - EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2 - - ------- - pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _) - = let - forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) - renumbered_ty = initNmbr (nmbrType forall_ty) - in - case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) -> - uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] } +upp_export [] = uppNil +upp_export names = uppBesides [uppStr "(", + uppIntersperse uppSP (map (upp_occname . getOccName) names), + uppStr ")"] + +upp_fixity (occ, Fixity prec dir, prov) = uppBesides [upp_dir dir, uppSP, + uppInt prec, uppSP, + upp_occname occ, uppSemi] +upp_dir InfixR = uppStr "infixr" +upp_dir InfixL = uppStr "infixl" +upp_dir InfixN = uppStr "infix" + +ppr_unqual_name :: NamedThing a => a -> Unpretty -- Just its occurrence name +ppr_unqual_name name = upp_occname (getOccName name) + +ppr_name :: NamedThing a => a -> Unpretty -- Its full name +ppr_name n = uppPStr (nameString (getName n)) + +upp_occname :: OccName -> Unpretty +upp_occname occ = uppPStr (occNameString occ) + +upp_module :: Module -> Unpretty +upp_module mod = uppPStr mod + +uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util + +ppr_ty ty = prettyToUn (pprType PprInterface ty) +ppr_tyvar tv = prettyToUn (ppr PprInterface tv) +ppr_tyvar_bndr tv = prettyToUn (pprTyVarBndr PprInterface tv) + +ppr_decl decl = prettyToUn (ppr PprInterface decl) `uppBeside` uppSemi + +renumber_ty ty = initNmbr (nmbrType ty) \end{code} + %************************************************************************ -%* * -\subsection{Printing tycons, classes, ...} -%* * +%* * +\subsection{Comparisons +%* * %************************************************************************ + -\begin{code} -ppr_class :: Class -> Unpretty - -ppr_class c - = --pprTrace "ppr_class:" (ppr PprDebug c) $ - case (initNmbr (nmbrClass c)) of { -- renumber it! - Class _ n tyvar super_classes sdsels ops sels defms insts links -> - - uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes, - ppr_name n, ppr_tyvar tyvar, - if null ops - then uppSemi - else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]] - } - where - ppr_context :: TyVar -> [Class] -> Unpretty +The various sorts above simply prevent unnecessary "wobbling" when +things change that don't have to. We therefore compare lexically, not +by unique - ppr_context tv [] = uppNil --- ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>")) - ppr_context tv super_classes - = uppBesides [uppStr "{{", - uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes), - uppStr "}} =>"] +\begin{code} +lt_avail :: AvailInfo -> AvailInfo -> Bool - ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv] +NotAvailable `lt_avail` (Avail _ _) = True +(Avail n1 _) `lt_avail` (Avail n2 _) = n1 `lt_name` n2 +any `lt_avail` NotAvailable = False - clas_mod = moduleOf (origName "ppr_class" c) +lt_name :: Name -> Name -> Bool +n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2 - ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty -\end{code} +lt_lexical :: NamedThing a => a -> a -> Bool +lt_lexical a1 a2 = getName a1 `lt_name` getName a2 -\begin{code} -ppr_val v ty -- renumber the type first! - = --pprTrace "ppr_val:" (ppr PprDebug v) $ - pp_sig v (initNmbr (nmbrType ty)) +lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool +lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2 -pp_sig op ty - = case (splitForAllTy ty) of { (tvs, rho_ty) -> - uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] } +sort_versions vs = sortLt lt_vers vs -ppr_forall [] = uppNil -ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ] +lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool +lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2 \end{code} + \begin{code} -ppr_tycon tycon - = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $ - ppr_tc (initNmbr (nmbrTyCon tycon)) - ------------------------- -ppr_tc (PrimTyCon _ n _ _) - = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ] - -ppr_tc FunTyCon - = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ] - -ppr_tc (TupleTyCon _ n _) - = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ] - -ppr_tc (SynTyCon _ n _ _ tvs expand) - = let - pp_tyvars = map ppr_tyvar tvs - in - uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars, - uppPStr SLIT(" = "), ppr_ty expand, uppSemi] - -ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) - = uppCat [pp_data_or_new, - ppr_context ctxt, - ppr_name n, - uppIntersperse uppSP (map ppr_tyvar tvs), - uppEquals, pp_condecls, - uppSemi] - -- NB: we do not print deriving info in interfaces - where - pp_data_or_new = case data_or_new of - DataType -> uppPStr SLIT("data") - NewType -> uppPStr SLIT("newtype") - - ppr_context [] = uppNil --- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")] - ppr_context cs - = uppBesides[uppStr "{{", - uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], - uppStr "}}", uppPStr SLIT(" =>")] - - pp_condecls - = let - (c:cs) = cons - in - uppCat ((ppr_con c) : (map ppr_next_con cs)) - - ppr_next_con con = uppCat [uppChar '|', ppr_con con] - - ppr_con con - = let - con_arg_tys = dataConRawArgTys con - labels = dataConFieldLabels con -- none if not a record - strict_marks = dataConStrictMarks con - in - uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys] - - ppr_fields labels strict_marks con_arg_tys - = if null labels then -- not a record thingy - uppIntersperse uppSP (zipWithEqual "ppr_fields" ppr_bang_ty strict_marks con_arg_tys) - else - uppCat [ uppChar '{', - uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys), - uppChar '}' ] - - ppr_bang_ty b t - = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }) - (prettyToUn (pprParendType PprInterface t)) - - ppr_field l b t - = uppBesides [ppr_name l, uppPStr SLIT(" :: "), - case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }, - ppr_ty t] +hPutCol :: Handle + -> (a -> Unpretty) + -> [a] + -> IO () +hPutCol hdl fmt xs = hPutStr hdl (uppShow 0 (uppAboves (map fmt xs))) >> + hPutStr hdl "\n" \end{code} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 223b015..864b2f3 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -19,7 +19,7 @@ import MachRegs import AbsCUtils ( getAmodeRep, mixedTypeLocn, nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList ) -import CgCompInfo ( mIN_UPD_SIZE ) +import Constants ( mIN_UPD_SIZE ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, closureUpdReqd ) diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index ef901f0..45e11d8 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -18,7 +18,7 @@ import MachMisc import MachRegs import AbsCSyn -- bits and bobs... -import CgCompInfo ( mIN_MP_INT_SIZE ) +import Constants ( mIN_MP_INT_SIZE ) import Literal ( Literal(..) ) import OrdList ( OrdList ) import PrimOp ( PrimOp(..) ) diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 419283c..664b2df 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -14,7 +14,7 @@ import MachMisc import MachRegs import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode ) -import CgCompInfo ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE, +import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE, sTD_UF_SIZE ) import OrdList ( OrdList ) diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 845078e..14bc255 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -15,7 +15,7 @@ import MachRegs import AbsCSyn import AbsCUtils ( getAmodeRep, mixedTypeLocn ) -import CgCompInfo ( spARelToInt, spBRelToInt ) +import Constants ( spARelToInt, spBRelToInt ) import CostCentre ( noCostCentreAttached ) import HeapOffs ( hpRelToInt, subOff ) import Literal ( Literal(..) ) diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index e112d0c..4b4523f 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -26,8 +26,8 @@ import PreludeGlaST # define PACK_BYTES _packCBytes #endif -import Name ( RdrName(..) ) -import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc, SrcLoc ) +import RdrHsSyn ( RdrName(..) ) +import SrcLoc ( mkSrcLoc, noSrcLoc, SrcLoc ) \end{code} \begin{code} @@ -47,7 +47,7 @@ thenUgn x y stuff initUgn :: UgnM a -> IO a initUgn action = let - do_it = action (SLIT(""),SLIT(""),mkUnknownSrcLoc) + do_it = action (SLIT(""),SLIT(""),noSrcLoc) in #if __GLASGOW_HASKELL__ >= 200 primIOToIO do_it @@ -105,7 +105,7 @@ mkSrcLocUgn :: U_long -> (SrcLoc -> UgnM a) -> UgnM a mkSrcLocUgn ln action (file,mod,_) = action loc (file,mod,loc) where - loc = mkSrcLoc2 file ln + loc = mkSrcLoc file ln getSrcLocUgn :: UgnM SrcLoc getSrcLocUgn stuff@(file,mod,loc) = returnUgn loc stuff diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index a0033b1..efac20b 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -461,8 +461,8 @@ NL [\n\r] %{ /* These SHOULDNAE work in "Code" (sigh) */ %} -{Id}"#" { - if (! nonstandardFlag) { +{Id}"#" { + if (! nonstandardFlag) { char errbuf[ERR_BUF_SIZE]; sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext); hsperror(errbuf); diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 04bd913..ed2bec5 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -7,20 +7,33 @@ #include "HsVersions.h" module PrelInfo ( - -- finite maps for built-in things (for the renamer and typechecker): - builtinNameInfo, builtinNameMaps, - builtinValNamesMap, builtinTcNamesMap, - builtinKeysMap, + builtinNames, builtinKeys, derivingOccurrences, SYN_IE(BuiltinNames), - SYN_IE(BuiltinKeys), SYN_IE(BuiltinIdInfos), - maybeCharLikeTyCon, maybeIntLikeTyCon + maybeCharLikeTyCon, maybeIntLikeTyCon, + + eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, compare_RDR, + minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, + enumFromThenTo_RDR, fromEnum_RDR, + range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR, + showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR, + eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, + eqH_Float_RDR, ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR, + geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR, and_RDR, not_RDR, append_RDR, + map_RDR, compose_RDR, mkInt_RDR, error_RDR, showString_RDR, showParen_RDR, readParen_RDR, + lex_RDR, showSpace_RDR, showList___RDR, readList___RDR, negate_RDR, + + numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, + monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR, + + needsDataDeclCtxtClassKeys, cCallishClassKeys, isNoDictClass, + isNumericClass, isStandardClass, isCcallishClass ) where IMP_Ubiq() -IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo ) -IMPORT_DELOOPER(IdLoop) ( SpecEnv ) +IMPORT_DELOOPER(PrelLoop) ( primOpName ) +-- IMPORT_DELOOPER(IdLoop) ( SpecEnv ) -- friends: import PrelMods -- Prelude module names @@ -31,16 +44,18 @@ import TysPrim -- TYPES import TysWiredIn -- others: -import FiniteMap ( FiniteMap, emptyFM, listToFM ) -import Id ( mkTupleCon, GenId, SYN_IE(Id) ) -import Maybes ( catMaybes ) -import Name ( origName, OrigName(..), Name ) -import RnHsSyn ( RnName(..) ) -import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) +import SpecEnv ( SpecEnv ) +import RdrHsSyn ( RdrName(..), varQual, tcQual, qual ) +import Id ( GenId, SYN_IE(Id) ) +import Name ( Name, OccName(..), DefnInfo(..), Provenance(..), + getName, mkGlobalName, modAndOcc ) +import Class ( Class(..), GenClass, classKey ) +import TyCon ( tyConDataCons, mkFunTyCon, TyCon ) import Type -import UniqFM ( UniqFM, emptyUFM, listToUFM ) +import Bag import Unique -- *Key stuff -import Util ( nOfThem, panic ) +import UniqFM ( UniqFM, listToUFM ) +import Util ( isIn ) \end{code} %************************************************************************ @@ -53,61 +68,29 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and @Classes@, the other to look up values. \begin{code} -builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos ) - -type BuiltinNames = (FiniteMap OrigName RnName, -- WiredIn Ids - FiniteMap OrigName RnName) -- WiredIn TyCons - -- Two maps because "[]" is in both... - -type BuiltinKeys = FiniteMap OrigName (Unique, Name -> RnName) - -- Names with known uniques - -type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids - -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 - assoc_val_wired - = concat [ - -- data constrs - concat (map pcDataConWiredInInfo g_con_tycons), - concat (map pcDataConWiredInInfo data_tycons), - - -- values - map pcIdWiredInInfo wired_in_ids, - primop_ids - ] - assoc_tc_wired - = concat [ - -- tycons - map pcTyConWiredInInfo prim_tycons, - map pcTyConWiredInInfo g_tycons, - map pcTyConWiredInInfo data_tycons - ] - - assoc_keys - = concat - [ - id_keys, - tysyn_keys, - class_keys, - class_op_keys - ] - - id_keys = map id_key id_keys_infos - id_key (str_mod, uniq, info) = (str_mod, (uniq, RnImplicit)) - - assoc_id_infos = catMaybes (map assoc_info id_keys_infos) - assoc_info (str_mod, uniq, Just info) = Just (uniq, info) - assoc_info (str_mod, uniq, Nothing) = Nothing +type BuiltinNames = Bag Name + +builtinNames :: BuiltinNames +builtinNames + = -- Wired in TyCons + unionManyBags (map getTyConNames wired_in_tycons) `unionBags` + + -- Wired in Ids + listToBag (map getName wired_in_ids) `unionBags` + + -- PrimOps + listToBag (map (getName.primOpName) allThePrimOps) `unionBags` + + -- Other names with magic keys + listToBag builtinKeys +\end{code} + + +\begin{code} +getTyConNames :: TyCon -> Bag Name +getTyConNames tycon + = getName tycon `consBag` listToBag (map getName (tyConDataCons tycon)) + -- Synonyms return empty list of constructors \end{code} @@ -115,8 +98,18 @@ We let a lot of "non-standard" values be visible, so that we can make sense of them in interface pragmas. It's cool, though they all have "non-standard" names, so they won't get past the parser in user code. -The WiredIn TyCons and DataCons ... +%************************************************************************ +%* * +\subsection{Wired in TyCons} +%* * +%************************************************************************ + + \begin{code} +wired_in_tycons = [mkFunTyCon] ++ + prim_tycons ++ + tuple_tycons ++ + data_tycons prim_tycons = [ addrPrimTyCon @@ -136,27 +129,12 @@ prim_tycons , wordPrimTyCon ] -g_tycons - = mkFunTyCon : g_con_tycons - -g_con_tycons - = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..37] ] - -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 - ] +tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ] data_tycons - = [ addrTyCon + = [ listTyCon + , addrTyCon , boolTyCon , charTyCon , doubleTyCon @@ -188,20 +166,37 @@ data_tycons , voidTyCon , wordTyCon ] + +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 + ] \end{code} +%************************************************************************ +%* * +\subsection{Wired in Ids} +%* * +%************************************************************************ + The WiredIn Ids ... ToDo: Some of these should be moved to id_keys_infos! + \begin{code} wired_in_ids = [ aBSENT_ERROR_ID , augmentId , buildId --- , copyableId , eRROR_ID , foldlId , foldrId --- , forkId , iRREFUT_PAT_ERROR_ID , integerMinusOneId , integerPlusOneId @@ -210,145 +205,288 @@ wired_in_ids , nON_EXHAUSTIVE_GUARDS_ERROR_ID , nO_DEFAULT_METHOD_ERROR_ID , nO_EXPLICIT_METHOD_ERROR_ID --- , noFollowId , pAR_ERROR_ID , pAT_ERROR_ID , packStringForCId --- , parAtAbsId --- , parAtForNowId --- , parAtId --- , parAtRelId --- , parGlobalId --- , parId --- , parLocalId , rEC_CON_ERROR_ID , rEC_UPD_ERROR_ID , realWorldPrimId , runSTId --- , seqId , tRACE_ID , unpackCString2Id , unpackCStringAppendId , unpackCStringFoldrId , unpackCStringId , voidId + +-- , copyableId +-- , forkId +-- , noFollowId +-- , parAtAbsId +-- , parAtForNowId +-- , parAtId +-- , parAtRelId +-- , parGlobalId +-- , parId +-- , parLocalId +-- , seqId ] +\end{code} -pcTyConWiredInInfo :: TyCon -> (OrigName, RnName) -pcTyConWiredInInfo tc = (origName "pcTyConWiredInInfo" tc, WiredInTyCon tc) -pcDataConWiredInInfo :: TyCon -> [(OrigName, RnName)] -pcDataConWiredInInfo tycon - = [ (origName "pcDataConWiredInInfo" con, WiredInId con) | con <- tyConDataCons tycon ] +%************************************************************************ +%* * +\subsection{Built-in keys} +%* * +%************************************************************************ -pcIdWiredInInfo :: Id -> (OrigName, RnName) -pcIdWiredInInfo id = (origName "pcIdWiredInInfo" id, WiredInId id) -\end{code} +Ids, Synonyms, Classes and ClassOps with builtin keys. -WiredIn primitive numeric operations ... \begin{code} -primop_ids - = map prim_fn allThePrimOps ++ map funny_fn funny_name_primops - where - prim_fn op = case (primOpNameInfo op) of (s,n) -> ((OrigName gHC_BUILTINS s),n) - funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((OrigName gHC_BUILTINS s),n) - -funny_name_primops - = [ (IntAddOp, SLIT("+#")) - , (IntSubOp, SLIT("-#")) - , (IntMulOp, SLIT("*#")) - , (IntGtOp, SLIT(">#")) - , (IntGeOp, SLIT(">=#")) - , (IntEqOp, SLIT("==#")) - , (IntNeOp, SLIT("/=#")) - , (IntLtOp, SLIT("<#")) - , (IntLeOp, SLIT("<=#")) - , (DoubleAddOp, SLIT("+##")) - , (DoubleSubOp, SLIT("-##")) - , (DoubleMulOp, SLIT("*##")) - , (DoubleDivOp, SLIT("/##")) - , (DoublePowerOp, SLIT("**##")) - , (DoubleGtOp, SLIT(">##")) - , (DoubleGeOp, SLIT(">=##")) - , (DoubleEqOp, SLIT("==##")) - , (DoubleNeOp, SLIT("/=##")) - , (DoubleLtOp, SLIT("<##")) - , (DoubleLeOp, SLIT("<=##")) +getKeyOrig :: (Module, OccName, Unique) -> Name +getKeyOrig (mod, occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit + +builtinKeys :: [Name] +builtinKeys + = map getKeyOrig + [ + -- Type constructors (synonyms especially) + (iO_BASE, TCOcc SLIT("IO"), iOTyConKey) + , (pREL_BASE, TCOcc SLIT("Ordering"), orderingTyConKey) + , (pREL_NUM, TCOcc SLIT("Rational"), rationalTyConKey) + , (pREL_NUM, TCOcc SLIT("Ratio"), ratioTyConKey) + + + -- Classes. *Must* include: + -- classes that are grabbed by key (e.g., eqClassKey) + -- classes in "Class.standardClassKeys" (quite a few) + , (pREL_BASE, TCOcc SLIT("Eq"), eqClassKey) -- mentioned, derivable + , (pREL_BASE, TCOcc SLIT("Eval"), evalClassKey) -- mentioned + , (pREL_BASE, TCOcc SLIT("Ord"), ordClassKey) -- derivable + , (pREL_BASE, TCOcc SLIT("Bounded"), boundedClassKey) -- derivable + , (pREL_BASE, TCOcc SLIT("Num"), numClassKey) -- mentioned, numeric + , (pREL_BASE, TCOcc SLIT("Enum"), enumClassKey) -- derivable + , (pREL_BASE, TCOcc SLIT("Monad"), monadClassKey) + , (pREL_BASE, TCOcc SLIT("MonadZero"), monadZeroClassKey) + , (pREL_BASE, TCOcc SLIT("MonadPlus"), monadPlusClassKey) + , (pREL_BASE, TCOcc SLIT("Functor"), functorClassKey) + , (pREL_BASE, TCOcc SLIT("Show"), showClassKey) -- derivable + , (pREL_NUM, TCOcc SLIT("Real"), realClassKey) -- numeric + , (pREL_NUM, TCOcc SLIT("Integral"), integralClassKey) -- numeric + , (pREL_NUM, TCOcc SLIT("Fractional"), fractionalClassKey) -- numeric + , (pREL_NUM, TCOcc SLIT("Floating"), floatingClassKey) -- numeric + , (pREL_NUM, TCOcc SLIT("RealFrac"), realFracClassKey) -- numeric + , (pREL_NUM, TCOcc SLIT("RealFloat"), realFloatClassKey) -- numeric + , (pREL_READ, TCOcc SLIT("Read"), readClassKey) -- derivable + , (iX, TCOcc SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) + , (fOREIGN, TCOcc SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish + , (fOREIGN, TCOcc SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish + + + -- ClassOps + , (pREL_BASE, VarOcc SLIT("fromInt"), fromIntClassOpKey) + , (pREL_BASE, VarOcc SLIT("fromInteger"), fromIntegerClassOpKey) + , (pREL_BASE, VarOcc SLIT("enumFrom"), enumFromClassOpKey) + , (pREL_BASE, VarOcc SLIT("enumFromThen"), enumFromThenClassOpKey) + , (pREL_BASE, VarOcc SLIT("enumFromTo"), enumFromToClassOpKey) + , (pREL_BASE, VarOcc SLIT("enumFromThenTo"), enumFromThenToClassOpKey) + , (pREL_BASE, VarOcc SLIT("fromEnum"), fromEnumClassOpKey) + , (pREL_BASE, VarOcc SLIT("=="), eqClassOpKey) + , (pREL_BASE, VarOcc SLIT(">>="), thenMClassOpKey) + , (pREL_BASE, VarOcc SLIT("zero"), zeroClassOpKey) + , (pREL_NUM, VarOcc SLIT("fromRational"), fromRationalClassOpKey) ] \end{code} +ToDo: make it do the ``like'' part properly (as in 0.26 and before). -Ids, Synonyms, Classes and ClassOps with builtin keys. -For the Ids we may also have some builtin IdInfo. \begin{code} -id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)] -id_keys_infos - = [ -- 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) - , (OrigName pRELUDE SLIT("readParen"), readParenIdKey, Nothing) - , (OrigName pRELUDE SLIT("showParen"), showParenIdKey, Nothing) - , (OrigName pRELUDE SLIT("showString"), showStringIdKey,Nothing) - , (OrigName gHC__ SLIT("readList__"), ureadListIdKey, Nothing) - , (OrigName gHC__ SLIT("showList__"), ushowListIdKey, Nothing) - , (OrigName gHC__ SLIT("showSpace"), showSpaceIdKey, Nothing) - ] +maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing +maybeIntLikeTyCon tc = if (uniqueOf tc == intDataConKey) then Just intDataCon else Nothing +\end{code} -tysyn_keys - = [ (OrigName gHC__ SLIT("IO"), (iOTyConKey, RnImplicitTyCon)) - , (OrigName pRELUDE SLIT("Ordering"), (orderingTyConKey, RnImplicitTyCon)) - , (OrigName rATIO SLIT("Rational"), (rationalTyConKey, RnImplicitTyCon)) - , (OrigName rATIO SLIT("Ratio"), (ratioTyConKey, RnImplicitTyCon)) - ] +%************************************************************************ +%* * +\subsection{Commonly-used RdrNames} +%* * +%************************************************************************ --- this "class_keys" list *must* include: --- classes that are grabbed by key (e.g., eqClassKey) --- classes in "Class.standardClassKeys" (quite a few) - -class_keys - = [ (str_mod, (k, RnImplicitClass)) | (str_mod,k) <- - [ (OrigName pRELUDE SLIT("Eq"), eqClassKey) -- mentioned, derivable - , (OrigName pRELUDE SLIT("Eval"), evalClassKey) -- mentioned - , (OrigName pRELUDE SLIT("Ord"), ordClassKey) -- derivable - , (OrigName pRELUDE SLIT("Num"), numClassKey) -- mentioned, numeric - , (OrigName pRELUDE SLIT("Real"), realClassKey) -- numeric - , (OrigName pRELUDE SLIT("Integral"), integralClassKey) -- numeric - , (OrigName pRELUDE SLIT("Fractional"), fractionalClassKey) -- numeric - , (OrigName pRELUDE SLIT("Floating"), floatingClassKey) -- numeric - , (OrigName pRELUDE SLIT("RealFrac"), realFracClassKey) -- numeric - , (OrigName pRELUDE SLIT("RealFloat"), realFloatClassKey) -- numeric - , (OrigName iX SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) - , (OrigName pRELUDE SLIT("Bounded"), boundedClassKey) -- derivable - , (OrigName pRELUDE SLIT("Enum"), enumClassKey) -- derivable - , (OrigName pRELUDE SLIT("Show"), showClassKey) -- derivable - , (OrigName pRELUDE SLIT("Read"), readClassKey) -- derivable - , (OrigName pRELUDE SLIT("Monad"), monadClassKey) - , (OrigName pRELUDE SLIT("MonadZero"), monadZeroClassKey) - , (OrigName pRELUDE SLIT("MonadPlus"), monadPlusClassKey) - , (OrigName pRELUDE SLIT("Functor"), functorClassKey) - , (OrigName gHC__ SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish - , (OrigName gHC__ SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish - ]] - -class_op_keys - = [ (str_mod, (k, RnImplicit)) | (str_mod,k) <- - [ (OrigName pRELUDE SLIT("fromInt"), fromIntClassOpKey) - , (OrigName pRELUDE SLIT("fromInteger"), fromIntegerClassOpKey) - , (OrigName pRELUDE SLIT("fromRational"), fromRationalClassOpKey) - , (OrigName pRELUDE SLIT("enumFrom"), enumFromClassOpKey) - , (OrigName pRELUDE SLIT("enumFromThen"), enumFromThenClassOpKey) - , (OrigName pRELUDE SLIT("enumFromTo"), enumFromToClassOpKey) - , (OrigName pRELUDE SLIT("enumFromThenTo"),enumFromThenToClassOpKey) - , (OrigName pRELUDE SLIT("=="), eqClassOpKey) - , (OrigName pRELUDE SLIT(">>="), thenMClassOpKey) - , (OrigName pRELUDE SLIT("zero"), zeroClassOpKey) - ]] +These RdrNames are not really "built in", but some parts of the compiler +(notably the deriving mechanism) need to mention their names, and it's convenient +to write them all down in one place. + +\begin{code} +prelude_primop op = qual (modAndOcc (primOpName op)) + +eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq")) +ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord")) +evalClass_RDR = tcQual (pREL_BASE, SLIT("Eval")) +monadZeroClass_RDR = tcQual (pREL_BASE, SLIT("MonadZero")) +enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum")) +numClass_RDR = tcQual (pREL_BASE, SLIT("Num")) +fractionalClass_RDR = tcQual (pREL_NUM, SLIT("Fractional")) +ccallableClass_RDR = tcQual (fOREIGN, SLIT("CCallable")) +creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable")) + +negate_RDR = varQual (pREL_BASE, SLIT("negate")) +eq_RDR = varQual (pREL_BASE, SLIT("==")) +ne_RDR = varQual (pREL_BASE, SLIT("/=")) +le_RDR = varQual (pREL_BASE, SLIT("<=")) +lt_RDR = varQual (pREL_BASE, SLIT("<")) +ge_RDR = varQual (pREL_BASE, SLIT(">=")) +gt_RDR = varQual (pREL_BASE, SLIT(">")) +ltTag_RDR = varQual (pREL_BASE, SLIT("LT")) +eqTag_RDR = varQual (pREL_BASE, SLIT("EQ")) +gtTag_RDR = varQual (pREL_BASE, SLIT("GT")) +max_RDR = varQual (pREL_BASE, SLIT("max")) +min_RDR = varQual (pREL_BASE, SLIT("min")) +compare_RDR = varQual (pREL_BASE, SLIT("compare")) +minBound_RDR = varQual (pREL_BASE, SLIT("minBound")) +maxBound_RDR = varQual (pREL_BASE, SLIT("maxBound")) +false_RDR = varQual (pREL_BASE, SLIT("False")) +true_RDR = varQual (pREL_BASE, SLIT("True")) +and_RDR = varQual (pREL_BASE, SLIT("&&")) +not_RDR = varQual (pREL_BASE, SLIT("not")) +compose_RDR = varQual (pREL_BASE, SLIT(".")) +append_RDR = varQual (pREL_BASE, SLIT("++")) +map_RDR = varQual (pREL_BASE, SLIT("map")) + +showList___RDR = varQual (pREL_BASE, SLIT("showList__")) +showsPrec_RDR = varQual (pREL_BASE, SLIT("showsPrec")) +showList_RDR = varQual (pREL_BASE, SLIT("showList")) +showSpace_RDR = varQual (pREL_BASE, SLIT("showSpace")) +showString_RDR = varQual (pREL_BASE, SLIT("showString")) +showParen_RDR = varQual (pREL_BASE, SLIT("showParen")) + +range_RDR = varQual (iX, SLIT("range")) +index_RDR = varQual (iX, SLIT("index")) +inRange_RDR = varQual (iX, SLIT("inRange")) + +readsPrec_RDR = varQual (pREL_READ, SLIT("readsPrec")) +readList_RDR = varQual (pREL_READ, SLIT("readList")) +readParen_RDR = varQual (pREL_READ, SLIT("readParen")) +lex_RDR = varQual (pREL_READ, SLIT("lex")) +readList___RDR = varQual (pREL_READ, SLIT("readList__")) + +fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum")) +enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom")) +enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo")) +enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen")) +enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo")) +plus_RDR = varQual (pREL_BASE, SLIT("+")) +times_RDR = varQual (pREL_BASE, SLIT("*")) +mkInt_RDR = varQual (pREL_BASE, SLIT("I#")) + +error_RDR = varQual (iO_BASE, SLIT("error")) + +eqH_Char_RDR = prelude_primop CharEqOp +ltH_Char_RDR = prelude_primop CharLtOp +eqH_Word_RDR = prelude_primop WordEqOp +ltH_Word_RDR = prelude_primop WordLtOp +eqH_Addr_RDR = prelude_primop AddrEqOp +ltH_Addr_RDR = prelude_primop AddrLtOp +eqH_Float_RDR = prelude_primop FloatEqOp +ltH_Float_RDR = prelude_primop FloatLtOp +eqH_Double_RDR = prelude_primop DoubleEqOp +ltH_Double_RDR = prelude_primop DoubleLtOp +eqH_Int_RDR = prelude_primop IntEqOp +ltH_Int_RDR = prelude_primop IntLtOp +geH_RDR = prelude_primop IntGeOp +leH_RDR = prelude_primop IntLeOp +minusH_RDR = prelude_primop IntSubOp + +intType_RDR = qual (modAndOcc intTyCon) \end{code} -ToDo: make it do the ``like'' part properly (as in 0.26 and before). +%************************************************************************ +%* * +\subsection[Class-std-groups]{Standard groups of Prelude classes} +%* * +%************************************************************************ + +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@TcDeriv@). + +@derivingOccurrences@ maps a class name to a list of the (qualified) occurrences +that will be mentioned by the derived code for the class when it is later generated. +We don't need to put in things that are WiredIn (because they are already mapped to their +correct name by the @NameSupply@. The class itself, and all its class ops, is +already flagged as an occurrence so we don't need to mention that either. + +@derivingOccurrences@ has an item for every derivable class, even if that item is empty, +because we treat lookup failure as indicating that the class is illegal in a deriving clause. + \begin{code} -maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing -maybeIntLikeTyCon tc = if (uniqueOf tc == intDataConKey) then Just intDataCon else Nothing +derivingOccurrences :: UniqFM [RdrName] +derivingOccurrences = listToUFM deriving_occ_info + +derivableClassKeys = map fst deriving_occ_info + +deriving_occ_info + = [ (eqClassKey, [intType_RDR, and_RDR, not_RDR]) + , (ordClassKey, [intType_RDR, compose_RDR]) + , (enumClassKey, [intType_RDR, map_RDR]) + , (evalClassKey, [intType_RDR]) + , (boundedClassKey, [intType_RDR]) + , (showClassKey, [intType_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR, + showParen_RDR, showSpace_RDR, showList___RDR]) + , (readClassKey, [intType_RDR, numClass_RDR, ordClass_RDR, append_RDR, + lex_RDR, readParen_RDR, readList___RDR]) + , (ixClassKey, [intType_RDR, numClass_RDR, and_RDR, map_RDR]) + ] + -- intType: Practically any deriving needs Int, either for index calculations, + -- or for taggery. + -- ordClass: really it's the methods that are actually used. + -- numClass: for Int literals +\end{code} + + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. + +\begin{code} +isCcallishClass, isNoDictClass, isNumericClass, isStandardClass :: Class -> Bool + +isNumericClass clas = classKey clas `is_elem` numericClassKeys +isStandardClass clas = classKey clas `is_elem` standardClassKeys +isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys +isNoDictClass clas = classKey clas `is_elem` noDictClassKeys +is_elem = isIn "is_X_Class" + +numericClassKeys + = [ numClassKey + , realClassKey + , integralClassKey + , fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] + +needsDataDeclCtxtClassKeys -- see comments in TcDeriv + = [ readClassKey + ] + +cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ] + +standardClassKeys + = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys + -- + -- We have to have "CCallable" and "CReturnable" in the standard + -- classes, so that if you go... + -- + -- _ccall_ foo ... 93{-numeric literal-} ... + -- + -- ... it can do The Right Thing on the 93. + +noDictClassKeys -- These classes are used only for type annotations; + -- they are not implemented by dictionaries, ever. + = cCallishClassKeys + -- I used to think that class Eval belonged in here, but + -- we really want functions with type (Eval a => ...) and that + -- means that we really want to pass a placeholder for an Eval + -- dictionary. The unit tuple is what we'll get if we leave things + -- alone, and that'll do for now. Could arrange to drop that parameter + -- in the end. \end{code} diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi index acf9a4e..ba1320a 100644 --- a/ghc/compiler/prelude/PrelLoop.lhi +++ b/ghc/compiler/prelude/PrelLoop.lhi @@ -7,8 +7,8 @@ import PreludePS ( _PackedString ) import Class ( GenClass ) import CoreUnfold ( mkMagicUnfolding, Unfolding ) -import IdUtils ( primOpNameInfo ) -import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName, ExportFlag ) +import IdUtils ( primOpName ) +import Name ( Name, ExportFlag ) import PrimOp ( PrimOp ) import RnHsSyn ( RnName ) import Type ( mkSigmaTy, mkFunTy, mkFunTys, GenType ) @@ -17,11 +17,9 @@ import Unique ( Unique ) import Usage ( GenUsage ) mkMagicUnfolding :: Unique -> Unfolding -mkPrimitiveName :: Unique -> OrigName -> Name -mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b mkFunTys :: [GenType a b] -> GenType a b -> GenType a b mkFunTy :: GenType a b -> GenType a b -> GenType a b -primOpNameInfo :: PrimOp -> (_PackedString, RnName) +primOpName :: PrimOp -> Name \end{code} diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 1d73db7..8d9a5ad 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -8,24 +8,32 @@ defined here so as to avod \begin{code} #include "HsVersions.h" -module PrelMods ( - gHC_BUILTINS, -- things that are really and truly primitive - pRELUDE, gHC__, - rATIO, iX, - modulesWithBuiltins - ) where +module PrelMods where CHK_Ubiq() -- debugging consistency check \end{code} \begin{code} +gHC__ = SLIT("GHC") -- Primitive types and values + pRELUDE = SLIT("Prelude") -gHC_BUILTINS = SLIT("GHCbuiltins") -- the truly-primitive things -gHC__ = SLIT("GHCbase") -- all GHC basics, add-ons, extras, everything - -- (which can be defined in Haskell) +pREL_BASE = SLIT("PrelBase") +pREL_READ = SLIT("PrelRead") +pREL_NUM = SLIT("PrelNum") +pREL_LIST = SLIT("PrelList") +pREL_TUP = SLIT("PrelTup") +pACKED_STRING= SLIT("PackedString") +cONC_BASE = SLIT("ConcBase") +iO_BASE = SLIT("IOBase") +mONAD = SLIT("Monad") rATIO = SLIT("Ratio") iX = SLIT("Ix") +sT_BASE = SLIT("STBase") +aRR_BASE = SLIT("ArrBase") +fOREIGN = SLIT("Foreign") -modulesWithBuiltins = [ gHC_BUILTINS, gHC__, pRELUDE, rATIO, iX ] +mAIN = SLIT("Main") +gHC_MAIN = SLIT("GHCmain") +gHC_ERR = SLIT("GHCerr") \end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 84fd4d9..c743362 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -10,7 +10,7 @@ module PrelVals where IMP_Ubiq() IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv ) -import Id ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals ) +import Id ( SYN_IE(Id), GenId, mkImported, mkTemplateLocals ) IMPORT_DELOOPER(PrelLoop) -- friends: @@ -23,7 +23,7 @@ import CmdLineOpts ( maybe_CompilingGhcInternals ) import CoreSyn -- quite a bit import IdInfo -- quite a bit import Literal ( mkMachInt ) -import Name ( ExportFlag(..) ) +import Name ( mkWiredInIdName ) import PragmaInfo import PrimOp ( PrimOp(..) ) import Type ( mkTyVarTy ) @@ -34,11 +34,11 @@ import Util ( panic ) \begin{code} -- only used herein: -pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id +pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id -pcMiscPrelId key m n ty info +pcMiscPrelId key mod occ ty info = let - name = mkWiredInName key (OrigName m n) ExportAll + name = mkWiredInIdName key mod occ imp imp = mkImported name ty info -- the usual case... in imp @@ -73,14 +73,14 @@ templates, but we don't ever expect to generate code for it. pc_bottoming_Id key mod name ty = pcMiscPrelId key mod name ty bottoming_info where - bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo + bottoming_info = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo -- these "bottom" out, no matter what their arguments eRROR_ID - = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy + = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy generic_ERROR_ID u n - = pc_bottoming_Id u SLIT("GHCerr") n errorTy + = pc_bottoming_Id u gHC_ERR n errorTy pAT_ERROR_ID = generic_ERROR_ID patErrorIdKey SLIT("patError") @@ -98,11 +98,11 @@ nO_EXPLICIT_METHOD_ERROR_ID = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError") aBSENT_ERROR_ID - = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr") + = pc_bottoming_Id absentErrorIdKey gHC_ERR SLIT("absentErr") (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) pAR_ERROR_ID - = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError") + = pcMiscPrelId parErrorIdKey gHC_ERR SLIT("parError") (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo openAlphaTy = mkTyVarTy openAlphaTyVar @@ -120,8 +120,8 @@ decide that the second argument is strict, evaluate that first (!!), and make a jolly old mess. \begin{code} tRACE_ID - = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy - (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) + = pcMiscPrelId traceIdKey iO_BASE SLIT("trace") traceTy + (noIdInfo `addSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) where traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy) \end{code} @@ -134,54 +134,55 @@ tRACE_ID \begin{code} packStringForCId - = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__") + = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pACKED_STRING SLIT("packCString#") (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo -------------------------------------------------------------------- unpackCStringId - = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS__") + = pcMiscPrelId unpackCStringIdKey pACKED_STRING SLIT("unpackCString#") (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo -- Andy says: --- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1) +-- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 1) -- but I don't like wired-in IdInfos (WDP) unpackCString2Id -- for cases when a string has a NUL in it - = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2__") + = pcMiscPrelId unpackCString2IdKey pACKED_STRING SLIT("unpackCString2#") (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy) noIdInfo -------------------------------------------------------------------- unpackCStringAppendId - = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__") + = pcMiscPrelId unpackCStringAppendIdKey pACKED_STRING SLIT("unpackAppendCString#") (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy) ((noIdInfo - {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-}) - `addInfo` mkArityInfo 2) + {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-}) + `addArityInfo` exactArity 2) unpackCStringFoldrId - = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__") + = pcMiscPrelId unpackCStringFoldrIdKey pACKED_STRING SLIT("unpackFoldrCString#") (mkSigmaTy [alphaTyVar] [] (mkFunTys [addrPrimTy{-a "char *" pointer-}, mkFunTys [charTy, alphaTy] alphaTy, alphaTy] alphaTy)) ((noIdInfo - {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-}) - `addInfo` mkArityInfo 3) + {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-}) + `addArityInfo` exactArity 3) \end{code} OK, this is Will's idea: we should have magic values for Integers 0, +1, +2, and -1 (go ahead, fire me): + \begin{code} integerZeroId - = pcMiscPrelId integerZeroIdKey gHC__ SLIT("integer_0") integerTy noIdInfo + = pcMiscPrelId integerZeroIdKey pREL_NUM SLIT("integer_0") integerTy noIdInfo integerPlusOneId - = pcMiscPrelId integerPlusOneIdKey gHC__ SLIT("integer_1") integerTy noIdInfo + = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo integerPlusTwoId - = pcMiscPrelId integerPlusTwoIdKey gHC__ SLIT("integer_2") integerTy noIdInfo + = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo integerMinusOneId - = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo + = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo \end{code} %************************************************************************ @@ -207,10 +208,10 @@ integerMinusOneId -} -seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq") +seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True seq_template)) where [x, y, z] = mkTemplateLocals [ @@ -242,10 +243,10 @@ seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq") par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; } -} -parId = pcMiscPrelId parIdKey gHC__ SLIT("par") +parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True par_template)) where [x, y, z] = mkTemplateLocals [ @@ -265,10 +266,10 @@ parId = pcMiscPrelId parIdKey gHC__ SLIT("par") {- _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; } -} -forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork") +forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True fork_template)) where [x, y, z] = mkTemplateLocals [ @@ -289,10 +290,10 @@ forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork") GranSim ones: \begin{code} {- OUT: -parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal") +parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True parLocal_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, x, y, z] @@ -313,10 +314,10 @@ parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) -parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal") +parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True parGlobal_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, x, y, z] @@ -338,11 +339,11 @@ parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal") (BindDefault z (Var y)))) -parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt") +parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy, gammaTy] gammaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True parAt_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, v, x, y, z] @@ -364,10 +365,10 @@ parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])] (BindDefault z (Var y)))) -parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs") +parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtAbs_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, v, x, y, z] @@ -389,10 +390,10 @@ parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) -parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel") +parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtRel_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, v, x, y, z] @@ -414,11 +415,11 @@ parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) -parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow") +parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy, gammaTy] gammaTy)) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtForNow_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, v, x, y, z] @@ -443,10 +444,10 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow") -- copyable and noFollow are currently merely hooks: they are translated into -- calls to the macros COPYABLE and NOFOLLOW -- HWL -copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable") +copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable") (mkSigmaTy [alphaTyVar] [] alphaTy) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True copyable_template)) where -- Annotations: x: closure that's tagged to by copyable [x, z] @@ -458,10 +459,10 @@ copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable") copyable_template = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] ) -noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow") +noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow") (mkSigmaTy [alphaTyVar] [] alphaTy) - (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template)) + (noIdInfo `addUnfoldInfo` (mkUnfolding True noFollow_template)) where -- Annotations: x: closure that's tagged to not follow [x, z] @@ -494,7 +495,7 @@ runST a m = case m _RealWorld (S# _RealWorld realWorld#) of We unfold always, just for simplicity: \begin{code} runSTId - = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info + = pcMiscPrelId runSTIdKey sT_BASE SLIT("runST") run_ST_ty id_info where s_tv = betaTyVar s = betaTy @@ -507,10 +508,10 @@ runSTId id_info = noIdInfo - `addInfo` mkArityInfo 1 - `addInfo` mkStrictnessInfo [WwStrict] Nothing - `addInfo` mkArgUsageInfo [ArgUsage 1] - -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template) + `addArityInfo` exactArity 1 + `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing + `addArgUsageInfo` mkArgUsageInfo [ArgUsage 1] + -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding True run_ST_template) -- see example below {- OUT: [m, t, r, wild] @@ -526,7 +527,7 @@ runSTId Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) ( Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) ( AlgAlts - [(mkTupleCon 2, [r, wild], Var r)] + [(pairDataCon, [r, wild], Var r)] NoDefault))) -} \end{code} @@ -564,13 +565,13 @@ All calls to @f@ will share a {\em single} array! End SLPJ 95/04. nasty as-is, change it back to a literal (@Literal@). \begin{code} realWorldPrimId - = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#") + = pcMiscPrelId realWorldPrimIdKey gHC__ SLIT("realWorld#") realWorldStatePrimTy noIdInfo \end{code} \begin{code} -voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo +voidId = pcMiscPrelId voidIdKey gHC__ SLIT("void") voidTy noIdInfo \end{code} %************************************************************************ @@ -581,12 +582,12 @@ voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo \begin{code} buildId - = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy + = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy ((((noIdInfo - {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-}) - `addInfo` mkStrictnessInfo [WwStrict] Nothing) - `addInfo` mkArgUsageInfo [ArgUsage 2]) - `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) + {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-}) + `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing) + `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2]) + `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) -- cheating, but since _build never actually exists ... where -- The type of this strange object is: @@ -626,11 +627,11 @@ mkBuild ty tv c n g expr \begin{code} augmentId - = pcMiscPrelId augmentIdKey SLIT("GHCerr") SLIT("augment") augmentTy + = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy (((noIdInfo - {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-}) - `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) - `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage]) + {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-}) + `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) + `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage]) -- cheating, but since _augment never actually exists ... where -- The type of this strange object is: @@ -643,7 +644,7 @@ augmentId \end{code} \begin{code} -foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr") +foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr") foldrTy idInfo where foldrTy = @@ -651,13 +652,13 @@ foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr") (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy) idInfo = (((((noIdInfo - {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-}) - `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) - `addInfo` mkArityInfo 3) - `addInfo` mkUpdateInfo [2,2,1]) - `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) + {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-}) + `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) + `addArityInfo` exactArity 3) + `addUpdateInfo` mkUpdateInfo [2,2,1]) + `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) -foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl") +foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl") foldlTy idInfo where foldlTy = @@ -665,11 +666,11 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl") (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy) idInfo = (((((noIdInfo - {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-}) - `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) - `addInfo` mkArityInfo 3) - `addInfo` mkUpdateInfo [2,2,1]) - `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy) + {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-}) + `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) + `addArityInfo` exactArity 3) + `addUpdateInfo` mkUpdateInfo [2,2,1]) + `addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy) -- A bit of magic goes no here. We translate appendId into ++, -- you have to be carefull when you actually compile append: @@ -686,15 +687,15 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl") -- {- OLD: doesn't apply with 1.3 appendId - = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo + = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo where appendTy = (mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy))) idInfo = (((noIdInfo - `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) - `addInfo` mkArityInfo 2) - `addInfo` mkUpdateInfo [1,2]) + `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) + `addArityInfo` exactArity 2) + `addUpdateInfo` mkUpdateInfo [1,2]) -} \end{code} diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 1e62e9c..0e522a4 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -36,7 +36,7 @@ import TysPrim import TysWiredIn import CStrings ( identToC ) -import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) +import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset ) import PprStyle ( codeStyle{-, PprStyle(..) ToDo:rm-} ) import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) @@ -702,12 +702,12 @@ primOpInfo CharNeOp = Compare SLIT("neChar#") charPrimTy primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy -primOpInfo IntGtOp = Compare SLIT("gtInt#") intPrimTy -primOpInfo IntGeOp = Compare SLIT("geInt#") intPrimTy -primOpInfo IntEqOp = Compare SLIT("eqInt#") intPrimTy -primOpInfo IntNeOp = Compare SLIT("neInt#") intPrimTy -primOpInfo IntLtOp = Compare SLIT("ltInt#") intPrimTy -primOpInfo IntLeOp = Compare SLIT("leInt#") intPrimTy +primOpInfo IntGtOp = Compare SLIT(">#") intPrimTy +primOpInfo IntGeOp = Compare SLIT(">=#") intPrimTy +primOpInfo IntEqOp = Compare SLIT("==#") intPrimTy +primOpInfo IntNeOp = Compare SLIT("/=#") intPrimTy +primOpInfo IntLtOp = Compare SLIT("<#") intPrimTy +primOpInfo IntLeOp = Compare SLIT("<=#") intPrimTy primOpInfo WordGtOp = Compare SLIT("gtWord#") wordPrimTy primOpInfo WordGeOp = Compare SLIT("geWord#") wordPrimTy @@ -730,12 +730,12 @@ primOpInfo FloatNeOp = Compare SLIT("neFloat#") floatPrimTy primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy -primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy -primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy -primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy -primOpInfo DoubleNeOp = Compare SLIT("neDouble#") doublePrimTy -primOpInfo DoubleLtOp = Compare SLIT("ltDouble#") doublePrimTy -primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy +primOpInfo DoubleGtOp = Compare SLIT(">##") doublePrimTy +primOpInfo DoubleGeOp = Compare SLIT(">=##") doublePrimTy +primOpInfo DoubleEqOp = Compare SLIT("==##") doublePrimTy +primOpInfo DoubleNeOp = Compare SLIT("/=##") doublePrimTy +primOpInfo DoubleLtOp = Compare SLIT("<##") doublePrimTy +primOpInfo DoubleLeOp = Compare SLIT("<=##") doublePrimTy \end{code} %************************************************************************ @@ -756,9 +756,9 @@ primOpInfo ChrOp = Coercing SLIT("chr#") intPrimTy charPrimTy %************************************************************************ \begin{code} -primOpInfo IntAddOp = Dyadic SLIT("plusInt#") intPrimTy -primOpInfo IntSubOp = Dyadic SLIT("minusInt#") intPrimTy -primOpInfo IntMulOp = Dyadic SLIT("timesInt#") intPrimTy +primOpInfo IntAddOp = Dyadic SLIT("+#") intPrimTy +primOpInfo IntSubOp = Dyadic SLIT("-#") intPrimTy +primOpInfo IntMulOp = Dyadic SLIT("*#") intPrimTy primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy @@ -851,10 +851,10 @@ primOpInfo FloatPowerOp = Dyadic SLIT("powerFloat#") floatPrimTy similar). \begin{code} -primOpInfo DoubleAddOp = Dyadic SLIT("plusDouble#") doublePrimTy -primOpInfo DoubleSubOp = Dyadic SLIT("minusDouble#") doublePrimTy -primOpInfo DoubleMulOp = Dyadic SLIT("timesDouble#") doublePrimTy -primOpInfo DoubleDivOp = Dyadic SLIT("divideDouble#") doublePrimTy +primOpInfo DoubleAddOp = Dyadic SLIT("+##") doublePrimTy +primOpInfo DoubleSubOp = Dyadic SLIT("-##") doublePrimTy +primOpInfo DoubleMulOp = Dyadic SLIT("*##") doublePrimTy +primOpInfo DoubleDivOp = Dyadic SLIT("/##") doublePrimTy primOpInfo DoubleNegOp = Monadic SLIT("negateDouble#") doublePrimTy primOpInfo Double2IntOp = Coercing SLIT("double2Int#") doublePrimTy intPrimTy @@ -875,7 +875,7 @@ primOpInfo DoubleAtanOp = Monadic SLIT("atanDouble#") doublePrimTy primOpInfo DoubleSinhOp = Monadic SLIT("sinhDouble#") doublePrimTy primOpInfo DoubleCoshOp = Monadic SLIT("coshDouble#") doublePrimTy primOpInfo DoubleTanhOp = Monadic SLIT("tanhDouble#") doublePrimTy -primOpInfo DoublePowerOp= Dyadic SLIT("powerDouble#") doublePrimTy +primOpInfo DoublePowerOp= Dyadic SLIT("**##") doublePrimTy \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 954659a..17ee58e 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -14,13 +14,13 @@ module TysPrim where IMP_Ubiq(){-uitous-} import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) -import Name ( mkPrimitiveName ) -import PrelMods ( gHC_BUILTINS ) +import Name ( mkWiredInTyConName ) import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) ) import Type ( applyTyCon, mkTyVarTys, mkTyConTy ) import TyVar ( GenTyVar(..), alphaTyVars ) import Usage ( usageOmega ) +import PrelMods ( gHC__ ) import Unique \end{code} @@ -40,10 +40,10 @@ alphaTys = mkTyVarTys alphaTyVars pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon pcPrimTyCon key str arity primrep - = mkPrimTyCon name (mk_kind arity) primrep + = the_tycon where - name = mkPrimitiveName key (OrigName gHC_BUILTINS str) - + name = mkWiredInTyConName key gHC__ str the_tycon + the_tycon = mkPrimTyCon name (mk_kind arity) primrep mk_kind 0 = mkUnboxedTypeKind mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1) @@ -111,17 +111,8 @@ We never manipulate values of type RealWorld; it's only used in the type system, to parameterise State#. \begin{code} -realWorldTy = applyTyCon realWorldTyCon [] -realWorldTyCon - = mkDataTyCon name mkBoxedTypeKind - [{-no tyvars-}] - [{-no context-}] - [{-no data cons!-}] -- we tell you *nothing* about this guy - [{-no derivings-}] - DataType - where - name = mkPrimitiveName realWorldTyConKey (OrigName gHC_BUILTINS SLIT("RealWorld")) - +realWorldTy = applyTyCon realWorldTyCon [] +realWorldTyCon = mk_no_constr_tycon realWorldTyConKey SLIT("RealWorld") realWorldStatePrimTy = mkStatePrimTy realWorldTy \end{code} @@ -137,17 +128,21 @@ defined in \tr{TysWiredIn.lhs}, not here. -- -- ) It's boxed; there is only one value of this -- type, namely "void", whose semantics is just bottom. -voidTy = mkTyConTy voidTyCon - -voidTyCon - = mkDataTyCon name mkBoxedTypeKind - [{-no tyvars-}] - [{-no context-}] - [{-no data cons!-}] - [{-no derivings-}] - DataType +voidTy = mkTyConTy voidTyCon +voidTyCon = mk_no_constr_tycon voidTyConKey SLIT("Void") +\end{code} + +\begin{code} +mk_no_constr_tycon key str + = the_tycon where - name = mkPrimitiveName voidTyConKey (OrigName gHC_BUILTINS SLIT("Void")) + name = mkWiredInTyConName key gHC__ str the_tycon + the_tycon = mkDataTyCon name mkBoxedTypeKind + [{-no tyvars-}] + [{-no context-}] + [{-no data cons!-}] -- we tell you *nothing* about this guy + [{-no derivings-}] + DataType \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 5b1e3d0..06c91a3 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -45,6 +45,7 @@ module TysWiredIn ( mkPrimIoTy, mkStateTy, mkStateTransformerTy, + tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon, mkTupleTy, nilDataCon, primIoTyCon, @@ -86,7 +87,7 @@ module TysWiredIn ( --import Kind IMP_Ubiq() -IMPORT_DELOOPER(TyLoop) ( mkDataCon, StrictnessMark(..) ) +IMPORT_DELOOPER(TyLoop) ( mkDataCon, mkTupleCon, StrictnessMark(..) ) IMPORT_DELOOPER(IdLoop) ( SpecEnv ) -- friends: @@ -95,15 +96,15 @@ import TysPrim -- others: import Kind ( mkBoxedTypeKind, mkArrowKind ) -import Name ( mkWiredInName, ExportFlag(..) ) -import SrcLoc ( mkBuiltinSrcLoc ) +import Name ( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr ) import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, NewOrData(..), TyCon ) -import Type ( mkTyConTy, applyTyCon, mkSigmaTy, - mkFunTy, maybeAppTyCon, +import Type ( mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys, + mkFunTy, mkFunTys, maybeAppTyCon, GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) ) -import TyVar ( tyVarKind, alphaTyVar, betaTyVar ) +import TyVar ( tyVarKind, alphaTyVars, alphaTyVar, betaTyVar ) +import Lex ( mkTupNameStr ) import Unique import Util ( assoc, panic ) @@ -124,25 +125,30 @@ pcDataTyCon = pc_tycon DataType pcNewTyCon = pc_tycon NewType pc_tycon new_or_data key mod str tyvars cons - = mkDataTyCon (mkWiredInName key (OrigName mod str) ExportAll) tycon_kind + = tycon + where + tycon = mkDataTyCon name tycon_kind tyvars [{-no context-}] cons [{-no derivings-}] new_or_data - where + name = mkWiredInTyConName key mod str tycon tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars pcSynTyCon key mod str kind arity tyvars expansion - = mkSynTyCon - (mkWiredInName key (OrigName mod str) ExportAll) - kind arity tyvars expansion + = tycon + where + tycon = mkSynTyCon name kind arity tyvars expansion + name = mkWiredInTyConName key mod str tycon pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id pcDataCon key mod str tyvars context arg_tys tycon specenv - = mkDataCon (mkWiredInName key (OrigName mod str) ExportAll) - [ NotMarkedStrict | a <- arg_tys ] - [ {- no labelled fields -} ] - tyvars context arg_tys tycon - -- specenv + = data_con + where + data_con = mkDataCon name + [ NotMarkedStrict | a <- arg_tys ] + [ {- no labelled fields -} ] + tyvars context arg_tys tycon + name = mkWiredInIdName key mod str data_con pcGenerateDataSpecs :: Type -> SpecEnv pcGenerateDataSpecs ty @@ -153,6 +159,45 @@ pcGenerateDataSpecs ty %************************************************************************ %* * +\subsection[TysWiredIn-tuples]{The tuple types} +%* * +%************************************************************************ + +\begin{code} +tupleTyCon :: Arity -> TyCon +tupleTyCon arity + = tycon + where + tycon = mkTupleTyCon uniq name arity + uniq = mkTupleTyConUnique arity + name = mkWiredInTyConName uniq mod_name (mkTupNameStr arity) tycon + mod_name | arity == 0 = pREL_BASE + | otherwise = pREL_TUP + +tupleCon :: Arity -> Id +tupleCon arity + = tuple_con + where + tuple_con = mkTupleCon arity name ty + uniq = mkTupleDataConUnique arity + name = mkWiredInIdName uniq mod_name (mkTupNameStr arity) tuple_con + mod_name | arity == 0 = pREL_BASE + | otherwise = pREL_TUP + ty = mkSigmaTy tyvars [] (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys)) + tyvars = take arity alphaTyVars + tyvar_tys = mkTyVarTys tyvars + tycon = tupleTyCon arity + +unitTyCon = tupleTyCon 0 +pairTyCon = tupleTyCon 2 + +unitDataCon = tupleCon 0 +pairDataCon = tupleCon 2 +\end{code} + + +%************************************************************************ +%* * \subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)} %* * %************************************************************************ @@ -160,8 +205,8 @@ pcGenerateDataSpecs ty \begin{code} charTy = mkTyConTy charTyCon -charTyCon = pcDataTyCon charTyConKey pRELUDE SLIT("Char") [] [charDataCon] -charDataCon = pcDataCon charDataConKey pRELUDE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv +charTyCon = pcDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [charDataCon] +charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv stringTy = mkListTy charTy -- convenience only \end{code} @@ -169,65 +214,65 @@ stringTy = mkListTy charTy -- convenience only \begin{code} intTy = mkTyConTy intTyCon -intTyCon = pcDataTyCon intTyConKey pRELUDE SLIT("Int") [] [intDataCon] -intDataCon = pcDataCon intDataConKey pRELUDE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv +intTyCon = pcDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [intDataCon] +intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv \end{code} \begin{code} wordTy = mkTyConTy wordTyCon -wordTyCon = pcDataTyCon wordTyConKey gHC__ SLIT("Word") [] [wordDataCon] +wordTyCon = pcDataTyCon wordTyConKey fOREIGN SLIT("Word") [] [wordDataCon] wordDataCon = pcDataCon wordDataConKey gHC__ SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv \end{code} \begin{code} addrTy = mkTyConTy addrTyCon -addrTyCon = pcDataTyCon addrTyConKey gHC__ SLIT("Addr") [] [addrDataCon] +addrTyCon = pcDataTyCon addrTyConKey fOREIGN SLIT("Addr") [] [addrDataCon] addrDataCon = pcDataCon addrDataConKey gHC__ SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv \end{code} \begin{code} floatTy = mkTyConTy floatTyCon -floatTyCon = pcDataTyCon floatTyConKey pRELUDE SLIT("Float") [] [floatDataCon] -floatDataCon = pcDataCon floatDataConKey pRELUDE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv +floatTyCon = pcDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [floatDataCon] +floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv \end{code} \begin{code} doubleTy = mkTyConTy doubleTyCon -doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE SLIT("Double") [] [doubleDataCon] -doubleDataCon = pcDataCon doubleDataConKey pRELUDE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv +doubleTyCon = pcDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [doubleDataCon] +doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv \end{code} \begin{code} mkStateTy ty = applyTyCon stateTyCon [ty] realWorldStateTy = mkStateTy realWorldTy -- a common use -stateTyCon = pcDataTyCon stateTyConKey gHC__ SLIT("State") alpha_tyvar [stateDataCon] +stateTyCon = pcDataTyCon stateTyConKey sT_BASE SLIT("State") alpha_tyvar [stateDataCon] stateDataCon - = pcDataCon stateDataConKey gHC__ SLIT("S#") + = pcDataCon stateDataConKey sT_BASE SLIT("S#") alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv \end{code} \begin{code} stablePtrTyCon - = pcDataTyCon stablePtrTyConKey gHC__ SLIT("StablePtr") + = pcDataTyCon stablePtrTyConKey fOREIGN SLIT("StablePtr") alpha_tyvar [stablePtrDataCon] where stablePtrDataCon - = pcDataCon stablePtrDataConKey gHC__ SLIT("StablePtr") + = pcDataCon stablePtrDataConKey fOREIGN SLIT("StablePtr") alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv \end{code} \begin{code} foreignObjTyCon - = pcDataTyCon foreignObjTyConKey gHC__ SLIT("ForeignObj") + = pcDataTyCon foreignObjTyConKey fOREIGN SLIT("ForeignObj") [] [foreignObjDataCon] where foreignObjDataCon - = pcDataCon foreignObjDataConKey gHC__ SLIT("ForeignObj") + = pcDataCon foreignObjDataConKey fOREIGN SLIT("ForeignObj") [] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv \end{code} @@ -242,27 +287,27 @@ foreignObjTyCon integerTy :: GenType t u integerTy = mkTyConTy integerTyCon -integerTyCon = pcDataTyCon integerTyConKey pRELUDE SLIT("Integer") [] [integerDataCon] +integerTyCon = pcDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [integerDataCon] -integerDataCon = pcDataCon integerDataConKey pRELUDE SLIT("J#") +integerDataCon = pcDataCon integerDataConKey pREL_BASE SLIT("J#") [] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv \end{code} And the other pairing types: \begin{code} return2GMPsTyCon = pcDataTyCon return2GMPsTyConKey - gHC__ SLIT("Return2GMPs") [] [return2GMPsDataCon] + pREL_NUM SLIT("Return2GMPs") [] [return2GMPsDataCon] return2GMPsDataCon - = pcDataCon return2GMPsDataConKey gHC__ SLIT("Return2GMPs") [] [] + = pcDataCon return2GMPsDataConKey pREL_NUM SLIT("Return2GMPs") [] [] [intPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon nullSpecEnv returnIntAndGMPTyCon = pcDataTyCon returnIntAndGMPTyConKey - gHC__ SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon] + pREL_NUM SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon] returnIntAndGMPDataCon - = pcDataCon returnIntAndGMPDataConKey gHC__ SLIT("ReturnIntAndGMP") [] [] + = pcDataCon returnIntAndGMPDataConKey pREL_NUM SLIT("ReturnIntAndGMP") [] [] [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon nullSpecEnv \end{code} @@ -281,118 +326,118 @@ We fish one of these \tr{StateAnd#} things with \begin{code} stateAndPtrPrimTyCon - = pcDataTyCon stateAndPtrPrimTyConKey gHC__ SLIT("StateAndPtr#") + = pcDataTyCon stateAndPtrPrimTyConKey sT_BASE SLIT("StateAndPtr#") alpha_beta_tyvars [stateAndPtrPrimDataCon] stateAndPtrPrimDataCon - = pcDataCon stateAndPtrPrimDataConKey gHC__ SLIT("StateAndPtr#") + = pcDataCon stateAndPtrPrimDataConKey sT_BASE SLIT("StateAndPtr#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] stateAndPtrPrimTyCon nullSpecEnv stateAndCharPrimTyCon - = pcDataTyCon stateAndCharPrimTyConKey gHC__ SLIT("StateAndChar#") + = pcDataTyCon stateAndCharPrimTyConKey sT_BASE SLIT("StateAndChar#") alpha_tyvar [stateAndCharPrimDataCon] stateAndCharPrimDataCon - = pcDataCon stateAndCharPrimDataConKey gHC__ SLIT("StateAndChar#") + = pcDataCon stateAndCharPrimDataConKey sT_BASE SLIT("StateAndChar#") alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy] stateAndCharPrimTyCon nullSpecEnv stateAndIntPrimTyCon - = pcDataTyCon stateAndIntPrimTyConKey gHC__ SLIT("StateAndInt#") + = pcDataTyCon stateAndIntPrimTyConKey sT_BASE SLIT("StateAndInt#") alpha_tyvar [stateAndIntPrimDataCon] stateAndIntPrimDataCon - = pcDataCon stateAndIntPrimDataConKey gHC__ SLIT("StateAndInt#") + = pcDataCon stateAndIntPrimDataConKey sT_BASE SLIT("StateAndInt#") alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy] stateAndIntPrimTyCon nullSpecEnv stateAndWordPrimTyCon - = pcDataTyCon stateAndWordPrimTyConKey gHC__ SLIT("StateAndWord#") + = pcDataTyCon stateAndWordPrimTyConKey sT_BASE SLIT("StateAndWord#") alpha_tyvar [stateAndWordPrimDataCon] stateAndWordPrimDataCon - = pcDataCon stateAndWordPrimDataConKey gHC__ SLIT("StateAndWord#") + = pcDataCon stateAndWordPrimDataConKey sT_BASE SLIT("StateAndWord#") alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy] stateAndWordPrimTyCon nullSpecEnv stateAndAddrPrimTyCon - = pcDataTyCon stateAndAddrPrimTyConKey gHC__ SLIT("StateAndAddr#") + = pcDataTyCon stateAndAddrPrimTyConKey sT_BASE SLIT("StateAndAddr#") alpha_tyvar [stateAndAddrPrimDataCon] stateAndAddrPrimDataCon - = pcDataCon stateAndAddrPrimDataConKey gHC__ SLIT("StateAndAddr#") + = pcDataCon stateAndAddrPrimDataConKey sT_BASE SLIT("StateAndAddr#") alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy] stateAndAddrPrimTyCon nullSpecEnv stateAndStablePtrPrimTyCon - = pcDataTyCon stateAndStablePtrPrimTyConKey gHC__ SLIT("StateAndStablePtr#") + = pcDataTyCon stateAndStablePtrPrimTyConKey fOREIGN SLIT("StateAndStablePtr#") alpha_beta_tyvars [stateAndStablePtrPrimDataCon] stateAndStablePtrPrimDataCon - = pcDataCon stateAndStablePtrPrimDataConKey gHC__ SLIT("StateAndStablePtr#") + = pcDataCon stateAndStablePtrPrimDataConKey fOREIGN SLIT("StateAndStablePtr#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]] stateAndStablePtrPrimTyCon nullSpecEnv stateAndForeignObjPrimTyCon - = pcDataTyCon stateAndForeignObjPrimTyConKey gHC__ SLIT("StateAndForeignObj#") + = pcDataTyCon stateAndForeignObjPrimTyConKey fOREIGN SLIT("StateAndForeignObj#") alpha_tyvar [stateAndForeignObjPrimDataCon] stateAndForeignObjPrimDataCon - = pcDataCon stateAndForeignObjPrimDataConKey gHC__ SLIT("StateAndForeignObj#") + = pcDataCon stateAndForeignObjPrimDataConKey fOREIGN SLIT("StateAndForeignObj#") alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []] stateAndForeignObjPrimTyCon nullSpecEnv stateAndFloatPrimTyCon - = pcDataTyCon stateAndFloatPrimTyConKey gHC__ SLIT("StateAndFloat#") + = pcDataTyCon stateAndFloatPrimTyConKey sT_BASE SLIT("StateAndFloat#") alpha_tyvar [stateAndFloatPrimDataCon] stateAndFloatPrimDataCon - = pcDataCon stateAndFloatPrimDataConKey gHC__ SLIT("StateAndFloat#") + = pcDataCon stateAndFloatPrimDataConKey sT_BASE SLIT("StateAndFloat#") alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy] stateAndFloatPrimTyCon nullSpecEnv stateAndDoublePrimTyCon - = pcDataTyCon stateAndDoublePrimTyConKey gHC__ SLIT("StateAndDouble#") + = pcDataTyCon stateAndDoublePrimTyConKey sT_BASE SLIT("StateAndDouble#") alpha_tyvar [stateAndDoublePrimDataCon] stateAndDoublePrimDataCon - = pcDataCon stateAndDoublePrimDataConKey gHC__ SLIT("StateAndDouble#") + = pcDataCon stateAndDoublePrimDataConKey sT_BASE SLIT("StateAndDouble#") alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy] stateAndDoublePrimTyCon nullSpecEnv \end{code} \begin{code} stateAndArrayPrimTyCon - = pcDataTyCon stateAndArrayPrimTyConKey gHC__ SLIT("StateAndArray#") + = pcDataTyCon stateAndArrayPrimTyConKey aRR_BASE SLIT("StateAndArray#") alpha_beta_tyvars [stateAndArrayPrimDataCon] stateAndArrayPrimDataCon - = pcDataCon stateAndArrayPrimDataConKey gHC__ SLIT("StateAndArray#") + = pcDataCon stateAndArrayPrimDataConKey aRR_BASE SLIT("StateAndArray#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy] stateAndArrayPrimTyCon nullSpecEnv stateAndMutableArrayPrimTyCon - = pcDataTyCon stateAndMutableArrayPrimTyConKey gHC__ SLIT("StateAndMutableArray#") + = pcDataTyCon stateAndMutableArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableArray#") alpha_beta_tyvars [stateAndMutableArrayPrimDataCon] stateAndMutableArrayPrimDataCon - = pcDataCon stateAndMutableArrayPrimDataConKey gHC__ SLIT("StateAndMutableArray#") + = pcDataCon stateAndMutableArrayPrimDataConKey aRR_BASE SLIT("StateAndMutableArray#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy] stateAndMutableArrayPrimTyCon nullSpecEnv stateAndByteArrayPrimTyCon - = pcDataTyCon stateAndByteArrayPrimTyConKey gHC__ SLIT("StateAndByteArray#") + = pcDataTyCon stateAndByteArrayPrimTyConKey aRR_BASE SLIT("StateAndByteArray#") alpha_tyvar [stateAndByteArrayPrimDataCon] stateAndByteArrayPrimDataCon - = pcDataCon stateAndByteArrayPrimDataConKey gHC__ SLIT("StateAndByteArray#") + = pcDataCon stateAndByteArrayPrimDataConKey aRR_BASE SLIT("StateAndByteArray#") alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy] stateAndByteArrayPrimTyCon nullSpecEnv stateAndMutableByteArrayPrimTyCon - = pcDataTyCon stateAndMutableByteArrayPrimTyConKey gHC__ SLIT("StateAndMutableByteArray#") + = pcDataTyCon stateAndMutableByteArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableByteArray#") alpha_tyvar [stateAndMutableByteArrayPrimDataCon] stateAndMutableByteArrayPrimDataCon - = pcDataCon stateAndMutableByteArrayPrimDataConKey gHC__ SLIT("StateAndMutableByteArray#") + = pcDataCon stateAndMutableByteArrayPrimDataConKey aRR_BASE SLIT("StateAndMutableByteArray#") alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty] stateAndMutableByteArrayPrimTyCon nullSpecEnv stateAndSynchVarPrimTyCon - = pcDataTyCon stateAndSynchVarPrimTyConKey gHC__ SLIT("StateAndSynchVar#") + = pcDataTyCon stateAndSynchVarPrimTyConKey cONC_BASE SLIT("StateAndSynchVar#") alpha_beta_tyvars [stateAndSynchVarPrimDataCon] stateAndSynchVarPrimDataCon - = pcDataCon stateAndSynchVarPrimDataConKey gHC__ SLIT("StateAndSynchVar#") + = pcDataCon stateAndSynchVarPrimDataConKey cONC_BASE SLIT("StateAndSynchVar#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy] stateAndSynchVarPrimTyCon nullSpecEnv \end{code} @@ -446,9 +491,9 @@ This is really just an ordinary synonym, except it is ABSTRACT. \begin{code} mkStateTransformerTy s a = applyTyCon stTyCon [s, a] -stTyCon = pcNewTyCon stTyConKey gHC__ SLIT("ST") alpha_beta_tyvars [stDataCon] +stTyCon = pcNewTyCon stTyConKey sT_BASE SLIT("ST") alpha_beta_tyvars [stDataCon] -stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST") +stDataCon = pcDataCon stDataConKey sT_BASE SLIT("ST") alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv where ty = mkFunTy (mkStateTy alphaTy) (mkTupleTy 2 [betaTy, mkStateTy alphaTy]) @@ -465,7 +510,7 @@ mkPrimIoTy a = mkStateTransformerTy realWorldTy a primIoTyCon = pcSynTyCon - primIoTyConKey gHC__ SLIT("PrimIO") + primIoTyConKey iO_BASE SLIT("PrimIO") (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind) 1 alpha_tyvar (mkPrimIoTy alphaTy) \end{code} @@ -521,10 +566,10 @@ primitive counterpart. \begin{code} boolTy = mkTyConTy boolTyCon -boolTyCon = pcDataTyCon boolTyConKey pRELUDE SLIT("Bool") [] [falseDataCon, trueDataCon] +boolTyCon = pcDataTyCon boolTyConKey pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon] -falseDataCon = pcDataCon falseDataConKey pRELUDE SLIT("False") [] [] [] boolTyCon nullSpecEnv -trueDataCon = pcDataCon trueDataConKey pRELUDE SLIT("True") [] [] [] boolTyCon nullSpecEnv +falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon nullSpecEnv +trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon nullSpecEnv \end{code} %************************************************************************ @@ -548,12 +593,12 @@ mkListTy ty = applyTyCon listTyCon [ty] alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty) -listTyCon = pcDataTyCon listTyConKey pRELUDE SLIT("[]") +listTyCon = pcDataTyCon listTyConKey pREL_BASE SLIT("[]") alpha_tyvar [nilDataCon, consDataCon] -nilDataCon = pcDataCon nilDataConKey pRELUDE SLIT("[]") alpha_tyvar [] [] listTyCon +nilDataCon = pcDataCon nilDataConKey pREL_BASE SLIT("[]") alpha_tyvar [] [] listTyCon (pcGenerateDataSpecs alphaListTy) -consDataCon = pcDataCon consDataConKey pRELUDE SLIT(":") +consDataCon = pcDataCon consDataConKey pREL_BASE SLIT(":") alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon (pcGenerateDataSpecs alphaListTy) -- Interesting: polymorphic recursion would help here. @@ -610,7 +655,7 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \begin{code} mkTupleTy :: Int -> [GenType t u] -> GenType t u -mkTupleTy arity tys = applyTyCon (mkTupleTyCon arity) tys +mkTupleTy arity tys = applyTyCon (tupleTyCon arity) tys unitTy = mkTupleTy 0 [] \end{code} @@ -644,10 +689,10 @@ isLiftTy ty alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty) liftTyCon - = pcDataTyCon liftTyConKey gHC__ SLIT("Lift") alpha_tyvar [liftDataCon] + = pcDataTyCon liftTyConKey pREL_BASE SLIT("Lift") alpha_tyvar [liftDataCon] liftDataCon - = pcDataCon liftDataConKey gHC__ SLIT("Lift") + = pcDataCon liftDataConKey pREL_BASE SLIT("Lift") alpha_tyvar [] alpha_ty liftTyCon ((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv` (mkSpecInfo [Just realWorldStatePrimTy] 0 bottom)) diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 635e245..bb2ede0 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -32,7 +32,7 @@ IMP_Ubiq(){-uitous-} import Id ( externallyVisibleId, GenId, SYN_IE(Id) ) import CStrings ( identToC, stringToC ) -import Name ( showRdr, getOccName, RdrName ) +import Name ( OccName, getOccString, moduleString ) import Pretty ( ppShow, prettyToUn ) import PprStyle ( PprStyle(..) ) import UniqSet @@ -393,7 +393,7 @@ uppCostCentre sty print_as_string cc basic_kind = do_caf is_caf ++ do_kind kind in if friendly_sty then - do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name)) + do_dupd is_dupd (basic_kind ++ ('/': moduleString mod_name) ++ ('/': _UNPK_ grp_name)) else basic_kind where @@ -407,8 +407,8 @@ uppCostCentre sty print_as_string cc do_id :: Id -> String do_id id = if print_as_string - then showRdr sty (getOccName id) -- use occ name - else showId sty id -- we really do + then getOccString id -- use occ name + else showId sty id -- we really do --------------- do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 89c4062..24e0fb3 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -38,7 +38,7 @@ import CostCentre -- lots of things import Id ( idType, mkSysLocal, emptyIdSet ) import Maybes ( maybeToBool ) import PprStyle -- ToDo: rm -import SrcLoc ( mkUnknownSrcLoc ) +import SrcLoc ( noSrcLoc ) import Type ( splitSigmaTy, getFunTy_maybe ) import UniqSupply ( getUnique, splitUniqSupply ) import Util ( removeDups, assertPanic ) @@ -301,7 +301,7 @@ boxHigherOrderArgs almost_expr args live_vars -- make a trivial let-binding for the top-level function getUniqueMM `thenMM` \ uniq -> let - new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc + new_var = mkSysLocal SLIT("ho") uniq var_type noSrcLoc in returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var ) else diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs index cd4d1b8..fdf9b11 100644 --- a/ghc/compiler/reader/PrefixSyn.lhs +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -55,7 +55,7 @@ data RdrBinding -- tell if its a Sig or a ClassOpSig, -- so we just save the pieces: | RdrTySig [RdrName] -- vars getting sigs - RdrNamePolyType -- the type + RdrNameHsType -- the type SrcLoc -- user pragmas come in in a Sig-ish way/form... diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index 2f22955..61da9a2 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -12,12 +12,11 @@ module PrefixToHs ( cvValSig, cvClassOpSig, cvInstDeclSig, + cvBinds, + cvMonoBindsAndSigs, cvMatches, - cvMonoBinds, - cvSepdBinds, - sepDeclsForTopBinds, - sepDeclsIntoSigsAndBinds + cvOtherDecls ) where IMP_Ubiq(){-uitous-} @@ -27,7 +26,7 @@ import HsSyn import RdrHsSyn import HsPragmas ( noGenPragmas, noClassOpPragmas ) -import SrcLoc ( mkSrcLoc2 ) +import SrcLoc ( mkSrcLoc ) import Util ( mapAndUnzip, panic, assertPanic ) \end{code} @@ -43,7 +42,7 @@ these conversion functions: cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter cvValSig (RdrTySig vars poly_ty src_loc) - = [ Sig v poly_ty noGenPragmas src_loc | v <- vars ] + = [ Sig v poly_ty src_loc | v <- vars ] cvClassOpSig (RdrTySig vars poly_ty src_loc) = [ ClassOpSig v poly_ty noClassOpPragmas src_loc | v <- vars ] @@ -66,36 +65,22 @@ analyser. \begin{code} cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds -cvBinds sf sig_cvtr raw_binding - = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding) - -cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> RdrNameHsBinds -cvSepdBinds sf sig_cvtr bindings - = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) -> +cvBinds sf sig_cvtr binding + = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) -> if (null sigs) then SingleBind (RecBind mbs) else BindWith (RecBind mbs) sigs } - -cvMonoBinds :: SrcFile -> [RdrBinding] -> RdrNameMonoBinds -cvMonoBinds sf bindings - = case (mkMonoBindsAndSigs sf bottom bindings) of { (mbs,sigs) -> - if (null sigs) - then mbs - else panic "cvMonoBinds: some sigs present" - } - where - bottom = panic "cvMonoBinds: sig converter!" \end{code} \begin{code} -mkMonoBindsAndSigs :: SrcFile +cvMonoBindsAndSigs :: SrcFile -> SigConverter - -> [RdrBinding] + -> RdrBinding -> (RdrNameMonoBinds, [RdrNameSig]) -mkMonoBindsAndSigs sf sig_cvtr fbs - = foldl mangle_bind (EmptyMonoBinds, []) fbs +cvMonoBindsAndSigs sf sig_cvtr fb + = mangle_bind (EmptyMonoBinds, []) fb where -- If the function being bound has at least one argument, then the -- guarded right hand sides of each pattern binding are knitted @@ -105,6 +90,9 @@ mkMonoBindsAndSigs sf sig_cvtr fbs -- function. Otherwise there is only one pattern, which is paired -- with a guarded right hand side. + mangle_bind acc (RdrAndBindings fb1 fb2) + = mangle_bind (mangle_bind acc fb1) fb2 + mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _) = (b_acc, s_acc ++ sig_cvtr sig) @@ -118,7 +106,7 @@ mkMonoBindsAndSigs sf sig_cvtr fbs -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings. = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) -> let - src_loc = mkSrcLoc2 sf good_srcline + src_loc = mkSrcLoc sf good_srcline in (b_acc `AndMonoBinds` PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc) @@ -136,15 +124,17 @@ mkMonoBindsAndSigs sf sig_cvtr fbs -- must be a function binding... = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) -> (b_acc `AndMonoBinds` - FunMonoBind var inf matches (mkSrcLoc2 sf srcline), s_acc) + FunMonoBind var inf matches (mkSrcLoc sf srcline), s_acc) } + + mangle_bind (b_acc, s_acc) other = (b_acc, s_acc) \end{code} \begin{code} cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds) cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding) - = (pat, [OtherwiseGRHS expr (mkSrcLoc2 sf srcline)], cvBinds sf cvValSig binding) + = (pat, [OtherwiseGRHS expr (mkSrcLoc sf srcline)], cvBinds sf cvValSig binding) cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding) = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding) @@ -189,11 +179,11 @@ cvMatch sf is_case rdr_match where (pat, binding, guarded_exprs) = case rdr_match of - RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)]) + RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)]) RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps) cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS -cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl) +cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl) \end{code} %************************************************************************ @@ -203,117 +193,16 @@ cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl) %************************************************************************ Separate declarations into all the various kinds: -\begin{display} -tys RdrTyDecl -ty "sigs" RdrSpecDataSig -classes RdrClassDecl -insts RdrInstDecl -inst "sigs" RdrSpecInstSig -defaults RdrDefaultDecl -binds RdrFunctionBinding RdrPatternBinding RdrTySig - RdrSpecValSig RdrInlineValSig RdrDeforestSig - RdrMagicUnfoldingSig -\end{display} - -This function isn't called directly; some other function calls it, -then checks that what it got is appropriate for that situation. -(Those functions follow...) - -\begin{code} -sepDecls (RdrTyDecl a) - tys tysigs classes insts instsigs defaults binds - = (a:tys,tysigs,classes,insts,instsigs,defaults,binds) - -sepDecls a@(RdrFunctionBinding _ _) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) - -sepDecls a@(RdrPatternBinding _ _) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) - --- RdrAndBindings catered for below... - -sepDecls (RdrClassDecl a) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,a:classes,insts,instsigs,defaults,binds) - -sepDecls (RdrInstDecl a) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,a:insts,instsigs,defaults,binds) - -sepDecls (RdrDefaultDecl a) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,a:defaults,binds) - -sepDecls a@(RdrTySig _ _ _) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) - -sepDecls a@(RdrSpecValSig _) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) - -sepDecls a@(RdrInlineValSig _) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) - -sepDecls a@(RdrDeforestSig _) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) - -sepDecls a@(RdrMagicUnfoldingSig _) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,defaults,a:binds) - -sepDecls (RdrSpecInstSig a) - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,a:instsigs,defaults,binds) - -sepDecls (RdrSpecDataSig a) - tys tysigs classes insts instsigs defaults binds - = (tys,a:tysigs,classes,insts,instsigs,defaults,binds) - -sepDecls RdrNullBind - tys tysigs classes insts instsigs defaults binds - = (tys,tysigs,classes,insts,instsigs,defaults,binds) - -sepDecls (RdrAndBindings bs1 bs2) - tys tysigs classes insts instsigs defaults binds - = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds) of { - (tys,tysigs,classes,insts,instsigs,defaults,binds) -> - sepDecls bs1 tys tysigs classes insts instsigs defaults binds - } -\end{code} \begin{code} -sepDeclsForTopBinds binding - = sepDecls binding [] [] [] [] [] [] [] - -sepDeclsForBinds binding - = case (sepDecls binding [] [] [] [] [] [] []) - of { (tys,tysigs,classes,insts,instsigs,defaults,binds) -> - ASSERT ((null tys) - && (null tysigs) - && (null classes) - && (null insts) - && (null instsigs) - && (null defaults)) - binds - } - -sepDeclsIntoSigsAndBinds binding - = case (sepDeclsForBinds binding) of { sigs_and_binds -> - foldr sep_stuff ([],[]) sigs_and_binds - } +cvOtherDecls :: RdrBinding -> [RdrNameHsDecl] +cvOtherDecls b + = go [] b where - sep_stuff s@(RdrTySig _ _ _) (sigs,defs) = (s:sigs,defs) - sep_stuff s@(RdrSpecValSig _) (sigs,defs) = (s:sigs,defs) - sep_stuff s@(RdrInlineValSig _) (sigs,defs) = (s:sigs,defs) - sep_stuff s@(RdrDeforestSig _) (sigs,defs) = (s:sigs,defs) - sep_stuff s@(RdrMagicUnfoldingSig _) (sigs,defs) = (s:sigs,defs) - sep_stuff d@(RdrFunctionBinding _ _) (sigs,defs) = (sigs,d:defs) - sep_stuff d@(RdrPatternBinding _ _) (sigs,defs) = (sigs,d:defs) - - + go acc (RdrAndBindings b1 b2) = go (go acc b1) b2 + go acc (RdrTyDecl d) = TyD d : acc + go acc (RdrClassDecl d) = ClD d : acc + go acc (RdrInstDecl d) = InstD d : acc + go acc (RdrDefaultDecl d) = DefD d : acc + go acc other = acc \end{code} diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 7b44b59..bd2f8e4 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -23,6 +23,7 @@ module RdrHsSyn ( SYN_IE(RdrNameGRHS), SYN_IE(RdrNameGRHSsAndBinds), SYN_IE(RdrNameHsBinds), + SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNameHsModule), SYN_IE(RdrNameIE), @@ -30,9 +31,8 @@ module RdrHsSyn ( SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameMatch), SYN_IE(RdrNameMonoBinds), - SYN_IE(RdrNameMonoType), SYN_IE(RdrNamePat), - SYN_IE(RdrNamePolyType), + SYN_IE(RdrNameHsType), SYN_IE(RdrNameQual), SYN_IE(RdrNameSig), SYN_IE(RdrNameSpecInstSig), @@ -45,15 +45,27 @@ module RdrHsSyn ( SYN_IE(RdrNameGenPragmas), SYN_IE(RdrNameInstancePragmas), SYN_IE(RdrNameCoreExpr), + extractHsTyVars, + + RdrName(..), + qual, varQual, tcQual, varUnqual, + dummyRdrVarName, dummyRdrTcName, + isUnqual, isQual, + showRdr, rdrNameOcc, + cmpRdr - getRawImportees, - getRawExportees ) where IMP_Ubiq() import HsSyn -import Name ( ExportFlag(..) ) +import Lex +import PrelMods ( pRELUDE ) +import Name ( ExportFlag(..), Module(..), pprModule, + OccName(..), pprOccName ) +import Pretty +import PprStyle ( PprStyle(..) ) +import Util ( cmpPString, panic, thenCmp ) \end{code} \begin{code} @@ -64,6 +76,7 @@ type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat type RdrNameClassOpSig = Sig RdrName type RdrNameConDecl = ConDecl RdrName type RdrNameContext = Context RdrName +type RdrNameHsDecl = HsDecl Fake Fake RdrName RdrNamePat type RdrNameSpecDataSig = SpecDataSig RdrName type RdrNameDefaultDecl = DefaultDecl RdrName type RdrNameFixityDecl = FixityDecl RdrName @@ -77,9 +90,8 @@ type RdrNameImportDecl = ImportDecl RdrName type RdrNameInstDecl = InstDecl Fake Fake RdrName RdrNamePat type RdrNameMatch = Match Fake Fake RdrName RdrNamePat type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat -type RdrNameMonoType = MonoType RdrName type RdrNamePat = InPat RdrName -type RdrNamePolyType = PolyType RdrName +type RdrNameHsType = HsType RdrName type RdrNameQual = Qualifier Fake Fake RdrName RdrNamePat type RdrNameSig = Sig RdrName type RdrNameSpecInstSig = SpecInstSig RdrName @@ -91,34 +103,101 @@ type RdrNameClassPragmas = ClassPragmas RdrName type RdrNameDataPragmas = DataPragmas RdrName type RdrNameGenPragmas = GenPragmas RdrName type RdrNameInstancePragmas = InstancePragmas RdrName -type RdrNameCoreExpr = UnfoldingCoreExpr RdrName +type RdrNameCoreExpr = GenCoreExpr RdrName RdrName RdrName RdrName +\end{code} + +@extractHsTyVars@ looks just for things that could be type variables. +It's used when making the for-alls explicit. + +\begin{code} +extractHsTyVars :: HsType RdrName -> [RdrName] +extractHsTyVars ty + = get ty [] + where + get (MonoTyApp con tys) acc = foldr get (insert con acc) tys + get (MonoListTy tc ty) acc = get ty acc + get (MonoTupleTy tc tys) acc = foldr get acc tys + get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc) + get (MonoDictTy cls ty) acc = get ty acc + get (MonoTyVar tv) acc = insert tv acc + get (HsPreForAllTy ctxt ty) acc = foldr (get . snd) (get ty acc) ctxt + get (HsForAllTy tvs ctxt ty) acc = filter (`notElem` locals) $ + foldr (get . snd) (get ty acc) ctxt + where + locals = map getTyVarName tvs + + insert (Qual _ _) acc = acc + insert (Unqual (TCOcc _)) acc = acc + insert other acc | other `elem` acc = acc + | otherwise = other : acc \end{code} + %************************************************************************ %* * -\subsection{Grabbing importees and exportees} +\subsection[RdrName]{The @RdrName@ datatype; names read from files} %* * %************************************************************************ \begin{code} -getRawImportees :: [RdrNameIE] -> [RdrName] -getRawExportees :: Maybe [RdrNameIE] -> ([(RdrName, ExportFlag)], [Module]) +data RdrName + = Unqual OccName + | Qual Module OccName -getRawImportees imps - = foldr do_imp [] imps - where - do_imp (IEVar n) acc = n:acc - do_imp (IEThingAbs n) acc = n:acc - do_imp (IEThingWith n _) acc = n:acc - do_imp (IEThingAll n) acc = n:acc - -getRawExportees Nothing = ([], []) -getRawExportees (Just exps) - = foldr do_exp ([],[]) exps - where - do_exp (IEVar n) (prs, mods) = ((n, ExportAll):prs, mods) - do_exp (IEThingAbs n) (prs, mods) = ((n, ExportAbs):prs, mods) - do_exp (IEThingAll n) (prs, mods) = ((n, ExportAll):prs, mods) - do_exp (IEThingWith n _) (prs, mods) = ((n, ExportAll):prs, mods) - do_exp (IEModuleContents n) (prs, mods) = (prs, n : mods) +qual (m,n) = Qual m n +tcQual (m,n) = Qual m (TCOcc n) +varQual (m,n) = Qual m (VarOcc n) + + -- This guy is used by the reader when HsSyn has a slot for + -- an implicit name that's going to be filled in by + -- the renamer. We can't just put "error..." because + -- we sometimes want to print out stuff after reading but + -- before renaming +dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY")) +dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY")) + +varUnqual n = Unqual (VarOcc n) + +isUnqual (Unqual _) = True +isUnqual (Qual _ _) = False + +isQual (Unqual _) = False +isQual (Qual _ _) = True + +cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2 +cmpRdr (Unqual n1) (Qual m2 n2) = LT_ +cmpRdr (Qual m1 n1) (Unqual n2) = GT_ +cmpRdr (Qual m1 n1) (Qual m2 n2) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2) + -- always compare module-names *second* + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Qual _ occ) = occ + +instance Text RdrName where -- debugging + showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn)) + +instance Eq RdrName where + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + +instance Ord RdrName where + a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + +instance Ord3 RdrName where + cmp = cmpRdr + +instance Outputable RdrName where + ppr sty (Unqual n) = pprOccName sty n + ppr sty (Qual m n) = ppBesides [pprModule sty m, ppStr ".", pprOccName sty n] + +instance NamedThing RdrName where -- Just so that pretty-printing of expressions works + getOccName = rdrNameOcc + getName = panic "no getName for RdrNames" + +showRdr sty rdr = ppShow 100 (ppr sty rdr) \end{code} + diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 9073270..2d10052 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -15,17 +15,19 @@ IMPORT_1_3(GHCio(stThen)) import UgenAll -- all Yacc parser gumpff... import PrefixSyn -- and various syntaxen. import HsSyn +import HsTypes ( HsTyVar(..) ) import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas ) import RdrHsSyn import PrefixToHs import ErrUtils ( addErrLoc, ghcExit ) import FiniteMap ( elemFM, FiniteMap ) -import Name ( RdrName(..), isRdrLexConOrSpecial, preludeQual ) +import Name ( RdrName(..), OccName(..) ) +import Lex ( isLexConId ) import PprStyle ( PprStyle(..) ) -import PrelMods ( pRELUDE ) +import PrelMods import Pretty -import SrcLoc ( mkBuiltinSrcLoc, SrcLoc ) +import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc ) import Util ( nOfThem, pprError, panic ) \end{code} @@ -56,16 +58,26 @@ wlkMaybe wlk_it (U_just x) \end{code} \begin{code} -rdQid :: ParseTree -> UgnM RdrName -rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid - -wlkQid :: U_qid -> UgnM RdrName -wlkQid (U_noqual name) - = returnUgn (Unqual name) -wlkQid (U_aqual mod name) - = returnUgn (Qual mod name) -wlkQid (U_gid n name) - = returnUgn (preludeQual name) +wlkTvId = wlkQid TvOcc +wlkTCId = wlkQid TCOcc +wlkVarId = wlkQid VarOcc +wlkDataId = wlkQid VarOcc +wlkEntId = wlkQid (\occ -> if isLexConId occ + then TCOcc occ + else VarOcc occ) + +wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName +wlkQid mk_occ_name (U_noqual name) + = returnUgn (Unqual (mk_occ_name name)) +wlkQid mk_occ_name (U_aqual mod name) + = returnUgn (Qual mod (mk_occ_name name)) + + -- I don't understand this one! It is what shows up when we meet (), [], or (,,,). +wlkQid mk_occ_name (U_gid n name) + = returnUgn (Unqual (mk_occ_name name)) + +rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid +rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid cvFlag :: U_long -> Bool cvFlag 0 = False @@ -108,36 +120,30 @@ rdModule wlkList rdFixOp hfixlist `thenUgn` \ fixities -> wlkBinding hmodlist `thenUgn` \ binding -> - case sepDeclsForTopBinds binding of - (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) -> - - returnUgn (modname, - HsModule modname + let + val_decl = ValD (add_main_sig modname (cvBinds srcfile cvValSig binding)) + other_decls = cvOtherDecls binding + in + returnUgn (modname, + HsModule modname (case srciface_version of { 0 -> Nothing; n -> Just n }) exports imports fixities - tydecls - tysigs - classdecls - instdecls - instsigs - defaultdecls - (add_main_sig modname (cvSepdBinds srcfile cvValSig binds)) - [{-no interface sigs yet-}] + (val_decl: other_decls) src_loc ) where add_main_sig modname binds - = if modname == SLIT("Main") then + = if modname == mAIN then let - s = Sig (Unqual SLIT("main")) (io_ty SLIT("IO")) noGenPragmas mkBuiltinSrcLoc + s = Sig (varUnqual SLIT("main")) (io_ty SLIT("IO")) mkGeneratedSrcLoc in add_sig binds s - else if modname == SLIT("GHCmain") then + else if modname == gHC_MAIN then let - s = Sig (Unqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) noGenPragmas mkBuiltinSrcLoc + s = Sig (varUnqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) mkGeneratedSrcLoc in add_sig binds s @@ -148,7 +154,7 @@ rdModule add_sig (BindWith b ss) s = BindWith b (s:ss) add_sig _ _ = panic "rdModule:add_sig" - io_ty t = HsForAllTy [] [] (MonoTyApp (Unqual t) [MonoTupleTy []]) + io_ty t = MonoTyApp (Unqual (TCOcc t)) [MonoTupleTy dummyRdrTcName []] \end{code} %************************************************************************ @@ -175,11 +181,11 @@ wlkExpr expr U_lsection lsexp lop -> -- left section wlkExpr lsexp `thenUgn` \ expr -> - wlkQid lop `thenUgn` \ op -> + wlkVarId lop `thenUgn` \ op -> returnUgn (SectionL expr (HsVar op)) U_rsection rop rsexp -> -- right section - wlkQid rop `thenUgn` \ op -> + wlkVarId rop `thenUgn` \ op -> wlkExpr rsexp `thenUgn` \ expr -> returnUgn (SectionR (HsVar op) expr) @@ -303,7 +309,7 @@ wlkExpr expr U_restr restre restrt -> -- expression with type signature wlkExpr restre `thenUgn` \ expr -> - wlkPolyType restrt `thenUgn` \ ty -> + wlkHsType restrt `thenUgn` \ ty -> returnUgn (ExprWithTySig expr ty) -------------------------------------------------------------- @@ -317,7 +323,7 @@ wlkExpr expr returnUgn (HsLit lit) U_ident n -> -- simple identifier - wlkQid n `thenUgn` \ var -> + wlkVarId n `thenUgn` \ var -> returnUgn (HsVar var) U_ap fun arg -> -- application @@ -326,18 +332,14 @@ wlkExpr expr returnUgn (HsApp expr1 expr2) U_infixap fun arg1 arg2 -> -- infix application - wlkQid fun `thenUgn` \ op -> + wlkVarId fun `thenUgn` \ op -> wlkExpr arg1 `thenUgn` \ expr1 -> wlkExpr arg2 `thenUgn` \ expr2 -> returnUgn (OpApp expr1 (HsVar op) expr2) U_negate nexp -> -- prefix negation wlkExpr nexp `thenUgn` \ expr -> - -- this is a hack - let - rdr = preludeQual SLIT("negate") - in - returnUgn (NegApp expr (HsVar rdr)) + returnUgn (NegApp expr (HsVar dummyRdrVarName)) U_llist llist -> -- explicit list wlkList rdExpr llist `thenUgn` \ exprs -> @@ -348,7 +350,7 @@ wlkExpr expr returnUgn (ExplicitTuple exprs) U_record con rbinds -> -- record construction - wlkQid con `thenUgn` \ rcon -> + wlkDataId con `thenUgn` \ rcon -> wlkList rdRbind rbinds `thenUgn` \ recbinds -> returnUgn (RecordCon (HsVar rcon) recbinds) @@ -373,7 +375,7 @@ wlkExpr expr rdRbind pt = rdU_tree pt `thenUgn` \ (U_rbind var exp) -> - wlkQid var `thenUgn` \ rvar -> + wlkVarId var `thenUgn` \ rvar -> wlkMaybe rdExpr exp `thenUgn` \ expr_maybe -> returnUgn ( case expr_maybe of @@ -398,7 +400,7 @@ wlkPat pat ) U_as avar as_pat -> -- "as" pattern - wlkQid avar `thenUgn` \ var -> + wlkVarId avar `thenUgn` \ var -> wlkPat as_pat `thenUgn` \ pat -> returnUgn (AsPatIn var pat) @@ -413,11 +415,11 @@ wlkPat pat returnUgn (LitPatIn lit) U_ident nn -> -- simple identifier - wlkQid nn `thenUgn` \ n -> + wlkVarId nn `thenUgn` \ n -> returnUgn ( - if isRdrLexConOrSpecial n - then ConPatIn n [] - else VarPatIn n + case rdrNameOcc n of + VarOcc occ | isLexConId occ -> ConPatIn n [] + other -> VarPatIn n ) U_ap l r -> -- "application": there's a list of patterns lurking here! @@ -455,7 +457,7 @@ wlkPat pat returnUgn (pat,acc) U_infixap fun arg1 arg2 -> -- infix pattern - wlkQid fun `thenUgn` \ op -> + wlkVarId fun `thenUgn` \ op -> wlkPat arg1 `thenUgn` \ pat1 -> wlkPat arg2 `thenUgn` \ pat2 -> returnUgn (ConOpPatIn pat1 op pat2) @@ -473,13 +475,13 @@ wlkPat pat returnUgn (TuplePatIn pats) U_record con rpats -> -- record destruction - wlkQid con `thenUgn` \ rcon -> + wlkDataId con `thenUgn` \ rcon -> wlkList rdRpat rpats `thenUgn` \ recpats -> returnUgn (RecPatIn rcon recpats) where rdRpat pt = rdU_tree pt `thenUgn` \ (U_rbind var pat) -> - wlkQid var `thenUgn` \ rvar -> + wlkVarId var `thenUgn` \ rvar -> wlkMaybe rdPat pat `thenUgn` \ pat_maybe -> returnUgn ( case pat_maybe of @@ -551,7 +553,7 @@ wlkBinding binding mkSrcLocUgn srcline $ \ src_loc -> wlkContext ntctxt `thenUgn` \ ctxt -> wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) -> - wlkList rdConDecl ntcon `thenUgn` \ con -> + wlkList rdConDecl ntcon `thenUgn` \ [con] -> wlkDerivings ntderivs `thenUgn` \ derivings -> returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc)) @@ -582,10 +584,7 @@ wlkBinding binding wlkBinding cbindw `thenUgn` \ binding -> getSrcFileUgn `thenUgn` \ sf -> let - (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding - - final_sigs = concat (map cvClassOpSig class_sigs) - final_methods = cvMonoBinds sf class_methods + (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding in returnUgn (RdrClassDecl (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc)) @@ -594,19 +593,17 @@ wlkBinding binding U_ibind ibindc iclas ibindi ibindw srcline -> mkSrcLocUgn srcline $ \ src_loc -> wlkContext ibindc `thenUgn` \ ctxt -> - wlkQid iclas `thenUgn` \ clas -> - wlkMonoType ibindi `thenUgn` \ inst_ty -> + wlkTCId iclas `thenUgn` \ clas -> + wlkMonoType ibindi `thenUgn` \ at_ty -> wlkBinding ibindw `thenUgn` \ binding -> getSrcModUgn `thenUgn` \ modname -> getSrcFileUgn `thenUgn` \ sf -> let - (ss, bs) = sepDeclsIntoSigsAndBinds binding - binds = cvMonoBinds sf bs - uprags = concat (map cvInstDeclSig ss) - ctxt_inst_ty = HsPreForAllTy ctxt inst_ty + (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding + inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty) in returnUgn (RdrInstDecl - (InstDecl clas ctxt_inst_ty binds True{-from here-} modname uprags noInstancePragmas src_loc)) + (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc)) -- "default" declaration U_dbind dbindts srcline -> @@ -625,7 +622,7 @@ wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName]) wlkDerivings (U_nothing) = returnUgn Nothing wlkDerivings (U_just pt) = rdU_list pt `thenUgn` \ ds -> - wlkList rdQid ds `thenUgn` \ derivs -> + wlkList rdTCId ds `thenUgn` \ derivs -> returnUgn (Just derivs) \end{code} @@ -633,55 +630,55 @@ wlkDerivings (U_just pt) -- type signature wlk_sig_thing (U_sbind sbindids sbindid srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkList rdQid sbindids `thenUgn` \ vars -> - wlkPolyType sbindid `thenUgn` \ poly_ty -> + wlkList rdVarId sbindids `thenUgn` \ vars -> + wlkHsType sbindid `thenUgn` \ poly_ty -> returnUgn (RdrTySig vars poly_ty src_loc) -- value specialisation user-pragma wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid uvar `thenUgn` \ var -> + wlkVarId uvar `thenUgn` \ var -> wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids -> returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc | (ty, using_id) <- tys_and_ids ]) where - rd_ty_and_id :: ParseTree -> UgnM (RdrNamePolyType, Maybe RdrName) + rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName) rd_ty_and_id pt = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) -> - wlkPolyType vspec_ty `thenUgn` \ ty -> - wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe -> + wlkHsType vspec_ty `thenUgn` \ ty -> + wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe -> returnUgn(ty, id_maybe) -- instance specialisation user-pragma wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid iclas `thenUgn` \ clas -> + wlkTCId iclas `thenUgn` \ clas -> wlkMonoType ispec_ty `thenUgn` \ ty -> returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc)) -- data specialisation user-pragma wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid itycon `thenUgn` \ tycon -> + wlkTCId itycon `thenUgn` \ tycon -> wlkList rdMonoType dspec_tys `thenUgn` \ tys -> returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc)) -- value inlining user-pragma wlk_sig_thing (U_inline_uprag ivar srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ivar `thenUgn` \ var -> + wlkVarId ivar `thenUgn` \ var -> returnUgn (RdrInlineValSig (InlineSig var src_loc)) -- "deforest me" user-pragma wlk_sig_thing (U_deforest_uprag ivar srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ivar `thenUgn` \ var -> + wlkVarId ivar `thenUgn` \ var -> returnUgn (RdrDeforestSig (DeforestSig var src_loc)) -- "magic" unfolding user-pragma wlk_sig_thing (U_magicuf_uprag ivar str srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ivar `thenUgn` \ var -> + wlkVarId ivar `thenUgn` \ var -> returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc)) \end{code} @@ -692,16 +689,16 @@ wlk_sig_thing (U_magicuf_uprag ivar str srcline) %************************************************************************ \begin{code} -rdPolyType :: ParseTree -> UgnM RdrNamePolyType -rdMonoType :: ParseTree -> UgnM RdrNameMonoType +rdHsType :: ParseTree -> UgnM RdrNameHsType +rdMonoType :: ParseTree -> UgnM RdrNameHsType -rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype +rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype -wlkPolyType :: U_ttype -> UgnM RdrNamePolyType -wlkMonoType :: U_ttype -> UgnM RdrNameMonoType +wlkHsType :: U_ttype -> UgnM RdrNameHsType +wlkMonoType :: U_ttype -> UgnM RdrNameHsType -wlkPolyType ttype +wlkHsType ttype = case ttype of U_context tcontextl tcontextt -> -- context wlkContext tcontextl `thenUgn` \ ctxt -> @@ -715,11 +712,11 @@ wlkPolyType ttype wlkMonoType ttype = case ttype of U_namedtvar tv -> -- type variable - wlkQid tv `thenUgn` \ tyvar -> + wlkTvId tv `thenUgn` \ tyvar -> returnUgn (MonoTyVar tyvar) U_tname tcon -> -- type constructor - wlkQid tcon `thenUgn` \ tycon -> + wlkTCId tcon `thenUgn` \ tycon -> returnUgn (MonoTyApp tycon []) U_tapp t1 t2 -> @@ -731,9 +728,9 @@ wlkMonoType ttype = case t of U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 -> collect t1 (ty2:acc) - U_tname tcon -> wlkQid tcon `thenUgn` \ tycon -> + U_tname tcon -> wlkTCId tcon `thenUgn` \ tycon -> returnUgn (tycon, acc) - U_namedtvar tv -> wlkQid tv `thenUgn` \ tyvar -> + U_namedtvar tv -> wlkTvId tv `thenUgn` \ tyvar -> returnUgn (tyvar, acc) U_tllist _ -> panic "tlist" U_ttuple _ -> panic "ttuple" @@ -744,11 +741,11 @@ wlkMonoType ttype U_tllist tlist -> -- list type wlkMonoType tlist `thenUgn` \ ty -> - returnUgn (MonoListTy ty) + returnUgn (MonoListTy dummyRdrTcName ty) U_ttuple ttuple -> wlkList rdMonoType ttuple `thenUgn` \ tys -> - returnUgn (MonoTupleTy tys) + returnUgn (MonoTupleTy dummyRdrTcName tys) U_tfun tfun targ -> wlkMonoType tfun `thenUgn` \ ty1 -> @@ -758,14 +755,14 @@ wlkMonoType ttype \end{code} \begin{code} -wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName]) +wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName]) wlkContext :: U_list -> UgnM RdrNameContext -wlkClassAssertTy :: U_ttype -> UgnM (RdrName, RdrName) +wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName) wlkTyConAndTyVars ttype = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) -> let - args = [ a | (MonoTyVar a) <- ty_args ] + args = [ UserTyVar a | (MonoTyVar a) <- ty_args ] in returnUgn (tycon, args) @@ -775,11 +772,13 @@ wlkContext list wlkClassAssertTy xs = wlkMonoType xs `thenUgn` \ mono_ty -> - returnUgn (mk_class_assertion mono_ty) + returnUgn (case mk_class_assertion mono_ty of + (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar) + ) -mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName) +mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType) -mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname) +mk_class_assertion (MonoTyApp name [ty@(MonoTyVar tyname)]) = (name, ty) mk_class_assertion other = pprError "ERROR: malformed type context: " (ppr PprForUser other) -- regrettably, the parser does let some junk past @@ -796,33 +795,33 @@ wlkConDecl :: U_constr -> UgnM RdrNameConDecl wlkConDecl (U_constrpre ccon ctys srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ccon `thenUgn` \ con -> + wlkDataId ccon `thenUgn` \ con -> wlkList rdBangType ctys `thenUgn` \ tys -> returnUgn (ConDecl con tys src_loc) wlkConDecl (U_constrinf cty1 cop cty2 srcline) = mkSrcLocUgn srcline $ \ src_loc -> wlkBangType cty1 `thenUgn` \ ty1 -> - wlkQid cop `thenUgn` \ op -> + wlkDataId cop `thenUgn` \ op -> wlkBangType cty2 `thenUgn` \ ty2 -> returnUgn (ConOpDecl ty1 op ty2 src_loc) wlkConDecl (U_constrnew ccon cty srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ccon `thenUgn` \ con -> + wlkDataId ccon `thenUgn` \ con -> wlkMonoType cty `thenUgn` \ ty -> returnUgn (NewConDecl con ty src_loc) wlkConDecl (U_constrrec ccon cfields srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ccon `thenUgn` \ con -> + wlkDataId ccon `thenUgn` \ con -> wlkList rd_field cfields `thenUgn` \ fields_lists -> returnUgn (RecConDecl con fields_lists src_loc) where rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName) rd_field pt = rdU_constr pt `thenUgn` \ (U_field fvars fty) -> - wlkList rdQid fvars `thenUgn` \ vars -> + wlkList rdVarId fvars `thenUgn` \ vars -> wlkBangType fty `thenUgn` \ ty -> returnUgn (vars, ty) @@ -832,9 +831,9 @@ rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty wlkBangType :: U_ttype -> UgnM (BangType RdrName) wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> - returnUgn (Banged (HsPreForAllTy [] ty)) + returnUgn (Banged ty) wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> - returnUgn (Unbanged (HsPreForAllTy [] ty)) + returnUgn (Unbanged ty) \end{code} %************************************************************************ @@ -851,7 +850,7 @@ rdMatch pt mkSrcLocUgn srcline $ \ src_loc -> wlkPat gpat `thenUgn` \ pat -> wlkBinding gbind `thenUgn` \ binding -> - wlkQid gsrcfun `thenUgn` \ srcfun -> + wlkVarId gsrcfun `thenUgn` \ srcfun -> let wlk_guards (U_pnoguards exp) = wlkExpr exp `thenUgn` \ expr -> @@ -881,12 +880,14 @@ rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl rdFixOp pt = rdU_tree pt `thenUgn` \ fix -> case fix of - U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op -> - returnUgn (InfixL op prec) - U_fixop op 0 prec -> wlkQid op `thenUgn` \ op -> - returnUgn (InfixN op prec) - U_fixop op 1 prec -> wlkQid op `thenUgn` \ op -> - returnUgn (InfixR op prec) + U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op -> + returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc) + -- ToDo: add SrcLoc! + where + dir = case dir_n of + (-1) -> InfixL + 0 -> InfixN + 1 -> InfixR _ -> error "ReadPrefix:rdFixOp" \end{code} @@ -926,21 +927,21 @@ rdEntity pt = rdU_entidt pt `thenUgn` \ entity -> case entity of U_entid evar -> -- just a value - wlkQid evar `thenUgn` \ var -> + wlkEntId evar `thenUgn` \ var -> returnUgn (IEVar var) U_enttype x -> -- abstract type constructor/class - wlkQid x `thenUgn` \ thing -> + wlkTCId x `thenUgn` \ thing -> returnUgn (IEThingAbs thing) U_enttypeall x -> -- non-abstract type constructor/class - wlkQid x `thenUgn` \ thing -> + wlkTCId x `thenUgn` \ thing -> returnUgn (IEThingAll thing) U_enttypenamed x ns -> -- non-abstract type constructor/class -- with specified constrs/methods - wlkQid x `thenUgn` \ thing -> - wlkList rdQid ns `thenUgn` \ names -> + wlkTCId x `thenUgn` \ thing -> + wlkList rdVarId ns `thenUgn` \ names -> returnUgn (IEThingWith thing names) U_entmod mod -> -- everything provided unqualified by a module diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 30083ff..1f6e831 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -5,22 +5,29 @@ module ParseIface ( parseIface ) where IMP_Ubiq(){-uitous-} -import ParseUtils - import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms -import HsPragmas ( noGenPragmas ) +import HsDecls ( HsIdInfo(..) ) +import HsTypes ( mkHsForAllTy ) +import HsCore +import Literal +import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) +import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, + ArgUsageInfo, FBTypeInfo + ) +import Kind ( Kind, mkArrowKind, mkTypeKind ) +import Lex +import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), + SYN_IE(RdrNamePragma), SYN_IE(ExportItem) + ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import Name ( ExportFlag(..), mkTupNameStr, preludeQual, - RdrName(..){-instance Outputable:ToDo:rm-} - ) ---import Outputable -- ToDo:rm ---import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging +import Name ( OccName(..), Provenance ) import SrcLoc ( mkIfaceSrcLoc ) import Util ( panic{-, pprPanic ToDo:rm-} ) + ----------------------------------------------------------------- parseIface = parseIToks . lexIface @@ -45,13 +52,13 @@ parseIface = parseIToks . lexIface BANG { ITbang } CBRACK { ITcbrack } CCURLY { ITccurly } - DCCURLY { ITdccurly } CLASS { ITclass } COMMA { ITcomma } CPAREN { ITcparen } DARROW { ITdarrow } DATA { ITdata } DCOLON { ITdcolon } + DERIVING { ITderiving } DOTDOT { ITdotdot } EQUAL { ITequal } FORALL { ITforall } @@ -62,7 +69,6 @@ parseIface = parseIToks . lexIface NEWTYPE { ITnewtype } OBRACK { ITobrack } OCURLY { ITocurly } - DOCURLY { ITdocurly } OPAREN { IToparen } RARROW { ITrarrow } SEMI { ITsemi } @@ -78,318 +84,410 @@ parseIface = parseIToks . lexIface QCONID { ITqconid $$ } QVARSYM { ITqvarsym $$ } QCONSYM { ITqconsym $$ } + + ARITY_PART { ITarity } + STRICT_PART { ITstrict } + UNFOLD_PART { ITunfold } + DEMAND { ITdemand $$ } + BOTTOM { ITbottom } + LAM { ITlam } + BIGLAM { ITbiglam } + CASE { ITcase } + OF { ITof } + LET { ITlet } + LETREC { ITletrec } + IN { ITin } + COERCE_IN { ITcoerce_in } + COERCE_OUT { ITcoerce_out } + CHAR { ITchar $$ } + STRING { ITstring $$ } %% iface :: { ParsedIface } iface : INTERFACE CONID INTEGER - usages_part versions_part - exports_part inst_modules_part - fixities_part decls_part instances_part pragmas_part - { case $9 of { (tm, vm) -> - ParsedIface $2 (panic "merge modules") (fromInteger $3) Nothing{-src version-} - $4 -- usages - $5 -- local versions - $6 -- exports map - $7 -- instance modules - $8 -- fixities map - tm -- decls maps - vm - $10 -- local instances - $11 -- pragmas map + inst_modules_part + usages_part + exports_part fixities_part + instances_part + decls_part + { ParsedIface + $2 -- Module name + (fromInteger $3) -- Module version + $5 -- Usages + $6 -- Exports + $4 -- Instance modules + $7 -- Fixities + $9 -- Decls + $8 -- Local instances } + + +usages_part :: { [ImportVersion OccName] } +usages_part : USAGES_PART module_stuff_pairs { $2 } + | { [] } + +module_stuff_pairs :: { [ImportVersion OccName] } +module_stuff_pairs : { [] } + | module_stuff_pair module_stuff_pairs { $1 : $2 } + +module_stuff_pair :: { ImportVersion OccName } +module_stuff_pair : mod_name INTEGER DCOLON name_version_pairs SEMI + { ($1, fromInteger $2, $4) } + +versions_part :: { [LocalVersion OccName] } +versions_part : VERSIONS_PART name_version_pairs { $2 } + | { [] } + +name_version_pairs :: { [LocalVersion OccName] } +name_version_pairs : { [] } + | name_version_pair name_version_pairs { $1 : $2 } + +name_version_pair :: { LocalVersion OccName } +name_version_pair : entity_occ INTEGER { ($1, fromInteger $2) -------------------------------------------------------------------------- - } - -usages_part :: { UsagesMap } -usages_part : USAGES_PART module_stuff_pairs { bagToFM $2 } - | { emptyFM } - -versions_part :: { VersionsMap } -versions_part : VERSIONS_PART name_version_pairs { bagToFM $2 } - | { emptyFM } - -module_stuff_pairs :: { Bag (Module, (Version, FiniteMap FAST_STRING Version)) } -module_stuff_pairs : module_stuff_pair - { unitBag $1 } - | module_stuff_pairs module_stuff_pair - { $1 `snocBag` $2 } - -module_stuff_pair :: { (Module, (Version, FiniteMap FAST_STRING Version)) } -module_stuff_pair : CONID INTEGER DCOLON name_version_pairs SEMI - { ($1, (fromInteger $2, bagToFM $4)) } - -name_version_pairs :: { Bag (FAST_STRING, Int) } -name_version_pairs : name_version_pair - { unitBag $1 } - | name_version_pairs name_version_pair - { $1 `snocBag` $2 } - -name_version_pair :: { (FAST_STRING, Int) } -name_version_pair : name INTEGER - { ($1, fromInteger $2) --------------------------------------------------------------------------- - } + } -exports_part :: { ExportsMap } -exports_part : EXPORTS_PART export_items { bagToFM $2 } - | { emptyFM } +exports_part :: { [ExportItem] } +exports_part : EXPORTS_PART export_items { $2 } + | { [] } -export_items :: { Bag (FAST_STRING, (OrigName, ExportFlag)) } -export_items : export_item { unitBag $1 } - | export_items export_item { $1 `snocBag` $2 } +export_items :: { [ExportItem] } +export_items : { [] } + | export_item export_items { $1 : $2 } -export_item :: { (FAST_STRING, (OrigName, ExportFlag)) } -export_item : CONID name maybe_dotdot { ($2, (OrigName $1 $2, $3)) } +export_item :: { ExportItem } +export_item : mod_name entity_occ maybe_dotdot { ($1, $2, $3) } -maybe_dotdot :: { ExportFlag } -maybe_dotdot : DOTDOT { ExportAll } - | { ExportAbs +maybe_dotdot :: { [OccName] } +maybe_dotdot : { [] } + | OPAREN val_occs CPAREN { $2 -------------------------------------------------------------------------- - } + } -inst_modules_part :: { Bag Module } -inst_modules_part : INSTANCE_MODULES_PART mod_list { $2 } - | { emptyBag } +inst_modules_part :: { [Module] } +inst_modules_part : { [] } + | INSTANCE_MODULES_PART mod_list { $2 } -mod_list :: { Bag Module } -mod_list : CONID { unitBag $1 } - | mod_list CONID { $1 `snocBag` $2 +mod_list :: { [Module] } +mod_list : { [] } + | mod_name mod_list { $1 : $2 -------------------------------------------------------------------------- - } + } -fixities_part :: { FixitiesMap } -fixities_part : FIXITIES_PART fixes { $2 } - | { emptyFM } +fixities_part :: { [(OccName,Fixity)] } +fixities_part : { [] } + | FIXITIES_PART fixes { $2 } -fixes :: { FixitiesMap } -fixes : fix { case $1 of (k,v) -> unitFM k v } - | fixes fix { case $2 of (k,v) -> addToFM $1 k v } +fixes :: { [(OccName,Fixity)] } +fixes : { [] } + | fix fixes { $1 : $2 } -fix :: { (FAST_STRING, RdrNameFixityDecl) } -fix : INFIXL INTEGER qname SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) } - | INFIXR INTEGER qname SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) } - | INFIX INTEGER qname SEMI { (de_qual $3, InfixN $3 (fromInteger $2)) +fix :: { (OccName, Fixity) } +fix : INFIXL INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixL) } + | INFIXR INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixR) } + | INFIX INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixN) -------------------------------------------------------------------------- - } - -decls_part :: { (LocalTyDefsMap, LocalValDefsMap) } -decls_part : DECLARATIONS_PART topdecls { $2 } - | { (emptyFM, emptyFM) } - -topdecls :: { (LocalTyDefsMap, LocalValDefsMap) } -topdecls : topdecl { $1 } - | topdecls topdecl { case $1 of { (ts1, vs1) -> - case $2 of { (ts2, vs2) -> - (plusFM ts1 ts2, plusFM vs1 vs2)}} - } - -topdecl :: { (LocalTyDefsMap, LocalValDefsMap) } -topdecl : typed SEMI { ($1, emptyFM) } - | datad SEMI { $1 } - | newtd SEMI { $1 } - | classd SEMI { $1 } - | decl { case $1 of { (n, Sig qn ty _ loc) -> - (emptyFM, unitFM n (ValSig qn loc ty)) } - } - -typed :: { LocalTyDefsMap } -typed : TYPE simple EQUAL type { mk_type $2 $4 } - -datad :: { (LocalTyDefsMap, LocalValDefsMap) } -datad : DATA simple EQUAL constrs { mk_data [] $2 $4 } - | DATA context DARROW simple EQUAL constrs { mk_data $2 $4 $6 } - -newtd :: { (LocalTyDefsMap, LocalValDefsMap) } -newtd : NEWTYPE simple EQUAL constr1 { mk_new [] $2 $4 } - | NEWTYPE context DARROW simple EQUAL constr1 { mk_new $2 $4 $6 } - -classd :: { (LocalTyDefsMap, LocalValDefsMap) } -classd : CLASS class cbody { mk_class [] $2 $3 } - | CLASS context DARROW class cbody { mk_class $2 $4 $5 } - -cbody :: { [(FAST_STRING, RdrNameSig)] } -cbody : WHERE OCURLY decls CCURLY { $3 } - | { [] } - -decls :: { [(FAST_STRING, RdrNameSig)] } -decls : decl { [$1] } - | decls decl { $1 ++ [$2] } - -decl :: { (FAST_STRING, RdrNameSig) } -decl : var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) } + } + +decls_part :: { [(Version, RdrNameHsDecl)] } +decls_part : { [] } + | DECLARATIONS_PART topdecls { $2 } + +topdecls :: { [(Version, RdrNameHsDecl)] } +topdecls : { [] } + | version topdecl topdecls { ($1,$2) : $3 } + +version :: { Version } +version : INTEGER { fromInteger $1 } + +topdecl :: { RdrNameHsDecl } +topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI + { TyD (TySynonym $2 $3 $5 mkIfaceSrcLoc) } + | DATA decl_context tc_name tv_bndrs EQUAL constrs deriving SEMI + { TyD (TyData $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) } + | NEWTYPE decl_context tc_name tv_bndrs EQUAL constr1 deriving SEMI + { TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) } + | CLASS decl_context tc_name tv_bndr csigs SEMI + { ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) } + | var_name DCOLON ctype id_info SEMI + { SigD (IfaceSig $1 $3 $4 mkIfaceSrcLoc) } + +decl_context :: { RdrNameContext } +decl_context : { [] } + | OCURLY context_list1 CCURLY DARROW { $2 } + +csigs :: { [RdrNameSig] } +csigs : { [] } + | WHERE OCURLY csigs1 CCURLY { $3 } + +csigs1 :: { [RdrNameSig] } +csigs1 : csig { [$1] } + | csig SEMI csigs1 { $1 : $3 } + +csig :: { RdrNameSig } +csig : var_name DCOLON ctype { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc +---------------------------------------------------------------- + } + +constrs :: { [RdrNameConDecl] } +constrs : constr { [$1] } + | constr VBAR constrs { $1 : $3 } + +constr :: { RdrNameConDecl } +constr : data_name batypes { ConDecl $1 $2 mkIfaceSrcLoc } + | data_name OCURLY fields1 CCURLY { RecConDecl $1 $3 mkIfaceSrcLoc } + +constr1 :: { RdrNameConDecl {- For a newtype -} } +constr1 : data_name atype { NewConDecl $1 $2 mkIfaceSrcLoc } + +deriving :: { Maybe [RdrName] } + : { Nothing } + | DERIVING OPAREN qtc_names1 CPAREN { Just $3 } + +batypes :: { [RdrNameBangType] } +batypes : { [] } + | batype batypes { $1 : $2 } + +batype :: { RdrNameBangType } +batype : atype { Unbanged $1 } + | BANG atype { Banged $2 } + +fields1 :: { [([RdrName], RdrNameBangType)] } +fields1 : field { [$1] } + | field COMMA fields1 { $1 : $3 } + +field :: { ([RdrName], RdrNameBangType) } +field : var_name DCOLON ctype { ([$1], Unbanged $3) } + | var_name DCOLON BANG ctype { ([$1], Banged $4) +-------------------------------------------------------------------------- + } + +forall :: { [HsTyVar RdrName] } +forall : OBRACK tv_bndrs CBRACK { $2 } context :: { RdrNameContext } -context : DOCURLY context_list DCCURLY { reverse $2 } - -context_list :: { RdrNameContext{-reversed-} } -context_list : class { [$1] } - | context_list COMMA class { $3 : $1 } - -class :: { (RdrName, RdrName) } -class : gtycon VARID { ($1, Unqual $2) } - -ctype :: { RdrNamePolyType } -ctype : FORALL OBRACK tyvars CBRACK context DARROW type { HsForAllTy (map Unqual $3) $5 $7 } - | FORALL OBRACK tyvars CBRACK type { HsForAllTy (map Unqual $3) [] $5 } - | type { HsForAllTy [] [] $1 } - -type :: { RdrNameMonoType } -type : btype { $1 } - | btype RARROW type { MonoFunTy $1 $3 } - -types :: { [RdrNameMonoType] } -types : type { [$1] } - | types COMMA type { $1 ++ [$3] } - -btype :: { RdrNameMonoType } -btype : gtyconapp { case $1 of (tc, tys) -> MonoTyApp tc tys } - | ntyconapp { case $1 of { (ty1, tys) -> - if null tys - then ty1 - else - case ty1 of { - MonoTyVar tv -> MonoTyApp tv tys; - MonoTyApp tc ts -> MonoTyApp tc (ts++tys); - MonoFunTy t1 t2 -> MonoTyApp (preludeQual SLIT("->")) (t1:t2:tys); - MonoListTy ty -> MonoTyApp (preludeQual SLIT("[]")) (ty:tys); - MonoTupleTy ts -> MonoTyApp (preludeQual (mkTupNameStr (length ts))) - (ts++tys); --- _ -> pprPanic "test:" (ppr PprDebug $1) - }} - } +context : { [] } + | OCURLY context_list1 CCURLY { $2 } -ntyconapp :: { (RdrNameMonoType, [RdrNameMonoType]) } -ntyconapp : ntycon { ($1, []) } - | ntyconapp atype { case $1 of (t1,tys) -> (t1, tys ++ [$2]) } +context_list1 :: { RdrNameContext } +context_list1 : class { [$1] } + | class COMMA context_list1 { $1 : $3 } -gtyconapp :: { (RdrName, [RdrNameMonoType]) } -gtyconapp : gtycon { ($1, []) } - | gtyconapp atype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) } +class :: { (RdrName, RdrNameHsType) } +class : qtc_name atype { ($1, $2) } -atype :: { RdrNameMonoType } -atype : gtycon { MonoTyApp $1 [] } - | ntycon { $1 } +ctype :: { RdrNameHsType } +ctype : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } + | type { $1 } -atypes :: { [RdrNameMonoType] } -atypes : atype { [$1] } - | atypes atype { $1 ++ [$2] } +type :: { RdrNameHsType } +type : btype { $1 } + | btype RARROW type { MonoFunTy $1 $3 } -ntycon :: { RdrNameMonoType } -ntycon : VARID { MonoTyVar (Unqual $1) } - | OPAREN type COMMA types CPAREN { MonoTupleTy ($2 : $4) } - | OBRACK type CBRACK { MonoListTy $2 } - | OPAREN type CPAREN { $2 } +ctypes2 :: { [RdrNameHsType] {- Two or more -} } +ctypes2 : ctype COMMA ctype { [$1,$3] } + | ctype COMMA ctypes2 { $1 : $3 } -gtycon :: { RdrName } -gtycon : QCONID { $1 } - | OPAREN RARROW CPAREN { preludeQual SLIT("->") } - | OBRACK CBRACK { preludeQual SLIT("[]") } - | OPAREN CPAREN { preludeQual SLIT("()") } - | OPAREN commas CPAREN { preludeQual (mkTupNameStr $2) } +btype :: { RdrNameHsType } +btype : atype { $1 } + | qtc_name atypes1 { MonoTyApp $1 $2 } + | tv_name atypes1 { MonoTyApp $1 $2 } -commas :: { Int } -commas : COMMA { 2{-1 comma => arity 2-} } - | commas COMMA { $1 + 1 } +atype :: { RdrNameHsType } +atype : qtc_name { MonoTyApp $1 [] } + | tv_name { MonoTyVar $1 } + | OPAREN ctypes2 CPAREN { MonoTupleTy dummyRdrTcName $2 } + | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } + | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } + | OPAREN ctype CPAREN { $2 } -simple :: { (RdrName, [FAST_STRING]) } -simple : gtycon { ($1, []) } - | gtyconvars { case $1 of (tc,tvs) -> (tc, reverse tvs) } +atypes1 :: { [RdrNameHsType] {- One or more -} } +atypes1 : atype { [$1] } + | atype atypes1 { $1 : $2 +--------------------------------------------------------------------- + } -gtyconvars :: { (RdrName, [FAST_STRING] {-reversed-}) } -gtyconvars : gtycon VARID { ($1, [$2]) } - | gtyconvars VARID { case $1 of (tc,tvs) -> (tc, $2 : tvs) } +mod_name :: { Module } + : CONID { $1 } -constrs :: { [(RdrName, RdrNameConDecl)] } -constrs : constr { [$1] } - | constrs VBAR constr { $1 ++ [$3] } +var_occ :: { OccName } +var_occ : VARID { VarOcc $1 } + | VARSYM { VarOcc $1 } + | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} } -constr :: { (RdrName, RdrNameConDecl) } -constr : btyconapp - { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) } - | QCONSYM { ($1, ConDecl $1 [] mkIfaceSrcLoc) } - | QCONSYM batypes { ($1, ConDecl $1 $2 mkIfaceSrcLoc) } - | gtycon OCURLY fields CCURLY - { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) } +entity_occ :: { OccName } +entity_occ : var_occ { $1 } + | CONID { TCOcc $1 } + | CONSYM { TCOcc $1 } -btyconapp :: { (RdrName, [RdrNameBangType]) } -btyconapp : gtycon { ($1, []) } - | btyconapp batype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) } +val_occ :: { OccName } +val_occ : var_occ { $1 } + | CONID { VarOcc $1 } + | CONSYM { VarOcc $1 } -batype :: { RdrNameBangType } -batype : atype { Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $1) } - | BANG atype { Banged (HsForAllTy [{-ToDo:tvs-}] [] $2) } +val_occs :: { [OccName] } + : { [] } + | val_occ val_occs { $1 : $2 } -batypes :: { [RdrNameBangType] } -batypes : batype { [$1] } - | batypes batype { $1 ++ [$2] } -fields :: { [([RdrName], RdrNameBangType)] } -fields : field { [$1] } - | fields COMMA field { $1 ++ [$3] } +qvar_name :: { RdrName } + : QVARID { varQual $1 } + | QVARSYM { varQual $1 } -field :: { ([RdrName], RdrNameBangType) } -field : var DCOLON type { ([$1], Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $3)) } - | var DCOLON BANG atype { ([$1], Banged (HsForAllTy [{-ToDo:tvs-}] [] $4)) } - -constr1 :: { (RdrName, RdrNameMonoType) } -constr1 : gtycon atype { ($1, $2) } - -var :: { RdrName } -var : QVARID { $1 } - | QVARSYM { $1 } - -qname :: { RdrName } -qname : QVARID { $1 } - | QCONID { $1 } - | QVARSYM { $1 } - | QCONSYM { $1 } - -name :: { FAST_STRING } -name : VARID { $1 } - | CONID { $1 } - | VARSYM { $1 } - | BANG { SLIT("!"){-sigh, double-sigh-} } - | CONSYM { $1 } - | OBRACK CBRACK { SLIT("[]") } - | OPAREN CPAREN { SLIT("()") } - | OPAREN commas CPAREN { mkTupNameStr $2 } - -instances_part :: { Bag RdrIfaceInst } +var_name :: { RdrName } +var_name : var_occ { Unqual $1 } + + +qdata_name :: { RdrName } +qdata_name : QCONID { varQual $1 } + | QCONSYM { varQual $1 } + +data_name :: { RdrName } +data_name : CONID { Unqual (VarOcc $1) } + | CONSYM { Unqual (VarOcc $1) } + + +qtc_name :: { RdrName } +qtc_name : QCONID { tcQual $1 } + +qtc_names1 :: { [RdrName] } + : qtc_name { [$1] } + | qtc_name COMMA qtc_names1 { $1 : $3 } + +tc_name :: { RdrName } +tc_name : CONID { Unqual (TCOcc $1) } + + +tv_name :: { RdrName } +tv_name : VARID { Unqual (TvOcc $1) } + +tv_names :: { [RdrName] } + : { [] } + | tv_name tv_names { $1 : $2 } + +tv_bndr :: { HsTyVar RdrName } +tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 } + | tv_name { UserTyVar $1 } + +tv_bndrs :: { [HsTyVar RdrName] } + : { [] } + | tv_bndr tv_bndrs { $1 : $2 } + +kind :: { Kind } + : akind { $1 } + | akind RARROW kind { mkArrowKind $1 $3 } + +akind :: { Kind } + : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} } + | OPAREN kind CPAREN { $2 +-------------------------------------------------------------------------- + } + + +instances_part :: { [RdrNameInstDecl] } instances_part : INSTANCES_PART instdecls { $2 } - | { emptyBag } - -instdecls :: { Bag RdrIfaceInst } -instdecls : instd { unitBag $1 } - | instdecls instd { $1 `snocBag` $2 } - -instd :: { RdrIfaceInst } -instd : INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (map Unqual $4) $6 $8 $9 } - | INSTANCE FORALL OBRACK tyvars CBRACK gtycon general_inst SEMI { mk_inst (map Unqual $4) [] $6 $7 } - | INSTANCE gtycon general_inst SEMI { mk_inst [] [] $2 $3 } - -restrict_inst :: { RdrNameMonoType } -restrict_inst : gtycon { MonoTyApp $1 [] } - | OPAREN gtyconvars CPAREN { case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono (reverse tvs)) } - | OPAREN VARID COMMA tyvars CPAREN { MonoTupleTy (map en_mono ($2:$4)) } - | OBRACK VARID CBRACK { MonoListTy (en_mono $2) } - | OPAREN VARID RARROW VARID CPAREN { MonoFunTy (en_mono $2) (en_mono $4) } - -general_inst :: { RdrNameMonoType } -general_inst : gtycon { MonoTyApp $1 [] } - | OPAREN gtyconapp CPAREN { case $2 of (tc,tys) -> MonoTyApp tc tys } - | OPAREN type COMMA types CPAREN { MonoTupleTy ($2:$4) } - | OBRACK type CBRACK { MonoListTy $2 } - | OPAREN btype RARROW type CPAREN { MonoFunTy $2 $4 } - -tyvars :: { [FAST_STRING] } -tyvars : VARID { [$1] } - | tyvars COMMA VARID { $1 ++ [$3] + | { [] } + +instdecls :: { [RdrNameInstDecl] } +instdecls : { [] } + | instd instdecls { $1 : $2 } + +instd :: { RdrNameInstDecl } +instd : INSTANCE ctype EQUAL var_name SEMI + { InstDecl $2 + EmptyMonoBinds {- No bindings -} + [] {- No user pragmas -} + (Just $4) {- Dfun id -} + mkIfaceSrcLoc -------------------------------------------------------------------------- - } + } + +id_info :: { [HsIdInfo RdrName] } +id_info : { [] } + | ARITY_PART arity_info id_info { HsArity $2 : $3 } + | STRICT_PART strict_info id_info { HsStrictness $2 : $3 } + | UNFOLD_PART core_expr id_info { HsUnfold $2 : $3 } + +arity_info :: { ArityInfo } +arity_info : INTEGER { exactArity (fromInteger $1) } + +strict_info :: { StrictnessInfo RdrName } +strict_info : DEMAND qvar_name { mkStrictnessInfo $1 (Just $2) } + | DEMAND { mkStrictnessInfo $1 Nothing } + | BOTTOM { mkBottomStrictnessInfo } + +core_expr :: { UfExpr RdrName } +core_expr : var_name { UfVar $1 } + | qvar_name { UfVar $1 } + | qdata_name { UfVar $1 } + | core_lit { UfLit $1 } + | core_expr core_arg { UfApp $1 $2 } + | LAM core_val_bndr RARROW core_expr { UfLam $2 $4 } + | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 } + + | CASE core_expr OF + OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) } + | CASE BANG core_expr OF + OCURLY prim_alts core_default CCURLY { UfCase $3 (UfPrimAlts $6 $7) } + + | LET OCURLY core_val_bndr EQUAL core_expr CCURLY + IN core_expr { UfLet (UfNonRec $3 $5) $8 } + | LETREC OCURLY rec_binds CCURLY + IN core_expr { UfLet (UfRec $3) $6 } + + | qdata_name BANG core_args { UfCon $1 $3 } + | qvar_name BANG core_args { UfPrim (UfOtherOp $1) $3 } + | coerce atype core_expr { UfCoerce $1 $2 $3 } + +rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } + : { [] } + | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } + +coerce :: { UfCoercion RdrName } +coerce : COERCE_IN qdata_name { UfIn $2 } + | COERCE_OUT qdata_name { UfOut $2 } + +prim_alts :: { [(Literal,UfExpr RdrName)] } + : { [] } + | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 } + +alg_alts :: { [(RdrName, [UfBinder RdrName], UfExpr RdrName)] } + : { [] } + | qdata_name core_val_bndrs RARROW + core_expr SEMI alg_alts { ($1,$2,$4) : $6 } + +core_default :: { UfDefault RdrName } + : { UfNoDefault } + | core_val_bndr RARROW core_expr { UfBindDefault $1 $3 } + +core_arg :: { UfArg RdrName } + : var_name { UfVarArg $1 } + | qvar_name { UfVarArg $1 } + | qdata_name { UfVarArg $1 } + | core_lit { UfLitArg $1 } + | OBRACK atype CBRACK { UfTyArg $2 } + +core_args :: { [UfArg RdrName] } + : { [] } + | core_arg core_args { $1 : $2 } + +core_lit :: { Literal } +core_lit : INTEGER { MachInt $1 True } + | CHAR { MachChar $1 } + | STRING { MachStr $1 } + +core_val_bndr :: { UfBinder RdrName } +core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 } + +core_val_bndrs :: { [UfBinder RdrName] } +core_val_bndrs : { [] } + | core_val_bndr core_val_bndrs { $1 : $2 } + +core_tv_bndr :: { UfBinder RdrName } +core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 } + | tv_name { UfTyBinder $1 mkTypeKind } + +core_tv_bndrs :: { [UfBinder RdrName] } +core_tv_bndrs : { [] } + | core_tv_bndr core_tv_bndrs { $1 : $2 } -pragmas_part :: { LocalPragmasMap } -pragmas_part : PRAGMAS_PART - { emptyFM } - | { emptyFM } -{ -} diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs deleted file mode 100644 index 4e28daf..0000000 --- a/ghc/compiler/rename/ParseUtils.lhs +++ /dev/null @@ -1,427 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[ParseUtils]{Help the interface parser} - -\begin{code} -#include "HsVersions.h" - -module ParseUtils where - -IMP_Ubiq(){-uitous-} - -IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper)) -IMPORT_1_3(List(partition)) - -import HsSyn -- quite a bit of stuff -import RdrHsSyn -- oodles of synonyms -import HsPragmas ( noDataPragmas, noClassPragmas, noClassOpPragmas, - noInstancePragmas - ) - -import ErrUtils ( SYN_IE(Error) ) -import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap ) -import Maybes ( maybeToBool, MaybeErr(..) ) -import Name ( isLexConId, isLexVarId, isLexConSym, - mkTupNameStr, preludeQual, isRdrLexCon, - RdrName(..) {-instance Outputable:ToDo:rm-} - ) -import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging -import PrelMods ( pRELUDE ) -import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr ) -import SrcLoc ( mkIfaceSrcLoc ) -import Util ( startsWith, isIn, panic, assertPanic{-, pprTrace ToDo:rm-} ) -\end{code} - -\begin{code} -type UsagesMap = FiniteMap Module (Version, VersionsMap) - -- module => its version, then to all its entities - -- and their versions; "instance" is a magic entity - -- representing all the instances def'd in that module -type VersionsMap = FiniteMap FAST_STRING Version - -- Versions for things def'd in this module -type ExportsMap = FiniteMap FAST_STRING (OrigName, ExportFlag) -type FixitiesMap = FiniteMap FAST_STRING RdrNameFixityDecl -type LocalTyDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class -type LocalValDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon -type LocalPragmasMap = FiniteMap FAST_STRING PragmaStuff - -type PragmaStuff = String - -data ParsedIface - = ParsedIface - Module -- Module name - (Bool, Bag Module) -- From a merging of these modules; True => merging occured - Version -- Module version number - (Maybe Version) -- Source version number - UsagesMap -- Used when compiling this module - VersionsMap -- Version numbers of things from this module - ExportsMap -- Exported names - (Bag Module) -- Special instance modules - FixitiesMap -- fixities of local things - LocalTyDefsMap -- Local TyCon/Class names defined - LocalValDefsMap -- Local value names defined - (Bag RdrIfaceInst) -- Local instance declarations - LocalPragmasMap -- Pragmas for local names - ------------------------------------------------------------------ - -data RdrIfaceDecl - = TypeSig RdrName SrcLoc RdrNameTyDecl - | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl - | DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl - | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl - | ValSig RdrName SrcLoc RdrNamePolyType - -data RdrIfaceInst - = InstSig RdrName RdrName SrcLoc (Module -> RdrNameInstDecl) - -- InstDecl minus a Module name -\end{code} - -\begin{code} ------------------------------------------------------------------ -data IfaceToken - = ITinterface -- keywords - | ITusages - | ITversions - | ITexports - | ITinstance_modules - | ITinstances - | ITfixities - | ITdeclarations - | ITpragmas - | ITdata - | ITtype - | ITnewtype - | ITclass - | ITwhere - | ITinstance - | ITinfixl - | ITinfixr - | ITinfix - | ITforall - | ITbang -- magic symbols - | ITvbar - | ITdcolon - | ITcomma - | ITdarrow - | ITdotdot - | ITequal - | ITocurly - | ITdccurly - | ITdocurly - | ITobrack - | IToparen - | ITrarrow - | ITccurly - | ITcbrack - | ITcparen - | ITsemi - | ITinteger Integer -- numbers and names - | ITvarid FAST_STRING - | ITconid FAST_STRING - | ITvarsym FAST_STRING - | ITconsym FAST_STRING - | ITqvarid RdrName - | ITqconid RdrName - | ITqvarsym RdrName - | ITqconsym RdrName - deriving Text -- debugging - -instance Text RdrName where -- debugging - showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn)) - ------------------------------------------------------------------ -de_qual (Unqual n) = n -de_qual (Qual _ n) = n - -en_mono :: FAST_STRING -> RdrNameMonoType -en_mono tv = MonoTyVar (Unqual tv) - -{-OLD: -type2context (MonoTupleTy tys) = map type2class_assertion tys -type2context other_ty = [ type2class_assertion other_ty ] - -type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar) -type2class_assertion _ = panic "type2class_assertion: bad format" --} - ------------------------------------------------------------------ -mk_type :: (RdrName, [FAST_STRING]) - -> RdrNameMonoType - -> LocalTyDefsMap - -mk_type (qtycon@(Qual mod tycon), tyvars) ty - = let - qtyvars = map Unqual tyvars - in - unitFM tycon (TypeSig qtycon mkIfaceSrcLoc $ - TySynonym qtycon qtyvars ty mkIfaceSrcLoc) - -mk_data :: RdrNameContext - -> (RdrName, [FAST_STRING]) - -> [(RdrName, RdrNameConDecl)] - -> (LocalTyDefsMap, LocalValDefsMap) - -mk_data ctxt (qtycon@(Qual mod tycon), tyvars) names_and_constrs - = let - (qthingnames, constrs) = unzip names_and_constrs - (qconnames, qfieldnames) = partition isRdrLexCon qthingnames - thingnames = [ t | (Qual _ t) <- qthingnames] - qtyvars = map Unqual tyvars - - decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc $ - TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc - in - (unitFM tycon decl, listToFM [(t,decl) | t <- thingnames]) - -mk_new :: RdrNameContext - -> (RdrName, [FAST_STRING]) - -> (RdrName, RdrNameMonoType) - -> (LocalTyDefsMap, LocalValDefsMap) - -mk_new ctxt (qtycon@(Qual mod1 tycon), tyvars) (qconname@(Qual mod2 conname), ty) - = ASSERT(mod1 == mod2) - let - qtyvars = map Unqual tyvars - constr = NewConDecl qconname ty mkIfaceSrcLoc - - decl = NewTypeSig qtycon qconname mkIfaceSrcLoc $ - TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc - in - (unitFM tycon decl, unitFM conname decl) - -mk_class :: RdrNameContext - -> (RdrName, RdrName) - -> [(FAST_STRING, RdrNameSig)] - -> (LocalTyDefsMap, LocalValDefsMap) - -mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs - = case (unzip ops_and_sigs) of { (opnames, sigs) -> - let - qopnames = map (Qual mod) opnames - op_sigs = map opify sigs - - decl = ClassSig qclas qopnames mkIfaceSrcLoc $ - ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc - in - (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) } - where - opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc - -mk_inst :: [RdrName] - -> RdrNameContext - -> RdrName -- class - -> RdrNameMonoType -- fish the tycon out yourself... - -> RdrIfaceInst - -mk_inst tvs ctxt qclas@(Qual cmod cname) mono_ty - = let - ty = HsForAllTy tvs ctxt mono_ty - in - -- pprTrace "mk_inst:" (ppr PprDebug ty) $ - InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod -> - InstDecl qclas ty - EmptyMonoBinds False{-not from_here-} mod [{-sigs-}] - noInstancePragmas mkIfaceSrcLoc - where - tycon_name (MonoTyApp tc _) = tc - tycon_name (MonoListTy _) = preludeQual SLIT("[]") - tycon_name (MonoFunTy _ _) = preludeQual SLIT("->") - tycon_name (MonoTupleTy ts) = preludeQual (mkTupNameStr (length ts)) - ------------------------------------------------------------------ -lexIface :: String -> [IfaceToken] - -lexIface input - = _scc_ "Lexer" - case input of - [] -> [] - - -- whitespace and comments - ' ' : cs -> lexIface cs - '\t' : cs -> lexIface cs - '\n' : cs -> lexIface cs - '-' : '-' : cs -> lex_comment cs - '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs - - '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs - '{' : '{' : cs -> ITdocurly : lexIface cs - '}' : '}' : cs -> ITdccurly : lexIface cs - '{' : cs -> ITocurly : lexIface cs - '}' : cs -> ITccurly : lexIface cs - '(' : cs -> IToparen : lexIface cs - ')' : cs -> ITcparen : lexIface cs - '[' : cs -> ITobrack : lexIface cs - ']' : cs -> ITcbrack : lexIface cs - ',' : cs -> ITcomma : lexIface cs - ';' : cs -> ITsemi : lexIface cs - - '_' : '_' : cs -> lex_keyword cs - - c : cs | isUpper c -> lex_word input -- don't know if "Module." on front or not - | isDigit c -> lex_num input - | isAlpha c -> lex_name Nothing is_var_sym input - | is_sym_sym c -> lex_name Nothing is_sym_sym input - - other -> error ("lexing:"++other) - where - lex_comment str - = case (span ((/=) '\n') str) of { (junk, rest) -> - lexIface rest } - - ------------------ - lex_nested_comment lvl [] = error "EOF in nested comment in interface" - lex_nested_comment lvl str - = case str of - '{' : '-' : xs -> lex_nested_comment (lvl+1) xs - '-' : '}' : xs -> if lvl == 1 - then lexIface xs - else lex_nested_comment (lvl-1) xs - _ : xs -> lex_nested_comment lvl xs - - ----------- - lex_num str - = case (span isDigit str) of { (num, rest) -> - ITinteger (read num) : lexIface rest } - - ----------- - is_var_sym c = isAlphanum c || c `elem` "_'#" - -- the last few for for Glasgow-extended names - - is_var_sym1 '\'' = False - is_var_sym1 '#' = False - is_var_sym1 '_' = False - is_var_sym1 c = is_var_sym c - - is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic - - is_list_sym '[' = True - is_list_sym ']' = True - is_list_sym _ = False - - is_tuple_sym '(' = True - is_tuple_sym ')' = True - is_tuple_sym ',' = True - is_tuple_sym _ = False - - ------------ - lex_word str@(c:cs) -- we know we have a capital letter to start - = -- we first try for "." on the front... - case (module_dot str) of - Nothing -> lex_name Nothing (in_the_club str) str - 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: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:y)) - - module_dot (c:cs) - = if not (isUpper c) || c == '\'' then - Nothing - else - case (span is_var_sym cs) of { (word, rest) -> - case rest of - [] -> Nothing - (r:rs) | r == '.' -> Just (_PK_ (c:word), rs) - _ -> Nothing - } - - lex_keyword str - = case (span is_var_sym str) of { (kw, rest) -> - case (lookupFM keywordsFM kw) of - Nothing -> panic ("lex_keyword:"++str) - Just xx -> xx : lexIface rest - } - - lex_name module_dot in_the_club str - = case (span in_the_club str) of { (word, rest) -> - case (lookupFM keywordsFM word) of - Just xx -> let - cont = xx : lexIface rest - in - case xx of - ITbang -> case module_dot of - Nothing -> cont - Just m -> ITqvarsym (Qual m SLIT("!")) - : lexIface rest - _ -> cont - Nothing -> - (let - f = head word -- first char - n = _PK_ word - in - case module_dot of - Nothing -> - categ f n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n) - Just m -> - let - q = Qual m n - in - categ f n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q) - - ) : lexIface rest ; - } - ------------ - categ f n conid varid consym varsym - = if f == '[' || f == '(' then - conid - else if isLexConId n then conid - else if isLexVarId n then varid - else if isLexConSym n then consym - else varsym - - ------------ - keywordsFM :: FiniteMap String IfaceToken - keywordsFM = listToFM [ - ("interface", ITinterface) - - ,("usages__", ITusages) - ,("versions__", ITversions) - ,("exports__", ITexports) - ,("instance_modules__", ITinstance_modules) - ,("instances__", ITinstances) - ,("fixities__", ITfixities) - ,("declarations__", ITdeclarations) - ,("pragmas__", ITpragmas) - ,("forall__", ITforall) - - ,("data", ITdata) - ,("type", ITtype) - ,("newtype", ITnewtype) - ,("class", ITclass) - ,("where", ITwhere) - ,("instance", ITinstance) - ,("infixl", ITinfixl) - ,("infixr", ITinfixr) - ,("infix", ITinfix) - - ,("->", ITrarrow) - ,("|", ITvbar) - ,("!", ITbang) - ,("::", ITdcolon) - ,("=>", ITdarrow) - ,("=", ITequal) - ] - ------------------------------------------------------------------ -type IfM a = MaybeErr a Error - -returnIf :: a -> IfM a -thenIf :: IfM a -> (a -> IfM b) -> IfM b -happyError :: Int -> [IfaceToken] -> IfM a - -returnIf a = Succeeded a - -thenIf (Succeeded a) k = k a -thenIf (Failed err) _ = Failed err - -happyError ln toks = Failed (ifaceParseErr ln toks) ------------------------------------------------------------------ - -ifaceParseErr ln toks sty - = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))] -\end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 54348b9..cd531b8 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -14,245 +14,187 @@ IMP_Ubiq() IMPORT_1_3(List(partition)) import HsSyn -import RdrHsSyn ( SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) ) -import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, SYN_IE(RenamedHsModule), isRnTyConOrClass, isRnWired ) - ---ToDo:rm: all for debugging only ---import Maybes ---import Name ---import Outputable ---import RnIfaces ---import PprStyle ---import Pretty ---import FiniteMap ---import Util (pprPanic, pprTrace) - -import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), - UsagesMap(..), VersionsMap(..) - ) -import RnMonad -import RnNames ( getGlobalNames, SYN_IE(GlobalNameInfo) ) -import RnSource ( rnSource ) -import RnIfaces ( rnIfaces, initIfaceCache, IfaceCache ) -import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv ) +import RdrHsSyn ( RdrName, SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) ) +import RnHsSyn ( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames ) -import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) -import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude ) +import CmdLineOpts ( opt_HiMap ) +import RnMonad +import RnNames ( getGlobalNames ) +import RnSource ( rnDecl ) +import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules, + mkSearchPath, getWiredInDecl + ) +import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn ) +import Id ( GenId {- instance NamedThing -} ) +import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined, + NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList, + isWiredInName, modAndOcc + ) +import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) +import TyCon ( TyCon ) import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap ) -import Maybes ( catMaybes ) -import Name ( isLocallyDefined, mkWiredInName, getLocalName, isLocalName, - origName, - Name, RdrName(..), ExportFlag(..) - ) ---import PprStyle -- ToDo:rm -import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) import Pretty -import Unique ( ixClassKey ) -import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) -import UniqSupply ( splitUniqSupply ) -import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +import PprStyle ( PprStyle(..) ) +import Util ( panic, assertPanic, pprTrace ) \end{code} + + \begin{code} renameModule :: UniqSupply -> RdrNameHsModule - - -> IO (RenamedHsModule, -- output, after renaming - RnEnv, -- final env (for renaming derivings) - [Module], -- imported modules; for profiling - - (Name -> ExportFlag, -- export info - ([(Name,ExportFlag)], - [(Name,ExportFlag)])), - - (UsagesMap, - VersionsMap, -- version info; for usage - [Module]), -- instance modules; for iface - - Bag Error, - Bag Warning) + -> IO (Maybe -- Nothing <=> everything up to date; + -- no ned to recompile any further + (RenamedHsModule, -- Output, after renaming + InterfaceDetails, -- Interface; for interface file generatino + RnNameSupply, -- Final env; for renaming derivings + [Module]), -- Imported modules; for profiling + Bag Error, + Bag Warning + ) \end{code} -ToDo: May want to arrange to return old interface for this module! -ToDo: Deal with instances (instance version, this module on instance list ???) \begin{code} -renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _) - - = {- - let - pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n] - in - 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 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,_)) -> +renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_decls loc) + = -- INITIALISE THE RENAMER MONAD + initRn mod_name us (mkSearchPath opt_HiMap) loc $ + + -- FIND THE GLOBAL NAME ENVIRONMENT + getGlobalNames this_mod `thenRn` \ global_name_info -> + + case global_name_info of { + Nothing -> -- Everything is up to date; no need to recompile further + returnRn Nothing ; + + -- Otherwise, just carry on + Just (export_env, rn_env, local_avails) -> + + -- RENAME THE SOURCE + -- We also add occurrences for Int, Double, and (), because they + -- are the types to which ambigious type variables may be defaulted by + -- the type checker; so they won't every appear explicitly. + -- [The () one is a GHC extension for defaulting CCall results.] + initRnMS rn_env mod_name SourceMode (mapRn rnDecl local_decls) `thenRn` \ rn_local_decls -> + addImplicitOccsRn [getName intTyCon, + getName doubleTyCon, + getName unitTyCon] `thenRn_` + + -- SLURP IN ALL THE NEEDED DECLARATIONS + -- Notice that the rnEnv starts empty + closeDecls rn_local_decls (availsToNameSet local_avails) [] + `thenRn` \ (rn_all_decls, imported_avails) -> + + -- SLURP IN ALL NEEDED INSTANCE DECLARATIONS + -- We keep the ones that only mention things (type constructors, classes) that are + -- already imported. Ones which don't can't possibly be useful to us. + getImportedInstDecls `thenRn` \ imported_insts -> let - rec_occ_fn :: Name -> [RdrName] - rec_occ_fn n = case lookupUFM rec_occ_fm n of - Nothing -> [] - Just (rn,occs) -> occs + all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets` + mkNameSet [name | Avail name _ <- imported_avails] - global_name_info = (builtinNameMaps, builtinKeysMap, rec_export_fn, rec_occ_fn) + rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl)) + | (inst_names, mod_name, inst_decl) <- imported_insts, + all (`elemNameSet` all_big_names) inst_names + ] in - getGlobalNames iface_cache global_name_info us1 input >>= - \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) -> + sequenceRn rn_needed_insts `thenRn` \ inst_decls -> + -- Maybe we need to do another close-decls? - if not (isEmptyBag top_errs) then - return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic) - 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, module_dotdots, src_occs), src_errs, src_warns) -> + -- GENERATE THE VERSION/USAGE INFO + getImportVersions imported_avails `thenRn` \ import_versions -> + getNameSupplyRn `thenRn` \ name_supply -> - --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $ - let - occ_fm :: UniqFM (RnName, [RdrName]) - occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs] - occ_fm = addListToUFM_C insert_occ emptyUFM occ_list - - insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds) - - insert new [] = [new] - insert new xxs@(x:xs) = case cmp new x of LT_ -> new : xxs - EQ_ -> xxs - GT__ -> x : insert new xs - - occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm)) - - multiple_occs (rn, (o1:o2:_)) = getLocalName o1 /= SLIT("negate") - -- the user is rarely responsible if - -- "negate" is mentioned in multiple ways - multiple_occs _ = False + -- GENERATE THE SPECIAL-INSTANCE MODULE LIST + -- The "special instance" modules are those modules that contain instance + -- declarations that contain no type constructor or class that was declared + -- in that module. + getSpecialInstModules `thenRn` \ imported_special_inst_mods -> + let + special_inst_decls = [d | InstD d@(InstDecl inst_ty _ _ _ _) <- rn_local_decls, + all (not.isLocallyDefined) (nameSetToList (extractHsTyNames inst_ty)) + ] + special_inst_mods | null special_inst_decls = imported_special_inst_mods + | otherwise = mod_name : imported_special_inst_mods in - return (rn_module, imp_mods, - top_errs `unionBags` src_errs, - top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, - occ_fm, (export_fn, module_dotdots)) - - }) >>= \ (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" + -- RETURN THE RENAMED MODULE let - -- split up all names that occurred in the source; between - -- those that are defined therein and those merely mentioned. - -- We also divide by tycon/class and value names (as usual). - - occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ] - -- all occurrence names, from this module and imported - - (defined_here, defined_elsewhere) - = partition isLocallyDefined occ_rns - - (_, imports_used) - = partition isRnWired defined_elsewhere - - (def_tcs, def_vals) = partition isRnTyConOrClass defined_here - (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns - -- the occ stuff includes *all* occurrences, - -- including those for which we have definitions - - (orig_def_env, orig_def_dups) - = extendGlobalRnEnv emptyRnEnv (map pairify_rn def_vals) - (map pairify_rn def_tcs) - (orig_occ_env, orig_occ_dups) - = extendGlobalRnEnv emptyRnEnv (map pairify_rn occ_vals) - (map pairify_rn occ_tcs) - - -- This stuff is pretty dodgy right now: I think original - -- names and occurrence names may be getting entangled - -- when they shouldn't be... WDP 96/06 - - pairify_rn rn -- ToDo: move to Name? - = let - name = getName rn - in - (if isLocalName name - then Unqual (getLocalName name) - else case (origName "pairify_rn" name) of { OrigName m n -> - Qual m n } - , rn) + import_mods = [mod | ImportDecl mod _ _ _ _ <- imports] + + renamed_module = HsModule mod_name vers + trashed_exports trashed_imports trashed_fixities + (inst_decls ++ rn_all_decls) + loc 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 (initMustHaves ++ imports_used) >>= - \ (rn_module_with_imports, final_env, - (implicit_val_fm, implicit_tc_fm), - usage_stuff, - (iface_errs, iface_warns)) -> - - return (rn_module_with_imports, - final_env, - imp_mods, - export_stuff, - usage_stuff, - errs_so_far `unionBags` iface_errs, - warns_so_far `unionBags` iface_warns) + returnRn (Just (renamed_module, + (import_versions, export_env, special_inst_mods), + name_supply, + import_mods)) + } where - rn_panic = panic "renameModule: aborted with errors" - - (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 ] + trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing + trashed_imports = {-trace "rnSource:trashed_imports"-} [] + trashed_fixities = [] \end{code} \begin{code} -makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath) - -makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)" -makeHiMap (Just f) - = readFile f >>= \ cts -> - return (snag_mod emptyFM cts []) - where - -- we alternate between "snag"ging mod(ule names) and path(names), - -- accumulating names (reversed) and the final resulting map - -- as we move along. - - snag_mod map [] [] = map - snag_mod map (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs [] - snag_mod map (c:cs) rmod = snag_mod map cs (c:rmod) - - snag_path map mod [] rpath = addToFM map mod (reverse rpath) - snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs [] - snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath) +closeDecls :: [RenamedHsDecl] -- Declarations got so far + -> NameSet -- Names bound by those declarations + -> [AvailInfo] -- Available stuff generated by closeDecls so far + -> RnMG ([RenamedHsDecl], -- The closed set + [AvailInfo]) -- Available stuff generated by closeDecls + -- The monad includes a list of possibly-unresolved Names + -- This list is empty when closeDecls returns + +closeDecls decls decl_names import_avails + = popOccurrenceName `thenRn` \ maybe_unresolved -> + + case maybe_unresolved of + + -- No more unresolved names; we're done + Nothing -> returnRn (decls, import_avails) + + -- An "unresolved" name that we've already dealt with + Just (name,_) | name `elemNameSet` decl_names + -> closeDecls decls decl_names import_avails + + -- An unresolved name that's wired in. In this case there's no + -- declaration to get, but we still want to record it as now available, + -- so that we remember to look for instance declarations involving it. + Just (name,_) | isWiredInName name + -> getWiredInDecl name `thenRn` \ decl_avail -> + closeDecls decls + (addAvailToNameSet decl_names decl_avail) + (decl_avail : import_avails) + + -- Genuinely unresolved name + Just (name,necessity) | otherwise + -> getDecl name `thenRn` \ (decl_avail,new_decl) -> + case decl_avail of + + -- Can't find the declaration; check that it was optional + NotAvailable -> checkRn (case necessity of { Optional -> True; other -> False}) + (getDeclErr name) `thenRn_` + closeDecls decls decl_names import_avails + + -- Found it + other -> initRnMS emptyRnEnv mod_name InterfaceMode ( + rnDecl new_decl + ) `thenRn` \ rn_decl -> + closeDecls (rn_decl : decls) + (addAvailToNameSet decl_names decl_avail) + (decl_avail : import_avails) + where + (mod_name,_) = modAndOcc name + +getDeclErr name sty + = ppSep [ppStr "Failed to find interface decl for", ppr sty name] \end{code} -Warning message used herein: -\begin{code} -multipleOccWarn (name, occs) sty - = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ", - ppInterleave ppComma (map (ppr sty) occs)] -\end{code} + diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index ced653a..0ff8016 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -12,11 +12,9 @@ they may be affected by renaming (which isn't fully worked out yet). #include "HsVersions.h" module RnBinds ( - rnTopBinds, + rnTopBinds, rnTopMonoBinds, rnMethodBinds, - rnBinds, - SYN_IE(FreeVars), - SYN_IE(DefinedVars) + rnBinds, rnMonoBinds ) where IMP_Ubiq() @@ -28,18 +26,25 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) +import RnEnv ( bindLocatedLocalsRn, lookupRn, lookupOccRn, isUnboundName ) import CmdLineOpts ( opt_SigsRequired ) import Digraph ( stronglyConnComp ) import ErrUtils ( addErrLoc, addShortErrLocLine ) -import Name ( getLocalName, RdrName ) +import Name ( OccName(..), Provenance, + Name {- instance Eq -}, + NameSet(..), emptyNameSet, mkNameSet, unionNameSets, + minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList + ) import Maybes ( catMaybes ) --import PprStyle--ToDo:rm import Pretty -import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, - unionUniqSets, unionManyUniqSets, - elementOfUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic ) +import UniqSet ( SYN_IE(UniqSet) ) +import ListSetOps ( minusList ) +import Bag ( bagToList ) +import UniqFM ( UniqFM ) +import ErrUtils ( SYN_IE(Error) ) \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -64,15 +69,6 @@ This is precisely what the function @rnBinds@ does. ToDo: deal with case where a single monobinds binds the same variable twice. -Sets of variable names are represented as sets explicitly, rather than lists. - -\begin{code} -type DefinedVars = UniqSet RnName -type FreeVars = UniqSet RnName -\end{code} - -i.e., binders. - The vertag tag is a unique @Int@; the tags only need to be unique within one @MonoBinds@, so that unique-Int plumbing is done explicitly (heavy monad machinery not needed). @@ -88,6 +84,7 @@ type Edge = (VertexTag, VertexTag) %* naming conventions * %* * %************************************************************************ + \subsection[name-conventions]{Name conventions} The basic algorithm involves walking over the tree and returning a tuple @@ -114,6 +111,7 @@ a set of variables free in @Exp@ is written @fvExp@ %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) * %* * %************************************************************************ + \subsubsection[dep-HsBinds]{Polymorphic bindings} Non-recursive expressions are reconstructed without any changes at top @@ -154,52 +152,52 @@ instance declarations. It expects only to see @FunMonoBind@s, and it expects the global environment to contain bindings for the binders (which are all class operations). +%************************************************************************ +%* * +%* Top-level bindings +%* * +%************************************************************************ + +@rnTopBinds@ and @rnTopMonoBinds@ assume that the environment already +contains bindings for the binders of this particular binding. + \begin{code} -rnTopBinds :: RdrNameHsBinds -> RnM_Fixes s RenamedHsBinds -rnMethodBinds :: RnName{-class-} -> RdrNameMonoBinds -> RnM_Fixes s RenamedMonoBinds -rnBinds :: RdrNameHsBinds -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName]) +rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds -rnTopBinds EmptyBinds = returnRn EmptyBinds +rnTopBinds EmptyBinds = returnRn EmptyBinds rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind [] rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs - -- the parser doesn't produce other forms - --- ******************************************************************** - -rnMethodBinds class_name EmptyMonoBinds = returnRn EmptyMonoBinds - -rnMethodBinds class_name (AndMonoBinds mb1 mb2) - = andRn AndMonoBinds (rnMethodBinds class_name mb1) - (rnMethodBinds class_name mb2) + -- The parser doesn't produce other forms -rnMethodBinds class_name (FunMonoBind occname inf matches locn) - = pushSrcLocRn locn $ - lookupClassOp class_name occname `thenRn` \ op_name -> - mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> - mapRn (checkPrecMatch inf op_name) new_matches `thenRn_` - returnRn (FunMonoBind op_name inf new_matches locn) - -rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn) - = pushSrcLocRn locn $ - lookupClassOp class_name occname `thenRn` \ op_name -> - rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) -> - returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn) --- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn) - = failButContinueRn EmptyMonoBinds (methodBindErr mbind locn) +rnTopMonoBinds :: RdrNameMonoBinds + -> [RdrNameSig] + -> RnMS s RenamedHsBinds --- ******************************************************************** +rnTopMonoBinds EmptyMonoBinds sigs + = returnRn EmptyBinds -rnBinds EmptyBinds = returnRn (EmptyBinds,emptyUniqSet,[]) -rnBinds (SingleBind (RecBind bind)) = rnNestedMonoBinds bind [] -rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs - -- the parser doesn't produce other forms +rnTopMonoBinds mbinds sigs + = mapRn lookupRn binder_rdr_names `thenRn` \ binder_names -> + let + binder_set = mkNameSet binder_names + in + rn_mono_binds True {- top level -} + binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) -> + returnRn new_binds + where + binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) \end{code} -@rnNestedMonoBinds@ +%************************************************************************ +%* * +%* Nested binds +%* * +%************************************************************************ + +@rnMonoBinds@ - collects up the binders for this declaration group, - - checkes that they form a set + - checks that they form a set - extends the environment to bind them to new local names - calls @rnMonoBinds@ to do the real work @@ -208,102 +206,78 @@ already done in pass3. All it does is call @rnMonoBinds@ and discards the free var info. \begin{code} -rnTopMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] -> RnM_Fixes s RenamedHsBinds +rnBinds :: RdrNameHsBinds + -> (RenamedHsBinds -> RnMS s (result, FreeVars)) + -> RnMS s (result, FreeVars) -rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds - -rnTopMonoBinds mbs sigs - = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn` \ siglist -> - rnMonoBinds mbs siglist `thenRn` \ (new_binds, fv_set) -> - returnRn new_binds +rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds +rnBinds (SingleBind (RecBind bind)) thing_inside = rnMonoBinds bind [] thing_inside +rnBinds (BindWith (RecBind bind) sigs) thing_inside = rnMonoBinds bind sigs thing_inside + -- the parser doesn't produce other forms -rnNestedMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] - -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName]) +rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] + -> (RenamedHsBinds -> RnMS s (result, FreeVars)) + -> RnMS s (result, FreeVars) -rnNestedMonoBinds EmptyMonoBinds sigs - = returnRn (EmptyBinds, emptyUniqSet, []) +rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds -rnNestedMonoBinds mbinds sigs -- Non-empty monobinds - = - -- Extract all the binders in this group, +rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds + = -- Extract all the binders in this group, -- and extend current scope, inventing new names for the new binders -- This also checks that the names form a set + bindLocatedLocalsRn "binding group" mbinders_w_srclocs $ \ new_mbinders -> let - mbinders_w_srclocs = collectMonoBindersAndLocs mbinds - mbinders = map fst mbinders_w_srclocs + binder_set = mkNameSet new_mbinders in - newLocalNames "variable" - mbinders_w_srclocs `thenRn` \ new_mbinders -> - - extendSS2 new_mbinders ( - rnBindSigs False{-not top- level-} mbinders sigs `thenRn` \ siglist -> - rnMonoBinds mbinds siglist - ) `thenRn` \ (new_binds, fv_set) -> - returnRn (new_binds, fv_set, new_mbinders) + rn_mono_binds False {- not top level -} + binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) -> + + -- Now do the "thing inside", and deal with the free-variable calculations + thing_inside binds `thenRn` \ (result,result_fvs) -> + returnRn (result, (result_fvs `unionNameSets` bind_fvs) `minusNameSet` binder_set) + where + mbinders_w_srclocs = bagToList (collectMonoBinders mbinds) \end{code} + +%************************************************************************ +%* * +%* MonoBinds -- the main work is done here +%* * +%************************************************************************ + @rnMonoBinds@ is used by *both* top-level and nested bindings. It assumes that all variables bound in this group are already in scope. -This is done *either* by pass 3 (for the top-level bindings), -*or* by @rnNestedMonoBinds@ (for the nested ones). +This is done *either* by pass 3 (for the top-level bindings), *or* by +@rnNestedMonoBinds@ (for the nested ones). \begin{code} -rnMonoBinds :: RdrNameMonoBinds - -> [RenamedSig] -- Signatures attached to this group - -> RnM_Fixes s (RenamedHsBinds, FreeVars) - -rnMonoBinds mbinds siglist +rn_mono_binds :: Bool -- True <=> top level + -> NameSet -- Binders of this group + -> RdrNameMonoBinds + -> [RdrNameSig] -- Signatures attached to this group + -> RnMS s (RenamedHsBinds, -- + FreeVars) -- Free variables + +rn_mono_binds is_top_lev binders mbinds sigs = -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned + rnBindSigs is_top_lev binders sigs `thenRn` \ siglist -> flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) -> -- Do the SCC analysis - let vertices = mkVertices mbinds_info - edges = mkEdges mbinds_info - - scc_result = stronglyConnComp (==) edges vertices + let vertices = mkVertices mbinds_info + edges = mkEdges mbinds_info + scc_result = stronglyConnComp (==) edges vertices + final_binds = foldr1 ThenBinds (map (reconstructCycle edges mbinds_info) scc_result) -- Deal with bound and free-var calculation - rhs_free_vars = foldr f emptyUniqSet mbinds_info - - final_binds = reconstructRec scc_result edges mbinds_info - - happy_answer = returnRn (final_binds, rhs_free_vars) + rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info] in - case (inline_sigs_in_recursive_binds final_binds) of - Nothing -> happy_answer - Just names_n_locns -> --- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff --- addErrRn (inlineInRecursiveBindsErr names_n_locns) `thenRn_` - {-not so-}happy_answer - where - f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars - - f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body - - inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs) - = case [(n, locn) | (InlineSig n locn) <- sigs ] of - [] -> Nothing - sigh -> -#if OMIT_DEFORESTER - Just sigh -#else - -- Allow INLINEd recursive functions if they are - -- designated DEFORESTable too. - case [(n, locn) | (DeforestSig n locn) <- sigs ] of - [] -> Just sigh - sigh -> Nothing -#endif - - inline_sigs_in_recursive_binds (ThenBinds b1 b2) - = case (inline_sigs_in_recursive_binds b1) of - Nothing -> inline_sigs_in_recursive_binds b2 - Just x -> Just x -- NB: won't report error(s) in b2 - - inline_sigs_in_recursive_binds anything_else = Nothing + returnRn (final_binds, rhs_fvs) \end{code} @flattenMonoBinds@ is ever-so-slightly magical in that it sticks @@ -313,7 +287,7 @@ unique ``vertex tags'' on its output; minor plumbing required. flattenMonoBinds :: Int -- Next free vertex tag -> [RenamedSig] -- Signatures -> RdrNameMonoBinds - -> RnM_Fixes s (Int, FlatMonoBindsInfo) + -> RnMS s (Int, FlatMonoBindsInfo) flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, []) @@ -329,64 +303,80 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) -- Find which things are bound in this group let - names_bound_here = collectPatBinders pat' - - sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here)) - [] sigs - - sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here - - is_elem = isIn "flattenMonoBinds" + names_bound_here = mkNameSet (collectPatBinders pat') + sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs + sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me in returnRn ( uniq + 1, [(uniq, - mkUniqSet names_bound_here, - fvs `unionUniqSets` sigs_fvs, - PatMonoBind pat' grhss_and_binds' locn, - sigs_etc_for_here + names_bound_here, + fvs `unionNameSets` sigs_fvs, + PatMonoBind pat' grhss_and_binds' locn, + sigs_for_me )] ) flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn) = pushSrcLocRn locn $ - lookupValue name `thenRn` \ name' -> - mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> - mapRn (checkPrecMatch inf name') new_matches `thenRn_` + mapRn (checkPrecMatch inf name) matches `thenRn_` + lookupRn name `thenRn` \ name' -> + mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> let - fvs = unionManyUniqSets fv_lists - - sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs - - sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me + fvs = unionManyNameSets fv_lists + sigs_for_me = filter ((name' ==) . sig_name) sigs + sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me in returnRn ( uniq + 1, [(uniq, - unitUniqSet name', - fvs `unionUniqSets` sigs_fvs, + unitNameSet name', + fvs `unionNameSets` sigs_fvs, FunMonoBind name' inf new_matches locn, sigs_for_me )] ) \end{code} -Grab type-signatures/user-pragmas of interest: + +@rnMethodBinds@ is used for the method bindings of an instance +declaration. like @rnMonoBinds@ but without dependency analysis. + \begin{code} -sig_for_here want_me acc s@(Sig n _ _ _) | want_me n = s:acc -sig_for_here want_me acc s@(InlineSig n _) | want_me n = s:acc -sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc -sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc -sig_for_here want_me acc s@(MagicUnfoldingSig n _ _) - | want_me n = s:acc -sig_for_here want_me acc other_wise = acc +rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds + +rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds + +rnMethodBinds (AndMonoBinds mb1 mb2) + = andRn AndMonoBinds (rnMethodBinds mb1) + (rnMethodBinds mb2) + +rnMethodBinds (FunMonoBind occname inf matches locn) + = pushSrcLocRn locn $ + mapRn (checkPrecMatch inf occname) matches `thenRn_` + lookupRn occname `thenRn` \ op_name -> + mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> + returnRn (FunMonoBind op_name inf new_matches locn) + +rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn) + = pushSrcLocRn locn $ + lookupRn occname `thenRn` \ op_name -> + rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) -> + returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn) + +-- Can't handle method pattern-bindings which bind multiple methods. +rnMethodBinds mbind@(PatMonoBind other_pat _ locn) + = pushSrcLocRn locn $ + failWithRn EmptyMonoBinds (methodBindErr mbind) +\end{code} +\begin{code} -- If a SPECIALIZE pragma is of the "... = blah" form, -- then we'd better make sure "blah" is taken into -- acct in the dependency analysis (or we get an -- unexpected out-of-scope error)! WDP 95/07 -sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` unitUniqSet blah +sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah) sig_fv _ acc = acc \end{code} @@ -400,55 +390,40 @@ This @MonoBinds@- and @ClassDecls@-specific code is segregated here, as the two cases are similar. \begin{code} -reconstructRec :: [Cycle] -- Result of SCC analysis; at least one - -> [Edge] -- Original edges - -> FlatMonoBindsInfo - -> RenamedHsBinds +reconstructCycle :: [Edge] -- Original edges + -> FlatMonoBindsInfo + -> Cycle + -> RenamedHsBinds -reconstructRec cycles edges mbi - = foldr1 ThenBinds (map (reconstructCycle mbi) cycles) +reconstructCycle edges mbi cycle + = mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) where - reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds - - reconstructCycle mbi2 cycle - = case [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle] - of { relevant_binds_and_sigs -> - - case (unzip relevant_binds_and_sigs) of { (binds, sig_lists) -> - - case (foldr AndMonoBinds EmptyMonoBinds binds) of { this_gp_binds -> - let - this_gp_sigs = foldr1 (++) sig_lists - have_sigs = not (null sig_lists) - -- ToDo: this might not be the right - -- thing to call this predicate; - -- e.g. "have_sigs [[], [], []]" ??????????? - in - mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs - }}} - where - is_elem = isIn "reconstructRec" - - mk_binds :: RenamedMonoBinds -> [RenamedSig] - -> Bool -> Bool -> RenamedHsBinds - - mk_binds bs ss True False = SingleBind (RecBind bs) - mk_binds bs ss True True{-have sigs-} = BindWith (RecBind bs) ss - mk_binds bs ss False False = SingleBind (NonRecBind bs) - mk_binds bs ss False True{-have sigs-} = BindWith (NonRecBind bs) ss - - -- moved from Digraph, as this is the only use here - -- (avoid overloading cost). We have to use elem - -- (not FiniteMaps or whatever), because there may be - -- many edges out of one vertex. We give it its own - -- "elem" just for speed. - - isCyclic es [] = panic "isCyclic: empty component" - isCyclic es [v] = (v,v) `elem` es - isCyclic es vs = True - - elem _ [] = False - elem x (y:ys) = x==y || elem x ys + relevant_binds_and_sigs = [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi, + vertex `is_elem` cycle] + (binds, sig_lists) = unzip relevant_binds_and_sigs + this_gp_binds = foldr1 AndMonoBinds binds + this_gp_sigs = foldr1 (++) sig_lists + + is_elem = isIn "reconstructRec" + + mk_binds :: RenamedMonoBinds -> [RenamedSig] -> Bool -> RenamedHsBinds + mk_binds bs [] True = SingleBind (RecBind bs) + mk_binds bs ss True = BindWith (RecBind bs) ss + mk_binds bs [] False = SingleBind (NonRecBind bs) + mk_binds bs ss False = BindWith (NonRecBind bs) ss + + -- moved from Digraph, as this is the only use here + -- (avoid overloading cost). We have to use elem + -- (not FiniteMaps or whatever), because there may be + -- many edges out of one vertex. We give it its own + -- "elem" just for speed. + + isCyclic es [] = panic "isCyclic: empty component" + isCyclic es [v] = (v,v) `elem` es + isCyclic es vs = True + + elem _ [] = False + elem x (y:ys) = x==y || elem x ys \end{code} %************************************************************************ @@ -465,8 +440,8 @@ renamed. \begin{code} type FlatMonoBindsInfo = [(VertexTag, -- Identifies the vertex - UniqSet RnName, -- Set of names defined in this vertex - UniqSet RnName, -- Set of names used in this vertex + NameSet, -- Set of names defined in this vertex + NameSet, -- Set of names used in this vertex RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat) [RenamedSig]) -- Signatures, if any, for this vertex ] @@ -476,12 +451,10 @@ mkEdges :: FlatMonoBindsInfo -> [Edge] mkVertices info = [ vertex | (vertex,_,_,_,_) <- info] -mkEdges flat_info - -- An edge (v,v') indicates that v depends on v' - = -- pprTrace "mkEdges:" (ppAboves [ppAboves[ppInt v, ppCat [ppr PprDebug d|d <- uniqSetToList defd], ppCat [ppr PprDebug u|u <- uniqSetToList used]] | (v,defd,used,_,_) <- flat_info]) $ - [ (source_vertex, target_vertex) +mkEdges flat_info -- An edge (v,v') indicates that v depends on v' + = [ (source_vertex, target_vertex) | (source_vertex, _, used_names, _, _) <- flat_info, - target_name <- uniqSetToList used_names, + target_name <- nameSetToList used_names, target_vertex <- vertices_defining target_name flat_info ] where @@ -491,8 +464,8 @@ mkEdges flat_info -- error) needs more thought. vertices_defining name flat_info2 - = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2, - name `elementOfUniqSet` names_defined + = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2, + name `elemNameSet` names_defined ] \end{code} @@ -509,139 +482,94 @@ flaggery, that all top-level things have type signatures. \begin{code} rnBindSigs :: Bool -- True <=> top-level binders - -> [RdrName] -- Binders for this decl group + -> NameSet -- Set of names bound in this group -> [RdrNameSig] - -> RnM_Fixes s [RenamedSig] -- List of Sig constructors - -rnBindSigs is_toplev binder_occnames sigs - = - -- Rename the signatures - -- Will complain about sigs for variables not in this group - mapRn rename_sig sigs `thenRn` \ sigs_maybe -> - let - sigs' = catMaybes sigs_maybe + -> RnMS s [RenamedSig] -- List of Sig constructors - -- Discard unbound ones we've already complained about, so we - -- complain about duplicate ones. +rnBindSigs is_toplev binders sigs + = -- Rename the signatures + mapRn renameSig sigs `thenRn` \ sigs' -> - (goodies, dups) = removeDups compare (filter (\ x -> not_unbound x && not_main x) sigs') + -- Check for (a) duplicate signatures + -- (b) signatures for things not in this group + -- (c) optionally, bindings with no signature + let + (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs') + not_this_group = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies + type_sig_vars = [n | Sig n _ _ <- goodies] + un_sigd_binders + | is_toplev && opt_SigsRequired = nameSetToList binders `minusList` type_sig_vars + | otherwise = [] in - mapRn (addErrRn . dupSigDeclErr) dups `thenRn_` - - getSrcLocRn `thenRn` \ locn -> - - (if (is_toplev && opt_SigsRequired) then - let - sig_frees = catMaybes (map (sig_free sigs) binder_occnames) - in - mapRn (addErrRn . missingSigErr locn) sig_frees - else - returnRn [] - ) `thenRn_` + mapRn dupSigDeclErr dups `thenRn_` + mapRn unknownSigErr not_this_group `thenRn_` + mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_` returnRn sigs' -- bad ones and all: -- we need bindings of *some* sort for every name + + +renameSig (Sig v ty src_loc) + = pushSrcLocRn src_loc $ + lookupRn v `thenRn` \ new_v -> + rnHsType ty `thenRn` \ new_ty -> + returnRn (Sig new_v new_ty src_loc) + +renameSig (SpecSig v ty using src_loc) + = pushSrcLocRn src_loc $ + lookupRn v `thenRn` \ new_v -> + rnHsType ty `thenRn` \ new_ty -> + rn_using using `thenRn` \ new_using -> + returnRn (SpecSig new_v new_ty new_using src_loc) where - rename_sig (Sig v ty pragmas src_loc) - = pushSrcLocRn src_loc $ - if not (v `elem` binder_occnames) then - addErrRn (unknownSigDeclErr "type signature" v src_loc) `thenRn_` - returnRn Nothing - else - lookupValue v `thenRn` \ new_v -> - rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty -> - - ASSERT(isNoGenPragmas pragmas) - returnRn (Just (Sig new_v new_ty noGenPragmas src_loc)) - - -- and now, the various flavours of value-modifying user-pragmas: - - rename_sig (SpecSig v ty using src_loc) - = pushSrcLocRn src_loc $ - if not (v `elem` binder_occnames) then - addErrRn (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn_` - returnRn Nothing - else - lookupValue v `thenRn` \ new_v -> - rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty -> - rn_using using `thenRn` \ new_using -> - returnRn (Just (SpecSig new_v new_ty new_using src_loc)) - where - rn_using Nothing = returnRn Nothing - rn_using (Just x) = lookupValue x `thenRn` \ new_x -> - returnRn (Just new_x) - - rename_sig (InlineSig v src_loc) - = pushSrcLocRn src_loc $ - if not (v `elem` binder_occnames) then - addErrRn (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn_` - returnRn Nothing - else - lookupValue v `thenRn` \ new_v -> - returnRn (Just (InlineSig new_v src_loc)) - - rename_sig (DeforestSig v src_loc) - = pushSrcLocRn src_loc $ - if not (v `elem` binder_occnames) then - addErrRn (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn_` - returnRn Nothing - else - lookupValue v `thenRn` \ new_v -> - returnRn (Just (DeforestSig new_v src_loc)) - - rename_sig (MagicUnfoldingSig v str src_loc) - = pushSrcLocRn src_loc $ - if not (v `elem` binder_occnames) then - addErrRn (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn_` - returnRn Nothing - else - lookupValue v `thenRn` \ new_v -> - returnRn (Just (MagicUnfoldingSig new_v str src_loc)) - - not_unbound, not_main :: RenamedSig -> Bool - - not_unbound (Sig n _ _ _) = not (isRnUnbound n) - not_unbound (SpecSig n _ _ _) = not (isRnUnbound n) - not_unbound (InlineSig n _) = not (isRnUnbound n) - 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 - -- sigs. Nothing, otherwise. - - sig_free [] ny = Just ny - sig_free (Sig nx _ _ _ : rest) ny - = if (nx == ny) then Nothing else sig_free rest ny - sig_free (_ : rest) ny = sig_free rest ny - - ------------------------------------- - compare :: RenamedSig -> RenamedSig -> TAG_ - compare (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmp` n2 - compare (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2 - compare (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2 - compare (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _) - = -- may have many specialisations for one value; + rn_using Nothing = returnRn Nothing + rn_using (Just x) = lookupOccRn x `thenRn` \ new_x -> + returnRn (Just new_x) + +renameSig (InlineSig v src_loc) + = pushSrcLocRn src_loc $ + lookupRn v `thenRn` \ new_v -> + returnRn (InlineSig new_v src_loc) + +renameSig (DeforestSig v src_loc) + = pushSrcLocRn src_loc $ + lookupRn v `thenRn` \ new_v -> + returnRn (DeforestSig new_v src_loc) + +renameSig (MagicUnfoldingSig v str src_loc) + = pushSrcLocRn src_loc $ + lookupRn v `thenRn` \ new_v -> + returnRn (MagicUnfoldingSig new_v str src_loc) +\end{code} + +Checking for distinct signatures; oh, so boring + +\begin{code} +cmp_sig :: RenamedSig -> RenamedSig -> TAG_ +cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `cmp` n2 +cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2 +cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2 +cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _) + = -- may have many specialisations for one value; -- but not ones that are exactly the same... - thenCmp (n1 `cmp` n2) (cmpPolyType cmp ty1 ty2) - - compare other_1 other_2 -- tags *must* be different - = let tag1 = tag other_1 - tag2 = tag other_2 - in - if tag1 _LT_ tag2 then LT_ else GT_ - - tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT) - tag (SpecSig n1 _ _ _) = ILIT(2) - tag (InlineSig n1 _) = ILIT(3) - tag (MagicUnfoldingSig n1 _ _) = ILIT(4) - tag (DeforestSig n1 _) = ILIT(5) - tag _ = panic# "tag(RnBinds)" + thenCmp (n1 `cmp` n2) (cmpHsType cmp ty1 ty2) + +cmp_sig other_1 other_2 -- Tags *must* be different + | (sig_tag other_1) _LT_ (sig_tag other_2) = LT_ + | otherwise = GT_ + +sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) +sig_tag (SpecSig n1 _ _ _) = ILIT(2) +sig_tag (InlineSig n1 _) = ILIT(3) +sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4) +sig_tag (DeforestSig n1 _) = ILIT(5) +sig_tag _ = panic# "tag(RnBinds)" + +sig_name (Sig n _ _) = n +sig_name (ClassOpSig n _ _ _) = n +sig_name (SpecSig n _ _ _) = n +sig_name (InlineSig n _) = n +sig_name (MagicUnfoldingSig n _ _) = n \end{code} %************************************************************************ @@ -651,46 +579,31 @@ rnBindSigs is_toplev binder_occnames sigs %************************************************************************ \begin{code} -dupSigDeclErr sigs - = let - undup_sigs = fst (removeDups cmp_sig sigs) - in - addErrLoc locn1 - ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty -> - ppAboves (map (ppr sty) undup_sigs) ) +dupSigDeclErr (sig:sigs) + = pushSrcLocRn loc $ + addErrRn (\sty -> ppSep [ppStr "more than one", + ppStr what_it_is, ppStr "given for", + ppQuote (ppr sty (sig_name sig))]) where - (what_it_is, locn1) - = case (head sigs) of - Sig _ _ _ loc -> ("type signature",loc) - ClassOpSig _ _ _ loc -> ("class-method type signature", loc) - SpecSig _ _ _ loc -> ("SPECIALIZE pragma",loc) - InlineSig _ loc -> ("INLINE pragma",loc) - MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc) - - cmp_sig a b = get_name a `cmp` get_name b - - get_name (Sig n _ _ _) = n - get_name (ClassOpSig n _ _ _) = n - get_name (SpecSig n _ _ _) = n - get_name (InlineSig n _) = n - get_name (MagicUnfoldingSig n _ _) = n - ------------------------- -methodBindErr mbind locn - = addErrLoc locn "Can't handle multiple methods defined by one pattern binding" - (\ sty -> ppr sty mbind) - --------------------------- -missingSigErr locn var - = addShortErrLocLine locn ( \ sty -> - ppBesides [ppStr "a definition but no type signature for `", - ppr sty var, - ppStr "'."]) - --------------------------------- -unknownSigDeclErr flavor var locn - = addShortErrLocLine locn ( \ sty -> - ppBesides [ppStr flavor, ppStr " but no definition for `", - ppr sty var, - ppStr "'."]) + (what_it_is, loc) = sig_doc sig + +unknownSigErr sig + = pushSrcLocRn loc $ + addErrRn (\sty -> ppSep [ppStr flavour, ppStr "but no definition for", + ppQuote (ppr sty (sig_name sig))]) + where + (flavour, loc) = sig_doc sig + +sig_doc (Sig _ _ loc) = ("type signature",loc) +sig_doc (ClassOpSig _ _ _ loc) = ("class-method type signature", loc) +sig_doc (SpecSig _ _ _ loc) = ("SPECIALIZE pragma",loc) +sig_doc (InlineSig _ loc) = ("INLINE pragma",loc) +sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc) + +missingSigErr var sty + = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)] + +methodBindErr mbind sty + = ppHang (ppStr "Can't handle multiple methods defined by one pattern binding") + 4 (ppr sty mbind) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs new file mode 100644 index 0000000..fa90d3f --- /dev/null +++ b/ghc/compiler/rename/RnEnv.lhs @@ -0,0 +1,469 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% +\section[RnEnv]{Environment manipulation for the renamer monad} + +\begin{code} +#include "HsVersions.h" + +module RnEnv where -- Export everything + +IMP_Ubiq() + +import CmdLineOpts ( opt_WarnNameShadowing, opt_IgnoreIfacePragmas ) +import HsSyn +import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE), + rdrNameOcc, isQual, qual + ) +import HsTypes ( getTyVarName, replaceTyVarName ) +import RnMonad +import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..), + occNameString, occNameFlavour, + SYN_IE(NameSet), emptyNameSet, addListToNameSet, + mkLocalName, mkGlobalName, modAndOcc, + isLocalName, isWiredInName, nameOccName, setNameProvenance, + pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance + ) +import TyCon ( TyCon ) +import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon ) +import FiniteMap +import Unique ( Unique, unboundKey ) +import Maybes ( maybeToBool ) +import UniqSupply +import SrcLoc ( SrcLoc, noSrcLoc ) +import Pretty +import PprStyle ( PprStyle(..) ) +import Util ( panic, removeDups, pprTrace, assertPanic ) +\end{code} + + + +%********************************************************* +%* * +\subsection{Making new names} +%* * +%********************************************************* + +\begin{code} +newGlobalName :: Module -> OccName -> RnM s d Name +newGlobalName mod occ + = -- First check the cache + getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + case lookupFM cache (mod,occ) of + + -- A hit in the cache! Return it, but change the src loc + -- of the thing we've found if this is a second definition site + -- (that is, if loc /= NoSrcLoc) + Just name -> returnRn name + + -- Miss in the cache, so build a new original name, + -- and put it in the cache + Nothing -> + let + (us', us1) = splitUniqSupply us + uniq = getUnique us1 + name = mkGlobalName uniq mod occ VanillaDefn Implicit + cache' = addToFM cache (mod,occ) name + in + setNameSupplyRn (us', inst_ns, cache') `thenRn_` + returnRn name + +newLocallyDefinedGlobalName :: Module -> OccName + -> (Name -> ExportFlag) -> SrcLoc + -> RnM s d Name +newLocallyDefinedGlobalName mod occ rec_exp_fn loc + = -- First check the cache + getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + + -- We are at the binding site for a locally-defined thing, so + -- you might think it can't be in the cache, but it can if it's a + -- wired in thing. In that case we need to use the correct unique etc... + -- so all we do is replace its provenance. + -- If it's not in the cache we put it there with the correct provenance. + -- The idea is that, after all this, the cache + -- will contain a Name with the correct Provenance (i.e. Local) + let + provenance = LocalDef (rec_exp_fn new_name) loc + (us', us1) = splitUniqSupply us + uniq = getUnique us1 + new_name = case lookupFM cache (mod,occ) of + Just name -> setNameProvenance name provenance + Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance + cache' = addToFM cache (mod,occ) new_name + in + setNameSupplyRn (us', inst_ns, cache') `thenRn_` + returnRn new_name + +-- newDfunName is used to allocate a name for the dictionary function for +-- a local instance declaration. No need to put it in the cache (I think!). +newDfunName :: SrcLoc -> RnMS s Name +newDfunName src_loc + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getModuleRn `thenRn` \ mod_name -> + let + (us', us1) = splitUniqSupply us + uniq = getUnique us1 + dfun_name = mkGlobalName uniq mod_name (VarOcc (_PK_ ("df" ++ show inst_ns))) + VanillaDefn (LocalDef Exported src_loc) + in + setNameSupplyRn (us', inst_ns+1, cache) `thenRn_` + returnRn dfun_name + + +newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] +newLocalNames rdr_names + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + let + n = length rdr_names + (us', us1) = splitUniqSupply us + uniqs = getUniques n us1 + locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc + | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs + ] + in + setNameSupplyRn (us', inst_ns, cache) `thenRn_` + returnRn locals + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = uniqueOf name == unboundKey +\end{code} + +\begin{code} +bindLocatedLocalsRn :: String -- Documentation string for error message + -> [(RdrName,SrcLoc)] + -> ([Name] -> RnMS s a) + -> RnMS s a +bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope + = -- Check for use of qualified names + mapRn (qualNameErr doc_str) quals `thenRn_` + -- Check for dupicated names in a binding group + mapRn (dupNamesErr doc_str) dups `thenRn_` + + getNameEnv `thenRn` \ name_env -> + (if opt_WarnNameShadowing + then + mapRn (check_shadow name_env) rdr_names_w_loc + else + returnRn [] + ) `thenRn_` + + newLocalNames rdr_names_w_loc `thenRn` \ names -> + let + new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names) + in + setNameEnv new_name_env (enclosed_scope names) + where + quals = filter (isQual.fst) rdr_names_w_loc + (these, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc + check_shadow name_env (rdr_name,loc) + = case lookupFM name_env rdr_name of + Nothing -> returnRn () + Just name -> pushSrcLocRn loc $ + addWarnRn (shadowedNameWarn rdr_name) + +bindLocalsRn doc_str rdr_names enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + bindLocatedLocalsRn doc_str (rdr_names `zip` repeat loc) enclosed_scope + +bindTyVarsRn doc_str tyvar_names enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + let + located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names] + in + bindLocatedLocalsRn doc_str located_tyvars $ \ names -> + enclosed_scope (zipWith replaceTyVarName tyvar_names names) +\end{code} + + +%********************************************************* +%* * +\subsection{Looking up names} +%* * +%********************************************************* + +Looking up a name in the RnEnv. + +\begin{code} +lookupRn :: RdrName -> RnMS s Name +lookupRn rdr_name + = getNameEnv `thenRn` \ name_env -> + case lookupFM name_env rdr_name of + + -- Found it! + Just name -> returnRn name + + -- Not found + Nothing -> getModeRn `thenRn` \ mode -> + case mode of + -- Not found when processing source code; so fail + SourceMode -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + + -- Not found when processing an imported declaration, + -- so we create a new name for the purpose + InterfaceMode -> + case rdr_name of + + Qual mod_name occ -> newGlobalName mod_name occ + + -- An Unqual is allowed; interface files contain + -- unqualified names for locally-defined things, such as + -- constructors of a data type. + Unqual occ -> getModuleRn `thenRn ` \ mod_name -> + newGlobalName mod_name occ + + +-- Just like lookupRn except that we record the occurrence too +-- Perhaps surprisingly, even wired-in names are recorded. +-- Why? So that we know which wired-in names are referred to when +-- deciding which instance declarations to import. +lookupOccRn :: RdrName -> RnMS s Name +lookupOccRn rdr_name + = lookupRn rdr_name `thenRn` \ name -> + if isLocalName name then + returnRn name + else + addOccurrenceName Compulsory name `thenRn_` + returnRn name + +-- lookupOptionalOccRn is similar, but it's used in places where +-- we don't *have* to find a definition for the thing. +lookupOptionalOccRn :: RdrName -> RnMS s Name +lookupOptionalOccRn rdr_name + = lookupRn rdr_name `thenRn` \ name -> + if opt_IgnoreIfacePragmas || isLocalName name then + -- Never look for optional things if we're + -- ignoring optional input interface information + returnRn name + else + addOccurrenceName Optional name `thenRn_` + returnRn name + +-- lookupImplicitOccRn takes an RdrName representing an *original* name, and +-- adds it to the occurrence pool so that it'll be loaded later. This is +-- used when language constructs (such as monad comprehensions, overloaded literals, +-- or deriving clauses) require some stuff to be loaded that isn't explicitly +-- mentioned in the code. +-- +-- This doesn't apply in interface mode, where everything is explicit, but +-- we don't check for this case: it does no harm to record an "extra" occurrence +-- and lookupImplicitOccRn isn't used much in interface mode (it's only the +-- Nothing clause of rnDerivs that calls it at all I think. +-- +-- For List and Tuple types it's important to get the correct +-- isLocallyDefined flag, which is used in turn when deciding +-- whether there are any instance decls in this module are "special". +-- The name cache should have the correct provenance, though. + +lookupImplicitOccRn :: RdrName -> RnMS s Name +lookupImplicitOccRn (Qual mod occ) + = newGlobalName mod occ `thenRn` \ name -> + addOccurrenceName Compulsory name `thenRn_` + returnRn name + +addImplicitOccRn :: Name -> RnM s d () +addImplicitOccRn name = addOccurrenceName Compulsory name + +addImplicitOccsRn :: [Name] -> RnM s d () +addImplicitOccsRn names = addOccurrenceNames Compulsory names + +intType_RDR = qual (modAndOcc (getName intTyCon)) +listType_RDR = qual (modAndOcc listType_name) +tupleType_RDR n = qual (modAndOcc (tupleType_name n)) + +charType_name = getName charTyCon +listType_name = getName listTyCon +tupleType_name n = getName (tupleTyCon n) +\end{code} + +\begin{code} +lookupFixity :: RdrName -> RnMS s Fixity +lookupFixity rdr_name + = getFixityEnv `thenRn` \ fixity_env -> + returnRn (lookupFixityEnv fixity_env rdr_name) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Envt utility functions} +%* * +%************************************************************************ + +=============== RnEnv ================ +\begin{code} +plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) + = plusNameEnvRn n1 n2 `thenRn` \ n -> + plusFixityEnvRn f1 f2 `thenRn` \ f -> + returnRn (RnEnv n f) +\end{code} + +=============== NameEnv ================ +\begin{code} +plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv +plusNameEnvRn n1 n2 + = mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2) `thenRn_` + returnRn (n1 `plusFM` n2) + +addOneToNameEnvRn :: NameEnv -> RdrName -> Name -> RnM s d NameEnv +addOneToNameEnvRn env rdr_name name + = mapRn (addErrRn.nameClashErr) (conflictFM (/=) env rdr_name name) `thenRn_` + returnRn (addToFM env rdr_name name) + +lookupNameEnv :: NameEnv -> RdrName -> Maybe Name +lookupNameEnv = lookupFM +\end{code} + +=============== FixityEnv ================ +\begin{code} +plusFixityEnvRn f1 f2 + = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_` + returnRn (f1 `plusFM` f2) + +addOneToFixityEnvRn env rdr_name fixity + = mapRn (addErrRn.fixityClashErr) (conflictFM bad_fix env rdr_name fixity) `thenRn_` + returnRn (addToFM env rdr_name fixity) + +lookupFixityEnv env rdr_name + = case lookupFM env rdr_name of + Just (fixity,_) -> fixity + Nothing -> Fixity 9 InfixL -- Default case + +bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool +bad_fix (f1,_) (f2,_) = f1 /= f2 + +pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Pretty +pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov +\end{code} + + + +=============== Avails ================ +\begin{code} +emptyModuleAvails :: ModuleAvails +plusModuleAvails :: ModuleAvails -> ModuleAvails -> ModuleAvails +lookupModuleAvails :: ModuleAvails -> Module -> Maybe [AvailInfo] + +emptyModuleAvails = emptyFM +plusModuleAvails = plusFM_C (++) +lookupModuleAvails = lookupFM +\end{code} + + +=============== AvailInfo ================ +\begin{code} +plusAvail (Avail n1 ns1) (Avail n2 ns2) = Avail n1 (nub (ns1 ++ ns2)) +plusAvail a NotAvailable = a +plusAvail NotAvailable a = a + +addAvailToNameSet :: NameSet -> AvailInfo -> NameSet +addAvailToNameSet names NotAvailable = names +addAvailToNameSet names (Avail n ns) = addListToNameSet names (n:ns) + +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails + +availNames :: AvailInfo -> [Name] +availNames NotAvailable = [] +availNames (Avail n ns) = n:ns + +filterAvail :: RdrNameIE -> AvailInfo -> AvailInfo +filterAvail (IEThingWith _ wanted) NotAvailable = NotAvailable +filterAvail (IEThingWith _ wanted) (Avail n ns) + | sub_names_ok = Avail n (filter is_wanted ns) + | otherwise = NotAvailable + where + is_wanted name = nameOccName name `elem` wanted_occs + sub_names_ok = all (`elem` avail_occs) wanted_occs + wanted_occs = map rdrNameOcc wanted + avail_occs = map nameOccName ns + + +filterAvail (IEThingAll _) avail = avail +filterAvail ie (Avail n ns) = Avail n [] -- IEThingAbs and IEVar + +-- pprAvail gets given the OccName of the "host" thing +pprAvail sty NotAvailable = ppStr "NotAvailable" +pprAvail sty (Avail n ns) = ppCat [pprOccName sty (nameOccName n), + ppStr "(", + ppInterleave ppComma (map (pprOccName sty.nameOccName) ns), + ppStr ")"] +\end{code} + + + + +%************************************************************************ +%* * +\subsection{Finite map utilities} +%* * +%************************************************************************ + + +Generally useful function on finite maps to check for overlap. + +\begin{code} +conflictsFM :: Ord a + => (b->b->Bool) -- False <=> no conflict; you can pick either + -> FiniteMap a b -> FiniteMap a b + -> [(a,(b,b))] +conflictsFM bad fm1 fm2 + = filter (\(a,(b1,b2)) -> bad b1 b2) + (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2)) + +conflictFM :: Ord a + => (b->b->Bool) + -> FiniteMap a b -> a -> b + -> [(a,(b,b))] +conflictFM bad fm key elt + = case lookupFM fm key of + Just elt' | bad elt elt' -> [(key,(elt,elt'))] + other -> [] +\end{code} + + +%************************************************************************ +%* * +\subsection{Envt utility functions} +%* * +%************************************************************************ + + +\begin{code} +nameClashErr (rdr_name, (name1,name2)) sty + = ppHang (ppCat [ppStr "Conflicting definitions for: ", ppr sty rdr_name]) + 4 (ppAboves [pprNameProvenance sty name1, + pprNameProvenance sty name2]) + +fixityClashErr (rdr_name, (fp1,fp2)) sty + = ppHang (ppCat [ppStr "Conflicting fixities for: ", ppr sty rdr_name]) + 4 (ppAboves [pprFixityProvenance sty fp1, + pprFixityProvenance sty fp2]) + +shadowedNameWarn shadow sty + = ppBesides [ppStr "More than one value with the same name (shadowing): ", ppr sty shadow] + +unknownNameErr name sty + = ppSep [ppStr flavour, ppStr "not in scope:", ppr sty name] + where + flavour = occNameFlavour (rdrNameOcc name) + +qualNameErr descriptor (name,loc) + = pushSrcLocRn loc $ + addErrRn (\sty -> ppBesides [ppStr "invalid use of qualified ", + ppStr descriptor, ppStr ": ", + pprNonSymOcc sty (rdrNameOcc name) ]) + +dupNamesErr descriptor ((name,loc) : dup_things) + = pushSrcLocRn loc $ + addErrRn (\sty -> ppBesides [ppStr "duplicate bindings of `", + ppr sty name, ppStr "' in ", + ppStr descriptor]) +\end{code} + diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 08b1763..613b37b 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -24,9 +24,17 @@ import HsSyn import RdrHsSyn import RnHsSyn import RnMonad - +import RnEnv +import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, + creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, + negate_RDR + ) +import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, + floatPrimTyCon, doublePrimTyCon + ) +import TyCon ( TyCon ) import ErrUtils ( addErrLoc, addShortErrLocLine ) -import Name ( isLocallyDefinedName, pprSym, Name, RdrName ) +import Name import Pretty import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} ) import UniqSet ( emptyUniqSet, unitUniqSet, @@ -44,15 +52,18 @@ import Util ( Ord3(..), removeDups, panic ) ********************************************************* \begin{code} -rnPat :: RdrNamePat -> RnM_Fixes s RenamedPat +rnPat :: RdrNamePat -> RnMS s RenamedPat rnPat WildPatIn = returnRn WildPatIn rnPat (VarPatIn name) - = lookupValue name `thenRn` \ vname -> + = lookupRn name `thenRn` \ vname -> returnRn (VarPatIn vname) -rnPat (LitPatIn n) = returnRn (LitPatIn n) +rnPat (LitPatIn lit) + = litOccurrence lit `thenRn_` + lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern + returnRn (LitPatIn lit) rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ pat' -> @@ -60,23 +71,23 @@ rnPat (LazyPatIn pat) rnPat (AsPatIn name pat) = rnPat pat `thenRn` \ pat' -> - lookupValue name `thenRn` \ vname -> + lookupRn name `thenRn` \ vname -> returnRn (AsPatIn vname pat') rnPat (ConPatIn con pats) - = lookupConstr con `thenRn` \ con' -> + = lookupRn con `thenRn` \ con' -> mapRn rnPat pats `thenRn` \ patslist -> returnRn (ConPatIn con' patslist) rnPat (ConOpPatIn pat1 con pat2) - = lookupConstr con `thenRn` \ con' -> - rnPat pat1 `thenRn` \ pat1' -> - rnPat pat2 `thenRn` \ pat2' -> - precParsePat (ConOpPatIn pat1' con' pat2') + = rnOpPat pat1 con pat2 +-- Negated patters can only be literals, and they are dealt with +-- by negating the literal at compile time, not by using the negation +-- operation in Num. So we don't need to make an implicit reference +-- to negate_RDR. rnPat neg@(NegPatIn pat) - = getSrcLocRn `thenRn` \ src_loc -> - addErrIfRn (not (valid_neg_pat pat)) (negPatErr neg src_loc) + = checkRn (valid_neg_pat pat) (negPatErr neg) `thenRn_` rnPat pat `thenRn` \ pat' -> returnRn (NegPatIn pat') @@ -90,15 +101,17 @@ rnPat (ParPatIn pat) returnRn (ParPatIn pat') rnPat (ListPatIn pats) - = mapRn rnPat pats `thenRn` \ patslist -> + = addImplicitOccRn listType_name `thenRn_` + mapRn rnPat pats `thenRn` \ patslist -> returnRn (ListPatIn patslist) rnPat (TuplePatIn pats) - = mapRn rnPat pats `thenRn` \ patslist -> + = addImplicitOccRn (tupleType_name (length pats)) `thenRn_` + mapRn rnPat pats `thenRn` \ patslist -> returnRn (TuplePatIn patslist) rnPat (RecPatIn con rpats) - = lookupConstr con `thenRn` \ con' -> + = lookupRn con `thenRn` \ con' -> rnRpats rpats `thenRn` \ rpats' -> returnRn (RecPatIn con' rpats') \end{code} @@ -110,28 +123,17 @@ rnPat (RecPatIn con rpats) ************************************************************************ \begin{code} -rnMatch :: RdrNameMatch -> RnM_Fixes s (RenamedMatch, FreeVars) - -rnMatch match - = getSrcLocRn `thenRn` \ src_loc -> - newLocalNames "variable in pattern" - (binders `zip` repeat src_loc) `thenRn` \ new_binders -> - extendSS2 new_binders (rnMatch_aux match) - where - binders = collect_binders match - - collect_binders :: RdrNameMatch -> [RdrName] +rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars) - collect_binders (GRHSMatch _) = [] - collect_binders (PatMatch pat match) - = collectPatBinders pat ++ collect_binders match - -rnMatch_aux (PatMatch pat match) - = rnPat pat `thenRn` \ pat' -> - rnMatch_aux match `thenRn` \ (match', fvMatch) -> - returnRn (PatMatch pat' match', fvMatch) +rnMatch (PatMatch pat match) + = bindLocalsRn "pattern" binders $ \ new_binders -> + rnPat pat `thenRn` \ pat' -> + rnMatch match `thenRn` \ (match', fvMatch) -> + returnRn (PatMatch pat' match', fvMatch `minusNameSet` mkNameSet new_binders) + where + binders = collectPatBinders pat -rnMatch_aux (GRHSMatch grhss_and_binds) +rnMatch (GRHSMatch grhss_and_binds) = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) -> returnRn (GRHSMatch grhss_and_binds', fvs) \end{code} @@ -143,25 +145,25 @@ rnMatch_aux (GRHSMatch grhss_and_binds) %************************************************************************ \begin{code} -rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnM_Fixes s (RenamedGRHSsAndBinds, FreeVars) +rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars) rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) - = rnBinds binds `thenRn` \ (binds', fvBinds, scope) -> - extendSS2 scope (rnGRHSs grhss) `thenRn` \ (grhss', fvGRHS) -> - returnRn (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS) + = rnBinds binds $ \ binds' -> + rnGRHSs grhss `thenRn` \ (grhss', fvGRHS) -> + returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS) where - rnGRHSs [] = returnRn ([], emptyUniqSet) + rnGRHSs [] = returnRn ([], emptyNameSet) rnGRHSs (grhs:grhss) = rnGRHS grhs `thenRn` \ (grhs', fvs) -> rnGRHSs grhss `thenRn` \ (grhss', fvss) -> - returnRn (grhs' : grhss', fvs `unionUniqSets` fvss) + returnRn (grhs' : grhss', fvs `unionNameSets` fvss) rnGRHS (GRHS guard expr locn) = pushSrcLocRn locn $ rnExpr guard `thenRn` \ (guard', fvsg) -> rnExpr expr `thenRn` \ (expr', fvse) -> - returnRn (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse) + returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse) rnGRHS (OtherwiseGRHS expr locn) = pushSrcLocRn locn $ @@ -176,39 +178,35 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnM_Fixes s ([RenamedHsExpr], FreeVars) +rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) -rnExprs [] = returnRn ([], emptyUniqSet) +rnExprs [] = returnRn ([], emptyNameSet) rnExprs (expr:exprs) = rnExpr expr `thenRn` \ (expr', fvExpr) -> rnExprs exprs `thenRn` \ (exprs', fvExprs) -> - returnRn (expr':exprs', fvExpr `unionUniqSets` fvExprs) + returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs) \end{code} Variables. We look up the variable and return the resulting name. The interesting question is what the free-variable set should be. We don't want to return imported or prelude things as free vars. So we -look at the RnName returned from the lookup, and make it part of the -free-var set iff if it's a LocallyDefined RnName. - -ToDo: what about RnClassOps ??? +look at the Name returned from the lookup, and make it part of the +free-var set iff if it's a LocallyDefined Name. \end{itemize} \begin{code} -fv_set vname@(RnName n) | isLocallyDefinedName n - = unitUniqSet vname -fv_set _ = emptyUniqSet - - -rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars) +rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) rnExpr (HsVar v) - = lookupValue v `thenRn` \ vname -> - returnRn (HsVar vname, fv_set vname) + = lookupOccRn v `thenRn` \ vname -> + returnRn (HsVar vname, if isLocallyDefined vname + then unitNameSet vname + else emptyUniqSet) -rnExpr (HsLit lit) - = returnRn (HsLit lit, emptyUniqSet) +rnExpr (HsLit lit) + = litOccurrence lit `thenRn_` + returnRn (HsLit lit, emptyNameSet) rnExpr (HsLam match) = rnMatch match `thenRn` \ (match', fvMatch) -> @@ -217,19 +215,11 @@ rnExpr (HsLam match) rnExpr (HsApp fun arg) = rnExpr fun `thenRn` \ (fun',fvFun) -> rnExpr arg `thenRn` \ (arg',fvArg) -> - returnRn (HsApp fun' arg', fvFun `unionUniqSets` fvArg) + returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg) -rnExpr (OpApp e1 op e2) - = rnExpr e1 `thenRn` \ (e1', fvs_e1) -> - rnExpr op `thenRn` \ (op', fvs_op) -> - rnExpr e2 `thenRn` \ (e2', fvs_e2) -> - precParseExpr (OpApp e1' op' e2') `thenRn` \ exp -> - returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2) +rnExpr (OpApp e1 (HsVar op) e2) = rnOpApp e1 op e2 -rnExpr (NegApp e n) - = rnExpr e `thenRn` \ (e', fvs_e) -> - rnExpr n `thenRn` \ (n', fvs_n) -> - returnRn (NegApp e' n', fvs_e `unionUniqSets` fvs_n) +rnExpr (NegApp e n) = completeNegApp (rnExpr e) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -238,15 +228,17 @@ rnExpr (HsPar e) rnExpr (SectionL expr op) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> rnExpr op `thenRn` \ (op', fvs_op) -> - returnRn (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr) + returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr) rnExpr (SectionR op expr) = rnExpr op `thenRn` \ (op', fvs_op) -> rnExpr expr `thenRn` \ (expr', fvs_expr) -> - returnRn (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr) + returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr) rnExpr (CCall fun args may_gc is_casm fake_result_ty) - = rnExprs args `thenRn` \ (args', fvs_args) -> + = lookupImplicitOccRn ccallableClass_RDR `thenRn_` + lookupImplicitOccRn creturnableClass_RDR `thenRn_` + rnExprs args `thenRn` \ (args', fvs_args) -> returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args) rnExpr (HsSCC label expr) @@ -257,44 +249,47 @@ rnExpr (HsCase expr ms src_loc) = pushSrcLocRn src_loc $ rnExpr expr `thenRn` \ (new_expr, e_fvs) -> mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) -> - returnRn (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs)) + returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs)) rnExpr (HsLet binds expr) - = rnBinds binds `thenRn` \ (binds', fvBinds, new_binders) -> - extendSS2 new_binders (rnExpr expr) `thenRn` \ (expr',fvExpr) -> - returnRn (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr) + = rnBinds binds $ \ binds' -> + rnExpr expr `thenRn` \ (expr',fvExpr) -> + returnRn (HsLet binds' expr', fvExpr) rnExpr (HsDo stmts src_loc) = pushSrcLocRn src_loc $ - rnStmts stmts `thenRn` \ (stmts', fvStmts) -> + lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too + rnStmts stmts `thenRn` \ (stmts', fvStmts) -> returnRn (HsDo stmts' src_loc, fvStmts) rnExpr (ListComp expr quals) - = rnQuals quals `thenRn` \ ((quals', qual_binders), fvQuals) -> - extendSS2 qual_binders (rnExpr expr) `thenRn` \ (expr', fvExpr) -> - returnRn (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals) + = addImplicitOccRn listType_name `thenRn_` + rnQuals expr quals `thenRn` \ ((expr', quals'), fvs) -> + returnRn (ListComp expr' quals', fvs) rnExpr (ExplicitList exps) - = rnExprs exps `thenRn` \ (exps', fvs) -> + = addImplicitOccRn listType_name `thenRn_` + rnExprs exps `thenRn` \ (exps', fvs) -> returnRn (ExplicitList exps', fvs) rnExpr (ExplicitTuple exps) - = rnExprs exps `thenRn` \ (exps', fvExps) -> + = addImplicitOccRn (tupleType_name (length exps)) `thenRn_` + rnExprs exps `thenRn` \ (exps', fvExps) -> returnRn (ExplicitTuple exps', fvExps) rnExpr (RecordCon (HsVar con) rbinds) - = lookupConstr con `thenRn` \ conname -> + = lookupOccRn con `thenRn` \ conname -> rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> returnRn (RecordCon (HsVar conname) rbinds', fvRbinds) rnExpr (RecordUpd expr rbinds) = rnExpr expr `thenRn` \ (expr', fvExpr) -> rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordUpd expr' rbinds', fvExpr `unionUniqSets` fvRbinds) + returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds) rnExpr (ExprWithTySig expr pty) = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnPolyType nullTyVarNamesEnv pty `thenRn` \ pty' -> + rnHsType pty `thenRn` \ pty' -> returnRn (ExprWithTySig expr' pty', fvExpr) rnExpr (HsIf p b1 b2 src_loc) @@ -302,10 +297,11 @@ rnExpr (HsIf p b1 b2 src_loc) rnExpr p `thenRn` \ (p', fvP) -> rnExpr b1 `thenRn` \ (b1', fvB1) -> rnExpr b2 `thenRn` \ (b2', fvB2) -> - returnRn (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2]) + returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2]) rnExpr (ArithSeqIn seq) - = rn_seq seq `thenRn` \ (new_seq, fvs) -> + = lookupImplicitOccRn enumClass_RDR `thenRn_` + rn_seq seq `thenRn` \ (new_seq, fvs) -> returnRn (ArithSeqIn new_seq, fvs) where rn_seq (From expr) @@ -315,19 +311,19 @@ rnExpr (ArithSeqIn seq) rn_seq (FromThen expr1 expr2) = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2) + returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2) rn_seq (FromTo expr1 expr2) = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2) + returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2) rn_seq (FromThenTo expr1 expr2 expr3) = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> returnRn (FromThenTo expr1' expr2' expr3', - unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3]) + unionManyNameSets [fvExpr1, fvExpr2, fvExpr3]) \end{code} %************************************************************************ @@ -340,15 +336,14 @@ rnExpr (ArithSeqIn seq) rnRbinds str rbinds = mapRn field_dup_err dup_fields `thenRn_` mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) -> - returnRn (rbinds', unionManyUniqSets fvRbind_s) + returnRn (rbinds', unionManyNameSets fvRbind_s) where (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ] - field_dup_err dups = getSrcLocRn `thenRn` \ src_loc -> - addErrRn (dupFieldErr str src_loc dups) + field_dup_err dups = addErrRn (dupFieldErr str dups) rn_rbind (field, expr, pun) - = lookupField field `thenRn` \ fieldname -> + = lookupOccRn field `thenRn` \ fieldname -> rnExpr expr `thenRn` \ (expr', fvExpr) -> returnRn ((fieldname, expr', pun), fvExpr) @@ -358,11 +353,10 @@ rnRpats rpats where (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ] - field_dup_err dups = getSrcLocRn `thenRn` \ src_loc -> - addErrRn (dupFieldErr "pattern" src_loc dups) + field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) rn_rpat (field, pat, pun) - = lookupField field `thenRn` \ fieldname -> + = lookupOccRn field `thenRn` \ fieldname -> rnPat pat `thenRn` \ pat' -> returnRn (fieldname, pat', pun) \end{code} @@ -382,42 +376,43 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This Quals. \begin{code} -rnQuals :: [RdrNameQual] - -> RnM_Fixes s (([RenamedQual], -- renamed qualifiers - [RnName]), -- qualifiers' binders - FreeVars) -- free variables - -rnQuals [qual] -- must be at least one qual - = rnQual qual `thenRn` \ ((new_qual, bs), fvs) -> - returnRn (([new_qual], bs), fvs) - -rnQuals (qual: quals) - = rnQual qual `thenRn` \ ((qual', bs1), fvQuals1) -> - extendSS2 bs1 (rnQuals quals) `thenRn` \ ((quals', bs2), fvQuals2) -> - returnRn - ((qual' : quals', bs1 ++ bs2), -- The ones on the right (bs2) shadow the - -- ones on the left (bs1) - fvQuals1 `unionUniqSets` fvQuals2) - -rnQual (GeneratorQual pat expr) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - let - binders = collectPatBinders pat - in - getSrcLocRn `thenRn` \ src_loc -> - newLocalNames "variable in list-comprehension-generator pattern" - (binders `zip` repeat src_loc) `thenRn` \ new_binders -> - extendSS new_binders (rnPat pat) `thenRn` \ pat' -> +rnQuals :: RdrNameHsExpr -> [RdrNameQual] + -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars) + +rnQuals expr [qual] -- must be at least one qual + = rnQual qual $ \ new_qual -> + rnExpr expr `thenRn` \ (expr', fvs) -> + returnRn ((expr', [new_qual]), fvs) + +rnQuals expr (qual: quals) + = rnQual qual $ \ qual' -> + rnQuals expr quals `thenRn` \ ((expr', quals'), fv_quals) -> + returnRn ((expr', qual' : quals'), fv_quals) - returnRn ((GeneratorQual pat' expr', new_binders), fvExpr) -rnQual (FilterQual expr) - = rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn ((FilterQual expr', []), fvs) +-- rnQual :: RdrNameQual +-- -> (RenamedQual -> RnMS s (a,FreeVars)) +-- -> RnMS s (a,FreeVars) +-- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2] -rnQual (LetQual binds) - = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) -> - returnRn ((LetQual binds', new_binders), binds_fvs) +rnQual (GeneratorQual pat expr) thing_inside + = rnExpr expr `thenRn` \ (expr', fv_expr) -> + bindLocalsRn "pattern in list comprehension" binders $ \ new_binders -> + rnPat pat `thenRn` \ pat' -> + + thing_inside (GeneratorQual pat' expr') `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders)) + where + binders = collectPatBinders pat + +rnQual (FilterQual expr) thing_inside + = rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (FilterQual expr') `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` fvs) + +rnQual (LetQual binds) thing_inside + = rnBinds binds $ \ binds' -> + thing_inside (LetQual binds') \end{code} @@ -428,39 +423,42 @@ rnQual (LetQual binds) %************************************************************************ \begin{code} -rnStmts :: [RdrNameStmt] -> RnM_Fixes s ([RenamedStmt], FreeVars) +rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars) -rnStmts [stmt@(ExprStmt _ _)] -- last stmt must be ExprStmt - = rnStmt stmt `thenRn` \ ((stmt',[]), fvStmt) -> - returnRn ([stmt'], fvStmt) +rnStmts [stmt@(ExprStmt expr src_loc)] -- last stmt must be ExprStmt + = pushSrcLocRn src_loc $ + rnExpr expr `thenRn` \ (expr', fv_expr) -> + returnRn ([ExprStmt expr' src_loc], fv_expr) rnStmts (stmt:stmts) - = rnStmt stmt `thenRn` \ ((stmt',bs), fvStmt) -> - extendSS2 bs (rnStmts stmts) `thenRn` \ (stmts', fvStmts) -> - returnRn (stmt':stmts', fvStmt `unionUniqSets` fvStmts) + = rnStmt stmt $ \ stmt' -> + rnStmts stmts `thenRn` \ (stmts', fv_stmts) -> + returnRn (stmt':stmts', fv_stmts) -rnStmt (BindStmt pat expr src_loc) - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fvExpr) -> - let - binders = collectPatBinders pat - in - newLocalNames "variable in do binding" - (binders `zip` repeat src_loc) `thenRn` \ new_binders -> - extendSS new_binders (rnPat pat) `thenRn` \ pat' -> +-- rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars) +-- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2] - returnRn ((BindStmt pat' expr' src_loc, new_binders), fvExpr) +rnStmt (BindStmt pat expr src_loc) thing_inside + = pushSrcLocRn src_loc $ + rnExpr expr `thenRn` \ (expr', fv_expr) -> + bindLocalsRn "pattern in do binding" binders $ \ new_binders -> + rnPat pat `thenRn` \ pat' -> -rnStmt (ExprStmt expr src_loc) - = - rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn ((ExprStmt expr' src_loc, []), fvs) + thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders)) + where + binders = collectPatBinders pat -rnStmt (LetStmt binds) - = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) -> - returnRn ((LetStmt binds', new_binders), binds_fvs) +rnStmt (ExprStmt expr src_loc) thing_inside + = pushSrcLocRn src_loc $ + rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` fvs) +rnStmt (LetStmt binds) thing_inside + = rnBinds binds $ \ binds' -> + thing_inside (LetStmt binds') \end{code} %************************************************************************ @@ -469,83 +467,89 @@ rnStmt (LetStmt binds) %* * %************************************************************************ -\begin{code} -precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr -precParsePat :: RenamedPat -> RnM_Fixes s RenamedPat +@rnOpApp@ deals with operator applications. It does some rearrangement of +the expression so that the precedences are right. This must be done on the +expression *before* renaming, because fixity info applies to the things +the programmer actually wrote. -precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2) - = lookupFixity op `thenRn` \ (op_fix, op_prec) -> - if 6 < op_prec then +\begin{code} +rnOpApp (NegApp e11 n) op e2 + = lookupFixity op `thenRn` \ (Fixity op_prec op_dir) -> + if op_prec > 6 then -- negate precedence 6 wired in -- (-x)*y ==> -(x*y) - precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app -> - returnRn (NegApp op_app n) + completeNegApp (rnOpApp e11 op e2) else - returnRn exp + completeOpApp (completeNegApp (rnExpr e11)) op (rnExpr e2) -precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2) - = lookupFixity op `thenRn` \ (op_fix, op_prec) -> - lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) -> - -- pprTrace "precParse:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $ +rnOpApp (OpApp e11 (HsVar op1) e12) op e2 + = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> + -- pprTrace "rnOpApp:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $ case (op1_prec `cmp` op_prec) of LT_ -> rearrange - EQ_ -> case (op1_fix, op_fix) of - (INFIXR, INFIXR) -> rearrange - (INFIXL, INFIXL) -> returnRn exp - _ -> getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn exp - (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc) - GT__ -> returnRn exp + EQ_ -> case (op1_dir, op_dir) of + (InfixR, InfixR) -> rearrange + (InfixL, InfixL) -> dont_rearrange + _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_` + dont_rearrange + GT__ -> dont_rearrange where - rearrange = precParseExpr (OpApp e12 (HsVar op) e2) `thenRn` \ e2' -> - returnRn (OpApp e11 (HsVar op1) e2') + rearrange = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2) + dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2) + +rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2) -precParseExpr exp = returnRn exp +completeOpApp rn_e1 op rn_e2 + = rn_e1 `thenRn` \ (e1', fvs1) -> + rn_e2 `thenRn` \ (e2', fvs2) -> + rnExpr (HsVar op) `thenRn` \ (op', fvs3) -> + returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3) +completeNegApp rn_expr + = rn_expr `thenRn` \ (e', fvs_e) -> + lookupImplicitOccRn negate_RDR `thenRn` \ neg -> + returnRn (NegApp e' (HsVar neg), fvs_e) +\end{code} -precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2) - = lookupFixity op `thenRn` \ (op_fix, op_prec) -> - if 6 < op_prec then +\begin{code} +rnOpPat p1@(NegPatIn p11) op p2 + = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + if op_prec > 6 then -- negate precedence 6 wired in - getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn pat (precParseNegPatErr (op,op_fix,op_prec) src_loc) + addErrRn (precParseNegPatErr (op,op_fix)) `thenRn_` + rnOpPat p11 op p2 `thenRn` \ op_pat -> + returnRn (NegPatIn op_pat) else - returnRn pat + completeOpPat (rnPat p1) op (rnPat p2) -precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2) - = lookupFixity op `thenRn` \ (op_fix, op_prec) -> - lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) -> +rnOpPat (ConOpPatIn p11 op1 p12) op p2 + = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> case (op1_prec `cmp` op_prec) of LT_ -> rearrange - EQ_ -> case (op1_fix, op_fix) of - (INFIXR, INFIXR) -> rearrange - (INFIXL, INFIXL) -> returnRn pat - _ -> getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn pat - (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc) - GT__ -> returnRn pat + EQ_ -> case (op1_dir, op_dir) of + (InfixR, InfixR) -> rearrange + (InfixL, InfixL) -> dont_rearrange + _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_` + dont_rearrange + GT__ -> dont_rearrange where - rearrange = precParsePat (ConOpPatIn p12 op p2) `thenRn` \ p2' -> - returnRn (ConOpPatIn p11 op1 p2') - -precParsePat pat = returnRn pat + rearrange = rnOpPat p11 op1 (ConOpPatIn p12 op p2) + dont_rearrange = completeOpPat (rnOpPat p11 op1 p12) op (rnPat p2) -data INFIX = INFIXL | INFIXR | INFIXN deriving Eq +rnOpPat p1 op p2 = completeOpPat (rnPat p1) op (rnPat p2) -lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int) -lookupFixity op - = getExtraRn `thenRn` \ fixity_fm -> - -- pprTrace "lookupFixity:" (ppAboves [ppCat [pprUnique u, ppr PprDebug i_f] | (u,i_f) <- ufmToList fixity_fm]) $ - case lookupUFM fixity_fm op of - Nothing -> returnRn (INFIXL, 9) - Just (InfixL _ n) -> returnRn (INFIXL, n) - Just (InfixR _ n) -> returnRn (INFIXR, n) - Just (InfixN _ n) -> returnRn (INFIXN, n) +completeOpPat rn_p1 op rn_p2 + = rn_p1 `thenRn` \ p1' -> + rn_p2 `thenRn` \ p2' -> + lookupRn op `thenRn` \ op' -> + returnRn (ConOpPatIn p1' op' p2') \end{code} \begin{code} -checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s () +checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s () checkPrecMatch False fn match = returnRn () @@ -556,50 +560,95 @@ checkPrecMatch True op _ = panic "checkPrecMatch" checkPrec op (ConOpPatIn _ op1 _) right - = lookupFixity op `thenRn` \ (op_fix, op_prec) -> - lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) -> - getSrcLocRn `thenRn` \ src_loc -> + = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && - (op1_fix == INFIXR && op_fix == INFIXR && right || - op1_fix == INFIXL && op_fix == INFIXL && not right)) + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) - info = (op,op_fix,op_prec) - info1 = (op1,op1_fix,op1_prec) + info = (op,op_fix) + info1 = (op1,op1_fix) (infol, infor) = if right then (info, info1) else (info1, info) in - addErrIfRn (not inf_ok) (precParseErr infol infor src_loc) + checkRn inf_ok (precParseErr infol infor) checkPrec op (NegPatIn _) right - = lookupFixity op `thenRn` \ (op_fix, op_prec) -> - getSrcLocRn `thenRn` \ src_loc -> - addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc) + = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix)) checkPrec op pat right = returnRn () \end{code} +%************************************************************************ +%* * +\subsubsection{Literals} +%* * +%************************************************************************ + +When literals occur we have to make sure that the types and classes they involve +are made available. + +\begin{code} +litOccurrence (HsChar _) + = addImplicitOccRn charType_name + +litOccurrence (HsCharPrim _) + = addImplicitOccRn (getName charPrimTyCon) + +litOccurrence (HsString _) + = addImplicitOccRn listType_name `thenRn_` + addImplicitOccRn charType_name + +litOccurrence (HsStringPrim _) + = addImplicitOccRn (getName addrPrimTyCon) + +litOccurrence (HsInt _) + = lookupImplicitOccRn numClass_RDR `thenRn_` -- Int and Integer are forced in by Num + returnRn () + +litOccurrence (HsFrac _) + = lookupImplicitOccRn fractionalClass_RDR `thenRn_` -- ... similarly Rational + returnRn () + +litOccurrence (HsIntPrim _) + = addImplicitOccRn (getName intPrimTyCon) + +litOccurrence (HsFloatPrim _) + = addImplicitOccRn (getName floatPrimTyCon) + +litOccurrence (HsDoublePrim _) + = addImplicitOccRn (getName doublePrimTyCon) + +litOccurrence (HsLitLit _) + = lookupImplicitOccRn ccallableClass_RDR `thenRn_` + returnRn () +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Errors} +%* * +%************************************************************************ + \begin{code} -dupFieldErr str src_loc (dup:rest) - = addShortErrLocLine src_loc (\ sty -> - ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str]) - -negPatErr pat src_loc - = addShortErrLocLine src_loc (\ sty -> - ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat]) - -precParseNegPatErr op src_loc - = addErrLoc src_loc "precedence parsing error" (\ sty -> - ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"]) - -precParseErr op1 op2 src_loc - = addErrLoc src_loc "precedence parsing error" (\ sty -> - ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2, - ppStr " in the same infix expression"]) - -pp_op sty (op, fix, prec) = ppBesides [pprSym sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen] -pp_fix INFIXL = ppStr "infixl" -pp_fix INFIXR = ppStr "infixr" -pp_fix INFIXN = ppStr "infix" +dupFieldErr str (dup:rest) sty + = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str] + +negPatErr pat sty + = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat] + +precParseNegPatErr op sty + = ppHang (ppStr "precedence parsing error") + 4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"]) + +precParseErr op1 op2 sty + = ppHang (ppStr "precedence parsing error") + 4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2, + ppStr " in the same infix expression"]) + +pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen] \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index db994b1..db49db2 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -12,191 +12,78 @@ IMP_Ubiq() import HsSyn -import Id ( isDataCon, GenId, SYN_IE(Id) ) -import Name ( isLocalName, nameUnique, Name, RdrName(..), - mkLocalName - ) +import Id ( GenId, SYN_IE(Id) ) +import Name ( Name ) import Outputable ( Outputable(..){-instance * []-} ) import PprStyle ( PprStyle(..) ) import PprType ( GenType, GenTyVar, TyCon ) import Pretty +import Name ( SYN_IE(NameSet), unitNameSet, mkNameSet, minusNameSet, unionNameSets, emptyNameSet ) import TyCon ( TyCon ) import TyVar ( GenTyVar ) -import Unique ( mkAlphaTyVarUnique, Unique ) +import Unique ( Unique ) import Util ( panic, pprPanic{-, pprTrace ToDo:rm-} ) \end{code} -\begin{code} -data RnName - = WiredInId Id - | WiredInTyCon TyCon - | RnName Name -- functions/binders/tyvars - | RnSyn Name -- type synonym - | RnData Name [Name] [Name] -- data type (with constrs and fields) - | RnConstr Name Name -- constructor (with data type) - | RnField Name Name -- field (with data type) - | RnClass Name [Name] -- class (with class ops) - | RnClassOp Name Name -- class op (with class) - | RnImplicit Name -- implicitly imported - | RnImplicitTyCon Name -- implicitly imported - | RnImplicitClass Name -- implicitly imported - | RnUnbound RdrName -- place holder - -mkRnName = RnName -mkRnImplicit = RnImplicit -mkRnImplicitTyCon = RnImplicitTyCon -mkRnImplicitClass = RnImplicitClass -mkRnUnbound = RnUnbound - -isRnWired (WiredInId _) = True -isRnWired (WiredInTyCon _) = True -isRnWired _ = False - -isRnLocal (RnName n) = isLocalName n -isRnLocal _ = False - -isRnTyCon (WiredInTyCon _) = True -isRnTyCon (RnSyn _) = True -isRnTyCon (RnData _ _ _) = True -isRnTyCon (RnImplicitTyCon _) = True -isRnTyCon _ = False - -isRnClass (RnClass _ _) = True -isRnClass (RnImplicitClass _) = True -isRnClass _ = False - --- a common need: isRnTyCon || isRnClass: -isRnTyConOrClass (WiredInTyCon _) = True -isRnTyConOrClass (RnSyn _) = True -isRnTyConOrClass (RnData _ _ _) = True -isRnTyConOrClass (RnImplicitTyCon _) = True -isRnTyConOrClass (RnClass _ _) = True -isRnTyConOrClass (RnImplicitClass _) = True -isRnTyConOrClass _ = False - -isRnConstr (RnConstr _ _) = True -isRnConstr (WiredInId id) = isDataCon id -isRnConstr _ = False - -isRnField (RnField _ _) = True -isRnField _ = False - -isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls -isRnClassOp cls n = True -- pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway - -isRnImplicit (RnImplicit _) = True -isRnImplicit (RnImplicitTyCon _) = True -isRnImplicit (RnImplicitClass _) = True -isRnImplicit _ = False - -isRnUnbound (RnUnbound _) = True -isRnUnbound _ = False - -isRnEntity (WiredInId _) = True -isRnEntity (WiredInTyCon _) = True -isRnEntity (RnName n) = not (isLocalName n) -isRnEntity (RnSyn _) = True -isRnEntity (RnData _ _ _) = True -isRnEntity (RnClass _ _) = True -isRnEntity _ = False - --- Very general NamedThing comparison, used when comparing --- Uniquable things with different types - -eqUniqsNamed n1 n2 = uniqueOf n1 == uniqueOf n2 -cmpUniqsNamed n1 n2 = uniqueOf n1 `cmp` uniqueOf n2 - -instance Eq RnName where - a == b = eqUniqsNamed a b - -instance Ord3 RnName where - a `cmp` b = cmpUniqsNamed a b - -instance Uniquable RnName where - uniqueOf = nameUnique . getName - -instance NamedThing RnName where - getName (WiredInId id) = getName id - getName (WiredInTyCon tc) = getName tc - getName (RnName n) = n - getName (RnSyn n) = n - getName (RnData n _ _) = n - getName (RnConstr n _) = n - getName (RnField n _) = n - getName (RnClass n _) = n - getName (RnClassOp n _) = n - getName (RnImplicit n) = n - getName (RnImplicitTyCon n) = n - getName (RnImplicitClass n) = n - getName (RnUnbound occ) = --pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ) - (case occ of - Unqual n -> mkLocalName bottom n False bottom2 - Qual m n -> mkLocalName bottom n False bottom2) - where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print - bottom2 = panic "getRnName: srcloc" - -instance Outputable RnName where -#ifdef DEBUG - ppr sty@PprShowAll (RnData n cs fs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"] - ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"] - ppr sty@PprShowAll (RnField n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"] - ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"] - ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"] -#endif - ppr sty (WiredInId id) = ppr sty id - ppr sty (WiredInTyCon tycon)= ppr sty tycon - ppr sty (RnUnbound occ) = ppBeside (ppr sty occ) (ppPStr SLIT("{-UNBOUND-}")) - ppr sty rn_name = ppr sty (getName rn_name) -\end{code} \begin{code} -type RenamedArithSeqInfo = ArithSeqInfo Fake Fake RnName RenamedPat -type RenamedBind = Bind Fake Fake RnName RenamedPat -type RenamedClassDecl = ClassDecl Fake Fake RnName RenamedPat -type RenamedClassOpSig = Sig RnName -type RenamedConDecl = ConDecl RnName -type RenamedContext = Context RnName -type RenamedSpecDataSig = SpecDataSig RnName -type RenamedDefaultDecl = DefaultDecl RnName -type RenamedFixityDecl = FixityDecl RnName -type RenamedGRHS = GRHS Fake Fake RnName RenamedPat -type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake RnName RenamedPat -type RenamedHsBinds = HsBinds Fake Fake RnName RenamedPat -type RenamedHsExpr = HsExpr Fake Fake RnName RenamedPat -type RenamedHsModule = HsModule Fake Fake RnName RenamedPat -type RenamedInstDecl = InstDecl Fake Fake RnName RenamedPat -type RenamedMatch = Match Fake Fake RnName RenamedPat -type RenamedMonoBinds = MonoBinds Fake Fake RnName RenamedPat -type RenamedMonoType = MonoType RnName -type RenamedPat = InPat RnName -type RenamedPolyType = PolyType RnName -type RenamedRecordBinds = HsRecordBinds Fake Fake RnName RenamedPat -type RenamedQual = Qualifier Fake Fake RnName RenamedPat -type RenamedSig = Sig RnName -type RenamedSpecInstSig = SpecInstSig RnName -type RenamedStmt = Stmt Fake Fake RnName RenamedPat -type RenamedTyDecl = TyDecl RnName - -type RenamedClassOpPragmas = ClassOpPragmas RnName -type RenamedClassPragmas = ClassPragmas RnName -type RenamedDataPragmas = DataPragmas RnName -type RenamedGenPragmas = GenPragmas RnName -type RenamedInstancePragmas = InstancePragmas RnName +type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat +type RenamedBind = Bind Fake Fake Name RenamedPat +type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat +type RenamedClassOpSig = Sig Name +type RenamedConDecl = ConDecl Name +type RenamedContext = Context Name +type RenamedHsDecl = HsDecl Fake Fake Name RenamedPat +type RenamedSpecDataSig = SpecDataSig Name +type RenamedDefaultDecl = DefaultDecl Name +type RenamedFixityDecl = FixityDecl Name +type RenamedGRHS = GRHS Fake Fake Name RenamedPat +type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake Name RenamedPat +type RenamedHsBinds = HsBinds Fake Fake Name RenamedPat +type RenamedHsExpr = HsExpr Fake Fake Name RenamedPat +type RenamedHsModule = HsModule Fake Fake Name RenamedPat +type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat +type RenamedMatch = Match Fake Fake Name RenamedPat +type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat +type RenamedPat = InPat Name +type RenamedHsType = HsType Name +type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat +type RenamedQual = Qualifier Fake Fake Name RenamedPat +type RenamedSig = Sig Name +type RenamedSpecInstSig = SpecInstSig Name +type RenamedStmt = Stmt Fake Fake Name RenamedPat +type RenamedTyDecl = TyDecl Name + +type RenamedClassOpPragmas = ClassOpPragmas Name +type RenamedClassPragmas = ClassPragmas Name +type RenamedDataPragmas = DataPragmas Name +type RenamedGenPragmas = GenPragmas Name +type RenamedInstancePragmas = InstancePragmas Name \end{code} +%************************************************************************ +%* * +\subsection{Free variables} +%* * +%************************************************************************ + \begin{code} -collectQualBinders :: [RenamedQual] -> [RnName] +extractCtxtTyNames :: RenamedContext -> NameSet +extractCtxtTyNames ctxt = foldr (unionNameSets . extractHsTyNames . snd) emptyNameSet ctxt -collectQualBinders quals - = concat (map collect quals) +extractHsTyNames :: RenamedHsType -> NameSet +extractHsTyNames ty + = get ty where - collect (GeneratorQual pat _) = collectPatBinders pat - collect (FilterQual expr) = [] - collect (LetQual binds) = collectTopLevelBinders binds + get (MonoTyApp con tys) = foldr (unionNameSets . get) (unitNameSet con) tys + get (MonoListTy tc ty) = unitNameSet tc `unionNameSets` get ty + get (MonoTupleTy tc tys) = foldr (unionNameSets . get) (unitNameSet tc) tys + get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 + get (MonoDictTy cls ty) = unitNameSet cls `unionNameSets` get ty + get (MonoTyVar tv) = unitNameSet tv + get (HsForAllTy tvs ctxt ty) = foldr (unionNameSets . get . snd) (get ty) ctxt + `minusNameSet` + mkNameSet (map getTyVarName tvs) -fixDeclName :: FixityDecl name -> name -fixDeclName (InfixL name i) = name -fixDeclName (InfixR name i) = name -fixDeclName (InfixN name i) = name \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 396f021..649391d 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -7,866 +7,565 @@ #include "HsVersions.h" module RnIfaces ( - cachedIface, - cachedDecl, CachingResult(..), - rnIfaces, - IfaceCache, initIfaceCache + getInterfaceExports, + getImportedInstDecls, + getSpecialInstModules, + getDecl, getWiredInDecl, + getImportVersions, + + checkUpToDate, + + getDeclBinders, + mkSearchPath ) where IMP_Ubiq() -import PreludeGlaST ( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) ) -#if __GLASGOW_HASKELL__ >= 200 -# define ST_THEN `stThen` -# define TRY_IO tryIO -IMPORT_1_3(GHCio(stThen,tryIO)) -#else -# define ST_THEN `thenPrimIO` -# define TRY_IO try -#endif - -import HsSyn -import HsPragmas ( noGenPragmas ) -import RdrHsSyn -import RnHsSyn +import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), + HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..), + FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo + ) +import HsPragmas ( noGenPragmas ) +import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), + RdrName, rdrNameOcc + ) +import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availNames ) +import RnSource ( rnHsType ) import RnMonad -import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) -import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) import ParseIface ( parseIface ) -import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), - VersionsMap(..), UsagesMap(..) - ) -import Bag ( emptyBag, unitBag, consBag, snocBag, - unionBags, unionManyBags, isEmptyBag, bagToList ) import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) -import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, - fmToList, delListFromFM, sizeFM, foldFM, unitFM, - plusFM_C, addListToFM{-, keysFM ToDo:rm-}, FiniteMap - ) -import Maybes ( maybeToBool, MaybeErr(..) ) -import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..), - isLexCon, RdrName(..), Name{-instance NamedThing-} ) ---import PprStyle -- ToDo:rm ---import Outputable -- ToDo:rm -import PrelInfo ( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) ) +import FiniteMap ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addListToFM, fmToList ) +import Name ( Name {-instance NamedThing-}, Provenance, OccName(..), + modAndOcc, occNameString, moduleString, pprModule, + NameSet(..), emptyNameSet, unionNameSets, nameSetToList, + minusNameSet, mkNameSet, + isWiredInName, maybeWiredInTyConName, maybeWiredInIdName + ) +import Id ( GenId, Id(..), idType, dataConTyCon, isDataCon ) +import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) +import Type ( namesOfType ) +import TyVar ( GenTyVar ) +import SrcLoc ( mkIfaceSrcLoc ) +import PrelMods ( gHC__ ) +import Bag +import Maybes ( MaybeErr(..), expectJust, maybeToBool ) +import ListSetOps ( unionLists ) import Pretty -import UniqFM ( emptyUFM ) -import UniqSupply ( splitUniqSupply ) -import Util ( sortLt, removeDups, cmpPString, startsWith, - panic, pprPanic, assertPanic{-, pprTrace ToDo:rm-} ) -\end{code} - -\begin{code} -type ModuleToIfaceContents = FiniteMap Module ParsedIface -type ModuleToIfaceFilePath = FiniteMap Module FilePath - -#if __GLASGOW_HASKELL__ >= 200 -# define REAL_WORLD RealWorld -#else -# define REAL_WORLD _RealWorld -#endif - -data IfaceCache - = IfaceCache - Module -- the name of the module being compiled - BuiltinNames -- so we can avoid going after things - -- the compiler already knows about - (MutableVar REAL_WORLD - (ModuleToIfaceContents, -- interfaces for individual interface files - ModuleToIfaceContents, -- merged interfaces based on module name - -- used for extracting info about original names - ModuleToIfaceFilePath)) - -initIfaceCache mod hi_files - = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var -> - return (IfaceCache mod builtinNameMaps iface_var) +import PprStyle ( PprStyle(..) ) +import Util ( pprPanic ) \end{code} -********************************************************* -* * -\subsection{Reading interface files} -* * -********************************************************* - -Return cached info about a Module's interface; otherwise, -read the interface (using our @ModuleToIfaceFilePath@ map -to decide where to look). - -Note: we have two notions of interface - * the interface for a particular file name - * the (combined) interface for a particular module name -The idea is that two source files may declare a module -with the same name with the declarations being merged. - -This allows us to have file PreludeList.hs producing -PreludeList.hi but defining part of module Prelude. -When PreludeList is imported its contents will be -added to Prelude. In this way all the original names -for a particular module will be available the imported -decls are renamed. - -ToDo: Check duplicate definitons are the same. -ToDo: Check/Merge duplicate pragmas. +%********************************************************* +%* * +\subsection{Loading a new interface file} +%* * +%********************************************************* \begin{code} -cachedIface :: IfaceCache - -> Bool -- True => want merged interface for original name - -- False => want file interface only - -> FAST_STRING -- item that prompted search (debugging only!) - -> Module - -> IO (MaybeErr ParsedIface Error) - -cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname - = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) -> - - case (lookupFM iface_fm modname) of - Just iface -> return (want_iface iface orig_fm) - Nothing -> - case (lookupFM file_fm modname) of - Nothing -> return (Failed (noIfaceErr modname)) - Just file -> - readIface file modname item >>= \ read_iface -> - case read_iface of - Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $ - return (Failed err) - Succeeded iface -> - let - iface_fm' = addToFM iface_fm modname iface - orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface - in - writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ -> - return (want_iface iface orig_fm') - where - want_iface iface orig_fm - | want_orig_iface - = case lookupFM orig_fm modname of - Nothing -> Failed (noOrigIfaceErr modname) - Just orig_iface -> Succeeded orig_iface - | otherwise - = Succeeded iface - - iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod - ----------- -mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1) - (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2) - = --pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)), - -- ppStr "merged with", ppPStr mod1]) $ - ASSERT(mod1 == mod2) - ParsedIface mod1 - (True, unionBags files2 files1) - (panic "mergeIface: module version numbers") - (panic "mergeIface: source version numbers") -- Version numbers etc must be extracted from - (panic "mergeIface: usage version numbers") -- the merged file interfaces named above - (panic "mergeIface: decl version numbers") - (panic "mergeIface: exports") - (panic "mergeIface: instance modules") - (plusFM_C (dup_merge {-"fixity" (ppr PprDebug . fixDeclName)-}) fixes1 fixes2) - (plusFM_C (dup_merge {-"tycon/class" (ppr PprDebug . idecl_nm)-}) tdefs1 tdefs2) - (plusFM_C (dup_merge {-"value" (ppr PprDebug . idecl_nm)-}) vdefs1 vdefs2) - (unionBags idefs1 idefs2) - (plusFM_C (dup_merge {-"pragma" ppStr-}) prags1 prags2) - where - dup_merge {-str ppr_dup-} dup1 dup2 - = --pprTrace "mergeIfaces:" - -- (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl", - -- ppr_dup dup1, ppr_dup dup2]) $ - dup2 - - idecl_nm (TypeSig n _ _) = n - idecl_nm (NewTypeSig n _ _ _) = n - idecl_nm (DataSig n _ _ _ _) = n - idecl_nm (ClassSig n _ _ _) = n - idecl_nm (ValSig n _ _) = n - ----------- -data CachingResult - = CachingFail Error -- tried to find a decl, something went wrong - | CachingHit RdrIfaceDecl -- got it - | CachingAvoided (Maybe (Either RnName RnName)) - -- didn't look in the interface - -- file(s); Nothing => the thing - -- *should* be in the source module; - -- Just (Left ...) => builtin val name; - -- Just (Right ..) => builtin tc name - -cachedDecl :: IfaceCache - -> Bool -- True <=> tycon or class name - -> OrigName - -> IO CachingResult - -cachedDecl iface_cache@(IfaceCache this_mod (b_val_names,b_tc_names) _) - class_or_tycon name@(OrigName mod str) - - = -- pprTrace "cachedDecl:" (ppr PprDebug name) $ - if mod == this_mod then -- some i/face has made a reference - return (CachingAvoided Nothing) -- to something from this module - else +loadInterface :: Pretty -> Module -> RnMG Ifaces +loadInterface doc_str load_mod + = getIfacesRn `thenRn` \ ifaces -> let - b_env = if class_or_tycon then b_tc_names else b_val_names + Ifaces this_mod mod_vers_map export_env_map vers_map decls_map inst_map inst_mods = ifaces in - case (lookupFM b_env name) of - Just rn -> -- in builtins! - return (CachingAvoided (Just ((if class_or_tycon then Right else Left) rn))) - - Nothing -> - cachedIface iface_cache True str mod >>= \ maybe_iface -> - case maybe_iface of - Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $ - return (CachingFail err) - Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> - case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of - Just decl -> return (CachingHit decl) - Nothing -> return (CachingFail (noDeclInIfaceErr mod str)) - ----------- -cachedDeclByType :: IfaceCache - -> RnName{-NB: diff type than cachedDecl -} - -> IO CachingResult - -cachedDeclByType iface_cache rn - -- the idea is: check that, e.g., if we're given an - -- RnClass, then we really get back a ClassDecl from - -- the cache (not an RnData, or something silly) - = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn) >>= \ maybe_decl -> + -- CHECK WHETHER WE HAVE IT ALREADY + if maybeToBool (lookupFM export_env_map load_mod) + then + returnRn ifaces -- Already in the cache; don't re-read it + else + + -- READ THE MODULE IN + findAndReadIface doc_str load_mod `thenRn` \ read_result -> + case read_result of { + -- Check for not found + Nothing -> -- Not found, so add an empty export env to the Ifaces map + -- so that we don't look again + let + new_export_env_map = addToFM export_env_map load_mod ([],[]) + new_ifaces = Ifaces this_mod mod_vers_map + new_export_env_map + vers_map decls_map inst_map inst_mods + in + setIfacesRn new_ifaces `thenRn_` + failWithRn new_ifaces (noIfaceErr load_mod) ; + + -- Found and parsed! + Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) -> + + -- LOAD IT INTO Ifaces + mapRn loadExport exports `thenRn` \ avails -> + foldlRn (loadDecl load_mod) (decls_map,vers_map) decls `thenRn` \ (new_decls_map, new_vers_map) -> + foldlRn (loadInstDecl load_mod) inst_map insts `thenRn` \ new_insts_map -> let - return_maybe_decl = return maybe_decl - return_failed msg = return (CachingFail msg) + export_env = (avails, fixs) + + -- Exclude this module from the "special-inst" modules + new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods) + + new_ifaces = Ifaces this_mod + (addToFM mod_vers_map load_mod mod_vers) + (addToFM export_env_map load_mod export_env) + new_vers_map + new_decls_map + new_insts_map + new_inst_mods in - case maybe_decl of - CachingAvoided _ -> return_maybe_decl - CachingFail io_msg -> return_failed (ifaceIoErr io_msg rn) - CachingHit if_decl -> - case rn of - WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn) - WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn) - RnUnbound _ -> panic "cachedDeclByType:" -- (ppr PprDebug rn) - - RnSyn _ -> return_maybe_decl - RnData _ _ _ -> return_maybe_decl - RnImplicitTyCon _ -> if is_tycon_decl if_decl - then return_maybe_decl - else return_failed (badIfaceLookupErr "type constructor" rn if_decl) - - RnClass _ _ -> return_maybe_decl - RnImplicitClass _ -> if is_class_decl if_decl - then return_maybe_decl - else return_failed (badIfaceLookupErr "class" rn if_decl) - - RnName _ -> return_maybe_decl - RnConstr _ _ -> return_maybe_decl - RnField _ _ -> return_maybe_decl - RnClassOp _ _ -> return_maybe_decl - RnImplicit _ -> if is_val_decl if_decl - then return_maybe_decl - else return_failed (badIfaceLookupErr "value" rn if_decl) + setIfacesRn new_ifaces `thenRn_` + returnRn new_ifaces + } + +loadExport :: ExportItem -> RnMG AvailInfo +loadExport (mod, occ, occs) + = new_name occ `thenRn` \ name -> + mapRn new_name occs `thenRn` \ names -> + returnRn (Avail name names) + where + new_name occ = newGlobalName mod occ + +loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap +loadVersion mod vers_map (occ, version) + = newGlobalName mod occ `thenRn` \ name -> + returnRn (addToFM vers_map name version) + + +loadDecl :: Module -> (DeclsMap, VersionMap) + -> (Version, RdrNameHsDecl) + -> RnMG (DeclsMap, VersionMap) +loadDecl mod (decls_map, vers_map) (version, decl) + = getDeclBinders new_implicit_name decl `thenRn` \ avail@(Avail name _) -> + returnRn (addListToFM decls_map + [(name,(avail,decl)) | name <- availNames avail], + addToFM vers_map name version + ) where - is_tycon_decl (TypeSig _ _ _) = True - is_tycon_decl (NewTypeSig _ _ _ _) = True - is_tycon_decl (DataSig _ _ _ _ _) = True - is_tycon_decl _ = False - - is_class_decl (ClassSig _ _ _ _) = True - is_class_decl _ = False - - is_val_decl (ValSig _ _ _) = True - is_val_decl (DataSig _ _ _ _ _) = True -- may be a constr or field - is_val_decl (NewTypeSig _ _ _ _) = True -- may be a constr - is_val_decl (ClassSig _ _ _ _) = True -- may be a method - is_val_decl _ = False + new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name) + +loadInstDecl :: Module -> Bag IfaceInst -> RdrNameInstDecl -> RnMG (Bag IfaceInst) +loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) + = initRnMS emptyRnEnv mod_name InterfaceMode $ + + -- Find out what type constructors and classes are mentioned in the + -- instance declaration. We have to be a bit clever. + -- + -- We want to rename the type so that we can find what + -- (free) type constructors are inside it. But we must *not* thereby + -- put new occurrences into the global pool because otherwise we'll force + -- them all to be loaded. We kill two birds with ones stone by renaming + -- with a fresh occurrence pool. + findOccurrencesRn (rnHsType inst_ty) `thenRn` \ ty_names -> + + returnRn ((ty_names, mod_name, decl) `consBag` insts) \end{code} -\begin{code} -readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error) -readIface file modname item - = --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >> - TRY_IO (readFile file) >>= \ read_result -> +%******************************************************** +%* * +\subsection{Loading usage information} +%* * +%******************************************************** + +\begin{code} +checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile +checkUpToDate mod_name + = findAndReadIface doc_str mod_name `thenRn` \ read_result -> case read_result of - Left err -> return (Failed (cannaeReadErr file err)) - Right contents -> --hPutStr stderr ".." >> - let parsed = parseIface contents in - --hPutStr stderr "..\n" >> - return ( - case parsed of - Failed _ -> parsed - Succeeded p -> Succeeded (init_merge modname p) - ) + Nothing -> -- Old interface file not found, so we'd better bale out + traceRn (ppSep [ppStr "Didnt find old iface", pprModule PprDebug mod_name]) `thenRn_` + returnRn False + + Just (ParsedIface _ _ usages _ _ _ _ _) + -> -- Found it, so now check it + checkModUsage usages where - init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags) - = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags -\end{code} + -- Only look in current directory, with suffix .hi + doc_str = ppSep [ppStr "Need usage info from", pprModule PprDebug mod_name] -\begin{code} -rnIfaces :: IfaceCache -- iface cache (mutvar) - -> [Module] -- directly imported modules - -> UniqSupply - -> RnEnv -- defined (in the source) name env - -> RnEnv -- mentioned (in the source) name env - -> RenamedHsModule -- module to extend with iface decls - -> [RnName] -- imported names required (really the - -- same info as in mentioned name env) - -- Also, all the things we may look up - -- later by key (Unique). - -> IO (RenamedHsModule, -- extended module - RnEnv, -- final env (for renaming derivings) - ImplicitEnv, -- implicit names used (for usage info) - (UsagesMap,VersionsMap,[Module]), -- usage info - (Bag Error, Bag Warning)) - -rnIfaces iface_cache imp_mods us - def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack) - occ_env@((qual, unqual, tc_qual, tc_unqual), stack) - rn_module@(HsModule modname iface_version exports imports fixities - typedecls typesigs classdecls instdecls instsigs - defdecls binds sigs src_loc) - todo - = {- - pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $ - pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ - pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ - pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ - pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ - - pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $ - pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $ - pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $ - pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $ - -} - - -- do transitive closure to bring in all needed names/defns and insts: - - decls_and_insts todo def_env occ_env empty_return us - >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs), - if_implicits, - if_errs_warns), - if_final_env) -> - - -- finalize what we want to say we learned about the - -- things we used - finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>= - \ usage_stuff@(usage_info, version_info, instance_mods) -> - - return (HsModule modname iface_version exports imports fixities - (typedecls ++ if_typedecls) - typesigs - (classdecls ++ if_classdecls) - (instdecls ++ if_instdecls) - instsigs defdecls binds - (sigs ++ if_sigs) - src_loc, - if_final_env, - if_implicits, - usage_stuff, - if_errs_warns) - where - decls_and_insts todo def_env occ_env to_return us - = let - (us1,us2) = splitUniqSupply us - in - do_decls todo -- initial batch of names to process - (def_env, occ_env, us1) -- init stuff down - to_return -- acc results - >>= \ (decls_return, - decls_def_env, - decls_occ_env) -> - - cacheInstModules iface_cache imp_mods >>= \ errs -> - - do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM - (add_errs errs decls_return) us2 - - -------- - do_insts def_env occ_env prev_env done_insts to_return us - | size_tc_env occ_env == size_tc_env prev_env - = return (to_return, occ_env) - - | otherwise - = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return - >>= \ (insts_return, - new_insts, - insts_occ_env, - new_unknowns) -> - - do_decls new_unknowns -- new batch of names to process - (def_env, insts_occ_env, us2) -- init stuff down - insts_return -- acc results - >>= \ (decls_return, - decls_def_env, - decls_occ_env) -> - - do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3 - where - (us1,us') = splitUniqSupply us - (us2,us3) = splitUniqSupply us' - - size_tc_env ((_, _, qual, unqual), _) - = sizeFM qual + sizeFM unqual - - - do_decls :: [RnName] -- Names we're looking for; we keep adding/deleting - -- from this list; we're done when empty (nothing - -- more needs to be looked for) - -> Go_Down -- see defn below - -> To_Return -- accumulated result - -> IO (To_Return, - RnEnv, -- extended decl env - RnEnv) -- extended occ env - - do_decls to_find@[] down to_return - = return (to_return, defenv down, occenv down) - - do_decls to_find@(n:ns) down to_return - = case (lookup_defd down n) of - Just _ -> -- previous processing must've found the stuff for this name; - -- continue with the rest: - -- pprTrace "do_decls:done:" (ppr PprDebug n) $ - do_decls ns down to_return - - Nothing - | moduleOf (origName "do_decls" n) == modname -> - -- avoid looking in interface for the module being compiled - --pprTrace "do_decls:this module error:" (ppr PprDebug n) $ - do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return) - - | otherwise -> - -- OK, see what the cache has for us... - - cachedDeclByType iface_cache n >>= \ maybe_ans -> - case maybe_ans of - CachingAvoided _ -> - --pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $ - do_decls ns down to_return - - CachingFail err -> -- add the error, but keep going: - --pprTrace "do_decls:cache error:" (ppr PprDebug n) $ - do_decls ns down (add_err err to_return) - - CachingHit iface_decl -> -- something needing renaming! - let - (us1, us2) = splitUniqSupply (uniqsupply down) - in - case (initRn False{-iface-} modname (occenv down) us1 ( - setExtraRn emptyUFM{-no fixities-} $ - rnIfaceDecl iface_decl)) of { - ((if_decl, if_defd, if_implicits), if_errs, if_warns) -> - let - new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits) - in - {- - pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n - , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns] - , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ] - , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ] - ]) $ - -} - do_decls (new_unknowns ++ ns) - (add_occs if_defd if_implicits $ - new_uniqsupply us2 down) - (add_decl if_decl $ - add_implicits if_implicits $ - add_errs if_errs $ - add_warns if_warns to_return) - } - ------------ -type Go_Down = (RnEnv, -- stuff we already have defns for; - -- to check quickly if we've already - -- found something for the name under consideration, - -- due to previous processing. - -- It starts off just w/ the defns for - -- the things in this module. - RnEnv, -- occurrence env; this gets added to as - -- we process new iface decls. It includes - -- entries for *all* occurrences, including those - -- for which we have definitions. - UniqSupply -- the obvious - ) - -lookup_defd (def_env, _, _) n - = (if isRnTyConOrClass n then lookupTcRnEnv else lookupRnEnv) def_env - (case (origName "lookup_defd" n) of { OrigName m s -> Qual m s }) - -- this is hack because we are reusing the RnEnv technology - -defenv (def_env, _, _) = def_env -occenv (_, occ_env, _) = occ_env -uniqsupply (_, _, us) = us - -new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us) - -add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us) - = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) -> - --(if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $ --- ASSERT(isEmptyBag def_dups) - let - de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ] - -- again, this hackery because we are reusing the RnEnv technology +checkModUsage [] = returnRn True -- Yes! Everything is up to date! - val_occs = val_defds ++ de_orig val_imps - tc_occs = tc_defds ++ de_orig tc_imps +checkModUsage ((mod, old_mod_vers, old_local_vers) : rest) + = loadInterface doc_str mod `thenRn` \ ifaces -> + let + Ifaces _ mod_vers_map _ new_vers_map _ _ _ = ifaces + maybe_new_mod_vers = lookupFM mod_vers_map mod + Just new_mod_vers = maybe_new_mod_vers in - case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) -> + -- If we can't find a version number for the old module then + -- bale out saying things aren't up to date + if not (maybeToBool maybe_new_mod_vers) then + returnRn False + else + + -- If the module version hasn't changed, just move on + if new_mod_vers == old_mod_vers then + traceRn (ppSep [ppStr "Module version unchanged:", pprModule PprDebug mod]) `thenRn_` + checkModUsage rest + else + traceRn (ppSep [ppStr "Module version has changed:", pprModule PprDebug mod]) `thenRn_` --- ASSERT(isEmptyBag occ_dups) --- False because we may get a dup on the name we just shoved in + -- New module version, so check entities inside + checkEntityUsage mod new_vers_map old_local_vers `thenRn` \ up_to_date -> + if up_to_date then + traceRn (ppStr "...but the bits I use havn't.") `thenRn_` + checkModUsage rest -- This one's ok, so check the rest + else + returnRn False -- This one failed, so just bail out now + where + doc_str = ppSep [ppStr "need version info for", pprModule PprDebug mod] - (new_def_env, new_occ_env, us) }} ----------------- -type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]), - ImplicitEnv, -- new names used implicitly - (Bag Error, Bag Warning) - ) - -empty_return :: To_Return -empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag)) - -add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs) - = case decl of - AddedTy t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs) - AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs) - AddedSig s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs) - -add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs) - = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs) - -add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs) - = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs) - -add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns)) -add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns)) -add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn)) -add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws)) +checkEntityUsage mod new_vers_map [] + = returnRn True -- Yes! All up to date! + +checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest) + = newGlobalName mod occ_name `thenRn` \ name -> + case lookupFM new_vers_map name of + + Nothing -> -- We used it before, but it ain't there now + traceRn (ppSep [ppStr "...and this no longer exported:", ppr PprDebug name]) `thenRn_` + returnRn False + + Just new_vers -> -- It's there, but is it up to date? + if new_vers == old_vers then + -- Up to date, so check the rest + checkEntityUsage mod new_vers_map rest + else + traceRn (ppSep [ppStr "...and this is out of date:", ppr PprDebug name]) `thenRn_` + returnRn False -- Out of date, so bale out \end{code} -\begin{code} -data AddedDecl -- purely local - = AddedTy RenamedTyDecl - | AddedClass RenamedClassDecl - | AddedSig RenamedSig - -rnIfaceDecl :: RdrIfaceDecl - -> RnM_Fixes REAL_WORLD - (AddedDecl, -- the resulting decl to add to the pot - ([(RdrName,RnName)], [(RdrName,RnName)]), - -- new val/tycon-class names that have - -- *been defined* while processing this decl - ImplicitEnv -- new implicit val/tycon-class names that we - -- stumbled into - ) - -rnIfaceDecl (TypeSig tc _ decl) - = rnTyDecl decl `thenRn` \ rn_decl -> - lookupTyCon tc `thenRn` \ rn_tc -> - getImplicitUpRn `thenRn` \ mentioned -> - let - defds = ([], [(tc, rn_tc)]) - implicits = mentioned `sub` defds - in - returnRn (AddedTy rn_decl, defds, implicits) -rnIfaceDecl (NewTypeSig tc dc _ decl) - = rnTyDecl decl `thenRn` \ rn_decl -> - lookupTyCon tc `thenRn` \ rn_tc -> - lookupValue dc `thenRn` \ rn_dc -> - getImplicitUpRn `thenRn` \ mentioned -> - let - defds = ([(dc, rn_dc)], [(tc, rn_tc)]) - implicits = mentioned `sub` defds - in - returnRn (AddedTy rn_decl, defds, implicits) - -rnIfaceDecl (DataSig tc dcs fcs _ decl) - = rnTyDecl decl `thenRn` \ rn_decl -> - lookupTyCon tc `thenRn` \ rn_tc -> - mapRn lookupValue dcs `thenRn` \ rn_dcs -> - mapRn lookupValue fcs `thenRn` \ rn_fcs -> - getImplicitUpRn `thenRn` \ mentioned -> - let - defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)]) - implicits = mentioned `sub` defds - in - returnRn (AddedTy rn_decl, defds, implicits) +%********************************************************* +%* * +\subsection{Getting in a declaration} +%* * +%********************************************************* -rnIfaceDecl (ClassSig clas ops _ decl) - = rnClassDecl decl `thenRn` \ rn_decl -> - lookupClass clas `thenRn` \ rn_clas -> - mapRn (lookupClassOp rn_clas) ops `thenRn` \ rn_ops -> - getImplicitUpRn `thenRn` \ mentioned -> - let - defds = (ops `zip` rn_ops, [(clas, rn_clas)]) - implicits = mentioned `sub` defds - in - returnRn (AddedClass rn_decl, defds, implicits) - -rnIfaceDecl (ValSig f src_loc ty) - -- should rename_sig in RnBinds be used here? ToDo - = lookupValue f `thenRn` \ rn_f -> - -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $ - rnPolyType nullTyVarNamesEnv ty `thenRn` \ rn_ty -> - getImplicitUpRn `thenRn` \ mentioned -> - let - defds = ([(f, rn_f)], []) - implicits = mentioned `sub` defds - in - returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits) +\begin{code} +getDecl :: Name -> RnMG (AvailInfo, RdrNameHsDecl) +getDecl name + = traceRn doc_str `thenRn_` + loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ _ decls_map _ _) -> + case lookupFM decls_map name of ----- -sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv + Just avail_w_decl -> returnRn avail_w_decl -sub (val_ment, tc_ment) (val_defds, tc_defds) - = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds), - delListFromFM tc_ment (map (qualToOrigName . fst) tc_defds)) + Nothing -> -- Can happen legitimately for "Optional" occurrences + returnRn (NotAvailable, ValD EmptyBinds) + where + (mod,_) = modAndOcc name + doc_str = ppSep [ppStr "Need decl for", ppr PprDebug name] \end{code} -% ------------------------------ +@getWiredInDecl@ maps a wired-in @Name@ to what it makes available. +It behaves exactly as if the wired in decl were actually in an interface file. +Specifically, + * if the wired-in name is a data type constructor or a data constructor, + it brings in the type constructor and all the data constructors; and + marks as "occurrences" any free vars of the data con. -@cacheInstModules@: cache instance modules specified in imports + * similarly for synonum type constructor -\begin{code} -cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error) + * if the wired-in name is another wired-in Id, it marks as "occurrences" + the free vars of the Id's type. -cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods - = readVar iface_var ST_THEN \ (iface_fm, _, _) -> - let - imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ] - (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces))) - get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims - in - --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $ - accumulate (map (cachedIface iface_cache False SLIT("instance_modules")) imp_imods) >>= \ err_or_ifaces -> + * it loads the interface file for the wired-in thing for the + sole purpose of making sure that its instance declarations are available - -- Sanity Check: - -- Assert that instance modules given by direct imports contains - -- instance modules extracted from all visited modules +All this is necessary so that we know all types that are "in play", so +that we know just what instances to bring into scope. + +\begin{code} +getWiredInDecl :: Name -> RnMG AvailInfo +getWiredInDecl name + = -- Force in the home module in case it has instance decls for + -- the thing we are interested in + (if mod == gHC__ then + returnRn () -- Mini hack; GHC is guaranteed not to have + -- instance decls, so it's a waste of time + -- to read it + else + loadInterface doc_str mod `thenRn_` + returnRn () + ) `thenRn_` + + if (maybeToBool maybe_wired_in_tycon) then + get_wired_tycon the_tycon + else -- Must be a wired-in-Id + if (isDataCon the_id) then -- ... a wired-in data constructor + get_wired_tycon (dataConTyCon the_id) + else -- ... a wired-in non data-constructor + get_wired_id the_id + where + doc_str = ppSep [ppStr "Need home module for wired in thing", ppr PprDebug name] + (mod,_) = modAndOcc name + maybe_wired_in_tycon = maybeWiredInTyConName name + maybe_wired_in_id = maybeWiredInIdName name + Just the_tycon = maybe_wired_in_tycon + Just the_id = maybe_wired_in_id + +get_wired_id id + = addImplicitOccsRn (nameSetToList id_mentioned) `thenRn_` + returnRn (Avail (getName id) []) + where + id_mentioned = namesOfType (idType id) - readVar iface_var ST_THEN \ (all_iface_fm, _, _) -> - let - all_ifaces = eltsFM all_iface_fm - (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces)))) - in - ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods) +get_wired_tycon tycon + | isSynTyCon tycon + = addImplicitOccsRn (nameSetToList mentioned) `thenRn_` + returnRn (Avail (getName tycon) []) + where + (tyvars,ty) = getSynTyConDefn tycon + mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars) - return (bag_errs err_or_ifaces) +get_wired_tycon tycon + | otherwise -- data or newtype + = addImplicitOccsRn (nameSetToList mentioned) `thenRn_` + returnRn (Avail (getName tycon) (map getName data_cons)) where - bag_errs [] = emptyBag - bag_errs (Failed err :rest) = err `consBag` bag_errs rest - bag_errs (Succeeded _:rest) = bag_errs rest + data_cons = tyConDataCons tycon + mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons \end{code} -@rnIfaceInstStuff@: Deal with instance declarations from interface files. +%********************************************************* +%* * +\subsection{Getting other stuff} +%* * +%********************************************************* \begin{code} -type InstanceEnv = FiniteMap (OrigName, OrigName) Int - -rnIfaceInstStuff - :: IfaceCache -- all about ifaces we've read - -> Module - -> UniqSupply - -> RnEnv -- current occ env - -> InstanceEnv -- instances for these tycon/class pairs done - -> To_Return - -> IO (To_Return, - InstanceEnv, -- extended instance env - RnEnv, -- final occ env - [RnName]) -- new unknown names - -rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_inst_env to_return - = -- all the instance decls we might even want to consider - -- are in the ParsedIfaces that are in our cache - - readVar iface_var ST_THEN \ (_, orig_iface_fm, _) -> - let - all_ifaces = eltsFM orig_iface_fm - all_insts = concat (map get_insts all_ifaces) - interesting_insts = filter want_inst all_insts +getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)]) +getInterfaceExports mod + = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _) -> + case lookupFM export_envs mod of + Nothing -> -- Not there; it must be that the interface file wasn't found; + -- the error will have been reported already. + -- (Actually loadInterface should put the empty export env in there + -- anyway, but this does no harm.) + returnRn ([],[]) + + Just stuff -> returnRn stuff + where + doc_str = ppSep [pprModule PprDebug mod, ppStr "is directly imported"] - -- Sanity Check: - -- Assert that there are no more instances for the done instances - claim_done = filter is_done_inst all_insts - claim_done_env = foldr add_done_inst emptyFM claim_done +getImportedInstDecls :: RnMG [IfaceInst] +getImportedInstDecls + = -- First load any special-instance modules that aren't aready loaded + getSpecialInstModules `thenRn` \ inst_mods -> + mapRn load_it inst_mods `thenRn_` - has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v } + -- Now we're ready to grab the instance declarations + getIfacesRn `thenRn` \ ifaces -> + let + Ifaces _ _ _ _ _ insts _ = ifaces in - {- - pprTrace "all_insts:\n" (ppr_insts (bagToList all_insts)) $ - pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $ - -} - ASSERT(sizeFM done_inst_env == sizeFM claim_done_env) - ASSERT(all (has_val claim_done_env) (fmToList done_inst_env)) - - case (initRn False{-iface-} modname occ_env us ( - setExtraRn emptyUFM{-no fixities-} $ - mapRn rnIfaceInst interesting_insts `thenRn` \ insts -> - getImplicitUpRn `thenRn` \ implicits -> - returnRn (insts, implicits))) of { - ((if_insts, if_implicits), if_errs, if_warns) -> - - return (add_insts if_insts $ - add_implicits if_implicits $ - add_errs if_errs $ - add_warns if_warns to_return, - foldr add_done_inst done_inst_env interesting_insts, - add_imp_occs if_implicits occ_env, - eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)) - } + returnRn (bagToList insts) where - get_insts (ParsedIface imod _ _ _ _ _ _ _ _ _ _ insts _) = [(imod, inst) | inst <- bagToList insts] - - tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon) - - add_done_inst (_, InstSig clas tycon _ _) inst_env - = addToFM_C (+) inst_env (tycon_class clas tycon) 1 - - is_done_inst (_, InstSig clas tycon _ _) - = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon)) - - add_imp_occs (val_imps, tc_imps) occ_env - = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of - (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups) - ext_occ_env - where - de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ] - -- again, this hackery because we are reusing the RnEnv technology - - want_inst i@(imod, InstSig clas tycon _ _) - = -- it's a "good instance" (one to hang onto) if we have a - -- chance of referring to *both* the class and tycon later on ... - --pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $ - mentionable tycon && mentionable clas && not (is_done_inst i) - where - mentionable nm - = case lookupTcRnEnv occ_env nm of - Just _ -> True - Nothing -> -- maybe it's builtin - let orig = qualToOrigName nm in - case (lookupFM builtinTcNamesMap orig) of - Just _ -> True - Nothing -> maybeToBool (lookupFM builtinKeysMap orig) + load_it mod = loadInterface (doc_str mod) mod + doc_str mod = ppSep [pprModule PprDebug mod, ppStr "is a special-instance module"] + +getSpecialInstModules :: RnMG [Module] +getSpecialInstModules + = getIfacesRn `thenRn` \ ifaces -> + let + Ifaces _ _ _ _ _ _ inst_mods = ifaces + in + returnRn inst_mods \end{code} \begin{code} -rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl +getImportVersions :: [AvailInfo] -- Imported avails + -> RnMG (VersionInfo Name) -- Version info for these names -rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod) +getImportVersions imported_avails + = getIfacesRn `thenRn` \ ifaces -> + let + Ifaces _ mod_versions_map _ version_map _ _ _ = ifaces + + -- import_versions is harder: we have to group together all the things imported + -- from a particular module. We do this with yet another finite map + + mv_map :: FiniteMap Module [LocalVersion Name] + mv_map = foldl add_mv emptyFM imported_avails + add_mv mv_map (Avail name _) + | isWiredInName name = mv_map -- Don't record versions for wired-in names + | otherwise = case lookupFM mv_map mod of + Just versions -> addToFM mv_map mod ((name,version):versions) + Nothing -> addToFM mv_map mod [(name,version)] + where + (mod,_) = modAndOcc name + version = case lookupFM version_map name of + Just v -> v + Nothing -> pprPanic "getVersionInfo:" (ppr PprDebug name) + + import_versions = [ (mod, expectJust "import_versions" (lookupFM mod_versions_map mod), local_versions) + | (mod, local_versions) <- fmToList mv_map + ] + + -- Question: should we filter the builtins out of import_versions? + in + returnRn import_versions \end{code} +%********************************************************* +%* * +\subsection{Getting binders out of a declaration} +%* * +%********************************************************* + +@getDeclBinders@ returns the names for a @RdrNameHsDecl@. +It's used for both source code (from @availsFromDecl@) and interface files +(from @loadDecl@). + +It doesn't deal with source-code specific things: ValD, DefD. They +are handled by the sourc-code specific stuff in RnNames. + \begin{code} -type BigMaps = (FiniteMap Module Version, -- module-version map - FiniteMap (FAST_STRING,Module) Version) -- ordinary version map - -finalIfaceInfo :: - IfaceCache -- iface cache - -> Module -- this module's name - -> RnEnv - -> [RenamedInstDecl] --- -> [RnName] -- all imported names required --- -> [Module] -- directly imported modules - -> IO (UsagesMap, - VersionsMap, -- info about version numbers - [Module]) -- special instance modules - -finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls - = --- pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ --- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ --- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ --- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ - readVar iface_var ST_THEN \ (_, orig_iface_fm, _) -> - let - all_ifaces = eltsFM orig_iface_fm - -- all the interfaces we have looked at +getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function + -> RdrNameHsDecl + -> RnMG AvailInfo - big_maps - -- combine all the version maps we have seen into maps to - -- (a) lookup a module-version number, lookup an entity's - -- individual version number - = foldr mk_map (emptyFM,emptyFM) all_ifaces +getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc)) + = new_name tycon src_loc `thenRn` \ tycon_name -> + getConFieldNames new_name condecls `thenRn` \ sub_names -> + returnRn (Avail tycon_name sub_names) - val_stuff@(val_usages, val_versions) - = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual +getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc)) + = new_name tycon src_loc `thenRn` \ tycon_name -> + new_name con src_loc `thenRn` \ con_name -> + returnRn (Avail tycon_name [con_name]) - (all_usages, all_versions) - = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual - in - return (all_usages, all_versions, []) +getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc)) + = new_name tycon src_loc `thenRn` \ tycon_name -> + returnRn (Avail tycon_name []) + +getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc)) + = new_name cname src_loc `thenRn` \ class_name -> + mapRn (getClassOpNames new_name) sigs `thenRn` \ sub_names -> + returnRn (Avail class_name sub_names) + +getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc)) + = new_name var src_loc `thenRn` \ var_name -> + returnRn (Avail var_name []) + +getDeclBinders new_name (DefD _) = returnRn NotAvailable +getDeclBinders new_name (InstD _) = returnRn NotAvailable + +---------------- +getConFieldNames new_name (ConDecl con _ src_loc : rest) + = new_name con src_loc `thenRn` \ n -> + getConFieldNames new_name rest `thenRn` \ ns -> + returnRn (n:ns) + +getConFieldNames new_name (NewConDecl con _ src_loc : rest) + = new_name con src_loc `thenRn` \ n -> + getConFieldNames new_name rest `thenRn` \ ns -> + returnRn (n:ns) + +getConFieldNames new_name (ConOpDecl _ con _ src_loc : rest) + = new_name con src_loc `thenRn` \ n -> + getConFieldNames new_name rest `thenRn` \ ns -> + returnRn (n:ns) + +getConFieldNames new_name (RecConDecl con fielddecls src_loc : rest) + = mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs -> + getConFieldNames new_name rest `thenRn` \ ns -> + returnRn (cfs ++ ns) where - mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map) - = (addToFM mv_map m mv, -- add this module - addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ]) - - ----------------------- - process_item :: BigMaps - -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components - -> (UsagesMap, VersionsMap) -- input - -> (UsagesMap, VersionsMap) -- output - - process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions) - | irrelevant rn - = as_before - | m == modname -- this module => add to "versions" - = (usages, addToFM versions n 1{-stub-}) - | otherwise -- from another module => add to "usages" - = case (add_to_usages usages key) of - Nothing -> as_before - Just new_usages -> (new_usages, versions) - where - add_to_usages usages key@(n,m) - = case (lookupFM big_mv_map m) of - Nothing -> Nothing - Just mv -> - case (lookupFM big_version_map key) of - Nothing -> Nothing - Just kv -> - Just $ addToFM usages m ( - case (lookupFM usages m) of - Nothing -> -- nothing for this module yet... - (mv, unitFM n kv) - - Just (mversion, mstuff) -> -- the "new" stuff will shadow the old - ASSERT(mversion == mv) - (mversion, addToFM mstuff n kv) - ) - - irrelevant (RnConstr _ _) = True -- We don't report these in their - irrelevant (RnField _ _) = True -- own right in usages/etc. - irrelevant (RnClassOp _ _) = True - irrelevant (RnImplicit n) = isLexCon (nameOf (origName "irrelevant" n)) -- really a RnConstr - irrelevant _ = False + fields = concat (map fst fielddecls) + +getConFieldNames new_name [] = returnRn [] +getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc \end{code} +%********************************************************* +%* * +\subsection{Reading an interface file} +%* * +%********************************************************* + \begin{code} -thisModImplicitWarn mod n sty - = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppr sty n, ppPStr SLIT("; assuming this module will provide it.")] +findAndReadIface :: Pretty -> Module -> RnMG (Maybe ParsedIface) + -- Nothing <=> file not found, or unreadable, or illegible + -- Just x <=> successfully found and parsed +findAndReadIface doc_str mod + = traceRn trace_msg `thenRn_` + getSearchPathRn `thenRn` \ dirs -> + try dirs dirs + where + trace_msg = ppHang (ppBesides [ppStr "Reading interface for ", + pprModule PprDebug mod, ppSemi]) + 4 (ppBesides [ppStr "reason: ", doc_str]) + + try all_dirs [] = traceRn (ppStr "...failed") `thenRn_` + returnRn Nothing + + try all_dirs (dir:dirs) + = readIface file_path `thenRn` \ read_result -> + case read_result of + Nothing -> try all_dirs dirs + Just iface -> traceRn (ppStr "...done") `thenRn_` + returnRn (Just iface) + where + file_path = dir ++ "/" ++ moduleString mod ++ ".hi" +\end{code} -noIfaceErr mod sty - = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod] +@readIface@ trys just one file. -noOrigIfaceErr mod sty - = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod] +\begin{code} +readIface :: String -> RnMG (Maybe ParsedIface) + -- Nothing <=> file not found, or unreadable, or illegible + -- Just x <=> successfully found and parsed +readIface file_path + = ioToRnMG (readFile file_path) `thenRn` \ read_result -> + case read_result of + Right contents -> case parseIface contents of + Failed err -> failWithRn Nothing err + Succeeded iface -> returnRn (Just iface) -noDeclInIfaceErr mod str sty - = ppBesides [ppPStr SLIT("Could not find interface declaration of: "), - ppPStr mod, ppStr ".", ppPStr str] + Left (NoSuchThing _) -> returnRn Nothing -cannaeReadErr file err sty - = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)] + Left err -> failWithRn Nothing + (cannaeReadFile file_path err) + +\end{code} + +mkSearchPath takes a string consisting of a colon-separated list of directories, and turns it into +a list of directories. For example: + + mkSearchPath "foo:.:baz" = ["foo", ".", "baz"] + +\begin{code} +mkSearchPath :: Maybe String -> SearchPath +mkSearchPath Nothing = ["."] +mkSearchPath (Just s) + = go s + where + go "" = [] + go s = first : go (drop 1 rest) + where + (first,rest) = span (/= ':') s +\end{code} -ifaceLookupWiredErr msg n sty - = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n] +%********************************************************* +%* * +\subsection{Errors} +%* * +%********************************************************* -badIfaceLookupErr msg name decl sty - = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"] +\begin{code} +noIfaceErr mod sty + = ppBesides [ppStr "Could not find interface for ", ppQuote (pprModule sty mod)] +-- , ppStr " in"]) 4 (ppAboves (map ppStr dirs)) -ifaceIoErr io_msg rn sty - = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn] +cannaeReadFile file err sty + = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)] \end{code} diff --git a/ghc/compiler/rename/RnLoop.lhi b/ghc/compiler/rename/RnLoop.lhi index f228aee..8aa729d 100644 --- a/ghc/compiler/rename/RnLoop.lhi +++ b/ghc/compiler/rename/RnLoop.lhi @@ -3,16 +3,18 @@ Breaks the RnSource/RnExpr/RnBinds loops. \begin{code} interface RnLoop where -import RdrHsSyn ( RdrNameHsBinds(..), RdrNamePolyType(..) ) -import RnHsSyn ( RnName, RenamedHsBinds(..), RenamedPolyType(..) ) -import RnBinds ( rnBinds, FreeVars(..) ) -import RnMonad ( TyVarNamesEnv(..), RnM_Fixes(..) ) -import RnSource ( rnPolyType ) +import RdrHsSyn ( RdrNameHsBinds(..), RdrNameHsType(..) ) +import RnHsSyn ( RenamedHsBinds(..), RenamedHsType(..) ) +import RnBinds ( rnBinds ) +import RnMonad ( RnMS(..), FreeVars ) +import RnSource ( rnHsType ) import UniqSet ( UniqSet(..) ) +import Name ( Name ) -rnBinds :: RdrNameHsBinds -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName]) -rnPolyType :: TyVarNamesEnv - -> RdrNamePolyType - -> RnM_Fixes s RenamedPolyType -type FreeVars = UniqSet RnName +rnBinds :: RdrNameHsBinds + -> (RenamedHsBinds -> RnMS s (result, FreeVars)) + -> RnMS s (result, FreeVars) + +rnHsType :: RdrNameHsType + -> RnMS s RenamedHsType \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 22cb653..f1fd847 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -6,166 +6,337 @@ \begin{code} #include "HsVersions.h" -module RnMonad ( - SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(RnM_Fixes), RnDown, SST_R, - initRn, thenRn, thenRn_, andRn, returnRn, - mapRn, mapAndUnzipRn, mapAndUnzip3Rn, - - addErrRn, addErrIfRn, addWarnRn, addWarnIfRn, - failButContinueRn, warnAndContinueRn, - setExtraRn, getExtraRn, getRnEnv, - getModuleRn, pushSrcLocRn, getSrcLocRn, - getSourceRn, getOccurrenceUpRn, - getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv, - rnGetUnique, rnGetUniques, - - newLocalNames, - lookupValue, lookupConstr, lookupField, lookupClassOp, - lookupTyCon, lookupClass, lookupTyConOrClass, - extendSS2, extendSS, - - SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv, - lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs, - - fixIO +module RnMonad( + RnMonad.., + SST_R ) where IMP_Ubiq(){-uitous-} -IMPORT_1_3(GHCbase(fixIO)) import SST +import PreludeGlaST ( SYN_IE(ST), thenST, returnST ) -import HsSyn ( FixityDecl ) -import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit, - mkRnImplicitTyCon, mkRnImplicitClass, - isRnLocal, isRnWired, isRnTyCon, isRnClass, - isRnTyConOrClass, isRnConstr, isRnField, - isRnClassOp, RenamedFixityDecl(..) ) -import RnUtils ( SYN_IE(RnEnv), extendLocalRnEnv, - lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, - qualNameErr, dupNamesErr - ) - -import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) -import CmdLineOpts ( opt_WarnNameShadowing ) +import HsSyn +import RdrHsSyn import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine, - SYN_IE(Error), SYN_IE(Warning) + pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning) ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM{-, fmToList ToDo:rm-} ) -import Maybes ( assocMaybe ) -import Name ( SYN_IE(Module), RdrName(..), isQual, - OrigName(..), Name, mkLocalName, mkImplicitName, - getOccName, pprNonSym +import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), + modAndOcc, NamedThing(..) ) -import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) -import PrelMods ( pRELUDE ) ---import PprStyle{-ToDo:rm-} ---import Outputable{-ToDo:rm-} +import CmdLineOpts ( opt_D_show_rn_trace ) +import PrelInfo ( builtinNames ) +import TyCon ( TyCon {- instance NamedThing -} ) +import TysWiredIn ( boolTyCon ) import Pretty -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) -import UniqFM ( UniqFM, emptyUFM ) -import UniqSet ( SYN_IE(UniqSet), mkUniqSet, minusUniqSet ) -import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply ) +import PprStyle ( PprStyle(..) ) +import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) import Unique ( Unique ) +import FiniteMap ( FiniteMap, emptyFM, bagToFM ) +import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) +import UniqSet import Util infixr 9 `thenRn`, `thenRn_` \end{code} + +%************************************************************************ +%* * +\subsection{Somewhat magical interface to other monads} +%* * +%************************************************************************ + \begin{code} -type RnM s r = RnMonad () s r -type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r - -type RnMonad x s r = RnDown x s -> SST s r - -data RnDown x s - = RnDown - x - Module -- Module name - SrcLoc -- Source location - (RnMode s) -- Source or Iface - RnEnv -- Renaming environment - (MutableVar s UniqSupply) -- Unique supply - (MutableVar s (Bag Warning, -- Warnings and Errors - Bag Error)) - -data RnMode s - = RnSource (MutableVar s (Bag (RnName, RdrName))) - -- Renaming source; returning occurences - - | RnIface BuiltinNames BuiltinKeys - (MutableVar s ImplicitEnv) - -- Renaming interface; creating and returning implicit names - -- ImplicitEnv: one map for Values and one for TyCons/Classes. - -type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName) -emptyImplicitEnv :: ImplicitEnv -emptyImplicitEnv = (emptyFM, emptyFM) - --- With a builtin polymorphic type for runSST the type for --- initTc should use RnM s r instead of RnM RealWorld r #if __GLASGOW_HASKELL__ >= 200 -# define REAL_WORLD GHCbuiltins.RealWorld +# define REAL_WORLD RealWorld #else # define REAL_WORLD _RealWorld #endif +\end{code} + +\begin{code} +sstToIO :: SST REAL_WORLD r -> IO r +sstToIO sst + = sstToST sst `thenST` \ r -> + returnST (Right r) + +ioToRnMG :: IO r -> RnMG (Either IOError13 r) +ioToRnMG io rn_down g_down = stToSST io + +traceRn :: Pretty -> RnMG () +traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >> + hPutStr stderr "\n") `thenRn_` + returnRn () + | otherwise = returnRn () +\end{code} -initRn :: Bool -- True => Source; False => Iface - -> Module - -> RnEnv - -> UniqSupply - -> RnM REAL_WORLD r - -> (r, Bag Error, Bag Warning) -initRn source mod env us do_rn - = runSST ( - newMutVarSST emptyBag `thenSST` \ occ_var -> - newMutVarSST emptyImplicitEnv `thenSST` \ imp_var -> - newMutVarSST us `thenSST` \ us_var -> - newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> - let - mode = if source then - RnSource occ_var - else - RnIface builtinNameMaps builtinKeysMap imp_var - - rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var - in +%************************************************************************ +%* * +\subsection{Data types} +%* * +%************************************************************************ + +=================================================== + MONAD TYPES +=================================================== + +\begin{code} +type RnM s d r = RnDown s -> d -> SST s r +type RnMS s r = RnM s (SDown s) r -- Renaming source +type RnMG r = RnM REAL_WORLD GDown r -- Getting global names etc +type MutVar a = MutableVar REAL_WORLD a -- ToDo: there ought to be a standard defn of this + + -- Common part +data RnDown s = RnDown + SrcLoc + (MutableVar s RnNameSupply) + (MutableVar s (Bag Warning, Bag Error)) + (MutableVar s [(Name,Necessity)]) -- Occurrences + +data Necessity = Compulsory | Optional -- We *must* find definitions for + -- compulsory occurrences; we *may* find them + -- for optional ones. + + -- For getting global names +data GDown = GDown + SearchPath + (MutVar Ifaces) + + -- For renaming source code +data SDown s = SDown + RnEnv + Module + RnSMode + + +data RnSMode = SourceMode + | InterfaceMode + +type SearchPath = [String] -- List of directories to seach for interface files +type FreeVars = NameSet +\end{code} + +=================================================== + ENVIRONMENTS +=================================================== + +\begin{code} +type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name) + -- Ensures that one (m,n) pair gets one unique + -- The Int is used to give a number to each instance declaration; + -- it's really a separate name supply. + +data RnEnv = RnEnv NameEnv FixityEnv +emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv + +type NameEnv = FiniteMap RdrName Name +emptyNameEnv = emptyFM + +type FixityEnv = FiniteMap RdrName (Fixity, Provenance) +emptyFixityEnv = emptyFM + -- It's possible to have a different fixity for B.op than for op: + -- + -- module A( op ) where module B where + -- import qualified B( op ) infixr 2 op + -- infixl 9 `op` op = ... + -- op a b = a `B.op` b + +data ExportEnv = ExportEnv Avails Fixities +type Avails = [AvailInfo] +type Fixities = [(OccName, Fixity, Provenance)] + -- Can contain duplicates, if one module defines the same fixity, + -- or the same type/class/id, more than once. Hence a boring old list. + -- This allows us to report duplicates in just one place, namely plusRnEnv. + +type ModuleAvails = FiniteMap Module Avails + +data AvailInfo = NotAvailable | Avail Name [Name] +\end{code} + +=================================================== + INTERFACE FILE STUFF +=================================================== + +\begin{code} +type ExportItem = (Module, OccName, [OccName]) +type VersionInfo name = [ImportVersion name] +type ImportVersion name = (Module, Version, [LocalVersion name]) +type LocalVersion name = (name, Version) + +data ParsedIface + = ParsedIface + Module -- Module name + Version -- Module version number + [ImportVersion OccName] -- Usages + [ExportItem] -- Exports + [Module] -- Special instance modules + [(OccName,Fixity)] -- Fixities + [(Version, RdrNameHsDecl)] -- Local definitions + [RdrNameInstDecl] -- Local instance declarations + +type InterfaceDetails = (VersionInfo Name, -- Version information + ExportEnv, -- What this module exports + [Module]) -- Instance modules + +type RdrNamePragma = () -- Fudge for now +------------------- + +data Ifaces = Ifaces + Module -- Name of this module + (FiniteMap Module Version) + (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports + VersionMap + DeclsMap + (Bag IfaceInst) + [Module] -- Set of modules with "special" instance declarations + -- Excludes this module + +type DeclsMap = FiniteMap Name (AvailInfo, RdrNameHsDecl) +type VersionMap = FiniteMap Name Version +type IfaceInst = ([Name], Module, RdrNameInstDecl) -- The Names are those tycons and + -- classes mentioned by the instance type +\end{code} + + +%************************************************************************ +%* * +\subsection{Main monad code} +%* * +%************************************************************************ + +\begin{code} +initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc + -> RnMG r + -> IO (r, Bag Error, Bag Warning) + +initRn mod us dirs loc do_rn + = sstToIO $ + newMutVarSST (us, 1, builtins) `thenSST` \ names_var -> + newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> + newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var -> + newMutVarSST initOccs `thenSST` \ occs_var -> + let + rn_down = RnDown loc names_var errs_var occs_var + g_down = GDown dirs iface_var + in -- do the buisness - do_rn rn_down `thenSST` \ res -> + do_rn rn_down g_down `thenSST` \ res -> -- grab errors and return - readMutVarSST errs_var `thenSST` \ (warns,errs) -> - returnSST (res, errs, warns) + readMutVarSST errs_var `thenSST` \ (warns,errs) -> + returnSST (res, errs, warns) + + +initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r +initRnMS env mod_name mode m rn_down g_down + = let + s_down = SDown env mod_name mode + in + m rn_down s_down + + +emptyIfaces :: Module -> Ifaces +emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyFM emptyBag [] + +builtins :: FiniteMap (Module,OccName) Name +builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames) + + -- Initial value for the occurrence pool. +initOccs :: [(Name,Necessity)] +initOccs = [(getName boolTyCon, Compulsory)] + -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and + -- rather implausible that not one will be used in the module. + -- We could add some other common types, notably lists, but the general idea is + -- to do as much as possible explicitly. +\end{code} + +\end{code} + + +@renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of +the main renamer. Examples: pragmas (which we don't want to rename unless +we actually explore them); and derived definitions, which are only generated +in the type checker. + +The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than +once you must either split it, or install a fresh unique supply. + +\begin{code} +renameSourceCode :: Module + -> RnNameSupply + -> RnMS REAL_WORLD r + -> r + +-- Alas, we can't use the real runST, with the desired signature: +-- renameSourceCode :: RnNameSupply -> RnMS s r -> r +-- because we can't manufacture "new versions of runST". + +renameSourceCode mod_name name_supply m + = runSST ( + newMutVarSST name_supply `thenSST` \ names_var -> + newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> + newMutVarSST [] `thenSST` \ occs_var -> + let + rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var + s_down = SDown emptyRnEnv mod_name InterfaceMode + in + m rn_down s_down `thenSST` \ result -> + + readMutVarSST errs_var `thenSST` \ (warns,errs) -> + + (if not (isEmptyBag errs) then + trace ("Urk! renameSourceCode found errors" ++ display errs) + else if not (isEmptyBag warns) then + trace ("Urk! renameSourceCode found warnings" ++ display warns) + else + id) $ + + returnSST result ) + where + display errs = ppShow 80 (pprBagOfErrors PprDebug errs) {-# INLINE thenRn #-} {-# INLINE thenRn_ #-} {-# INLINE returnRn #-} {-# INLINE andRn #-} -returnRn :: a -> RnMonad x s a -thenRn :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b -thenRn_ :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b -andRn :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a -mapRn :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b] -mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c]) - -returnRn v down = returnSST v -thenRn m k down = m down `thenSST` \ r -> k r down -thenRn_ m k down = m down `thenSST_` k down - -andRn combiner m1 m2 down - = m1 down `thenSST` \ res1 -> - m2 down `thenSST` \ res2 -> +returnRn :: a -> RnM s d a +thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b +thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b +andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a +mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b] +sequenceRn :: [RnM s d a] -> RnM s d [a] +foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b +mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c]) +fixRn :: (a -> RnM s d a) -> RnM s d a + +returnRn v gdown ldown = returnSST v +thenRn m k gdown ldown = m gdown ldown `thenSST` \ r -> k r gdown ldown +thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown +fixRn m gdown ldown = fixSST (\r -> m r gdown ldown) +andRn combiner m1 m2 gdown ldown + = m1 gdown ldown `thenSST` \ res1 -> + m2 gdown ldown `thenSST` \ res2 -> returnSST (combiner res1 res2) +sequenceRn [] = returnRn [] +sequenceRn (m:ms) = m `thenRn` \ r -> + sequenceRn ms `thenRn` \ rs -> + returnRn (r:rs) + mapRn f [] = returnRn [] mapRn f (x:xs) = f x `thenRn` \ r -> mapRn f xs `thenRn` \ rs -> returnRn (r:rs) +foldlRn k z [] = returnRn z +foldlRn k z (x:xs) = k z x `thenRn` \ z' -> + foldlRn k z' xs + mapAndUnzipRn f [] = returnRn ([],[]) mapAndUnzipRn f (x:xs) = f x `thenRn` \ (r1, r2) -> @@ -179,403 +350,168 @@ mapAndUnzip3Rn f (x:xs) returnRn (r1:rs1, r2:rs2, r3:rs3) \end{code} -For errors and warnings ... -\begin{code} -failButContinueRn :: a -> Error -> RnMonad x s a -failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var) - = readMutVarSST errs_var `thenSST` \ (warns,errs) -> - writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` - returnSST res - -warnAndContinueRn :: a -> Warning -> RnMonad x s a -warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var) - = readMutVarSST errs_var `thenSST` \ (warns,errs) -> - writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` - returnSST res - -addErrRn :: Error -> RnMonad x s () -addErrRn err = failButContinueRn () err - -addErrIfRn :: Bool -> Error -> RnMonad x s () -addErrIfRn True err = addErrRn err -addErrIfRn False err = returnRn () - -addWarnRn :: Warning -> RnMonad x s () -addWarnRn warn = warnAndContinueRn () warn - -addWarnIfRn :: Bool -> Warning -> RnMonad x s () -addWarnIfRn True warn = addWarnRn warn -addWarnIfRn False warn = returnRn () -\end{code} - -\begin{code} -getRnEnv :: RnMonad x s RnEnv -getRnEnv (RnDown _ _ _ _ env _ _) - = returnSST env - -setExtraRn :: x -> RnMonad x s r -> RnMonad y s r -setExtraRn x m (RnDown _ mod locn mode env us errs) - = m (RnDown x mod locn mode env us errs) - -getExtraRn :: RnMonad x s x -getExtraRn (RnDown x _ _ _ _ _ _) - = returnSST x - -getModuleRn :: RnMonad x s Module -getModuleRn (RnDown _ mod _ _ _ _ _) - = returnSST mod - -pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a -pushSrcLocRn locn m (RnDown x mod _ mode env us errs) - = m (RnDown x mod locn mode env us errs) - -getSrcLocRn :: RnMonad x s SrcLoc -getSrcLocRn (RnDown _ _ locn _ _ _ _) - = returnSST locn - -getSourceRn :: RnMonad x s Bool -getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True -getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False - -getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName)) -getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _) - = readMutVarSST occ_var -getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) - = panic "getOccurrenceUpRn:RnIface" - -getImplicitUpRn :: RnMonad x s ImplicitEnv -getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _) - = readMutVarSST imp_var -getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _) - = panic "getImplicitUpRn:RnIface" -\end{code} -\begin{code} -rnGetUnique :: RnMonad x s Unique -rnGetUnique (RnDown _ _ _ _ _ us_var _) - = get_unique us_var +%************************************************************************ +%* * +\subsection{Boring plumbing for common part} +%* * +%************************************************************************ -rnGetUniques :: Int -> RnMonad x s [Unique] -rnGetUniques n (RnDown _ _ _ _ _ us_var _) - = get_uniques n us_var - -get_unique us_var - = readMutVarSST us_var `thenSST` \ uniq_supply -> - let - (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply - uniq = getUnique uniq_s - in - writeMutVarSST us_var new_uniq_supply `thenSST_` - returnSST uniq - -get_uniques n us_var - = readMutVarSST us_var `thenSST` \ uniq_supply -> - let - (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply - uniqs = getUniques n uniq_s - in - writeMutVarSST us_var new_uniq_supply `thenSST_` - returnSST uniqs - -snoc_bag_var add bag_var - = readMutVarSST bag_var `thenSST` \ bag -> - writeMutVarSST bag_var (bag `snocBag` add) - -\end{code} - -********************************************************* -* * -\subsection{Making new names} -* * -********************************************************* - -@newLocalNames@ takes a bunch of RdrNames, which are defined together -in a group (eg a pattern or set of bindings), checks they are -unqualified and distinct, and creates new Names for them. +================ Errors and warnings ===================== \begin{code} -newLocalNames :: String -- Documentation string - -> [(RdrName, SrcLoc)] - -> RnMonad x s [RnName] - -newLocalNames str names_w_loc - = mapRn (addErrRn . qualNameErr str) quals `thenRn_` - mapRn (addErrRn . dupNamesErr str) dups `thenRn_` - mkLocalNames these +failWithRn :: a -> Error -> RnM s d a +failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST errs_var `thenSST` \ (warns,errs) -> + writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` + returnSST res where - quals = filter (isQual.fst) names_w_loc - (these, dups) = removeDups cmp_fst names_w_loc - cmp_fst (a,_) (b,_) = cmp a b -\end{code} + err = addShortErrLocLine loc msg -\begin{code} -mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName] -mkLocalNames names_w_locs - = rnGetUniques (length names_w_locs) `thenRn` \ uniqs -> - returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs) +warnWithRn :: a -> Warning -> RnM s d a +warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST errs_var `thenSST` \ (warns,errs) -> + writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` + returnSST res where - new_local uniq (Unqual str, srcloc) - = mkRnName (mkLocalName uniq str False{-emph names-} srcloc) -\end{code} + warn = addShortWarnLocLine loc msg +addErrRn :: Error -> RnM s d () +addErrRn err = failWithRn () err -********************************************************* -* * -\subsection{Looking up values} -* * -********************************************************* +checkRn :: Bool -> Error -> RnM s d () -- Check that a condition is true +checkRn False err = addErrRn err +checkRn True err = returnRn () -Action to look up a value depends on the RnMode. -\begin{description} -\item[RnSource:] -Lookup value in RnEnv, recording occurrence for non-local values found. -If not found report error and return Unbound name. -\item[RnIface:] -Lookup value in RnEnv. If not found lookup in implicit name env. -If not found create new implicit name, adding it to the implicit env. -\end{description} +addWarnRn :: Warning -> RnM s d () +addWarnRn warn = warnWithRn () warn -\begin{code} -lookupValue :: RdrName -> RnMonad x s RnName -lookupConstr :: RdrName -> RnMonad x s RnName -lookupField :: RdrName -> RnMonad x s RnName -lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName - -lookupValue rdr - = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value") - -lookupConstr rdr - = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor") - -lookupField rdr - = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field") +checkErrsRn :: RnM s d Bool -- True <=> no errors so far +checkErrsRn (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST errs_var `thenSST` \ (warns,errs) -> + returnSST (isEmptyBag errs) +\end{code} -lookupClassOp cls rdr - = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls) --- Note: the lookup checks are only performed when renaming source +================ Source location ===================== -lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) - = case lookup env rdr of - Just name | check name -> succ name - | otherwise -> fail - Nothing -> fail +\begin{code} +pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a +pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down + = m (RnDown loc' names_var errs_var occs_var) l_down - where - succ name = if isRnLocal name || isRnWired name then - returnSST name - else - snoc_bag_var (name,rdr) occ_var `thenSST_` - returnSST name - fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down - -lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) - = case lookup env rdr of - Just name -> returnSST name - Nothing -> case rdr of - Unqual n -> panic ("lookup_val:"++ _UNPK_ n) - Qual m n -> - lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n) - -lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig - = case (lookupFM b_names orig) of - Just xx -> returnSST xx - Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig - -lookup_or_create_implicit_val b_key imp_var us_var orig - = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> - case (lookupFM implicit_val_fm orig) of - Just implicit -> returnSST implicit - Nothing -> - (case (lookupFM b_key orig) of - Just (u,_) -> returnSST u - _ -> get_unique us_var - ) `thenSST` \ uniq -> - let - implicit = mkRnImplicit (mkImplicitName uniq orig) - new_val_fm = addToFM implicit_val_fm orig implicit - in - writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` - returnSST implicit +getSrcLocRn :: RnM s d SrcLoc +getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down + = returnSST loc \end{code} +================ Name supply ===================== \begin{code} -lookupTyCon :: RdrName -> RnMonad x s RnName -lookupClass :: RdrName -> RnMonad x s RnName +getNameSupplyRn :: RnM s d RnNameSupply +getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST names_var -lookupTyCon rdr - = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor" - -lookupClass rdr - = lookup_tc rdr isRnClass mkRnImplicitClass "class" - -lookupTyConOrClass rdr - = lookup_tc rdr isRnTyConOrClass - (panic "lookupTC:mk_implicit") "class or type constructor" - -lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _) - = case lookupTcRnEnv env rdr of - Just name | check name -> succ name - | otherwise -> fail - Nothing -> fail - where - succ name = snoc_bag_var (name,rdr) occ_var `thenSST_` - returnSST name - fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down - -lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) - = case lookupTcRnEnv env rdr of - Just name | check name -> returnSST name - | otherwise -> fail - Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n) - where - fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down - -lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n) - = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $ - case (lookupFM b_names orig) of - Just xx -> returnSST xx - Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig - -lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig - = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> - case (lookupFM implicit_tc_fm orig) of - Just implicit | check implicit -> returnSST implicit - | otherwise -> fail - Nothing -> - (case (lookupFM b_key orig) of - Just (u,_) -> returnSST u - _ -> get_unique us_var - ) `thenSST` \ uniq -> - let - implicit = mk_implicit (mkImplicitName uniq orig) - new_tc_fm = addToFM implicit_tc_fm orig implicit - in - writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` - returnSST implicit +setNameSupplyRn :: RnNameSupply -> RnM s d () +setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down + = writeMutVarSST names_var names' \end{code} - -@extendSS@ extends the scope; @extendSS2@ also removes the newly bound -free vars from the result. +================ Occurrences ===================== \begin{code} -extendSS :: [RnName] -- Newly bound names - -> RnMonad x s a - -> RnMonad x s a - -extendSS binders m down@(RnDown x mod locn mode env us errs) - = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_` - m) (RnDown x mod locn mode new_env us errs) - where - (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders - -extendSS2 :: [RnName] -- Newly bound names - -> RnMonad x s (a, UniqSet RnName) - -> RnMonad x s (a, UniqSet RnName) - -extendSS2 binders m - = extendSS binders m `thenRn` \ (r, fvs) -> - returnRn (r, fvs `minusUniqSet` (mkUniqSet binders)) +addOccurrenceName :: Necessity -> Name -> RnM s d () +addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST occs_var `thenSST` \ occs -> + writeMutVarSST occs_var ((name,necessity) : occs) + +addOccurrenceNames :: Necessity -> [Name] -> RnM s d () +addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST occs_var `thenSST` \ occs -> + writeMutVarSST occs_var ([(name,necessity) | name <- names] ++ occs) + +popOccurrenceName :: RnM s d (Maybe (Name,Necessity)) +popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST occs_var `thenSST` \ occs -> + case occs of + [] -> returnSST Nothing + (occ:occs) -> writeMutVarSST occs_var occs `thenSST_` + returnSST (Just occ) + +-- findOccurrencesRn does the enclosed thing with a *fresh* occurrences +-- variable, and returns the list of occurrences thus found. It's useful +-- when loading instance decls and specialisation signatures, when we want to +-- know the names of the things in the types, but we don't want to treat them +-- as occurrences. + +findOccurrencesRn :: RnM s d a -> RnM s d [Name] +findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down + = newMutVarSST [] `thenSST` \ new_occs_var -> + enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_` + readMutVarSST new_occs_var `thenSST` \ occs -> + returnSST (map fst occs) \end{code} -The free var set returned by @(extendSS binders m)@ is that returned -by @m@, {\em minus} binders. +%************************************************************************ +%* * +\subsection{Plumbing for rename-source part} +%* * +%************************************************************************ -********************************************************* -* * -\subsection{TyVarNamesEnv} -* * -********************************************************* +================ RnEnv ===================== \begin{code} -type TyVarNamesEnv = [(RdrName, RnName)] +getNameEnv :: RnMS s NameEnv +getNameEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode) + = returnSST name_env -nullTyVarNamesEnv :: TyVarNamesEnv -nullTyVarNamesEnv = [] +setNameEnv :: NameEnv -> RnMS s a -> RnMS s a +setNameEnv name_env' m rn_down (SDown (RnEnv name_env fixity_env) mod_name mode) + = m rn_down (SDown (RnEnv name_env' fixity_env) mod_name mode) -catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv -catTyVarNamesEnvs e1 e2 = e1 ++ e2 +getFixityEnv :: RnMS s FixityEnv +getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode) + = returnSST fixity_env -domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName] -domTyVarNamesEnv env = map fst env +setRnEnv :: RnEnv -> RnMS s a -> RnMS s a +setRnEnv rn_env' m rn_down (SDown rn_env mod_name mode) + = m rn_down (SDown rn_env' mod_name mode) \end{code} -@mkTyVarNamesEnv@ checks for duplicates, and complains if so. +================ Module and Mode ===================== \begin{code} -mkTyVarNamesEnv - :: SrcLoc - -> [RdrName] -- The type variables - -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars - -mkTyVarNamesEnv src_loc tyvars - = newLocalNames "type variable" - (tyvars `zip` repeat src_loc) `thenRn` \ rn_tyvars -> - - -- rn_tyvars may not be in the same order as tyvars, so we need some - -- jiggery pokery to build the right tyvar env, and return the - -- renamed tyvars in the original order. - let tv_occ_name_pairs = map tv_occ_name_pair rn_tyvars - tv_env = map (lookup_occ_name tv_occ_name_pairs) tyvars - rn_tyvars_in_orig_order = map snd tv_env - in - returnRn (tv_env, rn_tyvars_in_orig_order) - where - tv_occ_name_pair :: RnName -> (RdrName, RnName) - tv_occ_name_pair rn_name = (getOccName rn_name, rn_name) - - lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName) - lookup_occ_name pairs tyvar_occ - = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ) +getModuleRn :: RnMS s Module +getModuleRn rn_down (SDown rn_env mod_name mode) + = returnSST mod_name \end{code} \begin{code} -lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName -lookupTyVarName env occ - = case (assocMaybe env occ) of - Just name -> returnRn name - Nothing -> getSrcLocRn `thenRn` \ loc -> - failButContinueRn (mkRnUnbound occ) - (unknownNameErr "type variable" occ loc) +getModeRn :: RnMS s RnSMode +getModeRn rn_down (SDown rn_env mod_name mode) + = returnSST mode \end{code} -\begin{code} -#if __GLASGOW_HASKELL__ >= 200 - -- can get it from GHCbase -#else -fixIO :: (a -> IO a) -> IO a +%************************************************************************ +%* * +\subsection{Plumbing for rename-globals part} +%* * +%************************************************************************ -fixIO k s = let - result = k loop s - (Right loop, _) = result - in - result -#endif -\end{code} +\begin{code} +getIfacesRn :: RnMG Ifaces +getIfacesRn rn_down (GDown dirs iface_var) + = readMutVarSST iface_var -********************************************************* -* * -\subsection{Errors used in RnMonad} -* * -********************************************************* +setIfacesRn :: Ifaces -> RnMG () +setIfacesRn ifaces rn_down (GDown dirs iface_var) + = writeMutVarSST iface_var ifaces -\begin{code} -unknownNameErr descriptor name locn - = addShortErrLocLine locn $ \ sty -> - ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name] - -badClassOpErr clas op locn - = addErrLoc locn "" $ \ sty -> - ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `", - ppr sty clas, ppStr "'"] - -shadowedNameWarn locn shadow - = addShortWarnLocLine locn $ \ sty -> - ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] +getSearchPathRn :: RnMG SearchPath +getSearchPathRn rn_down (GDown dirs iface_var) + = returnSST dirs \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 28cd29a..069d710 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -7,1057 +7,460 @@ #include "HsVersions.h" module RnNames ( - getGlobalNames, - SYN_IE(GlobalNameInfo) + getGlobalNames ) where -import PreludeGlaST ( SYN_IE(MutableVar) ) - IMP_Ubiq() -import HsSyn -import RdrHsSyn -import RnHsSyn - +import CmdLineOpts ( opt_SourceUnchanged ) +import HsSyn ( HsModule(..), HsDecl(..), FixityDecl(..), Fixity, Fake, InPat, IE(..), HsTyVar, + TyDecl, ClassDecl, InstDecl, DefaultDecl, ImportDecl(..), HsBinds, IfaceSig + ) +import HsBinds ( collectTopBinders ) +import HsImpExp ( ieName ) +import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), SYN_IE(RdrNameImportDecl), + SYN_IE(RdrNameHsModule), SYN_IE(RdrNameFixityDecl), + rdrNameOcc + ) +import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) ) +import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate ) +import RnEnv import RnMonad -import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) ) -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, 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, FiniteMap ) -import Id ( GenId ) -import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) -import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName, - nameOf, qualToOrigName, mkImportedName, - nameExportFlag, nameImportFlag, - getLocalName, getSrcLoc, getImpLocs, - moduleNamePair, pprNonSym, - isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..) - ) -import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) -import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins ) +import FiniteMap +import PrelMods +import UniqFM ( UniqFM, emptyUFM, addListToUFM_C, lookupUFM ) +import Bag ( Bag, bagToList ) +import Maybes ( maybeToBool, expectJust ) +import Name import Pretty -import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) -import TyCon ( tyConDataCons ) -import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM ) -import UniqSupply ( splitUniqSupply ) -import Util ( isIn, assoc, cmpPString, sortLt, removeDups, - equivClasses, panic, assertPanic - ) ---import PprStyle --ToDo:rm +import PprStyle ( PprStyle(..) ) +import Util ( panic, pprTrace ) \end{code} -\begin{code} -type GlobalNameInfo = (BuiltinNames, - BuiltinKeys, - Name -> ExportFlag, -- export flag - Name -> [RdrName]) -- occurrence names - -- NB: both of the functions are in a *knot* and - -- must be tugged on oh-so-gently... - -type RnM_Info s r = RnMonad GlobalNameInfo s r - -getGlobalNames :: - IfaceCache - -> GlobalNameInfo - -> UniqSupply - -> RdrNameHsModule - -> IO (RnEnv, - [Module], -- directly imported modules - Bag (Module,RnName), -- unqualified imports from module - Bag RenamedFixityDecl, -- imported fixity decls - Bag Error, - Bag Warning) - -getGlobalNames iface_cache info us - (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _) - = let - (us1, us2) = splitUniqSupply us - in - case initRn True mod emptyRnEnv us1 - (setExtraRn info $ - getSourceNames ty_decls cls_decls binds) - of { ((src_vals, src_tcs), src_errs, src_warns) -> - doImportDecls iface_cache info us2 imports >>= - \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) -> - let - unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals) - unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs) +%************************************************************************ +%* * +\subsection{Get global names} +%* * +%************************************************************************ - (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs - (all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs) +\begin{code} +getGlobalNames :: RdrNameHsModule + -> RnMG (Maybe (ExportEnv, RnEnv, [AvailInfo])) + -- Nothing <=> no need to recompile + +getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) + = fixRn (\ ~(rec_exp_fn, _) -> + + -- PROCESS LOCAL DECLS + -- Do these *first* so that the correct provenance gets + -- into the global name cache. + importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails) -> + + -- PROCESS IMPORT DECLS + mapAndUnzipRn importsFromImportDecl all_imports + `thenRn` \ (imp_rn_envs, imp_avails_s) -> + + -- CHECK FOR EARLY EXIT + checkEarlyExit this_mod `thenRn` \ early_exit -> + if early_exit then + returnRn (junk_exp_fn, Nothing) + else + + -- COMBINE RESULTS + -- We put the local env first, so that a local provenance + -- "wins", even if a module imports itself. + foldlRn plusRnEnv emptyRnEnv imp_rn_envs `thenRn` \ imp_rn_env -> + plusRnEnv local_rn_env imp_rn_env `thenRn` \ rn_env -> + let + all_avails :: ModuleAvails + all_avails = foldr plusModuleAvails local_mod_avails imp_avails_s + local_avails = expectJust "getGlobalNames" (lookupModuleAvails local_mod_avails this_mod) + in + + -- PROCESS EXPORT LISTS + exportsFromAvail this_mod exports all_avails rn_env + `thenRn` \ (export_fn, export_env) -> + + returnRn (export_fn, Just (export_env, rn_env, local_avails)) + ) `thenRn` \ (_, result) -> + returnRn result + where + junk_exp_fn = error "RnNames:export_fn" - -- remove dups of the same imported thing - diff_imp_dups = filterBag diff_orig imp_dups - diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2 + all_imports = prel_imports ++ imports - all_dups = bagToList (src_dups `unionBags` diff_imp_dups) - dup_errs = map dup_err (equivClasses cmp_rdr all_dups) - cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2 - dup_err ((rdr,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest]) + prel_imports | this_mod == pRELUDE || + explicit_prelude_import = [] - 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) } + | otherwise = [ImportDecl pRELUDE + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} + mod_loc] + + explicit_prelude_import + = not (null [ () | (ImportDecl mod qual _ _ _) <- imports, mod == pRELUDE ]) \end{code} - -********************************************************* -* * -\subsection{Top-level source names} -* * -********************************************************* + +\begin{code} +checkEarlyExit mod + = if not opt_SourceUnchanged then + -- Source code changed; look no further + returnRn False + else + -- Unchanged source; look further + -- We check for + -- (a) errors so far. These can arise if a module imports + -- something that's no longer exported by the imported module + -- (b) usage information up to date + checkErrsRn `thenRn` \ no_errs_so_far -> + checkUpToDate mod `thenRn` \ up_to_date -> + returnRn (no_errs_so_far && up_to_date) +\end{code} + \begin{code} -getSourceNames :: -- Collects global *binders* (not uses) - [RdrNameTyDecl] - -> [RdrNameClassDecl] - -> RdrNameHsBinds - -> RnM_Info s (Bag RnName, -- values - Bag RnName) -- tycons/classes - -getSourceNames ty_decls cls_decls binds - = mapAndUnzip3Rn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s, fields_s) -> - mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) -> - getTopBindsNames binds `thenRn` \ bind_names -> - returnRn (unionManyBags constrs_s `unionBags` - unionManyBags fields_s `unionBags` - unionManyBags cls_ops_s `unionBags` bind_names, - listToBag tycon_s `unionBags` listToBag cls_s) - --------------- -getTyDeclNames :: RdrNameTyDecl - -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields - -getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc) - = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> - --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $ - --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $ - - newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> - getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM - condecls `thenRn` \ (con_names, field_names) -> - let - rn_tycon = RnData tycon_name con_names field_names - rn_constrs = [ RnConstr name tycon_name | name <- con_names] - rn_fields = [ RnField name tycon_name | name <- field_names] - in - returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields) - -getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc) - = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> - newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con - `thenRn` \ con_name -> - returnRn (RnData tycon_name [con_name] [], - unitBag (RnConstr con_name tycon_name), - emptyBag) - -getTyDeclNames (TySynonym tycon _ _ src_loc) - = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> - returnRn (RnSyn tycon_name, emptyBag, emptyBag) - ----------------- -getConFieldNames :: Maybe ExportFlag - -> Bag Name -> Bag Name - -> FiniteMap RdrName () - -> [RdrNameConDecl] - -> RnM_Info s ([Name], [Name]) - -getConFieldNames exp constrs fields have [] - = returnRn (bagToList constrs, bagToList fields) - -getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest) - = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name -> - getConFieldNames exp (constrs `snocBag` con_name) fields have rest - -getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest) - = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name -> - getConFieldNames exp (constrs `snocBag` con_name) fields have rest - -getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest) - = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_` - newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name -> - mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names -> +importsFromImportDecl :: RdrNameImportDecl + -> RnMG (RnEnv, ModuleAvails) + + -- Check for "import M ()", and then don't even look at M. + -- This makes sense, and is actually rather useful for the Prelude. +importsFromImportDecl (ImportDecl mod qual as_mod (Just (False,[])) loc) + = returnRn (emptyRnEnv, emptyModuleAvails) + +importsFromImportDecl (ImportDecl mod qual as_mod import_spec loc) + = pushSrcLocRn loc $ + getInterfaceExports mod `thenRn` \ (avails, fixities) -> + filterImports mod import_spec avails `thenRn` \ filtered_avails -> let - all_constrs = constrs `snocBag` con_name - all_fields = fields `unionBags` listToBag field_names + filtered_avails' = [ Avail (set_name_prov n) (map set_name_prov ns) + | Avail n ns <- filtered_avails + ] + fixities' = [ (occ,fixity,provenance) | (occ,fixity) <- fixities ] in - getConFieldNames exp all_constrs all_fields new_have rest + qualifyImports mod qual as_mod (ExportEnv filtered_avails' fixities') where - (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls)) - new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields - new_have = addListToFM have (zip new_fields (repeat ())) - -------------- -getClassNames :: RdrNameClassDecl - -> RnM_Info s (RnName, Bag RnName) -- class and class ops - -getClassNames (ClassDecl _ cname _ sigs _ _ src_loc) - = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name -> - getClassOpNames (Just (nameExportFlag class_name)) - sigs `thenRn` \ op_names -> - returnRn (RnClass class_name op_names, - listToBag (map (\ n -> RnClassOp n class_name) op_names)) - ---------------- -getClassOpNames :: Maybe ExportFlag - -> [RdrNameSig] - -> RnM_Info s [Name] - -getClassOpNames exp [] = returnRn [] - -getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs) - = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name -> - getClassOpNames exp sigs `thenRn` \ op_names -> - returnRn (op_name : op_names) -getClassOpNames exp (_ : sigs) - = getClassOpNames exp sigs + set_name_prov name = setNameProvenance name provenance + provenance = Imported mod loc \end{code} -********************************************************* -* * -\subsection{Bindings} -* * -********************************************************* \begin{code} -getTopBindsNames :: RdrNameHsBinds - -> RnM_Info s (Bag RnName) - -getTopBindsNames binds = doBinds binds - -doBinds EmptyBinds = returnRn emptyBag -doBinds (SingleBind bind) = doBind bind -doBinds (BindWith bind sigs) = doBind bind -doBinds (ThenBinds binds1 binds2) - = andRn unionBags (doBinds binds1) (doBinds binds2) - -doBind EmptyBind = returnRn emptyBag -doBind (NonRecBind mbind) = doMBinds mbind -doBind (RecBind mbind) = doMBinds mbind - -doMBinds EmptyMonoBinds = returnRn emptyBag -doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat -doMBinds (FunMonoBind p_name _ _ locn) = doName locn p_name -doMBinds (AndMonoBinds mbinds1 mbinds2) - = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2) - -doPats locn pats - = mapRn (doPat locn) pats `thenRn` \ pats_s -> - returnRn (unionManyBags pats_s) - -doPat locn WildPatIn = returnRn emptyBag -doPat locn (LitPatIn _) = returnRn emptyBag -doPat locn (LazyPatIn pat) = doPat locn pat -doPat locn (VarPatIn var) = doName locn var -doPat locn (NegPatIn pat) = doPat locn pat -doPat locn (ParPatIn pat) = doPat locn pat -doPat locn (ListPatIn pats) = doPats locn pats -doPat locn (TuplePatIn pats) = doPats locn pats -doPat locn (ConPatIn name pats) = doPats locn pats -doPat locn (ConOpPatIn p1 op p2) - = andRn unionBags (doPat locn p1) (doPat locn p2) -doPat locn (AsPatIn as_name pat) - = andRn unionBags (doName locn as_name) (doPat locn pat) -doPat locn (RecPatIn name fields) - = mapRn (doField locn) fields `thenRn` \ fields_s -> - returnRn (unionManyBags fields_s) - -doField locn (_, pat, _) = doPat locn pat - -doName locn rdr - = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name -> - returnRn (unitBag (RnName name)) +importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _) + = foldlRn getLocalDeclBinders [] decls `thenRn` \ avails -> + mapRn fixityFromFixDecl fix_decls `thenRn` \ fixities -> + qualifyImports mod + False -- Not qualified + Nothing -- No "as M" part + (ExportEnv avails fixities) + where + newLocalName rdr_name loc + = newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc + + getLocalDeclBinders avails (ValD binds) + = mapRn do_one (bagToList (collectTopBinders binds)) `thenRn` \ val_avails -> + returnRn (val_avails ++ avails) + + getLocalDeclBinders avails decl + = getDeclBinders newLocalName decl `thenRn` \ avail -> + returnRn (avail : avails) + + do_one (rdr_name, loc) + = newLocalName rdr_name loc `thenRn` \ name -> + returnRn (Avail name []) \end{code} -********************************************************* -* * -\subsection{Creating a new global name} -* * -********************************************************* +%************************************************************************ +%* * +\subsection{Filtering imports} +%* * +%************************************************************************ -\begin{code} -newGlobalName :: SrcLoc - -> Maybe ExportFlag - -> Bool{-True<=>value name,False<=>tycon/class-} - -> RdrName - -> RnM_Info s Name - -newGlobalName locn maybe_exp is_val_name (Unqual name) - = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> - getModuleRn `thenRn` \ mod -> - rnGetUnique `thenRn` \ u -> - let - orig = OrigName mod name - - (uniq, is_toplev) - = case (lookupFM b_keys orig) of - Just (key,_) -> (key, True) - Nothing -> if not opt_CompilingGhcInternals then (u,True) else -- really here just to save gratuitous lookup - case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of - Nothing -> (u, True) - Just xx -> (uniqueOf xx, False{-builtin!-}) - - exp = case maybe_exp of - Just flag -> flag - Nothing -> rec_exp_fn n - - n = if is_toplev - then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s - else mkWiredInName uniq orig exp - in - returnRn n +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). -newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name) - | opt_CompilingGhcInternals - -- we are actually defining something that compiler knows about (e.g., Bool) +\begin{code} +filterImports :: Module + -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hidin + -> [AvailInfo] -- What's available + -> RnMG [AvailInfo] -- What's actually imported + -- Complains if import spec mentions things the + -- module doesn't export - = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> - let - orig = OrigName mod name - - (uniq, is_toplev) - = case (lookupFM b_keys orig) of - Just (key,_) -> (key, True) - Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of - Nothing -> (panic "newGlobalName:Qual:uniq", True) - Just xx -> (uniqueOf xx, False{-builtin!-}) - - exp = case maybe_exp of - Just flag -> flag - Nothing -> rec_exp_fn n - - n = if is_toplev - then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s - else mkWiredInName uniq orig exp - in - returnRn n +filterImports mod Nothing imports + = returnRn imports - | otherwise - = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_` - returnRn (panic "newGlobalName:Qual") -\end{code} +filterImports mod (Just (want_hiding, import_items)) avails + = -- Check that each import item mentions things that are actually available + mapRn check_import_item import_items `thenRn_` -********************************************************* -* * -\subsection{Imported names} -* * -********************************************************* + -- Return filtered environment; no need to filter fixities + returnRn (map new_avail avails) -\begin{code} -type ImportNameInfo - = (GlobalNameInfo, - FiniteMap OrigName RnName, -- values imported so far - FiniteMap OrigName RnName, -- tycons/classes imported so far - Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns; - -- NB: this last field is in a knot - -- and mustn't be tugged on! - -type RnM_IInfo s r = RnMonad ImportNameInfo s r - ------------------------------------------------------------------- -doImportDecls :: - IfaceCache - -> GlobalNameInfo -- builtin and knot name info - -> UniqSupply - -> [RdrNameImportDecl] -- import declarations - -> IO (Bag (RdrName,RnName), -- imported values in scope - Bag (RdrName,RnName), -- imported tycons/classes in scope - [Module], -- directly imported modules - Bag (Module,RnName), -- unqualified import from module - Bag RenamedFixityDecl, -- fixity info for imported names - Bag Error, - Bag Warning) - -doImportDecls iface_cache g_info us src_imps - = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) -> - let - rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff) - add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2) - - rec_imp_fn :: Name -> (ExportFlag, [SrcLoc]) - rec_imp_fn n = case lookupUFM rec_imp_fm n of - Nothing -> (NotExported,[mkBuiltinSrcLoc]) - -- panic "RnNames:rec_imp_fn" - -- but the panic can show up - -- in error messages - Just (flag, locns) -> (flag, bagToList locns) - - i_info = (g_info, emptyFM, emptyFM, rec_imp_fn) - in - -- cache the imported modules - -- this ensures that all directly imported modules - -- will have their original name iface in scope - -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $ - accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >> - - -- process the imports - doImports iface_cache i_info us all_imps - - ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) -> - - return (vals, tcs, imp_mods, unquals, fixes, - imp_errs `unionBags` errs, - imp_warns `unionBags` warns) where - all_imps = implicit_prel ++ src_imps --- all_imps = implicit_qprel ++ the_imps + import_fm :: FiniteMap OccName RdrNameIE + import_fm = listToFM [(ieOcc ie, ie) | ie <- import_items] + + avail_fm :: FiniteMap OccName AvailInfo + avail_fm = listToFM [(nameOccName name, avail) | avail@(Avail name ns) <- avails] + + new_avail NotAvailable = NotAvailable + new_avail avail@(Avail name _) + | not in_import_items && want_hiding = avail + | not in_import_items && not want_hiding = NotAvailable + | in_import_items && want_hiding = NotAvailable + | in_import_items && not want_hiding = filtered_avail + where + maybe_import_item = lookupFM import_fm (nameOccName name) + in_import_items = maybeToBool maybe_import_item + Just import_item = maybe_import_item + filtered_avail = filterAvail import_item avail + + check_import_item :: RdrNameIE -> RnMG () + check_import_item item + = checkRn (maybeToBool maybe_matching_avail && sub_names_ok item avail) + (badImportItemErr mod item) + where + item_name = ieOcc item + maybe_matching_avail = lookupFM avail_fm item_name + Just avail = maybe_matching_avail + + sub_names_ok (IEVar _) _ = True + sub_names_ok (IEThingAbs _) _ = True + sub_names_ok (IEThingAll _) _ = True + sub_names_ok (IEThingWith _ wanted) (Avail _ has) = all ((`elem` has_list) . rdrNameOcc) wanted + where + has_list = map nameOccName has + sub_names_ok other1 other2 = False +\end{code} - explicit_prelude_imp - = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ]) - 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 +%************************************************************************ +%* * +\subsection{Qualifiying imports} +%* * +%************************************************************************ - (uniq_imps, imp_dups) = removeDups cmp_mod all_imps - cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 +@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec +of an import decl, and deals with producing an @RnEnv@ with the +right qaulified names. It also turns the @Names@ in the @ExportEnv@ into +fully fledged @Names@. - qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps, - mod == pRELUDE ] +\begin{code} +qualifyImports :: Module -- Improrted module + -> Bool -- True <=> qualified import + -> Maybe Module -- Optional "as M" part + -> ExportEnv -- What's imported + -> RnMG (RnEnv, ModuleAvails) + +qualifyImports this_mod qual as_mod (ExportEnv avails fixities) + = -- Make the qualified-name environments, checking of course for clashes + foldlRn add_name emptyNameEnv avails `thenRn` \ name_env -> + foldlRn (add_fixity name_env) emptyFixityEnv fixities `thenRn` \ fixity_env -> + + -- Deal with the "qualified" part; if not qualifies then add unqualfied bindings + if qual then + returnRn (RnEnv name_env fixity_env, mod_avail_env) + else + returnRn (RnEnv (unQualify name_env) (unQualify fixity_env), mod_avail_env) - qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ] - qual_name mod (Just as_mod) = as_mod - qual_name mod Nothing = mod + where + mod_avail_env = unitFM this_mod avails + + add_name name_env NotAvailable = returnRn name_env + add_name name_env (Avail n ns) = foldlRn add_one name_env (n : ns) + + add_one :: NameEnv -> Name -> RnMG NameEnv + add_one env name = addOneToNameEnvRn env (Qual this_mod occ_name) name + where + occ_name = nameOccName name + + add_fixity name_env fixity_env (occ_name, fixity, provenance) + | maybeToBool (lookupFM name_env qual_name) -- The name is imported + = addOneToFixityEnvRn fixity_env qual_name (fixity,provenance) + | otherwise -- It ain't imported + = returnRn fixity_env + where + qual_name = Qual this_mod occ_name +\end{code} - (_, qual_dups) = removeDups cmp_qual qual_mods - bad_qual_dups = filter (not . all_same_mod) qual_dups +unQualify adds an Unqual binding for every existing Qual binding. - cmp_qual (q1,_) (q2,_) = cmpPString q1 q2 - all_same_mod ((q,ImportDecl mod _ _ _ _):rest) - = all has_same_mod rest - where - has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2 +\begin{code} +unQualify :: FiniteMap RdrName elt -> FiniteMap RdrName elt +unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ, elt) <- fmToList fm] +\end{code} - imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ] +%************************************************************************ +%* * +\subsection{Local declarations} +%* * +%************************************************************************ - imp_warns = listToBag (map dupImportWarn imp_dups) - `unionBags` - listToBag (map qualPreludeImportWarn qprel_imps) - imp_errs = listToBag (map dupQualImportErr bad_qual_dups) +\begin{code} +fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, Fixity, Provenance) ------------------------ -doImports :: IfaceCache - -> ImportNameInfo - -> UniqSupply - -> [RdrNameImportDecl] -- import declarations - -> IO (Bag (RdrName,RnName), -- imported values in scope - Bag (RdrName,RnName), -- imported tycons/classes in scope - Bag (Module, RnName), -- unqualified import from module - Bag RenamedFixityDecl, -- fixity info for imported names - Bag Error, - Bag Warning, - Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs +fixityFromFixDecl (FixityDecl rdr_name fixity loc) + = returnRn (rdrNameOcc rdr_name, fixity, LocalDef (panic "export-flag") loc) +\end{code} -doImports iface_cache i_info us [] - = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) -doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps) - = let - (us1, us2) = splitUniqSupply us - in - doImport iface_cache i_info us1 imp - >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) -> - let - ext_vals = foldl add_new_one done_vals (bagToList vals1) - ext_tcs = foldl add_new_one done_tcs (bagToList tcs1) - in - doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps - >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) -> - return (vals1 `unionBags` vals2, - tcs1 `unionBags` tcs2, - unquals1 `unionBags` unquals2, - fixes1 `unionBags` fixes2, - errs1 `unionBags` errs2, - warns1 `unionBags` warns2, - imps1 `unionBags` imps2) - where - add_new_one :: FiniteMap OrigName RnName -- ones done so far - -> (dont_care, RnName) - -> FiniteMap OrigName RnName -- extended - - add_new_one fm (_, rn) - = let - orig = origName "add_new_one" rn - in - case (lookupFM fm orig) of - Just _ -> fm -- already there: no change - Nothing -> addToFM fm orig rn - ----------------------- -doImport :: IfaceCache - -> ImportNameInfo - -> UniqSupply - -> RdrNameImportDecl - -> IO (Bag (RdrName,RnName), -- values - Bag (RdrName,RnName), -- tycons/classes - Bag (Module,RnName), -- unqual imports - Bag RenamedFixityDecl, - Bag Error, - Bag Warning, - 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') - -- = (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 -> - return (emptyBag, emptyBag, emptyBag, emptyBag, - unitBag err, emptyBag, emptyBag) - Succeeded iface -> - let - (ies, chk_ies, get_errs) = do_ies iface - in - doOrigIEs iface_cache info mod src_loc us ies - >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) -> - accumulate (map (checkOrigIE iface_cache) chk_ies) - >>= \ chk_errs_warns -> - let - 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 - 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 - - unquals = if qual{-ified import-} - then emptyBag - else mapBag pair_as (ie_vals `unionBags` ie_tcs) - - final_fixes = listToBag (catMaybes fix_maybes) - - final_errs = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs)) - `unionBags` errs `unionBags` unionManyBags fix_errs - final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns) - `unionBags` warns - imp_stuff = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags - in - return (final_vals, final_tcs, unquals, final_fixes, - final_errs, final_warns, imp_stuff) - where - as_mod :: Module - as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this} - - mk_occ :: FAST_STRING -> RdrName - mk_occ str = if qual then Qual as_mod str else Unqual str - - fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName) - fst_occ (str, rn) = (mk_occ str, 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]) - -> (Bag (FAST_STRING, RnName), - Bag (FAST_STRING, RnName), - Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect - ) - -getBuiltins _ modname maybe_spec --- | 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) - - Just (True, ies) -> -- hiding does not work for builtin names - trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $ - (all_vals, all_tcs, maybe_spec) - - Just (False, ies) -> let - (vals,tcs,ies_left) = do_builtin ies - in - (vals, tcs, Just (False, ies_left)) - where - all_vals = do_all_builtin (fmToList b_val_names) - all_tcs = do_all_builtin (fmToList b_tc_names) - - do_all_builtin [] = emptyBag - do_all_builtin (((OrigName mod str),rn):rest) - = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $ - (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest) - - do_builtin [] = (emptyBag,emptyBag,[]) - do_builtin (ie:ies) - = let - (str, orig) - = case (ie_name ie) of - Unqual s -> (s, OrigName modname s) - Qual m s -> --pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $ - (s, OrigName modname s) - in - case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM... - Just rn -> case (ie,rn) of - (IEThingAbs _, WiredInTyCon tc) - -> (vals, (str, rn) `consBag` tcs, ies_left) - (IEThingAll _, WiredInTyCon tc) - -> (listToBag (map (\ id -> (getLocalName id, WiredInId id)) - (tyConDataCons tc)) - `unionBags` vals, - (str,rn) `consBag` tcs, ies_left) - (IEThingWith _ _, WiredInTyCon tc) -- No checking of With... - -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id)) - (tyConDataCons tc)) - `unionBags` vals, - (str,rn) `consBag` tcs, ies_left) - _ -> panic "importing builtin names (1)" - - Nothing -> - case (lookupFM b_val_names orig) of - Nothing -> (vals, tcs, ie:ies_left) - Just rn -> case (ie,rn) of - (IEVar _, WiredInId _) - -> ((str, rn) `consBag` vals, tcs, ies_left) - _ -> panic "importing builtin names (2)" - where - (vals, tcs, ies_left) = do_builtin ies --} - -------------------------- -getOrigIEs :: ParsedIface - -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah - -> ([IE OrigName], - [(IE OrigName, ExportFlag)], - Bag (Module -> SrcLoc -> Error)) - -getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all - = (map mkAllIE (eltsFM exps), [], emptyBag) - -getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding - = (map mkAllIE (eltsFM exps_left), found_ies, errs) - where - (found_ies, errs) = lookupIEs exps ies - exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies) +%************************************************************************ +%* * +\subsection{Export list processing +%* * +%************************************************************************ -getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these - = (map fst found_ies, found_ies, errs) - where - (found_ies, errs) = lookupIEs exps ies - ------------------------------------------------- -mkAllIE :: (OrigName, ExportFlag) -> IE OrigName - -mkAllIE (orig,ExportAbs) - = --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 name_orig || isLexSpecialSym name_orig - = IEThingAll orig - | otherwise - = IEVar orig - where - name_orig = nameOf orig +The @AvailEnv@ type is just used internally in @exportsFromAvail@. +When exporting we need to combine the availabilities for a particular +exported thing, and we also need to check for name clashes -- that +is: two exported things must have different @OccNames@. ------------- -lookupIEs :: ExportsMap - -> [RdrNameIE] - -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified - Bag (Module -> SrcLoc -> Error)) +\begin{code} +type AvailEnv = FiniteMap OccName (RdrNameIE, AvailInfo) + -- The FM maps each OccName to the RdrNameIE that gave rise to it, + -- for error reporting, as well as to its AvailInfo -lookupIEs exps ies - = foldr go ([], emptyBag) ies - where - go ie (already, errs) - = let - str = case (ie_name ie) of - Unqual s -> s - Qual m s -> s - in - case (lookupFM exps str) of - Nothing -> - (already, unknownImpSpecErr ie `consBag` errs) - Just (orig, flag) -> - ((orig_ie orig ie, flag) : already, - adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs) - - orig_ie orig (IEVar n) = IEVar orig - orig_ie orig (IEThingAbs n) = IEThingAbs orig - orig_ie orig (IEThingAll n) = IEThingAll orig - orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns) - where - (OrigName mod _) = orig - re_orig (Unqual s) = OrigName mod s - - seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies - --------------------------------------------- -doOrigIEs iface_cache info mod src_loc us [] - = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag) - -doOrigIEs iface_cache info mod src_loc us (ie:ies) - = let - (us1, us2) = splitUniqSupply us - in - doOrigIE iface_cache info mod src_loc us1 ie - >>= \ (vals1, tcs1, imps1, errs1, warns1) -> - doOrigIEs iface_cache info mod src_loc us2 ies - >>= \ (vals2, tcs2, imps2, errs2, warns2) -> - return (vals1 `unionBags` vals2, - tcs1 `unionBags` tcs2, - imps1 `unionBags` imps2, - errs1 `unionBags` errs2, - warns1 `unionBags` warns2) - ----------------------- -doOrigIE :: IfaceCache - -> ImportNameInfo - -> Module - -> SrcLoc - -> UniqSupply - -> IE OrigName - -> IO (Bag RnName, -- values - Bag RnName, -- tycons/classes - Bag (RnName,ExportFlag), -- import flags - Bag Error, - Bag Warning) - -doOrigIE iface_cache info mod src_loc us ie - = with_decl iface_cache (ie_name ie) - avoided_fn - (\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag)) - (\ decl -> case initRn True mod emptyRnEnv us - (setExtraRn info $ - pushSrcLocRn src_loc $ - getIfaceDeclNames ie decl) - of - ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns)) - where - avoided_fn Nothing -- the thing should be in the source - = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) - avoided_fn (Just (Left rn@(WiredInId _))) -- a builtin value brought into scope - = (unitBag rn, emptyBag, 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 - -> (IE OrigName, ExportFlag) - -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning)) - -checkOrigIE iface_cache (IEThingAll n, ExportAbs) - = with_decl iface_cache n - (\ _ -> (emptyBag, emptyBag)) - (\ err -> (unitBag (\ mod locn -> err), emptyBag)) - (\ decl -> case decl of - TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n)) - other -> (unitBag (allWhenAbsImpSpecErr n), emptyBag)) - -checkOrigIE iface_cache (IEThingWith n ns, ExportAbs) - = return (unitBag (withWhenAbsImpSpecErr n), emptyBag) - -checkOrigIE iface_cache (IEThingWith n ns, ExportAll) - = with_decl iface_cache n - (\ _ -> (emptyBag, emptyBag)) - (\ err -> (unitBag (\ mod locn -> err), emptyBag)) - (\ decl -> case decl of - NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag) - DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag) - ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag)) - where - check_with str has origs - | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs) - = emptyBag - | otherwise - = unitBag (withImpSpecErr str n has origs) - -checkOrigIE iface_cache other - = return (emptyBag, emptyBag) - ------------------------ -with_decl :: IfaceCache - -> OrigName - -> (Maybe (Either RnName RnName) -> something) -- if avoided.. - -> (Error -> something) -- if an error... - -> (RdrIfaceDecl -> something) -- if OK... - -> IO something - -with_decl iface_cache n do_avoid do_err do_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 +emptyAvailEnv = emptyFM -------------- -getFixityDecl :: IfaceCache - -> RnName - -> IO (Maybe RenamedFixityDecl, Bag Error) +unitAvailEnv :: RdrNameIE -> AvailInfo -> AvailEnv +unitAvailEnv ie NotAvailable + = emptyFM +unitAvailEnv ie avail@(Avail n ns) + = unitFM (nameOccName n) (ie,avail) -getFixityDecl iface_cache rn - = let - (OrigName mod str) = origName "getFixityDecl" rn +plusAvailEnv a1 a2 + = mapRn (addErrRn.availClashErr) (conflictsFM bad_avail a1 a2) `thenRn_` + returnRn (plusFM_C plus_avail a1 a2) - succeeded infx i = return (Just (infx rn i), emptyBag) - in - cachedIface iface_cache True str mod >>= \ maybe_iface -> - case maybe_iface of - Failed err -> - return (Nothing, unitBag err) - Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) -> - case lookupFM fixes str of - Nothing -> return (Nothing, emptyBag) - Just (InfixL _ i) -> succeeded InfixL i - Just (InfixR _ i) -> succeeded InfixR i - Just (InfixN _ i) -> succeeded InfixN i - -ie_name (IEVar n) = n -ie_name (IEThingAbs n) = n -ie_name (IEThingAll n) = n -ie_name (IEThingWith n _) = n - -adderr_if True err errs = err `consBag` errs -adderr_if False err errs = errs +listToAvailEnv :: RdrNameIE -> [AvailInfo] -> RnM s d AvailEnv +listToAvailEnv ie items + = foldlRn plusAvailEnv emptyAvailEnv (map (unitAvailEnv ie) items) + +bad_avail (ie1,Avail n1 _) (ie2,Avail n2 _) = n1 /= n2 -- Same OccName, different Name +plus_avail (ie1,a1) (ie2,a2) = (ie1, a1 `plusAvail` a2) \end{code} -********************************************************* -* * -\subsection{Actually creating the imported names} -* * -********************************************************* \begin{code} -getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl - -> RnM_IInfo s (Bag RnName, -- values - Bag RnName, -- tycons/classes - Bag (RnName,ExportFlag)) -- import flags - -getIfaceDeclNames ie (ValSig val src_loc _) - = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name -> - returnRn (unitBag (RnName val_name), - emptyBag, - unitBag (RnName val_name, ExportAll)) - -getIfaceDeclNames ie (TypeSig tycon src_loc _) - = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> - returnRn (emptyBag, - unitBag (RnSyn tycon_name), - unitBag (RnSyn tycon_name, ExportAll)) - -getIfaceDeclNames ie (NewTypeSig tycon con src_loc _) - = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> - newImportedName False src_loc (Just (nameExportFlag tycon_name)) - (Just (nameImportFlag tycon_name)) - con `thenRn` \ con_name -> - returnRn (if imp_all (imp_flag ie) then - unitBag (RnConstr con_name tycon_name) - else - emptyBag, - unitBag (RnData tycon_name [con_name] []), - unitBag (RnData tycon_name [con_name] [], imp_flag ie)) - -getIfaceDeclNames ie (DataSig tycon cons fields src_loc _) - = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> - let - map_me = mapRn (newImportedName False src_loc - (Just (nameExportFlag tycon_name)) - (Just (nameImportFlag tycon_name))) - in - map_me cons `thenRn` \ con_names -> - map_me fields `thenRn` \ field_names -> +exportsFromAvail :: Module + -> Maybe [RdrNameIE] -- Export spec + -> ModuleAvails + -> RnEnv + -> RnMG (Name -> ExportFlag, ExportEnv) + -- Complains if two distinct exports have same OccName + -- Complains about exports items not in scope +exportsFromAvail this_mod Nothing all_avails rn_env + = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) all_avails rn_env + +exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_env) + = mapRn exports_from_item export_items `thenRn` \ avail_envs -> + foldlRn plusAvailEnv emptyAvailEnv avail_envs `thenRn` \ export_avail_env -> let - rn_tycon = RnData tycon_name con_names field_names - rn_constrs = [ RnConstr name tycon_name | name <- con_names ] - rn_fields = [ RnField name tycon_name | name <- field_names ] + export_avails = map snd (eltsFM export_avail_env) + export_fixities = mk_exported_fixities (availsToNameSet export_avails) + export_fn = mk_export_fn export_avails in - returnRn (if imp_all (imp_flag ie) then - listToBag rn_constrs `unionBags` listToBag rn_fields - else - emptyBag, - unitBag rn_tycon, - unitBag (rn_tycon, imp_flag ie)) - -getIfaceDeclNames ie (ClassSig cls ops src_loc _) - = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name -> - mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name)) - (Just (nameImportFlag cls_name))) - ops `thenRn` \ op_names -> - returnRn (if imp_all (imp_flag ie) then - listToBag (map (\ n -> RnClassOp n cls_name) op_names) - else - emptyBag, - unitBag (RnClass cls_name op_names), - unitBag (RnClass cls_name op_names, imp_flag ie)) - - -imp_all ExportAll = True -imp_all _ = False - -imp_flag (IEThingAbs _) = ExportAbs -imp_flag (IEThingAll _) = ExportAll -imp_flag (IEThingWith _ _) = ExportAll -\end{code} + returnRn (export_fn, ExportEnv export_avails export_fixities) -********************************************************* -* * -\subsection{Creating a new imported name} -* * -********************************************************* + where + full_avail_env :: UniqFM AvailInfo + full_avail_env = addListToUFM_C plusAvail emptyUFM + [(name,avail) | avail@(Avail name _) <- concat (eltsFM all_avails)] + -- NB: full_avail_env won't contain bindings for data constructors and class ops, + -- which is right and proper; attempts to export them on their own will provoke an error + + exports_from_item :: RdrNameIE -> RnMG AvailEnv + exports_from_item ie@(IEModuleContents mod) + = case lookupFM all_avails mod of + Nothing -> failWithRn emptyAvailEnv (modExportErr mod) + Just avails -> addOccurrenceNames Compulsory [n | Avail n _ <- avails] `thenRn_` + listToAvailEnv ie avails + + exports_from_item ie + | not (maybeToBool maybe_in_scope) + = failWithRn emptyAvailEnv (unknownNameErr (ieName ie)) + +#ifdef DEBUG + -- I can't see why this should ever happen; if the thing is in scope + -- at all it ought to have some availability + | not (maybeToBool maybe_avail) + = pprTrace "exportsFromAvail: curious Nothing:" (ppr PprDebug name) + returnRn emptyAvailEnv +#endif + + | not enough_avail + = failWithRn emptyAvailEnv (exportItemErr ie export_avail) + + | otherwise -- Phew! It's OK! + = addOccurrenceName Compulsory name `thenRn_` + returnRn (unitAvailEnv ie export_avail) + where + maybe_in_scope = lookupNameEnv name_env (ieName ie) + Just name = maybe_in_scope + maybe_avail = lookupUFM full_avail_env name + Just avail = maybe_avail + export_avail = filterAvail ie avail + enough_avail = case export_avail of {NotAvailable -> False; other -> True} + + -- We export a fixity iff we export a thing with the same (qualified) RdrName + mk_exported_fixities :: NameSet -> [(OccName, Fixity, Provenance)] + mk_exported_fixities exports + = [ (rdrNameOcc rdr_name, fixity, prov) + | (rdr_name, (fixity, prov)) <- fmToList fixity_env, + export_fixity name_env exports rdr_name + ] + +mk_export_fn :: [AvailInfo] -> (Name -> ExportFlag) +mk_export_fn avails + = \name -> if name `elemNameSet` exported_names + then Exported + else NotExported + where + exported_names :: NameSet + exported_names = availsToNameSet avails + +export_fixity :: NameEnv -> NameSet -> RdrName -> Bool +export_fixity name_env exports (Unqual _) + = False -- The qualified fixity is always there as well +export_fixity name_env exports rdr_name@(Qual _ occ) + = case lookupFM name_env rdr_name of + Just fixity_name -> fixity_name `elemNameSet` exports + -- Check whether the exported thing is + -- the one to which the fixity attaches + other -> False -- Not even in scope +\end{code} + + +%************************************************************************ +%* * +\subsection{Errors} +%* * +%************************************************************************ \begin{code} -newImportedName :: Bool -- True => tycon or class - -> SrcLoc - -> Maybe ExportFlag -- maybe export flag - -> Maybe ExportFlag -- maybe import flag - -> RdrName -- orig name - -> RnM_IInfo s Name - -newImportedName tycon_or_class locn maybe_exp maybe_imp rdr - = let - orig = qualToOrigName rdr - in - getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) -> - case ((if tycon_or_class - then lookupFM done_tcs - else lookupFM done_vals) orig) of - - Just rn -> returnRn (getName rn) - Nothing -> - rnGetUnique `thenRn` \ u -> - let - uniq = case lookupFM b_keys orig of - Nothing -> u - Just (key,_) -> key - - exp = case maybe_exp of - Just xx -> xx - Nothing -> rec_exp_fn n - - imp = case maybe_imp of - Just xx -> xx - Nothing -> imp_flag - - (imp_flag, imp_locs) = rec_imp_fn n - - n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s - in - returnRn n -\end{code} +ieOcc ie = rdrNameOcc (ieName ie) -\begin{code} -globalDupNamesErr rdr rns sty - = ppAboves (message : map pp_dup rns) - where - message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"] - - pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty -> - ppCat [pp_descrip rn, pprNonSym sty rn]) sty - - get_loc rn = case getImpLocs rn of - [] -> getSrcLoc rn - locs -> head locs - - pp_descrip (RnName _) = ppStr "as a value:" - pp_descrip (RnSyn _) = ppStr "as a type synonym:" - pp_descrip (RnData _ _ _) = ppStr "as a data type:" - pp_descrip (RnConstr _ _) = ppStr "as a data constructor:" - pp_descrip (RnField _ _) = ppStr "as a record field:" - pp_descrip (RnClass _ _) = ppStr "as a class:" - pp_descrip (RnClassOp _ _) = ppStr "as a class method:" - pp_descrip _ = ppNil - -dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty - = ppAboves (item1 : map dup_item dup_imps) - where - item1 = addShortWarnLocLine locn1 (\ sty -> - ppCat [ppStr "multiple imports from module", ppPStr m1]) sty +badImportItemErr mod ie sty + = ppSep [ppStr "Module", pprModule sty mod, ppStr "does not export", ppr sty ie] - dup_item (ImportDecl m _ _ _ locn) - = addShortWarnLocLine locn (\ sty -> - ppCat [ppStr "here was another import from module", ppPStr m]) sty +modExportErr mod sty + = ppCat [ ppStr "Unknown module in export list: module", ppPStr mod] -qualPreludeImportWarn (ImportDecl m _ _ _ locn) - = addShortWarnLocLine locn (\ sty -> - ppCat [ppStr "qualified import of prelude module", ppPStr m]) +exportItemErr export_item NotAvailable sty + = ppSep [ ppStr "Export item not in scope:", ppr sty export_item ] -dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty - = ppAboves (item1 : map dup_item dup_quals) - where - item1 = addShortErrLocLine locn1 (\ sty -> - ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty - - dup_item (q,ImportDecl _ _ _ _ locn) - = addShortErrLocLine locn (\ sty -> - ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty - -unknownImpSpecErr ie imp_mod locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"]) - -duplicateImpSpecErr ie imp_mod locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"]) - -allWhenSynImpSpecWarn n imp_mod locn - = addShortWarnLocLine locn (\ sty -> - ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"]) - -allWhenAbsImpSpecErr n imp_mod locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"]) - -withWhenAbsImpSpecErr n imp_mod locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"]) - -withImpSpecErr str n has ns imp_mod locn - = addErrLoc locn "" (\ sty -> - ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"], - ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)], - ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ]) - -dupFieldErr con locn (dup:rest) - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"]) +exportItemErr export_item avail sty + = ppHang (ppStr "Export item not fully in scope:") + 4 (ppAboves [ppCat [ppStr "Wanted: ", ppr sty export_item], + ppCat [ppStr "Available: ", ppr sty (ieOcc export_item), pprAvail sty avail]]) + +availClashErr (occ_name, ((ie1,avail1), (ie2,avail2))) sty + = ppHang (ppCat [ppStr "Conflicting exports for local name: ", ppr sty occ_name]) + 4 (ppAboves [ppr sty ie1, ppr sty ie2]) \end{code} + diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index d650c01..e726eb3 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -6,43 +6,54 @@ \begin{code} #include "HsVersions.h" -module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where +module RnSource ( rnDecl, rnHsType ) where IMP_Ubiq() IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking -IMPORT_1_3(List(partition)) import HsSyn +import HsDecls ( HsIdInfo(..) ) import HsPragmas +import HsTypes ( getTyVarName ) import RdrHsSyn import RnHsSyn -import RnMonad +import HsCore + import RnBinds ( rnTopBinds, rnMethodBinds ) -import RnUtils ( getLocalsFromRnEnv, lookupGlobalRnEnv, lubExportFlag ) +import RnEnv ( bindTyVarsRn, lookupRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn, + lookupOptionalOccRn, newDfunName, + listType_RDR, tupleType_RDR ) +import RnMonad -import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) -import Class ( derivableClassKeys ) -import CmdLineOpts ( opt_CompilingGhcInternals ) +import Name ( Name, isLocallyDefined, isTvOcc, pprNonSym, + Provenance, + SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet, + elemNameSet + ) import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) -import Id ( isDataCon, GenId{-instance NamedThing-} ) +import Id ( GenId{-instance NamedThing-} ) +import IdInfo ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo ) +import SpecEnv ( SpecEnv ) +import CoreUnfold ( Unfolding(..), SimpleUnfolding ) +import MagicUFs ( MagicUnfoldingFun ) +import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) -import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), - nameImportFlag, RdrName, pprNonSym, Name ) +import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Outputable ( Outputable(..){-instances-} ) --import PprStyle -- ToDo:rm import Pretty import SrcLoc ( SrcLoc ) -import TyCon ( tyConDataCons, TyCon{-instance NamedThing-} ) +-- import TyCon ( TyCon{-instance NamedThing-} ) import Unique ( Unique ) -import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM ) import UniqSet ( SYN_IE(UniqSet) ) -import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString, +import UniqFM ( UniqFM, lookupUFM ) +import Util ( isIn, isn'tIn, thenCmp, removeDups, cmpPString, panic, assertPanic{- , pprTrace ToDo:rm-} ) \end{code} -rnSource `renames' the source module and export list. +rnDecl `renames' declarations. It simultaneously performs dependency analysis and precedence parsing. It also does the following error checks: \begin{enumerate} @@ -56,277 +67,25 @@ Checks the (..) etc constraints in the export list. \end{enumerate} -\begin{code} -rnSource :: [Module] -- imported modules - -> Bag (Module,RnName) -- unqualified imports from module - -> Bag RenamedFixityDecl -- fixity info for imported names - -> 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 - (HsModule mod version exports _ fixes - ty_decls specdata_sigs class_decls - inst_decls specinst_sigs defaults - binds _ src_loc) - - = pushSrcLocRn src_loc $ - - 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 - all_fixes_fm = listToUFM (map pair_name all_fixes) - - pair_name inf = (fixDeclName inf, inf) - in - setExtraRn all_fixes_fm $ - - mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls -> - mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs -> - mapRn rnClassDecl class_decls `thenRn` \ new_class_decls -> - mapRn rnInstDecl inst_decls `thenRn` \ new_inst_decls -> - mapRn rnSpecInstSig specinst_sigs `thenRn` \ new_specinst_sigs -> - rnDefaultDecl defaults `thenRn` \ new_defaults -> - rnTopBinds binds `thenRn` \ new_binds -> - - getOccurrenceUpRn `thenRn` \ occ_info -> - - returnRn ( - HsModule mod version - trashed_exports trashed_imports all_fixes - new_ty_decls new_specdata_sigs new_class_decls - new_inst_decls new_specinst_sigs new_defaults - new_binds [] src_loc, - exported_fn, module_dotdots, - occ_info - ) - where - trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing - trashed_imports = {-trace "rnSource:trashed_imports"-} [] -\end{code} - - %********************************************************* %* * -\subsection{Export list} +\subsection{Value declarations} %* * %********************************************************* \begin{code} -rnExports :: [Module] - -> Bag (Module,RnName) - -> Maybe [RdrNameIE] - -> 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 - , ([], []) - ) - -rnExports mods unqual_imps (Just exps) - = getModuleRn `thenRn` \ this_mod -> - getRnEnv `thenRn` \ rn_env -> - mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) -> - let - (tc_bags, val_bags) = unzip exp_bags - tc_names = bagToList (unionManyBags tc_bags) - val_names = bagToList (unionManyBags val_bags) - exp_mods = catMaybes mod_maybes - - -- Warn for duplicate names and modules - (_, dup_tc_names) = removeDups cmp_fst tc_names - (_, dup_val_names) = removeDups cmp_fst val_names - cmp_fst (x,_) (y,_) = x `cmp` y - - (uniq_mods, dup_mods) = removeDups cmpPString exp_mods - (expmods_this, expmods_imps) = partition (== this_mod) uniq_mods - - -- Get names for "module This_Mod" export - (this_tcs, this_vals) - = if null expmods_this - then ([], []) - else getLocalsFromRnEnv rn_env - - -- Get names for exported imported modules - (mod_tcs, mod_vals, empty_mods) - = case mapAndUnzip3 get_mod_names expmods_imps of - (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys) - - (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps) - - get_mod_names 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', 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) - tc_map = addListToUFM_C lub_expflag tc_map1 (map (pair_fst.exp_all) this_tcs) - - val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names) - val_map1 = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals) - val_map = addListToUFM_C lub_expflag val_map1 (map (pair_fst.exp_all) this_vals) - - pair_fst pr@(n,_) = (n,pr) - exp_all rn = (getName rn, ExportAll) - lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2) - - -- Check for exporting of duplicate local names - tc_locals = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map] - val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map] - (_, dup_tc_locals) = removeDups cmp_local tc_locals - (_, dup_val_locals) = removeDups cmp_local val_locals - cmp_local (x,_) (y,_) = x `cmpPString` y - - -- Build export flag function - final_exp_map = plusUFM tc_map val_map - exp_fn n = case lookupUFM final_exp_map n of - Nothing -> NotExported - Just (_,flag) -> flag - in - getSrcLocRn `thenRn` \ src_loc -> - mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_` - mapRn (addWarnRn . dupNameExportWarn src_loc) dup_val_names `thenRn_` - mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_` - 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, (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 -> - checkIEVar rn `thenRn` \ exps -> - returnRn (Nothing, exps) - where - checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll)) - checkIEVar (WiredInId i) = returnRn (emptyBag, unitBag (getName i, ExportAll)) - checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc) - checkIEVar rn@(RnField _ _) = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn (emptyBag, emptyBag) (fieldExportErr rn src_loc) - checkIEVar rn = --pprTrace "rnIE:IEVar:panic? ToDo?:" (ppr PprDebug rn) $ - returnRn (emptyBag, emptyBag) - -rnIE mods (IEThingAbs name) - = lookupTyConOrClass name `thenRn` \ rn -> - checkIEAbs rn `thenRn` \ exps -> - returnRn (Nothing, exps) - where - checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag) - checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag) - checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag) - checkIEAbs (WiredInTyCon t) = returnRn (unitBag (getName t,ExportAbs), emptyBag) - checkIEAbs rn = --pprTrace "rnIE:IEAbs:panic? ToDo?:" (ppr PprDebug rn) $ - returnRn (emptyBag, emptyBag) - -rnIE mods (IEThingAll name) - = lookupTyConOrClass name `thenRn` \ rn -> - checkIEAll rn `thenRn` \ exps -> - checkImportAll rn `thenRn_` - returnRn (Nothing, exps) - where - checkIEAll (RnData n cons fields) - = returnRn (unitBag (exp_all n), - listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields)) - - checkIEAll (WiredInTyCon t) - = returnRn (unitBag (exp_all (getName t)), listToBag (map exp_all cons)) - where - cons = map getName (tyConDataCons t) - - checkIEAll (RnClass n ops) - = returnRn (unitBag (exp_all n), listToBag (map exp_all ops)) - checkIEAll rn@(RnSyn n) - = getSrcLocRn `thenRn` \ src_loc -> - warnAndContinueRn (unitBag (n, ExportAbs), emptyBag) - (synAllExportErr False{-warning-} rn src_loc) - - checkIEAll rn = --pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $ - returnRn (emptyBag, emptyBag) - - exp_all n = (n, ExportAll) - -rnIE mods (IEThingWith name names) - = lookupTyConOrClass name `thenRn` \ rn -> - mapRn lookupValue names `thenRn` \ rns -> - checkIEWith rn rns `thenRn` \ exps -> - checkImportAll rn `thenRn_` - returnRn (Nothing, exps) - where - checkIEWith rn@(RnData n cons fields) rns - | same_names (cons++fields) rns - = returnRn (unitBag (exp_all n), listToBag (map exp_all cons) - `unionBags` - listToBag (map exp_all fields)) - | otherwise - = rnWithErr "constructors (and fields)" rn (cons++fields) rns - checkIEWith rn@(RnClass n ops) rns - | same_names ops rns - = returnRn (unitBag (exp_all n), listToBag (map exp_all ops)) - | otherwise - = rnWithErr "class ops" rn ops rns - checkIEWith rn@(RnSyn _) rns - = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc) - checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)" - checkIEWith rn rns - = --pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $ - returnRn (emptyBag, emptyBag) - - exp_all n = (n, ExportAll) - - same_names has rns - = all (not.isRnUnbound) rns && - sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns) - - rnWithErr str rn has rns - = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc) - -rnIE mods (IEModuleContents mod) - | isIn "rnIE:IEModule" mod mods - = returnRn (Just mod, (emptyBag, emptyBag)) - | otherwise - = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc) - - -checkImportAll rn - = case nameImportFlag (getName rn) of - ExportAll -> returnRn () - exp -> getSrcLocRn `thenRn` \ src_loc -> - addErrRn (importAllErr rn src_loc) +rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl + +rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds -> + returnRn (ValD new_binds) + + +rnDecl (SigD (IfaceSig name ty id_infos loc)) + = pushSrcLocRn loc $ + lookupRn name `thenRn` \ name' -> + rnHsType ty `thenRn` \ ty' -> + mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> + returnRn (SigD (IfaceSig name' ty' id_infos' loc)) \end{code} %********************************************************* @@ -348,126 +107,32 @@ it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl - -rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc) +rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc)) = pushSrcLocRn src_loc $ - lookupTyCon tycon `thenRn` \ tycon' -> - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') -> - rnContext tv_env src_loc context `thenRn` \ context' -> - rnConDecls tv_env condecls `thenRn` \ condecls' -> - rn_derivs tycon' src_loc derivings `thenRn` \ derivings' -> + lookupRn tycon `thenRn` \ tycon' -> + bindTyVarsRn "data declaration" tyvars $ \ tyvars' -> + rnContext context `thenRn` \ context' -> + mapRn rnConDecl condecls `thenRn` \ condecls' -> + rnDerivs derivings `thenRn` \ derivings' -> ASSERT(isNoDataPragmas pragmas) - returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc) + returnRn (TyD (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)) -rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc) +rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc)) = pushSrcLocRn src_loc $ - lookupTyCon tycon `thenRn` \ tycon' -> - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') -> - rnContext tv_env src_loc context `thenRn` \ context' -> - rnConDecls tv_env condecl `thenRn` \ condecl' -> - rn_derivs tycon' src_loc derivings `thenRn` \ derivings' -> + lookupRn tycon `thenRn` \ tycon' -> + bindTyVarsRn "newtype declaration" tyvars $ \ tyvars' -> + rnContext context `thenRn` \ context' -> + rnConDecl condecl `thenRn` \ condecl' -> + rnDerivs derivings `thenRn` \ derivings' -> ASSERT(isNoDataPragmas pragmas) - returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc) + returnRn (TyD (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)) -rnTyDecl (TySynonym name tyvars ty src_loc) +rnDecl (TyD (TySynonym name tyvars ty src_loc)) = pushSrcLocRn src_loc $ - lookupTyCon name `thenRn` \ name' -> - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') -> - rnMonoType tv_env ty `thenRn` \ ty' -> - returnRn (TySynonym name' tyvars' ty' src_loc) - -rn_derivs tycon2 locn Nothing -- derivs not specified - = returnRn Nothing - -rn_derivs tycon2 locn (Just ds) - = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs -> - returnRn (Just derivs) - where - rn_deriv tycon2 locn clas - = lookupClass clas `thenRn` \ clas_name -> - addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys) - (derivingNonStdClassErr clas_name locn) - `thenRn_` - returnRn clas_name - where - not_elem = isn'tIn "rn_deriv" -\end{code} - -@rnConDecls@ uses the `global name function' to create a new -constructor in which local names have been replaced by their original -names, reporting any unknown names. - -\begin{code} -rnConDecls :: TyVarNamesEnv - -> [RdrNameConDecl] - -> RnM_Fixes s [RenamedConDecl] - -rnConDecls tv_env con_decls - = mapRn rn_decl con_decls - where - rn_decl (ConDecl name tys src_loc) - = pushSrcLocRn src_loc $ - lookupConstr name `thenRn` \ new_name -> - mapRn rn_bang_ty tys `thenRn` \ new_tys -> - returnRn (ConDecl new_name new_tys src_loc) - - rn_decl (ConOpDecl ty1 op ty2 src_loc) - = pushSrcLocRn src_loc $ - lookupConstr op `thenRn` \ new_op -> - rn_bang_ty ty1 `thenRn` \ new_ty1 -> - rn_bang_ty ty2 `thenRn` \ new_ty2 -> - returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc) - - rn_decl (NewConDecl name ty src_loc) - = pushSrcLocRn src_loc $ - lookupConstr name `thenRn` \ new_name -> - rn_mono_ty ty `thenRn` \ new_ty -> - returnRn (NewConDecl new_name new_ty src_loc) - - rn_decl (RecConDecl name fields src_loc) - = pushSrcLocRn src_loc $ - lookupConstr name `thenRn` \ new_name -> - mapRn rn_field fields `thenRn` \ new_fields -> - returnRn (RecConDecl new_name new_fields src_loc) - - rn_field (names, ty) - = mapRn lookupField names `thenRn` \ new_names -> - rn_bang_ty ty `thenRn` \ new_ty -> - returnRn (new_names, new_ty) - - rn_mono_ty = rnMonoType tv_env - rn_poly_ty = rnPolyType tv_env - - rn_bang_ty (Banged ty) - = rn_poly_ty ty `thenRn` \ new_ty -> - returnRn (Banged new_ty) - rn_bang_ty (Unbanged ty) - = rn_poly_ty ty `thenRn` \ new_ty -> - returnRn (Unbanged new_ty) -\end{code} - -%********************************************************* -%* * -\subsection{SPECIALIZE data pragmas} -%* * -%********************************************************* - -\begin{code} -rnSpecDataSig :: RdrNameSpecDataSig - -> RnM_Fixes s RenamedSpecDataSig - -rnSpecDataSig (SpecDataSig tycon ty src_loc) - = pushSrcLocRn src_loc $ - let - tyvars = extractMonoTyNames is_tyvar_name ty - in - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) -> - lookupTyCon tycon `thenRn` \ tycon' -> - rnMonoType tv_env ty `thenRn` \ ty' -> - returnRn (SpecDataSig tycon' ty' src_loc) - -is_tyvar_name n = isLexVarId (getLocalName n) + lookupRn name `thenRn` \ name' -> + bindTyVarsRn "type declaration" tyvars $ \ tyvars' -> + rnHsType ty `thenRn` \ ty' -> + returnRn (TyD (TySynonym name' tyvars' ty' src_loc)) \end{code} %********************************************************* @@ -481,38 +146,37 @@ class declaration in which local names have been replaced by their original names, reporting any unknown names. \begin{code} -rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl - -rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) +rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) = pushSrcLocRn src_loc $ - mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) -> - rnContext tv_env src_loc context `thenRn` \ context' -> - lookupClass cname `thenRn` \ cname' -> - mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' -> - rnMethodBinds cname' mbinds `thenRn` \ mbinds' -> + bindTyVarsRn "class declaration" [tyvar] $ \ [tyvar'] -> + rnContext context `thenRn` \ context' -> + lookupRn cname `thenRn` \ cname' -> + mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' -> + rnMethodBinds mbinds `thenRn` \ mbinds' -> ASSERT(isNoClassPragmas pragmas) - returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc) + returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)) where - rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn) + rn_op clas clas_tyvar sig@(ClassOpSig op ty pragmas locn) = pushSrcLocRn locn $ - lookupClassOp clas op `thenRn` \ op_name -> - rnPolyType tv_env ty `thenRn` \ new_ty -> + lookupRn op `thenRn` \ op_name -> + rnHsType ty `thenRn` \ new_ty -> let - (HsForAllTy tvs ctxt op_ty) = new_ty - ctxt_tvs = extractCtxtTyNames ctxt - op_tvs = extractMonoTyNames is_tyvar_name op_ty + (ctxt, op_ty) = case new_ty of + HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty) + other -> ([], new_ty) + ctxt_fvs = extractCtxtTyNames ctxt + op_ty_fvs = extractHsTyNames op_ty -- Includes tycons/classes but we + -- don't care about that in -- check that class tyvar appears in op_ty - ( if isIn "rn_op" clas_tyvar op_tvs - then returnRn () - else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn) - ) `thenRn_` + checkRn (clas_tyvar `elemNameSet` op_ty_fvs) + (classTyVarNotInOpTyErr clas_tyvar sig) + `thenRn_` -- check that class tyvar *doesn't* appear in the sig's context - ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs - then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn) - else returnRn () - ) `thenRn_` + checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs)) + (classTyVarInOpCtxtErr clas_tyvar sig) + `thenRn_` ASSERT(isNoClassOpPragmas pragmas) returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn) @@ -525,138 +189,137 @@ rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) %* * %********************************************************* - -@rnInstDecl@ uses the `global name function' to create a new of -instance declaration in which local names have been replaced by their -original names, reporting any unknown names. - \begin{code} -rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl - -rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc) +rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_name src_loc)) = pushSrcLocRn src_loc $ - lookupClass cname `thenRn` \ cname' -> - - rnPolyType [] ty `thenRn` \ ty' -> - -- [] tv_env ensures that tyvars will be foralled + rnHsType inst_ty `thenRn` \ inst_ty' -> + rnMethodBinds mbinds `thenRn` \ mbinds' -> + mapRn rn_uprag uprags `thenRn` \ new_uprags -> + rn_dfun maybe_dfun_name `thenRn` \ dfun_name' -> - rnMethodBinds cname' mbinds `thenRn` \ mbinds' -> - mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags -> - - ASSERT(isNoInstancePragmas pragmas) - returnRn (InstDecl cname' ty' mbinds' - from_here modname new_uprags noInstancePragmas src_loc) + returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name' src_loc)) where - rn_uprag class_name (SpecSig op ty using locn) + rn_dfun Nothing = newDfunName src_loc `thenRn` \ n' -> + returnRn (Just n') + rn_dfun (Just n) = lookupOptionalOccRn n `thenRn` \ n' -> + returnRn (Just n') + + rn_uprag (SpecSig op ty using locn) = pushSrcLocRn src_loc $ - lookupClassOp class_name op `thenRn` \ op_name -> - rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty -> + lookupRn op `thenRn` \ op_name -> + rnHsType ty `thenRn` \ new_ty -> rn_using using `thenRn` \ new_using -> returnRn (SpecSig op_name new_ty new_using locn) - rn_uprag class_name (InlineSig op locn) + rn_uprag (InlineSig op locn) = pushSrcLocRn locn $ - lookupClassOp class_name op `thenRn` \ op_name -> + lookupRn op `thenRn` \ op_name -> returnRn (InlineSig op_name locn) - rn_uprag class_name (DeforestSig op locn) + rn_uprag (DeforestSig op locn) = pushSrcLocRn locn $ - lookupClassOp class_name op `thenRn` \ op_name -> + lookupRn op `thenRn` \ op_name -> returnRn (DeforestSig op_name locn) - rn_uprag class_name (MagicUnfoldingSig op str locn) + rn_uprag (MagicUnfoldingSig op str locn) = pushSrcLocRn locn $ - lookupClassOp class_name op `thenRn` \ op_name -> + lookupRn op `thenRn` \ op_name -> returnRn (MagicUnfoldingSig op_name str locn) - rn_using Nothing - = returnRn Nothing - rn_using (Just v) - = lookupValue v `thenRn` \ new_v -> - returnRn (Just new_v) + rn_using Nothing = returnRn Nothing + rn_using (Just v) = lookupOccRn v `thenRn` \ new_v -> + returnRn (Just new_v) \end{code} %********************************************************* %* * -\subsection{@SPECIALIZE instance@ user-pragmas} +\subsection{Default declarations} %* * %********************************************************* \begin{code} -rnSpecInstSig :: RdrNameSpecInstSig - -> RnM_Fixes s RenamedSpecInstSig - -rnSpecInstSig (SpecInstSig clas ty src_loc) +rnDecl (DefD (DefaultDecl tys src_loc)) = pushSrcLocRn src_loc $ - let - tyvars = extractMonoTyNames is_tyvar_name ty - in - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) -> - lookupClass clas `thenRn` \ new_clas -> - rnMonoType tv_env ty `thenRn` \ new_ty -> - returnRn (SpecInstSig new_clas new_ty src_loc) + mapRn rnHsType tys `thenRn` \ tys' -> + lookupImplicitOccRn numClass_RDR `thenRn_` + returnRn (DefD (DefaultDecl tys' src_loc)) \end{code} %********************************************************* %* * -\subsection{Default declarations} +\subsection{Support code for type/data declarations} %* * %********************************************************* -@rnDefaultDecl@ uses the `global name function' to create a new set -of default declarations in which local names have been replaced by -their original names, reporting any unknown names. +\begin{code} +rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name]) + +rnDerivs Nothing -- derivs not specified + = lookupImplicitOccRn evalClass_RDR `thenRn_` + returnRn Nothing + +rnDerivs (Just ds) + = lookupImplicitOccRn evalClass_RDR `thenRn_` + mapRn rn_deriv ds `thenRn` \ derivs -> + returnRn (Just derivs) + where + rn_deriv clas + = lookupOccRn clas `thenRn` \ clas_name -> + + -- Now add extra "occurrences" for things that + -- the deriving mechanism will later need in order to + -- generate code for this class. + case lookupUFM derivingOccurrences clas_name of + Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_` + returnRn clas_name + + Just occs -> mapRn lookupImplicitOccRn occs `thenRn_` + returnRn clas_name +\end{code} \begin{code} -rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl] +rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl -rnDefaultDecl [] = returnRn [] -rnDefaultDecl [DefaultDecl tys src_loc] +rnConDecl (ConDecl name tys src_loc) = pushSrcLocRn src_loc $ - mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' -> - returnRn [DefaultDecl tys' src_loc] -rnDefaultDecl defs@(d:ds) - = addErrRn (dupDefaultDeclErr defs) `thenRn_` - rnDefaultDecl [d] -\end{code} + lookupRn name `thenRn` \ new_name -> + mapRn rnBangTy tys `thenRn` \ new_tys -> + returnRn (ConDecl new_name new_tys src_loc) -%************************************************************************* -%* * -\subsection{Fixity declarations} -%* * -%************************************************************************* +rnConDecl (ConOpDecl ty1 op ty2 src_loc) + = pushSrcLocRn src_loc $ + lookupRn op `thenRn` \ new_op -> + rnBangTy ty1 `thenRn` \ new_ty1 -> + rnBangTy ty2 `thenRn` \ new_ty2 -> + returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc) -\begin{code} -rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl] +rnConDecl (NewConDecl name ty src_loc) + = pushSrcLocRn src_loc $ + lookupRn name `thenRn` \ new_name -> + rnHsType ty `thenRn` \ new_ty -> + returnRn (NewConDecl new_name new_ty src_loc) -rnFixes fixities - = getSrcLocRn `thenRn` \ src_loc -> - let - (_, dup_fixes) = removeDups cmp_fix fixities - cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2 - - rn_fixity fix@(InfixL name i) - = rn_fixity_pieces InfixL name i fix - rn_fixity fix@(InfixR name i) - = rn_fixity_pieces InfixR name i fix - rn_fixity fix@(InfixN name i) - = rn_fixity_pieces InfixN name i fix - - rn_fixity_pieces mk_fixity name i fix - = getRnEnv `thenRn` \ env -> - case lookupGlobalRnEnv env name of - 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. - -> returnRn (Just (mk_fixity res i)) - _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix) - in - mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_` - mapRn rn_fixity fixities `thenRn` \ fixes_maybe -> - returnRn (catMaybes fixes_maybe) +rnConDecl (RecConDecl name fields src_loc) + = pushSrcLocRn src_loc $ + lookupRn name `thenRn` \ new_name -> + mapRn rnField fields `thenRn` \ new_fields -> + returnRn (RecConDecl new_name new_fields src_loc) + +rnField (names, ty) + = mapRn lookupRn names `thenRn` \ new_names -> + rnBangTy ty `thenRn` \ new_ty -> + returnRn (new_names, new_ty) + +rnBangTy (Banged ty) + = rnHsType ty `thenRn` \ new_ty -> + returnRn (Banged new_ty) + +rnBangTy (Unbanged ty) + = rnHsType ty `thenRn` \ new_ty -> + returnRn (Unbanged new_ty) \end{code} + %********************************************************* %* * \subsection{Support code to rename types} @@ -664,180 +327,307 @@ rnFixes fixities %********************************************************* \begin{code} -rnPolyType :: TyVarNamesEnv - -> RdrNamePolyType - -> RnM_Fixes s RenamedPolyType +rnHsType :: RdrNameHsType -> RnMS s RenamedHsType -rnPolyType tv_env (HsForAllTy tvs ctxt ty) - = rn_poly_help tv_env tvs ctxt ty +rnHsType (HsForAllTy tvs ctxt ty) + = rn_poly_help tvs ctxt ty -rnPolyType tv_env (HsPreForAllTy ctxt ty) - = rn_poly_help tv_env forall_tyvars ctxt ty - where - mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty - forall_tyvars = {- - pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $ - pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $ - -} - mentioned_tyvars `minusList` domTyVarNamesEnv tv_env - ------------- -rn_poly_help :: TyVarNamesEnv - -> [RdrName] - -> RdrNameContext - -> RdrNameMonoType - -> RnM_Fixes s RenamedPolyType - -rn_poly_help tv_env tyvars ctxt ty - = {- - pprTrace "rnPolyType:" - (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env), - ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars), - ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt), - ppStr ";ty=", ppr PprShowAll ty]) $ - -} - getSrcLocRn `thenRn` \ src_loc -> - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) -> +rnHsType full_ty@(HsPreForAllTy ctxt ty) + = getNameEnv `thenRn` \ name_env -> let - tv_env2 = catTyVarNamesEnvs tv_env1 tv_env + mentioned_tyvars = extractHsTyVars full_ty + forall_tyvars = filter not_in_scope mentioned_tyvars + not_in_scope tv = case lookupFM name_env tv of + Nothing -> True + Just _ -> False in - rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt -> - rnMonoType tv_env2 ty `thenRn` \ new_ty -> - returnRn (HsForAllTy new_tyvars new_ctxt new_ty) -\end{code} - -\begin{code} -rnMonoType :: TyVarNamesEnv - -> RdrNameMonoType - -> RnM_Fixes s RenamedMonoType + rn_poly_help (map UserTyVar forall_tyvars) ctxt ty -rnMonoType tv_env (MonoTyVar tyvar) - = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' -> +rnHsType (MonoTyVar tyvar) + = lookupOccRn tyvar `thenRn` \ tyvar' -> returnRn (MonoTyVar tyvar') -rnMonoType tv_env (MonoListTy ty) - = rnMonoType tv_env ty `thenRn` \ ty' -> - returnRn (MonoListTy ty') +rnHsType (MonoFunTy ty1 ty2) + = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2) -rnMonoType tv_env (MonoFunTy ty1 ty2) - = andRn MonoFunTy (rnMonoType tv_env ty1) - (rnMonoType tv_env ty2) +rnHsType (MonoListTy _ ty) + = lookupImplicitOccRn listType_RDR `thenRn` \ tycon_name -> + rnHsType ty `thenRn` \ ty' -> + returnRn (MonoListTy tycon_name ty') -rnMonoType tv_env (MonoTupleTy tys) - = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' -> - returnRn (MonoTupleTy tys') +rnHsType (MonoTupleTy _ tys) + = lookupImplicitOccRn (tupleType_RDR (length tys)) `thenRn` \ tycon_name -> + mapRn rnHsType tys `thenRn` \ tys' -> + returnRn (MonoTupleTy tycon_name tys') -rnMonoType tv_env (MonoTyApp name tys) - = let - lookup_fn = if isLexVarId (getLocalName name) - then lookupTyVarName tv_env - else lookupTyCon - in - lookup_fn name `thenRn` \ name' -> - mapRn (rnMonoType tv_env) tys `thenRn` \ tys' -> +rnHsType (MonoTyApp name tys) + = lookupOccRn name `thenRn` \ name' -> + mapRn rnHsType tys `thenRn` \ tys' -> returnRn (MonoTyApp name' tys') + +rnHsType (MonoDictTy clas ty) + = lookupOccRn clas `thenRn` \ clas' -> + rnHsType ty `thenRn` \ ty' -> + returnRn (MonoDictTy clas' ty') + + +rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars + -> RdrNameContext + -> RdrNameHsType + -> RnMS s RenamedHsType + +rn_poly_help tyvars ctxt ty + = bindTyVarsRn "type signature" tyvars $ \ new_tyvars -> + rnContext ctxt `thenRn` \ new_ctxt -> + rnHsType ty `thenRn` \ new_ty -> + returnRn (HsForAllTy new_tyvars new_ctxt new_ty) \end{code} + \begin{code} -rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext +rnContext :: RdrNameContext -> RnMS s RenamedContext -rnContext tv_env locn ctxt +rnContext ctxt = mapRn rn_ctxt ctxt `thenRn` \ result -> let (_, dup_asserts) = removeDups cmp_assert result in -- If this isn't an error, then it ought to be: - mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_` + mapRn (addWarnRn . dupClassAssertWarn result) dup_asserts `thenRn_` returnRn result where - rn_ctxt (clas, tyvar) - = lookupClass clas `thenRn` \ clas_name -> - lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name -> - returnRn (clas_name, tyvar_name) + rn_ctxt (clas, ty) + = lookupOccRn clas `thenRn` \ clas_name -> + rnHsType ty `thenRn` \ ty' -> + returnRn (clas_name, ty') - cmp_assert (c1,tv1) (c2,tv2) - = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2) + cmp_assert (c1,ty1) (c2,ty2) + = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2) \end{code} +%********************************************************* +%* * +\subsection{IdInfo} +%* * +%********************************************************* + \begin{code} -dupNameExportWarn locn names@((n,_):_) - = addShortWarnLocLine locn $ \ sty -> - ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"] - -dupLocalsExportErr locn locals@((str,_):_) - = addErrLoc locn "exported names have same local name" $ \ sty -> - ppInterleave ppSP (map (pprNonSym sty . snd) locals) - -classOpExportErr op locn - = addShortErrLocLine locn $ \ sty -> - ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with its class"] - -fieldExportErr op locn - = addShortErrLocLine locn $ \ sty -> - ppBesides [ppStr "field name `", ppr sty op, ppStr "' can only be exported with its data type"] - -synAllExportErr is_error syn locn - = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty -> - ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"] - -withExportErr str rn has rns locn - = addErrLoc locn "" $ \ sty -> - ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"], - ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)], - ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ] - -importAllErr rn locn - = addShortErrLocLine locn $ \ sty -> - ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"] - -badModExportErr mod locn - = addShortErrLocLine locn $ \ sty -> - ppCat [ ppStr "unknown module in export list: module", ppPStr mod] - -emptyModExportWarn locn mod - = addShortWarnLocLine locn $ \ sty -> - ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"] - -dupModExportWarn locn mods@(mod:_) - = addShortWarnLocLine locn $ \ sty -> - ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"] - -derivingNonStdClassErr clas locn - = addShortErrLocLine locn $ \ sty -> - ppCat [ppStr "non-standard class in deriving:", ppr sty clas] - -dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty - = ppAboves (item1 : map dup_item dup_things) +rnIdInfo (HsStrictness strict) + = rnStrict strict `thenRn` \ strict' -> + returnRn (HsStrictness strict') + +rnIdInfo (HsUnfold expr) = rnCoreExpr expr `thenRn` \ expr' -> + returnRn (HsUnfold expr') +rnIdInfo (HsArity arity) = returnRn (HsArity arity) +rnIdInfo (HsUpdate update) = returnRn (HsUpdate update) +rnIdInfo (HsFBType fb) = returnRn (HsFBType fb) +rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au) +rnIdInfo (HsDeforest df) = returnRn (HsDeforest df) + +rnStrict (StrictnessInfo demands (Just worker)) + = lookupOptionalOccRn worker `thenRn` \ worker' -> + returnRn (StrictnessInfo demands (Just worker')) + +-- Boring, but necessary for the type checker. +rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing) +rnStrict BottomGuaranteed = returnRn BottomGuaranteed +rnStrict NoStrictnessInfo = returnRn NoStrictnessInfo +\end{code} + +UfCore expressions. + +\begin{code} +rnCoreExpr (UfVar v) + = lookupOptionalOccRn v `thenRn` \ v' -> + returnRn (UfVar v') + +rnCoreExpr (UfLit lit) = returnRn (UfLit lit) + +rnCoreExpr (UfCon con args) + = lookupOptionalOccRn con `thenRn` \ con' -> + mapRn rnCoreArg args `thenRn` \ args' -> + returnRn (UfCon con' args') + +rnCoreExpr (UfPrim prim args) + = rnCorePrim prim `thenRn` \ prim' -> + mapRn rnCoreArg args `thenRn` \ args' -> + returnRn (UfPrim prim' args') + +rnCoreExpr (UfApp fun arg) + = rnCoreExpr fun `thenRn` \ fun' -> + rnCoreArg arg `thenRn` \ arg' -> + returnRn (UfApp fun' arg') + +rnCoreExpr (UfCase scrut alts) + = rnCoreExpr scrut `thenRn` \ scrut' -> + rnCoreAlts alts `thenRn` \ alts' -> + returnRn (UfCase scrut' alts') + +rnCoreExpr (UfSCC cc expr) + = rnCoreExpr expr `thenRn` \ expr' -> + returnRn (UfSCC cc expr') + +rnCoreExpr(UfCoerce coercion ty body) + = rnCoercion coercion `thenRn` \ coercion' -> + rnHsType ty `thenRn` \ ty' -> + rnCoreExpr body `thenRn` \ body' -> + returnRn (UfCoerce coercion' ty' body') + +rnCoreExpr (UfLam bndr body) + = rnCoreBndr bndr $ \ bndr' -> + rnCoreExpr body `thenRn` \ body' -> + returnRn (UfLam bndr' body') + +rnCoreExpr (UfLet (UfNonRec bndr rhs) body) + = rnCoreExpr rhs `thenRn` \ rhs' -> + rnCoreBndr bndr $ \ bndr' -> + rnCoreExpr body `thenRn` \ body' -> + returnRn (UfLet (UfNonRec bndr' rhs') body') + +rnCoreExpr (UfLet (UfRec pairs) body) + = rnCoreBndrs bndrs $ \ bndrs' -> + mapRn rnCoreExpr rhss `thenRn` \ rhss' -> + rnCoreExpr body `thenRn` \ body' -> + returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body') where - item1 - = addShortErrLocLine locn1 (\ sty -> - ppStr "multiple default declarations") sty + (bndrs, rhss) = unzip pairs +\end{code} + +\begin{code} +rnCoreBndr (UfValBinder name ty) thing_inside + = rnHsType ty `thenRn` \ ty' -> + bindLocalsRn "unfolding value" [name] $ \ [name'] -> + thing_inside (UfValBinder name' ty') + +rnCoreBndr (UfTyBinder name kind) thing_inside + = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] -> + thing_inside (UfTyBinder name' kind) + +rnCoreBndr (UfUsageBinder name) thing_inside + = bindLocalsRn "unfolding usage" [name] $ \ [name'] -> + thing_inside (UfUsageBinder name') + +rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders + = mapRn rnHsType tys `thenRn` \ tys' -> + bindLocalsRn "unfolding value" names $ \ names' -> + thing_inside (zipWith UfValBinder names' tys') + where + names = map (\ (UfValBinder name _) -> name) bndrs + tys = map (\ (UfValBinder _ ty) -> ty) bndrs +\end{code} + +\begin{code} +rnCoreArg (UfVarArg v) = lookupOptionalOccRn v `thenRn` \ v' -> returnRn (UfVarArg v') +rnCoreArg (UfUsageArg u) = lookupOptionalOccRn u `thenRn` \ u' -> returnRn (UfUsageArg u') +rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty') +rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit) + +rnCoreAlts (UfAlgAlts alts deflt) + = mapRn rn_alt alts `thenRn` \ alts' -> + rnCoreDefault deflt `thenRn` \ deflt' -> + returnRn (UfAlgAlts alts' deflt') + where + rn_alt (con, bndrs, rhs) = lookupOptionalOccRn con `thenRn` \ con' -> + rnCoreBndrs bndrs $ \ bndrs' -> + rnCoreExpr rhs `thenRn` \ rhs' -> + returnRn (con', bndrs', rhs') + +rnCoreAlts (UfPrimAlts alts deflt) + = mapRn rn_alt alts `thenRn` \ alts' -> + rnCoreDefault deflt `thenRn` \ deflt' -> + returnRn (UfPrimAlts alts' deflt') + where + rn_alt (lit, rhs) = rnCoreExpr rhs `thenRn` \ rhs' -> + returnRn (lit, rhs') + +rnCoreDefault UfNoDefault = returnRn UfNoDefault +rnCoreDefault (UfBindDefault bndr rhs) = rnCoreBndr bndr $ \ bndr' -> + rnCoreExpr rhs `thenRn` \ rhs' -> + returnRn (UfBindDefault bndr' rhs') + +rnCoercion (UfIn n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfIn n') +rnCoercion (UfOut n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfOut n') + +rnCorePrim (UfOtherOp op) + = lookupOptionalOccRn op `thenRn` \ op' -> + returnRn (UfOtherOp op') - dup_item (DefaultDecl _ locn) - = addShortErrLocLine locn (\ sty -> - ppStr "here was another default declaration") sty +rnCorePrim (UfCCallOp str casm gc arg_tys res_ty) + = mapRn rnHsType arg_tys `thenRn` \ arg_tys' -> + rnHsType res_ty `thenRn` \ res_ty' -> + returnRn (UfCCallOp str casm gc arg_tys' res_ty') +\end{code} -undefinedFixityDeclErr locn decl - = addErrLoc locn "fixity declaration for unknown operator" $ \ sty -> - ppr sty decl +%********************************************************* +%* * +\subsection{Errors} +%* * +%********************************************************* -dupFixityDeclErr locn dups - = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty -> - ppAboves (map (ppr sty) dups) +\begin{code} +derivingNonStdClassErr clas sty + = ppCat [ppStr "non-standard class in deriving:", ppr sty clas] -classTyVarNotInOpTyErr clas_tyvar sig locn - = addShortErrLocLine locn $ \ sty -> - ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"]) +classTyVarNotInOpTyErr clas_tyvar sig sty + = ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"]) 4 (ppr sty sig) -classTyVarInOpCtxtErr clas_tyvar sig locn - = addShortErrLocLine locn $ \ sty -> - ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"]) +classTyVarInOpCtxtErr clas_tyvar sig sty + = ppHang (ppBesides [ ppStr "Class type variable `", ppr sty clas_tyvar, + ppStr "' present in method's local overloading context:"]) 4 (ppr sty sig) -dupClassAssertWarn ctxt locn dups - = addShortWarnLocLine locn $ \ sty -> - ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"]) +dupClassAssertWarn ctxt dups sty + = ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"]) 4 (ppr sty ctxt) \end{code} + + + + + +=================== OLD STUFF ====================== + +%********************************************************* +%* * +\subsection{SPECIALIZE data pragmas} +%* * +%********************************************************* + +\begin{pseudocode} +rnSpecDataSig :: RdrNameSpecDataSig + -> RnMS s RenamedSpecDataSig + +rnSpecDataSig (SpecDataSig tycon ty src_loc) + = pushSrcLocRn src_loc $ + let + tyvars = filter extractHsTyNames ty + in + mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) -> + lookupOccRn tycon `thenRn` \ tycon' -> + rnHsType tv_env ty `thenRn` \ ty' -> + returnRn (SpecDataSig tycon' ty' src_loc) + +\end{pseudocode} + +%********************************************************* +%* * +\subsection{@SPECIALIZE instance@ user-pragmas} +%* * +%********************************************************* + +\begin{pseudocode} +rnSpecInstSig :: RdrNameSpecInstSig + -> RnMS s RenamedSpecInstSig + +rnSpecInstSig (SpecInstSig clas ty src_loc) + = pushSrcLocRn src_loc $ + let + tyvars = extractHsTyNames is_tyvar_name ty + in + mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) -> + lookupOccRn clas `thenRn` \ new_clas -> + rnHsType tv_env ty `thenRn` \ new_ty -> + returnRn (SpecInstSig new_clas new_ty src_loc) +\end{pseudocode} diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs deleted file mode 100644 index acf64f7..0000000 --- a/ghc/compiler/rename/RnUtils.lhs +++ /dev/null @@ -1,236 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[RnUtils]{Functions used by both renaming passes} - -\begin{code} -#include "HsVersions.h" - -module RnUtils ( - SYN_IE(RnEnv), SYN_IE(QualNames), - SYN_IE(UnqualNames), SYN_IE(ScopeStack), - emptyRnEnv, initRnEnv, extendGlobalRnEnv, extendLocalRnEnv, - lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, - getLocalsFromRnEnv, - - lubExportFlag, - - qualNameErr, - dupNamesErr, - pprRnEnv -- debugging only - ) where - -IMP_Ubiq(){-uitous-} -IMPORT_1_3(List(partition)) - -import Bag ( Bag, emptyBag, snocBag, unionBags ) -import CmdLineOpts ( opt_GlasgowExts ) -import ErrUtils ( addShortErrLocLine ) -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 ) -\end{code} - -********************************************************* -* * -\subsection{RnEnv: renaming environment} -* * -********************************************************* - -Separate FiniteMaps are kept for lookup up Qual names, -Unqual names and Local names. - -\begin{code} -type RnEnv = ((QualNames, UnqualNames, QualNames, UnqualNames), ScopeStack) - -type QualNames = FiniteMap (FAST_STRING,Module) RnName -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]) -lookupRnEnv :: RnEnv -> RdrName -> Maybe RnName -lookupGlobalRnEnv :: RnEnv -> RdrName -> Maybe RnName -lookupTcRnEnv :: RnEnv -> RdrName -> Maybe RnName - -getLocalsFromRnEnv :: RnEnv -> ([RnName], [RnName]) - -- grabs the locally defined names from the unqual envs -\end{code} - -If the @RdrName@ is a @Qual@, @lookupValue@ looks it up in the global -value QualNames. If it is @Unqual@, it looks it up first in the -ScopeStack, and if it isn't found there, then in the global -vaule Unqual Names. - -@lookupTcRnEnv@ looks up tycons/classes in the alternative global -name space. - -@extendGlobalRnEnv@ adds global names to the RnEnv. It takes separate -value and tycon/class name lists. It returns any duplicate names -seperately. - -@extendRnEnv@ adds new local names to the ScopeStack in an RnEnv. -It optionally reports any shadowed names. - -\begin{code} -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) - (((qual', unqual', tc_qual', tc_unqual'), stack), tc_dups `unionBags` dups) - where - (qual', unqual', dups) = extend_global qual unqual val_list - (tc_qual', tc_unqual', tc_dups) = extend_global tc_qual tc_unqual tc_list - - extend_global qual unqual rdr_list = (qual', unqual', dups) - where - (qual_list, unqual_list) = partition (isQual.fst) rdr_list - qual_in = map mk_qual qual_list - unqual_in = map mk_unqual unqual_list - mk_qual (Qual m s, rn) = ((s,m), rn) - mk_unqual (Unqual s, rn) = (s, rn) - - (qual', qual_dups) = do_dups qual_in qual emptyBag (\ (s,m) -> Qual m s) - (unqual', unqual_dups) = do_dups unqual_in unqual emptyBag Unqual - - dups = unqual_dups `unionBags` qual_dups - - do_dups [] fm dups to_rdr = (fm, dups) - do_dups ((k,v):rest) fm dups to_rdr - = case lookupFM fm k of - Nothing -> do_dups rest (addToFM fm k v) dups to_rdr - Just cur -> do_dups rest fm (dups `snocBag` (to_rdr k, cur, v)) to_rdr - - -extendLocalRnEnv report_shadows (global, stack) new_local - = ((global, new_stack), dups) - where - (new_stack, dups) = extend new_local stack - - extend names stack - = if report_shadows then - do_shadows names stack [] - else - (addListToFM stack [ (getLocalName n, n) | n <- names], []) - - do_shadows [] stack dups = (stack, dups) - do_shadows (name:names) stack dups - = do_shadows names (addToFM stack str name) ext_dups - where - str = getLocalName name - 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 (lookupFM unqual str) - Qual mod str -> lookupFM qual (str,mod) - where - lookup fm thing do_on_fail - = case lookupFM fm thing of - found@(Just name) -> found - Nothing -> do_on_fail - -lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr - = case rdr of - Unqual str -> 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 -> lookupFM tc_qual (str,mod) - -getLocalsFromRnEnv ((_, vals, _, tcs), _) - = (filter isLocallyDefined (eltsFM vals), - filter isLocallyDefined (eltsFM tcs)) -\end{code} - -********************************************************* -* * -\subsection{Export Flag Functions} -* * -********************************************************* - -\begin{code} -lubExportFlag ExportAll ExportAll = ExportAll -lubExportFlag ExportAll ExportAbs = ExportAll -lubExportFlag ExportAbs ExportAll = ExportAll -lubExportFlag ExportAbs ExportAbs = ExportAbs -\end{code} - -********************************************************* -* * -\subsection{Errors used *more than once* in the renamer} -* * -********************************************************* - -\begin{code} -qualNameErr descriptor (name,locn) - = addShortErrLocLine locn ( \ sty -> - ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonSym sty name ] ) - -dupNamesErr descriptor ((name1,locn1) : dup_things) sty - = ppAboves (item1 : map dup_item dup_things) - where - item1 - = addShortErrLocLine locn1 (\ sty -> - ppBesides [ppStr "multiple declarations of a ", ppStr descriptor, ppStr " `", - pprNonSym sty name1, ppStr "'" ]) sty - - dup_item (name, locn) - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "here was another declaration of `", - pprNonSym sty name, ppStr "'" ]) sty - ------------------ -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/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index 9b44d2e..f668ecf 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -14,8 +14,6 @@ module BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!) - inlineUnconditionally, okToInline, - addBinderInfo, orBinderInfo, andBinderInfo, argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo, @@ -28,7 +26,6 @@ module BinderInfo ( IMP_Ubiq(){-uitous-} -import CoreUnfold ( FormSummary(..) ) import Pretty import Util ( panic ) \end{code} @@ -101,48 +98,23 @@ noBinderInfo = ManyOcc 0 -- A non-committal value \end{code} -Predicates -~~~~~~~~~~ \begin{code} -okToInline - :: FormSummary -- What the thing to be inlined is like - -> BinderInfo -- How the thing to be inlined occurs - -> Bool -- True => it's small enough to inline - -> Bool -- True => yes, inline it - --- Always inline bottoms -okToInline BottomForm occ_info small_enough - = True -- Unless one of the type args is unboxed?? - -- This used to be checked for, but I can't - -- see why so I've left it out. - --- A WHNF can be inlined if it occurs once, or is small -okToInline form occ_info small_enough - | is_whnf_form form - = small_enough || one_occ - where - one_occ = case occ_info of - OneOcc _ _ _ n_alts _ -> n_alts <= 1 - other -> False - - is_whnf_form VarForm = True - is_whnf_form ValueForm = True - is_whnf_form other = False - --- A non-WHNF can be inlined if it doesn't occur inside a lambda, --- and occurs exactly once or --- occurs once in each branch of a case and is small -okToInline OtherForm (OneOcc _ NoDupDanger _ n_alts _) small_enough - = n_alts <= 1 || small_enough - -okToInline form any_occ small_enough = False +isFun :: FunOrArg -> Bool +isFun FunOcc = True +isFun _ = False + +isDupDanger :: DuplicationDanger -> Bool +isDupDanger DupDanger = True +isDupDanger _ = False \end{code} @inlineUnconditionally@ decides whether a let-bound thing can definitely be inlined. \begin{code} +{- NOT USED + inlineUnconditionally :: Bool -> BinderInfo -> Bool --inlineUnconditionally ok_to_dup DeadCode = True @@ -153,16 +125,7 @@ inlineUnconditionally ok_to_dup (OneOcc FunOcc NoDupDanger NotInsideSCC n_alt_oc -- damage, e.g., limit to M alternatives. inlineUnconditionally _ _ = False -\end{code} - -\begin{code} -isFun :: FunOrArg -> Bool -isFun FunOcc = True -isFun _ = False - -isDupDanger :: DuplicationDanger -> Bool -isDupDanger DupDanger = True -isDupDanger _ = False +-} \end{code} diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs index 4369260..59765ec 100644 --- a/ghc/compiler/simplCore/ConFold.lhs +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -15,10 +15,10 @@ module ConFold ( completePrim ) where IMP_Ubiq(){-uitous-} import CoreSyn -import CoreUnfold ( Unfolding(..), SimpleUnfolding ) +import CoreUnfold ( Unfolding, SimpleUnfolding ) import Id ( idType ) import Literal ( mkMachInt, mkMachWord, Literal(..) ) -import MagicUFs ( MagicUnfoldingFun ) +-- import MagicUFs ( MagicUnfoldingFun ) import PrimOp ( PrimOp(..) ) import SimplEnv import SimplMonad diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs index 19ec58c..f7fc933 100644 --- a/ghc/compiler/simplCore/FoldrBuildWW.lhs +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -30,7 +30,7 @@ import Util ( panic{-ToDo:rm?-} ) -- ) --import IdInfo --import Maybes ---import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +--import SrcLoc ( noSrcLoc, SrcLoc ) --import Util \end{code} @@ -156,8 +156,8 @@ try_split_bind id expr = -- right function to use .. -- Now the bodies - c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty mkUnknownSrcLoc - n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty mkUnknownSrcLoc + c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty noSrcLoc + n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty noSrcLoc worker_rhs = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index a67c6a6..3f3c76f 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -17,7 +17,7 @@ liberateCase = panic "LiberateCase.liberateCase: ToDo" {- LATER: to end of file: import CoreUnfold ( UnfoldingGuidance(..) ) -import Id ( localiseId, toplevelishId{-debugging-} ) +import Id ( localiseId ) import Maybes import Outputable import Pretty @@ -169,7 +169,7 @@ libCaseBind env (Rec pairs) -- Why "localiseId" above? Because we're creating a new local -- copy of the original binding. In particular, the original - -- binding might have been for a TopLevId, and this copy clearly + -- binding might have been for a top-level, and this copy clearly -- will not be top-level! -- It is enough to change just the binder, because subsequent @@ -180,12 +180,11 @@ libCaseBind env (Rec pairs) -- to think that something is top-level when it isn't. rhs_small_enough rhs - = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE cON_DISCOUNT rhs) of + = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of UnfoldNever -> False _ -> True -- we didn't BOMB, so it must be OK lIBERATE_BOMB_SIZE = bombOutSize env - cON_DISCOUNT = error "libCaseBind" \end{code} @@ -307,8 +306,7 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var scruts' = (scrut_var, lvl) : scruts bind_lvl = case lookupIdEnv lvl_env scrut_var of Just lvl -> lvl - Nothing -> --false: ASSERT(toplevelishId scrut_var) - topLevel + Nothing -> topLevel lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id @@ -317,16 +315,14 @@ lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id #else = case (lookupIdEnv rec_env id) of xxx@(Just _) -> xxx - xxx -> --false: ASSERT(toplevelishId id) - xxx + xxx -> xxx #endif lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id = case lookupIdEnv lvl_env id of Just lvl -> lvl - Nothing -> ASSERT(toplevelishId id) - topLevel + Nothing -> topLevel freeScruts :: LibCaseEnv -> LibCaseLevel -- Level of the recursive Id diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 4453c10..3ed4f73 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -25,7 +25,6 @@ import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) import CoreSyn import Digraph ( stronglyConnComp ) import Id ( idWantsToBeINLINEd, isConstMethodId, - externallyVisibleId, emptyIdSet, unionIdSets, mkIdSet, unitIdSet, elementOfIdSet, addOneToIdSet, SYN_IE(IdSet), @@ -34,6 +33,7 @@ import Id ( idWantsToBeINLINEd, isConstMethodId, mapIdEnv, lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Eq-} ) +import Name ( isExported ) import Maybes ( maybeToBool ) import Outputable ( Outputable(..){-instance * (,) -} ) import PprCore @@ -138,7 +138,7 @@ tagBinder usage binder ) usage_of usage binder - | externallyVisibleId binder = ManyOcc 0 -- Visible-elsewhere things count as many + | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many | otherwise = case (lookupIdEnv usage binder) of Nothing -> DeadCode diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index e37a9fd..36295df 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -37,7 +37,7 @@ import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate, InstTyEnv(..) ) import Id ( mkSysLocal, idType ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import UniqSupply import Util @@ -138,9 +138,9 @@ getSATInfo var us env newSATName :: Id -> Type -> SatM Id newSATName id ty us env = case (getUnique us) of { unique -> - (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) } + (mkSysLocal new_str unique ty noSrcLoc, env) } where - new_str = panic "SATMonad.newSATName (ToDo)" -- getOccName id _APPEND_ SLIT("_sat") + new_str = getOccName id _APPEND_ SLIT("_sat") getArgLists :: CoreExpr -> ([Arg Type],[Arg Id]) getArgLists expr @@ -218,7 +218,7 @@ saTransform binder rhs (getOccName binder _APPEND_ SLIT("_fsat")) (uniqueOf binder) (idType binder) - mkUnknownSrcLoc + noSrcLoc rec_body = mkValLam non_static_args ( Let (NonRec fake_binder nonrec_rhs) {-in-} (dropArgs rhs)) diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index ca79733..2b61266 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -29,14 +29,14 @@ import CoreSyn import CoreUtils ( coreExprType ) import CoreUnfold ( whnfOrBottom ) import FreeVars -- all of it -import Id ( idType, mkSysLocal, toplevelishId, +import Id ( idType, mkSysLocal, nullIdEnv, addOneToIdEnv, growIdEnvList, unionManyIdSets, minusIdSet, mkIdSet, idSetToList, lookupIdEnv, SYN_IE(IdEnv) ) import Pretty ( ppStr, ppBesides, ppChar, ppInt ) -import SrcLoc ( mkUnknownSrcLoc ) +import SrcLoc ( noSrcLoc ) import Type ( isPrimType, mkTyVarTys, mkForAllTys ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, lookupTyVarEnv, @@ -269,19 +269,31 @@ lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr) = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' -> returnLvl (Coerce c ty expr') +-- We don't split adjacent lambdas. That is, given +-- \x y -> (x+1,y) +-- we don't float to give +-- \x -> let v = x+y in \y -> (v,y) +-- Why not? Because partial applications are fairly rare, and splitting +-- lambdas makes them more expensive. + lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs) - = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' -> - returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs') + = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' -> + returnLvl (foldr (Lam . ValBinder) body' lvld_args) where - incd_lvl = incMajorLvl ctxt_lvl - new_venv = growIdEnvList venv [(arg,incd_lvl)] + incd_lvl = incMajorLvl ctxt_lvl + (args, body) = annCollectValBinders rhs + lvld_args = [(a,incd_lvl) | a <- (arg:args)] + new_venv = growIdEnvList venv lvld_args + +-- We don't need to play such tricks for type lambdas, because +-- they don't get annotated -lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e) - = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' -> - returnLvl (Lam (TyBinder tyvar) e') +lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body) + = lvlExpr incd_lvl (venv, new_tenv) body `thenLvl` \ body' -> + returnLvl (Lam (TyBinder tyvar) body') where - incd_lvl = incMinorLvl ctxt_lvl - new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl + incd_lvl = incMinorLvl ctxt_lvl + new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e) = panic "SetLevels.lvlExpr:AnnLam UsageBinder" @@ -707,8 +719,7 @@ idLevel :: IdEnv Level -> Id -> Level idLevel venv v = case lookupIdEnv venv v of Just level -> level - Nothing -> ASSERT(toplevelishId v) - tOP_LEVEL + Nothing -> tOP_LEVEL tyvarLevel :: TyVarEnv Level -> TyVar -> Level tyvarLevel tenv tyvar @@ -717,6 +728,16 @@ tyvarLevel tenv tyvar Nothing -> tOP_LEVEL \end{code} +\begin{code} +annCollectValBinders (_, (AnnLam (ValBinder arg) rhs)) + = (arg:args, body) + where + (args, body) = annCollectValBinders rhs + +annCollectValBinders body + = ([], body) +\end{code} + %************************************************************************ %* * \subsection{Free-To-Level Monad} @@ -740,5 +761,5 @@ applications, to give them a fighting chance of being floated. newLvlVar :: Type -> LvlM Id newLvlVar ty us - = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc + = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc \end{code} diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 4318ec5..4a57044 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -16,9 +16,7 @@ IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun ) import BinderInfo -- too boring to try to select things... import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), - SimpleUnfolding, FormSummary - ) +import CoreUnfold ( Unfolding, SimpleUnfolding ) import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp, unTagBindersAlts ) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 1de8ab9..80d9bb3 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -14,11 +14,6 @@ IMPORT_1_3(IO(hPutStr,stderr)) import AnalFBWW ( analFBWW ) import Bag ( isEmptyBag, foldBag ) import BinderInfo ( BinderInfo{-instance Outputable-} ) -import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD, - uNFOLDING_USE_THRESHOLD, - uNFOLDING_OVERRIDE_THRESHOLD, - uNFOLDING_CON_DISCOUNT_WEIGHT - ) import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn, opt_D_show_passes, opt_D_simplifier_stats, @@ -27,29 +22,34 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn, opt_FoldrBuildOn, opt_ReportWhyUnfoldingsDisallowed, opt_ShowImportSpecs, - opt_UnfoldingCreationThreshold, - opt_UnfoldingOverrideThreshold, - opt_UnfoldingUseThreshold + opt_LiberateCaseThreshold ) import CoreLint ( lintCoreBindings ) import CoreSyn +import CoreUtils ( coreExprType ) import CoreUnfold -import CoreUtils ( substCoreBindings ) +import Literal ( Literal(..), literalType, mkMachInt ) import ErrUtils ( ghcExit ) import FiniteMap ( FiniteMap ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FoldrBuildWW ( mkFoldrBuildWW ) -import Id ( idType, toplevelishId, idWantsToBeINLINEd, - unfoldingUnfriendlyId, isWrapperId, +import Id ( mkSysLocal, setIdVisibility, nullIdEnv, addOneToIdEnv, delOneFromIdEnv, - lookupIdEnv, SYN_IE(IdEnv), + lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Outputable-} ) -import IdInfo ( mkUnfolding ) +import Name ( isExported, isLocallyDefined ) +import TyCon ( TyCon ) +import PrimOp ( PrimOp(..) ) +import PrelVals ( unpackCStringId, unpackCString2Id, + integerZeroId, integerPlusOneId, + integerPlusTwoId, integerMinusOneId + ) +import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts ) +import TysWiredIn ( stringTy ) import LiberateCase ( liberateCase ) import MagicUFs ( MagicUnfoldingFun ) -import Maybes ( maybeToBool ) import Outputable ( Outputable(..){-instance * (,) -} ) import PprCore import PprStyle ( PprStyle(..) ) @@ -62,16 +62,20 @@ import Specialise import SpecUtils ( pprSpecErrs ) import StrictAnal ( saWwTopBinds ) import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} ) -import Unique ( Unique{-instance Eq-} ) -import UniqSupply ( splitUniqSupply ) -import Util ( panic{-ToDo:rm-} ) +import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} ) +import UniqSupply ( splitUniqSupply, getUnique ) +import Util ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic ) +import SrcLoc ( noSrcLoc ) +import Constants ( tARGET_MIN_INT, tARGET_MAX_INT ) +import Bag +import Maybes + #ifndef OMIT_DEFORESTER import Deforest ( deforestProgram ) import DefUtils ( deforestable ) #endif -isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)" \end{code} \begin{code} @@ -83,57 +87,46 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do -> FiniteMap TyCon [(Bool, [Maybe Type])] -> [CoreBinding] -- input... -> IO - ([CoreBinding], -- results: program, plus... - IdEnv Unfolding, -- unfoldings to be exported from here + ([CoreBinding], -- results: program, plus... SpecialiseData) -- specialisation data core2core core_todos module_name ppr_style us local_tycons tycon_specs binds - = if null core_todos then -- very rare, I suspect... - -- well, we still must do some renumbering - return ( - (substCoreBindings nullIdEnv nullTyVarEnv binds us, - nullIdEnv, - init_specdata) - ) - else - (if do_verbose_core2core then + = -- Print heading + (if opt_D_verbose_core2core then hPutStr stderr "VERBOSE CORE-TO-CORE:\n" - else return ()) >> + else return ()) >> - -- better do the main business - foldl_mn do_core_pass - (binds, us, nullIdEnv, init_specdata, zeroSimplCount) + -- Do the main business + foldl_mn do_core_pass + (binds, us1, init_specdata, zeroSimplCount) core_todos - >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) -> - - (if opt_D_simplifier_stats - then hPutStr stderr ("\nSimplifier Stats:\n") - >> - hPutStr stderr (showSimplCount simpl_stats) - >> - hPutStr stderr "\n" - else return () - ) >> - - return (processed_binds, inline_env, spec_data) + >>= \ (processed_binds, _, spec_data, simpl_stats) -> + + -- Do the final tidy-up + let + final_binds = tidyCorePgm module_name us2 processed_binds + in + + -- Report statistics + (if opt_D_simplifier_stats then + hPutStr stderr ("\nSimplifier Stats:\n") >> + hPutStr stderr (showSimplCount simpl_stats) >> + hPutStr stderr "\n" + else return ()) >> + + -- + return (final_binds, spec_data) where + (us1, us2) = splitUniqSupply us init_specdata = initSpecData local_tycons tycon_specs - do_verbose_core2core = opt_D_verbose_core2core - - lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME - -- Use 4x a known threshold - = case opt_UnfoldingOverrideThreshold of - Nothing -> 4 * uNFOLDING_USE_THRESHOLD - Just xx -> 4 * xx - ------------- core_linter = if opt_DoCoreLinting then lintCoreBindings ppr_style else ( \ whodunnit spec_done binds -> binds ) -------------- - do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do + do_core_pass info@(binds, us, spec_data, simpl_stats) to_do = let (us1, us2) = splitUniqSupply us in @@ -144,7 +137,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds then " (foldr/build)" else "") >> case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of (p, it_cnt, simpl_stats2) - -> end_pass False us2 p inline_env spec_data simpl_stats2 + -> end_pass False us2 p spec_data simpl_stats2 ("Simplify (" ++ show it_cnt ++ ")" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild then " foldr/build" else "") @@ -153,49 +146,37 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> _scc_ "CoreDoFoldrBuildWorkerWrapper" begin_pass "FBWW" >> case (mkFoldrBuildWW us1 binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" } + end_pass False us2 binds2 spec_data simpl_stats "FBWW" } CoreDoFoldrBuildWWAnal -> _scc_ "CoreDoFoldrBuildWWAnal" begin_pass "AnalFBWW" >> case (analFBWW binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" } + end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" } CoreLiberateCase -> _scc_ "LiberateCase" begin_pass "LiberateCase" >> - case (liberateCase lib_case_threshold binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" } - - CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres - -> _scc_ "CoreInlinings1" - begin_pass "CalcInlinings" >> - case (calcInlinings False inline_env binds) of { inline_env2 -> - end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" } - - CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres - -> _scc_ "CoreInlinings2" - begin_pass "CalcInlinings" >> - case (calcInlinings True inline_env binds) of { inline_env2 -> - end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" } + case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 -> + end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" } CoreDoFloatInwards -> _scc_ "FloatInwards" begin_pass "FloatIn" >> case (floatInwards binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" } + end_pass False us2 binds2 spec_data simpl_stats "FloatIn" } CoreDoFullLaziness -> _scc_ "CoreFloating" begin_pass "FloatOut" >> case (floatOutwards us1 binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" } + end_pass False us2 binds2 spec_data simpl_stats "FloatOut" } CoreDoStaticArgs -> _scc_ "CoreStaticArgs" begin_pass "StaticArgs" >> case (doStaticArgs binds us1) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" } + end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" } -- Binds really should be dependency-analysed for static- -- arg transformation... Not to worry, they probably are. -- (I don't think it *dies* if they aren't [WDP 94/04/15]) @@ -204,7 +185,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> _scc_ "CoreStranal" begin_pass "StrAnal" >> case (saWwTopBinds us1 binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" } + end_pass False us2 binds2 spec_data simpl_stats "StrAnal" } CoreDoSpecialising -> _scc_ "Specialise" @@ -227,7 +208,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds else return ()) >> - end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise" + end_pass False us2 p spec_data2 simpl_stats "Specialise" } CoreDoDeforest @@ -237,11 +218,11 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> _scc_ "Deforestation" begin_pass "Deforestation" >> case (deforestProgram binds us1) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" } + end_pass False us2 binds2 spec_data simpl_stats "Deforestation" } #endif CoreDoPrintCore -- print result of last pass - -> end_pass True us2 binds inline_env spec_data simpl_stats "Print" + -> end_pass True us2 binds spec_data simpl_stats "Print" ------------------------------------------------- @@ -250,12 +231,12 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n") else \ what -> return () - end_pass print us2 binds2 inline_env2 + end_pass print us2 binds2 spec_data2@(SpecData spec_done _ _ _ _ _ _ _) simpl_stats2 what = -- report verbosely, if required - (if (do_verbose_core2core && not print) || - (print && not do_verbose_core2core) + (if (opt_D_verbose_core2core && not print) || + (print && not opt_D_verbose_core2core) then hPutStr stderr ("\n*** "++what++":\n") >> @@ -271,7 +252,6 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds return (linted_binds, -- processed binds, possibly run thru CoreLint us2, -- UniqueSupply for the next guy - inline_env2, -- possibly-updated inline env spec_data2, -- possibly-updated specialisation info simpl_stats2 -- accumulated simplifier stats ) @@ -279,265 +259,433 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -- here so it can be inlined... foldl_mn f z [] = return z foldl_mn f z (x:xs) = f z x >>= \ zz -> - foldl_mn f zz xs + foldl_mn f zz xs \end{code} ---- ToDo: maybe move elsewhere --- -For top-level, exported binders that either (a)~have been INLINEd by -the programmer or (b)~are sufficiently ``simple'' that they should be -inlined, we want to record this info in a suitable IdEnv. -But: if something has a ``wrapper unfolding,'' we do NOT automatically -give it a regular unfolding (exception below). We usually assume its -worker will get a ``regular'' unfolding. We can then treat these two -levels of unfolding separately (we tend to be very friendly towards -wrapper unfoldings, for example), giving more fine-tuned control. +%************************************************************************ +%* * +\subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising} +%* * +%************************************************************************ + +Several tasks are done by @tidyCorePgm@ + +1. Eliminate indirections. The point here is to transform + x_local = E + x_exported = x_local + ==> + x_exported = E + +2. Make certain top-level bindings into Globals. The point is that + Global things get externally-visible labels at code generation + time + +3. Make the representation of NoRep literals explicit, and + float their bindings to the top level + +4. Convert + case x of {...; x' -> ...x'...} + ==> + case x of {...; _ -> ...x... } + See notes in SimplCase.lhs, near simplDefault for the reasoning here. + +5. *Mangle* cases involving fork# and par# in the discriminant. The + original templates for these primops (see @PrelVals.lhs@) constructed + case expressions with boolean results solely to fool the strictness + analyzer, the simplifier, and anyone else who might want to fool with + the evaluation order. At this point in the compiler our evaluation + order is safe. Therefore, we convert expressions of the form: + + case par# e of + True -> rhs + False -> parError# + ==> + case par# e of + _ -> rhs + +6. Eliminate polymorphic case expressions. We can't generate code for them yet. + +Eliminate indirections +~~~~~~~~~~~~~~~~~~~~~~ +In @elimIndirections@, we look for things at the top-level of the form... +\begin{verbatim} + x_local = .... + x_exported = x_local +\end{verbatim} +In cases we find like this, we go {\em backwards} and replace +\tr{x_local} with \tr{x_exported}. This save a gratuitous jump +(from \tr{x_exported} to \tr{x_local}), and makes strictness +information propagate better. + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} + +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +There's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might elminate a binding that's mentioned in the +unfolding for something. + +General Strategy: first collect the info; then make a \tr{Id -> Id} mapping. +Then blast the whole program (LHSs as well as RHSs) with it. -The exception is: If the ``regular unfolding'' mentions no other -global Ids (i.e., it's all PrimOps and cases and local Ids) then we -assume it must be really good and we take it anyway. -We also need to check that everything in the RHS (values and types) -will be visible on the other side of an interface, too. \begin{code} -calcInlinings :: Bool -- True => inlinings with _scc_s are OK - -> IdEnv Unfolding - -> [CoreBinding] - -> IdEnv Unfolding - -calcInlinings scc_s_OK inline_env_so_far top_binds - = let - result = foldl calci inline_env_so_far top_binds - in - --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result))) - result +tidyCorePgm :: Module -> UniqSupply -> [CoreBinding] -> [CoreBinding] + +tidyCorePgm mod us binds_in + = initTM mod indirection_env us $ + tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds -> + returnTM (bagToList binds) where - pp_item (binder, details) - = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details] - where - pp_det NoUnfolding = ppStr "_N_" ---LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE" - pp_det (CoreUnfolding (SimpleUnfolding _ guide expr)) - = ppAbove (ppr PprDebug guide) (ppr PprDebug expr) - pp_det other = ppStr "???" - - ------------ - my_trace = if opt_ReportWhyUnfoldingsDisallowed - then trace - else \ msg stuff -> stuff - - (unfolding_creation_threshold, explicit_creation_threshold) - = case opt_UnfoldingCreationThreshold of - Nothing -> (uNFOLDING_CREATION_THRESHOLD, False) - Just xx -> (xx, True) - - unfold_use_threshold - = case opt_UnfoldingUseThreshold of - Nothing -> uNFOLDING_USE_THRESHOLD - Just xx -> xx - - unfold_override_threshold - = case opt_UnfoldingOverrideThreshold of - Nothing -> uNFOLDING_OVERRIDE_THRESHOLD - Just xx -> xx - - con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT - - calci inline_env (Rec pairs) - = foldl (calc True{-recursive-}) inline_env pairs - - calci inline_env bind@(NonRec binder rhs) - = calc False{-not recursive-} inline_env (binder, rhs) - - --------------------------------------- - - calc is_recursive inline_env (binder, rhs) - | not (toplevelishId binder) - = --pprTrace "giving up on not top-level:" (ppr PprDebug binder) - ignominious_defeat - - | rhs_mentions_an_unmentionable - || (not explicit_INLINE_requested - && (rhs_looks_like_a_caf || guidance_size_too_big)) - = let - my_my_trace - = if explicit_INLINE_requested - && not (isWrapperId binder) -- these always claim to be INLINEd - && not have_inlining_already - then trace -- we'd better have a look... - else my_trace - - which = if scc_s_OK then " (late):" else " (early):" - in - my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) ( - ignominious_defeat - ) + (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in + + try_bind :: IdEnv Id -> CoreBinding -> (IdEnv Id, Maybe CoreBinding) + try_bind env_so_far + (NonRec exported_binder (Var local_id)) + | isExported exported_binder && -- Only if this is exported + isLocallyDefined local_id && -- Only if this one is defined in this + not (isExported local_id) && -- module, so that we *can* change its + -- binding to be the exported thing! + not (maybeToBool (lookupIdEnv env_so_far local_id)) + -- Only if not already substituted for + = (addOneToIdEnv env_so_far local_id exported_binder, Nothing) + + try_bind env_so_far bind + = (env_so_far, Just bind) +\end{code} + +Top level bindings +~~~~~~~~~~~~~~~~~~ +\begin{code} +tidyTopBindings [] = returnTM emptyBag +tidyTopBindings (b:bs) + = tidyTopBinding b $ + tidyTopBindings bs + +tidyTopBinding :: CoreBinding + -> TidyM (Bag CoreBinding) + -> TidyM (Bag CoreBinding) + +tidyTopBinding (NonRec bndr rhs) thing_inside + = getFloats (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) -> + mungeTopBinder bndr $ \ bndr' -> + thing_inside `thenTM` \ binds -> + returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds) + +tidyTopBinding (Rec pairs) thing_inside + = mungeTopBinders binders $ \ binders' -> + getFloats (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) -> + thing_inside `thenTM` \ binds_inside -> + returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside) + where + (binders, rhss) = unzip pairs +\end{code} + + +Local Bindings +~~~~~~~~~~~~~~ +\begin{code} +tidyCoreBinding (NonRec bndr rhs) + = tidyCoreExpr rhs `thenTM` \ rhs' -> + returnTM (NonRec bndr rhs') + +tidyCoreBinding (Rec pairs) + = mapTM do_one pairs `thenTM` \ pairs' -> + returnTM (Rec pairs') + where + do_one (bndr,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' -> + returnTM (bndr, rhs') + +\end{code} - | rhs `isWrapperFor` binder - -- Don't add an explicit "unfolding"; let the worker/wrapper - -- stuff do its thing. INLINE things don't get w/w'd, so - -- they will be OK. - = ignominious_defeat - -#if ! OMIT_DEFORESTER - -- For the deforester: bypass the barbed wire for recursive - -- functions that want to be inlined and are tagged deforestable - -- by the user, allowing these things to be communicated - -- across module boundaries. - - | is_recursive && - explicit_INLINE_requested && - deforestable binder && - scc_s_OK -- hack, only get them in - -- calc_inlinings2 - = glorious_success UnfoldAlways -#endif - | is_recursive && not rhs_looks_like_a_data_val - -- The only recursive defns we are prepared to tolerate at the - -- moment is top-level very-obviously-a-data-value ones. - -- We *need* these for dictionaries to be exported! - = --pprTrace "giving up on rec:" (ppr PprDebug binder) - ignominious_defeat - - -- Not really interested unless it's exported, but doing it - -- this way (not worrying about export-ness) gets us all the - -- workers/specs, etc., too; which we will need for generating - -- interfaces. We are also not interested if this binder is - -- in the environment we already have (perhaps from a previous - -- run of calcInlinings -- "earlier" is presumed to mean - -- "better"). - - | explicit_INLINE_requested - = glorious_success UnfoldAlways - - | otherwise - = glorious_success guidance - - where - guidance - = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs - where - max_out_threshold = if explicit_INLINE_requested - then 100000 -- you asked for it, you got it - else unfolding_creation_threshold - - guidance_size - = case guidance of - UnfoldAlways -> 0 -- *extremely* small - UnfoldIfGoodArgs _ _ _ size -> size - - guidance_size_too_big - -- Does the guidance suggest that this unfolding will - -- be of no use *no matter* the arguments given to it? - -- Could be more sophisticated... - = not (couldBeSmallEnoughToInline con_discount_weight unfold_use_threshold guidance) - - - rhs_looks_like_a_caf = not (whnfOrBottom rhs) - - rhs_looks_like_a_data_val - = case (collectBinders rhs) of - (_, _, [], Con _ _) -> True - other -> False - - rhs_arg_tys - = case (collectBinders rhs) of - (_, _, val_binders, _) -> map idType val_binders - - (mentioned_ids, _, _, mentions_litlit) - = mentionedInUnfolding (\x -> x) rhs - - rhs_mentions_an_unmentionable - = foldBag (||) unfoldingUnfriendlyId False mentioned_ids - || mentions_litlit - -- ToDo: probably need to chk tycons/classes... - - mentions_no_other_ids = isEmptyBag mentioned_ids - - explicit_INLINE_requested - -- did it come from a user {-# INLINE ... #-}? - -- (Warning: must avoid including wrappers.) - = idWantsToBeINLINEd binder - && not (rhs `isWrapperFor` binder) - - have_inlining_already = maybeToBool (lookupIdEnv inline_env binder) - - ignominious_defeat = inline_env -- just give back what we got - - {- - "glorious_success" is ours if we've found a suitable unfolding. - - But we check for a couple of fine points. - - (1) If this Id already has an inlining in the inline_env, - we don't automatically take it -- the earlier one is - "likely" to be better. - - But if the new one doesn't mention any other global - Ids, and it's pretty small (< UnfoldingOverrideThreshold), - then we take the chance that the new one *is* better. - - (2) If we have an Id w/ a worker/wrapper split (with - an unfolding for the wrapper), we tend to want to keep - it -- and *nuke* any inlining that we conjured up - earlier. - - But, again, if this unfolding doesn't mention any - other global Ids (and small enough), then it is - probably better than the worker/wrappery, so we take - it. - -} - glorious_success guidance - = let - new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs) - - foldr_building = opt_FoldrBuildOn - in - if (not have_inlining_already) then - -- Not in env: we take it no matter what - -- NB: we could check for worker/wrapper-ness, - -- but the truth is we probably haven't run - -- the strictness analyser yet. - new_env - - else if explicit_INLINE_requested then - -- If it was a user INLINE, then we know it's already - -- in the inline_env; we stick with what we already - -- have. - --pprTrace "giving up on INLINE:" (ppr PprDebug binder) - ignominious_defeat - - else if isWrapperId binder then - -- It's in the env, but we have since worker-wrapperised; - -- we either take this new one (because it's so good), - -- or we *undo* the one in the inline_env, so the - -- wrapper-inlining will take over. - - if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then - new_env - else - delOneFromIdEnv inline_env binder - - else - -- It's in the env, nothing to do w/ worker wrapper; - -- we'll take it if it is better. - - if not foldr_building -- ANDY hates us... (see below) - && mentions_no_other_ids - && guidance_size <= unfold_override_threshold then - new_env - else - --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold]) - ignominious_defeat -- and at the last hurdle, too! +Expressions +~~~~~~~~~~~ +\begin{code} +tidyCoreExpr (Var v) = lookupTM v `thenTM` \ v' -> + returnTM (Var v') + +tidyCoreExpr (Lit lit) + = litToRep lit `thenTM` \ (_, lit_expr) -> + returnTM lit_expr + +tidyCoreExpr (App fun arg) + = tidyCoreExpr fun `thenTM` \ fun' -> + tidyCoreArg arg `thenTM` \ arg' -> + returnTM (App fun' arg') + +tidyCoreExpr (Con con args) + = mapTM tidyCoreArg args `thenTM` \ args' -> + returnTM (Con con args') + +tidyCoreExpr (Prim prim args) + = mapTM tidyCoreArg args `thenTM` \ args' -> + returnTM (Prim prim args') + +tidyCoreExpr (Lam bndr body) + = tidyCoreExpr body `thenTM` \ body' -> + returnTM (Lam bndr body') + +tidyCoreExpr (Let bind body) + = tidyCoreBinding bind `thenTM` \ bind' -> + tidyCoreExpr body `thenTM` \ body' -> + returnTM (Let bind' body') + +tidyCoreExpr (SCC cc body) + = tidyCoreExpr body `thenTM` \ body' -> + returnTM (SCC cc body') + +tidyCoreExpr (Coerce coercion ty body) + = tidyCoreExpr body `thenTM` \ body' -> + returnTM (Coerce coercion ty body') + +-- Wierd case for par, seq, fork etc. See notes above. +tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs))) + | funnyParallelOp op + = tidyCoreExpr scrut `thenTM` \ scrut' -> + tidyCoreExpr rhs `thenTM` \ rhs' -> + returnTM (Case scrut' (PrimAlts [] (BindDefault binder rhs'))) + +-- Eliminate polymorphic case, for which we can't generate code just yet +tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs))) + | not (maybeToBool (maybeAppSpecDataTyConExpandingDicts (coreExprType scrut))) + = pprTrace "Warning: discarding polymophic case:" (ppr PprDebug scrut) $ + case scrut of + Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs) + other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs) + +tidyCoreExpr (Case scrut alts) + = tidyCoreExpr scrut `thenTM` \ scrut' -> + tidy_alts alts `thenTM` \ alts' -> + returnTM (Case scrut' alts') + where + tidy_alts (AlgAlts alts deflt) + = mapTM tidy_alg_alt alts `thenTM` \ alts' -> + tidy_deflt deflt `thenTM` \ deflt' -> + returnTM (AlgAlts alts' deflt') + + tidy_alts (PrimAlts alts deflt) + = mapTM tidy_prim_alt alts `thenTM` \ alts' -> + tidy_deflt deflt `thenTM` \ deflt' -> + returnTM (PrimAlts alts' deflt') + + tidy_alg_alt (con,bndrs,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' -> + returnTM (con,bndrs,rhs') + + tidy_prim_alt (lit,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' -> + returnTM (lit,rhs') + + -- We convert case x of {...; x' -> ...x'...} + -- to + -- case x of {...; _ -> ...x... } + -- + -- See notes in SimplCase.lhs, near simplDefault for the reasoning. + -- It's quite easily done: simply extend the environment to bind the + -- default binder to the scrutinee. + + tidy_deflt NoDefault = returnTM NoDefault + tidy_deflt (BindDefault bndr rhs) + = extend_env (tidyCoreExpr rhs) `thenTM` \ rhs' -> + returnTM (BindDefault bndr rhs') + where + extend_env = case scrut of + Var v -> extendEnvTM bndr v + other -> \x -> x \end{code} -ANDY, on the hatred of the check above; why obliterate it? Consider +Arguments +~~~~~~~~~ +\begin{code} +tidyCoreArg :: CoreArg -> TidyM CoreArg + +tidyCoreArg (VarArg v) + = lookupTM v `thenTM` \ v' -> + returnTM (VarArg v') + +tidyCoreArg (LitArg lit) + = litToRep lit `thenTM` \ (lit_ty, lit_expr) -> + case lit_expr of + Var v -> returnTM (VarArg v) + Lit l -> returnTM (LitArg l) + other -> addTopFloat lit_ty lit_expr `thenTM` \ v -> + returnTM (VarArg v) + +tidyCoreArg (TyArg ty) = returnTM (TyArg ty) +tidyCoreArg (UsageArg u) = returnTM (UsageArg u) +\end{code} + + +%************************************************************************ +%* * +\subsection[coreToStg-lits]{Converting literals} +%* * +%************************************************************************ + +Literals: the NoRep kind need to be de-no-rep'd. +We always replace them with a simple variable, and float a suitable +binding out to the top level. + +\begin{code} + +litToRep :: Literal -> TidyM (Type, CoreExpr) + +litToRep (NoRepStr s) + = returnTM (stringTy, rhs) + where + rhs = if (any is_NUL (_UNPK_ s)) + + then -- Must cater for NULs in literal string + mkGenApp (Var unpackCString2Id) + [LitArg (MachStr s), + LitArg (mkMachInt (toInteger (_LENGTH_ s)))] + + else -- No NULs in the string + App (Var unpackCStringId) (LitArg (MachStr s)) + + is_NUL c = c == '\0' +\end{code} + +If an Integer is small enough (Haskell implementations must support +Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@; +otherwise, wrap with @litString2Integer@. + +\begin{code} +litToRep (NoRepInteger i integer_ty) + = returnTM (integer_ty, rhs) + where + rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for + | i == 1 = Var integerPlusOneId -- a few very common Integer literals! + | i == 2 = Var integerPlusTwoId + | i == (-1) = Var integerMinusOneId + + | i > tARGET_MIN_INT && -- Small enough, so start from an Int + i < tARGET_MAX_INT + = Prim Int2IntegerOp [LitArg (mkMachInt i)] + + | otherwise -- Big, so start from a string + = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))] + + +litToRep (NoRepRational r rational_ty) + = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg -> + tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg -> + returnTM (rational_ty, Con ratio_data_con [num_arg, denom_arg]) + where + (ratio_data_con, integer_ty) + = case (maybeAppDataTyCon rational_ty) of + Just (tycon, [i_ty], [con]) + -> ASSERT(is_integer_ty i_ty && uniqueOf tycon == ratioTyConKey) + (con, i_ty) + + _ -> (panic "ratio_data_con", panic "integer_ty") + + is_integer_ty ty + = case (maybeAppDataTyCon ty) of + Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey + _ -> False + +litToRep other_lit = returnTM (literalType other_lit, Lit other_lit) +\end{code} + +\begin{code} +funnyParallelOp SeqOp = True +funnyParallelOp ParOp = True +funnyParallelOp ForkOp = True +funnyParallelOp _ = False +\end{code} + + +%************************************************************************ +%* * +\subsection{The monad} +%* * +%************************************************************************ + +\begin{code} +type TidyM a = Module + -> IdEnv Id + -> (UniqSupply, Bag CoreBinding) + -> (a, (UniqSupply, Bag CoreBinding)) + +initTM mod env us m + = case m mod env (us,emptyBag) of + (result, (us',floats)) -> result + +returnTM v mod env usf = (v, usf) +thenTM m k mod env usf = case m mod env usf of + (r, usf') -> k r mod env usf' + +mapTM f [] = returnTM [] +mapTM f (x:xs) = f x `thenTM` \ r -> + mapTM f xs `thenTM` \ rs -> + returnTM (r:rs) +\end{code} + + +\begin{code} +getFloats :: TidyM a -> TidyM (a, Bag CoreBinding) +getFloats m mod env (us,floats) + = case m mod env (us,emptyBag) of + (r, (us',floats')) -> ((r, floats'), (us',floats)) + + +-- Need to extend the environment when we munge a binder, so that occurrences +-- of the binder will print the correct way (i.e. as a global not a local) +mungeTopBinder :: Id -> (Id -> TidyM a) -> TidyM a +mungeTopBinder id thing_inside mod env usf + = case lookupIdEnv env id of + Just global -> thing_inside global mod env usf + Nothing -> thing_inside new_global mod new_env usf + where + new_env = addOneToIdEnv env id new_global + new_global = setIdVisibility mod id + +mungeTopBinders [] k = k [] +mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' -> + mungeTopBinders bs $ \ bs' -> + k (b' : bs') + +addTopFloat :: Type -> CoreExpr -> TidyM Id +addTopFloat lit_ty lit_rhs mod env (us, floats) + = (lit_id, (us', floats `snocBag` NonRec lit_id lit_rhs)) + where + lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc + lit_id = setIdVisibility mod lit_local + (us', us1) = splitUniqSupply us + uniq = getUnique us1 + +lookupTM v mod env usf + = case lookupIdEnv env v of + Nothing -> (v, usf) + Just v' -> (v', usf) + +extendEnvTM v v' m mod env usf + = m mod (addOneToIdEnv env v v') usf +\end{code} - head xs = foldr (\ x _ -> x) (_|_) xs -This then is exported via a pragma. However, -*if* you include the extra code above, you will -export the non-foldr/build version. diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index b2be6a1..26d6029 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -50,12 +50,13 @@ IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC ) -import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) -import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) ) +import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, + SimplifierSwitch(..), SwitchResult(..) + ) import CoreSyn import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup, - Unfolding(..), SimpleUnfolding(..), FormSummary(..), - mkSimpleUnfolding, + Unfolding(..), UfExpr, RdrName, + SimpleUnfolding(..), FormSummary(..), calcUnfoldingGuidance, UnfoldingGuidance(..) ) import CoreUtils ( coreExprCc, unTagBinders ) @@ -66,7 +67,6 @@ import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly, SYN_IE(IdEnv), SYN_IE(IdSet), GenId ) -import IdInfo ( bottomIsGuaranteed, StrictnessInfo ) import Literal ( isNoRepLit, Literal{-instances-} ) import Maybes ( maybeToBool, expectJust ) import Name ( isLocallyDefined ) @@ -472,13 +472,37 @@ inline t everywhere. But if we do *both* these reasonable things we get in ...t... -(The t in the body doesn't get inlined because by the time the recursive -group is done we see that t's RHS isn't an atom.) +Bad news! (f x) is duplicated! (The t in the body doesn't get +inlined because by the time the recursive group is done we see that +t's RHS isn't an atom.) + +Our solution is this: + (a) we inline un-simplified RHSs, and then simplify + them in a clone-only environment. + (b) we inline only variables and values +This means taht + + + r = f x ==> r = f x + t = r ==> t = r + x = ...t... ==> x = ...r... + in in + t r -Bad news! (f x) is duplicated! Our solution is to only be prepared to -inline RHSs in their own RHSs if they are *values* (lambda or constructor). +Now t is dead, and we're home. -This means that silly x=y bindings in recursive group will never go away. Sigh. ToDo! +Most silly x=y bindings in recursive group will go away. But not all: + + let y = 1:x + x = y + +Here, we can't inline x because it's in an argument position. so we'll just replace +with a clone of y. Instead we'll probably inline y (a small value) to give + + let y = 1:x + x = 1:y + +which is OK if not clever. -} extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) @@ -486,9 +510,10 @@ extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env co = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps where new_out_id_env = case (form_summary, guidance) of - (ValueForm, UnfoldNever) -> out_id_env -- No new stuff to put in - (ValueForm, _) -> out_id_env_with_unfolding - other -> out_id_env -- Not a value + (_, UnfoldNever) -> out_id_env -- No new stuff to put in + (ValueForm, _) -> out_id_env_with_unfolding + (VarForm, _) -> out_id_env_with_unfolding + other -> out_id_env -- Not a value or variable -- If there is an unfolding, we add rhs-info for out_id, -- No need to modify occ info because RHS is pre-simplification @@ -496,19 +521,18 @@ extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env co (out_id, occ_info, rhs_info) -- Compute unfolding details + -- Note that we use the "old" environment, that just has clones of the rec-bound vars, + -- in the InUnfolding. So if we ever use the InUnfolding we'll just inline once. + -- Only if the thing is still small enough next time round will we inline again. rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs) form_summary = mkFormSummary old_rhs guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs) mkSimplUnfoldingGuidance chkr out_id rhs - | not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id - = UnfoldAlways - - | otherwise - = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs + = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs where - bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold + inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 20662f8..879bd2c 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -28,7 +28,7 @@ IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of import Id ( mkSysLocal, mkIdWithNewUniq ) import CoreUnfold ( SimpleUnfolding ) import SimplEnv -import SrcLoc ( mkUnknownSrcLoc ) +import SrcLoc ( noSrcLoc ) import TyVar ( cloneTyVar ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply @@ -312,7 +312,7 @@ combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2) \begin{code} newId :: Type -> SmplM Id newId ty us sc - = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc) + = (mkSysLocal SLIT("s") uniq ty noSrcLoc, sc) where uniq = getUnique us @@ -321,7 +321,7 @@ newIds tys us sc = (zipWithEqual "newIds" mk_id tys uniqs, sc) where uniqs = getUniques (length tys) us - mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc + mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc cloneTyVarSmpl :: TyVar -> SmplM TyVar diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index a2d2797..edfe71a 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -16,8 +16,7 @@ import CmdLineOpts ( opt_D_verbose_core2core, import CoreSyn import CoreUnfold ( SimpleUnfolding ) import CoreUtils ( substCoreExpr ) -import Id ( externallyVisibleId, - mkIdEnv, lookupIdEnv, SYN_IE(IdEnv), +import Id ( mkIdEnv, lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Ord3-} ) import Maybes ( catMaybes ) @@ -44,8 +43,7 @@ simplifyPgm :: [CoreBinding] -- input simplifyPgm binds s_sw_chkr simpl_stats us = case (splitUniqSupply us) of { (s1, s2) -> case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) -> - case (tidy_top pgm2 s2) of { pgm3 -> - (pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}} + (pgm2, it_count, combineSimplCounts simpl_stats simpl_stats2) }} where simpl_switch_is_on = switchIsOn s_sw_chkr @@ -99,104 +97,3 @@ simplifyPgm binds s_sw_chkr simpl_stats us ) \end{code} -In @tidy_top@, we look for things at the top-level of the form... -\begin{verbatim} -x_local = .... - -x_exported = x_local -- or perhaps... - -x_exported = /\ tyvars -> x_local tyvars -- where this is eta-reducible -\end{verbatim} -In cases we find like this, we go {\em backwards} and replace -\tr{x_local} with \tr{x_exported}. This save a gratuitous jump -(from \tr{x_exported} to \tr{x_local}), and makes strictness -information propagate better. - -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then obviously we give up. - -Strategy: first collect the info; then make a \tr{Id -> Id} mapping. -Then blast the whole program (LHSs as well as RHSs) with it. - -\begin{code} -type BlastEnv = IdEnv Id -- domain is local Ids; range is exported Ids - -not_elem = isn'tIn "undup" - -tidy_top :: [CoreBinding] -> UniqSM [CoreBinding] - -tidy_top binds_in - = if null blast_alist then - returnUs binds_in -- no joy there - else - mapUs blast binds_in `thenUs` \ binds_maybe -> - returnUs (catMaybes binds_maybe) - where - blast_alist = undup (foldl find_cand [] binds_in) - blast_id_env = mkIdEnv blast_alist - blast_val_env= mkIdEnv [ (l, Var e) | (l,e) <- blast_alist ] - blast_all_exps = map snd blast_alist - - --------- - find_cand blast_list (Rec _) = blast_list -- recursively paranoid, as usual - - find_cand blast_list (NonRec binder rhs) - = if not (externallyVisibleId binder) then - blast_list - else - case rhs_equiv_to_local_var rhs of - Nothing -> blast_list - Just local -> (local, binder) : blast_list -- tag it on - - ------------------------------------------ - -- if an Id appears >1 time in the domain, - -- *all* occurrences must be expunged. - undup :: [(Id, Id)] -> [(Id, Id)] - - undup blast_list - = let - (singles, dups) = removeDups compare blast_list - list_of_dups = concat dups - in - [ s | s <- singles, s `not_elem` list_of_dups ] - where - compare (x,_) (y,_) = x `cmp` y - - ------------------------------------------ - rhs_equiv_to_local_var (Var x) - = if externallyVisibleId x then Nothing else Just x - - rhs_equiv_to_local_var expr = Nothing - - ------------------------------------------ - -- "blast" does the substitution: - -- returns Nothing if a binding goes away - -- returns "Just b" to give back a fixed-up binding - - blast :: CoreBinding -> UniqSM (Maybe CoreBinding) - - blast (Rec pairs) - = mapUs blast_pr pairs `thenUs` \ blasted_pairs -> - returnUs (Just (Rec blasted_pairs)) - where - blast_pr (binder, rhs) - = substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs -> - returnUs ( - case (lookupIdEnv blast_id_env binder) of - Just exportee -> (exportee, new_rhs) - Nothing -> (binder, new_rhs) - ) - - blast (NonRec binder rhs) - = if binder `is_elem` blast_all_exps then - returnUs Nothing -- this binding dies! - else - substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs -> - returnUs (Just ( - case (lookupIdEnv blast_id_env binder) of - Just exportee -> NonRec exportee new_rhs - Nothing -> NonRec binder new_rhs - )) - where - is_elem = isIn "blast" -\end{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index fa14e39..0017880 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -31,7 +31,7 @@ import CoreUnfold ( SimpleUnfolding, mkFormSummary, FormSummary(..) ) import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys, getIdArity, GenId{-instance Eq-} ) -import IdInfo ( arityMaybe ) +import IdInfo ( ArityInfo(..) ) import Maybes ( maybeToBool ) import PrelVals ( augmentId, buildId ) import PrimOp ( primOpIsCheap ) @@ -218,12 +218,7 @@ eta_fun expr@(Var v) | isBottomingId v -- Bottoming ids have "infinite arity" = 10000 -- Blargh. Infinite enough! -eta_fun expr@(Var v) - | maybeToBool arity_maybe -- We know the arity - = arity - where - arity_maybe = arityMaybe (getIdArity v) - arity = case arity_maybe of { Just arity -> arity } +eta_fun expr@(Var v) = idMinArity v eta_fun other = 0 -- Give up \end{code} @@ -280,12 +275,11 @@ manifestlyCheap other_expr -- look for manifest partial application num_val_args == 0 || -- Just a type application of -- a variable (f t1 t2 t3) -- counts as WHNF - case (arityMaybe (getIdArity f)) of - Nothing -> False - Just arity -> num_val_args < arity + num_val_args < idMinArity f _ -> False } + \end{code} Eta reduction on type lambdas @@ -407,6 +401,11 @@ simplIdWantsToBeINLINEd id env then False else idWantsToBeINLINEd id +idMinArity id = case getIdArity id of + UnknownArity -> 0 + ArityAtLeast n -> n + ArityExactly n -> n + type_ok_for_let_to_case :: Type -> Bool type_ok_for_let_to_case ty diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 2a6499e..80951af 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -13,19 +13,19 @@ module SimplVar ( IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(SmplLoop) ( simplExpr ) -import CgCompInfo ( uNFOLDING_USE_THRESHOLD, +import Constants ( uNFOLDING_USE_THRESHOLD, uNFOLDING_CON_DISCOUNT_WEIGHT ) import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..), +import CoreUnfold ( Unfolding(..), UfExpr, RdrName, UnfoldingGuidance(..), SimpleUnfolding(..), FormSummary, - smallEnoughToInline ) -import BinderInfo ( BinderInfo, noBinderInfo, okToInline ) + okToInline, smallEnoughToInline ) +import BinderInfo ( BinderInfo, noBinderInfo ) import CostCentre ( CostCentre, noCostCentreAttached ) import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation, - GenId{-instance Outputable-} + idMustBeINLINEd, GenId{-instance Outputable-} ) import SpecEnv ( SpecEnv, lookupSpecEnv ) import IdInfo ( DeforestInfo(..) ) @@ -58,7 +58,15 @@ completeVar env var args | not do_deforest && maybeToBool maybe_unfolding_info && - (always_inline || (ok_to_inline && not essential_unfoldings_only)) && + (not essential_unfoldings_only || idMustBeINLINEd var) && + ok_to_inline && + -- If "essential_unfolds_only" is true we do no inlinings at all, + -- EXCEPT for things that absolutely have to be done + -- (see comments with idMustBeINLINEd) + -- + -- Need to be careful: the RHS of INLINE functions is protected against inlining + -- by essential_unfoldings_only being set true; we must not inline workers back into + -- wrappers, even thouth the former have an unfold-always guidance. costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env) = tick UnfoldingDone `thenSmpl_` simplExpr unfold_env unf_template args @@ -110,19 +118,16 @@ completeVar env var args ok_to_inline = okToInline form occ_info small_enough - small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance + small_enough = smallEnoughToInline arg_evals guidance arg_evals = [is_evald arg | arg <- args, isValArg arg] is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v) is_evald (LitArg l) = True - con_disc = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount - unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold - #if OMIT_DEFORESTER do_deforest = False #else - do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False } + do_deforest = case (getDeforestInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False } #endif diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 2141e07..9d44435 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -21,12 +21,13 @@ import CoreSyn import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, unTagBinders, squashableDictishCcExpr ) -import Id ( idType, idWantsToBeINLINEd, - externallyVisibleId, +import Id ( idType, idWantsToBeINLINEd, addIdArity, getIdDemandInfo, addIdDemandInfo, GenId{-instance NamedThing-} ) -import IdInfo ( willBeDemanded, DemandInfo ) +import Name ( isExported ) +import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), + atLeastArity, unknownArity ) import Literal ( isNoRepLit ) import Maybes ( maybeToBool ) --import Name ( isExported ) @@ -43,7 +44,7 @@ import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, splitFunTy, getFunTy_maybe, eqTy ) import TysWiredIn ( realWorldStateTy ) -import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic ) +import Util ( isSingleton, zipEqual, zipWithEqual, panic, pprPanic, assertPanic ) \end{code} The controlling flags, and what they do @@ -194,8 +195,8 @@ simplTopBinds env [] = returnSmpl [] simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds) = -- No cloning necessary at top level -- Process the binding - simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> - completeNonRec env binder in_id rhs' `thenSmpl` \ (new_env, binds1') -> + simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) -> + completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') -> -- Process the other bindings simplTopBinds new_env binds `thenSmpl` \ binds2' -> @@ -379,6 +380,8 @@ simplExpr env expr@(Lam (ValBinder binder) body) orig_args new_env = markDangerousOccs env (take n orig_args) in simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} + `thenSmpl` \ (expr', arity) -> + returnSmpl expr' go n env non_val_lam_expr args -- The lambda had enough arguments = simplExpr env non_val_lam_expr args @@ -487,11 +490,12 @@ simplRhsExpr :: SimplEnv -> InBinder -> InExpr - -> SmplM OutExpr + -> SmplM (OutExpr, ArityInfo) simplRhsExpr env binder@(id,occ_info) rhs | dont_eta_expand rhs - = simplExpr rhs_env rhs [] + = simplExpr rhs_env rhs [] `thenSmpl` \ rhs' -> + returnSmpl (rhs', unknownArity) | otherwise -- Have a go at eta expansion = -- Deal with the big lambda part @@ -504,17 +508,20 @@ simplRhsExpr env binder@(id,occ_info) rhs -- Deal with the little lambda part -- Note that we call simplLam even if there are no binders, -- in case it can do arity expansion. - simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ lambda' -> + simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ (lambda', arity) -> -- Put it back together returnSmpl ( (if switchIsSet env SimplDoEtaReduction then mkTyLamTryingEta - else mkTyLam) tyvars' lambda' + else mkTyLam) tyvars' lambda', + arity ) where - rhs_env | not (switchIsSet env IgnoreINLINEPragma) && + rhs_env | -- not (switchIsSet env IgnoreINLINEPragma) && + -- No! Don't ever inline in a INLINE thing's rhs, because + -- doing so will inline a worker straight back into its wrapper! idWantsToBeINLINEd id = switchOffInlining env | otherwise @@ -579,7 +586,10 @@ the abstraction will always be applied to at least min_no_of_args. \begin{code} simplValLam env expr min_no_of_args | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off - null binders || -- or it's a thunk + +-- We used to disable eta expansion for thunks, but I don't see why. +-- null binders || -- or it's a thunk + null potential_extra_binder_tys || -- or ain't a function no_of_extra_binders <= 0 -- or no extra binders needed = cloneIds env binders `thenSmpl` \ binders' -> @@ -590,7 +600,8 @@ simplValLam env expr min_no_of_args returnSmpl ( (if switchIsSet new_env SimplDoEtaReduction then mkValLamTryingEta - else mkValLam) binders' body' + else mkValLam) binders' body', + atLeastArity no_of_binders ) | otherwise -- Eta expansion possible @@ -604,11 +615,13 @@ simplValLam env expr min_no_of_args returnSmpl ( (if switchIsSet new_env SimplDoEtaReduction then mkValLamTryingEta - else mkValLam) (binders' ++ extra_binders') body' + else mkValLam) (binders' ++ extra_binders') body', + atLeastArity (no_of_binders + no_of_extra_binders) ) where (binders,body) = collectValBinders expr + no_of_binders = length binders (potential_extra_binder_tys, res_ty) = splitFunTy (simplTy env (coreExprType (unTagBinders body))) -- Note: it's possible that simplValLam will be applied to something @@ -620,8 +633,14 @@ simplValLam env expr min_no_of_args extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys no_of_extra_binders = -- First, use the info about how many args it's - -- always applied to in its scope - (min_no_of_args - length binders) + -- always applied to in its scope; but ignore this + -- if it's a thunk! To see why we ignore it for thunks, + -- consider let f = lookup env key in (f 1, f 2) + -- We'd better not eta expand f just because it is + -- always applied! + (if null binders + then 0 + else min_no_of_args - no_of_binders) -- Next, try seeing if there's a lambda hidden inside -- something cheap @@ -635,7 +654,6 @@ simplValLam env expr min_no_of_args case potential_extra_binder_tys of [ty] | ty `eqTy` realWorldStateTy -> 1 other -> 0 - \end{code} @@ -728,6 +746,10 @@ ToDo: check this is OK with andy -- Dead code is now discarded by the occurrence analyser, simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty + | idWantsToBeINLINEd id + = complete_bind env rhs -- Don't messa bout with floating or let-to-case on + -- INLINE things + | otherwise = simpl_bind env rhs where -- Try let-to-case; see notes below about let-to-case @@ -774,9 +796,10 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty simpl_bind env rhs = complete_bind env rhs complete_bind env rhs - = simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> + = simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) -> cloneId env binder `thenSmpl` \ new_id -> - completeNonRec env binder new_id rhs' `thenSmpl` \ (new_env, binds) -> + completeNonRec env binder + (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) -> body_c new_env `thenSmpl` \ body' -> returnSmpl (mkCoLetsAny binds body') @@ -997,6 +1020,9 @@ simplBind env (Rec pairs) body_c body_ty (pairs', body') = do_float body do_float other = ([], other) + +-- The env passed to simplRecursiveGroup already has +-- bindings that clone the variables of the group. simplRecursiveGroup env new_ids pairs = -- Add unfoldings to the new_ids corresponding to their RHS let @@ -1007,17 +1033,33 @@ simplRecursiveGroup env new_ids pairs env new_ids_w_pairs in - mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss -> + mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss_w_arities -> let - new_pairs = zipEqual "simplRecGp" new_ids new_rhss + new_pairs = zipWithEqual "simplRecGp" mk_new_pair new_ids new_rhss_w_arities + mk_new_pair id (rhs,arity) = (id `withArity` arity, rhs) + -- NB: the new arity isn't used when processing its own + -- right hand sides, nor in the subsequent code + -- The latter is something of a pity, and not hard to fix; but + -- the info will percolate on the next iteration anyway + +{- THE NEXT FEW LINES ARE PLAIN WRONG occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs new_env = foldl add_binding env occs_w_new_pairs add_binding env (occ_info,(new_id,new_rhs)) = extendEnvGivenBinding env occ_info new_id new_rhs + +Here's why it's wrong: consider + let f x = ...f x'... + in + f 3 + +If the RHS is small we'll inline f in the body of the let, then +again, then again...URK +-} in - returnSmpl (Rec new_pairs, new_env) + returnSmpl (Rec new_pairs, rhs_env) \end{code} @@ -1105,9 +1147,9 @@ completeNonRec env binder new_id rhs@(Lit lit) completeNonRec env binder new_id rhs@(Con con con_args) | switchIsSet env SimplReuseCon && maybeToBool maybe_existing_con && - not (externallyVisibleId new_id) -- Don't bother for exported things - -- because we won't be able to drop - -- its binding. + not (isExported new_id) -- Don't bother for exported things + -- because we won't be able to drop + -- its binding. = tick ConReused `thenSmpl_` returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs]) where @@ -1153,7 +1195,7 @@ fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs) fix_up_demandedness False {- May not be demanded -} (Rec pairs) = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs] -un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info) +un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info) is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op is_cheap_prim_app other = False @@ -1170,5 +1212,8 @@ computeResultType env expr args go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of Just (_, res_ty) -> go res_ty args Nothing -> panic "computeResultType" + +var `withArity` UnknownArity = var +var `withArity` arity = var `addIdArity` arity \end{code} diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 5f14b60..29ed395 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -13,12 +13,13 @@ IMP_Ubiq(){-uitous-} import StgSyn import Bag ( emptyBag, unionBags, unitBag, snocBag, bagToList ) -import Id ( idType, mkSysLocal, addIdArity, +import Id ( idType, mkSysLocal, addIdArity, mkIdSet, unitIdSet, minusIdSet, unionManyIdSets, idSetToList, SYN_IE(IdSet), nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv) ) -import SrcLoc ( mkUnknownSrcLoc ) +import IdInfo ( ArityInfo, exactArity ) +import SrcLoc ( noSrcLoc ) import Type ( splitForAllTy, mkForAllTys, mkFunTys ) import UniqSupply ( getUnique, splitUniqSupply ) import Util ( zipEqual, panic, assertPanic ) @@ -441,8 +442,8 @@ newSupercombinator :: Type -> LiftM Id newSupercombinator ty arity ci us idenv - = (mkSysLocal SLIT("sc") uniq ty mkUnknownSrcLoc) -- ToDo: improve location - `addIdArity` arity + = (mkSysLocal SLIT("sc") uniq ty noSrcLoc) -- ToDo: improve location + `addIdArity` exactArity arity -- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it? where uniq = getUnique us diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs index 725bf48..a61c2c3 100644 --- a/ghc/compiler/simplStg/SatStgRhs.lhs +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -69,8 +69,7 @@ import Id ( idType, getIdArity, addIdArity, mkSysLocal, nullIdEnv, addOneToIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv) ) -import IdInfo ( arityMaybe ) -import SrcLoc ( mkUnknownSrcLoc ) +import SrcLoc ( noSrcLoc ) import Type ( splitSigmaTy, splitForAllTy, splitFunTyExpandingDicts ) import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) import Util ( panic, assertPanic ) @@ -99,6 +98,10 @@ This pass \begin{code} satStgRhs :: [StgBinding] -> UniqSM [StgBinding] +satStgRhs = panic "satStgRhs" + +{- NUKED FOR NOW SLPJ Dec 96 + satStgRhs p = satProgram nullIdEnv p @@ -305,5 +308,7 @@ lookupVar env v = case lookupIdEnv env v of newName :: Type -> UniqSM Id newName ut = getUnique `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc) + returnUs (mkSysLocal SLIT("sat") uniq ut noSrcLoc) + +-} \end{code} diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 1f45f07..2718501 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -19,7 +19,6 @@ import Name ( isLocallyDefined ) import SCCfinal ( stgMassageForProfiling ) import SatStgRhs ( satStgRhs ) import StgLint ( lintStgBindings ) -import StgSAT ( doStaticArgs ) import StgStats ( showStgStats ) import StgVarInfo ( setStgVarInfo ) import UpdAnal ( updateAnalyse ) @@ -28,8 +27,7 @@ import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup, opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, StgToDo(..) ) -import Id ( externallyVisibleId, - nullIdEnv, lookupIdEnv, addOneToIdEnv, +import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, growIdEnvList, isNullIdEnv, SYN_IE(IdEnv), GenId{-instance Eq/Outputable -} ) @@ -39,7 +37,6 @@ import Pretty ( ppShow, ppAbove, ppAboves, ppStr ) import UniqSupply ( splitUniqSupply ) import Util ( mapAccumL, panic, assertPanic ) -unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)" \end{code} \begin{code} @@ -67,24 +64,23 @@ stg2stg stg_todos module_name ppr_style us binds -- Do the main business! foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos >>= \ (processed_binds, _, cost_centres) -> - -- Do essential wind-up: part (a) is SatStgRhs - -- Not optional, because correct arity information is used by - -- the code generator. Afterwards do setStgVarInfo; it gives - -- the wrong answers if arities are subsequently changed, - -- which stgSatRhs might do. Furthermore, setStgVarInfo - -- decides about let-no-escape things, which in turn do a - -- better job if arities are correct, which is done by - -- satStgRhs. + -- Do essential wind-up - case (satStgRhs processed_binds us4later) of { saturated_binds -> - - -- Essential wind-up: part (b), eliminate indirections - - let no_ind_binds = elimIndirections saturated_binds in +{- Nuked for now SLPJ Dec 96 + -- Essential wind-up: part (a), saturate RHSs + -- This must occur *after* elimIndirections, because elimIndirections + -- can change things' arities. Consider: + -- x_local = f x + -- x_global = \a -> x_local a + -- Then elimIndirections will change the program to + -- x_global = f x + -- and lo and behold x_global's arity has changed! + case (satStgRhs processed_binds us4later) of { saturated_binds -> +-} - -- Essential wind-up: part (c), do setStgVarInfo. It has to + -- Essential wind-up: part (b), do setStgVarInfo. It has to -- happen regardless, because the code generator uses its -- decorations. -- @@ -94,24 +90,23 @@ stg2stg stg_todos module_name ppr_style us binds -- things, which in turn do a better job if arities are -- correct, which is done by satStgRhs. -- + +{- Done in Core now. Nuke soon. SLPJ Nov 96 let -- ToDo: provide proper flag control! binds_to_mangle = if not do_unlocalising - then no_ind_binds + then saturated_binds else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds) in - return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres) - }} +-} + + return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres) + } where do_let_no_escapes = opt_StgDoLetNoEscapes do_verbose_stg2stg = opt_D_verbose_stg2stg - (do_unlocalising, unlocal_tag) - = case (opt_EnsureSplittableC) of - Nothing -> (False, panic "tag") - Just tag -> (True, _PK_ tag) - grp_name = case (opt_SccGroup) of Just xx -> _PK_ xx Nothing -> module_name -- default: module name @@ -127,13 +122,7 @@ stg2stg stg_todos module_name ppr_style us binds (us1, us2) = splitUniqSupply us in case to_do of - StgDoStaticArgs -> - ASSERT(null (fst ccs) && null (snd ccs)) - _scc_ "StgStaticArgs" - let - binds3 = doStaticArgs binds us1 - in - end_pass us2 "StgStaticArgs" ccs binds3 + StgDoStaticArgs -> panic "STG static argument transformation deleted" StgDoUpdateAnalysis -> ASSERT(null (fst ccs) && null (snd ccs)) @@ -186,166 +175,4 @@ foldl_mn f z (x:xs) = f z x >>= \ zz -> foldl_mn f zz xs \end{code} -%************************************************************************ -%* * -\subsection[SimplStg-unlocalise]{Unlocalisation in STG code} -%* * -%************************************************************************ - -The idea of all this ``unlocalise'' stuff is that in certain (prelude -only) modules we split up the .hc file into lots of separate little -files, which are separately compiled by the C compiler. That gives -lots of little .o files. The idea is that if you happen to mention -one of them you don't necessarily pull them all in. (Pulling in a -piece you don't need can be v bad, because it may mention other pieces -you don't need either, and so on.) - -Sadly, splitting up .hc files means that local names (like s234) are -now globally visible, which can lead to clashes between two .hc -files. So unlocaliseWhatnot goes through making all the local things -into global things, essentially by giving them full names so when they -are printed they'll have their module name too. Pretty revolting -really. -\begin{code} -type UnlocalEnv = IdEnv Id - -lookup_uenv :: UnlocalEnv -> Id -> Id -lookup_uenv env id = case lookupIdEnv env id of - Nothing -> id - Just new_id -> new_id - -unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding]) - -unlocaliseStgBinds mod uenv [] = (uenv, []) - -unlocaliseStgBinds mod uenv (b : bs) - = case (unlocal_top_bind mod uenv b) of { (new_uenv, new_b) -> - case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) -> - (uenv3, new_b : new_bs) }} - ------------------- - -unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding) - -unlocal_top_bind mod uenv bind@(StgNonRec binder _) - = let new_uenv = case unlocaliseId mod binder of - Nothing -> uenv - Just new_binder -> addOneToIdEnv uenv binder new_binder - in - (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) - -unlocal_top_bind mod uenv bind@(StgRec pairs) - = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ] - new_uenv = growIdEnvList uenv [ (b,new_b) - | (b, Just new_b) <- maybe_unlocaliseds] - in - (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) -\end{code} - -%************************************************************************ -%* * -\subsection[SimplStg-indirections]{Eliminating indirections in STG code} -%* * -%************************************************************************ - -In @elimIndirections@, we look for things at the top-level of the form... -\begin{verbatim} - x_local = ....rhs... - ... - x_exported = x_local - ... -\end{verbatim} -In cases we find like this, we go {\em backwards} and replace -\tr{x_local} with \tr{...rhs...}, to produce -\begin{verbatim} - x_exported = ...rhs... - ... - ... -\end{verbatim} -This saves a gratuitous jump -(from \tr{x_exported} to \tr{x_local}), and makes strictness -information propagate better. - -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we eliminate only the first one. Thus: -\begin{verbatim} - x_local = ....rhs... - ... - x_exported1 = x_local - ... - x_exported2 = x_local - ... -\end{verbatim} -becomes -\begin{verbatim} - x_exported1 = ....rhs... - ... - ... - x_exported2 = x_exported1 - ... -\end{verbatim} - -We also have to watch out for - - f = \xyz -> g x y z - -This can arise post lambda lifting; the original might have been - - f = \xyz -> letrec g = [xy] \ [k] -> e - in - g z - -Strategy: first collect the info; then make a \tr{Id -> Id} mapping. -Then blast the whole program (LHSs as well as RHSs) with it. - -\begin{code} -elimIndirections :: [StgBinding] -> [StgBinding] - -elimIndirections binds_in - = if isNullIdEnv blast_env then - binds_in -- Nothing to do - else - [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds] - where - lookup_fn id = case lookupIdEnv blast_env id of - Just new_id -> new_id - Nothing -> id - - (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in - - try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding) - try_bind env_so_far - (StgNonRec exported_binder - (StgRhsClosure _ _ _ _ - lambda_args - (StgApp (StgVarArg local_binder) fun_args _) - )) - | externallyVisibleId exported_binder && -- Only if this is exported - not (externallyVisibleId local_binder) && -- Only if this one is defined in this - isLocallyDefined local_binder && -- module, so that we *can* change its - -- binding to be the exported thing! - not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before - args_match lambda_args fun_args -- Just an eta-expansion - - = (addOneToIdEnv env_so_far local_binder exported_binder, - Nothing) - where - args_match [] [] = True - args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas - args_match _ _ = False - - try_bind env_so_far bind - = (env_so_far, Just bind) - - in_dom env id = maybeToBool (lookupIdEnv env id) -\end{code} - -@renameTopStgBind@ renames top level binders and all occurrences thereof. - -\begin{code} -renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding - -renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs) -renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] -\end{code} diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs deleted file mode 100644 index 9e356f0..0000000 --- a/ghc/compiler/simplStg/StgSAT.lhs +++ /dev/null @@ -1,178 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -%************************************************************************ -%* * -\section[SAT]{Static Argument Transformation pass} -%* * -%************************************************************************ - -May be seen as removing invariants from loops: -Arguments of recursive functions that do not change in recursive -calls are removed from the recursion, which is done locally -and only passes the arguments which effectively change. - -Example: -map = /\ ab -> \f -> \xs -> case xs of - [] -> [] - (a:b) -> f a : map f b - -as map is recursively called with the same argument f (unmodified) -we transform it to - -map = /\ ab -> \f -> \xs -> let map' ys = case ys of - [] -> [] - (a:b) -> f a : map' b - in map' xs - -Notice that for a compiler that uses lambda lifting this is -useless as map' will be transformed back to what map was. - -\begin{code} -#include "HsVersions.h" - -module StgSAT ( doStaticArgs ) where - -IMP_Ubiq(){-uitous-} - -import StgSyn -import UniqSupply ( SYN_IE(UniqSM) ) -import Util ( panic ) -\end{code} - -\begin{code} -doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding] - -doStaticArgs = panic "StgSAT.doStaticArgs" - -{- LATER: to end of file: -doStaticArgs binds - = initSAT (mapSAT sat_bind binds) - where - sat_bind (StgNonRec binder expr) - = emptyEnvSAT `thenSAT_` - satRhs expr `thenSAT` (\ expr' -> - returnSAT (StgNonRec binder expr')) - sat_bind (StgRec [(binder,rhs)]) - = emptyEnvSAT `thenSAT_` - insSAEnv binder (getArgLists rhs) `thenSAT_` - satRhs rhs `thenSAT` (\ rhs' -> - saTransform binder rhs') - sat_bind (StgRec pairs) - = emptyEnvSAT `thenSAT_` - mapSAT satRhs rhss `thenSAT` \ rhss' -> - returnSAT (StgRec (binders `zip` rhss')) - where - (binders, rhss) = unzip pairs -\end{code} - -\begin{code} -satAtom (StgVarArg v) - = updSAEnv (Just (v,([],[]))) `thenSAT_` - returnSAT () - -satAtom _ = returnSAT () -\end{code} - -\begin{code} -satExpr :: StgExpr -> SatM StgExpr - -satExpr e@(StgCon con args lvs) - = mapSAT satAtom args `thenSAT_` - returnSAT e - -satExpr e@(StgPrim op args lvs) - = mapSAT satAtom args `thenSAT_` - returnSAT e - -satExpr e@(StgApp (StgLitArg _) _ _) - = returnSAT e - -satExpr e@(StgApp (StgVarArg v) args _) - = updSAEnv (Just (v,([],map tagArg args))) `thenSAT_` - mapSAT satAtom args `thenSAT_` - returnSAT e - where - tagArg (StgVarArg v) = Static v - tagArg _ = NotStatic - -satExpr (StgCase expr lv1 lv2 uniq alts) - = satExpr expr `thenSAT` \ expr' -> - sat_alts alts `thenSAT` \ alts' -> - returnSAT (StgCase expr' lv1 lv2 uniq alts') - where - sat_alts (StgAlgAlts ty alts deflt) - = mapSAT satAlgAlt alts `thenSAT` \ alts' -> - sat_default deflt `thenSAT` \ deflt' -> - returnSAT (StgAlgAlts ty alts' deflt') - where - satAlgAlt (con, params, use_mask, rhs) - = satExpr rhs `thenSAT` \ rhs' -> - returnSAT (con, params, use_mask, rhs') - - sat_alts (StgPrimAlts ty alts deflt) - = mapSAT satPrimAlt alts `thenSAT` \ alts' -> - sat_default deflt `thenSAT` \ deflt' -> - returnSAT (StgPrimAlts ty alts' deflt') - where - satPrimAlt (lit, rhs) - = satExpr rhs `thenSAT` \ rhs' -> - returnSAT (lit, rhs') - - sat_default StgNoDefault - = returnSAT StgNoDefault - sat_default (StgBindDefault binder used rhs) - = satExpr rhs `thenSAT` \ rhs' -> - returnSAT (StgBindDefault binder used rhs') - -satExpr (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs) body) - = satExpr body `thenSAT` \ body' -> - satRhs rhs `thenSAT` \ rhs' -> - returnSAT (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs') body') - -satExpr (StgLetNoEscape lv1 lv2 (StgRec [(binder,rhs)]) body) - = satExpr body `thenSAT` \ body' -> - insSAEnv binder (getArgLists rhs) `thenSAT_` - satRhs rhs `thenSAT` \ rhs' -> - saTransform binder rhs' `thenSAT` \ binding -> - returnSAT (StgLetNoEscape lv1 lv2 binding body') - -satExpr (StgLetNoEscape lv1 lv2 (StgRec binds) body) - = let (binders, rhss) = unzip binds - in - satExpr body `thenSAT` \ body' -> - mapSAT satRhs rhss `thenSAT` \ rhss' -> - returnSAT (StgLetNoEscape lv1 lv2 (StgRec (binders `zip` rhss')) body') - -satExpr (StgLet (StgNonRec binder rhs) body) - = satExpr body `thenSAT` \ body' -> - satRhs rhs `thenSAT` \ rhs' -> - returnSAT (StgLet (StgNonRec binder rhs') body') - -satExpr (StgLet (StgRec [(binder,rhs)]) body) - = satExpr body `thenSAT` \ body' -> - insSAEnv binder (getArgLists rhs) `thenSAT_` - satRhs rhs `thenSAT` \ rhs' -> - saTransform binder rhs' `thenSAT` \ binding -> - returnSAT (StgLet binding body') - -satExpr (StgLet (StgRec binds) body) - = let (binders, rhss) = unzip binds - in - satExpr body `thenSAT` \ body' -> - mapSAT satRhs rhss `thenSAT` \ rhss' -> - returnSAT (StgLet (StgRec (binders `zip` rhss')) body') - -satExpr (StgSCC ty cc expr) - = satExpr expr `thenSAT` \ expr' -> - returnSAT (StgSCC ty cc expr') -\end{code} - -\begin{code} -satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs - -satRhs (StgRhsClosure cc bi fvs upd args body) - = satExpr body `thenSAT` \ body' -> - returnSAT (StgRhsClosure cc bi fvs upd args body') --} -\end{code} diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs deleted file mode 100644 index 66e138e..0000000 --- a/ghc/compiler/simplStg/StgSATMonad.lhs +++ /dev/null @@ -1,167 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 -% -%************************************************************************ -%* * -\section[SATMonad]{The Static Argument Transformation pass Monad} -%* * -%************************************************************************ - -\begin{code} -#include "HsVersions.h" - -module StgSATMonad ( getArgLists, saTransform ) where - -IMP_Ubiq(){-uitous-} - -import Util ( panic ) - -getArgLists = panic "StgSATMonad.getArgLists" -saTransform = panic "StgSATMonad.saTransform" -\end{code} - -%************************************************************************ -%* * -\subsection{Utility Functions} -%* * -%************************************************************************ - -\begin{code} -{- LATER: to end of file: - -newSATNames :: [Id] -> SatM [Id] -newSATNames [] = returnSAT [] -newSATNames (id:ids) = newSATName id (idType id) `thenSAT` \ id' -> - newSATNames ids `thenSAT` \ ids' -> - returnSAT (id:ids) - -getArgLists :: StgRhs -> ([Arg Type],[Arg Id]) -getArgLists (StgRhsCon _ _ _) - = ([],[]) -getArgLists (StgRhsClosure _ _ _ _ args _) - = ([], [Static v | v <- args]) - -\end{code} - -\begin{code} -saTransform :: Id -> StgRhs -> SatM StgBinding -saTransform binder rhs - = getSATInfo binder `thenSAT` \ r -> - case r of - Just (_,args) | any isStatic args - -- [Andre] test: do it only if we have more than one static argument. - --Just (_,args) | length (filter isStatic args) > 1 - -> newSATName binder (new_ty args) `thenSAT` \ binder' -> - let non_static_args = get_nsa args (snd (getArgLists rhs)) - in - newSATNames non_static_args `thenSAT` \ non_static_args' -> - mkNewRhs binder binder' args rhs non_static_args' non_static_args - `thenSAT` \ new_rhs -> - trace ("SAT(STG) "++ show (length (filter isStatic args))) ( - returnSAT (StgNonRec binder new_rhs) - ) - _ -> returnSAT (StgRec [(binder, rhs)]) - - where - get_nsa :: [Arg a] -> [Arg a] -> [a] - get_nsa [] _ = [] - get_nsa _ [] = [] - get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as - get_nsa (_:args) (_:as) = get_nsa args as - - mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args - = let - local_body = StgApp (StgVarArg binder') - [StgVarArg a | a <- non_static_args] emptyUniqSet - - rec_body = StgRhsClosure cc bi fvs upd non_static_args' - (doStgSubst binder args subst_env body) - - subst_env = mkIdEnv - ((binder,binder'):zip non_static_args non_static_args') - in - returnSAT ( - StgRhsClosure cc bi fvs upd rhsargs - (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body) - ) - - new_ty args - = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty') - where - -- get type info for the local function: - (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder - (reg_arg_tys, res_type) = splitFunTy tau_ty - - -- now, we drop the ones that are - -- static, that is, the ones we will not pass to the local function - l = length dict_tys - dict_tys' = dropStatics (take l args) dict_tys - reg_arg_tys' = dropStatics (drop l args) reg_arg_tys - tau_ty' = glueTyArgs reg_arg_tys' res_type -\end{code} - -NOTE: This does not keep live variable/free variable information!! - -\begin{code} -doStgSubst binder orig_args subst_env body - = substExpr body - where - substExpr (StgCon con args lvs) - = StgCon con (map substAtom args) emptyUniqSet - substExpr (StgPrim op args lvs) - = StgPrim op (map substAtom args) emptyUniqSet - substExpr expr@(StgApp (StgLitArg _) [] _) - = expr - substExpr (StgApp atom@(StgVarArg v) args lvs) - | v `eqId` binder - = StgApp (StgVarArg (lookupNoFailIdEnv subst_env v)) - (remove_static_args orig_args args) emptyUniqSet - | otherwise - = StgApp (substAtom atom) (map substAtom args) lvs - substExpr (StgCase scrut lv1 lv2 uniq alts) - = StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts) - where - subst_alts (StgAlgAlts ty alg_alts deflt) - = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt) - subst_alts (StgPrimAlts ty prim_alts deflt) - = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt) - subst_alg_alt (con, args, use_mask, rhs) - = (con, args, use_mask, substExpr rhs) - subst_prim_alt (lit, rhs) - = (lit, substExpr rhs) - subst_deflt StgNoDefault - = StgNoDefault - subst_deflt (StgBindDefault var used rhs) - = StgBindDefault var used (substExpr rhs) - substExpr (StgLetNoEscape fv1 fv2 b body) - = StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body) - substExpr (StgLet b body) - = StgLet (substBinding b) (substExpr body) - substExpr (StgSCC ty cc expr) - = StgSCC ty cc (substExpr expr) - substRhs (StgRhsCon cc v args) - = StgRhsCon cc v (map substAtom args) - substRhs (StgRhsClosure cc bi fvs upd args body) - = StgRhsClosure cc bi [] upd args (substExpr body) - - substBinding (StgNonRec binder rhs) - = StgNonRec binder (substRhs rhs) - substBinding (StgRec pairs) - = StgRec (zip binders (map substRhs rhss)) - where - (binders,rhss) = unzip pairs - - substAtom atom@(StgLitArg lit) = atom - substAtom atom@(StgVarArg v) - = case lookupIdEnv subst_env v of - Just v' -> StgVarArg v' - Nothing -> atom - - remove_static_args _ [] - = [] - remove_static_args (Static _:origs) (_:as) - = remove_static_args origs as - remove_static_args (NotStatic:origs) (a:as) - = substAtom a:remove_static_args origs as --} -\end{code} diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs index 5a98a3e..2b75497 100644 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -27,7 +27,7 @@ > --import Id > --import IdInfo > --import Pretty -> --import SrcLoc ( mkUnknownSrcLoc ) +> --import SrcLoc ( noSrcLoc ) > --import StgSyn > --import UniqSet > --import Unique ( getBuiltinUniques ) @@ -479,7 +479,7 @@ Convert a Closure into a representation that can be placed in a .hi file. > where > (c,b,_) = foldl doApp f ids > ids = map mkid (getBuiltinUniques arity) -> mkid u = mkSysLocal SLIT("upd") u noType mkUnknownSrcLoc +> mkid u = mkSysLocal SLIT("upd") u noType noSrcLoc > countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2 > noType = panic "UpdAnal: no type!" > diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index bd7ec63..beb30cd 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -24,7 +24,7 @@ module SpecUtils ( IMP_Ubiq(){-uitous-} import Bag ( isEmptyBag, bagToList ) -import Class ( classOpString, GenClass{-instance NamedThing-} ) +import Class ( GenClass{-instance NamedThing-}, GenClassOp {- instance NamedThing -} ) import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, lookupWithDefaultFM ) @@ -33,7 +33,7 @@ import Id ( idType, isDictFunId, isConstMethodId_maybe, GenId {-instance NamedThing -} ) import Maybes ( maybeToBool, catMaybes, firstJust ) -import Name ( origName, isLexVarSym, isLexSpecialSym, pprNonSym ) +import Name ( OccName, pprNonSym, pprOccName, modAndOcc ) import PprStyle ( PprStyle(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, TyCon{-ditto-}, GenType{-ditto-}, GenTyVar @@ -228,7 +228,10 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs where (mod_name, id_name) = get_id_name id + get_id_name id + +{- Don't understand this -- and looks TURGID. SLPJ 4 Nov 96 | maybeToBool (isDefaultMethodId_maybe id) = (this_mod, _NIL_) @@ -238,12 +241,13 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs in (use_mod, _NIL_) | otherwise - = case (origName "get_id_name" id) of { OrigName m n -> (m, n) } +-} + = modAndOcc id get_ty_data (ty, tys) = (mod_name, [(ty_name, ty, tys)]) where - (OrigName mod_name ty_name) = origName "get_ty_data" ty + (mod_name, ty_name) = modAndOcc ty module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm] mods = map head (equivClasses _CMP_STRING_ module_names) @@ -280,7 +284,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs pp_module mod = ppBesides [ppPStr mod, ppStr ":"] -pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty +pp_tyspec :: PprStyle -> Pretty -> (OccName, TyCon, [Maybe Type]) -> Pretty pp_tyspec sty pp_mod (_, tycon, tys) = ppCat [pp_mod, @@ -296,7 +300,7 @@ pp_tyspec sty pp_mod (_, tycon, tys) choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv) choose_ty (tv, Just ty) = (ty, Nothing) -pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty +pp_idspec :: PprStyle -> Pretty -> (OccName, Id, [Maybe Type], Bool) -> Pretty pp_idspec sty pp_mod (_, id, tys, is_err) | isDictFunId id @@ -309,28 +313,24 @@ pp_idspec sty pp_mod (_, id, tys, is_err) | is_const_method_id = let Just (cls, clsty, clsop) = const_method_maybe - (OrigName _ cls_str) = origName "pp_idspec" cls - clsop_str = classOpString clsop in ppCat [pp_mod, ppStr "{-# SPECIALIZE", - pp_clsop clsop_str, ppStr "::", + pprNonSym sty clsop, ppStr "::", pprGenType sty spec_ty, ppStr "#-} {- IN instance", - ppPStr cls_str, pprParendGenType sty clsty, + pprOccName sty (getOccName cls), pprParendGenType sty clsty, ppStr "-}", pp_essential ] | is_default_method_id = let Just (cls, clsop, _) = default_method_maybe - (OrigName _ cls_str) = origName "pp_idspec2" cls - clsop_str = classOpString clsop in ppCat [pp_mod, ppStr "{- instance", - ppPStr cls_str, + pprOccName sty (getOccName cls), ppStr "EXPLICIT METHOD REQUIRED", - pp_clsop clsop_str, ppStr "::", + pprNonSym sty clsop, ppStr "::", pprGenType sty spec_ty, ppStr "-}", pp_essential ] @@ -349,10 +349,4 @@ pp_idspec sty pp_mod (_, id, tys, is_err) default_method_maybe = isDefaultMethodId_maybe id is_default_method_id = maybeToBool default_method_maybe - - pp_clsop str | isLexVarSym str && not (isLexSpecialSym str) - = ppParens (ppPStr str) - | otherwise - = ppPStr str - \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 8164e0c..f76ed75 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -2472,7 +2472,7 @@ cloneLetBinders top_lev is_rec old_ids tvenv idenv us -- Don't clone if it is a top-level thing. Why not? -- (a) we don't want to change the uniques - -- on such things (see TopLevId in Id.lhs) + -- on such things -- (b) we don't have to be paranoid about name capture -- (c) the thing is polymorphic so no need to subst diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 114131a..a6385c1 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -23,11 +23,12 @@ import StgSyn -- output import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList ) import CoreUtils ( coreExprType ) import CostCentre ( noCostCentre ) -import Id ( mkSysLocal, idType, isBottomingId, +import Id ( mkSysLocal, idType, isBottomingId, addIdArity, externallyVisibleId, - nullIdEnv, addOneToIdEnv, lookupIdEnv, + nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList, SYN_IE(IdEnv), GenId{-instance NamedThing-} ) +import IdInfo ( ArityInfo, exactArity ) import Literal ( mkMachInt, Literal(..) ) import PrelVals ( unpackCStringId, unpackCString2Id, integerZeroId, integerPlusOneId, @@ -35,13 +36,13 @@ import PrelVals ( unpackCStringId, unpackCString2Id, ) import PrimOp ( PrimOp(..) ) import SpecUtils ( mkSpecialisedCon ) -import SrcLoc ( mkUnknownSrcLoc ) +import SrcLoc ( noSrcLoc ) import TyCon ( TyCon{-instance Uniquable-} ) import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts ) import TysWiredIn ( stringTy ) import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} ) import UniqSupply -- all of it, really -import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +import Util ( zipLazy, panic, assertPanic{-, pprTrace ToDo:rm-} ) --import Pretty--ToDo:rm --import PprStyle--ToDo:rm --import PprType --ToDo:rm @@ -62,17 +63,18 @@ The business of this pass is to convert Core to Stg. On the way: x = y t1 t2 where t1, t2 are types -* We make the representation of NoRep literals explicit, and - float their bindings to the top level +* We pin correct arities on each let(rec)-bound binder, and propagate them + to their uses. This is used + a) when emitting arity info into interface files + b) in the code generator, when deciding if a right-hand side + is a saturated application so we can generate a VAP closure. + (b) is rather untidy, but the easiest compromise was to propagate arities here. * We do *not* pin on the correct free/live var info; that's done later. Instead we use bOGUS_LVS and _FVS as a placeholder. -* We convert case x of {...; x' -> ...x'...} - to - case x of {...; _ -> ...x... } - - See notes in SimplCase.lhs, near simplDefault for the reasoning here. +[Quite a bit of stuff that used to be here has moved + to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96] %************************************************************************ @@ -108,75 +110,16 @@ topCoreBindsToStg :: UniqSupply -- name supply -> [StgBinding] -- output topCoreBindsToStg us core_binds - = case (initUs us (binds_to_stg nullIdEnv core_binds)) of + = case (initUs us (coreBindsToStg nullIdEnv core_binds)) of (_, stuff) -> stuff where - binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding] - - binds_to_stg env [] = returnUs [] - binds_to_stg env (b:bs) - = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) -> - binds_to_stg new_env bs `thenUs` \ new_bs -> - returnUs (bagToList float_binds ++ -- Literals - new_b ++ - new_bs) - - do_top_bind env bind@(Rec pairs) - = coreBindToStg env bind - - do_top_bind env bind@(NonRec var rhs) - = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) -> -{- TESTING: - let - ppr_blah xs = ppInterleave ppComma (map pp_x xs) - pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x] - in - pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $ --} - case stg_binds of - [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] -> - -- Mega-special case; there's still a binding there - -- no fvs (of course), *no args*, "let" rhs - let - (extra_float_binds, rhs_body') = seek_liftable [] rhs_body - in - returnUs (extra_float_binds ++ - [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')], - new_env, - float_binds) - - other -> returnUs (stg_binds, new_env, float_binds) - - -------------------- - -- HACK: look for very simple, obviously-liftable bindings - -- that can come up to the top level; those that couldn't - -- 'cause they were big-lambda constrained in the Core world. - - seek_liftable :: [StgBinding] -- accumulator... - -> StgExpr -- look for top-lev liftables - -> ([StgBinding], StgExpr) -- result - - seek_liftable acc expr@(StgLet inner_bind body) - | is_liftable inner_bind - = seek_liftable (inner_bind : acc) body - - seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished - - -------------------- - is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body)) - = not (null args) -- it's manifestly a function... - || isLeakFreeType [] (idType binder) - || is_whnf body - -- ToDo: use a decent manifestlyWHNF function for STG? - where - is_whnf (StgCon _ _ _) = True - is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v - is_whnf other = False - - is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)]) - = not (null args) -- it's manifestly a (recursive) function... + coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding] - is_liftable anything_else = False + coreBindsToStg env [] = returnUs [] + coreBindsToStg env (b:bs) + = coreBindToStg env b `thenUs` \ (new_b, new_env) -> + coreBindsToStg new_env bs `thenUs` \ new_bs -> + returnUs (new_b ++ new_bs) \end{code} %************************************************************************ @@ -189,36 +132,34 @@ topCoreBindsToStg us core_binds coreBindToStg :: StgEnv -> CoreBinding -> UniqSM ([StgBinding], -- Empty or singleton - StgEnv, -- New envt - Bag StgBinding) -- Floats + StgEnv) -- Floats coreBindToStg env (NonRec binder rhs) - = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - + = coreRhsToStg env rhs `thenUs` \ stg_rhs -> let -- Binds to return if RHS is trivial - triv_binds = if externallyVisibleId binder then - -- pprTrace "coreBindToStg:keeping:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $ - [StgNonRec binder stg_rhs] -- Retain it - else - -- pprTrace "coreBindToStg:tossing:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $ - [] -- Discard it + triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it + | otherwise = [] -- Discard it in case stg_rhs of StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> -- Trivial RHS, so augment envt, and ditch the binding - returnUs (triv_binds, new_env, rhs_binds) + returnUs (triv_binds, new_env) where new_env = addOneToIdEnv env binder atom StgRhsCon cc con_id [] -> -- Trivial RHS, so augment envt, and ditch the binding - returnUs (triv_binds, new_env, rhs_binds) + returnUs (triv_binds, new_env) where new_env = addOneToIdEnv env binder (StgVarArg con_id) other -> -- Non-trivial RHS, so don't augment envt - returnUs ([StgNonRec binder stg_rhs], env, rhs_binds) + returnUs ([StgNonRec binder_w_arity stg_rhs], new_env) + where + binder_w_arity = binder `addIdArity` (rhsArity stg_rhs) + new_env = addOneToIdEnv env binder (StgVarArg binder_w_arity) + -- new_env propagates the arity coreBindToStg env (Rec pairs) = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND **** @@ -226,8 +167,15 @@ coreBindToStg env (Rec pairs) let (binders, rhss) = unzip pairs in - mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) -> - returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds) + mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss -> + let + binders_w_arities = [ b `addIdArity` rhsArity rhs + | (b,rhs) <- binders `zip` stg_rhss] + in + returnUs ([StgRec (binders_w_arities `zip` stg_rhss)], env) + +rhsArity (StgRhsClosure _ _ _ _ args _) = exactArity (length args) +rhsArity (StgRhsCon _ _ _) = exactArity 0 \end{code} @@ -238,17 +186,18 @@ coreBindToStg env (Rec pairs) %************************************************************************ \begin{code} -coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding) +coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs coreRhsToStg env core_rhs - = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) -> + = coreExprToStg env core_rhs `thenUs` \ stg_expr -> let stg_rhs = case stg_expr of StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _) | var1 == var2 -> rhs -- This curious stuff is to unravel what a lambda turns into -- We have to do it this way, rather than spot a lambda in the - -- incoming rhs + -- incoming rhs. Why? Because trivial bindings might conceal + -- what the rhs is actually like. StgCon con args _ -> StgRhsCon noCostCentre con args @@ -259,117 +208,7 @@ coreRhsToStg env core_rhs [] stg_expr in - returnUs (stg_rhs, stg_binds) -\end{code} - - -%************************************************************************ -%* * -\subsection[coreToStg-lits]{Converting literals} -%* * -%************************************************************************ - -Literals: the NoRep kind need to be de-no-rep'd. -We always replace them with a simple variable, and float a suitable -binding out to the top level. - -If an Integer is small enough (Haskell implementations must support -Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@; -otherwise, wrap with @litString2Integer@. - -\begin{code} -tARGET_MIN_INT, tARGET_MAX_INT :: Integer -tARGET_MIN_INT = -536870912 -tARGET_MAX_INT = 536870912 - -litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding) - -litToStgArg (NoRepStr s) - = newStgVar stringTy `thenUs` \ var -> - let - rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) - stgArgOcc -- safe - bOGUS_FVs - Updatable -- WAS: ReEntrant (see note below) - [] -- No arguments - val - --- We used not to update strings, so that they wouldn't clog up the heap, --- but instead be unpacked each time. But on some programs that costs a lot --- [eg hpg], so now we update them. - - val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string - StgApp (StgVarArg unpackCString2Id) - [StgLitArg (MachStr s), - StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))] - bOGUS_LVs - else - StgApp (StgVarArg unpackCStringId) - [StgLitArg (MachStr s)] - bOGUS_LVs - in - returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) - where - is_NUL c = c == '\0' - -litToStgArg (NoRepInteger i integer_ty) - -- extremely convenient to look out for a few very common - -- Integer literals! - | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag) - | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag) - | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag) - | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag) - - | otherwise - = newStgVar integer_ty `thenUs` \ var -> - let - rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) - stgArgOcc -- safe - bOGUS_FVs - Updatable -- Update an integer - [] -- No arguments - val - - val - | i > tARGET_MIN_INT && i < tARGET_MAX_INT - = -- Start from an Int - StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs - - | otherwise - = -- Start from a string - StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs - in - returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) - -litToStgArg (NoRepRational r rational_ty) - = --ASSERT(is_rational_ty) - --(if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $ - litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) -> - litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) -> - newStgVar rational_ty `thenUs` \ var -> - let - rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) - ratio_data_con -- Constructor - [num_atom, denom_atom] - in - returnUs (StgVarArg var, binds1 `unionBags` - binds2 `unionBags` - unitBag (StgNonRec var rhs)) - where - (is_rational_ty, ratio_data_con, integer_ty) - = case (maybeAppDataTyCon rational_ty) of - Just (tycon, [i_ty], [con]) - -> ASSERT(is_integer_ty i_ty) - (uniqueOf tycon == ratioTyConKey, con, i_ty) - - _ -> (False, panic "ratio_data_con", panic "integer_ty") - - is_integer_ty ty - = case (maybeAppDataTyCon ty) of - Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey - _ -> False - -litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) + returnUs stg_rhs \end{code} @@ -380,31 +219,19 @@ litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) %************************************************************************ \begin{code} -coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding) +coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg]) -coreArgsToStg env [] = returnUs ([], [], emptyBag) +coreArgsToStg env [] = ([], []) coreArgsToStg env (a:as) - = coreArgsToStg env as `thenUs` \ (tys, args, binds) -> - do_arg a tys args binds + = case a of + TyArg t -> (t:trest, vrest) + UsageArg u -> (trest, vrest) + VarArg v -> (trest, stgLookup env v : vrest) + LitArg l -> (trest, StgLitArg l : vrest) where - do_arg a trest vrest binds - = case a of - TyArg t -> returnUs (t:trest, vrest, binds) - UsageArg u -> returnUs (trest, vrest, binds) - VarArg v -> returnUs (trest, stgLookup env v : vrest, binds) - LitArg i -> litToStgArg i `thenUs` \ (v, bs) -> - returnUs (trest, v:vrest, bs `unionBags` binds) + (trest,vrest) = coreArgsToStg env as \end{code} -There's not anything interesting we can ASSERT about \tr{var} if it -isn't in the StgEnv. (WDP 94/06) -\begin{code} -stgLookup :: StgEnv -> Id -> StgArg - -stgLookup env var = case (lookupIdEnv env var) of - Nothing -> StgVarArg var - Just atom -> atom -\end{code} %************************************************************************ %* * @@ -413,30 +240,26 @@ stgLookup env var = case (lookupIdEnv env var) of %************************************************************************ \begin{code} -coreExprToStg :: StgEnv - -> CoreExpr - -> UniqSM (StgExpr, -- Result - Bag StgBinding) -- Float these to top level -\end{code} +coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr -\begin{code} coreExprToStg env (Lit lit) - = litToStgArg lit `thenUs` \ (atom, binds) -> - returnUs (StgApp atom [] bOGUS_LVs, binds) + = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs) coreExprToStg env (Var var) - = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) + = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs) coreExprToStg env (Con con args) - = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) -> - let + = let + (types, stg_atoms) = coreArgsToStg env args spec_con = mkSpecialisedCon con types in - returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds) + returnUs (StgCon spec_con stg_atoms bOGUS_LVs) coreExprToStg env (Prim op args) - = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) -> - returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds) + = let + (types, stg_atoms) = coreArgsToStg env args + in + returnUs (StgPrim op stg_atoms bOGUS_LVs) \end{code} %************************************************************************ @@ -450,21 +273,21 @@ coreExprToStg env expr@(Lam _ _) = let (_,_, binders, body) = collectBinders expr in - coreExprToStg env body `thenUs` \ stuff@(stg_body, binds) -> + coreExprToStg env body `thenUs` \ stg_body -> if null binders then -- it was all type/usage binders; tossed - returnUs stuff + returnUs stg_body else newStgVar (coreExprType expr) `thenUs` \ var -> returnUs - (StgLet (StgNonRec var (StgRhsClosure noCostCentre + (StgLet (StgNonRec (var `addIdArity` exactArity (length binders)) + (StgRhsClosure noCostCentre stgArgOcc bOGUS_FVs ReEntrant -- binders is non-empty binders stg_body)) - (StgApp (StgVarArg var) [] bOGUS_LVs), - binds) + (StgApp (StgVarArg var) [] bOGUS_LVs)) \end{code} %************************************************************************ @@ -476,23 +299,21 @@ coreExprToStg env expr@(Lam _ _) \begin{code} coreExprToStg env expr@(App _ _) = let - (fun,args) = collect_args expr [] + (fun,args) = collect_args expr [] + (_, stg_args) = coreArgsToStg env args in - -- Deal with the arguments - coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) -> - -- Now deal with the function 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) + returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs) (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 -> - coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) -> + coreExprToStg env fun `thenUs` \ (stg_fun) -> let fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) stgArgOcc @@ -502,8 +323,7 @@ coreExprToStg env expr@(App _ _) stg_fun in returnUs (StgLet (StgNonRec fun_id fun_rhs) - (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs), - arg_binds `unionBags` fun_binds) + (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs)) where -- Collect arguments, discarding type/usage applications collect_args (App e (TyArg _)) args = collect_args e args @@ -518,115 +338,48 @@ coreExprToStg env expr@(App _ _) %* * %************************************************************************ -At this point, we *mangle* cases involving fork# and par# in the -discriminant. The original templates for these primops (see -@PrelVals.lhs@) constructed case expressions with boolean results -solely to fool the strictness analyzer, the simplifier, and anyone -else who might want to fool with the evaluation order. Now, we -believe that once the translation to STG code is performed, our -evaluation order is safe. Therefore, we convert expressions of the -form: - - case par# e of - True -> rhs - False -> parError# - -to - - case par# e of - _ -> rhs - \begin{code} - -coreExprToStg env (Case discrim@(Prim op _) alts) - | funnyParallelOp op - = getUnique `thenUs` \ uniq -> - coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> - alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs ( - StgCase stg_discrim - bOGUS_LVs - bOGUS_LVs - uniq - stg_alts, - discrim_binds `unionBags` alts_binds - ) - where - funnyParallelOp SeqOp = True - funnyParallelOp ParOp = True - funnyParallelOp ForkOp = True - funnyParallelOp _ = False - - discrim_ty = coreExprType discrim - - alts_to_stg (PrimAlts _ (BindDefault binder rhs)) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - let - stg_deflt = StgBindDefault binder False stg_rhs - in - returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds) - --- OK, back to real life... - coreExprToStg env (Case discrim alts) - = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> - alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) -> + = coreExprToStg env discrim `thenUs` \ stg_discrim -> + alts_to_stg discrim alts `thenUs` \ stg_alts -> getUnique `thenUs` \ uniq -> returnUs ( StgCase stg_discrim bOGUS_LVs bOGUS_LVs uniq - stg_alts, - discrim_binds `unionBags` alts_binds + stg_alts ) where discrim_ty = coreExprType discrim (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty alts_to_stg discrim (AlgAlts alts deflt) - = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) -> - mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt, - deflt_binds `unionBags` unionManyBags alts_binds) + = default_to_stg discrim deflt `thenUs` \ stg_deflt -> + mapUs boxed_alt_to_stg alts `thenUs` \ stg_alts -> + returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt) where boxed_alt_to_stg (con, bs, rhs) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs), - rhs_binds) + = coreExprToStg env rhs `thenUs` \ stg_rhs -> + returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs) where spec_con = mkSpecialisedCon con discrim_ty_args alts_to_stg discrim (PrimAlts alts deflt) - = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) -> - mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> - returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt, - deflt_binds `unionBags` unionManyBags alts_binds) + = default_to_stg discrim deflt `thenUs` \ stg_deflt -> + mapUs unboxed_alt_to_stg alts `thenUs` \ stg_alts -> + returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt) where unboxed_alt_to_stg (lit, rhs) - = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs ((lit, stg_rhs), rhs_binds) + = coreExprToStg env rhs `thenUs` \ stg_rhs -> + returnUs (lit, stg_rhs) default_to_stg discrim NoDefault - = returnUs (StgNoDefault, emptyBag) + = returnUs StgNoDefault default_to_stg discrim (BindDefault binder rhs) - = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) -> - returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs, - rhs_binds) - where - -- - -- We convert case x of {...; x' -> ...x'...} - -- to - -- case x of {...; _ -> ...x... } - -- - -- See notes in SimplCase.lhs, near simplDefault for the reasoning. - -- It's quite easily done: simply extend the environment to bind the - -- default binder to the scrutinee. - -- - new_env = case discrim of - Var v -> addOneToIdEnv env binder (stgLookup env v) - other -> env + = coreExprToStg env rhs `thenUs` \ stg_rhs -> + returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs) \end{code} %************************************************************************ @@ -637,9 +390,9 @@ coreExprToStg env (Case discrim alts) \begin{code} coreExprToStg env (Let bind body) - = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) -> - coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) -> - returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2) + = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) -> + coreExprToStg new_env body `thenUs` \ stg_body -> + returnUs (mkStgLets stg_binds stg_body) \end{code} @@ -652,8 +405,8 @@ coreExprToStg env (Let bind body) Covert core @scc@ expression directly to STG @scc@ expression. \begin{code} coreExprToStg env (SCC cc expr) - = coreExprToStg env expr `thenUs` \ (stg_expr, binds) -> - returnUs (StgSCC (coreExprType expr) cc stg_expr, binds) + = coreExprToStg env expr `thenUs` \ stg_expr -> + returnUs (StgSCC (coreExprType expr) cc stg_expr) \end{code} \begin{code} @@ -667,14 +420,22 @@ coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr %* * %************************************************************************ -Utilities. +There's not anything interesting we can ASSERT about \tr{var} if it +isn't in the StgEnv. (WDP 94/06) + +\begin{code} +stgLookup :: StgEnv -> Id -> StgArg +stgLookup env var = case (lookupIdEnv env var) of + Nothing -> StgVarArg var + Just atom -> atom +\end{code} Invent a fresh @Id@: \begin{code} newStgVar :: Type -> UniqSM Id newStgVar ty = getUnique `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc) + returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc) \end{code} \begin{code} diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index bac7e8a..6de6376 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -40,9 +40,9 @@ module StgSyn ( IMP_Ubiq(){-uitous-} import CostCentre ( showCostCentre ) -import Id ( externallyVisibleId, idPrimRep, GenId{-instance NamedThing-} ) +import Id ( idPrimRep, GenId{-instance NamedThing-} ) import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} ) -import Name ( isSymLexeme ) +import Name ( pprNonSym ) import Outputable ( ifPprDebug, interppSP, interpp'SP, Outputable(..){-instance * Bool-} ) @@ -478,24 +478,11 @@ latest/greatest pragma info. \begin{code} collectFinalStgBinders :: [StgBinding] -- input program - -> [Id] -- final externally-visible top-level Ids + -> [Id] -collectFinalStgBinders binds - = ex [] binds - where - ex es [] = es - - ex es ((StgNonRec b _) : binds) - = if not (externallyVisibleId b) then - ex es binds - else - ex (b:es) binds - - ex es ((StgRec []) : binds) = ex es binds - - ex es ((StgRec ((b, rhs) : pairs)) : binds) - = ex es (StgNonRec b rhs : (StgRec pairs : binds)) - -- OK, a total hack; laziness rules +collectFinalStgBinders [] = [] +collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds +collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds \end{code} %************************************************************************ @@ -643,6 +630,12 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) ppNest 2 (ppr_alts sty alts), ppStr "}"] where + ppr_default sty StgNoDefault = ppNil + ppr_default sty (StgBindDefault bndr used expr) + = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr) + where + pp_binder = if used then ppr sty bndr else ppChar '_' + pp_ty (StgAlgAlts ty _ _) = ppr sty ty pp_ty (StgPrimAlts ty _ _) = ppr sty ty @@ -651,13 +644,8 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) ppr_default sty deflt ] where ppr_bxd_alt sty (con, params, use_mask, expr) - = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"]) + = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppStr "->"]) 4 (ppBeside (ppr sty expr) ppSemi) - where - ppr_con sty con - = if isSymLexeme con - then ppBesides [ppLparen, ppr sty con, ppRparen] - else ppr sty con ppr_alts sty (StgPrimAlts ty alts deflt) = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts), @@ -666,12 +654,6 @@ pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) ppr_ubxd_alt sty (lit, expr) = ppHang (ppCat [ppr sty lit, ppStr "->"]) 4 (ppBeside (ppr sty expr) ppSemi) - - ppr_default sty StgNoDefault = ppNil - ppr_default sty (StgBindDefault bndr used expr) - = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr) - where - pp_binder = if used then ppr sty bndr else ppChar '_' \end{code} \begin{code} diff --git a/ghc/compiler/stgSyn/StgUtils.lhs b/ghc/compiler/stgSyn/StgUtils.lhs index d586d8e..2448e12 100644 --- a/ghc/compiler/stgSyn/StgUtils.lhs +++ b/ghc/compiler/stgSyn/StgUtils.lhs @@ -6,7 +6,10 @@ x% \begin{code} #include "HsVersions.h" -module StgUtils ( mapStgBindeesRhs ) where +module StgUtils + -- ( mapStgBindeesRhs ) Dead code SLPJ Nov 96 + where +{- DEAD CODE SLPJ Nov 96 IMP_Ubiq(){-uitous-} @@ -19,6 +22,7 @@ This utility function simply applies the given function to every bindee in the program. \begin{code} + mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs) @@ -87,4 +91,6 @@ mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg mapStgBindeesArg fn a@(StgLitArg _) = a mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id) + +-} \end{code} diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index cb9509a..fff2a5d 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -18,14 +18,15 @@ module SaAbsInt ( IMP_Ubiq(){-uitous-} import CoreSyn -import CoreUnfold ( Unfolding(..), SimpleUnfolding(..), FormSummary ) +import CoreUnfold ( Unfolding(..), UfExpr, RdrName, SimpleUnfolding(..), FormSummary ) import CoreUtils ( unTagBinders ) import Id ( idType, getIdStrictness, getIdUnfolding, dataConTyCon, dataConArgTys ) -import IdInfo ( StrictnessInfo(..), Demand(..), +import IdInfo ( StrictnessInfo(..), wwPrim, wwStrict, wwEnum, wwUnpack ) +import Demand ( Demand(..) ) import MagicUFs ( MagicUnfoldingFun ) import Maybes ( maybeToBool ) import Outputable ( Outputable(..){-instance * []-} ) @@ -393,7 +394,7 @@ absId anal var env (Just abs_val, _, _) -> abs_val -- Bound in the environment - (Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) -> + (Nothing, noStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) -> -- We have an unfolding for the expr -- Assume the unfolding has no free variables since it -- came from inside the Id diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index 2050131..e3fd7ab 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -25,7 +25,8 @@ import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Outputable-} ) -import IdInfo ( StrictnessInfo(..), Demand{-instance Outputable-} ) +import IdInfo ( StrictnessInfo(..) ) +import Demand ( Demand{-instance Outputable-} ) import Outputable ( Outputable(..){-instance * []-} ) import PprType ( GenType{-instance Outputable-} ) import Pretty ( ppStr, ppCat ) @@ -116,7 +117,7 @@ getStrAnalFlags (AbsValEnv flags _) = flags \end{code} \begin{code} -absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal +absValFromStrictness :: AnalysisKind -> StrictnessInfo bdee -> AbsVal absValFromStrictness anal NoStrictnessInfo = AbsTop diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index b0c21b4..9f38ead 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -404,13 +404,6 @@ addStrictnessInfoToId addStrictnessInfoToId strflags str_val abs_val binder body -{- SCHEDULED FOR NUKING - | isWrapperId binder - = binder -- Avoid clobbering existing strictness info - -- (and, more importantly, worker info). - -- Deeply suspicious (SLPJ) --} - | isBot str_val = binder `addIdStrictness` mkBottomStrictnessInfo diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 251b7b2..457cab2 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -11,16 +11,16 @@ module WorkWrap ( workersAndWrappers ) where IMP_Ubiq(){-uitous-} import CoreSyn -import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding ) -import MagicUFs ( MagicUnfoldingFun ) +import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance ) +import CmdLineOpts ( opt_UnfoldingCreationThreshold ) import CoreUtils ( coreExprType ) import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId, addIdStrictness, addInlinePragma, GenId ) -import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker, - mkStrictnessInfo, StrictnessInfo(..) +import IdInfo ( noIdInfo, addUnfoldInfo, + mkStrictnessInfo, addStrictnessInfo, StrictnessInfo(..) ) import SaLib import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) @@ -184,7 +184,10 @@ tryWW :: Id -- the fn binder -- if two, then a worker and a -- wrapper. tryWW fn_id rhs - | idWantsToBeINLINEd fn_id + | certainlySmallEnoughToInline $ + calcUnfoldingGuidance (idWantsToBeINLINEd fn_id) + opt_UnfoldingCreationThreshold + rhs -- No point in worker/wrappering something that is going to be -- INLINEd wholesale anyway. If the strictness analyser is run -- twice, this test also prevents wrappers (which are INLINEd) @@ -196,14 +199,8 @@ tryWW fn_id rhs NoStrictnessInfo -> do_nothing BottomGuaranteed -> do_nothing - StrictnessInfo [] _ -> do_nothing -- V weird (but possible?) StrictnessInfo args_info _ -> - if not (indicatesWorker args_info) then - do_nothing - else - - -- OK, it looks as if a worker is worth a try let (uvars, tyvars, args, body) = collectBinders rhs body_ty = coreExprType body @@ -211,12 +208,9 @@ tryWW fn_id rhs mkWwBodies body_ty tyvars args args_info `thenUs` \ result -> case result of - Nothing -> -- Very peculiar. This can only happen if we hit an - -- abstract type, which we shouldn't have since we've - -- constructed the args_info in this module! - - -- False. We might hit the all-args-absent-and-the- - -- body-is-unboxed case. A Nothing is legit. (WDP 94/10) + Nothing -> -- We've hit the all-args-absent-and-the-body-is-unboxed case, + -- or there are too many args for a w/w split, + -- or there's no benefit from w/w (e.g. SSS) do_nothing Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) -> @@ -227,7 +221,7 @@ tryWW fn_id rhs worker_ty = worker_ty_w_hole body_ty worker_id = mkWorkerId worker_uniq fn_id worker_ty - (noIdInfo `addInfo` worker_strictness) + (noIdInfo `addStrictnessInfo` worker_strictness) wrapper_rhs = wrapper_w_hole worker_id worker_rhs = worker_w_hole body diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index f2762b7..8222772 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -18,7 +18,7 @@ import CoreSyn import Id ( idType, mkSysLocal, dataConArgTys ) import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) ) import PrelVals ( aBSENT_ERROR_ID ) -import SrcLoc ( mkUnknownSrcLoc ) +import SrcLoc ( noSrcLoc ) import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys, maybeAppDataTyConExpandingDicts ) @@ -193,7 +193,7 @@ mkWwBodies -- hole for worker id CoreExpr -> CoreExpr, -- Worker expr w/ hole -- for original fn body - StrictnessInfo, -- Worker strictness info + StrictnessInfo Id, -- Worker strictness info Type -> Type) -- Worker type w/ hole ) -- for type of original fn body @@ -205,7 +205,9 @@ mkWwBodies body_ty tyvars args arg_infos then returnUs Nothing else -- the rest... - mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos) + mk_ww_arg_processing args arg_infos + False -- Initialise the "useful-split" flag + (mAX_WORKER_ARGS - nonAbsentArgs arg_infos) `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) -> let (work_args, wrkr_demands) = unzip work_args_info @@ -261,11 +263,19 @@ mk_ww_arg_processing -> [Demand] -- Strictness info for those args -- must be at least as long as args + -> Bool -- False <=> we've done nothing useful in an enclosing call + -- If this is False when we hit the end of the arg list, we + -- don't want to do a w/w split... the wrapper would be the identity fn! + -- So we return Nothing + -> Int -- Number of extra args we are prepared to add. -- This prevents over-eager unpacking, leading -- to huge-arity functions. -> UniqSM (Maybe -- Nothing iff any unpack on abstract type + -- or if the wrapper would be the identity fn (can happen if we unpack + -- a huge structure, and decide not to do it) + (CoreExpr -> CoreExpr, -- Wrapper expr w/ -- hole for worker id -- applied to types @@ -274,17 +284,20 @@ mk_ww_arg_processing CoreExpr -> CoreExpr) -- Worker body expr w/ hole ) -- for original fn body -mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id)) +mk_ww_arg_processing [] _ useful_split _ = if useful_split then + returnUs (Just (id, [], id)) + else + returnUs Nothing -mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args +mk_ww_arg_processing (arg : args) (WwLazy True : infos) useful_split max_extra_args = -- Absent argument -- So, finish args to the right... --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) ( let arg_ty = idType arg in - mk_ww_arg_processing args infos max_extra_args - -- we've already discounted for absent args, + mk_ww_arg_processing args infos True {- useful split -} max_extra_args + -- We've already discounted for absent args, -- so we don't change max_extra_args `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> @@ -306,7 +319,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args panic "WwLib: haven't done mk_absent_let for primitives yet" -mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args +mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) useful_split max_extra_args | new_max_extra_args > 0 -- Check that we are prepared to add arguments = -- this is the complicated one. --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) $ @@ -319,6 +332,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args Just (_, _, []) -> -- An abstract type -- We have to give up on the whole idea returnUs Nothing + Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd panic "mk_ww_arg_processing: multi-constr" @@ -332,12 +346,12 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args let unpk_args = zipWithEqual "mk_ww_arg_processing" - (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc) + (\ u t -> mkSysLocal SLIT("upk") u t noSrcLoc) uniqs inst_con_arg_tys in -- In processing the rest, push the sub-component args -- and infos on the front of the current bunch - mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args + mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) True {- useful split -} new_max_extra_args `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> returnUs (Just ( @@ -370,14 +384,14 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args (map TyArg con_tys ++ map VarArg unpk_args))) body -mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args +mk_ww_arg_processing (arg : args) (arg_demand : infos) useful_split max_extra_args | otherwise = -- For all others at the moment, we just -- pass them to the worker unchanged. --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) ( -- Finish args to the right... - mk_ww_arg_processing args infos max_extra_args + mk_ww_arg_processing args infos useful_split max_extra_args `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> returnUs (Just ( @@ -389,4 +403,7 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args \ hole -> work_rest hole )) --) + +nonAbsentArgs :: [Demand] -> Int +nonAbsentArgs cmpts = length [() | WwLazy True <- cmpts] \end{code} diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs index e3d6267..08e8367 100644 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -14,7 +14,7 @@ module GenSpecEtc ( IMP_Ubiq() -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE, newDicts, tyVarsOfInst, instToId ) import TcEnv ( tcGetGlobalTyVars, tcExtendGlobalTyVars ) @@ -34,7 +34,7 @@ import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds), SYN_IE(TcBin import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag ) import Class ( GenClass ) import Id ( GenId, SYN_IE(Id), mkUserId, idType ) -import Kind ( isUnboxedKind, isTypeKind, mkBoxedTypeKind ) +import Kind ( isUnboxedTypeKind, isTypeKind, mkBoxedTypeKind ) import ListSetOps ( minusList, unionLists, intersectLists ) import Maybes ( allMaybes ) import Name ( Name{--O only-} ) @@ -163,7 +163,7 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn let tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order - unboxed_kind_tyvars = filter (isUnboxedKind . tyVarKind) tyvars + unboxed_kind_tyvars = filter (isUnboxedTypeKind . tyVarKind) tyvars unresolved_kind_tyvars = filter (isTypeKind . tyVarKind) tyvars box_it tyvar = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ boxed_ty -> diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 6b8a7af..fa9dba3 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -33,32 +33,31 @@ IMPORT_1_3(Ratio(Rational)) import HsSyn ( HsLit(..), HsExpr(..), HsBinds, InPat, OutPat, Stmt, Qualifier, Match, - ArithSeqInfo, PolyType, Fake ) -import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr), - RnName{-instance NamedThing-} - ) + ArithSeqInfo, HsType, Fake ) +import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr), mkHsTyApp, mkHsDictApp, tcIdTyVars ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey ) import TcType ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet), tcInstType, zonkTcType ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) -import Class ( isCcallishClass, isNoDictClass, classInstEnv, +import Class ( classInstEnv, SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp) ) import ErrUtils ( addErrLoc, SYN_IE(Error) ) import Id ( GenId, idType, mkInstId ) +import PrelInfo ( isCcallishClass, isNoDictClass ) import MatchEnv ( lookupMEnv, insertMEnv ) -import Name ( mkLocalName, getLocalName, Name ) +import Name ( OccName(..), Name, mkLocalName, mkSysLocalName, occNameString ) import Outputable import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType ) import PprStyle ( PprStyle(..) ) import Pretty import SpecEnv ( SpecEnv ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import Type ( GenType, eqSimpleTy, instantiateTy, isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy, splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes, @@ -236,17 +235,18 @@ newOverloadedLit orig lit ty \begin{code} instToId :: Inst s -> TcIdOcc s instToId (Dict u clas ty orig loc) - = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str False{-emph name-} loc)) + = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc)) where - str = SLIT("d.") _APPEND_ (getLocalName clas) + str = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas))) + instToId (Method u id tys rho_ty orig loc) - = TcId (mkInstId u tau_ty (mkLocalName u str False{-emph name-} loc)) + = TcId (mkInstId u tau_ty (mkLocalName u str loc)) where (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type - str = SLIT("m.") _APPEND_ (getLocalName id) + str = VarOcc (SLIT("m.") _APPEND_ (occNameString (getOccName id))) instToId (LitInst u list ty orig loc) - = TcId (mkInstId u ty (mkLocalName u SLIT("lit") True{-emph uniq-} loc)) + = TcId (mkInstId u ty (mkSysLocalName u SLIT("lit") loc)) \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 7d5b01c..3ce5967 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -11,39 +11,40 @@ module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where IMP_Ubiq() import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), - HsExpr, Match, PolyType, InPat, OutPat(..), + HsExpr, Match, HsType, InPat, OutPat(..), GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, collectBinders ) import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedBind), RenamedSig(..), - SYN_IE(RenamedMonoBinds), RnName(..) + SYN_IE(RenamedMonoBinds) ) import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcMonoBinds), TcIdOcc(..), SYN_IE(TcIdBndr) ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) ) import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) ) import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds ) import SpecEnv ( SpecEnv ) IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) import TcMatches ( tcMatchesFun ) -import TcMonoType ( tcPolyType ) +import TcMonoType ( tcHsType ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( newTcTyVar, tcInstSigType ) +import TcType ( newTcTyVar, tcInstSigType, newTyVarTys ) import Unify ( unifyTauTy ) import Kind ( mkBoxedTypeKind, mkTypeKind ) -import Id ( GenId, idType, mkUserId ) +import Id ( GenId, idType, mkUserLocal, mkUserId ) import IdInfo ( noIdInfo ) import Maybes ( assocMaybe, catMaybes ) -import Name ( pprNonSym, Name ) +import Name ( pprNonSym, getOccName, getSrcLoc, Name ) import PragmaInfo ( PragmaInfo(..) ) import Pretty import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, mkSigmaTy, splitSigmaTy, splitRhoTy, mkForAllTy, splitForAllTy ) -import Util ( isIn, zipEqual, panic ) +import Bag ( bagToList ) +import Util ( isIn, zipEqual, zipWith3Equal, panic ) \end{code} %************************************************************************ @@ -175,15 +176,11 @@ tcBindAndThen combiner bind sigs do_next ) `thenTc` \ (_, result) -> returnTc result where - binder_names = collectBinders bind + binder_names = map fst (bagToList (collectBinders bind)) -tcBindAndSigs binder_rn_names bind sigs prag_info_fn - = let - binder_names = map de_rn binder_rn_names - de_rn (RnName n) = n - in - recoverTc ( +tcBindAndSigs binder_names bind sigs prag_info_fn + = recoverTc ( -- If typechecking the binds fails, then return with each -- binder given type (forall a.a), to minimise subsequent -- error messages @@ -197,17 +194,24 @@ tcBindAndSigs binder_rn_names bind sigs prag_info_fn ) $ -- Create a new identifier for each binder, with each being given - -- a type-variable type. - newMonoIds binder_rn_names kind (\ mono_ids -> + -- a fresh unique, and a type-variable type. + tcGetUniques no_of_binders `thenNF_Tc` \ uniqs -> + newTyVarTys no_of_binders kind `thenNF_Tc` \ tys -> + let + mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs tys + mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name) + in + tcExtendLocalValEnv binder_names mono_ids ( tcTySigs sigs `thenTc` \ sig_info -> tc_bind bind `thenTc` \ (bind', lie) -> - returnTc (mono_ids, bind', lie, sig_info) + returnTc (bind', lie, sig_info) ) - `thenTc` \ (mono_ids, bind', lie, sig_info) -> + `thenTc` \ (bind', lie, sig_info) -> -- Notice that genBinds gets the old (non-extended) environment genBinds binder_names mono_ids bind' lie sig_info prag_info_fn where + no_of_binders = length binder_names kind = case bind of NonRecBind _ -> mkTypeKind -- Recursive, so no unboxed types RecBind _ -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types @@ -219,7 +223,7 @@ tcBindAndSigs binder_rn_names bind sigs prag_info_fn {- data SigInfo - = SigInfo RnName + = SigInfo Name (TcIdBndr s) -- Polymorpic version (TcIdBndr s) -- Monomorphic verstion [TcType s] [TcIdOcc s] -- Instance information for the monomorphic version @@ -238,7 +242,7 @@ data SigInfo -- Typecheck the binding group tcExtendLocalEnv poly_sigs ( - newMonoIds nosig_binders kind (\ nosig_local_ids -> + newLocalIds nosig_binders kind (\ nosig_local_ids -> tcMonoBinds mono_sigs mono_binds `thenTc` \ binds_w_lies -> returnTc (nosig_local_ids, binds_w_lies) )) `thenTc` \ (nosig_local_ids, binds_w_lies) -> @@ -448,9 +452,9 @@ split up, and have fresh type variables installed. All non-type-signature \begin{code} tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s] -tcTySigs (Sig v ty _ src_loc : other_sigs) +tcTySigs (Sig v ty src_loc : other_sigs) = tcAddSrcLoc src_loc ( - tcPolyType ty `thenTc` \ sigma_ty -> + tcHsType ty `thenTc` \ sigma_ty -> tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' -> let (tyvars', theta', tau') = splitSigmaTy sigma_ty' @@ -506,11 +510,11 @@ Here are the easy cases for tcPragmaSigs \begin{code} tcPragmaSig (DeforestSig name loc) - = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE) + = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE) tcPragmaSig (InlineSig name loc) - = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE) + = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE) tcPragmaSig (MagicUnfoldingSig name string loc) - = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE) + = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE) \end{code} The interesting case is for SPECIALISE pragmas. There are two forms. @@ -567,7 +571,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) tcAddErrCtxt (valSpecSigCtxt name spec_ty) $ -- Get and instantiate its alleged specialised type - tcPolyType poly_ty `thenTc` \ sig_sigma -> + tcHsType poly_ty `thenTc` \ sig_sigma -> tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty -> let (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty @@ -642,7 +646,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id)) spec_info = SpecInfo spec_tys (length main_theta) local_spec_id in - returnTc ((name, addInfo spec_info), spec_binds, spec_lie) + returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie) -} \end{code} @@ -656,6 +660,8 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) Not exported: \begin{code} +{- In GenSpec at the moment + isUnRestrictedGroup :: [TcIdBndr s] -- Signatures given for these -> TcBind s -> Bool @@ -673,6 +679,7 @@ isUnResMono sigs (FunMonoBind _ _ _ _) = True isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && isUnResMono sigs mb2 isUnResMono sigs EmptyMonoBinds = True +-} \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index fea81a4..48af28e 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -10,15 +10,16 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where IMP_Ubiq() -import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), - Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), - HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType, +import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), + Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), + DefaultDecl, TyDecl, InstDecl, IfaceSig, + HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar, Stmt, Qualifier, ArithSeqInfo, InPat, Fake ) +import HsTypes ( getTyVarName ) import HsPragmas ( ClassPragmas(..) ) import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds), - RenamedGenPragmas(..), RenamedContext(..), - RnName{-instance Uniquable-} + RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl) ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr), mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) @@ -27,20 +28,21 @@ import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, n import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars ) import TcInstDcls ( processInstBinds ) import TcKind ( unifyKind, TcKind ) -import TcMonad hiding ( rnMtoTcM ) -import TcMonoType ( tcPolyType, tcMonoType, tcContext ) +import TcMonad +import TcMonoType ( tcHsType, tcContext ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType ) import Bag ( foldBag, unionManyBags ) -import Class ( GenClass, mkClass, mkClassOp, classBigSig, +import Class ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig, classOps, classOpString, classOpLocalType, - classOpTagByString, SYN_IE(ClassOp) + classOpTagByOccName, SYN_IE(ClassOp) ) -import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, +import Id ( GenId, mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, getIdUnfolding, idType ) +import CoreUnfold ( getUnfoldingTemplate ) import IdInfo -import Name ( isLocallyDefined, origName, getLocalName ) +import Name ( Name, isLocallyDefined, moduleString, modAndOcc, nameString ) import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID ) import PprStyle import Pretty @@ -57,7 +59,7 @@ import Util -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) tcGenPragmas ty id ps = returnNF_Tc noIdInfo -tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addInfo` spec, +tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec, noIdInfo) \end{code} @@ -104,8 +106,8 @@ tcClassDecl1 rec_inst_mapper tcAddErrCtxt (classDeclCtxt class_name) $ -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupClass class_name `thenNF_Tc` \ (class_kind, rec_class) -> - tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, rec_tyvar) -> + tcLookupClass class_name `thenTc` \ (class_kind, rec_class) -> + tcLookupTyVar (getTyVarName tyvar_name) `thenNF_Tc` \ (tyvar_kind, rec_tyvar) -> let (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class in @@ -175,41 +177,22 @@ tcClassContext rec_class rec_tyvar context pragmas in -- Make super-class selector ids - mapTc (mk_super_id rec_class) - (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids -> - -- NB: we worry about matching list lengths below + mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids -> -- Done returnTc (super_classes, sc_sel_ids) where - mk_super_id rec_class (super_class, maybe_pragma) - = fixTc ( \ rec_super_id -> - tcGetUnique `thenNF_Tc` \ uniq -> - - -- GET THE PRAGMA INFO FOR THE SUPERCLASS - (case maybe_pragma of - Nothing -> returnNF_Tc noIdInfo - Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag - ) `thenNF_Tc` \ id_info -> - let - rec_tyvar_ty = mkTyVarTy rec_tyvar + rec_tyvar_ty = mkTyVarTy rec_tyvar + + mk_super_id rec_class super_class + = tcGetUnique `thenNF_Tc` \ uniq -> + let ty = mkForAllTy rec_tyvar $ mkFunTy (mkDictTy rec_class rec_tyvar_ty) (mkDictTy super_class rec_tyvar_ty) - in - -- BUILD THE SUPERCLASS ID - returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info) - ) - - maybe_pragmas :: [Maybe RenamedGenPragmas] - maybe_pragmas = case pragmas of - NoClassPragmas -> repeat Nothing - SuperDictPragmas prags -> ASSERT(length prags == length context) - map Just prags - -- If there are any pragmas there should - -- be one for each superclass - + in + returnTc (mkSuperDictSelId uniq rec_class super_class ty) tcClassSig :: Class -- Knot tying only! @@ -232,30 +215,22 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn -- NB: Renamer checks that the class type variable is mentioned in local_ty, -- and that it is not constrained by theta - tcPolyType op_ty `thenTc` \ local_ty -> + tcHsType op_ty `thenTc` \ local_ty -> let global_ty = mkSigmaTy [rec_clas_tyvar] [(rec_clas, mkTyVarTy rec_clas_tyvar)] local_ty - class_op_nm = getLocalName op_name + class_op_nm = getOccName op_name class_op = mkClassOp class_op_nm - (classOpTagByString rec_clas{-yeeps!-} class_op_nm) + (classOpTagByOccName rec_clas{-yeeps!-} class_op_nm) local_ty in - -- Munch the pragmas - tcClassOpPragmas - global_ty - rec_sel_id rec_defm_id - (rec_classop_spec_fn class_op) - pragmas `thenNF_Tc` \ (op_info, defm_info) -> - -- Build the selector id and default method id tcGetUnique `thenNF_Tc` \ d_uniq -> let - op_uniq = uniqueOf op_name - sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info - defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info + sel_id = mkMethodSelId op_name rec_clas class_op global_ty + defm_id = mkDefaultMethodId op_name d_uniq rec_clas class_op False global_ty -- ToDo: improve the "False" in returnTc (class_op, sel_id, defm_id) @@ -286,14 +261,13 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to each local class decl. \begin{code} -tcClassDecls2 :: Bag RenamedClassDecl +tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM s (LIE s, TcHsBinds s) tcClassDecls2 decls - = foldBag combine - tcClassDecl2 - (returnNF_Tc (emptyLIE, EmptyBinds)) - decls + = foldr combine + (returnNF_Tc (emptyLIE, EmptyBinds)) + [tcClassDecl2 cls_decl | ClD cls_decl <- decls] where combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) -> tc2 `thenNF_Tc` \ (lie2, binds2) -> @@ -318,17 +292,20 @@ tcClassDecl2 (ClassDecl context class_name tcAddSrcLoc src_loc $ -- Get the relevant class - tcLookupClass class_name `thenNF_Tc` \ (_, clas) -> + tcLookupClass class_name `thenTc` \ (_, clas) -> let (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids) = classBigSig clas + + -- The selector binds are already in the selector Id's unfoldings + sel_binds = SingleBind $ NonRecBind $ foldr AndMonoBinds EmptyMonoBinds $ + [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id)) + | sel_id <- sc_sel_ids ++ op_sel_ids, + isLocallyDefined sel_id + ] in + -- Generate bindings for the default methods tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) -> - - -- Generate bindings for the selector functions - buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids - `thenNF_Tc` \ sel_binds -> - -- Ditto for the methods buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds `thenTc` \ (const_insts, meth_binds) -> @@ -337,134 +314,6 @@ tcClassDecl2 (ClassDecl context class_name %************************************************************************ %* * -\subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses} -%* * -%************************************************************************ - -\begin{code} -buildSelectors :: Class -- The class object - -> TyVar -- Class type variable - -> TcTyVar s -- Instantiated class type variable (TyVarTy) - -> [Class] -> [Id] -- Superclasses and selectors - -> [ClassOp] -> [Id] -- Class ops and selectors - -> NF_TcM s (TcHsBinds s) - -buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids - = - -- Make new Ids for the components of the dictionary - let - clas_tyvar_ty = mkTyVarTy clas_tc_tyvar - mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType - in - mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys -> - newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids -> - - newDicts ClassDeclOrigin - [ (super_clas, clas_tyvar_ty) - | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) -> - - newDicts ClassDeclOrigin - [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) -> - - -- Make suitable bindings for the selectors - let - mk_sel sel_id method_or_dict - = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict - in - listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds -> - listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds -> - - returnNF_Tc (SingleBind ( - NonRecBind ( - foldr AndMonoBinds - (foldr AndMonoBinds EmptyMonoBinds op_sel_binds) - sc_sel_binds - ))) -\end{code} - -%************************************************************************ -%* * -\subsection[ClassDcl-misc]{Miscellaneous} -%* * -%************************************************************************ - -Make a selector expression for @sel_id@ from a dictionary @clas_dict@ -consisting of @dicts@ and @methods@. - -====================== OLD ============================ -We have to do a bit of jiggery pokery to get the type variables right. -Suppose we have the class decl: -\begin{verbatim} - class Foo a where - op1 :: Ord b => a -> b -> a - op2 :: ... -\end{verbatim} -Then the method selector for \tr{op1} is like this: -\begin{verbatim} - op1_sel = /\a b -> \dFoo dOrd -> case dFoo of - (op1_method,op2_method) -> op1_method b dOrd -\end{verbatim} -Note that the type variable for \tr{b} and the (Ord b) dictionary -are lifted to the top lambda, and -\tr{op1_method} is applied to them. This is preferable to the alternative: -\begin{verbatim} - op1_sel' = /\a -> \dFoo -> case dFoo of - (op1_method,op2_method) -> op1_method -\end{verbatim} -because \tr{op1_sel'} then has the rather strange type -\begin{verbatim} - op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a -\end{verbatim} -whereas \tr{op1_sel} (the one we use) has the decent type -\begin{verbatim} - op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a -\end{verbatim} -========================= END OF OLD =========================== - -NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and -the rest of the compiler darn well ought to cope. - - - -NOTE that we return a TcMonoBinds (which is later zonked) even though -there's no real back-substitution to do. It's just simpler this way! - -NOTE ALSO that the selector has no free type variables, so we -don't bother to instantiate the class-op's local type; instead -we just use the variables inside it. - -\begin{code} -mkSelBind :: Id -- the selector id - -> TcTyVar s -> TcIdOcc s -- class tyvar and dict - -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict - -> TcIdOcc s -- the superclass/method being slected - -> NF_TcM s (TcMonoBinds s) - -mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op) - = - -- sel_id = /\ clas_tyvar -> \ clas_dict -> - -- case clas_dict of - -- -> method_or_dict - - returnNF_Tc (VarMonoBind (RealId sel_id) ( - TyLam [clas_tyvar] ( - DictLam [clas_dict] ( - HsCase - (HsVar clas_dict) - ([PatMatch (DictPat dicts methods) ( - GRHSMatch (GRHSsAndBindsOut - [OtherwiseGRHS - (HsVar method_or_dict) - mkGeneratedSrcLoc] - EmptyBinds - (idType op)))]) - mkGeneratedSrcLoc - )))) -\end{code} - - -%************************************************************************ -%* * \subsection[Default methods]{Default methods} %* * %************************************************************************ @@ -601,28 +450,15 @@ makeClassDeclDefaultMethodRhs clas method_ids tag returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)) -{- OLD AND COMPLICATED - tcInstSigType () `thenNF_Tc` \ method_ty -> - let - (tyvars, theta, tau) = splitSigmaTy method_ty - in - newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) -> - - returnNF_Tc (mkHsTyLam tyvars ( - mkHsDictLam dict_ids ( - HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau]) - (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) --} - where - (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" clas + (clas_mod, clas_name) = modAndOcc clas method_id = method_ids !! (tag-1) class_op = (classOps clas) !! (tag-1) - error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "." + error_msg = _UNPK_ (nameString (getName clas)) ++ (ppShow 80 (ppr PprForUser class_op)) - ++ "\"" +-- ++ "\"" Don't know what this trailing quote is for! \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 066f90e..bb0557d 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -10,35 +10,40 @@ module TcDefaults ( tcDefaults ) where IMP_Ubiq() -import HsSyn ( DefaultDecl(..), MonoType, +import HsSyn ( HsDecl(..), TyDecl, ClassDecl, InstDecl, HsBinds, + DefaultDecl(..), HsType, IfaceSig, HsExpr, HsLit, ArithSeqInfo, Fake, InPat) -import RnHsSyn ( RenamedDefaultDecl(..) ) +import RnHsSyn ( RenamedHsDecl(..), RenamedDefaultDecl(..) ) import TcHsSyn ( TcIdOcc ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( InstOrigin(..) ) import TcEnv ( tcLookupClassByKey ) import SpecEnv ( SpecEnv ) -import TcMonoType ( tcMonoType ) +import TcMonoType ( tcHsType ) import TcSimplify ( tcSimplifyCheckThetas ) import TysWiredIn ( intTy, doubleTy, unitTy ) import Unique ( numClassKey ) +import Pretty ( ppStr, ppAboves ) +import ErrUtils ( addShortErrLocLine ) import Util \end{code} \begin{code} -tcDefaults :: [RenamedDefaultDecl] +default_default = [intTy, doubleTy] -- language-specified default `default' + +tcDefaults :: [RenamedHsDecl] -> TcM s [Type] -- defaulting types to heave -- into Tc monad for later use -- in Disambig. +tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls] -tcDefaults [] - = returnTc [intTy, doubleTy] -- language-specified default `default' +tc_defaults [] = returnTc default_default -tcDefaults [DefaultDecl mono_tys locn] +tc_defaults [DefaultDecl mono_tys locn] = tcAddSrcLoc locn $ - mapTc tcMonoType mono_tys `thenTc` \ tau_tys -> + mapTc tcHsType mono_tys `thenTc` \ tau_tys -> case tau_tys of [] -> returnTc [] -- no defaults @@ -53,4 +58,19 @@ tcDefaults [DefaultDecl mono_tys locn] returnTc tau_tys +tc_defaults decls + = failTc (dupDefaultDeclErr decls) + + +dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty + = ppAboves (item1 : map dup_item dup_things) + where + item1 + = addShortErrLocLine locn1 (\ sty -> + ppStr "multiple default declarations") sty + + dup_item (DefaultDecl _ locn) + = addShortErrLocLine locn (\ sty -> + ppStr "here was another default declaration") sty + \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index c937957..fee38f4 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -12,11 +12,14 @@ module TcDeriv ( tcDeriving ) where IMP_Ubiq() -import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..), +import HsSyn ( HsDecl, FixityDecl, Fixity, InstDecl, + Sig, HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, HsExpr, HsLit, InPat, - ArithSeqInfo, Fake, MonoType ) + ArithSeqInfo, Fake, HsType + ) import HsPragmas ( InstancePragmas(..) ) -import RnHsSyn ( mkRnName, RnName(..), SYN_IE(RenamedHsBinds), RenamedFixityDecl(..) ) +import RdrHsSyn ( RdrName, SYN_IE(RdrNameMonoBinds) ) +import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), SYN_IE(RenamedFixityDecl) ) import TcHsSyn ( TcIdOcc ) import TcMonad @@ -28,18 +31,19 @@ import TcGenDeriv -- Deriv stuff import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcSimplify ( tcSimplifyThetas ) -import RnMonad -import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv ) -import RnBinds ( rnMethodBinds, rnTopBinds ) +import RnBinds ( rnMethodBinds, rnTopMonoBinds ) +import RnEnv ( newDfunName ) +import RnMonad ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..), + setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn ) import Bag ( Bag, isEmptyBag, unionBags, listToBag ) -import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass ) +import Class ( classKey, GenClass ) import ErrUtils ( pprBagOfErrors, addErrLoc, SYN_IE(Error) ) import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId ) +import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool ) -import Name ( isLocallyDefined, getSrcLoc, - mkTopLevName, origName, mkImplicitName, ExportFlag(..), - RdrName(..), Name{--O only-} +import Name ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance, + Name{--O only-} ) import Outputable ( Outputable(..){-instances e.g., (,)-} ) import PprType ( GenType, GenTyVar, GenClass, TyCon ) @@ -194,24 +198,22 @@ context to the instance decl. The "offending classes" are \begin{code} tcDeriving :: Module -- name of module under scrutiny - -> RnEnv -- for "renaming" bits of generated code + -> RnNameSupply -- for "renaming" bits of generated code -> Bag InstInfo -- What we already know about instances - -> [RenamedFixityDecl] -- Fixity info; used by Read and Show -> TcM s (Bag InstInfo, -- The generated "instance decls". RenamedHsBinds, -- Extra generated bindings PprStyle -> Pretty) -- Printable derived instance decls; -- for debugging via -ddump-derivings. -tcDeriving modname rn_env inst_decl_infos_in fixities +tcDeriving modname rn_name_supply inst_decl_infos_in = -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - makeDerivEqns `thenTc` \ eqns -> + makeDerivEqns `thenTc` \ eqns -> -- Take the equation list and solve it, to deliver a list of -- solutions, a.k.a. the contexts for the instance decls -- required for the corresponding equations. - solveDerivEqns inst_decl_infos_in eqns - `thenTc` \ new_inst_infos -> + solveDerivEqns inst_decl_infos_in eqns `thenTc` \ new_inst_infos -> -- Now augment the InstInfos, adding in the rather boring -- actual-code-to-do-the-methods binds. We may also need to @@ -219,19 +221,37 @@ tcDeriving modname rn_env inst_decl_infos_in fixities -- "con2tag" and/or "tag2con" functions. We do these -- separately. - gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc -> - gen_tag_n_con_binds rn_env nm_alist_etc - `thenTc` \ (extra_binds, deriver_rn_env) -> + gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc -> + + + let + extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc + extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list + method_binds_s = map gen_bind new_inst_infos + + -- Rename to get RenamedBinds. + -- The only tricky bit is that the extra_binds must scope over the + -- method bindings for the instances. + (dfun_names_w_method_binds, rn_extra_binds) + = renameSourceCode modname rn_name_supply ( + rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds -> + mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds -> + returnRn (dfun_names_w_method_binds, rn_extra_binds) + ) + rn_one meth_binds = newDfunName mkGeneratedSrcLoc `thenRn` \ dfun_name -> + rnMethodBinds meth_binds `thenRn` \ rn_meth_binds -> + returnRn (dfun_name, rn_meth_binds) + in - mapTc (gen_inst_info modname fixities deriver_rn_env) new_inst_infos - `thenTc` \ really_new_inst_infos -> + mapTc (gen_inst_info modname) + (new_inst_infos `zip` dfun_names_w_method_binds) `thenTc` \ really_new_inst_infos -> let - ddump_deriv = ddump_deriving really_new_inst_infos extra_binds + ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds in --pprTrace "derived:\n" (ddump_deriv PprDebug) $ returnTc (listToBag really_new_inst_infos, - extra_binds, + rn_extra_binds, ddump_deriv) where ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty) @@ -239,7 +259,7 @@ tcDeriving modname rn_env inst_decl_infos_in fixities ddump_deriving inst_infos extra_binds sty = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds]) where - pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _) + pp_info (InstInfo clas tvs ty inst_decl_theta _ _ mbinds _ _) = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty))) (ppr sty mbinds) \end{code} @@ -271,17 +291,22 @@ makeDerivEqns :: TcM s [DerivEqn] makeDerivEqns = tcGetEnv `thenNF_Tc` \ env -> - tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> let - tycons = filter isDataTyCon (getEnv_TyCons env) + local_data_tycons = filter (\tc -> isLocallyDefined tc && isDataTyCon tc) + (getEnv_TyCons env) -- ToDo: what about newtypes??? - think_about_deriving = need_deriving eval_clas tycons in - mapTc chk_out think_about_deriving `thenTc_` + if null local_data_tycons then + -- Bale out now; evalClass may not be loaded if there aren't any + returnTc [] + else + tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> let - (derive_these, _) = removeDups cmp_deriv think_about_deriving - eqns = map mk_eqn derive_these + think_about_deriving = need_deriving eval_clas local_data_tycons + (derive_these, _) = removeDups cmp_deriv think_about_deriving + eqns = map mk_eqn derive_these in + mapTc chk_out think_about_deriving `thenTc_` returnTc eqns where ------------------------------------------------------------------ @@ -467,14 +492,11 @@ add_solns inst_infos_in eqns solns dummy_dfun_id - (my_panic "const_meth_ids") - (my_panic "binds") (my_panic "from_here") - (my_panic "modname") mkGeneratedSrcLoc + (my_panic "binds") (getSrcLoc tycon) (my_panic "upragmas") where dummy_dfun_id - = mkDictFunId bottom bottom bottom dummy_dfun_ty - bottom bottom bottom bottom + = mkDictFunId bottom dummy_dfun_ty bottom bottom where bottom = panic "dummy_dfun_id" @@ -556,144 +578,66 @@ the renamer. What a great hack! \end{itemize} \begin{code} -gen_inst_info :: Module -- Module name - -> [RenamedFixityDecl] -- all known fixities; - -- may be needed for Text - -> RnEnv -- lookup stuff for names we may use - -> InstInfo -- the main stuff to work on - -> TcM s InstInfo -- the gen'd (filled-in) "instance decl" - -gen_inst_info modname fixities deriver_rn_env - (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _) +-- Generate the method bindings for the required instance +gen_bind :: InstInfo -> RdrNameMonoBinds +gen_bind (InstInfo clas _ ty _ _ _ _ _ _) + | not from_here + = EmptyMonoBinds + | otherwise + = assoc "gen_inst_info:bad derived class" + [(eqClassKey, gen_Eq_binds) + ,(ordClassKey, gen_Ord_binds) + ,(enumClassKey, gen_Enum_binds) + ,(evalClassKey, gen_Eval_binds) + ,(boundedClassKey, gen_Bounded_binds) + ,(showClassKey, gen_Show_binds) + ,(readClassKey, gen_Read_binds) + ,(ixClassKey, gen_Ix_binds) + ] + (classKey clas) + tycon + where + from_here = isLocallyDefined tycon + (tycon,_,_) = getAppDataTyCon ty + + +gen_inst_info :: Module -- Module name + -> (InstInfo, (Name, RenamedMonoBinds)) -- the main stuff to work on + -> TcM s InstInfo -- the gen'd (filled-in) "instance decl" + +gen_inst_info modname + (InstInfo clas tyvars ty inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds)) = -- Generate the various instance-related Ids mkInstanceRelatedIds - True {-from_here-} locn modname - NoInstancePragmas + dfun_name clas tyvars ty inst_decl_theta - [{-no user pragmas-}] - `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> + `thenNF_Tc` \ (dfun_id, dfun_theta) -> - -- Generate the bindings for the new instance declaration, - -- rename it, and check for errors - let - (tycon,_,_) = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $ - getAppDataTyCon ty - - proto_mbinds - = assoc "gen_inst_info:bad derived class" - [(eqClassKey, gen_Eq_binds) - ,(ordClassKey, gen_Ord_binds) - ,(enumClassKey, gen_Enum_binds) - ,(evalClassKey, gen_Eval_binds) - ,(boundedClassKey, gen_Bounded_binds) - ,(showClassKey, gen_Show_binds fixities) - ,(readClassKey, gen_Read_binds fixities) - ,(ixClassKey, gen_Ix_binds) - ] - clas_key $ tycon - in -{- - let - ((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env - in - pprTrace "gen_inst:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ - pprTrace "gen_inst:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ - pprTrace "gen_inst:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ - pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ --} - -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $ - - rnMtoTcM deriver_rn_env ( - setExtraRn emptyUFM{-no fixities-} $ - rnMethodBinds clas_Name proto_mbinds - ) `thenNF_Tc` \ (mbinds, errs) -> - - if not (isEmptyBag errs) then - panic "gen_inst_info:renamer errs!\n" --- pprPanic "gen_inst_info:renamer errs!\n" --- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds)) - else - -- All done - let - from_here = isLocallyDefined tycon -- If so, then from here - in returnTc (InstInfo clas tyvars ty inst_decl_theta - dfun_theta dfun_id const_meth_ids - (if from_here then mbinds else EmptyMonoBinds) - from_here modname locn []) + dfun_theta dfun_id + meth_binds + locn []) where - clas_key = classKey clas - clas_Name = RnImplicitClass (mkImplicitName clas_key (origName "gen_inst_info" clas)) + from_here = isLocallyDefined tycon + (tycon,_,_) = getAppDataTyCon ty \end{code} + %************************************************************************ %* * -\subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)} +\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} %* * %************************************************************************ + data Foo ... = ... con2tag_Foo :: Foo ... -> Int# tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# maxtag_Foo :: Int -- ditto (NB: not unboxed) -\begin{code} -gen_tag_n_con_binds :: RnEnv - -> [(RdrName, TyCon, TagThingWanted)] - -> TcM s (RenamedHsBinds, - RnEnv) -- input one with any new names added - -gen_tag_n_con_binds rn_env nm_alist_etc - = - let - -- We have the renamer's final "name funs" in our hands - -- (they were passed in). So we can handle ProtoNames - -- that refer to anything "out there". But our generated - -- code may also mention "con2tag" (etc.). So we need - -- to augment to "name funs" to include those. - - names_to_add = [ pn | (pn,_,_) <- nm_alist_etc ] - in - tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs -> - let - pairs_to_add = [ case pn of { Qual pnm pnn -> - (pn, mkRnName (mkTopLevName u (OrigName pnm pnn) mkGeneratedSrcLoc ExportAll [])) } - | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ] - - deriver_rn_env - = if null names_to_add - then rn_env else added_rn_env - - (added_rn_env, errs_bag) - = extendGlobalRnEnv rn_env pairs_to_add [{-no tycons-}] - - ---------------- - proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc - proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list - in - ASSERT(isEmptyBag errs_bag) - - rnMtoTcM deriver_rn_env ( - setExtraRn emptyUFM{-no fixities-} $ - rnTopBinds (SingleBind (RecBind proto_mbinds)) - ) `thenNF_Tc` \ (binds, errs) -> - - if not (isEmptyBag errs) then - panic "gen_tag_n_con_binds:renamer errs!\n" --- pprPanic "gen_tag_n_con_binds:renamer errs!\n" --- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds)) - else - returnTc (binds, deriver_rn_env) -\end{code} - -%************************************************************************ -%* * -\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} -%* * -%************************************************************************ We have a @con2tag@ function for a tycon if: \begin{itemize} @@ -724,7 +668,7 @@ gen_taggery_Names inst_infos foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> foldlTc do_tag2con names_so_far tycons_of_interest where - all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _ _ _ _) <- inst_infos ] + all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _) <- inst_infos ] mk_CT c ty = (c, fst (getAppTyCon ty)) @@ -739,7 +683,7 @@ gen_taggery_Names inst_infos || (we_are_deriving enumClassKey tycon) || (we_are_deriving ixClassKey tycon) then - returnTc ((con2tag_PN tycon, tycon, GenCon2Tag) + returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag) : acc_Names) else returnTc acc_Names @@ -748,8 +692,8 @@ gen_taggery_Names inst_infos = if (we_are_deriving enumClassKey tycon) || (we_are_deriving ixClassKey tycon) then - returnTc ( (tag2con_PN tycon, tycon, GenTag2Con) - : (maxtag_PN tycon, tycon, GenMaxTag) + returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con) + : (maxtag_RDR tycon, tycon, GenMaxTag) : acc_Names) else returnTc acc_Names diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index bda4f4a..a13c8aa 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -6,7 +6,7 @@ module TcEnv( initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes, - tcTyVarScope, tcTyVarScopeGivenKinds, tcLookupTyVar, + tcExtendTyVarEnv, tcLookupTyVar, tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey, tcExtendClassEnv, tcLookupClass, tcLookupClassByKey, @@ -14,7 +14,7 @@ module TcEnv( tcExtendGlobalValEnv, tcExtendLocalValEnv, tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, - tcLookupGlobalValue, tcLookupGlobalValueByKey, + tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe, newMonoIds, newLocalIds, newLocalId, tcGetGlobalTyVars, tcExtendGlobalTyVars @@ -24,23 +24,26 @@ module TcEnv( IMP_Ubiq() IMPORT_DELOOPER(TcMLoop) -- for paranoia checking -import Id ( SYN_IE(Id), GenId, idType, mkUserLocal ) +import HsTypes ( HsTyVar(..) ) +import Id ( SYN_IE(Id), GenId, idType, mkUserLocal, mkUserId ) +import PragmaInfo ( PragmaInfo(..) ) import TcHsSyn ( SYN_IE(TcIdBndr), TcIdOcc(..) ) -import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind ) +import TcKind ( TcKind, newKindVars, newKindVar, tcDefaultKind, kindToTcKind ) import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), newTyVarTys, tcInstTyVars, zonkTcTyVars ) -import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet ) +import TyVar ( unionTyVarSets, emptyTyVarSet ) import Type ( tyVarsOfTypes, splitForAllTy ) import TyCon ( TyCon, tyConKind, synTyConArity ) import Class ( SYN_IE(Class), GenClass, classSig ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad -import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} ) +import Name ( Name, OccName(..), getSrcLoc, occNameString, + maybeWiredInTyConName, maybeWiredInIdName, pprSym + ) import PprStyle import Pretty -import RnHsSyn ( RnName(..) ) import Unique ( pprUnique10{-, pprUnique ToDo:rm-} ) import UniqFM import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy, @@ -74,43 +77,18 @@ getEnv_TyCons (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts] getEnv_Classes (TcEnv _ _ cs _ _ _) = [clas | (_, clas) <- eltsUFM cs] \end{code} -Making new TcTyVars, with knot tying! -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type variable env +~~~~~~~~~~~~~~~~~ \begin{code} -tcTyVarScopeGivenKinds - :: [Name] -- Names of some type variables - -> [TcKind s] - -> ([TyVar] -> TcM s a) -- Thing to type check in their scope - -> TcM s a -- Result - -tcTyVarScopeGivenKinds names kinds thing_inside - = fixTc (\ ~(rec_tyvars, _) -> - -- Ok to look at names, kinds, but not tyvars! - - tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - let - tve' = addListToUFM tve (zipEqual "tcTyVarScopeGivenKinds" names (kinds `zipLazy` rec_tyvars)) - in - tcSetEnv (TcEnv tve' tce ce gve lve gtvs) - (thing_inside rec_tyvars) `thenTc` \ result -> - - -- Get the tyvar's Kinds from their TcKinds - mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' -> - - -- Construct the real TyVars - let - tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mkTyVar names kinds' - in - returnTc (tyvars, result) - ) `thenTc` \ (_,result) -> - returnTc result - -tcTyVarScope names thing_inside - = newKindVars (length names) `thenNF_Tc` \ kinds -> - tcTyVarScopeGivenKinds names kinds thing_inside +tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r +tcExtendTyVarEnv names kinds_w_types scope + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + let + tve' = addListToUFM tve (zipEqual "tcTyVarScope" names kinds_w_types) + in + tcSetEnv (TcEnv tve' tce ce gve lve gtvs) scope \end{code} - The Kind, TyVar, Class and TyCon envs ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -118,7 +96,7 @@ Extending the environments. Notice the uses of @zipLazy@, which makes sure that the knot-tied TyVars, TyCons and Classes aren't looked at too early. \begin{code} -tcExtendTyConEnv :: [(RnName,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r +tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r tcExtendTyConEnv names_w_arities tycons scope = newKindVars (length names_w_arities) `thenNF_Tc` \ kinds -> @@ -134,7 +112,7 @@ tcExtendTyConEnv names_w_arities tycons scope returnTc result -tcExtendClassEnv :: [RnName] -> [Class] -> TcM s r -> TcM s r +tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r tcExtendClassEnv names classes scope = newKindVars (length names) `thenNF_Tc` \ kinds -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> @@ -155,12 +133,16 @@ tcLookupTyVar name returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name) -tcLookupTyCon (WiredInTyCon tc) -- wired in tycons - = returnNF_Tc (kindToTcKind (tyConKind tc), synTyConArity tc, tc) - tcLookupTyCon name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM tce (pprPanic "tcLookupTyCon:" (ppr PprShowAll name)) name) + = case maybeWiredInTyConName name of + Just tc -> returnTc (kindToTcKind (tyConKind tc), synTyConArity tc, tc) + Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + case lookupUFM tce name of + Just stuff -> returnTc stuff + Nothing -> -- Could be that he's using a class name as a type constructor + case lookupUFM ce name of + Just _ -> failTc (classAsTyConErr name) + Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name) tcLookupTyConByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> @@ -175,7 +157,12 @@ tcLookupClass name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> -- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $ -- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $ - returnNF_Tc (lookupWithDefaultUFM ce (pprPanic "tcLookupClass:" (ppr PprShowAll name)) name) + case lookupUFM ce name of + Just stuff -> returnTc stuff + Nothing -> -- Could be that he's using a type constructor as a class + case lookupUFM tce name of + Just _ -> failTc (tyConAsClassErr name) + Nothing -> pprPanic "tcLookupClass:" (ppr PprShowAll name) tcLookupClassByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> @@ -242,7 +229,7 @@ tcExtendGlobalTyVars extra_global_tvs scope \end{code} \begin{code} -tcLookupLocalValue :: RnName -> NF_TcM s (Maybe (TcIdBndr s)) +tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s)) tcLookupLocalValue name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupUFM lve name) @@ -252,26 +239,30 @@ tcLookupLocalValueByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupUFM_Directly lve uniq) -tcLookupLocalValueOK :: String -> RnName -> NF_TcM s (TcIdBndr s) +tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s) tcLookupLocalValueOK err name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM lve (panic err) name) -tcLookupGlobalValue :: RnName -> NF_TcM s Id - -tcLookupGlobalValue (WiredInId id) -- wired in ids - = returnNF_Tc id +tcLookupGlobalValue :: Name -> NF_TcM s Id tcLookupGlobalValue name - = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM gve def name) + = case maybeWiredInIdName name of + Just id -> returnNF_Tc id + Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupWithDefaultUFM gve def name) where -#ifdef DEBUG def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name) -#else - def = panic "tcLookupGlobalValue" -#endif + +tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id) + +tcLookupGlobalValueMaybe name + = case maybeWiredInIdName name of + Just id -> returnNF_Tc (Just id) + Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupUFM gve name) + tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id tcLookupGlobalValueByKey uniq @@ -291,39 +282,40 @@ Constructing new Ids ~~~~~~~~~~~~~~~~~~~~ \begin{code} -newMonoIds :: [RnName] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a +-- Uses the Name as the Name of the Id +newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a newMonoIds names kind m = newTyVarTys no_of_names kind `thenNF_Tc` \ tys -> - tcGetUniques no_of_names `thenNF_Tc` \ uniqs -> let - new_ids = zipWith3Equal "newMonoIds" mk_id names uniqs tys - - mk_id name uniq ty - = let - name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n } - in - mkUserLocal name_str uniq ty (getSrcLoc name) + new_ids = zipWithEqual "newMonoIds" mk_id names tys + mk_id name ty = mkUserId name ty NoPragmaInfo in tcExtendLocalValEnv names new_ids (m new_ids) where no_of_names = length names -newLocalId :: FAST_STRING -> TcType s -> NF_TcM s (TcIdOcc s) +newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s) newLocalId name ty = tcGetSrcLoc `thenNF_Tc` \ loc -> tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (TcId (mkUserLocal name uniq ty loc)) + returnNF_Tc (mkUserLocal name uniq ty loc) -newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdOcc s] +newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s] newLocalIds names tys = tcGetSrcLoc `thenNF_Tc` \ loc -> tcGetUniques (length names) `thenNF_Tc` \ uniqs -> let new_ids = zipWith3Equal "newLocalIds" mk_id names uniqs tys - mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc) + mk_id name uniq ty = mkUserLocal name uniq ty loc in returnNF_Tc new_ids \end{code} +\begin{code} +classAsTyConErr name sty + = ppBesides [ppStr "Class used as a type constructor: ", pprSym sty name] +tyConAsClassErr name sty + = ppBesides [ppStr "Type constructor used as a class: ", pprSym sty name] +\end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 9c59b43..3215394 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -13,18 +13,17 @@ IMP_Ubiq() import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..), HsBinds(..), Bind(..), MonoBinds(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, - Match, Fake, InPat, OutPat, PolyType, + Match, Fake, InPat, OutPat, HsType, failureFreePat, collectPatBinders ) import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual), - SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds), - RnName{-instance Outputable-} + SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds) ) import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt), TcIdOcc(..), SYN_IE(TcRecordBinds), mkHsTyApp ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( Inst, InstOrigin(..), OverloadedLit(..), SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newMethodWithGivenTy, newDicts ) @@ -35,7 +34,7 @@ import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, ) import SpecEnv ( SpecEnv ) import TcMatches ( tcMatchesCase, tcMatch ) -import TcMonoType ( tcPolyType ) +import TcMonoType ( tcHsType ) import TcPat ( tcPat ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) import TcType ( SYN_IE(TcType), TcMaybe(..), @@ -463,7 +462,7 @@ tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) \begin{code} tcExpr in_expr@(ExprWithTySig expr poly_ty) = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) -> - tcPolyType poly_ty `thenTc` \ sigma_sig -> + tcHsType poly_ty `thenTc` \ sigma_sig -> -- Check the tau-type part tcSetErrCtxt (exprSigCtxt in_expr) $ @@ -627,7 +626,7 @@ tcArg expected_arg_ty arg %************************************************************************ \begin{code} -tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s) +tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s) tcId name = -- Look up the Id and instantiate its type diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs index 309149e..7072a55 100644 --- a/ghc/compiler/typecheck/TcGRHSs.lhs +++ b/ghc/compiler/typecheck/TcGRHSs.lhs @@ -16,7 +16,7 @@ import HsSyn ( GRHSsAndBinds(..), GRHS(..), import RnHsSyn ( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) ) import TcHsSyn ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), TcIdOcc(..) ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( Inst, SYN_IE(LIE), plusLIE ) import TcBinds ( tcBindsAndThen ) import TcExpr ( tcExpr ) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index f449cca..3bc2b69 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -12,30 +12,6 @@ This is where we do all the grimy bindings' generation. #include "HsVersions.h" module TcGenDeriv ( - a_Expr, - a_PN, - a_Pat, - ah_PN, - b_Expr, - b_PN, - b_Pat, - bh_PN, - c_Expr, - c_PN, - c_Pat, - ch_PN, - cmp_eq_PN, - d_Expr, - d_PN, - d_Pat, - dh_PN, - eqH_Int_PN, - eqTag_Expr, - eq_PN, - error_PN, - false_Expr, - false_PN, - geH_PN, gen_Bounded_binds, gen_Enum_binds, gen_Eval_binds, @@ -45,19 +21,8 @@ module TcGenDeriv ( gen_Read_binds, gen_Show_binds, gen_tag_n_con_monobind, - gtTag_Expr, - gt_PN, - leH_PN, - ltH_Int_PN, - ltTag_Expr, - lt_PN, - minusH_PN, - mkInt_PN, - rangeSize_PN, - true_Expr, - true_PN, - - con2tag_PN, tag2con_PN, maxtag_PN, + + con2tag_RDR, tag2con_RDR, maxtag_RDR, TagThingWanted(..) ) where @@ -67,29 +32,26 @@ IMPORT_1_3(List(partition)) import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt, - ArithSeqInfo, Sig, PolyType, FixityDecl, Fake ) -import RdrHsSyn ( SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) ) -import RnHsSyn ( RenamedFixityDecl(..) ) ---import RnUtils + ArithSeqInfo, Sig, HsType, FixityDecl, Fake ) +import RdrHsSyn ( RdrName(..), varQual, varUnqual, + SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) + ) +-- import RnHsSyn ( RenamedFixityDecl(..) ) import Id ( GenId, dataConNumFields, isNullaryDataCon, dataConTag, dataConRawArgTys, fIRST_TAG, isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) ) -import IdUtils ( primOpId ) import Maybes ( maybeToBool ) -import Name ( origName, preludeQual, nameOf, RdrName(..), OrigName(..) ) -import PrelMods ( pRELUDE, gHC__, iX ) -import PrelVals ( eRROR_ID ) +import Name ( getOccString, getSrcLoc, occNameString, modAndOcc, OccName, Name ) import PrimOp ( PrimOp(..) ) +import PrelInfo -- Lots of RdrNames import SrcLoc ( mkGeneratedSrcLoc ) import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon ) import Type ( eqTy, isPrimType ) import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) -import TysWiredIn ( falseDataCon, trueDataCon, intDataCon ) ---import Unique import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic ) \end{code} @@ -177,6 +139,7 @@ gen_Eq_binds :: TyCon -> RdrNameMonoBinds gen_Eq_binds tycon = let + tycon_loc = getSrcLoc tycon (nullary_cons, nonnullary_cons) = partition isNullaryDataCon (tyConDataCons tycon) @@ -188,22 +151,24 @@ gen_Eq_binds tycon [([a_Pat, b_Pat], false_Expr)] else -- calc. and compare the tags [([a_Pat, b_Pat], - untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)] - (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN true_Expr false_Expr))] + untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))] in - mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest) - `AndMonoBinds` boring_ne_method + mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest) + `AndMonoBinds` + mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] ( + HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR]))) where ------------------------------------------------------------------ pats_etc data_con = let - con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed) - con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) + con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed) + con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed) - data_con_PN = qual_orig_name data_con + data_con_RDR = qual_orig_name data_con con_arity = length tys_needed - as_needed = take con_arity as_PNs - bs_needed = take con_arity bs_PNs + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs tys_needed = dataConRawArgTys data_con in ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) @@ -213,10 +178,6 @@ gen_Eq_binds tycon = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) where nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b)) - -boring_ne_method - = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $ - HsApp (HsVar not_PN) (HsPar (mk_easy_App eq_PN [a_PN, b_PN])) \end{code} %************************************************************************ @@ -317,15 +278,16 @@ gen_Ord_binds :: TyCon -> RdrNameMonoBinds gen_Ord_binds tycon = defaulted `AndMonoBinds` compare where + tycon_loc = getSrcLoc tycon -------------------------------------------------------------------- - compare = mk_easy_FunMonoBind compare_PN + compare = mk_easy_FunMonoBind tycon_loc compare_RDR [a_Pat, b_Pat] [cmp_eq] (if maybeToBool (maybeTyConSingleCon tycon) then cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr else - untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] - (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN + untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] + (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR -- True case; they are equal -- If an enumeration type we are done; else -- recursively compare their components @@ -336,25 +298,25 @@ gen_Ord_binds tycon ) -- False case; they aren't equal -- So we need to do a less-than comparison on the tags - (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr))) + (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))) (nullary_cons, nonnullary_cons) = partition isNullaryDataCon (tyConDataCons tycon) cmp_eq - = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc) + = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ deflt_pats_etc) where pats_etc data_con = ([con1_pat, con2_pat], nested_compare_expr tys_needed as_needed bs_needed) where - con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed) - con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) + con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed) + con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed) - data_con_PN = qual_orig_name data_con + data_con_RDR = qual_orig_name data_con con_arity = length tys_needed - as_needed = take con_arity as_PNs - bs_needed = take con_arity bs_PNs + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs tys_needed = dataConRawArgTys data_con nested_compare_expr [ty] [a] [b] @@ -372,18 +334,18 @@ gen_Ord_binds tycon defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] -lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] ( +lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr) -le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] ( +le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] ( compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr) -ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] ( +ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] ( compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr) -gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] ( +gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] ( compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr) -max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] ( +max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] ( compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr) -min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] ( +min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] ( compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr) \end{code} @@ -427,24 +389,32 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods. gen_Enum_binds :: TyCon -> RdrNameMonoBinds gen_Enum_binds tycon - = enum_from `AndMonoBinds` enum_from_then + = enum_from `AndMonoBinds` + enum_from_then `AndMonoBinds` + from_enum where + tycon_loc = getSrcLoc tycon enum_from - = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] $ - untag_Expr tycon [(a_PN, ah_PN)] $ - HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $ + = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $ + untag_Expr tycon [(a_RDR, ah_RDR)] $ + HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $ HsPar (enum_from_to_Expr - (mk_easy_App mkInt_PN [ah_PN]) - (HsVar (maxtag_PN tycon))) + (mk_easy_App mkInt_RDR [ah_RDR]) + (HsVar (maxtag_RDR tycon))) enum_from_then - = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] $ - untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] $ - HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $ + = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $ + untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ + HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $ HsPar (enum_from_then_to_Expr - (mk_easy_App mkInt_PN [ah_PN]) - (mk_easy_App mkInt_PN [bh_PN]) - (HsVar (maxtag_PN tycon))) + (mk_easy_App mkInt_RDR [ah_RDR]) + (mk_easy_App mkInt_RDR [bh_RDR]) + (HsVar (maxtag_RDR tycon))) + + from_enum + = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $ + untag_Expr tycon [(a_RDR, ah_RDR)] $ + (mk_easy_App mkInt_RDR [ah_RDR]) \end{code} %************************************************************************ @@ -471,24 +441,25 @@ gen_Bounded_binds tycon ASSERT(length data_cons == 1) min_bound_1con `AndMonoBinds` max_bound_1con where - data_cons = tyConDataCons tycon + data_cons = tyConDataCons tycon + tycon_loc = getSrcLoc tycon ----- enum-flavored: --------------------------- - min_bound_enum = mk_easy_FunMonoBind minBound_PN [] [] (HsVar data_con_1_PN) - max_bound_enum = mk_easy_FunMonoBind maxBound_PN [] [] (HsVar data_con_N_PN) + min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR) + max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons - data_con_1_PN = qual_orig_name data_con_1 - data_con_N_PN = qual_orig_name data_con_N + data_con_1_RDR = qual_orig_name data_con_1 + data_con_N_RDR = qual_orig_name data_con_N ----- single-constructor-flavored: ------------- arity = dataConNumFields data_con_1 - min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $ - mk_easy_App data_con_1_PN (nOfThem arity minBound_PN) - max_bound_1con = mk_easy_FunMonoBind maxBound_PN [] [] $ - mk_easy_App data_con_1_PN (nOfThem arity maxBound_PN) + min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $ + mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR) + max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $ + mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} %************************************************************************ @@ -557,50 +528,51 @@ gen_Ix_binds tycon then enum_ixes else single_con_ixes where - tycon_str = _UNPK_ (nameOf (origName "gen_Ix_binds" tycon)) + tycon_str = getOccString tycon + tycon_loc = getSrcLoc tycon -------------------------------------------------------------- enum_ixes = enum_range `AndMonoBinds` enum_index `AndMonoBinds` enum_inRange enum_range - = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] $ - untag_Expr tycon [(a_PN, ah_PN)] $ - untag_Expr tycon [(b_PN, bh_PN)] $ - HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $ + = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $ + untag_Expr tycon [(a_RDR, ah_RDR)] $ + untag_Expr tycon [(b_RDR, bh_RDR)] $ + HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $ HsPar (enum_from_to_Expr - (mk_easy_App mkInt_PN [ah_PN]) - (mk_easy_App mkInt_PN [bh_PN])) + (mk_easy_App mkInt_RDR [ah_RDR]) + (mk_easy_App mkInt_RDR [bh_RDR])) enum_index - = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] ( - HsIf (HsPar (mk_easy_App inRange_PN [c_PN, d_PN])) ( - untag_Expr tycon [(a_PN, ah_PN)] ( - untag_Expr tycon [(d_PN, dh_PN)] ( + = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] ( + HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) ( + untag_Expr tycon [(a_RDR, ah_RDR)] ( + untag_Expr tycon [(d_RDR, dh_RDR)] ( let - grhs = [OtherwiseGRHS (mk_easy_App mkInt_PN [c_PN]) mkGeneratedSrcLoc] + grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc] in HsCase - (HsPar (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN))) - [PatMatch (VarPatIn c_PN) + (HsPar (OpApp (HsVar dh_RDR) (HsVar minusH_RDR) (HsVar ah_RDR))) + [PatMatch (VarPatIn c_RDR) (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] - mkGeneratedSrcLoc + tycon_loc )) ) {-else-} ( - HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n")))) + HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n")))) ) - mkGeneratedSrcLoc) + tycon_loc) enum_inRange - = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] ( - untag_Expr tycon [(a_PN, ah_PN)] ( - untag_Expr tycon [(b_PN, bh_PN)] ( - untag_Expr tycon [(c_PN, ch_PN)] ( - HsIf (HsPar (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN))) ( - (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN)) + = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] ( + untag_Expr tycon [(a_RDR, ah_RDR)] ( + untag_Expr tycon [(b_RDR, bh_RDR)] ( + untag_Expr tycon [(c_RDR, ch_RDR)] ( + HsIf (HsPar (OpApp (HsVar ch_RDR) (HsVar geH_RDR) (HsVar ah_RDR))) ( + (OpApp (HsVar ch_RDR) (HsVar leH_RDR) (HsVar bh_RDR)) ) {-else-} ( false_Expr - ) mkGeneratedSrcLoc)))) + ) tycon_loc)))) -------------------------------------------------------------- single_con_ixes = single_con_range `AndMonoBinds` @@ -615,49 +587,51 @@ gen_Ix_binds tycon dc con_arity = dataConNumFields data_con - data_con_PN = qual_orig_name data_con - con_pat xs = ConPatIn data_con_PN (map VarPatIn xs) - con_expr xs = mk_easy_App data_con_PN xs + data_con_RDR = qual_orig_name data_con + con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs) + con_expr xs = mk_easy_App data_con_RDR xs - as_needed = take con_arity as_PNs - bs_needed = take con_arity bs_PNs - cs_needed = take con_arity cs_PNs + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + cs_needed = take con_arity cs_RDRs -------------------------------------------------------------- single_con_range - = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] ( + = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] ( ListComp (con_expr cs_needed) (zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed) ) where mk_qual a b c = GeneratorQual (VarPatIn c) - (HsApp (HsVar range_PN) (ExplicitTuple [HsVar a, HsVar b])) + (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b])) ---------------- single_con_index - = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] ( + = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] ( foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed)) where mk_index multiply_by (l, u, i) =OpApp ( - (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i)) - ) (HsVar plus_PN) ( + (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i)) + ) (HsVar plus_RDR) ( OpApp ( - (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u])) - ) (HsVar times_PN) multiply_by + (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u])) + ) (HsVar times_RDR) multiply_by ) range_size - = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] ( + = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] ( OpApp ( - (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr) - ) (HsVar plus_PN) (HsLit (HsInt 1))) + (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr) + ) (HsVar plus_RDR) (HsLit (HsInt 1))) ------------------ single_con_inRange - = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] ( + = mk_easy_FunMonoBind tycon_loc inRange_RDR + [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] + [] ( foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) where - in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c) + in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c) \end{code} %************************************************************************ @@ -669,38 +643,39 @@ gen_Ix_binds tycon Ignoring all the infix-ery mumbo jumbo (ToDo) \begin{code} -gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: TyCon -> RdrNameMonoBinds -gen_Read_binds fixities tycon +gen_Read_binds tycon = reads_prec `AndMonoBinds` read_list where + tycon_loc = getSrcLoc tycon ----------------------------------------------------------------------- - read_list = mk_easy_FunMonoBind readList_PN [] [] - (HsApp (HsVar readList___PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))) + read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] [] + (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0))))) ----------------------------------------------------------------------- reads_prec = let read_con_comprehensions = map read_con (tyConDataCons tycon) in - mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] ( + mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] ( foldl1 append_Expr read_con_comprehensions ) where read_con data_con -- note: "b" is the string being "read" = let - data_con_PN = qual_orig_name data_con - data_con_str= nameOf (origName "gen_Read_binds" data_con) + data_con_RDR = qual_orig_name data_con + data_con_str= occNameString (getOccName data_con) con_arity = dataConNumFields data_con - as_needed = take con_arity as_PNs - bs_needed = take con_arity bs_PNs - con_expr = mk_easy_App data_con_PN as_needed + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + con_expr = mk_easy_App data_con_RDR as_needed nullary_con = isNullaryDataCon data_con con_qual = GeneratorQual (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat]) - (HsApp (HsVar lex_PN) c_Expr) + (HsApp (HsVar lex_RDR) c_Expr) field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed)) @@ -708,21 +683,21 @@ gen_Read_binds fixities tycon = if nullary_con then -- must be False (parens are surely optional) false_Expr else -- parens depend on precedence... - HsPar (OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9))) + HsPar (OpApp a_Expr (HsVar gt_RDR) (HsLit (HsInt 9))) in HsApp ( readParen_Expr read_paren_arg $ HsPar $ - HsLam (mk_easy_Match [c_Pat] [] ( + HsLam (mk_easy_Match tycon_loc [c_Pat] [] ( ListComp (ExplicitTuple [con_expr, if null bs_needed then d_Expr else HsVar (last bs_needed)]) (con_qual : field_quals))) - ) (HsVar b_PN) + ) (HsVar b_RDR) where mk_qual draw_from (con_field, str_left) = (HsVar str_left, -- what to draw from down the line... GeneratorQual (TuplePatIn [VarPatIn con_field, VarPatIn str_left]) - (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from)) + (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)) \end{code} %************************************************************************ @@ -734,36 +709,37 @@ gen_Read_binds fixities tycon Ignoring all the infix-ery mumbo jumbo (ToDo) \begin{code} -gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: TyCon -> RdrNameMonoBinds -gen_Show_binds fixities tycon +gen_Show_binds tycon = shows_prec `AndMonoBinds` show_list where + tycon_loc = getSrcLoc tycon ----------------------------------------------------------------------- - show_list = mk_easy_FunMonoBind showList_PN [] [] - (HsApp (HsVar showList___PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0))))) + show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] [] + (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0))))) ----------------------------------------------------------------------- shows_prec - = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon)) + = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) where pats_etc data_con = let - data_con_PN = qual_orig_name data_con + data_con_RDR = qual_orig_name data_con con_arity = dataConNumFields data_con - bs_needed = take con_arity bs_PNs - con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) + bs_needed = take con_arity bs_RDRs + con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed) nullary_con = isNullaryDataCon data_con show_con - = let (OrigName mod nm) = origName "gen_Show_binds" data_con + = let nm = occNameString (getOccName data_con) space_maybe = if nullary_con then _NIL_ else SLIT(" ") in - HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe))) + HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe))) show_thingies = show_con : (spacified real_show_thingies) real_show_thingies - = [ HsApp (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 10))) (HsVar b) + = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b) | b <- bs_needed ] in if nullary_con then -- skip the showParen junk... @@ -771,12 +747,12 @@ gen_Show_binds fixities tycon ([a_Pat, con_pat], show_con) else ([a_Pat, con_pat], - showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10)))) + showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_RDR) (HsLit (HsInt 10)))) (HsPar (nested_compose_Expr show_thingies))) where spacified [] = [] spacified [x] = [x] - spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs) + spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs) \end{code} %************************************************************************ @@ -806,8 +782,8 @@ gen_tag_n_con_monobind TagThingWanted) -> RdrNameMonoBinds -gen_tag_n_con_monobind (pn, tycon, GenCon2Tag) - = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon)) +gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) + = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon)) where mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) @@ -815,23 +791,24 @@ gen_tag_n_con_monobind (pn, tycon, GenCon2Tag) = ASSERT(isDataCon var) ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))) where - pat = ConPatIn var_PN (nOfThem (dataConNumFields var) WildPatIn) - var_PN = qual_orig_name var + pat = ConPatIn var_RDR (nOfThem (dataConNumFields var) WildPatIn) + var_RDR = qual_orig_name var -gen_tag_n_con_monobind (pn, tycon, GenTag2Con) - = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon)) +gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) + = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon)) where mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) mk_stuff var = ASSERT(isDataCon var) - ([lit_pat], HsVar var_PN) + ([lit_pat], HsVar var_RDR) where - lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))] - var_PN = qual_orig_name var + lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))] + var_RDR = qual_orig_name var -gen_tag_n_con_monobind (pn, tycon, GenMaxTag) - = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag))) +gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) + = mk_easy_FunMonoBind (getSrcLoc tycon) + rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag))) where max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) @@ -858,15 +835,15 @@ multi-clause definitions; it generates: \end{verbatim} \begin{code} -mk_easy_FunMonoBind :: RdrName -> [RdrNamePat] +mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat] -> [RdrNameMonoBinds] -> RdrNameHsExpr -> RdrNameMonoBinds -mk_easy_FunMonoBind fun pats binds expr - = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc +mk_easy_FunMonoBind loc fun pats binds expr + = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc -mk_easy_Match pats binds expr - = mk_match pats expr (mkbind binds) +mk_easy_Match loc pats binds expr + = mk_match loc pats expr (mkbind binds) where mkbind [] = EmptyBinds mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs)) @@ -874,19 +851,19 @@ mk_easy_Match pats binds expr -- "recursive" MonoBinds, and it is its job to sort things out -- from there. -mk_FunMonoBind :: RdrName +mk_FunMonoBind :: SrcLoc -> RdrName -> [([RdrNamePat], RdrNameHsExpr)] -> RdrNameMonoBinds -mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind" -mk_FunMonoBind fun pats_and_exprs +mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind" +mk_FunMonoBind loc fun pats_and_exprs = FunMonoBind fun False{-not infix-} - [ mk_match p e EmptyBinds | (p,e) <-pats_and_exprs ] - mkGeneratedSrcLoc + [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ] + loc -mk_match pats expr binds +mk_match loc pats expr binds = foldr PatMatch - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] binds)) + (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds)) (map paren pats) where paren p@(VarPatIn _) = p @@ -897,6 +874,8 @@ mk_match pats expr binds mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs) \end{code} +ToDo: Better SrcLocs. + \begin{code} compare_Case, cmp_eq_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr @@ -913,24 +892,24 @@ careful_compare_Case :: -- checks for primitive types... -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -compare_Case = compare_gen_Case compare_PN -cmp_eq_Expr = compare_gen_Case cmp_eq_PN +compare_Case = compare_gen_Case compare_RDR +cmp_eq_Expr = compare_gen_Case cmp_eq_RDR compare_gen_Case fun lt eq gt a b = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} - [PatMatch (ConPatIn ltTag_PN []) + [PatMatch (ConPatIn ltTag_RDR []) (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)), - PatMatch (ConPatIn eqTag_PN []) + PatMatch (ConPatIn eqTag_RDR []) (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)), - PatMatch (ConPatIn gtTag_PN []) + PatMatch (ConPatIn gtTag_RDR []) (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))] mkGeneratedSrcLoc careful_compare_Case ty lt eq gt a b = if not (isPrimType ty) then - compare_gen_Case compare_PN lt eq gt a b + compare_gen_Case compare_RDR lt eq gt a b else -- we have to do something special for primitive things... HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b)) @@ -948,36 +927,36 @@ assoc_ty_id tyids ty res = [id | (ty',id) <- tyids, eqTy ty ty'] eq_op_tbl = - [(charPrimTy, eqH_Char_PN) - ,(intPrimTy, eqH_Int_PN) - ,(wordPrimTy, eqH_Word_PN) - ,(addrPrimTy, eqH_Addr_PN) - ,(floatPrimTy, eqH_Float_PN) - ,(doublePrimTy, eqH_Double_PN) + [(charPrimTy, eqH_Char_RDR) + ,(intPrimTy, eqH_Int_RDR) + ,(wordPrimTy, eqH_Word_RDR) + ,(addrPrimTy, eqH_Addr_RDR) + ,(floatPrimTy, eqH_Float_RDR) + ,(doublePrimTy, eqH_Double_RDR) ] lt_op_tbl = - [(charPrimTy, ltH_Char_PN) - ,(intPrimTy, ltH_Int_PN) - ,(wordPrimTy, ltH_Word_PN) - ,(addrPrimTy, ltH_Addr_PN) - ,(floatPrimTy, ltH_Float_PN) - ,(doublePrimTy, ltH_Double_PN) + [(charPrimTy, ltH_Char_RDR) + ,(intPrimTy, ltH_Int_RDR) + ,(wordPrimTy, ltH_Word_RDR) + ,(addrPrimTy, ltH_Addr_RDR) + ,(floatPrimTy, ltH_Float_RDR) + ,(doublePrimTy, ltH_Double_RDR) ] ----------------------------------------------------------------------- and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -and_Expr a b = OpApp a (HsVar and_PN) b -append_Expr a b = OpApp a (HsVar append_PN) b +and_Expr a b = OpApp a (HsVar and_RDR) b +append_Expr a b = OpApp a (HsVar append_RDR) b ----------------------------------------------------------------------- eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr eq_Expr ty a b = if not (isPrimType ty) then - OpApp a (HsVar eq_PN) b + OpApp a (HsVar eq_RDR) b else -- we have to do something special for primitive things... OpApp a (HsVar relevant_eq_op) b where @@ -1011,141 +990,78 @@ enum_from_then_to_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2 -enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2 +enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2 +enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2 showParen_Expr, readParen_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2 -readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2 +showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2 +readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr nested_compose_Expr [e] = parenify e nested_compose_Expr (e:es) - = HsApp (HsApp (HsVar compose_PN) (parenify e)) (nested_compose_Expr es) + = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es) parenify e@(HsVar _) = e parenify e = HsPar e \end{code} \begin{code} -qual_orig_name n = case (origName "qual_orig_name" n) of { OrigName m n -> Qual m n } - -a_PN = Unqual SLIT("a") -b_PN = Unqual SLIT("b") -c_PN = Unqual SLIT("c") -d_PN = Unqual SLIT("d") -ah_PN = Unqual SLIT("a#") -bh_PN = Unqual SLIT("b#") -ch_PN = Unqual SLIT("c#") -dh_PN = Unqual SLIT("d#") -cmp_eq_PN = Unqual SLIT("cmp_eq") -rangeSize_PN = Qual iX SLIT("rangeSize") - -as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ] -cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] - -eq_PN = preludeQual {-SLIT("Eq")-} SLIT("==") -ne_PN = preludeQual {-SLIT("Eq")-} SLIT("/=") -le_PN = preludeQual {-SLIT("Ord")-} SLIT("<=") -lt_PN = preludeQual {-SLIT("Ord")-} SLIT("<") -ge_PN = preludeQual {-SLIT("Ord")-} SLIT(">=") -gt_PN = preludeQual {-SLIT("Ord")-} SLIT(">") -max_PN = preludeQual {-SLIT("Ord")-} SLIT("max") -min_PN = preludeQual {-SLIT("Ord")-} SLIT("min") -compare_PN = preludeQual {-SLIT("Ord")-} SLIT("compare") -minBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("minBound") -maxBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("maxBound") -enumFrom_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFrom") -enumFromTo_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromTo") -enumFromThen_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromThen") -enumFromThenTo_PN= preludeQual {-SLIT("Enum")-} SLIT("enumFromThenTo") -range_PN = Qual iX SLIT("range") -index_PN = Qual iX SLIT("index") -inRange_PN = Qual iX SLIT("inRange") -readsPrec_PN = preludeQual {-SLIT("Read")-} SLIT("readsPrec") -readList_PN = preludeQual {-SLIT("Read")-} SLIT("readList") -showsPrec_PN = preludeQual {-SLIT("Show")-} SLIT("showsPrec") -showList_PN = preludeQual {-SLIT("Show")-} SLIT("showList") -plus_PN = preludeQual {-SLIT("Num")-} SLIT("+") -times_PN = preludeQual {-SLIT("Num")-} SLIT("*") -ltTag_PN = preludeQual SLIT("LT") -eqTag_PN = preludeQual SLIT("EQ") -gtTag_PN = preludeQual SLIT("GT") - -eqH_Char_PN = prelude_primop CharEqOp -ltH_Char_PN = prelude_primop CharLtOp -eqH_Word_PN = prelude_primop WordEqOp -ltH_Word_PN = prelude_primop WordLtOp -eqH_Addr_PN = prelude_primop AddrEqOp -ltH_Addr_PN = prelude_primop AddrLtOp -eqH_Float_PN = prelude_primop FloatEqOp -ltH_Float_PN = prelude_primop FloatLtOp -eqH_Double_PN = prelude_primop DoubleEqOp -ltH_Double_PN = prelude_primop DoubleLtOp -eqH_Int_PN = prelude_primop IntEqOp -ltH_Int_PN = prelude_primop IntLtOp -geH_PN = prelude_primop IntGeOp -leH_PN = prelude_primop IntLeOp -minusH_PN = prelude_primop IntSubOp - -prelude_primop o = case (origName "prelude_primop" (primOpId o)) of { OrigName m n -> Qual m n } - -false_PN = preludeQual SLIT("False") -true_PN = preludeQual SLIT("True") -and_PN = preludeQual SLIT("&&") -not_PN = preludeQual SLIT("not") -append_PN = preludeQual SLIT("++") -map_PN = preludeQual SLIT("map") -compose_PN = preludeQual SLIT(".") -mkInt_PN = preludeQual SLIT("I#") -error_PN = preludeQual SLIT("error") -showString_PN = preludeQual SLIT("showString") -showParen_PN = preludeQual SLIT("showParen") -readParen_PN = preludeQual SLIT("readParen") -lex_PN = Qual gHC__ SLIT("lex") -showSpace_PN = Qual gHC__ SLIT("showSpace") -showList___PN = Qual gHC__ SLIT("showList__") -readList___PN = Qual gHC__ SLIT("readList__") - -a_Expr = HsVar a_PN -b_Expr = HsVar b_PN -c_Expr = HsVar c_PN -d_Expr = HsVar d_PN -ltTag_Expr = HsVar ltTag_PN -eqTag_Expr = HsVar eqTag_PN -gtTag_Expr = HsVar gtTag_PN -false_Expr = HsVar false_PN -true_Expr = HsVar true_PN - -con2tag_Expr tycon = HsVar (con2tag_PN tycon) - -a_Pat = VarPatIn a_PN -b_Pat = VarPatIn b_PN -c_Pat = VarPatIn c_PN -d_Pat = VarPatIn d_PN - -con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName - -con2tag_PN tycon - = let (OrigName mod nm) = origName "con2tag_PN" tycon - con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") +qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n } + +a_RDR = varUnqual SLIT("a") +b_RDR = varUnqual SLIT("b") +c_RDR = varUnqual SLIT("c") +d_RDR = varUnqual SLIT("d") +ah_RDR = varUnqual SLIT("a#") +bh_RDR = varUnqual SLIT("b#") +ch_RDR = varUnqual SLIT("c#") +dh_RDR = varUnqual SLIT("d#") +cmp_eq_RDR = varUnqual SLIT("cmp_eq") +rangeSize_RDR = varUnqual SLIT("rangeSize") + +as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] + +a_Expr = HsVar a_RDR +b_Expr = HsVar b_RDR +c_Expr = HsVar c_RDR +d_Expr = HsVar d_RDR +ltTag_Expr = HsVar ltTag_RDR +eqTag_Expr = HsVar eqTag_RDR +gtTag_Expr = HsVar gtTag_RDR +false_Expr = HsVar false_RDR +true_Expr = HsVar true_RDR + +con2tag_Expr tycon = HsVar (con2tag_RDR tycon) + +a_Pat = VarPatIn a_RDR +b_Pat = VarPatIn b_RDR +c_Pat = VarPatIn c_RDR +d_Pat = VarPatIn d_RDR + +con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName + +con2tag_RDR tycon + = let (mod, nm) = modAndOcc tycon + con2tag = SLIT("con2tag_") _APPEND_ occNameString nm _APPEND_ SLIT("#") in - Qual mod con2tag + varQual (mod, con2tag) -tag2con_PN tycon - = let (OrigName mod nm) = origName "tag2con_PN" tycon - tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") +tag2con_RDR tycon + = let (mod, nm) = modAndOcc tycon + tag2con = SLIT("tag2con_") _APPEND_ occNameString nm _APPEND_ SLIT("#") in - Qual mod tag2con + varQual (mod, tag2con) -maxtag_PN tycon - = let (OrigName mod nm) = origName "maxtag_PN" tycon - maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") +maxtag_RDR tycon + = let (mod, nm) = modAndOcc tycon + maxtag = SLIT("maxtag_") _APPEND_ occNameString nm _APPEND_ SLIT("#") in - Qual mod maxtag + varQual (mod, maxtag) \end{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 00eb754..9b0be49 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -15,7 +15,7 @@ module TcHsSyn ( SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcPat), SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch), SYN_IE(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds), - SYN_IE(TcHsModule), + SYN_IE(TcHsModule), SYN_IE(TcCoreExpr), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind), SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat), @@ -44,7 +44,7 @@ import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids -- others: import Name ( Name{--O only-} ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), zonkTcTypeToType, zonkTcTyVarToTyVar ) @@ -56,6 +56,7 @@ import Type ( mkTyVarTy, tyVarsOfType ) import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet ) import TysPrim ( voidTy ) +import CoreSyn ( GenCoreExpr ) import Unique ( Unique ) -- instances import UniqFM import PprStyle @@ -92,6 +93,8 @@ type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s) +type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar + type TypecheckedPat = OutPat TyVar UVar Id type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat @@ -284,6 +287,10 @@ zonkMonoBinds te ve (VarMonoBind var expr) zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (VarMonoBind new_var new_expr, [new_var]) +zonkMonoBinds te ve (CoreMonoBind var core_expr) + = zonkIdBndr te var `thenNF_Tc` \ new_var -> + returnNF_Tc (CoreMonoBind new_var core_expr, [new_var]) + zonkMonoBinds te ve (FunMonoBind var inf ms locn) = zonkIdBndr te var `thenNF_Tc` \ new_var -> mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms -> diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index b8e1b1a..656a1e2 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -10,24 +10,32 @@ module TcIfaceSig ( tcInterfaceSigs ) where IMP_Ubiq() -import TcMonad hiding ( rnMtoTcM ) -import TcMonoType ( tcPolyType ) +import TcMonad +import TcMonoType ( tcHsType ) +import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv ) +import TcKind ( TcKind, kindToTcKind ) -import HsSyn ( Sig(..), PolyType ) -import RnHsSyn ( RenamedSig(..), RnName(..) ) +import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds, + Fake, InPat, HsType ) +import RnHsSyn ( RenamedHsDecl(..) ) +import HsCore +import HsDecls ( HsIdInfo(..) ) +import CoreSyn +import CoreUnfold +import MagicUFs ( MagicUnfoldingFun ) +import SpecEnv ( SpecEnv ) +import PrimOp ( PrimOp(..) ) -import CmdLineOpts ( opt_CompilingGhcInternals ) -import Id ( mkImported ) ---import Name ( Name(..) ) +import Id ( GenId, mkImported, mkUserId, isPrimitiveId_maybe ) +import TyVar ( mkTyVar ) +import Name ( Name ) +import PragmaInfo ( PragmaInfo(..) ) import Maybes ( maybeToBool ) import Pretty -import Util ( panic ) - - ---import TcPragmas ( tcGenPragmas ) -import IdInfo ( noIdInfo ) -tcGenPragmas ty id ps = returnNF_Tc noIdInfo +import PprStyle ( PprStyle(..) ) +import Util ( zipWithEqual, panic, pprTrace, pprPanic ) +import IdInfo \end{code} Ultimately, type signatures in interfaces will have pragmatic @@ -38,37 +46,221 @@ As always, we do not have to worry about user-pragmas in interface signatures. \begin{code} -tcInterfaceSigs :: [RenamedSig] -> TcM s [Id] +tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id] + -- Ignore non-sig-decls in these decls + +tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest) + = tcAddSrcLoc src_loc $ + tcHsType ty `thenTc` \ sigma_ty -> + tcIdInfo name noIdInfo id_infos `thenTc` \ id_info' -> + let + sig_id = mkImported name sigma_ty id_info' + in + tcInterfaceSigs rest `thenTc` \ sig_ids -> + returnTc (sig_id : sig_ids) + +tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest tcInterfaceSigs [] = returnTc [] +\end{code} + +Inside here we use only the Global environment, even for locally bound variables. +Why? Because we know all the types and want to bind them to real Ids. + +\begin{code} +tcIdInfo name info [] = returnTc info + +tcIdInfo name info (HsArity arity : rest) + = tcIdInfo name (info `addArityInfo` arity) rest + +tcIdInfo name info (HsUpdate upd : rest) + = tcIdInfo name (info `addUpdateInfo` upd) rest + +tcIdInfo name info (HsFBType fb : rest) + = tcIdInfo name (info `addFBTypeInfo` fb) rest + +tcIdInfo name info (HsArgUsage au : rest) + = tcIdInfo name (info `addArgUsageInfo` au) rest + +tcIdInfo name info (HsDeforest df : rest) + = tcIdInfo name (info `addDeforestInfo` df) rest + +tcIdInfo name info (HsUnfold expr : rest) + = tcUnfolding name expr `thenNF_Tc` \ unfold_info -> + tcIdInfo name (info `addUnfoldInfo` unfold_info) rest + +tcIdInfo name info (HsStrictness strict : rest) + = tcStrictness strict `thenTc` \ strict_info -> + tcIdInfo name (info `addStrictnessInfo` strict_info) rest +\end{code} + +\begin{code} +tcStrictness (StrictnessInfo demands (Just worker)) + = tcLookupGlobalValue worker `thenNF_Tc` \ worker_id -> + returnTc (StrictnessInfo demands (Just worker_id)) + +-- Boring to write these out, but the result type differe from the arg type... +tcStrictness (StrictnessInfo demands Nothing) = returnTc (StrictnessInfo demands Nothing) +tcStrictness NoStrictnessInfo = returnTc NoStrictnessInfo +tcStrictness BottomGuaranteed = returnTc BottomGuaranteed +\end{code} + +For unfoldings we try to do the job lazily, so that we never type check +an unfolding that isn't going to be looked at. + +\begin{code} +tcUnfolding name core_expr + = forkNF_Tc ( + recoverNF_Tc (returnNF_Tc no_unfolding) ( + tcCoreExpr core_expr `thenTc` \ core_expr' -> + returnTc (mkUnfolding False core_expr') + )) + where + no_unfolding = pprTrace "tcUnfolding failed:" (ppr PprDebug name) NoUnfolding +\end{code} + +UfCore expressions. + +\begin{code} +tcCoreExpr :: UfExpr Name -> TcM s CoreExpr + +tcCoreExpr (UfVar name) + = tcLookupGlobalValue name `thenNF_Tc` \ id -> + returnTc (Var id) + +tcCoreExpr (UfLit lit) = returnTc (Lit lit) + +tcCoreExpr (UfCon con args) + = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> + mapTc tcCoreArg args `thenTc` \ args' -> + returnTc (Con con_id args') + +tcCoreExpr (UfPrim prim args) + = tcCorePrim prim `thenTc` \ primop -> + mapTc tcCoreArg args `thenTc` \ args' -> + returnTc (Prim primop args') + +tcCoreExpr (UfApp fun arg) + = tcCoreExpr fun `thenTc` \ fun' -> + tcCoreArg arg `thenTc` \ arg' -> + returnTc (App fun' arg') + +tcCoreExpr (UfCase scrut alts) + = tcCoreExpr scrut `thenTc` \ scrut' -> + tcCoreAlts alts `thenTc` \ alts' -> + returnTc (Case scrut' alts') -tcInterfaceSigs (Sig name ty pragmas src_loc : sigs) - | has_full_name - = tcAddSrcLoc src_loc ( - tcPolyType ty `thenTc` \ sigma_ty -> - fixTc ( \ rec_id -> - tcGenPragmas (Just sigma_ty) rec_id pragmas - `thenNF_Tc` \ id_info -> - returnTc (mkImported full_name sigma_ty id_info) - )) `thenTc` \ id -> - tcInterfaceSigs sigs `thenTc` \ sigs' -> - returnTc (id:sigs') - - | otherwise -- odd name... - = case name of - WiredInId _ | opt_CompilingGhcInternals - -> tcInterfaceSigs sigs - _ -> tcAddSrcLoc src_loc $ - failTc (ifaceSigNameErr name) +tcCoreExpr (UfSCC cc expr) + = tcCoreExpr expr `thenTc` \ expr' -> + returnTc (SCC cc expr') + +tcCoreExpr(UfCoerce coercion ty body) + = tcCoercion coercion `thenTc` \ coercion' -> + tcHsType ty `thenTc` \ ty' -> + tcCoreExpr body `thenTc` \ body' -> + returnTc (Coerce coercion' ty' body') + +tcCoreExpr (UfLam bndr body) + = tcCoreLamBndr bndr $ \ bndr' -> + tcCoreExpr body `thenTc` \ body' -> + returnTc (Lam bndr' body') + +tcCoreExpr (UfLet (UfNonRec bndr rhs) body) + = tcCoreExpr rhs `thenTc` \ rhs' -> + tcCoreValBndr bndr $ \ bndr' -> + tcCoreExpr body `thenTc` \ body' -> + returnTc (Let (NonRec bndr' rhs') body') + +tcCoreExpr (UfLet (UfRec pairs) body) + = tcCoreValBndrs bndrs $ \ bndrs' -> + mapTc tcCoreExpr rhss `thenTc` \ rhss' -> + tcCoreExpr body `thenTc` \ body' -> + returnTc (Let (Rec (bndrs' `zip` rhss')) body') where - has_full_name = maybeToBool full_name_maybe - (Just full_name) = full_name_maybe - full_name_maybe = case name of - RnName fn -> Just fn - RnImplicit fn -> Just fn - _ -> Nothing - -ifaceSigNameErr name sty - = ppHang (ppStr "Bad name in an interface type signature (a Prelude name?)") - 4 (ppr sty name) + (bndrs, rhss) = unzip pairs \end{code} + +\begin{code} +tcCoreLamBndr (UfValBinder name ty) thing_inside + = tcHsType ty `thenTc` \ ty' -> + let + id = mkUserId name ty' NoPragmaInfo + in + tcExtendGlobalValEnv [id] $ + thing_inside (ValBinder id) + +tcCoreLamBndr (UfTyBinder name kind) thing_inside + = let + tyvar = mkTyVar name kind + in + tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $ + thing_inside (TyBinder tyvar) + +tcCoreLamBndr (UfUsageBinder name) thing_inside + = error "tcCoreLamBndr: usage" + +tcCoreValBndr (UfValBinder name ty) thing_inside + = tcHsType ty `thenTc` \ ty' -> + let + id = mkUserId name ty' NoPragmaInfo + in + tcExtendGlobalValEnv [id] $ + thing_inside id + +tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders + = mapTc tcHsType tys `thenTc` \ tys' -> + let + ids = zipWithEqual "tcCoreValBndr" mk_id names tys' + mk_id name ty' = mkUserId name ty' NoPragmaInfo + in + tcExtendGlobalValEnv ids $ + thing_inside ids + where + names = map (\ (UfValBinder name _) -> name) bndrs + tys = map (\ (UfValBinder _ ty) -> ty) bndrs +\end{code} + +\begin{code} +tcCoreArg (UfVarArg v) = tcLookupGlobalValue v `thenNF_Tc` \ v' -> returnTc (VarArg v') +tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty') +tcCoreArg (UfLitArg lit) = returnTc (LitArg lit) +tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage" + +tcCoreAlts (UfAlgAlts alts deflt) + = mapTc tc_alt alts `thenTc` \ alts' -> + tcCoreDefault deflt `thenTc` \ deflt' -> + returnTc (AlgAlts alts' deflt') + where + tc_alt (con, bndrs, rhs) = tcLookupGlobalValue con `thenNF_Tc` \ con' -> + tcCoreValBndrs bndrs $ \ bndrs' -> + tcCoreExpr rhs `thenTc` \ rhs' -> + returnTc (con', bndrs', rhs') + +tcCoreAlts (UfPrimAlts alts deflt) + = mapTc tc_alt alts `thenTc` \ alts' -> + tcCoreDefault deflt `thenTc` \ deflt' -> + returnTc (PrimAlts alts' deflt') + where + tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' -> + returnTc (lit, rhs') + +tcCoreDefault UfNoDefault = returnTc NoDefault +tcCoreDefault (UfBindDefault bndr rhs) = tcCoreValBndr bndr $ \ bndr' -> + tcCoreExpr rhs `thenTc` \ rhs' -> + returnTc (BindDefault bndr' rhs') + +tcCoercion (UfIn n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceIn n') +tcCoercion (UfOut n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceOut n') + +tcCorePrim (UfOtherOp op) + = tcLookupGlobalValue op `thenNF_Tc` \ op_id -> + case isPrimitiveId_maybe op_id of + Just prim_op -> returnTc prim_op + Nothing -> pprPanic "tcCorePrim" (ppr PprDebug op_id) + +tcCorePrim (UfCCallOp str casm gc arg_tys res_ty) + = mapTc tcHsType arg_tys `thenTc` \ arg_tys' -> + tcHsType res_ty `thenTc` \ res_ty' -> + returnTc (CCallOp str casm gc arg_tys' res_ty') +\end{code} + diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 5194f9e..030ab80 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -15,16 +15,16 @@ module TcInstDcls ( IMP_Ubiq() -import HsSyn ( InstDecl(..), FixityDecl, Sig(..), +import HsSyn ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl, + FixityDecl, IfaceSig, Sig(..), SpecInstSig(..), HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, InPat(..), OutPat(..), HsExpr(..), HsLit(..), Stmt, Qualifier, ArithSeqInfo, Fake, - PolyType(..), MonoType ) + HsType(..), HsTyVar ) import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), - RenamedInstDecl(..), RenamedFixityDecl(..), - RenamedSig(..), RenamedSpecInstSig(..), - RnName(..){-incl instance Outputable-} + SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), + SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl) ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType, @@ -32,19 +32,20 @@ import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), mkHsDictLam, mkHsDictApp ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad +import RnMonad ( SYN_IE(RnNameSupply) ) import GenSpecEtc ( checkSigTyVars ) import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper), newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE ) import TcBinds ( tcPragmaSigs ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars ) +import TcEnv ( tcLookupClass, newLocalId, tcExtendGlobalTyVars ) import SpecEnv ( SpecEnv ) import TcGRHSs ( tcGRHSsAndBinds ) import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcKind ( TcKind, unifyKind ) import TcMatches ( tcMatchesFun ) -import TcMonoType ( tcContext, tcMonoTypeKind ) +import TcMonoType ( tcTyVarScope, tcContext, tcHsTypeKind ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType @@ -59,31 +60,32 @@ import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals, opt_SpecialiseOverloaded ) import Class ( GenClass, GenClassOp, - isCcallishClass, classBigSig, - classOps, classOpLocalType, - classOpTagByString_maybe + classBigSig, classOps, classOpLocalType, + classOpTagByOccName_maybe ) -import Id ( GenId, idType, isDefaultMethodId_maybe ) +import Id ( GenId, idType, isDefaultMethodId_maybe, isNullaryDataCon, dataConArgTys ) +import PrelInfo ( isCcallishClass ) import ListSetOps ( minusList ) import Maybes ( maybeToBool, expectJust ) -import Name ( getLocalName, origName, nameOf, Name{--O only-} ) +import Name ( getOccString, occNameString, moduleString, isLocallyDefined, OccName, Name{--O only-} ) import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID ) -import PrelMods ( pRELUDE ) import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, pprParendGenType ) import PprStyle +import SrcLoc ( SrcLoc ) import Pretty -import RnUtils ( SYN_IE(RnEnv) ) import TyCon ( isSynTyCon, derivedFor ) import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, - getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy + getTyCon_maybe, maybeAppTyCon, + maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy ) import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets ) +import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( stringTy ) -import Unique ( Unique ) -import Util ( zipEqual, panic ) +import Unique ( Unique, cCallableClassKey, cReturnableClassKey ) +import Util ( zipEqual, panic, pprPanic, pprTrace ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -160,98 +162,70 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. \end{enumerate} \begin{code} -tcInstDecls1 :: Bag RenamedInstDecl - -> [RenamedSpecInstSig] +tcInstDecls1 :: [RenamedHsDecl] -> Module -- module name for deriving - -> RnEnv -- for renaming derivings - -> [RenamedFixityDecl] -- fixities for deriving + -> RnNameSupply -- for renaming derivings -> TcM s (Bag InstInfo, RenamedHsBinds, PprStyle -> Pretty) -tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities +tcInstDecls1 decls mod_name rn_name_supply = -- Do the ordinary instance declarations - mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls - `thenNF_Tc` \ inst_info_bags -> + mapNF_Tc (tcInstDecl1 mod_name) + [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags -> let - decl_inst_info = concatBag inst_info_bags + decl_inst_info = unionManyBags inst_info_bags in -- Handle "derived" instances; note that we only do derivings -- for things in this module; we ignore deriving decls from -- interfaces! We pass fixities, because they may be used -- in deriving Read and Show. - tcDeriving mod_name rn_env decl_inst_info fixities + tcDeriving mod_name rn_name_supply decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) -> let - inst_info = deriv_inst_info `unionBags` decl_inst_info - in -{- LATER - -- Handle specialise instance pragmas - tcSpecInstSigs inst_info specinst_sigs - `thenTc` \ spec_inst_info -> --} - let - spec_inst_info = emptyBag -- For now - - full_inst_info = inst_info `unionBags` spec_inst_info + full_inst_info = deriv_inst_info `unionBags` decl_inst_info in returnTc (full_inst_info, deriv_binds, ddump_deriv) -tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) +tcInstDecl1 :: Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) -tcInstDecl1 mod_name - (InstDecl class_name - poly_ty@(HsForAllTy tyvar_names context inst_ty) - binds - from_here inst_mod uprags pragmas src_loc) +tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc) = -- Prime error recovery, set source location recoverNF_Tc (returnNF_Tc emptyBag) $ tcAddSrcLoc src_loc $ -- Look things up - tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) -> + tcLookupClass class_name `thenTc` \ (clas_kind, clas) -> - let - de_rn (RnName n) = n - in -- Typecheck the context and instance type - tcTyVarScope (map de_rn tyvar_names) (\ tyvars -> + tcTyVarScope tyvar_names (\ tyvars -> tcContext context `thenTc` \ theta -> - tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) -> + tcHsTypeKind inst_ty `thenTc` \ (tau_kind, tau) -> unifyKind clas_kind tau_kind `thenTc_` returnTc (tyvars, theta, tau) ) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) -> -- Check for respectable instance type - scrutiniseInstanceType from_here clas inst_tau + scrutiniseInstanceType dfun_name clas inst_tau `thenTc` \ (inst_tycon,arg_tys) -> - -- Deal with the case where we are deriving - -- and importing the same instance - if (not from_here && (clas `derivedFor` inst_tycon) - && all isTyVarTy arg_tys) - then - if mod_name == inst_mod - then - -- Imported instance came from this module; - -- discard and derive fresh instance - returnTc emptyBag - else - -- Imported instance declared in another module; - -- report duplicate instance error - failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon) - else - -- Make the dfun id and constant-method ids - mkInstanceRelatedIds from_here src_loc inst_mod pragmas - clas inst_tyvars inst_tau inst_theta uprags - `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> + mkInstanceRelatedIds dfun_name + clas inst_tyvars inst_tau inst_theta + `thenNF_Tc` \ (dfun_id, dfun_theta) -> returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta - dfun_theta dfun_id const_meth_ids - binds from_here inst_mod src_loc uprags)) + dfun_theta dfun_id + binds src_loc uprags)) + where + (tyvar_names, context, dict_ty) = case poly_ty of + HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty) + other -> ([], [], poly_ty) + (class_name, inst_ty) = case dict_ty of + MonoDictTy cls ty -> (cls,ty) + other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty) \end{code} @@ -345,13 +319,14 @@ First comes the easy case of a non-local instance decl. tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcHsBinds s) -tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _) - = returnNF_Tc (emptyLIE, EmptyBinds) - tcInstDecl2 (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta - dfun_id const_meth_ids monobinds - True{-here-} inst_mod locn uprags) + dfun_id monobinds + locn uprags) + | not (isLocallyDefined dfun_id) + = returnNF_Tc (emptyLIE, EmptyBinds) + + | otherwise = -- Prime error recovery recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $ tcAddSrcLoc locn $ @@ -388,10 +363,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) mk_method_expr - = if opt_OmitDefaultInstanceMethods then - makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod - else - makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id + = makeInstanceDeclDefaultMethodExpr locn clas meth_ids defm_ids inst_ty' this_dict_id in tcExtendGlobalTyVars inst_tyvars_set' ( processInstBinds clas mk_method_expr avail_insts meth_ids monobinds @@ -437,9 +409,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty = AbsBinds inst_tyvars' dfun_arg_dicts_ids - ((this_dict_id, RealId dfun_id) - : (meth_ids `zip` map RealId const_meth_ids)) - -- NB: const_meth_ids will often be empty + [(this_dict_id, RealId dfun_id)] super_binds (RecBind dict_and_method_binds) @@ -457,7 +427,8 @@ See the notes under default decls in TcClassDcl.lhs. \begin{code} makeInstanceDeclDefaultMethodExpr - :: InstOrigin s + :: SrcLoc + -> Class -> [TcIdOcc s] -> [Id] -> TcType s @@ -465,50 +436,33 @@ makeInstanceDeclDefaultMethodExpr -> Int -> NF_TcM s (TcExpr s) -makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag - = - -- def_op_id = defm_id inst_ty this_dict +makeInstanceDeclDefaultMethodExpr src_loc clas meth_ids defm_ids inst_ty this_dict tag + | not defm_is_err -- Not sure that the default method is just error message + = -- def_op_id = defm_id inst_ty this_dict returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict]) - where - idx = tag - 1 - meth_id = meth_ids !! idx - defm_id = defm_ids !! idx - -makeInstanceDeclNoDefaultExpr - :: InstOrigin s - -> [TcIdOcc s] - -> [Id] - -> TcType s - -> Class - -> Module - -> Int - -> NF_TcM s (TcExpr s) -makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag - = - -- Produce a warning if the default instance method - -- has been omitted when one exists in the class - warnTc (not err_defm_ok) - (omitDefaultMethodWarn clas_op clas_name inst_ty) + | otherwise -- There's definitely no default decl in the class, + -- so we produce a warning, and a better run=time error message too + = warnTc True (omitDefaultMethodWarn clas_op clas_name inst_ty) `thenNF_Tc_` + returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)) where idx = tag - 1 - meth_id = meth_ids !! idx - clas_op = (classOps clas) !! idx + meth_id = meth_ids !! idx defm_id = defm_ids !! idx - Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id + Just (_, _, defm_is_err) = isDefaultMethodId_maybe defm_id - error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "." - ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "." - ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\"" + error_msg = ppShow 80 (ppSep [ppr PprForUser clas_op, ppStr "at", ppr PprForUser src_loc]) - clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas) + clas_op = (classOps clas) !! idx + clas_name = getOccString clas \end{code} + %************************************************************************ %* * \subsection{Processing each method} @@ -595,14 +549,14 @@ processInstBinds1 clas avail_insts method_ids mbind FunMonoBind op _ _ locn -> (op, locn) PatMonoBind (VarPatIn op) _ locn -> (op, locn) - occ = getLocalName op - origin = InstanceDeclOrigin + occ = getOccName op + origin = InstanceDeclOrigin in tcAddSrcLoc locn $ -- Make a method id for the method let - maybe_tag = classOpTagByString_maybe clas occ + maybe_tag = classOpTagByOccName_maybe clas occ (Just tag) = maybe_tag method_id = method_ids !! (tag-1) method_ty = tcIdType method_id @@ -640,10 +594,12 @@ processInstBinds1 clas avail_insts method_ids mbind newLocalId occ method_tau `thenNF_Tc` \ local_id -> newLocalId occ method_ty `thenNF_Tc` \ copy_id -> let + tc_local_id = TcId local_id + tc_copy_id = TcId copy_id sig_tyvar_set = mkTyVarSet sig_tyvars in -- Typecheck the method - tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) -> + tcMethodBind tc_local_id method_tau mbind `thenTc` \ (mbind', lieIop) -> -- Check the overloading part of the signature. @@ -680,10 +636,10 @@ processInstBinds1 clas avail_insts method_ids mbind (AbsBinds method_tyvars method_dict_ids - [(local_id, copy_id)] + [(tc_local_id, tc_copy_id)] dict_binds (NonRecBind mbind')) - (HsVar copy_id))) + (HsVar tc_copy_id))) \end{code} \begin{code} @@ -744,7 +700,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc clas = lookupCE ce class_name -- Renamer ensures this can't fail -- Make some new type variables, named as in the specialised instance type - ty_names = extractMonoTyNames ???is_tyvarish_name??? ty + ty_names = extractHsTyNames ???is_tyvarish_name??? ty (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names in babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty) @@ -764,7 +720,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) -> let Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta - _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst + _ _ binds _ uprag) = maybe_unspec_inst subst = case matchTy unspec_inst_ty inst_ty of Just subst -> subst @@ -787,9 +743,9 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv in - mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas + mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag - `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> + `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) -> getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> (if sw_chkr SpecialiseTrace then @@ -806,8 +762,8 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc else id) ( returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta - dfun_theta dfun_id const_meth_ids - binds True{-from here-} mod src_loc uprag)) + dfun_theta dfun_id + binds src_loc uprag)) ))) @@ -853,13 +809,13 @@ compiled elsewhere). In these cases, we let them go through anyway. We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} -scrutiniseInstanceType from_here clas inst_tau +scrutiniseInstanceType dfun_name clas inst_tau -- TYCON CHECK | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon = failTc (instTypeErr inst_tau) -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1) - | not from_here + | not (isLocallyDefined dfun_name) = returnTc (inst_tycon,arg_tys) -- TYVARS CHECK @@ -879,10 +835,8 @@ scrutiniseInstanceType from_here clas inst_tau | -- CCALL CHECK -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. - isCcallishClass clas - && not (maybeToBool (maybeBoxedPrimType inst_tau) - || opt_CompilingGhcInternals) -- this lets us get up to mischief; - -- e.g., instance CCallable () + (uniqueOf clas == cCallableClassKey && not (ccallable_type inst_tau)) || + (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau)) = failTc (nonBoxedPrimCCallErr clas inst_tau) | otherwise @@ -892,6 +846,38 @@ scrutiniseInstanceType from_here clas inst_tau (possible_tycon, arg_tys) = splitAppTy inst_tau inst_tycon_maybe = getTyCon_maybe possible_tycon inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe + +-- These conditions come directly from what the DsCCall is capable of. +-- Totally grotesque. Green card should solve this. + +ccallable_type ty = maybeToBool (maybeBoxedPrimType ty) || + ty `eqTy` stringTy || + byte_arr_thing + where + byte_arr_thing = case maybeAppDataTyCon ty of + Just (tycon, ty_args, [data_con]) -> +-- pprTrace "cc1" (ppSep [ppr PprDebug tycon, ppr PprDebug data_con, +-- ppSep (map (ppr PprDebug) data_con_arg_tys)])( + length data_con_arg_tys == 2 && + maybeToBool maybe_arg2_tycon && +-- pprTrace "cc2" (ppSep [ppr PprDebug arg2_tycon]) ( + (arg2_tycon == byteArrayPrimTyCon || + arg2_tycon == mutableByteArrayPrimTyCon) +-- )) + where + data_con_arg_tys = dataConArgTys data_con ty_args + (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys + maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2 + Just (arg2_tycon,_) = maybe_arg2_tycon + + other -> False + +creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) || + -- Or, a data type with a single nullary constructor + case (maybeAppDataTyCon ty) of + Just (tycon, tys_applied, [data_con]) + -> isNullaryDataCon data_con + other -> False \end{code} \begin{code} @@ -915,19 +901,19 @@ derivingWhenInstanceImportedErr inst_mod clas tycon sty pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"] nonBoxedPrimCCallErr clas inst_ty sty - = ppHang (ppStr "Instance isn't for a `boxed-primitive' type") + = ppHang (ppStr "Unacceptable instance type for ccall-ish class") 4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `", ppr sty inst_ty, ppStr "'"]) omitDefaultMethodWarn clas_op clas_name inst_ty sty = ppCat [ppStr "Warning: Omitted default method for", ppr sty clas_op, ppStr "in instance", - ppPStr clas_name, pprParendGenType sty inst_ty] + ppStr clas_name, pprParendGenType sty inst_ty] instMethodNotInClassErr occ clas sty = ppHang (ppStr "Instance mentions a method not in the class") 4 (ppBesides [ppStr "class `", ppr sty clas, ppStr "' method `", - ppPStr occ, ppStr "'"]) + ppr sty occ, ppStr "'"]) patMonoBindsCtxt pbind sty = ppHang (ppStr "In a pattern binding:") diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 9af279f..f43b4cd 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -20,7 +20,8 @@ import HsSyn ( MonoBinds, Fake, InPat, Sig ) import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..), RenamedInstancePragmas(..) ) -import TcMonad hiding ( rnMtoTcM ) +import TcEnv ( tcLookupGlobalValueMaybe ) +import TcMonad import Inst ( SYN_IE(InstanceMapper) ) import Bag ( bagToList ) @@ -29,7 +30,7 @@ import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv), SYN_IE(ClassOp) ) import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp ) -import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal ) +import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, replaceIdInfo, getIdInfo ) import MatchEnv ( nullMEnv, insertMEnv ) import Maybes ( MaybeErr(..), mkLookupFunDef ) import Name ( getSrcLoc, Name{--O only-} ) @@ -63,10 +64,7 @@ data InstInfo -- element for each superclass; the "Mark -- Jones optimisation" Id -- The dfun id - [Id] -- Constant methods (either all or none) RenamedMonoBinds -- Bindings, b - Bool -- True <=> local instance decl - Module -- Name of module where this instance defined SrcLoc -- Source location assoc'd with this instance's defn [RenamedSig] -- User pragmas recorded for generating specialised instances \end{code} @@ -78,22 +76,30 @@ data InstInfo %************************************************************************ \begin{code} -mkInstanceRelatedIds :: Bool - -> SrcLoc - -> Module - -> RenamedInstancePragmas +mkInstanceRelatedIds :: Name -- Name to use for the dict fun; -> Class -> [TyVar] -> Type -> ThetaType - -> [RenamedSig] - -> TcM s (Id, ThetaType, [Id]) + -> NF_TcM s (Id, ThetaType) -mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas - clas inst_tyvars inst_ty inst_decl_theta uprags - = -- MAKE THE DFUN ID +mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta + = tcLookupGlobalValueMaybe dfun_name `thenNF_Tc` \ maybe_id -> let - dfun_theta = case inst_decl_theta of + -- Extract the dfun's IdInfo from the interface file, + -- provided it's imported. + -- We have to be lazy here; people look at the dfun Id itself + dfun_info = case maybe_id of + Nothing -> noIdInfo + Just imported_dfun_id -> getIdInfo imported_dfun_id + in + returnNF_Tc (new_dfun_id `replaceIdInfo` dfun_info, dfun_theta) + + where + (_, super_classes, _, _, _, _) = classBigSig clas + super_class_theta = super_classes `zip` repeat inst_ty + + dfun_theta = case inst_decl_theta of [] -> [] -- If inst_decl_theta is empty, then we don't -- want to have any dict arguments, so that we can -- expose the constant methods. @@ -102,73 +108,9 @@ mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas -- Otherwise we pass the superclass dictionaries to -- the dictionary function; the Mark Jones optimisation. - dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty) - in - tcGetUnique `thenNF_Tc` \ dfun_uniq -> - fixTc ( \ rec_dfun_id -> - -{- LATER - tcDictFunPragmas dfun_ty rec_dfun_id inst_pragmas - `thenNF_Tc` \ dfun_pragma_info -> - let - dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta - dfun_id_info = dfun_pragma_info `addInfo` dfun_specenv - in --} - let dfun_id_info = noIdInfo in -- For now - - returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info) - ) `thenTc` \ dfun_id -> - --- pprTrace "DFUN: " (ppr PprDebug dfun_id) $ - - -- MAKE THE CONSTANT-METHOD IDS - -- if there are no type variables involved - (if (null inst_decl_theta) - then - mapTc mk_const_meth_id class_ops - else - returnTc [] - ) `thenTc` \ const_meth_ids -> - - returnTc (dfun_id, dfun_theta, const_meth_ids) - where - (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas - tenv = [(class_tyvar, inst_ty)] - - super_class_theta = super_classes `zip` repeat inst_ty + dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty) - mk_const_meth_id op - = tcGetUnique `thenNF_Tc` \ uniq -> - fixTc (\ rec_const_meth_id -> - -{- LATER - -- Figure out the IdInfo from the pragmas - (case assocMaybe opname_prag_pairs (getName op) of - Nothing -> returnTc inline_info - Just prag -> tcGenPragmas (Just meth_ty) rec_const_meth_id prag - ) `thenNF_Tc` \ id_info -> --} - let id_info = noIdInfo -- For now - in - returnTc (mkConstMethodId uniq clas op inst_ty meth_ty - from_here src_loc inst_mod id_info) - ) - where - op_ty = classOpLocalType op - meth_ty = mkForAllTys inst_tyvars (instantiateTy tenv op_ty) -{- LATER - inline_me = isIn "mkInstanceRelatedIds" op ops_to_inline - inline_info = if inline_me - then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways) - else noIdInfo - - opname_prag_pairs = case inst_pragmas of - ConstantInstancePragma _ name_prag_pairs -> name_prag_pairs - other_inst_pragmas -> [] - - ops_to_inline = [op | (InlineSig op _) <- uprags] --} + new_dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty \end{code} @@ -185,7 +127,7 @@ buildInstanceEnvs :: Bag InstInfo buildInstanceEnvs info = let icmp :: InstInfo -> InstInfo -> TAG_ - (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _) + (InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _) = c1 `cmp` c2 info_by_class = equivClasses icmp (bagToList info) @@ -202,7 +144,7 @@ buildInstanceEnvs info buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv))) -buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _) +buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _) = foldlTc addClassInstance (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas]) inst_infos @@ -223,9 +165,9 @@ addClassInstance -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)]) addClassInstance - (class_inst_env, op_spec_envs) + input_stuff@(class_inst_env, op_spec_envs) (InstInfo clas inst_tyvars inst_ty _ _ - dfun_id const_meth_ids _ _ _ src_loc _) + dfun_id _ src_loc _) = -- We only add specialised/overlapped instances @@ -240,10 +182,15 @@ addClassInstance -- Add the instance to the class's instance environment case insertMEnv matchTy class_inst_env inst_ty dfun_id of { - Failed (ty', dfun_id') -> dupInstFailure clas (inst_ty, src_loc) + Failed (ty', dfun_id') -> recoverTc (returnTc input_stuff) $ + dupInstFailure clas (inst_ty, src_loc) (ty', getSrcLoc dfun_id'); Succeeded class_inst_env' -> + returnTc (class_inst_env', op_spec_envs) + +{- OLD STUFF FOR CONSTANT METHODS + -- If there are any constant methods, then add them to -- the SpecEnv of each class op (ie selector) -- @@ -283,6 +230,8 @@ addClassInstance rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars)) in returnTc (class_inst_env', op_spec_envs') + END OF OLD STUFF -} + } \end{code} diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs index 5f66907..f284526 100644 --- a/ghc/compiler/typecheck/TcKind.lhs +++ b/ghc/compiler/typecheck/TcKind.lhs @@ -19,7 +19,7 @@ module TcKind ( IMP_Ubiq(){-uitous-} import Kind -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Unique ( Unique, pprUnique10 ) import Pretty diff --git a/ghc/compiler/typecheck/TcLoop.lhi b/ghc/compiler/typecheck/TcLoop.lhi index 452dc7a..bdf0d5d 100644 --- a/ghc/compiler/typecheck/TcLoop.lhi +++ b/ghc/compiler/typecheck/TcLoop.lhi @@ -9,10 +9,10 @@ import HsMatches(GRHSsAndBinds) import HsPat(InPat, OutPat) import HsSyn(Fake) import TcHsSyn(TcIdOcc) -import RnHsSyn(RnName) import TcType(TcMaybe) import SST(FSST_R) import Unique(Unique) +import Name(Name) import TyVar(GenTyVar) import TcEnv(TcEnv) import TcMonad(TcDown) @@ -21,7 +21,7 @@ import Bag(Bag) import Type(GenType) import Inst(Inst) -tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake RnName (InPat RnName) +tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake Name (InPat Name) -> TcDown a -> TcEnv a -> State# a diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 1eba821..8a7d520 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -13,16 +13,17 @@ IMP_Ubiq() import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat, HsExpr, HsBinds, OutPat, Fake, collectPatBinders, pprMatch ) -import RnHsSyn ( SYN_IE(RenamedMatch), RnName{-instance Outputable-} ) +import RnHsSyn ( SYN_IE(RenamedMatch) ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( Inst, SYN_IE(LIE), plusLIE ) import TcEnv ( newMonoIds ) IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) import TcPat ( tcPat ) import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType ) import Unify ( unifyTauTy, unifyTauTyList ) +import Name ( Name {- instance Outputable -} ) import Kind ( Kind, mkTypeKind ) import Pretty @@ -36,7 +37,7 @@ is used in error messages. It checks that all the equations have the same number of arguments before using @tcMatches@ to do the work. \begin{code} -tcMatchesFun :: RnName +tcMatchesFun :: Name -> TcType s -- Expected type -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s) @@ -80,7 +81,7 @@ tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches \begin{code} -data FunOrCase = MCase | MFun RnName -- Records whether doing fun or case rhss; +data FunOrCase = MCase | MFun Name -- Records whether doing fun or case rhss; -- used to produced better error messages tcMatchesExpected :: TcType s diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 113c82e..09140f1 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -10,15 +10,14 @@ module TcModule ( typecheckModule, SYN_IE(TcResults), SYN_IE(TcResultBinds), - SYN_IE(TcIfaceInfo), SYN_IE(TcSpecialiseRequests), SYN_IE(TcDDumpDeriv) ) where IMP_Ubiq(){-uitous-} -import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, - TyDecl, SpecDataSig, ClassDecl, InstDecl, +import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), Bind, HsExpr, + TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig, SpecInstSig, DefaultDecl, Sig, Fake, InPat, FixityDecl, IE, ImportDecl ) @@ -26,7 +25,7 @@ import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) ) import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr), TcIdOcc(..), zonkBinds, zonkDictBinds ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( Inst, plusLIE ) import TcBinds ( tcBindsAndThen ) import TcClassDcl ( tcClassDecls2 ) @@ -42,14 +41,14 @@ import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls1 ) import TcTyDecls ( mkDataBinds ) +import RnMonad ( RnNameSupply(..) ) import Bag ( listToBag ) import Class ( GenClass, classSelIds ) import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) ) -import Id ( idType, isMethodSelId, isTopLevId, GenId, SYN_IE(IdEnv), nullIdEnv ) +import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv ) import Maybes ( catMaybes ) import Name ( isLocallyDefined ) import Pretty -import RnUtils ( SYN_IE(RnEnv) ) import TyCon ( TyCon ) import Type ( applyTyCon ) import TysWiredIn ( unitTy, mkPrimIoTy ) @@ -69,7 +68,8 @@ Outside-world interface: -- Convenient type synonyms first: type TcResults = (TcResultBinds, - TcIfaceInfo, + [TyCon], + Bag InstInfo, -- Instance declaration information TcSpecialiseRequests, TcDDumpDeriv) @@ -83,9 +83,6 @@ type TcResultBinds [(Id, TypecheckedHsExpr)]) -- constant instance binds -type TcIfaceInfo -- things for the interface generator - = ([Id], [TyCon], [Class], Bag InstInfo) - type TcSpecialiseRequests = FiniteMap TyCon [(Bool, [Maybe Type])] -- source tycon specialisation requests @@ -96,7 +93,7 @@ type TcDDumpDeriv --------------- typecheckModule :: UniqSupply - -> RnEnv -- for renaming derivings + -> RnNameSupply -> RenamedHsModule -> MaybeErr (TcResults, -- if all goes well... @@ -104,24 +101,19 @@ typecheckModule (Bag Error, -- if we had errors... Bag Warning) -typecheckModule us rn_env mod - = initTc us (tcModule rn_env mod) +typecheckModule us rn_name_supply mod + = initTc us (tcModule rn_name_supply mod) \end{code} The internal monster: \begin{code} -tcModule :: RnEnv -- for renaming derivings +tcModule :: RnNameSupply -- for renaming derivings -> RenamedHsModule -- input -> TcM s TcResults -- output -tcModule rn_env - (HsModule mod_name verion exports imports fixities - ty_decls specdata_sigs cls_decls inst_decls specinst_sigs - default_decls val_decls sigs src_loc) - - = ASSERT(null imports) - - tcAddSrcLoc src_loc $ -- record where we're starting +tcModule rn_name_supply + (HsModule mod_name verion exports imports fixities decls src_loc) + = tcAddSrcLoc src_loc $ -- record where we're starting -- Tie the knot for inteface-file value declaration signatures -- This info is only used inside the knot for type-checking the @@ -140,30 +132,28 @@ tcModule rn_env fixTc ( \ ~(rec_inst_mapper, _, _, _, _) -> -- Type-check the type and class decls - --trace "tcTyAndClassDecls:" $ - tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag - `thenTc` \ env -> + -- trace "tcTyAndClassDecls:" $ + tcTyAndClassDecls1 rec_inst_mapper decls `thenTc` \ env -> - --trace "tc3" $ + -- trace "tc3" $ -- Typecheck the instance decls, includes deriving tcSetEnv env ( - --trace "tcInstDecls:" $ - tcInstDecls1 inst_decls_bag specinst_sigs - mod_name rn_env fixities - ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> + -- trace "tcInstDecls:" $ + tcInstDecls1 decls mod_name rn_name_supply + ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> - --trace "tc4" $ + -- trace "tc4" $ buildInstanceEnvs inst_info `thenTc` \ inst_mapper -> returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv) ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) -> - --trace "tc5" $ + -- trace "tc5" $ tcSetEnv env ( -- Default declarations - tcDefaults default_decls `thenTc` \ defaulting_tys -> + tcDefaults decls `thenTc` \ defaulting_tys -> tcSetDefaultTys defaulting_tys ( -- for the iface sigs... -- Create any necessary record selector Ids and their bindings @@ -187,29 +177,29 @@ tcModule rn_env -- What we rely on is that pragmas are typechecked lazily; if -- any type errors are found (ie there's an inconsistency) -- we silently discard the pragma - tcInterfaceSigs sigs `thenTc` \ sig_ids -> + tcInterfaceSigs decls `thenTc` \ sig_ids -> tcGetEnv `thenNF_Tc` \ env -> - --trace "tc6" $ + -- trace "tc6" $ returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids) )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) -> - --trace "tc7" $ + -- trace "tc7" $ tcSetEnv env ( -- to the end... tcSetDefaultTys defaulting_tys ( -- ditto -- Value declarations next. -- We also typecheck any extra binds that came out of the "deriving" process - --trace "tcBinds:" $ + -- trace "tcBinds:" $ tcBindsAndThen (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing)) - (val_decls `ThenBinds` deriv_binds) + (get_val_decls decls `ThenBinds` deriv_binds) ( -- Second pass over instance declarations, -- to compile the bindings themselves. - --trace "tc8" $ + -- trace "tc8" $ tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> - tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> + tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> tcGetEnv `thenNF_Tc` \ env -> returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)), lie_instdecls `plusLIE` lie_clasdecls, @@ -223,7 +213,7 @@ tcModule rn_env -- restriction, and no subsequent decl instantiates its -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) - --trace "tc9" $ + -- trace "tc9" $ tcSimplifyTop lie_alldecls `thenTc` \ const_insts -> -- Backsubstitution. Monomorphic top-level decls may have @@ -252,22 +242,15 @@ tcModule rn_env local_tycons = filter isLocallyDefined tycons local_classes = filter isLocallyDefined classes - local_vals = [ v | v <- eltsUFM ve2, isLocallyDefined v && isTopLevId v ] - -- the isTopLevId is doubtful... in -- FINISHED AT LAST returnTc ( (data_binds', cls_binds', inst_binds', val_binds', const_insts'), - -- the next collection is just for mkInterface - (local_vals, local_tycons, local_classes, inst_info), - - tycon_specs, + local_tycons, inst_info, tycon_specs, ddump_deriv ))) - where - ty_decls_bag = listToBag ty_decls - cls_decls_bag = listToBag cls_decls - inst_decls_bag = listToBag inst_decls + +get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \end{code} diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index e595a83..5bd270c 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -10,7 +10,8 @@ module TcMonad( foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc, mapBagTc, fixTc, tryTc, - returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, + returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc, + listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc, checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, @@ -26,8 +27,6 @@ module TcMonad( tcNewMutVar, tcReadMutVar, tcWriteMutVar, - rnMtoTcM, - SYN_IE(TcError), SYN_IE(TcWarning), mkTcErr, arityErr, @@ -50,18 +49,11 @@ import Usage ( SYN_IE(Usage), GenUsage ) import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) ) import SST -import RnMonad ( SYN_IE(RnM), RnDown, initRn, setExtraRn, - returnRn, thenRn, getImplicitUpRn - ) -import RnUtils ( SYN_IE(RnEnv) ) - import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} ) ---import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) import Maybes ( MaybeErr(..) ) ---import Name ( Name ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply ) import Unique ( Unique ) @@ -103,7 +95,7 @@ initTc us do_this newMutVarSST emptyUFM `thenSST` \ tvs_var -> let init_down = TcDown [] us_var - mkUnknownSrcLoc + noSrcLoc [] errs_var init_env = initEnv tvs_var in @@ -229,12 +221,20 @@ fixTc :: (a -> TcM s a) -> TcM s a fixTc m env down = fixFSST (\ loop -> m loop env down) \end{code} -@forkNF_Tc@ runs a sub-typecheck action in a separate state thread. -This elegantly ensures that it can't zap any type variables that -belong to the main thread. We throw away any error messages! +@forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state +thread. Ideally, this elegantly ensures that it can't zap any type +variables that belong to the main thread. But alas, the environment +contains TyCon and Class environments that include (TcKind s) stuff, +which is a Royal Pain. By the time this fork stuff is used they'll +have been unified down so there won't be any kind variables, but we +can't express that in the current typechecker framework. + +So we compromise and use unsafeInterleaveSST. -\begin{pseudocode} -forkNF_Tc :: NF_TcM s' r -> NF_TcM s r +We throw away any error messages! + +\begin{code} +forkNF_Tc :: NF_TcM s r -> NF_TcM s r forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env = -- Get a fresh unique supply readMutVarSST u_var `thenSST` \ us -> @@ -242,39 +242,18 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env (us1, us2) = splitUniqSupply us in writeMutVarSST u_var us1 `thenSST_` - returnSST ( runSST ( - newMutVarSST us2 `thenSST` \ u_var' -> + + unsafeInterleaveSST ( + newMutVarSST us2 `thenSST` \ us_var' -> newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' -> newMutVarSST emptyUFM `thenSST` \ tv_var' -> let - down' = TcDown deflts us_var src_loc err_cxt err_var' - env' = forkEnv env tv_var' + down' = TcDown deflts us_var' src_loc err_cxt err_var' in - m down' env' - + m down' env -- ToDo: optionally dump any error messages - )) -\end{pseudocode} - -@forkTcDown@ makes a new "down" blob for a lazily-computed fork -of the type checker. - -\begin{pseudocode} -forkTcDown (TcDown deflts u_var src_loc err_cxt err_var) - = -- Get a fresh unique supply - readMutVarSST u_var `thenSST` \ us -> - let - (us1, us2) = splitUniqSupply us - in - writeMutVarSST u_var us1 `thenSST_` - - -- Make fresh MutVars for the unique supply and errors - newMutVarSST us2 `thenSST` \ u_var' -> - newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' -> - - -- Done - returnSST (TcDown deflts u_var' src_loc err_cxt err_var') -\end{pseudocode} + ) +\end{code} Error handling @@ -470,39 +449,6 @@ getErrCtxt (TcDown def us loc ctxt errs) = ctxt \end{code} -\section{rn4MtoTcM} -%~~~~~~~~~~~~~~~~~~ - -\begin{code} -rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error) - -rnMtoTcM rn_env rn_action down env - = readMutVarSST u_var `thenSST` \ uniq_supply -> - let - (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply - in - writeMutVarSST u_var new_uniq_supply `thenSST_` - let - (rn_result, rn_errs, rn_warns) - = initRn False{-*interface* mode! so we can see the builtins-} - (panic "rnMtoTcM:module") - rn_env uniq_s ( - rn_action `thenRn` \ result -> - - -- Though we are in "interface mode", we must - -- not have added anything to the ImplicitEnv! - getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) -> - if (isEmptyFM v_env && isEmptyFM tc_env) - then returnRn result - else panic "rnMtoTcM: non-empty ImplicitEnv!" --- (ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env] --- ++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env])) - ) - in - returnSST (rn_result, rn_errs) - where - u_var = getUniqSupplyVar down -\end{code} TypeChecking Errors diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index d933c2f..f426434 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -6,107 +6,94 @@ \begin{code} #include "HsVersions.h" -module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where +module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where IMP_Ubiq(){-uitous-} -import HsSyn ( PolyType(..), MonoType(..), Fake ) -import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..), - RenamedContext(..), RnName(..), - isRnLocal, isRnClass, isRnTyCon - ) +import HsSyn ( HsType(..), HsTyVar(..), Fake ) +import RnHsSyn ( RenamedHsType(..), RenamedContext(..) ) -import TcMonad hiding ( rnMtoTcM ) -import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, - tcTyVarScope, tcTyVarScopeGivenKinds - ) +import TcMonad +import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv ) import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind, mkTcArrowKind, unifyKind, newKindVar, - kindToTcKind + kindToTcKind, tcDefaultKind ) import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType), mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy, mkSigmaTy, mkDictTy ) -import TyVar ( GenTyVar, SYN_IE(TyVar) ) -import Class ( cCallishClassKeys ) +import TyVar ( GenTyVar, SYN_IE(TyVar), mkTyVar ) +import PrelInfo ( cCallishClassKeys ) import TyCon ( TyCon ) +import Name ( Name, OccName, isTvOcc ) import TysWiredIn ( mkListTy, mkTupleTy ) import Unique ( Unique ) import PprStyle import Pretty -import Util ( zipWithEqual, panic{-, pprPanic ToDo:rm-} ) +import Util ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} ) \end{code} -tcMonoType and tcMonoTypeKind +tcHsType and tcHsTypeKind ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcMonoType checks that the type really is of kind Type! +tcHsType checks that the type really is of kind Type! \begin{code} -tcMonoType :: RenamedMonoType -> TcM s Type +tcHsType :: RenamedHsType -> TcM s Type -tcMonoType ty - = tcMonoTypeKind ty `thenTc` \ (kind,ty) -> +tcHsType ty + = tcHsTypeKind ty `thenTc` \ (kind,ty) -> unifyKind kind mkTcTypeKind `thenTc_` returnTc ty \end{code} -tcMonoTypeKind does the real work. It returns a kind and a type. +tcHsTypeKind does the real work. It returns a kind and a type. \begin{code} -tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type) +tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type) -tcMonoTypeKind (MonoTyVar name) +tcHsTypeKind (MonoTyVar name) = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> returnTc (kind, mkTyVarTy tyvar) -tcMonoTypeKind (MonoListTy ty) - = tcMonoType ty `thenTc` \ tau_ty -> +tcHsTypeKind (MonoListTy _ ty) + = tcHsType ty `thenTc` \ tau_ty -> returnTc (mkTcTypeKind, mkListTy tau_ty) -tcMonoTypeKind (MonoTupleTy tys) - = mapTc tcMonoType tys `thenTc` \ tau_tys -> +tcHsTypeKind (MonoTupleTy _ tys) + = mapTc tcHsType tys `thenTc` \ tau_tys -> returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys) -tcMonoTypeKind (MonoFunTy ty1 ty2) - = tcMonoType ty1 `thenTc` \ tau_ty1 -> - tcMonoType ty2 `thenTc` \ tau_ty2 -> +tcHsTypeKind (MonoFunTy ty1 ty2) + = tcHsType ty1 `thenTc` \ tau_ty1 -> + tcHsType ty2 `thenTc` \ tau_ty2 -> returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2) -tcMonoTypeKind (MonoTyApp name tys) - | isRnLocal name -- Must be a type variable +tcHsTypeKind (MonoTyApp name tys) + | isTvOcc (getOccName name) -- Must be a type variable = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> tcMonoTyApp kind (mkTyVarTy tyvar) tys - | otherwise {-isRnTyCon name-} -- Must be a type constructor - = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) -> + | otherwise -- Must be a type constructor + = tcLookupTyCon name `thenTc` \ (kind,maybe_arity,tycon) -> case maybe_arity of Just arity -> tcSynApp name kind arity tycon tys -- synonum Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data --- | otherwise --- = pprPanic "tcMonoTypeKind:" (ppr PprDebug name) - --- for unfoldings only: -tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty) - = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars -> - tcMonoTypeKind ty `thenTc` \ (kind, ty') -> - unifyKind kind mkTcTypeKind `thenTc_` - returnTc (mkTcTypeKind, ty') - ) - where - (rn_names, kinds) = unzip tyvars_w_kinds - names = map de_rn rn_names - tc_kinds = map kindToTcKind kinds - de_rn (RnName n) = n +tcHsTypeKind (HsForAllTy tv_names context ty) + = tcTyVarScope tv_names $ \ tyvars -> + tcContext context `thenTc` \ theta -> + tcHsType ty `thenTc` \ tau -> + -- For-all's are of kind type! + returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau) -- for unfoldings only: -tcMonoTypeKind (MonoDictTy class_name ty) - = tcMonoTypeKind ty `thenTc` \ (arg_kind, arg_ty) -> - tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) -> +tcHsTypeKind (MonoDictTy class_name ty) + = tcHsTypeKind ty `thenTc` \ (arg_kind, arg_ty) -> + tcLookupClass class_name `thenTc` \ (class_kind, clas) -> unifyKind class_kind arg_kind `thenTc_` returnTc (mkTcTypeKind, mkDictTy clas arg_ty) \end{code} @@ -115,13 +102,13 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} tcMonoTyApp fun_kind fun_ty tys - = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> + = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> newKindVar `thenNF_Tc` \ result_kind -> unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_` returnTc (result_kind, foldl mkAppTy fun_ty arg_tys) tcSynApp name syn_kind arity tycon tys - = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> + = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> newKindVar `thenNF_Tc` \ result_kind -> unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_` @@ -141,16 +128,16 @@ Contexts tcContext :: RenamedContext -> TcM s ThetaType tcContext context = mapTc tcClassAssertion context -tcClassAssertion (class_name, tyvar_name) +tcClassAssertion (class_name, ty) = checkTc (canBeUsedInContext class_name) (naughtyCCallContextErr class_name) `thenTc_` - tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) -> - tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, tyvar) -> + tcLookupClass class_name `thenTc` \ (class_kind, clas) -> + tcHsTypeKind ty `thenTc` \ (ty_kind, ty) -> - unifyKind class_kind tyvar_kind `thenTc_` + unifyKind class_kind ty_kind `thenTc_` - returnTc (clas, mkTyVarTy tyvar) + returnTc (clas, ty) \end{code} HACK warning: Someone discovered that @CCallable@ and @CReturnable@ @@ -163,24 +150,43 @@ Doing this utterly wrecks the whole point of introducing these classes so we specifically check that this isn't being done. \begin{code} -canBeUsedInContext :: RnName -> Bool -canBeUsedInContext n - = isRnClass n && not (uniqueOf n `elem` cCallishClassKeys) +canBeUsedInContext :: Name -> Bool +canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys) \end{code} -Polytypes -~~~~~~~~~ +Type variables, with knot tying! +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcPolyType :: RenamedPolyType -> TcM s Type -tcPolyType (HsForAllTy tyvar_names context ty) - = tcTyVarScope names (\ tyvars -> - tcContext context `thenTc` \ theta -> - tcMonoType ty `thenTc` \ tau -> - returnTc (mkSigmaTy tyvars theta tau) - ) - where - names = map de_rn tyvar_names - de_rn (RnName n) = n +tcTyVarScope + :: [HsTyVar Name] -- Names of some type variables + -> ([TyVar] -> TcM s a) -- Thing to type check in their scope + -> TcM s a -- Result + +tcTyVarScope tyvar_names thing_inside + = mapAndUnzipNF_Tc tcHsTyVar tyvar_names `thenNF_Tc` \ (names, kinds) -> + + fixTc (\ ~(rec_tyvars, _) -> + -- Ok to look at names, kinds, but not tyvars! + + tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars) + (thing_inside rec_tyvars) `thenTc` \ result -> + + -- Get the tyvar's Kinds from their TcKinds + mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' -> + + -- Construct the real TyVars + let + tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds' + in + returnTc (tyvars, result) + ) `thenTc` \ (_,result) -> + returnTc result + +tcHsTyVar (UserTyVar name) + = newKindVar `thenNF_Tc` \ tc_kind -> + returnNF_Tc (name, tc_kind) +tcHsTyVar (IfaceTyVar name kind) + = returnNF_Tc (name, kindToTcKind kind) \end{code} Errors and contexts diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index becc2d6..1a5f055 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -11,16 +11,17 @@ module TcPat ( tcPat ) where IMP_Ubiq(){-uitous-} import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, Qualifier, PolyType, + Match, HsBinds, Qualifier, HsType, ArithSeqInfo, Stmt, Fake ) -import RnHsSyn ( SYN_IE(RenamedPat), RnName{-instance Outputable-} ) +import RnHsSyn ( SYN_IE(RenamedPat) ) import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( Inst, OverloadedLit(..), InstOrigin(..), emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE), newMethod, newOverloadedLit ) +import Name ( Name {- instance Outputable -} ) import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupLocalValueOK ) import SpecEnv ( SpecEnv ) @@ -326,7 +327,7 @@ tcPats (pat:pats) unifies the actual args against the expected ones. \begin{code} -matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s) +matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s) matchConArgTys con arg_tys = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 061dc65..93f04cd 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -15,11 +15,11 @@ module TcSimplify ( IMP_Ubiq() import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, - Match, HsBinds, Qualifier, PolyType, ArithSeqInfo, + Match, HsBinds, Qualifier, HsType, ArithSeqInfo, GRHSsAndBinds, Stmt, Fake ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( lookupInst, lookupSimpleInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst, instToId, instBindingRequired, @@ -36,19 +36,20 @@ import Unify ( unifyTauTy ) import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, snocBag, consBag, unionBags, isEmptyBag ) import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv), - isNumericClass, isStandardClass, isCcallishClass, isSuperClassOf, classSuperDictSelId, classInstEnv ) import Id ( GenId ) +import PrelInfo ( isNumericClass, isStandardClass, isCcallishClass ) + import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool ) import Outputable ( Outputable(..){-instance * []-} ) --import PprStyle--ToDo:rm import PprType ( GenType, GenTyVar ) import Pretty -import SrcLoc ( mkUnknownSrcLoc ) +import SrcLoc ( noSrcLoc ) import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy, getTyVar_maybe ) -import TysWiredIn ( intTy ) +import TysWiredIn ( intTy, unitTy ) import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), elementOfTyVarSet, emptyTyVarSet, unionTyVarSets, isEmptyTyVarSet, tyVarSetToList ) @@ -660,10 +661,7 @@ Since we're not using the result of @foo@, the result if (presumably) disambigOne :: [SimpleDictInfo s] -> TcM s () disambigOne dict_infos - | not (isStandardNumericDefaultable classes) - = failTc (ambigErr dicts) -- no default - - | otherwise -- isStandardNumericDefaultable dict_infos + | any isNumericClass classes && all isStandardClass classes = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT -- SO, TRY DEFAULT TYPES IN ORDER @@ -674,7 +672,7 @@ disambigOne dict_infos tcGetDefaultTys `thenNF_Tc` \ default_tys -> let try_default [] -- No defaults work, so fail - = failTc (defaultErr dicts default_tys) + = failTc (ambigErr dicts) try_default (default_ty : default_tys) = tryTc (try_default default_tys) $ -- If default_ty fails, we try @@ -689,6 +687,14 @@ disambigOne dict_infos tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome! unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) + | all isCcallishClass classes + = -- Default CCall stuff to (); we don't even both to check that () is an + -- instance of CCallable/CReturnable, because we know it is. + unifyTauTy (mkTyVarTy tyvar) unitTy + + | otherwise -- No defaults + = failTc (ambigErr dicts) + where (_,_,tyvar) = head dict_infos -- Should be non-empty dicts = [dict | (dict,_,_) <- dict_infos] @@ -696,19 +702,6 @@ disambigOne dict_infos \end{code} -@isStandardNumericDefaultable@ sees whether the dicts have the -property required for defaulting; namely at least one is numeric, and -all are standard; or all are CcallIsh. - -\begin{code} -isStandardNumericDefaultable :: [Class] -> Bool - -isStandardNumericDefaultable classes - = --pprTrace "isStdNumeric:\n" (ppAboves [ppCat (map (ppr PprDebug) classes), ppCat (map (ppr PprDebug . isNumericClass) classes), ppCat (map (ppr PprDebug . isStandardClass) classes), ppCat (map (ppr PprDebug . isCcallishClass) classes)]) $ - (any isNumericClass classes && all isStandardClass classes) - || (all isCcallishClass classes) -\end{code} - Errors and contexts @@ -737,14 +730,4 @@ reduceErr insts sty (bagToList insts)) \end{code} -\begin{code} -defaultErr dicts defaulting_tys sty - = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:") - 4 (ppAboves [ - ppHang (ppStr "Conflicting:") - 4 (ppInterleave ppSemi (map (pprInst sty ""{-???-}) dicts)), - ppHang (ppStr "Defaulting types :") - 4 (ppr sty defaulting_tys), - ppStr "([Int, Double] is the default list of defaulting types.)" ]) -\end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index d4d3c25..afaf13e 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -12,27 +12,28 @@ module TcTyClsDecls ( IMP_Ubiq(){-uitous-} -import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), - ClassDecl(..), MonoType(..), PolyType(..), - Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr ) -import RnHsSyn ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..), - RnName(..){-instance Uniquable-} +import HsSyn ( HsDecl(..), TyDecl(..), ConDecl(..), BangType(..), + ClassDecl(..), HsType(..), HsTyVar, DefaultDecl, InstDecl, + IfaceSig, Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr, + hsDeclName + ) +import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..), SYN_IE(RenamedHsDecl) ) import TcHsSyn ( SYN_IE(TcHsBinds), TcIdOcc(..) ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( SYN_IE(InstanceMapper) ) import TcClassDcl ( tcClassDecl1 ) -import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv, - tcTyVarScope ) +import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv ) import SpecEnv ( SpecEnv ) import TcKind ( TcKind, newKindVars ) import TcTyDecls ( tcTyDecl, mkDataBinds ) +import TcMonoType ( tcTyVarScope ) import Bag import Class ( SYN_IE(Class), classSelIds ) import Digraph ( findSCCs, SCC(..) ) -import Name ( getSrcLoc ) +import Name ( Name, getSrcLoc, isTvOcc, nameOccName ) import PprStyle import Pretty import UniqSet ( SYN_IE(UniqSet), emptyUniqSet, @@ -48,23 +49,13 @@ import Util ( panic{-, pprTrace-} ) The main function ~~~~~~~~~~~~~~~~~ \begin{code} -data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl - tcTyAndClassDecls1 :: InstanceMapper - -> Bag RenamedTyDecl -> Bag RenamedClassDecl + -> [RenamedHsDecl] -> TcM s (TcEnv s) -tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls - = sortByDependency syn_decls cls_decls decls `thenTc` \ groups -> +tcTyAndClassDecls1 inst_mapper decls + = sortByDependency decls `thenTc` \ groups -> tcGroups inst_mapper groups - where - cls_decls = mapBag ClD rncls_decls - ty_decls = mapBag TyD rnty_decls - syn_decls = filterBag is_syn_decl ty_decls - decls = ty_decls `unionBags` cls_decls - - is_syn_decl (TyD (TySynonym _ _ _ _)) = True - is_syn_decl _ = False tcGroups inst_mapper [] = tcGetEnv `thenNF_Tc` \ env -> @@ -83,7 +74,7 @@ tcGroups inst_mapper (group:groups) Dealing with a group ~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s) +tcGroup :: InstanceMapper -> Bag RenamedHsDecl -> TcM s (TcEnv s) tcGroup inst_mapper decls = -- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $ @@ -119,10 +110,7 @@ tcGroup inst_mapper decls returnTc final_env where - (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls - - tyvar_names = map de_rn tyvar_rn_names - de_rn (RnName n) = n + (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls combine do_a do_b = do_a `thenTc` \ (a1,a2) -> @@ -134,7 +122,7 @@ Dealing with one decl ~~~~~~~~~~~~~~~~~~~~~ \begin{code} tcDecl :: InstanceMapper - -> Decl + -> RenamedHsDecl -> TcM s (Bag TyCon, Bag Class) tcDecl inst_mapper (TyD decl) @@ -149,54 +137,73 @@ tcDecl inst_mapper (ClD decl) Dependency analysis ~~~~~~~~~~~~~~~~~~~ \begin{code} -sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl] -sortByDependency syn_decls cls_decls decls +sortByDependency :: [RenamedHsDecl] -> TcM s [Bag RenamedHsDecl] +sortByDependency decls = let -- CHECK FOR SYNONYM CYCLES syn_sccs = findSCCs mk_edges syn_decls - syn_cycles = [map fmt_decl (bagToList decls) - | CyclicSCC decls <- syn_sccs] + syn_cycles = [ map fmt_decl (bagToList decls) + | CyclicSCC decls <- syn_sccs] in checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_` let -- CHECK FOR CLASS CYCLES cls_sccs = findSCCs mk_edges cls_decls - cls_cycles = [map fmt_decl (bagToList decls) - | CyclicSCC decls <- cls_sccs] + cls_cycles = [ map fmt_decl (bagToList decls) + | CyclicSCC decls <- cls_sccs] in checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_` -- DO THE MAIN DEPENDENCY ANALYSIS let - decl_sccs = findSCCs mk_edges decls + decl_sccs = findSCCs mk_edges ty_cls_decls scc_bags = map bag_acyclic decl_sccs in returnTc (scc_bags) - + where - bag_acyclic (AcyclicSCC scc) = unitBag scc - bag_acyclic (CyclicSCC sccs) = sccs + syn_decls = listToBag (filter is_syn_decl decls) + ty_cls_decls = listToBag (filter is_ty_cls_decl decls) + cls_decls = listToBag (filter is_cls_decl decls) + + + +bag_acyclic (AcyclicSCC scc) = unitBag scc +bag_acyclic (CyclicSCC sccs) = sccs + +is_syn_decl (TyD (TySynonym _ _ _ _)) = True +is_syn_decl _ = False + +is_ty_cls_decl (TyD _) = True +is_ty_cls_decl (ClD _) = True +is_ty_cls_decl other = False + +is_cls_decl (ClD _) = True +is_cls_decl other = False fmt_decl decl = (ppr PprForUser name, getSrcLoc name) where - name = get_name decl - get_name (TyD (TyData _ name _ _ _ _ _)) = name - get_name (TyD (TyNew _ name _ _ _ _ _)) = name - get_name (TyD (TySynonym name _ _ _)) = name - get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name + name = hsDeclName decl \end{code} Edges in Type/Class decls ~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} mk_edges (TyD (TyData ctxt name _ condecls derivs _ _)) - = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs)) + = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` + get_cons condecls `unionUniqSets` + get_deriv derivs)) + mk_edges (TyD (TyNew ctxt name _ condecl derivs _ _)) - = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl `unionUniqSets` get_deriv derivs)) + = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` + get_con condecl `unionUniqSets` + get_deriv derivs)) + mk_edges (TyD (TySynonym name _ rhs _)) = (uniqueOf name, set_to_bag (get_ty rhs)) + mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _)) = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs)) @@ -208,35 +215,33 @@ get_deriv (Just clss) = unionManyUniqSets (map set_name clss) get_cons cons = unionManyUniqSets (map get_con cons) - where - get_con (ConDecl _ btys _) - = unionManyUniqSets (map get_bty btys) - get_con (ConOpDecl bty1 _ bty2 _) - = unionUniqSets (get_bty bty1) (get_bty bty2) - get_con (NewConDecl _ ty _) - = get_ty ty - get_con (RecConDecl _ nbtys _) - = unionManyUniqSets (map (get_bty.snd) nbtys) - - get_bty (Banged ty) = get_pty ty - get_bty (Unbanged ty) = get_pty ty + +get_con (ConDecl _ btys _) + = unionManyUniqSets (map get_bty btys) +get_con (ConOpDecl bty1 _ bty2 _) + = unionUniqSets (get_bty bty1) (get_bty bty2) +get_con (NewConDecl _ ty _) + = get_ty ty +get_con (RecConDecl _ nbtys _) + = unionManyUniqSets (map (get_bty.snd) nbtys) + +get_bty (Banged ty) = get_ty ty +get_bty (Unbanged ty) = get_ty ty get_ty (MonoTyVar tv) = emptyUniqSet get_ty (MonoTyApp name tys) - = (if isRnTyCon name then set_name name else emptyUniqSet) + = (if isTvOcc (nameOccName name) then emptyUniqSet else set_name name) `unionUniqSets` get_tys tys get_ty (MonoFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2) -get_ty (MonoListTy ty) - = get_ty ty -- careful when defining [] (,,) etc as -get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges! - = get_tys tys -get_ty other = panic "TcTyClsDecls:get_ty" - -get_pty (HsForAllTy _ ctxt mty) +get_ty (MonoListTy tc ty) + = set_name tc `unionUniqSets` get_ty ty +get_ty (MonoTupleTy tc tys) + = set_name tc `unionUniqSets` get_tys tys +get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty -get_pty other = panic "TcTyClsDecls:get_pty" +get_ty other = panic "TcTyClsDecls:get_ty" get_tys tys = unionManyUniqSets (map get_ty tys) @@ -244,7 +249,7 @@ get_tys tys get_sigs sigs = unionManyUniqSets (map get_sig sigs) where - get_sig (ClassOpSig _ ty _ _) = get_pty ty + get_sig (ClassOpSig _ ty _ _) = get_ty ty get_sig other = panic "TcTyClsDecls:get_sig" set_name name = unitUniqSet (uniqueOf name) @@ -276,10 +281,10 @@ Monad c in bop's type signature means that D must have kind Type->Type. \begin{code} -get_binders :: Bag Decl - -> ([RnName], -- TyVars; no dups - [(RnName, Maybe Arity)],-- Tycons; no dups; arities for synonyms - [RnName]) -- Classes; no dups +get_binders :: Bag RenamedHsDecl + -> ([HsTyVar Name], -- TyVars; no dups + [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms + [Name]) -- Classes; no dups get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes) where @@ -304,6 +309,7 @@ sigs_tvs sigs = unionManyBags (map sig_tvs sigs) where sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar + pty_tvs other = emptyBag \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index b684d2e..960e2e5 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -17,39 +17,39 @@ IMP_Ubiq(){-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo, - PolyType, Fake, InPat, - Bind(..), MonoBinds(..), Sig, - MonoType ) -import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..), - RnName{-instance Outputable-} + HsType, Fake, InPat, HsTyVar, + Bind(..), MonoBinds(..), Sig ) +import HsTypes ( getTyVarName ) +import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) ) import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, SYN_IE(TcHsBinds), TcIdOcc(..) ) import Inst ( newDicts, InstOrigin(..), Inst ) -import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext ) +import TcMonoType ( tcHsTypeKind, tcHsType, tcContext ) import TcSimplify ( tcSimplifyThetas ) import TcType ( tcInstTyVars, tcInstType, tcInstId ) import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, newLocalId, newLocalIds, tcLookupClassByKey ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind ) import PprType ( GenClass, GenType{-instance Outputable-}, GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} ) +import CoreUnfold ( getUnfoldingTemplate ) import Class ( GenClass{-instance Eq-}, classInstEnv ) import Id ( mkDataCon, dataConSig, mkRecordSelId, idType, dataConFieldLabels, dataConStrictMarks, - StrictnessMark(..), + StrictnessMark(..), getIdUnfolding, GenId{-instance NamedThing-} ) import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) import SpecEnv ( SpecEnv, nullSpecEnv ) -import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc, - Name{-instance Ord3-} +import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc, + OccName(..), Name{-instance Ord3-} ) import Outputable ( Outputable(..), interpp'SP ) import Pretty @@ -80,11 +80,12 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) tcAddErrCtxt (tySynCtxt tycon_name) $ -- Look up the pieces - tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) -> - mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> + tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) -> + mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names + `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> -- Look at the rhs - tcMonoTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) -> + tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) -> -- Unify tycon kind with (k1->...->kn->rhs) unifyKind tycon_kind @@ -118,7 +119,7 @@ tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_ = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc) - = tcTyDataOrNew NewType context tycon_name tyvar_names con_decl derivings pragmas src_loc + = tcTyDataOrNew NewType context tycon_name tyvar_names [con_decl] derivings pragmas src_loc tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc @@ -126,9 +127,10 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra tcAddErrCtxt (tyDataCtxt tycon_name) $ -- Lookup the pieces - tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) -> - mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> - tc_derivs derivings `thenNF_Tc` \ derived_classes -> + tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) -> + mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) + tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> + tc_derivs derivings `thenTc` \ derived_classes -> -- Typecheck the context tcContext context `thenTc` \ ctxt -> @@ -156,12 +158,12 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra in returnTc tycon -tc_derivs Nothing = returnNF_Tc [] -tc_derivs (Just ds) = mapNF_Tc tc_deriv ds +tc_derivs Nothing = returnTc [] +tc_derivs (Just ds) = mapTc tc_deriv ds tc_deriv name - = tcLookupClass name `thenNF_Tc` \ (_, clas) -> - returnNF_Tc clas + = tcLookupClass name `thenTc` \ (_, clas) -> + returnTc clas \end{code} Generating constructor/selector bindings for data declarations @@ -178,14 +180,20 @@ mkDataBinds (tycon : tycons) mkDataBinds_one tycon = ASSERT( isDataTyCon tycon || isNewTyCon tycon ) - mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) -> - mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) -> - returnTc (con_ids ++ sel_ids, - SingleBind $ NonRecBind $ - foldr AndMonoBinds - (foldr AndMonoBinds EmptyMonoBinds sel_binds) - con_binds - ) + mapTc checkConstructorContext data_cons `thenTc_` + mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> + let + data_ids = data_cons ++ sel_ids + + -- For the locally-defined things + -- we need to turn the unfoldings inside the Ids into bindings, + binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id)) + | data_id <- data_ids, isLocallyDefined data_id + ] + in + returnTc (data_ids, + SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds)) + ) where data_cons = tyConDataCons tycon fields = [ (con, field) | con <- data_cons, @@ -198,153 +206,56 @@ mkDataBinds_one tycon = fieldLabelName field1 `cmp` fieldLabelName field2 \end{code} -We're going to build a constructor that looks like: - - data (Data a, C b) => T a b = T1 !a !Int b - - T1 = /\ a b -> - \d1::Data a, d2::C b -> - \p q r -> case p of { p -> - case q of { q -> - HsCon T1 [a,b] [p,q,r]}} - -Notice that - -* d2 is thrown away --- a context in a data decl is used to make sure - one *could* construct dictionaries at the site the constructor - is used, but the dictionary isn't actually used. - -* We have to check that we can construct Data dictionaries for - the types a and Int. Once we've done that we can throw d1 away too. - -* We use (case p of ...) to evaluate p, rather than "seq" because - all that matters is that the arguments are evaluated. "seq" is - very careful to preserve evaluation order, which we don't need - to be here. +-- Check that all the types of all the strict arguments are in Eval \begin{code} -mkConstructor con_id - | not (isLocallyDefinedName (getName con_id)) - = returnTc (con_id, EmptyMonoBinds) +checkConstructorContext con_id + | not (isLocallyDefined con_id) + = returnTc () | otherwise -- It is locally defined - = tcInstId con_id `thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) -> - newDicts DataDeclOrigin tc_theta `thenNF_Tc` \ (_, dicts) -> + = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> let - (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau - n_args = length tc_arg_tys - in - newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args -> + strict_marks = dataConStrictMarks con_id + (tyvars,theta,tau) = splitSigmaTy (idType con_id) + (arg_tys, result_ty) = splitFunTy tau - -- Check that all the types of all the strict arguments are in Eval - tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> - let - (_,theta,tau) = splitSigmaTy (idType con_id) - (arg_tys, _) = splitFunTy tau - strict_marks = dataConStrictMarks con_id - eval_theta = [ (eval_clas,arg_ty) - | (arg_ty, MarkedStrict) <- zipEqual "strict_args" + eval_theta = [ (eval_clas,arg_ty) + | (arg_ty, MarkedStrict) <- zipEqual "strict_args" arg_tys strict_marks - ] + ] in tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' -> checkTc (null eval_theta') - (missingEvalErr con_id eval_theta') `thenTc_` - - -- Build the data constructor - let - con_rhs = mkHsTyLam tc_tyvars $ - mkHsDictLam dicts $ - mk_pat_match args $ - mk_case (zipEqual "strict_args" args strict_marks) $ - HsCon con_id (mkTyVarTys tc_tyvars) (map HsVar args) - - mk_pat_match [] body = body - mk_pat_match (arg:args) body = HsLam $ - PatMatch (VarPat arg) $ - SimpleMatch (mk_pat_match args body) - - mk_case [] body = body - mk_case ((arg,MarkedStrict):args) body = HsCase (HsVar arg) - [PatMatch (VarPat arg) $ - SimpleMatch (mk_case args body)] - src_loc - mk_case (_:args) body = mk_case args body - - src_loc = nameSrcLoc (getName con_id) - in - - returnTc (con_id, VarMonoBind (RealId con_id) con_rhs) + (missingEvalErr con_id eval_theta') \end{code} -We're going to build a record selector that looks like this: - - data T a b c = T1 { op :: a, ...} - | T2 { op :: a, ...} - | T3 - - sel :: forall a b c. T a b c -> a - sel = /\ a b c -> \ T1 { sel = x } -> x - T2 { sel = 2 } -> x - -Note that the selector Id itself is used as the field -label; it has to be an Id, you see! - \begin{code} mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- These fields all have the same name, but are from -- different constructors in the data type - = let - field_ty = fieldLabelType first_field_label - field_name = fieldLabelName first_field_label - other_tys = [fieldLabelType fl | (_, fl) <- other_fields] - (tyvars, _, _, _) = dataConSig first_con - data_ty = applyTyCon tycon (mkTyVarTys tyvars) - -- tyvars of first_con may be free in field_ty - in - -- Check that all the fields in the group have the same type -- This check assumes that all the constructors of a given -- data type use the same type variables - checkTc (all (eqTy field_ty) other_tys) + = checkTc (all (eqTy field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` - - -- Create an Id for the field itself - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) -> - tcInstType tenv field_ty `thenNF_Tc` \ field_ty' -> - let - data_ty' = applyTyCon tycon tyvar_tys - in - newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id -> - newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id -> - - -- Now build the selector - let - selector_ty :: Type - selector_ty = mkForAllTys tyvars $ - mkFunTy data_ty $ - field_ty + returnTc selector_id + where + field_ty = fieldLabelType first_field_label + field_name = fieldLabelName first_field_label + other_tys = [fieldLabelType fl | (_, fl) <- other_fields] + (tyvars, _, _, _) = dataConSig first_con + data_ty = applyTyCon tycon (mkTyVarTys tyvars) + -- tyvars of first_con may be free in field_ty + -- Now build the selector + + selector_ty :: Type + selector_ty = mkForAllTys tyvars $ + mkFunTy data_ty $ + field_ty - selector_id :: Id - selector_id = mkRecordSelId first_field_label selector_ty - - -- HsSyn is dreadfully verbose for defining the selector! - selector_rhs = mkHsTyLam tyvars' $ - HsLam $ - PatMatch (VarPat record_id) $ - SimpleMatch $ - selector_body - - selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon) - - mk_match (con_id, field_label) - = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $ - SimpleMatch $ - HsVar field_id - in - returnTc (selector_id, if isLocallyDefinedName (getName tycon) - then VarMonoBind (RealId selector_id) selector_rhs - else EmptyMonoBinds) + selector_id :: Id + selector_id = mkRecordSelId first_field_label selector_ty \end{code} Constructors @@ -360,7 +271,7 @@ tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc) tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc) = tcAddSrcLoc src_loc $ - tcMonoType ty `thenTc` \ arg_ty -> + tcHsType ty `thenTc` \ arg_ty -> let data_con = mkDataCon (getName name) [NotMarkedStrict] @@ -396,7 +307,7 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) returnTc data_con tcField (field_label_names, bty) - = tcPolyType (get_pty bty) `thenTc` \ field_ty -> + = tcHsType (get_pty bty) `thenTc` \ field_ty -> returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names] tcDataCon tycon tyvars ctxt name btys src_loc @@ -405,7 +316,7 @@ tcDataCon tycon tyvars ctxt name btys src_loc stricts = map get_strictness btys tys = map get_pty btys in - mapTc tcPolyType tys `thenTc` \ arg_tys -> + mapTc tcHsType tys `thenTc` \ arg_tys -> let data_con = mkDataCon (getName name) stricts diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index eff458d..a340107 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -52,7 +52,7 @@ import Class ( GenClass ) import Id ( idType ) import Kind ( Kind ) import TcKind ( TcKind ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Usage ( SYN_IE(Usage), GenUsage, SYN_IE(UVar), duffUsage ) import TysPrim ( voidTy ) diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index 9fba979..57b4a09 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -14,7 +14,7 @@ module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where IMP_Ubiq() -- friends: -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe ) import TyCon ( TyCon, mkFunTyCon ) import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind ) diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index e7630b0..ee57c76 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -14,11 +14,7 @@ module Class ( classSuperDictSelId, classOpId, classDefaultMethodId, classSig, classBigSig, classInstEnv, isSuperClassOf, - classOpTagByString, classOpTagByString_maybe, - - derivableClassKeys, needsDataDeclCtxtClassKeys, - cCallishClassKeys, isNoDictClass, - isNumericClass, isStandardClass, isCcallishClass, + classOpTagByOccName, classOpTagByOccName_maybe, GenClassOp(..), SYN_IE(ClassOp), mkClassOp, @@ -38,10 +34,10 @@ import Usage ( GenUsage, SYN_IE(Usage), SYN_IE(UVar) ) import MatchEnv ( MatchEnv ) import Maybes ( assocMaybe ) -import Name ( changeUnique, Name ) +import Name ( changeUnique, Name, OccName, occNameString ) import Unique -- Keys for built-in classes import Pretty ( SYN_IE(Pretty), ppCat, ppPStr ) ---import PprStyle ( PprStyle ) +import PprStyle ( PprStyle(..) ) import SrcLoc ( SrcLoc ) import Util \end{code} @@ -59,7 +55,7 @@ get appropriately general instances of Ord3 for GenType. \begin{code} data GenClassOp ty - = ClassOp FAST_STRING -- The operation name + = ClassOp OccName -- The operation name Int -- Unique within a class; starts at 1 @@ -175,77 +171,6 @@ clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas %************************************************************************ %* * -\subsection[Class-std-groups]{Standard groups of Prelude classes} -%* * -%************************************************************************ - -@derivableClassKeys@ is also used in checking \tr{deriving} constructs -(@TcDeriv@). - -NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ -even though every numeric class has these two as a superclass, -because the list of ambiguous dictionaries hasn't been simplified. - -\begin{code} -isNumericClass, isStandardClass :: Class -> Bool - -isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $ - key `is_elem` numericClassKeys -isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys -isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys -isNoDictClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys -is_elem = isIn "is_X_Class" - -numericClassKeys - = [ numClassKey - , realClassKey - , integralClassKey - , fractionalClassKey - , floatingClassKey - , realFracClassKey - , realFloatClassKey - ] - -derivableClassKeys - = [ eqClassKey - , ordClassKey - , enumClassKey - , evalClassKey - , boundedClassKey - , showClassKey - , readClassKey - , ixClassKey - ] - -needsDataDeclCtxtClassKeys -- see comments in TcDeriv - = [ readClassKey - ] - -cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ] - -standardClassKeys - = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys - -- - -- We have to have "CCallable" and "CReturnable" in the standard - -- classes, so that if you go... - -- - -- _ccall_ foo ... 93{-numeric literal-} ... - -- - -- ... it can do The Right Thing on the 93. - -noDictClassKeys -- These classes are used only for type annotations; - -- they are not implemented by dictionaries, ever. - = cCallishClassKeys - -- I used to think that class Eval belonged in here, but - -- we really want functions with type (Eval a => ...) and that - -- means that we really want to pass a placeholder for an Eval - -- dictionary. The unit tuple is what we'll get if we leave things - -- alone, and that'll do for now. Could arrange to drop that parameter - -- in the end. -\end{code} - -%************************************************************************ -%* * \subsection[Class-instances]{Instance declarations for @Class@} %* * %************************************************************************ @@ -274,6 +199,9 @@ instance Uniquable (GenClass tyvar uvar) where instance NamedThing (GenClass tyvar uvar) where getName (Class _ n _ _ _ _ _ _ _ _) = n + +instance NamedThing (GenClassOp ty) where + getOccName (ClassOp occ _ _) = occ \end{code} @@ -316,14 +244,14 @@ object). Of course, the type of @op@ recorded in the GVE will be its ****************************************************************** \begin{code} -mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty +mkClassOp :: OccName -> Int -> ty -> GenClassOp ty mkClassOp name tag ty = ClassOp name tag ty classOpTag :: GenClassOp ty -> Int classOpTag (ClassOp _ tag _) = tag classOpString :: GenClassOp ty -> FAST_STRING -classOpString (ClassOp str _ _) = str +classOpString (ClassOp occ _ _) = occNameString occ classOpLocalType :: GenClassOp ty -> ty {-SigmaType-} classOpLocalType (ClassOp _ _ ty) = ty @@ -331,23 +259,23 @@ classOpLocalType (ClassOp _ _ ty) = ty Rather unsavoury ways of getting ClassOp tags: \begin{code} -classOpTagByString_maybe :: Class -> FAST_STRING -> Maybe Int -classOpTagByString :: Class -> FAST_STRING -> Int +classOpTagByOccName_maybe :: Class -> OccName -> Maybe Int +classOpTagByOccName :: Class -> OccName -> Int -classOpTagByString clas op - = case (classOpTagByString_maybe clas op) of +classOpTagByOccName clas op + = case (classOpTagByOccName_maybe clas op) of Just tag -> tag #ifdef DEBUG - Nothing -> pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas))) + Nothing -> pprPanic "classOpTagByOccName:" (ppCat (ppr PprDebug op : map (ppPStr . classOpString) (classOps clas))) #endif -classOpTagByString_maybe clas op - = go (map classOpString (classOps clas)) 1 +classOpTagByOccName_maybe clas op + = go (classOps clas) 1 where - go [] _ = Nothing - go (n:ns) tag = if n == op - then Just tag - else go ns (tag+1) + go [] _ = Nothing + go (ClassOp occ _ _ : ns) tag = if occ == op + then Just tag + else go ns (tag+1) \end{code} %************************************************************************ diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs index ab77d19..cb29e48 100644 --- a/ghc/compiler/types/Kind.lhs +++ b/ghc/compiler/types/Kind.lhs @@ -17,7 +17,9 @@ module Kind ( hasMoreBoxityInfo, resultKind, argKind, - isUnboxedKind, isTypeKind, + pprKind, pprParendKind, + + isUnboxedTypeKind, isTypeKind, isBoxedTypeKind, notArrowKind ) where @@ -45,9 +47,13 @@ isTypeKind :: Kind -> Bool isTypeKind TypeKind = True isTypeKind other = False -isUnboxedKind :: Kind -> Bool -isUnboxedKind UnboxedTypeKind = True -isUnboxedKind other = False +isBoxedTypeKind :: Kind -> Bool +isBoxedTypeKind BoxedTypeKind = True +isBoxedTypeKind other = False + +isUnboxedTypeKind :: Kind -> Bool +isUnboxedTypeKind UnboxedTypeKind = True +isUnboxedTypeKind other = False hasMoreBoxityInfo :: Kind -> Kind -> Bool @@ -85,11 +91,11 @@ Printing instance Outputable Kind where ppr sty kind = pprKind kind -pprKind TypeKind = ppStr "*" -pprKind BoxedTypeKind = ppStr "*b" -pprKind UnboxedTypeKind = ppStr "*u" -pprKind (ArrowKind k1 k2) = ppSep [pprKind_parend k1, ppStr "->", pprKind k2] +pprKind TypeKind = ppStr "**" -- Can be boxed or unboxed +pprKind BoxedTypeKind = ppStr "*" +pprKind UnboxedTypeKind = ppStr "*#" -- Unboxed +pprKind (ArrowKind k1 k2) = ppSep [pprParendKind k1, ppStr "->", pprKind k2] -pprKind_parend k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen] -pprKind_parend k = pprKind k +pprParendKind k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen] +pprParendKind k = pprKind k \end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 1a7cfe3..7bb3928 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -7,14 +7,13 @@ #include "HsVersions.h" module PprType( - GenTyVar, pprGenTyVar, + GenTyVar, pprGenTyVar, pprTyVarBndr, TyCon, pprTyCon, showTyCon, GenType, pprGenType, pprParendGenType, pprType, pprParendType, pprMaybeTy, getTypeString, - typeMaybeString, specMaybeTysSuffix, getTyDescription, GenClass, @@ -37,15 +36,15 @@ import TyVar ( GenTyVar(..) ) import TyCon ( TyCon(..), NewOrData ) import Class ( SYN_IE(Class), GenClass(..), SYN_IE(ClassOp), GenClassOp(..) ) -import Kind ( Kind(..) ) +import Kind ( Kind(..), isBoxedTypeKind, pprParendKind ) import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) ) -- others: import CStrings ( identToC ) import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( maybeToBool ) -import Name ( isLexVarSym, isLexSpecialSym, origName, moduleOf, - getLocalName, Name{-instance Outputable-} +import Name ( nameString, Name{-instance Outputable-}, + OccName, pprOccName, getOccString, pprNonSymOcc ) import Outputable ( ifPprShowAll, interpp'SP ) import PprEnv @@ -97,11 +96,12 @@ works just by setting the initial context precedence very high. pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => PprStyle -> GenType tyvar uvar -> Pretty -pprGenType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC ty -pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty +pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty +pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty -pprType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC (ty :: Type) -pprParendType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type) +pprType, pprParendType :: PprStyle -> Type -> Pretty +pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty +pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty @@ -110,132 +110,132 @@ pprMaybeTy sty (Just ty) = pprParendGenType sty ty \end{code} \begin{code} -ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> PprEnv tyvar uvar bndr occ -> Int +ppr_ty :: PprEnv tyvar uvar bndr occ -> Int -> GenType tyvar uvar -> Pretty -ppr_ty sty env ctxt_prec (TyVarTy tyvar) - = ppr_tyvar env tyvar +ppr_ty env ctxt_prec (TyVarTy tyvar) + = pTyVarO env tyvar -ppr_ty sty env ctxt_prec (TyConTy tycon usage) - = ppr sty tycon +ppr_ty env ctxt_prec (TyConTy tycon usage) + = ppr_tycon env tycon -ppr_ty sty env ctxt_prec ty@(ForAllTy _ _) - | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty - - | otherwise = ppSep [ ppPStr SLIT("_forall_"), - ppIntersperse pp'SP pp_tyvars, - ppPStr SLIT("=>"), - ppr_ty sty env' ctxt_prec body_ty - ] +ppr_ty env ctxt_prec ty@(ForAllTy _ _) + | show_forall = ppSep [ ppPStr SLIT("_forall_"), pp_tyvars, + pp_theta, ppPStr SLIT("=>"), pp_body + ] + | null theta = pp_body + | otherwise = ppSep [pp_theta, ppPStr SLIT("=>"), pp_body] where - (tyvars, body_ty) = splitForAllTy ty - env' = foldl add_tyvar env tyvars - pp_tyvars = map (ppr_tyvar env') tyvars - -ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty) + (tyvars, rho_ty) = splitForAllTy ty + (theta, body_ty) | show_context = splitRhoTy rho_ty + | otherwise = ([], rho_ty) + + pp_tyvars = ppBracket (ppIntersperse ppSP (map (pTyVarB env) tyvars)) + pp_theta | null theta = ppNil + | otherwise = ppCurlies (ppInterleave ppComma (map (ppr_dict env tOP_PREC) theta)) + pp_body = ppr_ty env ctxt_prec body_ty + + sty = pStyle env + show_forall = case sty of + PprForUser -> False + other -> True + + show_context = case sty of + PprInterface -> True + PprForUser -> True + other -> False + +ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty) = panic "ppr_ty:ForAllUsageTy" -ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _) - | showUserishTypes sty - -- Print a nice looking context (Eq a, Text b) => ... - = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")), - ppr_ty sty env ctxt_prec body_ty - ] - where - (theta, body_ty) = splitRhoTy ty - - ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 } - - ppr_theta_1 [ct] = ppr_dict sty env tOP_PREC ct - ppr_theta_1 cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts)) - - ppr_theta_2 cts = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"] - -ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) +ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) -- We fiddle the precedences passed to left/right branches, -- so that right associativity comes out nicely... = maybeParen ctxt_prec fUN_PREC - (ppCat [ppr_ty sty env fUN_PREC ty1, + (ppCat [ppr_ty env fUN_PREC ty1, ppPStr SLIT("->"), - ppr_ty sty env tOP_PREC ty2]) + ppr_ty env tOP_PREC ty2]) -ppr_ty sty env ctxt_prec ty@(AppTy _ _) - = ppr_corner sty env ctxt_prec fun_ty arg_tys +ppr_ty env ctxt_prec ty@(AppTy _ _) + = ppr_corner env ctxt_prec fun_ty arg_tys where (fun_ty, arg_tys) = splitAppTy ty -ppr_ty sty env ctxt_prec (SynTy tycon tys expansion) - | codeStyle sty +ppr_ty env ctxt_prec (SynTy tycon tys expansion) + | codeStyle (pStyle env) -- always expand types that squeak into C-variable names - = ppr_ty sty env ctxt_prec expansion + = ppr_ty env ctxt_prec expansion | otherwise = ppBeside - (ppr_app sty env ctxt_prec (ppr sty tycon) tys) - (ifPprShowAll sty (ppCat [ppStr " {- expansion:", - ppr_ty sty env tOP_PREC expansion, - ppStr "-}"])) + (ppr_app env ctxt_prec (ppr_tycon env tycon) tys) + (ifPprShowAll (pStyle env) (ppCat [ppStr " {- expansion:", + ppr_ty env tOP_PREC expansion, + ppStr "-}"])) + +ppr_ty env ctxt_prec (DictTy clas ty usage) + = ppCurlies (ppr_dict env tOP_PREC (clas, ty)) + -- Curlies are temporary -ppr_ty sty env ctxt_prec (DictTy clas ty usage) - = ppr_dict sty env ctxt_prec (clas, ty) -- Some help functions -ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys +ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys | length arg_tys == 2 - = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) + = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) where (ty1:ty2:_) = arg_tys -ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys - | not (codeStyle sty) -- no magic in that case +ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys + | not (codeStyle (pStyle env)) -- no magic in that case = --ASSERT(length arg_tys == a) --(if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $ ppBesides [ppLparen, arg_tys_w_commas, ppRparen] where - arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys) + arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty env tOP_PREC) arg_tys) -ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys - | not (codeStyle sty) && uniqueOf tycon == listTyConKey +ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys + | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey = ASSERT(length arg_tys == 1) - ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack] + ppBesides [ppLbrack, ppr_ty env tOP_PREC ty1, ppRbrack] where (ty1:_) = arg_tys -ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys - = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys +ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys + = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys -ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys - = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys +ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys + = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys -ppr_app sty env ctxt_prec pp_fun [] +ppr_app env ctxt_prec pp_fun [] = pp_fun -ppr_app sty env ctxt_prec pp_fun arg_tys +ppr_app env ctxt_prec pp_fun arg_tys = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces]) where - arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys) + arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty env tYCON_PREC) arg_tys) -ppr_dict sty env ctxt_prec (clas, ty) +ppr_dict env ctxt_prec (clas, ty) = maybeParen ctxt_prec tYCON_PREC - (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty]) + (ppCat [ppr_class env clas, ppr_ty env tYCON_PREC ty]) \end{code} -This stuff is effectively stubbed out for the time being -(WDP 960425): \begin{code} + -- This one uses only "ppr" init_ppr_env sty - = initPprEnv sty b b b b b b b b b b b + = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b where b = panic "PprType:init_ppr_env" -ppr_tyvar env tyvar = ppr (pStyle env) tyvar -ppr_uvar env uvar = ppr (pStyle env) uvar + -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types +init_ppr_env_type sty + = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b + where + b = panic "PprType:init_ppr_env" -add_tyvar env tyvar = env -add_uvar env uvar = env +ppr_tycon env tycon = ppr (pStyle env) tycon +ppr_class env clas = ppr (pStyle env) clas \end{code} @ppr_ty@ takes an @Int@ that is the precedence of the context. @@ -274,7 +274,7 @@ pprGenTyVar sty (TyVar uniq kind name usage) where pp_u = pprUnique uniq pp_name = case name of - Just n -> ppPStr (getLocalName n) + Just n -> pprOccName sty (getOccName n) Nothing -> case kind of TypeKind -> ppChar 'o' BoxedTypeKind -> ppChar 't' @@ -282,6 +282,16 @@ pprGenTyVar sty (TyVar uniq kind name usage) ArrowKind _ _ -> ppChar 'a' \end{code} +We print type-variable binders with their kinds in interface files. + +\begin{code} +pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage) + | not (isBoxedTypeKind kind) + = ppBesides [pprGenTyVar sty tyvar, ppStr "::", pprParendKind kind] + +pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar +\end{code} + %************************************************************************ %* * \subsection[TyCon]{@TyCon@} @@ -309,6 +319,14 @@ maybe_code sty x mangle '>' = ppPStr SLIT("Zg") pprTyCon :: PprStyle -> TyCon -> Pretty +pprTyCon sty tycon = ppr sty (getName tycon) + +{- This old code looks suspicious to me. + Just printing the name should do the job; apart from the extra junk + on SynTyCons etc. + + Let's try and live without all this... + Delete in due course. SLPJ Nov 96 pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name @@ -322,9 +340,6 @@ pprTyCon sty (TupleTyCon _ _ arity) = case arity of n -> maybe_code sty ( "(" ++ nOfThem (n-1) ',' ++ ")" ) pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd) - | uniq == listTyConKey - = maybe_code sty "[]" - | otherwise = ppr sty name pprTyCon sty (SpecTyCon tc ty_maybes) @@ -341,6 +356,7 @@ pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion) interpp'SP sty tyvars, pprParendGenType sty expansion, ppStr "-}"])) +-} \end{code} @@ -363,10 +379,8 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) PprShowAll -> pp_sigd _ -> pp_user where - pp_C = ppPStr op_name - pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name) - then ppParens pp_C - else pp_C + pp_C = ppr sty op_name + pp_user = pprNonSymOcc sty op_name pp_sigd = ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] \end{code} @@ -383,50 +397,28 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) -- Produces things like what we have in mkCompoundName, -- which can be "dot"ted together... -getTypeString :: Type -> [Either OrigName FAST_STRING] +getTypeString :: Type -> FAST_STRING getTypeString ty = case (splitAppTy ty) of { (tc, args) -> - do_tc tc : map do_arg_ty args } + _CONCAT_ (do_tc tc : map do_arg_ty args) } where - do_tc (TyConTy tc _) = Left (origName "do_tc" tc) + do_tc (TyConTy tc _) = nameString (getName tc) do_tc (SynTy _ _ ty) = do_tc ty do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $ - Right (_PK_ (ppShow 1000 (pprType PprForC other))) + (_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 (TyConTy tc _) = nameString (getName tc) + do_arg_ty (TyVarTy tv) = _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) $ - Right (_PK_ (ppShow 1000 (pprType PprForC other))) + _PK_ (ppShow 1000 (pprType PprForC other)) -- PprForC expands type synonyms as it goes; -- it also forces consistent naming of tycons -- (e.g., can't have both "(,) a b" and "(a,b)": -- must be consistent! - -------------------------------------------------- - -- tidy: very ad-hoc - tidy [] = [] -- done - - tidy (' ' : more) - = case more of - ' ' : _ -> tidy more - '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs) - other -> ' ' : tidy more - - tidy (',' : more) = ',' : tidy (no_leading_sps more) - - tidy (x : xs) = x : tidy xs -- catch all - - no_leading_sps [] = [] - no_leading_sps (' ':xs) = no_leading_sps xs - no_leading_sps other = other - -typeMaybeString :: Maybe Type -> [Either OrigName FAST_STRING] -typeMaybeString Nothing = [Right SLIT("!")] -typeMaybeString (Just t) = getTypeString t - specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING specMaybeTysSuffix ty_maybes = panic "PprType.specMaybeTysSuffix" @@ -450,8 +442,8 @@ getTyDescription ty TyVarTy _ -> "*" AppTy fun _ -> getTyDescription fun FunTy _ res _ -> '-' : '>' : fun_result res - TyConTy tycon _ -> _UNPK_ (getLocalName tycon) - SynTy tycon _ _ -> _UNPK_ (getLocalName tycon) + TyConTy tycon _ -> getOccString tycon + SynTy tycon _ _ -> getOccString tycon DictTy _ _ _ -> "dict" ForAllTy _ ty -> getTyDescription ty _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index e38da87..d473ea4 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -44,7 +44,7 @@ IMPORT_DELOOPER(TyLoop) ( SYN_IE(Type), GenType, SYN_IE(Class), GenClass, SYN_IE(Id), GenId, splitSigmaTy, splitFunTy, - mkTupleCon, isNullaryDataCon, idType + tupleCon, isNullaryDataCon, idType --LATER: specMaybeTysSuffix ) @@ -53,12 +53,12 @@ import Usage ( GenUsage, SYN_IE(Usage) ) import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind ) import Maybes -import Name ( Name, RdrName(..), appendRdr, nameUnique, - mkTupleTyConName, mkFunTyConName - ) -import Unique ( Unique, funTyConKey, mkTupleTyConUnique ) +import Name ( Name, nameUnique, mkWiredInTyConName ) +import Unique ( Unique, funTyConKey ) import Pretty ( SYN_IE(Pretty), PrettyRep ) import PrimRep ( PrimRep(..) ) +import PrelMods ( gHC__, pREL_TUP, pREL_BASE ) +import Lex ( mkTupNameStr ) import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic ) --import {-hide me-} @@ -124,14 +124,11 @@ data NewOrData \end{code} \begin{code} -mkFunTyCon = FunTyCon -mkSpecTyCon = SpecTyCon +mkFunTyCon = FunTyCon +mkFunTyConName = mkWiredInTyConName funTyConKey gHC__ SLIT("->") FunTyCon -mkTupleTyCon arity - = TupleTyCon u n arity - where - n = mkTupleTyConName arity - u = uniqueOf n +mkSpecTyCon = SpecTyCon +mkTupleTyCon = TupleTyCon mkDataTyCon name = DataTyCon (nameUnique name) name mkPrimTyCon name = PrimTyCon (nameUnique name) name @@ -229,7 +226,7 @@ tyConDataCons :: TyCon -> [Id] tyConFamilySize :: TyCon -> Int tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons -tyConDataCons (TupleTyCon _ _ a) = [mkTupleCon a] +tyConDataCons (TupleTyCon _ _ a) = [tupleCon a] tyConDataCons other = [] -- You may think this last equation should fail, -- but it's quite convenient to return no constructors for @@ -267,7 +264,7 @@ getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty) \begin{code} maybeTyConSingleCon :: TyCon -> Maybe Id -maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (mkTupleCon arity) +maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (tupleCon arity) maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing maybeTyConSingleCon (PrimTyCon _ _ _ _) = Nothing @@ -344,4 +341,5 @@ instance NamedThing TyCon where getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc)) getName other = Nothing -} + \end{code} diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi index 31e348c..1086dec 100644 --- a/ghc/compiler/types/TyLoop.lhi +++ b/ghc/compiler/types/TyLoop.lhi @@ -8,8 +8,9 @@ import PreludeStdIO ( Maybe ) import Unique ( Unique ) import FieldLabel ( FieldLabel ) -import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon, +import Id ( Id, GenId, StrictnessMark, mkDataCon, mkTupleCon, isNullaryDataCon, dataConArgTys, idType ) +import TysWiredIn ( tupleCon, tupleTyCon ) import PprType ( specMaybeTysSuffix ) import Name ( Name ) import TyCon ( TyCon ) @@ -31,7 +32,7 @@ type Class = GenClass (GenTyVar (GenUsage Unique)) Unique type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -- Needed in TyCon -mkTupleCon :: Int -> Id +tupleCon :: Int -> Id isNullaryDataCon :: Id -> Bool specMaybeTysSuffix :: [Maybe Type] -> _PackedString idType :: Id -> Type @@ -40,6 +41,7 @@ splitFunTy :: GenType t u -> ([GenType t u], GenType t u) instance Eq (GenClass a b) -- Needed in Type +tupleTyCon :: Int -> TyCon dataConArgTys :: Id -> [Type] -> [Type] voidTy :: Type @@ -48,4 +50,5 @@ data StrictnessMark = MarkedStrict | NotMarkedStrict mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] -> [TyVar] -> [(Class,Type)] -> [Type] -> TyCon -> Id +mkTupleCon :: Int -> Name -> Type -> Id \end{code} diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index b7fc8b7..fd59f96 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -35,11 +35,11 @@ import UniqSet -- nearly all of it import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, plusUFM, sizeUFM, delFromUFM, UniqFM ) -import Name ( mkLocalName, changeUnique, Name, RdrName(..) ) +import Name ( mkSysLocalName, changeUnique, Name ) import Pretty ( SYN_IE(Pretty), PrettyRep, ppBeside, ppPStr ) import PprStyle ( PprStyle ) --import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) ) -import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import SrcLoc ( noSrcLoc, SrcLoc ) import Unique ( showUnique, mkAlphaTyVarUnique, Unique ) import Util ( panic, Ord3(..) ) \end{code} @@ -162,5 +162,5 @@ instance Uniquable (GenTyVar a) where instance NamedThing (GenTyVar a) where getName (TyVar _ _ (Just n) _) = n - getName (TyVar u _ _ _) = mkLocalName u (showUnique u) True{-emph uniq-} mkUnknownSrcLoc + getName (TyVar u _ _ _) = mkSysLocalName u SLIT("t") noSrcLoc \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index d63cecc..daee172 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -37,7 +37,7 @@ module Type ( isTauTy, - tyVarsOfType, tyVarsOfTypes, typeKind + tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind ) where IMP_Ubiq() @@ -48,7 +48,7 @@ IMPORT_DELOOPER(TyLoop) -- friends: import Class ( classSig, classOpLocalType, GenClass{-instances-} ) import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind ) -import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, +import TyCon ( mkFunTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet), @@ -59,6 +59,10 @@ import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar, eqUsage ) +import Name ( NamedThing(..), + NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet + ) + -- others import Maybes ( maybeToBool, assocMaybe ) import PrimRep ( PrimRep(..) ) @@ -159,7 +163,7 @@ expandTy (DictTy clas ty u) -- no methods! other -> ASSERT(not (null all_arg_tys)) - foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys + foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys -- A tuple of 'em -- Note: length of all_arg_tys can be 0 if the class is @@ -245,6 +249,10 @@ getFunTyExpandingDicts_maybe peek (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res) getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty) + +getFunTyExpandingDicts_maybe True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty + -- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking + getFunTyExpandingDicts_maybe peek other | not peek = Nothing -- that was easy | otherwise @@ -266,6 +274,12 @@ splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type) splitFunTy t = split_fun_ty getFunTy_maybe t splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t + -- This "peeking" stuff is used only by the code generator. + -- It's interested in the representation type of things, ignoring: + -- newtype + -- foralls + -- expanding dictionary reps + -- synonyms, of course split_fun_ty get t = go t [] where @@ -534,6 +548,19 @@ tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys + +-- Find the free names of a type, including the type constructors and classes it mentions +namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet +namesOfType (TyVarTy tv) = unitNameSet (getName tv) +namesOfType (TyConTy tycon usage) = unitNameSet (getName tycon) +namesOfType (SynTy tycon tys ty) = unitNameSet (getName tycon) `unionNameSets` + namesOfType ty +namesOfType (FunTy arg res _) = namesOfType arg `unionNameSets` namesOfType res +namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg +namesOfType (DictTy clas ty _) = unitNameSet (getName clas) `unionNameSets` + namesOfType ty +namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar) +namesOfType (ForAllUsageTy _ _ ty) = panic "forall usage" \end{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index d8c5989..f281856 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -54,9 +54,9 @@ module FiniteMap ( minusFM, foldFM, - IF_NOT_GHC(intersectFM COMMA) - IF_NOT_GHC(intersectFM_C COMMA) - IF_NOT_GHC(mapFM COMMA filterFM COMMA) + intersectFM, + intersectFM_C, + mapFM, filterFM, sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, @@ -69,14 +69,17 @@ module FiniteMap ( #endif ) where +IMPORT_DELOOPER(SpecLoop) import Maybes +import Bag ( Bag, foldBag ) +import Outputable ( Outputable(..) ) -#ifdef COMPILING_GHC -IMP_Ubiq(){-uitous-} # ifdef DEBUG -import Pretty +import PprStyle ( PprStyle ) +import Pretty ( SYN_IE(Pretty), PrettyRep ) # endif -import Bag ( foldBag ) + +#ifdef COMPILING_GHC # if ! OMIT_NATIVE_CODEGEN # define IF_NCG(a) a @@ -144,8 +147,8 @@ minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt - -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2 intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt -intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) - -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt +intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt2) + -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt2 -- MAPPING, FOLDING, FILTERING foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 1f17679..a3834fd 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -38,9 +38,10 @@ module Maybes ( #if defined(COMPILING_GHC) -CHK_Ubiq() -- debugging consistency check +CHK_Ubiq() -- debugging consistency check -import Unique (Unique) -- only for specialising +IMPORT_DELOOPER( SpecLoop ) -- Specialisation +import Unique (Unique) -- only for specialising #else import Maybe -- renamer will tell us if there are any conflicts @@ -140,7 +141,6 @@ assocMaybe alist key :: [(FAST_STRING, b)] -> FAST_STRING -> Maybe b , [(Int, b)] -> Int -> Maybe b , [(Unique, b)] -> Unique -> Maybe b - , [(RdrName, b)] -> RdrName -> Maybe b #-} #endif \end{code} diff --git a/ghc/compiler/utils/PprStyle.lhs b/ghc/compiler/utils/PprStyle.lhs index b8ee2ed..dfb4ec2 100644 --- a/ghc/compiler/utils/PprStyle.lhs +++ b/ghc/compiler/utils/PprStyle.lhs @@ -8,7 +8,7 @@ module PprStyle ( PprStyle(..), - codeStyle, + codeStyle, ifaceStyle, showUserishTypes ) where @@ -39,19 +39,22 @@ style). The most likely ones are variations on how much type info is shown. The following test decides whether or not we are actually generating -code (either C or assembly). +code (either C or assembly), or generating interface files. \begin{code} codeStyle :: PprStyle -> Bool codeStyle PprForC = True codeStyle (PprForAsm _ _) = True codeStyle _ = False + +ifaceStyle :: PprStyle -> Bool +ifaceStyle PprInterface = True +ifaceStyle other = False \end{code} \begin{code} -- True means types like (Eq a, Text b) => a -> b -- False means types like _forall_ a b => Eq a -> Text b -> a -> b showUserishTypes PprForUser = True -showUserishTypes PprInterface = True showUserishTypes other = False \end{code} diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index ad2a76f..8bfd952 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -27,7 +27,7 @@ module Pretty ( #endif ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals, - ppBracket, ppParens, ppQuote, + ppBracket, ppParens, ppQuote, ppCurlies, ppCat, ppBeside, ppBesides, ppAbove, ppAboves, ppNest, ppSep, ppHang, ppInterleave, ppIntersperse, @@ -168,6 +168,7 @@ ppEquals = ppChar '=' ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack) ppParens p = ppBeside ppLparen (ppBeside p ppRparen) +ppCurlies p = ppBeside (ppChar '{') (ppBeside p (ppChar '}')) ppQuote p = ppBeside (ppChar '`') (ppBeside p (ppChar '\'')) ppInterleave sep ps = ppSep (pi ps) diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs index 4c4cbb4..e574a84 100644 --- a/ghc/compiler/utils/SST.lhs +++ b/ghc/compiler/utils/SST.lhs @@ -11,6 +11,7 @@ module SST( thenSST, thenSST_, returnSST, fixSST, thenFSST, thenFSST_, returnFSST, failFSST, recoverFSST, recoverSST, fixFSST, + unsafeInterleaveSST, newMutVarSST, readMutVarSST, writeMutVarSST #if __GLASGOW_HASKELL__ >= 200 @@ -70,6 +71,11 @@ stToSST st s runSST :: SST REAL_WORLD r -> r runSST m = case m realWorld# of SST_R r s -> r +unsafeInterleaveSST :: SST s r -> SST s r +unsafeInterleaveSST m s = SST_R r s -- Duplicates the state! + where + SST_R r _ = m s + returnSST :: r -> SST s r thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi index 0ffea8b..aaf4be1 100644 --- a/ghc/compiler/utils/Ubiq.lhi +++ b/ghc/compiler/utils/Ubiq.lhi @@ -21,24 +21,23 @@ import CostCentre ( CostCentre ) import FieldLabel ( FieldLabel ) import FiniteMap ( FiniteMap ) import HeapOffs ( HeapOffset ) -import HsCore ( UnfoldingCoreExpr ) import HsPat ( OutPat ) import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, InstancePragmas ) import Id ( StrictnessMark, GenId, Id(..) ) -import IdInfo ( IdInfo, OptIdInfo(..), ArityInfo, DeforestInfo, Demand, StrictnessInfo, UpdateInfo ) +import IdInfo ( IdInfo, ArityInfo, DeforestInfo, StrictnessInfo, UpdateInfo ) +import Demand ( Demand ) import Kind ( Kind ) import Literal ( Literal ) import MachRegs ( Reg ) import Maybes ( MaybeErr ) import MatchEnv ( MatchEnv ) -import Name ( Module(..), OrigName, RdrName, Name, ExportFlag, NamedThing(..) ) +import Name ( Module(..), OccName, Name, ExportFlag, NamedThing(..) ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle ) import PragmaInfo ( PragmaInfo ) import Pretty ( PrettyRep ) import PrimOp ( PrimOp ) import PrimRep ( PrimRep ) -import RnHsSyn ( RnName ) import SMRep ( SMRep ) import SrcLoc ( SrcLoc ) import TcType ( TcMaybe ) @@ -55,12 +54,9 @@ import Util ( Ord3(..) ) -- to try to contain their visibility. class NamedThing a where - getName :: a -> Name -class OptIdInfo a where - noInfo :: a - getInfo :: IdInfo -> a - addInfo :: IdInfo -> a -> IdInfo - ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep + getOccName :: a -> OccName + getName :: a -> Name + class Ord3 a where cmp :: a -> a -> Int# class Outputable a where @@ -111,8 +107,7 @@ data Literal data MaybeErr a b data MatchEnv a b data Name -data OrigName = OrigName _PackedString _PackedString -data RdrName = Unqual _PackedString | Qual _PackedString _PackedString +data OccName data Reg data OutPat a b c data PprStyle @@ -120,16 +115,14 @@ data PragmaInfo data PrettyRep data PrimOp data PrimRep -- NB: an enumeration -data RnName data SimplifierSwitch data SMRep data SrcLoc -data StrictnessInfo +data StrictnessInfo bdee data StrictnessMark data SwitchResult data TcMaybe s data TyCon -data UnfoldingCoreExpr a data UniqFM a data UpdateInfo data UniqSupply @@ -150,19 +143,13 @@ 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/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 6374705..8f9e9f9 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -52,12 +52,13 @@ module UniqFM ( ) where #if defined(COMPILING_GHC) -IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER( SpecLoop ) #endif import Unique ( Unique, u2i, mkUniqueGrimily ) import Util import Pretty ( SYN_IE(Pretty), PrettyRep ) +import Outputable ( Outputable(..) ) import PprStyle ( PprStyle ) import SrcLoc ( SrcLoc ) @@ -141,27 +142,20 @@ ufmToList :: UniqFM elt -> [(Unique, elt)] {-# SPECIALIZE addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt - , UniqFM elt -> [(RnName, elt)] -> UniqFM elt #-} {-# SPECIALIZE addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt - , (elt -> elt -> elt) -> UniqFM elt -> [(RnName,elt)] -> UniqFM elt #-} {-# SPECIALIZE addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt #-} {-# SPECIALIZE listToUFM :: [(Unique, elt)] -> UniqFM elt - , [(RnName, elt)] -> UniqFM elt #-} {-# SPECIALIZE lookupUFM :: UniqFM elt -> Name -> Maybe elt - , UniqFM elt -> RnName -> Maybe elt , UniqFM elt -> Unique -> Maybe elt #-} -{-# SPECIALIZE - lookupWithDefaultUFM :: UniqFM elt -> elt -> RnName -> elt - #-} #endif {- __GLASGOW_HASKELL__ -} \end{code} diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs index 5d892fb..122e71d 100644 --- a/ghc/compiler/utils/UniqSet.lhs +++ b/ghc/compiler/utils/UniqSet.lhs @@ -14,18 +14,19 @@ module UniqSet ( SYN_IE(UniqSet), -- abstract type: NOT mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet, - addOneToUniqSet, + addOneToUniqSet, addListToUniqSet, unionUniqSets, unionManyUniqSets, minusUniqSet, elementOfUniqSet, mapUniqSet, intersectUniqSets, - isEmptyUniqSet + isEmptyUniqSet, filterUniqSet, sizeUniqSet ) where -IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER( SpecLoop ) import Maybes ( maybeToBool ) import UniqFM import Unique ( Unique ) import SrcLoc ( SrcLoc ) +import Outputable ( Outputable(..) ) import Pretty ( SYN_IE(Pretty), PrettyRep ) import PprStyle ( PprStyle ) import Util ( Ord3(..) ) @@ -65,7 +66,10 @@ mkUniqSet :: Uniquable a => [a] -> UniqSet a mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs]) addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -addOneToUniqSet set x = set `unionUniqSets` unitUniqSet x +addOneToUniqSet (MkUniqSet set) x = MkUniqSet (addToUFM set x x) + +addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +addListToUniqSet (MkUniqSet set) xs = MkUniqSet (addListToUFM set [(x,x) | x<-xs]) unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a unionUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (plusUFM set1 set2) @@ -79,12 +83,18 @@ unionManyUniqSets (s:ss) = s `unionUniqSets` unionManyUniqSets ss minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a minusUniqSet (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (minusUFM set1 set2) +filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +filterUniqSet pred (MkUniqSet set) = MkUniqSet (filterUFM pred set) + intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a intersectUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (intersectUFM set1 set2) elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool elementOfUniqSet x (MkUniqSet set) = maybeToBool (lookupUFM set x) +sizeUniqSet :: UniqSet a -> Int +sizeUniqSet (MkUniqSet set) = sizeUFM set + isEmptyUniqSet :: UniqSet a -> Bool isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-} @@ -103,15 +113,15 @@ mapUniqSet f (MkUniqSet set) addOneToUniqSet :: UniqSet Unique -> Unique -> UniqSet Unique #-} {-# SPECIALIZE - elementOfUniqSet :: RnName -> UniqSet RnName -> Bool + elementOfUniqSet :: Name -> UniqSet Name -> Bool , Unique -> UniqSet Unique -> Bool #-} {-# SPECIALIZE - mkUniqSet :: [RnName] -> UniqSet RnName + mkUniqSet :: [Name] -> UniqSet Name #-} {-# SPECIALIZE - unitUniqSet :: RnName -> UniqSet RnName + unitUniqSet :: Name -> UniqSet Name , Unique -> UniqSet Unique #-} #endif diff --git a/ghc/docs/state_interface/state-interface.verb b/ghc/docs/state_interface/state-interface.verb index 291d5f0..56a7df8 100644 --- a/ghc/docs/state_interface/state-interface.verb +++ b/ghc/docs/state_interface/state-interface.verb @@ -8,23 +8,112 @@ \begin{document} -\title{GHC prelude: types and operations} -\author{Simon L Peyton Jones \and John Launchbury \and Will Partain} +\title{The GHC Prelude and Libraries} +\author{Simon L Peyton Jones \and Will Partain} \maketitle \tableofcontents -This ``state interface document'' corresponds to Glasgow Haskell -version~2.01. +\section{Introduction} -\section{Really primitive stuff} +This document describes GHC's prelude and libraries. The basic story is that of +the Haskell 1.3 Report and Libraries document (which we do not reproduce here), +but this document describes in addition: +\begin{itemize} +\item GHC's additional non-standard libraries and types, such as state transformers, + packed strings, foreign objects, stable pointers, and so on. + +\item GHC's primitive types and operations. The standard Haskell functions are implemented + on top of these, and it is sometimes useful to use them directly. + +\item The organsiation of these libraries into directories. +\end{itemize} + +\section{Overview} + +The libraries are organised into the following three groups, each of which +is kept in a separate sub-directory of GHC's installed @lib/@ directory: +\begin{description} +\item[@lib/required/@] These are the libraries {\em required} by the Haskell +definition. All are defined by the Haskell Report, or by the Haskell Libraries Report. +They currently comprise: +\begin{itemize} +\item @Prelude@. +\item @List@: more functions on lists. +\item @Char@: more functions on characters. +\item @Maybe@: more functions on @Maybe@ types. +\item @Complex@: functions on complex numbers. +\item @Ratio@: functions on rational numbers. +\item @Monad@: functions on characters. +\item @Ix@: the @Ix@ class of indexing operations. +\item @Array@: monolithic arrays. +\item @IO@: basic input/output functions. +\item @Directory@: basic functions for accessing the file system. +\item @System@: basic operating-system interface functions. +\end{itemize} + +\item[@lib/glaExts@] GHC extension libraries, currently comprising: +\begin{itemize} +\item @PackedString@: functions that manipulate strings packed efficiently, one character per byte. +\item @ST@: the state transformer monad. +\item @Foreign@: types and operations for GHC's foreign-language interface. +\end{itemize} + +\item[@lib/concurrent@] GHC extension libraries to support Concurrent Haskell, currently comprising: +\begin{itemize} +\item @Concurrent.hs@: main library. +\item @Parallel.hs@: stuff for multi-processor parallelism. +\item @Channel.hs@ +\item @ChannelVar.hs@ +\item @Merge.hs@ +\item @SampleVar.hs@ +\item @Semaphore.hs@ +\end{itemize} + +\item[@lib/ghc@] These libraries are the pieces on which all the others are built. +They aren't typically imported by Joe Programmer, but there's nothing to stop you +doing so if you want. In general, the modules prefixed by @Prel@ are pieces that go +towards building @Prelude@. + +\begin{itemize} +\item @GHC@: this ``library'' brings into scope all the primitive types and operations, such as +@Int#@, @+#@, @encodeFloat#@, etc etc. It is unique in that there is no Haskell +source code for it. Details in Section \ref{sect:ghc}. + +\item @PrelBase@: defines the basic types and classes without which very few Haskell programs can work. +The classes are: @Eq@, @Ord@, @Enum@, @Bounded@, @Num@, @Show@, @Eval@, @Monad@, @MonadZero@, @MonadPlus@. +The types are: list, @Bool@, @Char@, @Ordering@, @String@, @Int@, @Integer@, @Maybe@, @Either@. + +\item @PrelTup@: defines tuples and their instances. +\item @PrelList@: defines most of the list operations required by @Prelude@. (A few are in @PrelBase@. + +\item @PrelNum@ defines: the numeric classes beyond @Num@ (namely @Real@, @Integral@, +@Fractional@, @Floating@, @RealFrac@, @RealFloat@; instances for appropriate classes +for @Int@ and @Integer@; the types @Float@, @Double@, and @Ratio@ and their instances. + +\item @PrelRead@: the @Read@ class and all its instances. It's kept separate because many programs +don't use @Read@ at all, so we don't even want to link in its code. + +\item @ConcBase@: substrate stuff for Concurrent Haskell. + +\item @IOBase@: substrate stuff for the main I/O libraries. +\item @IOHandle@: large blob of code for doing I/O on handles. +\item @PrelIO@: the remaining small pieces to produce the I/O stuff needed by @Prelude@. +\item @GHCerr@: error reporting code, called from code that the compiler plants in compiled programs. +\item @GHCmain@: the definition of @mainPrimIO@, which is what {\em really} gets + called by the runtime system. @mainPrimIO@ in turn calls @main@. +\end{itemize} +\end{description} + +\section{The module @GHC@: really primitive stuff} +\label{sect:ghc} This section defines all the types which are primitive in Glasgow Haskell, and the operations provided for them. -A primitive type is one which cannot be defined in Haskell, and which is -therefore built into the language and compiler. -Primitive types are always unboxed; that is, a value of primitive type cannot be +A primitive type is one which cannot be defined in Haskell, and which +is therefore built into the language and compiler. Primitive types +are always unboxed; that is, a value of primitive type cannot be bottom. Primitive values are often represented by a simple bit-pattern, such as @Int#@, diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl index f97cbd9..36c100d 100644 --- a/ghc/driver/ghc-iface.lprl +++ b/ghc/driver/ghc-iface.lprl @@ -5,6 +5,15 @@ %************************************************************************ \begin{code} +%OldVersion = (); +%Decl = (); # details about individual definitions +%Stuff = (); # where we glom things together +%HiExists = ('old',-1, 'new',-1); # 1 <=> definitely exists; 0 <=> doesn't +%HiHasBeenRead = ('old', 0, 'new', 0); +%ModuleVersion = ('old', 0, 'new', 0); + + + sub postprocessHiFile { local($hsc_hi, # The iface info produced by hsc. $hifile_target, # The name both of the .hi file we @@ -14,7 +23,7 @@ sub postprocessHiFile { local($new_hi) = "$Tmp_prefix.hi-new"; -# print STDERR `$Cat $hsc_hi`; +# print STDERR `$Cat $hsc_hi`; &constructNewHiFile($hsc_hi, $hifile_target, $new_hi); @@ -53,16 +62,16 @@ sub deUsagifyHi { open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n"); open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n"); - # read up to __usages__ line + # read up to _usages_ line $_ = ; - while ($_ ne '' && ! /^__usages__/) { - print NEWHIF $_ unless /^(interface |\{-# GHC_PRAGMA)/; + while ($_ ne '' && ! /^_usages_/) { + print NEWHIF $_ unless /^(_interface_ |\{-# GHC_PRAGMA)/; $_ = ; } if ( $_ ne '' ) { - # skip to next __ line + # skip to next _ line $_ = ; - while ($_ ne '' && ! /^__/) { $_ = ; } + while ($_ ne '' && ! /^_/) { $_ = ; } # print the rest while ($_ ne '') { @@ -87,67 +96,48 @@ sub constructNewHiFile { open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n"); - local($new_module_version) = &calcNewModuleVersion(); - print NEWHI "interface ", $ModuleName{'new'}, " $new_module_version\n"; - - print NEWHI "__usages__\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq ''; - - local(@version_keys) = sort (keys %Version); - local($num_ver_things) = 0; - foreach $v (@version_keys) { - next unless $v =~ /^new:(.*$)/; - last if $num_ver_things >= 1; - $num_ver_things++; - } - - print NEWHI "__versions__\n" unless $num_ver_things < 1; - foreach $v (@version_keys) { + local(@decl_names) = (); # Entities in _declarations_ section of new module + foreach $v (sort (keys %Decl)) { next unless $v =~ /^new:(.*$)/; - $v = $1; - - &printNewItemVersion($v, $new_module_version), "\n"; + push(@decl_names,$1); } - print NEWHI "__exports__\n"; - print NEWHI $Stuff{'new:exports'}; + local($new_module_version) = &calcNewModuleVersion(@decl_names); + print NEWHI "_interface_ ", $ModuleName{'new'}, " $new_module_version\n"; if ( $Stuff{'new:instance_modules'} ) { - print NEWHI "__instance_modules__\n"; + print NEWHI "_instance_modules_\n"; print NEWHI $Stuff{'new:instance_modules'}; } + print NEWHI "_usages_\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq ''; + + print NEWHI "_exports_\n"; + print NEWHI $Stuff{'new:exports'}; + if ( $Stuff{'new:fixities'} ) { - print NEWHI "__fixities__\n"; + print NEWHI "_fixities_\n"; print NEWHI $Stuff{'new:fixities'}; } - if ( $Stuff{'new:declarations'} ) { - print NEWHI "__declarations__\n"; - print NEWHI $Stuff{'new:declarations'}; - } - if ( $Stuff{'new:instances'} ) { - print NEWHI "__instances__\n"; + print NEWHI "_instances_\n"; print NEWHI $Stuff{'new:instances'}; } - if ( $Stuff{'new:pragmas'} ) { - print NEWHI "__pragmas__\n"; - print NEWHI $Stuff{'new:pragmas'}; + print NEWHI "_declarations_\n"; + foreach $v (@decl_names) { + &printNewItemVersion(NEWHI, $v, $new_module_version); # Print new version number + print NEWHI $Decl{"new:$v"}; # Print the new decl itself } + + close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n"); } \end{code} \begin{code} -%Version = (); -%Decl = (); # details about individual definitions -%Stuff = (); # where we glom things together -%HiExists = ('old',-1, 'new',-1); # 1 <=> definitely exists; 0 <=> doesn't -%HiHasBeenRead = ('old', 0, 'new', 0); -%ModuleVersion = ('old', 0, 'new', 0); - sub readHiFile { local($mod, # module to read; can be special tag 'old' # (old .hi file for module being compiled) or @@ -158,13 +148,12 @@ sub readHiFile { $HiExists{$mod} = -1; # 1 <=> definitely exists; 0 <=> doesn't $HiHasBeenRead{$mod} = 0; $ModuleVersion{$mod} = 0; + $Stuff{"$mod:instance_modules"} = ''; $Stuff{"$mod:usages"} = ''; # stuff glommed together $Stuff{"$mod:exports"} = ''; - $Stuff{"$mod:instance_modules"} = ''; - $Stuff{"$mod:instances"} = ''; $Stuff{"$mod:fixities"} = ''; + $Stuff{"$mod:instances"} = ''; $Stuff{"$mod:declarations"} = ''; - $Stuff{"$mod:pragmas"} = ''; if (! -f $hifile) { # no pre-existing .hi file $HiExists{$mod} = 0; @@ -185,52 +174,65 @@ sub readHiFile { last hi_line; } - if ( /^interface ([A-Z]\S*) (\d+)/ ) { + if ( /^_interface_ ([A-Z]\S*) (\d+)/ ) { $ModuleName{$mod} = $1; # not sure this is used much... $ModuleVersion{$mod} = $2; - } elsif ( /^interface ([A-Z]\S*)/ && $mod eq 'new' ) { # special case: no version + } elsif ( /^_interface_ ([A-Z]\S*)/ && $mod eq 'new' ) { # special case: no version $ModuleName{'new'} = $1; - } elsif ( /^__([a-z]+)__$/ ) { + } elsif ( /^_([a-z_]+)_$/ ) { $now_in = $1; } elsif ( $now_in eq 'usages' && /^(\S+)\s+(\d+)\s+:: (.*)/ ) { $Stuff{"$mod:usages"} .= $_; # save the whole thing - } elsif ( $now_in eq 'versions' && /^(\S+) (\d+)/ ) { - local($item) = $1; - local($n) = $2; -#print STDERR "version read:item=$item, n=$n, line=$_"; - $Version{"$mod:$item"} = $n; - } elsif ( $now_in eq 'versions' && /^(\S+)/ && $mod eq 'new') { # doesn't have versions - local($item) = $1; -#print STDERR "new version read:item=$item, line=$_"; - $Version{"$mod:$item"} = 'y'; # stub value... - - } elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities|pragmas)$/ ) { + } elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities)$/ ) { $Stuff{"$mod:$1"} .= $_; # just save it up } elsif ( $now_in eq 'declarations' ) { # relatively special treatment needed... - $Stuff{"$mod:declarations"} .= $_; # just save it up - - if ( /^[A-Z][A-Za-z0-9_']*\.(\S+)\s+::\s+/ ) { - $Decl{"$mod:$1"} = $_; - - } elsif ( /^type\s+[A-Z][A-Za-z0-9_']*\.(\S+)/ ) { - $Decl{"$mod:$1"} = $_; - - } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) { - $Decl{"$mod:$3"} = $_; - - } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+.*where\s+\{.*\};/ ) { - $Decl{"$mod:$2"} = $_; # must be wary of => bit matching after "where"... - } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) { - $Decl{"$mod:$2"} = $_; - - } else { # oh, well... - print STDERR "$Pgm: decl line didn't match?\n$_"; + # We're in a declaration + + # Strip off the initial version number, if any + if ( /^([0-9]+) (.*\n)/ ) { + # The "\n" is because we need to keep the newline at the end, so that + # it looks the same as if there's no version number and this if statement + # doesn't fire. + + # So there's an initial version number + $version = $1; + $_ = $2; + } + + if ( /^(\S+)\s+::\s+/ ) { + $current_name = $1; + $Decl{"$mod:$current_name"} = $_; + if ($mod eq "old") { $OldVersion{$current_name} = $version; } + + } elsif ( /^type\s+(\S+)/ ) { + $current_name = $1; + $Decl{"$mod:$current_name"} = $_; + if ($mod eq "old") { $OldVersion{$current_name} = $version; } + + } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?(\S+)\s+/ ) { + $current_name = $3; + $Decl{"$mod:$current_name"} = $_; + if ($mod eq "old") { $OldVersion{$current_name} = $version; } + + } elsif ( /class\s+(.*\s+=>\s+)?(\S+)\s+.*where\s+\{.*\};/ ) { + # must be wary of => bit matching after "where"... + $current_name = $2; + $Decl{"$mod:$current_name"} = $_; + if ($mod eq "old") { $OldVersion{$current_name} = $version; } + + } elsif ( /class\s+(.*\s+=>\s+)?(\S+)\s+/ ) { + $current_name = $2; + $Decl{"$mod:$current_name"} = $_; + if ($mod eq "old") { $OldVersion{$current_name} = $version; } + + } else { # Continuation line + $Decl{"$mod:$current_name"} .= $_ } } else { @@ -249,6 +251,7 @@ sub readHiFile { \begin{code} sub calcNewModuleVersion { + local (@decl_names) = @_; return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0; # could use "time()" as initial version; if a module existed, then was deleted, @@ -259,43 +262,49 @@ sub calcNewModuleVersion { local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two local($changed_version) = $unchanged_version + 1; - return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'}; +# This statement is curious; it is subsumed by the foreach! +# return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'}; - foreach $t ( 'exports', 'instance_modules', 'instances', 'fixities', 'declarations', 'pragmas' ) { + foreach $t ( 'usages' , 'exports', 'instance_modules', 'instances', 'fixities' ) { return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"}; } +# Decl need separate treatment; they aren't in $Stuff + foreach $v (@decl_names) { + return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"}; + } + + print STDERR "Module version unchanged at $unchanged_version\n"; return($unchanged_version); } sub mv_change { local($mv, $str) = @_; -#print STDERR "$Pgm: module version changed to $mv; reason: $str\n"; + print STDERR "$Pgm: module version changed to $mv; reason: $str\n"; return($mv); } sub printNewItemVersion { - local($item, $mod_version) = @_; + local($hifile, $item, $mod_version) = @_; + local($idecl) = $Decl{"new:$item"}; - if (! defined($Decl{"new:$item"}) ) { -# it's OK, because the thing is almost-certainly wired-in -# print STDERR "$item: no decl?! (nothing into __versions__)\n"; - return; - } + if (! defined($Decl{"old:$item"})) { # Old decl doesn't exist + print STDERR "new: $item\n"; + print $hifile "$mod_version "; # Use module version - local($idecl) = $Decl{"new:$item"}; + } elsif ($idecl ne $Decl{"old:$item"}) { # Old decl differs from new decl + local($odecl) = $Decl{"old:$item"}; +# print STDERR "changed: $item\nOld: $odecl\nNew: $idecl\n"; + print $hifile "$mod_version "; # Use module version - if (! defined($Decl{"old:$item"})) { -#print STDERR "new: $item\n"; - print NEWHI "$item $mod_version\n"; - } elsif ($idecl ne $Decl{"old:$item"}) { -#print STDERR "changed: $item\n"; - print NEWHI "$item $mod_version\n"; - } elsif (! defined($Version{"old:$item"}) ) { -#print STDERR "$item: no old version?!\n" - } else { - print NEWHI "$item ", $Version{"old:$item"}, "\n"; + } elsif (! defined($OldVersion{"$item"}) ) { + print STDERR "$item: no old version?!\n"; + print $hifile "$mod_version "; # Use module version + + } else { # Identical decls, so use old version number + print STDERR "$item: unchanged\n"; + print $hifile $OldVersion{"$item"}, " "; } return; } diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 653e546..a6d5f13 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -410,10 +410,14 @@ require special handling. @SysImport_dir = ( $(INSTALLING) ) ? ( "$InstDataDirGhc/imports" ) - : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/prelude" + : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/ghc" + , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/glaExts" , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/required" , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/concurrent" ); +# We need to look in ghc/ and glaExts/ when searching for implicitly needed .hi files, but +# we should really *not* look there for explicitly imported modules. + $GhcVersionInfo = int ($(PROJECTVERSION) * 100); $Haskell1Version = 3; # i.e., Haskell 1.3 @Cpp_define = (); @@ -899,10 +903,7 @@ arg: while($_ = $ARGV[0]) { /^-user-prelude-force/ && do { # ignore if not -user-prelude next arg; }; - /^-split-objs(.*)/ && do { - local($sname) = &grab_arg_arg('-split-objs', $1); - $sname =~ s/ //g; # no spaces - + /^-split-objs/ && do { if ( $TargetPlatform !~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|sparc)-/ ) { $SplitObjFiles = 0; print STDERR "WARNING: don't know how to split objects on this platform: $TargetPlatform\n`-split-objs' option ignored\n"; @@ -910,7 +911,7 @@ arg: while($_ = $ARGV[0]) { $SplitObjFiles = 1; $HscOut = '-C='; - push(@HsC_flags, "-fglobalise-toplev-names=$sname"); + push(@HsC_flags, "-fglobalise-toplev-names"); push(@CcBoth_flags, '-DUSE_SPLIT_MARKERS'); require('ghc-split.prl') @@ -1031,6 +1032,7 @@ arg: while($_ = $ARGV[0]) { /^-d(dump|ppr)-/ && do { push(@HsC_flags, $_); next arg; }; /^-dverbose-(simpl|stg)/ && do { push(@HsC_flags, $_); next arg; }; /^-dshow-passes/ && do { push(@HsC_flags, $_); next arg; }; + /^-dshow-rn-trace/ && do { push(@HsC_flags, $_); next arg; }; /^-dsource-stats/ && do { push(@HsC_flags, $_); next arg; }; /^-dsimplifier-stats/ && do { push(@HsC_flags, $_); next arg; }; /^-dstg-stats/ && do { $Oopt_StgStats = $_; next arg; }; @@ -1400,7 +1402,7 @@ It really really wants to be the last STG-to-STG pass that is run. '-fdo-case-elim', '-fcase-merge', '-fdo-eta-reduction', - '-fdo-lambda-eta-expansion', + '-fdo-lambda-eta-expansion', # After full laziness '-freuse-con', $Oopt_PedanticBottoms, $Oopt_MonadEtaExpansion, @@ -1490,7 +1492,7 @@ It really really wants to be the last STG-to-STG pass that is run. #LATER: '-fcalc-inlinings2', -- pointless for 2.01 # stg2stg passes -#LATER: '-fupdate-analysis', + '-fupdate-analysis', '-flambda-lift', $Oopt_FinalStgProfilingMassage, $Oopt_StgStats, @@ -1706,14 +1708,15 @@ $Under = ( $TargetPlatform =~ /^alpha-/ unshift(@Ld_flags, (($Ld_main) ? ( '-u', "${Under}Main_" . $Ld_main . '_closure', - ) : (), - '-u', "${Under}GHCbase_unsafePerformPrimIO_fast1", - '-u', "${Under}Prelude_Z91Z93_closure", # i.e., [] - '-u', "${Under}Prelude_IZh_static_info", - '-u', "${Under}Prelude_False_inregs_info", - '-u', "${Under}Prelude_True_inregs_info", - '-u', "${Under}Prelude_CZh_static_info", - '-u', "${Under}DEBUG_REGS")) + ) : () +# , '-u', "${Under}STbase_unsafePerformPrimIO_fast1" +# , '-u', "${Under}Prelude_Z91Z93_closure" # i.e., [] +# , '-u', "${Under}Prelude_IZh_static_info" +# , '-u', "${Under}Prelude_False_inregs_info" +# , '-u', "${Under}Prelude_True_inregs_info" +# , '-u', "${Under}Prelude_CZh_static_info" +# , '-u', "${Under}DEBUG_REGS" + )) ; # just for fun, now... \end{code} @@ -2084,57 +2087,13 @@ phase) to @"$ifile_root."@. \end{code} -Check if hsc needs to be run at all. - -\begin{code} - local($more_processing_required) = 1; - - if ( $Do_recomp_chkr && $do_hsc && ! $going_interactive ) { - # recompilation-checking is important enough to live off by itself - require('ghc-recomp.prl') - || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-recomp.prl!\n"); - - $more_processing_required - = &runRecompChkr($ifile, $hscpp_hsc, $ifile_root, $ofile_target, $hifile_target); - if ( ! $more_processing_required ) { - print STDERR "$Pgm:recompile: NOT NEEDED!\n"; # Yay! - # propagate dependency: - &run_something("touch $ofile_target", "Touch $ofile_target, to propagate dependencies"); - } - } - - $do_hsc = 0, $do_cc = 0, $do_as = 0 if ! $more_processing_required; -\end{code} +Now the Haskell compiler, C compiler, and assembler \begin{code} - if ( $do_hsc ) { - - &runHsc($ifile_root, $hsc_out, $hsc_hi, $going_interactive); - - # interface-handling is important enough to live off by itself - require('ghc-iface.prl') - || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n"); - - &postprocessHiFile($hsc_hi, $hifile_target, $going_interactive); - - # save a copy of the .hc file, even if we are carrying on... - if ($HscOut eq '-C=' && $do_cc && $Keep_hc_file_too) { - local($to_do) = "$Rm $ifile_root.hc; $Cp $hsc_out $ifile_root.hc"; - &run_something($to_do, 'Saving copy of .hc file'); - } - - # save a copy of the .s file, even if we are carrying on... - if ($HscOut eq '-S=' && $do_as && $Keep_s_file_too) { - local($to_do) = "$Rm $ifile_root.s; $Cp $hsc_out $ifile_root.s"; - &run_something($to_do, 'Saving copy of .s file'); - } - - # if we're going to split up object files, - # we inject split markers into the .hc file now - if ( $HscOut eq '-C=' && $SplitObjFiles ) { - &inject_split_markers ( $hsc_out ); - } + if ($do_hsc) { + &runHscAndProcessInterfaces( $ifile, $hscpp_hsc, $ifile_root, + $ofile_target, $hifile_target); } if ($do_cc) { @@ -2205,6 +2164,117 @@ sub runHscpp { \end{code} \begin{code} +sub runHscAndProcessInterfaces { + local($ifile, $hscpp_hsc, $ifiel_root, $ofile_target, $hifile_target) = @_; + + # $ifile is the original input file + # $hscpp_hsc post-unlit, post-cpp, etc., input file + # $ifile_root input filename minus suffix + # $ofile_target the output file that we ultimately hope to produce + # $hifile_target the .hi file ... (ditto) + + local($source_unchanged) = 1; + +# Check if the source file is up to date relative to the target; in +# that case we say "source is unchanged" and let the compiler bale out +# early if the import usage information allows it. + + ($i_dev,$i_ino,$i_mode,$i_nlink,$i_uid,$i_gid,$i_rdev,$i_size, + $i_atime,$i_mtime,$i_ctime,$i_blksize,$i_blocks) = stat($ifile); + + if ( ! -f $ofile_target ) { + print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n"; + $source_unchanged = 0; + } + + ($o_dev,$o_ino,$o_mode,$o_nlink,$o_uid,$o_gid,$o_rdev,$o_size, + $o_atime,$o_mtime,$o_ctime,$o_blksize,$o_blocks) = stat(_); # stat info from -f test + + if ( ! -f $hifile_target ) { + print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n"; + $source_unchanged = 0; + } + + ($hi_dev,$hi_ino,$hi_mode,$hi_nlink,$hi_uid,$hi_gid,$hi_rdev,$hi_size, + $hi_atime,$hi_mtime,$hi_ctime,$hi_blksize,$hi_blocks) = stat(_); # stat info from -f test + + if ($i_mtime > $o_mtime) { + print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n"; + $source_unchanged = 0; + } + + # So if source_unchanged is still "1", we pass on the good news to the compiler + # The -recomp flag can disable this, forcing recompilation + if ($Do_recomp_chkr && $source_unchanged) { + push(@HsC_flags, '-fsource-unchanged'); + } + +# Run the compiler + + &runHsc($ifile_root, $hsc_out, $hsc_hi, $going_interactive); + +# See if it baled out early, saying nothing needed doing. +# We work this out by seeing if it created an output .hi file + + if ( ! -f $hsc_hi ) { + # Doesn't exist, so we baled out early. + # Tell the C compiler and assembler not to run + $do_cc = 0; $do_as = 0; + + # Update dependency info + &run_something("touch $ofile_target", "Touch $ofile_target, to propagate dependencies"); + + } else { + +# Didn't bale out early (new .hi file) so we thunder on + + # If non-interactive, heave in the consistency info at the end + # NB: pretty hackish (depends on how $output is set) + if ( ! $going_interactive ) { + if ( $HscOut eq '-C=' ) { + $to_do = "echo 'static char ghc_hsc_ID[] = \"\@(#)hsc $ifile\t$HsC_major_version.$HsC_minor_version,$HsC_consist_options\";' >> $hsc_out"; + + } elsif ( $HscOut eq '-S=' ) { + local($consist) = "hsc.$ifile.$HsC_major_version.$HsC_minor_version.$HsC_consist_options"; + $consist =~ s/,/./g; + $consist =~ s/\//./g; + $consist =~ s/-/_/g; + $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? + $to_do = "echo '\n\t.text\n$consist:' >> $hsc_out"; + } + &run_something($to_do, 'Pin on Haskell consistency info'); + } + + + # Interface-handling is important enough to live off by itself + require('ghc-iface.prl') + || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n"); + + &postprocessHiFile($hsc_hi, $hifile_target, $going_interactive); + + # save a copy of the .hc file, even if we are carrying on... + if ($HscOut eq '-C=' && $do_cc && $Keep_hc_file_too) { + local($to_do) = "$Rm $ifile_root.hc; $Cp $hsc_out $ifile_root.hc"; + &run_something($to_do, 'Saving copy of .hc file'); + } + + # save a copy of the .s file, even if we are carrying on... + if ($HscOut eq '-S=' && $do_as && $Keep_s_file_too) { + local($to_do) = "$Rm $ifile_root.s; $Cp $hsc_out $ifile_root.s"; + &run_something($to_do, 'Saving copy of .s file'); + } + + # if we're going to split up object files, + # we inject split markers into the .hc file now + if ( $HscOut eq '-C=' && $SplitObjFiles ) { + &inject_split_markers ( $hsc_out ); + } + } +} +\end{code} + + +\begin{code} sub runHsc { local($ifile_root, $hsc_out, $hsc_hi, $going_interactive) = @_; @@ -2212,7 +2282,9 @@ sub runHsc { foreach $a ( @HsP_flags ) { $a = ",$a" unless $a =~ /^,/; } &makeHiMap() unless $HiMapDone; - push(@HsC_flags, "-himap=$HiMapFile"); +# print STDERR "HiIncludes: $HiIncludeString\n"; + push(@HsC_flags, "-himap=$HiIncludeString"); +# push(@HsC_flags, "-himap=$HiMapFile"); # here, we may produce .hc/.s and/or .hi files local($output) = ''; @@ -2254,23 +2326,6 @@ sub runHsc { # finish business w/ nofibbish time/bytes-alloc stats &process_ghc_timings() if $CollectGhcTimings; - - # if non-interactive, heave in the consistency info at the end - # NB: pretty hackish (depends on how $output is set) - if ( ! $going_interactive ) { - if ( $HscOut eq '-C=' ) { - $to_do = "echo 'static char ghc_hsc_ID[] = \"\@(#)hsc $ifile\t$HsC_major_version.$HsC_minor_version,$HsC_consist_options\";' >> $hsc_out"; - - } elsif ( $HscOut eq '-S=' ) { - local($consist) = "hsc.$ifile.$HsC_major_version.$HsC_minor_version.$HsC_consist_options"; - $consist =~ s/,/./g; - $consist =~ s/\//./g; - $consist =~ s/-/_/g; - $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly? - $to_do = "echo '\n\t.text\n$consist:' >> $hsc_out"; - } - &run_something($to_do, 'Pin on Haskell consistency info'); - } } \end{code} @@ -2280,6 +2335,7 @@ of (module-name, pathname) pairs, one per line, separated by a space. %HiMap = (); $HiMapDone = 0; $HiMapFile = ''; +$HiIncludeString = (); # dir1:dir2:dir3, to pass to GHC sub makeHiMap { @@ -2288,6 +2344,9 @@ sub makeHiMap { local($mod, $path, $d, $e); foreach $d ( @Import_dir ) { + if ($HiIncludeString) { $HiIncludeString = "$HiIncludeString:$d"; + } else { $HiIncludeString = $d; } + opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n"); local(@entry) = readdir(DIR); foreach $e ( @entry ) { @@ -2306,6 +2365,9 @@ sub makeHiMap { } foreach $d ( @SysImport_dir ) { + if ($HiIncludeString) { $HiIncludeString = "$HiIncludeString:$d"; + } else { $HiIncludeString = $d; } + opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n"); local(@entry) = readdir(DIR); foreach $e ( @entry ) { diff --git a/ghc/includes/CostCentre.lh b/ghc/includes/CostCentre.lh index 3993b29..4444090 100644 --- a/ghc/includes/CostCentre.lh +++ b/ghc/includes/CostCentre.lh @@ -394,6 +394,15 @@ extern F_ *register_stack; } while(0); \ FUNEND; } +#else /* PROFILING */ + +/* When things are working these shouldn't be emitted when not profiling, + but it was convenient at one point to have them expand to nothing + when not profiling. SLPJ Dec 96 */ + +#define START_REGISTER_CCS(reg_mod_name) +#define END_REGISTER_CCS() + #endif /* PROFILING */ \end{code} diff --git a/ghc/includes/SMInfoTables.lh b/ghc/includes/SMInfoTables.lh index 071bce3..674444d 100644 --- a/ghc/includes/SMInfoTables.lh +++ b/ghc/includes/SMInfoTables.lh @@ -476,6 +476,10 @@ to identify the closure type. #define INFO_BF_TYPE (MAKE_BASE_INFO_TYPE(21L) | _NS | _MU | _BH) #define INFO_INTERNAL_TYPE (MAKE_BASE_INFO_TYPE(22L)) +/* S = single-entry thunk + U = updatable thunk + N = head normal form */ + #define INFO_SPEC_N_TYPE (INFO_SPEC_TYPE | _NF | _NS) #define INFO_SPEC_S_TYPE (INFO_SPEC_TYPE | _TH) #define INFO_SPEC_U_TYPE (INFO_SPEC_TYPE | _UP | _TH) @@ -1742,7 +1746,7 @@ during a return. /* Declare the phantom info table vectors (just Bool at the moment) */ #ifndef COMPILING_GHC -EXTDATA_RO(Prelude_Bool_itblvtbl); +EXTDATA_RO(PrelBase_Bool_itblvtbl); #endif \end{code} diff --git a/ghc/includes/StgMacros.lh b/ghc/includes/StgMacros.lh index 7b8bb69..f7b21b6 100644 --- a/ghc/includes/StgMacros.lh +++ b/ghc/includes/StgMacros.lh @@ -390,12 +390,13 @@ even for 8-bit chars). #define ltCharZh(r,a,b) r=(I_)((a)< (b)) #define leCharZh(r,a,b) r=(I_)((a)<=(b)) -#define gtIntZh(r,a,b) r=(I_)((a) >(b)) -#define geIntZh(r,a,b) r=(I_)((a)>=(b)) -#define eqIntZh(r,a,b) r=(I_)((a)==(b)) -#define neIntZh(r,a,b) r=(I_)((a)!=(b)) -#define ltIntZh(r,a,b) r=(I_)((a) <(b)) -#define leIntZh(r,a,b) r=(I_)((a)<=(b)) +/* Int comparisons: >#, >=# etc */ +#define ZgZh(r,a,b) r=(I_)((a) >(b)) +#define ZgZeZh(r,a,b) r=(I_)((a)>=(b)) +#define ZeZeZh(r,a,b) r=(I_)((a)==(b)) +#define ZdZeZh(r,a,b) r=(I_)((a)!=(b)) +#define ZlZh(r,a,b) r=(I_)((a) <(b)) +#define ZlZeZh(r,a,b) r=(I_)((a)<=(b)) #define gtWordZh(r,a,b) r=(I_)((a) >(b)) #define geWordZh(r,a,b) r=(I_)((a)>=(b)) @@ -418,12 +419,13 @@ even for 8-bit chars). #define ltFloatZh(r,a,b) r=(I_)((a)< (b)) #define leFloatZh(r,a,b) r=(I_)((a)<=(b)) -#define gtDoubleZh(r,a,b) r=(I_)((a)> (b)) -#define geDoubleZh(r,a,b) r=(I_)((a)>=(b)) -#define eqDoubleZh(r,a,b) r=(I_)((a)==(b)) -#define neDoubleZh(r,a,b) r=(I_)((a)!=(b)) -#define ltDoubleZh(r,a,b) r=(I_)((a)< (b)) -#define leDoubleZh(r,a,b) r=(I_)((a)<=(b)) +/* Double comparisons: >##, >=#@ etc */ +#define ZgZhZh(r,a,b) r=(I_)((a) >(b)) +#define ZgZeZhZh(r,a,b) r=(I_)((a)>=(b)) +#define ZeZeZhZh(r,a,b) r=(I_)((a)==(b)) +#define ZdZeZhZh(r,a,b) r=(I_)((a)!=(b)) +#define ZlZhZh(r,a,b) r=(I_)((a) <(b)) +#define ZlZeZhZh(r,a,b) r=(I_)((a)<=(b)) \end{code} %************************************************************************ @@ -448,11 +450,11 @@ even for 8-bit chars). \begin{code} I_ stg_div PROTO((I_ a, I_ b)); -#define plusIntZh(r,a,b) r=(a)+(b) -#define minusIntZh(r,a,b) r=(a)-(b) -#define timesIntZh(r,a,b) r=(a)*(b) +#define ZpZh(r,a,b) r=(a)+(b) +#define ZmZh(r,a,b) r=(a)-(b) +#define ZtZh(r,a,b) r=(a)*(b) #define quotIntZh(r,a,b) r=(a)/(b) -#define divIntZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b)) +#define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b)) #define remIntZh(r,a,b) r=(a)%(b) #define negateIntZh(r,a) r=-(a) \end{code} @@ -530,10 +532,10 @@ I_ stg_div PROTO((I_ a, I_ b)); %************************************************************************ \begin{code} -#define plusDoubleZh(r,a,b) r=(a)+(b) -#define minusDoubleZh(r,a,b) r=(a)-(b) -#define timesDoubleZh(r,a,b) r=(a)*(b) -#define divideDoubleZh(r,a,b) r=(a)/(b) +#define ZpZhZh(r,a,b) r=(a)+(b) +#define ZmZhZh(r,a,b) r=(a)-(b) +#define ZtZhZh(r,a,b) r=(a)*(b) +#define ZdZhZh(r,a,b) r=(a)/(b) #define negateDoubleZh(r,a) r=-(a) #define int2DoubleZh(r,a) r=(StgDouble)(a) @@ -554,7 +556,8 @@ I_ stg_div PROTO((I_ a, I_ b)); #define sinhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a) #define coshDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a) #define tanhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a) -#define powerDoubleZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b) +/* Power: **## */ +#define ZtZtZhZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b) \end{code} %************************************************************************ diff --git a/ghc/lib/.depend b/ghc/lib/.depend index 832f3bb..9af0540 100644 --- a/ghc/lib/.depend +++ b/ghc/lib/.depend @@ -1,77 +1,701 @@ # DO NOT DELETE: Beginning of Haskell dependencies -prelude/GHCbase.o : prelude/GHCbase.hs -prelude/GHCbase.o : required/Array.hi -prelude/GHCbase.o : required/Char.hi -prelude/GHCbase.o : required/Ix.hi -prelude/GHCbase.o : required/Ratio.hi -prelude/GHCbase.o : prelude/GHCerr.hi -prelude/GHCerr.o : prelude/GHCerr.hs -prelude/GHCerr.o : prelude/GHCbase.hi -prelude/GHCio.o : prelude/GHCio.hs -prelude/GHCio.o : ../../ghc/includes/error.h -prelude/GHCio.o : prelude/GHCbase.hi -prelude/GHCio.o : required/Ix.hi -prelude/GHCmain.o : prelude/GHCmain.hs -prelude/GHCmain.o : prelude/GHCbase.hi -prelude/GHCps.o : prelude/GHCps.hs -prelude/GHCps.o : required/Ix.hi -prelude/GHCps.o : required/Char.hi -prelude/GHCps.o : prelude/GHCbase.hi -prelude/Prelude.o : prelude/Prelude.hs -prelude/Prelude.o : ./../includes/ieee-flpt.h -prelude/Prelude.o : prelude/GHCbase.hi -prelude/Prelude.o : prelude/GHCio.hi -prelude/Prelude.o : required/Ratio.hi -prelude/Prelude.o : required/Char.hi -prelude/Prelude.o : required/IO.hi -prelude/PreludeGlaST.o : prelude/PreludeGlaST.hs -prelude/PreludeGlaST.o : prelude/GHCbase.hi -required/Array.o : required/Array.hs +ghc/ArrBase.o : ghc/ArrBase.lhs +ghc/ArrBase.mc.o : ghc/ArrBase.lhs +ghc/ArrBase.norm.o : ghc/ArrBase.lhs +ghc/ArrBase.p.o : ghc/ArrBase.lhs +ghc/ArrBase.mc.o : ghc/IOBase.mc.hi +ghc/ArrBase.norm.o : ghc/IOBase.norm.hi +ghc/ArrBase.p.o : ghc/IOBase.p.hi +ghc/ArrBase.o : required/Ix.hi +ghc/ArrBase.mc.o : required/Ix.mc.hi +ghc/ArrBase.norm.o : required/Ix.norm.hi +ghc/ArrBase.p.o : required/Ix.p.hi +ghc/ArrBase.o : ghc/PrelList.hi +ghc/ArrBase.mc.o : ghc/PrelList.mc.hi +ghc/ArrBase.norm.o : ghc/PrelList.norm.hi +ghc/ArrBase.p.o : ghc/PrelList.p.hi +ghc/ArrBase.o : ghc/PrelNum.hi +ghc/ArrBase.mc.o : ghc/PrelNum.mc.hi +ghc/ArrBase.norm.o : ghc/PrelNum.norm.hi +ghc/ArrBase.p.o : ghc/PrelNum.p.hi +ghc/ArrBase.o : ghc/STBase.hi +ghc/ArrBase.mc.o : ghc/STBase.mc.hi +ghc/ArrBase.norm.o : ghc/STBase.norm.hi +ghc/ArrBase.p.o : ghc/STBase.p.hi +ghc/ArrBase.o : ghc/PrelBase.hi +ghc/ArrBase.mc.o : ghc/PrelBase.mc.hi +ghc/ArrBase.norm.o : ghc/PrelBase.norm.hi +ghc/ArrBase.p.o : ghc/PrelBase.p.hi +ghc/ArrBase.o : ghc/PrelTup.hi +ghc/ArrBase.mc.o : ghc/PrelTup.mc.hi +ghc/ArrBase.norm.o : ghc/PrelTup.norm.hi +ghc/ArrBase.p.o : ghc/PrelTup.p.hi +ghc/ArrBase.o : ghc/GHC.hi +ghc/ArrBase.mc.o : ghc/GHC.mc.hi +ghc/ArrBase.norm.o : ghc/GHC.norm.hi +ghc/ArrBase.p.o : ghc/GHC.p.hi +ghc/ConcBase.o : ghc/ConcBase.lhs +ghc/ConcBase.mc.o : ghc/ConcBase.lhs +ghc/ConcBase.norm.o : ghc/ConcBase.lhs +ghc/ConcBase.p.o : ghc/ConcBase.lhs +ghc/ConcBase.o : required/Prelude.hi +ghc/ConcBase.o : ghc/STBase.hi +ghc/ConcBase.o : ghc/GHCerr.hi +ghc/ConcBase.mc.o : ghc/STBase.mc.hi +ghc/ConcBase.norm.o : ghc/STBase.norm.hi +ghc/ConcBase.p.o : ghc/STBase.p.hi +ghc/GHCerr.o : ghc/GHCerr.lhs +ghc/GHCerr.mc.o : ghc/GHCerr.lhs +ghc/GHCerr.norm.o : ghc/GHCerr.lhs +ghc/GHCerr.p.o : ghc/GHCerr.lhs +ghc/GHCerr.o : ghc/IOBase.hi +ghc/GHCerr.mc.o : ghc/IOBase.mc.hi +ghc/GHCerr.norm.o : ghc/IOBase.norm.hi +ghc/GHCerr.p.o : ghc/IOBase.p.hi +ghc/GHCmain.o : ghc/GHCmain.lhs +ghc/GHCmain.mc.o : ghc/GHCmain.lhs +ghc/GHCmain.norm.o : ghc/GHCmain.lhs +ghc/GHCmain.p.o : ghc/GHCmain.lhs +ghc/GHCmain.mc.o : required/Prelude.mc.hi +ghc/GHCmain.norm.o : required/Prelude.norm.hi +ghc/GHCmain.p.o : required/Prelude.p.hi +ghc/GHCmain.o : ghc/IOBase.hi +ghc/GHCmain.mc.o : ghc/IOBase.mc.hi +ghc/GHCmain.norm.o : ghc/IOBase.norm.hi +ghc/GHCmain.p.o : ghc/IOBase.p.hi +ghc/GHCmain.o : ghc/STBase.hi +ghc/GHCmain.mc.o : ghc/STBase.mc.hi +ghc/GHCmain.norm.o : ghc/STBase.norm.hi +ghc/GHCmain.p.o : ghc/STBase.p.hi +ghc/IOBase.o : ghc/IOBase.lhs +ghc/IOBase.mc.o : ghc/IOBase.lhs +ghc/IOBase.norm.o : ghc/IOBase.lhs +ghc/IOBase.p.o : ghc/IOBase.lhs +ghc/IOBase.o : ../../ghc/includes/error.h +ghc/IOBase.mc.o : ../../ghc/includes/error.h +ghc/IOBase.norm.o : ../../ghc/includes/error.h +ghc/IOBase.p.o : ../../ghc/includes/error.h +ghc/IOBase.mc.o : required/Prelude.mc.hi +ghc/IOBase.norm.o : required/Prelude.norm.hi +ghc/IOBase.p.o : required/Prelude.p.hi +ghc/IOBase.o : ghc/STBase.hi +ghc/IOBase.mc.o : ghc/STBase.mc.hi +ghc/IOBase.norm.o : ghc/STBase.norm.hi +ghc/IOBase.p.o : ghc/STBase.p.hi +ghc/IOBase.o : ghc/PrelTup.hi +ghc/IOBase.mc.o : ghc/PrelTup.mc.hi +ghc/IOBase.norm.o : ghc/PrelTup.norm.hi +ghc/IOBase.p.o : ghc/PrelTup.p.hi +ghc/IOBase.o : glaExts/Foreign.hi +ghc/IOBase.mc.o : glaExts/Foreign.mc.hi +ghc/IOBase.norm.o : glaExts/Foreign.norm.hi +ghc/IOBase.p.o : glaExts/Foreign.p.hi +ghc/IOBase.o : glaExts/PackedString.hi +ghc/IOBase.mc.o : glaExts/PackedString.mc.hi +ghc/IOBase.norm.o : glaExts/PackedString.norm.hi +ghc/IOBase.p.o : glaExts/PackedString.p.hi +ghc/IOBase.o : ghc/PrelBase.hi +ghc/IOBase.mc.o : ghc/PrelBase.mc.hi +ghc/IOBase.norm.o : ghc/PrelBase.norm.hi +ghc/IOBase.p.o : ghc/PrelBase.p.hi +ghc/IOBase.o : ghc/GHC.hi +ghc/IOBase.mc.o : ghc/GHC.mc.hi +ghc/IOBase.norm.o : ghc/GHC.norm.hi +ghc/IOBase.p.o : ghc/GHC.p.hi +ghc/IOHandle.o : ghc/IOHandle.lhs +ghc/IOHandle.mc.o : ghc/IOHandle.lhs +ghc/IOHandle.norm.o : ghc/IOHandle.lhs +ghc/IOHandle.p.o : ghc/IOHandle.lhs +ghc/IOHandle.o : ../../ghc/includes/error.h +ghc/IOHandle.mc.o : ../../ghc/includes/error.h +ghc/IOHandle.norm.o : ../../ghc/includes/error.h +ghc/IOHandle.p.o : ../../ghc/includes/error.h +ghc/IOHandle.mc.o : required/Prelude.mc.hi +ghc/IOHandle.norm.o : required/Prelude.norm.hi +ghc/IOHandle.p.o : required/Prelude.p.hi +ghc/IOHandle.o : glaExts/ST.hi +ghc/IOHandle.mc.o : glaExts/ST.mc.hi +ghc/IOHandle.norm.o : glaExts/ST.norm.hi +ghc/IOHandle.p.o : glaExts/ST.p.hi +ghc/IOHandle.o : ghc/STBase.hi +ghc/IOHandle.mc.o : ghc/STBase.mc.hi +ghc/IOHandle.norm.o : ghc/STBase.norm.hi +ghc/IOHandle.p.o : ghc/STBase.p.hi +ghc/IOHandle.o : ghc/ArrBase.hi +ghc/IOHandle.mc.o : ghc/ArrBase.mc.hi +ghc/IOHandle.norm.o : ghc/ArrBase.norm.hi +ghc/IOHandle.p.o : ghc/ArrBase.p.hi +ghc/IOHandle.o : ghc/PrelRead.hi +ghc/IOHandle.mc.o : ghc/PrelRead.mc.hi +ghc/IOHandle.norm.o : ghc/PrelRead.norm.hi +ghc/IOHandle.p.o : ghc/PrelRead.p.hi +ghc/IOHandle.o : required/Ix.hi +ghc/IOHandle.mc.o : required/Ix.mc.hi +ghc/IOHandle.norm.o : required/Ix.norm.hi +ghc/IOHandle.p.o : required/Ix.p.hi +ghc/IOHandle.o : ghc/IOBase.hi +ghc/IOHandle.mc.o : ghc/IOBase.mc.hi +ghc/IOHandle.norm.o : ghc/IOBase.norm.hi +ghc/IOHandle.p.o : ghc/IOBase.p.hi +ghc/IOHandle.o : ghc/PrelTup.hi +ghc/IOHandle.mc.o : ghc/PrelTup.mc.hi +ghc/IOHandle.norm.o : ghc/PrelTup.norm.hi +ghc/IOHandle.p.o : ghc/PrelTup.p.hi +ghc/IOHandle.o : ghc/PrelBase.hi +ghc/IOHandle.mc.o : ghc/PrelBase.mc.hi +ghc/IOHandle.norm.o : ghc/PrelBase.norm.hi +ghc/IOHandle.p.o : ghc/PrelBase.p.hi +ghc/IOHandle.o : ghc/GHC.hi +ghc/IOHandle.mc.o : ghc/GHC.mc.hi +ghc/IOHandle.norm.o : ghc/GHC.norm.hi +ghc/IOHandle.p.o : ghc/GHC.p.hi +ghc/PrelBase.o : ghc/PrelBase.lhs +ghc/PrelBase.mc.o : ghc/PrelBase.lhs +ghc/PrelBase.norm.o : ghc/PrelBase.lhs +ghc/PrelBase.p.o : ghc/PrelBase.lhs +ghc/PrelBase.mc.o : required/Prelude.mc.hi +ghc/PrelBase.norm.o : required/Prelude.norm.hi +ghc/PrelBase.p.o : required/Prelude.p.hi +ghc/PrelBase.mc.o : ghc/IOBase.mc.hi +ghc/PrelBase.norm.o : ghc/IOBase.norm.hi +ghc/PrelBase.p.o : ghc/IOBase.p.hi +ghc/PrelBase.o : ghc/GHC.hi +ghc/PrelBase.mc.o : ghc/GHC.mc.hi +ghc/PrelBase.norm.o : ghc/GHC.norm.hi +ghc/PrelBase.p.o : ghc/GHC.p.hi +ghc/PrelIO.o : ghc/PrelIO.lhs +ghc/PrelIO.mc.o : ghc/PrelIO.lhs +ghc/PrelIO.norm.o : ghc/PrelIO.lhs +ghc/PrelIO.p.o : ghc/PrelIO.lhs +ghc/PrelIO.mc.o : required/Prelude.mc.hi +ghc/PrelIO.norm.o : required/Prelude.norm.hi +ghc/PrelIO.p.o : required/Prelude.p.hi +ghc/PrelIO.o : required/IO.hi +ghc/PrelIO.mc.o : required/IO.mc.hi +ghc/PrelIO.norm.o : required/IO.norm.hi +ghc/PrelIO.p.o : required/IO.p.hi +ghc/PrelIO.o : ghc/IOHandle.hi +ghc/PrelIO.mc.o : ghc/IOHandle.mc.hi +ghc/PrelIO.norm.o : ghc/IOHandle.norm.hi +ghc/PrelIO.p.o : ghc/IOHandle.p.hi +ghc/PrelIO.o : ghc/IOBase.hi +ghc/PrelIO.mc.o : ghc/IOBase.mc.hi +ghc/PrelIO.norm.o : ghc/IOBase.norm.hi +ghc/PrelIO.p.o : ghc/IOBase.p.hi +ghc/PrelIO.o : ghc/PrelBase.hi +ghc/PrelIO.mc.o : ghc/PrelBase.mc.hi +ghc/PrelIO.norm.o : ghc/PrelBase.norm.hi +ghc/PrelIO.p.o : ghc/PrelBase.p.hi +ghc/PrelIO.o : ghc/PrelRead.hi +ghc/PrelIO.mc.o : ghc/PrelRead.mc.hi +ghc/PrelIO.norm.o : ghc/PrelRead.norm.hi +ghc/PrelIO.p.o : ghc/PrelRead.p.hi +ghc/PrelList.o : ghc/PrelList.lhs +ghc/PrelList.mc.o : ghc/PrelList.lhs +ghc/PrelList.norm.o : ghc/PrelList.lhs +ghc/PrelList.p.o : ghc/PrelList.lhs +ghc/PrelList.mc.o : required/Prelude.mc.hi +ghc/PrelList.norm.o : required/Prelude.norm.hi +ghc/PrelList.p.o : required/Prelude.p.hi +ghc/PrelList.mc.o : ghc/IOBase.mc.hi +ghc/PrelList.norm.o : ghc/IOBase.norm.hi +ghc/PrelList.p.o : ghc/IOBase.p.hi +ghc/PrelList.o : ghc/PrelTup.hi +ghc/PrelList.mc.o : ghc/PrelTup.mc.hi +ghc/PrelList.norm.o : ghc/PrelTup.norm.hi +ghc/PrelList.p.o : ghc/PrelTup.p.hi +ghc/PrelList.o : ghc/PrelBase.hi +ghc/PrelList.mc.o : ghc/PrelBase.mc.hi +ghc/PrelList.norm.o : ghc/PrelBase.norm.hi +ghc/PrelList.p.o : ghc/PrelBase.p.hi +ghc/PrelNum.o : ghc/PrelNum.lhs +ghc/PrelNum.mc.o : ghc/PrelNum.lhs +ghc/PrelNum.norm.o : ghc/PrelNum.lhs +ghc/PrelNum.p.o : ghc/PrelNum.lhs +ghc/PrelNum.o : ./../includes/ieee-flpt.h +ghc/PrelNum.mc.o : ./../includes/ieee-flpt.h +ghc/PrelNum.norm.o : ./../includes/ieee-flpt.h +ghc/PrelNum.p.o : ./../includes/ieee-flpt.h +ghc/PrelNum.mc.o : required/Prelude.mc.hi +ghc/PrelNum.norm.o : required/Prelude.norm.hi +ghc/PrelNum.p.o : required/Prelude.p.hi +ghc/PrelNum.mc.o : ghc/IOBase.mc.hi +ghc/PrelNum.norm.o : ghc/IOBase.norm.hi +ghc/PrelNum.p.o : ghc/IOBase.p.hi +ghc/PrelNum.o : ghc/PrelList.hi +ghc/PrelNum.mc.o : ghc/PrelList.mc.hi +ghc/PrelNum.norm.o : ghc/PrelList.norm.hi +ghc/PrelNum.p.o : ghc/PrelList.p.hi +ghc/PrelNum.o : ghc/PrelBase.hi +ghc/PrelNum.mc.o : ghc/PrelBase.mc.hi +ghc/PrelNum.norm.o : ghc/PrelBase.norm.hi +ghc/PrelNum.p.o : ghc/PrelBase.p.hi +ghc/PrelNum.o : ghc/GHC.hi +ghc/PrelNum.mc.o : ghc/GHC.mc.hi +ghc/PrelNum.norm.o : ghc/GHC.norm.hi +ghc/PrelNum.p.o : ghc/GHC.p.hi +ghc/PrelRead.o : ghc/PrelRead.lhs +ghc/PrelRead.mc.o : ghc/PrelRead.lhs +ghc/PrelRead.norm.o : ghc/PrelRead.lhs +ghc/PrelRead.p.o : ghc/PrelRead.lhs +ghc/PrelRead.mc.o : required/Prelude.mc.hi +ghc/PrelRead.norm.o : required/Prelude.norm.hi +ghc/PrelRead.p.o : required/Prelude.p.hi +ghc/PrelRead.mc.o : ghc/IOBase.mc.hi +ghc/PrelRead.norm.o : ghc/IOBase.norm.hi +ghc/PrelRead.p.o : ghc/IOBase.p.hi +ghc/PrelRead.o : ghc/PrelNum.hi +ghc/PrelRead.mc.o : ghc/PrelNum.mc.hi +ghc/PrelRead.norm.o : ghc/PrelNum.norm.hi +ghc/PrelRead.p.o : ghc/PrelNum.p.hi +ghc/PrelRead.o : ghc/PrelList.hi +ghc/PrelRead.mc.o : ghc/PrelList.mc.hi +ghc/PrelRead.norm.o : ghc/PrelList.norm.hi +ghc/PrelRead.p.o : ghc/PrelList.p.hi +ghc/PrelRead.o : ghc/PrelTup.hi +ghc/PrelRead.mc.o : ghc/PrelTup.mc.hi +ghc/PrelRead.norm.o : ghc/PrelTup.norm.hi +ghc/PrelRead.p.o : ghc/PrelTup.p.hi +ghc/PrelRead.o : ghc/PrelBase.hi +ghc/PrelRead.mc.o : ghc/PrelBase.mc.hi +ghc/PrelRead.norm.o : ghc/PrelBase.norm.hi +ghc/PrelRead.p.o : ghc/PrelBase.p.hi +ghc/PrelTup.o : ghc/PrelTup.lhs +ghc/PrelTup.mc.o : ghc/PrelTup.lhs +ghc/PrelTup.norm.o : ghc/PrelTup.lhs +ghc/PrelTup.p.o : ghc/PrelTup.lhs +ghc/PrelTup.mc.o : required/Prelude.mc.hi +ghc/PrelTup.norm.o : required/Prelude.norm.hi +ghc/PrelTup.p.o : required/Prelude.p.hi +ghc/PrelTup.mc.o : ghc/IOBase.mc.hi +ghc/PrelTup.norm.o : ghc/IOBase.norm.hi +ghc/PrelTup.p.o : ghc/IOBase.p.hi +ghc/PrelTup.o : ghc/PrelBase.hi +ghc/PrelTup.mc.o : ghc/PrelBase.mc.hi +ghc/PrelTup.norm.o : ghc/PrelBase.norm.hi +ghc/PrelTup.p.o : ghc/PrelBase.p.hi +ghc/STBase.o : ghc/STBase.lhs +ghc/STBase.mc.o : ghc/STBase.lhs +ghc/STBase.norm.o : ghc/STBase.lhs +ghc/STBase.p.o : ghc/STBase.lhs +ghc/STBase.mc.o : required/Prelude.mc.hi +ghc/STBase.norm.o : required/Prelude.norm.hi +ghc/STBase.p.o : required/Prelude.p.hi +ghc/STBase.o : required/Ix.hi +ghc/STBase.mc.o : required/Ix.mc.hi +ghc/STBase.norm.o : required/Ix.norm.hi +ghc/STBase.p.o : required/Ix.p.hi +ghc/STBase.o : required/Monad.hi +ghc/STBase.mc.o : required/Monad.mc.hi +ghc/STBase.norm.o : required/Monad.norm.hi +ghc/STBase.p.o : required/Monad.p.hi +ghc/STBase.o : ghc/PrelTup.hi +ghc/STBase.mc.o : ghc/PrelTup.mc.hi +ghc/STBase.norm.o : ghc/PrelTup.norm.hi +ghc/STBase.p.o : ghc/PrelTup.p.hi +ghc/STBase.o : ghc/PrelBase.hi +ghc/STBase.mc.o : ghc/PrelBase.mc.hi +ghc/STBase.norm.o : ghc/PrelBase.norm.hi +ghc/STBase.p.o : ghc/PrelBase.p.hi +ghc/STBase.o : ghc/GHC.hi +ghc/STBase.mc.o : ghc/GHC.mc.hi +ghc/STBase.norm.o : ghc/GHC.norm.hi +ghc/STBase.p.o : ghc/GHC.p.hi +required/Array.o : required/Array.lhs +required/Array.mc.o : required/Array.lhs +required/Array.norm.o : required/Array.lhs +required/Array.p.o : required/Array.lhs +required/Array.mc.o : required/Prelude.mc.hi +required/Array.norm.o : required/Prelude.norm.hi +required/Array.p.o : required/Prelude.p.hi required/Array.o : required/Ix.hi -required/Array.o : required/List.hi -required/Array.o : prelude/GHCbase.hi -required/Char.o : required/Char.hs -required/Complex.o : required/Complex.hs -required/Directory.o : required/Directory.hs -required/Directory.o : prelude/GHCio.hi -required/Directory.o : prelude/PreludeGlaST.hi -required/Directory.o : prelude/GHCps.hi -required/IO.o : required/IO.hs +required/Array.mc.o : required/Ix.mc.hi +required/Array.norm.o : required/Ix.norm.hi +required/Array.p.o : required/Ix.p.hi +required/Array.o : ghc/PrelList.hi +required/Array.mc.o : ghc/PrelList.mc.hi +required/Array.norm.o : ghc/PrelList.norm.hi +required/Array.p.o : ghc/PrelList.p.hi +required/Array.o : ghc/PrelRead.hi +required/Array.mc.o : ghc/PrelRead.mc.hi +required/Array.norm.o : ghc/PrelRead.norm.hi +required/Array.p.o : ghc/PrelRead.p.hi +required/Array.o : ghc/ArrBase.hi +required/Array.mc.o : ghc/ArrBase.mc.hi +required/Array.norm.o : ghc/ArrBase.norm.hi +required/Array.p.o : ghc/ArrBase.p.hi +required/Array.o : ghc/PrelBase.hi +required/Array.mc.o : ghc/PrelBase.mc.hi +required/Array.norm.o : ghc/PrelBase.norm.hi +required/Array.p.o : ghc/PrelBase.p.hi +required/Char.o : required/Char.lhs +required/Char.mc.o : required/Char.lhs +required/Char.norm.o : required/Char.lhs +required/Char.p.o : required/Char.lhs +required/Char.mc.o : required/Prelude.mc.hi +required/Char.norm.o : required/Prelude.norm.hi +required/Char.p.o : required/Prelude.p.hi +required/Char.o : ghc/PrelBase.hi +required/Char.mc.o : ghc/PrelBase.mc.hi +required/Char.norm.o : ghc/PrelBase.norm.hi +required/Char.p.o : ghc/PrelBase.p.hi +required/Complex.o : required/Complex.lhs +required/Complex.mc.o : required/Complex.lhs +required/Complex.norm.o : required/Complex.lhs +required/Complex.p.o : required/Complex.lhs +required/Directory.o : required/Directory.lhs +required/Directory.mc.o : required/Directory.lhs +required/Directory.norm.o : required/Directory.lhs +required/Directory.p.o : required/Directory.lhs +required/Directory.o : glaExts/Foreign.hi +required/Directory.mc.o : glaExts/Foreign.mc.hi +required/Directory.norm.o : glaExts/Foreign.norm.hi +required/Directory.p.o : glaExts/Foreign.p.hi +required/Directory.o : ghc/IOBase.hi +required/Directory.mc.o : ghc/IOBase.mc.hi +required/Directory.norm.o : ghc/IOBase.norm.hi +required/Directory.p.o : ghc/IOBase.p.hi +required/Directory.o : ghc/STBase.hi +required/Directory.mc.o : ghc/STBase.mc.hi +required/Directory.norm.o : ghc/STBase.norm.hi +required/Directory.p.o : ghc/STBase.p.hi +required/Directory.o : glaExts/PackedString.hi +required/Directory.mc.o : glaExts/PackedString.mc.hi +required/Directory.norm.o : glaExts/PackedString.norm.hi +required/Directory.p.o : glaExts/PackedString.p.hi +required/IO.o : required/IO.lhs +required/IO.mc.o : required/IO.lhs +required/IO.norm.o : required/IO.lhs +required/IO.p.o : required/IO.lhs +required/IO.mc.o : required/Prelude.mc.hi +required/IO.norm.o : required/Prelude.norm.hi +required/IO.p.o : required/Prelude.p.hi required/IO.o : required/Ix.hi -required/IO.o : prelude/GHCio.hi -required/IO.o : prelude/GHCbase.hi -required/IO.o : prelude/GHCps.hi -required/Ix.o : required/Ix.hs -required/List.o : required/List.hs -required/Maybe.o : required/Maybe.hs -required/Monad.o : required/Monad.hs -required/Ratio.o : required/Ratio.hs -required/System.o : required/System.hs -required/System.o : prelude/GHCio.hi -required/System.o : prelude/GHCps.hi -required/System.o : prelude/GHCbase.hi -concurrent/Channel.o : concurrent/Channel.hs -concurrent/Channel.o : prelude/GHCbase.hi -concurrent/ChannelVar.o : concurrent/ChannelVar.hs -concurrent/ChannelVar.o : prelude/GHCbase.hi -concurrent/Concurrent.o : concurrent/Concurrent.hs +required/IO.mc.o : required/Ix.mc.hi +required/IO.norm.o : required/Ix.norm.hi +required/IO.p.o : required/Ix.p.hi +required/IO.o : ghc/STBase.hi +required/IO.mc.o : ghc/STBase.mc.hi +required/IO.norm.o : ghc/STBase.norm.hi +required/IO.p.o : ghc/STBase.p.hi +required/IO.o : ghc/IOBase.hi +required/IO.mc.o : ghc/IOBase.mc.hi +required/IO.norm.o : ghc/IOBase.norm.hi +required/IO.p.o : ghc/IOBase.p.hi +required/IO.o : ghc/ArrBase.hi +required/IO.mc.o : ghc/ArrBase.mc.hi +required/IO.norm.o : ghc/ArrBase.norm.hi +required/IO.p.o : ghc/ArrBase.p.hi +required/IO.o : ghc/IOHandle.hi +required/IO.mc.o : ghc/IOHandle.mc.hi +required/IO.norm.o : ghc/IOHandle.norm.hi +required/IO.p.o : ghc/IOHandle.p.hi +required/IO.o : glaExts/PackedString.hi +required/IO.mc.o : glaExts/PackedString.mc.hi +required/IO.norm.o : glaExts/PackedString.norm.hi +required/IO.p.o : glaExts/PackedString.p.hi +required/IO.o : ghc/PrelBase.hi +required/IO.mc.o : ghc/PrelBase.mc.hi +required/IO.norm.o : ghc/PrelBase.norm.hi +required/IO.p.o : ghc/PrelBase.p.hi +required/IO.o : ghc/GHC.hi +required/IO.mc.o : ghc/GHC.mc.hi +required/IO.norm.o : ghc/GHC.norm.hi +required/IO.p.o : ghc/GHC.p.hi +required/Ix.o : required/Ix.lhs +required/Ix.mc.o : required/Ix.lhs +required/Ix.norm.o : required/Ix.lhs +required/Ix.p.o : required/Ix.lhs +required/Ix.mc.o : required/Prelude.mc.hi +required/Ix.norm.o : required/Prelude.norm.hi +required/Ix.p.o : required/Prelude.p.hi +required/Ix.mc.o : ghc/IOBase.mc.hi +required/Ix.norm.o : ghc/IOBase.norm.hi +required/Ix.p.o : ghc/IOBase.p.hi +required/Ix.o : ghc/PrelNum.hi +required/Ix.mc.o : ghc/PrelNum.mc.hi +required/Ix.norm.o : ghc/PrelNum.norm.hi +required/Ix.p.o : ghc/PrelNum.p.hi +required/Ix.o : ghc/PrelTup.hi +required/Ix.mc.o : ghc/PrelTup.mc.hi +required/Ix.norm.o : ghc/PrelTup.norm.hi +required/Ix.p.o : ghc/PrelTup.p.hi +required/Ix.o : ghc/PrelBase.hi +required/Ix.mc.o : ghc/PrelBase.mc.hi +required/Ix.norm.o : ghc/PrelBase.norm.hi +required/Ix.p.o : ghc/PrelBase.p.hi +required/List.o : required/List.lhs +required/List.mc.o : required/List.lhs +required/List.norm.o : required/List.lhs +required/List.p.o : required/List.lhs +required/List.mc.o : required/Prelude.mc.hi +required/List.norm.o : required/Prelude.norm.hi +required/List.p.o : required/Prelude.p.hi +required/Maybe.o : required/Maybe.lhs +required/Maybe.mc.o : required/Maybe.lhs +required/Maybe.norm.o : required/Maybe.lhs +required/Maybe.p.o : required/Maybe.lhs +required/Maybe.mc.o : required/Prelude.mc.hi +required/Maybe.norm.o : required/Prelude.norm.hi +required/Maybe.p.o : required/Prelude.p.hi +required/Maybe.mc.o : ghc/IOBase.mc.hi +required/Maybe.norm.o : ghc/IOBase.norm.hi +required/Maybe.p.o : ghc/IOBase.p.hi +required/Maybe.o : required/Monad.hi +required/Maybe.mc.o : required/Monad.mc.hi +required/Maybe.norm.o : required/Monad.norm.hi +required/Maybe.p.o : required/Monad.p.hi +required/Maybe.o : ghc/PrelList.hi +required/Maybe.mc.o : ghc/PrelList.mc.hi +required/Maybe.norm.o : ghc/PrelList.norm.hi +required/Maybe.p.o : ghc/PrelList.p.hi +required/Maybe.o : ghc/PrelBase.hi +required/Maybe.mc.o : ghc/PrelBase.mc.hi +required/Maybe.norm.o : ghc/PrelBase.norm.hi +required/Maybe.p.o : ghc/PrelBase.p.hi +required/Monad.o : required/Monad.lhs +required/Monad.mc.o : required/Monad.lhs +required/Monad.norm.o : required/Monad.lhs +required/Monad.p.o : required/Monad.lhs +required/Monad.mc.o : required/Prelude.mc.hi +required/Monad.norm.o : required/Prelude.norm.hi +required/Monad.p.o : required/Prelude.p.hi +required/Monad.o : ghc/PrelList.hi +required/Monad.mc.o : ghc/PrelList.mc.hi +required/Monad.norm.o : ghc/PrelList.norm.hi +required/Monad.p.o : ghc/PrelList.p.hi +required/Monad.o : ghc/PrelTup.hi +required/Monad.mc.o : ghc/PrelTup.mc.hi +required/Monad.norm.o : ghc/PrelTup.norm.hi +required/Monad.p.o : ghc/PrelTup.p.hi +required/Monad.o : ghc/PrelBase.hi +required/Monad.mc.o : ghc/PrelBase.mc.hi +required/Monad.norm.o : ghc/PrelBase.norm.hi +required/Monad.p.o : ghc/PrelBase.p.hi +required/Prelude.o : required/Prelude.lhs +required/Prelude.mc.o : required/Prelude.lhs +required/Prelude.norm.o : required/Prelude.lhs +required/Prelude.p.o : required/Prelude.lhs +required/Prelude.o : ghc/PrelBase.hi +required/Prelude.mc.o : ghc/PrelBase.mc.hi +required/Prelude.norm.o : ghc/PrelBase.norm.hi +required/Prelude.p.o : ghc/PrelBase.p.hi +required/Prelude.o : ghc/PrelList.hi +required/Prelude.mc.o : ghc/PrelList.mc.hi +required/Prelude.norm.o : ghc/PrelList.norm.hi +required/Prelude.p.o : ghc/PrelList.p.hi +required/Prelude.o : ghc/PrelIO.hi +required/Prelude.mc.o : ghc/PrelIO.mc.hi +required/Prelude.norm.o : ghc/PrelIO.norm.hi +required/Prelude.p.o : ghc/PrelIO.p.hi +required/Prelude.o : ghc/PrelRead.hi +required/Prelude.mc.o : ghc/PrelRead.mc.hi +required/Prelude.norm.o : ghc/PrelRead.norm.hi +required/Prelude.p.o : ghc/PrelRead.p.hi +required/Prelude.o : ghc/PrelNum.hi +required/Prelude.mc.o : ghc/PrelNum.mc.hi +required/Prelude.norm.o : ghc/PrelNum.norm.hi +required/Prelude.p.o : ghc/PrelNum.p.hi +required/Prelude.o : ghc/PrelTup.hi +required/Prelude.mc.o : ghc/PrelTup.mc.hi +required/Prelude.norm.o : ghc/PrelTup.norm.hi +required/Prelude.p.o : ghc/PrelTup.p.hi +required/Prelude.o : required/Monad.hi +required/Prelude.mc.o : required/Monad.mc.hi +required/Prelude.norm.o : required/Monad.norm.hi +required/Prelude.p.o : required/Monad.p.hi +required/Prelude.o : required/Maybe.hi +required/Prelude.mc.o : required/Maybe.mc.hi +required/Prelude.norm.o : required/Maybe.norm.hi +required/Prelude.p.o : required/Maybe.p.hi +required/Prelude.o : ghc/IOBase.hi +required/Prelude.mc.o : ghc/IOBase.mc.hi +required/Prelude.norm.o : ghc/IOBase.norm.hi +required/Prelude.p.o : ghc/IOBase.p.hi +required/Ratio.o : required/Ratio.lhs +required/Ratio.mc.o : required/Ratio.lhs +required/Ratio.norm.o : required/Ratio.lhs +required/Ratio.p.o : required/Ratio.lhs +required/Ratio.mc.o : required/Prelude.mc.hi +required/Ratio.norm.o : required/Prelude.norm.hi +required/Ratio.p.o : required/Prelude.p.hi +required/Ratio.o : ghc/PrelNum.hi +required/Ratio.mc.o : ghc/PrelNum.mc.hi +required/Ratio.norm.o : ghc/PrelNum.norm.hi +required/Ratio.p.o : ghc/PrelNum.p.hi +required/System.o : required/System.lhs +required/System.mc.o : required/System.lhs +required/System.norm.o : required/System.lhs +required/System.p.o : required/System.lhs +required/System.o : glaExts/Foreign.hi +required/System.mc.o : glaExts/Foreign.mc.hi +required/System.norm.o : glaExts/Foreign.norm.hi +required/System.p.o : glaExts/Foreign.p.hi +required/System.o : ghc/IOBase.hi +required/System.mc.o : ghc/IOBase.mc.hi +required/System.norm.o : ghc/IOBase.norm.hi +required/System.p.o : ghc/IOBase.p.hi +required/System.o : ghc/ArrBase.hi +required/System.mc.o : ghc/ArrBase.mc.hi +required/System.norm.o : ghc/ArrBase.norm.hi +required/System.p.o : ghc/ArrBase.p.hi +required/System.o : glaExts/PackedString.hi +required/System.mc.o : glaExts/PackedString.mc.hi +required/System.norm.o : glaExts/PackedString.norm.hi +required/System.p.o : glaExts/PackedString.p.hi +glaExts/Foreign.o : glaExts/Foreign.lhs +glaExts/Foreign.mc.o : glaExts/Foreign.lhs +glaExts/Foreign.norm.o : glaExts/Foreign.lhs +glaExts/Foreign.p.o : glaExts/Foreign.lhs +glaExts/Foreign.mc.o : required/Prelude.mc.hi +glaExts/Foreign.norm.o : required/Prelude.norm.hi +glaExts/Foreign.p.o : required/Prelude.p.hi +glaExts/Foreign.o : ghc/STBase.hi +glaExts/Foreign.mc.o : ghc/STBase.mc.hi +glaExts/Foreign.norm.o : ghc/STBase.norm.hi +glaExts/Foreign.p.o : ghc/STBase.p.hi +glaExts/Foreign.o : ghc/ArrBase.hi +glaExts/Foreign.mc.o : ghc/ArrBase.mc.hi +glaExts/Foreign.norm.o : ghc/ArrBase.norm.hi +glaExts/Foreign.p.o : ghc/ArrBase.p.hi +glaExts/Foreign.o : ghc/PrelNum.hi +glaExts/Foreign.mc.o : ghc/PrelNum.mc.hi +glaExts/Foreign.norm.o : ghc/PrelNum.norm.hi +glaExts/Foreign.p.o : ghc/PrelNum.p.hi +glaExts/Foreign.o : ghc/PrelBase.hi +glaExts/Foreign.mc.o : ghc/PrelBase.mc.hi +glaExts/Foreign.norm.o : ghc/PrelBase.norm.hi +glaExts/Foreign.p.o : ghc/PrelBase.p.hi +glaExts/Foreign.o : ghc/GHC.hi +glaExts/Foreign.mc.o : ghc/GHC.mc.hi +glaExts/Foreign.norm.o : ghc/GHC.norm.hi +glaExts/Foreign.p.o : ghc/GHC.p.hi +glaExts/PackedString.o : glaExts/PackedString.lhs +glaExts/PackedString.mc.o : glaExts/PackedString.lhs +glaExts/PackedString.norm.o : glaExts/PackedString.lhs +glaExts/PackedString.p.o : glaExts/PackedString.lhs +glaExts/PackedString.mc.o : required/Prelude.mc.hi +glaExts/PackedString.norm.o : required/Prelude.norm.hi +glaExts/PackedString.p.o : required/Prelude.p.hi +glaExts/PackedString.mc.o : ghc/IOBase.mc.hi +glaExts/PackedString.norm.o : ghc/IOBase.norm.hi +glaExts/PackedString.p.o : ghc/IOBase.p.hi +glaExts/PackedString.o : required/Ix.hi +glaExts/PackedString.mc.o : required/Ix.mc.hi +glaExts/PackedString.norm.o : required/Ix.norm.hi +glaExts/PackedString.p.o : required/Ix.p.hi +glaExts/PackedString.o : ghc/PrelList.hi +glaExts/PackedString.mc.o : ghc/PrelList.mc.hi +glaExts/PackedString.norm.o : ghc/PrelList.norm.hi +glaExts/PackedString.p.o : ghc/PrelList.p.hi +glaExts/PackedString.o : ghc/STBase.hi +glaExts/PackedString.mc.o : ghc/STBase.mc.hi +glaExts/PackedString.norm.o : ghc/STBase.norm.hi +glaExts/PackedString.p.o : ghc/STBase.p.hi +glaExts/PackedString.o : ghc/ArrBase.hi +glaExts/PackedString.mc.o : ghc/ArrBase.mc.hi +glaExts/PackedString.norm.o : ghc/ArrBase.norm.hi +glaExts/PackedString.p.o : ghc/ArrBase.p.hi +glaExts/PackedString.o : ghc/PrelBase.hi +glaExts/PackedString.mc.o : ghc/PrelBase.mc.hi +glaExts/PackedString.norm.o : ghc/PrelBase.norm.hi +glaExts/PackedString.p.o : ghc/PrelBase.p.hi +glaExts/PackedString.o : ghc/GHC.hi +glaExts/PackedString.mc.o : ghc/GHC.mc.hi +glaExts/PackedString.norm.o : ghc/GHC.norm.hi +glaExts/PackedString.p.o : ghc/GHC.p.hi +glaExts/ST.o : glaExts/ST.lhs +glaExts/ST.mc.o : glaExts/ST.lhs +glaExts/ST.norm.o : glaExts/ST.lhs +glaExts/ST.p.o : glaExts/ST.lhs +glaExts/ST.mc.o : required/Prelude.mc.hi +glaExts/ST.norm.o : required/Prelude.norm.hi +glaExts/ST.p.o : required/Prelude.p.hi +glaExts/ST.mc.o : ghc/IOBase.mc.hi +glaExts/ST.norm.o : ghc/IOBase.norm.hi +glaExts/ST.p.o : ghc/IOBase.p.hi +glaExts/ST.o : ghc/ArrBase.hi +glaExts/ST.mc.o : ghc/ArrBase.mc.hi +glaExts/ST.norm.o : ghc/ArrBase.norm.hi +glaExts/ST.p.o : ghc/ArrBase.p.hi +glaExts/ST.o : ghc/STBase.hi +glaExts/ST.mc.o : ghc/STBase.mc.hi +glaExts/ST.norm.o : ghc/STBase.norm.hi +glaExts/ST.p.o : ghc/STBase.p.hi +glaExts/ST.o : ghc/PrelBase.hi +glaExts/ST.mc.o : ghc/PrelBase.mc.hi +glaExts/ST.norm.o : ghc/PrelBase.norm.hi +glaExts/ST.p.o : ghc/PrelBase.p.hi +glaExts/ST.o : ghc/GHC.hi +glaExts/ST.mc.o : ghc/GHC.mc.hi +glaExts/ST.norm.o : ghc/GHC.norm.hi +glaExts/ST.p.o : ghc/GHC.p.hi +concurrent/Channel.o : concurrent/Channel.lhs +concurrent/Channel.mc.o : concurrent/Channel.lhs +concurrent/Channel.norm.o : concurrent/Channel.lhs +concurrent/Channel.p.o : concurrent/Channel.lhs +concurrent/ChannelVar.o : concurrent/ChannelVar.lhs +concurrent/ChannelVar.mc.o : concurrent/ChannelVar.lhs +concurrent/ChannelVar.norm.o : concurrent/ChannelVar.lhs +concurrent/ChannelVar.p.o : concurrent/ChannelVar.lhs +concurrent/Concurrent.o : concurrent/Concurrent.lhs +concurrent/Concurrent.mc.o : concurrent/Concurrent.lhs +concurrent/Concurrent.norm.o : concurrent/Concurrent.lhs +concurrent/Concurrent.p.o : concurrent/Concurrent.lhs +concurrent/Concurrent.o : required/IO.hi +concurrent/Concurrent.mc.o : required/IO.mc.hi +concurrent/Concurrent.norm.o : required/IO.norm.hi +concurrent/Concurrent.p.o : required/IO.p.hi concurrent/Concurrent.o : concurrent/Parallel.hi +concurrent/Concurrent.mc.o : concurrent/Parallel.mc.hi +concurrent/Concurrent.norm.o : concurrent/Parallel.norm.hi +concurrent/Concurrent.p.o : concurrent/Parallel.p.hi concurrent/Concurrent.o : concurrent/ChannelVar.hi +concurrent/Concurrent.mc.o : concurrent/ChannelVar.mc.hi +concurrent/Concurrent.norm.o : concurrent/ChannelVar.norm.hi +concurrent/Concurrent.p.o : concurrent/ChannelVar.p.hi concurrent/Concurrent.o : concurrent/Channel.hi +concurrent/Concurrent.mc.o : concurrent/Channel.mc.hi +concurrent/Concurrent.norm.o : concurrent/Channel.norm.hi +concurrent/Concurrent.p.o : concurrent/Channel.p.hi concurrent/Concurrent.o : concurrent/Semaphore.hi +concurrent/Concurrent.mc.o : concurrent/Semaphore.mc.hi +concurrent/Concurrent.norm.o : concurrent/Semaphore.norm.hi +concurrent/Concurrent.p.o : concurrent/Semaphore.p.hi concurrent/Concurrent.o : concurrent/Merge.hi +concurrent/Concurrent.mc.o : concurrent/Merge.mc.hi +concurrent/Concurrent.norm.o : concurrent/Merge.norm.hi +concurrent/Concurrent.p.o : concurrent/Merge.p.hi concurrent/Concurrent.o : concurrent/SampleVar.hi -concurrent/Concurrent.o : prelude/GHCbase.hi -concurrent/Merge.o : concurrent/Merge.hs +concurrent/Concurrent.mc.o : concurrent/SampleVar.mc.hi +concurrent/Concurrent.norm.o : concurrent/SampleVar.norm.hi +concurrent/Concurrent.p.o : concurrent/SampleVar.p.hi +concurrent/Concurrent.o : ghc/ConcBase.hi +concurrent/Concurrent.mc.o : ghc/ConcBase.mc.hi +concurrent/Concurrent.norm.o : ghc/ConcBase.norm.hi +concurrent/Concurrent.p.o : ghc/ConcBase.p.hi +concurrent/Merge.o : concurrent/Merge.lhs +concurrent/Merge.mc.o : concurrent/Merge.lhs +concurrent/Merge.norm.o : concurrent/Merge.lhs +concurrent/Merge.p.o : concurrent/Merge.lhs concurrent/Merge.o : concurrent/Semaphore.hi -concurrent/Merge.o : prelude/GHCbase.hi -concurrent/Merge.o : prelude/GHCio.hi -concurrent/Merge.o : concurrent/Concurrent.hi -concurrent/Parallel.o : concurrent/Parallel.hs -concurrent/Parallel.o : prelude/GHCbase.hi -concurrent/Parallel.o : prelude/GHCerr.hi -concurrent/SampleVar.o : concurrent/SampleVar.hs -concurrent/SampleVar.o : prelude/GHCbase.hi -concurrent/Semaphore.o : concurrent/Semaphore.hs -concurrent/Semaphore.o : prelude/GHCbase.hi +concurrent/Merge.mc.o : concurrent/Semaphore.mc.hi +concurrent/Merge.norm.o : concurrent/Semaphore.norm.hi +concurrent/Merge.p.o : concurrent/Semaphore.p.hi +concurrent/Parallel.o : concurrent/Parallel.lhs +concurrent/Parallel.mc.o : concurrent/Parallel.lhs +concurrent/Parallel.norm.o : concurrent/Parallel.lhs +concurrent/Parallel.p.o : concurrent/Parallel.lhs +concurrent/SampelVar.o : concurrent/SampelVar.lhs +concurrent/SampelVar.mc.o : concurrent/SampelVar.lhs +concurrent/SampelVar.norm.o : concurrent/SampelVar.lhs +concurrent/SampelVar.p.o : concurrent/SampelVar.lhs +concurrent/SampleVar.o : concurrent/SampleVar.lhs +concurrent/SampleVar.mc.o : concurrent/SampleVar.lhs +concurrent/SampleVar.norm.o : concurrent/SampleVar.lhs +concurrent/SampleVar.p.o : concurrent/SampleVar.lhs +concurrent/Semaphore.o : concurrent/Semaphore.lhs +concurrent/Semaphore.mc.o : concurrent/Semaphore.lhs +concurrent/Semaphore.norm.o : concurrent/Semaphore.lhs +concurrent/Semaphore.p.o : concurrent/Semaphore.lhs # DO NOT DELETE: End of Haskell dependencies diff --git a/ghc/lib/Jmakefile b/ghc/lib/Jmakefile new file mode 100644 index 0000000..d7a1adf --- /dev/null +++ b/ghc/lib/Jmakefile @@ -0,0 +1,269 @@ +/* This is the Jmakefile for the library stuff. + This stuff is all written in (Glasgow-extended) Haskell. + +Everything here *must* be compiled w/ the Glasgow Haskell compiler. +(Hence the use of $(GHC), rather than $(HC) [the latter is your "standard" +Haskell compiler -- whatever you've configured]). + +If you use EXTRA_HC_OPTS on the command line (which you shouldn't, +strictly speaking), it will probably work -- it is pinned onto +GHC_OPTS, just for fun. +*/ + +/**************************************************************** +* * +* Jmakefile preamble-y things * +* * +****************************************************************/ + +#define IHaveSubdirs + +#if IncludeTestDirsInBuild == YES +#define __ghc_lib_tests_dir tests +#else +#define __ghc_lib_tests_dir /* nothing */ +#endif + +SUBDIRS = cbits __ghc_lib_tests_dir + +#define NoDocsTargetForSubdirs +#define NoInstallDocsTargetForSubdirs +#define NoDependTargetForSubdirs + +GhcDriverNeededHere(depend all) +EtagsNeededHere(tags) + +/**************************************************************** +* * +* options used for compiling/etc. things * +* * +****************************************************************/ + +/* The driver will give warnings if -split-objs, but that's cool... */ +GHC_OPTS=-recomp -cpp \ + -dcore-lint \ + -irequired:glaExts:ghc \ + HcMaxHeapFlag $(EXTRA_HC_OPTS) + +EXTRA_MKDEPENDHS_OPTS = -irequired:prelude:ghc:hbc:glaExts:concurrent + +PREL_OPTS= + +/* per-build options: shared with RTS */ +#define rts_or_lib(r,l) l +#include "../mkworld/GHC_OPTS" + +/* this is just friendliness to "hstags" */ +HSTAGS_OPTS=-fglasgow-exts + +/***************************************************************/ + +/**************************************************************** +* * +* what it is we are compiling; * +* these are long and tedious lists, but c'est la guerre * +* * +****************************************************************/ + +BASIC_HS = \ +required/Prelude.lhs \ +required/Array.lhs \ +required/Char.lhs \ +required/Complex.lhs \ +required/Directory.lhs \ +required/IO.lhs \ +required/Ix.lhs \ +required/List.lhs \ +required/Maybe.lhs \ +required/Monad.lhs \ +required/Ratio.lhs \ +required/System.lhs \ +\ +ghc/PrelBase.lhs \ +ghc/GHCerr.lhs \ +ghc/PrelIO.lhs \ +ghc/IOHandle.lhs \ +ghc/IOBase.lhs \ +ghc/STBase.lhs \ +ghc/ArrBase.lhs \ +ghc/PrelRead.lhs \ +ghc/GHCmain.lhs \ +ghc/PrelList.lhs \ +ghc/PrelNum.lhs \ +ghc/PrelTup.lhs \ +\ +glaExts/ST.lhs \ +glaExts/Foreign.lhs \ +glaExts/PackedString.lhs \ + +# Leave out concurrency for now +# \ +ghc/ConcBase.lhs \ +# concurrent/Channel.lhs \ +# concurrent/ChannelVar.lhs \ +# concurrent/Merge.lhs \ +# concurrent/Parallel.lhs \ +# concurrent/SampleVar.lhs \ +# concurrent/Semaphore.lhs \ +# concurrent/Concurrent.lhs + +BASIC_HIs = $(BASIC_HS:.lhs=.hi) + +BASIC_OBJS_DIRS = $(BASIC_HS:.lhs=) + +/* easy way to make many many Make variables: */ +WayThingVars(BASIC) + +/************************************************************************ +* * +* Macros for creating and installing libHS.a (in its many flavors). * +* * +*************************************************************************/ + +/**************************************************************** +* * +* Creating and installing... * +* libHS_.a standard Prelude library * +* * +****************************************************************/ + +/* make sure install's target dir is there */ +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTLIBDIR_GHC) $(INSTDATADIR_GHC)/imports) + +InstallDataTarget(MODULES,$(INSTDATADIR_GHC)/imports) +#endif /* installing */ + +BasicEverything(libHS, $(INSTLIBDIR_GHC), $(INSTDATADIR_GHC)) + +/**************************************************************** +* * +* Creating the individual .hc files: * +* * +* For the just-vary-the-GC-thanks flavors, we only need to * +* compile .hs->.hc once; then re-use the .hc file each time. * +* * +* For the profiling one (_p) and all the user-specified * +* ones, we recompile the Haskell each time. * +* * +* NB: old (WDP 95/06) * +****************************************************************/ + +/* some "helpful" internal macros first... */ + +#if GhcWithHscBuiltViaC == YES && HaskellCompilerType == HC_USE_HC_FILES +#define CompileWayishly__(hc,file,isuf,way,flags) @@\ +clean :: @@\ + $(RM) CAT3(file,way,.hc) +#endif + +/* now use the macro: */ + +/* NB: the -Onots are only because -O would not go through on + a reasonably-sized machine (i.e., one I have) +*/ + + +CompileWayishly(GHC,required/Prelude,lhs, /*-split-objs Prelude*/ -fglasgow-exts) +CompileWayishly(GHC,required/Array,lhs, /*-split-objs Array*/ -fglasgow-exts) +CompileWayishly(GHC,required/Char,lhs, /*-split-objs Char*/) +CompileWayishly(GHC,required/Complex,lhs, /*-split-objs Complex*/) +CompileWayishly(GHC,required/Ix,lhs, /*-split-objs Ix*/ -fglasgow-exts) +CompileWayishly(GHC,required/List,lhs, /*-split-objs List*/) +CompileWayishly(GHC,required/Maybe,lhs, /*-split-objs Maybe*/) +CompileWayishly(GHC,required/Monad,lhs, /*-split-objs Monad*/) +CompileWayishly(GHC,required/Ratio,lhs, /*-split-objs Ratio*/) + +CompileWayishly(GHC,required/Directory,lhs, /*-split-objs Directory*/ -fglasgow-exts \ + '-#include"cbits/stgio.h"' -monly-3-regs) +CompileWayishly(GHC,required/IO,lhs, /*-split-objs IO*/ -fglasgow-exts \ + '-#include"cbits/stgio.h"') +CompileWayishly(GHC,required/System,lhs, /*-split-objs System*/ -fglasgow-exts \ + '-#include"cbits/stgio.h"') + + +CompileWayishly(GHC,ghc/ConcBase,lhs, /*-split-objs ConcBase*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/PrelBase,lhs, /*-split-objs PrelBase*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/STBase,lhs, /*-split-objs STBase*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/IOBase,lhs, /*-split-objs IOBase*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/ArrBase,lhs, /*-split-objs ArrBase*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/PrelRead,lhs, /*-split-objs PrelRead*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/PrelList,lhs, /*-split-objs PrelList*/) +CompileWayishly(GHC,ghc/PrelNum,lhs, /*-split-objs PrelNum*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/PrelTup,lhs, /*-split-objs PrelTup*/) +CompileWayishly(GHC,ghc/PrelIO,lhs, /*-split-objs PrelIO*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/IOHandle,lhs, /*-split-objs IOHandle*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/GHCerr,lhs, /*-split-objs GHCerr*/ -fglasgow-exts) +CompileWayishly(GHC,ghc/GHCmain,lhs, /*-split-objs GHCmain*/ -fglasgow-exts) + +CompileWayishly(GHC,glaExts/Foreign,lhs, /*-split-objs Foreign*/ -fglasgow-exts) +CompileWayishly(GHC,glaExts/ST,lhs, /*-split-objs ST*/ -fglasgow-exts) +CompileWayishly(GHC,glaExts/PackedString,lhs, /*-split-objs PackedString*/ -fglasgow-exts) + + +CompileWayishly(GHC,concurrent/Channel,lhs,) +CompileWayishly(GHC,concurrent/ChannelVar,lhs,) +CompileWayishly(GHC,concurrent/Merge,lhs,-iconcurrent) +CompileWayishly(GHC,concurrent/Parallel,lhs,-fglasgow-exts) +CompileWayishly(GHC,concurrent/SampleVar,lhs,) +CompileWayishly(GHC,concurrent/Semaphore,lhs,) +CompileWayishly(GHC,concurrent/Concurrent,lhs,-iconcurrent) + +/**************************************************************** +* * +* misc "make" targets -- depend, clean, tags * +* * +****************************************************************/ + +hc-files : $(BASIC_HS:.lhs=.hc) + +/* this is a BAD idea! +ExtraStuffToClean( $(SRCS_C) ) + without the .hc files, the distrib cannot boot itself +*/ +ExtraStuffToBeVeryClean( $(SRCS_C) ) +ExtraStuffToBeVeryClean( $(STD_VERY_CLEAN) ) + +ClearTagsFile() +/* Ugly but OK? [WDP 94/09] */ +HsTagsTarget( */[A-Z]*.*hs ) +HSTAGS_OPTS=-cpp -fglasgow-exts + +/* should be *LAST* */ +#if HaskellCompilerType != HC_USE_HC_FILES + /* otherwise, the dependencies jeopardize our .hc files -- + which are all we have! */ +MAIN_INCLUDE_DIR = $(TOP_PWD)/$(CURRENT_DIR)/$(GHC_INCLUDES) + +MKDEPENDHS_OPTS= \ +IfBuild_mc(-s mc) \ +IfBuild_mr(-s mr) \ +IfBuild_mt(-s mt) \ +IfBuild_mp(-s mp) \ +IfBuild_mg(-s mg) \ +IfBuild_2s(-s 2s) \ +IfBuild_1s(-s 1s) \ +IfBuild_du(-s du) \ +IfBuild_p(-s p) \ +IfBuild_t(-s t) \ +IfBuild_a(-s a) \ +IfBuild_b(-s b) \ +IfBuild_c(-s c) \ +IfBuild_d(-s d) \ +IfBuild_e(-s e) \ +IfBuild_f(-s f) \ +IfBuild_g(-s g) \ +IfBuild_h(-s h) \ +IfBuild_i(-s i) \ +IfBuild_j(-s j) \ +IfBuild_k(-s k) \ +IfBuild_l(-s l) \ +IfBuild_m(-s m) \ +IfBuild_n(-s n) \ +IfBuild_o(-s o) \ +IfBuild_A(-s A) \ +IfBuild_B(-s B) \ +-o hc -I$(MAIN_INCLUDE_DIR) + +HaskellDependTarget( $(BASIC_HS) ) +#endif diff --git a/ghc/lib/Makefile b/ghc/lib/Makefile index 2f90b3a..006c382 100644 --- a/ghc/lib/Makefile +++ b/ghc/lib/Makefile @@ -1,5 +1,5 @@ #----------------------------------------------------------------------------- -# $Id: Makefile,v 1.2 1996/11/21 16:47:41 simonm Exp $ +# $Id: Makefile,v 1.3 1996/12/19 09:13:55 simonpj Exp $ TOP = ../.. include $(TOP)/ghc/mk/ghc.mk @@ -25,6 +25,10 @@ all :: $(MAKE) -f Makefile.libHS suffix=$$i; \ done +# Shortcut for typical case when testing: just make the "normal" version +libHS.a :: + $(MAKE) -f Makefile.libHS suffix=norm + install :: @for i in $(WAY_SUFFIXES); do \ $(MAKE) -f Makefile.libHS suffix=$$i install; \ diff --git a/ghc/lib/Makefile.libHS b/ghc/lib/Makefile.libHS index 6e03d3f..453eb2f 100644 --- a/ghc/lib/Makefile.libHS +++ b/ghc/lib/Makefile.libHS @@ -1,5 +1,5 @@ #----------------------------------------------------------------------------- -# $Id: Makefile.libHS,v 1.2 1996/11/21 16:47:42 simonm Exp $ +# $Id: Makefile.libHS,v 1.3 1996/12/19 09:13:56 simonpj Exp $ TOP = ../.. include $(TOP)/ghc/mk/ghc.mk @@ -7,16 +7,30 @@ include $(TOP)/ghc/mk/ghc.mk # per-build options: shared with runtime system include ../mk/buildflags.mk +# ============= ADDED BY SIMON ============= +ifeq ($(GhcWithHscBuiltViaC),YES) + HC = $(GHC) + SuffixRule_hc_o = YES +else + HaskellSuffixRules = YES +endif +include $(TOP)/mk/rules.mk +# =========================================== + # Everything here *must* be compiled with the Glasgow Haskell compiler. # (Hence the use of $(GHC), rather than $(HC).) # The driver will give warnings if -split-objs, but that's cool... GHC_OPTS = \ - -recomp -cpp -dcore-lint -irequired -fusing-ghc-internals -fvia-C \ + -recomp -cpp -dcore-lint -fglasgow-exts -fvia-C \ $(HcMaxHeapFlag) $(EXTRA_HC_OPTS) -SRCS = $(wildcard prelude/*.hs required/*.hs concurrent/*.hs) -OBJS = $(SRCS:.hs=.$(suffix)_o) +SRCS = $(wildcard ghc/*.lhs required/*.lhs glaExts/*.lhs concurrent/*.lhs) +ifeq ($(suffix), norm) +OBJS = $(SRCS:.lhs=.o) +else +OBJS = $(SRCS:.lhs=.$(suffix)_o) +endif #----------------------------------------------------------------------------- # Rules for building various types of objects from HS files @@ -31,10 +45,10 @@ LIB_GHC = $(GHC) $(GHCFLAGS) -o $@ -c endif ifneq ($(GhcWithHscBuiltViaC),YES) -%.o : %.hs - $(LIB_GHC) $($*_flags) $*.hs +%.o : %.lhs + $(LIB_GHC) $($*_flags) $*.lhs -%.$(suffix)_o : %.hs +%.$(suffix)_o : %.lhs $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hs else # $(GhcWithHscBuiltViaC) == YES @@ -75,27 +89,9 @@ veryclean :: # The -Onots are only because -O would not go through on # a reasonably-sized machine (i.e., one I have) -prelude/Prelude_flags = \ - -iprelude -fglasgow-exts -fcompiling-ghc-internals Prelude \ - -fno-implicit-prelude '-\#include"cbits/stgio.h"' -H18m -Onot -prelude/GHCbase_flags = \ - -iprelude -fglasgow-exts -fcompiling-ghc-internals GHCbase \ - '-\#include"cbits/stgio.h"' -H20m -monly-2-regs -Onot -prelude/GHCerr_flags = \ - -iprelude -fglasgow-exts -fcompiling-ghc-internals GHCerr -H12m -Onot -prelude/GHCps_flags = \ - -iprelude -fglasgow-exts '-\#include"cbits/stgio.h"' -monly-3-regs -Onot -prelude/GHCio_flags = \ - -iprelude -fglasgow-exts '-\#include"cbits/stgio.h"' -Onot -prelude/GHCmain_flags = -iprelude -fglasgow-exts -prelude/PreludeGlaST_flags = -iprelude -fglasgow-exts - -required/Array_flags = -fglasgow-exts -iprelude -Onot -required/Directory_flags = \ - -fglasgow-exts '-\#include"cbits/stgio.h"' -monly-3-regs -required/IO_flags = -fglasgow-exts '-\#include"cbits/stgio.h"' -required/Ix_flags = -fglasgow-exts -required/System_flags = -fglasgow-exts '-\#include"cbits/stgio.h"' +ghc/PackedString_flags = '-\#include"cbits/stgio.h"' -monly-3-regs +required/Directory_flags = '-\#include"cbits/stgio.h"' -monly-3-regs +required/System_flags = '-\#include"cbits/stgio.h"' concurrent/Merge_flags = -iconcurrent concurrent/Parallel_flags = -fglasgow-exts @@ -105,7 +101,7 @@ concurrent/Concurrent_flags = -iconcurrent # Depend and install stuff MKDEPENDHS_OPTS += -I$(GHC_INCLUDES) -MKDEPENDHS_OPTS += -irequired:prelude:ghc:hbc:glaExts:concurrent +MKDEPENDHS_OPTS += -irequired:ghc:hbc:glaExts:concurrent MKDEPENDHS_OPTS += $(foreach way,$(WAY_SUFFIXES),-s .$(way)) # Todo: make this a generic include of hsdepend.mk or something. diff --git a/ghc/runtime/main/StgStartup.lhc b/ghc/runtime/main/StgStartup.lhc index 086f755..b41500d 100644 --- a/ghc/runtime/main/StgStartup.lhc +++ b/ghc/runtime/main/StgStartup.lhc @@ -198,9 +198,9 @@ SET_STATIC_HDR(EmptySPTable_closure,EmptyStablePointerTable_info,CC_SUBSUMED,,ED /* Question: this is just an amusing hex code isn't it -- or does it mean something? ADR */ P_ realWorldZh_closure = (P_) 0xbadbadbaL; -P_ GHCbuiltins_void_closure = (P_) 0xbadbadbaL; +P_ GHC_void_closure = (P_) 0xbadbadbaL; -SET_STATIC_HDR(WorldStateToken_closure,GHCbase_SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_) +SET_STATIC_HDR(WorldStateToken_closure,STBase_SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_) , (W_) 0xbadbadbaL }; diff --git a/ghc/runtime/prims/PrimMisc.lc b/ghc/runtime/prims/PrimMisc.lc index 142bab6..dc29069 100644 --- a/ghc/runtime/prims/PrimMisc.lc +++ b/ghc/runtime/prims/PrimMisc.lc @@ -86,11 +86,11 @@ Phantom info table vectors for multiple constructor primitive types that might have to perform a DynamicReturn (just Bool at the moment). \begin{code} -ED_RO_(Prelude_False_inregs_info); -ED_RO_(Prelude_True_inregs_info); +ED_RO_(PrelBase_False_inregs_info); +ED_RO_(PrelBase_True_inregs_info); -const W_ Prelude_Bool_itblvtbl[] = { - (W_) Prelude_False_inregs_info, - (W_) Prelude_True_inregs_info +const W_ PrelBase_Bool_itblvtbl[] = { + (W_) PrelBase_False_inregs_info, + (W_) PrelBase_True_inregs_info }; \end{code} diff --git a/ghc/runtime/storage/SMstatic.lc b/ghc/runtime/storage/SMstatic.lc index 96400af..861b67f 100644 --- a/ghc/runtime/storage/SMstatic.lc +++ b/ghc/runtime/storage/SMstatic.lc @@ -11,15 +11,15 @@ are built by the compiler from {\tr uTys.hs}. #define NULL_REG_MAP #include "SMinternal.h" -EXTDATA_RO(Prelude_CZh_static_info); -EXTDATA_RO(Prelude_IZh_static_info); +EXTDATA_RO(PrelBase_CZh_static_info); +EXTDATA_RO(PrelBase_IZh_static_info); #define __CHARLIKE_CLOSURE(n) (CHARLIKE_closures+((n)*(CHARLIKE_HS+1))) #define __INTLIKE_CLOSURE(n) (INTLIKE_closures_def+(((n)-MIN_INTLIKE)*(INTLIKE_HS+1))) -#define CHARLIKE_HDR(n) SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),Prelude_CZh_static_info,CC_DONTZuCARE), (W_) n +#define CHARLIKE_HDR(n) SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),PrelBase_CZh_static_info,CC_DONTZuCARE), (W_) n -#define INTLIKE_HDR(n) SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),Prelude_IZh_static_info,CC_DONTZuCARE), (W_) n +#define INTLIKE_HDR(n) SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),PrelBase_IZh_static_info,CC_DONTZuCARE), (W_) n const W_ CHARLIKE_closures[] = { CHARLIKE_HDR(0), -- 1.7.10.4