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 -- Top-level fusion lost if we do this for (e.g. string constants)
796 | opt_SimplNoPreInlining = False
797 | otherwise = case idOccInfo bndr of
798 IAmDead -> True -- Happens in ((\x.1) v)
799 OneOcc in_lam once -> not in_lam && once
800 -- Not inside a lambda, one occurrence ==> safe!
803 active = case getMode env of
804 SimplGently -> isAlwaysActive prag
805 SimplPhase n -> isActive n prag
806 prag = idInlinePragma bndr
809 postInlineUnconditionally
810 ~~~~~~~~~~~~~~~~~~~~~~~~~
811 @postInlineUnconditionally@ decides whether to unconditionally inline
812 a thing based on the form of its RHS; in particular if it has a
813 trivial RHS. If so, we can inline and discard the binding altogether.
815 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
816 only have *forward* references Hence, it's safe to discard the binding
818 NOTE: This isn't our last opportunity to inline. We're at the binding
819 site right now, and we'll get another opportunity when we get to the
822 Note that we do this unconditional inlining only for trival RHSs.
823 Don't inline even WHNFs inside lambdas; doing so may simply increase
824 allocation when the function is called. This isn't the last chance; see
827 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
828 Because we don't even want to inline them into the RHS of constructor
829 arguments. See NOTE above
831 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
832 it's best to inline it anyway. We often get a=E; b=a from desugaring,
833 with both a and b marked NOINLINE. But that seems incompatible with
834 our new view that inlining is like a RULE, so I'm sticking to the 'active'
838 postInlineUnconditionally :: SimplEnv -> OutId -> Bool -> OutExpr -> Bool
839 postInlineUnconditionally env bndr loop_breaker rhs
843 && not (isExportedId bndr)
845 active = case getMode env of
846 SimplGently -> isAlwaysActive prag
847 SimplPhase n -> isActive n prag
848 prag = idInlinePragma bndr
851 blackListInline tells if we must not inline at a call site because the
852 Id's inline pragma says not to do so.
854 However, blackListInline is ignored for things with with Compulsory inlinings,
855 because they don't have bindings, so we must inline them no matter how
859 activeInline :: SimplEnv -> OutId -> Bool
861 = case getMode env of
862 SimplGently -> isDataConWrapId id
863 -- No inlining at all when doing gentle stuff,
864 -- except (hack alert) for data con wrappers
865 -- We want to inline data con wrappers even in gentle mode
866 -- because rule LHSs match better then
867 SimplPhase n -> isActive n (idInlinePragma id)
869 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
870 -- Nothing => No rules at all
872 = case getMode env of
873 SimplGently -> Nothing -- No rules in gentle mode
874 SimplPhase n -> Just (isActive n)
878 %************************************************************************
880 \subsubsection{Command-line switches}
882 %************************************************************************
885 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
886 getSimplIntSwitch chkr switch
887 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
889 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
891 switchIsOn lookup_fn switch
892 = case (lookup_fn switch) of
893 SwBool False -> False
896 intSwitchSet :: (switch -> SwitchResult)
900 intSwitchSet lookup_fn switch
901 = case (lookup_fn (switch (panic "intSwitchSet"))) of
902 SwInt int -> Just int
908 type SwitchChecker = SimplifierSwitch -> SwitchResult
911 = SwBool Bool -- on/off
912 | SwString FAST_STRING -- nothing or a String
913 | SwInt Int -- nothing or an Int
915 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
916 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
917 -- in the list; defaults right at the end.
919 tidied_on_switches = foldl rm_dups [] on_switches
920 -- The fold*l* ensures that we keep the latest switches;
921 -- ie the ones that occur earliest in the list.
923 sw_tbl :: Array Int SwitchResult
924 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
928 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
930 defined_elems = map mk_assoc_elem tidied_on_switches
932 -- (avoid some unboxing, bounds checking, and other horrible things:)
933 #if __GLASGOW_HASKELL__ < 405
934 case sw_tbl of { Array bounds_who_needs_'em stuff ->
936 case sw_tbl of { Array _ _ stuff ->
939 case (indexArray# stuff (tagOf_SimplSwitch switch)) of
940 #if __GLASGOW_HASKELL__ < 400
942 #elif __GLASGOW_HASKELL__ < 403
949 mk_assoc_elem k@(MaxSimplifierIterations lvl)
950 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
952 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
954 -- cannot have duplicates if we are going to use the array thing
955 rm_dups switches_so_far switch
956 = if switch `is_elem` switches_so_far
958 else switch : switches_so_far
960 sw `is_elem` [] = False
961 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
965 These things behave just like enumeration types.
968 instance Eq SimplifierSwitch where
969 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
971 instance Ord SimplifierSwitch where
972 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
973 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
976 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
977 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
979 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
981 lAST_SIMPL_SWITCH_TAG = 2