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, getIdUnfolding )
55 import IdInfo ( InlinePragInfo(..) )
56 import Demand ( Demand )
58 import CoreUnfold ( isCompulsoryUnfolding )
59 import PprCore () -- Instances
60 import Rules ( RuleBase )
61 import CostCentre ( CostCentreStack, subsumedCCS )
62 import Name ( isLocallyDefined )
66 import qualified Subst
67 import Subst ( Subst, emptySubst, mkSubst,
68 substTy, substEnv, substExpr,
69 InScopeSet, substInScope, isInScope, lookupInScope
71 import Type ( Type, TyVarSubst, applyTy )
72 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
76 import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
77 opt_PprStyle_Debug, opt_HistorySize,
80 import Unique ( Unique )
81 import Maybes ( expectJust )
82 import Util ( zipWithEqual )
85 infixr 9 `thenSmpl`, `thenSmpl_`
88 %************************************************************************
90 \subsection[Simplify-types]{Type declarations}
92 %************************************************************************
95 type InBinder = CoreBndr
96 type InId = Id -- Not yet cloned
97 type InType = Type -- Ditto
98 type InBind = CoreBind
99 type InExpr = CoreExpr
103 type OutBinder = CoreBndr
104 type OutId = Id -- Cloned
105 type OutType = Type -- Cloned
106 type OutBind = CoreBind
107 type OutExpr = CoreExpr
108 type OutAlt = CoreAlt
109 type OutArg = CoreArg
111 type SwitchChecker = SimplifierSwitch -> SwitchResult
115 %************************************************************************
117 \subsection{The continuation data type}
119 %************************************************************************
122 type OutExprStuff = OutStuff (InScopeSet, OutExpr)
123 type OutStuff a = ([OutBind], a)
124 -- We return something equivalent to (let b in e), but
125 -- in pieces to avoid the quadratic blowup when floating
126 -- incrementally. Comments just before simplExprB in Simplify.lhs
128 data SimplCont -- Strict contexts
129 = Stop OutType -- Type of the result
131 | CoerceIt OutType -- The To-type, simplified
134 | InlinePlease -- This continuation makes a function very
135 SimplCont -- keen to inline itelf
138 InExpr SubstEnv -- The argument, as yet unsimplified,
139 SimplCont -- and its subst-env
142 InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
145 | ArgOf DupFlag -- An arbitrary strict context: the argument
146 -- of a strict function, or a primitive-arg fn
148 OutType -- The type of the expression being sought by the context
149 -- f (error "foo") ==> coerce t (error "foo")
151 -- We need to know the type t, to which to coerce.
152 (OutExpr -> SimplM OutExprStuff) -- What to do with the result
154 instance Outputable SimplCont where
155 ppr (Stop _) = ptext SLIT("Stop")
156 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
157 ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
158 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
159 (nest 4 (ppr alts)) $$ ppr cont
160 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
161 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
163 data DupFlag = OkToDup | NoDup
165 instance Outputable DupFlag where
166 ppr OkToDup = ptext SLIT("ok")
167 ppr NoDup = ptext SLIT("nodup")
169 contIsDupable :: SimplCont -> Bool
170 contIsDupable (Stop _) = True
171 contIsDupable (ApplyTo OkToDup _ _ _) = True
172 contIsDupable (ArgOf OkToDup _ _) = True
173 contIsDupable (Select OkToDup _ _ _ _) = True
174 contIsDupable (CoerceIt _ cont) = contIsDupable cont
175 contIsDupable (InlinePlease cont) = contIsDupable cont
176 contIsDupable other = False
178 contArgs :: InScopeSet -> SimplCont -> ([OutExpr], SimplCont)
179 -- Get the arguments from the continuation
180 -- Apply the appropriate substitution first;
181 -- this is done lazily and typically only the bit at the top is used
182 contArgs in_scope (ApplyTo _ e s cont)
183 = case contArgs in_scope cont of
184 (args, result) -> (substExpr (mkSubst in_scope s) e : args, result)
185 contArgs in_scope result_cont
188 contIsInline :: SimplCont -> Bool
189 contIsInline (InlinePlease cont) = True
190 contIsInline other = False
192 discardInline :: SimplCont -> SimplCont
193 discardInline (InlinePlease cont) = cont
194 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
195 discardInline cont = cont
199 Comment about contIsInteresting
200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
201 We want to avoid inlining an expression where there can't possibly be
202 any gain, such as in an argument position. Hence, if the continuation
203 is interesting (eg. a case scrutinee, application etc.) then we
204 inline, otherwise we don't.
206 Previously some_benefit used to return True only if the variable was
207 applied to some value arguments. This didn't work:
209 let x = _coerce_ (T Int) Int (I# 3) in
210 case _coerce_ Int (T Int) x of
213 we want to inline x, but can't see that it's a constructor in a case
214 scrutinee position, and some_benefit is False.
218 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
220 .... case dMonadST _@_ x0 of (a,b,c) -> ....
222 we'd really like to inline dMonadST here, but we *don't* want to
223 inline if the case expression is just
225 case x of y { DEFAULT -> ... }
227 since we can just eliminate this case instead (x is in WHNF). Similar
228 applies when x is bound to a lambda expression. Hence
229 contIsInteresting looks for case expressions with just a single
233 contIsInteresting :: SimplCont -> Bool
234 contIsInteresting (Select _ _ alts _ _) = not (just_default alts)
235 contIsInteresting (CoerceIt _ cont) = contIsInteresting cont
236 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
237 contIsInteresting (ApplyTo _ _ _ _) = True
239 contIsInteresting (ArgOf _ _ _) = False
240 -- If this call is the arg of a strict function, the context
241 -- is a bit interesting. If we inline here, we may get useful
242 -- evaluation information to avoid repeated evals: e.g.
244 -- Here the contIsInteresting makes the '*' keener to inline,
245 -- which in turn exposes a constructor which makes the '+' inline.
246 -- Assuming that +,* aren't small enough to inline regardless.
248 -- HOWEVER, I put this back to False when I discovered that strings
249 -- were getting inlined straight back into applications of 'error'
250 -- because the latter is strict.
252 -- f = \x -> ...(error s)...
254 contIsInteresting (InlinePlease _) = True
255 contIsInteresting other = False
257 just_default [(DEFAULT,_,_)] = True -- See notes below for why we look
258 just_default alts = False -- for this special case
263 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
264 pushArgs se [] cont = cont
265 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
267 discardCont :: SimplCont -- A continuation, expecting
268 -> SimplCont -- Replace the continuation with a suitable coerce
269 discardCont (Stop to_ty) = Stop to_ty
270 discardCont cont = CoerceIt to_ty (Stop to_ty)
272 to_ty = contResultType cont
274 contResultType :: SimplCont -> OutType
275 contResultType (Stop to_ty) = to_ty
276 contResultType (ArgOf _ to_ty _) = to_ty
277 contResultType (ApplyTo _ _ _ cont) = contResultType cont
278 contResultType (CoerceIt _ cont) = contResultType cont
279 contResultType (InlinePlease cont) = contResultType cont
280 contResultType (Select _ _ _ _ cont) = contResultType cont
282 countValArgs :: SimplCont -> Int
283 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
284 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
285 countValArgs other = 0
287 countArgs :: SimplCont -> Int
288 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
293 %************************************************************************
295 \subsection{Monad plumbing}
297 %************************************************************************
299 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
300 (Command-line switches move around through the explicitly-passed SimplEnv.)
303 type SimplM result -- We thread the unique supply because
304 = SimplEnv -- constantly splitting it is rather expensive
307 -> (result, UniqSupply, SimplCount)
311 seChkr :: SwitchChecker,
312 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
313 seBlackList :: Id -> Bool, -- True => don't inline this Id
314 seSubst :: Subst -- The current substitution
316 -- The range of the substitution is OutType and OutExpr resp
318 -- The substitution is idempotent
319 -- It *must* be applied; things in its domain simply aren't
320 -- bound in the result.
322 -- The substitution usually maps an Id to its clone,
323 -- but if the orig defn is a let-binding, and
324 -- the RHS of the let simplifies to an atom,
325 -- we just add the binding to the substitution and elide the let.
327 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
328 -- The elements of the set may have better IdInfo than the
329 -- occurrences of in-scope Ids, and (more important) they will
330 -- have a correctly-substituted type. So we use a lookup in this
331 -- set to replace occurrences
335 initSmpl :: SwitchChecker
336 -> UniqSupply -- No init count; set to 0
337 -> VarSet -- In scope (usually empty, but useful for nested calls)
338 -> (Id -> Bool) -- Black-list function
342 initSmpl chkr us in_scope black_list m
343 = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
344 (result, _, count) -> (result, count)
347 {-# INLINE thenSmpl #-}
348 {-# INLINE thenSmpl_ #-}
349 {-# INLINE returnSmpl #-}
351 returnSmpl :: a -> SimplM a
352 returnSmpl e env us sc = (e, us, sc)
354 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
355 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
357 thenSmpl m k env us0 sc0
358 = case (m env us0 sc0) of
359 (m_result, us1, sc1) -> k m_result env us1 sc1
361 thenSmpl_ m k env us0 sc0
362 = case (m env us0 sc0) of
363 (_, us1, sc1) -> k env us1 sc1
368 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
369 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
371 mapSmpl f [] = returnSmpl []
373 = f x `thenSmpl` \ x' ->
374 mapSmpl f xs `thenSmpl` \ xs' ->
377 mapAndUnzipSmpl f [] = returnSmpl ([],[])
378 mapAndUnzipSmpl f (x:xs)
379 = f x `thenSmpl` \ (r1, r2) ->
380 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
381 returnSmpl (r1:rs1, r2:rs2)
383 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
384 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
385 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
386 returnSmpl (acc'', x':xs')
390 %************************************************************************
392 \subsection{The unique supply}
394 %************************************************************************
397 getUniqueSmpl :: SimplM Unique
398 getUniqueSmpl env us sc = case splitUniqSupply us of
399 (us1, us2) -> (uniqFromSupply us1, us2, sc)
401 getUniquesSmpl :: Int -> SimplM [Unique]
402 getUniquesSmpl n env us sc = case splitUniqSupply us of
403 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
407 %************************************************************************
409 \subsection{Counting up what we've done}
411 %************************************************************************
414 getSimplCount :: SimplM SimplCount
415 getSimplCount env us sc = (sc, us, sc)
417 tick :: Tick -> SimplM ()
418 tick t env us sc = sc' `seq` ((), us, sc')
422 freeTick :: Tick -> SimplM ()
423 -- Record a tick, but don't add to the total tick count, which is
424 -- used to decide when nothing further has happened
425 freeTick t env us sc = sc' `seq` ((), us, sc')
427 sc' = doFreeTick t sc
431 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
433 -- Defined both with and without debugging
434 zeroSimplCount :: SimplCount
435 isZeroSimplCount :: SimplCount -> Bool
436 pprSimplCount :: SimplCount -> SDoc
437 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
438 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
443 ----------------------------------------------------------
445 ----------------------------------------------------------
446 type SimplCount = Int
450 isZeroSimplCount n = n==0
452 doTick t n = n+1 -- Very basic when not debugging
453 doFreeTick t n = n -- Don't count leaf visits
455 pprSimplCount n = ptext SLIT("Total ticks:") <+> int n
457 plusSimplCount n m = n+m
460 ----------------------------------------------------------
462 ----------------------------------------------------------
464 data SimplCount = SimplCount {
465 ticks :: !Int, -- Total ticks
466 details :: !TickCounts, -- How many of each type
468 log1 :: [Tick], -- Last N events; <= opt_HistorySize
469 log2 :: [Tick] -- Last opt_HistorySize events before that
472 type TickCounts = FiniteMap Tick Int
474 zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
475 n_log = 0, log1 = [], log2 = []}
477 isZeroSimplCount sc = ticks sc == 0
479 doFreeTick tick sc@SimplCount { details = dts }
480 = dts' `seqFM` sc { details = dts' }
482 dts' = dts `addTick` tick
484 -- Gross hack to persuade GHC 3.03 to do this important seq
485 seqFM fm x | isEmptyFM fm = x
488 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
489 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
490 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
492 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
494 -- Don't use plusFM_C because that's lazy, and we want to
495 -- be pretty strict here!
496 addTick :: TickCounts -> Tick -> TickCounts
497 addTick fm tick = case lookupFM fm tick of
498 Nothing -> addToFM fm tick 1
499 Just n -> n1 `seq` addToFM fm tick n1
503 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
504 sc2@(SimplCount { ticks = tks2, details = dts2 })
505 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
507 -- A hackish way of getting recent log info
508 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
509 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
513 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
514 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
516 pprTickCounts (fmToList dts),
517 if verboseSimplStats then
519 ptext SLIT("Log (most recent first)"),
520 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
524 pprTickCounts :: [(Tick,Int)] -> SDoc
525 pprTickCounts [] = empty
526 pprTickCounts ((tick1,n1):ticks)
527 = vcat [int tot_n <+> text (tickString tick1),
528 pprTCDetails real_these,
532 tick1_tag = tickToTag tick1
533 (these, others) = span same_tick ticks
534 real_these = (tick1,n1):these
535 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
536 tot_n = sum [n | (_,n) <- real_these]
538 pprTCDetails ticks@((tick,_):_)
539 | verboseSimplStats || isRuleFired tick
540 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
546 %************************************************************************
550 %************************************************************************
554 = PreInlineUnconditionally Id
555 | PostInlineUnconditionally Id
558 | RuleFired FAST_STRING -- Rule name
560 | LetFloatFromLet Id -- Thing floated out
561 | EtaExpansion Id -- LHS binder
562 | EtaReduction Id -- Binder on outer lambda
563 | BetaReduction Id -- Lambda binder
566 | CaseOfCase Id -- Bndr on *inner* case
567 | KnownBranch Id -- Case binder
568 | CaseMerge Id -- Binder on outer case
569 | CaseElim Id -- Case binder
570 | CaseIdentity Id -- Case binder
571 | FillInCaseDefault Id -- Case binder
574 | SimplifierDone -- Ticked at each iteration of the simplifier
576 isRuleFired (RuleFired _) = True
577 isRuleFired other = False
579 instance Outputable Tick where
580 ppr tick = text (tickString tick) <+> pprTickCts tick
582 instance Eq Tick where
583 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
585 instance Ord Tick where
588 tickToTag :: Tick -> Int
589 tickToTag (PreInlineUnconditionally _) = 0
590 tickToTag (PostInlineUnconditionally _) = 1
591 tickToTag (UnfoldingDone _) = 2
592 tickToTag (RuleFired _) = 3
593 tickToTag (LetFloatFromLet _) = 4
594 tickToTag (EtaExpansion _) = 5
595 tickToTag (EtaReduction _) = 6
596 tickToTag (BetaReduction _) = 7
597 tickToTag (CaseOfCase _) = 8
598 tickToTag (KnownBranch _) = 9
599 tickToTag (CaseMerge _) = 10
600 tickToTag (CaseElim _) = 11
601 tickToTag (CaseIdentity _) = 12
602 tickToTag (FillInCaseDefault _) = 13
603 tickToTag BottomFound = 14
604 tickToTag SimplifierDone = 16
606 tickString :: Tick -> String
607 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
608 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
609 tickString (UnfoldingDone _) = "UnfoldingDone"
610 tickString (RuleFired _) = "RuleFired"
611 tickString (LetFloatFromLet _) = "LetFloatFromLet"
612 tickString (EtaExpansion _) = "EtaExpansion"
613 tickString (EtaReduction _) = "EtaReduction"
614 tickString (BetaReduction _) = "BetaReduction"
615 tickString (CaseOfCase _) = "CaseOfCase"
616 tickString (KnownBranch _) = "KnownBranch"
617 tickString (CaseMerge _) = "CaseMerge"
618 tickString (CaseElim _) = "CaseElim"
619 tickString (CaseIdentity _) = "CaseIdentity"
620 tickString (FillInCaseDefault _) = "FillInCaseDefault"
621 tickString BottomFound = "BottomFound"
622 tickString SimplifierDone = "SimplifierDone"
624 pprTickCts :: Tick -> SDoc
625 pprTickCts (PreInlineUnconditionally v) = ppr v
626 pprTickCts (PostInlineUnconditionally v)= ppr v
627 pprTickCts (UnfoldingDone v) = ppr v
628 pprTickCts (RuleFired v) = ppr v
629 pprTickCts (LetFloatFromLet v) = ppr v
630 pprTickCts (EtaExpansion v) = ppr v
631 pprTickCts (EtaReduction v) = ppr v
632 pprTickCts (BetaReduction v) = ppr v
633 pprTickCts (CaseOfCase v) = ppr v
634 pprTickCts (KnownBranch v) = ppr v
635 pprTickCts (CaseMerge v) = ppr v
636 pprTickCts (CaseElim v) = ppr v
637 pprTickCts (CaseIdentity v) = ppr v
638 pprTickCts (FillInCaseDefault v) = ppr v
639 pprTickCts other = empty
641 cmpTick :: Tick -> Tick -> Ordering
642 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
644 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
647 -- Always distinguish RuleFired, so that the stats
648 -- can report them even in non-verbose mode
650 cmpEqTick :: Tick -> Tick -> Ordering
651 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
652 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
653 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
654 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
655 cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b
656 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
657 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
658 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
659 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
660 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
661 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
662 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
663 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
664 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
665 cmpEqTick other1 other2 = EQ
669 %************************************************************************
671 \subsubsection{Command-line switches}
673 %************************************************************************
676 getSwitchChecker :: SimplM SwitchChecker
677 getSwitchChecker env us sc = (seChkr env, us, sc)
679 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
680 getSimplIntSwitch chkr switch
681 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
685 @switchOffInlining@ is used to prepare the environment for simplifying
686 the RHS of an Id that's marked with an INLINE pragma. It is going to
687 be inlined wherever they are used, and then all the inlining will take
688 effect. Meanwhile, there isn't much point in doing anything to the
689 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
691 (a) not doing so will inline a worker straight back into its wrapper!
693 and (b) Consider the following example
698 in ...g...g...g...g...g...
700 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
701 and thence copied multiple times when g is inlined.
703 Andy disagrees! Example:
704 all xs = foldr (&&) True xs
705 any p = all . map p {-# INLINE any #-}
707 Problem: any won't get deforested, and so if it's exported and
708 the importer doesn't use the inlining, (eg passes it as an arg)
709 then we won't get deforestation at all.
710 We havn't solved this problem yet!
712 We prepare the envt by simply modifying the in_scope_env, which has all the
713 unfolding info. At one point we did it by modifying the chkr so that
714 it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
715 important, simplifications happening in the body of the RHS.
719 We *don't* prevent inlining from happening for identifiers
720 that are marked as IMustBeINLINEd. An example of where
721 doing this is crucial is:
723 class Bar a => Foo a where
729 If `f' needs to peer inside Foo's superclass, Bar, it refers
730 to the appropriate super class selector, which is marked as
731 must-inlineable. We don't generate any code for a superclass
732 selector, so failing to inline it in the RHS of `f' will
733 leave a reference to a non-existent id, with bad consequences.
735 ALSO NOTE that we do all this by modifing the inline-pragma,
736 not by zapping the unfolding. The latter may still be useful for
737 knowing when something is evaluated.
739 June 98 update: I've gone back to dealing with this by adding
740 the EssentialUnfoldingsOnly switch. That doesn't stop essential
741 unfoldings, nor inlineUnconditionally stuff; and the thing's going
742 to be inlined at every call site anyway. Running over the whole
743 environment seems like wild overkill.
746 switchOffInlining :: SimplM a -> SimplM a
747 switchOffInlining m env us sc
748 = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (getIdUnfolding v)) &&
749 ((v `isInScope` subst) || not (isLocallyDefined v))
751 -- Black list anything that is in scope or imported.
752 -- The in-scope thing arranges *not* to black list inlinings that are
753 -- completely inside the switch-off-inlining block.
754 -- This allows simplification to proceed un-hindered inside the block.
756 -- At one time I had an exception for constant Ids (constructors, primops)
757 -- && (old_black_list v || not (isConstantId v ))
758 -- because (a) some don't have bindings, so we never want not to inline them
759 -- (b) their defns are very seldom big, so there's no size penalty
761 -- But that failed because if we inline (say) [] in build's rhs, then
762 -- the exported thing doesn't match rules
764 -- But we must inline primops (which have compulsory unfoldings) in the
765 -- last phase of simplification, because they don't have bindings.
766 -- The simplifier now *never* inlines blacklisted things (even if they
767 -- have compulsory unfoldings) so we must not black-list compulsory
768 -- unfoldings inside INLINE prags.
771 old_black_list = seBlackList env
775 %************************************************************************
777 \subsubsection{The ``enclosing cost-centre''}
779 %************************************************************************
782 getEnclosingCC :: SimplM CostCentreStack
783 getEnclosingCC env us sc = (seCC env, us, sc)
785 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
786 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
790 %************************************************************************
792 \subsubsection{The @SimplEnv@ type}
794 %************************************************************************
798 emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
800 emptySimplEnv sw_chkr in_scope black_list
801 = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
802 seBlackList = black_list,
803 seSubst = mkSubst in_scope emptySubstEnv }
804 -- The top level "enclosing CC" is "SUBSUMED".
806 getEnv :: SimplM SimplEnv
807 getEnv env us sc = (env, us, sc)
809 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
810 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m
811 (SimplEnv {seSubst = old_subst}) us sc
812 = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
814 getSubst :: SimplM Subst
815 getSubst env us sc = (seSubst env, us, sc)
817 getBlackList :: SimplM (Id -> Bool)
818 getBlackList env us sc = (seBlackList env, us, sc)
820 setSubst :: Subst -> SimplM a -> SimplM a
821 setSubst subst m env us sc = m (env {seSubst = subst}) us sc
823 getSubstEnv :: SimplM SubstEnv
824 getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
826 extendInScope :: CoreBndr -> SimplM a -> SimplM a
827 extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
828 = m (env {seSubst = Subst.extendInScope subst v}) us sc
830 extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
831 extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
832 = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
834 getInScope :: SimplM InScopeSet
835 getInScope env us sc = (substInScope (seSubst env), us, sc)
837 setInScope :: InScopeSet -> SimplM a -> SimplM a
838 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
839 = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
841 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
842 modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc
843 = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
845 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
846 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
847 = m (env { seSubst = Subst.extendSubst subst var res }) us sc
849 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
850 extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
851 = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
853 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
854 setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
855 = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
857 zapSubstEnv :: SimplM a -> SimplM a
858 zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
859 = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
861 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
862 getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
863 = ((subst, us), us, sc)
865 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
866 setSimplBinderStuff (subst, us) m env _ sc
867 = m (env {seSubst = subst}) us sc
872 newId :: Type -> (Id -> SimplM a) -> SimplM a
873 -- Extends the in-scope-env too
874 newId ty m env@(SimplEnv {seSubst = subst}) us sc
875 = case splitUniqSupply us of
876 (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
878 v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
880 newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
881 newIds tys m env@(SimplEnv {seSubst = subst}) us sc
882 = case splitUniqSupply us of
883 (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
885 vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
886 (uniqsFromSupply (length tys) us1) tys