2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
8 InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
9 OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
10 FloatsWith, FloatsWithExpr,
14 initSmpl, returnSmpl, thenSmpl, thenSmpl_,
15 mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
18 -- The simplifier mode
22 getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
27 getSimplCount, zeroSimplCount, pprSimplCount,
28 plusSimplCount, isZeroSimplCount,
31 SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
32 isAmongSimpl, intSwitchSet, switchIsOn,
35 getEnclosingCC, setEnclosingCC,
38 SimplEnv, emptySimplEnv, getSubst, setSubst,
39 getSubstEnv, extendSubst, extendSubstList,
40 getInScope, setInScope, modifyInScope, addNewInScopeIds,
41 setSubstEnv, zapSubstEnv,
44 Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
45 allLifted, wrapFloats, floatBinds,
49 preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
53 #include "HsVersions.h"
55 import Id ( Id, idType, idOccInfo, idInlinePragma )
57 import CoreUtils ( needsCaseBinding, exprIsTrivial )
58 import PprCore () -- Instances
59 import CostCentre ( CostCentreStack, subsumedCCS )
64 import qualified Subst
65 import Subst ( Subst, mkSubst, substEnv,
66 InScopeSet, mkInScopeSet, substInScope,
69 import Type ( Type, isUnLiftedType )
70 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
74 import BasicTypes ( TopLevelFlag, isTopLevel, isLoopBreaker,
75 Activation, isActive, isAlwaysActive,
78 import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
79 DynFlags, DynFlag(..), dopt,
80 opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining,
82 import Unique ( Unique )
86 import Maybes ( expectJust )
88 import GLAEXTS ( indexArray# )
90 #if __GLASGOW_HASKELL__ < 503
91 import PrelArr ( Array(..) )
93 import GHC.Arr ( Array(..) )
96 import Array ( array, (//) )
98 infixr 0 `thenSmpl`, `thenSmpl_`
101 %************************************************************************
103 \subsection[Simplify-types]{Type declarations}
105 %************************************************************************
108 type InBinder = CoreBndr
109 type InId = Id -- Not yet cloned
110 type InType = Type -- Ditto
111 type InBind = CoreBind
112 type InExpr = CoreExpr
116 type OutBinder = CoreBndr
117 type OutId = Id -- Cloned
118 type OutTyVar = TyVar -- Cloned
119 type OutType = Type -- Cloned
120 type OutBind = CoreBind
121 type OutExpr = CoreExpr
122 type OutAlt = CoreAlt
123 type OutArg = CoreArg
126 %************************************************************************
130 %************************************************************************
133 type FloatsWithExpr = FloatsWith OutExpr
134 type FloatsWith a = (Floats, a)
135 -- We return something equivalent to (let b in e), but
136 -- in pieces to avoid the quadratic blowup when floating
137 -- incrementally. Comments just before simplExprB in Simplify.lhs
139 data Floats = Floats (OrdList OutBind)
140 InScopeSet -- Environment "inside" all the floats
141 Bool -- True <=> All bindings are lifted
143 allLifted :: Floats -> Bool
144 allLifted (Floats _ _ is_lifted) = is_lifted
146 wrapFloats :: Floats -> OutExpr -> OutExpr
147 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
149 isEmptyFloats :: Floats -> Bool
150 isEmptyFloats (Floats bs _ _) = isNilOL bs
152 floatBinds :: Floats -> [OutBind]
153 floatBinds (Floats bs _ _) = fromOL bs
155 flattenFloats :: Floats -> Floats
156 -- Flattens into a single Rec group
157 flattenFloats (Floats bs is is_lifted)
158 = ASSERT2( is_lifted, ppr (fromOL bs) )
159 Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
163 emptyFloats :: SimplEnv -> Floats
164 emptyFloats env = Floats nilOL (getInScope env) True
166 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
167 -- A single non-rec float; extend the in-scope set
168 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
169 (Subst.extendInScopeSet (getInScope env) var)
170 (not (isUnLiftedType (idType var)))
172 addFloats :: SimplEnv -> Floats
173 -> (SimplEnv -> SimplM (FloatsWith a))
174 -> SimplM (FloatsWith a)
175 addFloats env (Floats b1 is1 l1) thing_inside
179 = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
180 returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
182 addLetBind :: OutBind -> Floats -> Floats
183 addLetBind bind (Floats binds in_scope lifted)
184 = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
186 is_lifted_bind (Rec _) = True
187 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
189 -- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
190 -- * extends the in-scope env
191 -- * assumes it's a let-bindable thing
192 addAuxiliaryBind :: SimplEnv -> OutBind
193 -> (SimplEnv -> SimplM (FloatsWith a))
194 -> SimplM (FloatsWith a)
195 -- Extends the in-scope environment as well as wrapping the bindings
196 addAuxiliaryBind env bind thing_inside
197 = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
198 thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
199 returnSmpl (addLetBind bind floats, x)
203 %************************************************************************
205 \subsection{Monad plumbing}
207 %************************************************************************
209 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
210 (Command-line switches move around through the explicitly-passed SimplEnv.)
214 = DynFlags -- We thread the unique supply because
215 -> UniqSupply -- constantly splitting it is rather expensive
217 -> (result, UniqSupply, SimplCount)
222 -> UniqSupply -- No init count; set to 0
227 = case m dflags us (zeroSimplCount dflags) of
228 (result, _, count) -> (result, count)
231 {-# INLINE thenSmpl #-}
232 {-# INLINE thenSmpl_ #-}
233 {-# INLINE returnSmpl #-}
235 returnSmpl :: a -> SimplM a
236 returnSmpl e dflags us sc = (e, us, sc)
238 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
239 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
241 thenSmpl m k dflags us0 sc0
242 = case (m dflags us0 sc0) of
243 (m_result, us1, sc1) -> k m_result dflags us1 sc1
245 thenSmpl_ m k dflags us0 sc0
246 = case (m dflags us0 sc0) of
247 (_, us1, sc1) -> k dflags us1 sc1
252 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
253 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
255 mapSmpl f [] = returnSmpl []
257 = f x `thenSmpl` \ x' ->
258 mapSmpl f xs `thenSmpl` \ xs' ->
261 mapAndUnzipSmpl f [] = returnSmpl ([],[])
262 mapAndUnzipSmpl f (x:xs)
263 = f x `thenSmpl` \ (r1, r2) ->
264 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
265 returnSmpl (r1:rs1, r2:rs2)
267 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
268 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
269 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
270 returnSmpl (acc'', x':xs')
274 %************************************************************************
276 \subsection{The unique supply}
278 %************************************************************************
281 getUniqSupplySmpl :: SimplM UniqSupply
282 getUniqSupplySmpl dflags us sc
283 = case splitUniqSupply us of
284 (us1, us2) -> (us1, us2, sc)
286 getUniqueSmpl :: SimplM Unique
287 getUniqueSmpl dflags us sc
288 = case splitUniqSupply us of
289 (us1, us2) -> (uniqFromSupply us1, us2, sc)
291 getUniquesSmpl :: SimplM [Unique]
292 getUniquesSmpl dflags us sc
293 = case splitUniqSupply us of
294 (us1, us2) -> (uniqsFromSupply us1, us2, sc)
296 getDOptsSmpl :: SimplM DynFlags
297 getDOptsSmpl dflags us sc
302 %************************************************************************
304 \subsection{Counting up what we've done}
306 %************************************************************************
309 getSimplCount :: SimplM SimplCount
310 getSimplCount dflags us sc = (sc, us, sc)
312 tick :: Tick -> SimplM ()
314 = sc' `seq` ((), us, sc')
318 freeTick :: Tick -> SimplM ()
319 -- Record a tick, but don't add to the total tick count, which is
320 -- used to decide when nothing further has happened
321 freeTick t dflags us sc
322 = sc' `seq` ((), us, sc')
324 sc' = doFreeTick t sc
328 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
330 zeroSimplCount :: DynFlags -> SimplCount
331 isZeroSimplCount :: SimplCount -> Bool
332 pprSimplCount :: SimplCount -> SDoc
333 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
334 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
338 data SimplCount = VerySimplZero -- These two are used when
339 | VerySimplNonZero -- we are only interested in
343 ticks :: !Int, -- Total ticks
344 details :: !TickCounts, -- How many of each type
346 log1 :: [Tick], -- Last N events; <= opt_HistorySize
347 log2 :: [Tick] -- Last opt_HistorySize events before that
350 type TickCounts = FiniteMap Tick Int
352 zeroSimplCount dflags
353 -- This is where we decide whether to do
354 -- the VerySimpl version or the full-stats version
355 | dopt Opt_D_dump_simpl_stats dflags
356 = SimplCount {ticks = 0, details = emptyFM,
357 n_log = 0, log1 = [], log2 = []}
361 isZeroSimplCount VerySimplZero = True
362 isZeroSimplCount (SimplCount { ticks = 0 }) = True
363 isZeroSimplCount other = False
365 doFreeTick tick sc@SimplCount { details = dts }
366 = dts' `seqFM` sc { details = dts' }
368 dts' = dts `addTick` tick
369 doFreeTick tick sc = sc
371 -- Gross hack to persuade GHC 3.03 to do this important seq
372 seqFM fm x | isEmptyFM fm = x
375 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
376 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
377 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
379 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
381 doTick tick sc = VerySimplNonZero -- The very simple case
384 -- Don't use plusFM_C because that's lazy, and we want to
385 -- be pretty strict here!
386 addTick :: TickCounts -> Tick -> TickCounts
387 addTick fm tick = case lookupFM fm tick of
388 Nothing -> addToFM fm tick 1
389 Just n -> n1 `seq` addToFM fm tick n1
394 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
395 sc2@(SimplCount { ticks = tks2, details = dts2 })
396 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
398 -- A hackish way of getting recent log info
399 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
400 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
403 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
404 plusSimplCount sc1 sc2 = VerySimplNonZero
406 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
407 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
408 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
409 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
411 pprTickCounts (fmToList dts),
412 if verboseSimplStats then
414 ptext SLIT("Log (most recent first)"),
415 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
419 pprTickCounts :: [(Tick,Int)] -> SDoc
420 pprTickCounts [] = empty
421 pprTickCounts ((tick1,n1):ticks)
422 = vcat [int tot_n <+> text (tickString tick1),
423 pprTCDetails real_these,
427 tick1_tag = tickToTag tick1
428 (these, others) = span same_tick ticks
429 real_these = (tick1,n1):these
430 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
431 tot_n = sum [n | (_,n) <- real_these]
433 pprTCDetails ticks@((tick,_):_)
434 | verboseSimplStats || isRuleFired tick
435 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
440 %************************************************************************
444 %************************************************************************
448 = PreInlineUnconditionally Id
449 | PostInlineUnconditionally Id
452 | RuleFired FastString -- Rule name
455 | EtaExpansion Id -- LHS binder
456 | EtaReduction Id -- Binder on outer lambda
457 | BetaReduction Id -- Lambda binder
460 | CaseOfCase Id -- Bndr on *inner* case
461 | KnownBranch Id -- Case binder
462 | CaseMerge Id -- Binder on outer case
463 | AltMerge Id -- Case binder
464 | CaseElim Id -- Case binder
465 | CaseIdentity Id -- Case binder
466 | FillInCaseDefault Id -- Case binder
469 | SimplifierDone -- Ticked at each iteration of the simplifier
471 isRuleFired (RuleFired _) = True
472 isRuleFired other = False
474 instance Outputable Tick where
475 ppr tick = text (tickString tick) <+> pprTickCts tick
477 instance Eq Tick where
478 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
480 instance Ord Tick where
483 tickToTag :: Tick -> Int
484 tickToTag (PreInlineUnconditionally _) = 0
485 tickToTag (PostInlineUnconditionally _) = 1
486 tickToTag (UnfoldingDone _) = 2
487 tickToTag (RuleFired _) = 3
488 tickToTag LetFloatFromLet = 4
489 tickToTag (EtaExpansion _) = 5
490 tickToTag (EtaReduction _) = 6
491 tickToTag (BetaReduction _) = 7
492 tickToTag (CaseOfCase _) = 8
493 tickToTag (KnownBranch _) = 9
494 tickToTag (CaseMerge _) = 10
495 tickToTag (CaseElim _) = 11
496 tickToTag (CaseIdentity _) = 12
497 tickToTag (FillInCaseDefault _) = 13
498 tickToTag BottomFound = 14
499 tickToTag SimplifierDone = 16
500 tickToTag (AltMerge _) = 17
502 tickString :: Tick -> String
503 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
504 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
505 tickString (UnfoldingDone _) = "UnfoldingDone"
506 tickString (RuleFired _) = "RuleFired"
507 tickString LetFloatFromLet = "LetFloatFromLet"
508 tickString (EtaExpansion _) = "EtaExpansion"
509 tickString (EtaReduction _) = "EtaReduction"
510 tickString (BetaReduction _) = "BetaReduction"
511 tickString (CaseOfCase _) = "CaseOfCase"
512 tickString (KnownBranch _) = "KnownBranch"
513 tickString (CaseMerge _) = "CaseMerge"
514 tickString (AltMerge _) = "AltMerge"
515 tickString (CaseElim _) = "CaseElim"
516 tickString (CaseIdentity _) = "CaseIdentity"
517 tickString (FillInCaseDefault _) = "FillInCaseDefault"
518 tickString BottomFound = "BottomFound"
519 tickString SimplifierDone = "SimplifierDone"
521 pprTickCts :: Tick -> SDoc
522 pprTickCts (PreInlineUnconditionally v) = ppr v
523 pprTickCts (PostInlineUnconditionally v)= ppr v
524 pprTickCts (UnfoldingDone v) = ppr v
525 pprTickCts (RuleFired v) = ppr v
526 pprTickCts LetFloatFromLet = empty
527 pprTickCts (EtaExpansion v) = ppr v
528 pprTickCts (EtaReduction v) = ppr v
529 pprTickCts (BetaReduction v) = ppr v
530 pprTickCts (CaseOfCase v) = ppr v
531 pprTickCts (KnownBranch v) = ppr v
532 pprTickCts (CaseMerge v) = ppr v
533 pprTickCts (AltMerge v) = ppr v
534 pprTickCts (CaseElim v) = ppr v
535 pprTickCts (CaseIdentity v) = ppr v
536 pprTickCts (FillInCaseDefault v) = ppr v
537 pprTickCts other = empty
539 cmpTick :: Tick -> Tick -> Ordering
540 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
542 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
545 -- Always distinguish RuleFired, so that the stats
546 -- can report them even in non-verbose mode
548 cmpEqTick :: Tick -> Tick -> Ordering
549 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
550 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
551 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
552 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
553 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
554 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
555 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
556 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
557 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
558 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
559 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
560 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
561 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
562 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
563 cmpEqTick other1 other2 = EQ
568 %************************************************************************
570 \subsubsection{The @SimplEnv@ type}
572 %************************************************************************
578 seMode :: SimplifierMode,
579 seChkr :: SwitchChecker,
580 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
581 seSubst :: Subst -- The current substitution
583 -- The range of the substitution is OutType and OutExpr resp
585 -- The substitution is idempotent
586 -- It *must* be applied; things in its domain simply aren't
587 -- bound in the result.
589 -- The substitution usually maps an Id to its clone,
590 -- but if the orig defn is a let-binding, and
591 -- the RHS of the let simplifies to an atom,
592 -- we just add the binding to the substitution and elide the let.
594 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
595 -- The elements of the set may have better IdInfo than the
596 -- occurrences of in-scope Ids, and (more important) they will
597 -- have a correctly-substituted type. So we use a lookup in this
598 -- set to replace occurrences
600 emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> VarSet -> SimplEnv
601 emptySimplEnv mode switches in_scope
602 = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, seMode = mode,
603 seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
604 -- The top level "enclosing CC" is "SUBSUMED".
606 ---------------------
607 getSwitchChecker :: SimplEnv -> SwitchChecker
608 getSwitchChecker env = seChkr env
610 ---------------------
611 getMode :: SimplEnv -> SimplifierMode
612 getMode env = seMode env
614 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
615 setMode mode env = env { seMode = mode }
617 ---------------------
618 getEnclosingCC :: SimplEnv -> CostCentreStack
619 getEnclosingCC env = seCC env
621 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
622 setEnclosingCC env cc = env {seCC = cc}
624 ---------------------
625 getSubst :: SimplEnv -> Subst
626 getSubst env = seSubst env
628 setSubst :: SimplEnv -> Subst -> SimplEnv
629 setSubst env subst = env {seSubst = subst}
631 extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv
632 extendSubst env@(SimplEnv {seSubst = subst}) var res
633 = env {seSubst = Subst.extendSubst subst var res}
635 extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv
636 extendSubstList env@(SimplEnv {seSubst = subst}) vars ress
637 = env {seSubst = Subst.extendSubstList subst vars ress}
639 ---------------------
640 getInScope :: SimplEnv -> InScopeSet
641 getInScope env = substInScope (seSubst env)
643 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
644 setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
646 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
647 setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
648 = env {seSubst = Subst.setInScope subst in_scope}
650 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
651 -- The new Ids are guaranteed to be freshly allocated
652 addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
653 = env {seSubst = Subst.extendNewInScopeList subst vs}
655 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
656 modifyInScope env@(SimplEnv {seSubst = subst}) v v'
657 = env {seSubst = Subst.modifyInScope subst v v'}
659 ---------------------
660 getSubstEnv :: SimplEnv -> SubstEnv
661 getSubstEnv env = substEnv (seSubst env)
663 setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv
664 setSubstEnv env@(SimplEnv {seSubst = subst}) senv
665 = env {seSubst = Subst.setSubstEnv subst senv}
667 zapSubstEnv :: SimplEnv -> SimplEnv
668 zapSubstEnv env@(SimplEnv {seSubst = subst})
669 = env {seSubst = Subst.zapSubstEnv subst}
673 %************************************************************************
675 \subsection{Decisions about inlining}
677 %************************************************************************
679 Inlining is controlled partly by the SimplifierMode switch. This has two
682 SimplGently (a) Simplifying before specialiser/full laziness
683 (b) Simplifiying inside INLINE pragma
684 (c) Simplifying the LHS of a rule
685 (d) Simplifying a GHCi expression or Template
688 SimplPhase n Used at all other times
690 The key thing about SimplGently is that it does no call-site inlining.
691 Before full laziness we must be careful not to inline wrappers,
692 because doing so inhibits floating
693 e.g. ...(case f x of ...)...
694 ==> ...(case (case x of I# x# -> fw x#) of ...)...
695 ==> ...(case x of I# x# -> case fw x# of ...)...
696 and now the redex (f x) isn't floatable any more.
698 The no-inling thing is also important for Template Haskell. You might be
699 compiling in one-shot mode with -O2; but when TH compiles a splice before
700 running it, we don't want to use -O2. Indeed, we don't want to inline
701 anything, because the byte-code interpreter might get confused about
702 unboxed tuples and suchlike.
706 SimplGently is also used as the mode to simplify inside an InlineMe note.
709 inlineMode :: SimplifierMode
710 inlineMode = SimplGently
713 It really is important to switch off inlinings inside such
714 expressions. Consider the following example
720 in ...g...g...g...g...g...
722 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
723 and thence copied multiple times when g is inlined.
726 This function may be inlinined in other modules, so we
727 don't want to remove (by inlining) calls to functions that have
728 specialisations, or that may have transformation rules in an importing
731 E.g. {-# INLINE f #-}
734 and suppose that g is strict *and* has specialisations. If we inline
735 g's wrapper, we deny f the chance of getting the specialised version
736 of g when f is inlined at some call site (perhaps in some other
739 It's also important not to inline a worker back into a wrapper.
741 wraper = inline_me (\x -> ...worker... )
742 Normally, the inline_me prevents the worker getting inlined into
743 the wrapper (initially, the worker's only call site!). But,
744 if the wrapper is sure to be called, the strictness analyser will
745 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
746 continuation. That's why the keep_inline predicate returns True for
747 ArgOf continuations. It shouldn't do any harm not to dissolve the
748 inline-me note under these circumstances.
750 Note that the result is that we do very little simplification
753 all xs = foldr (&&) True xs
754 any p = all . map p {-# INLINE any #-}
756 Problem: any won't get deforested, and so if it's exported and the
757 importer doesn't use the inlining, (eg passes it as an arg) then we
758 won't get deforestation at all. We havn't solved this problem yet!
761 preInlineUnconditionally
762 ~~~~~~~~~~~~~~~~~~~~~~~~
763 @preInlineUnconditionally@ examines a bndr to see if it is used just
764 once in a completely safe way, so that it is safe to discard the
765 binding inline its RHS at the (unique) usage site, REGARDLESS of how
766 big the RHS might be. If this is the case we don't simplify the RHS
767 first, but just inline it un-simplified.
769 This is much better than first simplifying a perhaps-huge RHS and then
770 inlining and re-simplifying it. Indeed, it can be at least quadratically
779 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
781 NB: we don't even look at the RHS to see if it's trivial
784 where x is used many times, but this is the unique occurrence of y.
785 We should NOT inline x at all its uses, because then we'd do the same
786 for y -- aargh! So we must base this pre-rhs-simplification decision
787 solely on x's occurrences, not on its rhs.
789 Evne RHSs labelled InlineMe aren't caught here, because there might be
790 no benefit from inlining at the call site.
792 [Sept 01] Don't unconditionally inline a top-level thing, because that
793 can simply make a static thing into something built dynamically. E.g.
797 [Remember that we treat \s as a one-shot lambda.] No point in
798 inlining x unless there is something interesting about the call site.
800 But watch out: if you aren't careful, some useful foldr/build fusion
801 can be lost (most notably in spectral/hartel/parstof) because the
802 foldr didn't see the build. Doing the dynamic allocation isn't a big
803 deal, in fact, but losing the fusion can be. But the right thing here
804 seems to be to do a callSiteInline based on the fact that there is
805 something interesting about the call site (it's strict). Hmm. That
808 Conclusion: inline top level things gaily until Phase 0 (the last
809 phase), at which point don't.
812 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
813 preInlineUnconditionally env top_lvl bndr
814 | isTopLevel top_lvl, SimplPhase 0 <- phase = False
815 -- If we don't have this test, consider
816 -- x = length [1,2,3]
817 -- The full laziness pass carefully floats all the cons cells to
818 -- top level, and preInlineUnconditionally floats them all back in.
819 -- Result is (a) static allocation replaced by dynamic allocation
820 -- (b) many simplifier iterations because this tickles
821 -- a related problem; only one inlining per pass
823 -- On the other hand, I have seen cases where top-level fusion is
824 -- lost if we don't inline top level thing (e.g. string constants)
825 -- Hence the test for phase zero (which is the phase for all the final
826 -- simplifications). Until phase zero we take no special notice of
827 -- top level things, but then we become more leery about inlining
831 | opt_SimplNoPreInlining = False
832 | otherwise = case idOccInfo bndr of
833 IAmDead -> True -- Happens in ((\x.1) v)
834 OneOcc in_lam once -> not in_lam && once
835 -- Not inside a lambda, one occurrence ==> safe!
839 active = case phase of
840 SimplGently -> isAlwaysActive prag
841 SimplPhase n -> isActive n prag
842 prag = idInlinePragma bndr
845 postInlineUnconditionally
846 ~~~~~~~~~~~~~~~~~~~~~~~~~
847 @postInlineUnconditionally@ decides whether to unconditionally inline
848 a thing based on the form of its RHS; in particular if it has a
849 trivial RHS. If so, we can inline and discard the binding altogether.
851 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
852 only have *forward* references Hence, it's safe to discard the binding
854 NOTE: This isn't our last opportunity to inline. We're at the binding
855 site right now, and we'll get another opportunity when we get to the
858 Note that we do this unconditional inlining only for trival RHSs.
859 Don't inline even WHNFs inside lambdas; doing so may simply increase
860 allocation when the function is called. This isn't the last chance; see
863 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
864 Because we don't even want to inline them into the RHS of constructor
865 arguments. See NOTE above
867 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
868 it's best to inline it anyway. We often get a=E; b=a from desugaring,
869 with both a and b marked NOINLINE. But that seems incompatible with
870 our new view that inlining is like a RULE, so I'm sticking to the 'active'
874 postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
875 postInlineUnconditionally env bndr occ_info rhs
878 && not (isLoopBreaker occ_info)
879 && not (isExportedId bndr)
880 -- We used to have (isOneOcc occ_info) instead of
881 -- not (isLoopBreaker occ_info) && not (isExportedId bndr)
882 -- That was because a rather fragile use of rules got confused
883 -- if you inlined even a binding f=g e.g. We used to have
885 -- But now a more precise use of phases has eliminated this problem,
886 -- so the is_active test will do the job. I think.
888 -- OLD COMMENT: (delete soon)
889 -- Indeed, you might suppose that
890 -- there is nothing wrong with substituting for a trivial RHS, even
891 -- if it occurs many times. But consider
893 -- h = _inline_me_ (...x...)
894 -- Here we do *not* want to have x inlined, even though the RHS is
895 -- trivial, becuase the contract for an INLINE pragma is "no inlining".
896 -- This is important in the rules for the Prelude
898 active = case getMode env of
899 SimplGently -> isAlwaysActive prag
900 SimplPhase n -> isActive n prag
901 prag = idInlinePragma bndr
903 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
904 activeInline env id occ
905 = case getMode env of
906 SimplGently -> isOneOcc occ && isAlwaysActive prag
907 -- No inlining at all when doing gentle stuff,
908 -- except for local things that occur once
909 -- The reason is that too little clean-up happens if you
910 -- don't inline use-once things. Also a bit of inlining is *good* for
911 -- full laziness; it can expose constant sub-expressions.
912 -- Example in spectral/mandel/Mandel.hs, where the mandelset
913 -- function gets a useful let-float if you inline windowToViewport
915 -- NB: we used to have a second exception, for data con wrappers.
916 -- On the grounds that we use gentle mode for rule LHSs, and
917 -- they match better when data con wrappers are inlined.
918 -- But that only really applies to the trivial wrappers (like (:)),
919 -- and they are now constructed as Compulsory unfoldings (in MkId)
920 -- so they'll happen anyway.
922 SimplPhase n -> isActive n prag
924 prag = idInlinePragma id
926 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
927 -- Nothing => No rules at all
929 = case getMode env of
930 SimplGently -> Just isAlwaysActive
931 -- Used to be Nothing (no rules in gentle mode)
932 -- Main motivation for changing is that I wanted
933 -- lift String ===> ...
934 -- to work in Template Haskell when simplifying
935 -- splices, so we get simpler code for literal strings
936 SimplPhase n -> Just (isActive n)
940 %************************************************************************
942 \subsubsection{Command-line switches}
944 %************************************************************************
947 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
948 getSimplIntSwitch chkr switch
949 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
951 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
953 switchIsOn lookup_fn switch
954 = case (lookup_fn switch) of
955 SwBool False -> False
958 intSwitchSet :: (switch -> SwitchResult)
962 intSwitchSet lookup_fn switch
963 = case (lookup_fn (switch (panic "intSwitchSet"))) of
964 SwInt int -> Just int
970 type SwitchChecker = SimplifierSwitch -> SwitchResult
973 = SwBool Bool -- on/off
974 | SwString FastString -- nothing or a String
975 | SwInt Int -- nothing or an Int
977 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
978 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
979 -- in the list; defaults right at the end.
981 tidied_on_switches = foldl rm_dups [] on_switches
982 -- The fold*l* ensures that we keep the latest switches;
983 -- ie the ones that occur earliest in the list.
985 sw_tbl :: Array Int SwitchResult
986 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
990 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
992 defined_elems = map mk_assoc_elem tidied_on_switches
994 -- (avoid some unboxing, bounds checking, and other horrible things:)
995 case sw_tbl of { Array _ _ stuff ->
997 case (indexArray# stuff (tagOf_SimplSwitch switch)) of
1001 mk_assoc_elem k@(MaxSimplifierIterations lvl)
1002 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
1004 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
1006 -- cannot have duplicates if we are going to use the array thing
1007 rm_dups switches_so_far switch
1008 = if switch `is_elem` switches_so_far
1009 then switches_so_far
1010 else switch : switches_so_far
1012 sw `is_elem` [] = False
1013 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
1017 These things behave just like enumeration types.
1020 instance Eq SimplifierSwitch where
1021 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
1023 instance Ord SimplifierSwitch where
1024 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
1025 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
1028 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
1029 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
1031 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
1033 lAST_SIMPL_SWITCH_TAG = 2