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
686 SimplPhase n Used at all other times
688 The key thing about SimplGently is that it does no call-site inlining.
689 Before full laziness we must be careful not to inline wrappers,
690 because doing so inhibits floating
691 e.g. ...(case f x of ...)...
692 ==> ...(case (case x of I# x# -> fw x#) of ...)...
693 ==> ...(case x of I# x# -> case fw x# of ...)...
694 and now the redex (f x) isn't floatable any more.
698 SimplGently is also used as the mode to simplify inside an InlineMe note.
701 inlineMode :: SimplifierMode
702 inlineMode = SimplGently
705 It really is important to switch off inlinings inside such
706 expressions. Consider the following example
712 in ...g...g...g...g...g...
714 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
715 and thence copied multiple times when g is inlined.
718 This function may be inlinined in other modules, so we
719 don't want to remove (by inlining) calls to functions that have
720 specialisations, or that may have transformation rules in an importing
723 E.g. {-# INLINE f #-}
726 and suppose that g is strict *and* has specialisations. If we inline
727 g's wrapper, we deny f the chance of getting the specialised version
728 of g when f is inlined at some call site (perhaps in some other
731 It's also important not to inline a worker back into a wrapper.
733 wraper = inline_me (\x -> ...worker... )
734 Normally, the inline_me prevents the worker getting inlined into
735 the wrapper (initially, the worker's only call site!). But,
736 if the wrapper is sure to be called, the strictness analyser will
737 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
738 continuation. That's why the keep_inline predicate returns True for
739 ArgOf continuations. It shouldn't do any harm not to dissolve the
740 inline-me note under these circumstances.
742 Note that the result is that we do very little simplification
745 all xs = foldr (&&) True xs
746 any p = all . map p {-# INLINE any #-}
748 Problem: any won't get deforested, and so if it's exported and the
749 importer doesn't use the inlining, (eg passes it as an arg) then we
750 won't get deforestation at all. We havn't solved this problem yet!
753 preInlineUnconditionally
754 ~~~~~~~~~~~~~~~~~~~~~~~~
755 @preInlineUnconditionally@ examines a bndr to see if it is used just
756 once in a completely safe way, so that it is safe to discard the
757 binding inline its RHS at the (unique) usage site, REGARDLESS of how
758 big the RHS might be. If this is the case we don't simplify the RHS
759 first, but just inline it un-simplified.
761 This is much better than first simplifying a perhaps-huge RHS and then
762 inlining and re-simplifying it. Indeed, it can be at least quadratically
771 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
773 NB: we don't even look at the RHS to see if it's trivial
776 where x is used many times, but this is the unique occurrence of y.
777 We should NOT inline x at all its uses, because then we'd do the same
778 for y -- aargh! So we must base this pre-rhs-simplification decision
779 solely on x's occurrences, not on its rhs.
781 Evne RHSs labelled InlineMe aren't caught here, because there might be
782 no benefit from inlining at the call site.
784 [Sept 01] Don't unconditionally inline a top-level thing, because that
785 can simply make a static thing into something built dynamically. E.g.
789 [Remember that we treat \s as a one-shot lambda.] No point in
790 inlining x unless there is something interesting about the call site.
792 But watch out: if you aren't careful, some useful foldr/build fusion
793 can be lost (most notably in spectral/hartel/parstof) because the
794 foldr didn't see the build. Doing the dynamic allocation isn't a big
795 deal, in fact, but losing the fusion can be. But the right thing here
796 seems to be to do a callSiteInline based on the fact that there is
797 something interesting about the call site (it's strict). Hmm. That
800 Conclusion: inline top level things gaily until Phase 0 (the last
801 phase), at which point don't.
804 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
805 preInlineUnconditionally env top_lvl bndr
806 | isTopLevel top_lvl, SimplPhase 0 <- phase = False
807 -- If we don't have this test, consider
808 -- x = length [1,2,3]
809 -- The full laziness pass carefully floats all the cons cells to
810 -- top level, and preInlineUnconditionally floats them all back in.
811 -- Result is (a) static allocation replaced by dynamic allocation
812 -- (b) many simplifier iterations because this tickles
813 -- a related problem; only one inlining per pass
815 -- On the other hand, I have seen cases where top-level fusion is
816 -- lost if we don't inline top level thing (e.g. string constants)
817 -- Hence the test for phase zero (which is the phase for all the final
818 -- simplifications). Until phase zero we take no special notice of
819 -- top level things, but then we become more leery about inlining
823 | opt_SimplNoPreInlining = False
824 | otherwise = case idOccInfo bndr of
825 IAmDead -> True -- Happens in ((\x.1) v)
826 OneOcc in_lam once -> not in_lam && once
827 -- Not inside a lambda, one occurrence ==> safe!
831 active = case phase of
832 SimplGently -> isAlwaysActive prag
833 SimplPhase n -> isActive n prag
834 prag = idInlinePragma bndr
837 postInlineUnconditionally
838 ~~~~~~~~~~~~~~~~~~~~~~~~~
839 @postInlineUnconditionally@ decides whether to unconditionally inline
840 a thing based on the form of its RHS; in particular if it has a
841 trivial RHS. If so, we can inline and discard the binding altogether.
843 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
844 only have *forward* references Hence, it's safe to discard the binding
846 NOTE: This isn't our last opportunity to inline. We're at the binding
847 site right now, and we'll get another opportunity when we get to the
850 Note that we do this unconditional inlining only for trival RHSs.
851 Don't inline even WHNFs inside lambdas; doing so may simply increase
852 allocation when the function is called. This isn't the last chance; see
855 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
856 Because we don't even want to inline them into the RHS of constructor
857 arguments. See NOTE above
859 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
860 it's best to inline it anyway. We often get a=E; b=a from desugaring,
861 with both a and b marked NOINLINE. But that seems incompatible with
862 our new view that inlining is like a RULE, so I'm sticking to the 'active'
866 postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
867 postInlineUnconditionally env bndr occ_info rhs
870 && not (isLoopBreaker occ_info)
871 && not (isExportedId bndr)
872 -- We used to have (isOneOcc occ_info) instead of
873 -- not (isLoopBreaker occ_info) && not (isExportedId bndr)
874 -- That was because a rather fragile use of rules got confused
875 -- if you inlined even a binding f=g e.g. We used to have
877 -- But now a more precise use of phases has eliminated this problem,
878 -- so the is_active test will do the job. I think.
880 -- OLD COMMENT: (delete soon)
881 -- Indeed, you might suppose that
882 -- there is nothing wrong with substituting for a trivial RHS, even
883 -- if it occurs many times. But consider
885 -- h = _inline_me_ (...x...)
886 -- Here we do *not* want to have x inlined, even though the RHS is
887 -- trivial, becuase the contract for an INLINE pragma is "no inlining".
888 -- This is important in the rules for the Prelude
890 active = case getMode env of
891 SimplGently -> isAlwaysActive prag
892 SimplPhase n -> isActive n prag
893 prag = idInlinePragma bndr
896 blackListInline tells if we must not inline at a call site because the
897 Id's inline pragma says not to do so.
899 However, blackListInline is ignored for things with with Compulsory inlinings,
900 because they don't have bindings, so we must inline them no matter how
904 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
905 activeInline env id occ
906 = case getMode env of
907 SimplGently -> isAlwaysActive prag && isOneOcc occ
908 -- No inlining at all when doing gentle stuff,
909 -- except for things that occur once
910 -- The reason is that too little clean-up happens if you
911 -- don't inline use-once things. Also a bit of inlining is *good* for
912 -- full laziness; it can expose constant sub-expressions.
913 -- Example in spectral/mandel/Mandel.hs, where the mandelset
914 -- function gets a useful let-float if you inline windowToViewport
916 -- NB: we used to have a second exception, for data con wrappers.
917 -- On the grounds that we use gentle mode for rule LHSs, and
918 -- they match better when data con wrappers are inlined.
919 -- But that only really applies to the trivial wrappers (like (:)),
920 -- and they are now constructed as Compulsory unfoldings (in MkId)
921 -- so they'll happen anyway.
923 SimplPhase n -> isActive n prag
925 prag = idInlinePragma id
927 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
928 -- Nothing => No rules at all
930 = case getMode env of
931 SimplGently -> Nothing -- No rules in gentle mode
932 SimplPhase n -> Just (isActive n)
936 %************************************************************************
938 \subsubsection{Command-line switches}
940 %************************************************************************
943 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
944 getSimplIntSwitch chkr switch
945 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
947 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
949 switchIsOn lookup_fn switch
950 = case (lookup_fn switch) of
951 SwBool False -> False
954 intSwitchSet :: (switch -> SwitchResult)
958 intSwitchSet lookup_fn switch
959 = case (lookup_fn (switch (panic "intSwitchSet"))) of
960 SwInt int -> Just int
966 type SwitchChecker = SimplifierSwitch -> SwitchResult
969 = SwBool Bool -- on/off
970 | SwString FastString -- nothing or a String
971 | SwInt Int -- nothing or an Int
973 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
974 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
975 -- in the list; defaults right at the end.
977 tidied_on_switches = foldl rm_dups [] on_switches
978 -- The fold*l* ensures that we keep the latest switches;
979 -- ie the ones that occur earliest in the list.
981 sw_tbl :: Array Int SwitchResult
982 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
986 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
988 defined_elems = map mk_assoc_elem tidied_on_switches
990 -- (avoid some unboxing, bounds checking, and other horrible things:)
991 case sw_tbl of { Array _ _ stuff ->
993 case (indexArray# stuff (tagOf_SimplSwitch switch)) of
997 mk_assoc_elem k@(MaxSimplifierIterations lvl)
998 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
1000 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
1002 -- cannot have duplicates if we are going to use the array thing
1003 rm_dups switches_so_far switch
1004 = if switch `is_elem` switches_so_far
1005 then switches_so_far
1006 else switch : switches_so_far
1008 sw `is_elem` [] = False
1009 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
1013 These things behave just like enumeration types.
1016 instance Eq SimplifierSwitch where
1017 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
1019 instance Ord SimplifierSwitch where
1020 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
1021 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
1024 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
1025 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
1027 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
1029 lAST_SIMPL_SWITCH_TAG = 2