diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-11-06 16:26:57 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-11-06 16:26:57 +0000 |
| commit | 2e43779c758294571bdf5ef6f2be440487d8e196 (patch) | |
| tree | 9fc4cb1239a15fba6292952c86664b507bec2222 /compiler | |
| parent | 545bb79667ebcbf5e776f76518cf68b4d507e7f5 (diff) | |
| parent | 9f68cceca364600e2ed8d8b4c9e2684eb83549fc (diff) | |
| download | haskell-2e43779c758294571bdf5ef6f2be440487d8e196.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
Diffstat (limited to 'compiler')
27 files changed, 1529 insertions, 1516 deletions
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index ec63b893e9..9d42db0c0b 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -5,13 +5,6 @@ \section[Id]{@Ids@: Value and constructor identifiers} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | -- #name_types# -- GHC uses several kinds of name internally: @@ -24,76 +17,76 @@ -- -- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TypeRep.Type' and some additional -- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that --- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either +-- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either -- be global or local, see "Var#globalvslocal" -- -- * 'Var.Var': see "Var#name_types" module Id ( -- * The main types - Var, Id, isId, - - -- ** Simple construction - mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, - mkLocalId, mkLocalIdWithInfo, mkExportedLocalId, - mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, - mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, mkWiredInIdName, - - -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, idRepArity, - recordSelectorFieldLabel, - - -- ** Modifying an Id - setIdName, setIdUnique, Id.setIdType, - setIdExported, setIdNotExported, - globaliseId, localiseId, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo, - - - -- ** Predicates on Ids - isImplicitId, isDeadBinder, + Var, Id, isId, + + -- ** Simple construction + mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, + mkLocalId, mkLocalIdWithInfo, mkExportedLocalId, + mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, + mkWorkerId, mkWiredInIdName, + + -- ** Taking an Id apart + idName, idType, idUnique, idInfo, idDetails, idRepArity, + recordSelectorFieldLabel, + + -- ** Modifying an Id + setIdName, setIdUnique, Id.setIdType, + setIdExported, setIdNotExported, + globaliseId, localiseId, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo, + + + -- ** Predicates on Ids + isImplicitId, isDeadBinder, isStrictId, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, isNaughtyRecordSelector, - isClassOpId_maybe, isDFunId, - isPrimOpId, isPrimOpId_maybe, - isFCallId, isFCallId_maybe, - isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isClassOpId_maybe, isDFunId, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, isConLikeId, isBottomingId, idIsFrom, hasNoBinding, - -- ** Evidence variables - DictId, isDictId, dfunNSilent, isEvVar, + -- ** Evidence variables + DictId, isDictId, dfunNSilent, isEvVar, - -- ** Inline pragma stuff - idInlinePragma, setInlinePragma, modifyInlinePragma, + -- ** Inline pragma stuff + idInlinePragma, setInlinePragma, modifyInlinePragma, idInlineActivation, setInlineActivation, idRuleMatchInfo, - -- ** One-shot lambdas - isOneShotBndr, isOneShotLambda, isStateHackType, - setOneShotLambda, clearOneShotLambda, - - -- ** Reading 'IdInfo' fields - idArity, - idDemandInfo, idDemandInfo_maybe, - idStrictness, idStrictness_maybe, - idUnfolding, realIdUnfolding, - idSpecialisation, idCoreRules, idHasRules, - idCafInfo, - idLBVarInfo, - idOccInfo, - - -- ** Writing 'IdInfo' fields - setIdUnfoldingLazily, - setIdUnfolding, - setIdArity, - setIdDemandInfo, - setIdStrictness, zapIdStrictness, - setIdSpecialisation, - setIdCafInfo, - setIdOccInfo, zapIdOccInfo, + -- ** One-shot lambdas + isOneShotBndr, isOneShotLambda, isStateHackType, + setOneShotLambda, clearOneShotLambda, + + -- ** Reading 'IdInfo' fields + idArity, + idDemandInfo, idDemandInfo_maybe, + idStrictness, idStrictness_maybe, + idUnfolding, realIdUnfolding, + idSpecialisation, idCoreRules, idHasRules, + idCafInfo, + idLBVarInfo, + idOccInfo, + + -- ** Writing 'IdInfo' fields + setIdUnfoldingLazily, + setIdUnfolding, + setIdArity, + setIdDemandInfo, + setIdStrictness, zapIdStrictness, + setIdSpecialisation, + setIdCafInfo, + setIdOccInfo, zapIdOccInfo, ) where @@ -104,7 +97,7 @@ import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) ) import IdInfo import BasicTypes --- Imported and re-exported +-- Imported and re-exported import Var( Var, Id, DictId, idInfo, idDetails, globaliseId, varType, isId, isLocalId, isGlobalId, isExportedId ) @@ -130,22 +123,22 @@ import Util import StaticFlags -- infixl so you can say (id `set` a `set` b) -infixl 1 `setIdUnfoldingLazily`, - `setIdUnfolding`, - `setIdArity`, - `setIdOccInfo`, - `setIdDemandInfo`, - `setIdStrictness`, - `setIdSpecialisation`, - `setInlinePragma`, - `setInlineActivation`, - `idCafInfo` +infixl 1 `setIdUnfoldingLazily`, + `setIdUnfolding`, + `setIdArity`, + `setIdOccInfo`, + `setIdDemandInfo`, + `setIdStrictness`, + `setIdSpecialisation`, + `setInlinePragma`, + `setInlineActivation`, + `idCafInfo` \end{code} %************************************************************************ -%* * +%* * \subsection{Basic Id manipulation} -%* * +%* * %************************************************************************ \begin{code} @@ -176,9 +169,9 @@ setIdNotExported :: Id -> Id setIdNotExported = Var.setIdNotExported localiseId :: Id -> Id --- Make an with the same unique and type as the +-- Make an with the same unique and type as the -- incoming Id, but with an *Internal* Name and *LocalId* flavour -localiseId id +localiseId id | ASSERT( isId id ) isLocalId id && isInternalName name = id | otherwise @@ -199,17 +192,17 @@ modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) -- maybeModifyIdInfo tries to avoid unnecesary thrashing maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info -maybeModifyIdInfo Nothing id = id +maybeModifyIdInfo Nothing id = id \end{code} %************************************************************************ -%* * +%* * \subsection{Simple Id construction} -%* * +%* * %************************************************************************ 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, +but in addition it pins free-tyvar-info onto the Id's type, where it can easily be found. Note [Free type variables] @@ -218,7 +211,7 @@ At one time we cached the free type variables of the type of an Id at the root of the type in a TyNote. The idea was to avoid repeating the free-type-variable calculation. But it turned out to slow down the compiler overall. I don't quite know why; perhaps finding free -type variables of an Id isn't all that common whereas applying a +type variables of an Id isn't all that common whereas applying a substitution (which changes the free type variables) is more common. Anyway, we removed it in March 2008. @@ -242,16 +235,16 @@ mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info - -- Note [Free type variables] + -- Note [Free type variables] --- | Create a local 'Id' that is marked as exported. +-- | Create a local 'Id' that is marked as exported. -- This prevents things attached to it from being removed as dead code. mkExportedLocalId :: Name -> Type -> Id mkExportedLocalId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo - -- Note [Free type variables] + -- Note [Free type variables] --- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") +-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") -- that are created by the compiler out of thin air mkSysLocal :: FastString -> Unique -> Type -> Id mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty @@ -275,7 +268,7 @@ mkWiredInIdName mod fs uniq id 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} -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id @@ -297,9 +290,9 @@ mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys %************************************************************************ -%* * +%* * \subsection{Special Ids} -%* * +%* * %************************************************************************ \begin{code} @@ -331,8 +324,8 @@ isNaughtyRecordSelector id = case Var.idDetails id of _ -> False isClassOpId_maybe id = case Var.idDetails id of - ClassOpId cls -> Just cls - _other -> Nothing + ClassOpId cls -> Just cls + _other -> Nothing isPrimOpId id = case Var.idDetails id of PrimOpId _ -> True @@ -384,14 +377,14 @@ hasNoBinding :: Id -> Bool -- binding, even though it is defined in this module. -- Data constructor workers used to be things of this kind, but --- they aren't any more. Instead, we inject a binding for --- them at the CorePrep stage. +-- they aren't any more. Instead, we inject a binding for +-- them at the CorePrep stage. -- EXCEPT: unboxed tuples, which definitely have no binding hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> True -- See Note [Primop wrappers] - FCallId _ -> True - DataConWorkId dc -> isUnboxedTupleCon dc - _ -> False + PrimOpId _ -> True -- See Note [Primop wrappers] + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleCon dc + _ -> False isImplicitId :: Id -> Bool -- ^ 'isImplicitId' tells whether an 'Id's info is implied by other @@ -400,14 +393,14 @@ isImplicitId :: Id -> Bool isImplicitId id = case Var.idDetails id of FCallId {} -> True - ClassOpId {} -> True + ClassOpId {} -> True PrimOpId {} -> True DataConWorkId {} -> True - DataConWrapId {} -> True - -- These are are implied by their type or class decl; - -- remember that all type and class decls appear in the interface file. - -- The dfun id is not an implicit Id; it must *not* be omitted, because - -- it carries version info for the instance decl + DataConWrapId {} -> True + -- These are are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl _ -> False idIsFrom :: Module -> Id -> Bool @@ -432,13 +425,13 @@ used by GHCi, which does not implement primops direct at all. \begin{code} isDeadBinder :: Id -> Bool isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) - | otherwise = False -- TyVars count as not dead + | otherwise = False -- TyVars count as not dead \end{code} %************************************************************************ -%* * - Evidence variables -%* * +%* * + Evidence variables +%* * %************************************************************************ \begin{code} @@ -450,14 +443,14 @@ isDictId id = isDictTy (idType id) \end{code} %************************************************************************ -%* * +%* * \subsection{IdInfo stuff} -%* * +%* * %************************************************************************ \begin{code} - --------------------------------- - -- ARITY + --------------------------------- + -- ARITY idArity :: Id -> Arity idArity id = arityInfo (idInfo id) @@ -492,14 +485,14 @@ zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` Nothing) id isStrictId :: Id -> Bool isStrictId id = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - (isStrictDmd (idDemandInfo id)) || + (isStrictDmd (idDemandInfo id)) || (isStrictType (idType id)) - --------------------------------- - -- UNFOLDING + --------------------------------- + -- UNFOLDING idUnfolding :: Id -> Unfolding -- Do not expose the unfolding of a loop breaker! -idUnfolding id +idUnfolding id | isStrongLoopBreaker (occInfo info) = NoUnfolding | otherwise = unfoldingInfo info where @@ -524,8 +517,8 @@ idDemandInfo id = demandInfo (idInfo id) `orElse` topDmd setIdDemandInfo :: Id -> Demand -> Id setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` Just dmd) id - --------------------------------- - -- SPECIALISATION + --------------------------------- + -- SPECIALISATION -- See Note [Specialisations and RULES in IdInfo] in IdInfo.lhs @@ -541,16 +534,16 @@ idHasRules id = not (isEmptySpecInfo (idSpecialisation id)) setIdSpecialisation :: Id -> SpecInfo -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id - --------------------------------- - -- CAF INFO + --------------------------------- + -- CAF INFO idCafInfo :: Id -> CafInfo idCafInfo id = cafInfo (idInfo id) setIdCafInfo :: Id -> CafInfo -> Id setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id - --------------------------------- - -- Occcurrence INFO + --------------------------------- + -- Occcurrence INFO idOccInfo :: Id -> OccInfo idOccInfo id = occInfo (idInfo id) @@ -562,8 +555,8 @@ zapIdOccInfo b = b `setIdOccInfo` NoOccInfo \end{code} - --------------------------------- - -- INLINING + --------------------------------- + -- INLINING The inline pragma tells us to be very keen to inline this Id, but it's still OK not to if optimisation is switched off. @@ -591,8 +584,8 @@ isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) \end{code} - --------------------------------- - -- ONE-SHOT LAMBDAS + --------------------------------- + -- ONE-SHOT LAMBDAS \begin{code} idLBVarInfo :: Id -> LBVarInfo idLBVarInfo id = lbvarInfo (idInfo id) @@ -608,29 +601,29 @@ isOneShotBndr id = isOneShotLambda id || isStateHackType (idType id) -- | Should we apply the state hack to values of this 'Type'? isStateHackType :: Type -> Bool isStateHackType ty - | opt_NoStateHack + | opt_NoStateHack = False | otherwise = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon + Just tycon -> tycon == statePrimTyCon _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.lhs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.lhs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. -- | Returns whether the lambda associated with the 'Id' is certainly applied at most once. @@ -644,13 +637,13 @@ setOneShotLambda :: Id -> Id setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id clearOneShotLambda :: Id -> Id -clearOneShotLambda id +clearOneShotLambda id | isOneShotLambda id = modifyIdInfo (`setLBVarInfo` NoLBVarInfo) id - | otherwise = id + | otherwise = id -- The OneShotLambda functions simply fiddle with the IdInfo flag -- But watch out: this may change the type of something else --- f = \x -> e +-- f = \x -> e -- If we change the one-shot-ness of x, f's type changes \end{code} @@ -665,14 +658,14 @@ zapDemandIdInfo :: Id -> Id zapDemandIdInfo = zapInfo zapDemandInfo zapFragileIdInfo :: Id -> Id -zapFragileIdInfo = zapInfo zapFragileInfo +zapFragileIdInfo = zapInfo zapFragileInfo \end{code} Note [transferPolyIdInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~ -This transfer is used in two places: - FloatOut (long-distance let-floating) - SimplUtils.abstractFloats (short-distance let-floating) +This transfer is used in two places: + FloatOut (long-distance let-floating) + SimplUtils.abstractFloats (short-distance let-floating) Consider the short-distance let-floating: @@ -685,13 +678,13 @@ Then if we float thus we *do not* want to lose g's * strictness information - * arity + * arity * inline pragma (though that is bit more debatable) * occurrence info Mostly this is just an optimisation, but it's *vital* to transfer the occurrence info. Consider - + NonRec { f = /\a. let Rec { g* = ..g.. } in ... } where the '*' means 'LoopBreaker'. Then if we float we must get @@ -708,8 +701,8 @@ It's not so simple to retain * rules so we simply discard those. Sooner or later this may bite us. -If we abstract wrt one or more *value* binders, we must modify the -arity and strictness info before transferring it. E.g. +If we abstract wrt one or more *value* binders, we must modify the +arity and strictness info before transferring it. E.g. f = \x. e --> g' = \y. \x. e @@ -717,17 +710,17 @@ arity and strictness info before transferring it. E.g. Notice that g' has an arity one more than the original g \begin{code} -transferPolyIdInfo :: Id -- Original Id - -> [Var] -- Abstract wrt these variables - -> Id -- New Id - -> Id +transferPolyIdInfo :: Id -- Original Id + -> [Var] -- Abstract wrt these variables + -> Id -- New Id + -> Id transferPolyIdInfo old_id abstract_wrt new_id = modifyIdInfo transfer new_id where - arity_increase = count isId abstract_wrt -- Arity increases by the - -- number of value binders + arity_increase = count isId abstract_wrt -- Arity increases by the + -- number of value binders - old_info = idInfo old_id + old_info = idInfo old_id old_arity = arityInfo old_info old_inline_prag = inlinePragInfo old_info old_occ_info = occInfo old_info @@ -736,7 +729,7 @@ transferPolyIdInfo old_id abstract_wrt new_id new_strictness = fmap (increaseStrictSigArity arity_increase) old_strictness transfer new_info = new_info `setStrictnessInfo` new_strictness - `setArityInfo` new_arity - `setInlinePragInfo` old_inline_prag - `setOccInfo` old_occ_info + `setArityInfo` new_arity + `setInlinePragInfo` old_inline_prag + `setOccInfo` old_occ_info \end{code} diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 35d4a89a23..27d3c524c2 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -48,6 +48,8 @@ module Module pprModule, mkModule, stableModuleCmp, + HasModule(..), + ContainsModule(..), -- * The ModuleLocation type ModLocation(..), @@ -276,6 +278,12 @@ pprPackagePrefix p mod = getPprStyle doc -- the PrintUnqualified tells us which modules have to -- be qualified with package names | otherwise = empty + +class ContainsModule t where + extractModule :: t -> Module + +class HasModule m where + getModule :: m Module \end{code} %************************************************************************ diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 32813e8ac3..281ae938ed 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -5,13 +5,6 @@ \section[Name]{@Name@: to transmit name info from renamer to typechecker} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | -- #name_types# -- GHC uses several kinds of name internally: @@ -39,42 +32,42 @@ -- Names are system names, if they are names manufactured by the compiler module Name ( - -- * The main types - Name, -- Abstract - BuiltInSyntax(..), - - -- ** Creating 'Name's - mkSystemName, mkSystemNameAt, - mkInternalName, mkClonedInternalName, mkDerivedInternalName, - mkSystemVarName, mkSysTvName, + -- * The main types + Name, -- Abstract + BuiltInSyntax(..), + + -- ** Creating 'Name's + mkSystemName, mkSystemNameAt, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, + mkSystemVarName, mkSysTvName, mkFCallName, mkExternalName, mkWiredInName, - -- ** Manipulating and deconstructing 'Name's - nameUnique, setNameUnique, - nameOccName, nameModule, nameModule_maybe, - tidyNameOcc, - hashName, localiseName, + -- ** Manipulating and deconstructing 'Name's + nameUnique, setNameUnique, + nameOccName, nameModule, nameModule_maybe, + tidyNameOcc, + hashName, localiseName, mkLocalisedOccName, - nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, + nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, - -- ** Predicates on 'Name's - isSystemName, isInternalName, isExternalName, - isTyVarName, isTyConName, isDataConName, - isValName, isVarName, - isWiredInName, isBuiltInSyntax, - wiredInNameTyThing_maybe, - nameIsLocalOrFrom, stableNameCmp, + -- ** Predicates on 'Name's + isSystemName, isInternalName, isExternalName, + isTyVarName, isTyConName, isDataConName, + isValName, isVarName, + isWiredInName, isBuiltInSyntax, + wiredInNameTyThing_maybe, + nameIsLocalOrFrom, stableNameCmp, - -- * Class 'NamedThing' and overloaded friends - NamedThing(..), - getSrcLoc, getSrcSpan, getOccString, + -- * Class 'NamedThing' and overloaded friends + NamedThing(..), + getSrcLoc, getSrcSpan, getOccString, - pprInfixName, pprPrefixName, pprModulePrefix, + pprInfixName, pprPrefixName, pprModulePrefix, - -- Re-export the OccName stuff - module OccName + -- Re-export the OccName stuff + module OccName ) where #include "Typeable.h" @@ -97,21 +90,21 @@ import Data.Data \end{code} %************************************************************************ -%* * +%* * \subsection[Name-datatype]{The @Name@ datatype, and name construction} -%* * +%* * %************************************************************************ - + \begin{code} -- | A unique, unambigious name for something, containing information about where -- that thing originated. data Name = Name { - n_sort :: NameSort, -- What sort of name it is - n_occ :: !OccName, -- Its occurrence name - n_uniq :: FastInt, -- UNPACK doesn't work, recursive type + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: FastInt, -- UNPACK doesn't work, recursive type --(note later when changing Int# -> FastInt: is that still true about UNPACK?) - n_loc :: !SrcSpan -- Definition site - } + n_loc :: !SrcSpan -- Definition site + } deriving Typeable -- NOTE: we make the n_loc field strict to eliminate some potential @@ -120,17 +113,17 @@ data Name = Name { data NameSort = External Module - + | WiredIn Module TyThing BuiltInSyntax - -- A variant of External, for wired-in things + -- A variant of External, for wired-in things - | Internal -- A user-defined Id or TyVar - -- defined in the module being compiled + | Internal -- A user-defined Id or TyVar + -- defined in the module being compiled - | System -- A system-defined Id or TyVar. Typically the - -- OccName is very uninformative (like 's') + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') --- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, +-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, -- which have special syntactic forms. They aren't in scope -- as such. data BuiltInSyntax = BuiltInSyntax | UserSyntax @@ -138,7 +131,7 @@ data BuiltInSyntax = BuiltInSyntax | UserSyntax Notes about the NameSorts: -1. Initially, top-level Ids (including locally-defined ones) get External names, +1. Initially, top-level Ids (including locally-defined ones) get External names, and all other local Ids get Internal names 2. Things with a External name are given C static labels, so they finally @@ -150,8 +143,8 @@ Notes about the NameSorts: is changed to Internal, and a Internal that is visible is changed to External 4. A System Name differs in the following ways: - a) has unique attached when printing dumps - b) unifier eliminates sys tyvars in favour of user provs where possible + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible Before anything gets printed in interface files or output code, it's fed through a 'tidy' processor, which zaps the OccNames to have @@ -161,9 +154,9 @@ Notes about the NameSorts: Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) -Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, - not read from an interface file. - E.g. Bool, True, Int, Float, and many others +Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, + not read from an interface file. + E.g. Bool, True, Int, Float, and many others All built-in syntax is for wired-in things. @@ -171,11 +164,11 @@ All built-in syntax is for wired-in things. instance HasOccName Name where occName = nameOccName -nameUnique :: Name -> Unique -nameOccName :: Name -> OccName -nameModule :: Name -> Module -nameSrcLoc :: Name -> SrcLoc -nameSrcSpan :: Name -> SrcSpan +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan nameUnique name = mkUniqueGrimily (iBox (n_uniq name)) nameOccName name = n_occ name @@ -184,17 +177,17 @@ nameSrcSpan name = n_loc name \end{code} %************************************************************************ -%* * +%* * \subsection{Predicates on names} -%* * +%* * %************************************************************************ \begin{code} nameIsLocalOrFrom :: Module -> Name -> Bool -isInternalName :: Name -> Bool -isExternalName :: Name -> Bool -isSystemName :: Name -> Bool -isWiredInName :: Name -> Bool +isInternalName :: Name -> Bool +isExternalName :: Name -> Bool +isSystemName :: Name -> Bool +isWiredInName :: Name -> Bool isWiredInName (Name {n_sort = WiredIn _ _ _}) = True isWiredInName _ = False @@ -221,7 +214,7 @@ nameModule_maybe _ = Nothing nameIsLocalOrFrom from name | isExternalName name = from == nameModule name - | otherwise = True + | otherwise = True isTyVarName :: Name -> Bool isTyVarName name = isTvOcc (nameOccName name) @@ -244,9 +237,9 @@ isSystemName _ = False %************************************************************************ -%* * +%* * \subsection{Making names} -%* * +%* * %************************************************************************ \begin{code} @@ -257,12 +250,12 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq , n_sort = Internal , n_occ = occ , n_loc = loc } - -- NB: You might worry that after lots of huffing and - -- puffing we might end up with two local names with distinct - -- uniques, but the same OccName. Indeed we can, but that's ok - -- * the insides of the compiler don't care: they use the Unique - -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the - -- uniques if you get confused + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused -- * for interface files we tidyCore first, which makes -- the OccNames distinct when they need to be @@ -278,7 +271,7 @@ mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) -- | Create a name which definitely originates in the given module mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name -mkExternalName uniq mod occ loc +mkExternalName uniq mod occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = External mod, n_occ = occ, n_loc = loc } @@ -286,16 +279,16 @@ mkExternalName uniq mod occ loc mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name mkWiredInName mod occ uniq thing built_in = Name { n_uniq = getKeyFastInt uniq, - n_sort = WiredIn mod thing built_in, - n_occ = occ, n_loc = wiredInSrcSpan } + n_sort = WiredIn mod thing built_in, + n_occ = occ, n_loc = wiredInSrcSpan } -- | Create a name brought into being by the compiler mkSystemName :: Unique -> OccName -> Name mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name -mkSystemNameAt uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = System - , n_occ = occ, n_loc = loc } +mkSystemNameAt uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = System + , n_occ = occ, n_loc = loc } mkSystemVarName :: Unique -> FastString -> Name mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) @@ -321,7 +314,7 @@ tidyNameOcc :: Name -> OccName -> Name -- In doing so, we change System --> Internal, so that when we print -- it we don't get the unique by default. It's tidy now! tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} -tidyNameOcc name occ = name { n_occ = occ } +tidyNameOcc name occ = name { n_occ = occ } -- | Make the 'Name' into an internal name, regardless of what it was to begin with localiseName :: Name -> Name @@ -329,30 +322,30 @@ localiseName n = n { n_sort = Internal } \end{code} \begin{code} --- |Create a localised variant of a name. +-- |Create a localised variant of a name. -- -- If the name is external, encode the original's module name to disambiguate. -- mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name) where - origin + origin | nameIsLocalOrFrom this_mod name = Nothing | otherwise = Just (moduleNameColons . moduleName . nameModule $ name) \end{code} %************************************************************************ -%* * +%* * \subsection{Hashing and comparison} -%* * +%* * %************************************************************************ \begin{code} -hashName :: Name -> Int -- ToDo: should really be Word +hashName :: Name -> Int -- ToDo: should really be Word hashName name = getKey (nameUnique name) + 1 - -- The +1 avoids keys with lots of zeros in the ls bits, which - -- interacts badly with the cheap and cheerful multiplication in - -- hashExpr + -- The +1 avoids keys with lots of zeros in the ls bits, which + -- interacts badly with the cheap and cheerful multiplication in + -- hashExpr cmpName :: Name -> Name -> Ordering cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2) @@ -360,7 +353,7 @@ cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2) stableNameCmp :: Name -> Name -> Ordering -- Compare lexicographically stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) - (Name { n_sort = s2, n_occ = occ2 }) + (Name { n_sort = s2, n_occ = occ2 }) = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) -- The ordinary compare on OccNames is lexicogrpahic where @@ -379,9 +372,9 @@ stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) \end{code} %************************************************************************ -%* * +%* * \subsection[Name-instances]{Instance declarations} -%* * +%* * %************************************************************************ \begin{code} @@ -391,9 +384,9 @@ instance Eq Name where instance Ord Name where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } compare a b = cmpName a b instance Uniquable Name where @@ -410,15 +403,15 @@ instance Data Name where \end{code} %************************************************************************ -%* * +%* * \subsection{Binary} -%* * +%* * %************************************************************************ \begin{code} instance Binary Name where put_ bh name = - case getUserData bh of + case getUserData bh of UserData{ ud_put_name = put_name } -> put_name bh name get bh = @@ -427,9 +420,9 @@ instance Binary Name where \end{code} %************************************************************************ -%* * +%* * \subsection{Pretty printing} -%* * +%* * %************************************************************************ \begin{code} @@ -448,20 +441,20 @@ pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ}) case sort of WiredIn mod _ builtin -> pprExternal sty uniq mod occ n True builtin External mod -> pprExternal sty uniq mod occ n False UserSyntax - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ where uniq = mkUniqueGrimily (iBox u) pprExternal :: PprStyle -> Unique -> Module -> OccName -> Name -> Bool -> BuiltInSyntax -> SDoc pprExternal sty uniq mod occ name is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ - -- In code style, always qualify - -- ToDo: maybe we could print all wired-in things unqualified - -- in code style, to reduce symbol table bloat? + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? | debugStyle sty = pp_mod <> ppr_occ_name occ - <> braces (hsep [if is_wired then ptext (sLit "(w)") else empty, - pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) + <> braces (hsep [if is_wired then ptext (sLit "(w)") else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax | otherwise = pprModulePrefix sty mod name <> ppr_occ_name occ where @@ -473,23 +466,23 @@ pprExternal sty uniq mod occ name is_wired is_builtin pprInternal :: PprStyle -> Unique -> OccName -> SDoc pprInternal sty uniq occ | codeStyle sty = pprUnique uniq - | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) + | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - -- For debug dumps, we're not necessarily dumping - -- tidied code, so we need to print the uniques. - | otherwise = ppr_occ_name occ -- User style + -- For debug dumps, we're not necessarily dumping + -- tidied code, so we need to print the uniques. + | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style pprSystem :: PprStyle -> Unique -> OccName -> SDoc pprSystem sty uniq occ | codeStyle sty = pprUnique uniq | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - <> braces (pprNameSpaceBrief (occNameSpace occ)) - | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq - -- If the tidy phase hasn't run, the OccName - -- is unlikely to be informative (like 's'), - -- so print the unique + <> braces (pprNameSpaceBrief (occNameSpace occ)) + | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique pprModulePrefix :: PprStyle -> Module -> Name -> SDoc @@ -500,7 +493,7 @@ pprModulePrefix sty mod name = sdocWithDynFlags $ \dflags -> then empty else case qualName sty name of -- See Outputable.QualifyName: - NameQual modname -> ppr modname <> dot -- Name is in scope + NameQual modname -> ppr modname <> dot -- Name is in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in <> ppr (moduleName mod) <> dot -- scope eithber @@ -517,39 +510,39 @@ ppr_underscore_unique uniq ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ) - -- Don't use pprOccName; instead, just print the string of the OccName; - -- we print the namespace in the debug stuff above + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above -- In code style, we Z-encode the strings. The results of Z-encoding each FastString are -- cached behind the scenes in the FastString implementation. ppr_z_occ_name :: OccName -> SDoc ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) --- Prints (if mod information is available) "Defined at <loc>" or +-- Prints (if mod information is available) "Defined at <loc>" or -- "Defined in <mod>" information for a Name. pprDefinedAt :: Name -> SDoc pprDefinedAt name = ptext (sLit "Defined") <+> pprNameDefnLoc name pprNameDefnLoc :: Name -> SDoc --- Prints "at <loc>" or +-- Prints "at <loc>" or -- or "in <mod>" depending on what info is available -pprNameDefnLoc name +pprNameDefnLoc name = case nameSrcLoc name of -- nameSrcLoc rather than nameSrcSpan - -- It seems less cluttered to show a location - -- rather than a span for the definition point + -- It seems less cluttered to show a location + -- rather than a span for the definition point RealSrcLoc s -> ptext (sLit "at") <+> ppr s UnhelpfulLoc s | isInternalName name || isSystemName name -> ptext (sLit "at") <+> ftext s - | otherwise + | otherwise -> ptext (sLit "in") <+> quotes (ppr (nameModule name)) \end{code} %************************************************************************ -%* * +%* * \subsection{Overloaded functions related to Names} -%* * +%* * %************************************************************************ \begin{code} @@ -558,20 +551,20 @@ class NamedThing a where getOccName :: a -> OccName getName :: a -> Name - getOccName n = nameOccName (getName n) -- Default method + getOccName n = nameOccName (getName n) -- Default method \end{code} \begin{code} -getSrcLoc :: NamedThing a => a -> SrcLoc -getSrcSpan :: NamedThing a => a -> SrcSpan -getOccString :: NamedThing a => a -> String +getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan +getOccString :: NamedThing a => a -> String -getSrcLoc = nameSrcLoc . getName -getSrcSpan = nameSrcSpan . getName -getOccString = occNameString . getOccName +getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName +getOccString = occNameString . getOccName pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc --- See Outputable.pprPrefixVar, pprInfixVar; +-- See Outputable.pprPrefixVar, pprInfixVar; -- add parens or back-quotes as appropriate pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 1291f6466a..dfa44ca274 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -1065,6 +1065,12 @@ doReturn exprs_code = do updfr_off <- getUpdFrameOff emit (mkReturnSimple dflags exprs updfr_off) +mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple dflags actuals updfr_off = + mkReturn dflags e actuals updfr_off + where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off) + (gcWord dflags)) + doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () doRawJump expr_code vols = do dflags <- getDynFlags diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 1536794a70..7971b1de0f 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -12,7 +12,7 @@ module MkGraph , mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra , mkRawJump , mkCbranch, mkSwitch - , mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch + , mkReturn, mkComment, mkCallEntry, mkBranch , copyInOflow, copyOutOflow , noExtraStack , toCall, Transfer(..) @@ -23,7 +23,6 @@ import BlockId import Cmm import CmmCallConv - import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) import DynFlags import FastString @@ -241,11 +240,6 @@ mkReturn dflags e actuals updfr_off = lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 -mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -mkReturnSimple dflags actuals updfr_off = - mkReturn dflags e actuals updfr_off - where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags) - mkBranch :: BlockId -> CmmAGraph mkBranch bid = mkLast (CmmBranch bid) diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 7612cd1a49..aef1e4f792 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -306,6 +306,11 @@ loadThreadState dflags tso stack = do -- SpLim = stack->stack + RESERVED_STACK_WORDS; mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) (rESERVED_STACK_WORDS dflags)), + -- HpAlloc = 0; + -- HpAlloc is assumed to be set to non-zero only by a failed + -- a heap check, see HeapStackCheck.cmm:GC_GENERIC + mkAssign hpAlloc (zeroExpr dflags), + openNursery dflags, -- and load the current cost centre stack from the TSO when profiling: if gopt Opt_SccProfilingOn dflags then @@ -367,13 +372,14 @@ stgHp = CmmReg hp stgCurrentTSO = CmmReg currentTSO stgCurrentNursery = CmmReg currentNursery -sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg +sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg sp = CmmGlobal Sp spLim = CmmGlobal SpLim hp = CmmGlobal Hp hpLim = CmmGlobal HpLim currentTSO = CmmGlobal CurrentTSO currentNursery = CmmGlobal CurrentNursery +hpAlloc = CmmGlobal HpAlloc -- ----------------------------------------------------------------------------- -- For certain types passed to foreign calls, we adjust the actual diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 72dd664698..fe2a0217e0 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -6,13 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmPrim ( cgOpApp, cgPrimOp -- internal(ish), used by cgCase to get code for a @@ -36,7 +29,7 @@ import BasicTypes import MkGraph import StgSyn import Cmm -import Type ( Type, tyConAppTyCon ) +import Type ( Type, tyConAppTyCon ) import TyCon import CLabel import CmmUtils @@ -51,62 +44,62 @@ import Control.Monad (liftM) import Data.Bits ------------------------------------------------------------------------ --- Primitive operations and foreign calls +-- Primitive operations and foreign calls ------------------------------------------------------------------------ {- Note [Foreign call results] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ A foreign call always returns an unboxed tuple of results, one of which is the state token. This seems to happen even for pure -calls. +calls. Even if we returned a single result for pure calls, it'd still be right to wrap it in a singleton unboxed tuple, because the result might be a Haskell closure pointer, we don't want to evaluate it. -} ---------------------------------- -cgOpApp :: StgOp -- The op - -> [StgArg] -- Arguments - -> Type -- Result type (always an unboxed tuple) +cgOpApp :: StgOp -- The op + -> [StgArg] -- Arguments + -> Type -- Result type (always an unboxed tuple) -> FCode ReturnKind --- Foreign calls -cgOpApp (StgFCallOp fcall _) stg_args res_ty +-- Foreign calls +cgOpApp (StgFCallOp fcall _) stg_args res_ty = cgForeignCall fcall stg_args res_ty -- Note [Foreign call results] --- tagToEnum# is special: we need to pull the constructor +-- tagToEnum# is special: we need to pull the constructor -- out of the table, and perform an appropriate return. -cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty +cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty = ASSERT(isEnumerationTyCon tycon) - do { dflags <- getDynFlags + do { dflags <- getDynFlags ; args' <- getNonVoidArgAmodes [arg] ; let amode = case args' of [amode] -> amode _ -> panic "TagToEnumOp had void arg" - ; emitReturn [tagToClosure dflags tycon amode] } + ; emitReturn [tagToClosure dflags tycon amode] } where - -- If you're reading this code in the attempt to figure - -- out why the compiler panic'ed here, it is probably because - -- you used tagToEnum# in a non-monomorphic setting, e.g., - -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# - -- That won't work. - tycon = tyConAppTyCon res_ty + -- If you're reading this code in the attempt to figure + -- out why the compiler panic'ed here, it is probably because + -- you used tagToEnum# in a non-monomorphic setting, e.g., + -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# + -- That won't work. + tycon = tyConAppTyCon res_ty cgOpApp (StgPrimOp primop) args res_ty | primOpOutOfLine primop - = do { cmm_args <- getNonVoidArgAmodes args + = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } | ReturnsPrim VoidRep <- result_info - = do cgPrimOp [] primop args + = do cgPrimOp [] primop args emitReturn [] | ReturnsPrim rep <- result_info = do dflags <- getDynFlags res <- newTemp (primRepCmmType dflags rep) - cgPrimOp [res] primop args + cgPrimOp [res] primop args emitReturn [CmmReg (CmmLocal res)] | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon @@ -116,7 +109,7 @@ cgOpApp (StgPrimOp primop) args res_ty | ReturnsAlg tycon <- result_info , isEnumerationTyCon tycon - -- c.f. cgExpr (...TagToEnumOp...) + -- c.f. cgExpr (...TagToEnumOp...) = do dflags <- getDynFlags tag_reg <- newTemp (bWord dflags) cgPrimOp [tag_reg] primop args @@ -128,15 +121,15 @@ cgOpApp (StgPrimOp primop) args res_ty result_info = getPrimOpResultInfo primop cgOpApp (StgPrimCallOp primcall) args _res_ty - = do { cmm_args <- getNonVoidArgAmodes args + = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } --------------------------------------------------- -cgPrimOp :: [LocalReg] -- where to put the results - -> PrimOp -- the op - -> [StgArg] -- arguments - -> FCode () +cgPrimOp :: [LocalReg] -- where to put the results + -> PrimOp -- the op + -> [StgArg] -- arguments + -> FCode () cgPrimOp results op args = do dflags <- getDynFlags @@ -145,35 +138,35 @@ cgPrimOp results op args ------------------------------------------------------------------------ --- Emitting code for a primop +-- Emitting code for a primop ------------------------------------------------------------------------ emitPrimOp :: DynFlags - -> [LocalReg] -- where to put the results - -> PrimOp -- the op - -> [CmmExpr] -- arguments - -> FCode () + -> [LocalReg] -- where to put the results + -> PrimOp -- the op + -> [CmmExpr] -- arguments + -> FCode () -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] -{- +{- With some bit-twiddling, we can define int{Add,Sub}Czh portably in C, and without needing any comparisons. This may not be the fastest way to do it - if you have better code, please send it! --SDM - + Return : r = a + b, c = 0 if no overflow, 1 on overflow. - - We currently don't make use of the r value if c is != 0 (i.e. + + We currently don't make use of the r value if c is != 0 (i.e. overflow), we just convert to big integers and try again. This could be improved by making r and c the correct values for - plugging into a new J#. - - { r = ((I_)(a)) + ((I_)(b)); \ - c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } Wading through the mass of bracketry, it seems to reduce to: c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) @@ -181,22 +174,22 @@ emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] = emit $ catAGraphs [ mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] + ], mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] + ] ] emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] {- Similarly: - #define subIntCzh(r,c,a,b) \ - { r = ((I_)(a)) - ((I_)(b)); \ - c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ } c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) @@ -204,24 +197,24 @@ emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] = emit $ catAGraphs [ mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), mkAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordXor dflags) [aa,bb], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] + ], mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] + ] ] emitPrimOp _ [res] ParOp [arg] - = - -- for now, just implement this in a C function - -- later, we might want to inline it. + = + -- for now, just implement this in a C function + -- later, we might want to inline it. emitCCall - [(res,NoHint)] - (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) - [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] + [(res,NoHint)] + (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] emitPrimOp dflags [res] SparkOp [arg] = do @@ -251,10 +244,10 @@ emitPrimOp dflags [res] ReadMutVarOp [mutv] emitPrimOp dflags [] WriteMutVarOp [mutv,var] = do emitStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var - emitCCall - [{-no results-}] - (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)] + emitCCall + [{-no results-}] + (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)] -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes @@ -279,7 +272,7 @@ emitPrimOp dflags [res] ByteArrayContents_Char [arg] emitPrimOp dflags [res] StableNameToIntOp [arg] = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) --- #define eqStableNamezh(r,sn1,sn2) \ +-- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ @@ -303,13 +296,13 @@ emitPrimOp dflags [res] DataToTagOp [arg] {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable objects, even if they are in old space. When they become immutable, - they can be removed from this scavenge list. -} + they can be removed from this scavenge list. -} -- #define unsafeFreezzeArrayzh(r,a) --- { +-- { -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); --- r = a; --- } +-- r = a; +-- } emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] = emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), @@ -319,7 +312,7 @@ emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), mkAssign (CmmLocal res) arg ] --- #define unsafeFreezzeByteArrayzh(r,a) r=(a) +-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] = emitAssign (CmmLocal res) arg @@ -492,16 +485,11 @@ emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = doSetByteArrayOp ba off len c -- Population count -emitPrimOp dflags [res] PopCnt8Op [w] = - emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 -emitPrimOp dflags [res] PopCnt16Op [w] = - emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 -emitPrimOp dflags [res] PopCnt32Op [w] = - emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 -emitPrimOp _ [res] PopCnt64Op [w] = - emitPopCntCall res w W64 -- arg always has type W64, no need to narrow -emitPrimOp dflags [res] PopCntOp [w] = - emitPopCntCall res w (wordWidth dflags) +emitPrimOp _ [res] PopCnt8Op [w] = emitPopCntCall res w W8 +emitPrimOp _ [res] PopCnt16Op [w] = emitPopCntCall res w W16 +emitPrimOp _ [res] PopCnt32Op [w] = emitPopCntCall res w W32 +emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64 +emitPrimOp dflags [res] PopCntOp [w] = emitPopCntCall res w (wordWidth dflags) -- The rest just translate straightforwardly emitPrimOp dflags [res] op [arg] @@ -695,9 +683,9 @@ nopOp Int2WordOp = True nopOp Word2IntOp = True nopOp Int2AddrOp = True nopOp Addr2IntOp = True -nopOp ChrOp = True -- Int# and Char# are rep'd the same -nopOp OrdOp = True -nopOp _ = False +nopOp ChrOp = True -- Int# and Char# are rep'd the same +nopOp OrdOp = True +nopOp _ = False -- These PrimOps turn into double casts @@ -708,7 +696,7 @@ narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32) narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8) narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16) narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32) -narrowOp _ = Nothing +narrowOp _ = Nothing -- Native word signless ops @@ -879,7 +867,7 @@ doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCod doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = do dflags <- getDynFlags mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx -doIndexByteArrayOp _ _ _ _ +doIndexByteArrayOp _ _ _ _ = panic "CgPrimOp: doIndexByteArrayOp" doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> FCode () @@ -898,7 +886,7 @@ doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode () doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val] = do dflags <- getDynFlags mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx val -doWriteByteArrayOp _ _ _ +doWriteByteArrayOp _ _ _ = panic "CgPrimOp: doWriteByteArrayOp" doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () @@ -915,13 +903,13 @@ doWritePtrArrayOp addr idx val (CmmMachOp (mo_wordUShr dflags) [idx, mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)]) ) (CmmLit (CmmInt 1 W8)) - + loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType - -> LocalReg -> CmmExpr -> CmmExpr -> FCode () + -> LocalReg -> CmmExpr -> CmmExpr -> FCode () mkBasicIndexedRead off Nothing read_rep res base idx = do dflags <- getDynFlags emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx) @@ -931,7 +919,7 @@ mkBasicIndexedRead off (Just cast) read_rep res base idx cmmLoadIndexOffExpr dflags off read_rep base idx]) mkBasicIndexedWrite :: ByteOff -> Maybe MachOp - -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () + -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () mkBasicIndexedWrite off Nothing base idx val = do dflags <- getDynFlags emitStore (cmmIndexOffExpr dflags off (typeWidth (cmmExprType dflags val)) base idx) val diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 0cf4b97159..daf49eebac 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -28,6 +28,7 @@ import Name import Type import TyCon import Coercion +import TcEnv import TcType import CmmExpr @@ -211,12 +212,8 @@ dsFCall fn_id co fcall mDeclHeader = do (fcall', cDoc) <- case fcall of CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) -> - do fcall_uniq <- newUnique - let wrapperName = mkFastString "ghc_wrapper_" `appendFS` - mkFastString (showPpr dflags fcall_uniq) `appendFS` - mkFastString "_" `appendFS` - cName - fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) + do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) + let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) c = includes $$ fun_proto <+> braces (cRet <> semi) includes = vcat [ text "#include <" <> ftext h <> text ">" diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 6ed0f64a06..5e94d515d7 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -167,6 +167,9 @@ data DsGblEnv , ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays' } +instance ContainsModule DsGblEnv where + extractModule = ds_mod + data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings ds_loc :: SrcSpan -- to put in pattern-matching error msgs diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 953b2c4568..a2413d5151 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -1,6 +1,3 @@ -{-# OPTIONS -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - ----------------------------------------------------------------------------- -- -- Makefile Dependency Generation @@ -51,7 +48,25 @@ import Data.Maybe ( isJust ) doMkDependHS :: GhcMonad m => [FilePath] -> m () doMkDependHS srcs = do -- Initialisation - dflags <- GHC.getSessionDynFlags + dflags0 <- GHC.getSessionDynFlags + + -- We kludge things a bit for dependency generation. Rather than + -- generating dependencies for each way separately, we generate + -- them once and then duplicate them for each way's osuf/hisuf. + -- We therefore do the initial dependency generation with an empty + -- way and .o/.hi extensions, regardless of any flags that might + -- be specified. + let dflags = dflags0 { + ways = [], + buildTag = mkBuildTag [], + hiSuf = "hi", + objectSuf = "o" + } + _ <- GHC.setSessionDynFlags dflags + + when (null (depSuffixes dflags)) $ + ghcError (ProgramError "You must specify at least one -dep-suffix") + files <- liftIO $ beginMkDependHS dflags -- Do the downsweep to find all the modules @@ -263,24 +278,13 @@ writeDependency root hdl targets dep ----------------------------- insertSuffixes :: FilePath -- Original filename; e.g. "foo.o" - -> [String] -- Extra suffices e.g. ["x","y"] - -> [FilePath] -- Zapped filenames e.g. ["foo.o", "foo.x_o", "foo.y_o"] + -> [String] -- Suffix prefixes e.g. ["x_", "y_"] + -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] -- Note that that the extra bit gets inserted *before* the old suffix - -- We assume the old suffix contains no dots, so we can strip it with removeSuffix - - -- NOTE: we used to have this comment - -- In order to construct hi files with alternate suffixes, we - -- now have to find the "basename" of the hi file. This is - -- difficult because we can't just split the hi filename - -- at the last dot - the hisuf might have dots in it. So we - -- check whether the hi filename ends in hisuf, and if it does, - -- we strip off hisuf, otherwise we strip everything after the - -- last dot. - -- But I'm not sure we care about hisufs with dots in them. - -- Lots of other things will break first! - + -- We assume the old suffix contains no dots, so we know where to + -- split it insertSuffixes file_name extras - = file_name : [ basename <.> (extra ++ "_" ++ suffix) | extra <- extras ] + = [ basename <.> (extra ++ suffix) | extra <- extras ] where (basename, suffix) = case splitExtension file_name of -- Drop the "." from the extension diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d745cd63af..07ebd4013e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -670,6 +670,8 @@ data DynFlags = DynFlags { maxWorkerArgs :: Int, + ghciHistSize :: Int, + -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, flushOut :: FlushOut, @@ -688,7 +690,9 @@ data DynFlags = DynFlags { interactivePrint :: Maybe String, - llvmVersion :: IORef (Int) + llvmVersion :: IORef (Int), + + nextWrapperNum :: IORef Int } class HasDynFlags m where @@ -1109,12 +1113,14 @@ initDynFlags dflags = do refFilesToNotIntermediateClean <- newIORef [] refGeneratedDumps <- newIORef Set.empty refLlvmVersion <- newIORef 28 + wrapperNum <- newIORef 0 return dflags{ filesToClean = refFilesToClean, dirsToClean = refDirsToClean, filesToNotIntermediateClean = refFilesToNotIntermediateClean, generatedDumps = refGeneratedDumps, - llvmVersion = refLlvmVersion + llvmVersion = refLlvmVersion, + nextWrapperNum = wrapperNum } -- | The normal 'DynFlags'. Note that they is not suitable for use in this form @@ -1227,6 +1233,8 @@ defaultDynFlags mySettings = maxWorkerArgs = 10, + ghciHistSize = 50, -- keep a log of length 50 by default + log_action = defaultLogAction, flushOut = defaultFlushOut, flushErr = defaultFlushErr, @@ -1235,7 +1243,8 @@ defaultDynFlags mySettings = traceLevel = 1, profAuto = NoProfAuto, llvmVersion = panic "defaultDynFlags: No llvmVersion", - interactivePrint = Nothing + interactivePrint = Nothing, + nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum" } defaultWays :: Settings -> [Way] @@ -2126,6 +2135,8 @@ dynamic_flags = [ , Flag "fmax-worker-args" (intSuffix (\n d -> d {maxWorkerArgs = n})) + , Flag "fghci-hist-size" (intSuffix (\n d -> d {ghciHistSize = n})) + ------ Profiling ---------------------------------------------------- -- OLD profiling flags diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 64b2d3303c..9b9c14bb0b 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -220,13 +220,15 @@ runStmtWithLocation source linenumber expr step = let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) + size = ghciHistSize idflags' + case step of RunAndLogSteps -> traceRunStatus expr bindings tyThings - breakMVar statusMVar status emptyHistory + breakMVar statusMVar status (emptyHistory size) _other -> handleRunStatus expr bindings tyThings - breakMVar statusMVar status emptyHistory + breakMVar statusMVar status (emptyHistory size) runDecls :: GhcMonad m => String -> m [Name] runDecls = runDeclsWithLocation "<interactive>" 1 @@ -268,8 +270,8 @@ withVirtualCWD m = do parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr -emptyHistory :: BoundedList History -emptyHistory = nilBL 50 -- keep a log of length 50 +emptyHistory :: Int -> BoundedList History +emptyHistory size = nilBL size handleRunStatus :: GhcMonad m => String-> ([TyThing],GlobalRdrEnv) -> [Id] diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index eb59d2b82a..619bf9a5fc 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -1,39 +1,32 @@ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1993-2004 --- +-- -- The native code generator's monad. -- -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module NCGMonad ( - NatM_State(..), mkNatM_State, - - NatM, -- instance Monad - initNat, - addImportNat, - getUniqueNat, - mapAccumLNat, - setDeltaNat, - getDeltaNat, - getBlockIdNat, - getNewLabelNat, - getNewRegNat, - getNewRegPairNat, - getPicBaseMaybeNat, - getPicBaseNat, - getDynFlags -) - + NatM_State(..), mkNatM_State, + + NatM, -- instance Monad + initNat, + addImportNat, + getUniqueNat, + mapAccumLNat, + setDeltaNat, + getDeltaNat, + getBlockIdNat, + getNewLabelNat, + getNewRegNat, + getNewRegPairNat, + getPicBaseMaybeNat, + getPicBaseNat, + getDynFlags +) + where - + #include "HsVersions.h" import Reg @@ -41,19 +34,19 @@ import Size import TargetReg import BlockId -import CLabel ( CLabel, mkAsmTempLabel ) +import CLabel ( CLabel, mkAsmTempLabel ) import UniqSupply -import Unique ( Unique ) +import Unique ( Unique ) import DynFlags -data NatM_State - = NatM_State { - natm_us :: UniqSupply, - natm_delta :: Int, - natm_imports :: [(CLabel)], - natm_pic :: Maybe Reg, - natm_dflags :: DynFlags - } +data NatM_State + = NatM_State { + natm_us :: UniqSupply, + natm_delta :: Int, + natm_imports :: [(CLabel)], + natm_pic :: Maybe Reg, + natm_dflags :: DynFlags + } newtype NatM result = NatM (NatM_State -> (result, NatM_State)) @@ -61,12 +54,12 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State -mkNatM_State us delta dflags - = NatM_State us delta [] Nothing dflags +mkNatM_State us delta dflags + = NatM_State us delta [] Nothing dflags initNat :: NatM_State -> NatM a -> (a, NatM_State) -initNat init_st m - = case unNat m init_st of { (r,st) -> (r,st) } +initNat init_st m + = case unNat m init_st of { (r,st) -> (r,st) } instance Monad NatM where @@ -76,17 +69,17 @@ instance Monad NatM where thenNat :: NatM a -> (a -> NatM b) -> NatM b thenNat expr cont - = NatM $ \st -> case unNat expr st of - (result, st') -> unNat (cont result) st' + = NatM $ \st -> case unNat expr st of + (result, st') -> unNat (cont result) st' returnNat :: a -> NatM a -returnNat result - = NatM $ \st -> (result, st) +returnNat result + = NatM $ \st -> (result, st) mapAccumLNat :: (acc -> x -> NatM (acc, y)) -> acc - -> [x] - -> NatM (acc, [y]) + -> [x] + -> NatM (acc, [y]) mapAccumLNat _ b [] = return (b, []) @@ -106,32 +99,32 @@ instance HasDynFlags NatM where getDeltaNat :: NatM Int -getDeltaNat - = NatM $ \ st -> (natm_delta st, st) +getDeltaNat + = NatM $ \ st -> (natm_delta st, st) setDeltaNat :: Int -> NatM () -setDeltaNat delta - = NatM $ \ (NatM_State us _ imports pic dflags) -> - ((), NatM_State us delta imports pic dflags) +setDeltaNat delta + = NatM $ \ (NatM_State us _ imports pic dflags) -> + ((), NatM_State us delta imports pic dflags) addImportNat :: CLabel -> NatM () -addImportNat imp - = NatM $ \ (NatM_State us delta imports pic dflags) -> - ((), NatM_State us delta (imp:imports) pic dflags) +addImportNat imp + = NatM $ \ (NatM_State us delta imports pic dflags) -> + ((), NatM_State us delta (imp:imports) pic dflags) getBlockIdNat :: NatM BlockId -getBlockIdNat - = do u <- getUniqueNat - return (mkBlockId u) +getBlockIdNat + = do u <- getUniqueNat + return (mkBlockId u) getNewLabelNat :: NatM CLabel -getNewLabelNat - = do u <- getUniqueNat - return (mkAsmTempLabel u) +getNewLabelNat + = do u <- getUniqueNat + return (mkAsmTempLabel u) getNewRegNat :: Size -> NatM Reg @@ -152,16 +145,16 @@ getNewRegPairNat rep getPicBaseMaybeNat :: NatM (Maybe Reg) -getPicBaseMaybeNat - = NatM (\state -> (natm_pic state, state)) +getPicBaseMaybeNat + = NatM (\state -> (natm_pic state, state)) getPicBaseNat :: Size -> NatM Reg -getPicBaseNat rep - = do mbPicBase <- getPicBaseMaybeNat - case mbPicBase of - Just picBase -> return picBase - Nothing - -> do - reg <- getNewRegNat rep - NatM (\state -> (reg, state { natm_pic = Just reg })) +getPicBaseNat rep + = do mbPicBase <- getPicBaseMaybeNat + case mbPicBase of + Just picBase -> return picBase + Nothing + -> do + reg <- getNewRegNat rep + NatM (\state -> (reg, state { natm_pic = Just reg })) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index cfadd57869..b3160ed2ca 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1774,7 +1774,7 @@ genCCall32' dflags target dest_regs args = do let -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we - -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] + -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] sizes = map (arg_size . cmmExprType dflags . hintlessCmm) (reverse args) raw_arg_size = sum sizes + wORD_SIZE dflags arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size @@ -2034,7 +2034,7 @@ genCCall64' dflags target dest_regs args = do -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we - -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] + -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] (real_size, adjust_rsp) <- if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0 then return (tot_arg_size, nilOL) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index fbbaf65819..717b885e63 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -39,6 +39,7 @@ import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch import RnPat import RnEnv import DynFlags +import Module import Name import NameEnv import NameSet diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index f29d64c55c..5e466c9a32 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -52,7 +52,7 @@ import Name import NameSet import NameEnv import Avail -import Module ( ModuleName, moduleName ) +import Module import UniqFM import DataCon ( dataConFieldLabels, dataConTyCon ) import TyCon ( isTupleTyCon, tyConArity ) diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 038f754406..606549161f 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -40,6 +40,7 @@ import DynFlags import BasicTypes ( FixityDirection(..) ) import PrelNames +import Module import Name import NameSet import RdrName diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index bc1e1e5199..c2c265044c 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -72,7 +72,7 @@ import PprCore import CoreUtils import CoreLint ( lintCoreBindings ) import HscTypes -import Module ( Module ) +import Module import DynFlags import StaticFlags import Rules ( RuleBase ) @@ -863,9 +863,6 @@ getHscEnv = read cr_hsc_env getRuleBase :: CoreM RuleBase getRuleBase = read cr_rule_base -getModule :: CoreM Module -getModule = read cr_module - addSimplCount :: SimplCount -> CoreM () addSimplCount count = write (CoreWriter { cw_simpl_count = count }) @@ -874,6 +871,9 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count }) instance HasDynFlags CoreM where getDynFlags = fmap hsc_dflags getHscEnv +instance HasModule CoreM where + getModule = read cr_module + -- | The original name cache is the current mapping from 'Module' and -- 'OccName' to a compiler-wide unique 'Name' getOrigNameCache :: CoreM OrigNameCache diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index b2f83deb91..7a01ee2ee5 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -9,15 +9,8 @@ ToDo [Nov 2010] \section[SpecConstr]{Specialise over constructors} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SpecConstr( - specConstrProgram + specConstrProgram #ifdef GHCI , SpecConstrAnnotation(..) #endif @@ -28,28 +21,28 @@ module SpecConstr( import CoreSyn import CoreSubst import CoreUtils -import CoreUnfold ( couldBeSmallEnoughToInline ) -import CoreFVs ( exprsFreeVars ) +import CoreUnfold ( couldBeSmallEnoughToInline ) +import CoreFVs ( exprsFreeVars ) import CoreMonad -import Literal ( litIsLifted ) +import Literal ( litIsLifted ) import HscTypes ( ModGuts(..) ) -import WwLib ( mkWorkerArgs ) +import WwLib ( mkWorkerArgs ) import DataCon -import Coercion hiding( substTy, substCo ) +import Coercion hiding( substTy, substCo ) import Rules -import Type hiding ( substTy ) +import Type hiding ( substTy ) import Id -import MkCore ( mkImpossibleExpr ) +import MkCore ( mkImpossibleExpr ) import Var import VarEnv import VarSet import Name import BasicTypes -import DynFlags ( DynFlags(..) ) -import StaticFlags ( opt_PprStyle_Debug ) -import Maybes ( orElse, catMaybes, isJust, isNothing ) +import DynFlags ( DynFlags(..) ) +import StaticFlags ( opt_PprStyle_Debug ) +import Maybes ( orElse, catMaybes, isJust, isNothing ) import Demand -import DmdAnal ( both ) +import DmdAnal ( both ) import Serialized ( deserializeWithData ) import Util import Pair @@ -58,7 +51,7 @@ import Outputable import FastString import UniqFM import MonadUtils -import Control.Monad ( zipWithM ) +import Control.Monad ( zipWithM ) import Data.List @@ -72,76 +65,76 @@ import GHC.Exts( SpecConstrAnnotation(..) ) \end{code} ----------------------------------------------------- - Game plan + Game plan ----------------------------------------------------- Consider - drop n [] = [] - drop 0 xs = [] - drop n (x:xs) = drop (n-1) xs + drop n [] = [] + drop 0 xs = [] + drop n (x:xs) = drop (n-1) xs After the first time round, we could pass n unboxed. This happens in numerical code too. Here's what it looks like in Core: - drop n xs = case xs of - [] -> [] - (y:ys) -> case n of - I# n# -> case n# of - 0 -> [] - _ -> drop (I# (n# -# 1#)) xs + drop n xs = case xs of + [] -> [] + (y:ys) -> case n of + I# n# -> case n# of + 0 -> [] + _ -> drop (I# (n# -# 1#)) xs Notice that the recursive call has an explicit constructor as argument. Noticing this, we can make a specialised version of drop - - RULE: drop (I# n#) xs ==> drop' n# xs - drop' n# xs = let n = I# n# in ...orig RHS... + RULE: drop (I# n#) xs ==> drop' n# xs + + drop' n# xs = let n = I# n# in ...orig RHS... Now the simplifier will apply the specialisation in the rhs of drop', giving - drop' n# xs = case xs of - [] -> [] - (y:ys) -> case n# of - 0 -> [] - _ -> drop (n# -# 1#) xs + drop' n# xs = case xs of + [] -> [] + (y:ys) -> case n# of + 0 -> [] + _ -> drop (n# -# 1#) xs -Much better! +Much better! We'd also like to catch cases where a parameter is carried along unchanged, but evaluated each time round the loop: - f i n = if i>0 || i>n then i else f (i*2) n + f i n = if i>0 || i>n then i else f (i*2) n Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. In Core, by the time we've w/wd (f is strict in i) we get - f i# n = case i# ># 0 of - False -> I# i# - True -> case n of n' { I# n# -> - case i# ># n# of - False -> I# i# - True -> f (i# *# 2#) n' + f i# n = case i# ># 0 of + False -> I# i# + True -> case n of n' { I# n# -> + case i# ># n# of + False -> I# i# + True -> f (i# *# 2#) n' At the call to f, we see that the argument, n is know to be (I# n#), and n is evaluated elsewhere in the body of f, so we can play the same -trick as above. +trick as above. Note [Reboxing] ~~~~~~~~~~~~~~~ We must be careful not to allocate the same constructor twice. Consider - f p = (...(case p of (a,b) -> e)...p..., - ...let t = (r,s) in ...t...(f t)...) + f p = (...(case p of (a,b) -> e)...p..., + ...let t = (r,s) in ...t...(f t)...) At the recursive call to f, we can see that t is a pair. But we do NOT want to make a specialised copy: - f' a b = let p = (a,b) in (..., ...) + f' a b = let p = (a,b) in (..., ...) because now t is allocated by the caller, then r and s are passed to the recursive call, which allocates the (r,s) pair again. This happens if (a) the argument p is used in other than a case-scrutinsation way. (b) the argument to the call is not a 'fresh' tuple; you have to - look into its unfolding to see that it's a tuple + look into its unfolding to see that it's a tuple Hence the "OR" part of Note [Good arguments] below. @@ -155,16 +148,16 @@ If at the call site the (I# x) was an unfolding, then we'd have to rely on CSE to eliminate the duplicate allocation.... This alternative doesn't look attractive enough to pursue. -ALTERNATIVE 3: ignore the reboxing problem. The trouble is that +ALTERNATIVE 3: ignore the reboxing problem. The trouble is that the conservative reboxing story prevents many useful functions from being specialised. Example: - foo :: Maybe Int -> Int -> Int - foo (Just m) 0 = 0 - foo x@(Just m) n = foo x (n-m) + foo :: Maybe Int -> Int -> Int + foo (Just m) 0 = 0 + foo x@(Just m) n = foo x (n-m) Here the use of 'x' will clearly not require boxing in the specialised function. The strictness analyser has the same problem, in fact. Example: - f p@(a,b) = ... + f p@(a,b) = ... If we pass just 'a' and 'b' to the worker, it might need to rebox the pair to create (a,b). A more sophisticated analysis might figure out precisely the cases in which this could happen, but the strictness @@ -179,25 +172,25 @@ Note [Good arguments] ~~~~~~~~~~~~~~~~~~~~~ So we look for -* A self-recursive function. Ignore mutual recursion for now, +* A self-recursive function. Ignore mutual recursion for now, because it's less common, and the code is simpler for self-recursion. * EITHER - a) At a recursive call, one or more parameters is an explicit + a) At a recursive call, one or more parameters is an explicit constructor application - AND - That same parameter is scrutinised by a case somewhere in + AND + That same parameter is scrutinised by a case somewhere in the RHS of the function OR b) At a recursive call, one or more parameters has an unfolding that is an explicit constructor application - AND - That same parameter is scrutinised by a case somewhere in + AND + That same parameter is scrutinised by a case somewhere in the RHS of the function - AND + AND Those are the only uses of the parameter (see Note [Reboxing]) @@ -206,11 +199,11 @@ What to abstract over There's a bit of a complication with type arguments. If the call site looks like - f p = ...f ((:) [a] x xs)... + f p = ...f ((:) [a] x xs)... then our specialised function look like - f_spec x xs = let p = (:) [a] x xs in ....as before.... + f_spec x xs = let p = (:) [a] x xs in ....as before.... This only makes sense if either a) the type variable 'a' is in scope at the top of f, or @@ -220,7 +213,7 @@ Actually, (a) may hold for value arguments too, in which case we may not want to pass them. Supose 'x' is in scope at f's defn, but xs is not. Then we'd like - f_spec xs = let p = (:) [a] x xs in ....as before.... + f_spec xs = let p = (:) [a] x xs in ....as before.... Similarly (b) may hold too. If x is already an argument at the call, no need to pass it again. @@ -228,17 +221,17 @@ call, no need to pass it again. Finally, if 'a' is not in scope at the call site, we could abstract it as we do the term variables: - f_spec a x xs = let p = (:) [a] x xs in ...as before... + f_spec a x xs = let p = (:) [a] x xs in ...as before... So the grand plan is: - * abstract the call site to a constructor-only pattern - e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) + * abstract the call site to a constructor-only pattern + e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) - * Find the free variables of the abstracted pattern + * Find the free variables of the abstracted pattern - * Pass these variables, less any that are in scope at - the fn defn. But see Note [Shadowing] below. + * Pass these variables, less any that are in scope at + the fn defn. But see Note [Shadowing] below. NOTICE that we only abstract over variables that are not in scope, @@ -253,13 +246,13 @@ that are bound between the usage site and the definition site; or (more seriously) may be bound to something different at the definition site. For example: - f x = letrec g y v = let x = ... - in ...(g (a,b) x)... + f x = letrec g y v = let x = ... + in ...(g (a,b) x)... -Since 'x' is in scope at the call site, we may make a rewrite rule that +Since 'x' is in scope at the call site, we may make a rewrite rule that looks like - RULE forall a,b. g (a,b) x = ... -But this rule will never match, because it's really a different 'x' at + RULE forall a,b. g (a,b) x = ... +But this rule will never match, because it's really a different 'x' at the call site -- and that difference will be manifest by the time the simplifier gets to it. [A worry: the simplifier doesn't *guarantee* no-shadowing, so perhaps it may not be distinct?] @@ -292,9 +285,9 @@ It produces \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) -> case ww_sme of ds_Xlw { __DEFAULT -> - case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> - T.$wfoo ww1_Xmz lvl_rmV - }; + case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> + T.$wfoo ww1_Xmz lvl_rmV + }; 0 -> 0 } @@ -310,7 +303,7 @@ When is this worth it? Call the constant 'lvl' Also do this is if the function has RULES? -Also +Also Note [Specialising for lambda parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -327,14 +320,14 @@ explicit lambda as the argument: \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) -> case ww_sm8 of ds_Xlr { __DEFAULT -> - case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> - T.$wfoo - ww1_Xmq - (\ (n_ad3 :: GHC.Base.Int) -> - case n_ad3 of wild_alB { GHC.Base.I# x_alA -> - GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) - }) - }; + case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> + T.$wfoo + ww1_Xmq + (\ (n_ad3 :: GHC.Base.Int) -> + case n_ad3 of wild_alB { GHC.Base.I# x_alA -> + GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) + }) + }; 0 -> 0 } @@ -351,7 +344,7 @@ Looks cool, but probably rare...but it might be easy to implement. Note [SpecConstr for casts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider +Consider data family T a :: * data instance T Int = T Int @@ -360,8 +353,8 @@ Consider go (T 0) = 0 go (T n) = go (T (n-1)) -The recursive call ends up looking like - go (T (I# ...) `cast` g) +The recursive call ends up looking like + go (T (I# ...) `cast` g) So we want to spot the construtor application inside the cast. That's why we have the Cast case in argToPat @@ -384,7 +377,7 @@ If we start with the RHSs of 'foo', we get lots and lots of specialisations, most of which are not needed. But if we start with the (single) call in the rhs of 'bar' we get exactly one fully-specialised copy, and all the recursive calls go to this fully-specialised copy. Indeed, the original -function is later collected as dead code. This is very important in +function is later collected as dead code. This is very important in specialising the loops arising from stream fusion, for example in NDP where we were getting literally hundreds of (mostly unused) specialisations of a local function. @@ -397,7 +390,7 @@ ones, such as letrec foo x y = ....foo... in map foo xs then we will end up calling the un-specialised function, so then we *should* -use the calls in the un-specialised RHS as seeds. We call these "boring +use the calls in the un-specialised RHS as seeds. We call these "boring call patterns, and callsToPats reports if it finds any of these. @@ -523,7 +516,7 @@ that we have ForceSpecConstr, this NoSpecConstr is probably redundant. (Used only for PArray.) ----------------------------------------------------- - Stuff not yet handled + Stuff not yet handled ----------------------------------------------------- Here are notes arising from Roman's work that I don't want to lose. @@ -543,16 +536,16 @@ looks like a boxed use of the argument. A pity. $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# $wfoo_sFw = \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) -> - case ww_sFo of ds_Xw6 [Just L] { - __DEFAULT -> - case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { - __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; - 0 -> - case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> - case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> - $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy - } } }; - 0 -> 0 + case ww_sFo of ds_Xw6 [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { + __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; + 0 -> + case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> + case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> + $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy + } } }; + 0 -> 0 Example 2 ~~~~~~~~~ @@ -573,34 +566,34 @@ a strict tuple. Before SpecConstr, we have GHC.Base.Int) -> case ww_sFU of ds_Xws [Just L] { __DEFAULT -> - case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { - __DEFAULT -> - case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> - $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 - }; - 0 -> - case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> - case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> - $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 - } } }; + case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { + __DEFAULT -> + case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 + }; + 0 -> + case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> + case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 + } } }; 0 -> 0 } We get two specialisations: "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#} - Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) - = Foo.$s$wfoo1 a_sFB sc_sGC ; + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) + = Foo.$s$wfoo1 a_sFB sc_sGC ; "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#} - Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) - = Foo.$s$wfoo y_aFp sc_sGC ; + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) + = Foo.$s$wfoo y_aFp sc_sGC ; But perhaps the first one isn't good. After all, we know that tpl_B2 is a T (I# x) really, because T is strict and Int has one constructor. (We can't unbox the strict fields, becuase T is polymorphic!) %************************************************************************ -%* * +%* * \subsection{Top level wrapper stuff} -%* * +%* * %************************************************************************ \begin{code} @@ -613,7 +606,7 @@ specConstrProgram guts let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts)) return (guts { mg_binds = binds' }) where - go _ [] = return [] + go _ [] = return [] go env (bind:binds) = do (env', bind') <- scTopBind env bind binds' <- go env' binds return (bind' : binds') @@ -621,72 +614,72 @@ specConstrProgram guts %************************************************************************ -%* * +%* * \subsection{Environment: goes downwards} -%* * +%* * %************************************************************************ \begin{code} data ScEnv = SCE { sc_dflags :: DynFlags, - sc_size :: Maybe Int, -- Size threshold - sc_count :: Maybe Int, -- Max # of specialisations for any one fn - -- See Note [Avoiding exponential blowup] + sc_size :: Maybe Int, -- Size threshold + sc_count :: Maybe Int, -- Max # of specialisations for any one fn + -- See Note [Avoiding exponential blowup] sc_force :: Bool, -- Force specialisation? -- See Note [Forcing specialisation] - sc_subst :: Subst, -- Current substitution - -- Maps InIds to OutExprs + sc_subst :: Subst, -- Current substitution + -- Maps InIds to OutExprs - sc_how_bound :: HowBoundEnv, - -- Binds interesting non-top-level variables - -- Domain is OutVars (*after* applying the substitution) + sc_how_bound :: HowBoundEnv, + -- Binds interesting non-top-level variables + -- Domain is OutVars (*after* applying the substitution) - sc_vals :: ValueEnv, - -- Domain is OutIds (*after* applying the substitution) - -- Used even for top-level bindings (but not imported ones) + sc_vals :: ValueEnv, + -- Domain is OutIds (*after* applying the substitution) + -- Used even for top-level bindings (but not imported ones) sc_annotations :: UniqFM SpecConstrAnnotation - } + } --------------------- -- As we go, we apply a substitution (sc_subst) to the current term -type InExpr = CoreExpr -- _Before_ applying the subst +type InExpr = CoreExpr -- _Before_ applying the subst type InVar = Var -type OutExpr = CoreExpr -- _After_ applying the subst +type OutExpr = CoreExpr -- _After_ applying the subst type OutId = Id type OutVar = Var --------------------- -type HowBoundEnv = VarEnv HowBound -- Domain is OutVars +type HowBoundEnv = VarEnv HowBound -- Domain is OutVars --------------------- -type ValueEnv = IdEnv Value -- Domain is OutIds -data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors - -- The AltCon is never DEFAULT - | LambdaVal -- Inlinable lambdas or PAPs +type ValueEnv = IdEnv Value -- Domain is OutIds +data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors + -- The AltCon is never DEFAULT + | LambdaVal -- Inlinable lambdas or PAPs instance Outputable Value where ppr (ConVal con args) = ppr con <+> interpp'SP args - ppr LambdaVal = ptext (sLit "<Lambda>") + ppr LambdaVal = ptext (sLit "<Lambda>") --------------------- initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv initScEnv dflags anns = SCE { sc_dflags = dflags, sc_size = specConstrThreshold dflags, - sc_count = specConstrCount dflags, + sc_count = specConstrCount dflags, sc_force = False, - sc_subst = emptySubst, - sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv, + sc_subst = emptySubst, + sc_how_bound = emptyVarEnv, + sc_vals = emptyVarEnv, sc_annotations = anns } -data HowBound = RecFun -- These are the recursive functions for which - -- we seek interesting call patterns +data HowBound = RecFun -- These are the recursive functions for which + -- we seek interesting call patterns - | RecArg -- These are those functions' arguments, or their sub-components; - -- we gather occurrence information for these + | RecArg -- These are those functions' arguments, or their sub-components; + -- we gather occurrence information for these instance Outputable HowBound where ppr RecFun = text "RecFun" @@ -711,10 +704,10 @@ zapScSubst :: ScEnv -> ScEnv zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } extendScInScope :: ScEnv -> [Var] -> ScEnv - -- Bring the quantified variables into scope + -- Bring the quantified variables into scope extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars } - -- Extend the substitution + -- Extend the substitution extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr } @@ -724,18 +717,18 @@ extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv extendHowBound env bndrs how_bound = env { sc_how_bound = extendVarEnvList (sc_how_bound env) - [(bndr,how_bound) | bndr <- bndrs] } + [(bndr,how_bound) | bndr <- bndrs] } extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var]) -extendBndrsWith how_bound env bndrs +extendBndrsWith how_bound env bndrs = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs') where (subst', bndrs') = substBndrs (sc_subst env) bndrs - hb_env' = sc_how_bound env `extendVarEnvList` - [(bndr,how_bound) | bndr <- bndrs'] + hb_env' = sc_how_bound env `extendVarEnvList` + [(bndr,how_bound) | bndr <- bndrs'] extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var) -extendBndrWith how_bound env bndr +extendBndrWith how_bound env bndr = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr') where (subst', bndr') = substBndr (sc_subst env) bndr @@ -743,13 +736,13 @@ extendBndrWith how_bound env bndr extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') - where - (subst', bndrs') = substRecBndrs (sc_subst env) bndrs + where + (subst', bndrs') = substRecBndrs (sc_subst env) bndrs extendBndr :: ScEnv -> Var -> (ScEnv, Var) extendBndr env bndr = (env { sc_subst = subst' }, bndr') - where - (subst', bndr') = substBndr (sc_subst env) bndr + where + (subst', bndr') = substBndr (sc_subst env) bndr extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _ Nothing = env @@ -757,8 +750,8 @@ extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) -- When we encounter --- case scrut of b --- C x y -> ... +-- case scrut of b +-- C x y -> ... -- we want to bind b, to (C x y) -- NB1: Extends only the sc_vals part of the envt -- NB2: Kill the dead-ness info on the pattern binders x,y, since @@ -768,7 +761,7 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs where live_case_bndr = not (isDeadBinder case_bndr) env1 | Var v <- scrut = extendValEnv env v cval - | otherwise = env -- See Note [Add scrutinee to ValueEnv too] + | otherwise = env -- See Note [Add scrutinee to ValueEnv too] env2 | live_case_bndr = extendValEnv env1 case_bndr cval | otherwise = env1 @@ -778,25 +771,25 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs = alt_bndrs cval = case con of - DEFAULT -> Nothing - LitAlt {} -> Just (ConVal con []) - DataAlt {} -> Just (ConVal con vanilla_args) - where - vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ - varsToCoreExprs alt_bndrs - - zap v | isTyVar v = v -- See NB2 above + DEFAULT -> Nothing + LitAlt {} -> Just (ConVal con []) + DataAlt {} -> Just (ConVal con vanilla_args) + where + vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ + varsToCoreExprs alt_bndrs + + zap v | isTyVar v = v -- See NB2 above | otherwise = zapIdOccInfo v decreaseSpecCount :: ScEnv -> Int -> ScEnv -- See Note [Avoiding exponential blowup] -decreaseSpecCount env n_specs +decreaseSpecCount env n_specs = env { sc_count = case sc_count env of Nothing -> Nothing Just n -> Just (n `div` (n_specs + 1)) } - -- The "+1" takes account of the original function; - -- See Note [Avoiding exponential blowup] + -- The "+1" takes account of the original function; + -- See Note [Avoiding exponential blowup] --------------------------------------------------- -- See Note [SpecConstrAnnotation] @@ -852,7 +845,7 @@ will have a binding for y, and for c c -> I# v BUT that's not enough! Looking at the call (f y) we see that y is pair (a,b), but we also need to know what 'b' is. -So in extendCaseBndrs we must *also* add the binding +So in extendCaseBndrs we must *also* add the binding b -> I# v else we lose a useful specialisation for f. This is necessary even though the simplifier has systematically replaced uses of 'x' with 'y' @@ -865,12 +858,12 @@ The sc_count field of the ScEnv says how many times we are prepared to duplicate a single function. But we must take care with recursive specialiations. Consider - let $j1 = let $j2 = let $j3 = ... - in + let $j1 = let $j2 = let $j3 = ... + in ...$j3... - in + in ...$j2... - in + in ...$j1... If we specialise $j1 then in each specialisation (as well as the original) @@ -883,25 +876,25 @@ copies we are making at this level, including the original. %************************************************************************ -%* * +%* * \subsection{Usage information: flows upwards} -%* * +%* * %************************************************************************ \begin{code} data ScUsage = SCU { - scu_calls :: CallEnv, -- Calls - -- The functions are a subset of the - -- RecFuns in the ScEnv + scu_calls :: CallEnv, -- Calls + -- The functions are a subset of the + -- RecFuns in the ScEnv - scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences - } -- The domain is OutIds + scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences + } -- The domain is OutIds type CallEnv = IdEnv [Call] type Call = (ValueEnv, [CoreArg]) - -- The arguments of the call, together with the - -- env giving the constructor bindings at the call site + -- The arguments of the call, together with the + -- env giving the constructor bindings at the call site nullUsage :: ScUsage nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } @@ -911,7 +904,7 @@ combineCalls = plusVarEnv_C (++) combineUsage :: ScUsage -> ScUsage -> ScUsage combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), - scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } + scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } combineUsages :: [ScUsage] -> ScUsage combineUsages [] = nullUsage @@ -922,13 +915,13 @@ lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs]) -data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument - | UnkOcc -- Used in some unknown way +data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument + | UnkOcc -- Used in some unknown way - | ScrutOcc -- See Note [ScrutOcc] + | ScrutOcc -- See Note [ScrutOcc] (DataConEnv [ArgOcc]) -- How the sub-components are used -type DataConEnv a = UniqFM a -- Keyed by DataCon +type DataConEnv a = UniqFM a -- Keyed by DataCon {- Note [ScrutOcc] ~~~~~~~~~~~~~~~~~~~ @@ -941,17 +934,17 @@ is *only* taken apart or applied. where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, The domain of the UniqFM is the Unique of the data constructor -The [ArgOcc] is the occurrences of the *pattern-bound* components +The [ArgOcc] is the occurrences of the *pattern-bound* components of the data structure. E.g. - data T a = forall b. MkT a b (b->a) + data T a = forall b. MkT a b (b->a) A pattern binds b, x::a, y::b, z::b->a, but not 'a'! -} instance Outputable ArgOcc where ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs - ppr UnkOcc = ptext (sLit "unk-occ") - ppr NoOcc = ptext (sLit "no-occ") + ppr UnkOcc = ptext (sLit "unk-occ") + ppr NoOcc = ptext (sLit "no-occ") evalScrutOcc :: ArgOcc evalScrutOcc = ScrutOcc emptyUFM @@ -961,11 +954,11 @@ evalScrutOcc = ScrutOcc emptyUFM -- in the overall result, even if it's also used in a boxed way -- This might be too agressive; see Note [Reboxing] Alternative 3 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc -combineOcc NoOcc occ = occ -combineOcc occ NoOcc = occ +combineOcc NoOcc occ = occ +combineOcc occ NoOcc = occ combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys -combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs +combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs combineOcc UnkOcc UnkOcc = UnkOcc combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] @@ -978,15 +971,15 @@ setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ setScrutOcc env usg (Var v) occ | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ } - | otherwise = usg -setScrutOcc _env usg _other _occ -- Catch-all - = usg + | otherwise = usg +setScrutOcc _env usg _other _occ -- Catch-all + = usg \end{code} %************************************************************************ -%* * +%* * \subsection{The main recursive function} -%* * +%* * %************************************************************************ The main recursive function gathers up usage information, and @@ -994,15 +987,15 @@ creates specialised versions of functions. \begin{code} scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) - -- The unique supply is needed when we invent - -- a new name for the specialised function and its args + -- The unique supply is needed when we invent + -- a new name for the specialised function and its args scExpr env e = scExpr' env e scExpr' env (Var v) = case scSubstId env v of - Var v' -> return (mkVarUsage env v' [], Var v') - e' -> scExpr (zapScSubst env) e' + Var v' -> return (mkVarUsage env v' [], Var v') + e' -> scExpr (zapScSubst env) e' scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) @@ -1016,98 +1009,98 @@ scExpr' env (Lam b e) = do let (env', b') = extendBndr env b (usg, e') <- scExpr env' e return (usg, Lam b' e') -scExpr' env (Case scrut b ty alts) - = do { (scrut_usg, scrut') <- scExpr env scrut - ; case isValue (sc_vals env) scrut' of - Just (ConVal con args) -> sc_con_app con args scrut' - _other -> sc_vanilla scrut_usg scrut' - } +scExpr' env (Case scrut b ty alts) + = do { (scrut_usg, scrut') <- scExpr env scrut + ; case isValue (sc_vals env) scrut' of + Just (ConVal con args) -> sc_con_app con args scrut' + _other -> sc_vanilla scrut_usg scrut' + } where - sc_con_app con args scrut' -- Known constructor; simplify - = do { let (_, bs, rhs) = findAlt con alts - `orElse` (DEFAULT, [], mkImpossibleExpr ty) - alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) - ; scExpr alt_env' rhs } - - sc_vanilla scrut_usg scrut' -- Normal case + sc_con_app con args scrut' -- Known constructor; simplify + = do { let (_, bs, rhs) = findAlt con alts + `orElse` (DEFAULT, [], mkImpossibleExpr ty) + alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) + ; scExpr alt_env' rhs } + + sc_vanilla scrut_usg scrut' -- Normal case = do { let (alt_env,b') = extendBndrWith RecArg env b - -- Record RecArg for the components + -- Record RecArg for the components - ; (alt_usgs, alt_occs, alts') - <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts + ; (alt_usgs, alt_occs, alts') + <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts - ; let scrut_occ = foldr combineOcc NoOcc alt_occs - scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ - -- The combined usage of the scrutinee is given - -- by scrut_occ, which is passed to scScrut, which - -- in turn treats a bare-variable scrutinee specially + ; let scrut_occ = foldr combineOcc NoOcc alt_occs + scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ + -- The combined usage of the scrutinee is given + -- by scrut_occ, which is passed to scScrut, which + -- in turn treats a bare-variable scrutinee specially - ; return (foldr combineUsage scrut_usg' alt_usgs, - Case scrut' b' (scSubstTy env ty) alts') } + ; return (foldr combineUsage scrut_usg' alt_usgs, + Case scrut' b' (scSubstTy env ty) alts') } sc_alt env scrut' b' (con,bs,rhs) = do { let (env1, bs1) = extendBndrsWith RecArg env bs - (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 - ; (usg, rhs') <- scExpr env2 rhs - ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) - scrut_occ = case con of - DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) - _ -> ScrutOcc emptyUFM - ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } + (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 + ; (usg, rhs') <- scExpr env2 rhs + ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) + scrut_occ = case con of + DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) + _ -> ScrutOcc emptyUFM + ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } scExpr' env (Let (NonRec bndr rhs) body) - | isTyVar bndr -- Type-lets may be created by doBeta + | isTyVar bndr -- Type-lets may be created by doBeta = scExpr' (extendScSubst env bndr rhs) body - | otherwise - = do { let (body_env, bndr') = extendBndr env bndr - ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs) + | otherwise + = do { let (body_env, bndr') = extendBndr env bndr + ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs) - ; let body_env2 = extendHowBound body_env [bndr'] RecFun - -- Note [Local let bindings] - RI _ rhs' _ _ _ = rhs_info + ; let body_env2 = extendHowBound body_env [bndr'] RecFun + -- Note [Local let bindings] + RI _ rhs' _ _ _ = rhs_info body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') - ; (body_usg, body') <- scExpr body_env3 body + ; (body_usg, body') <- scExpr body_env3 body -- NB: For non-recursive bindings we inherit sc_force flag from -- the parent function (see Note [Forcing specialisation]) - ; (spec_usg, specs) <- specialise env - (scu_calls body_usg) - rhs_info + ; (spec_usg, specs) <- specialise env + (scu_calls body_usg) + rhs_info (SI [] 0 (Just rhs_usg)) - ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } - `combineUsage` rhs_usg `combineUsage` spec_usg, - mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body') - } + ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } + `combineUsage` rhs_usg `combineUsage` spec_usg, + mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body') + } -- A *local* recursive group: see Note [Local recursive groups] scExpr' env (Let (Rec prs) body) - = do { let (bndrs,rhss) = unzip prs - (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + = do { let (bndrs,rhss) = unzip prs + (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun force_spec = any (forceSpecBndr env) bndrs' -- Note [Forcing specialisation] - ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; (body_usg, body') <- scExpr rhs_env2 body + ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) + ; (body_usg, body') <- scExpr rhs_env2 body - -- NB: start specLoop from body_usg - ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec) + -- NB: start specLoop from body_usg + ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec) (scu_calls body_usg) rhs_infos nullUsage - [SI [] 0 (Just usg) | usg <- rhs_usgs] - -- Do not unconditionally generate specialisations from rhs_usgs - -- Instead use them only if we find an unspecialised call - -- See Note [Local recursive groups] + [SI [] 0 (Just usg) | usg <- rhs_usgs] + -- Do not unconditionally generate specialisations from rhs_usgs + -- Instead use them only if we find an unspecialised call + -- See Note [Local recursive groups] - ; let rhs_usg = combineUsages rhs_usgs - all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg + ; let rhs_usg = combineUsages rhs_usgs + all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs)) - ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, - Let bind' body') } + ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, + Let bind' body') } \end{code} Note [Local let bindings] @@ -1130,45 +1123,45 @@ harmful. I'm not sure. \begin{code} scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) -scApp env (Var fn, args) -- Function is a variable +scApp env (Var fn, args) -- Function is a variable = ASSERT( not (null args) ) - do { args_w_usgs <- mapM (scExpr env) args - ; let (arg_usgs, args') = unzip args_w_usgs - arg_usg = combineUsages arg_usgs - ; case scSubstId env fn of - fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') - -- Do beta-reduction and try again - - Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', + do { args_w_usgs <- mapM (scExpr env) args + ; let (arg_usgs, args') = unzip args_w_usgs + arg_usg = combineUsages arg_usgs + ; case scSubstId env fn of + fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') + -- Do beta-reduction and try again + + Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', mkApps (Var fn') args') - other_fn' -> return (arg_usg, mkApps other_fn' args') } - -- NB: doing this ignores any usage info from the substituted - -- function, but I don't think that matters. If it does - -- we can fix it. + other_fn' -> return (arg_usg, mkApps other_fn' args') } + -- NB: doing this ignores any usage info from the substituted + -- function, but I don't think that matters. If it does + -- we can fix it. where doBeta :: OutExpr -> [OutExpr] -> OutExpr -- ToDo: adjust for System IF doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) - doBeta fn args = mkApps fn args + doBeta fn args = mkApps fn args --- The function is almost always a variable, but not always. +-- The function is almost always a variable, but not always. -- In particular, if this pass follows float-in, --- which it may, we can get --- (let f = ...f... in f) arg1 arg2 +-- which it may, we can get +-- (let f = ...f... in f) arg1 arg2 scApp env (other_fn, args) - = do { (fn_usg, fn') <- scExpr env other_fn - ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args - ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } + = do { (fn_usg, fn') <- scExpr env other_fn + ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args + ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } ---------------------- mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage mkVarUsage env fn args = case lookupHowBound env fn of - Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)] - , scu_occs = emptyVarEnv } - Just RecArg -> SCU { scu_calls = emptyVarEnv - , scu_occs = unitVarEnv fn arg_occ } + Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)] + , scu_occs = emptyVarEnv } + Just RecArg -> SCU { scu_calls = emptyVarEnv + , scu_occs = unitVarEnv fn arg_occ } Nothing -> nullUsage where -- I rather think we could use UnkOcc all the time @@ -1181,116 +1174,116 @@ scTopBind env (Rec prs) | Just threshold <- sc_size env , not force_spec , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) - -- No specialisation - = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs - ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss - ; return (rhs_env, Rec (bndrs' `zip` rhss')) } - | otherwise -- Do specialisation - = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun - - ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; let rhs_usg = combineUsages rhs_usgs - - ; (_, specs) <- specLoop (scForce rhs_env2 force_spec) + -- No specialisation + = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs + ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss + ; return (rhs_env, Rec (bndrs' `zip` rhss')) } + | otherwise -- Do specialisation + = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + + ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) + ; let rhs_usg = combineUsages rhs_usgs + + ; (_, specs) <- specLoop (scForce rhs_env2 force_spec) (scu_calls rhs_usg) rhs_infos nullUsage - [SI [] 0 Nothing | _ <- bndrs] + [SI [] 0 Nothing | _ <- bndrs] - ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business - Rec (concat (zipWith specInfoBinds rhs_infos specs))) } + ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business + Rec (concat (zipWith specInfoBinds rhs_infos specs))) } where (bndrs,rhss) = unzip prs force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation] scTopBind env (NonRec bndr rhs) - = do { (_, rhs') <- scExpr env rhs - ; let (env1, bndr') = extendBndr env bndr - env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs') - ; return (env2, NonRec bndr' rhs') } + = do { (_, rhs') <- scExpr env rhs + ; let (env1, bndr') = extendBndr env bndr + env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs') + ; return (env2, NonRec bndr' rhs') } ---------------------- scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo) scRecRhs env (bndr,rhs) - = do { let (arg_bndrs,body) = collectBinders rhs - (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs - ; (body_usg, body') <- scExpr body_env body - ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' - ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body') + = do { let (arg_bndrs,body) = collectBinders rhs + (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs + ; (body_usg, body') <- scExpr body_env body + ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' + ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body') arg_bndrs body arg_occs) } - -- The arg_occs says how the visible, - -- lambda-bound binders of the RHS are used - -- (including the TyVar binders) - -- Two pats are the same if they match both ways + -- The arg_occs says how the visible, + -- lambda-bound binders of the RHS are used + -- (including the TyVar binders) + -- Two pats are the same if they match both ways ---------------------- specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _) - = [(id,rhs) | OS _ _ id rhs <- specs] ++ - -- First the specialised bindings + = [(id,rhs) | OS _ _ id rhs <- specs] ++ + -- First the specialised bindings [(fn `addIdSpecialisations` rules, new_rhs)] - -- And now the original binding + -- And now the original binding where rules = [r | OS _ r _ _ <- specs] \end{code} %************************************************************************ -%* * - The specialiser itself -%* * +%* * + The specialiser itself +%* * %************************************************************************ \begin{code} -data RhsInfo = RI OutId -- The binder - OutExpr -- The new RHS - [InVar] InExpr -- The *original* RHS (\xs.body) - -- Note [Specialise original body] - [ArgOcc] -- Info on how the xs occur in body +data RhsInfo = RI OutId -- The binder + OutExpr -- The new RHS + [InVar] InExpr -- The *original* RHS (\xs.body) + -- Note [Specialise original body] + [ArgOcc] -- Info on how the xs occur in body -data SpecInfo = SI [OneSpec] -- The specialisations we have generated +data SpecInfo = SI [OneSpec] -- The specialisations we have generated - Int -- Length of specs; used for numbering them + Int -- Length of specs; used for numbering them - (Maybe ScUsage) -- Just cs => we have not yet used calls in the - -- from calls in the *original* RHS as - -- seeds for new specialisations; - -- if you decide to do so, here is the - -- RHS usage (which has not yet been - -- unleashed) - -- Nothing => we have - -- See Note [Local recursive groups] + (Maybe ScUsage) -- Just cs => we have not yet used calls in the + -- from calls in the *original* RHS as + -- seeds for new specialisations; + -- if you decide to do so, here is the + -- RHS usage (which has not yet been + -- unleashed) + -- Nothing => we have + -- See Note [Local recursive groups] - -- One specialisation: Rule plus definition -data OneSpec = OS CallPat -- Call pattern that generated this specialisation - CoreRule -- Rule connecting original id with the specialisation - OutId OutExpr -- Spec id + its rhs + -- One specialisation: Rule plus definition +data OneSpec = OS CallPat -- Call pattern that generated this specialisation + CoreRule -- Rule connecting original id with the specialisation + OutId OutExpr -- Spec id + its rhs specLoop :: ScEnv - -> CallEnv - -> [RhsInfo] - -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter - -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto... + -> CallEnv + -> [RhsInfo] + -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter + -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto... specLoop env all_calls rhs_infos usg_so_far specs_so_far - = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far - ; let (new_usg_s, all_specs) = unzip specs_w_usg - new_usg = combineUsages new_usg_s - new_calls = scu_calls new_usg - all_usg = usg_so_far `combineUsage` new_usg - ; if isEmptyVarEnv new_calls then - return (all_usg, all_specs) - else - specLoop env new_calls rhs_infos all_usg all_specs } - -specialise + = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far + ; let (new_usg_s, all_specs) = unzip specs_w_usg + new_usg = combineUsages new_usg_s + new_calls = scu_calls new_usg + all_usg = usg_so_far `combineUsage` new_usg + ; if isEmptyVarEnv new_calls then + return (all_usg, all_specs) + else + specLoop env new_calls rhs_infos all_usg all_specs } + +specialise :: ScEnv - -> CallEnv -- Info on calls + -> CallEnv -- Info on calls -> RhsInfo - -> SpecInfo -- Original RHS plus patterns dealt with - -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage + -> SpecInfo -- Original RHS plus patterns dealt with + -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage -- Note: this only generates *specialised* bindings -- The original binding is added by specInfoBinds @@ -1299,126 +1292,130 @@ specialise -- So when we make a specialised copy of the RHS, we're starting -- from an RHS whose nested functions have been optimised already. -specialise env bind_calls (RI fn _ arg_bndrs body arg_occs) +specialise env bind_calls (RI fn _ arg_bndrs body arg_occs) spec_info@(SI specs spec_count mb_unspec) | not (isBottomingId fn) -- Note [Do not specialise diverging functions] - , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation] - , notNull arg_bndrs -- Only specialise functions + , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation] + , notNull arg_bndrs -- Only specialise functions , Just all_calls <- lookupVarEnv bind_calls fn - = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls --- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns" + = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls +-- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns" -- , text "arg_occs" <+> ppr arg_occs --- , text "calls" <+> ppr all_calls --- , text "good pats" <+> ppr pats]) $ --- return () +-- , text "calls" <+> ppr all_calls +-- , text "good pats" <+> ppr pats]) $ +-- return () - -- Bale out if too many specialisations - ; let n_pats = length pats + -- Bale out if too many specialisations + ; let n_pats = length pats spec_count' = n_pats + spec_count - ; case sc_count env of - Just max | not (sc_force env) && spec_count' > max - -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for - then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125 + ; case sc_count env of + Just max | not (sc_force env) && spec_count' > max + -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for + then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125 return (nullUsage, spec_info) else return (nullUsage, spec_info) - where - msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn) - , nest 2 (ptext (sLit "has") <+> + where + msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn) + , nest 2 (ptext (sLit "has") <+> speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+> ptext (sLit "but the limit is") <+> int max) ] - , ptext (sLit "Use -fspec-constr-count=n to set the bound") - , extra ] - extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations") - | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs]) + , ptext (sLit "Use -fspec-constr-count=n to set the bound") + , extra ] + extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations") + | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs]) - _normal_case -> do { + _normal_case -> do { let spec_env = decreaseSpecCount env n_pats - ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) - (pats `zip` [spec_count..]) - -- See Note [Specialise original body] - - ; let spec_usg = combineUsages spec_usgs - (new_usg, mb_unspec') - = case mb_unspec of - Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) - _ -> (spec_usg, mb_unspec) - - ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } } + ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) + (pats `zip` [spec_count..]) + -- See Note [Specialise original body] + + ; let spec_usg = combineUsages spec_usgs + (new_usg, mb_unspec') + = case mb_unspec of + Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) + _ -> (spec_usg, mb_unspec) + + ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } } | otherwise - = return (nullUsage, spec_info) -- The boring case + = return (nullUsage, spec_info) -- The boring case --------------------- spec_one :: ScEnv - -> OutId -- Function - -> [InVar] -- Lambda-binders of RHS; should match patterns - -> InExpr -- Body of the original function - -> (CallPat, Int) - -> UniqSM (ScUsage, OneSpec) -- Rule and binding + -> OutId -- Function + -> [InVar] -- Lambda-binders of RHS; should match patterns + -> InExpr -- Body of the original function + -> (CallPat, Int) + -> UniqSM (ScUsage, OneSpec) -- Rule and binding -- spec_one creates a specialised copy of the function, together -- with a rule for using it. I'm very proud of how short this -- function is, considering what it does :-). -{- +{- Example - - In-scope: a, x::a + + In-scope: a, x::a f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))... - [c::*, v::(b,c) are presumably bound by the (...) part] + [c::*, v::(b,c) are presumably bound by the (...) part] ==> f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] -> - (...entire body of f...) [b -> (b,c), - y -> ((:) (a,(b,c)) (x,v) hw)] - - RULE: forall b::* c::*, -- Note, *not* forall a, x - v::(b,c), - hw::[(a,(b,c))] . - - f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw + (...entire body of f...) [b -> (b,c), + y -> ((:) (a,(b,c)) (x,v) hw)] + + RULE: forall b::* c::*, -- Note, *not* forall a, x + v::(b,c), + hw::[(a,(b,c))] . + + f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw -} spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) - = do { spec_uniq <- getUniqueUs + = do { spec_uniq <- getUniqueUs ; let spec_env = extendScSubstList (extendScInScope env qvars) - (arg_bndrs `zip` pats) - fn_name = idName fn - fn_loc = nameSrcSpan fn_name - spec_occ = mkSpecOcc (nameOccName fn_name) - dflags = sc_dflags env - rule_name = mkFastString ("SC:" ++ showSDoc dflags (ppr fn <> int rule_number)) - spec_name = mkInternalName spec_uniq spec_occ fn_loc --- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ --- return () - - -- Specialise the body - ; (spec_usg, spec_body) <- scExpr spec_env body - --- ; pprTrace "done spec_one}" (ppr fn) $ --- return () - - -- And build the results - ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) - `setIdStrictness` spec_str -- See Note [Transfer strictness] - `setIdArity` count isId spec_lam_args - spec_str = calcSpecStrictness fn spec_lam_args pats - (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty - -- Usual w/w hack to avoid generating - -- a spec_rhs of unlifted type and no args + (arg_bndrs `zip` pats) + fn_name = idName fn + fn_loc = nameSrcSpan fn_name + fn_occ = nameOccName fn_name + spec_occ = mkSpecOcc fn_occ + -- We use fn_occ rather than fn in the rule_name string + -- as we don't want the uniq to end up in the rule, and + -- hence in the ABI, as that can cause spurious ABI + -- changes (#4012). + rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) + spec_name = mkInternalName spec_uniq spec_occ fn_loc +-- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ +-- return () + + -- Specialise the body + ; (spec_usg, spec_body) <- scExpr spec_env body + +-- ; pprTrace "done spec_one}" (ppr fn) $ +-- return () + + -- And build the results + ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) + `setIdStrictness` spec_str -- See Note [Transfer strictness] + `setIdArity` count isId spec_lam_args + spec_str = calcSpecStrictness fn spec_lam_args pats + (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty + -- Usual w/w hack to avoid generating + -- a spec_rhs of unlifted type and no args spec_rhs = mkLams spec_lam_args spec_body - body_ty = exprType spec_body - rule_rhs = mkVarApps (Var spec_id) spec_call_args + body_ty = exprType spec_body + rule_rhs = mkVarApps (Var spec_id) spec_call_args inline_act = idInlineActivation fn - rule = mkRule True {- Auto -} True {- Local -} + rule = mkRule True {- Auto -} True {- Local -} rule_name inline_act fn_name qvars pats rule_rhs - -- See Note [Transfer activation] - ; return (spec_usg, OS call_pat rule spec_id spec_rhs) } + -- See Note [Transfer activation] + ; return (spec_usg, OS call_pat rule spec_id spec_rhs) } -calcSpecStrictness :: Id -- The original function +calcSpecStrictness :: Id -- The original function -> [Var] -> [CoreExpr] -- Call pattern - -> StrictSig -- Strictness of specialised thing + -> StrictSig -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats = StrictSig (mkTopDmdType spec_dmds TopRes) @@ -1435,8 +1432,8 @@ calcSpecStrictness fn qvars pats go_one env d (Var v) = extendVarEnv_C both env v d go_one env (Box d) e = go_one env d e - go_one env (Eval (Prod ds)) e - | (Var _, args) <- collectArgs e = go env ds args + go_one env (Eval (Prod ds)) e + | (Var _, args) <- collectArgs e = go env ds args go_one env _ _ = env \end{code} @@ -1477,7 +1474,7 @@ the specialised one. Suppose, for example and a RULE f (a:as) b = f_spec a as b Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need -when calling f_spec instead of call-by-value. And that can result in +when calling f_spec instead of call-by-value. And that can result in unbounded worsening in space (cf the classic foldl vs foldl') See Trac #3437 for a good example. @@ -1486,9 +1483,9 @@ The function calcSpecStrictness performs the calculation. %************************************************************************ -%* * +%* * \subsection{Argument analysis} -%* * +%* * %************************************************************************ This code deals with analysing call-site arguments to see whether @@ -1501,63 +1498,63 @@ we quantify over. Clearly over 'a' and 'x', but what about any type variables free in x's type? In fact we don't need to worry about them because (f @a) can only be a well-typed application if its type is compatible with x, so any variables free in x's type must be free in (f @a), and hence either be gathered -via 'a' itself, or be in scope at f's defn. Hence we just take +via 'a' itself, or be in scope at f's defn. Hence we just take (exprsFreeVars pats). -BUT phantom type synonyms can mess this reasoning up, +BUT phantom type synonyms can mess this reasoning up, eg x::T b with type T b = Int -So we apply expandTypeSynonyms to the bound Ids. +So we apply expandTypeSynonyms to the bound Ids. See Trac # 5458. Yuk. \begin{code} -type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments +type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat]) - -- Result has no duplicate patterns, - -- nor ones mentioned in done_pats - -- Bool indicates that there was at least one boring pattern + -- Result has no duplicate patterns, + -- nor ones mentioned in done_pats + -- Bool indicates that there was at least one boring pattern callsToPats env done_specs bndr_occs calls - = do { mb_pats <- mapM (callToPats env bndr_occs) calls + = do { mb_pats <- mapM (callToPats env bndr_occs) calls - ; let good_pats :: [CallPat] - good_pats = catMaybes mb_pats - done_pats = [p | OS p _ _ _ <- done_specs] - is_done p = any (samePat p) done_pats + ; let good_pats :: [CallPat] + good_pats = catMaybes mb_pats + done_pats = [p | OS p _ _ _ <- done_specs] + is_done p = any (samePat p) done_pats - ; return (any isNothing mb_pats, - filterOut is_done (nubBy samePat good_pats)) } + ; return (any isNothing mb_pats, + filterOut is_done (nubBy samePat good_pats)) } callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) - -- The [Var] is the variables to quantify over in the rule - -- Type variables come first, since they may scope - -- over the following term variables - -- The [CoreExpr] are the argument patterns for the rule + -- The [Var] is the variables to quantify over in the rule + -- Type variables come first, since they may scope + -- over the following term variables + -- The [CoreExpr] are the argument patterns for the rule callToPats env bndr_occs (con_env, args) - | length args < length bndr_occs -- Check saturated + | length args < length bndr_occs -- Check saturated = return Nothing | otherwise - = do { let in_scope = substInScope (sc_subst env) - ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs - ; let pat_fvs = varSetElems (exprsFreeVars pats) - in_scope_vars = getInScopeVars in_scope - qvars = filterOut (`elemVarSet` in_scope_vars) pat_fvs - -- Quantify over variables that are not in sccpe - -- at the call site - -- See Note [Free type variables of the qvar types] - -- See Note [Shadowing] at the top - - (tvs, ids) = partition isTyVar qvars - qvars' = tvs ++ map sanitise ids - -- Put the type variables first; the type of a term - -- variable may mention a type variable - - sanitise id = id `setIdType` expandTypeSynonyms (idType id) - -- See Note [Free type variables of the qvar types] - - ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $ - if interesting - then return (Just (qvars', pats)) - else return Nothing } + = do { let in_scope = substInScope (sc_subst env) + ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs + ; let pat_fvs = varSetElems (exprsFreeVars pats) + in_scope_vars = getInScopeVars in_scope + qvars = filterOut (`elemVarSet` in_scope_vars) pat_fvs + -- Quantify over variables that are not in sccpe + -- at the call site + -- See Note [Free type variables of the qvar types] + -- See Note [Shadowing] at the top + + (tvs, ids) = partition isTyVar qvars + qvars' = tvs ++ map sanitise ids + -- Put the type variables first; the type of a term + -- variable may mention a type variable + + sanitise id = id `setIdType` expandTypeSynonyms (idType id) + -- See Note [Free type variables of the qvar types] + + ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $ + if interesting + then return (Just (qvars', pats)) + else return Nothing } -- argToPat takes an actual argument, and returns an abstracted -- version, consisting of just the "constructor skeleton" of the @@ -1566,45 +1563,45 @@ callToPats env bndr_occs (con_env, args) -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) argToPat :: ScEnv - -> InScopeSet -- What's in scope at the fn defn site - -> ValueEnv -- ValueEnv at the call site - -> CoreArg -- A call arg (or component thereof) - -> ArgOcc - -> UniqSM (Bool, CoreArg) + -> InScopeSet -- What's in scope at the fn defn site + -> ValueEnv -- ValueEnv at the call site + -> CoreArg -- A call arg (or component thereof) + -> ArgOcc + -> UniqSM (Bool, CoreArg) --- Returns (interesting, pat), +-- Returns (interesting, pat), -- where pat is the pattern derived from the argument --- interesting=True if the pattern is non-trivial (not a variable or type) --- E.g. x:xs --> (True, x:xs) --- f xs --> (False, w) where w is a fresh wildcard --- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard --- \x. x+y --> (True, \x. x+y) --- lvl7 --> (True, lvl7) if lvl7 is bound --- somewhere further out +-- interesting=True if the pattern is non-trivial (not a variable or type) +-- E.g. x:xs --> (True, x:xs) +-- f xs --> (False, w) where w is a fresh wildcard +-- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard +-- \x. x+y --> (True, \x. x+y) +-- lvl7 --> (True, lvl7) if lvl7 is bound +-- somewhere further out argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ = return (False, arg) - + argToPat env in_scope val_env (Tick _ arg) arg_occ = argToPat env in_scope val_env arg arg_occ - -- Note [Notes in call patterns] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Ignore Notes. In particular, we want to ignore any InlineMe notes - -- Perhaps we should not ignore profiling notes, but I'm going to - -- ride roughshod over them all for now. - --- See Note [Notes in RULE matching] in Rules + -- Note [Notes in call patterns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Ignore Notes. In particular, we want to ignore any InlineMe notes + -- Perhaps we should not ignore profiling notes, but I'm going to + -- ride roughshod over them all for now. + --- See Note [Notes in RULE matching] in Rules argToPat env in_scope val_env (Let _ arg) arg_occ = argToPat env in_scope val_env arg arg_occ - -- See Note [Matching lets] in Rule.lhs - -- Look through let expressions - -- e.g. f (let v = rhs in (v,w)) - -- Here we can specialise for f (v,w) - -- because the rule-matcher will look through the let. + -- See Note [Matching lets] in Rule.lhs + -- Look through let expressions + -- e.g. f (let v = rhs in (v,w)) + -- Here we can specialise for f (v,w) + -- because the rule-matcher will look through the let. {- Disabled; see Note [Matching cases] in Rule.lhs argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ - | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs + | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs = argToPat env in_scope val_env rhs arg_occ -} @@ -1613,29 +1610,29 @@ argToPat env in_scope val_env (Cast arg co) arg_occ -- can lead to identity coercions = argToPat env in_scope val_env arg arg_occ | not (ignoreType env ty2) - = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ - ; if not interesting then - wildCardPat ty2 - else do - { -- Make a wild-card pattern for the coercion - uniq <- getUniqueUs - ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType ty1 ty2) - ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } + = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ + ; if not interesting then + wildCardPat ty2 + else do + { -- Make a wild-card pattern for the coercion + uniq <- getUniqueUs + ; let co_name = mkSysTvName uniq (fsLit "sg") + co_var = mkCoVar co_name (mkCoercionType ty1 ty2) + ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } where Pair ty1 ty2 = coercionKind co - -{- Disabling lambda specialisation for now - It's fragile, and the spec_loop can be infinite + +{- Disabling lambda specialisation for now + It's fragile, and the spec_loop can be infinite argToPat in_scope val_env arg arg_occ | is_value_lam arg = return (True, arg) where - is_value_lam (Lam v e) -- Spot a value lambda, even if - | isId v = True -- it is inside a type lambda - | otherwise = is_value_lam e + is_value_lam (Lam v e) -- Spot a value lambda, even if + | isId v = True -- it is inside a type lambda + | otherwise = is_value_lam e is_value_lam other = False -} @@ -1645,21 +1642,21 @@ argToPat env in_scope val_env arg arg_occ | Just (ConVal (DataAlt dc) args) <- isValue val_env arg , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc - = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args + = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs - ; return (True, + ; return (True, mkConApp dc (ty_args ++ args')) } where mb_scrut dc = case arg_occ of - ScrutOcc bs + ScrutOcc bs | Just occs <- lookupUFM bs dc -> Just (occs) -- See Note [Reboxing] _other | sc_force env -> Just (repeat UnkOcc) | otherwise -> Nothing - -- Check if the argument is a variable that - -- (a) is used in an interesting way in the body - -- (b) we know what its value is + -- Check if the argument is a variable that + -- (a) is used in an interesting way in the body + -- (b) we know what its value is -- In that case it counts as "interesting" argToPat env in_scope val_env (Var v) arg_occ | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) @@ -1667,30 +1664,30 @@ argToPat env in_scope val_env (Var v) arg_occ not (ignoreType env (varType v)) = return (True, Var v) where - is_value - | isLocalId v = v `elemInScopeSet` in_scope - && isJust (lookupVarEnv val_env v) - -- Local variables have values in val_env - | otherwise = isValueUnfolding (idUnfolding v) - -- Imports have unfoldings - --- I'm really not sure what this comment means --- And by not wild-carding we tend to get forall'd --- variables that are in soope, which in turn can --- expose the weakness in let-matching --- See Note [Matching lets] in Rules - - -- Check for a variable bound inside the function. + is_value + | isLocalId v = v `elemInScopeSet` in_scope + && isJust (lookupVarEnv val_env v) + -- Local variables have values in val_env + | otherwise = isValueUnfolding (idUnfolding v) + -- Imports have unfoldings + +-- I'm really not sure what this comment means +-- And by not wild-carding we tend to get forall'd +-- variables that are in soope, which in turn can +-- expose the weakness in let-matching +-- See Note [Matching lets] in Rules + + -- Check for a variable bound inside the function. -- Don't make a wild-card, because we may usefully share - -- e.g. f a = let x = ... in f (x,x) + -- e.g. f a = let x = ... in f (x,x) -- NB: this case follows the lambda and con-app cases!! -- argToPat _in_scope _val_env (Var v) _arg_occ -- = return (False, Var v) - -- SLPJ : disabling this to avoid proliferation of versions - -- also works badly when thinking about seeding the loop - -- from the body of the let - -- f x y = letrec g z = ... in g (x,y) - -- We don't want to specialise for that *particular* x,y + -- SLPJ : disabling this to avoid proliferation of versions + -- also works badly when thinking about seeding the loop + -- from the body of the let + -- f x y = letrec g z = ... in g (x,y) + -- We don't want to specialise for that *particular* x,y -- The default case: make a wild-card -- We use this for coercions too @@ -1704,8 +1701,8 @@ wildCardPat ty ; return (False, varToCoreExpr id) } argsToPats :: ScEnv -> InScopeSet -> ValueEnv - -> [CoreArg] -> [ArgOcc] -- Should be same length - -> UniqSM (Bool, [CoreArg]) + -> [CoreArg] -> [ArgOcc] -- Should be same length + -> UniqSM (Bool, [CoreArg]) argsToPats env in_scope val_env args occs = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs ; let (interesting_s, args') = unzip stuff @@ -1721,37 +1718,37 @@ isValue _env (Lit lit) isValue env (Var v) | Just stuff <- lookupVarEnv env v - = Just stuff -- You might think we could look in the idUnfolding here - -- but that doesn't take account of which branch of a - -- case we are in, which is the whole point + = Just stuff -- You might think we could look in the idUnfolding here + -- but that doesn't take account of which branch of a + -- case we are in, which is the whole point | not (isLocalId v) && isCheapUnfolding unf = isValue env (unfoldingTemplate unf) where unf = idUnfolding v - -- However we do want to consult the unfolding - -- as well, for let-bound constructors! + -- However we do want to consult the unfolding + -- as well, for let-bound constructors! isValue env (Lam b e) | isTyVar b = case isValue env e of - Just _ -> Just LambdaVal - Nothing -> Nothing + Just _ -> Just LambdaVal + Nothing -> Nothing | otherwise = Just LambdaVal -isValue _env expr -- Maybe it's a constructor application +isValue _env expr -- Maybe it's a constructor application | (Var fun, args) <- collectArgs expr = case isDataConWorkId_maybe fun of - Just con | args `lengthAtLeast` dataConRepArity con - -- Check saturated; might be > because the - -- arity excludes type args - -> Just (ConVal (DataAlt con) args) + Just con | args `lengthAtLeast` dataConRepArity con + -- Check saturated; might be > because the + -- arity excludes type args + -> Just (ConVal (DataAlt con) args) - _other | valArgCount args < idArity fun - -- Under-applied function - -> Just LambdaVal -- Partial application + _other | valArgCount args < idArity fun + -- Under-applied function + -> Just LambdaVal -- Partial application - _other -> Nothing + _other -> Nothing isValue _env _expr = Nothing @@ -1759,27 +1756,27 @@ samePat :: CallPat -> CallPat -> Bool samePat (vs1, as1) (vs2, as2) = all2 same as1 as2 where - same (Var v1) (Var v2) - | v1 `elem` vs1 = v2 `elem` vs2 - | v2 `elem` vs2 = False - | otherwise = v1 == v2 + same (Var v1) (Var v2) + | v1 `elem` vs1 = v2 `elem` vs2 + | v2 `elem` vs2 = False + | otherwise = v1 == v2 same (Lit l1) (Lit l2) = l1==l2 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 - same (Type {}) (Type {}) = True -- Note [Ignore type differences] + same (Type {}) (Type {}) = True -- Note [Ignore type differences] same (Coercion {}) (Coercion {}) = True same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes - same (Cast e1 _) e2 = same e1 e2 + same (Cast e1 _) e2 = same e1 e2 same e1 (Tick _ e2) = same e1 e2 same e1 (Cast e2 _) = same e1 e2 - same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) - False -- Let, lambda, case should not occur + same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) + False -- Let, lambda, case should not occur bad (Case {}) = True bad (Let {}) = True bad (Lam {}) = True - bad _other = False + bad _other = False \end{code} Note [Ignore type differences] @@ -1787,6 +1784,6 @@ Note [Ignore type differences] We do not want to generate specialisations where the call patterns differ only in their type arguments! Not only is it utterly useless, but it also means that (with polymorphic recursion) we can generate -an infinite number of specialisations. Example is Data.Sequence.adjustTree, +an infinite number of specialisations. Example is Data.Sequence.adjustTree, I think. diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index a63471011f..f0394c8762 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -32,6 +32,7 @@ import TysPrim import Id import Var import VarSet +import Module import Name import NameSet import NameEnv diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index f3fc936996..aa39673224 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -50,7 +50,8 @@ module TcEnv( -- New Ids newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName, - mkStableIdFromString, mkStableIdFromName + mkStableIdFromString, mkStableIdFromName, + mkWrapperName ) where #include "HsVersions.h" @@ -80,10 +81,15 @@ import HscTypes import DynFlags import SrcLoc import BasicTypes +import Module import Outputable +import Encoding import FastString import ListSetOps import Util + +import Data.IORef +import Data.List \end{code} @@ -750,7 +756,8 @@ mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM mkStableIdFromString str sig_ty loc occ_wrapper = do uniq <- newUnique mod <- getModule - let occ = mkVarOcc (str ++ '_' : show uniq) :: OccName + name <- mkWrapperName "stable" str + let occ = mkVarOccFS name :: OccName gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name id = mkExportedLocalId gnm sig_ty :: Id return id @@ -759,6 +766,21 @@ mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcI mkStableIdFromName nm = mkStableIdFromString (getOccString nm) \end{code} +\begin{code} +mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) + => String -> String -> m FastString +mkWrapperName what nameBase + = do dflags <- getDynFlags + thisMod <- getModule + let wrapperRef = nextWrapperNum dflags + pkg = packageIdString (modulePackageId thisMod) + mod = moduleNameString (moduleName thisMod) + wrapperNum <- liftIO $ readIORef wrapperRef + liftIO $ writeIORef wrapperRef (wrapperNum + 1) + let components = [what, show wrapperNum, pkg, mod, nameBase] + return $ mkFastString $ zEncodeString $ intercalate ":" components +\end{code} + %************************************************************************ %* * \subsection{Errors} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ee337c4d51..d866893545 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -480,9 +480,6 @@ dumpOptTcRn flag doc = whenDOptM flag (dumpTcRn doc) %************************************************************************ \begin{code} -getModule :: TcRn Module -getModule = do { env <- getGblEnv; return (tcg_mod env) } - setModule :: Module -> TcRn a -> TcRn a setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 9c5249a615..e6d2013ff2 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -16,59 +16,52 @@ For state that is global and should be returned at the end (e.g not part of the stack mechanism), you should use an TcRef (= IORef) to store them. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcRnTypes( - TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module - TcRef, + TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module + TcRef, - -- The environment types - Env(..), - TcGblEnv(..), TcLclEnv(..), - IfGblEnv(..), IfLclEnv(..), + -- The environment types + Env(..), + TcGblEnv(..), TcLclEnv(..), + IfGblEnv(..), IfLclEnv(..), - -- Ranamer types - ErrCtxt, RecFieldEnv(..), - ImportAvails(..), emptyImportAvails, plusImportAvails, - WhereFrom(..), mkModDeps, + -- Ranamer types + ErrCtxt, RecFieldEnv(..), + ImportAvails(..), emptyImportAvails, plusImportAvails, + WhereFrom(..), mkModDeps, - -- Typechecker types - TcTypeEnv, TcIdBinder(..), TcTyThing(..), PromotionErr(..), + -- Typechecker types + TcTypeEnv, TcIdBinder(..), TcTyThing(..), PromotionErr(..), pprTcTyThingCategory, pprPECategory, - -- Template Haskell - ThStage(..), topStage, topAnnStage, topSpliceStage, - ThLevel, impLevel, outerLevel, thLevel, + -- Template Haskell + ThStage(..), topStage, topAnnStage, topSpliceStage, + ThLevel, impLevel, outerLevel, thLevel, - -- Arrows - ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, + -- Arrows + ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, - -- Canonical constraints + -- Canonical constraints Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, dropDerivedWC, singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan, isCDictCan_Maybe, isCFunEqCan_Maybe, - isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, + isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt, isHoleCt, ctEvidence, SubGoalDepth, mkNonCanonical, mkNonCanonicalCt, - ctPred, ctEvPred, ctEvTerm, ctEvId, + ctPred, ctEvPred, ctEvTerm, ctEvId, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols, Implication(..), - CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, + CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, ctLocDepth, bumpCtLocDepth, setCtLocOrigin, setCtLocEnv, - CtOrigin(..), + CtOrigin(..), pushErrCtxt, pushErrCtxtSameOrigin, - SkolemInfo(..), + SkolemInfo(..), CtEvidence(..), mkGivenLoc, @@ -76,14 +69,14 @@ module TcRnTypes( isDerived, canSolve, canRewrite, CtFlavour(..), ctEvFlavour, ctFlavour, - -- Pretty printing + -- Pretty printing pprEvVarTheta, pprWantedsWithLocs, - pprEvVars, pprEvVarWithType, + pprEvVars, pprEvVarWithType, pprArising, pprArisingAt, - -- Misc other types - TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds - + -- Misc other types + TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds + ) where #include "HsVersions.h" @@ -125,28 +118,28 @@ import Data.Set (Set) %************************************************************************ -%* * - Standard monad definition for TcRn +%* * + Standard monad definition for TcRn All the combinators for the monad can be found in TcRnMonad -%* * +%* * %************************************************************************ The monad itself has to be defined here, because it is mentioned by ErrCtxt \begin{code} -type TcRef a = IORef a -type TcId = Id -type TcIdSet = IdSet +type TcRef a = IORef a +type TcId = Id +type TcIdSet = IdSet type TcRnIf a b c = IOEnv (Env a b) c -type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff +type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff -type IfG a = IfM () a -- Top level -type IfL a = IfM IfLclEnv a -- Nested +type IfG a = IfM () a -- Top level +type IfL a = IfM IfLclEnv a -- Nested type TcRn a = TcRnIf TcGblEnv TcLclEnv a -type RnM a = TcRn a -- Historical -type TcM a = TcRn a -- Historical +type RnM a = TcRn a -- Historical +type TcM a = TcRn a -- Historical \end{code} Representation of type bindings to uninstantiated meta variables used during @@ -183,13 +176,16 @@ data Env gbl lcl env_gbl :: gbl, -- Info about things defined at the top level -- of the module being compiled - env_lcl :: lcl -- Nested stuff; changes as we go into + env_lcl :: lcl -- Nested stuff; changes as we go into } instance ContainsDynFlags (Env gbl lcl) where extractDynFlags env = hsc_dflags (env_top env) --- TcGblEnv describes the top-level of the module at the +instance ContainsModule gbl => ContainsModule (Env gbl lcl) where + extractModule env = extractModule (env_gbl env) + +-- TcGblEnv describes the top-level of the module at the -- point at which the typechecker is finished work. -- It is this structure that is handed on to the desugarer -- For state that needs to be updated during the typechecking @@ -197,47 +193,47 @@ instance ContainsDynFlags (Env gbl lcl) where data TcGblEnv = TcGblEnv { - tcg_mod :: Module, -- ^ Module being compiled - tcg_src :: HscSource, + tcg_mod :: Module, -- ^ Module being compiled + tcg_src :: HscSource, -- ^ What kind of module (regular Haskell, hs-boot, ext-core) - tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming - tcg_default :: Maybe [Type], + tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming + tcg_default :: Maybe [Type], -- ^ Types used for defaulting. @Nothing@ => no @default@ decl - tcg_fix_env :: FixityEnv, -- ^ Just for things in this module - tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module + tcg_fix_env :: FixityEnv, -- ^ Just for things in this module + tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module - tcg_type_env :: TypeEnv, + tcg_type_env :: TypeEnv, -- ^ Global type env for the module we are compiling now. All - -- TyCons and Classes (for this module) end up in here right away, - -- along with their derived constructors, selectors. - -- - -- (Ids defined in this module start in the local envt, though they - -- move to the global envt during zonking) - - tcg_type_env_var :: TcRef TypeEnv, - -- Used only to initialise the interface-file - -- typechecker in initIfaceTcRn, so that it can see stuff - -- bound in this module when dealing with hi-boot recursions - -- Updated at intervals (e.g. after dealing with types and classes) - - tcg_inst_env :: InstEnv, - -- ^ Instance envt for all /home-package/ modules; + -- TyCons and Classes (for this module) end up in here right away, + -- along with their derived constructors, selectors. + -- + -- (Ids defined in this module start in the local envt, though they + -- move to the global envt during zonking) + + tcg_type_env_var :: TcRef TypeEnv, + -- Used only to initialise the interface-file + -- typechecker in initIfaceTcRn, so that it can see stuff + -- bound in this module when dealing with hi-boot recursions + -- Updated at intervals (e.g. after dealing with types and classes) + + tcg_inst_env :: InstEnv, + -- ^ Instance envt for all /home-package/ modules; -- Includes the dfuns in tcg_insts - tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances - - -- Now a bunch of things about this module that are simply - -- accumulated, but never consulted until the end. - -- Nevertheless, it's convenient to accumulate them along - -- with the rest of the info from this module. - tcg_exports :: [AvailInfo], -- ^ What is exported - tcg_imports :: ImportAvails, + tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances + + -- Now a bunch of things about this module that are simply + -- accumulated, but never consulted until the end. + -- Nevertheless, it's convenient to accumulate them along + -- with the rest of the info from this module. + tcg_exports :: [AvailInfo], -- ^ What is exported + tcg_imports :: ImportAvails, -- ^ Information about what was imported from where, including - -- things bound in this module. Also store Safe Haskell info + -- things bound in this module. Also store Safe Haskell info -- here about transative trusted packaage requirements. - tcg_dus :: DefUses, + tcg_dus :: DefUses, -- ^ What is defined in this module and what is used. -- The latter is used to generate -- @@ -246,7 +242,7 @@ data TcGblEnv -- -- (b) unused-import info - tcg_keep :: TcRef NameSet, + tcg_keep :: TcRef NameSet, -- ^ Locally-defined top-level names to keep alive. -- -- "Keep alive" means give them an Exported flag, so that the @@ -279,42 +275,42 @@ data TcGblEnv -- -- Splices disable recompilation avoidance (see #481) - tcg_dfun_n :: TcRef OccSet, + tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. - -- The next fields accumulate the payload of the module - -- The binds, rules and foreign-decl fiels are collected - -- initially in un-zonked form and are finally zonked in tcRnSrcDecls + -- The next fields accumulate the payload of the module + -- The binds, rules and foreign-decl fiels are collected + -- initially in un-zonked form and are finally zonked in tcRnSrcDecls tcg_rn_exports :: Maybe [Located (IE Name)], tcg_rn_imports :: [LImportDecl Name], - -- Keep the renamed imports regardless. They are not - -- voluminous and are needed if you want to report unused imports + -- Keep the renamed imports regardless. They are not + -- voluminous and are needed if you want to report unused imports tcg_used_rdrnames :: TcRef (Set RdrName), - -- The set of used *imported* (not locally-defined) RdrNames - -- Used only to report unused import declarations + -- The set of used *imported* (not locally-defined) RdrNames + -- Used only to report unused import declarations - tcg_rn_decls :: Maybe (HsGroup Name), + tcg_rn_decls :: Maybe (HsGroup Name), -- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed -- decls. tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile - tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings - tcg_binds :: LHsBinds Id, -- Value bindings in this module - tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature + tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings + tcg_binds :: LHsBinds Id, -- Value bindings in this module + tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids - tcg_warns :: Warnings, -- ...Warnings and deprecations - tcg_anns :: [Annotation], -- ...Annotations + tcg_warns :: Warnings, -- ...Warnings and deprecations + tcg_anns :: [Annotation], -- ...Annotations tcg_tcs :: [TyCon], -- ...TyCons and Classes - tcg_insts :: [ClsInst], -- ...Instances + tcg_insts :: [ClsInst], -- ...Instances tcg_fam_insts :: [FamInst], -- ...Family instances tcg_rules :: [LRuleDecl Id], -- ...Rules tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations - tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs + tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the -- prog uses hpc instrumentation. @@ -326,122 +322,125 @@ data TcGblEnv -- as -XSafe (Safe Haskell) } -data RecFieldEnv - = RecFields (NameEnv [Name]) -- Maps a constructor name *in this module* - -- to the fields for that constructor - NameSet -- Set of all fields declared *in this module*; - -- used to suppress name-shadowing complaints - -- when using record wild cards - -- E.g. let fld = e in C {..} - -- This is used when dealing with ".." notation in record - -- construction and pattern matching. - -- The FieldEnv deals *only* with constructors defined in *this* - -- module. For imported modules, we get the same info from the - -- TypeEnv +instance ContainsModule TcGblEnv where + extractModule env = tcg_mod env + +data RecFieldEnv + = RecFields (NameEnv [Name]) -- Maps a constructor name *in this module* + -- to the fields for that constructor + NameSet -- Set of all fields declared *in this module*; + -- used to suppress name-shadowing complaints + -- when using record wild cards + -- E.g. let fld = e in C {..} + -- This is used when dealing with ".." notation in record + -- construction and pattern matching. + -- The FieldEnv deals *only* with constructors defined in *this* + -- module. For imported modules, we get the same info from the + -- TypeEnv \end{code} %************************************************************************ -%* * - The interface environments - Used when dealing with IfaceDecls -%* * +%* * + The interface environments + Used when dealing with IfaceDecls +%* * %************************************************************************ \begin{code} -data IfGblEnv +data IfGblEnv = IfGblEnv { - -- The type environment for the module being compiled, - -- in case the interface refers back to it via a reference that - -- was originally a hi-boot file. - -- We need the module name so we can test when it's appropriate - -- to look in this env. - if_rec_types :: Maybe (Module, IfG TypeEnv) - -- Allows a read effect, so it can be in a mutable - -- variable; c.f. handling the external package type env - -- Nothing => interactive stuff, no loops possible + -- The type environment for the module being compiled, + -- in case the interface refers back to it via a reference that + -- was originally a hi-boot file. + -- We need the module name so we can test when it's appropriate + -- to look in this env. + if_rec_types :: Maybe (Module, IfG TypeEnv) + -- Allows a read effect, so it can be in a mutable + -- variable; c.f. handling the external package type env + -- Nothing => interactive stuff, no loops possible } data IfLclEnv = IfLclEnv { - -- The module for the current IfaceDecl - -- So if we see f = \x -> x - -- it means M.f = \x -> x, where M is the if_mod - if_mod :: Module, - - -- The field is used only for error reporting - -- if (say) there's a Lint error in it - if_loc :: SDoc, - -- Where the interface came from: - -- .hi file, or GHCi state, or ext core - -- plus which bit is currently being examined - - if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings - -- (and coercions) - if_id_env :: UniqFM Id -- Nested id binding + -- The module for the current IfaceDecl + -- So if we see f = \x -> x + -- it means M.f = \x -> x, where M is the if_mod + if_mod :: Module, + + -- The field is used only for error reporting + -- if (say) there's a Lint error in it + if_loc :: SDoc, + -- Where the interface came from: + -- .hi file, or GHCi state, or ext core + -- plus which bit is currently being examined + + if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings + -- (and coercions) + if_id_env :: UniqFM Id -- Nested id binding } \end{code} %************************************************************************ -%* * - The local typechecker environment -%* * +%* * + The local typechecker environment +%* * %************************************************************************ The Global-Env/Local-Env story ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During type checking, we keep in the tcg_type_env - * All types and classes - * All Ids derived from types and classes (constructors, selectors) + * All types and classes + * All Ids derived from types and classes (constructors, selectors) At the end of type checking, we zonk the local bindings, and as we do so we add to the tcg_type_env - * Locally defined top-level Ids + * Locally defined top-level Ids Why? Because they are now Ids not TcIds. This final GlobalEnv is - a) fed back (via the knot) to typechecking the - unfoldings of interface signatures - b) used in the ModDetails of this module + a) fed back (via the knot) to typechecking the + unfoldings of interface signatures + b) used in the ModDetails of this module \begin{code} -data TcLclEnv -- Changes as we move inside an expression - -- Discarded after typecheck/rename; not passed on to desugarer +data TcLclEnv -- Changes as we move inside an expression + -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { - tcl_loc :: SrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_untch :: Untouchables, -- Birthplace for new unification variables - tcl_th_ctxt :: ThStage, -- Template Haskell context - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context - - tcl_rdr :: LocalRdrEnv, -- Local name envt - -- Maintained during renaming, of course, but also during - -- type checking, solely so that when renaming a Template-Haskell - -- splice we have the right environment for the renamer. - -- - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence contructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - tcl_env :: TcTypeEnv, -- The local type environment: - -- Ids and TyVars defined in this module + tcl_loc :: SrcSpan, -- Source span + tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top + tcl_untch :: Untouchables, -- Birthplace for new unification variables + tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + + tcl_rdr :: LocalRdrEnv, -- Local name envt + -- Maintained during renaming, of course, but also during + -- type checking, solely so that when renaming a Template-Haskell + -- splice we have the right environment for the renamer. + -- + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence contructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + + tcl_env :: TcTypeEnv, -- The local type environment: + -- Ids and TyVars defined in this module tcl_bndrs :: [TcIdBinder], -- Stack of locally-bound Ids, innermost on top -- Used only for error reporting tcl_tidy :: TidyEnv, -- Used for tidying types; contains all -- in-scope type variables (but not term variables) - - tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" - -- Namely, the in-scope TyVars bound in tcl_env, - -- plus the tyvars mentioned in the types of Ids bound - -- in tcl_lenv. + + tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" + -- Namely, the in-scope TyVars bound in tcl_env, + -- plus the tyvars mentioned in the types of Ids bound + -- in tcl_lenv. -- Why mutable? see notes with tcGetGlobalTyVars - tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef Messages -- Place to accumulate errors + tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints + tcl_errs :: TcRef Messages -- Place to accumulate errors } type TcTypeEnv = NameEnv TcTyThing @@ -449,35 +448,35 @@ data TcIdBinder = TcIdBndr TcId TopLevelFlag {- Note [Given Insts] ~~~~~~~~~~~~~~~~~~ -Because of GADTs, we have to pass inwards the Insts provided by type signatures +Because of GADTs, we have to pass inwards the Insts provided by type signatures and existential contexts. Consider - data T a where { T1 :: b -> b -> T [b] } - f :: Eq a => T a -> Bool - f (T1 x y) = [x]==[y] + data T a where { T1 :: b -> b -> T [b] } + f :: Eq a => T a -> Bool + f (T1 x y) = [x]==[y] The constructor T1 binds an existential variable 'b', and we need Eq [b]. -Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we +Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we pass it inwards. -} --------------------------- --- Template Haskell stages and levels +-- Template Haskell stages and levels --------------------------- -data ThStage -- See Note [Template Haskell state diagram] in TcSplice - = Splice -- Top-level splicing - -- This code will be run *at compile time*; - -- the result replaces the splice - -- Binding level = 0 - - | Comp -- Ordinary Haskell code - -- Binding level = 1 +data ThStage -- See Note [Template Haskell state diagram] in TcSplice + = Splice -- Top-level splicing + -- This code will be run *at compile time*; + -- the result replaces the splice + -- Binding level = 0 + + | Comp -- Ordinary Haskell code + -- Binding level = 1 - | Brack -- Inside brackets - ThStage -- Binding level = level(stage) + 1 - (TcRef [PendingSplice]) -- Accumulate pending splices here - (TcRef WantedConstraints) -- and type constraints here + | Brack -- Inside brackets + ThStage -- Binding level = level(stage) + 1 + (TcRef [PendingSplice]) -- Accumulate pending splices here + (TcRef WantedConstraints) -- and type constraints here topStage, topAnnStage, topSpliceStage :: ThStage topStage = Comp @@ -486,26 +485,26 @@ topSpliceStage = Splice instance Outputable ThStage where ppr Splice = text "Splice" - ppr Comp = text "Comp" + ppr Comp = text "Comp" ppr (Brack s _ _) = text "Brack" <> parens (ppr s) -type ThLevel = Int +type ThLevel = Int -- See Note [Template Haskell levels] in TcSplice - -- Incremented when going inside a bracket, - -- decremented when going inside a splice - -- NB: ThLevel is one greater than the 'n' in Fig 2 of the - -- original "Template meta-programming for Haskell" paper + -- Incremented when going inside a bracket, + -- decremented when going inside a splice + -- NB: ThLevel is one greater than the 'n' in Fig 2 of the + -- original "Template meta-programming for Haskell" paper impLevel, outerLevel :: ThLevel -impLevel = 0 -- Imported things; they can be used inside a top level splice -outerLevel = 1 -- Things defined outside brackets +impLevel = 0 -- Imported things; they can be used inside a top level splice +outerLevel = 1 -- Things defined outside brackets -- NB: Things at level 0 are not *necessarily* imported. --- eg $( \b -> ... ) here b is bound at level 0 +-- eg $( \b -> ... ) here b is bound at level 0 -- --- For example: --- f = ... --- g1 = $(map ...) is OK --- g2 = $(f ...) is not OK; because we havn't compiled f yet +-- For example: +-- f = ... +-- g1 = $(map ...) is OK +-- g2 = $(f ...) is not OK; because we havn't compiled f yet thLevel :: ThStage -> ThLevel thLevel Splice = 0 @@ -522,22 +521,22 @@ In arrow notation, a variable bound by a proc (or enclosed let/kappa) is not in scope to the left of an arrow tail (-<) or the head of (|..|). For example - proc x -> (e1 -< e2) + proc x -> (e1 -< e2) Here, x is not in scope in e1, but it is in scope in e2. This can get a bit complicated: - let x = 3 in - proc y -> (proc z -> e1) -< e2 + let x = 3 in + proc y -> (proc z -> e1) -< e2 -Here, x and z are in scope in e1, but y is not. +Here, x and z are in scope in e1, but y is not. We implement this by recording the environment when passing a proc (using newArrowScope), and returning to that (using escapeArrowScope) on the left of -< and the head of (|..|). -All this can be dealt with by the *renamer*; by the time we get to +All this can be dealt with by the *renamer*; by the time we get to the *type checker* we have sorted out the scopes -} @@ -549,40 +548,40 @@ data ArrowCtxt newArrowScope :: TcM a -> TcM a newArrowScope = updEnv $ \env -> - env { env_lcl = (env_lcl env) { tcl_arrow_ctxt = ArrowCtxt env } } + env { env_lcl = (env_lcl env) { tcl_arrow_ctxt = ArrowCtxt env } } -- Return to the stored environment (from the enclosing proc) escapeArrowScope :: TcM a -> TcM a escapeArrowScope = updEnv $ \ env -> case tcl_arrow_ctxt (env_lcl env) of - NoArrowCtxt -> env - ArrowCtxt env' -> env' + NoArrowCtxt -> env + ArrowCtxt env' -> env' --------------------------- -- TcTyThing --------------------------- data TcTyThing - = AGlobal TyThing -- Used only in the return type of a lookup + = AGlobal TyThing -- Used only in the return type of a lookup - | ATcId { -- Ids defined in this module; may not be fully zonked - tct_id :: TcId, - tct_closed :: TopLevelFlag, -- See Note [Bindings with closed types] - tct_level :: ThLevel } + | ATcId { -- Ids defined in this module; may not be fully zonked + tct_id :: TcId, + tct_closed :: TopLevelFlag, -- See Note [Bindings with closed types] + tct_level :: ThLevel } - | ATyVar Name TcTyVar -- The type variable to which the lexically scoped type - -- variable is bound. We only need the Name - -- for error-message purposes; it is the corresponding - -- Name in the domain of the envt + | ATyVar Name TcTyVar -- The type variable to which the lexically scoped type + -- variable is bound. We only need the Name + -- for error-message purposes; it is the corresponding + -- Name in the domain of the envt | AThing TcKind -- Used temporarily, during kind checking, for the - -- tycons and clases in this recursive group + -- tycons and clases in this recursive group -- Can be a mono-kind or a poly-kind; in TcTyClsDcls see -- Note [Type checking recursive type and class declarations] - | APromotionErr PromotionErr + | APromotionErr PromotionErr -data PromotionErr +data PromotionErr = TyConPE -- TyCon used in a kind before we are ready -- data T :: T -> * where ... | ClassPE -- Ditto Class @@ -593,13 +592,13 @@ data PromotionErr | RecDataConPE -- Data constructor in a reuursive loop -- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls -instance Outputable TcTyThing where -- Debugging only +instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = pprTyThing g - ppr elt@(ATcId {}) = text "Identifier" <> - brackets (ppr (tct_id elt) <> dcolon + ppr elt@(ATcId {}) = text "Identifier" <> + brackets (ppr (tct_id elt) <> dcolon <> ppr (varType (tct_id elt)) <> comma - <+> ppr (tct_closed elt) <> comma - <+> ppr (tct_level elt)) + <+> ppr (tct_closed elt) <> comma + <+> ppr (tct_level elt)) ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv ppr (AThing k) = text "AThing" <+> ppr k ppr (APromotionErr err) = text "APromotionErr" <+> ppr err @@ -632,7 +631,7 @@ Consider f x = let g ys = map not ys in ... -Can we generalise 'g' under the OutsideIn algorithm? Yes, +Can we generalise 'g' under the OutsideIn algorithm? Yes, because all g's free variables are top-level; that is they themselves have no free type variables, and it is the type variables in the environment that makes things tricky for OutsideIn generalisation. @@ -640,13 +639,13 @@ environment that makes things tricky for OutsideIn generalisation. Definition: A variable is "closed", and has tct_closed set to TopLevel, - iff + iff a) all its free variables are imported, or are themselves closed b) generalisation is not restricted by the monomorphism restriction Under OutsideIn we are free to generalise a closed let-binding. This is an extension compared to the JFP paper on OutsideIn, which -used "top-level" as a proxy for "closed". (It's not a good proxy +used "top-level" as a proxy for "closed". (It's not a good proxy anyway -- the MR can make a top-level binding with a free type variable.) @@ -655,7 +654,7 @@ Note that: * A nested binding may be closed (eg 'g' in the example we started with) Indeed, that's the point; whether a function is defined at top level - or nested is orthogonal to the question of whether or not it is closed + or nested is orthogonal to the question of whether or not it is closed * A binding may be non-closed because it mentions a lexically scoped *type variable* Eg @@ -665,19 +664,19 @@ Note that: \begin{code} type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) - -- Monadic so that we have a chance - -- to deal with bound type variables just before error - -- message construction + -- Monadic so that we have a chance + -- to deal with bound type variables just before error + -- message construction - -- Bool: True <=> this is a landmark context; do not - -- discard it when trimming for display + -- Bool: True <=> this is a landmark context; do not + -- discard it when trimming for display \end{code} %************************************************************************ -%* * - Operations over ImportAvails -%* * +%* * + Operations over ImportAvails +%* * %************************************************************************ \begin{code} @@ -693,10 +692,10 @@ type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) -- -- * when figuring out what things are really unused -- -data ImportAvails +data ImportAvails = ImportAvails { - imp_mods :: ImportedMods, - -- = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)], + imp_mods :: ImportedMods, + -- = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)], -- ^ Domain is all directly-imported modules -- The 'ModuleName' is what the module was imported as, e.g. in -- @ @@ -737,7 +736,7 @@ data ImportAvails -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. - + imp_trust_pkgs :: [PackageId], -- ^ This is strictly a subset of imp_dep_pkgs and records the -- packages the current module needs to trust for Safe Haskell @@ -765,10 +764,10 @@ data ImportAvails } mkModDeps :: [(ModuleName, IsBootInterface)] - -> ModuleNameEnv (ModuleName, IsBootInterface) + -> ModuleNameEnv (ModuleName, IsBootInterface) mkModDeps deps = foldl add emptyUFM deps - where - add env elt@(m,_) = addToUFM env m elt + where + add env elt@(m,_) = addToUFM env m elt emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, @@ -802,37 +801,37 @@ plusImportAvails imp_orphs = orphs1 `unionLists` orphs2, imp_finsts = finsts1 `unionLists` finsts2 } where - plus_mod_dep (m1, boot1) (m2, boot2) + plus_mod_dep (m1, boot1) (m2, boot2) = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) -- Check mod-names match (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that \end{code} %************************************************************************ -%* * +%* * \subsection{Where from} -%* * +%* * %************************************************************************ The @WhereFrom@ type controls where the renamer looks for an interface file \begin{code} -data WhereFrom - = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) - | ImportBySystem -- Non user import. +data WhereFrom + = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) + | ImportBySystem -- Non user import. instance Outputable WhereFrom where ppr (ImportByUser is_boot) | is_boot = ptext (sLit "{- SOURCE -}") - | otherwise = empty - ppr ImportBySystem = ptext (sLit "{- SYSTEM -}") + | otherwise = empty + ppr ImportBySystem = ptext (sLit "{- SYSTEM -}") \end{code} %************************************************************************ -%* * +%* * %* Canonical constraints * %* * %* These are the constraints the low-level simplifier works with * -%* * +%* * %************************************************************************ @@ -841,8 +840,8 @@ instance Outputable WhereFrom where -- xi ::= a | T xis | xis -> xis | ... | forall a. tau -- Two important notes: -- (i) No type families, unless we are under a ForAll --- (ii) Note that xi types can contain unexpanded type synonyms; --- however, the (transitive) expansions of those type synonyms +-- (ii) Note that xi types can contain unexpanded type synonyms; +-- however, the (transitive) expansions of those type synonyms -- will not contain any type functions, unless we are under a ForAll. -- We enforce the structure of Xi types when we flatten (TcCanonical) @@ -851,10 +850,10 @@ type Xi = Type -- In many comments, "xi" ranges over Xi type Cts = Bag Ct data Ct - -- Atomic canonical constraints + -- Atomic canonical constraints = CDictCan { -- e.g. Num xi cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_class :: Class, + cc_class :: Class, cc_tyargs :: [Xi], cc_loc :: CtLoc @@ -862,7 +861,7 @@ data Ct | CIrredEvCan { -- These stand for yet-unknown predicates cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - -- In CIrredEvCan, the ctev_pred of the evidence is flat + -- In CIrredEvCan, the ctev_pred of the evidence is flat -- and hence it may only be of the form (tv xi1 xi2 ... xin) -- Since, if it were a type constructor application, that'd make the -- whole constraint a CDictCan, or CTyEqCan. And it can't be @@ -870,33 +869,33 @@ data Ct cc_loc :: CtLoc } - | CTyEqCan { -- tv ~ xi (recall xi means function free) - -- Invariant: + | CTyEqCan { -- tv ~ xi (recall xi means function free) + -- Invariant: -- * tv not in tvs(xi) (occurs check) -- * typeKind xi `compatKind` typeKind tv -- See Note [Spontaneous solving and kind compatibility] -- * We prefer unification variables on the left *JUST* for efficiency cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_tyvar :: TcTyVar, + cc_tyvar :: TcTyVar, cc_rhs :: Xi, cc_loc :: CtLoc } - | CFunEqCan { -- F xis ~ xi - -- Invariant: * isSynFamilyTyCon cc_fun + | CFunEqCan { -- F xis ~ xi + -- Invariant: * isSynFamilyTyCon cc_fun -- * typeKind (F xis) `compatKind` typeKind xi cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_fun :: TyCon, -- A type function - cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated - cc_rhs :: Xi, -- *never* over-saturated (because if so - -- we should have decomposed) + cc_fun :: TyCon, -- A type function + cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated + cc_rhs :: Xi, -- *never* over-saturated (because if so + -- we should have decomposed) cc_loc :: CtLoc - + } - | CNonCanonical { -- See Note [NonCanonical Semantics] - cc_ev :: CtEvidence, + | CNonCanonical { -- See Note [NonCanonical Semantics] + cc_ev :: CtEvidence, cc_loc :: CtLoc } @@ -909,7 +908,7 @@ data Ct Note [Ct/evidence invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field -of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, +of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) This holds by construction; look at the unique place where CDictCan is built (in TcCanonical). @@ -928,29 +927,29 @@ mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_loc = cc_loc ct } ctEvidence :: Ct -> CtEvidence ctEvidence = cc_ev -ctPred :: Ct -> PredType +ctPred :: Ct -> PredType -- See Note [Ct/evidence invariant] ctPred ct = ctEvPred (cc_ev ct) dropDerivedWC :: WantedConstraints -> WantedConstraints dropDerivedWC wc@(WC { wc_flat = flats }) = wc { wc_flat = filterBag isWantedCt flats } - -- Don't filter the insolubles, because derived + -- Don't filter the insolubles, because derived -- insolubles should stay so that we report them. -- The implications are (recursively) already filtered \end{code} %************************************************************************ -%* * +%* * CtEvidence The "flavor" of a canonical constraint -%* * +%* * %************************************************************************ \begin{code} isWantedCt :: Ct -> Bool -isWantedCt = isWanted . cc_ev +isWantedCt = isWanted . cc_ev isGivenCt :: Ct -> Bool isGivenCt = isGiven . cc_ev @@ -958,10 +957,10 @@ isGivenCt = isGiven . cc_ev isDerivedCt :: Ct -> Bool isDerivedCt = isDerived . cc_ev -isCTyEqCan :: Ct -> Bool -isCTyEqCan (CTyEqCan {}) = True +isCTyEqCan :: Ct -> Bool +isCTyEqCan (CTyEqCan {}) = True isCTyEqCan (CFunEqCan {}) = False -isCTyEqCan _ = False +isCTyEqCan _ = False isCDictCan_Maybe :: Ct -> Maybe Class isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls @@ -980,8 +979,8 @@ isCFunEqCan (CFunEqCan {}) = True isCFunEqCan _ = False isCNonCanonical :: Ct -> Bool -isCNonCanonical (CNonCanonical {}) = True -isCNonCanonical _ = False +isCNonCanonical (CNonCanonical {}) = True +isCNonCanonical _ = False isHoleCt:: Ct -> Bool isHoleCt (CHoleCan {}) = True @@ -992,7 +991,7 @@ isHoleCt _ = False \begin{code} instance Outputable Ct where ppr ct = ppr (cc_ev ct) <+> parens (text ct_sort) - where ct_sort = case ct of + where ct_sort = case ct of CTyEqCan {} -> "CTyEqCan" CFunEqCan {} -> "CFunEqCan" CNonCanonical {} -> "CNonCanonical" @@ -1002,19 +1001,19 @@ instance Outputable Ct where \end{code} \begin{code} -singleCt :: Ct -> Cts -singleCt = unitBag +singleCt :: Ct -> Cts +singleCt = unitBag -andCts :: Cts -> Cts -> Cts +andCts :: Cts -> Cts -> Cts andCts = unionBags -extendCts :: Cts -> Ct -> Cts -extendCts = snocBag +extendCts :: Cts -> Ct -> Cts +extendCts = snocBag -andManyCts :: [Cts] -> Cts +andManyCts :: [Cts] -> Cts andManyCts = unionManyBags -emptyCts :: Cts +emptyCts :: Cts emptyCts = emptyBag isEmptyCts :: Cts -> Bool @@ -1022,14 +1021,14 @@ isEmptyCts = isEmptyBag \end{code} %************************************************************************ -%* * - Wanted constraints +%* * + Wanted constraints These are forced to be in TcRnTypes because - TcLclEnv mentions WantedConstraints - WantedConstraint mentions CtLoc - CtLoc mentions ErrCtxt - ErrCtxt mentions TcM -%* * + TcLclEnv mentions WantedConstraints + WantedConstraint mentions CtLoc + CtLoc mentions ErrCtxt + ErrCtxt mentions TcM +%* * v%************************************************************************ \begin{code} @@ -1046,7 +1045,7 @@ emptyWC :: WantedConstraints emptyWC = WC { wc_flat = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag } mkFlatWC :: [Ct] -> WantedConstraints -mkFlatWC cts +mkFlatWC cts = WC { wc_flat = listToBag cts, wc_impl = emptyBag, wc_insol = emptyBag } isEmptyWC :: WantedConstraints -> Bool @@ -1092,29 +1091,29 @@ instance Outputable WantedConstraints where pprBag :: (a -> SDoc) -> Bag a -> SDoc pprBag pp b = foldrBag (($$) . pp) empty b \end{code} - + %************************************************************************ -%* * +%* * Implication constraints %* * %************************************************************************ \begin{code} data Implication - = Implic { + = Implic { ic_untch :: Untouchables, -- Untouchables: unification variables -- free in the environment - ic_skols :: [TcTyVar], -- Introduced skolems + ic_skols :: [TcTyVar], -- Introduced skolems ic_info :: SkolemInfo, -- See Note [Skolems in an implication] -- See Note [Shadowing in a constraint] ic_fsks :: [TcTyVar], -- Extra flatten-skolems introduced by the flattening - -- done by canonicalisation. + -- done by canonicalisation. ic_given :: [EvVar], -- Given evidence variables - -- (order does not matter) + -- (order does not matter) ic_env :: TcLclEnv, -- Gives the source location and error context -- for the implicatdion, and hence for all the @@ -1132,7 +1131,7 @@ instance Outputable Implication where , ic_given = given , ic_wanted = wanted , ic_binds = binds, ic_info = info }) - = ptext (sLit "Implic") <+> braces + = ptext (sLit "Implic") <+> braces (sep [ ptext (sLit "Untouchables =") <+> ppr untch , ptext (sLit "Skolems =") <+> ppr skols , ptext (sLit "Flatten-skolems =") <+> ppr fsks @@ -1162,7 +1161,7 @@ untouchables, and therefore cannot be unified with anything at all, let alone the skolems. Instead, ic_skols is used only when considering floating a constraint -outside the implication in TcSimplify.floatEqualities or +outside the implication in TcSimplify.floatEqualities or TcSimplify.approximateImplications Note [Insoluble constraints] @@ -1171,18 +1170,18 @@ Some of the errors that we get during canonicalization are best reported when all constraints have been simplified as much as possible. For instance, assume that during simplification the following constraints arise: - - [Wanted] F alpha ~ uf1 - [Wanted] beta ~ uf1 beta + + [Wanted] F alpha ~ uf1 + [Wanted] beta ~ uf1 beta When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail we will simply see a message: - 'Can't construct the infinite type beta ~ uf1 beta' + 'Can't construct the infinite type beta ~ uf1 beta' and the user has no idea what the uf1 variable is. Instead our plan is that we will NOT fail immediately, but: (1) Record the "frozen" error in the ic_insols field - (2) Isolate the offending constraint from the rest of the inerts + (2) Isolate the offending constraint from the rest of the inerts (3) Keep on simplifying/canonicalizing At the end, we will hopefully have substituted uf1 := F alpha, and we @@ -1196,18 +1195,18 @@ never see it. %************************************************************************ -%* * +%* * Pretty printing -%* * +%* * %************************************************************************ \begin{code} -pprEvVars :: [EvVar] -> SDoc -- Print with their types +pprEvVars :: [EvVar] -> SDoc -- Print with their types pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) pprEvVarTheta :: [EvVar] -> SDoc pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) - + pprEvVarWithType :: EvVar -> SDoc pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) @@ -1219,9 +1218,9 @@ pprWantedsWithLocs wcs \end{code} %************************************************************************ -%* * +%* * CtEvidence -%* * +%* * %************************************************************************ Note [Evidence field of CtEvidence] @@ -1231,19 +1230,19 @@ ctev_evar; instead we look at the cte_pred field. The evtm/evar field may be un-zonked. \begin{code} -data CtEvidence +data CtEvidence = CtGiven { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] , ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence] -- Truly given, not depending on subgoals -- NB: Spontaneous unifications belong here - + | CtWanted { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] , ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence] - -- Wanted goal - + -- Wanted goal + | CtDerived { ctev_pred :: TcPredType } - -- A goal that we don't really have to solve and can't immediately - -- rewrite anything other than a derived (there's no evidence!) + -- A goal that we don't really have to solve and can't immediately + -- rewrite anything other than a derived (there's no evidence!) -- but if we do manage to solve it may help in solving other goals. data CtFlavour = Given | Wanted | Derived @@ -1263,7 +1262,7 @@ ctEvPred = ctev_pred ctEvTerm :: CtEvidence -> EvTerm ctEvTerm (CtGiven { ctev_evtm = tm }) = tm ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev -ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" +ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" (ppr ctev) ctEvId :: CtEvidence -> TcId @@ -1295,32 +1294,32 @@ isDerived (CtDerived {}) = True isDerived _ = False canSolve :: CtFlavour -> CtFlavour -> Bool --- canSolve ctid1 ctid2 --- The constraint ctid1 can be used to solve ctid2 +-- canSolve ctid1 ctid2 +-- The constraint ctid1 can be used to solve ctid2 -- "to solve" means a reaction where the active parts of the two constraints match. --- active(F xis ~ xi) = F xis --- active(tv ~ xi) = tv --- active(D xis) = D xis --- active(IP nm ty) = nm +-- active(F xis ~ xi) = F xis +-- active(tv ~ xi) = tv +-- active(D xis) = D xis +-- active(IP nm ty) = nm -- -- NB: either (a `canSolve` b) or (b `canSolve` a) must hold ----------------------------------------- -canSolve Given _ = True +canSolve Given _ = True canSolve Wanted Derived = True canSolve Wanted Wanted = True canSolve Derived Derived = True -- Derived can't solve wanted/given -canSolve _ _ = False -- No evidence for a derived, anyway +canSolve _ _ = False -- No evidence for a derived, anyway -canRewrite :: CtFlavour -> CtFlavour -> Bool --- canRewrite ct1 ct2 --- The equality constraint ct1 can be used to rewrite inside ct2 -canRewrite = canSolve +canRewrite :: CtFlavour -> CtFlavour -> Bool +-- canRewrite ct1 ct2 +-- The equality constraint ct1 can be used to rewrite inside ct2 +canRewrite = canSolve \end{code} %************************************************************************ -%* * +%* * CtLoc -%* * +%* * %************************************************************************ The 'CtLoc' gives information about where a constraint came from. @@ -1337,7 +1336,7 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin -- context: tcl_ctxt :: [ErrCtxt] -- binder stack: tcl_bndrs :: [TcIdBinders] -type SubGoalDepth = Int -- An ever increasing number used to restrict +type SubGoalDepth = Int -- An ever increasing number used to restrict -- simplifier iterations. Bounded by -fcontext-stack. -- See Note [WorkList] @@ -1368,7 +1367,7 @@ setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc setCtLocEnv ctl env = ctl { ctl_env = env } pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc -pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) +pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc @@ -1384,7 +1383,7 @@ pprArising FunDepOrigin = empty pprArising orig = text "arising from" <+> ppr orig pprArisingAt :: CtLoc -> SDoc -pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl}) +pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl}) = sep [ text "arising from" <+> ppr o , text "at" <+> ppr (tcl_loc lcl)] \end{code} @@ -1400,28 +1399,28 @@ pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl}) -- a) type variables are skolemised -- b) an implication constraint is generated data SkolemInfo - = SigSkol UserTypeCtxt -- A skolem that is created by instantiating + = SigSkol UserTypeCtxt -- A skolem that is created by instantiating Type -- a programmer-supplied type signature - -- Location of the binding site is on the TyVar + -- Location of the binding site is on the TyVar - -- The rest are for non-scoped skolems - | ClsSkol Class -- Bound at a class decl - | InstSkol -- Bound at an instance decl + -- The rest are for non-scoped skolems + | ClsSkol Class -- Bound at a class decl + | InstSkol -- Bound at an instance decl | DataSkol -- Bound at a data type declaration | FamInstSkol -- Bound at a family instance decl - | PatSkol -- An existential type variable bound by a pattern for + | PatSkol -- An existential type variable bound by a pattern for DataCon -- a data constructor with an existential type. - (HsMatchContext Name) - -- e.g. data T = forall a. Eq a => MkT a - -- f (MkT x) = ... - -- The pattern MkT x will allocate an existential type - -- variable for 'a'. + (HsMatchContext Name) + -- e.g. data T = forall a. Eq a => MkT a + -- f (MkT x) = ... + -- The pattern MkT x will allocate an existential type + -- variable for 'a'. - | ArrowSkol -- An arrow form (see TcArrows) + | ArrowSkol -- An arrow form (see TcArrows) | IPSkol [HsIPName] -- Binding site of an implicit parameter - | RuleSkol RuleName -- The LHS of a RULE + | RuleSkol RuleName -- The LHS of a RULE | InferSkol [(Name,TcType)] -- We have inferred a type for these (mutually-recursivive) @@ -1465,16 +1464,16 @@ pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") pprSkolInfo (UnifyForAllSkol tvs ty) = ptext (sLit "the type") <+> ppr (mkForAllTys tvs ty) -- UnkSkol --- For type variables the others are dealt with by pprSkolTvBinding. +-- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") \end{code} %************************************************************************ -%* * +%* * CtOrigin -%* * +%* * %************************************************************************ \begin{code} @@ -1482,41 +1481,41 @@ data CtOrigin = GivenOrigin SkolemInfo -- All the others are for *wanted* constraints - | OccurrenceOf Name -- Occurrence of an overloaded identifier - | AppOrigin -- An application of some kind + | OccurrenceOf Name -- Occurrence of an overloaded identifier + | AppOrigin -- An application of some kind - | SpecPragOrigin Name -- Specialisation pragma for identifier + | SpecPragOrigin Name -- Specialisation pragma for identifier | TypeEqOrigin { uo_actual :: TcType , uo_expected :: TcType } - | KindEqOrigin + | KindEqOrigin TcType TcType -- A kind equality arising from unifying these two types CtOrigin -- originally arising from this - | IPOccOrigin HsIPName -- Occurrence of an implicit parameter + | IPOccOrigin HsIPName -- Occurrence of an implicit parameter - | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal - | NegateOrigin -- Occurrence of syntactic negation + | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal + | NegateOrigin -- Occurrence of syntactic negation | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc | PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:] | SectionOrigin - | TupleOrigin -- (..,..) - | AmbigOrigin Name -- f :: ty - | ExprSigOrigin -- e :: ty - | PatSigOrigin -- p :: ty - | PatOrigin -- Instantiating a polytyped pattern at a constructor + | TupleOrigin -- (..,..) + | AmbigOrigin Name -- f :: ty + | ExprSigOrigin -- e :: ty + | PatSigOrigin -- p :: ty + | PatOrigin -- Instantiating a polytyped pattern at a constructor | RecordUpdOrigin | ViewPatOrigin - | ScOrigin -- Typechecking superclasses of an instance declaration - | DerivOrigin -- Typechecking deriving + | ScOrigin -- Typechecking superclasses of an instance declaration + | DerivOrigin -- Typechecking deriving | StandAloneDerivOrigin -- Typechecking stand-alone deriving - | DefaultOrigin -- Typechecking a default decl - | DoOrigin -- Arising from a do expression + | DefaultOrigin -- Typechecking a default decl + | DoOrigin -- Arising from a do expression | MCompOrigin -- Arising from a monad comprehension | IfOrigin -- Arising from an if statement - | ProcOrigin -- Arising from a proc expression + | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation | FunDepOrigin | HoleOrigin @@ -1537,16 +1536,16 @@ pprO IfOrigin = ptext (sLit "an if statement") pprO (LiteralOrigin lit) = hsep [ptext (sLit "the literal"), quotes (ppr lit)] pprO (ArithSeqOrigin seq) = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)] pprO (PArrSeqOrigin seq) = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)] -pprO SectionOrigin = ptext (sLit "an operator section") -pprO TupleOrigin = ptext (sLit "a tuple") -pprO NegateOrigin = ptext (sLit "a use of syntactic negation") -pprO ScOrigin = ptext (sLit "the superclasses of an instance declaration") -pprO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration") +pprO SectionOrigin = ptext (sLit "an operator section") +pprO TupleOrigin = ptext (sLit "a tuple") +pprO NegateOrigin = ptext (sLit "a use of syntactic negation") +pprO ScOrigin = ptext (sLit "the superclasses of an instance declaration") +pprO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration") pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") -pprO DefaultOrigin = ptext (sLit "a 'default' declaration") -pprO DoOrigin = ptext (sLit "a do statement") +pprO DefaultOrigin = ptext (sLit "a 'default' declaration") +pprO DoOrigin = ptext (sLit "a do statement") pprO MCompOrigin = ptext (sLit "a statement in a monad comprehension") -pprO ProcOrigin = ptext (sLit "a proc expression") +pprO ProcOrigin = ptext (sLit "a proc expression") pprO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] pprO (KindEqOrigin t1 t2 _) = ptext (sLit "a kind equality arising from") <+> sep [ppr t1, char '~', ppr t2] pprO AnnOrigin = ptext (sLit "an annotation") diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 469635ef29..ffcf5c2991 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -48,6 +48,7 @@ import MkCore ( rEC_SEL_ERROR_ID ) import IdInfo import Var import VarSet +import Module import Name import NameSet import NameEnv diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index ee7e616305..35d7973c04 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -32,6 +32,7 @@ module IOEnv ( import DynFlags import Exception +import Module import Panic import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, @@ -93,6 +94,10 @@ instance ContainsDynFlags env => HasDynFlags (IOEnv env) where getDynFlags = do env <- getEnv return $ extractDynFlags env +instance ContainsModule env => HasModule (IOEnv env) where + getModule = do env <- getEnv + return $ extractModule env + ---------------------------------------------------------------------- -- Fundmantal combinators specific to the monad ---------------------------------------------------------------------- diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.lhs index e6fab9be26..210a7b9f02 100644 --- a/compiler/utils/Maybes.lhs +++ b/compiler/utils/Maybes.lhs @@ -17,7 +17,6 @@ module Maybes ( MaybeErr(..), -- Instance of Monad failME, isSuccess, - fmapM_maybe, orElse, mapCatMaybes, allMaybes, @@ -85,14 +84,6 @@ orElse :: Maybe a -> a -> a Nothing `orElse` y = y \end{code} -\begin{code} -fmapM_maybe :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) -fmapM_maybe _ Nothing = return Nothing -fmapM_maybe f (Just x) = do - x' <- f x - return $ Just x' -\end{code} - %************************************************************************ %* * \subsection[MaybeT type]{The @MaybeT@ monad transformer} diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 7b5a7aae44..680300abd4 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -11,7 +11,7 @@ Basically, the things need to be in class @Uniquable@, and we use the (A similar thing to @UniqSet@, as opposed to @Set@.) The interface is based on @FiniteMap@s, but the implementation uses -@Data.IntMap@, which is both maitained and faster than the past +@Data.IntMap@, which is both maintained and faster than the past implementation (see commit log). The @UniqFM@ interface maps directly to Data.IntMap, only |