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 )
54 import CoreUnfold ( isCompulsoryUnfolding )
55 import CoreUtils ( exprOkForSpeculation )
56 import PprCore () -- Instances
57 import CostCentre ( CostCentreStack, subsumedCCS )
58 import OccName ( UserFS )
62 import qualified Subst
63 import Subst ( Subst, mkSubst, substEnv,
64 InScopeSet, mkInScopeSet, substInScope
66 import Type ( Type, isUnLiftedType )
67 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
71 import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
72 DynFlags, DynFlag(..), dopt,
73 opt_PprStyle_Debug, opt_HistorySize,
76 import Unique ( Unique )
77 import Maybes ( expectJust )
78 import Util ( zipWithEqual )
81 infixr 0 `thenSmpl`, `thenSmpl_`
84 %************************************************************************
86 \subsection[Simplify-types]{Type declarations}
88 %************************************************************************
91 type InBinder = CoreBndr
92 type InId = Id -- Not yet cloned
93 type InType = Type -- Ditto
94 type InBind = CoreBind
95 type InExpr = CoreExpr
99 type OutBinder = CoreBndr
100 type OutId = Id -- Cloned
101 type OutType = Type -- Cloned
102 type OutBind = CoreBind
103 type OutExpr = CoreExpr
104 type OutAlt = CoreAlt
105 type OutArg = CoreArg
107 type SwitchChecker = SimplifierSwitch -> SwitchResult
109 type OutExprStuff = OutStuff OutExpr
110 type OutStuff a = (OrdList OutBind, (InScopeSet, a))
111 -- We return something equivalent to (let b in e), but
112 -- in pieces to avoid the quadratic blowup when floating
113 -- incrementally. Comments just before simplExprB in Simplify.lhs
117 wrapFloats :: OrdList CoreBind -> CoreExpr -> CoreExpr
118 wrapFloats binds body = foldOL Let body binds
120 returnOutStuff :: a -> SimplM (OutStuff a)
121 returnOutStuff x = getInScope `thenSmpl` \ in_scope ->
122 returnSmpl (nilOL, (in_scope, x))
124 addFloats :: OrdList CoreBind -> InScopeSet -> SimplM (OutStuff a) -> SimplM (OutStuff a)
125 addFloats floats in_scope thing_inside
126 = setInScope in_scope thing_inside `thenSmpl` \ (binds, res) ->
127 returnSmpl (floats `appOL` binds, res)
129 addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
130 addLetBind bind thing_inside
131 = thing_inside `thenSmpl` \ (binds, res) ->
132 returnSmpl (bind `consOL` binds, res)
134 addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
135 addLetBinds binds1 thing_inside
136 = thing_inside `thenSmpl` \ (binds2, res) ->
137 returnSmpl (toOL binds1 `appOL` binds2, res)
139 addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
140 -- Extends the in-scope environment as well as wrapping the bindings
141 addAuxiliaryBinds binds1 thing_inside
142 = addNewInScopeIds (bindersOfBinds binds1) $
143 addLetBinds binds1 thing_inside
145 addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
146 -- Extends the in-scope environment as well as wrapping the bindings
147 addAuxiliaryBind bind thing_inside
148 = addNewInScopeIds (bindersOf bind) $
149 addLetBind bind thing_inside
151 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
152 -- Make a case expression instead of a let
153 -- These can arise either from the desugarer,
154 -- or from beta reductions: (\x.e) (x +# y)
156 addCaseBind bndr rhs thing_inside
157 = thing_inside `thenSmpl` \ (floats, (_, body)) ->
158 returnOutStuff (Case rhs bndr [(DEFAULT, [], wrapFloats floats body)])
160 addNonRecBind bndr rhs thing_inside
161 -- Checks for needing a case binding
162 | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
163 | otherwise = addLetBind (NonRec bndr rhs) thing_inside
167 %************************************************************************
169 \subsection{Monad plumbing}
171 %************************************************************************
173 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
174 (Command-line switches move around through the explicitly-passed SimplEnv.)
179 -> SimplEnv -- We thread the unique supply because
180 -> UniqSupply -- constantly splitting it is rather expensive
182 -> (result, UniqSupply, SimplCount)
184 type BlackList = Id -> Bool -- True => don't inline this Id
188 seChkr :: SwitchChecker,
189 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
190 seBlackList :: BlackList,
191 seSubst :: Subst -- The current substitution
193 -- The range of the substitution is OutType and OutExpr resp
195 -- The substitution is idempotent
196 -- It *must* be applied; things in its domain simply aren't
197 -- bound in the result.
199 -- The substitution usually maps an Id to its clone,
200 -- but if the orig defn is a let-binding, and
201 -- the RHS of the let simplifies to an atom,
202 -- we just add the binding to the substitution and elide the let.
204 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
205 -- The elements of the set may have better IdInfo than the
206 -- occurrences of in-scope Ids, and (more important) they will
207 -- have a correctly-substituted type. So we use a lookup in this
208 -- set to replace occurrences
214 -> UniqSupply -- No init count; set to 0
215 -> VarSet -- In scope (usually empty, but useful for nested calls)
216 -> BlackList -- Black-list function
220 initSmpl dflags chkr us in_scope black_list m
221 = case m dflags (emptySimplEnv chkr in_scope black_list) us
222 (zeroSimplCount dflags) of
223 (result, _, count) -> (result, count)
226 {-# INLINE thenSmpl #-}
227 {-# INLINE thenSmpl_ #-}
228 {-# INLINE returnSmpl #-}
230 returnSmpl :: a -> SimplM a
231 returnSmpl e dflags env us sc = (e, us, sc)
233 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
234 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
236 thenSmpl m k dflags env us0 sc0
237 = case (m dflags env us0 sc0) of
238 (m_result, us1, sc1) -> k m_result dflags env us1 sc1
240 thenSmpl_ m k dflags env us0 sc0
241 = case (m dflags env us0 sc0) of
242 (_, us1, sc1) -> k dflags env us1 sc1
247 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
248 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
250 mapSmpl f [] = returnSmpl []
252 = f x `thenSmpl` \ x' ->
253 mapSmpl f xs `thenSmpl` \ xs' ->
256 mapAndUnzipSmpl f [] = returnSmpl ([],[])
257 mapAndUnzipSmpl f (x:xs)
258 = f x `thenSmpl` \ (r1, r2) ->
259 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
260 returnSmpl (r1:rs1, r2:rs2)
262 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
263 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
264 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
265 returnSmpl (acc'', x':xs')
269 %************************************************************************
271 \subsection{The unique supply}
273 %************************************************************************
276 getUniqSupplySmpl :: SimplM UniqSupply
277 getUniqSupplySmpl dflags env us sc
278 = case splitUniqSupply us of
279 (us1, us2) -> (us1, us2, sc)
281 getUniqueSmpl :: SimplM Unique
282 getUniqueSmpl dflags env us sc
283 = case splitUniqSupply us of
284 (us1, us2) -> (uniqFromSupply us1, us2, sc)
286 getUniquesSmpl :: Int -> SimplM [Unique]
287 getUniquesSmpl n dflags env us sc
288 = case splitUniqSupply us of
289 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
291 getDOptsSmpl :: SimplM DynFlags
292 getDOptsSmpl dflags env us sc
297 %************************************************************************
299 \subsection{Counting up what we've done}
301 %************************************************************************
304 getSimplCount :: SimplM SimplCount
305 getSimplCount dflags env us sc = (sc, us, sc)
307 tick :: Tick -> SimplM ()
308 tick t dflags env us sc
309 = sc' `seq` ((), us, sc')
313 freeTick :: Tick -> SimplM ()
314 -- Record a tick, but don't add to the total tick count, which is
315 -- used to decide when nothing further has happened
316 freeTick t dflags env us sc
317 = sc' `seq` ((), us, sc')
319 sc' = doFreeTick t sc
323 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
325 zeroSimplCount :: DynFlags -> SimplCount
326 isZeroSimplCount :: SimplCount -> Bool
327 pprSimplCount :: SimplCount -> SDoc
328 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
329 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
333 data SimplCount = VerySimplZero -- These two are used when
334 | VerySimplNonZero -- we are only interested in
338 ticks :: !Int, -- Total ticks
339 details :: !TickCounts, -- How many of each type
341 log1 :: [Tick], -- Last N events; <= opt_HistorySize
342 log2 :: [Tick] -- Last opt_HistorySize events before that
345 type TickCounts = FiniteMap Tick Int
347 zeroSimplCount dflags
348 -- This is where we decide whether to do
349 -- the VerySimpl version or the full-stats version
350 | dopt Opt_D_dump_simpl_stats dflags
351 = SimplCount {ticks = 0, details = emptyFM,
352 n_log = 0, log1 = [], log2 = []}
356 isZeroSimplCount VerySimplZero = True
357 isZeroSimplCount (SimplCount { ticks = 0 }) = True
358 isZeroSimplCount other = False
360 doFreeTick tick sc@SimplCount { details = dts }
361 = dts' `seqFM` sc { details = dts' }
363 dts' = dts `addTick` tick
364 doFreeTick tick sc = sc
366 -- Gross hack to persuade GHC 3.03 to do this important seq
367 seqFM fm x | isEmptyFM fm = x
370 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
371 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
372 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
374 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
376 doTick tick sc = VerySimplNonZero -- The very simple case
379 -- Don't use plusFM_C because that's lazy, and we want to
380 -- be pretty strict here!
381 addTick :: TickCounts -> Tick -> TickCounts
382 addTick fm tick = case lookupFM fm tick of
383 Nothing -> addToFM fm tick 1
384 Just n -> n1 `seq` addToFM fm tick n1
389 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
390 sc2@(SimplCount { ticks = tks2, details = dts2 })
391 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
393 -- A hackish way of getting recent log info
394 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
395 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
398 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
399 plusSimplCount sc1 sc2 = VerySimplNonZero
401 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
402 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
403 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
404 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
406 pprTickCounts (fmToList dts),
407 if verboseSimplStats then
409 ptext SLIT("Log (most recent first)"),
410 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
414 pprTickCounts :: [(Tick,Int)] -> SDoc
415 pprTickCounts [] = empty
416 pprTickCounts ((tick1,n1):ticks)
417 = vcat [int tot_n <+> text (tickString tick1),
418 pprTCDetails real_these,
422 tick1_tag = tickToTag tick1
423 (these, others) = span same_tick ticks
424 real_these = (tick1,n1):these
425 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
426 tot_n = sum [n | (_,n) <- real_these]
428 pprTCDetails ticks@((tick,_):_)
429 | verboseSimplStats || isRuleFired tick
430 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
435 %************************************************************************
439 %************************************************************************
443 = PreInlineUnconditionally Id
444 | PostInlineUnconditionally Id
447 | RuleFired FAST_STRING -- Rule name
450 | EtaExpansion Id -- LHS binder
451 | EtaReduction Id -- Binder on outer lambda
452 | BetaReduction Id -- Lambda binder
455 | CaseOfCase Id -- Bndr on *inner* case
456 | KnownBranch Id -- Case binder
457 | CaseMerge Id -- Binder on outer case
458 | CaseElim Id -- Case binder
459 | CaseIdentity Id -- Case binder
460 | FillInCaseDefault Id -- Case binder
463 | SimplifierDone -- Ticked at each iteration of the simplifier
465 isRuleFired (RuleFired _) = True
466 isRuleFired other = False
468 instance Outputable Tick where
469 ppr tick = text (tickString tick) <+> pprTickCts tick
471 instance Eq Tick where
472 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
474 instance Ord Tick where
477 tickToTag :: Tick -> Int
478 tickToTag (PreInlineUnconditionally _) = 0
479 tickToTag (PostInlineUnconditionally _) = 1
480 tickToTag (UnfoldingDone _) = 2
481 tickToTag (RuleFired _) = 3
482 tickToTag LetFloatFromLet = 4
483 tickToTag (EtaExpansion _) = 5
484 tickToTag (EtaReduction _) = 6
485 tickToTag (BetaReduction _) = 7
486 tickToTag (CaseOfCase _) = 8
487 tickToTag (KnownBranch _) = 9
488 tickToTag (CaseMerge _) = 10
489 tickToTag (CaseElim _) = 11
490 tickToTag (CaseIdentity _) = 12
491 tickToTag (FillInCaseDefault _) = 13
492 tickToTag BottomFound = 14
493 tickToTag SimplifierDone = 16
495 tickString :: Tick -> String
496 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
497 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
498 tickString (UnfoldingDone _) = "UnfoldingDone"
499 tickString (RuleFired _) = "RuleFired"
500 tickString LetFloatFromLet = "LetFloatFromLet"
501 tickString (EtaExpansion _) = "EtaExpansion"
502 tickString (EtaReduction _) = "EtaReduction"
503 tickString (BetaReduction _) = "BetaReduction"
504 tickString (CaseOfCase _) = "CaseOfCase"
505 tickString (KnownBranch _) = "KnownBranch"
506 tickString (CaseMerge _) = "CaseMerge"
507 tickString (CaseElim _) = "CaseElim"
508 tickString (CaseIdentity _) = "CaseIdentity"
509 tickString (FillInCaseDefault _) = "FillInCaseDefault"
510 tickString BottomFound = "BottomFound"
511 tickString SimplifierDone = "SimplifierDone"
513 pprTickCts :: Tick -> SDoc
514 pprTickCts (PreInlineUnconditionally v) = ppr v
515 pprTickCts (PostInlineUnconditionally v)= ppr v
516 pprTickCts (UnfoldingDone v) = ppr v
517 pprTickCts (RuleFired v) = ppr v
518 pprTickCts LetFloatFromLet = empty
519 pprTickCts (EtaExpansion v) = ppr v
520 pprTickCts (EtaReduction v) = ppr v
521 pprTickCts (BetaReduction v) = ppr v
522 pprTickCts (CaseOfCase v) = ppr v
523 pprTickCts (KnownBranch v) = ppr v
524 pprTickCts (CaseMerge v) = ppr v
525 pprTickCts (CaseElim v) = ppr v
526 pprTickCts (CaseIdentity v) = ppr v
527 pprTickCts (FillInCaseDefault v) = ppr v
528 pprTickCts other = empty
530 cmpTick :: Tick -> Tick -> Ordering
531 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
533 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
536 -- Always distinguish RuleFired, so that the stats
537 -- can report them even in non-verbose mode
539 cmpEqTick :: Tick -> Tick -> Ordering
540 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
541 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
542 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
543 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
544 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
545 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
546 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
547 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
548 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
549 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
550 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
551 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
552 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
553 cmpEqTick other1 other2 = EQ
557 %************************************************************************
559 \subsubsection{Command-line switches}
561 %************************************************************************
564 getSwitchChecker :: SimplM SwitchChecker
565 getSwitchChecker dflags env us sc = (seChkr env, us, sc)
567 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
568 getSimplIntSwitch chkr switch
569 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
573 @setBlackList@ is used to prepare the environment for simplifying
574 the RHS of an Id that's marked with an INLINE pragma. It is going to
575 be inlined wherever they are used, and then all the inlining will take
576 effect. Meanwhile, there isn't much point in doing anything to the
577 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
579 (a) not doing so will inline a worker straight back into its wrapper!
581 and (b) Consider the following example
586 in ...g...g...g...g...g...
588 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
589 and thence copied multiple times when g is inlined.
591 Andy disagrees! Example:
592 all xs = foldr (&&) True xs
593 any p = all . map p {-# INLINE any #-}
595 Problem: any won't get deforested, and so if it's exported and
596 the importer doesn't use the inlining, (eg passes it as an arg)
597 then we won't get deforestation at all.
598 We havn't solved this problem yet!
600 We prepare the envt by simply modifying the black list.
604 We *don't* prevent inlining from happening for identifiers
605 that are marked as IMustBeINLINEd. An example of where
606 doing this is crucial is:
608 class Bar a => Foo a where
614 If `f' needs to peer inside Foo's superclass, Bar, it refers
615 to the appropriate super class selector, which is marked as
616 must-inlineable. We don't generate any code for a superclass
617 selector, so failing to inline it in the RHS of `f' will
618 leave a reference to a non-existent id, with bad consequences.
620 ALSO NOTE that we do all this by modifing the black list
621 not by zapping the unfolding. The latter may still be useful for
622 knowing when something is evaluated.
625 setBlackList :: BlackList -> SimplM a -> SimplM a
626 setBlackList black_list m dflags env us sc
627 = m dflags (env { seBlackList = black_list }) us sc
629 getBlackList :: SimplM BlackList
630 getBlackList dflags env us sc = (seBlackList env, us, sc)
632 noInlineBlackList :: BlackList
633 -- Inside inlinings, black list anything that is in scope or imported.
634 -- except for things that must be unfolded (Compulsory)
635 -- and data con wrappers. The latter is a hack, like the one in
636 -- SimplCore.simplRules, to make wrappers inline in rule LHSs.
637 -- We may as well do the same here.
638 noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
639 not (isDataConWrapId v)
640 -- NB: this implementation means that even inlinings *completely within*
641 -- an INLINE won't happen, which is perhaps overkill.
642 -- An earlier verion had: (v `isInScope` subst) || not (isLocallyDefined v)
643 -- but it's more expensive, and it probably doesn't matter.
647 %************************************************************************
649 \subsubsection{The ``enclosing cost-centre''}
651 %************************************************************************
654 getEnclosingCC :: SimplM CostCentreStack
655 getEnclosingCC dflags env us sc = (seCC env, us, sc)
657 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
658 setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc
662 %************************************************************************
664 \subsubsection{The @SimplEnv@ type}
666 %************************************************************************
670 emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv
672 emptySimplEnv sw_chkr in_scope black_list
673 = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
674 seBlackList = black_list,
675 seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
676 -- The top level "enclosing CC" is "SUBSUMED".
678 getEnv :: SimplM SimplEnv
679 getEnv dflags env us sc = (env, us, sc)
681 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
682 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags
683 (SimplEnv {seSubst = old_subst}) us sc
684 = m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)})
687 getSubst :: SimplM Subst
688 getSubst dflags env us sc = (seSubst env, us, sc)
690 setSubst :: Subst -> SimplM a -> SimplM a
691 setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc
693 getSubstEnv :: SimplM SubstEnv
694 getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc)
696 addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
697 -- The new Ids are guaranteed to be freshly allocated
698 addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc
699 = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
701 getInScope :: SimplM InScopeSet
702 getInScope dflags env us sc = (substInScope (seSubst env), us, sc)
704 setInScope :: InScopeSet -> SimplM a -> SimplM a
705 setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc
706 = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc
708 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
709 modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc
710 = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc
712 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
713 extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc
714 = m dflags (env { seSubst = Subst.extendSubst subst var res }) us sc
716 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
717 extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc
718 = m dflags (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
720 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
721 setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc
722 = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc
724 zapSubstEnv :: SimplM a -> SimplM a
725 zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc
726 = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc
728 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
729 getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc
730 = ((subst, us), us, sc)
732 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
733 setSimplBinderStuff (subst, us) m dflags env _ sc
734 = m dflags (env {seSubst = subst}) us sc
739 newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
740 -- Extends the in-scope-env too
741 newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc
742 = case splitUniqSupply us of
743 (us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v})
746 v = mkSysLocal fs (uniqFromSupply us1) ty
748 newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
749 newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
750 = case splitUniqSupply us of
751 (us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs})
754 vs = zipWithEqual "newIds" (mkSysLocal fs)
755 (uniqsFromSupply (length tys) us1) tys