diff options
Diffstat (limited to 'ghc/compiler/simplCore/SimplMonad.lhs')
| -rw-r--r-- | ghc/compiler/simplCore/SimplMonad.lhs | 687 |
1 files changed, 454 insertions, 233 deletions
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 9c1a6671ee..17a4639fe5 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -11,19 +11,24 @@ module SimplMonad ( -- The continuation type SimplCont(..), DupFlag(..), contIsDupable, contResultType, + contIsInteresting, pushArgs, discardCont, countValArgs, countArgs, + contIsInline, discardInlineCont, -- The monad SimplM, initSmpl, returnSmpl, thenSmpl, thenSmpl_, mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl, + -- The inlining black-list + getBlackList, + -- Unique supply getUniqueSmpl, getUniquesSmpl, newId, newIds, -- Counting - SimplCount, TickType(..), TickCounts, - tick, tickUnfold, + SimplCount, Tick(..), TickCounts, + tick, freeTick, getSimplCount, zeroSimplCount, pprSimplCount, plusSimplCount, isZeroSimplCount, @@ -34,31 +39,41 @@ module SimplMonad ( getEnclosingCC, setEnclosingCC, -- Environments - InScopeEnv, SubstEnv, + getSubst, setSubst, + getSubstEnv, extendSubst, extendSubstList, getInScope, setInScope, extendInScope, extendInScopes, modifyInScope, - emptySubstEnv, getSubstEnv, setSubstEnv, zapSubstEnv, - extendIdSubst, extendTySubst, - getTyEnv, getValEnv, + setSubstEnv, zapSubstEnv, getSimplBinderStuff, setSimplBinderStuff, switchOffInlining ) where #include "HsVersions.h" +import Const ( Con(DEFAULT) ) import Id ( Id, mkSysLocal, idMustBeINLINEd ) import IdInfo ( InlinePragInfo(..) ) import Demand ( Demand ) import CoreSyn -import CoreUtils ( IdSubst, SubstCoreExpr, coreExprType, coreAltsType ) +import PprCore () -- Instances +import Rules ( RuleBase ) import CostCentre ( CostCentreStack, subsumedCCS ) import Var ( TyVar ) import VarEnv import VarSet -import Type ( Type, TyVarSubst, funResultTy, fullSubstTy, applyTy ) +import qualified Subst +import Subst ( Subst, emptySubst, mkSubst, + substTy, substEnv, + InScopeSet, substInScope, isInScope, lookupInScope + ) +import Type ( Type, TyVarSubst, applyTy ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, UniqSupply ) -import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), intSwitchSet ) +import FiniteMap +import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), + opt_PprStyle_Debug, opt_HistorySize, + intSwitchSet + ) import Unique ( Unique ) import Maybes ( expectJust ) import Util ( zipWithEqual ) @@ -101,19 +116,21 @@ type SwitchChecker = SimplifierSwitch -> SwitchResult %************************************************************************ \begin{code} -type OutExprStuff = OutStuff (InScopeEnv, OutExpr) +type OutExprStuff = OutStuff (InScopeSet, OutExpr) type OutStuff a = ([OutBind], a) -- We return something equivalent to (let b in e), but -- in pieces to avoid the quadratic blowup when floating -- incrementally. Comments just before simplExprB in Simplify.lhs data SimplCont -- Strict contexts - = Stop + = Stop OutType -- Type of the result - | CoerceIt DupFlag - InType SubstEnv + | CoerceIt OutType -- The To-type, simplified SimplCont + | InlinePlease -- This continuation makes a function very + SimplCont -- keen to inline itelf + | ApplyTo DupFlag InExpr SubstEnv -- The argument, as yet unsimplified, SimplCont -- and its subst-env @@ -122,18 +139,23 @@ data SimplCont -- Strict contexts InId [InAlt] SubstEnv -- The case binder, alts, and subst-env SimplCont - | ArgOf DupFlag -- An arbitrary strict context: the argument - (OutExpr -> SimplM OutExprStuff) -- of a strict function, or a primitive-arg fn - -- or a PrimOp - OutType -- Type of the result of the whole thing + | ArgOf DupFlag -- An arbitrary strict context: the argument + -- of a strict function, or a primitive-arg fn + -- or a PrimOp + OutType -- The type of the expression being sought by the context + -- f (error "foo") ==> coerce t (error "foo") + -- when f is strict + -- We need to know the type t, to which to coerce. + (OutExpr -> SimplM OutExprStuff) -- What to do with the result instance Outputable SimplCont where - ppr Stop = ptext SLIT("Stop") + ppr (Stop _) = ptext SLIT("Stop") ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont - ppr (ArgOf dup cont_fn _) = ptext SLIT("ArgOf...") <+> ppr dup + ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ (nest 4 (ppr alts)) $$ ppr cont - ppr (CoerceIt dup ty se cont) = (ptext SLIT("CoerceIt") <+> ppr dup <+> ppr ty) $$ ppr cont + ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont + ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont data DupFlag = OkToDup | NoDup @@ -142,25 +164,107 @@ instance Outputable DupFlag where ppr NoDup = ptext SLIT("nodup") contIsDupable :: SimplCont -> Bool -contIsDupable Stop = True +contIsDupable (Stop _) = True contIsDupable (ApplyTo OkToDup _ _ _) = True contIsDupable (ArgOf OkToDup _ _) = True contIsDupable (Select OkToDup _ _ _ _) = True -contIsDupable (CoerceIt OkToDup _ _ _) = True +contIsDupable (CoerceIt _ cont) = contIsDupable cont +contIsDupable (InlinePlease cont) = contIsDupable cont contIsDupable other = False -contResultType :: InScopeEnv -> Type -> SimplCont -> Type -contResultType in_scope e_ty cont - = go e_ty cont - where - go e_ty Stop = e_ty - go e_ty (ApplyTo _ (Type ty) se cont) = go (applyTy e_ty (simpl se ty)) cont - go e_ty (ApplyTo _ val_arg _ cont) = go (funResultTy e_ty) cont - go e_ty (ArgOf _ fun cont_ty) = cont_ty - go e_ty (CoerceIt _ ty se cont) = go (simpl se ty) cont - go e_ty (Select _ _ alts se cont) = go (simpl se (coreAltsType alts)) cont - - simpl (ty_subst, _) ty = fullSubstTy ty_subst in_scope ty +contIsInline :: SimplCont -> Bool +contIsInline (InlinePlease cont) = True +contIsInline other = False + +discardInlineCont :: SimplCont -> SimplCont +discardInlineCont (InlinePlease cont) = cont +discardInlineCont cont = cont +\end{code} + + +Comment about contIsInteresting +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee, application etc.) then we +inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. + +\begin{code} +contIsInteresting :: SimplCont -> Bool +contIsInteresting (Select _ _ alts _ _) = not (just_default alts) +contIsInteresting (CoerceIt _ cont) = contIsInteresting cont +contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont +contIsInteresting (ApplyTo _ _ _ _) = True +contIsInteresting (ArgOf _ _ _) = True + -- If this call is the arg of a strict function, the context + -- is a bit interesting. If we inline here, we may get useful + -- evaluation information to avoid repeated evals: e.g. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. +contIsInteresting (InlinePlease _) = True +contIsInteresting other = False + +just_default [(DEFAULT,_,_)] = True -- See notes below for why we look +just_default alts = False -- for this special case +\end{code} + + +\begin{code} +pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont +pushArgs se [] cont = cont +pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont) + +discardCont :: SimplCont -- A continuation, expecting + -> SimplCont -- Replace the continuation with a suitable coerce +discardCont (Stop to_ty) = Stop to_ty +discardCont cont = CoerceIt to_ty (Stop to_ty) + where + to_ty = contResultType cont + +contResultType :: SimplCont -> OutType +contResultType (Stop to_ty) = to_ty +contResultType (ArgOf _ to_ty _) = to_ty +contResultType (ApplyTo _ _ _ cont) = contResultType cont +contResultType (CoerceIt _ cont) = contResultType cont +contResultType (InlinePlease cont) = contResultType cont +contResultType (Select _ _ _ _ cont) = contResultType cont + +countValArgs :: SimplCont -> Int +countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont +countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont +countValArgs other = 0 + +countArgs :: SimplCont -> Int +countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont +countArgs other = 0 \end{code} @@ -182,21 +286,40 @@ type SimplM result -- We thread the unique supply because data SimplEnv = SimplEnv { - seChkr :: SwitchChecker, - seCC :: CostCentreStack, -- The enclosing CCS (when profiling) - seSubst :: SubstEnv, -- The current substitution - seInScope :: InScopeEnv -- Says what's in scope and gives info about it + seChkr :: SwitchChecker, + seCC :: CostCentreStack, -- The enclosing CCS (when profiling) + seBlackList :: Id -> Bool, -- True => don't inline this Id + seSubst :: Subst -- The current substitution } + -- The range of the substitution is OutType and OutExpr resp + -- + -- The substitution is idempotent + -- It *must* be applied; things in its domain simply aren't + -- bound in the result. + -- + -- The substitution usually maps an Id to its clone, + -- but if the orig defn is a let-binding, and + -- the RHS of the let simplifies to an atom, + -- we just add the binding to the substitution and elide the let. + + -- The in-scope part of Subst includes *all* in-scope TyVars and Ids + -- The elements of the set may have better IdInfo than the + -- occurrences of in-scope Ids, and (more important) they will + -- have a correctly-substituted type. So we use a lookup in this + -- set to replace occurrences \end{code} \begin{code} initSmpl :: SwitchChecker -> UniqSupply -- No init count; set to 0 + -> VarSet -- In scope (usually empty, but useful for nested calls) + -> (Id -> Bool) -- Black-list function -> SimplM a -> (a, SimplCount) -initSmpl chkr us m = case m (emptySimplEnv chkr) us zeroSimplCount of - (result, _, count) -> (result, count) +initSmpl chkr us in_scope black_list m + = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of + (result, _, count) -> (result, count) {-# INLINE thenSmpl #-} @@ -266,135 +389,262 @@ getUniquesSmpl n env us sc = case splitUniqSupply us of %************************************************************************ \begin{code} -doTickSmpl :: (SimplCount -> SimplCount) -> SimplM () -doTickSmpl f env us sc = sc' `seq` ((), us, sc') - where - sc' = f sc - getSimplCount :: SimplM SimplCount getSimplCount env us sc = (sc, us, sc) -\end{code} - -The assoc list isn't particularly costly, because we only use -the number of ticks in ``real life.'' +tick :: Tick -> SimplM () +tick t env us sc = sc' `seq` ((), us, sc') + where + sc' = doTick t sc + +freeTick :: Tick -> SimplM () +-- Record a tick, but don't add to the total tick count, which is +-- used to decide when nothing further has happened +freeTick t env us sc = sc' `seq` ((), us, sc') + where + sc' = doFreeTick t sc +\end{code} -The right thing to do, if you want that to go fast, is thread -a mutable array through @SimplM@. +\begin{code} +verboseSimplStats = opt_PprStyle_Debug -- For now, anyway + +-- Defined both with and without debugging +zeroSimplCount :: SimplCount +isZeroSimplCount :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doTick, doFreeTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount +\end{code} \begin{code} -data SimplCount - = SimplCount !TickCounts - !UnfoldingHistory - -type TickCounts = [(TickType, Int)] -- Assoc list of all diff kinds of ticks - -- Kept in increasing order of TickType - -- Zeros not present - -type UnfoldingHistory = (Int, -- N - [Id], -- Last N unfoldings - [Id]) -- The MaxUnfoldHistory unfoldings before that - -data TickType - = PreInlineUnconditionally - | PostInlineUnconditionally - | UnfoldingDone - | MagicUnfold - | CaseOfCase - | LetFloatFromLet - | KnownBranch - | Let2Case - | Case2Let - | CaseMerge - | CaseElim - | CaseIdentity - | EtaExpansion - | CaseOfError - | BetaReduction - | SpecialisationDone - | FillInCaseDefault - | LeavesExamined - deriving (Eq, Ord, Show) - -pprSimplCount :: SimplCount -> SDoc -pprSimplCount (SimplCount stuff (_, unf1, unf2)) - = vcat (map ppr_item stuff) - $$ (text "Most recent unfoldings (most recent at top):" - $$ nest 4 (vcat (map ppr (unf1 ++ unf2)))) - where - ppr_item (t,n) = text (show t) <+> char '\t' <+> ppr n +#ifndef DEBUG +---------------------------------------------------------- +-- Debugging OFF +---------------------------------------------------------- +type SimplCount = Int zeroSimplCount :: SimplCount -zeroSimplCount = SimplCount [] (0, [], []) - -isZeroSimplCount :: SimplCount -> Bool -isZeroSimplCount (SimplCount [] _) = True -isZeroSimplCount (SimplCount [(LeavesExamined,_)] _) = True -isZeroSimplCount other = False - --- incTick is careful to be pretty strict, so we don't --- get a huge buildup of thunks -incTick :: TickType -> FAST_INT -> TickCounts -> TickCounts -incTick tick_type n [] - = [(tick_type, IBOX(n))] - -incTick tick_type n (x@(ttype, I# cnt#) : xs) - = case tick_type `compare` ttype of - LT -> -- Insert here - (tick_type, IBOX(n)) : x : xs - - EQ -> -- Increment - case cnt# +# n of - incd -> (ttype, IBOX(incd)) : xs - - GT -> -- Move on - rest `seq` x : rest - where - rest = incTick tick_type n xs - --- Second argument is more recent stuff -plusSimplCount :: SimplCount -> SimplCount -> SimplCount -plusSimplCount (SimplCount tc1 uh1) (SimplCount tc2 uh2) - = SimplCount (plusTickCounts tc1 tc2) (plusUnfolds uh1 uh2) - -plusTickCounts :: TickCounts -> TickCounts -> TickCounts -plusTickCounts ts1 [] = ts1 -plusTickCounts [] ts2 = ts2 -plusTickCounts ((tt1,n1) : ts1) ((tt2,n2) : ts2) - = case tt1 `compare` tt2 of - LT -> (tt1,n1) : plusTickCounts ts1 ((tt2,n2) : ts2) - EQ -> (tt1,n1+n2) : plusTickCounts ts1 ts2 - GT -> (tt2,n2) : plusTickCounts ((tt1,n1) : ts1) ts2 - --- Second argument is the more recent stuff -plusUnfolds uh1 (0, h2, t2) = uh1 -- Nothing recent -plusUnfolds (n1, h1, t1) (n2, h2, []) = (n2, h2, (h1++t1)) -- Small amount recent -plusUnfolds (n1, h1, t1) uh2 = uh2 -- Decent batch recent -\end{code} +zeroSimplCount = 0 +isZeroSimplCount n = n==0 -Counting-related monad functions: +doTick t n = n+1 -- Very basic when not debugging +doFreeTick t n = n -- Don't count leaf visits -\begin{code} -tick :: TickType -> SimplM () +pprSimplCount n = ptext SLIT("Total ticks:") <+> int n + +plusSimplCount n m = n+m + +#else +---------------------------------------------------------- +-- Debugging ON +---------------------------------------------------------- + +data SimplCount = SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize + log2 :: [Tick] -- Last opt_HistorySize events before that + } -tick tick_type - = doTickSmpl f +type TickCounts = FiniteMap Tick Int + +zeroSimplCount = SimplCount {ticks = 0, details = emptyFM, + n_log = 0, log1 = [], log2 = []} + +isZeroSimplCount sc = ticks sc == 0 + +doFreeTick tick sc@SimplCount { details = dts } + = dts' `seqFM` sc { details = dts' } + where + dts' = dts `addTick` tick + +-- Gross hack to persuade GHC 3.03 to do this important seq +seqFM fm x | isEmptyFM fm = x + | otherwise = x + +doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 } + | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +-- Don't use plusFM_C because that's lazy, and we want to +-- be pretty strict here! +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = case lookupFM fm tick of + Nothing -> addToFM fm tick 1 + Just n -> n1 `seq` addToFM fm tick n1 + where + n1 = n+1 + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 } where - f (SimplCount stuff unf) = SimplCount (incTick tick_type ILIT(1) stuff) unf - -maxUnfoldHistory :: Int -maxUnfoldHistory = 20 - -tickUnfold :: Id -> SimplM () -tickUnfold id - = doTickSmpl f - where - f (SimplCount stuff (n_unf, unf1, unf2)) - | n_unf >= maxUnfoldHistory = SimplCount new_stuff (1, [id], unf1) - | otherwise = SimplCount new_stuff (n_unf+1, id:unf1, unf2) - where - new_stuff = incTick UnfoldingDone ILIT(1) stuff + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + + +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [ptext SLIT("Total ticks: ") <+> int tks, + text "", + pprTickCounts (fmToList dts), + if verboseSimplStats then + vcat [text "", + ptext SLIT("Log (most recent first)"), + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else empty + ] + +pprTickCounts :: [(Tick,Int)] -> SDoc +pprTickCounts [] = empty +pprTickCounts ((tick1,n1):ticks) + = vcat [int tot_n <+> text (tickString tick1), + pprTCDetails real_these, + pprTickCounts others + ] + where + tick1_tag = tickToTag tick1 + (these, others) = span same_tick ticks + real_these = (tick1,n1):these + same_tick (tick2,_) = tickToTag tick2 == tick1_tag + tot_n = sum [n | (_,n) <- real_these] + +pprTCDetails ticks@((tick,_):_) + | verboseSimplStats || isRuleFired tick + = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks]) + | otherwise + = empty +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{Ticks} +%* * +%************************************************************************ + +\begin{code} +data Tick + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FAST_STRING -- Rule name + + | LetFloatFromLet Id -- Thing floated out + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | BottomFound + | LeafVisit + | SimplifierDone -- Ticked at each iteration of the simplifier + +isRuleFired (RuleFired _) = True +isRuleFired other = False + +instance Outputable Tick where + ppr tick = text (tickString tick) <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of { EQ -> True; other -> False } + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag (LetFloatFromLet _) = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag BottomFound = 14 +tickToTag LeafVisit = 15 +tickToTag SimplifierDone = 16 + +tickString :: Tick -> String +tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" +tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" +tickString (UnfoldingDone _) = "UnfoldingDone" +tickString (RuleFired _) = "RuleFired" +tickString (LetFloatFromLet _) = "LetFloatFromLet" +tickString (EtaExpansion _) = "EtaExpansion" +tickString (EtaReduction _) = "EtaReduction" +tickString (BetaReduction _) = "BetaReduction" +tickString (CaseOfCase _) = "CaseOfCase" +tickString (KnownBranch _) = "KnownBranch" +tickString (CaseMerge _) = "CaseMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString BottomFound = "BottomFound" +tickString SimplifierDone = "SimplifierDone" +tickString LeafVisit = "LeafVisit" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts (LetFloatFromLet v) = ppr v +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts other = empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b + | otherwise -> EQ + LT -> LT + -- Always distinguish RuleFired, so that the stats + -- can report them even in non-verbose mode + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b +cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick other1 other2 = EQ \end{code} @@ -476,11 +726,8 @@ environment seems like wild overkill. \begin{code} switchOffInlining :: SimplM a -> SimplM a -switchOffInlining m env@(SimplEnv { seChkr = sw_chkr }) us sc - = m (env { seChkr = new_chkr }) us sc - where - new_chkr EssentialUnfoldingsOnly = SwBool True - new_chkr other = sw_chkr other +switchOffInlining m env us sc + = m (env { seBlackList = \v -> True }) us sc \end{code} @@ -505,120 +752,94 @@ setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc %* * %************************************************************************ -\begin{code} -type SubstEnv = (TyVarSubst, IdSubst) - -- The range of these substitutions is OutType and OutExpr resp - -- - -- The substitution is idempotent - -- It *must* be applied; things in its domain simply aren't - -- bound in the result. - -- - -- The substitution usually maps an Id to its clone, - -- but if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just add the binding to the substitution and elide the let. - -type InScopeEnv = IdOrTyVarSet - -- Domain includes *all* in-scope TyVars and Ids - -- - -- The elements of the set may have better IdInfo than the - -- occurrences of in-scope Ids, and (more important) they will - -- have a correctly-substituted type. So we use a lookup in this - -- set to replace occurrences - --- INVARIANT: If t is in the in-scope set, it certainly won't be --- in the domain of the SubstEnv, and vice versa -\end{code} - \begin{code} -emptySubstEnv :: SubstEnv -emptySubstEnv = (emptyVarEnv, emptyVarEnv) - -emptySimplEnv :: SwitchChecker -> SimplEnv +emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv -emptySimplEnv sw_chkr +emptySimplEnv sw_chkr in_scope black_list = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS, - seSubst = emptySubstEnv, - seInScope = emptyVarSet } - + seBlackList = black_list, + seSubst = mkSubst in_scope emptySubstEnv } -- The top level "enclosing CC" is "SUBSUMED". -getTyEnv :: SimplM (TyVarSubst, InScopeEnv) -getTyEnv (SimplEnv {seSubst = (ty_subst,_), seInScope = in_scope}) us sc - = ((ty_subst, in_scope), us, sc) +getSubst :: SimplM Subst +getSubst env us sc = (seSubst env, us, sc) -getValEnv :: SimplM (IdSubst, InScopeEnv) -getValEnv (SimplEnv {seSubst = (_, id_subst), seInScope = in_scope}) us sc - = ((id_subst, in_scope), us, sc) +getBlackList :: SimplM (Id -> Bool) +getBlackList env us sc = (seBlackList env, us, sc) -getInScope :: SimplM InScopeEnv -getInScope env us sc = (seInScope env, us, sc) +setSubst :: Subst -> SimplM a -> SimplM a +setSubst subst m env us sc = m (env {seSubst = subst}) us sc -setInScope :: InScopeEnv -> SimplM a -> SimplM a -setInScope in_scope m env us sc = m (env {seInScope = in_scope}) us sc +getSubstEnv :: SimplM SubstEnv +getSubstEnv env us sc = (substEnv (seSubst env), us, sc) extendInScope :: CoreBndr -> SimplM a -> SimplM a -extendInScope v m env@(SimplEnv {seInScope = in_scope}) us sc - = m (env {seInScope = extendVarSet in_scope v}) us sc +extendInScope v m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.extendInScope subst v}) us sc extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a -extendInScopes vs m env@(SimplEnv {seInScope = in_scope}) us sc - = m (env {seInScope = foldl extendVarSet in_scope vs}) us sc +extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.extendInScopes subst vs}) us sc + +getInScope :: SimplM InScopeSet +getInScope env us sc = (substInScope (seSubst env), us, sc) + +setInScope :: InScopeSet -> SimplM a -> SimplM a +setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.setInScope subst in_scope}) us sc modifyInScope :: CoreBndr -> SimplM a -> SimplM a modifyInScope v m env us sc #ifdef DEBUG - | not (v `elemVarSet` seInScope env ) + | not (v `isInScope` seSubst env) = pprTrace "modifyInScope: not in scope:" (ppr v) m env us sc #endif | otherwise = extendInScope v m env us sc -getSubstEnv :: SimplM SubstEnv -getSubstEnv env us sc = (seSubst env, us, sc) - -setSubstEnv :: SubstEnv -> SimplM a -> SimplM a -setSubstEnv subst_env m env us sc = m (env {seSubst = subst_env}) us sc +extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a +extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc + = m (env { seSubst = Subst.extendSubst subst var res }) us sc -extendIdSubst :: Id -> SubstCoreExpr -> SimplM a -> SimplM a -extendIdSubst id expr m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc - = m (env { seSubst = (ty_subst, extendVarEnv id_subst id expr) }) us sc +extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a +extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc + = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc -extendTySubst :: TyVar -> OutType -> SimplM a -> SimplM a -extendTySubst tv ty m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc - = m (env { seSubst = (extendVarEnv ty_subst tv ty, id_subst) }) us sc +setSubstEnv :: SubstEnv -> SimplM a -> SimplM a +setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc zapSubstEnv :: SimplM a -> SimplM a -zapSubstEnv m env us sc = m (env {seSubst = emptySubstEnv}) us sc +zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc + = m (env {seSubst = Subst.zapSubstEnv subst}) us sc -getSimplBinderStuff :: SimplM (TyVarSubst, IdSubst, InScopeEnv, UniqSupply) -getSimplBinderStuff (SimplEnv {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc - = ((ty_subst, id_subst, in_scope, us), us, sc) +getSimplBinderStuff :: SimplM (Subst, UniqSupply) +getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc + = ((subst, us), us, sc) -setSimplBinderStuff :: (TyVarSubst, IdSubst, InScopeEnv, UniqSupply) - -> SimplM a -> SimplM a -setSimplBinderStuff (ty_subst, id_subst, in_scope, us) m env _ sc - = m (env {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc +setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a +setSimplBinderStuff (subst, us) m env _ sc + = m (env {seSubst = subst}) us sc \end{code} \begin{code} newId :: Type -> (Id -> SimplM a) -> SimplM a -- Extends the in-scope-env too -newId ty m env@(SimplEnv {seInScope = in_scope}) us sc +newId ty m env@(SimplEnv {seSubst = subst}) us sc = case splitUniqSupply us of - (us1, us2) -> m v (env {seInScope = extendVarSet in_scope v}) us2 sc + (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc where v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a -newIds tys m env@(SimplEnv {seInScope = in_scope}) us sc +newIds tys m env@(SimplEnv {seSubst = subst}) us sc = case splitUniqSupply us of - (us1, us2) -> m vs (env {seInScope = foldl extendVarSet in_scope vs}) us2 sc + (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc where vs = zipWithEqual "newIds" (mkSysLocal SLIT("s")) (uniqsFromSupply (length tys) us1) tys -\end{code} +\end{code} |