diff options
Diffstat (limited to 'compiler')
93 files changed, 2462 insertions, 2083 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 6b918dbc08..e244c0db65 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -273,7 +273,7 @@ data DataCon -- dcExTyVars = [x,y] -- dcEqSpec = [a~(x,y)] -- dcOtherTheta = [x~y, Ord x] - -- dcOrigArgTys = [a,List b] + -- dcOrigArgTys = [x,y] -- dcRepTyCon = T dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor 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/Cmm.hs b/compiler/cmm/Cmm.hs index 8409f0dbeb..e1701bd4c5 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -71,6 +71,14 @@ data GenCmmDecl d h g = CmmProc -- A procedure h -- Extra header such as the info table CLabel -- Entry label + [GlobalReg] -- Registers live on entry. Note that the set of live + -- registers will be correct in generated C-- code, but + -- not in hand-written C-- code. However, + -- splitAtProcPoints calculates correct liveness + -- information for CmmProc's. Right now only the LLVM + -- back-end relies on correct liveness information and + -- for that back-end we always call splitAtProcPoints, so + -- all is good. g -- Control-flow graph for the procedure's code | CmmData -- Static data @@ -100,8 +108,8 @@ data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable , stack_info :: CmmStackInfo } topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable -topInfoTable (CmmProc infos _ g) = mapLookup (g_entry g) (info_tbls infos) -topInfoTable _ = Nothing +topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) +topInfoTable _ = Nothing data CmmStackInfo = StackInfo { diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 304f4c2170..af78b40e0f 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -250,7 +250,7 @@ to_SRT dflags top_srt off len bmp -- any CAF that is reachable from c. localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) -localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) = +localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) = case topInfoTable proc of Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep) && not (isStackRep rep) @@ -295,7 +295,7 @@ bundle :: Map CLabel CAFSet -> (CAFEnv, CmmDecl) -> (CAFSet, Maybe CLabel) -> (BlockEnv CAFSet, CmmDecl) -bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl) +bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl) = ( mapMapWithKey get_cafs (info_tbls infos), decl ) where entry = g_entry g @@ -371,8 +371,8 @@ buildSRTs dflags top_srt caf_map -} updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl -updInfoSRTs srt_env (CmmProc top_info top_l g) = - CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g +updInfoSRTs srt_env (CmmProc top_info top_l live g) = + CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g where updInfoTbl l info_tbl = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env } updInfoSRTs _ t = t diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 180b2d7eab..7fc89e2f54 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -9,7 +9,7 @@ module CmmCallConv ( ParamLocation(..), assignArgumentsPos, assignStack, - globalArgRegs, realArgRegs + globalArgRegs, realArgRegsCover ) where #include "HsVersions.h" @@ -69,22 +69,27 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) assign_regs assts [] _ = (assts, []) assign_regs assts (r:rs) regs = if isFloatType ty then float else int where float = case (w, regs) of - (W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls)) - (W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls)) + (W32, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) + (W32, (vs, f:fs, ds, ls, ss)) + | not hasSseRegs -> k (RegisterParam f, (vs, fs, ds, ls, ss)) + (W64, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) + (W64, (vs, fs, d:ds, ls, ss)) + | not hasSseRegs -> k (RegisterParam d, (vs, fs, ds, ls, ss)) (W80, _) -> panic "F80 unsupported register type" _ -> (assts, (r:rs)) int = case (w, regs) of (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits (wordWidth dflags) - -> k (RegisterParam (v gcp), (vs, fs, ds, ls)) - (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags) - -> k (RegisterParam l, (vs, fs, ds, ls)) + (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags) + -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) + (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags) + -> k (RegisterParam l, (vs, fs, ds, ls, ss)) _ -> (assts, (r:rs)) k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' ty = arg_ty r w = typeWidth ty gcp | isGcPtrType ty = VGcPtr | otherwise = VNonGcPtr + hasSseRegs = mAX_Real_SSE_REG dflags /= 0 assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a] @@ -109,6 +114,7 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. , [GlobalReg] -- floats , [GlobalReg] -- doubles , [GlobalReg] -- longs (int64 and word64) + , [Int] -- SSE (floats and doubles) ) -- Vanilla registers can contain pointers, Ints, Chars. @@ -122,7 +128,8 @@ getRegsWithoutNode dflags = ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags) , realFloatRegs dflags , realDoubleRegs dflags - , realLongRegs dflags) + , realLongRegs dflags + , sseRegNos dflags) -- getRegsWithNode uses R1/node even if it isn't a register getRegsWithNode dflags = @@ -131,15 +138,18 @@ getRegsWithNode dflags = else realVanillaRegs dflags , realFloatRegs dflags , realDoubleRegs dflags - , realLongRegs dflags) + , realLongRegs dflags + , sseRegNos dflags) allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] +allSseRegs :: DynFlags -> [Int] allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) +allSseRegs dflags = regList (mAX_SSE_REG dflags) realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] @@ -149,6 +159,9 @@ realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags) +sseRegNos :: DynFlags -> [Int] +sseRegNos dflags =regList (mAX_SSE_REG dflags) + regList :: Int -> [Int] regList n = [1 .. n] @@ -156,10 +169,11 @@ allRegs :: DynFlags -> AvailRegs allRegs dflags = (allVanillaRegs dflags, allFloatRegs dflags, allDoubleRegs dflags, - allLongRegs dflags) + allLongRegs dflags, + allSseRegs dflags) noRegs :: AvailRegs -noRegs = ([], [], [], []) +noRegs = ([], [], [], [], []) globalArgRegs :: DynFlags -> [GlobalReg] globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++ @@ -167,8 +181,19 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++ allDoubleRegs dflags ++ allLongRegs dflags -realArgRegs :: DynFlags -> [GlobalReg] -realArgRegs dflags = map ($VGcPtr) (realVanillaRegs dflags) ++ - realFloatRegs dflags ++ - realDoubleRegs dflags ++ - realLongRegs dflags +-- This returns the set of global registers that *cover* the machine registers +-- used for argument passing. On platforms where registers can overlap---right +-- now just x86-64, where Float and Double registers overlap---passing this set +-- of registers is guaranteed to preserve the contents of all live registers. We +-- only use this functionality in hand-written C-- code in the RTS. +realArgRegsCover :: DynFlags -> [GlobalReg] +realArgRegsCover dflags + | hasSseRegs = map ($VGcPtr) (realVanillaRegs dflags) ++ + realDoubleRegs dflags ++ + realLongRegs dflags + | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++ + realFloatRegs dflags ++ + realDoubleRegs dflags ++ + realLongRegs dflags + where + hasSseRegs = mAX_Real_SSE_REG dflags /= 0 diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 4028efddf6..82f7243e73 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -28,7 +28,7 @@ cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph cmmCfgOpts split g = fst (blockConcat split g) cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl -cmmCfgOptsProc split (CmmProc info lbl g) = CmmProc info' lbl g' +cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' where (g', env) = blockConcat split g info' = info{ info_tbls = new_info_tbls } new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 017d120d84..39f0b86ec8 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -19,7 +19,7 @@ import Outputable cmmOfZgraph :: CmmGroup -> Old.CmmGroup cmmOfZgraph tops = map mapTop tops - where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g) + where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g) mapTop (CmmData s ds) = CmmData s ds add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a] @@ -109,7 +109,7 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid] CmmSwitch arg ids -> [Old.CmmSwitch arg ids] -- ToDo: STG Live - CmmCall e _ r _ _ _ -> [Old.CmmJump e (Just r)] + CmmCall e _ r _ _ _ -> [Old.CmmJump e r] CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall" tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of Old.BasicBlock _ stmts -> stmts diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 128eb1ca62..87713c6b0d 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,16 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} module CmmExpr ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr , CmmReg(..), cmmRegType , CmmLit(..), cmmLitType , LocalReg(..), localRegType - , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg + , GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg , VGcPtr(..), vgcFlag -- Temporary! - , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed - , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet - , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet - , regSetToList + + , DefinerOfRegs, UserOfRegs + , foldRegsDefd, foldRegsUsed, filterRegsUsed + , foldLocalRegsDefd, foldLocalRegsUsed + + , RegSet, LocalRegSet, GlobalRegSet + , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet + , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet + , regSetToList , regUsedIn + , Area(..) , module CmmMachOp , module CmmType @@ -177,7 +185,7 @@ localRegType (LocalReg _ rep) = rep -- Register-use information for expressions and other types ----------------------------------------------------------------------------- --- | Sets of local registers +-- | Sets of registers -- These are used for dataflow facts, and a common operation is taking -- the union of two RegSets and then asking whether the union is the @@ -185,16 +193,19 @@ localRegType (LocalReg _ rep) = rep -- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary -- Sets. -type RegSet = Set LocalReg -emptyRegSet :: RegSet -nullRegSet :: RegSet -> Bool -elemRegSet :: LocalReg -> RegSet -> Bool -extendRegSet :: RegSet -> LocalReg -> RegSet -deleteFromRegSet :: RegSet -> LocalReg -> RegSet -mkRegSet :: [LocalReg] -> RegSet -minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet -sizeRegSet :: RegSet -> Int -regSetToList :: RegSet -> [LocalReg] +type RegSet r = Set r +type LocalRegSet = RegSet LocalReg +type GlobalRegSet = RegSet GlobalReg + +emptyRegSet :: Ord r => RegSet r +nullRegSet :: Ord r => RegSet r -> Bool +elemRegSet :: Ord r => r -> RegSet r -> Bool +extendRegSet :: Ord r => RegSet r -> r -> RegSet r +deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r +mkRegSet :: Ord r => [r] -> RegSet r +minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r +sizeRegSet :: Ord r => RegSet r -> Int +regSetToList :: Ord r => RegSet r -> [r] emptyRegSet = Set.empty nullRegSet = Set.null @@ -208,58 +219,75 @@ timesRegSet = Set.intersection sizeRegSet = Set.size regSetToList = Set.toList -class UserOfLocalRegs a where - foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b +class Ord r => UserOfRegs r a where + foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b + +foldLocalRegsUsed :: UserOfRegs LocalReg a + => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsUsed = foldRegsUsed -class DefinerOfLocalRegs a where - foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b +class Ord r => DefinerOfRegs r a where + foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b -filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet -filterRegsUsed p e = - foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs) +foldLocalRegsDefd :: DefinerOfRegs LocalReg a + => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsDefd = foldRegsDefd + +filterRegsUsed :: UserOfRegs r e => DynFlags -> (r -> Bool) -> e -> RegSet r +filterRegsUsed dflags p e = + foldRegsUsed dflags + (\regs r -> if p r then extendRegSet regs r else regs) emptyRegSet e -instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where - foldRegsUsed f z (Just x) = foldRegsUsed f z x - foldRegsUsed _ z Nothing = z +instance UserOfRegs LocalReg CmmReg where + foldRegsUsed _ f z (CmmLocal reg) = f z reg + foldRegsUsed _ _ z (CmmGlobal _) = z + +instance DefinerOfRegs LocalReg CmmReg where + foldRegsDefd _ f z (CmmLocal reg) = f z reg + foldRegsDefd _ _ z (CmmGlobal _) = z -instance UserOfLocalRegs CmmReg where - foldRegsUsed f z (CmmLocal reg) = f z reg - foldRegsUsed _ z (CmmGlobal _) = z +instance UserOfRegs GlobalReg CmmReg where + foldRegsUsed _ _ z (CmmLocal _) = z + foldRegsUsed _ f z (CmmGlobal reg) = f z reg -instance DefinerOfLocalRegs CmmReg where - foldRegsDefd f z (CmmLocal reg) = f z reg - foldRegsDefd _ z (CmmGlobal _) = z +instance DefinerOfRegs GlobalReg CmmReg where + foldRegsDefd _ _ z (CmmLocal _) = z + foldRegsDefd _ f z (CmmGlobal reg) = f z reg -instance UserOfLocalRegs LocalReg where - foldRegsUsed f z r = f z r +instance Ord r => UserOfRegs r r where + foldRegsUsed _ f z r = f z r -instance DefinerOfLocalRegs LocalReg where - foldRegsDefd f z r = f z r +instance Ord r => DefinerOfRegs r r where + foldRegsDefd _ f z r = f z r -instance UserOfLocalRegs RegSet where - foldRegsUsed f = Set.fold (flip f) +instance Ord r => UserOfRegs r (RegSet r) where + foldRegsUsed _ f = Set.fold (flip f) -instance UserOfLocalRegs CmmExpr where - foldRegsUsed f z e = expr z e +instance UserOfRegs r CmmReg => UserOfRegs r CmmExpr where + foldRegsUsed dflags f z e = expr z e where expr z (CmmLit _) = z - expr z (CmmLoad addr _) = foldRegsUsed f z addr - expr z (CmmReg r) = foldRegsUsed f z r - expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs - expr z (CmmRegOff r _) = foldRegsUsed f z r + expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr + expr z (CmmReg r) = foldRegsUsed dflags f z r + expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs + expr z (CmmRegOff r _) = foldRegsUsed dflags f z r expr z (CmmStackSlot _ _) = z -instance UserOfLocalRegs a => UserOfLocalRegs [a] where - foldRegsUsed _ set [] = set - foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs +instance UserOfRegs r a => UserOfRegs r (Maybe a) where + foldRegsUsed dflags f z (Just x) = foldRegsUsed dflags f z x + foldRegsUsed _ _ z Nothing = z -instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where - foldRegsDefd _ set [] = set - foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs +instance UserOfRegs r a => UserOfRegs r [a] where + foldRegsUsed _ _ set [] = set + foldRegsUsed dflags f set (x:xs) = foldRegsUsed dflags f (foldRegsUsed dflags f set x) xs -instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where - foldRegsDefd _ set Nothing = set - foldRegsDefd f set (Just x) = foldRegsDefd f set x +instance DefinerOfRegs r a => DefinerOfRegs r [a] where + foldRegsDefd _ _ set [] = set + foldRegsDefd dflags f set (x:xs) = foldRegsDefd dflags f (foldRegsDefd dflags f set x) xs + +instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where + foldRegsDefd _ _ set Nothing = set + foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x ----------------------------------------------------------------------------- -- Another reg utility @@ -424,3 +452,10 @@ globalRegType dflags Hp = gcWord dflags -- The initialiser for all -- dynamically allocated closures globalRegType dflags _ = bWord dflags + +isArgReg :: GlobalReg -> Bool +isArgReg (VanillaReg {}) = True +isArgReg (FloatReg {}) = True +isArgReg (DoubleReg {}) = True +isArgReg (LongReg {}) = True +isArgReg _ = False diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index e952c831ff..699469c116 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -90,7 +90,7 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) +mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) -- -- in the non-tables-next-to-code case, procs can have at most a -- single info table associated with the entry label of the proc. @@ -99,7 +99,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) = case topInfoTable proc of -- must be at most one -- no info table Nothing -> - return [CmmProc mapEmpty entry_lbl blocks] + return [CmmProc mapEmpty entry_lbl live blocks] Just info@CmmInfoTable { cit_lbl = info_lbl } -> do (top_decls, (std_info, extra_bits)) <- @@ -120,7 +120,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) -- Separately emit info table (with the function entry -- point as first entry) and the entry code return (top_decls ++ - [CmmProc mapEmpty entry_lbl blocks, + [CmmProc mapEmpty entry_lbl live blocks, mkDataLits Data info_lbl (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) @@ -134,7 +134,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) = do (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos) return (concat top_declss ++ - [CmmProc (mapFromList raw_infos) entry_lbl blocks]) + [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) where do_one_info (lbl,itbl) = do diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index de9f35a798..78bef17a42 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -111,9 +111,9 @@ cmmLayoutStack dflags procpoints entry_args -- We need liveness info. We could do removeDeadAssignments at -- the same time, but it buys nothing over doing cmmSink later, - -- and costs a lot more than just cmmLiveness. + -- and costs a lot more than just cmmLocalLiveness. -- (graph, liveness) <- removeDeadAssignments graph0 - let (graph, liveness) = (graph0, cmmLiveness graph0) + let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0) -- pprTrace "liveness" (ppr liveness) $ return () let blocks = postorderDfs graph @@ -132,7 +132,7 @@ cmmLayoutStack dflags procpoints entry_args layout :: DynFlags -> BlockSet -- proc points - -> BlockEnv CmmLive -- liveness + -> BlockEnv CmmLocalLive -- liveness -> BlockId -- entry -> ByteOff -- stack args on entry @@ -319,7 +319,7 @@ getStackLoc (Young l) n stackmaps = -- extra code that goes *after* the Sp adjustment. handleLastNode - :: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff + :: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff -> BlockEnv StackMap -> StackMap -> Block CmmNode O O -> CmmNode O C @@ -499,7 +499,7 @@ fixupStack old_stack new_stack = concatMap move new_locs setupStackFrame :: DynFlags -> BlockId -- label of continuation - -> BlockEnv CmmLive -- liveness + -> BlockEnv CmmLocalLive -- liveness -> ByteOff -- updfr -> ByteOff -- bytes of return values on stack -> StackMap -- current StackMap @@ -602,7 +602,7 @@ futureContinuation middle = foldBlockNodesB f middle Nothing -- on the stack and return the new StackMap and the assignments to do -- the saving. -- -allocate :: DynFlags -> ByteOff -> RegSet -> StackMap +allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap -> (StackMap, [CmmNode O O]) allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0 , sm_regs = regs0 } @@ -847,8 +847,8 @@ elimStackStores stackmap stackmaps area_off nodes setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl -setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g) - = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g +setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g) + = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g where fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = info_tbl { cit_rep = StackRep (get_liveness lbl) } diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 87a3ebfb5e..da7b094643 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -32,10 +32,10 @@ import Data.Maybe cmmLint :: (Outputable d, Outputable h) => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc -cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops +cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc -cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g +cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint dflags l p = @@ -46,18 +46,19 @@ runCmmLint dflags l p = nest 2 (ppr p)]) Right _ -> Nothing -lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint () -lintCmmDecl (CmmProc _ lbl g) - = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g -lintCmmDecl (CmmData {}) +lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint () +lintCmmDecl dflags (CmmProc _ lbl _ g) + = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g +lintCmmDecl _ (CmmData {}) = return () -lintCmmGraph :: CmmGraph -> CmmLint () -lintCmmGraph g = cmmLiveness g `seq` mapM_ (lintCmmBlock labels) blocks - -- cmmLiveness throws an error if there are registers - -- live on entry to the graph (i.e. undefined - -- variables) +lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint () +lintCmmGraph dflags g = + cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks + -- cmmLiveness throws an error if there are registers + -- live on entry to the graph (i.e. undefined + -- variables) where blocks = toBlockList g labels = setFromList (map entryLabel blocks) diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index f0163fefc4..7d674b76a2 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module CmmLive - ( CmmLive - , cmmLiveness + ( CmmLocalLive + , CmmGlobalLive + , cmmLocalLiveness + , cmmGlobalLiveness , liveLattice , noLiveOnEntry, xferLive, gen, kill, gen_kill , removeDeadAssignments @@ -12,6 +16,7 @@ module CmmLive where import UniqSupply +import DynFlags import BlockId import Cmm import CmmUtils @@ -26,10 +31,14 @@ import Outputable ----------------------------------------------------------------------------- -- | The variables live on entry to a block -type CmmLive = RegSet +type CmmLive r = RegSet r +type CmmLocalLive = CmmLive LocalReg +type CmmGlobalLive = CmmLive GlobalReg -- | The dataflow lattice -liveLattice :: DataflowLattice CmmLive +liveLattice :: Ord r => DataflowLattice (CmmLive r) +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-} +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-} liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add where add _ (OldFact old) (NewFact new) = (changeIf $ sizeRegSet join > sizeRegSet old, join) @@ -37,58 +46,73 @@ liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add -- | A mapping from block labels to the variables live on entry -type BlockEntryLiveness = BlockEnv CmmLive +type BlockEntryLiveness r = BlockEnv (CmmLive r) ----------------------------------------------------------------------------- -- | Calculated liveness info for a CmmGraph ----------------------------------------------------------------------------- -cmmLiveness :: CmmGraph -> BlockEntryLiveness -cmmLiveness graph = - check $ dataflowAnalBwd graph [] $ analBwd liveLattice xferLive +cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg +cmmLocalLiveness dflags graph = + check $ dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags) where entry = g_entry graph check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts +cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg +cmmGlobalLiveness dflags graph = + dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags) + -- | On entry to the procedure, there had better not be any LocalReg's live-in. -noLiveOnEntry :: BlockId -> CmmLive -> a -> a +noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a noLiveOnEntry bid in_fact x = if nullRegSet in_fact then x else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) -- | The transfer equations use the traditional 'gen' and 'kill' -- notations, which should be familiar from the Dragon Book. -gen :: UserOfLocalRegs a => a -> RegSet -> RegSet -gen a live = foldRegsUsed extendRegSet live a -kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet -kill a live = foldRegsDefd deleteFromRegSet live a +gen :: UserOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r +{-# INLINE gen #-} +gen dflags a live = foldRegsUsed dflags extendRegSet live a + +kill :: DefinerOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r +{-# INLINE kill #-} +kill dflags a live = foldRegsDefd dflags deleteFromRegSet live a -gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) - => a -> CmmLive -> CmmLive -gen_kill a = gen a . kill a +gen_kill :: (DefinerOfRegs r a, UserOfRegs r a) + => DynFlags -> a -> CmmLive r -> CmmLive r +{-# INLINE gen_kill #-} +gen_kill dflags a = gen dflags a . kill dflags a -- | The transfer function -xferLive :: BwdTransfer CmmNode CmmLive -xferLive = mkBTransfer3 fst mid lst +xferLive :: forall r . ( UserOfRegs r (CmmNode O O) + , DefinerOfRegs r (CmmNode O O) + , UserOfRegs r (CmmNode O C) + , DefinerOfRegs r (CmmNode O C)) + => DynFlags -> BwdTransfer CmmNode (CmmLive r) +{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive LocalReg) #-} +{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive GlobalReg) #-} +xferLive dflags = mkBTransfer3 fst mid lst where fst _ f = f - mid :: CmmNode O O -> CmmLive -> CmmLive - mid n f = gen_kill n f - lst :: CmmNode O C -> FactBase CmmLive -> CmmLive - lst n f = gen_kill n $ joinOutFacts liveLattice n f + mid :: CmmNode O O -> CmmLive r -> CmmLive r + mid n f = gen_kill dflags n f + lst :: CmmNode O C -> FactBase (CmmLive r) -> CmmLive r + lst n f = gen_kill dflags n $ joinOutFacts liveLattice n f ----------------------------------------------------------------------------- -- Removing assignments to dead variables ----------------------------------------------------------------------------- -removeDeadAssignments :: CmmGraph -> UniqSM (CmmGraph, BlockEnv CmmLive) -removeDeadAssignments g = - dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites +removeDeadAssignments :: DynFlags -> CmmGraph + -> UniqSM (CmmGraph, BlockEnv CmmLocalLive) +removeDeadAssignments dflags g = + dataflowPassBwd g [] $ analRewBwd liveLattice (xferLive dflags) rewrites where rewrites = mkBRewrite3 nothing middle nothing -- SDM: no need for deepBwdRw here, we only rewrite to empty -- Beware: deepBwdRw with one polymorphic function seems more -- reasonable here, but GHC panics while compiling, see bug -- #4045. - middle :: CmmNode O O -> Fact O CmmLive -> CmmReplGraph O O + middle :: CmmNode O O -> Fact O CmmLocalLive -> CmmReplGraph O O middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` live) = return $ Just emptyGraph @@ -99,5 +123,5 @@ removeDeadAssignments g = = return $ Just emptyGraph middle _ _ = return Nothing - nothing :: CmmNode e x -> Fact x CmmLive -> CmmReplGraph e x + nothing :: CmmNode e x -> Fact x CmmLocalLive -> CmmReplGraph e x nothing _ _ = return Nothing diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index b7bb270bd6..6fa3007fbe 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -1,5 +1,7 @@ -- CmmNode type for representation using Hoopl graphs. +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. @@ -16,7 +18,9 @@ module CmmNode ( mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors ) where +import CodeGen.Platform import CmmExpr +import DynFlags import FastString import ForeignCall import SMRep @@ -280,8 +284,8 @@ data ForeignTarget -- The target of a foreign call -------------------------------------------------- -- Instances of register and slot users / definers -instance UserOfLocalRegs (CmmNode e x) where - foldRegsUsed f z n = case n of +instance UserOfRegs LocalReg (CmmNode e x) where + foldRegsUsed dflags f z n = case n of CmmAssign _ expr -> fold f z expr CmmStore addr rval -> fold f (fold f z addr) rval CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args @@ -291,24 +295,58 @@ instance UserOfLocalRegs (CmmNode e x) where CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args _ -> z where fold :: forall a b. - UserOfLocalRegs a => + UserOfRegs LocalReg a => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsUsed f z n + fold f z n = foldRegsUsed dflags f z n -instance UserOfLocalRegs ForeignTarget where - foldRegsUsed _f z (PrimTarget _) = z - foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e +instance UserOfRegs GlobalReg (CmmNode e x) where + foldRegsUsed dflags f z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. + UserOfRegs GlobalReg a => + (b -> GlobalReg -> b) -> b -> a -> b + fold f z n = foldRegsUsed dflags f z n -instance DefinerOfLocalRegs (CmmNode e x) where - foldRegsDefd f z n = case n of +instance UserOfRegs r CmmExpr => UserOfRegs r ForeignTarget where + foldRegsUsed _ _ z (PrimTarget _) = z + foldRegsUsed dflags f z (ForeignTarget e _) = foldRegsUsed dflags f z e + +instance DefinerOfRegs LocalReg (CmmNode e x) where + foldRegsDefd dflags f z n = case n of CmmAssign lhs _ -> fold f z lhs CmmUnsafeForeignCall _ fs _ -> fold f z fs CmmForeignCall {res=res} -> fold f z res _ -> z where fold :: forall a b. - DefinerOfLocalRegs a => + DefinerOfRegs LocalReg a => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsDefd f z n + fold f z n = foldRegsDefd dflags f z n + +instance DefinerOfRegs GlobalReg (CmmNode e x) where + foldRegsDefd dflags f z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt) + CmmCall {} -> fold f z activeRegs + CmmForeignCall {tgt=tgt} -> fold f z (foreignTargetRegs tgt) + _ -> z + where fold :: forall a b. + DefinerOfRegs GlobalReg a => + (b -> GlobalReg -> b) -> b -> a -> b + fold f z n = foldRegsDefd dflags f z n + + platform = targetPlatform dflags + activeRegs = activeStgRegs platform + activeCallerSavesRegs = filter (callerSaves platform) activeRegs + + foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = [] + foreignTargetRegs _ = activeCallerSavesRegs ----------------------------------- diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index dffd417e07..0d44f0ffd5 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -419,10 +419,10 @@ exactLog2 x_ cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl -- XXX: revisit if we actually want to do this -- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts -cmmLoopifyForC dflags (CmmProc infos entry_lbl +cmmLoopifyForC dflags (CmmProc infos entry_lbl live (ListGraph blocks@(BasicBlock top_id _ : _))) = -- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ - CmmProc infos entry_lbl (ListGraph blocks') + CmmProc infos entry_lbl live (ListGraph blocks') where blocks' = [ BasicBlock id (map do_stmt stmts) | BasicBlock id stmts <- blocks ] diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index c483502cd9..dfa44ca274 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -482,7 +482,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } do let prof = NoProfilingInfo rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] return (mkCmmRetLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 , cit_rep = rep , cit_prof = prof, cit_srt = NoC_SRT }, []) } @@ -497,7 +497,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } bitmap = mkLiveness dflags (map Just (drop 1 live)) rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap return (mkCmmRetLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 , cit_rep = rep , cit_prof = prof, cit_srt = NoC_SRT }, live) } @@ -609,8 +609,9 @@ safety :: { Safety } vols :: { [GlobalReg] } : '[' ']' { [] } | '[' '*' ']' {% do df <- getDynFlags - ; return (realArgRegs df) } - -- all of them + ; return (realArgRegsCover df) } + -- All of them. See comment attached + -- to realArgRegsCover | '[' globals ']' { $2 } globals :: { [GlobalReg] } @@ -1064,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/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index aa8fa2c1f5..70ff754166 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -61,7 +61,7 @@ cpsTop hsc_env proc = -- later passes by removing lots of empty blocks, so we do it -- even when optimisation isn't turned on. -- - CmmProc h l g <- {-# SCC "cmmCfgOpts(1)" #-} + CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOptsProc splitting_proc_points proc dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g @@ -121,7 +121,7 @@ cpsTop hsc_env proc = dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ splitAtProcPoints dflags l call_pps proc_points pp_map - (CmmProc h l g) + (CmmProc h l v g) dumps Opt_D_dump_cmmz_split "Post splitting" gs ------------- Populate info tables with stack info ----------------- @@ -140,7 +140,7 @@ cpsTop hsc_env proc = else do -- attach info tables to return points - g <- return $ attachContInfoTables call_pps (CmmProc h l g) + g <- return $ attachContInfoTables call_pps (CmmProc h l v g) ------------- Populate info tables with stack info ----------------- g <- {-# SCC "setInfoTableStackMap" #-} diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index ddccf7ba49..02b232d488 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -18,6 +18,7 @@ import Cmm import PprCmm () import CmmUtils import CmmInfo +import CmmLive (cmmGlobalLiveness) import Data.List (sortBy) import Maybes import Control.Monad @@ -210,7 +211,7 @@ splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockE CmmDecl -> UniqSM [CmmDecl] splitAtProcPoints dflags entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) - top_l g@(CmmGraph {g_entry=entry})) = + top_l _ g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach let addBlock b graphEnv = case mapLookup bid procMap of @@ -226,6 +227,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap where graph = mapLookup procId graphEnv `orElse` mapEmpty graph' = mapInsert bid b graph + let liveness = cmmGlobalLiveness dflags g + let ppLiveness pp = filter isArgReg $ + regSetToList $ + expectJust "ppLiveness" $ mapLookup pp liveness + graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g -- Build a map from proc point BlockId to pairs of: @@ -248,8 +254,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap let add_jump_block (env, bs) (pp, l) = do bid <- liftM mkBlockId getUniqueM let b = blockJoin (CmmEntry bid) emptyBlock jump - jump = CmmCall (CmmLit (CmmLabel l)) Nothing [{-XXX-}] 0 0 0 - -- XXX: No regs are live at the call + live = ppLiveness pp + jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 return (mapInsert pp bid env, b : bs) add_jumps newGraphEnv (ppId, blockEnv) = @@ -293,17 +299,19 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap | bid == entry = CmmProc (TopInfo {info_tbls = info_tbls, stack_info = stack_info}) - top_l (replacePPIds g) + top_l live g' | otherwise = case expectJust "pp label" $ mapLookup bid procLabels of (lbl, Just info_lbl) -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) , stack_info=stack_info}) - lbl (replacePPIds g) + lbl live g' (lbl, Nothing) -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) - lbl (replacePPIds g) + lbl live g' where + g' = replacePPIds g + live = ppLiveness (g_entry g') stack_info = StackInfo { arg_space = 0 , updfr_space = Nothing , do_layout = True } @@ -333,7 +341,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap procs splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] - -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a -- recursive lookup, see comment below. replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph @@ -358,8 +365,8 @@ replaceBranches env cmmg -- Not splitting proc points: add info tables for continuations attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl -attachContInfoTables call_proc_points (CmmProc top_info top_l g) - = CmmProc top_info{info_tbls = info_tbls'} top_l g +attachContInfoTables call_proc_points (CmmProc top_info top_l live g) + = CmmProc top_info{info_tbls = info_tbls'} top_l live g where info_tbls' = mapUnion (info_tbls top_info) $ mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs index 0f2aeaa939..8381d12e7c 100644 --- a/compiler/cmm/CmmRewriteAssignments.hs +++ b/compiler/cmm/CmmRewriteAssignments.hs @@ -42,11 +42,11 @@ rewriteAssignments dflags g = do -- first perform usage analysis and bake this information into the -- graph (backwards transform), and then do a forwards transform -- to actually perform inlining and sinking. - g' <- annotateUsage g + g' <- annotateUsage dflags g g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $ analRewFwd assignmentLattice (assignmentTransfer dflags) - (assignmentRewrite `thenFwdRw` machOpFoldRewrite dflags) + (assignmentRewrite dflags `thenFwdRw` machOpFoldRewrite dflags) return (modifyGraph eraseRegUsage g'') ---------------------------------------------------------------- @@ -159,13 +159,13 @@ data WithRegUsage n e x where Plain :: n e x -> WithRegUsage n e x AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O -instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where - foldRegsUsed f z (Plain n) = foldRegsUsed f z n - foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e +instance UserOfRegs LocalReg (n e x) => UserOfRegs LocalReg (WithRegUsage n e x) where + foldRegsUsed dflags f z (Plain n) = foldRegsUsed dflags f z n + foldRegsUsed dflags f z (AssignLocal _ e _) = foldRegsUsed dflags f z e -instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where - foldRegsDefd f z (Plain n) = foldRegsDefd f z n - foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r +instance DefinerOfRegs LocalReg (n e x) => DefinerOfRegs LocalReg (WithRegUsage n e x) where + foldRegsDefd dflags f z (Plain n) = foldRegsDefd dflags f z n + foldRegsDefd dflags f z (AssignLocal r _ _) = foldRegsDefd dflags f z r instance NonLocal n => NonLocal (WithRegUsage n) where entryLabel (Plain n) = entryLabel n @@ -190,8 +190,8 @@ usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f) -- We reuse the names 'gen' and 'kill', although we're doing something -- slightly different from the Dragon Book -usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap -usageTransfer = mkBTransfer3 first middle last +usageTransfer :: DynFlags -> BwdTransfer (WithRegUsage CmmNode) UsageMap +usageTransfer dflags = mkBTransfer3 first middle last where first _ f = f middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap middle n f = gen_kill n f @@ -209,9 +209,9 @@ usageTransfer = mkBTransfer3 first middle last gen_kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap gen_kill a = gen a . kill a gen :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap - gen a f = foldRegsUsed increaseUsage f a + gen a f = foldLocalRegsUsed dflags increaseUsage f a kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap - kill a f = foldRegsDefd delFromUFM f a + kill a f = foldLocalRegsDefd dflags delFromUFM f a increaseUsage f r = addToUFM_C combine f r SingleUse where combine _ _ = ManyUse @@ -228,11 +228,11 @@ usageRewrite = mkBRewrite3 first middle last last _ _ = return Nothing type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode) -annotateUsage :: CmmGraph -> UniqSM (CmmGraphWithRegUsage) -annotateUsage vanilla_g = +annotateUsage :: DynFlags -> CmmGraph -> UniqSM (CmmGraphWithRegUsage) +annotateUsage dflags vanilla_g = let g = modifyGraph liftRegUsage vanilla_g in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $ - analRewBwd usageLattice usageTransfer usageRewrite + analRewBwd usageLattice (usageTransfer dflags) usageRewrite ---------------------------------------------------------------- --- Assignment tracking @@ -286,8 +286,8 @@ assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUF -- Deletes sinks from assignment map, because /this/ is the place -- where it will be sunk to. -deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap -deleteSinks n m = foldRegsUsed (adjustUFM f) m n +deleteSinks :: UserOfRegs LocalReg n => DynFlags -> n -> AssignmentMap -> AssignmentMap +deleteSinks dflags n m = foldLocalRegsUsed dflags (adjustUFM f) m n where f (AlwaysSink _) = NeverOptimize f old = old @@ -319,8 +319,8 @@ middleAssignment :: DynFlags -> WithRegUsage CmmNode O O -> AssignmentMap -- the correct optimization policy. -- 3. Look for all assignments that reference that register and -- invalidate them. -middleAssignment _ n@(AssignLocal r e usage) assign - = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign +middleAssignment dflags n@(AssignLocal r e usage) assign + = invalidateUsersOf (CmmLocal r) . add . deleteSinks dflags n $ assign where add m = addToUFM m r $ case usage of SingleUse -> AlwaysInline e @@ -339,8 +339,8 @@ middleAssignment _ n@(AssignLocal r e usage) assign -- 1. Delete any sinking assignments that were used by this instruction -- 2. Look for all assignments that reference this register and -- invalidate them. -middleAssignment _ (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign - = invalidateUsersOf reg . deleteSinks n $ assign +middleAssignment dflags (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign + = invalidateUsersOf reg . deleteSinks dflags n $ assign -- Algorithm for unannotated assignments of *local* registers: do -- nothing (it's a reload, so no state should have changed) @@ -351,7 +351,7 @@ middleAssignment _ (Plain (CmmAssign (CmmLocal _) _)) assign = assign -- 2. Look for all assignments that load from memory locations that -- were clobbered by this store and invalidate them. middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign - = let m = deleteSinks n assign + = let m = deleteSinks dflags n assign in foldUFM_Directly f m m -- [foldUFM performance] where f u (xassign -> Just x) m | clobbers dflags (lhs, rhs) (u, x) = addToUFM_Directly m u NeverOptimize f _ _ m = m @@ -373,7 +373,7 @@ middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign -- store extra information about expressions that allow this and other -- checks to be done cheaply.) middleAssignment dflags (Plain n@(CmmUnsafeForeignCall{})) assign - = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n) + = deleteCallerSaves (foldLocalRegsDefd dflags (\m r -> addToUFM m r NeverOptimize) (deleteSinks dflags n assign) n) where deleteCallerSaves m = foldUFM_Directly f m m f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize f _ _ m = m @@ -442,10 +442,10 @@ overlaps (_, o, w) (_, o', w') = s' = o' - w' in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK -lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)] -lastAssignment (Plain (CmmCall _ (Just k) _ _ _ _)) assign = [(k, invalidateVolatile k assign)] -lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)] -lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l +lastAssignment :: DynFlags -> WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)] +lastAssignment _ (Plain (CmmCall _ (Just k) _ _ _ _)) assign = [(k, invalidateVolatile k assign)] +lastAssignment _ (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)] +lastAssignment dflags l assign = map (\id -> (id, deleteSinks dflags l assign)) $ successors l -- Invalidates any expressions that have volatile contents: essentially, -- all terminals volatile except for literals and loads of stack slots @@ -471,7 +471,7 @@ assignmentTransfer :: DynFlags assignmentTransfer dflags = mkFTransfer3 (flip const) (middleAssignment dflags) - ((mkFactBase assignmentLattice .) . lastAssignment) + ((mkFactBase assignmentLattice .) . lastAssignment dflags) -- Note [Soundness of inlining] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -533,8 +533,8 @@ assignmentTransfer dflags -- values from the assignment map, due to reassignment of the local -- register.) This is probably not locally sound. -assignmentRewrite :: FwdRewrite UniqSM (WithRegUsage CmmNode) AssignmentMap -assignmentRewrite = mkFRewrite3 first middle last +assignmentRewrite :: DynFlags -> FwdRewrite UniqSM (WithRegUsage CmmNode) AssignmentMap +assignmentRewrite dflags = mkFRewrite3 first middle last where first _ _ = return Nothing middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O @@ -543,7 +543,7 @@ assignmentRewrite = mkFRewrite3 first middle last last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l -- Tuple is (inline?, reloads for sinks) precompute :: AssignmentMap -> CmmNode O x -> (Bool, [WithRegUsage CmmNode O O]) - precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless + precompute assign n = foldLocalRegsUsed dflags f (False, []) n -- duplicates are harmless where f (i, l) r = case lookupUFM assign r of Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l) Just (AlwaysInline _) -> (True, l) diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 7553e37325..2a080c2e58 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -125,7 +125,7 @@ type Assignment = (LocalReg, CmmExpr, AbsMem) cmmSink :: DynFlags -> CmmGraph -> CmmGraph cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks where - liveness = cmmLiveness graph + liveness = cmmLocalLiveness dflags graph getLive l = mapFindWithDefault Set.empty l liveness blocks = postorderDfs graph @@ -147,8 +147,8 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks -- the node. This will help us decide whether we can inline -- an assignment in the current node or not. live = Set.unions (map getLive succs) - live_middle = gen_kill last live - ann_middles = annotate live_middle (blockToList middle) + live_middle = gen_kill dflags last live + ann_middles = annotate dflags live_middle (blockToList middle) -- Now sink and inline in this block (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk) @@ -187,7 +187,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks upd set | r `Set.member` set = set `Set.union` live_rhs | otherwise = set - live_rhs = foldRegsUsed extendRegSet emptyRegSet rhs + live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs final_middle = foldl blockSnoc middle' dropped_last @@ -215,9 +215,9 @@ isTrivial _ = False -- -- annotate each node with the set of registers live *after* the node -- -annotate :: RegSet -> [CmmNode O O] -> [(RegSet, CmmNode O O)] -annotate live nodes = snd $ foldr ann (live,[]) nodes - where ann n (live,nodes) = (gen_kill n live, (live,n) : nodes) +annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)] +annotate dflags live nodes = snd $ foldr ann (live,[]) nodes + where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes) -- -- Find the blocks that have multiple successors (join points) @@ -234,7 +234,7 @@ findJoinPoints blocks = mapFilter (>1) succ_counts -- filter the list of assignments to remove any assignments that -- are not live in a continuation. -- -filterAssignments :: DynFlags -> RegSet -> [Assignment] -> [Assignment] +filterAssignments :: DynFlags -> LocalRegSet -> [Assignment] -> [Assignment] filterAssignments dflags live assigs = reverse (go assigs []) where go [] kept = kept go (a@(r,_,_):as) kept | needed = go as (a:kept) @@ -251,7 +251,7 @@ filterAssignments dflags live assigs = reverse (go assigs []) -- as we go. walk :: DynFlags - -> [(RegSet, CmmNode O O)] -- nodes of the block, annotated with + -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with -- the set of registers live *after* -- this node. @@ -310,7 +310,7 @@ shouldSink _ _other = Nothing -- out of inlining, but the inliner will see that r is live -- after the instruction and choose not to inline r in the rhs. -- -shouldDiscard :: CmmNode e x -> RegSet -> Bool +shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool shouldDiscard node live = case node of CmmAssign r (CmmReg r') | r == r' -> True @@ -346,7 +346,7 @@ dropAssignments dflags should_drop state assigs tryToInline :: DynFlags - -> RegSet -- set of registers live after this + -> LocalRegSet -- set of registers live after this -- node. We cannot inline anything -- that is live after the node, unless -- it is small enough to duplicate. @@ -360,7 +360,7 @@ tryToInline tryToInline dflags live node assigs = go usages node [] assigs where usages :: UniqFM Int - usages = foldRegsUsed addUsage emptyUFM node + usages = foldRegsUsed dflags addUsage emptyUFM node go _usages node _skipped [] = (node, []) @@ -371,14 +371,14 @@ tryToInline dflags live node assigs = go usages node [] assigs | otherwise = dont_inline where inline_and_discard = go usages' inl_node skipped rest - where usages' = foldRegsUsed addUsage usages rhs + where usages' = foldRegsUsed dflags addUsage usages rhs dont_inline = keep node -- don't inline the assignment, keep it inline_and_keep = keep inl_node -- inline the assignment, keep it keep node' = (final_node, a : rest') where (final_node, rest') = go usages' node' (l:skipped) rest - usages' = foldRegsUsed (\m r -> addToUFM m r 2) usages rhs + usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2) usages rhs -- we must not inline anything that is mentioned in the RHS -- of a binding that we have already skipped, so we set the -- usages of the regs on the RHS to 2. @@ -458,7 +458,7 @@ conflicts dflags (r, rhs, addr) node -- (1) an assignment to a register conflicts with a use of the register | CmmAssign reg _ <- node, reg `regUsedIn` rhs = True - | foldRegsUsed (\b r' -> r == r' || b) False node = True + | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True -- (2) a store to an address conflicts with a read of the same memory | CmmStore addr' e <- node diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 1e2ddfadd1..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) @@ -304,20 +298,20 @@ stackStubExpr w = CmmLit (CmmInt 0 w) copyInOflow :: DynFlags -> Convention -> Area -> [CmmFormal] -> [CmmFormal] - -> (Int, CmmAGraph) + -> (Int, [GlobalReg], CmmAGraph) copyInOflow dflags conv area formals extra_stk - = (offset, catAGraphs $ map mkMiddle nodes) - where (offset, nodes) = copyIn dflags conv area formals extra_stk + = (offset, gregs, catAGraphs $ map mkMiddle nodes) + where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. copyIn :: DynFlags -> Convention -> Area -> [CmmFormal] -> [CmmFormal] - -> (ByteOff, [CmmNode O O]) + -> (ByteOff, [GlobalReg], [CmmNode O O]) copyIn dflags conv area formals extra_stk - = (stk_size, map ci (stk_args ++ args)) + = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) where ci (reg, RegisterParam r) = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) @@ -386,7 +380,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] - -> (Int, CmmAGraph) + -> (Int, [GlobalReg], CmmAGraph) mkCallEntry dflags conv formals extra_stk = copyInOflow dflags conv Old formals extra_stk diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index cf05db92b8..fccdd8137d 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + ----------------------------------------------------------------------------- -- -- Old-style Cmm data types @@ -86,8 +88,8 @@ type RawCmmDecl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt data GenBasicBlock i = BasicBlock BlockId [i] type CmmBasicBlock = GenBasicBlock CmmStmt -instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where - foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l +instance UserOfRegs r i => UserOfRegs r (GenBasicBlock i) where + foldRegsUsed dflags f set (BasicBlock _ l) = foldRegsUsed dflags f set l -- | The branch block id is that of the first block in -- the branch, which is that branch's entry point @@ -103,7 +105,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) -- | Returns the info table associated with the CmmDecl's entry point, -- if any. topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i -topInfoTable (CmmProc infos _ (ListGraph (b:_))) +topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) = mapLookup (blockId b) infos topInfoTable _ = Nothing @@ -116,8 +118,8 @@ cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g' cmmMapGraph f tops = map (cmmTopMapGraph f) tops cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' -cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g) -cmmTopMapGraph _ (CmmData s ds) = CmmData s ds +cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g) +cmmTopMapGraph _ (CmmData s ds) = CmmData s ds ----------------------------------------------------------------------------- -- CmmStmt @@ -156,7 +158,7 @@ data CmmStmt | CmmJump -- Jump to another C-- function, CmmExpr -- Target - (Maybe [GlobalReg]) -- Live registers at call site; + [GlobalReg] -- Live registers at call site; -- Nothing -> no information, assume -- all live -- Just .. -> info on liveness, [] @@ -187,8 +189,8 @@ data CmmSafety | CmmInterruptible -- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]' -instance UserOfLocalRegs CmmStmt where - foldRegsUsed f (set::b) s = stmt s set +instance UserOfRegs LocalReg CmmStmt where + foldRegsUsed dflags f (set::b) s = stmt s set where stmt :: CmmStmt -> b -> b stmt (CmmNop) = id @@ -202,18 +204,18 @@ instance UserOfLocalRegs CmmStmt where stmt (CmmJump e _) = gen e stmt (CmmReturn) = id - gen :: UserOfLocalRegs a => a -> b -> b - gen a set = foldRegsUsed f set a + gen :: UserOfRegs LocalReg a => a -> b -> b + gen a set = foldRegsUsed dflags f set a -instance UserOfLocalRegs CmmCallTarget where - foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e - foldRegsUsed f set (CmmPrim _ mStmts) = foldRegsUsed f set mStmts +instance UserOfRegs LocalReg CmmCallTarget where + foldRegsUsed dflags f set (CmmCallee e _) = foldRegsUsed dflags f set e + foldRegsUsed dflags f set (CmmPrim _ mStmts) = foldRegsUsed dflags f set mStmts -instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where - foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a) +instance UserOfRegs r a => UserOfRegs r (CmmHinted a) where + foldRegsUsed dflags f set a = foldRegsUsed dflags f set (hintlessCmm a) -instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where - foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a) +instance DefinerOfRegs r a => DefinerOfRegs r (CmmHinted a) where + foldRegsDefd dflags f set a = foldRegsDefd dflags f set (hintlessCmm a) {- Discussion diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index f158369b13..9a4fb42bc5 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -48,7 +48,7 @@ runCmmLint _ l p = Right _ -> Nothing lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmDecl dflags (CmmProc _ lbl (ListGraph blocks)) +lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks)) = addLintInfo (text "in proc " <> ppr lbl) $ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks in mapM_ (lintCmmBlock dflags labels) blocks diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index dcde86e37c..edfaef8098 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -161,7 +161,7 @@ genCondBranch expr ident = -- -- jump foo(a, b, c); -- -genJump :: CmmExpr -> Maybe [GlobalReg] -> SDoc +genJump :: CmmExpr -> [GlobalReg] -> SDoc genJump expr live = hcat [ ptext (sLit "jump") , space @@ -171,7 +171,7 @@ genJump expr live = CmmLoad (CmmReg _) _ -> pprExpr expr _ -> parens (pprExpr expr) , semi <+> ptext (sLit "// ") - , maybe empty ppr live] + , ppr live] -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index e07bd6459d..e0ff99cb29 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -81,7 +81,7 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops -- top level procs -- pprTop :: RawCmmDecl -> SDoc -pprTop proc@(CmmProc _ clbl (ListGraph blocks)) = +pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) = (case topInfoTable proc of Nothing -> empty Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 2cb90e9a22..354a3d4563 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -92,9 +92,9 @@ pprCmmGroup tops pprTop :: (Outputable d, Outputable info, Outputable i) => GenCmmDecl d info i -> SDoc -pprTop (CmmProc info lbl graph) +pprTop (CmmProc info lbl live graph) - = vcat [ ppr lbl <> lparen <> rparen + = vcat [ ppr lbl <> lparen <> rparen <+> ptext (sLit "// ") <+> ppr live , nest 8 $ lbrace <+> ppr info $$ rbrace , nest 4 $ ppr graph , rbrace ] diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 1f0b82532b..67d8fd8817 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -36,10 +36,16 @@ baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags -baseRegOffset _ (FloatReg n) = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")") +baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags +baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags +baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags -baseRegOffset _ (DoubleReg n) = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")") +baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags +baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags +baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags +baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags +baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags @@ -90,9 +96,9 @@ get_Regtable_addr_from_offset dflags _ offset = fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) = +fixStgRegisters dflags (CmmProc info lbl live (ListGraph blocks)) = let blocks' = map (fixStgRegBlock dflags) blocks - in CmmProc info lbl $ ListGraph blocks' + in CmmProc info lbl live $ ListGraph blocks' fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock fixStgRegBlock dflags (BasicBlock id stmts) = diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index a0859252ff..9176cb330c 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -717,7 +717,7 @@ emitEnter fun = do -- AssignTo res_regs _ -> do { lret <- newLabelC - ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] + ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] ; lcall <- newLabelC ; updfr_off <- getUpdFrameOff ; let area = Young lret diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index e7925667a8..aef1e4f792 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -213,7 +213,7 @@ emitForeignCall safety results target args updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target k <- newLabelC - let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results [] + let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results [] -- see Note [safe foreign call convention] emit $ ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) @@ -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/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 7393faac9f..7805473915 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -416,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do Nothing -> genericGC checkYield code Just gc -> do lret <- newLabelC - let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] + let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] lcont <- newLabelC emitOutOfLine lret (copyin <*> mkBranch lcont) emitLabel lcont diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 39676635aa..bb0b8a78d0 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -126,7 +126,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack AssignTo res_regs _ -> do k <- newLabelC let area = Young k - (off, copyin) = copyInOflow dflags retConv area res_regs [] + (off, _, copyin) = copyInOflow dflags retConv area res_regs [] copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off extra_stack emit (copyout <*> mkLabel k <*> copyin) @@ -521,7 +521,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body ; let args' = if node_points then (node : arg_regs) else arg_regs conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall else NativeDirectCall - (offset, _) = mkCallEntry dflags conv args' [] + (offset, _, _) = mkCallEntry dflags conv args' [] ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index b7797bdae6..7a0816f041 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -713,12 +713,12 @@ emitProcWithStackFrame emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False = do { dflags <- getDynFlags - ; emitProc_ mb_info lbl blocks (widthInBytes (wordWidth dflags)) False + ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False } emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout = do { dflags <- getDynFlags - ; let (offset, entry) = mkCallEntry dflags conv args stk_args - ; emitProc_ mb_info lbl (entry <*> blocks) offset True + ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args + ; emitProc_ mb_info lbl live (entry <*> blocks) offset True } emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" @@ -729,13 +729,13 @@ emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel emitProcWithConvention conv mb_info lbl args blocks = emitProcWithStackFrame conv mb_info lbl [] args blocks True -emitProc :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> FCode () -emitProc mb_info lbl blocks offset - = emitProc_ mb_info lbl blocks offset True +emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode () +emitProc mb_info lbl live blocks offset + = emitProc_ mb_info lbl live blocks offset True -emitProc_ :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> Bool +emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool -> FCode () -emitProc_ mb_info lbl blocks offset do_layout +emitProc_ mb_info lbl live blocks offset do_layout = do { dflags <- getDynFlags ; l <- newLabelC ; let @@ -751,7 +751,7 @@ emitProc_ mb_info lbl blocks offset do_layout tinfo = TopInfo { info_tbls = infos , stack_info=sinfo} - proc_block = CmmProc tinfo lbl blks + proc_block = CmmProc tinfo lbl live blks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } @@ -795,7 +795,7 @@ mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags k <- newLabelC let area = Young k - (off, copyin) = copyInOflow dflags retConv area results [] + (off, _, copyin) = copyInOflow dflags retConv area results [] copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack return (copyout <*> mkLabel k <*> copyin) 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/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index fb579ab672..6e9a7acbb3 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -42,6 +42,7 @@ import MkCore import DynFlags import CostCentre import Id +import Module import VarSet import VarEnv import DataCon @@ -296,7 +297,7 @@ dsExpr (ExplicitTuple tup_args boxity) (map (Type . exprType) args ++ args) } dsExpr (HsSCC cc expr@(L loc _)) = do - mod_name <- getModuleDs + mod_name <- getModule count <- goptM Opt_ProfCountEntries uniq <- newUnique Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 0cf4b97159..bf06be109f 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 ">" @@ -404,7 +401,7 @@ dsFExportDynamic :: Id -> DsM ([Binding], SDoc, SDoc) dsFExportDynamic id co0 cconv = do fe_id <- newSysLocalDs ty - mod <- getModuleDs + mod <- getModule dflags <- getDynFlags let -- hack: need to get at the name of the C stub we're about to generate. diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 1af39d1a0f..bc71fa8493 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -23,6 +23,7 @@ import DsMonad import DsUtils import TysWiredIn import PrelNames +import Module import Name import SrcLoc import Outputable @@ -146,7 +147,7 @@ isTrueLHsExpr (L _ (HsTick tickish e)) isTrueLHsExpr (L _ (HsBinTick ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x - this_mod <- getModuleDs + this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 6ed0f64a06..bc0e2e14dc 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -16,7 +16,6 @@ module DsMonad ( duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, newFailLocalDs, newPredVarDs, getSrcSpanDs, putSrcSpanDs, - getModuleDs, mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, @@ -167,6 +166,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 @@ -349,9 +351,6 @@ the @SrcSpan@ being carried around. getGhcModeDs :: DsM GhcMode getGhcModeDs = getDynFlags >>= return . ghcMode -getModuleDs :: DsM Module -getModuleDs = do { env <- getGblEnv; return (ds_mod env) } - getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) } diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 0b14946793..609041ba24 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -67,6 +67,7 @@ import TysWiredIn import BasicTypes import UniqSet import UniqSupply +import Module import PrelNames import Outputable import SrcLoc @@ -759,7 +760,7 @@ mkOptTickBox (Just tickish) e = Tick tickish e mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr mkBinaryTickBox ixT ixF e = do uq <- newUnique - this_mod <- getModuleDs + this_mod <- getModule let bndr1 = mkSysLocal (fsLit "t1") uq boolTy let falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 4ff09eff66..17b30424c6 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -207,8 +207,8 @@ sizeSS (SizedSeq n _) = n data Operand = Op Word | SmallOp Word16 - | LargeOp Word | LabelOp Word16 +-- (unused) | LargeOp Word data Assembler a = AllocPtr (IO BCOPtr) (Word -> Assembler a) @@ -244,10 +244,10 @@ type LabelEnv = Word16 -> Word largeOp :: Bool -> Operand -> Bool largeOp long_jumps op = case op of - LargeOp _ -> True - SmallOp _ -> False - Op w -> isLarge w - LabelOp _ -> long_jumps + SmallOp _ -> False + Op w -> isLarge w + LabelOp _ -> long_jumps +-- LargeOp _ -> True runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> State AsmState IO a runAsm dflags long_jumps e = go @@ -272,9 +272,9 @@ runAsm dflags long_jumps e = go | otherwise = w words = concatMap expand ops expand (SmallOp w) = [w] - expand (LargeOp w) = largeArg dflags w expand (LabelOp w) = expand (Op (e w)) expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w] +-- expand (LargeOp w) = largeArg dflags w State $ \(st_i0,st_l0,st_p0) -> do let st_i1 = addListToSS st_i0 (opcode : words) return ((st_i1,st_l0,st_p0), ()) @@ -306,9 +306,9 @@ inspectAsm dflags long_jumps initial_offset size = sum (map count ops) + 1 largeOps = any (largeOp long_jumps) ops count (SmallOp _) = 1 - count (LargeOp _) = largeArg16s dflags count (LabelOp _) = count (Op 0) count (Op _) = if largeOps then largeArg16s dflags else 1 +-- count (LargeOp _) = largeArg16s dflags -- Bring in all the bci_ bytecode constants. #include "rts/Bytecodes.h" diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index bf49a98a3b..49e943c0de 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -749,7 +749,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- In such case, we return a best approximation: -- ignore the unpointed args, and recover the pointeds -- This preserves laziness, and should be safe. - traceTR (text "Nothing" <+> ppr dcname) + traceTR (text "Not constructor" <+> ppr dcname) let dflags = hsc_dflags hsc_env tag = showPpr dflags dcname vars <- replicateM (length$ elems$ ptrs clos) @@ -758,7 +758,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do | (i, tv) <- zip [0..] vars] return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) Just dc -> do - traceTR (text "Just" <+> ppr dc) + traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) subTtypes <- getDataConArgTys dc my_ty subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes return (Term my_ty (Right dc) a subTerms) @@ -939,14 +939,16 @@ getDataConArgTys :: DataCon -> Type -> TR [Type] -- not be fully known. Moreover, the arg types might involve existentials; -- if so, make up fresh RTTI type variables for them getDataConArgTys dc con_app_ty - = do { (_, ex_tys, _) <- instTyVars ex_tvs + = do { (_, ex_tys, ex_subst) <- instTyVars ex_tvs ; let UnaryRep rep_con_app_ty = repType con_app_ty + ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty)) ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of Just (tc, ty_args) | dataConTyCon dc == tc -> ASSERT( univ_tvs `equalLength` ty_args) return ty_args - _ -> do { (_, ty_args, subst) <- instTyVars univ_tvs - ; let res_ty = substTy subst (dataConOrigResTy dc) + _ -> do { (_, ty_args, univ_subst) <- instTyVars univ_tvs + ; let res_ty = substTy ex_subst (substTy univ_subst (dataConOrigResTy dc)) + -- See Note [Constructor arg types] ; addConstraint rep_con_app_ty res_ty ; return ty_args } -- It is necessary to check dataConTyCon dc == tc @@ -954,11 +956,38 @@ getDataConArgTys dc con_app_ty -- newtype and tcSplitTyConApp has not removed it. In -- that case, we happily give up and don't match ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys) + ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr ty_args $$ ppr subst)) ; return (substTys subst (dataConRepArgTys dc)) } where univ_tvs = dataConUnivTyVars dc ex_tvs = dataConExTyVars dc +{- Note [Constructor arg types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a GADT (cf Trac #7386) + data family D a b + data instance D [a] b where + MkT :: b -> D [a] (Maybe b) + +In getDataConArgTys +* con_app_ty is the known type (from outside) of the constructor application, + say D [Int] Bool + +* The data constructor MkT has a (representation) dataConTyCon = DList, + say where + data DList a b where + MkT :: b -> DList a (Maybe b) + +So the dataConTyCon of the data constructor, DList, differs from +the "outside" type, D. So we can't straightforwardly decompose the +"outside" type, and we end up in the "_" branch of the case. + +Then we match the dataConOrigResTy of the data constructor against the +outside type, hoping to get a substitution that tells how to instantiate +the *representation* type constructor. This looks a bit delicate to +me, but it seems to work. +-} + -- Soundness checks -------------------- {- diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 211620ac42..571348f577 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -41,11 +41,11 @@ llvmCodeGen dflags h us cmms (cdata,env) = {-# SCC "llvm_split" #-} foldr split ([], initLlvmEnv dflags) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) - split p@(CmmProc _ l _) (d,e) = + split p@(CmmProc _ l live _) (d,e) = let lbl = strCLabel_llvm env $ case topInfoTable p of Nothing -> l Just (Statics info_lbl _) -> info_lbl - env' = funInsert lbl (llvmFunTy dflags) e + env' = funInsert lbl (llvmFunTy dflags live) e in (d,env') in do showPass dflags "LlVM CodeGen" @@ -129,7 +129,7 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars = cmmProcLlvmGens dflags h us env cmms count ivars -cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars +cmmProcLlvmGens dflags h us env ((CmmProc _ _ _ (ListGraph [])) : cmms) count ivars = cmmProcLlvmGens dflags h us env cmms count ivars cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 86fab77ad9..849e40d203 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -7,6 +7,7 @@ module LlvmCodeGen.Base ( LlvmCmmDecl, LlvmBasicBlock, + LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion, @@ -46,6 +47,9 @@ import Unique type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) type LlvmBasicBlock = GenBasicBlock LlvmStatement +-- | Global registers live on proc entry +type LiveGlobalRegs = [GlobalReg] + -- | Unresolved code. -- Of the form: (data label, data type, unresolved data) type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic]) @@ -88,29 +92,29 @@ llvmGhcCC dflags | otherwise = CC_Ncc 10 -- | Llvm Function type for Cmm function -llvmFunTy :: DynFlags -> LlvmType -llvmFunTy dflags = LMFunction $ llvmFunSig' dflags (fsLit "a") ExternallyVisible +llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType +llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible -- | Llvm Function signature -llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig env lbl link - = llvmFunSig' (getDflags env) (strCLabel_llvm env lbl) link +llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl +llvmFunSig env live lbl link + = llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link -llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig' dflags lbl link +llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl +llvmFunSig' dflags live lbl link = let toParams x | isPointer x = (x, [NoAlias, NoCapture]) | otherwise = (x, []) in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs dflags)) + (map (toParams . getVarType) (llvmFunArgs dflags live)) (llvmFunAlign dflags) -- | Create a Haskell function in LLVM. -mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks +mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks -> LlvmFunction -mkLlvmFunc env lbl link sec blks +mkLlvmFunc env live lbl link sec blks = let dflags = getDflags env - funDec = llvmFunSig env lbl link - funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags) + funDec = llvmFunSig env live lbl link + funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags live) in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks -- | Alignment to use for functions @@ -122,9 +126,15 @@ llvmInfAlign :: DynFlags -> LMAlign llvmInfAlign dflags = Just (wORD_SIZE dflags) -- | A Function's arguments -llvmFunArgs :: DynFlags -> [LlvmVar] -llvmFunArgs dflags = map (lmGlobalRegArg dflags) (activeStgRegs platform) +llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] +llvmFunArgs dflags live = + map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform)) where platform = targetPlatform dflags + isLive r = not (isFloat r) || r `elem` alwaysLive || r `elem` live + isPassed r = not (isFloat r) || isLive r + isFloat (FloatReg _) = True + isFloat (DoubleReg _) = True + isFloat _ = False -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr] diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 73cd98f63a..d62fbf4397 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -37,10 +37,10 @@ type LlvmStatements = OrdList LlvmStatement -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env proc0@(CmmProc _ lbl (ListGraph blocks)) = do - (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) +genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do + (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) let info = topInfoTable proc0 - proc = CmmProc info lbl (ListGraph lmblocks) + proc = CmmProc info lbl live (ListGraph lmblocks) return (env', proc:lmdata) genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" @@ -51,22 +51,23 @@ genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" -- | Generate code for a list of blocks that make up a complete procedure. basicBlocksCodeGen :: LlvmEnv + -> LiveGlobalRegs -> [CmmBasicBlock] -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -basicBlocksCodeGen env ([]) (blocks, tops) +basicBlocksCodeGen env live ([]) (blocks, tops) = do let dflags = getDflags env let (blocks', allocs) = mapAndUnzip dominateAllocs blocks let allocs' = concat allocs let ((BasicBlock id fstmts):rblks) = blocks' - let fblocks = (BasicBlock id $ funPrologue dflags ++ allocs' ++ fstmts):rblks + let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks return (env, fblocks, tops) -basicBlocksCodeGen env (block:blocks) (lblocks', ltops') +basicBlocksCodeGen env live (block:blocks) (lblocks', ltops') = do (env', lb, lt) <- basicBlockCodeGen env block let lblocks = lblocks' ++ lb let ltops = ltops' ++ lt - basicBlocksCodeGen env' blocks (lblocks, ltops) + basicBlocksCodeGen env' live blocks (lblocks, ltops) -- | Allocations need to be extracted so they can be moved to the entry @@ -510,11 +511,11 @@ cmmPrimOpFunctions env mop ++ " not supported here") -- | Tail function calls -genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData +genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData -- Call to known function genJump env (CmmLit (CmmLabel lbl)) live = do - (env', vf, stmts, top) <- getHsFunc env lbl + (env', vf, stmts, top) <- getHsFunc env live lbl (stgRegs, stgStmts) <- funEpilogue env live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing @@ -523,7 +524,7 @@ genJump env (CmmLit (CmmLabel lbl)) live = do -- Call to unknown function / address genJump env expr live = do - let fty = llvmFunTy (getDflags env) + let fty = llvmFunTy (getDflags env) live (env', vf, stmts, top) <- exprToVar env expr let cast = case getVarType vf of @@ -1246,29 +1247,40 @@ genLit _ CmmHighStackMark -- -- | Function prologue. Load STG arguments into variables for function. -funPrologue :: DynFlags -> [LlvmStatement] -funPrologue dflags = concat $ map getReg $ activeStgRegs platform +funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement] +funPrologue dflags live = concat $ map getReg $ activeStgRegs platform where platform = targetPlatform dflags + isLive r = r `elem` alwaysLive || r `elem` live getReg rr = let reg = lmGlobalRegVar dflags rr arg = lmGlobalRegArg dflags rr + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - in [alloc, Store arg reg] + in + if isLive rr + then [alloc, Store arg reg] + else [alloc, Store trash reg] -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here. -funEpilogue :: LlvmEnv -> Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements) +funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements) -- Have information and liveness optimisation is enabled -funEpilogue env (Just live) | gopt Opt_RegLiveness dflags = do - loads <- mapM loadExpr (activeStgRegs platform) +funEpilogue env live = do + loads <- mapM loadExpr (filter isPassed (activeStgRegs platform)) let (vars, stmts) = unzip loads return (vars, concatOL stmts) where dflags = getDflags env platform = targetPlatform dflags - loadExpr r | r `elem` alwaysLive || r `elem` live = do + isLive r = r `elem` alwaysLive || r `elem` live + isPassed r = not (isFloat r) || isLive r + isFloat (FloatReg _) = True + isFloat (DoubleReg _) = True + isFloat _ = False + loadExpr r | isLive r = do let reg = lmGlobalRegVar dflags r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) @@ -1276,19 +1288,6 @@ funEpilogue env (Just live) | gopt Opt_RegLiveness dflags = do let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) return (LMLitVar $ LMUndefLit ty, unitOL Nop) --- don't do liveness optimisation -funEpilogue env _ = do - loads <- mapM loadExpr (activeStgRegs platform) - let (vars, stmts) = unzip loads - return (vars, concatOL stmts) - where - dflags = getDflags env - platform = targetPlatform dflags - loadExpr r = do - let reg = lmGlobalRegVar dflags r - (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg - return (v, unitOL s) - -- | A serries of statements to trash all the STG registers. -- @@ -1317,8 +1316,8 @@ trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform -- -- This is for Haskell functions, function type is assumed, so doesn't work -- with foreign functions. -getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData -getHsFunc env lbl +getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData +getHsFunc env live lbl = let dflags = getDflags env fn = strCLabel_llvm env lbl ty = funLookup fn env @@ -1332,13 +1331,13 @@ getHsFunc env lbl Just ty' -> do let fun = LMGlobalVar fn (pLift ty') ExternallyVisible Nothing Nothing False - (v1, s1) <- doExpr (pLift (llvmFunTy dflags)) $ - Cast LM_Bitcast fun (pLift (llvmFunTy dflags)) + (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $ + Cast LM_Bitcast fun (pLift (llvmFunTy dflags live)) return (env, v1, unitOL s1, []) -- label not in module, create external reference Nothing -> do - let ty' = LMFunction $ llvmFunSig env lbl ExternallyVisible + let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False let top = CmmData Data [([],[ty'])] let env' = funInsert fn ty' env diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index c791e85a52..73632f5fd4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -83,7 +83,7 @@ pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar]) pprLlvmCmmDecl _ _ (CmmData _ lmdata) = (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) +pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks)) = let (idoc, ivar) = case mb_info of Nothing -> (empty, []) Just (Statics info_lbl dat) @@ -98,7 +98,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) else Internal lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blks - fun = mkLlvmFunc env lbl' link sec' lmblocks + fun = mkLlvmFunc env live lbl' link sec' lmblocks in ppLlvmFunction fun ), ivar) diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 49c900d5e0..e6cfcb2e18 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -47,8 +47,14 @@ lmGlobalReg dflags suf reg FloatReg 2 -> floatGlobal $"F2" ++ suf FloatReg 3 -> floatGlobal $"F3" ++ suf FloatReg 4 -> floatGlobal $"F4" ++ suf + FloatReg 5 -> floatGlobal $"F5" ++ suf + FloatReg 6 -> floatGlobal $"F6" ++ suf DoubleReg 1 -> doubleGlobal $ "D1" ++ suf DoubleReg 2 -> doubleGlobal $ "D2" ++ suf + DoubleReg 3 -> doubleGlobal $ "D3" ++ suf + DoubleReg 4 -> doubleGlobal $ "D4" ++ suf + DoubleReg 5 -> doubleGlobal $ "D5" ++ suf + DoubleReg 6 -> doubleGlobal $ "D6" ++ suf _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!" -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc 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 4cef95eb6e..07ebd4013e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -277,7 +277,6 @@ data GeneralFlag | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation | Opt_PedanticBottoms -- Be picky about how we treat bottom | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) - | Opt_RegLiveness -- Use the STG Reg liveness information (hidden flag) | Opt_IrrefutableTuples | Opt_CmmSink | Opt_CmmElimCommonBlocks @@ -671,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, @@ -689,7 +690,9 @@ data DynFlags = DynFlags { interactivePrint :: Maybe String, - llvmVersion :: IORef (Int) + llvmVersion :: IORef (Int), + + nextWrapperNum :: IORef Int } class HasDynFlags m where @@ -1110,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 @@ -1228,6 +1233,8 @@ defaultDynFlags mySettings = maxWorkerArgs = 10, + ghciHistSize = 50, -- keep a log of length 50 by default + log_action = defaultLogAction, flushOut = defaultFlushOut, flushErr = defaultFlushErr, @@ -1236,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] @@ -2127,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 @@ -2349,7 +2359,6 @@ fFlags = [ ( "regs-graph", Opt_RegsGraph, nop ), ( "regs-iterative", Opt_RegsIterative, nop ), ( "llvm-tbaa", Opt_LlvmTBAA, nop), -- hidden flag - ( "regs-liveness", Opt_RegLiveness, nop), -- hidden flag ( "irrefutable-tuples", Opt_IrrefutableTuples, nop ), ( "cmm-sink", Opt_CmmSink, nop ), ( "cmm-elim-common-blocks", Opt_CmmElimCommonBlocks, nop ), @@ -2376,7 +2385,8 @@ fFlags = [ fLangFlags :: [FlagSpec ExtensionFlag] fLangFlags = [ ( "th", Opt_TemplateHaskell, - deprecatedForExtension "TemplateHaskell" >> checkTemplateHaskellOk ), + \on -> deprecatedForExtension "TemplateHaskell" on + >> checkTemplateHaskellOk on ), ( "fi", Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), ( "ffi", Opt_ForeignFunctionInterface, @@ -2633,7 +2643,6 @@ optLevelFlags -- XXX disabled, see #7192 -- , ([2], Opt_RegsGraph) , ([0,1,2], Opt_LlvmTBAA) - , ([0,1,2], Opt_RegLiveness) , ([1,2], Opt_CmmSink) , ([1,2], Opt_CmmElimCommonBlocks) @@ -2764,11 +2773,11 @@ setPackageTrust = do l <- getCurLoc upd $ \d -> d { pkgTrustOnLoc = l } -setGenDeriving :: Bool -> DynP () +setGenDeriving :: TurnOnFlag -> DynP () setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) setGenDeriving False = return () -checkTemplateHaskellOk :: Bool -> DynP () +checkTemplateHaskellOk :: TurnOnFlag -> DynP () #ifdef GHCI checkTemplateHaskellOk turn_on | turn_on && rtsIsProfiled 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/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index ef61adfbec..23aca9293c 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -290,7 +290,7 @@ nativeCodeGen' dflags ncgImpl h us cmms | gopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph []) + split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] (ListGraph []) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) @@ -550,8 +550,8 @@ cmmNativeGen dflags ncgImpl us cmm count x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge (CmmProc info lbl (ListGraph code)) = - CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) +x86fp_kludge (CmmProc info lbl live (ListGraph code)) = + CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code) -- | Build a doc for all the imports. @@ -627,8 +627,8 @@ sequenceTop => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr sequenceTop _ top@(CmmData _ _) = top -sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = - CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks) +sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) = + CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks) -- The algorithm is very simple (and stupid): we make a graph out of -- the blocks where there is an edge from one block to another iff the @@ -744,7 +744,7 @@ generateJumpTables :: NcgImpl statics instr jumpDest -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] generateJumpTables ncgImpl xs = concatMap f xs - where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs + where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) @@ -768,10 +768,10 @@ build_mapping :: NcgImpl statics instr jumpDest -> GenCmmDecl d (BlockEnv t) (ListGraph instr) -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest) build_mapping _ top@(CmmData _ _) = (top, emptyUFM) -build_mapping _ (CmmProc info lbl (ListGraph [])) - = (CmmProc info lbl (ListGraph []), emptyUFM) -build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) - = (CmmProc info lbl (ListGraph (head:others)), mapping) +build_mapping _ (CmmProc info lbl live (ListGraph [])) + = (CmmProc info lbl live (ListGraph []), emptyUFM) +build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) + = (CmmProc info lbl live (ListGraph (head:others)), mapping) -- drop the shorted blocks, but don't ever drop the first one, -- because it is pointed to by a global label. where @@ -804,8 +804,8 @@ apply_mapping :: NcgImpl statics instr jumpDest -> GenCmmDecl statics h (ListGraph instr) apply_mapping ncgImpl ufm (CmmData sec statics) = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) -apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) - = CmmProc info lbl (ListGraph $ map short_bb blocks) +apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map short_bb blocks) where short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i @@ -878,9 +878,9 @@ Ideas for other things we could do (put these in Hoopl please!): cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do +cmmToCmm dflags (CmmProc info lbl live (ListGraph blocks)) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold blocks - return $ CmmProc info lbl (ListGraph blocks') + return $ CmmProc info lbl live (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) 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/PIC.hs b/compiler/nativeGen/PIC.hs index 1ea62dad82..69f3e29add 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -693,7 +693,7 @@ initializePicBase_ppc -> NatM [NatCmmDecl CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg - (CmmProc info lab (ListGraph blocks) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) | osElfTarget os = do dflags <- getDynFlags @@ -719,11 +719,11 @@ initializePicBase_ppc ArchPPC os picReg : PPC.ADD picReg picReg (PPC.RIReg tmp) : insns) - return (CmmProc info lab (ListGraph (b' : tail blocks)) : gotOffset : statics) + return (CmmProc info lab live (ListGraph (b' : tail blocks)) : gotOffset : statics) initializePicBase_ppc ArchPPC OSDarwin picReg - (CmmProc info lab (ListGraph blocks) : statics) - = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) + = return (CmmProc info lab live (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (PPC.FETCHPC picReg : insns) @@ -746,9 +746,9 @@ initializePicBase_x86 -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg - (CmmProc info lab (ListGraph blocks) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) | osElfTarget os - = return (CmmProc info lab (ListGraph blocks') : statics) + = return (CmmProc info lab live (ListGraph blocks') : statics) where blocks' = case blocks of [] -> [] (b:bs) -> fetchGOT b : map maybeFetchGOT bs @@ -764,8 +764,8 @@ initializePicBase_x86 ArchX86 os picReg BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab (ListGraph blocks) : statics) - = return (CmmProc info lab (ListGraph blocks') : statics) + (CmmProc info lab live (ListGraph blocks) : statics) + = return (CmmProc info lab live (ListGraph blocks') : statics) where blocks' = case blocks of [] -> [] diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 026e8933d7..848c7f933c 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -71,11 +71,11 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags case picBaseMb of diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 576e19db1a..045ce8d48e 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -51,7 +51,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index 019cf82f6a..2b74d1daea 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -26,21 +26,18 @@ where #include "nativeGen/NCG.h" #include "HsVersions.h" -import PPC.Regs import PPC.Instr import BlockId import OldCmm import CLabel -import Outputable import Unique -data JumpDest = DestBlockId BlockId | DestImm Imm +data JumpDest = DestBlockId BlockId getJumpDestBlockId :: JumpDest -> Maybe BlockId getJumpDestBlockId (DestBlockId bid) = Just bid -getJumpDestBlockId _ = Nothing canShortcut :: Instr -> Maybe JumpDest canShortcut _ = Nothing @@ -80,7 +77,5 @@ shortBlockId fn blockid = case fn blockid of Nothing -> mkAsmTempLabel uq Just (DestBlockId blockid') -> shortBlockId fn blockid' - Just (DestImm (ImmCLbl lbl)) -> lbl - _other -> panic "shortBlockId" where uq = getUnique blockid diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 0680beac00..c4fb7ac378 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -75,7 +75,7 @@ slurpJoinMovs live = slurpCmm emptyBag live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) + slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs slurpLI rs (LiveInstr _ Nothing) = rs diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 6e110266d1..25bd313826 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -91,7 +91,7 @@ regSpill_top platform regSlotMap cmm CmmData{} -> return cmm - CmmProc info label sccs + CmmProc info label live sccs | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info -> do -- We should only passed Cmms with the liveness maps filled in, but we'll @@ -115,7 +115,7 @@ regSpill_top platform regSlotMap cmm -- Apply the spiller to all the basic blocks in the CmmProc. sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs - return $ CmmProc info' label sccs' + return $ CmmProc info' label live sccs' where -- | Given a BlockId and the set of registers live in it, -- if registers in this block are being spilled to stack slots, diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 9348dca936..7f86b9a884 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -301,10 +301,10 @@ cleanTopBackward cmm CmmData{} -> return cmm - CmmProc info label sccs + CmmProc info label live sccs | LiveInfo _ _ _ liveSlotsOnEntry <- info -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label sccs' + return $ CmmProc info label live sccs' cleanBlockBackward diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index abcc6a69b6..879597fd88 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -79,7 +79,7 @@ slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () - countCmm (CmmProc info _ sccs) + countCmm (CmmProc info _ _ sccs) = mapM_ (countBlock info) $ flattenSCCs sccs diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3f1efe5824..fc5b992603 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -150,12 +150,12 @@ regAlloc _ (CmmData sec d) , Nothing , Nothing ) -regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl []) - = return ( CmmProc info lbl (ListGraph []) +regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) + = return ( CmmProc info lbl live (ListGraph []) , Nothing , Nothing ) -regAlloc dflags (CmmProc static lbl sccs) +regAlloc dflags (CmmProc static lbl live sccs) | LiveInfo info (Just first_id) (Just block_live) _ <- static = do -- do register allocation on each component. @@ -174,12 +174,12 @@ regAlloc dflags (CmmProc static lbl sccs) | otherwise = Nothing - return ( CmmProc info lbl (ListGraph (first' : rest')) + return ( CmmProc info lbl live (ListGraph (first' : rest')) , extra_stack , Just stats) -- bogus. to make non-exhaustive match warning go away. -regAlloc _ (CmmProc _ _ _) +regAlloc _ (CmmProc _ _ _ _) = panic "RegAllocLinear.regAlloc: no match" diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 608f0a423b..12c138897c 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -246,9 +246,9 @@ mapBlockTopM mapBlockTopM _ cmm@(CmmData{}) = return cmm -mapBlockTopM f (CmmProc header label sccs) +mapBlockTopM f (CmmProc header label live sccs) = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label sccs' + return $ CmmProc header label live sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) mapSCCM f (AcyclicSCC x) @@ -278,9 +278,9 @@ mapGenBlockTopM mapGenBlockTopM _ cmm@(CmmData{}) = return cmm -mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) +mapGenBlockTopM f (CmmProc header label live (ListGraph blocks)) = do blocks' <- mapM f blocks - return $ CmmProc header label (ListGraph blocks') + return $ CmmProc header label live (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. @@ -296,7 +296,7 @@ slurpConflicts live = slurpCmm (emptyBag, emptyBag) live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ sccs) + slurpCmm rs (CmmProc info _ _ sccs) = foldl' (slurpSCC info) rs sccs slurpSCC info rs (AcyclicSCC b) @@ -375,7 +375,7 @@ slurpReloadCoalesce live -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg) slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ sccs) + slurpCmm cs (CmmProc _ _ _ sccs) = slurpComp cs (flattenSCCs sccs) slurpComp :: Bag (Reg, Reg) @@ -475,7 +475,7 @@ stripLive dflags live where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label live sccs) = let final_blocks = flattenSCCs sccs -- make sure the block that was first in the input list @@ -484,12 +484,12 @@ stripLive dflags live ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - in CmmProc info label + in CmmProc info label live (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) - = CmmProc info label (ListGraph []) + stripCmm (CmmProc (LiveInfo info Nothing _ _) label live []) + = CmmProc info label live (ListGraph []) -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc @@ -559,14 +559,14 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label sccs) + patchCmm (CmmProc info label live sccs) | LiveInfo static id (Just blockMap) mLiveSlots <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set blockMap' = mapMap patchRegSet blockMap info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label $ map patchSCC sccs + in CmmProc info' label live $ map patchSCC sccs | otherwise = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" @@ -635,17 +635,17 @@ natCmmTopToLive natCmmTopToLive (CmmData i d) = CmmData i d -natCmmTopToLive (CmmProc info lbl (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] +natCmmTopToLive (CmmProc info lbl live (ListGraph [])) + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl live [] -natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) +natCmmTopToLive (CmmProc info lbl live (ListGraph blocks@(first : _))) = let first_id = blockId first sccs = sccBlocks blocks sccsLive = map (fmap (\(BasicBlock l instrs) -> BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) $ sccs - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl live sccsLive sccBlocks @@ -674,18 +674,18 @@ regLiveness regLiveness _ (CmmData i d) = return $ CmmData i d -regLiveness _ (CmmProc info lbl []) +regLiveness _ (CmmProc info lbl live []) | LiveInfo static mFirst _ _ <- info = return $ CmmProc (LiveInfo static mFirst (Just mapEmpty) Map.empty) - lbl [] + lbl live [] -regLiveness platform (CmmProc info lbl sccs) +regLiveness platform (CmmProc info lbl live sccs) | LiveInfo static mFirst _ liveSlotsOnEntry <- info = let (ann_sccs, block_live) = computeLiveness platform sccs in return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl ann_sccs + lbl live ann_sccs -- ----------------------------------------------------------------------------- @@ -734,7 +734,7 @@ reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr reverseBlocksInTops top = case top of CmmData{} -> top - CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + CmmProc info lbl live sccs -> CmmProc info lbl live (reverse sccs) -- | Computing liveness diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index aeb6d10acc..c4efdf677e 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -59,10 +59,10 @@ import Control.Monad ( mapAndUnzipM ) cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) let tops = proc : concat statics return tops diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index c468fcc255..fa397771d7 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -32,8 +32,8 @@ expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr expandTop top@(CmmData{}) = top -expandTop (CmmProc info lbl (ListGraph blocks)) - = CmmProc info lbl (ListGraph $ map expandBlock blocks) +expandTop (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map expandBlock blocks) -- | Expand out synthetic instructions in this block diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 55afac0ee2..9bfa3141cc 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -53,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 7ab30bf922..b3160ed2ca 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -93,11 +93,11 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags @@ -173,9 +173,8 @@ stmtToInstrs stmt = do panic "stmtToInstrs: return statement should have been cps'd away" -jumpRegs :: DynFlags -> Maybe [GlobalReg] -> [Reg] -jumpRegs dflags Nothing = allHaskellArgRegs dflags -jumpRegs dflags (Just gregs) = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] +jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] +jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] where platform = targetPlatform dflags -------------------------------------------------------------------------------- @@ -1775,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 @@ -2035,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/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 7bd9b0cc9e..d089fc3ec2 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -828,8 +828,8 @@ allocMoreStack -> NatCmmDecl statics X86.Instr.Instr allocMoreStack _ _ top@(CmmData _ _) = top -allocMoreStack platform amount (CmmProc info lbl (ListGraph code)) = - CmmProc info lbl (ListGraph (map insert_stack_insns code)) +allocMoreStack platform amount (CmmProc info lbl live (ListGraph code)) = + CmmProc info lbl live (ListGraph (map insert_stack_insns code)) where alloc = mkStackAllocInstr platform amount dealloc = mkStackDeallocInstr platform amount diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 420da7cc3d..76715f1996 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -53,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of 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/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index c3b40fe0f2..9738585aa4 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -121,10 +121,26 @@ wrapSrcSpanCps fn (L loc a) lookupConCps :: Located RdrName -> CpsRn (Located Name) lookupConCps con_rdr = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr - ; (r, fvs) <- k con_name - ; return (r, fvs `plusFV` unitFV (unLoc con_name)) }) + ; k con_name }) + -- We do not add the constructor name to the free vars + -- See Note [Patterns are not uses] \end{code} +Note [Patterns are not uses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + module Foo( f, g ) where + data T = T1 | T2 + + f T1 = True + f T2 = False + + g _ = T1 + +Arguaby we should report T2 as unused, even though it appears in a +pattern, because it never occurs in a constructed position. See +Trac #7336. + %********************************************************* %* * Name makers 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/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index d75a224bb8..ac8b2f3919 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -1697,11 +1697,14 @@ Note [getProxies is subtle] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The code for getProxies isn't all that obvious. Consider - case v |> cov of x { DEFAULT -> - case x |> cox1 of y { DEFAULT -> - case x |> cox2 of z { DEFAULT -> r + case v |> cov of x { DEFAULT -> {{ let v = x |> sym cov }} + case x |> cox1 of y { DEFAULT -> {{ let x = y |> sym cox1 }} + case x |> cox2 of z { DEFAULT -> {{ let x = z |> sym cox2 }} + r -These will give us a ProxyEnv looking like: +Bindings in double braces are injected. + +At 'r', these will give us a ProxyEnv looking like: x |-> (x, [(y, cox1), (z, cox2)]) v |-> (v, [(x, cov)]) @@ -1711,7 +1714,7 @@ From this we want to extract the bindings y = x |> cox1 Notice that later bindings may mention earlier ones, and that -we need to go "both ways". +we can go "both ways". Note [Zap case binders in proxy bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 3309e12a33..3dd88446e1 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1150,17 +1150,12 @@ canEqLeafTyVarEq loc ev tv s2 -- ev :: tv ~ s2 setEvBind (ctev_evar ev) (mkEvCast (EvCoercion (mkTcReflCo xi1)) co) ; return Stop } ; - (Just tv1', _) -> + (Just tv1', _) -> do -- LHS rewrote to a type variable, RHS to something else - case occurCheckExpand tv1' xi2 of - Nothing -> -- Occurs check error - do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co - ; case mb of - Nothing -> return Stop - Just new_ev -> canEqFailure loc new_ev xi1 xi2 } - - Just xi2' -> -- No occurs check, so we can continue; but make sure + { dflags <- getDynFlags + ; case occurCheckExpand dflags tv1' xi2 of + OC_OK xi2' -> -- No occurs check, so we can continue; but make sure -- that the new goal has enough type synonyms expanded by -- by the occurCheckExpand do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2') co @@ -1169,7 +1164,13 @@ canEqLeafTyVarEq loc ev tv s2 -- ev :: tv ~ s2 Just new_ev -> continueWith $ CTyEqCan { cc_ev = new_ev, cc_loc = loc , cc_tyvar = tv1', cc_rhs = xi2' } } - } } + _bad -> -- Occurs check error + do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co + ; case mb of + Nothing -> return Stop + Just new_ev -> canEqFailure loc new_ev xi1 xi2 } + + } } } mkHdEqPred :: Type -> TcCoercion -> TcCoercion -> TcCoercion -- Make a higher-dimensional equality diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index f3fc936996..934a9fb84a 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,33 @@ 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 -- Note [Generating fresh names for ccall wrapper] + 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 + +{- +Note [Generating fresh names for FFI wrappers] + +We used to use a unique, rather than nextWrapperNum, to distinguish +between FFI wrapper functions. However, the wrapper names that we +generate are external names. This means that if a call to them ends up +in an unfolding, then we can't alpha-rename them, and thus if the +unique randomly changes from one compile to another then we get a +spurious ABI change (#4012). +-} +\end{code} + %************************************************************************ %* * \subsection{Errors} diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 6ac8793f6c..a754d10be8 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -548,7 +548,8 @@ mkEqErr1 ctxt ct | isGiven ev = do { (ctxt, binds_msg) <- relevantBindings ctxt ct ; let (given_loc, given_msg) = mk_given (cec_encl ctxt) - ; mkEqErr_help ctxt (given_msg $$ binds_msg) + ; dflags <- getDynFlags + ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg) (ct { cc_loc = given_loc}) -- Note [Inaccessible code] Nothing ty1 ty2 } @@ -556,7 +557,8 @@ mkEqErr1 ctxt ct = do { (ctxt, binds_msg) <- relevantBindings ctxt ct ; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin (cc_loc ct)) ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig - ; mkEqErr_help ctxt (wanted_msg $$ binds_msg) + ; dflags <- getDynFlags + ; mkEqErr_help dflags ctxt (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 } where ev = cc_ev ct @@ -587,45 +589,67 @@ mkEqErr1 ctxt ct mk_wanted_extra _ = (Nothing, empty) -mkEqErr_help, reportEqErr - :: ReportErrCtxt -> SDoc - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -mkEqErr_help ctxt extra ct oriented ty1 ty2 - | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt extra ct oriented tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt extra ct swapped tv2 ty1 +mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc + -> Ct + -> Maybe SwapFlag -- Nothing <=> not sure + -> TcType -> TcType -> TcM ErrMsg +mkEqErr_help dflags ctxt extra ct oriented ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt extra ct swapped tv2 ty1 | otherwise = reportEqErr ctxt extra ct oriented ty1 ty2 where swapped = fmap flipSwap oriented +reportEqErr :: ReportErrCtxt -> SDoc + -> Ct + -> Maybe SwapFlag -- Nothing <=> not sure + -> TcType -> TcType -> TcM ErrMsg reportEqErr ctxt extra1 ct oriented ty1 ty2 = do { (ctxt', extra2) <- mkEqInfoMsg ctxt ct ty1 ty2 ; mkErrorMsg ctxt' ct (vcat [ misMatchOrCND ctxt' ct oriented ty1 ty2 , extra2, extra1]) } -mkTyVarEqErr :: ReportErrCtxt -> SDoc -> Ct -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg +mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct + -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg -- tv1 and ty2 are already tidied -mkTyVarEqErr ctxt extra ct oriented tv1 ty2 - -- Occurs check - | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would - -- be oriented the other way round; see TcCanonical.reOrient +mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 + | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; see TcCanonical.reOrient || isSigTyVar tv1 && not (isTyVarTy ty2) = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 , extraTyVarInfo ctxt ty1 ty2 , extra ]) - -- So tv is a meta tyvar, and presumably it is - -- an *untouchable* meta tyvar, else it'd have been unified + -- So tv is a meta tyvar (or started that way before we + -- generalised it). So presumably it is an *untouchable* + -- meta tyvar or a SigTv, else it'd have been unified | not (k2 `tcIsSubKind` k1) -- Kind error = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra) - | isNothing (occurCheckExpand tv1 ty2) + | OC_Occurs <- occ_check_expand = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 (sep [ppr ty1, char '~', ppr ty2]) ; (ctxt', extra2) <- mkEqInfoMsg ctxt ct ty1 ty2 ; mkErrorMsg ctxt' ct (occCheckMsg $$ extra2 $$ extra) } + | OC_Forall <- occ_check_expand + = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable") + <+> quotes (ppr tv1) + , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2) + , nest 2 (ptext (sLit "Perhaps you want -XImpredicativeTypes")) ] + ; mkErrorMsg ctxt ct msg } + + -- If the immediately-enclosing implication has 'tv' a skolem, and + -- we know by now its an InferSkol kind of skolem, then presumably + -- it started life as a SigTv, else it'd have been unified, given + -- that there's no occurs-check or forall problem + | (implic:_) <- cec_encl ctxt + , Implic { ic_skols = skols } <- implic + , tv1 `elem` skols + = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented ty1 ty2 + , extraTyVarInfo ctxt ty1 ty2 + , extra ]) + -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic @@ -665,6 +689,7 @@ mkTyVarEqErr ctxt extra ct oriented tv1 ty2 -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, becuase F is a type function. where + occ_check_expand = occurCheckExpand dflags tv1 ty2 k1 = tyVarKind tv1 k2 = typeKind ty2 ty1 = mkTyVarTy tv1 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 9075033ff2..d554588e00 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -318,10 +318,13 @@ tcExpr (OpApp arg1 op fix arg2) res_ty -- Make sure that the argument and result types have kind '*' -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 - -- ($) :: forall ab. (a->b) -> a -> b - ; a_ty <- newFlexiTyVarTy liftedTypeKind - ; b_ty <- newFlexiTyVarTy liftedTypeKind + -- (which gives a seg fault) + -- We do this by unifying with a MetaTv; but of course + -- it must allow foralls in the type it unifies with (hence PolyTv)! + -- ($) :: forall ab. (a->b) -> a -> b + ; a_ty <- newPolyFlexiTyVarTy + ; b_ty <- newPolyFlexiTyVarTy ; arg2' <- tcArg op (arg2, arg2_ty, 2) ; co_res <- unifyType b_ty res_ty -- b ~ res diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 70559f7e7c..36762b993d 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -67,14 +67,13 @@ import NameEnv import TysWiredIn import BasicTypes import SrcLoc -import DynFlags ( ExtensionFlag( Opt_DataKinds ) ) +import DynFlags ( ExtensionFlag( Opt_DataKinds ), getDynFlags ) import Unique import UniqSupply import Outputable import FastString import Util -import Data.Maybe import Control.Monad ( unless, when, zipWithM ) import PrelNames( ipClassName, funTyConKey ) \end{code} @@ -1229,7 +1228,8 @@ Here * Then unificaiton makes a_sig := a_sk -That's why we must make a_sig a SigTv, not a SkolemTv, so that it can unify to a_sk. +That's why we must make a_sig a MetaTv (albeit a SigTv), +not a SkolemTv, so that it can unify to a_sk. For RULE binders, though, things are a bit different (yuk). RULE "foo" forall (x::a) (y::[a]). f x y = ... @@ -1340,6 +1340,7 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) ; act_kind <- zonkTcKind act_kind ; traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr exp_kind) ; env0 <- tcInitTidyEnv + ; dflags <- getDynFlags ; let (exp_as, _) = splitKindFunTys exp_kind (act_as, _) = splitKindFunTys act_kind n_exp_as = length exp_as @@ -1351,12 +1352,16 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) occurs_check | Just act_tv <- tcGetTyVar_maybe act_kind - = isNothing (occurCheckExpand act_tv exp_kind) + = check_occ act_tv exp_kind | Just exp_tv <- tcGetTyVar_maybe exp_kind - = isNothing (occurCheckExpand exp_tv act_kind) + = check_occ exp_tv act_kind | otherwise = False + check_occ tv k = case occurCheckExpand dflags tv k of + OC_Occurs -> True + _bad -> False + err | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) <+> ptext (sLit "is unlifted") diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index a75890f70a..3facc1e7e4 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -335,13 +335,17 @@ kickOutRewritable new_flav new_tv -- constraints that mention type variables whose -- kinds could contain this variable! - kick_out_eq inert_ct = kick_out_ct inert_ct && - not (ctFlavour inert_ct `canRewrite` new_flav) - -- If also the inert can rewrite the subst then there is no danger of - -- occurs check errors sor keep it there. No need to rewrite the inert equality - -- (as we did in the past) because of point (8) of - -- See Note [Detailed InertCans Invariants] - -- and Note [Delicate equality kick-out] + kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs, cc_ev = ev }) + = (new_flav `canRewrite` inert_flav) -- See Note [Delicate equality kick-out] + && (new_tv `elemVarSet` kind_vars || -- (1) + (not (inert_flav `canRewrite` new_flav) && -- (2) + new_tv `elemVarSet` (extendVarSet (tyVarsOfType rhs) tv))) + where + inert_flav = ctEvFlavour ev + kind_vars = tyVarsOfType (tyVarKind tv) `unionVarSet` + tyVarsOfType (typeKind rhs) + + kick_out_eq other_ct = pprPanic "kick_out_eq" (ppr other_ct) \end{code} Note [Kick out insolubles] @@ -355,27 +359,34 @@ outer type constructors match. Note [Delicate equality kick-out] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Delicate: -When kicking out rewritable constraints, it would be safe to simply -kick out all rewritable equalities, but instead we only kick out those -that, when rewritten, may result in occur-check errors. Example: - - WorkItem = [G] a ~ b - Inerts = { [W] b ~ [a] } -Now at this point the work item cannot be further rewritten by the -inert (due to the weaker inert flavor). Instead the workitem can -rewrite the inert leading to potential occur check errors. So we must -kick the inert out. On the other hand, if the inert flavor was as -powerful or more powerful than the workitem flavor, the work-item could -not have reached this stage (because it would have already been -rewritten by the inert). - -The coclusion is: we kick out the 'dangerous' equalities that may -require recanonicalization (occurs checks) and the rest we keep -there in the inerts without further checks. - -In the past we used to rewrite-on-the-spot those equalities that we keep in, -but this is no longer necessary see Note [Non-idempotent inert substitution]. +When adding an equality (a ~ xi), we kick out an inert type-variable +equality (b ~ phi) in two cases + +(1) If the new tyvar can rewrite the kind LHS or RHS of the inert + equality. Example: + Work item: [W] k ~ * + Inert: [W] (a:k) ~ ty + [W] (b:*) ~ c :: k + We must kick out those blocked inerts so that we rewrite them + and can subsequently unify. + +(2) If the new tyvar can + Work item: [G] a ~ b + Inert: [W] b ~ [a] + Now at this point the work item cannot be further rewritten by the + inert (due to the weaker inert flavor). But we can't add the work item + as-is because the inert set would then have a cyclic substitution, + when rewriting a wanted type mentioning 'a'. So we must kick the inert out. + + We have to do this only if the inert *cannot* rewrite the work item; + it it can, then the work item will have been fully rewritten by the + inert during canonicalisation. So for example: + Work item: [W] a ~ Int + Inert: [W] b ~ [a] + No need to kick out the inert, beause the inert substitution is not + necessarily idemopotent. See Note [Non-idempotent inert substitution]. + +See also point (8) of Note [Detailed InertCans Invariants] \begin{code} data SPSolveResult = SPCantSolve diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index afc575caf7..f45519b7dd 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -24,6 +24,7 @@ module TcMType ( newFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] + newPolyFlexiTyVarTy, newMetaKindVar, newMetaKindVars, mkKindSigVar, mkTcTyVarName, cloneMetaTyVar, @@ -318,8 +319,9 @@ newMetaTyVar meta_info kind = do { uniq <- newUnique ; let name = mkTcTyVarName uniq s s = case meta_info of - TauTv -> fsLit "t" - SigTv -> fsLit "a" + PolyTv -> fsLit "s" + TauTv -> fsLit "t" + SigTv -> fsLit "a" ; details <- newMetaDetails meta_info ; return (mkTcTyVar name kind details) } @@ -438,6 +440,10 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) +newPolyFlexiTyVarTy :: TcM TcType +newPolyFlexiTyVarTy = do { tv <- newMetaTyVar PolyTv liftedTypeKind + ; return (TyVarTy tv) } + tcInstTyVars :: [TKVar] -> TcM ([TcTyVar], [TcType], TvSubst) -- Instantiate with META type variables -- Note that this works for a sequence of kind and type 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..4b2ea8fa94 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,14 +908,14 @@ 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). In contrast, the type of the evidence *term* (ccev_evtm or ctev_evar) in the evidence may *not* be fully zonked; we are careful not to look at it -during constraint solving. Seee Note [Evidence field of CtEvidence] +during constraint solving. See Note [Evidence field of CtEvidence] \begin{code} mkNonCanonical :: CtLoc -> CtEvidence -> Ct @@ -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/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 78fb0bf7e3..7541cd79f9 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -477,29 +477,34 @@ The InertCans represents a collection of constraints with the following properti 7 Non-equality constraints are fully rewritten with respect to the equalities (CTyEqCan) - 8 Equalities _do_not_ form an idempotent substitution but they are guarranteed to not have - any occurs errors. Additional notes: - - - The lack of idempotence of the inert substitution implies that we must make sure - that when we rewrite a constraint we apply the substitution /recursively/ to the - types involved. Currently the one AND ONLY way in the whole constraint solver - that we rewrite types and constraints wrt to the inert substitution is - TcCanonical/flattenTyVar. - - - In the past we did try to have the inert substituion as idempotent as possible but - this would only be true for constraints of the same flavor, so in total the inert - substitution could not be idempotent, due to flavor-related issued. - Note [Non-idempotent inert substitution] explains what is going on. - - - Whenever a constraint ends up in the worklist we do recursively apply exhaustively - the inert substitution to it to check for occurs errors but if an equality is already - in the inert set and we can guarantee that adding a new equality will not cause the - first equality to have an occurs check then we do not rewrite the inert equality. - This happens in TcInteract, rewriteInertEqsFromInertEq. + 8 Equalities _do_not_ form an idempotent substitution, but they are + guaranteed to not have any occurs errors. Additional notes: + + - The lack of idempotence of the inert substitution implies + that we must make sure that when we rewrite a constraint we + apply the substitution /recursively/ to the types + involved. Currently the one AND ONLY way in the whole + constraint solver that we rewrite types and constraints wrt + to the inert substitution is TcCanonical/flattenTyVar. + + - In the past we did try to have the inert substitution as + idempotent as possible but this would only be true for + constraints of the same flavor, so in total the inert + substitution could not be idempotent, due to flavor-related + issued. Note [Non-idempotent inert substitution] explains + what is going on. + + - Whenever a constraint ends up in the worklist we do + recursively apply exhaustively the inert substitution to it + to check for occurs errors. But if an equality is already in + the inert set and we can guarantee that adding a new equality + will not cause the first equality to have an occurs check + then we do not rewrite the inert equality. This happens in + TcInteract, rewriteInertEqsFromInertEq. - See Note [Delicate equality kick-out] to see which inert equalities can safely stay - in the inert set and which must be kicked out to be rewritten and re-checked for - occurs errors. + See Note [Delicate equality kick-out] to see which inert + equalities can safely stay in the inert set and which must be + kicked out to be rewritten and re-checked for occurs errors. 9 Given family or dictionary constraints don't mention touchable unification variables @@ -1596,11 +1601,17 @@ Main purpose: create new evidence for new_pred; Not Just new_evidence -} --- If derived, don't even look at the coercion --- NB: this allows us to sneak away with ``error'' thunks for --- coercions that come from derived ids (which don't exist!) - +rewriteCtFlavor (CtDerived {}) new_pred _co + = -- If derived, don't even look at the coercion. + -- This is very important, DO NOT re-order the equations for + -- rewriteCtFlavor to put the isTcReflCo test first! + -- Why? Because for *Derived* constraints, c, the coercion, which + -- was produced by flattening, may contain suspended calls to + -- (ctEvTerm c), which fails for Derived constraints. + -- (Getting this wrong caused Trac #7384.) + newDerived new_pred + rewriteCtFlavor old_ev new_pred co | isTcReflCo co -- If just reflexivity then you may re-use the same variable = return (Just (if ctEvPred old_ev `eqType` new_pred @@ -1612,9 +1623,6 @@ rewriteCtFlavor old_ev new_pred co -- However, if they *do* look the same, we'd prefer to stick with old_pred -- then retain the old type, so that error messages come out mentioning synonyms -rewriteCtFlavor (CtDerived {}) new_pred _co - = newDerived new_pred - rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) new_pred co = do { new_ev <- newGivenEvVar new_pred new_tm -- See Note [Bind new Givens immediately] ; return (Just new_ev) } 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/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index aa69d75e56..73565e0023 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -74,7 +74,7 @@ module TcType ( --------------------------------- -- Misc type manipulators - deNoteType, occurCheckExpand, + deNoteType, occurCheckExpand, OccCheckResult(..), orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo, getDFunTyKey, evVarPred_maybe, evVarPred, @@ -331,6 +331,8 @@ data MetaInfo -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls + | PolyTv -- Like TauTv, but can unify with a sigma-type + | SigTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable -- SigTvs are only distinguished to improve error messages @@ -488,8 +490,9 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch }) = pp_info <> brackets (ppr untch) where pp_info = case info of - TauTv -> ptext (sLit "tau") - SigTv -> ptext (sLit "sig") + PolyTv -> ptext (sLit "poly") + TauTv -> ptext (sLit "tau") + SigTv -> ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) @@ -1187,57 +1190,98 @@ even though we could also expand F to get rid of b. See also Note [Type synonyms and canonicalization] in TcCanonical \begin{code} -occurCheckExpand :: TcTyVar -> Type -> Maybe Type +data OccCheckResult a + = OC_OK a + | OC_Forall + | OC_NonTyVar + | OC_Occurs + +instance Monad OccCheckResult where + return x = OC_OK x + OC_OK x >>= k = k x + OC_Forall >>= _ = OC_Forall + OC_NonTyVar >>= _ = OC_NonTyVar + OC_Occurs >>= _ = OC_Occurs + +occurCheckExpand :: DynFlags -> TcTyVar -> Type -> OccCheckResult Type -- See Note [Occurs check expansion] --- Check whether the given variable occurs in the given type. We may --- have needed to do some type synonym unfolding in order to get rid --- of the variable, so we also return the unfolded version of the --- type, which is guaranteed to be syntactically free of the given --- type variable. If the type is already syntactically free of the --- variable, then the same type is returned. - -occurCheckExpand tv ty - | not (tv `elemVarSet` tyVarsOfType ty) = Just ty - | otherwise = go ty +-- Check whether +-- a) the given variable occurs in the given type. +-- b) there is a forall in the type (unless we have -XImpredicativeTypes +-- or it's a PolyTv +-- c) if it's a SigTv, ty should be a tyvar +-- +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. + +occurCheckExpand dflags tv ty + | MetaTv { mtv_info = SigTv } <- details + = go_sig_tv ty + | fast_check ty = return ty + | otherwise = go ty where - go t@(TyVarTy tv') | tv == tv' = Nothing - | otherwise = Just t + details = ASSERT2( isTcTyVar tv, ppr tv ) tcTyVarDetails tv + + impredicative + = case details of + MetaTv { mtv_info = PolyTv } -> True + MetaTv { mtv_info = SigTv } -> False + MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags + || isOpenTypeKind (tyVarKind tv) + -- Note [OpenTypeKind accepts foralls] + -- in TcUnify + _other -> True + -- We can have non-meta tyvars in given constraints + + -- Check 'ty' is a tyvar, or can be expanded into one + go_sig_tv ty@(TyVarTy {}) = OC_OK ty + go_sig_tv ty | Just ty' <- tcView ty = go_sig_tv ty' + go_sig_tv _ = OC_NonTyVar + + -- True => fine + fast_check (LitTy {}) = True + fast_check (TyVarTy tv') = tv /= tv' + fast_check (TyConApp _ tys) = all fast_check tys + fast_check (FunTy arg res) = fast_check arg && fast_check res + fast_check (AppTy fun arg) = fast_check fun && fast_check arg + fast_check (ForAllTy tv' ty) = impredicative + && fast_check (tyVarKind tv') + && (tv == tv' || fast_check ty) + + go t@(TyVarTy tv') | tv == tv' = OC_Occurs + | otherwise = return t go ty@(LitTy {}) = return ty go (AppTy ty1 ty2) = do { ty1' <- go ty1 ; ty2' <- go ty2 ; return (mkAppTy ty1' ty2') } - -- mkAppTy <$> go ty1 <*> go ty2 go (FunTy ty1 ty2) = do { ty1' <- go ty1 ; ty2' <- go ty2 ; return (mkFunTy ty1' ty2') } - -- mkFunTy <$> go ty1 <*> go ty2 - go ty@(ForAllTy {}) - | tv `elemVarSet` tyVarsOfTypes tvs_knds = Nothing + go ty@(ForAllTy tv' body_ty) + | not impredicative = OC_Forall + | not (fast_check (tyVarKind tv')) = OC_Occurs -- Can't expand away the kinds unless we create -- fresh variables which we don't want to do at this point. - | otherwise = do { rho' <- go rho - ; return (mkForAllTys tvs rho') } - where - (tvs,rho) = splitForAllTys ty - tvs_knds = map tyVarKind tvs + -- In principle fast_check might fail because of a for-all + -- but we don't yet have poly-kinded tyvars so I'm not + -- going to worry about that now + | tv == tv' = return ty + | otherwise = do { body' <- go body_ty + ; return (ForAllTy tv' body') } -- For a type constructor application, first try expanding away the -- offending variable from the arguments. If that doesn't work, next -- see if the type constructor is a type synonym, and if so, expand -- it and try again. go ty@(TyConApp tc tys) -{- - | isSynFamilyTyCon tc -- It's ok for tv to occur under a type family application - = return ty -- Eg. (a ~ F a) is not an occur-check error - -- NB This case can't occur during canonicalisation, - -- because the arg is a Xi-type, but can occur in the - -- call from TcErrors - | otherwise --} - = do { tys <- mapM go tys; return (mkTyConApp tc tys) } - `firstJust` -- First try to eliminate the tyvar from the args - do { ty <- tcView ty; go ty } - -- Failing that, try to expand a synonym + = case do { tys <- mapM go tys; return (mkTyConApp tc tys) } of + OC_OK ty -> return ty -- First try to eliminate the tyvar from the args + bad | Just ty' <- tcView ty -> go ty' + | otherwise -> bad + -- Failing that, try to expand a synonym \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 999575be85..04f1acc595 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -160,6 +160,7 @@ matchExpectedFunTys herald arity orig_ty defer n_req fun_ty = addErrCtxtM mk_ctxt $ do { arg_tys <- newFlexiTyVarTys n_req openTypeKind + -- See Note [Foralls to left of arrow] ; res_ty <- newFlexiTyVarTy openTypeKind ; co <- unifyType fun_ty (mkFunTys arg_tys res_ty) ; return (co, arg_tys, res_ty) } @@ -179,6 +180,14 @@ matchExpectedFunTys herald arity orig_ty else ptext (sLit "has only") <+> speakN n_args] \end{code} +Note [Foralls to left of arrow] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f (x :: forall a. a -> a) = x +We give 'f' the type (alpha -> beta), and then want to unify +the alpha with (forall a. a->a). We want to the arg and result +of (->) to have openTypeKind, and this also permits foralls, so +we are ok. \begin{code} ---------------------- @@ -317,15 +326,24 @@ tcSubType origin ctxt ty_actual ty_expected = do { (sk_wrap, inst_wrap) <- tcGen ctxt ty_expected $ \ _ sk_rho -> do { (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual - ; cow <- unifyType in_rho sk_rho + ; cow <- unify in_rho sk_rho ; return (coToHsWrapper cow <.> in_wrap) } ; return (sk_wrap <.> inst_wrap) } | otherwise -- Urgh! It seems deeply weird to have equality -- when actual is not a polytype, and it makes a big -- difference e.g. tcfail104 - = do { cow <- unifyType ty_actual ty_expected + = do { cow <- unify ty_actual ty_expected ; return (coToHsWrapper cow) } + where + -- In the case of patterns we call tcSubType with (expected, actual) + -- rather than (actual, expected). To get error messages the + -- right way round we have to fiddle with the origin + unify ty1 ty2 = uType u_origin ty1 ty2 + where + u_origin = case origin of + PatSigOrigin -> TypeEqOrigin { uo_actual = ty2, uo_expected = ty1 } + _other -> TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind @@ -763,8 +781,9 @@ uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2) uUnfilledVar origin swapped tv1 details1 non_var_ty2 -- ty2 is not a type variable = case details1 of - MetaTv { mtv_info = TauTv, mtv_ref = ref1 } - -> do { mb_ty2' <- checkTauTvUpdate tv1 non_var_ty2 + MetaTv { mtv_ref = ref1 } + -> do { dflags <- getDynFlags + ; mb_ty2' <- checkTauTvUpdate dflags tv1 non_var_ty2 ; case mb_ty2' of Just ty2' -> updateMeta tv1 ref1 ty2' Nothing -> do { traceTc "Occ/kind defer" @@ -830,9 +849,9 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2 -- type sig ---------------- -checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType) +checkTauTvUpdate :: DynFlags -> TcTyVar -> TcType -> TcM (Maybe TcType) -- (checkTauTvUpdate tv ty) --- We are about to update the TauTv tv with ty. +-- We are about to update the TauTv/PolyTv tv with ty. -- Check (a) that tv doesn't occur in ty (occurs check) -- (b) that kind(ty) is a sub-kind of kind(tv) -- @@ -851,7 +870,11 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType) -- we return Nothing, leaving it to the later constraint simplifier to -- sort matters out. -checkTauTvUpdate tv ty +checkTauTvUpdate dflags tv ty + | SigTv <- info + = ASSERT( not (isTyVarTy ty) ) + return Nothing + | otherwise = do { ty1 <- zonkTcType ty ; sub_k <- unifyKindX (tyVarKind tv) (typeKind ty1) ; case sub_k of @@ -859,12 +882,19 @@ checkTauTvUpdate tv ty Just LT -> return Nothing _ | defer_me ty1 -- Quick test -> -- Failed quick test so try harder - case occurCheckExpand tv ty1 of - Nothing -> return Nothing - Just ty2 | defer_me ty2 -> return Nothing - | otherwise -> return (Just ty2) + case occurCheckExpand dflags tv ty1 of + OC_OK ty2 | defer_me ty2 -> return Nothing + | otherwise -> return (Just ty2) + _ -> return Nothing | otherwise -> return (Just ty1) } where + info = ASSERT2( isMetaTyVar tv, ppr tv ) metaTyVarInfo tv + + impredicative = xopt Opt_ImpredicativeTypes dflags + || isOpenTypeKind (tyVarKind tv) + -- Note [OpenTypeKind accepts foralls] + || case info of { PolyTv -> True; _ -> False } + defer_me :: TcType -> Bool -- Checks for (a) occurrence of tv -- (b) type family applicatios @@ -874,9 +904,27 @@ checkTauTvUpdate tv ty defer_me (TyConApp tc tys) = isSynFamilyTyCon tc || any defer_me tys defer_me (FunTy arg res) = defer_me arg || defer_me res defer_me (AppTy fun arg) = defer_me fun || defer_me arg - defer_me (ForAllTy _ ty) = defer_me ty + defer_me (ForAllTy _ ty) = not impredicative || defer_me ty \end{code} +Note [OpenTypeKind accepts foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a common paradigm: + foo :: (forall a. a -> a) -> Int + foo = error "urk" +To make this work we need to instantiate 'error' with a polytype. +A similar case is + bar :: Bool -> (forall a. a->a) -> Int + bar True = \x. (x 3) + bar False = error "urk" +Here we need to instantiate 'error' with a polytype. + +But 'error' has an OpenTypeKind type variable, precisely so that +we can instantiate it with Int#. So we also allow such type variables +to be instantiate with foralls. It's a bit of a hack, but seems +straightforward. + + Note [Conservative unification check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When unifying (tv ~ rhs), w try to avoid creating deferred constraints @@ -1146,9 +1194,10 @@ uUnboundKVar kv1 non_var_k2 ; let k2b = defaultKind k2a -- MetaKindVars must be bound only to simple kinds - ; case occurCheckExpand kv1 k2b of - Just k2c -> do { writeMetaTyVar kv1 k2c; return (Just EQ) } - _ -> return Nothing } + ; dflags <- getDynFlags + ; case occurCheckExpand dflags kv1 k2b of + OC_OK k2c -> do { writeMetaTyVar kv1 k2c; return (Just EQ) } + _ -> return Nothing } mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) mkKindErrorCtxt ty1 ty2 k1 k2 env0 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 diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs index 96e0dbc225..da95884326 100644 --- a/compiler/vectorise/Vectorise/Generic/PADict.hs +++ b/compiler/vectorise/Vectorise/Generic/PADict.hs @@ -13,7 +13,7 @@ import BasicTypes import CoreSyn import CoreUtils import CoreUnfold -import DsMonad +import Module import TyCon import Type import Id @@ -58,7 +58,7 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr = polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda abstract over; and they -- are put in the envt, so when we need a (PA a) we can find it in -- the envt; they don't include the silent superclass args yet - do { mod <- liftDs getModuleDs + do { mod <- liftDs getModule ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name -- The superclass dictionary is a (silent) argument if the tycon is polymorphic... diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs index 30b8a0e1e4..def1ffa58c 100644 --- a/compiler/vectorise/Vectorise/Monad/Naming.hs +++ b/compiler/vectorise/Vectorise/Monad/Naming.hs @@ -19,6 +19,7 @@ import DsMonad import TcType import Type import Var +import Module import Name import SrcLoc import MkId @@ -37,7 +38,7 @@ import Control.Monad -- mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name mkLocalisedName mk_occ name - = do { mod <- liftDs getModuleDs + = do { mod <- liftDs getModule ; u <- liftDs newUnique ; let occ_name = mkLocalisedOccName mod mk_occ name @@ -86,7 +87,7 @@ cloneVar var = liftM (setIdUnique var) (liftDs newUnique) -- newExportedVar :: OccName -> Type -> VM Var newExportedVar occ_name ty - = do mod <- liftDs getModuleDs + = do mod <- liftDs getModule u <- liftDs newUnique let name = mkExternalName u mod occ_name noSrcSpan |