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 )
83 import Maybes ( expectJust )
85 import Array ( array, (//) )
87 import GlaExts ( indexArray# )
89 #if __GLASGOW_HASKELL__ < 503
90 import PrelArr ( Array(..) )
92 import GHC.Arr ( Array(..) )
95 infixr 0 `thenSmpl`, `thenSmpl_`
98 %************************************************************************
100 \subsection[Simplify-types]{Type declarations}
102 %************************************************************************
105 type InBinder = CoreBndr
106 type InId = Id -- Not yet cloned
107 type InType = Type -- Ditto
108 type InBind = CoreBind
109 type InExpr = CoreExpr
113 type OutBinder = CoreBndr
114 type OutId = Id -- Cloned
115 type OutTyVar = TyVar -- Cloned
116 type OutType = Type -- Cloned
117 type OutBind = CoreBind
118 type OutExpr = CoreExpr
119 type OutAlt = CoreAlt
120 type OutArg = CoreArg
123 %************************************************************************
127 %************************************************************************
130 type FloatsWithExpr = FloatsWith OutExpr
131 type FloatsWith a = (Floats, a)
132 -- We return something equivalent to (let b in e), but
133 -- in pieces to avoid the quadratic blowup when floating
134 -- incrementally. Comments just before simplExprB in Simplify.lhs
136 data Floats = Floats (OrdList OutBind)
137 InScopeSet -- Environment "inside" all the floats
138 Bool -- True <=> All bindings are lifted
140 allLifted :: Floats -> Bool
141 allLifted (Floats _ _ is_lifted) = is_lifted
143 wrapFloats :: Floats -> OutExpr -> OutExpr
144 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
146 isEmptyFloats :: Floats -> Bool
147 isEmptyFloats (Floats bs _ _) = isNilOL bs
149 floatBinds :: Floats -> [OutBind]
150 floatBinds (Floats bs _ _) = fromOL bs
152 flattenFloats :: Floats -> Floats
153 -- Flattens into a single Rec group
154 flattenFloats (Floats bs is is_lifted)
155 = ASSERT2( is_lifted, ppr (fromOL bs) )
156 Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
160 emptyFloats :: SimplEnv -> Floats
161 emptyFloats env = Floats nilOL (getInScope env) True
163 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
164 -- A single non-rec float; extend the in-scope set
165 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
166 (Subst.extendInScopeSet (getInScope env) var)
167 (not (isUnLiftedType (idType var)))
169 addFloats :: SimplEnv -> Floats
170 -> (SimplEnv -> SimplM (FloatsWith a))
171 -> SimplM (FloatsWith a)
172 addFloats env (Floats b1 is1 l1) thing_inside
176 = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
177 returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
179 addLetBind :: OutBind -> Floats -> Floats
180 addLetBind bind (Floats binds in_scope lifted)
181 = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
183 is_lifted_bind (Rec _) = True
184 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
186 -- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
187 -- * extends the in-scope env
188 -- * assumes it's a let-bindable thing
189 addAuxiliaryBind :: SimplEnv -> OutBind
190 -> (SimplEnv -> SimplM (FloatsWith a))
191 -> SimplM (FloatsWith a)
192 -- Extends the in-scope environment as well as wrapping the bindings
193 addAuxiliaryBind env bind thing_inside
194 = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
195 thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
196 returnSmpl (addLetBind bind floats, x)
200 %************************************************************************
202 \subsection{Monad plumbing}
204 %************************************************************************
206 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
207 (Command-line switches move around through the explicitly-passed SimplEnv.)
211 = DynFlags -- We thread the unique supply because
212 -> UniqSupply -- constantly splitting it is rather expensive
214 -> (result, UniqSupply, SimplCount)
219 -> UniqSupply -- No init count; set to 0
224 = case m dflags us (zeroSimplCount dflags) of
225 (result, _, count) -> (result, count)
228 {-# INLINE thenSmpl #-}
229 {-# INLINE thenSmpl_ #-}
230 {-# INLINE returnSmpl #-}
232 returnSmpl :: a -> SimplM a
233 returnSmpl e dflags us sc = (e, us, sc)
235 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
236 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
238 thenSmpl m k dflags us0 sc0
239 = case (m dflags us0 sc0) of
240 (m_result, us1, sc1) -> k m_result dflags us1 sc1
242 thenSmpl_ m k dflags us0 sc0
243 = case (m dflags us0 sc0) of
244 (_, us1, sc1) -> k dflags us1 sc1
249 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
250 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
252 mapSmpl f [] = returnSmpl []
254 = f x `thenSmpl` \ x' ->
255 mapSmpl f xs `thenSmpl` \ xs' ->
258 mapAndUnzipSmpl f [] = returnSmpl ([],[])
259 mapAndUnzipSmpl f (x:xs)
260 = f x `thenSmpl` \ (r1, r2) ->
261 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
262 returnSmpl (r1:rs1, r2:rs2)
264 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
265 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
266 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
267 returnSmpl (acc'', x':xs')
271 %************************************************************************
273 \subsection{The unique supply}
275 %************************************************************************
278 getUniqSupplySmpl :: SimplM UniqSupply
279 getUniqSupplySmpl dflags us sc
280 = case splitUniqSupply us of
281 (us1, us2) -> (us1, us2, sc)
283 getUniqueSmpl :: SimplM Unique
284 getUniqueSmpl dflags us sc
285 = case splitUniqSupply us of
286 (us1, us2) -> (uniqFromSupply us1, us2, sc)
288 getUniquesSmpl :: SimplM [Unique]
289 getUniquesSmpl dflags us sc
290 = case splitUniqSupply us of
291 (us1, us2) -> (uniqsFromSupply us1, us2, sc)
293 getDOptsSmpl :: SimplM DynFlags
294 getDOptsSmpl dflags us sc
299 %************************************************************************
301 \subsection{Counting up what we've done}
303 %************************************************************************
306 getSimplCount :: SimplM SimplCount
307 getSimplCount dflags us sc = (sc, us, sc)
309 tick :: Tick -> SimplM ()
311 = sc' `seq` ((), us, sc')
315 freeTick :: Tick -> SimplM ()
316 -- Record a tick, but don't add to the total tick count, which is
317 -- used to decide when nothing further has happened
318 freeTick t dflags us sc
319 = sc' `seq` ((), us, sc')
321 sc' = doFreeTick t sc
325 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
327 zeroSimplCount :: DynFlags -> SimplCount
328 isZeroSimplCount :: SimplCount -> Bool
329 pprSimplCount :: SimplCount -> SDoc
330 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
331 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
335 data SimplCount = VerySimplZero -- These two are used when
336 | VerySimplNonZero -- we are only interested in
340 ticks :: !Int, -- Total ticks
341 details :: !TickCounts, -- How many of each type
343 log1 :: [Tick], -- Last N events; <= opt_HistorySize
344 log2 :: [Tick] -- Last opt_HistorySize events before that
347 type TickCounts = FiniteMap Tick Int
349 zeroSimplCount dflags
350 -- This is where we decide whether to do
351 -- the VerySimpl version or the full-stats version
352 | dopt Opt_D_dump_simpl_stats dflags
353 = SimplCount {ticks = 0, details = emptyFM,
354 n_log = 0, log1 = [], log2 = []}
358 isZeroSimplCount VerySimplZero = True
359 isZeroSimplCount (SimplCount { ticks = 0 }) = True
360 isZeroSimplCount other = False
362 doFreeTick tick sc@SimplCount { details = dts }
363 = dts' `seqFM` sc { details = dts' }
365 dts' = dts `addTick` tick
366 doFreeTick tick sc = sc
368 -- Gross hack to persuade GHC 3.03 to do this important seq
369 seqFM fm x | isEmptyFM fm = x
372 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
373 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
374 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
376 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
378 doTick tick sc = VerySimplNonZero -- The very simple case
381 -- Don't use plusFM_C because that's lazy, and we want to
382 -- be pretty strict here!
383 addTick :: TickCounts -> Tick -> TickCounts
384 addTick fm tick = case lookupFM fm tick of
385 Nothing -> addToFM fm tick 1
386 Just n -> n1 `seq` addToFM fm tick n1
391 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
392 sc2@(SimplCount { ticks = tks2, details = dts2 })
393 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
395 -- A hackish way of getting recent log info
396 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
397 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
400 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
401 plusSimplCount sc1 sc2 = VerySimplNonZero
403 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
404 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
405 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
406 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
408 pprTickCounts (fmToList dts),
409 if verboseSimplStats then
411 ptext SLIT("Log (most recent first)"),
412 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
416 pprTickCounts :: [(Tick,Int)] -> SDoc
417 pprTickCounts [] = empty
418 pprTickCounts ((tick1,n1):ticks)
419 = vcat [int tot_n <+> text (tickString tick1),
420 pprTCDetails real_these,
424 tick1_tag = tickToTag tick1
425 (these, others) = span same_tick ticks
426 real_these = (tick1,n1):these
427 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
428 tot_n = sum [n | (_,n) <- real_these]
430 pprTCDetails ticks@((tick,_):_)
431 | verboseSimplStats || isRuleFired tick
432 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
437 %************************************************************************
441 %************************************************************************
445 = PreInlineUnconditionally Id
446 | PostInlineUnconditionally Id
449 | RuleFired FAST_STRING -- Rule name
452 | EtaExpansion Id -- LHS binder
453 | EtaReduction Id -- Binder on outer lambda
454 | BetaReduction Id -- Lambda binder
457 | CaseOfCase Id -- Bndr on *inner* case
458 | KnownBranch Id -- Case binder
459 | CaseMerge Id -- Binder on outer case
460 | AltMerge Id -- Case binder
461 | CaseElim Id -- Case binder
462 | CaseIdentity Id -- Case binder
463 | FillInCaseDefault Id -- Case binder
466 | SimplifierDone -- Ticked at each iteration of the simplifier
468 isRuleFired (RuleFired _) = True
469 isRuleFired other = False
471 instance Outputable Tick where
472 ppr tick = text (tickString tick) <+> pprTickCts tick
474 instance Eq Tick where
475 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
477 instance Ord Tick where
480 tickToTag :: Tick -> Int
481 tickToTag (PreInlineUnconditionally _) = 0
482 tickToTag (PostInlineUnconditionally _) = 1
483 tickToTag (UnfoldingDone _) = 2
484 tickToTag (RuleFired _) = 3
485 tickToTag LetFloatFromLet = 4
486 tickToTag (EtaExpansion _) = 5
487 tickToTag (EtaReduction _) = 6
488 tickToTag (BetaReduction _) = 7
489 tickToTag (CaseOfCase _) = 8
490 tickToTag (KnownBranch _) = 9
491 tickToTag (CaseMerge _) = 10
492 tickToTag (CaseElim _) = 11
493 tickToTag (CaseIdentity _) = 12
494 tickToTag (FillInCaseDefault _) = 13
495 tickToTag BottomFound = 14
496 tickToTag SimplifierDone = 16
497 tickToTag (AltMerge _) = 17
499 tickString :: Tick -> String
500 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
501 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
502 tickString (UnfoldingDone _) = "UnfoldingDone"
503 tickString (RuleFired _) = "RuleFired"
504 tickString LetFloatFromLet = "LetFloatFromLet"
505 tickString (EtaExpansion _) = "EtaExpansion"
506 tickString (EtaReduction _) = "EtaReduction"
507 tickString (BetaReduction _) = "BetaReduction"
508 tickString (CaseOfCase _) = "CaseOfCase"
509 tickString (KnownBranch _) = "KnownBranch"
510 tickString (CaseMerge _) = "CaseMerge"
511 tickString (AltMerge _) = "AltMerge"
512 tickString (CaseElim _) = "CaseElim"
513 tickString (CaseIdentity _) = "CaseIdentity"
514 tickString (FillInCaseDefault _) = "FillInCaseDefault"
515 tickString BottomFound = "BottomFound"
516 tickString SimplifierDone = "SimplifierDone"
518 pprTickCts :: Tick -> SDoc
519 pprTickCts (PreInlineUnconditionally v) = ppr v
520 pprTickCts (PostInlineUnconditionally v)= ppr v
521 pprTickCts (UnfoldingDone v) = ppr v
522 pprTickCts (RuleFired v) = ppr v
523 pprTickCts LetFloatFromLet = empty
524 pprTickCts (EtaExpansion v) = ppr v
525 pprTickCts (EtaReduction v) = ppr v
526 pprTickCts (BetaReduction v) = ppr v
527 pprTickCts (CaseOfCase v) = ppr v
528 pprTickCts (KnownBranch v) = ppr v
529 pprTickCts (CaseMerge v) = ppr v
530 pprTickCts (AltMerge v) = ppr v
531 pprTickCts (CaseElim v) = ppr v
532 pprTickCts (CaseIdentity v) = ppr v
533 pprTickCts (FillInCaseDefault v) = ppr v
534 pprTickCts other = empty
536 cmpTick :: Tick -> Tick -> Ordering
537 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
539 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
542 -- Always distinguish RuleFired, so that the stats
543 -- can report them even in non-verbose mode
545 cmpEqTick :: Tick -> Tick -> Ordering
546 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
547 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
548 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
549 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
550 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
551 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
552 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
553 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
554 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
555 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
556 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
557 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
558 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
559 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
560 cmpEqTick other1 other2 = EQ
565 %************************************************************************
567 \subsubsection{The @SimplEnv@ type}
569 %************************************************************************
575 seMode :: SimplifierMode,
576 seChkr :: SwitchChecker,
577 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
578 seSubst :: Subst -- The current substitution
580 -- The range of the substitution is OutType and OutExpr resp
582 -- The substitution is idempotent
583 -- It *must* be applied; things in its domain simply aren't
584 -- bound in the result.
586 -- The substitution usually maps an Id to its clone,
587 -- but if the orig defn is a let-binding, and
588 -- the RHS of the let simplifies to an atom,
589 -- we just add the binding to the substitution and elide the let.
591 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
592 -- The elements of the set may have better IdInfo than the
593 -- occurrences of in-scope Ids, and (more important) they will
594 -- have a correctly-substituted type. So we use a lookup in this
595 -- set to replace occurrences
597 emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> VarSet -> SimplEnv
598 emptySimplEnv mode switches in_scope
599 = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, seMode = mode,
600 seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
601 -- The top level "enclosing CC" is "SUBSUMED".
603 ---------------------
604 getSwitchChecker :: SimplEnv -> SwitchChecker
605 getSwitchChecker env = seChkr env
607 ---------------------
608 getMode :: SimplEnv -> SimplifierMode
609 getMode env = seMode env
611 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
612 setMode mode env = env { seMode = mode }
614 ---------------------
615 getEnclosingCC :: SimplEnv -> CostCentreStack
616 getEnclosingCC env = seCC env
618 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
619 setEnclosingCC env cc = env {seCC = cc}
621 ---------------------
622 getSubst :: SimplEnv -> Subst
623 getSubst env = seSubst env
625 setSubst :: SimplEnv -> Subst -> SimplEnv
626 setSubst env subst = env {seSubst = subst}
628 extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv
629 extendSubst env@(SimplEnv {seSubst = subst}) var res
630 = env {seSubst = Subst.extendSubst subst var res}
632 extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv
633 extendSubstList env@(SimplEnv {seSubst = subst}) vars ress
634 = env {seSubst = Subst.extendSubstList subst vars ress}
636 ---------------------
637 getInScope :: SimplEnv -> InScopeSet
638 getInScope env = substInScope (seSubst env)
640 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
641 setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
643 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
644 setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
645 = env {seSubst = Subst.setInScope subst in_scope}
647 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
648 -- The new Ids are guaranteed to be freshly allocated
649 addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
650 = env {seSubst = Subst.extendNewInScopeList subst vs}
652 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
653 modifyInScope env@(SimplEnv {seSubst = subst}) v v'
654 = env {seSubst = Subst.modifyInScope subst v v'}
656 ---------------------
657 getSubstEnv :: SimplEnv -> SubstEnv
658 getSubstEnv env = substEnv (seSubst env)
660 setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv
661 setSubstEnv env@(SimplEnv {seSubst = subst}) senv
662 = env {seSubst = Subst.setSubstEnv subst senv}
664 zapSubstEnv :: SimplEnv -> SimplEnv
665 zapSubstEnv env@(SimplEnv {seSubst = subst})
666 = env {seSubst = Subst.zapSubstEnv subst}
670 %************************************************************************
672 \subsection{Decisions about inlining}
674 %************************************************************************
676 Inlining is controlled partly by the SimplifierMode switch. This has two
679 SimplGently (a) Simplifying before specialiser/full laziness
680 (b) Simplifiying inside INLINE pragma
681 (c) Simplifying the LHS of a rule
683 SimplPhase n Used at all other times
685 The key thing about SimplGently is that it does no call-site inlining.
686 Before full laziness we must be careful not to inline wrappers,
687 because doing so inhibits floating
688 e.g. ...(case f x of ...)...
689 ==> ...(case (case x of I# x# -> fw x#) of ...)...
690 ==> ...(case x of I# x# -> case fw x# of ...)...
691 and now the redex (f x) isn't floatable any more.
695 SimplGently is also used as the mode to simplify inside an InlineMe note.
698 inlineMode :: SimplifierMode
699 inlineMode = SimplGently
702 It really is important to switch off inlinings inside such
703 expressions. Consider the following example
709 in ...g...g...g...g...g...
711 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
712 and thence copied multiple times when g is inlined.
715 This function may be inlinined in other modules, so we
716 don't want to remove (by inlining) calls to functions that have
717 specialisations, or that may have transformation rules in an importing
720 E.g. {-# INLINE f #-}
723 and suppose that g is strict *and* has specialisations. If we inline
724 g's wrapper, we deny f the chance of getting the specialised version
725 of g when f is inlined at some call site (perhaps in some other
728 It's also important not to inline a worker back into a wrapper.
730 wraper = inline_me (\x -> ...worker... )
731 Normally, the inline_me prevents the worker getting inlined into
732 the wrapper (initially, the worker's only call site!). But,
733 if the wrapper is sure to be called, the strictness analyser will
734 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
735 continuation. That's why the keep_inline predicate returns True for
736 ArgOf continuations. It shouldn't do any harm not to dissolve the
737 inline-me note under these circumstances.
739 Note that the result is that we do very little simplification
742 all xs = foldr (&&) True xs
743 any p = all . map p {-# INLINE any #-}
745 Problem: any won't get deforested, and so if it's exported and the
746 importer doesn't use the inlining, (eg passes it as an arg) then we
747 won't get deforestation at all. We havn't solved this problem yet!
750 preInlineUnconditionally
751 ~~~~~~~~~~~~~~~~~~~~~~~~
752 @preInlineUnconditionally@ examines a bndr to see if it is used just
753 once in a completely safe way, so that it is safe to discard the
754 binding inline its RHS at the (unique) usage site, REGARDLESS of how
755 big the RHS might be. If this is the case we don't simplify the RHS
756 first, but just inline it un-simplified.
758 This is much better than first simplifying a perhaps-huge RHS and then
759 inlining and re-simplifying it. Indeed, it can be at least quadratically
768 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
770 NB: we don't even look at the RHS to see if it's trivial
773 where x is used many times, but this is the unique occurrence of y.
774 We should NOT inline x at all its uses, because then we'd do the same
775 for y -- aargh! So we must base this pre-rhs-simplification decision
776 solely on x's occurrences, not on its rhs.
778 Evne RHSs labelled InlineMe aren't caught here, because there might be
779 no benefit from inlining at the call site.
781 [Sept 01] Don't unconditionally inline a top-level thing, because that
782 can simply make a static thing into something built dynamically. E.g.
786 [Remember that we treat \s as a one-shot lambda.] No point in
787 inlining x unless there is something interesting about the call site.
789 But watch out: if you aren't careful, some useful foldr/build fusion
790 can be lost (most notably in spectral/hartel/parstof) because the
791 foldr didn't see the build. Doing the dynamic allocation isn't a big
792 deal, in fact, but losing the fusion can be. But the right thing here
793 seems to be to do a callSiteInline based on the fact that there is
794 something interesting about the call site (it's strict). Hmm. That
797 Conclusion: inline top level things gaily until Phase 0 (the last
798 phase), at which point don't.
801 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
802 preInlineUnconditionally env top_lvl bndr
803 | isTopLevel top_lvl, SimplPhase 0 <- phase = False
804 -- If we don't have this test, consider
805 -- x = length [1,2,3]
806 -- The full laziness pass carefully floats all the cons cells to
807 -- top level, and preInlineUnconditionally floats them all back in.
808 -- Result is (a) static allocation replaced by dynamic allocation
809 -- (b) many simplifier iterations because this tickles
810 -- a related problem; only one inlining per pass
812 -- On the other hand, I have seen cases where top-level fusion is
813 -- lost if we don't inline top level thing (e.g. string constants)
814 -- Hence the test for phase zero (which is the phase for all the final
815 -- simplifications). Until phase zero we take no special notice of
816 -- top level things, but then we become more leery about inlining
820 | opt_SimplNoPreInlining = False
821 | otherwise = case idOccInfo bndr of
822 IAmDead -> True -- Happens in ((\x.1) v)
823 OneOcc in_lam once -> not in_lam && once
824 -- Not inside a lambda, one occurrence ==> safe!
828 active = case phase of
829 SimplGently -> isAlwaysActive prag
830 SimplPhase n -> isActive n prag
831 prag = idInlinePragma bndr
834 postInlineUnconditionally
835 ~~~~~~~~~~~~~~~~~~~~~~~~~
836 @postInlineUnconditionally@ decides whether to unconditionally inline
837 a thing based on the form of its RHS; in particular if it has a
838 trivial RHS. If so, we can inline and discard the binding altogether.
840 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
841 only have *forward* references Hence, it's safe to discard the binding
843 NOTE: This isn't our last opportunity to inline. We're at the binding
844 site right now, and we'll get another opportunity when we get to the
847 Note that we do this unconditional inlining only for trival RHSs.
848 Don't inline even WHNFs inside lambdas; doing so may simply increase
849 allocation when the function is called. This isn't the last chance; see
852 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
853 Because we don't even want to inline them into the RHS of constructor
854 arguments. See NOTE above
856 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
857 it's best to inline it anyway. We often get a=E; b=a from desugaring,
858 with both a and b marked NOINLINE. But that seems incompatible with
859 our new view that inlining is like a RULE, so I'm sticking to the 'active'
863 postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
864 postInlineUnconditionally env bndr occ_info rhs
867 && not (isLoopBreaker occ_info)
868 && not (isExportedId bndr)
869 -- We used to have (isOneOcc occ_info) instead of
870 -- not (isLoopBreaker occ_info) && not (isExportedId bndr)
871 -- That was because a rather fragile use of rules got confused
872 -- if you inlined even a binding f=g e.g. We used to have
874 -- But now a more precise use of phases has eliminated this problem,
875 -- so the is_active test will do the job. I think.
877 -- OLD COMMENT: (delete soon)
878 -- Indeed, you might suppose that
879 -- there is nothing wrong with substituting for a trivial RHS, even
880 -- if it occurs many times. But consider
882 -- h = _inline_me_ (...x...)
883 -- Here we do *not* want to have x inlined, even though the RHS is
884 -- trivial, becuase the contract for an INLINE pragma is "no inlining".
885 -- This is important in the rules for the Prelude
887 active = case getMode env of
888 SimplGently -> isAlwaysActive prag
889 SimplPhase n -> isActive n prag
890 prag = idInlinePragma bndr
893 blackListInline tells if we must not inline at a call site because the
894 Id's inline pragma says not to do so.
896 However, blackListInline is ignored for things with with Compulsory inlinings,
897 because they don't have bindings, so we must inline them no matter how
901 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
902 activeInline env id occ
903 = case getMode env of
904 SimplGently -> isAlwaysActive prag && isOneOcc occ
905 -- No inlining at all when doing gentle stuff,
906 -- except for things that occur once
907 -- The reason is that too little clean-up happens if you
908 -- don't inline use-once things. Also a bit of inlining is *good* for
909 -- full laziness; it can expose constant sub-expressions.
910 -- Example in spectral/mandel/Mandel.hs, where the mandelset
911 -- function gets a useful let-float if you inline windowToViewport
913 -- NB: we used to have a second exception, for data con wrappers.
914 -- On the grounds that we use gentle mode for rule LHSs, and
915 -- they match better when data con wrappers are inlined.
916 -- But that only really applies to the trivial wrappers (like (:)),
917 -- and they are now constructed as Compulsory unfoldings (in MkId)
918 -- so they'll happen anyway.
920 SimplPhase n -> isActive n prag
922 prag = idInlinePragma id
924 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
925 -- Nothing => No rules at all
927 = case getMode env of
928 SimplGently -> Nothing -- No rules in gentle mode
929 SimplPhase n -> Just (isActive n)
933 %************************************************************************
935 \subsubsection{Command-line switches}
937 %************************************************************************
940 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
941 getSimplIntSwitch chkr switch
942 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
944 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
946 switchIsOn lookup_fn switch
947 = case (lookup_fn switch) of
948 SwBool False -> False
951 intSwitchSet :: (switch -> SwitchResult)
955 intSwitchSet lookup_fn switch
956 = case (lookup_fn (switch (panic "intSwitchSet"))) of
957 SwInt int -> Just int
963 type SwitchChecker = SimplifierSwitch -> SwitchResult
966 = SwBool Bool -- on/off
967 | SwString FAST_STRING -- nothing or a String
968 | SwInt Int -- nothing or an Int
970 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
971 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
972 -- in the list; defaults right at the end.
974 tidied_on_switches = foldl rm_dups [] on_switches
975 -- The fold*l* ensures that we keep the latest switches;
976 -- ie the ones that occur earliest in the list.
978 sw_tbl :: Array Int SwitchResult
979 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
983 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
985 defined_elems = map mk_assoc_elem tidied_on_switches
987 -- (avoid some unboxing, bounds checking, and other horrible things:)
988 #if __GLASGOW_HASKELL__ < 405
989 case sw_tbl of { Array bounds_who_needs_'em stuff ->
991 case sw_tbl of { Array _ _ stuff ->
994 case (indexArray# stuff (tagOf_SimplSwitch switch)) of
995 #if __GLASGOW_HASKELL__ < 400
997 #elif __GLASGOW_HASKELL__ < 403
1004 mk_assoc_elem k@(MaxSimplifierIterations lvl)
1005 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
1007 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
1009 -- cannot have duplicates if we are going to use the array thing
1010 rm_dups switches_so_far switch
1011 = if switch `is_elem` switches_so_far
1012 then switches_so_far
1013 else switch : switches_so_far
1015 sw `is_elem` [] = False
1016 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
1020 These things behave just like enumeration types.
1023 instance Eq SimplifierSwitch where
1024 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
1026 instance Ord SimplifierSwitch where
1027 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
1028 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
1031 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
1032 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
1034 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
1036 lAST_SIMPL_SWITCH_TAG = 2