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,
43 getSubstEnv, extendSubst, extendSubstList,
44 getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
45 setSubstEnv, zapSubstEnv,
46 getSimplBinderStuff, setSimplBinderStuff,
50 #include "HsVersions.h"
52 import Const ( Con(DEFAULT) )
53 import Id ( Id, mkSysLocal, idMustBeINLINEd )
54 import IdInfo ( InlinePragInfo(..) )
55 import Demand ( Demand )
57 import PprCore () -- Instances
58 import Rules ( RuleBase )
59 import CostCentre ( CostCentreStack, subsumedCCS )
63 import qualified Subst
64 import Subst ( Subst, emptySubst, mkSubst,
65 substTy, substEnv, substExpr,
66 InScopeSet, substInScope, isInScope, lookupInScope
68 import Type ( Type, TyVarSubst, applyTy )
69 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
73 import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
74 opt_PprStyle_Debug, opt_HistorySize,
77 import Unique ( Unique )
78 import Maybes ( expectJust )
79 import Util ( zipWithEqual )
82 infixr 9 `thenSmpl`, `thenSmpl_`
85 %************************************************************************
87 \subsection[Simplify-types]{Type declarations}
89 %************************************************************************
92 type InBinder = CoreBndr
93 type InId = Id -- Not yet cloned
94 type InType = Type -- Ditto
95 type InBind = CoreBind
96 type InExpr = CoreExpr
100 type OutBinder = CoreBndr
101 type OutId = Id -- Cloned
102 type OutType = Type -- Cloned
103 type OutBind = CoreBind
104 type OutExpr = CoreExpr
105 type OutAlt = CoreAlt
106 type OutArg = CoreArg
108 type SwitchChecker = SimplifierSwitch -> SwitchResult
112 %************************************************************************
114 \subsection{The continuation data type}
116 %************************************************************************
119 type OutExprStuff = OutStuff (InScopeSet, OutExpr)
120 type OutStuff a = ([OutBind], a)
121 -- We return something equivalent to (let b in e), but
122 -- in pieces to avoid the quadratic blowup when floating
123 -- incrementally. Comments just before simplExprB in Simplify.lhs
125 data SimplCont -- Strict contexts
126 = Stop OutType -- Type of the result
128 | CoerceIt OutType -- The To-type, simplified
131 | InlinePlease -- This continuation makes a function very
132 SimplCont -- keen to inline itelf
135 InExpr SubstEnv -- The argument, as yet unsimplified,
136 SimplCont -- and its subst-env
139 InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
142 | ArgOf DupFlag -- An arbitrary strict context: the argument
143 -- of a strict function, or a primitive-arg fn
145 OutType -- The type of the expression being sought by the context
146 -- f (error "foo") ==> coerce t (error "foo")
148 -- We need to know the type t, to which to coerce.
149 (OutExpr -> SimplM OutExprStuff) -- What to do with the result
151 instance Outputable SimplCont where
152 ppr (Stop _) = ptext SLIT("Stop")
153 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
154 ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
155 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
156 (nest 4 (ppr alts)) $$ ppr cont
157 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
158 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
160 data DupFlag = OkToDup | NoDup
162 instance Outputable DupFlag where
163 ppr OkToDup = ptext SLIT("ok")
164 ppr NoDup = ptext SLIT("nodup")
166 contIsDupable :: SimplCont -> Bool
167 contIsDupable (Stop _) = True
168 contIsDupable (ApplyTo OkToDup _ _ _) = True
169 contIsDupable (ArgOf OkToDup _ _) = True
170 contIsDupable (Select OkToDup _ _ _ _) = True
171 contIsDupable (CoerceIt _ cont) = contIsDupable cont
172 contIsDupable (InlinePlease cont) = contIsDupable cont
173 contIsDupable other = False
175 contArgs :: InScopeSet -> SimplCont -> ([OutExpr], SimplCont)
176 -- Get the arguments from the continuation
177 -- Apply the appropriate substitution first;
178 -- this is done lazily and typically only the bit at the top is used
179 contArgs in_scope (ApplyTo _ e s cont)
180 = case contArgs in_scope cont of
181 (args, result) -> (substExpr (mkSubst in_scope s) e : args, result)
182 contArgs in_scope result_cont
185 contIsInline :: SimplCont -> Bool
186 contIsInline (InlinePlease cont) = True
187 contIsInline other = False
189 discardInline :: SimplCont -> SimplCont
190 discardInline (InlinePlease cont) = cont
191 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
192 discardInline cont = cont
196 Comment about contIsInteresting
197 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
198 We want to avoid inlining an expression where there can't possibly be
199 any gain, such as in an argument position. Hence, if the continuation
200 is interesting (eg. a case scrutinee, application etc.) then we
201 inline, otherwise we don't.
203 Previously some_benefit used to return True only if the variable was
204 applied to some value arguments. This didn't work:
206 let x = _coerce_ (T Int) Int (I# 3) in
207 case _coerce_ Int (T Int) x of
210 we want to inline x, but can't see that it's a constructor in a case
211 scrutinee position, and some_benefit is False.
215 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
217 .... case dMonadST _@_ x0 of (a,b,c) -> ....
219 we'd really like to inline dMonadST here, but we *don't* want to
220 inline if the case expression is just
222 case x of y { DEFAULT -> ... }
224 since we can just eliminate this case instead (x is in WHNF). Similar
225 applies when x is bound to a lambda expression. Hence
226 contIsInteresting looks for case expressions with just a single
230 contIsInteresting :: SimplCont -> Bool
231 contIsInteresting (Select _ _ alts _ _) = not (just_default alts)
232 contIsInteresting (CoerceIt _ cont) = contIsInteresting cont
233 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
234 contIsInteresting (ApplyTo _ _ _ _) = True
236 contIsInteresting (ArgOf _ _ _) = False
237 -- If this call is the arg of a strict function, the context
238 -- is a bit interesting. If we inline here, we may get useful
239 -- evaluation information to avoid repeated evals: e.g.
241 -- Here the contIsInteresting makes the '*' keener to inline,
242 -- which in turn exposes a constructor which makes the '+' inline.
243 -- Assuming that +,* aren't small enough to inline regardless.
245 -- HOWEVER, I put this back to False when I discovered that strings
246 -- were getting inlined straight back into applications of 'error'
247 -- because the latter is strict.
249 -- f = \x -> ...(error s)...
251 contIsInteresting (InlinePlease _) = True
252 contIsInteresting other = False
254 just_default [(DEFAULT,_,_)] = True -- See notes below for why we look
255 just_default alts = False -- for this special case
260 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
261 pushArgs se [] cont = cont
262 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
264 discardCont :: SimplCont -- A continuation, expecting
265 -> SimplCont -- Replace the continuation with a suitable coerce
266 discardCont (Stop to_ty) = Stop to_ty
267 discardCont cont = CoerceIt to_ty (Stop to_ty)
269 to_ty = contResultType cont
271 contResultType :: SimplCont -> OutType
272 contResultType (Stop to_ty) = to_ty
273 contResultType (ArgOf _ to_ty _) = to_ty
274 contResultType (ApplyTo _ _ _ cont) = contResultType cont
275 contResultType (CoerceIt _ cont) = contResultType cont
276 contResultType (InlinePlease cont) = contResultType cont
277 contResultType (Select _ _ _ _ cont) = contResultType cont
279 countValArgs :: SimplCont -> Int
280 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
281 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
282 countValArgs other = 0
284 countArgs :: SimplCont -> Int
285 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
290 %************************************************************************
292 \subsection{Monad plumbing}
294 %************************************************************************
296 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
297 (Command-line switches move around through the explicitly-passed SimplEnv.)
300 type SimplM result -- We thread the unique supply because
301 = SimplEnv -- constantly splitting it is rather expensive
304 -> (result, UniqSupply, SimplCount)
308 seChkr :: SwitchChecker,
309 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
310 seBlackList :: Id -> Bool, -- True => don't inline this Id
311 seSubst :: Subst -- The current substitution
313 -- The range of the substitution is OutType and OutExpr resp
315 -- The substitution is idempotent
316 -- It *must* be applied; things in its domain simply aren't
317 -- bound in the result.
319 -- The substitution usually maps an Id to its clone,
320 -- but if the orig defn is a let-binding, and
321 -- the RHS of the let simplifies to an atom,
322 -- we just add the binding to the substitution and elide the let.
324 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
325 -- The elements of the set may have better IdInfo than the
326 -- occurrences of in-scope Ids, and (more important) they will
327 -- have a correctly-substituted type. So we use a lookup in this
328 -- set to replace occurrences
332 initSmpl :: SwitchChecker
333 -> UniqSupply -- No init count; set to 0
334 -> VarSet -- In scope (usually empty, but useful for nested calls)
335 -> (Id -> Bool) -- Black-list function
339 initSmpl chkr us in_scope black_list m
340 = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
341 (result, _, count) -> (result, count)
344 {-# INLINE thenSmpl #-}
345 {-# INLINE thenSmpl_ #-}
346 {-# INLINE returnSmpl #-}
348 returnSmpl :: a -> SimplM a
349 returnSmpl e env us sc = (e, us, sc)
351 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
352 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
354 thenSmpl m k env us0 sc0
355 = case (m env us0 sc0) of
356 (m_result, us1, sc1) -> k m_result env us1 sc1
358 thenSmpl_ m k env us0 sc0
359 = case (m env us0 sc0) of
360 (_, us1, sc1) -> k env us1 sc1
365 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
366 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
368 mapSmpl f [] = returnSmpl []
370 = f x `thenSmpl` \ x' ->
371 mapSmpl f xs `thenSmpl` \ xs' ->
374 mapAndUnzipSmpl f [] = returnSmpl ([],[])
375 mapAndUnzipSmpl f (x:xs)
376 = f x `thenSmpl` \ (r1, r2) ->
377 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
378 returnSmpl (r1:rs1, r2:rs2)
380 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
381 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
382 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
383 returnSmpl (acc'', x':xs')
387 %************************************************************************
389 \subsection{The unique supply}
391 %************************************************************************
394 getUniqueSmpl :: SimplM Unique
395 getUniqueSmpl env us sc = case splitUniqSupply us of
396 (us1, us2) -> (uniqFromSupply us1, us2, sc)
398 getUniquesSmpl :: Int -> SimplM [Unique]
399 getUniquesSmpl n env us sc = case splitUniqSupply us of
400 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
404 %************************************************************************
406 \subsection{Counting up what we've done}
408 %************************************************************************
411 getSimplCount :: SimplM SimplCount
412 getSimplCount env us sc = (sc, us, sc)
414 tick :: Tick -> SimplM ()
415 tick t env us sc = sc' `seq` ((), us, sc')
419 freeTick :: Tick -> SimplM ()
420 -- Record a tick, but don't add to the total tick count, which is
421 -- used to decide when nothing further has happened
422 freeTick t env us sc = sc' `seq` ((), us, sc')
424 sc' = doFreeTick t sc
428 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
430 -- Defined both with and without debugging
431 zeroSimplCount :: SimplCount
432 isZeroSimplCount :: SimplCount -> Bool
433 pprSimplCount :: SimplCount -> SDoc
434 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
435 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
440 ----------------------------------------------------------
442 ----------------------------------------------------------
443 type SimplCount = Int
447 isZeroSimplCount n = n==0
449 doTick t n = n+1 -- Very basic when not debugging
450 doFreeTick t n = n -- Don't count leaf visits
452 pprSimplCount n = ptext SLIT("Total ticks:") <+> int n
454 plusSimplCount n m = n+m
457 ----------------------------------------------------------
459 ----------------------------------------------------------
461 data SimplCount = SimplCount {
462 ticks :: !Int, -- Total ticks
463 details :: !TickCounts, -- How many of each type
465 log1 :: [Tick], -- Last N events; <= opt_HistorySize
466 log2 :: [Tick] -- Last opt_HistorySize events before that
469 type TickCounts = FiniteMap Tick Int
471 zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
472 n_log = 0, log1 = [], log2 = []}
474 isZeroSimplCount sc = ticks sc == 0
476 doFreeTick tick sc@SimplCount { details = dts }
477 = dts' `seqFM` sc { details = dts' }
479 dts' = dts `addTick` tick
481 -- Gross hack to persuade GHC 3.03 to do this important seq
482 seqFM fm x | isEmptyFM fm = x
485 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
486 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
487 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
489 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
491 -- Don't use plusFM_C because that's lazy, and we want to
492 -- be pretty strict here!
493 addTick :: TickCounts -> Tick -> TickCounts
494 addTick fm tick = case lookupFM fm tick of
495 Nothing -> addToFM fm tick 1
496 Just n -> n1 `seq` addToFM fm tick n1
500 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
501 sc2@(SimplCount { ticks = tks2, details = dts2 })
502 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
504 -- A hackish way of getting recent log info
505 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
506 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
510 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
511 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
513 pprTickCounts (fmToList dts),
514 if verboseSimplStats then
516 ptext SLIT("Log (most recent first)"),
517 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
521 pprTickCounts :: [(Tick,Int)] -> SDoc
522 pprTickCounts [] = empty
523 pprTickCounts ((tick1,n1):ticks)
524 = vcat [int tot_n <+> text (tickString tick1),
525 pprTCDetails real_these,
529 tick1_tag = tickToTag tick1
530 (these, others) = span same_tick ticks
531 real_these = (tick1,n1):these
532 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
533 tot_n = sum [n | (_,n) <- real_these]
535 pprTCDetails ticks@((tick,_):_)
536 | verboseSimplStats || isRuleFired tick
537 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
543 %************************************************************************
547 %************************************************************************
551 = PreInlineUnconditionally Id
552 | PostInlineUnconditionally Id
555 | RuleFired FAST_STRING -- Rule name
557 | LetFloatFromLet Id -- Thing floated out
558 | EtaExpansion Id -- LHS binder
559 | EtaReduction Id -- Binder on outer lambda
560 | BetaReduction Id -- Lambda binder
563 | CaseOfCase Id -- Bndr on *inner* case
564 | KnownBranch Id -- Case binder
565 | CaseMerge Id -- Binder on outer case
566 | CaseElim Id -- Case binder
567 | CaseIdentity Id -- Case binder
568 | FillInCaseDefault Id -- Case binder
572 | SimplifierDone -- Ticked at each iteration of the simplifier
574 isRuleFired (RuleFired _) = True
575 isRuleFired other = False
577 instance Outputable Tick where
578 ppr tick = text (tickString tick) <+> pprTickCts tick
580 instance Eq Tick where
581 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
583 instance Ord Tick where
586 tickToTag :: Tick -> Int
587 tickToTag (PreInlineUnconditionally _) = 0
588 tickToTag (PostInlineUnconditionally _) = 1
589 tickToTag (UnfoldingDone _) = 2
590 tickToTag (RuleFired _) = 3
591 tickToTag (LetFloatFromLet _) = 4
592 tickToTag (EtaExpansion _) = 5
593 tickToTag (EtaReduction _) = 6
594 tickToTag (BetaReduction _) = 7
595 tickToTag (CaseOfCase _) = 8
596 tickToTag (KnownBranch _) = 9
597 tickToTag (CaseMerge _) = 10
598 tickToTag (CaseElim _) = 11
599 tickToTag (CaseIdentity _) = 12
600 tickToTag (FillInCaseDefault _) = 13
601 tickToTag BottomFound = 14
602 tickToTag LeafVisit = 15
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"
622 tickString LeafVisit = "LeafVisit"
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 -> True }) us sc
752 %************************************************************************
754 \subsubsection{The ``enclosing cost-centre''}
756 %************************************************************************
759 getEnclosingCC :: SimplM CostCentreStack
760 getEnclosingCC env us sc = (seCC env, us, sc)
762 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
763 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
767 %************************************************************************
769 \subsubsection{The @SimplEnv@ type}
771 %************************************************************************
775 emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
777 emptySimplEnv sw_chkr in_scope black_list
778 = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
779 seBlackList = black_list,
780 seSubst = mkSubst in_scope emptySubstEnv }
781 -- The top level "enclosing CC" is "SUBSUMED".
783 getSubst :: SimplM Subst
784 getSubst env us sc = (seSubst env, us, sc)
786 getBlackList :: SimplM (Id -> Bool)
787 getBlackList env us sc = (seBlackList env, us, sc)
789 setSubst :: Subst -> SimplM a -> SimplM a
790 setSubst subst m env us sc = m (env {seSubst = subst}) us sc
792 getSubstEnv :: SimplM SubstEnv
793 getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
795 extendInScope :: CoreBndr -> SimplM a -> SimplM a
796 extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
797 = m (env {seSubst = Subst.extendInScope subst v}) us sc
799 extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
800 extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
801 = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
803 getInScope :: SimplM InScopeSet
804 getInScope env us sc = (substInScope (seSubst env), us, sc)
806 setInScope :: InScopeSet -> SimplM a -> SimplM a
807 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
808 = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
810 modifyInScope :: CoreBndr -> SimplM a -> SimplM a
811 modifyInScope v m env us sc
813 | not (v `isInScope` seSubst env)
814 = pprTrace "modifyInScope: not in scope:" (ppr v)
818 = extendInScope v m env us sc
820 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
821 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
822 = m (env { seSubst = Subst.extendSubst subst var res }) us sc
824 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
825 extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
826 = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
828 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
829 setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
830 = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
832 zapSubstEnv :: SimplM a -> SimplM a
833 zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
834 = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
836 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
837 getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
838 = ((subst, us), us, sc)
840 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
841 setSimplBinderStuff (subst, us) m env _ sc
842 = m (env {seSubst = subst}) us sc
847 newId :: Type -> (Id -> SimplM a) -> SimplM a
848 -- Extends the in-scope-env too
849 newId ty m env@(SimplEnv {seSubst = subst}) us sc
850 = case splitUniqSupply us of
851 (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
853 v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
855 newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
856 newIds tys m env@(SimplEnv {seSubst = subst}) us sc
857 = case splitUniqSupply us of
858 (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
860 vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
861 (uniqsFromSupply (length tys) us1) tys