X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplMonad.lhs;h=bc09e1128ce96c8dbc97fa159b21b3e52e003aa8;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=9c1a6671ee124164aa26468fc6cfc4c5b1dfb1f2;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 9c1a667..bc09e11 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -5,165 +5,55 @@ \begin{code} module SimplMonad ( - InId, InBind, InExpr, InAlt, InArg, InType, InBinder, - OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, - OutExprStuff, OutStuff, - - -- The continuation type - SimplCont(..), DupFlag(..), contIsDupable, contResultType, - -- The monad SimplM, initSmpl, returnSmpl, thenSmpl, thenSmpl_, mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl, + getDOptsSmpl, -- Unique supply - getUniqueSmpl, getUniquesSmpl, - newId, newIds, + getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId, -- Counting - SimplCount, TickType(..), TickCounts, - tick, tickUnfold, + SimplCount, Tick(..), + tick, freeTick, getSimplCount, zeroSimplCount, pprSimplCount, plusSimplCount, isZeroSimplCount, -- Switch checker - SwitchChecker, getSwitchChecker, getSimplIntSwitch, - - -- Cost centres - getEnclosingCC, setEnclosingCC, - - -- Environments - InScopeEnv, SubstEnv, - getInScope, setInScope, extendInScope, extendInScopes, modifyInScope, - emptySubstEnv, getSubstEnv, setSubstEnv, zapSubstEnv, - extendIdSubst, extendTySubst, - getTyEnv, getValEnv, - getSimplBinderStuff, setSimplBinderStuff, - switchOffInlining + SwitchChecker, SwitchResult(..), getSimplIntSwitch, + isAmongSimpl, intSwitchSet, switchIsOn ) where #include "HsVersions.h" -import Id ( Id, mkSysLocal, idMustBeINLINEd ) -import IdInfo ( InlinePragInfo(..) ) -import Demand ( Demand ) -import CoreSyn -import CoreUtils ( IdSubst, SubstCoreExpr, coreExprType, coreAltsType ) -import CostCentre ( CostCentreStack, subsumedCCS ) -import Var ( TyVar ) -import VarEnv -import VarSet -import Type ( Type, TyVarSubst, funResultTy, fullSubstTy, applyTy ) +import Id ( Id, mkSysLocal ) +import Type ( Type ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, UniqSupply ) -import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), intSwitchSet ) +import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt ) +import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize ) import Unique ( Unique ) import Maybes ( expectJust ) -import Util ( zipWithEqual ) +import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList ) +import FastString ( FastString ) import Outputable +import FastTypes -infixr 9 `thenSmpl`, `thenSmpl_` -\end{code} +import GLAEXTS ( indexArray# ) -%************************************************************************ -%* * -\subsection[Simplify-types]{Type declarations} -%* * -%************************************************************************ +#if __GLASGOW_HASKELL__ < 503 +import PrelArr ( Array(..) ) +#else +import GHC.Arr ( Array(..) ) +#endif -\begin{code} -type InBinder = CoreBndr -type InId = Id -- Not yet cloned -type InType = Type -- Ditto -type InBind = CoreBind -type InExpr = CoreExpr -type InAlt = CoreAlt -type InArg = CoreArg - -type OutBinder = CoreBndr -type OutId = Id -- Cloned -type OutType = Type -- Cloned -type OutBind = CoreBind -type OutExpr = CoreExpr -type OutAlt = CoreAlt -type OutArg = CoreArg +import Array ( array, (//) ) -type SwitchChecker = SimplifierSwitch -> SwitchResult +infixr 0 `thenSmpl`, `thenSmpl_` \end{code} - -%************************************************************************ -%* * -\subsection{The continuation data type} -%* * -%************************************************************************ - -\begin{code} -type OutExprStuff = OutStuff (InScopeEnv, 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 - - | CoerceIt DupFlag - InType SubstEnv - SimplCont - - | ApplyTo DupFlag - InExpr SubstEnv -- The argument, as yet unsimplified, - SimplCont -- and its subst-env - - | Select DupFlag - 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 - -instance Outputable SimplCont where - 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 (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 - -data DupFlag = OkToDup | NoDup - -instance Outputable DupFlag where - ppr OkToDup = ptext SLIT("ok") - ppr NoDup = ptext SLIT("nodup") - -contIsDupable :: SimplCont -> Bool -contIsDupable Stop = True -contIsDupable (ApplyTo OkToDup _ _ _) = True -contIsDupable (ArgOf OkToDup _ _) = True -contIsDupable (Select OkToDup _ _ _ _) = True -contIsDupable (CoerceIt OkToDup _ _ _) = True -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 -\end{code} - - %************************************************************************ %* * \subsection{Monad plumbing} @@ -174,48 +64,48 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter. (Command-line switches move around through the explicitly-passed SimplEnv.) \begin{code} -type SimplM result -- We thread the unique supply because - = SimplEnv -- constantly splitting it is rather expensive - -> UniqSupply - -> SimplCount - -> (result, UniqSupply, SimplCount) - -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 - } +newtype SimplM result + = SM { unSM :: DynFlags -- We thread the unique supply because + -> UniqSupply -- constantly splitting it is rather expensive + -> SimplCount + -> (result, UniqSupply, SimplCount)} \end{code} \begin{code} -initSmpl :: SwitchChecker +initSmpl :: DynFlags -> UniqSupply -- No init count; set to 0 -> SimplM a -> (a, SimplCount) -initSmpl chkr us m = case m (emptySimplEnv chkr) us zeroSimplCount of - (result, _, count) -> (result, count) +initSmpl dflags us m + = case unSM m dflags us (zeroSimplCount dflags) of + (result, _, count) -> (result, count) {-# INLINE thenSmpl #-} {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-} +instance Monad SimplM where + (>>) = thenSmpl_ + (>>=) = thenSmpl + return = returnSmpl + returnSmpl :: a -> SimplM a -returnSmpl e env us sc = (e, us, sc) +returnSmpl e = SM (\ dflags us sc -> (e, us, sc)) thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b thenSmpl_ :: SimplM a -> SimplM b -> SimplM b -thenSmpl m k env us0 sc0 - = case (m env us0 sc0) of - (m_result, us1, sc1) -> k m_result env us1 sc1 +thenSmpl m k + = SM (\ dflags us0 sc0 -> + case (unSM m dflags us0 sc0) of + (m_result, us1, sc1) -> unSM (k m_result) dflags us1 sc1 ) -thenSmpl_ m k env us0 sc0 - = case (m env us0 sc0) of - (_, us1, sc1) -> k env us1 sc1 +thenSmpl_ m k + = SM (\dflags us0 sc0 -> + case (unSM m dflags us0 sc0) of + (_, us1, sc1) -> unSM k dflags us1 sc1) \end{code} @@ -235,6 +125,7 @@ mapAndUnzipSmpl f (x:xs) mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) -> returnSmpl (r1:rs1, r2:rs2) +mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) mapAccumLSmpl f acc [] = returnSmpl (acc, []) mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') -> @@ -249,13 +140,28 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> %************************************************************************ \begin{code} -getUniqueSmpl :: SimplM Unique -getUniqueSmpl env us sc = case splitUniqSupply us of - (us1, us2) -> (uniqFromSupply us1, us2, sc) +getUniqSupplySmpl :: SimplM UniqSupply +getUniqSupplySmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (us1, us2, sc)) -getUniquesSmpl :: Int -> SimplM [Unique] -getUniquesSmpl n env us sc = case splitUniqSupply us of - (us1, us2) -> (uniqsFromSupply n us1, us2, sc) +getUniqueSmpl :: SimplM Unique +getUniqueSmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (uniqFromSupply us1, us2, sc)) + +getUniquesSmpl :: SimplM [Unique] +getUniquesSmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (uniqsFromSupply us1, us2, sc)) + +getDOptsSmpl :: SimplM DynFlags +getDOptsSmpl + = SM (\dflags us sc -> (dflags, us, sc)) + +newId :: FastString -> Type -> SimplM Id +newId fs ty = getUniqueSmpl `thenSmpl` \ uniq -> + returnSmpl (mkSysLocal fs uniq ty) \end{code} @@ -266,359 +172,355 @@ 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) +getSimplCount = SM (\dflags us sc -> (sc, us, sc)) + +tick :: Tick -> SimplM () +tick t + = SM (\dflags us sc -> let sc' = doTick t sc + in sc' `seq` ((), us, 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 + = SM (\dflags us sc -> let sc' = doFreeTick t sc + in sc' `seq` ((), us, sc')) \end{code} - -The assoc list isn't particularly costly, because we only use -the number of ticks in ``real life.'' - -The right thing to do, if you want that to go fast, is thread -a mutable array through @SimplM@. - \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 - -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} - +verboseSimplStats = opt_PprStyle_Debug -- For now, anyway -Counting-related monad functions: +zeroSimplCount :: DynFlags -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doTick, doFreeTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount +\end{code} \begin{code} -tick :: TickType -> SimplM () +data SimplCount = VerySimplZero -- These two are used when + | VerySimplNonZero -- we are only interested in + -- termination info + + | 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 + } + +type TickCounts = FiniteMap Tick Int + +zeroSimplCount dflags + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dopt Opt_D_dump_simpl_stats dflags + = SimplCount {ticks = 0, details = emptyFM, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplZero -tick tick_type - = doTickSmpl f +isZeroSimplCount VerySimplZero = True +isZeroSimplCount (SimplCount { ticks = 0 }) = True +isZeroSimplCount other = False + +doFreeTick tick sc@SimplCount { details = dts } + = dts' `seqFM` sc { details = dts' } 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 -\end{code} + dts' = dts `addTick` tick +doFreeTick tick sc = sc +-- Gross hack to persuade GHC 3.03 to do this important seq +seqFM fm x | isEmptyFM fm = x + | otherwise = x -%************************************************************************ -%* * -\subsubsection{Command-line switches} -%* * -%************************************************************************ +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 } -\begin{code} -getSwitchChecker :: SimplM SwitchChecker -getSwitchChecker env us sc = (seChkr env, us, sc) +doTick tick sc = VerySimplNonZero -- The very simple case -getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int -getSimplIntSwitch chkr switch - = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) -\end{code} +-- 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 -@switchOffInlining@ is used to prepare the environment for simplifying -the RHS of an Id that's marked with an INLINE pragma. It is going to -be inlined wherever they are used, and then all the inlining will take -effect. Meanwhile, there isn't much point in doing anything to the -as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off -inlining! because - (a) not doing so will inline a worker straight back into its wrapper! - -and (b) Consider the following example - let f = \pq -> BIG - in - let g = \y -> f y y - {-# INLINE g #-} - in ...g...g...g...g...g... - - Now, if that's the ONLY occurrence of f, it will be inlined inside g, - and thence copied multiple times when g is inlined. - - Andy disagrees! Example: - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} - - Problem: any won't get deforested, and so if it's exported and - the importer doesn't use the inlining, (eg passes it as an arg) - then we won't get deforestation at all. - We havn't solved this problem yet! - -We prepare the envt by simply modifying the in_scope_env, which has all the -unfolding info. At one point we did it by modifying the chkr so that -it said "EssentialUnfoldingsOnly", but that prevented legitmate, and -important, simplifications happening in the body of the RHS. - -6/98 update: - -We *don't* prevent inlining from happening for identifiers -that are marked as IMustBeINLINEd. An example of where -doing this is crucial is: - - class Bar a => Foo a where - ...g.... - {-# INLINE f #-} - f :: Foo a => a -> b - f x = ....Foo_sc1... - -If `f' needs to peer inside Foo's superclass, Bar, it refers -to the appropriate super class selector, which is marked as -must-inlineable. We don't generate any code for a superclass -selector, so failing to inline it in the RHS of `f' will -leave a reference to a non-existent id, with bad consequences. - -ALSO NOTE that we do all this by modifing the inline-pragma, -not by zapping the unfolding. The latter may still be useful for -knowing when something is evaluated. - -June 98 update: I've gone back to dealing with this by adding -the EssentialUnfoldingsOnly switch. That doesn't stop essential -unfoldings, nor inlineUnconditionally stuff; and the thing's going -to be inlined at every call site anyway. Running over the whole -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 +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 } + where + -- 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 + +plusSimplCount VerySimplZero VerySimplZero = VerySimplZero +plusSimplCount sc1 sc2 = VerySimplNonZero + +pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!") +pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!") +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 - new_chkr EssentialUnfoldingsOnly = SwBool True - new_chkr other = sw_chkr other + 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 \end{code} - %************************************************************************ %* * -\subsubsection{The ``enclosing cost-centre''} +\subsection{Ticks} %* * %************************************************************************ \begin{code} -getEnclosingCC :: SimplM CostCentreStack -getEnclosingCC env us sc = (seCC env, us, sc) +data Tick + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name -setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a -setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc + | LetFloatFromLet + | 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 + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | BottomFound + | 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 SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +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 (AltMerge _) = "AltMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString BottomFound = "BottomFound" +tickString SimplifierDone = "SimplifierDone" + +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 = empty +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 (AltMerge 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 (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 (AltMerge a) (AltMerge 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} %************************************************************************ %* * -\subsubsection{The @SimplEnv@ type} +\subsubsection{Command-line switches} %* * %************************************************************************ \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} +type SwitchChecker = SimplifierSwitch -> SwitchResult +data SwitchResult + = SwBool Bool -- on/off + | SwString FastString -- nothing or a String + | SwInt Int -- nothing or an Int + +isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult +isAmongSimpl on_switches -- Switches mentioned later occur *earlier* + -- in the list; defaults right at the end. + = let + tidied_on_switches = foldl rm_dups [] on_switches + -- The fold*l* ensures that we keep the latest switches; + -- ie the ones that occur earliest in the list. + + sw_tbl :: Array Int SwitchResult + sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds... + all_undefined) + // defined_elems + + all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] + + defined_elems = map mk_assoc_elem tidied_on_switches + in + -- (avoid some unboxing, bounds checking, and other horrible things:) + case sw_tbl of { Array _ _ stuff -> + \ switch -> + case (indexArray# stuff (tagOf_SimplSwitch switch)) of + (# v #) -> v + } + where + mk_assoc_elem k@(MaxSimplifierIterations lvl) + = (iBox (tagOf_SimplSwitch k), SwInt lvl) + mk_assoc_elem k + = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom! + + -- cannot have duplicates if we are going to use the array thing + rm_dups switches_so_far switch + = if switch `is_elem` switches_so_far + then switches_so_far + else switch : switches_so_far + where + sw `is_elem` [] = False + sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s) + || sw `is_elem` ss +\end{code} \begin{code} -emptySubstEnv :: SubstEnv -emptySubstEnv = (emptyVarEnv, emptyVarEnv) - -emptySimplEnv :: SwitchChecker -> SimplEnv - -emptySimplEnv sw_chkr - = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS, - seSubst = emptySubstEnv, - seInScope = emptyVarSet } - - -- 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) - -getValEnv :: SimplM (IdSubst, InScopeEnv) -getValEnv (SimplEnv {seSubst = (_, id_subst), seInScope = in_scope}) us sc - = ((id_subst, in_scope), us, sc) - -getInScope :: SimplM InScopeEnv -getInScope env us sc = (seInScope env, us, sc) - -setInScope :: InScopeEnv -> SimplM a -> SimplM a -setInScope in_scope m env us sc = m (env {seInScope = in_scope}) us sc +getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int +getSimplIntSwitch chkr switch + = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) -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 +switchIsOn :: (switch -> SwitchResult) -> switch -> Bool -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 +switchIsOn lookup_fn switch + = case (lookup_fn switch) of + SwBool False -> False + _ -> True -modifyInScope :: CoreBndr -> SimplM a -> SimplM a -modifyInScope v m env us sc -#ifdef DEBUG - | not (v `elemVarSet` seInScope env ) - = pprTrace "modifyInScope: not in scope:" (ppr v) - m env us sc -#endif - | otherwise - = extendInScope v m env us sc +intSwitchSet :: (switch -> SwitchResult) + -> (Int -> switch) + -> Maybe Int -getSubstEnv :: SimplM SubstEnv -getSubstEnv env us sc = (seSubst env, us, sc) +intSwitchSet lookup_fn switch + = case (lookup_fn (switch (panic "intSwitchSet"))) of + SwInt int -> Just int + _ -> Nothing +\end{code} -setSubstEnv :: SubstEnv -> SimplM a -> SimplM a -setSubstEnv subst_env m env us sc = m (env {seSubst = subst_env}) 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 +These things behave just like enumeration types. -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 +\begin{code} +instance Eq SimplifierSwitch where + a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b -zapSubstEnv :: SimplM a -> SimplM a -zapSubstEnv m env us sc = m (env {seSubst = emptySubstEnv}) us sc +instance Ord SimplifierSwitch where + a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b + a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b -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) -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 -\end{code} +tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1) +tagOf_SimplSwitch NoCaseOfCase = _ILIT(2) +-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! -\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 - = case splitUniqSupply us of - (us1, us2) -> m v (env {seInScope = extendVarSet in_scope 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 - = case splitUniqSupply us of - (us1, us2) -> m vs (env {seInScope = foldl extendVarSet in_scope vs}) us2 sc - where - vs = zipWithEqual "newIds" (mkSysLocal SLIT("s")) - (uniqsFromSupply (length tys) us1) tys +lAST_SIMPL_SWITCH_TAG = 2 \end{code}