From 51a571c0f5b0201ea53bec60fcaafb78c01c017e Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 8 Mar 2001 12:07:43 +0000 Subject: [PATCH] [project @ 2001-03-08 12:07:38 by simonpj] -------------------- A major hygiene pass -------------------- 1. The main change here is to Move what was the "IdFlavour" out of IdInfo, and into the varDetails field of a Var It was a mess before, because the flavour was a permanent attribute of an Id, whereas the rest of the IdInfo was ephemeral. It's all much tidier now. Main places to look: Var.lhs Defn of VarDetails IdInfo.lhs Defn of GlobalIdDetails The main remaining infelicity is that SpecPragmaIds are right down in Var.lhs, which seems unduly built-in for such an ephemeral thing. But that is no worse than before. 2. Tidy up the HscMain story a little. Move mkModDetails from MkIface into CoreTidy (where it belongs more nicely) This was partly forced by (1) above, because I didn't want to make DictFun Ids into a separate kind of Id (which is how it was before). Not having them separate means we have to keep a list of them right through, rather than pull them out of the bindings at the end. 3. Add NameEnv as a separate module (to join NameSet). 4. Remove unnecessary {-# SOURCE #-} imports from FieldLabel. --- ghc/compiler/DEPEND-NOTES | 8 +- ghc/compiler/basicTypes/FieldLabel.lhs | 5 +- ghc/compiler/basicTypes/Id.lhs | 158 ++++++++++++-------------- ghc/compiler/basicTypes/IdInfo.hi-boot | 4 +- ghc/compiler/basicTypes/IdInfo.hi-boot-5 | 4 +- ghc/compiler/basicTypes/IdInfo.lhs | 162 ++++++++++---------------- ghc/compiler/basicTypes/MkId.lhs | 107 ++++++------------ ghc/compiler/basicTypes/Name.lhs | 58 +--------- ghc/compiler/basicTypes/Var.lhs | 181 ++++++++++++++++++++++-------- ghc/compiler/compMan/CompManager.lhs | 4 +- ghc/compiler/coreSyn/CoreFVs.lhs | 27 +---- ghc/compiler/coreSyn/CoreLint.lhs | 4 +- ghc/compiler/coreSyn/CoreSat.lhs | 19 +--- ghc/compiler/coreSyn/CoreTidy.lhs | 155 +++++++++++++++++++------ ghc/compiler/coreSyn/CoreUnfold.lhs | 8 +- ghc/compiler/coreSyn/CoreUtils.lhs | 10 +- ghc/compiler/coreSyn/PprCore.lhs | 17 ++- ghc/compiler/coreSyn/Subst.lhs | 15 ++- ghc/compiler/deSugar/Desugar.lhs | 2 +- ghc/compiler/deSugar/DsForeign.lhs | 8 +- ghc/compiler/ghci/ByteCodeGen.lhs | 5 +- ghc/compiler/main/ErrUtils.lhs | 11 +- ghc/compiler/main/HscMain.lhs | 66 +++++------ ghc/compiler/main/HscTypes.lhs | 21 +++- ghc/compiler/main/MkIface.lhs | 168 ++++++++++----------------- ghc/compiler/rename/Rename.lhs | 4 +- ghc/compiler/rename/RnEnv.lhs | 4 +- ghc/compiler/rename/RnHiFiles.lhs | 2 +- ghc/compiler/rename/RnIfaces.lhs | 4 +- ghc/compiler/rename/RnMonad.lhs | 2 +- ghc/compiler/rename/RnNames.lhs | 11 +- ghc/compiler/simplCore/SATMonad.lhs | 4 +- ghc/compiler/simplCore/SimplCore.lhs | 17 ++- ghc/compiler/simplCore/SimplUtils.lhs | 4 +- ghc/compiler/specialise/SpecConstr.lhs | 7 +- ghc/compiler/specialise/Specialise.lhs | 7 +- ghc/compiler/stgSyn/CoreToStg.lhs | 6 +- ghc/compiler/stranal/WorkWrap.lhs | 3 +- ghc/compiler/typecheck/Inst.lhs | 6 +- ghc/compiler/typecheck/TcBinds.lhs | 6 +- ghc/compiler/typecheck/TcClassDcl.lhs | 4 +- ghc/compiler/typecheck/TcEnv.lhs | 9 +- ghc/compiler/typecheck/TcForeign.lhs | 8 +- ghc/compiler/typecheck/TcHsSyn.lhs | 2 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 16 +-- ghc/compiler/typecheck/TcModule.lhs | 109 +++++++----------- ghc/compiler/typecheck/TcMonoType.lhs | 4 +- ghc/compiler/typecheck/TcPat.lhs | 4 +- ghc/compiler/typecheck/TcRules.lhs | 6 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 2 +- ghc/compiler/types/Generics.lhs | 14 +-- ghc/compiler/usageSP/UsageSPInf.lhs | 1 - ghc/compiler/usageSP/UsageSPUtils.lhs | 1 - 53 files changed, 711 insertions(+), 783 deletions(-) diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index f92764e..fb966c6 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -5,12 +5,12 @@ The Name/Var/Type group is a bit complicated. Here's the deal Things in brackets are what the module *uses*. A 'loop' indicates a use from a module compiled later - Name, PrimRep, FieldLabel (loop Type.Type) + Name, PrimRep then PrelNames then - Var (Name, loop CoreSyn.CoreExpr, loop IdInfo.IdInfo, - loop Type.GenType, loop Type.Kind) + Var (Name, loop IdInfo.IdInfo, + loop Type.Type, loop Type.Kind) then VarEnv, VarSet, ThinAir then @@ -20,7 +20,7 @@ then then Type (loop DataCon.DataCon, loop Subst.substTy) then - TysPrim (Type), PprEnv (loop DataCon.DataCon, Type) + FieldLabel( Type), TysPrim (Type), PprEnv (loop DataCon.DataCon, Type) then Unify, PprType (PprEnv) then diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index 50a6687..b388d37 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -16,9 +16,8 @@ module FieldLabel( #include "HsVersions.h" -import {-# SOURCE #-} TypeRep( Type ) -- FieldLabel is compiled very early -import {-# SOURCE #-} TyCon( TyCon ) -- FieldLabel is compiled very early - +import Type( Type ) +import TyCon( TyCon ) import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique ) import Outputable import Unique ( Uniquable(..) ) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 7c66c22..f53e85d 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,28 +8,29 @@ module Id ( Id, DictId, -- Simple construction - mkId, mkVanillaId, mkSysLocal, mkUserLocal, + mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, + mkSysLocal, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, + mkWorkerId, -- Taking an Id apart idName, idType, idUnique, idInfo, - idPrimRep, isId, + idPrimRep, isId, globalIdDetails, recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdNoDiscard, + setIdName, setIdUnique, setIdType, setIdNoDiscard, setGlobalIdDetails, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapDemandIdInfo, + zapLamIdInfo, zapDemandIdInfo, -- Predicates isImplicitId, isDeadBinder, - externallyVisibleId, - isSpecPragmaId, isRecordSelector, - isPrimOpId, isPrimOpId_maybe, isDictFunId, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isPrimOpId_maybe, isDataConId, isDataConId_maybe, isDataConWrapId, isDataConWrapId_maybe, isBottomingId, - isExportedId, isLocalId, hasNoBinding, -- Inline pragma stuff @@ -52,7 +53,6 @@ module Id ( setIdOccInfo, idArity, idArityInfo, - idFlavour, idDemandInfo, idStrictness, idTyGenInfo, @@ -72,13 +72,14 @@ module Id ( import CoreSyn ( Unfolding, CoreRules ) import BasicTypes ( Arity ) import Var ( Id, DictId, - isId, mkIdVar, - idName, idType, idUnique, idInfo, - setIdName, setVarType, setIdUnique, + isId, isExportedId, isSpecPragmaId, isLocalId, + idName, idType, idUnique, idInfo, isGlobalId, + setIdName, setVarType, setIdUnique, setIdNoDiscard, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - externallyVisibleId + globalIdDetails, setGlobalIdDetails ) +import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId ) import Type ( Type, typePrimRep, addFreeTyVars, usOnce, seqType, splitTyConApp_maybe ) @@ -87,9 +88,9 @@ import IdInfo import Demand ( Demand ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, - getOccName + getOccName, getSrcLoc ) -import OccName ( UserFS ) +import OccName ( UserFS, mkWorkerOcc ) import PrimRep ( PrimRep ) import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel ) @@ -120,38 +121,54 @@ infixl 1 `setIdUnfolding`, %* * %************************************************************************ -Absolutely all Ids are made by mkId. It - a) Pins free-tyvar-info onto the Id's type, - where it can easily be found. - b) Ensures that exported Ids are +Absolutely all Ids are made by mkId. It is just like Var.mkId, +but in addition it pins free-tyvar-info onto the Id's type, +where it can easily be found. \begin{code} -mkId :: Name -> Type -> IdInfo -> Id -mkId name ty info = mkIdVar name (addFreeTyVars ty) info +mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id +mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info + +mkSpecPragmaId :: OccName -> Unique -> Type -> SrcLoc -> Id +mkSpecPragmaId occ uniq ty loc = Var.mkSpecPragmaId (mkLocalName uniq occ loc) + (addFreeTyVars ty) + noCafIdInfo + +mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info \end{code} \begin{code} -mkVanillaId :: Name -> Type -> Id -mkVanillaId name ty = mkId name ty vanillaIdInfo +mkLocalId :: Name -> Type -> Id +mkLocalId name ty = mkLocalIdWithInfo name ty noCafIdInfo -- SysLocal: for an Id being created by the compiler out of thin air... -- UserLocal: an Id with a name the user might recognize... mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id mkSysLocal :: UserFS -> Unique -> Type -> Id +mkVanillaGlobal :: Name -> Type -> IdInfo -> Id -mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty -mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName uniq occ loc) ty +mkSysLocal fs uniq ty = mkLocalId (mkSysLocalName uniq fs) ty +mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName uniq occ loc) ty +mkVanillaGlobal = mkGlobalId VanillaGlobal \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @Uniques@, but that's OK because the templates are supposed to be instantiated before use. - + \begin{code} -- "Wild Id" typically used when you need a binder that you don't expect to use mkWildId :: Type -> Id mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty +mkWorkerId :: Unique -> Id -> Type -> Id +-- A worker gets a local name. CoreTidy will globalise it if necessary. +mkWorkerId uniq unwrkr ty + = mkLocalId wkr_name ty + where + wkr_name = mkLocalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr) + -- "Template locals" typically used in unfoldings mkTemplateLocals :: [Type] -> [Id] mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl")) @@ -161,8 +178,8 @@ mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl")) mkTemplateLocalsNum :: Int -> [Type] -> [Id] -- The Int gives the starting point for unique allocation mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl")) - (getNumBuiltinUniques n (length tys)) - tys + (getNumBuiltinUniques n (length tys)) + tys mkTemplateLocal :: Int -> Type -> Id mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty @@ -191,95 +208,64 @@ idPrimRep id = typePrimRep (idType id) %* * %************************************************************************ -\begin{code} -idFlavour :: Id -> IdFlavour -idFlavour id = flavourInfo (idInfo id) +The @SpecPragmaId@ exists only to make Ids that are +on the *LHS* of bindings created by SPECIALISE pragmas; +eg: s = f Int d +The SpecPragmaId is never itself mentioned; it +exists solely so that the specialiser will find +the call to f, and make specialised version of it. +The SpecPragmaId binding is discarded by the specialiser +when it gathers up overloaded calls. +Meanwhile, it is not discarded as dead code. -setIdNoDiscard :: Id -> Id -setIdNoDiscard id -- Make an Id into a NoDiscardId, unless it is already - = modifyIdInfo setNoDiscardInfo id +\begin{code} recordSelectorFieldLabel :: Id -> FieldLabel -recordSelectorFieldLabel id = case idFlavour id of - RecordSelId lbl -> lbl +recordSelectorFieldLabel id = case globalIdDetails id of + RecordSelId lbl -> lbl -isRecordSelector id = case idFlavour id of +isRecordSelector id = case globalIdDetails id of RecordSelId lbl -> True other -> False -isPrimOpId id = case idFlavour id of +isPrimOpId id = case globalIdDetails id of PrimOpId op -> True other -> False -isPrimOpId_maybe id = case idFlavour id of +isPrimOpId_maybe id = case globalIdDetails id of PrimOpId op -> Just op other -> Nothing -isDataConId id = case idFlavour id of +isDataConId id = case globalIdDetails id of DataConId _ -> True other -> False -isDataConId_maybe id = case idFlavour id of +isDataConId_maybe id = case globalIdDetails id of DataConId con -> Just con other -> Nothing -isDataConWrapId_maybe id = case idFlavour id of +isDataConWrapId_maybe id = case globalIdDetails id of DataConWrapId con -> Just con other -> Nothing -isDataConWrapId id = case idFlavour id of +isDataConWrapId id = case globalIdDetails id of DataConWrapId con -> True other -> False -isSpecPragmaId id = case idFlavour id of - SpecPragmaId -> True - other -> False - -hasNoBinding id = case idFlavour id of - DataConId _ -> True - PrimOpId _ -> True - other -> False -- hasNoBinding returns True of an Id which may not have a -- binding, even though it is defined in this module. Notably, -- the constructors of a dictionary are in this situation. +hasNoBinding id = case globalIdDetails id of + DataConId _ -> True + PrimOpId _ -> True + other -> False -isDictFunId id = case idFlavour id of - DictFunId -> True - other -> False - --- Don't drop a binding for an exported Id, --- if it otherwise looks dead. --- Perhaps a better name would be isDiscardableId -isExportedId :: Id -> Bool -isExportedId id = case idFlavour id of - VanillaId -> False - other -> True - -isLocalId :: Id -> Bool --- True of Ids that are locally defined, but are not constants --- like data constructors, record selectors, and the like. --- See comments with CoreFVs.isLocalVar -isLocalId id -#ifdef DEBUG - | not (isId id) = pprTrace "isLocalid" (ppr id) False - | otherwise -#endif - = case idFlavour id of - VanillaId -> True - ExportedId -> True - SpecPragmaId -> True - other -> False -\end{code} - - -isImplicitId tells whether an Id's info is implied by other -declarations, so we don't need to put its signature in an interface -file, even if it's mentioned in some other interface unfolding. - -\begin{code} isImplicitId :: Id -> Bool + -- isImplicitId tells whether an Id's info is implied by other + -- declarations, so we don't need to put its signature in an interface + -- file, even if it's mentioned in some other interface unfolding. isImplicitId id - = case idFlavour id of + = case globalIdDetails id of RecordSelId _ -> True -- Includes dictionary selectors PrimOpId _ -> True DataConId _ -> True diff --git a/ghc/compiler/basicTypes/IdInfo.hi-boot b/ghc/compiler/basicTypes/IdInfo.hi-boot index f180e04..2edaa0a 100644 --- a/ghc/compiler/basicTypes/IdInfo.hi-boot +++ b/ghc/compiler/basicTypes/IdInfo.hi-boot @@ -1,7 +1,9 @@ _interface_ IdInfo 1 _exports_ -IdInfo IdInfo seqIdInfo vanillaIdInfo; +IdInfo IdInfo GlobalIdDetails notGlobalId seqIdInfo vanillaIdInfo; _declarations_ 1 data IdInfo ; +1 data GlobalIdDetails ; +1 notGlobalId _:_ GlobalIdDetails ;; 1 seqIdInfo _:_ IdInfo -> PrelBase.() ;; 1 vanillaIdInfo _:_ IdInfo ;; diff --git a/ghc/compiler/basicTypes/IdInfo.hi-boot-5 b/ghc/compiler/basicTypes/IdInfo.hi-boot-5 index efd8cc4..4a326ca 100644 --- a/ghc/compiler/basicTypes/IdInfo.hi-boot-5 +++ b/ghc/compiler/basicTypes/IdInfo.hi-boot-5 @@ -1,6 +1,8 @@ __interface IdInfo 1 0 where -__export IdInfo IdInfo seqIdInfo vanillaIdInfo ; +__export IdInfo IdInfo GlobalIdDetails notGlobalId seqIdInfo vanillaIdInfo ; 1 data IdInfo ; +1 data GlobalIdDetails ; +1 notGlobalId :: GlobalIdDetails ; 1 seqIdInfo :: IdInfo -> PrelBase.Z0T ; 1 vanillaIdInfo :: IdInfo ; diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 91ecbe2..cde3737 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -8,18 +8,15 @@ Haskell. [WDP 94/11]) \begin{code} module IdInfo ( - IdInfo, -- Abstract + GlobalIdDetails(..), notGlobalId, -- Not abstract - vanillaIdInfo, constantIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo, + IdInfo, -- Abstract + vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo, noCafIdInfo, + seqIdInfo, megaSeqIdInfo, -- Zapping zapLamInfo, zapDemandInfo, - zapSpecPragInfo, shortableIdInfo, copyIdInfo, - - -- Flavour - IdFlavour(..), flavourInfo, makeConstantFlavour, - setNoDiscardInfo, setFlavourInfo, - ppFlavourInfo, + shortableIdInfo, copyIdInfo, -- Arity ArityInfo(..), @@ -104,14 +101,54 @@ infixl 1 `setDemandInfo`, -- infixl so you can say (id `set` a `set` b) \end{code} +%************************************************************************ +%* * +\subsection{GlobalIdDetails +%* * +%************************************************************************ + +This type is here (rather than in Id.lhs) mainly because there's +an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported +(recursively) by Var.lhs. + +\begin{code} +data GlobalIdDetails + = VanillaGlobal -- Imported from elsewhere, a default method Id. + + | RecordSelId FieldLabel -- The Id for a record selector + | DataConId DataCon -- The Id for a data constructor *worker* + | DataConWrapId DataCon -- The Id for a data constructor *wrapper* + -- [the only reasons we need to know is so that + -- a) we can suppress printing a definition in the interface file + -- b) when typechecking a pattern we can get from the + -- Id back to the data con] + + | PrimOpId PrimOp -- The Id for a primitive operator + + | NotGlobalId -- Used as a convenient extra return value from globalIdDetails + +notGlobalId = NotGlobalId + +instance Outputable GlobalIdDetails where + ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") + ppr VanillaGlobal = ptext SLIT("[GlobalId]") + ppr (DataConId _) = ptext SLIT("[DataCon]") + ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") + ppr (PrimOpId _) = ptext SLIT("[PrimOp]") + ppr (RecordSelId _) = ptext SLIT("[RecSel]") +\end{code} + + +%************************************************************************ +%* * +\subsection{The main IdInfo type} +%* * +%************************************************************************ + An @IdInfo@ gives {\em optional} information about an @Id@. If present it never lies, but it may not be present, in which case there is always a conservative assumption which can be made. - There is one exception: the 'flavour' is *not* optional. - You must not discard it. - It used to be in Var.lhs, but that seems unclean. - Two @Id@s may have different info even though they have the same @Unique@ (and are hence the same @Id@); for example, one might lack the properties attached to the other. @@ -124,7 +161,6 @@ case. KSW 1999-04). \begin{code} data IdInfo = IdInfo { - flavourInfo :: IdFlavour, -- NOT OPTIONAL arityInfo :: ArityInfo, -- Its arity demandInfo :: Demand, -- Whether or not it is definitely demanded specInfo :: CoreRules, -- Specialisations of this function which exist @@ -144,8 +180,7 @@ seqIdInfo (IdInfo {}) = () megaSeqIdInfo :: IdInfo -> () megaSeqIdInfo info - = seqFlavour (flavourInfo info) `seq` - seqArity (arityInfo info) `seq` + = seqArity (arityInfo info) `seq` seqDemand (demandInfo info) `seq` seqRules (specInfo info) `seq` seqTyGenInfo (tyGenInfo info) `seq` @@ -165,7 +200,6 @@ megaSeqIdInfo info Setters \begin{code} -setFlavourInfo info fl = fl `seq` info { flavourInfo = fl } setWorkerInfo info wk = wk `seq` info { workerInfo = wk } setSpecInfo info sp = PSEQ sp (info { specInfo = sp }) setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg } @@ -197,34 +231,14 @@ setArityInfo info ar = info { arityInfo = ar } setCafInfo info cf = info { cafInfo = cf } setCprInfo info cp = info { cprInfo = cp } setLBVarInfo info lb = info { lbvarInfo = lb } - -setNoDiscardInfo info = case flavourInfo info of - VanillaId -> info { flavourInfo = ExportedId } - other -> info -zapSpecPragInfo info = case flavourInfo info of - SpecPragmaId -> info { flavourInfo = VanillaId } - other -> info \end{code} \begin{code} vanillaIdInfo :: IdInfo - -- Used for locally-defined Ids - -- We are going to calculate correct CAF information at the end -vanillaIdInfo = mkIdInfo VanillaId NoCafRefs - -constantIdInfo :: IdInfo - -- Used for imported Ids - -- The default is that they *do* have CAFs; an interface-file pragma - -- may say "oh no it doesn't", but in the absence of such a pragma - -- we'd better assume it does -constantIdInfo = mkIdInfo ConstantId MayHaveCafRefs - -mkIdInfo :: IdFlavour -> CafInfo -> IdInfo -mkIdInfo flv caf +vanillaIdInfo = IdInfo { - flavourInfo = flv, - cafInfo = caf, + cafInfo = MayHaveCafRefs, -- Safe! arityInfo = UnknownArity, demandInfo = wwLazy, specInfo = emptyCoreRules, @@ -237,74 +251,18 @@ mkIdInfo flv caf inlinePragInfo = NoInlinePragInfo, occInfo = NoOccInfo } -\end{code} - - -%************************************************************************ -%* * -\subsection{Flavour} -%* * -%************************************************************************ - -\begin{code} -data IdFlavour - = VanillaId -- Locally defined, not exported - | ExportedId -- Locally defined, exported - | SpecPragmaId -- Locally defined, RHS holds specialised call - | ConstantId -- Imported from elsewhere, or a default method Id. +noTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever + -- Many built-in things have fixed types, so we shouldn't + -- run around generalising them - | DictFunId -- We flag dictionary functions so that we can - -- conveniently extract the DictFuns from a set of - -- bindings when building a module's interface +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Local things don't refer to Cafs - | DataConId DataCon -- The Id for a data constructor *worker* - | DataConWrapId DataCon -- The Id for a data constructor *wrapper* - -- [the only reasons we need to know is so that - -- a) we can suppress printing a definition in the interface file - -- b) when typechecking a pattern we can get from the - -- Id back to the data con] - | PrimOpId PrimOp -- The Id for a primitive operator - | RecordSelId FieldLabel -- The Id for a record selector - - -makeConstantFlavour :: IdFlavour -> IdFlavour -makeConstantFlavour flavour = new_flavour - where new_flavour = case flavour of - VanillaId -> ConstantId - ExportedId -> ConstantId - ConstantId -> ConstantId -- e.g. Default methods - DictFunId -> DictFunId - flavour -> pprTrace "makeConstantFlavour" - (ppFlavourInfo flavour) - flavour - - -ppFlavourInfo :: IdFlavour -> SDoc -ppFlavourInfo VanillaId = empty -ppFlavourInfo ExportedId = ptext SLIT("[Exported]") -ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") -ppFlavourInfo ConstantId = ptext SLIT("[Constant]") -ppFlavourInfo DictFunId = ptext SLIT("[DictFun]") -ppFlavourInfo (DataConId _) = ptext SLIT("[DataCon]") -ppFlavourInfo (DataConWrapId _) = ptext SLIT("[DataConWrapper]") -ppFlavourInfo (PrimOpId _) = ptext SLIT("[PrimOp]") -ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]") - -seqFlavour :: IdFlavour -> () -seqFlavour f = f `seq` () +noCafOrTyGenIdInfo = noTyGenIdInfo `setCafInfo` NoCafRefs + -- Most also guarantee not to refer to CAFs \end{code} -The @SpecPragmaId@ exists only to make Ids that are -on the *LHS* of bindings created by SPECIALISE pragmas; -eg: s = f Int d -The SpecPragmaId is never itself mentioned; it -exists solely so that the specialiser will find -the call to f, and make specialised version of it. -The SpecPragmaId binding is discarded by the specialiser -when it gathers up overloaded calls. -Meanwhile, it is not discarded as dead code. - %************************************************************************ %* * @@ -501,8 +459,6 @@ seqWorker NoWorker = () ppWorkerInfo NoWorker = empty ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("__P") <+> ppr wk_id -noWorkerInfo = NoWorker - workerExists :: WorkerInfo -> Bool workerExists NoWorker = False workerExists (HasWorker _ _) = True diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index f037efd..e5a2a49 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -13,8 +13,6 @@ have a standard form, namely: \begin{code} module MkId ( - mkSpecPragmaId, mkWorkerId, - mkDictFunId, mkDefaultMethodId, mkDictSelId, @@ -54,10 +52,7 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, import Class ( Class, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar ) import VarSet ( isEmptyVarSet ) -import Name ( mkWiredInName, mkLocalName, - mkWorkerOcc, mkCCallName, - Name, NamedThing(..), getSrcLoc - ) +import Name ( mkWiredInName, mkCCallName, Name ) import OccName ( mkVarOcc ) import PrimOp ( PrimOp(DataToTagOp, CCallOp), primOpSig, mkPrimOpIdName, @@ -72,15 +67,15 @@ import DataCon ( DataCon, StrictnessMark(..), dataConSig, dataConStrictMarks, dataConId, maybeMarkedUnboxed, splitProductType_maybe ) -import Id ( idType, mkId, - mkVanillaId, mkTemplateLocals, mkTemplateLocalsNum, +import Id ( idType, mkGlobalId, mkVanillaGlobal, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, idCprInfo ) -import IdInfo ( IdInfo, constantIdInfo, mkIdInfo, +import IdInfo ( IdInfo, vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo, exactArity, setUnfoldingInfo, setCafInfo, setCprInfo, - setArityInfo, setSpecInfo, setTyGenInfo, + setArityInfo, setSpecInfo, mkStrictnessInfo, setStrictnessInfo, - IdFlavour(..), CafInfo(..), CprInfo(..), TyGenInfo(..) + GlobalIdDetails(..), CafInfo(..), CprInfo(..) ) import FieldLabel ( mkFieldLabel, fieldLabelName, firstFieldLabelTag, allFieldLabelTags, fieldLabelType @@ -95,7 +90,6 @@ import UnicodeUtil ( stringToUtf8 ) import Char ( ord ) \end{code} - %************************************************************************ %* * \subsection{Wired in Ids} @@ -132,32 +126,6 @@ wiredInIds %************************************************************************ %* * -\subsection{Easy ones} -%* * -%************************************************************************ - -\begin{code} -mkSpecPragmaId occ uniq ty loc - = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId NoCafRefs) - -- Maybe a SysLocal? But then we'd lose the location - -mkDefaultMethodId dm_name rec_c ty - = mkId dm_name ty info - where - info = constantIdInfo `setTyGenInfo` TyGenNever - -- type is wired-in (see comment at TcClassDcl.tcClassSig), so - -- do not generalise it - -mkWorkerId :: Unique -> Id -> Type -> Id --- A worker gets a local name. CoreTidy will globalise it if necessary. -mkWorkerId uniq unwrkr ty - = mkVanillaId wkr_name ty - where - wkr_name = mkLocalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr) -\end{code} - -%************************************************************************ -%* * \subsection{Data constructors} %* * %************************************************************************ @@ -167,9 +135,9 @@ mkDataConId :: Name -> DataCon -> Id -- Makes the *worker* for the data constructor; that is, the function -- that takes the reprsentation arguments and builds the constructor. mkDataConId work_name data_con - = mkId work_name (dataConRepType data_con) info + = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info where - info = mkIdInfo (DataConId data_con) NoCafRefs + info = noCafOrTyGenIdInfo `setArityInfo` exactArity arity `setStrictnessInfo` strict_info `setCprInfo` cpr_info @@ -228,10 +196,10 @@ Notice that mkDataConWrapId data_con = wrap_id where - wrap_id = mkId (dataConName data_con) wrap_ty info + wrap_id = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info work_id = dataConId data_con - info = mkIdInfo (DataConWrapId data_con) NoCafRefs + info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs) `setCprInfo` cpr_info -- The Cpr info can be important inside INLINE rhss, where the @@ -239,9 +207,6 @@ mkDataConWrapId data_con `setArityInfo` exactArity arity -- It's important to specify the arity, so that partial -- applications are treated as values - `setTyGenInfo` TyGenNever - -- No point generalising its type, since it gets eagerly inlined - -- away anyway wrap_ty = mkForAllTys all_tyvars $ mkFunTys all_arg_tys @@ -382,8 +347,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id -- we can't conjure it up out of thin air = sel_id where - sel_id = mkId (fieldLabelName field_label) selector_ty info - + sel_id = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info field_ty = fieldLabelType field_label data_cons = tyConDataCons tycon tyvars = tyConTyVars tycon -- These scope over the types in @@ -429,10 +393,10 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id mkFunTy data_ty field_tau arity = 1 + n_dict_tys + n_field_dict_tys - info = mkIdInfo (RecordSelId field_label) caf_info + info = noTyGenIdInfo + `setCafInfo` caf_info `setArityInfo` exactArity arity `setUnfoldingInfo` unfolding - `setTyGenInfo` TyGenNever -- ToDo: consider adding further IdInfo unfolding = mkTopUnfolding sel_rhs @@ -551,14 +515,13 @@ mkDictSelId name clas = sel_id where ty = exprType rhs - sel_id = mkId name ty info + sel_id = mkGlobalId (RecordSelId field_lbl) name ty info field_lbl = mkFieldLabel name tycon ty tag tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id - info = mkIdInfo (RecordSelId field_lbl) NoCafRefs + info = noCafOrTyGenIdInfo `setArityInfo` exactArity 1 `setUnfoldingInfo` unfolding - `setTyGenInfo` TyGenNever -- We no longer use 'must-inline' on record selectors. They'll -- inline like crazy if they scrutinise a constructor @@ -598,9 +561,9 @@ mkPrimOpId prim_op (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) name = mkPrimOpIdName prim_op - id = mkId name ty info + id = mkGlobalId (PrimOpId prim_op) name ty info - info = mkIdInfo (PrimOpId prim_op) NoCafRefs + info = noCafOrTyGenIdInfo `setSpecInfo` rules `setArityInfo` exactArity arity `setStrictnessInfo` strict_info @@ -622,7 +585,7 @@ mkCCallOpId uniq ccall ty = ASSERT( isEmptyVarSet (tyVarsOfType ty) ) -- A CCallOpId should have no free type variables; -- when doing substitutions won't substitute over it - mkId name ty info + mkGlobalId (PrimOpId prim_op) name ty info where occ_str = showSDocIface (braces (pprCCallOp ccall <+> ppr ty)) -- The "occurrence name" of a ccall is the full info about the @@ -631,7 +594,7 @@ mkCCallOpId uniq ccall ty name = mkCCallName uniq occ_str prim_op = CCallOp ccall - info = mkIdInfo (PrimOpId prim_op) NoCafRefs + info = noCafOrTyGenIdInfo `setArityInfo` exactArity arity `setStrictnessInfo` strict_info @@ -644,11 +607,14 @@ mkCCallOpId uniq ccall ty %************************************************************************ %* * -\subsection{DictFuns} +\subsection{DictFuns and default methods} %* * %************************************************************************ \begin{code} +mkDefaultMethodId dm_name ty + = mkVanillaGlobal dm_name ty noTyGenIdInfo + mkDictFunId :: Name -- Name to use for the dict fun; -> Class -> [TyVar] @@ -657,14 +623,12 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Id mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta - = mkId dfun_name dfun_ty info + = mkVanillaGlobal dfun_name dfun_ty noTyGenIdInfo where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) - info = mkIdInfo DictFunId MayHaveCafRefs - `setTyGenInfo` TyGenNever - -- type is wired-in (see comment at TcClassDcl.tcClassSig), so - -- do not generalise it - -- An imported dfun may refer to CAFs, so we assume the worst + info = noTyGenIdInfo + -- Type is wired-in (see comment at TcClassDcl.tcClassSig), + -- so do not generalise it {- 1 dec 99: disable the Mark Jones optimisation for the sake of compatibility with Hugs. @@ -716,7 +680,7 @@ another gun with which to shoot yourself in the foot. unsafeCoerceId = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info where - info = constantIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] @@ -734,8 +698,7 @@ evaluate its argument and call the dataToTag# primitive. getTagId = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info where - info = constantIdInfo - `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs -- We don't provide a defn for this; you must inline it ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy) @@ -753,7 +716,7 @@ nasty as-is, change it back to a literal (@Literal@). realWorldPrimId -- :: State# RealWorld = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#") realWorldStatePrimTy - (noCafIdInfo `setUnfoldingInfo` mkOtherCon []) + (noCafOrTyGenIdInfo `setUnfoldingInfo` mkOtherCon []) -- The mkOtherCon makes it look that realWorld# is evaluated -- which in turn makes Simplify.interestingArg return True, -- which in turn makes INLINE things applied to realWorld# likely @@ -806,8 +769,7 @@ aBSENT_ERROR_ID pAR_ERROR_ID = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError") - (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafIdInfo - + (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafOrTyGenIdInfo \end{code} @@ -822,7 +784,7 @@ pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id pcMiscPrelId key mod str ty info = let name = mkWiredInName mod (mkVarOcc str) key - imp = mkId name ty info -- the usual case... + imp = mkVanillaGlobal name ty info -- the usual case... in imp -- We lie and say the thing is imported; otherwise, we get into @@ -834,16 +796,13 @@ pcMiscPrelId key mod str ty info pc_bottoming_Id key mod name ty = pcMiscPrelId key mod name ty bottoming_info where - bottoming_info = noCafIdInfo + bottoming_info = noCafOrTyGenIdInfo `setStrictnessInfo` mkStrictnessInfo ([wwStrict], True) -- these "bottom" out, no matter what their arguments generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy --- Very useful... -noCafIdInfo = constantIdInfo `setCafInfo` NoCafRefs - (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 8286e39..229a0e8 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -26,14 +26,6 @@ module Name ( isTyVarName, isDllName, nameIsLocalOrFrom, isHomePackageName, - -- Environment - NameEnv, mkNameEnv, - emptyNameEnv, unitNameEnv, nameEnvElts, - extendNameEnv_C, extendNameEnv, foldNameEnv, filterNameEnv, - plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList, - lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv, - - -- Class NamedThing and overloaded friends NamedThing(..), getSrcLoc, getOccString, toRdrName @@ -46,10 +38,8 @@ import Module ( Module, moduleName, mkVanillaModule, isHomeModule ) import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_Static ) import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) -import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 ) +import Unique ( Unique, Uniquable(..), u2i, pprUnique ) import FastTypes -import Maybes ( expectJust ) -import UniqFM import Outputable \end{code} @@ -276,52 +266,6 @@ instance NamedThing Name where %************************************************************************ %* * -\subsection{Name environment} -%* * -%************************************************************************ - -\begin{code} -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -mkNameEnv :: [(Name,a)] -> NameEnv a -nameEnvElts :: NameEnv a -> [a] -extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a -extendNameEnvList:: NameEnv a -> [(Name,a)] -> NameEnv a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool -unitNameEnv :: Name -> a -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -lookupNameEnv_NF :: NameEnv a -> Name -> a -mapNameEnv :: (a->b) -> NameEnv a -> NameEnv b -foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b -filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt - -emptyNameEnv = emptyUFM -foldNameEnv = foldUFM -mkNameEnv = listToUFM -nameEnvElts = eltsUFM -extendNameEnv_C = addToUFM_C -extendNameEnv = addToUFM -plusNameEnv = plusUFM -plusNameEnv_C = plusUFM_C -extendNameEnvList= addListToUFM -delFromNameEnv = delFromUFM -elemNameEnv = elemUFM -mapNameEnv = mapUFM -unitNameEnv = unitUFM -filterNameEnv = filterUFM - -lookupNameEnv = lookupUFM -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n) -\end{code} - - -%************************************************************************ -%* * \subsection{Pretty printing} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index a7c4e3c..062767a 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -13,27 +13,37 @@ module Var ( TyVar, tyVarName, tyVarKind, setTyVarName, setTyVarUnique, - mkTyVar, mkSysTyVar, isTyVar, isSigTyVar, + mkTyVar, mkSysTyVar, newMutTyVar, newSigTyVar, - readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable, + readMutTyVar, writeMutTyVar, makeTyVarImmutable, -- Ids Id, DictId, idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, - setIdName, setIdUnique, setIdInfo, lazySetIdInfo, zapIdInfo, - mkIdVar, isId, externallyVisibleId + setIdName, setIdUnique, setIdInfo, lazySetIdInfo, + setIdNoDiscard, zapSpecPragmaId, + + globalIdDetails, setGlobalIdDetails, + + mkLocalId, mkGlobalId, mkSpecPragmaId, + + isTyVar, isMutTyVar, isSigTyVar, + isId, isLocalVar, isLocalId, + isGlobalId, isExportedId, isSpecPragmaId, + mustHaveLocalBinding ) where #include "HsVersions.h" import {-# SOURCE #-} TypeRep( Type, Kind ) -import {-# SOURCE #-} IdInfo( IdInfo, seqIdInfo, vanillaIdInfo ) +import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, + IdInfo, seqIdInfo ) -import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) import Name ( Name, OccName, NamedThing(..), setNameUnique, setNameOcc, nameUnique, mkSysLocalName, isExternallyVisibleName ) +import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) import FastTypes import Outputable @@ -66,18 +76,42 @@ data Var } data VarDetails - = AnId + = LocalId -- Used for locally-defined Ids (see NOTE below) + LocalIdDetails -- True <=> exported; don't discard even if dead + + | GlobalId -- Used for imported Ids, dict selectors etc + GlobalIdDetails + | TyVar | MutTyVar (IORef (Maybe Type)) -- Used during unification; Bool -- True <=> this is a type signature variable, which -- should not be unified with a non-tyvar type --- For a long time I tried to keep mutable Vars statically type-distinct --- from immutable Vars, but I've finally given up. It's just too painful. --- After type checking there are no MutTyVars left, but there's no static check --- of that fact. + -- For a long time I tried to keep mutable Vars statically type-distinct + -- from immutable Vars, but I've finally given up. It's just too painful. + -- After type checking there are no MutTyVars left, but there's no static check + -- of that fact. + +data LocalIdDetails + = NotExported -- Not exported + | Exported -- Exported + | SpecPragma -- Not exported, but not to be discarded either + -- It's unclean that this is so deeply built in \end{code} +LocalId and GlobalId +~~~~~~~~~~~~~~~~~~~~ +A GlobalId is + * always a constant (top-level) + * imported, or data constructor, or primop, or record selector + +A LocalId is + * bound within an expression (lambda, case, local let(rec)) + * or defined at top level in the module being compiled + +After CoreTidy, top-level LocalIds are turned into GlobalIds + + \begin{code} instance Outputable Var where ppr var = ppr (varName var) @@ -189,20 +223,6 @@ writeMutTyVar (Var {varDetails = MutTyVar loc _}) val = writeIORef loc val makeTyVarImmutable :: TyVar -> TyVar makeTyVarImmutable tyvar = tyvar { varDetails = TyVar} - -isTyVar :: Var -> Bool -isTyVar (Var {varDetails = details}) = case details of - TyVar -> True - MutTyVar _ _ -> True - other -> False - -isMutTyVar :: Var -> Bool -isMutTyVar (Var {varDetails = MutTyVar _ _}) = True -isMutTyVar other = False - -isSigTyVar :: Var -> Bool -isSigTyVar (Var {varDetails = MutTyVar _ is_sig}) = is_sig -isSigTyVar other = False \end{code} @@ -231,6 +251,17 @@ setIdUnique = setVarUnique setIdName :: Id -> Name -> Id setIdName = setVarName +setIdNoDiscard :: Id -> Id +setIdNoDiscard id + = WARN( not (isLocalId id), ppr id ) + id { varDetails = LocalId Exported } + +zapSpecPragmaId :: Id -> Id +zapSpecPragmaId id + = case varDetails id of + LocalId SpecPragma -> id { varDetails = LocalId NotExported } + other -> id + lazySetIdInfo :: Id -> IdInfo -> Id lazySetIdInfo var info = var {varInfo = info} @@ -238,9 +269,6 @@ setIdInfo :: Id -> IdInfo -> Id setIdInfo var info = seqIdInfo info `seq` var {varInfo = info} -- Try to avoid spack leaks by seq'ing -zapIdInfo :: Id -> Id -zapIdInfo var = var {varInfo = vanillaIdInfo} - modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id modifyIdInfo fn var@(Var {varInfo = info}) = seqIdInfo new_info `seq` var {varInfo = new_info} @@ -254,31 +282,94 @@ maybeModifyIdInfo fn var@(Var {varInfo = info}) = case fn info of Just new_info -> var {varInfo = new_info} \end{code} +%************************************************************************ +%* * +\subsection{Predicates over variables +%* * +%************************************************************************ + \begin{code} -mkIdVar :: Name -> Type -> IdInfo -> Id -mkIdVar name ty info - = Var {varName = name, realUnique = getKey (nameUnique name), varType = ty, - varDetails = AnId, varInfo = info} +mkId :: Name -> Type -> VarDetails -> IdInfo -> Id +mkId name ty details info + = Var { varName = name, + realUnique = getKey (nameUnique name), -- Cache the unique + varType = ty, + varDetails = details, + varInfo = info } + +mkLocalId :: Name -> Type -> IdInfo -> Id +mkLocalId name ty info = mkId name ty (LocalId NotExported) info + +mkSpecPragmaId :: Name -> Type -> IdInfo -> Id +mkSpecPragmaId name ty info = mkId name ty (LocalId SpecPragma) info + +mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId details name ty info = mkId name ty (GlobalId details) info \end{code} \begin{code} -isId :: Var -> Bool -isId (Var {varDetails = AnId}) = True -isId other = False -\end{code} +isTyVar, isMutTyVar, isSigTyVar :: Var -> Bool +isId, isLocalVar, isLocalId :: Var -> Bool +isGlobalId, isExportedId, isSpecPragmaId :: Var -> Bool +mustHaveLocalBinding :: Var -> Bool -@externallyVisibleId@: is it true that another module might be -able to ``see'' this Id in a code generation sense. That -is, another .o file might refer to this Id. +isTyVar var = case varDetails var of + TyVar -> True + MutTyVar _ _ -> True + other -> False -In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's -local-ness precisely so that the test here would be easy +isMutTyVar (Var {varDetails = MutTyVar _ _}) = True +isMutTyVar other = False -This defn appears here (rather than, say, in Id.lhs) because -CostCentre.lhs uses it (CostCentre feeds PprType feeds Id.lhs) +isSigTyVar (Var {varDetails = MutTyVar _ is_sig}) = is_sig +isSigTyVar other = False +isId var = case varDetails var of + LocalId _ -> True + GlobalId _ -> True + other -> False + +isLocalId var = case varDetails var of + LocalId _ -> True + other -> False + +-- isLocalVar returns True for type variables as well as local Ids +-- These are the variables that we need to pay attention to when finding free +-- variables, or doing dependency analysis. +isLocalVar var = case varDetails var of + LocalId _ -> True + TyVar -> True + MutTyVar _ _ -> True + other -> False + +-- mustHaveLocalBinding returns True of Ids and TyVars +-- that must have a binding in this module. The converse +-- is not quite right: there are some GlobalIds that must have +-- bindings, such as record selectors. But that doesn't matter, +-- because it's only used for assertions +mustHaveLocalBinding var = isLocalVar var + +isGlobalId var = case varDetails var of + GlobalId _ -> True + other -> False + +isExportedId var = case varDetails var of + LocalId Exported -> True + GlobalId _ -> True + other -> False + +isSpecPragmaId var = case varDetails var of + LocalId SpecPragma -> True + other -> False \end{code} + \begin{code} -externallyVisibleId :: Id -> Bool -externallyVisibleId var = isExternallyVisibleName (varName var) +globalIdDetails :: Var -> GlobalIdDetails +-- Works OK on local Ids too, returning notGlobalId +globalIdDetails var = case varDetails var of + GlobalId details -> details + other -> notGlobalId +setGlobalIdDetails :: Id -> GlobalIdDetails -> Id +setGlobalIdDetails id details = id { varDetails = GlobalId details } \end{code} + diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index bae0a21..f2ba82a 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -37,8 +37,8 @@ import CmTypes import HscTypes import RnEnv ( unQualInScope ) import Id ( idType, idName ) -import Name ( Name, lookupNameEnv, extendNameEnvList, - NamedThing(..) ) +import Name ( Name, NamedThing(..) ) +import NameEnv import RdrName ( emptyRdrEnv ) import Module ( Module, ModuleName, moduleName, isHomeModule, mkModuleName, moduleNameUserString, moduleUserString ) diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index d170a3b..4729b20 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -5,8 +5,6 @@ Taken quite directly from the Peyton Jones/Lester paper. \begin{code} module CoreFVs ( - isLocalVar, mustHaveLocalBinding, - exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars exprsFreeVars, -- [CoreExpr] -> VarSet @@ -26,7 +24,7 @@ module CoreFVs ( import CoreSyn import Id ( Id, idType, isLocalId, hasNoBinding, idSpecialisation ) import VarSet -import Var ( Var, isId ) +import Var ( Var, isId, isLocalVar ) import Type ( tyVarsOfType ) import Util ( mapAndUnzip ) import Outputable @@ -35,29 +33,6 @@ import Outputable %************************************************************************ %* * -\subsection{isLocalVar} -%* * -%************************************************************************ - -@isLocalVar@ returns True of all TyVars, and of Ids that are defined in -this module and are not constants like data constructors and record selectors. -These are the variables that we need to pay attention to when finding free -variables, or doing dependency analysis. - -\begin{code} -isLocalVar :: Var -> Bool -isLocalVar v = isTyVar v || isLocalId v -\end{code} - -\begin{code} -mustHaveLocalBinding :: Var -> Bool --- True <=> the variable must have a binding in this module -mustHaveLocalBinding v = isTyVar v || (isLocalId v && not (hasNoBinding v)) -\end{code} - - -%************************************************************************ -%* * \section{Finding the free variables of an expression} %* * %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index cbcfb56..c5315ec 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -16,13 +16,13 @@ import IO ( hPutStr, hPutStrLn, stdout ) import CoreSyn import Rules ( RuleBase, pprRuleBase ) -import CoreFVs ( idFreeVars, mustHaveLocalBinding ) +import CoreFVs ( idFreeVars ) import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType ) import Bag import Literal ( literalType ) import DataCon ( dataConRepType ) -import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId ) +import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding ) import VarSet import Subst ( mkTyVarSubst, substTy ) import Name ( getSrcLoc ) diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CoreSat.lhs index f80d356..f1bf15c 100644 --- a/ghc/compiler/coreSyn/CoreSat.lhs +++ b/ghc/compiler/coreSyn/CoreSat.lhs @@ -21,9 +21,8 @@ import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) ) import PrimOp ( PrimOp(..) ) import Var ( Id, TyVar, setTyVarUnique ) import VarSet -import IdInfo ( IdFlavour(..) ) -import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity, - isDeadBinder, setIdType, isPrimOpId_maybe +import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity, + isDeadBinder, setIdType, isPrimOpId_maybe, hasNoBinding ) import UniqSupply @@ -372,10 +371,8 @@ cloneTyVar tv -- The type is the type of the entire application maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr maybeSaturate fn expr n_args ty - = case idFlavour fn of - PrimOpId op -> saturate_it - DataConId dc -> saturate_it - other -> returnUs expr + | hasNoBinding fn = saturate_it + | otherwise = returnUs expr where fn_arity = idArity fn excess_arity = fn_arity - n_args @@ -475,12 +472,8 @@ tryEta bndrs expr@(App _ _) ok bndr other = False -- we can't eta reduce something which must be saturated. - ok_to_eta_reduce (Var f) - = case idFlavour f of - PrimOpId op -> False - DataConId dc -> False - other -> True - ok_to_eta_reduce _ = False --safe. ToDo: generalise + ok_to_eta_reduce (Var f) = not (hasNoBinding f) + ok_to_eta_reduce _ = False --safe. ToDo: generalise tryEta bndrs (Let bind@(NonRec b r) body) | not (any (`elemVarSet` fvs) bndrs) diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index cf7c2d5..5cd70ea 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -15,26 +15,29 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) import CoreUtils ( exprArity ) -import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars ) +import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars, ruleSomeLhsFreeVars ) import CoreLint ( showPass, endPass ) import VarEnv import VarSet -import Var ( Id, Var ) -import Id ( idType, idInfo, idName, isExportedId, - idCafInfo, mkId, isLocalId, isImplicitId, - idFlavour, modifyIdInfo, idArity +import Var ( Id, Var, varName, globalIdDetails, setGlobalIdDetails ) +import Id ( idType, idInfo, idName, isExportedId, idSpecialisation, + idCafInfo, mkVanillaGlobal, isLocalId, isImplicitId, + modifyIdInfo, idArity, hasNoBinding, mkLocalIdWithInfo ) import IdInfo {- loads of stuff -} import Name ( getOccName, nameOccName, globaliseName, setNameOcc, - localiseName, mkLocalName, isGlobalName, isDllName + localiseName, mkLocalName, isGlobalName, isDllName, isLocalName ) +import NameEnv ( filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType, tidyType, tidyTyVar ) import Module ( Module, moduleName ) import PrimOp ( PrimOp(..), setCCallUnique ) import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ), - NameSupply( nsNames ), OrigNameCache + NameSupply( nsNames ), OrigNameCache, + TypeEnv, extendTypeEnvList, + DFunId, ModDetails(..), TyThing(..) ) import UniqSupply import DataCon ( DataCon, dataConName ) @@ -101,8 +104,8 @@ binder rather like the cloning step above. - Give the Id its UTTERLY FINAL IdInfo; in ptic, - * Its flavour becomes ConstantId, reflecting the fact that - from now on we regard it as a constant, not local, Id + * Its IdDetails becomes VanillaGlobal, reflecting the fact that + from now on we regard it as a global, not local, Id * its unfolding, if it should have one @@ -118,16 +121,18 @@ RHSs, so that they print nicely in interfaces. \begin{code} tidyCorePgm :: DynFlags -> Module -> PersistentCompilerState + -> TypeEnv -> [DFunId] -> [CoreBind] -> [IdCoreRule] - -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule]) -tidyCorePgm dflags mod pcs binds_in orphans_in + -> IO (PersistentCompilerState, [CoreBind], ModDetails) + +tidyCorePgm dflags mod pcs env_tc insts_tc binds_in orphans_in = do { showPass dflags "Tidy Core" ; let ext_ids = findExternalSet binds_in orphans_in ; us <- mkSplitUniqSupply 't' -- for "tidy" - ; let ((us1, orig_env', occ_env, subst_env), binds_out) + ; let ((us1, orig_env', occ_env, subst_env), tidy_binds) = mapAccumL (tidyTopBind mod ext_ids) (init_tidy_env us) binds_in @@ -137,9 +142,27 @@ tidyCorePgm dflags mod pcs binds_in orphans_in ; let prs' = prs { prsOrig = orig { nsNames = orig_env' } } pcs' = pcs { pcs_PRS = prs' } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out + ; let final_ids = [ id | bind <- tidy_binds + , id <- bindersOf bind + , isGlobalName (idName id)] + + -- Dfuns are local Ids that might have + -- changed their unique during tidying + ; let lookup_dfun_id id = lookupVarEnv subst_env id `orElse` + pprPanic "lookup_dfun_id" (ppr id) + + + ; let final_rules = mkFinalRules orphans_out final_ids + final_type_env = mkFinalTypeEnv env_tc final_ids + final_dfun_ids = map lookup_dfun_id insts_tc - ; return (pcs', binds_out, orphans_out) + ; let new_details = ModDetails { md_types = final_type_env, + md_rules = final_rules, + md_insts = final_dfun_ids } + + ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds + + ; return (pcs', tidy_binds, new_details) } where -- We also make sure to avoid any exported binders. Consider @@ -156,7 +179,7 @@ tidyCorePgm dflags mod pcs binds_in orphans_in init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv) avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in, - isGlobalName (idName bndr)] + isGlobalName (idName bndr)] tidyCoreExpr :: CoreExpr -> IO CoreExpr @@ -170,6 +193,73 @@ tidyCoreExpr expr %************************************************************************ %* * +\subsection{Write a new interface file} +%* * +%************************************************************************ + +\begin{code} +mkFinalTypeEnv :: TypeEnv -- From typechecker + -> [Id] -- Final Ids + -> TypeEnv + +mkFinalTypeEnv type_env final_ids + = extendTypeEnvList (filterNameEnv keep_it type_env) + (map AnId final_ids) + where + -- The competed type environment is gotten from + -- a) keeping the types and classes + -- b) removing all Ids, + -- c) adding Ids with correct IdInfo, including unfoldings, + -- gotten from the bindings + -- From (c) we keep only those Ids with Global names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones + -- This truncates the type environment to include only the + -- exported Ids and things needed from them, which saves space + -- + -- However, we do keep things like constructors, which should not appear + -- in interface files, because they are needed by importing modules when + -- using the compilation manager + + -- We keep constructor workers, because they won't appear + -- in the bindings from which final_ids are derived! + keep_it (AnId id) = hasNoBinding id -- Remove all Ids except constructor workers + keep_it other = True -- Keep all TyCons and Classes +\end{code} + +\begin{code} +mkFinalRules :: [IdCoreRule] -- Orphan rules + -> [Id] -- Ids that are exported, so we need their rules + -> [IdCoreRule] + -- The complete rules are gotten by combining + -- a) the orphan rules + -- b) rules embedded in the top-level Ids +mkFinalRules orphan_rules emitted + | opt_OmitInterfacePragmas = [] + | otherwise + = orphan_rules ++ local_rules + where + local_rules = [ (fn, rule) + | fn <- emitted, + rule <- rulesRules (idSpecialisation fn), + not (isBuiltinRule rule), + -- We can't print builtin rules in interface files + -- Since they are built in, an importing module + -- will have access to them anyway + + -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules + -- from coming out, and to make it work properly we need to add ???? + -- (put it back in for now) + isEmptyVarSet (ruleSomeLhsFreeVars (isLocalName . varName) rule) + -- Spit out a rule only if none of its LHS free vars are + -- LocalName things i.e. things that aren't visible to importing modules + -- This is a good reason not to do it when we emit the Id itself + ] +\end{code} + + +%************************************************************************ +%* * \subsection{Step 1: finding externals} %* * %************************************************************************ @@ -182,7 +272,7 @@ findExternalSet binds orphan_rules = foldr find init_needed binds where orphan_rule_ids :: IdSet - orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule + orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule | (_, rule) <- orphan_rules] init_needed :: IdEnv Bool init_needed = mapUFM (\_ -> False) orphan_rule_ids @@ -210,8 +300,6 @@ findExternalSet binds orphan_rules need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id need_pr needed_set (id,rhs) = need_id needed_set id -isIdAndLocal id = isId id && isLocalId id - addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool -- The Id is needed; extend the needed set -- with it and its dependents (free vars etc) @@ -251,7 +339,7 @@ addExternal (id,rhs) needed rhs_is_small && -- Small enough okToUnfoldInHiFile rhs -- No casms etc - unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs + unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs | otherwise = emptyVarSet worker_ids = case worker_info of @@ -357,7 +445,7 @@ tidyTopBinder mod ext_ids tidy_env rhs caf_info idinfo' = tidyIdInfo us_l tidy_env is_external unfold_info arity_info caf_info id - id' = mkId name' ty' idinfo' + id' = mkVanillaGlobal name' ty' idinfo' subst_env' = extendVarEnv subst_env2 id id' maybe_external = lookupVarEnv ext_ids id @@ -374,7 +462,8 @@ tidyTopBinder mod ext_ids tidy_env rhs caf_info tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id | opt_OmitInterfacePragmas || not is_external -- No IdInfo if the Id isn't external, or if we don't have -O - = mkIdInfo new_flavour caf_info + = vanillaIdInfo + `setCafInfo` caf_info `setStrictnessInfo` strictnessInfo core_idinfo `setArityInfo` ArityExactly arity_info -- Keep strictness, arity and CAF info; it's used by the code generator @@ -382,7 +471,8 @@ tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id | otherwise = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo)) in - mkIdInfo new_flavour caf_info + vanillaIdInfo + `setCafInfo` caf_info `setCprInfo` cprInfo core_idinfo `setStrictnessInfo` strictnessInfo core_idinfo `setInlinePragInfo` inlinePragInfo core_idinfo @@ -395,10 +485,6 @@ tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id -- after this!). where core_idinfo = idInfo id - new_flavour = makeConstantFlavour (flavourInfo core_idinfo) - -- A DFunId must stay a DFunId, so that we can gather the - -- DFunIds up later. Other local things become ConstantIds. - -- This is where we set names to local/global based on whether they really are -- externally visible (see comment at the top of this module). If the name @@ -560,7 +646,7 @@ tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var) tidyBndr env var | isTyVar var = returnUs (tidyTyVar env var) - | otherwise = tidyId env var vanillaIdInfo + | otherwise = tidyId env var noCafIdInfo tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var]) tidyBndrs env vars = mapAccumLUs tidyBndr env vars @@ -570,7 +656,7 @@ tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var) tidyBndrWithRhs env (id,rhs) = tidyId env id idinfo where - idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs) + idinfo = noCafIdInfo `setArityInfo` ArityExactly (exprArity rhs) -- NB: This throws away the IdInfo of the Id, which we -- no longer need. That means we don't need to -- run over it with env, nor renumber it. @@ -586,21 +672,20 @@ tidyId env@(tidy_env, var_env) id idinfo name' = mkLocalName uniq occ' noSrcLoc (tidy_env', occ') = tidyOccName tidy_env (getOccName id) ty' = tidyType (tidy_env,var_env) (idType id) - id' = mkId name' ty' idinfo + id' = mkLocalIdWithInfo name' ty' idinfo var_env' = extendVarEnv var_env id id' in returnUs ((tidy_env', var_env'), id') fiddleCCall id - = case idFlavour id of + = case globalIdDetails id of PrimOpId (CCallOp ccall) -> -- Make a guaranteed unique name for a dynamic ccall. getUniqueUs `thenUs` \ uniq -> - returnUs (modifyIdInfo (`setFlavourInfo` - PrimOpId (CCallOp (setCCallUnique ccall uniq))) id) - other_flavour -> - returnUs id + returnUs (setGlobalIdDetails id + (PrimOpId (CCallOp (setCCallUnique ccall uniq)))) + other -> returnUs id \end{code} %************************************************************************ @@ -697,7 +782,7 @@ rhsIsNonUpd other_expr idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool idAppIsNonUpd id n_val_args args - = case idFlavour id of + = case globalIdDetails id of DataConId con | not (isDynConApp con args) -> True other -> n_val_args < idArity id diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 756201a..cf9107b 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -42,14 +42,14 @@ import CoreSyn import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) -import Id ( Id, idType, idFlavour, isId, +import Id ( Id, idType, isId, idSpecialisation, idInlinePragma, idUnfolding, - isPrimOpId_maybe + isPrimOpId_maybe, globalIdDetails ) import VarSet import Literal ( isLitLitLit, litSize ) import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm ) -import IdInfo ( InlinePragInfo(..), OccInfo(..), IdFlavour(..), +import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..), isNeverInlinePrag ) import Type ( isUnLiftedType ) @@ -288,7 +288,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr | fun `hasKey` buildIdKey = buildSize | fun `hasKey` augmentIdKey = augmentSize | otherwise - = case idFlavour fun of + = case globalIdDetails fun of DataConId dc -> conSizeN (valArgCount args) PrimOpId op -> primOpSize op (valArgCount args) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 1b552af..1fa614a 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -51,12 +51,12 @@ import Literal ( hashLiteral, literalType, litIsDupable ) import DataCon ( DataCon, dataConRepArity ) import PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable ) -import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, +import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding ) import IdInfo ( LBVarInfo(..), - IdFlavour(..), + GlobalIdDetails(..), megaSeqIdInfo ) import Demand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, @@ -419,7 +419,7 @@ idAppIsCheap id n_val_args | n_val_args == 0 = True -- Just a type application of -- a variable (f t1 t2 t3) -- counts as WHNF - | otherwise = case idFlavour id of + | otherwise = case globalIdDetails id of DataConId _ -> True RecordSelId _ -> True -- I'm experimenting with making record selection -- look cheap, so we will substitute it inside a @@ -467,7 +467,7 @@ exprOkForSpeculation other_expr = go other_expr 0 True where go (Var f) n_args args_ok - = case idFlavour f of + = case globalIdDetails f of DataConId _ -> True -- The strictness of the constructor has already -- been expressed by its "wrapper", so we don't need -- to take the arguments into account @@ -543,7 +543,7 @@ exprIsValue other_expr idAppIsValue :: Id -> Int -> Bool idAppIsValue id n_val_args - = case idFlavour id of + = case globalIdDetails id of DataConId _ -> True PrimOpId _ -> n_val_args < idArity id other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id) diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 4f9a5e1..9ab7fd5 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -20,11 +20,12 @@ module PprCore ( import CoreSyn import CostCentre ( pprCostCentreCore ) import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, - idInfo, idInlinePragma, idDemandInfo, idOccInfo + idInfo, idInlinePragma, idDemandInfo, idOccInfo, + globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId ) import Var ( isTyVar ) import IdInfo ( IdInfo, megaSeqIdInfo, - arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, + arityInfo, ppArityInfo, specInfo, cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, cprInfo, ppCprInfo, @@ -297,7 +298,7 @@ and @pprCoreExpr@ functions. \begin{code} -- Used for printing dump info pprCoreBinder LetBind binder - = vcat [sig, pragmas, ppr binder] + = vcat [sig, pprIdDetails binder, pragmas, ppr binder] where sig = pprTypedBinder binder pragmas = ppIdInfo binder (idInfo binder) @@ -332,11 +333,15 @@ pprIdBndr id = ppr id <+> \begin{code} +pprIdDetails :: Id -> SDoc +pprIdDetails id | isGlobalId id = ppr (globalIdDetails id) + | isExportedId id = ptext SLIT("[Exported]") + | isSpecPragmaId id = ptext SLIT("[SpecPrag]") + | otherwise = empty + ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo b info - = hsep [ - ppFlavourInfo (flavourInfo info), - ppArityInfo a, + = hsep [ ppArityInfo a, ppTyGenInfo g, ppWorkerInfo (workerInfo info), ppStrictnessInfo s, diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 5471a23..cffa095 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -41,20 +41,20 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreRules(..), CoreRule(..), isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding ) -import CoreFVs ( exprFreeVars, mustHaveLocalBinding ) +import CoreFVs ( exprFreeVars ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( ThetaType, PredType(..), ClassContext, tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy ) import VarSet import VarEnv -import Var ( setVarUnique, isId ) -import Id ( idType, idInfo, setIdInfo, setIdType, idOccInfo, maybeModifyIdInfo ) -import IdInfo ( IdInfo, mkIdInfo, +import Var ( setVarUnique, isId, mustHaveLocalBinding ) +import Id ( idType, idInfo, setIdInfo, setIdType, + idOccInfo, maybeModifyIdInfo ) +import IdInfo ( IdInfo, vanillaIdInfo, occInfo, isFragileOcc, setOccInfo, - specInfo, setSpecInfo, flavourInfo, + specInfo, setSpecInfo, unfoldingInfo, setUnfoldingInfo, - CafInfo(NoCafRefs), WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo, lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo ) @@ -566,8 +566,7 @@ simplLetId subst@(Subst in_scope env) old_id old_info = idInfo old_id id1 = uniqAway in_scope old_id id2 = substIdType subst id1 - new_id = id2 `setIdInfo` mkIdInfo (flavourInfo old_info) NoCafRefs - -- Zap the IdIno altogether, but preserve the flavour + new_id = setIdInfo id2 vanillaIdInfo -- Extend the substitution if the unique has changed, -- or there's some useful occurrence information diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 5e2c504..0765a94 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -25,7 +25,7 @@ import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. import Module ( Module ) import Id ( Id ) -import Name ( lookupNameEnv ) +import NameEnv ( lookupNameEnv ) import VarEnv import VarSet import Bag ( isEmptyBag ) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index ebc1e6d..7e1f46d 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -20,10 +20,9 @@ import HsDecls ( extNameStatic ) import CallConv import TcHsSyn ( TypecheckedForeignDecl ) import CoreUtils ( exprType, mkInlineMe ) -import Id ( Id, idType, idName, mkId, mkSysLocal, +import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal, setInlinePragma ) -import IdInfo ( neverInlinePrag, vanillaIdInfo, IdFlavour(..), - setFlavourInfo ) +import IdInfo ( neverInlinePrag, vanillaIdInfo ) import Literal ( Literal(..) ) import Module ( Module, moduleUserString ) import Name ( mkGlobalName, nameModule, nameOccName, getOccString, @@ -260,8 +259,7 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn helper_ty = mkForAllTys tvs $ mkFunTys wrapper_arg_tys io_res_ty - f_helper_glob = mkId helper_name helper_ty - (vanillaIdInfo `setFlavourInfo` ExportedId) + f_helper_glob = mkVanillaGlobal helper_name helper_ty vanillaIdInfo where name = idName fn_id mod diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 3962210..a2a1fa8 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -102,8 +102,9 @@ coreExprToBCOs dflags expr -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything - let invented_name = mkSysLocalName (mkPseudoUnique3 0) SLIT("Expr-Top-Level") - let invented_id = mkVanillaId invented_name (panic "invented_id's type") + let invented_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0) + (panic "invented_id's type") + let invented_name = idName invented_id let (BcM_State all_proto_bcos final_ctr) = runBc (BcM_State [] 0) diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index a566b6e..a262bd6 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -13,7 +13,9 @@ module ErrUtils ( printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, ghcExit, - doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, showPass + doIfSet, doIfSet_dyn, + dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, + showPass ) where #include "HsVersions.h" @@ -141,6 +143,13 @@ dumpIfSet_dyn dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 = printDump (dump hdr doc) | otherwise = return () +dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO () +dumpIfSet_dyn_or dflags flags hdr doc + | or [dopt flag dflags | flag <- flags] + || verbosity dflags >= 4 + = printDump (dump hdr doc) + | otherwise = return () + dump hdr doc = vcat [text "", line <+> text hdr <+> line, diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index ab8730c..c8c5bdd 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -16,8 +16,8 @@ module HscMain ( HscResult(..), hscMain, import RdrHsSyn ( RdrNameStmt ) import Rename ( renameStmt ) import ByteCodeGen ( byteCodeGen ) -import Id ( Id, idName, idFlavour, modifyIdInfo ) -import IdInfo ( setFlavourInfo, makeConstantFlavour ) +import Id ( Id, idName ) +import IdInfo ( GlobalIdDetails(VanillaGlobal) ) import HscTypes ( InteractiveContext(..), TyThing(..) ) #endif @@ -32,8 +32,7 @@ import Rename ( checkOldIface, renameModule, closeIfaceDecls ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) import PrelNames ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE ) -import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, - writeIface, pprIface ) +import MkIface ( completeIface, writeIface, pprIface ) import Type ( Type ) import TcModule import InstEnv ( emptyInstEnv ) @@ -68,9 +67,8 @@ import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), ) import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) import OccName ( OccName ) -import Name ( Name, nameModule, nameOccName, getName, isGlobalName, - emptyNameEnv - ) +import Name ( Name, nameModule, nameOccName, getName, isGlobalName ) +import NameEnv ( emptyNameEnv ) import Module ( Module, lookupModuleEnvByName ) import Monad ( when ) @@ -167,13 +165,10 @@ hscNoRecomp ghci_mode dflags mod location (Just old_iface) hst hit pcs_ch case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); - Just (pcs_tc, env_tc, local_rules) -> do { + Just (pcs_tc, new_details) -> - -- create a new details from the closed, typechecked, old iface - let new_details = mkModDetailsFromIface env_tc local_rules - ; return (HscNoRecomp pcs_tc new_details old_iface) - }}}} + }}} compMsg mod location = mod_str ++ take (12 - length mod_str) (repeat ' ') @@ -228,7 +223,8 @@ hscRecomp ghci_mode dflags mod location maybe_checked_iface hst hit pcs_ch Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); Just (pcs_tc, tc_result) -> do { - ; let env_tc = tc_env tc_result + ; let env_tc = tc_env tc_result + insts_tc = tc_insts tc_result ------------------- -- DESUGAR @@ -238,19 +234,25 @@ hscRecomp ghci_mode dflags mod location maybe_checked_iface hst hit pcs_ch deSugar dflags pcs_tc hst this_mod print_unqualified tc_result ------------------- - -- SIMPLIFY, TIDY-CORE + -- SIMPLIFY + ------------------- + ; (simplified, orphan_rules) + <- _scc_ "Core2Core" + core2core dflags pcs_tc hst dont_discard ds_binds ds_rules + + ------------------- + -- TIDY ------------------- - -- We grab the the unfoldings at this point. - ; (pcs_simpl, tidy_binds, orphan_rules) - <- simplThenTidy dflags pcs_tc hst this_mod dont_discard ds_binds ds_rules - + ; (pcs_simpl, tidy_binds, new_details) + <- tidyCorePgm dflags this_mod pcs_tc env_tc insts_tc + simplified orphan_rules + ------------------- -- BUILD THE NEW ModDetails AND ModIface ------------------- - ; let new_details = mkModDetails env_tc tidy_binds orphan_rules ; final_iface <- _scc_ "MkFinalIface" mkFinalIface ghci_mode dflags location - maybe_checked_iface new_iface new_details + maybe_checked_iface new_iface new_details ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION @@ -322,19 +324,6 @@ myParseModule dflags src_filename }} -simplThenTidy dflags pcs hst this_mod dont_discard binds rules - = do -- Do main Core-language transformations --------- - -- _scc_ "Core2Core" - (simplified, orphan_rules) - <- core2core dflags pcs hst dont_discard binds rules - - -- Do the final tidy-up - (pcs', tidy_binds, tidy_orphan_rules) - <- tidyCorePgm dflags this_mod pcs simplified orphan_rules - - return (pcs', tidy_binds, tidy_orphan_rules) - - restOfCodeGeneration dflags toInterp this_mod imported_module_names foreign_stuff env_tc tidy_binds hit pit -- these last two for mapping ModNames to Modules @@ -511,18 +500,15 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr ; bcos <- coreExprToBCOs dflags sat_expr ; let - -- make all the bound ids "constant" ids, now that + -- Make all the bound ids "global" ids, now that -- they're notionally top-level bindings. This is -- important: otherwise when we come to compile an expression -- using these ids later, the byte code generator will consider -- the occurrences to be free rather than global. - constant_bound_ids = map constantizeId bound_ids; - - constantizeId id - = modifyIdInfo (`setFlavourInfo` makeConstantFlavour - (idFlavour id)) id + global_bound_ids = map globaliseId bound_ids; + globaliseId id = setIdGlobalDetails id VanillaGlobal - ; return (pcs2, Just (constant_bound_ids, ty, bcos)) + ; return (pcs2, Just (global_bound_ids, ty, bcos)) }}}}} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index ec70d32..c358e8e 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -52,7 +52,7 @@ module HscTypes ( import RdrName ( RdrNameEnv, addListToRdrEnv, emptyRdrEnv, mkRdrUnqual, rdrEnvToList ) import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) -import Name -- Env +import NameEnv import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv @@ -169,6 +169,25 @@ data ModDetails md_insts :: [DFunId], -- Dfun-ids for the instances in this module md_rules :: [IdCoreRule] -- Domain may include Ids from other modules } + +-- NOT YET IMPLEMENTED +-- The ModDetails takes on several slightly different forms: +-- +-- After typecheck + desugar +-- md_types contains TyCons, Classes, and hasNoBinding Ids +-- md_insts all instances from this module (incl derived ones) +-- md_rules all rules from this module +-- md_binds desugared bindings +-- +-- After simplification +-- md_types same as after typecheck +-- md_insts ditto +-- md_rules orphan rules only (local ones attached to binds) +-- md_binds with rules attached +-- +-- After tidy +-- md_types now contains Ids as well, replete with correct IdInfo +-- apart from \end{code} \begin{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 665683b..11a70b8 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -5,8 +5,8 @@ \begin{code} module MkIface ( - mkModDetails, mkModDetailsFromIface, completeIface, - writeIface, pprIface, pprUsage + completeIface, writeIface, + pprModDetails, pprIface, pprUsage ) where #include "HsVersions.h" @@ -19,31 +19,23 @@ import BasicTypes ( Fixity(..), NewOrData(..), ) import RnMonad import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) -import TcHsSyn ( TypecheckedRuleDecl ) import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - TyThing(..), DFunId, TypeEnv, Avails, + TyThing(..), DFunId, Avails, WhatsImported(..), GenAvailInfo(..), ImportVersion, AvailInfo, Deprecations(..), - extendTypeEnvList, lookupVersion, + lookupVersion, ) import CmdLineOpts -import Id ( idType, idInfo, isImplicitId, isDictFunId, - idSpecialisation, isLocalId, idName, hasNoBinding - ) -import Var ( isId ) -import VarSet +import Id ( idType, idInfo, isImplicitId, isLocalId, idName ) import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks ) import IdInfo -- Lots -import CoreSyn ( CoreBind, CoreRule(..), IdCoreRule, - isBuiltinRule, rulesRules, - bindersOf, bindersOfBinds - ) -import CoreFVs ( ruleSomeLhsFreeVars ) +import CoreSyn ( CoreBind, CoreRule(..) ) import CoreUnfold ( neverUnfold, unfoldingTemplate ) -import Name ( getName, nameModule, Name, NamedThing(..) ) -import Name -- Env +import PprCore ( pprIdCoreRule ) +import Name ( getName, nameModule, toRdrName, isGlobalName, Name, NamedThing(..) ) +import NameEnv import OccName ( pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds, tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon @@ -54,7 +46,7 @@ import Type ( splitSigmaTy, tidyTopType, deNoteType ) import SrcLoc ( noSrcLoc ) import Outputable import Module ( ModuleName ) -import Maybes ( orElse ) +import Util ( sortLt ) import IO ( IOMode(..), openFile, hClose ) \end{code} @@ -62,99 +54,6 @@ import IO ( IOMode(..), openFile, hClose ) %************************************************************************ %* * -\subsection{Write a new interface file} -%* * -%************************************************************************ - -\begin{code} -mkModDetails :: TypeEnv -- From typechecker - -> [CoreBind] -- Final bindings - -- they have authoritative arity info - -> [IdCoreRule] -- Tidy orphan rules - -> ModDetails -mkModDetails type_env tidy_binds orphan_rules - = ModDetails { md_types = new_type_env, - md_rules = rule_dcls, - md_insts = filter isDictFunId final_ids } - where - -- The competed type environment is gotten from - -- a) keeping the types and classes - -- b) removing all Ids, - -- c) adding Ids with correct IdInfo, including unfoldings, - -- gotten from the bindings - -- From (c) we keep only those Ids with Global names; - -- the CoreTidy pass makes sure these are all and only - -- the externally-accessible ones - -- This truncates the type environment to include only the - -- exported Ids and things needed from them, which saves space - -- - -- However, we do keep things like constructors, which should not appear - -- in interface files, because they are needed by importing modules when - -- using the compilation manager - new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env) - (map AnId final_ids) - - -- We keep constructor workers, because they won't appear - -- in the bindings from which final_ids are derived! - keep_it (AnId id) = hasNoBinding id - keep_it other = True - - final_ids = [id | bind <- tidy_binds - , id <- bindersOf bind - , isGlobalName (idName id)] - - -- The complete rules are gotten by combining - -- a) the orphan rules - -- b) rules embedded in the top-level Ids - rule_dcls | opt_OmitInterfacePragmas = [] - | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids) - --- This version is used when we are re-linking a module --- so we've only run the type checker on its previous interface -mkModDetailsFromIface :: TypeEnv - -> [TypecheckedRuleDecl] - -> ModDetails -mkModDetailsFromIface type_env rules - = ModDetails { md_types = type_env, - md_rules = rule_dcls, - md_insts = dfun_ids } - where - dfun_ids = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id] - rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules] - -- All the rules from an interface are of the IfaceRuleOut form -\end{code} - -\begin{code} -getRules :: [IdCoreRule] -- Orphan rules - -> [CoreBind] -- Bindings, with rules in the top-level Ids - -> IdSet -- Ids that are exported, so we need their rules - -> [IdCoreRule] -getRules orphan_rules binds emitted - = orphan_rules ++ local_rules - where - local_rules = [ (fn, rule) - | fn <- bindersOfBinds binds, - fn `elemVarSet` emitted, - rule <- rulesRules (idSpecialisation fn), - not (isBuiltinRule rule), - -- We can't print builtin rules in interface files - -- Since they are built in, an importing module - -- will have access to them anyway - - -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules - -- from coming out, and to make it work properly we need to add ???? - -- (put it back in for now) - all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) - -- Spit out a rule only if all its lhs free vars are emitted - -- This is a good reason not to do it when we emit the Id itself - ] - -interestingId id = isId id && isLocalId id -\end{code} - - -%************************************************************************ -%* * \subsection{Completing an interface} %* * %************************************************************************ @@ -456,6 +355,53 @@ diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers %************************************************************************ %* * +\subsection{Writing ModDetails} +%* * +%************************************************************************ + +\begin{code} +pprModDetails :: ModDetails -> SDoc +pprModDetails (ModDetails { md_types = type_env, md_insts = dfun_ids, md_rules = rules }) + = vcat [ dump_types dfun_ids type_env + , dump_insts dfun_ids + , dump_rules rules] + +dump_types dfun_ids type_env + = text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids) + where + ids = [id | AnId id <- nameEnvElts type_env, want_sig id] + want_sig id | opt_PprStyle_Debug = True + | otherwise = isLocalId id && + isGlobalName (idName id) && + not (id `elem` dfun_ids) + -- isLocalId ignores data constructors, records selectors etc + -- The isGlobalName ignores local dictionary and method bindings + -- that the type checker has invented. User-defined things have + -- Global names. + +dump_insts [] = empty +dump_insts dfun_ids = text "INSTANCES" $$ nest 4 (dump_sigs dfun_ids) + +dump_sigs ids + -- Print type signatures + -- Convert to HsType so that we get source-language style printing + -- And sort by RdrName + = vcat $ map ppr_sig $ sortLt lt_sig $ + [ (toRdrName id, toHsType (idType id)) + | id <- ids ] + where + lt_sig (n1,_) (n2,_) = n1 < n2 + ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t + +dump_rules [] = empty +dump_rules rs = vcat [ptext SLIT("{-# RULES"), + nest 4 (vcat (map pprIdCoreRule rs)), + ptext SLIT("#-}")] +\end{code} + + +%************************************************************************ +%* * \subsection{Writing an interface file} %* * %************************************************************************ diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 76575cd..25b86e7 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -43,9 +43,9 @@ import Module ( Module, ModuleName, WhereFrom(..), moduleEnvElts ) import Name ( Name, nameIsLocalOrFrom, nameModule ) -import Name ( mkNameEnv, nameEnvElts, extendNameEnv ) -import RdrName ( foldRdrEnv, isQual ) +import NameEnv import NameSet +import RdrName ( foldRdrEnv, isQual ) import PrelNames ( SyntaxMap, pRELUDE_Name ) import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printErrorsAndWarnings, errorsFound ) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 5884c34..c8090f9 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -29,9 +29,9 @@ import Name ( Name, getSrcLoc, mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, - setNameModuleAndLoc, mkNameEnv + setNameModuleAndLoc ) -import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts ) +import NameEnv import NameSet import OccName ( OccName, occNameUserString, occNameFlavour ) import Module ( ModuleName, moduleName, mkVanillaModule, diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 690795b..4477e89 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -42,7 +42,7 @@ import ParseIface ( parseIface ) import Name ( Name {-instance NamedThing-}, nameModule, isLocalName, nameIsLocalOrFrom ) -import Name ( mkNameEnv, extendNameEnv ) +import NameEnv import Module ( Module, moduleName, isHomeModule, ModuleName, WhereFrom(..), diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index e72c059..bb27937 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -40,7 +40,8 @@ import TyCon ( isSynTyCon, getSynTyConDefn ) import Name ( Name {-instance NamedThing-}, nameOccName, nameModule, isLocalName, NamedThing(..) ) -import Name ( elemNameEnv, delFromNameEnv ) +import NameEnv ( elemNameEnv, delFromNameEnv, lookupNameEnv ) +import NameSet import Module ( Module, ModuleEnv, moduleName, isHomeModule, ModuleName, WhereFrom(..), @@ -48,7 +49,6 @@ import Module ( Module, ModuleEnv, extendModuleEnv_C, foldModuleEnv, lookupModuleEnv, elemModuleSet, extendModuleSet ) -import NameSet import PrelInfo ( wiredInThingEnv ) import Maybes ( orElse ) import FiniteMap diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 9f3bb3e..22badd8 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -58,7 +58,7 @@ import Name ( Name, OccName, NamedThing(..), nameOccName, decode, mkLocalName, mkKnownKeyGlobal ) -import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) +import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) import Module ( Module, ModuleName, ModuleSet, emptyModuleSet ) import NameSet import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index df1925d..51918de 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -26,10 +26,10 @@ import RnMonad import FiniteMap import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR_Unqual, isUnboundName ) -import UniqFM ( lookupUFM ) import Module ( ModuleName, moduleName, WhereFrom(..) ) +import Name ( Name, nameSrcLoc, nameOccName ) import NameSet -import Name ( Name, nameSrcLoc, nameOccName, nameEnvElts ) +import NameEnv import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, GenAvailInfo(..), AvailInfo, Avails, AvailEnv, Deprecations(..), ModIface(..) @@ -39,7 +39,6 @@ import OccName ( setOccNameSpace, dataName ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable import Maybes ( maybeToBool, catMaybes, mapMaybe ) -import UniqFM ( emptyUFM, listToUFM ) import ListSetOps ( removeDups ) import Util ( sortLt ) import List ( partition ) @@ -370,7 +369,7 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails \begin{code} mkEmptyExportAvails :: ModuleName -> ExportAvails -mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) +mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyNameEnv) mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails mkExportAvails mod_name unqual_imp gbl_env avails @@ -396,7 +395,7 @@ mkExportAvails mod_name unqual_imp gbl_env avails unqual_in_scope n = unQualInScope gbl_env n - entity_avail_env = listToUFM [ (name,avail) | avail <- avails, + entity_avail_env = mkNameEnv [ (name,avail) | avail <- avails, name <- availNames avail] plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails @@ -491,7 +490,7 @@ exportsFromAvail this_mod (Just export_items) = lookupSrcName global_name_env (ieName ie) `thenRn` \ name -> -- See what's available in the current environment - case lookupUFM entity_avail_env name of { + case lookupNameEnv entity_avail_env name of { Nothing -> -- Presumably this happens because lookupSrcName didn't find -- the name and returned an unboundName, which won't be in -- the entity_avail_env, of course diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index 0e75d9f..7c3f243 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -35,7 +35,7 @@ import Type ( mkTyVarTy, mkSigmaTy, InstTyEnv(..) ) import MkId ( mkSysLocal ) -import Id ( idType, idName, mkVanillaId ) +import Id ( idType, idName, mkLocalId ) import UniqSupply import Util @@ -139,7 +139,7 @@ newSATName id ty us env let new_name = mkCompoundName SLIT("$sat") unique (idName id) in - (mkVanillaId new_name ty, env) } + (mkLocalId new_name ty, env) } getArgLists :: CoreExpr -> ([Arg Type],[Arg Id]) getArgLists expr diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 52a5b1b..47addf3 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -23,7 +23,7 @@ import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, extendRuleBaseList, addRuleBaseFVs, pprRuleBase ) import Module ( moduleEnvElts ) import CoreUnfold -import PprCore ( pprCoreBindings, pprIdCoreRule, pprCoreExpr ) +import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr ) import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) @@ -32,7 +32,7 @@ import SimplMonad import ErrUtils ( dumpIfSet, dumpIfSet_dyn ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( idName, isDataConWrapId, setIdNoDiscard, isLocalId ) +import Id ( idName, isDataConWrapId, setIdNoDiscard, isLocalId, isImplicitId ) import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) @@ -273,11 +273,16 @@ updateBinders rule_ids rule_rhs_fvs is_exported binds update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] update_bndr bndr - | is_exported (idName bndr) - || bndr `elemVarSet` rule_rhs_fvs = setIdNoDiscard bndr' - | otherwise = bndr' + | isImplicitId bndr = bndr -- Constructors, selectors; doesn't + -- make sense to call setIdNoDiscard + -- Also can't have rules + | dont_discard bndr = setIdNoDiscard bndr_with_rules + | otherwise = bndr_with_rules where - bndr' = lookupVarSet rule_ids bndr `orElse` bndr + bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr + + dont_discard bndr = is_exported (idName bndr) + || bndr `elemVarSet` rule_rhs_fvs \end{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index c4f528e..f61b513 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -31,7 +31,7 @@ import Subst ( InScopeSet, mkSubst, substExpr ) import qualified Subst ( simplBndrs, simplBndr, simplLetId ) import Id ( idType, idName, idUnfolding, idStrictness, - mkVanillaId, idInfo + mkLocalId, idInfo ) import IdInfo ( StrictnessInfo(..) ) import Maybes ( maybeToBool, catMaybes ) @@ -615,7 +615,7 @@ tryRhsTyLam rhs -- Only does something if there's a let let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course - poly_id = mkVanillaId poly_name poly_ty + poly_id = mkLocalId poly_name poly_ty -- In the olden days, it was crucial to copy the occInfo of the original var, -- because we were looking at occurrence-analysed but as yet unsimplified code! diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index 59fef91..528140c 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -16,7 +16,7 @@ import CoreUtils ( exprType, eqExpr ) import CoreFVs ( exprsFreeVars ) import DataCon ( dataConRepArity ) import Type ( tyConAppArgs ) -import PprCore ( pprCoreRules ) +import PprCore ( pprCoreRules, pprCoreRule ) import Id ( Id, idName, idType, idSpecialisation, isDataConId_maybe, mkUserLocal, mkSysLocal ) @@ -430,7 +430,6 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs}) let (_, pats) = argsToPats con_env us call_args ] in - pprTrace "specialise" (ppr all_calls $$ ppr good_calls) $ mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) (nubBy same_call good_calls `zip` [1..]) where @@ -446,8 +445,7 @@ good_arg con_env arg_occs (bndr, arg) bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool bndr_usg_ok arg_occs bndr arg - = pprTrace "bndr_ok" (ppr bndr <+> ppr (lookupVarEnv arg_occs bndr)) $ - case lookupVarEnv arg_occs bndr of + = case lookupVarEnv arg_occs bndr of Just CaseScrut -> True -- Used only by case scrutiny Just Both -> case arg of -- Used by case and elsewhere App _ _ -> True -- so the arg should be an explicit con app @@ -502,6 +500,7 @@ spec_one env fn rhs (pats, n) spec_id = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc rule = Rule rule_name pat_fvs pats (mkVarApps (Var spec_id) bndrs) in + pprTrace "SpecConstr" (pprCoreRule (ppr fn) rule) $ returnUs (rule, (spec_id, spec_rhs)) \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 5c89aaf..da60b7f 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -12,10 +12,6 @@ import CmdLineOpts ( DynFlags, DynFlag(..) ) import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, modifyIdInfo ) -import IdInfo ( zapSpecPragInfo ) -import VarSet -import VarEnv - import Type ( Type, mkTyVarTy, splitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, mkForAllTys @@ -25,6 +21,7 @@ import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet, substAndCloneId, substAndCloneIds, substAndCloneRecIds, lookupIdSubst, substInScope ) +import Var ( zapSpecPragmaId ) import VarSet import VarEnv import CoreSyn @@ -815,7 +812,7 @@ specDefn subst calls (fn, rhs) returnSM ((zapped_fn, rhs'), [], rhs_uds) where - zapped_fn = modifyIdInfo zapSpecPragInfo fn + zapped_fn = zapSpecPragmaId fn -- If the fn is a SpecPragmaId, make it discardable -- It's role as a holder for a call instance is o'er -- But it might be alive for some other reason by now. diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index b59411d..4040280 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -20,7 +20,7 @@ import StgSyn import Type import TyCon ( isAlgTyCon ) import Id -import Var ( Var ) +import Var ( Var, globalIdDetails ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -308,7 +308,7 @@ coreToStgExpr (Case scrut bndr alts) case scrut of -- ToDo: Notes? e@(App _ _) | (v, args) <- myCollectArgs e, - PrimOpId (CCallOp ccall) <- idFlavour v, + PrimOpId (CCallOp ccall) <- globalIdDetails v, ccallMayGC ccall -> Just (filterVarSet isForeignObjArg (exprFreeVars e)) _ -> Nothing @@ -507,7 +507,7 @@ coreToStgApp maybe_thunk_body f args -- continuation, but it does no harm to just union the -- two regardless. - app = case idFlavour f of + app = case globalIdDetails f of DataConId dc -> StgConApp dc args' PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args)) _other -> StgApp f args' diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 371920a..2a20080 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -12,9 +12,8 @@ import CoreSyn import CoreUnfold ( certainlyWillInline ) import CoreLint ( showPass, endPass ) import CoreUtils ( exprType ) -import MkId ( mkWorkerId ) import Id ( Id, idType, idStrictness, idArity, isOneShotLambda, - setIdStrictness, idInlinePragma, + setIdStrictness, idInlinePragma, mkWorkerId, setIdWorkerInfo, idCprInfo, setInlinePragma ) import Type ( Type, isNewType, splitForAllTys, splitFunTys ) import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..), diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 0652f81..efe9eed 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -48,7 +48,7 @@ import TcType ( TcThetaType, TcClassContext, ) import CoreFVs ( idFreeTyVars ) import Class ( Class ) -import Id ( Id, idType, mkUserLocal, mkSysLocal, mkVanillaId ) +import Id ( Id, idType, mkUserLocal, mkSysLocal, mkLocalId ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import Name ( mkDictOcc, mkMethodOcc, getOccName, mkLocalName ) import NameSet ( NameSet ) @@ -314,14 +314,14 @@ newDictsAtLoc inst_loc@(_,loc,_) theta = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta) where - mk_dict uniq pred = Dict (mkVanillaId (mk_dict_name uniq pred) (mkPredTy pred)) pred inst_loc + mk_dict uniq pred = Dict (mkLocalId (mk_dict_name uniq pred) (mkPredTy pred)) pred inst_loc mk_dict_name uniq (Class cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc mk_dict_name uniq (IParam name ty) = name newIPDict orig name ty = tcGetInstLoc orig `thenNF_Tc` \ inst_loc -> - returnNF_Tc (Dict (mkVanillaId name ty) (IParam name ty) inst_loc) + returnNF_Tc (Dict (mkLocalId name ty) (IParam name ty) inst_loc) \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 65c8549..282e61b 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -39,7 +39,7 @@ import TcType ( newTyVarTy, newTyVar, import TcUnify ( unifyTauTy, unifyTauTyLists ) import CoreFVs ( idFreeTyVars ) -import Id ( mkVanillaId, setInlinePragma ) +import Id ( mkLocalId, setInlinePragma ) import Var ( idType, idName ) import IdInfo ( InlinePragInfo(..) ) import Name ( Name, getOccName, getSrcLoc ) @@ -217,7 +217,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec poly_ids = map mk_dummy binder_names mk_dummy name = case maybeSig tc_ty_sigs name of Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature - Nothing -> mkVanillaId name forall_a_a -- No signature + Nothing -> mkLocalId name forall_a_a -- No signature in returnTc (EmptyMonoBinds, emptyLIE, poly_ids) ) $ @@ -278,7 +278,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec (sig_tyvars, sig_poly_id) Nothing -> (real_tyvars_to_gen, new_poly_id) - new_poly_id = mkVanillaId binder_name poly_ty + new_poly_id = mkLocalId binder_name poly_ty poly_ty = mkForAllTys real_tyvars_to_gen $ mkFunTys dict_tys $ idType zonked_mono_id diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 3d0e943..7f8ffda 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -44,7 +44,7 @@ import DataCon ( mkDataCon, notMarkedStrict ) import Id ( Id, idType, idName ) import Module ( Module ) import Name ( Name, NamedThing(..) ) -import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts ) +import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts ) import NameSet ( emptyNameSet ) import Outputable import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred, @@ -287,7 +287,7 @@ tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env let -- Build the selector id and default method id sel_id = mkDictSelId op_name clas - dm_id = mkDefaultMethodId dm_name clas global_ty + dm_id = mkDefaultMethodId dm_name global_ty DefMeth dm_name = sig_dm dm_info = case maybe_dm_env of diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 20b0f90..8cfac29 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -44,9 +44,8 @@ import TcMonad import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, zonkTcTyVarsAndFV ) -import Id ( idName, mkUserLocal, isDataConWrapId_maybe ) -import IdInfo ( constantIdInfo ) -import MkId ( mkSpecPragmaId ) +import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe ) +import IdInfo ( vanillaIdInfo ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet import Type ( Type, @@ -60,7 +59,7 @@ import Name ( Name, OccName, NamedThing(..), nameOccName, getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom ) -import Name ( NameEnv, lookupNameEnv, nameEnvElts, +import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv, plusNameEnv ) import OccName ( mkDFunOcc, occNameString ) import HscTypes ( DFunId, @@ -215,7 +214,7 @@ tcAddImportedIdInfo env id -- The Id must be returned without a data dependency on maybe_id where new_info = case tcLookupRecId_maybe env (idName id) of - Nothing -> pprTrace "tcAddIdInfo" (ppr id) constantIdInfo + Nothing -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo Just imported_id -> idInfo imported_id -- ToDo: could check that types are the same diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 875d974..b394eef 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -34,7 +34,7 @@ import TcExpr ( tcPolyExpr ) import Inst ( emptyLIE, LIE, plusLIE ) import ErrUtils ( Message ) -import Id ( Id, mkVanillaId ) +import Id ( Id, mkLocalId ) import Name ( nameOccName ) import Type ( splitFunTys , splitTyConApp_maybe @@ -94,7 +94,7 @@ tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) = case splitFunTys t_ty of (arg_tys, res_ty) -> checkForeignExport True t_ty arg_tys res_ty `thenTc_` - let i = (mkVanillaId nm sig_ty) in + let i = (mkLocalId nm sig_ty) in returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc)) tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) = @@ -108,7 +108,7 @@ tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) = in check (isFFILabelTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_` - let i = (mkVanillaId nm sig_ty) in + let i = (mkLocalId nm sig_ty) in returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc)) tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) = @@ -126,7 +126,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_ case splitFunTys t_ty of (arg_tys, res_ty) -> checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_` - let i = (mkVanillaId nm ty) in + let i = (mkLocalId nm ty) in returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 24782f7..21ca4be 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -38,7 +38,7 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idName, idType, isLocalId, setIdType, Id ) +import Id ( idName, idType, setIdType, Id ) import DataCon ( dataConWrapId ) import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 0a97ff4..8ffe3c3 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -25,7 +25,7 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkId, mkVanillaId, idName, isDataConWrapId_maybe ) +import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe ) import Module ( Module ) import MkId ( mkCCallOpId ) import IdInfo @@ -74,12 +74,12 @@ tcInterfaceSigs unf_env mod decls tcIfaceType ty `thenTc` \ sigma_ty -> tcIdInfo unf_env in_scope_vars name sigma_ty id_infos `thenTc` \ id_info -> - returnTc (mkId name sigma_ty id_info) + returnTc (mkVanillaGlobal name sigma_ty id_info) \end{code} \begin{code} tcIdInfo unf_env in_scope_vars name ty info_ins - = foldlTc tcPrag constantIdInfo info_ins + = foldlTc tcPrag vanillaIdInfo info_ins where tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity) tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) @@ -236,7 +236,7 @@ tcCoreExpr (UfCase scrut case_bndr alts) = tcCoreExpr scrut `thenTc` \ scrut' -> let scrut_ty = exprType scrut' - case_bndr' = mkVanillaId case_bndr scrut_ty + case_bndr' = mkLocalId case_bndr scrut_ty in tcExtendGlobalValEnv [case_bndr'] $ mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' -> @@ -271,7 +271,7 @@ tcCoreExpr (UfNote note expr) tcCoreLamBndr (UfValBinder name ty) thing_inside = tcIfaceType ty `thenTc` \ ty' -> let - id = mkVanillaId name ty' + id = mkLocalId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id @@ -291,7 +291,7 @@ tcCoreLamBndrs (b:bs) thing_inside tcCoreValBndr (UfValBinder name ty) thing_inside = tcIfaceType ty `thenTc` \ ty' -> let - id = mkVanillaId name ty' + id = mkLocalId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id @@ -299,7 +299,7 @@ tcCoreValBndr (UfValBinder name ty) thing_inside tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders = mapTc tcIfaceType tys `thenTc` \ tys' -> let - ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys' + ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' in tcExtendGlobalValEnv ids $ thing_inside ids @@ -348,7 +348,7 @@ tcCoreAlt scrut_ty alt@(con, names, rhs) ppr arg_tys) | otherwise #endif - = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys + = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys in ASSERT( con `elem` cons && length inst_tys == length main_tyvars ) tcExtendTyVarEnv ex_tyvars' $ diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 9e063a0..e6b03a1 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -11,12 +11,11 @@ module TcModule ( #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug ) +import CmdLineOpts ( DynFlag(..), DynFlags ) import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), - Stmt(..), InPat(..), HsMatchContext(..), + Stmt(..), InPat(..), HsMatchContext(..), RuleDecl(..), isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch ) -import HsTypes ( toHsType ) import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName, returnIOName, bindIOName, failIOName, itName @@ -30,7 +29,7 @@ import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, zonkExpr, zonkIdBndr ) - +import MkIface ( pprModDetails ) import TcExpr ( tcMonoExpr ) import TcMonad import TcType ( newTyVarTy, zonkTcType, tcInstType ) @@ -40,10 +39,10 @@ import Inst ( emptyLIE, plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults, defaultDefaultTys ) -import TcEnv ( TcEnv, RecTcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe, +import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe, isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv, tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon, - TcTyThing(..), tcLookupId + TcTyThing(..), tcLookupId ) import TcRules ( tcIfaceRules, tcSourceRules ) import TcForeign ( tcForeignImports, tcForeignExports ) @@ -55,23 +54,23 @@ import TcTyClsDecls ( tcTyAndClassDecls ) import CoreUnfold ( unfoldingTemplate, hasUnfolding ) import TysWiredIn ( mkListTy, unitTy ) import Type -import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass ) -import Id ( Id, idType, idName, isLocalId, idUnfolding ) +import ErrUtils ( printErrorsAndWarnings, errorsFound, + dumpIfSet_dyn, dumpIfSet_dyn_or, showPass ) +import Id ( Id, idType, idUnfolding ) import Module ( Module, moduleName ) -import Name ( Name, toRdrName, isGlobalName ) -import Name ( nameEnvElts, lookupNameEnv ) +import Name ( Name ) +import NameEnv ( nameEnvElts, lookupNameEnv ) import TyCon ( tyConGenInfo ) -import Util import BasicTypes ( EP(..), Fixity, RecFlag(..) ) import SrcLoc ( noSrcLoc ) import Outputable import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, PackageTypeEnv, ModIface(..), + ModDetails(..), DFunId, TypeEnv, extendTypeEnvList, TyThing(..), implicitTyThingIds, mkTypeEnv ) -import Rules ( ruleBaseIds ) import VarSet \end{code} @@ -306,9 +305,10 @@ data TcResults = TcResults { -- All these fields have info *just for this module* tc_env :: TypeEnv, -- The top level TypeEnv + tc_insts :: [DFunId], -- Instances + tc_rules :: [TypecheckedRuleDecl], -- Transformation rules tc_binds :: TypecheckedMonoBinds, -- Bindings - tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. - tc_rules :: [TypecheckedRuleDecl] -- Transformation rules + tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports. } @@ -427,6 +427,7 @@ tcModule pcs hst get_fixity this_mod decls returnTc (final_env, new_pcs, TcResults { tc_env = local_type_env, + tc_insts = map iDFunId local_insts, tc_binds = implicit_binds `AndMonoBinds` all_binds', tc_fords = foi_decls ++ foe_decls', tc_rules = all_local_rules @@ -454,12 +455,9 @@ typecheckIface -> HomeSymbolTable -> ModIface -- Iface for this module (just module & fixities) -> (SyntaxMap, [RenamedHsDecl]) - -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl])) + -> IO (Maybe (PersistentCompilerState, ModDetails)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module). - -- The TcResults returned contains only the environment - -- and rules. - typecheckIface dflags pcs hst mod_iface (syn_map, decls) = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $ @@ -480,15 +478,14 @@ typecheckIface dflags pcs hst mod_iface (syn_map, decls) deriv_binds, local_rules) -> ASSERT(nullBinds deriv_binds) let - local_things = filter (isLocalThing this_mod) - (nameEnvElts (getTcGEnv env)) - local_type_env :: TypeEnv - local_type_env = mkTypeEnv local_things - in - - -- throw away local_inst_info - returnTc (new_pcs, local_type_env, local_rules) + local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env)) + mod_details = ModDetails { md_types = mkTypeEnv local_things, + md_insts = map iDFunId local_inst_info, + md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules] } + -- All the rules from an interface are of the IfaceRuleOut form + in + returnTc (new_pcs, mod_details) tcImports :: RecTcEnv -> PersistentCompilerState @@ -500,9 +497,9 @@ tcImports :: RecTcEnv RenamedHsBinds, [TypecheckedRuleDecl]) -- tcImports is a slight mis-nomer. --- It deals with everythign that could be an import: +-- It deals with everything that could be an import: -- type and class decls --- interface signatures +-- interface signatures (checked lazily) -- instance decls -- rule decls -- These can occur in source code too, of course @@ -664,47 +661,31 @@ typecheck dflags syn_map pcs hst unqual thing_inside \begin{code} printTcDump dflags Nothing = return () printTcDump dflags (Just (_, results)) - = do dumpIfSet_dyn dflags Opt_D_dump_types - "Type signatures" (dump_sigs (tc_env results)) - dumpIfSet_dyn dflags Opt_D_dump_tc - "Typechecked" (dump_tc results) + = do dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc] + "Interface" (dump_tc_iface results) -printIfaceDump dflags Nothing = return () -printIfaceDump dflags (Just (_, env, rules)) - = do dumpIfSet_dyn dflags Opt_D_dump_types - "Type signatures" (dump_sigs env) dumpIfSet_dyn dflags Opt_D_dump_tc - "Typechecked" (dump_iface env rules) + "Typechecked" (ppr (tc_binds results)) -dump_tc results - = vcat [ppr (tc_binds results), - pp_rules (tc_rules results), - ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)] - ] + +printIfaceDump dflags Nothing = return () +printIfaceDump dflags (Just (_, details)) + = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc] + "Interface" (pprModDetails details) -dump_iface env rules - = vcat [pp_rules rules, - ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env] - ] +dump_tc_iface results + = vcat [pprModDetails (ModDetails {md_types = tc_env results, + md_insts = tc_insts results, + md_rules = []}) , + ppr_rules (tc_rules results), -dump_sigs env -- Print type signatures - = -- Convert to HsType so that we get source-language style printing - -- And sort by RdrName - vcat $ map ppr_sig $ sortLt lt_sig $ - [ (toRdrName id, toHsType (idType id)) - | AnId id <- nameEnvElts env, - want_sig id + ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)] ] - where - lt_sig (n1,_) (n2,_) = n1 < n2 - ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t - want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocalId id && isGlobalName (idName id) - -- isLocalId ignores data constructors, records selectors etc - -- The isGlobalName ignores local dictionary and method bindings - -- that the type checker has invented. User-defined things have - -- Global names. +ppr_rules [] = empty +ppr_rules rs = vcat [ptext SLIT("{-# RULES"), + nest 4 (vcat (map ppr rs)), + ptext SLIT("#-}")] ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"), vcat (map ppr_gen_tycon tcs), @@ -726,8 +707,4 @@ ppr_ep (EP from to) where (_,from_tau) = splitForAllTys (idType from) -pp_rules [] = empty -pp_rules rs = vcat [ptext SLIT("{-# RULES"), - nest 4 (vcat (map ppr rs)), - ptext SLIT("#-}")] \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 71bfb5b..c86db59 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -51,7 +51,7 @@ import Type ( Type, Kind, PredType(..), ThetaType, SigmaType, TauType, import PprType ( pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) import CoreFVs ( idFreeTyVars ) -import Id ( mkVanillaId, idName, idType ) +import Id ( mkLocalId, idName, idType ) import Var ( Id, Var, TyVar, mkTyVar, tyVarKind ) import VarEnv import VarSet @@ -660,7 +660,7 @@ tcTySig (Sig v ty src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (tcsigCtxt v) $ tcHsSigType ty `thenTc` \ sigma_tc_ty -> - mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> + mkTcSig (mkLocalId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> returnTc sig mkTcSig :: TcId -> SrcLoc -> NF_TcM TcSigInfo diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index e5bfc93..e6c6949 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -17,7 +17,7 @@ import Inst ( InstOrigin(..), emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, newMethod, newOverloadedLit, newDicts, newClassDicts ) -import Id ( mkVanillaId ) +import Id ( mkLocalId ) import Name ( Name ) import FieldLabel ( fieldLabelName ) import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId ) @@ -52,7 +52,7 @@ import Outputable -- This is the right function to pass to tcPat when -- we're looking at a lambda-bound pattern, -- so there's no polymorphic guy to worry about -tcMonoPatBndr binder_name pat_ty = returnTc (mkVanillaId binder_name pat_ty) +tcMonoPatBndr binder_name pat_ty = returnTc (mkLocalId binder_name pat_ty) \end{code} diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 153d37c..b8f5bb8 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -22,7 +22,7 @@ import TcExpr ( tcExpr ) import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing ) import Rules ( extendRuleBase ) import Inst ( LIE, plusLIEs, instToId ) -import Id ( idName, idType, mkVanillaId ) +import Id ( idName, idType, mkLocalId ) import Module ( Module ) import VarSet import Type ( tyVarsOfTypes, openTypeKind ) @@ -137,9 +137,9 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc) sig_tys = [t | RuleBndrSig _ t <- vars] new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty -> - returnNF_Tc (mkVanillaId var ty) + returnNF_Tc (mkLocalId var ty) new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty -> - returnNF_Tc (mkVanillaId var ty) + returnNF_Tc (mkLocalId var ty) ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> doubleQuotes (ptext name) diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index dc3e8b0..b755fe0 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -40,7 +40,7 @@ import Var ( varName ) import FiniteMap import Digraph ( stronglyConnComp, SCC(..) ) import Name ( Name, getSrcLoc, isTyVarName ) -import Name ( NameEnv, mkNameEnv, lookupNameEnv_NF ) +import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv_NF ) import NameSet import Outputable import Maybes ( mapMaybe ) diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 4af9f41..da2b7d8 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -24,14 +24,14 @@ import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..), import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) import VarSet ( varSetElems ) -import Id ( Id, mkTemplateLocal, idType, idName, - mkTemplateLocalsNum, mkId +import Id ( Id, mkVanillaGlobal, idType, idName, + mkTemplateLocal, mkTemplateLocalsNum ) import TysWiredIn ( genericTyCons, genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, inlDataCon, crossTyCon, crossDataCon ) -import IdInfo ( constantIdInfo, setUnfoldingInfo ) +import IdInfo ( noCafOrTyGenIdInfo, setUnfoldingInfo ) import CoreUnfold ( mkTopUnfolding ) import Unique ( mkBuiltinUnique ) @@ -250,16 +250,16 @@ mkTyConGenInfo tycon [from_name, to_name] = Nothing | otherwise - = Just (EP { fromEP = mkId from_name from_ty from_id_info, - toEP = mkId to_name to_ty to_id_info }) + = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info, + toEP = mkVanillaGlobal to_name to_ty to_id_info }) where tyvars = tyConTyVars tycon -- [a, b, c] datacons = tyConDataConsIfAvailable tycon -- [C, D] tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c tyvar_tys = mkTyVarTys tyvars - from_id_info = constantIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn - to_id_info = constantIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn + from_id_info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn + to_id_info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty) to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty) diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index e745689..8be6654 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -18,7 +18,6 @@ import UsageSPLint import UConSet import CoreSyn -import CoreFVs ( mustHaveLocalBinding ) import Rules ( RuleBase ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( applyTy, applyTys, diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index 95ccf3a..0a18567 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -27,7 +27,6 @@ module UsageSPUtils ( {- SEE BELOW: -- KSW 2000-10-13 {- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13 import CoreSyn -import CoreFVs ( mustHaveLocalBinding ) import Var ( Var, varType, setVarType, mkUVar ) import Id ( isExportedId ) import Name ( isLocallyDefined ) -- 1.7.10.4