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, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
10 OutExprStuff, OutStuff,
12 -- The continuation type
13 SimplCont(..), DupFlag(..), contIsDupable, contResultType,
14 contIsInteresting, pushArgs, discardCont, countValArgs, countArgs,
15 contArgs, contIsInline, discardInline,
19 initSmpl, returnSmpl, thenSmpl, thenSmpl_,
20 mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
22 -- The inlining black-list
26 getUniqueSmpl, getUniquesSmpl,
32 getSimplCount, zeroSimplCount, pprSimplCount,
33 plusSimplCount, isZeroSimplCount,
36 SwitchChecker, getSwitchChecker, getSimplIntSwitch,
39 getEnclosingCC, setEnclosingCC,
42 getEnv, setAllExceptInScope,
44 getSubstEnv, extendSubst, extendSubstList,
45 getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
46 setSubstEnv, zapSubstEnv,
47 getSimplBinderStuff, setSimplBinderStuff,
51 #include "HsVersions.h"
53 import Const ( Con(DEFAULT) )
54 import Id ( Id, mkSysLocal, isConstantId )
55 import IdInfo ( InlinePragInfo(..) )
56 import Demand ( Demand )
58 import PprCore () -- Instances
59 import Rules ( RuleBase )
60 import CostCentre ( CostCentreStack, subsumedCCS )
61 import Name ( isLocallyDefined )
65 import qualified Subst
66 import Subst ( Subst, emptySubst, mkSubst,
67 substTy, substEnv, substExpr,
68 InScopeSet, substInScope, isInScope, lookupInScope
70 import Type ( Type, TyVarSubst, applyTy )
71 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
75 import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
76 opt_PprStyle_Debug, opt_HistorySize,
79 import Unique ( Unique )
80 import Maybes ( expectJust )
81 import Util ( zipWithEqual )
84 infixr 9 `thenSmpl`, `thenSmpl_`
87 %************************************************************************
89 \subsection[Simplify-types]{Type declarations}
91 %************************************************************************
94 type InBinder = CoreBndr
95 type InId = Id -- Not yet cloned
96 type InType = Type -- Ditto
97 type InBind = CoreBind
98 type InExpr = CoreExpr
102 type OutBinder = CoreBndr
103 type OutId = Id -- Cloned
104 type OutType = Type -- Cloned
105 type OutBind = CoreBind
106 type OutExpr = CoreExpr
107 type OutAlt = CoreAlt
108 type OutArg = CoreArg
110 type SwitchChecker = SimplifierSwitch -> SwitchResult
114 %************************************************************************
116 \subsection{The continuation data type}
118 %************************************************************************
121 type OutExprStuff = OutStuff (InScopeSet, OutExpr)
122 type OutStuff a = ([OutBind], a)
123 -- We return something equivalent to (let b in e), but
124 -- in pieces to avoid the quadratic blowup when floating
125 -- incrementally. Comments just before simplExprB in Simplify.lhs
127 data SimplCont -- Strict contexts
128 = Stop OutType -- Type of the result
130 | CoerceIt OutType -- The To-type, simplified
133 | InlinePlease -- This continuation makes a function very
134 SimplCont -- keen to inline itelf
137 InExpr SubstEnv -- The argument, as yet unsimplified,
138 SimplCont -- and its subst-env
141 InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
144 | ArgOf DupFlag -- An arbitrary strict context: the argument
145 -- of a strict function, or a primitive-arg fn
147 OutType -- The type of the expression being sought by the context
148 -- f (error "foo") ==> coerce t (error "foo")
150 -- We need to know the type t, to which to coerce.
151 (OutExpr -> SimplM OutExprStuff) -- What to do with the result
153 instance Outputable SimplCont where
154 ppr (Stop _) = ptext SLIT("Stop")
155 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
156 ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
157 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
158 (nest 4 (ppr alts)) $$ ppr cont
159 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
160 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
162 data DupFlag = OkToDup | NoDup
164 instance Outputable DupFlag where
165 ppr OkToDup = ptext SLIT("ok")
166 ppr NoDup = ptext SLIT("nodup")
168 contIsDupable :: SimplCont -> Bool
169 contIsDupable (Stop _) = True
170 contIsDupable (ApplyTo OkToDup _ _ _) = True
171 contIsDupable (ArgOf OkToDup _ _) = True
172 contIsDupable (Select OkToDup _ _ _ _) = True
173 contIsDupable (CoerceIt _ cont) = contIsDupable cont
174 contIsDupable (InlinePlease cont) = contIsDupable cont
175 contIsDupable other = False
177 contArgs :: InScopeSet -> SimplCont -> ([OutExpr], SimplCont)
178 -- Get the arguments from the continuation
179 -- Apply the appropriate substitution first;
180 -- this is done lazily and typically only the bit at the top is used
181 contArgs in_scope (ApplyTo _ e s cont)
182 = case contArgs in_scope cont of
183 (args, result) -> (substExpr (mkSubst in_scope s) e : args, result)
184 contArgs in_scope result_cont
187 contIsInline :: SimplCont -> Bool
188 contIsInline (InlinePlease cont) = True
189 contIsInline other = False
191 discardInline :: SimplCont -> SimplCont
192 discardInline (InlinePlease cont) = cont
193 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
194 discardInline cont = cont
198 Comment about contIsInteresting
199 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
200 We want to avoid inlining an expression where there can't possibly be
201 any gain, such as in an argument position. Hence, if the continuation
202 is interesting (eg. a case scrutinee, application etc.) then we
203 inline, otherwise we don't.
205 Previously some_benefit used to return True only if the variable was
206 applied to some value arguments. This didn't work:
208 let x = _coerce_ (T Int) Int (I# 3) in
209 case _coerce_ Int (T Int) x of
212 we want to inline x, but can't see that it's a constructor in a case
213 scrutinee position, and some_benefit is False.
217 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
219 .... case dMonadST _@_ x0 of (a,b,c) -> ....
221 we'd really like to inline dMonadST here, but we *don't* want to
222 inline if the case expression is just
224 case x of y { DEFAULT -> ... }
226 since we can just eliminate this case instead (x is in WHNF). Similar
227 applies when x is bound to a lambda expression. Hence
228 contIsInteresting looks for case expressions with just a single
232 contIsInteresting :: SimplCont -> Bool
233 contIsInteresting (Select _ _ alts _ _) = not (just_default alts)
234 contIsInteresting (CoerceIt _ cont) = contIsInteresting cont
235 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
236 contIsInteresting (ApplyTo _ _ _ _) = True
238 contIsInteresting (ArgOf _ _ _) = False
239 -- If this call is the arg of a strict function, the context
240 -- is a bit interesting. If we inline here, we may get useful
241 -- evaluation information to avoid repeated evals: e.g.
243 -- Here the contIsInteresting makes the '*' keener to inline,
244 -- which in turn exposes a constructor which makes the '+' inline.
245 -- Assuming that +,* aren't small enough to inline regardless.
247 -- HOWEVER, I put this back to False when I discovered that strings
248 -- were getting inlined straight back into applications of 'error'
249 -- because the latter is strict.
251 -- f = \x -> ...(error s)...
253 contIsInteresting (InlinePlease _) = True
254 contIsInteresting other = False
256 just_default [(DEFAULT,_,_)] = True -- See notes below for why we look
257 just_default alts = False -- for this special case
262 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
263 pushArgs se [] cont = cont
264 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
266 discardCont :: SimplCont -- A continuation, expecting
267 -> SimplCont -- Replace the continuation with a suitable coerce
268 discardCont (Stop to_ty) = Stop to_ty
269 discardCont cont = CoerceIt to_ty (Stop to_ty)
271 to_ty = contResultType cont
273 contResultType :: SimplCont -> OutType
274 contResultType (Stop to_ty) = to_ty
275 contResultType (ArgOf _ to_ty _) = to_ty
276 contResultType (ApplyTo _ _ _ cont) = contResultType cont
277 contResultType (CoerceIt _ cont) = contResultType cont
278 contResultType (InlinePlease cont) = contResultType cont
279 contResultType (Select _ _ _ _ cont) = contResultType cont
281 countValArgs :: SimplCont -> Int
282 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
283 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
284 countValArgs other = 0
286 countArgs :: SimplCont -> Int
287 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
292 %************************************************************************
294 \subsection{Monad plumbing}
296 %************************************************************************
298 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
299 (Command-line switches move around through the explicitly-passed SimplEnv.)
302 type SimplM result -- We thread the unique supply because
303 = SimplEnv -- constantly splitting it is rather expensive
306 -> (result, UniqSupply, SimplCount)
310 seChkr :: SwitchChecker,
311 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
312 seBlackList :: Id -> Bool, -- True => don't inline this Id
313 seSubst :: Subst -- The current substitution
315 -- The range of the substitution is OutType and OutExpr resp
317 -- The substitution is idempotent
318 -- It *must* be applied; things in its domain simply aren't
319 -- bound in the result.
321 -- The substitution usually maps an Id to its clone,
322 -- but if the orig defn is a let-binding, and
323 -- the RHS of the let simplifies to an atom,
324 -- we just add the binding to the substitution and elide the let.
326 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
327 -- The elements of the set may have better IdInfo than the
328 -- occurrences of in-scope Ids, and (more important) they will
329 -- have a correctly-substituted type. So we use a lookup in this
330 -- set to replace occurrences
334 initSmpl :: SwitchChecker
335 -> UniqSupply -- No init count; set to 0
336 -> VarSet -- In scope (usually empty, but useful for nested calls)
337 -> (Id -> Bool) -- Black-list function
341 initSmpl chkr us in_scope black_list m
342 = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
343 (result, _, count) -> (result, count)
346 {-# INLINE thenSmpl #-}
347 {-# INLINE thenSmpl_ #-}
348 {-# INLINE returnSmpl #-}
350 returnSmpl :: a -> SimplM a
351 returnSmpl e env us sc = (e, us, sc)
353 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
354 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
356 thenSmpl m k env us0 sc0
357 = case (m env us0 sc0) of
358 (m_result, us1, sc1) -> k m_result env us1 sc1
360 thenSmpl_ m k env us0 sc0
361 = case (m env us0 sc0) of
362 (_, us1, sc1) -> k env us1 sc1
367 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
368 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
370 mapSmpl f [] = returnSmpl []
372 = f x `thenSmpl` \ x' ->
373 mapSmpl f xs `thenSmpl` \ xs' ->
376 mapAndUnzipSmpl f [] = returnSmpl ([],[])
377 mapAndUnzipSmpl f (x:xs)
378 = f x `thenSmpl` \ (r1, r2) ->
379 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
380 returnSmpl (r1:rs1, r2:rs2)
382 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
383 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
384 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
385 returnSmpl (acc'', x':xs')
389 %************************************************************************
391 \subsection{The unique supply}
393 %************************************************************************
396 getUniqueSmpl :: SimplM Unique
397 getUniqueSmpl env us sc = case splitUniqSupply us of
398 (us1, us2) -> (uniqFromSupply us1, us2, sc)
400 getUniquesSmpl :: Int -> SimplM [Unique]
401 getUniquesSmpl n env us sc = case splitUniqSupply us of
402 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
406 %************************************************************************
408 \subsection{Counting up what we've done}
410 %************************************************************************
413 getSimplCount :: SimplM SimplCount
414 getSimplCount env us sc = (sc, us, sc)
416 tick :: Tick -> SimplM ()
417 tick t env us sc = sc' `seq` ((), us, sc')
421 freeTick :: Tick -> SimplM ()
422 -- Record a tick, but don't add to the total tick count, which is
423 -- used to decide when nothing further has happened
424 freeTick t env us sc = sc' `seq` ((), us, sc')
426 sc' = doFreeTick t sc
430 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
432 -- Defined both with and without debugging
433 zeroSimplCount :: SimplCount
434 isZeroSimplCount :: SimplCount -> Bool
435 pprSimplCount :: SimplCount -> SDoc
436 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
437 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
442 ----------------------------------------------------------
444 ----------------------------------------------------------
445 type SimplCount = Int
449 isZeroSimplCount n = n==0
451 doTick t n = n+1 -- Very basic when not debugging
452 doFreeTick t n = n -- Don't count leaf visits
454 pprSimplCount n = ptext SLIT("Total ticks:") <+> int n
456 plusSimplCount n m = n+m
459 ----------------------------------------------------------
461 ----------------------------------------------------------
463 data SimplCount = SimplCount {
464 ticks :: !Int, -- Total ticks
465 details :: !TickCounts, -- How many of each type
467 log1 :: [Tick], -- Last N events; <= opt_HistorySize
468 log2 :: [Tick] -- Last opt_HistorySize events before that
471 type TickCounts = FiniteMap Tick Int
473 zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
474 n_log = 0, log1 = [], log2 = []}
476 isZeroSimplCount sc = ticks sc == 0
478 doFreeTick tick sc@SimplCount { details = dts }
479 = dts' `seqFM` sc { details = dts' }
481 dts' = dts `addTick` tick
483 -- Gross hack to persuade GHC 3.03 to do this important seq
484 seqFM fm x | isEmptyFM fm = x
487 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
488 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
489 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
491 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
493 -- Don't use plusFM_C because that's lazy, and we want to
494 -- be pretty strict here!
495 addTick :: TickCounts -> Tick -> TickCounts
496 addTick fm tick = case lookupFM fm tick of
497 Nothing -> addToFM fm tick 1
498 Just n -> n1 `seq` addToFM fm tick n1
502 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
503 sc2@(SimplCount { ticks = tks2, details = dts2 })
504 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
506 -- A hackish way of getting recent log info
507 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
508 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
512 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
513 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
515 pprTickCounts (fmToList dts),
516 if verboseSimplStats then
518 ptext SLIT("Log (most recent first)"),
519 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
523 pprTickCounts :: [(Tick,Int)] -> SDoc
524 pprTickCounts [] = empty
525 pprTickCounts ((tick1,n1):ticks)
526 = vcat [int tot_n <+> text (tickString tick1),
527 pprTCDetails real_these,
531 tick1_tag = tickToTag tick1
532 (these, others) = span same_tick ticks
533 real_these = (tick1,n1):these
534 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
535 tot_n = sum [n | (_,n) <- real_these]
537 pprTCDetails ticks@((tick,_):_)
538 | verboseSimplStats || isRuleFired tick
539 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
545 %************************************************************************
549 %************************************************************************
553 = PreInlineUnconditionally Id
554 | PostInlineUnconditionally Id
557 | RuleFired FAST_STRING -- Rule name
559 | LetFloatFromLet Id -- Thing floated out
560 | EtaExpansion Id -- LHS binder
561 | EtaReduction Id -- Binder on outer lambda
562 | BetaReduction Id -- Lambda binder
565 | CaseOfCase Id -- Bndr on *inner* case
566 | KnownBranch Id -- Case binder
567 | CaseMerge Id -- Binder on outer case
568 | CaseElim Id -- Case binder
569 | CaseIdentity Id -- Case binder
570 | FillInCaseDefault Id -- Case binder
573 | SimplifierDone -- Ticked at each iteration of the simplifier
575 isRuleFired (RuleFired _) = True
576 isRuleFired other = False
578 instance Outputable Tick where
579 ppr tick = text (tickString tick) <+> pprTickCts tick
581 instance Eq Tick where
582 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
584 instance Ord Tick where
587 tickToTag :: Tick -> Int
588 tickToTag (PreInlineUnconditionally _) = 0
589 tickToTag (PostInlineUnconditionally _) = 1
590 tickToTag (UnfoldingDone _) = 2
591 tickToTag (RuleFired _) = 3
592 tickToTag (LetFloatFromLet _) = 4
593 tickToTag (EtaExpansion _) = 5
594 tickToTag (EtaReduction _) = 6
595 tickToTag (BetaReduction _) = 7
596 tickToTag (CaseOfCase _) = 8
597 tickToTag (KnownBranch _) = 9
598 tickToTag (CaseMerge _) = 10
599 tickToTag (CaseElim _) = 11
600 tickToTag (CaseIdentity _) = 12
601 tickToTag (FillInCaseDefault _) = 13
602 tickToTag BottomFound = 14
603 tickToTag SimplifierDone = 16
605 tickString :: Tick -> String
606 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
607 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
608 tickString (UnfoldingDone _) = "UnfoldingDone"
609 tickString (RuleFired _) = "RuleFired"
610 tickString (LetFloatFromLet _) = "LetFloatFromLet"
611 tickString (EtaExpansion _) = "EtaExpansion"
612 tickString (EtaReduction _) = "EtaReduction"
613 tickString (BetaReduction _) = "BetaReduction"
614 tickString (CaseOfCase _) = "CaseOfCase"
615 tickString (KnownBranch _) = "KnownBranch"
616 tickString (CaseMerge _) = "CaseMerge"
617 tickString (CaseElim _) = "CaseElim"
618 tickString (CaseIdentity _) = "CaseIdentity"
619 tickString (FillInCaseDefault _) = "FillInCaseDefault"
620 tickString BottomFound = "BottomFound"
621 tickString SimplifierDone = "SimplifierDone"
623 pprTickCts :: Tick -> SDoc
624 pprTickCts (PreInlineUnconditionally v) = ppr v
625 pprTickCts (PostInlineUnconditionally v)= ppr v
626 pprTickCts (UnfoldingDone v) = ppr v
627 pprTickCts (RuleFired v) = ppr v
628 pprTickCts (LetFloatFromLet v) = ppr v
629 pprTickCts (EtaExpansion v) = ppr v
630 pprTickCts (EtaReduction v) = ppr v
631 pprTickCts (BetaReduction v) = ppr v
632 pprTickCts (CaseOfCase v) = ppr v
633 pprTickCts (KnownBranch v) = ppr v
634 pprTickCts (CaseMerge v) = ppr v
635 pprTickCts (CaseElim v) = ppr v
636 pprTickCts (CaseIdentity v) = ppr v
637 pprTickCts (FillInCaseDefault v) = ppr v
638 pprTickCts other = empty
640 cmpTick :: Tick -> Tick -> Ordering
641 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
643 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
646 -- Always distinguish RuleFired, so that the stats
647 -- can report them even in non-verbose mode
649 cmpEqTick :: Tick -> Tick -> Ordering
650 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
651 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
652 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
653 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
654 cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b
655 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
656 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
657 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
658 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
659 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
660 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
661 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
662 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
663 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
664 cmpEqTick other1 other2 = EQ
668 %************************************************************************
670 \subsubsection{Command-line switches}
672 %************************************************************************
675 getSwitchChecker :: SimplM SwitchChecker
676 getSwitchChecker env us sc = (seChkr env, us, sc)
678 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
679 getSimplIntSwitch chkr switch
680 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
684 @switchOffInlining@ is used to prepare the environment for simplifying
685 the RHS of an Id that's marked with an INLINE pragma. It is going to
686 be inlined wherever they are used, and then all the inlining will take
687 effect. Meanwhile, there isn't much point in doing anything to the
688 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
690 (a) not doing so will inline a worker straight back into its wrapper!
692 and (b) Consider the following example
697 in ...g...g...g...g...g...
699 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
700 and thence copied multiple times when g is inlined.
702 Andy disagrees! Example:
703 all xs = foldr (&&) True xs
704 any p = all . map p {-# INLINE any #-}
706 Problem: any won't get deforested, and so if it's exported and
707 the importer doesn't use the inlining, (eg passes it as an arg)
708 then we won't get deforestation at all.
709 We havn't solved this problem yet!
711 We prepare the envt by simply modifying the in_scope_env, which has all the
712 unfolding info. At one point we did it by modifying the chkr so that
713 it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
714 important, simplifications happening in the body of the RHS.
718 We *don't* prevent inlining from happening for identifiers
719 that are marked as IMustBeINLINEd. An example of where
720 doing this is crucial is:
722 class Bar a => Foo a where
728 If `f' needs to peer inside Foo's superclass, Bar, it refers
729 to the appropriate super class selector, which is marked as
730 must-inlineable. We don't generate any code for a superclass
731 selector, so failing to inline it in the RHS of `f' will
732 leave a reference to a non-existent id, with bad consequences.
734 ALSO NOTE that we do all this by modifing the inline-pragma,
735 not by zapping the unfolding. The latter may still be useful for
736 knowing when something is evaluated.
738 June 98 update: I've gone back to dealing with this by adding
739 the EssentialUnfoldingsOnly switch. That doesn't stop essential
740 unfoldings, nor inlineUnconditionally stuff; and the thing's going
741 to be inlined at every call site anyway. Running over the whole
742 environment seems like wild overkill.
745 switchOffInlining :: SimplM a -> SimplM a
746 switchOffInlining m env us sc
747 = m (env { seBlackList = \v -> (v `isInScope` subst) || not (isLocallyDefined v)
749 -- Black list anything that is in scope or imported.
750 -- The in-scope thing arranges *not* to black list inlinings that are
751 -- completely inside the switch-off-inlining block.
752 -- This allows simplification to proceed un-hindered inside the block.
754 -- At one time I had an exception for constant Ids (constructors, primops)
755 -- && (old_black_list v || not (isConstantId v ))
756 -- because (a) some don't have bindings, so we never want not to inline them
757 -- (b) their defns are very seldom big, so there's no size penalty
759 -- But that failed because if we inline (say) [] in build's rhs, then
760 -- the exported thing doesn't match rules
763 old_black_list = seBlackList env
767 %************************************************************************
769 \subsubsection{The ``enclosing cost-centre''}
771 %************************************************************************
774 getEnclosingCC :: SimplM CostCentreStack
775 getEnclosingCC env us sc = (seCC env, us, sc)
777 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
778 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
782 %************************************************************************
784 \subsubsection{The @SimplEnv@ type}
786 %************************************************************************
790 emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
792 emptySimplEnv sw_chkr in_scope black_list
793 = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
794 seBlackList = black_list,
795 seSubst = mkSubst in_scope emptySubstEnv }
796 -- The top level "enclosing CC" is "SUBSUMED".
798 getEnv :: SimplM SimplEnv
799 getEnv env us sc = (env, us, sc)
801 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
802 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m
803 (SimplEnv {seSubst = old_subst}) us sc
804 = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
806 getSubst :: SimplM Subst
807 getSubst env us sc = (seSubst env, us, sc)
809 getBlackList :: SimplM (Id -> Bool)
810 getBlackList env us sc = (seBlackList env, us, sc)
812 setSubst :: Subst -> SimplM a -> SimplM a
813 setSubst subst m env us sc = m (env {seSubst = subst}) us sc
815 getSubstEnv :: SimplM SubstEnv
816 getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
818 extendInScope :: CoreBndr -> SimplM a -> SimplM a
819 extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
820 = m (env {seSubst = Subst.extendInScope subst v}) us sc
822 extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
823 extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
824 = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
826 getInScope :: SimplM InScopeSet
827 getInScope env us sc = (substInScope (seSubst env), us, sc)
829 setInScope :: InScopeSet -> SimplM a -> SimplM a
830 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
831 = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
833 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
834 modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc
835 = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
837 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
838 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
839 = m (env { seSubst = Subst.extendSubst subst var res }) us sc
841 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
842 extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
843 = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
845 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
846 setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
847 = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
849 zapSubstEnv :: SimplM a -> SimplM a
850 zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
851 = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
853 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
854 getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
855 = ((subst, us), us, sc)
857 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
858 setSimplBinderStuff (subst, us) m env _ sc
859 = m (env {seSubst = subst}) us sc
864 newId :: Type -> (Id -> SimplM a) -> SimplM a
865 -- Extends the in-scope-env too
866 newId ty m env@(SimplEnv {seSubst = subst}) us sc
867 = case splitUniqSupply us of
868 (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
870 v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
872 newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
873 newIds tys m env@(SimplEnv {seSubst = subst}) us sc
874 = case splitUniqSupply us of
875 (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
877 vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
878 (uniqsFromSupply (length tys) us1) tys