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, returnOutStuff,
14 initSmpl, returnSmpl, thenSmpl, thenSmpl_,
15 mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
18 -- The inlining black-list
19 setBlackList, getBlackList, noInlineBlackList,
22 getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
28 getSimplCount, zeroSimplCount, pprSimplCount,
29 plusSimplCount, isZeroSimplCount,
32 SwitchChecker, getSwitchChecker, getSimplIntSwitch,
35 getEnclosingCC, setEnclosingCC,
38 getEnv, setAllExceptInScope,
40 getSubstEnv, extendSubst, extendSubstList,
41 getInScope, setInScope, modifyInScope, addNewInScopeIds,
42 setSubstEnv, zapSubstEnv,
43 getSimplBinderStuff, setSimplBinderStuff,
46 addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds,
47 addCaseBind, needsCaseBinding, addNonRecBind, wrapFloats, addFloats
50 #include "HsVersions.h"
52 import Id ( Id, mkSysLocal, idType, idUnfolding, isDataConWrapId,
55 import CoreUnfold ( isCompulsoryUnfolding )
56 import CoreUtils ( exprOkForSpeculation )
57 import PprCore () -- Instances
58 import CostCentre ( CostCentreStack, subsumedCCS )
59 import OccName ( UserFS )
63 import qualified Subst
64 import Subst ( Subst, mkSubst, substEnv,
65 InScopeSet, mkInScopeSet, substInScope,
68 import Type ( Type, isUnLiftedType )
69 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
73 import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
74 DynFlags, DynFlag(..), dopt,
75 opt_PprStyle_Debug, opt_HistorySize,
78 import Unique ( Unique )
79 import Maybes ( expectJust )
80 import Util ( zipWithEqual )
83 infixr 0 `thenSmpl`, `thenSmpl_`
86 %************************************************************************
88 \subsection[Simplify-types]{Type declarations}
90 %************************************************************************
93 type InBinder = CoreBndr
94 type InId = Id -- Not yet cloned
95 type InType = Type -- Ditto
96 type InBind = CoreBind
97 type InExpr = CoreExpr
101 type OutBinder = CoreBndr
102 type OutId = Id -- Cloned
103 type OutType = Type -- Cloned
104 type OutBind = CoreBind
105 type OutExpr = CoreExpr
106 type OutAlt = CoreAlt
107 type OutArg = CoreArg
109 type SwitchChecker = SimplifierSwitch -> SwitchResult
111 type OutExprStuff = OutStuff OutExpr
112 type OutStuff a = (OrdList OutBind, (InScopeSet, a))
113 -- We return something equivalent to (let b in e), but
114 -- in pieces to avoid the quadratic blowup when floating
115 -- incrementally. Comments just before simplExprB in Simplify.lhs
119 wrapFloats :: OrdList CoreBind -> CoreExpr -> CoreExpr
120 wrapFloats binds body = foldOL Let body binds
122 returnOutStuff :: a -> SimplM (OutStuff a)
123 returnOutStuff x = getInScope `thenSmpl` \ in_scope ->
124 returnSmpl (nilOL, (in_scope, x))
126 addFloats :: OrdList CoreBind -> InScopeSet -> SimplM (OutStuff a) -> SimplM (OutStuff a)
127 addFloats floats in_scope thing_inside
128 = setInScope in_scope thing_inside `thenSmpl` \ (binds, res) ->
129 returnSmpl (floats `appOL` binds, res)
131 addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
132 addLetBind bind thing_inside
133 = thing_inside `thenSmpl` \ (binds, res) ->
134 returnSmpl (bind `consOL` binds, res)
136 addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
137 addLetBinds binds1 thing_inside
138 = thing_inside `thenSmpl` \ (binds2, res) ->
139 returnSmpl (toOL binds1 `appOL` binds2, res)
141 addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
142 -- Extends the in-scope environment as well as wrapping the bindings
143 addAuxiliaryBinds binds1 thing_inside
144 = addNewInScopeIds (bindersOfBinds binds1) $
145 addLetBinds binds1 thing_inside
147 addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
148 -- Extends the in-scope environment as well as wrapping the bindings
149 addAuxiliaryBind bind thing_inside
150 = addNewInScopeIds (bindersOf bind) $
151 addLetBind bind thing_inside
153 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
154 -- Make a case expression instead of a let
155 -- These can arise either from the desugarer,
156 -- or from beta reductions: (\x.e) (x +# y)
158 addCaseBind bndr rhs thing_inside
159 = thing_inside `thenSmpl` \ (floats, (_, body)) ->
160 returnOutStuff (Case rhs bndr [(DEFAULT, [], wrapFloats floats body)])
162 addNonRecBind bndr rhs thing_inside
163 -- Checks for needing a case binding
164 | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
165 | otherwise = addLetBind (NonRec bndr rhs) thing_inside
169 %************************************************************************
171 \subsection{Monad plumbing}
173 %************************************************************************
175 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
176 (Command-line switches move around through the explicitly-passed SimplEnv.)
181 -> SimplEnv -- We thread the unique supply because
182 -> UniqSupply -- constantly splitting it is rather expensive
184 -> (result, UniqSupply, SimplCount)
186 type BlackList = Id -> Bool -- True => don't inline this Id
190 seChkr :: SwitchChecker,
191 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
192 seBlackList :: BlackList,
193 seSubst :: Subst -- The current substitution
195 -- The range of the substitution is OutType and OutExpr resp
197 -- The substitution is idempotent
198 -- It *must* be applied; things in its domain simply aren't
199 -- bound in the result.
201 -- The substitution usually maps an Id to its clone,
202 -- but if the orig defn is a let-binding, and
203 -- the RHS of the let simplifies to an atom,
204 -- we just add the binding to the substitution and elide the let.
206 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
207 -- The elements of the set may have better IdInfo than the
208 -- occurrences of in-scope Ids, and (more important) they will
209 -- have a correctly-substituted type. So we use a lookup in this
210 -- set to replace occurrences
216 -> UniqSupply -- No init count; set to 0
217 -> VarSet -- In scope (usually empty, but useful for nested calls)
218 -> BlackList -- Black-list function
222 initSmpl dflags chkr us in_scope black_list m
223 = case m dflags (emptySimplEnv chkr in_scope black_list) us
224 (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 env 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 env us0 sc0
239 = case (m dflags env us0 sc0) of
240 (m_result, us1, sc1) -> k m_result dflags env us1 sc1
242 thenSmpl_ m k dflags env us0 sc0
243 = case (m dflags env us0 sc0) of
244 (_, us1, sc1) -> k dflags env 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 env us sc
280 = case splitUniqSupply us of
281 (us1, us2) -> (us1, us2, sc)
283 getUniqueSmpl :: SimplM Unique
284 getUniqueSmpl dflags env us sc
285 = case splitUniqSupply us of
286 (us1, us2) -> (uniqFromSupply us1, us2, sc)
288 getUniquesSmpl :: SimplM [Unique]
289 getUniquesSmpl dflags env us sc
290 = case splitUniqSupply us of
291 (us1, us2) -> (uniqsFromSupply us1, us2, sc)
293 getDOptsSmpl :: SimplM DynFlags
294 getDOptsSmpl dflags env us sc
299 %************************************************************************
301 \subsection{Counting up what we've done}
303 %************************************************************************
306 getSimplCount :: SimplM SimplCount
307 getSimplCount dflags env us sc = (sc, us, sc)
309 tick :: Tick -> SimplM ()
310 tick t dflags env us sc
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 env 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 | CaseElim Id -- Case binder
461 | CaseIdentity Id -- Case binder
462 | FillInCaseDefault Id -- Case binder
465 | SimplifierDone -- Ticked at each iteration of the simplifier
467 isRuleFired (RuleFired _) = True
468 isRuleFired other = False
470 instance Outputable Tick where
471 ppr tick = text (tickString tick) <+> pprTickCts tick
473 instance Eq Tick where
474 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
476 instance Ord Tick where
479 tickToTag :: Tick -> Int
480 tickToTag (PreInlineUnconditionally _) = 0
481 tickToTag (PostInlineUnconditionally _) = 1
482 tickToTag (UnfoldingDone _) = 2
483 tickToTag (RuleFired _) = 3
484 tickToTag LetFloatFromLet = 4
485 tickToTag (EtaExpansion _) = 5
486 tickToTag (EtaReduction _) = 6
487 tickToTag (BetaReduction _) = 7
488 tickToTag (CaseOfCase _) = 8
489 tickToTag (KnownBranch _) = 9
490 tickToTag (CaseMerge _) = 10
491 tickToTag (CaseElim _) = 11
492 tickToTag (CaseIdentity _) = 12
493 tickToTag (FillInCaseDefault _) = 13
494 tickToTag BottomFound = 14
495 tickToTag SimplifierDone = 16
497 tickString :: Tick -> String
498 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
499 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
500 tickString (UnfoldingDone _) = "UnfoldingDone"
501 tickString (RuleFired _) = "RuleFired"
502 tickString LetFloatFromLet = "LetFloatFromLet"
503 tickString (EtaExpansion _) = "EtaExpansion"
504 tickString (EtaReduction _) = "EtaReduction"
505 tickString (BetaReduction _) = "BetaReduction"
506 tickString (CaseOfCase _) = "CaseOfCase"
507 tickString (KnownBranch _) = "KnownBranch"
508 tickString (CaseMerge _) = "CaseMerge"
509 tickString (CaseElim _) = "CaseElim"
510 tickString (CaseIdentity _) = "CaseIdentity"
511 tickString (FillInCaseDefault _) = "FillInCaseDefault"
512 tickString BottomFound = "BottomFound"
513 tickString SimplifierDone = "SimplifierDone"
515 pprTickCts :: Tick -> SDoc
516 pprTickCts (PreInlineUnconditionally v) = ppr v
517 pprTickCts (PostInlineUnconditionally v)= ppr v
518 pprTickCts (UnfoldingDone v) = ppr v
519 pprTickCts (RuleFired v) = ppr v
520 pprTickCts LetFloatFromLet = empty
521 pprTickCts (EtaExpansion v) = ppr v
522 pprTickCts (EtaReduction v) = ppr v
523 pprTickCts (BetaReduction v) = ppr v
524 pprTickCts (CaseOfCase v) = ppr v
525 pprTickCts (KnownBranch v) = ppr v
526 pprTickCts (CaseMerge v) = ppr v
527 pprTickCts (CaseElim v) = ppr v
528 pprTickCts (CaseIdentity v) = ppr v
529 pprTickCts (FillInCaseDefault v) = ppr v
530 pprTickCts other = empty
532 cmpTick :: Tick -> Tick -> Ordering
533 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
535 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
538 -- Always distinguish RuleFired, so that the stats
539 -- can report them even in non-verbose mode
541 cmpEqTick :: Tick -> Tick -> Ordering
542 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
543 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
544 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
545 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
546 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
547 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
548 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
549 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
550 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
551 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
552 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
553 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
554 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
555 cmpEqTick other1 other2 = EQ
559 %************************************************************************
561 \subsubsection{Command-line switches}
563 %************************************************************************
566 getSwitchChecker :: SimplM SwitchChecker
567 getSwitchChecker dflags env us sc = (seChkr env, us, sc)
569 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
570 getSimplIntSwitch chkr switch
571 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
575 @setBlackList@ is used to prepare the environment for simplifying
576 the RHS of an Id that's marked with an INLINE pragma. It is going to
577 be inlined wherever they are used, and then all the inlining will take
578 effect. Meanwhile, there isn't much point in doing anything to the
579 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
581 (a) not doing so will inline a worker straight back into its wrapper!
583 and (b) Consider the following example
588 in ...g...g...g...g...g...
590 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
591 and thence copied multiple times when g is inlined.
593 Andy disagrees! Example:
594 all xs = foldr (&&) True xs
595 any p = all . map p {-# INLINE any #-}
597 Problem: any won't get deforested, and so if it's exported and
598 the importer doesn't use the inlining, (eg passes it as an arg)
599 then we won't get deforestation at all.
600 We havn't solved this problem yet!
602 We prepare the envt by simply modifying the black list.
606 We *don't* prevent inlining from happening for identifiers
607 that are marked as IMustBeINLINEd. An example of where
608 doing this is crucial is:
610 class Bar a => Foo a where
616 If `f' needs to peer inside Foo's superclass, Bar, it refers
617 to the appropriate super class selector, which is marked as
618 must-inlineable. We don't generate any code for a superclass
619 selector, so failing to inline it in the RHS of `f' will
620 leave a reference to a non-existent id, with bad consequences.
622 ALSO NOTE that we do all this by modifing the black list
623 not by zapping the unfolding. The latter may still be useful for
624 knowing when something is evaluated.
627 setBlackList :: BlackList -> SimplM a -> SimplM a
628 setBlackList black_list m dflags env us sc
629 = m dflags (env { seBlackList = black_list }) us sc
631 getBlackList :: SimplM BlackList
632 getBlackList dflags env us sc = (seBlackList env, us, sc)
634 noInlineBlackList :: SimplM BlackList
635 -- Inside inlinings, black list anything that is in scope or imported.
636 -- except for things that must be unfolded (Compulsory)
637 -- and data con wrappers. The latter is a hack, like the one in
638 -- SimplCore.simplRules, to make wrappers inline in rule LHSs.
639 -- We may as well do the same here.
640 noInlineBlackList dflags env us sc = (blacklisted,us,sc)
641 where blacklisted v =
642 not (isCompulsoryUnfolding (idUnfolding v)) &&
643 not (isDataConWrapId v) &&
644 (v `isInScope` (seSubst env) || isGlobalId v)
645 -- NB: An earlier version omitted the last clause; this meant
646 -- that even inlinings *completely within* an INLINE didn't happen.
647 -- This was cheaper, and probably adequate, but produced awful code
648 -- for some dictionary constructions.
652 %************************************************************************
654 \subsubsection{The ``enclosing cost-centre''}
656 %************************************************************************
659 getEnclosingCC :: SimplM CostCentreStack
660 getEnclosingCC dflags env us sc = (seCC env, us, sc)
662 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
663 setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc
667 %************************************************************************
669 \subsubsection{The @SimplEnv@ type}
671 %************************************************************************
675 emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv
677 emptySimplEnv sw_chkr in_scope black_list
678 = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
679 seBlackList = black_list,
680 seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
681 -- The top level "enclosing CC" is "SUBSUMED".
683 getEnv :: SimplM SimplEnv
684 getEnv dflags env us sc = (env, us, sc)
686 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
687 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags
688 (SimplEnv {seSubst = old_subst}) us sc
689 = m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)})
692 getSubst :: SimplM Subst
693 getSubst dflags env us sc = (seSubst env, us, sc)
695 setSubst :: Subst -> SimplM a -> SimplM a
696 setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc
698 getSubstEnv :: SimplM SubstEnv
699 getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc)
701 addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
702 -- The new Ids are guaranteed to be freshly allocated
703 addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc
704 = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
706 getInScope :: SimplM InScopeSet
707 getInScope dflags env us sc = (substInScope (seSubst env), us, sc)
709 setInScope :: InScopeSet -> SimplM a -> SimplM a
710 setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc
711 = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc
713 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
714 modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc
715 = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc
717 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
718 extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc
719 = m dflags (env { seSubst = Subst.extendSubst subst var res }) us sc
721 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
722 extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc
723 = m dflags (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
725 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
726 setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc
727 = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc
729 zapSubstEnv :: SimplM a -> SimplM a
730 zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc
731 = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc
733 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
734 getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc
735 = ((subst, us), us, sc)
737 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
738 setSimplBinderStuff (subst, us) m dflags env _ sc
739 = m dflags (env {seSubst = subst}) us sc
744 newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
745 -- Extends the in-scope-env too
746 newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc
747 = case splitUniqSupply us of
748 (us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v})
751 v = mkSysLocal fs (uniqFromSupply us1) ty
753 newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
754 newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
755 = case splitUniqSupply us of
756 (us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs})
759 vs = zipWith (mkSysLocal fs) (uniqsFromSupply us1) tys