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,
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__ < 301
90 import ArrBase ( Array(..) )
92 import PrelArr ( 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.
761 NB: we don't even look at the RHS to see if it's trivial
764 where x is used many times, but this is the unique occurrence of y.
765 We should NOT inline x at all its uses, because then we'd do the same
766 for y -- aargh! So we must base this pre-rhs-simplification decision
767 solely on x's occurrences, not on its rhs.
769 Evne RHSs labelled InlineMe aren't caught here, because there might be
770 no benefit from inlining at the call site.
772 [Sept 01] Don't unconditionally inline a top-level thing, because that
773 can simply make a static thing into something built dynamically. E.g.
777 [Remember that we treat \s as a one-shot lambda.] No point in
778 inlining x unless there is something interesting about the call site.
780 But watch out: if you aren't careful, some useful foldr/build fusion
781 can be lost (most notably in spectral/hartel/parstof) because the
782 foldr didn't see the build. Doing the dynamic allocation isn't a big
783 deal, in fact, but losing the fusion can be. But the right thing here
784 seems to be to do a callSiteInline based on the fact that there is
785 something interesting about the call site (it's strict). Hmm. That
789 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
790 preInlineUnconditionally env top_lvl bndr
791 | isTopLevel top_lvl = False
792 -- If we don't have this test, consider
793 -- x = length [1,2,3]
794 -- The full laziness pass carefully floats all the cons cells to
795 -- top level, and preInlineUnconditionally floats them all back in.
796 -- Result is (a) static allocation replaced by dynamic allocation
797 -- (b) many simplifier iterations because this tickles
800 -- On the other hand, I have seen cases where top-level fusion is
801 -- lost if we don't inline top level thing (e.g. string constants)
805 | opt_SimplNoPreInlining = False
806 | otherwise = case idOccInfo bndr of
807 IAmDead -> True -- Happens in ((\x.1) v)
808 OneOcc in_lam once -> not in_lam && once
809 -- Not inside a lambda, one occurrence ==> safe!
812 active = case getMode env of
813 SimplGently -> isAlwaysActive prag
814 SimplPhase n -> isActive n prag
815 prag = idInlinePragma bndr
818 postInlineUnconditionally
819 ~~~~~~~~~~~~~~~~~~~~~~~~~
820 @postInlineUnconditionally@ decides whether to unconditionally inline
821 a thing based on the form of its RHS; in particular if it has a
822 trivial RHS. If so, we can inline and discard the binding altogether.
824 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
825 only have *forward* references Hence, it's safe to discard the binding
827 NOTE: This isn't our last opportunity to inline. We're at the binding
828 site right now, and we'll get another opportunity when we get to the
831 Note that we do this unconditional inlining only for trival RHSs.
832 Don't inline even WHNFs inside lambdas; doing so may simply increase
833 allocation when the function is called. This isn't the last chance; see
836 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
837 Because we don't even want to inline them into the RHS of constructor
838 arguments. See NOTE above
840 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
841 it's best to inline it anyway. We often get a=E; b=a from desugaring,
842 with both a and b marked NOINLINE. But that seems incompatible with
843 our new view that inlining is like a RULE, so I'm sticking to the 'active'
847 postInlineUnconditionally :: SimplEnv -> OutId -> Bool -> OutExpr -> Bool
848 postInlineUnconditionally env bndr loop_breaker rhs
852 && not (isExportedId bndr)
854 active = case getMode env of
855 SimplGently -> isAlwaysActive prag
856 SimplPhase n -> isActive n prag
857 prag = idInlinePragma bndr
860 blackListInline tells if we must not inline at a call site because the
861 Id's inline pragma says not to do so.
863 However, blackListInline is ignored for things with with Compulsory inlinings,
864 because they don't have bindings, so we must inline them no matter how
868 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
869 activeInline env id occ
870 = case getMode env of
871 SimplGently -> isOneOcc occ
872 -- No inlining at all when doing gentle stuff,
873 -- except for things that occur once
874 -- The reason is that too little clean-up happens if you
875 -- don't inline use-once things. Also a bit of inlining is *good* for
876 -- full laziness; it can expose constant sub-expressions.
877 -- Example in spectral/mandel/Mandel.hs, where the mandelset
878 -- function gets a useful let-float if you inline windowToViewport
880 -- NB: we used to have a second exception, for data con wrappers.
881 -- On the grounds that we use gentle mode for rule LHSs, and
882 -- they match better when data con wrappers are inlined.
883 -- But that only really applies to the trivial wrappers (like (:)),
884 -- and they are now constructed as Compulsory unfoldings (in MkId)
885 -- so they'll happen anyway.
887 SimplPhase n -> isActive n (idInlinePragma id)
889 -- Belongs in BasicTypes; this frag occurs in OccurAnal too
890 isOneOcc (OneOcc _ _) = True
891 isOneOcc other = False
893 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
894 -- Nothing => No rules at all
896 = case getMode env of
897 SimplGently -> Nothing -- No rules in gentle mode
898 SimplPhase n -> Just (isActive n)
902 %************************************************************************
904 \subsubsection{Command-line switches}
906 %************************************************************************
909 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
910 getSimplIntSwitch chkr switch
911 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
913 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
915 switchIsOn lookup_fn switch
916 = case (lookup_fn switch) of
917 SwBool False -> False
920 intSwitchSet :: (switch -> SwitchResult)
924 intSwitchSet lookup_fn switch
925 = case (lookup_fn (switch (panic "intSwitchSet"))) of
926 SwInt int -> Just int
932 type SwitchChecker = SimplifierSwitch -> SwitchResult
935 = SwBool Bool -- on/off
936 | SwString FAST_STRING -- nothing or a String
937 | SwInt Int -- nothing or an Int
939 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
940 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
941 -- in the list; defaults right at the end.
943 tidied_on_switches = foldl rm_dups [] on_switches
944 -- The fold*l* ensures that we keep the latest switches;
945 -- ie the ones that occur earliest in the list.
947 sw_tbl :: Array Int SwitchResult
948 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
952 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
954 defined_elems = map mk_assoc_elem tidied_on_switches
956 -- (avoid some unboxing, bounds checking, and other horrible things:)
957 #if __GLASGOW_HASKELL__ < 405
958 case sw_tbl of { Array bounds_who_needs_'em stuff ->
960 case sw_tbl of { Array _ _ stuff ->
963 case (indexArray# stuff (tagOf_SimplSwitch switch)) of
964 #if __GLASGOW_HASKELL__ < 400
966 #elif __GLASGOW_HASKELL__ < 403
973 mk_assoc_elem k@(MaxSimplifierIterations lvl)
974 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
976 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
978 -- cannot have duplicates if we are going to use the array thing
979 rm_dups switches_so_far switch
980 = if switch `is_elem` switches_so_far
982 else switch : switches_so_far
984 sw `is_elem` [] = False
985 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
989 These things behave just like enumeration types.
992 instance Eq SimplifierSwitch where
993 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
995 instance Ord SimplifierSwitch where
996 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
997 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
1000 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
1001 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
1003 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
1005 lAST_SIMPL_SWITCH_TAG = 2