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, isDataConWrapId,
56 idOccInfo, idInlinePragma
59 import CoreUtils ( needsCaseBinding, exprIsTrivial )
60 import PprCore () -- Instances
61 import CostCentre ( CostCentreStack, subsumedCCS )
66 import qualified Subst
67 import Subst ( Subst, mkSubst, substEnv,
68 InScopeSet, mkInScopeSet, substInScope,
71 import Type ( Type, isUnLiftedType )
72 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
76 import BasicTypes ( TopLevelFlag, isTopLevel,
77 Activation, isActive, isAlwaysActive,
80 import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
81 DynFlags, DynFlag(..), dopt,
82 opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining,
84 import Unique ( Unique )
85 import Maybes ( expectJust )
87 import Array ( array, (//) )
89 import GlaExts ( indexArray# )
91 #if __GLASGOW_HASKELL__ < 301
92 import ArrBase ( Array(..) )
94 import PrelArr ( Array(..) )
97 infixr 0 `thenSmpl`, `thenSmpl_`
100 %************************************************************************
102 \subsection[Simplify-types]{Type declarations}
104 %************************************************************************
107 type InBinder = CoreBndr
108 type InId = Id -- Not yet cloned
109 type InType = Type -- Ditto
110 type InBind = CoreBind
111 type InExpr = CoreExpr
115 type OutBinder = CoreBndr
116 type OutId = Id -- Cloned
117 type OutTyVar = TyVar -- Cloned
118 type OutType = Type -- Cloned
119 type OutBind = CoreBind
120 type OutExpr = CoreExpr
121 type OutAlt = CoreAlt
122 type OutArg = CoreArg
125 %************************************************************************
129 %************************************************************************
132 type FloatsWithExpr = FloatsWith OutExpr
133 type FloatsWith a = (Floats, a)
134 -- We return something equivalent to (let b in e), but
135 -- in pieces to avoid the quadratic blowup when floating
136 -- incrementally. Comments just before simplExprB in Simplify.lhs
138 data Floats = Floats (OrdList OutBind)
139 InScopeSet -- Environment "inside" all the floats
140 Bool -- True <=> All bindings are lifted
142 allLifted :: Floats -> Bool
143 allLifted (Floats _ _ is_lifted) = is_lifted
145 wrapFloats :: Floats -> OutExpr -> OutExpr
146 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
148 isEmptyFloats :: Floats -> Bool
149 isEmptyFloats (Floats bs _ _) = isNilOL bs
151 floatBinds :: Floats -> [OutBind]
152 floatBinds (Floats bs _ _) = fromOL bs
154 flattenFloats :: Floats -> Floats
155 -- Flattens into a single Rec group
156 flattenFloats (Floats bs is is_lifted)
157 = ASSERT2( is_lifted, ppr (fromOL bs) )
158 Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
162 emptyFloats :: SimplEnv -> Floats
163 emptyFloats env = Floats nilOL (getInScope env) True
165 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
166 -- A single non-rec float; extend the in-scope set
167 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
168 (Subst.extendInScopeSet (getInScope env) var)
169 (not (isUnLiftedType (idType var)))
171 addFloats :: SimplEnv -> Floats
172 -> (SimplEnv -> SimplM (FloatsWith a))
173 -> SimplM (FloatsWith a)
174 addFloats env (Floats b1 is1 l1) thing_inside
178 = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
179 returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
181 addLetBind :: OutBind -> Floats -> Floats
182 addLetBind bind (Floats binds in_scope lifted)
183 = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
185 is_lifted_bind (Rec _) = True
186 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
188 -- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
189 -- * extends the in-scope env
190 -- * assumes it's a let-bindable thing
191 addAuxiliaryBind :: SimplEnv -> OutBind
192 -> (SimplEnv -> SimplM (FloatsWith a))
193 -> SimplM (FloatsWith a)
194 -- Extends the in-scope environment as well as wrapping the bindings
195 addAuxiliaryBind env bind thing_inside
196 = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
197 thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
198 returnSmpl (addLetBind bind floats, x)
202 %************************************************************************
204 \subsection{Monad plumbing}
206 %************************************************************************
208 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
209 (Command-line switches move around through the explicitly-passed SimplEnv.)
213 = DynFlags -- We thread the unique supply because
214 -> UniqSupply -- constantly splitting it is rather expensive
216 -> (result, UniqSupply, SimplCount)
221 -> UniqSupply -- No init count; set to 0
226 = case m dflags us (zeroSimplCount dflags) of
227 (result, _, count) -> (result, count)
230 {-# INLINE thenSmpl #-}
231 {-# INLINE thenSmpl_ #-}
232 {-# INLINE returnSmpl #-}
234 returnSmpl :: a -> SimplM a
235 returnSmpl e dflags us sc = (e, us, sc)
237 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
238 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
240 thenSmpl m k dflags us0 sc0
241 = case (m dflags us0 sc0) of
242 (m_result, us1, sc1) -> k m_result dflags us1 sc1
244 thenSmpl_ m k dflags us0 sc0
245 = case (m dflags us0 sc0) of
246 (_, us1, sc1) -> k dflags us1 sc1
251 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
252 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
254 mapSmpl f [] = returnSmpl []
256 = f x `thenSmpl` \ x' ->
257 mapSmpl f xs `thenSmpl` \ xs' ->
260 mapAndUnzipSmpl f [] = returnSmpl ([],[])
261 mapAndUnzipSmpl f (x:xs)
262 = f x `thenSmpl` \ (r1, r2) ->
263 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
264 returnSmpl (r1:rs1, r2:rs2)
266 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
267 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
268 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
269 returnSmpl (acc'', x':xs')
273 %************************************************************************
275 \subsection{The unique supply}
277 %************************************************************************
280 getUniqSupplySmpl :: SimplM UniqSupply
281 getUniqSupplySmpl dflags us sc
282 = case splitUniqSupply us of
283 (us1, us2) -> (us1, us2, sc)
285 getUniqueSmpl :: SimplM Unique
286 getUniqueSmpl dflags us sc
287 = case splitUniqSupply us of
288 (us1, us2) -> (uniqFromSupply us1, us2, sc)
290 getUniquesSmpl :: SimplM [Unique]
291 getUniquesSmpl dflags us sc
292 = case splitUniqSupply us of
293 (us1, us2) -> (uniqsFromSupply us1, us2, sc)
295 getDOptsSmpl :: SimplM DynFlags
296 getDOptsSmpl dflags us sc
301 %************************************************************************
303 \subsection{Counting up what we've done}
305 %************************************************************************
308 getSimplCount :: SimplM SimplCount
309 getSimplCount dflags us sc = (sc, us, sc)
311 tick :: Tick -> SimplM ()
313 = sc' `seq` ((), us, sc')
317 freeTick :: Tick -> SimplM ()
318 -- Record a tick, but don't add to the total tick count, which is
319 -- used to decide when nothing further has happened
320 freeTick t dflags us sc
321 = sc' `seq` ((), us, sc')
323 sc' = doFreeTick t sc
327 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
329 zeroSimplCount :: DynFlags -> SimplCount
330 isZeroSimplCount :: SimplCount -> Bool
331 pprSimplCount :: SimplCount -> SDoc
332 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
333 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
337 data SimplCount = VerySimplZero -- These two are used when
338 | VerySimplNonZero -- we are only interested in
342 ticks :: !Int, -- Total ticks
343 details :: !TickCounts, -- How many of each type
345 log1 :: [Tick], -- Last N events; <= opt_HistorySize
346 log2 :: [Tick] -- Last opt_HistorySize events before that
349 type TickCounts = FiniteMap Tick Int
351 zeroSimplCount dflags
352 -- This is where we decide whether to do
353 -- the VerySimpl version or the full-stats version
354 | dopt Opt_D_dump_simpl_stats dflags
355 = SimplCount {ticks = 0, details = emptyFM,
356 n_log = 0, log1 = [], log2 = []}
360 isZeroSimplCount VerySimplZero = True
361 isZeroSimplCount (SimplCount { ticks = 0 }) = True
362 isZeroSimplCount other = False
364 doFreeTick tick sc@SimplCount { details = dts }
365 = dts' `seqFM` sc { details = dts' }
367 dts' = dts `addTick` tick
368 doFreeTick tick sc = sc
370 -- Gross hack to persuade GHC 3.03 to do this important seq
371 seqFM fm x | isEmptyFM fm = x
374 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
375 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
376 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
378 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
380 doTick tick sc = VerySimplNonZero -- The very simple case
383 -- Don't use plusFM_C because that's lazy, and we want to
384 -- be pretty strict here!
385 addTick :: TickCounts -> Tick -> TickCounts
386 addTick fm tick = case lookupFM fm tick of
387 Nothing -> addToFM fm tick 1
388 Just n -> n1 `seq` addToFM fm tick n1
393 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
394 sc2@(SimplCount { ticks = tks2, details = dts2 })
395 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
397 -- A hackish way of getting recent log info
398 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
399 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
402 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
403 plusSimplCount sc1 sc2 = VerySimplNonZero
405 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
406 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
407 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
408 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
410 pprTickCounts (fmToList dts),
411 if verboseSimplStats then
413 ptext SLIT("Log (most recent first)"),
414 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
418 pprTickCounts :: [(Tick,Int)] -> SDoc
419 pprTickCounts [] = empty
420 pprTickCounts ((tick1,n1):ticks)
421 = vcat [int tot_n <+> text (tickString tick1),
422 pprTCDetails real_these,
426 tick1_tag = tickToTag tick1
427 (these, others) = span same_tick ticks
428 real_these = (tick1,n1):these
429 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
430 tot_n = sum [n | (_,n) <- real_these]
432 pprTCDetails ticks@((tick,_):_)
433 | verboseSimplStats || isRuleFired tick
434 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
439 %************************************************************************
443 %************************************************************************
447 = PreInlineUnconditionally Id
448 | PostInlineUnconditionally Id
451 | RuleFired FAST_STRING -- Rule name
454 | EtaExpansion Id -- LHS binder
455 | EtaReduction Id -- Binder on outer lambda
456 | BetaReduction Id -- Lambda binder
459 | CaseOfCase Id -- Bndr on *inner* case
460 | KnownBranch Id -- Case binder
461 | CaseMerge Id -- Binder on outer case
462 | AltMerge Id -- Case binder
463 | CaseElim Id -- Case binder
464 | CaseIdentity Id -- Case binder
465 | FillInCaseDefault Id -- Case binder
468 | SimplifierDone -- Ticked at each iteration of the simplifier
470 isRuleFired (RuleFired _) = True
471 isRuleFired other = False
473 instance Outputable Tick where
474 ppr tick = text (tickString tick) <+> pprTickCts tick
476 instance Eq Tick where
477 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
479 instance Ord Tick where
482 tickToTag :: Tick -> Int
483 tickToTag (PreInlineUnconditionally _) = 0
484 tickToTag (PostInlineUnconditionally _) = 1
485 tickToTag (UnfoldingDone _) = 2
486 tickToTag (RuleFired _) = 3
487 tickToTag LetFloatFromLet = 4
488 tickToTag (EtaExpansion _) = 5
489 tickToTag (EtaReduction _) = 6
490 tickToTag (BetaReduction _) = 7
491 tickToTag (CaseOfCase _) = 8
492 tickToTag (KnownBranch _) = 9
493 tickToTag (CaseMerge _) = 10
494 tickToTag (CaseElim _) = 11
495 tickToTag (CaseIdentity _) = 12
496 tickToTag (FillInCaseDefault _) = 13
497 tickToTag BottomFound = 14
498 tickToTag SimplifierDone = 16
499 tickToTag (AltMerge _) = 17
501 tickString :: Tick -> String
502 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
503 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
504 tickString (UnfoldingDone _) = "UnfoldingDone"
505 tickString (RuleFired _) = "RuleFired"
506 tickString LetFloatFromLet = "LetFloatFromLet"
507 tickString (EtaExpansion _) = "EtaExpansion"
508 tickString (EtaReduction _) = "EtaReduction"
509 tickString (BetaReduction _) = "BetaReduction"
510 tickString (CaseOfCase _) = "CaseOfCase"
511 tickString (KnownBranch _) = "KnownBranch"
512 tickString (CaseMerge _) = "CaseMerge"
513 tickString (AltMerge _) = "AltMerge"
514 tickString (CaseElim _) = "CaseElim"
515 tickString (CaseIdentity _) = "CaseIdentity"
516 tickString (FillInCaseDefault _) = "FillInCaseDefault"
517 tickString BottomFound = "BottomFound"
518 tickString SimplifierDone = "SimplifierDone"
520 pprTickCts :: Tick -> SDoc
521 pprTickCts (PreInlineUnconditionally v) = ppr v
522 pprTickCts (PostInlineUnconditionally v)= ppr v
523 pprTickCts (UnfoldingDone v) = ppr v
524 pprTickCts (RuleFired v) = ppr v
525 pprTickCts LetFloatFromLet = empty
526 pprTickCts (EtaExpansion v) = ppr v
527 pprTickCts (EtaReduction v) = ppr v
528 pprTickCts (BetaReduction v) = ppr v
529 pprTickCts (CaseOfCase v) = ppr v
530 pprTickCts (KnownBranch v) = ppr v
531 pprTickCts (CaseMerge v) = ppr v
532 pprTickCts (AltMerge v) = ppr v
533 pprTickCts (CaseElim v) = ppr v
534 pprTickCts (CaseIdentity v) = ppr v
535 pprTickCts (FillInCaseDefault v) = ppr v
536 pprTickCts other = empty
538 cmpTick :: Tick -> Tick -> Ordering
539 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
541 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
544 -- Always distinguish RuleFired, so that the stats
545 -- can report them even in non-verbose mode
547 cmpEqTick :: Tick -> Tick -> Ordering
548 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
549 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
550 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
551 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
552 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
553 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
554 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
555 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
556 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
557 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
558 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
559 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
560 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
561 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
562 cmpEqTick other1 other2 = EQ
567 %************************************************************************
569 \subsubsection{The @SimplEnv@ type}
571 %************************************************************************
577 seMode :: SimplifierMode,
578 seChkr :: SwitchChecker,
579 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
580 seSubst :: Subst -- The current substitution
582 -- The range of the substitution is OutType and OutExpr resp
584 -- The substitution is idempotent
585 -- It *must* be applied; things in its domain simply aren't
586 -- bound in the result.
588 -- The substitution usually maps an Id to its clone,
589 -- but if the orig defn is a let-binding, and
590 -- the RHS of the let simplifies to an atom,
591 -- we just add the binding to the substitution and elide the let.
593 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
594 -- The elements of the set may have better IdInfo than the
595 -- occurrences of in-scope Ids, and (more important) they will
596 -- have a correctly-substituted type. So we use a lookup in this
597 -- set to replace occurrences
599 emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> VarSet -> SimplEnv
600 emptySimplEnv mode switches in_scope
601 = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, seMode = mode,
602 seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
603 -- The top level "enclosing CC" is "SUBSUMED".
605 ---------------------
606 getSwitchChecker :: SimplEnv -> SwitchChecker
607 getSwitchChecker env = seChkr env
609 ---------------------
610 getMode :: SimplEnv -> SimplifierMode
611 getMode env = seMode env
613 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
614 setMode mode env = env { seMode = mode }
616 ---------------------
617 getEnclosingCC :: SimplEnv -> CostCentreStack
618 getEnclosingCC env = seCC env
620 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
621 setEnclosingCC env cc = env {seCC = cc}
623 ---------------------
624 getSubst :: SimplEnv -> Subst
625 getSubst env = seSubst env
627 setSubst :: SimplEnv -> Subst -> SimplEnv
628 setSubst env subst = env {seSubst = subst}
630 extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv
631 extendSubst env@(SimplEnv {seSubst = subst}) var res
632 = env {seSubst = Subst.extendSubst subst var res}
634 extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv
635 extendSubstList env@(SimplEnv {seSubst = subst}) vars ress
636 = env {seSubst = Subst.extendSubstList subst vars ress}
638 ---------------------
639 getInScope :: SimplEnv -> InScopeSet
640 getInScope env = substInScope (seSubst env)
642 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
643 setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
645 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
646 setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
647 = env {seSubst = Subst.setInScope subst in_scope}
649 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
650 -- The new Ids are guaranteed to be freshly allocated
651 addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
652 = env {seSubst = Subst.extendNewInScopeList subst vs}
654 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
655 modifyInScope env@(SimplEnv {seSubst = subst}) v v'
656 = env {seSubst = Subst.modifyInScope subst v v'}
658 ---------------------
659 getSubstEnv :: SimplEnv -> SubstEnv
660 getSubstEnv env = substEnv (seSubst env)
662 setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv
663 setSubstEnv env@(SimplEnv {seSubst = subst}) senv
664 = env {seSubst = Subst.setSubstEnv subst senv}
666 zapSubstEnv :: SimplEnv -> SimplEnv
667 zapSubstEnv env@(SimplEnv {seSubst = subst})
668 = env {seSubst = Subst.zapSubstEnv subst}
672 %************************************************************************
674 \subsection{Decisions about inlining}
676 %************************************************************************
678 Inlining is controlled partly by the SimplifierMode switch. This has two
681 SimplGently (a) Simplifying before specialiser/full laziness
682 (b) Simplifiying inside INLINE pragma
683 (c) Simplifying the LHS of a rule
685 SimplPhase n Used at all other times
687 The key thing about SimplGently is that it does no call-site inlining.
688 Before full laziness we must be careful not to inline wrappers,
689 because doing so inhibits floating
690 e.g. ...(case f x of ...)...
691 ==> ...(case (case x of I# x# -> fw x#) of ...)...
692 ==> ...(case x of I# x# -> case fw x# of ...)...
693 and now the redex (f x) isn't floatable any more.
697 SimplGently is also used as the mode to simplify inside an InlineMe note.
700 inlineMode :: SimplifierMode
701 inlineMode = SimplGently
704 It really is important to switch off inlinings inside such
705 expressions. Consider the following example
711 in ...g...g...g...g...g...
713 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
714 and thence copied multiple times when g is inlined.
717 This function may be inlinined in other modules, so we
718 don't want to remove (by inlining) calls to functions that have
719 specialisations, or that may have transformation rules in an importing
722 E.g. {-# INLINE f #-}
725 and suppose that g is strict *and* has specialisations. If we inline
726 g's wrapper, we deny f the chance of getting the specialised version
727 of g when f is inlined at some call site (perhaps in some other
730 It's also important not to inline a worker back into a wrapper.
732 wraper = inline_me (\x -> ...worker... )
733 Normally, the inline_me prevents the worker getting inlined into
734 the wrapper (initially, the worker's only call site!). But,
735 if the wrapper is sure to be called, the strictness analyser will
736 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
737 continuation. That's why the keep_inline predicate returns True for
738 ArgOf continuations. It shouldn't do any harm not to dissolve the
739 inline-me note under these circumstances.
741 Note that the result is that we do very little simplification
744 all xs = foldr (&&) True xs
745 any p = all . map p {-# INLINE any #-}
747 Problem: any won't get deforested, and so if it's exported and the
748 importer doesn't use the inlining, (eg passes it as an arg) then we
749 won't get deforestation at all. We havn't solved this problem yet!
752 preInlineUnconditionally
753 ~~~~~~~~~~~~~~~~~~~~~~~~
754 @preInlineUnconditionally@ examines a bndr to see if it is used just
755 once in a completely safe way, so that it is safe to discard the
756 binding inline its RHS at the (unique) usage site, REGARDLESS of how
757 big the RHS might be. If this is the case we don't simplify the RHS
758 first, but just inline it un-simplified.
760 This is much better than first simplifying a perhaps-huge RHS and then
761 inlining and re-simplifying it.
763 NB: we don't even look at the RHS to see if it's trivial
766 where x is used many times, but this is the unique occurrence of y.
767 We should NOT inline x at all its uses, because then we'd do the same
768 for y -- aargh! So we must base this pre-rhs-simplification decision
769 solely on x's occurrences, not on its rhs.
771 Evne RHSs labelled InlineMe aren't caught here, because there might be
772 no benefit from inlining at the call site.
774 [Sept 01] Don't unconditionally inline a top-level thing, because that
775 can simply make a static thing into something built dynamically. E.g.
779 [Remember that we treat \s as a one-shot lambda.] No point in
780 inlining x unless there is something interesting about the call site.
782 But watch out: if you aren't careful, some useful foldr/build fusion
783 can be lost (most notably in spectral/hartel/parstof) because the
784 foldr didn't see the build. Doing the dynamic allocation isn't a big
785 deal, in fact, but losing the fusion can be. But the right thing here
786 seems to be to do a callSiteInline based on the fact that there is
787 something interesting about the call site (it's strict). Hmm. That
791 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
792 preInlineUnconditionally env top_lvl bndr
793 | isTopLevel top_lvl = False
794 -- If we don't have this test, consider
795 -- x = length [1,2,3]
796 -- The full laziness pass carefully floats all the cons cells to
797 -- top level, and preInlineUnconditionally floats them all back in.
798 -- Result is (a) static allocation replaced by dynamic allocation
799 -- (b) many simplifier iterations because this tickles
802 -- On the other hand, I have seen cases where top-level fusion is
803 -- lost if we don't inline top level thing (e.g. string constants)
807 | opt_SimplNoPreInlining = False
808 | otherwise = case idOccInfo bndr of
809 IAmDead -> True -- Happens in ((\x.1) v)
810 OneOcc in_lam once -> not in_lam && once
811 -- Not inside a lambda, one occurrence ==> safe!
814 active = case getMode env of
815 SimplGently -> isAlwaysActive prag
816 SimplPhase n -> isActive n prag
817 prag = idInlinePragma bndr
820 postInlineUnconditionally
821 ~~~~~~~~~~~~~~~~~~~~~~~~~
822 @postInlineUnconditionally@ decides whether to unconditionally inline
823 a thing based on the form of its RHS; in particular if it has a
824 trivial RHS. If so, we can inline and discard the binding altogether.
826 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
827 only have *forward* references Hence, it's safe to discard the binding
829 NOTE: This isn't our last opportunity to inline. We're at the binding
830 site right now, and we'll get another opportunity when we get to the
833 Note that we do this unconditional inlining only for trival RHSs.
834 Don't inline even WHNFs inside lambdas; doing so may simply increase
835 allocation when the function is called. This isn't the last chance; see
838 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
839 Because we don't even want to inline them into the RHS of constructor
840 arguments. See NOTE above
842 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
843 it's best to inline it anyway. We often get a=E; b=a from desugaring,
844 with both a and b marked NOINLINE. But that seems incompatible with
845 our new view that inlining is like a RULE, so I'm sticking to the 'active'
849 postInlineUnconditionally :: SimplEnv -> OutId -> Bool -> OutExpr -> Bool
850 postInlineUnconditionally env bndr loop_breaker rhs
854 && not (isExportedId bndr)
856 active = case getMode env of
857 SimplGently -> isAlwaysActive prag
858 SimplPhase n -> isActive n prag
859 prag = idInlinePragma bndr
862 blackListInline tells if we must not inline at a call site because the
863 Id's inline pragma says not to do so.
865 However, blackListInline is ignored for things with with Compulsory inlinings,
866 because they don't have bindings, so we must inline them no matter how
870 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
871 activeInline env id occ
872 = case getMode env of
873 SimplGently -> isOneOcc occ
874 -- No inlining at all when doing gentle stuff,
875 -- except for things that occur once
876 -- The reason is that too little clean-up happens if you
877 -- don't inline use-once things. Also a bit of inlining is *good* for
878 -- full laziness; it can expose constant sub-expressions.
879 -- Example in spectral/mandel/Mandel.hs, where the mandelset
880 -- function gets a useful let-float if you inline windowToViewport
882 -- NB: we used to have a second exception, for data con wrappers.
883 -- On the grounds that we use gentle mode for rule LHSs, and
884 -- they match better when data con wrappers are inlined.
885 -- But that only really applies to the trivial wrappers (like (:)),
886 -- and they are now constructed as Compulsory unfoldings (in MkId)
887 -- so they'll happen anyway.
889 SimplPhase n -> isActive n (idInlinePragma id)
891 -- Belongs in BasicTypes; this frag occurs in OccurAnal too
892 isOneOcc (OneOcc _ _) = True
893 isOneOcc other = False
895 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
896 -- Nothing => No rules at all
898 = case getMode env of
899 SimplGently -> Nothing -- No rules in gentle mode
900 SimplPhase n -> Just (isActive n)
904 %************************************************************************
906 \subsubsection{Command-line switches}
908 %************************************************************************
911 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
912 getSimplIntSwitch chkr switch
913 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
915 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
917 switchIsOn lookup_fn switch
918 = case (lookup_fn switch) of
919 SwBool False -> False
922 intSwitchSet :: (switch -> SwitchResult)
926 intSwitchSet lookup_fn switch
927 = case (lookup_fn (switch (panic "intSwitchSet"))) of
928 SwInt int -> Just int
934 type SwitchChecker = SimplifierSwitch -> SwitchResult
937 = SwBool Bool -- on/off
938 | SwString FAST_STRING -- nothing or a String
939 | SwInt Int -- nothing or an Int
941 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
942 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
943 -- in the list; defaults right at the end.
945 tidied_on_switches = foldl rm_dups [] on_switches
946 -- The fold*l* ensures that we keep the latest switches;
947 -- ie the ones that occur earliest in the list.
949 sw_tbl :: Array Int SwitchResult
950 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
954 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
956 defined_elems = map mk_assoc_elem tidied_on_switches
958 -- (avoid some unboxing, bounds checking, and other horrible things:)
959 #if __GLASGOW_HASKELL__ < 405
960 case sw_tbl of { Array bounds_who_needs_'em stuff ->
962 case sw_tbl of { Array _ _ stuff ->
965 case (indexArray# stuff (tagOf_SimplSwitch switch)) of
966 #if __GLASGOW_HASKELL__ < 400
968 #elif __GLASGOW_HASKELL__ < 403
975 mk_assoc_elem k@(MaxSimplifierIterations lvl)
976 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
978 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
980 -- cannot have duplicates if we are going to use the array thing
981 rm_dups switches_so_far switch
982 = if switch `is_elem` switches_so_far
984 else switch : switches_so_far
986 sw `is_elem` [] = False
987 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
991 These things behave just like enumeration types.
994 instance Eq SimplifierSwitch where
995 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
997 instance Ord SimplifierSwitch where
998 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
999 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
1002 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
1003 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
1005 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
1007 lAST_SIMPL_SWITCH_TAG = 2