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,
14 initSmpl, returnSmpl, thenSmpl, thenSmpl_,
15 mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
18 -- The inlining black-list
19 setBlackList, getBlackList, noInlineBlackList,
22 getUniqueSmpl, getUniquesSmpl,
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
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 )
61 import qualified Subst
62 import Subst ( Subst, mkSubst, substEnv,
63 InScopeSet, mkInScopeSet, substInScope
65 import Type ( Type, isUnLiftedType )
66 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
70 import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
71 DynFlags, DynFlag(..), dopt,
72 opt_PprStyle_Debug, opt_HistorySize,
75 import Unique ( Unique )
76 import Maybes ( expectJust )
77 import Util ( zipWithEqual )
80 infixr 0 `thenSmpl`, `thenSmpl_`
83 %************************************************************************
85 \subsection[Simplify-types]{Type declarations}
87 %************************************************************************
90 type InBinder = CoreBndr
91 type InId = Id -- Not yet cloned
92 type InType = Type -- Ditto
93 type InBind = CoreBind
94 type InExpr = CoreExpr
98 type OutBinder = CoreBndr
99 type OutId = Id -- Cloned
100 type OutType = Type -- Cloned
101 type OutBind = CoreBind
102 type OutExpr = CoreExpr
103 type OutAlt = CoreAlt
104 type OutArg = CoreArg
106 type SwitchChecker = SimplifierSwitch -> SwitchResult
108 type OutExprStuff = OutStuff (InScopeSet, OutExpr)
109 type OutStuff a = ([OutBind], a)
110 -- We return something equivalent to (let b in e), but
111 -- in pieces to avoid the quadratic blowup when floating
112 -- incrementally. Comments just before simplExprB in Simplify.lhs
116 addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
117 addLetBind bind thing_inside
118 = thing_inside `thenSmpl` \ (binds, res) ->
119 returnSmpl (bind : binds, res)
121 addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
122 addLetBinds binds1 thing_inside
123 = thing_inside `thenSmpl` \ (binds2, res) ->
124 returnSmpl (binds1 ++ binds2, res)
126 addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
127 -- Extends the in-scope environment as well as wrapping the bindings
128 addAuxiliaryBinds binds1 thing_inside
129 = addNewInScopeIds (bindersOfBinds binds1) $
130 addLetBinds binds1 thing_inside
132 addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
133 -- Extends the in-scope environment as well as wrapping the bindings
134 addAuxiliaryBind bind thing_inside
135 = addNewInScopeIds (bindersOf bind) $
136 addLetBind bind thing_inside
138 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
139 -- Make a case expression instead of a let
140 -- These can arise either from the desugarer,
141 -- or from beta reductions: (\x.e) (x +# y)
143 addCaseBind bndr rhs thing_inside
144 = getInScope `thenSmpl` \ in_scope ->
145 thing_inside `thenSmpl` \ (floats, (_, body)) ->
146 returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets floats body)]))
148 addNonRecBind bndr rhs thing_inside
149 -- Checks for needing a case binding
150 | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
151 | otherwise = addLetBind (NonRec bndr rhs) thing_inside
155 %************************************************************************
157 \subsection{Monad plumbing}
159 %************************************************************************
161 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
162 (Command-line switches move around through the explicitly-passed SimplEnv.)
167 -> SimplEnv -- We thread the unique supply because
168 -> UniqSupply -- constantly splitting it is rather expensive
170 -> (result, UniqSupply, SimplCount)
172 type BlackList = Id -> Bool -- True => don't inline this Id
176 seChkr :: SwitchChecker,
177 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
178 seBlackList :: BlackList,
179 seSubst :: Subst -- The current substitution
181 -- The range of the substitution is OutType and OutExpr resp
183 -- The substitution is idempotent
184 -- It *must* be applied; things in its domain simply aren't
185 -- bound in the result.
187 -- The substitution usually maps an Id to its clone,
188 -- but if the orig defn is a let-binding, and
189 -- the RHS of the let simplifies to an atom,
190 -- we just add the binding to the substitution and elide the let.
192 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
193 -- The elements of the set may have better IdInfo than the
194 -- occurrences of in-scope Ids, and (more important) they will
195 -- have a correctly-substituted type. So we use a lookup in this
196 -- set to replace occurrences
202 -> UniqSupply -- No init count; set to 0
203 -> VarSet -- In scope (usually empty, but useful for nested calls)
204 -> BlackList -- Black-list function
208 initSmpl dflags chkr us in_scope black_list m
209 = case m dflags (emptySimplEnv chkr in_scope black_list) us
210 (zeroSimplCount dflags) of
211 (result, _, count) -> (result, count)
214 {-# INLINE thenSmpl #-}
215 {-# INLINE thenSmpl_ #-}
216 {-# INLINE returnSmpl #-}
218 returnSmpl :: a -> SimplM a
219 returnSmpl e dflags env us sc = (e, us, sc)
221 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
222 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
224 thenSmpl m k dflags env us0 sc0
225 = case (m dflags env us0 sc0) of
226 (m_result, us1, sc1) -> k m_result dflags env us1 sc1
228 thenSmpl_ m k dflags env us0 sc0
229 = case (m dflags env us0 sc0) of
230 (_, us1, sc1) -> k dflags env us1 sc1
235 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
236 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
238 mapSmpl f [] = returnSmpl []
240 = f x `thenSmpl` \ x' ->
241 mapSmpl f xs `thenSmpl` \ xs' ->
244 mapAndUnzipSmpl f [] = returnSmpl ([],[])
245 mapAndUnzipSmpl f (x:xs)
246 = f x `thenSmpl` \ (r1, r2) ->
247 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
248 returnSmpl (r1:rs1, r2:rs2)
250 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
251 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
252 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
253 returnSmpl (acc'', x':xs')
257 %************************************************************************
259 \subsection{The unique supply}
261 %************************************************************************
264 getUniqueSmpl :: SimplM Unique
265 getUniqueSmpl dflags env us sc
266 = case splitUniqSupply us of
267 (us1, us2) -> (uniqFromSupply us1, us2, sc)
269 getUniquesSmpl :: Int -> SimplM [Unique]
270 getUniquesSmpl n dflags env us sc
271 = case splitUniqSupply us of
272 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
274 getDOptsSmpl :: SimplM DynFlags
275 getDOptsSmpl dflags env us sc
280 %************************************************************************
282 \subsection{Counting up what we've done}
284 %************************************************************************
287 getSimplCount :: SimplM SimplCount
288 getSimplCount dflags env us sc = (sc, us, sc)
290 tick :: Tick -> SimplM ()
291 tick t dflags env us sc
292 = sc' `seq` ((), us, sc')
296 freeTick :: Tick -> SimplM ()
297 -- Record a tick, but don't add to the total tick count, which is
298 -- used to decide when nothing further has happened
299 freeTick t dflags env us sc
300 = sc' `seq` ((), us, sc')
302 sc' = doFreeTick t sc
306 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
308 zeroSimplCount :: DynFlags -> SimplCount
309 isZeroSimplCount :: SimplCount -> Bool
310 pprSimplCount :: SimplCount -> SDoc
311 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
312 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
316 data SimplCount = VerySimplZero -- These two are used when
317 | VerySimplNonZero -- we are only interested in
321 ticks :: !Int, -- Total ticks
322 details :: !TickCounts, -- How many of each type
324 log1 :: [Tick], -- Last N events; <= opt_HistorySize
325 log2 :: [Tick] -- Last opt_HistorySize events before that
328 type TickCounts = FiniteMap Tick Int
330 zeroSimplCount dflags
331 -- This is where we decide whether to do
332 -- the VerySimpl version or the full-stats version
333 | dopt Opt_D_dump_simpl_stats dflags
334 = SimplCount {ticks = 0, details = emptyFM,
335 n_log = 0, log1 = [], log2 = []}
339 isZeroSimplCount VerySimplZero = True
340 isZeroSimplCount (SimplCount { ticks = 0 }) = True
341 isZeroSimplCount other = False
343 doFreeTick tick sc@SimplCount { details = dts }
344 = dts' `seqFM` sc { details = dts' }
346 dts' = dts `addTick` tick
347 doFreeTick tick sc = sc
349 -- Gross hack to persuade GHC 3.03 to do this important seq
350 seqFM fm x | isEmptyFM fm = x
353 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
354 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
355 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
357 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
359 doTick tick sc = VerySimplNonZero -- The very simple case
362 -- Don't use plusFM_C because that's lazy, and we want to
363 -- be pretty strict here!
364 addTick :: TickCounts -> Tick -> TickCounts
365 addTick fm tick = case lookupFM fm tick of
366 Nothing -> addToFM fm tick 1
367 Just n -> n1 `seq` addToFM fm tick n1
372 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
373 sc2@(SimplCount { ticks = tks2, details = dts2 })
374 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
376 -- A hackish way of getting recent log info
377 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
378 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
381 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
382 plusSimplCount sc1 sc2 = VerySimplNonZero
384 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
385 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
386 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
387 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
389 pprTickCounts (fmToList dts),
390 if verboseSimplStats then
392 ptext SLIT("Log (most recent first)"),
393 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
397 pprTickCounts :: [(Tick,Int)] -> SDoc
398 pprTickCounts [] = empty
399 pprTickCounts ((tick1,n1):ticks)
400 = vcat [int tot_n <+> text (tickString tick1),
401 pprTCDetails real_these,
405 tick1_tag = tickToTag tick1
406 (these, others) = span same_tick ticks
407 real_these = (tick1,n1):these
408 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
409 tot_n = sum [n | (_,n) <- real_these]
411 pprTCDetails ticks@((tick,_):_)
412 | verboseSimplStats || isRuleFired tick
413 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
418 %************************************************************************
422 %************************************************************************
426 = PreInlineUnconditionally Id
427 | PostInlineUnconditionally Id
430 | RuleFired FAST_STRING -- Rule name
432 | LetFloatFromLet Id -- Thing floated out
433 | EtaExpansion Id -- LHS binder
434 | EtaReduction Id -- Binder on outer lambda
435 | BetaReduction Id -- Lambda binder
438 | CaseOfCase Id -- Bndr on *inner* case
439 | KnownBranch Id -- Case binder
440 | CaseMerge Id -- Binder on outer case
441 | CaseElim Id -- Case binder
442 | CaseIdentity Id -- Case binder
443 | FillInCaseDefault Id -- Case binder
446 | SimplifierDone -- Ticked at each iteration of the simplifier
448 isRuleFired (RuleFired _) = True
449 isRuleFired other = False
451 instance Outputable Tick where
452 ppr tick = text (tickString tick) <+> pprTickCts tick
454 instance Eq Tick where
455 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
457 instance Ord Tick where
460 tickToTag :: Tick -> Int
461 tickToTag (PreInlineUnconditionally _) = 0
462 tickToTag (PostInlineUnconditionally _) = 1
463 tickToTag (UnfoldingDone _) = 2
464 tickToTag (RuleFired _) = 3
465 tickToTag (LetFloatFromLet _) = 4
466 tickToTag (EtaExpansion _) = 5
467 tickToTag (EtaReduction _) = 6
468 tickToTag (BetaReduction _) = 7
469 tickToTag (CaseOfCase _) = 8
470 tickToTag (KnownBranch _) = 9
471 tickToTag (CaseMerge _) = 10
472 tickToTag (CaseElim _) = 11
473 tickToTag (CaseIdentity _) = 12
474 tickToTag (FillInCaseDefault _) = 13
475 tickToTag BottomFound = 14
476 tickToTag SimplifierDone = 16
478 tickString :: Tick -> String
479 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
480 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
481 tickString (UnfoldingDone _) = "UnfoldingDone"
482 tickString (RuleFired _) = "RuleFired"
483 tickString (LetFloatFromLet _) = "LetFloatFromLet"
484 tickString (EtaExpansion _) = "EtaExpansion"
485 tickString (EtaReduction _) = "EtaReduction"
486 tickString (BetaReduction _) = "BetaReduction"
487 tickString (CaseOfCase _) = "CaseOfCase"
488 tickString (KnownBranch _) = "KnownBranch"
489 tickString (CaseMerge _) = "CaseMerge"
490 tickString (CaseElim _) = "CaseElim"
491 tickString (CaseIdentity _) = "CaseIdentity"
492 tickString (FillInCaseDefault _) = "FillInCaseDefault"
493 tickString BottomFound = "BottomFound"
494 tickString SimplifierDone = "SimplifierDone"
496 pprTickCts :: Tick -> SDoc
497 pprTickCts (PreInlineUnconditionally v) = ppr v
498 pprTickCts (PostInlineUnconditionally v)= ppr v
499 pprTickCts (UnfoldingDone v) = ppr v
500 pprTickCts (RuleFired v) = ppr v
501 pprTickCts (LetFloatFromLet v) = ppr v
502 pprTickCts (EtaExpansion v) = ppr v
503 pprTickCts (EtaReduction v) = ppr v
504 pprTickCts (BetaReduction v) = ppr v
505 pprTickCts (CaseOfCase v) = ppr v
506 pprTickCts (KnownBranch v) = ppr v
507 pprTickCts (CaseMerge v) = ppr v
508 pprTickCts (CaseElim v) = ppr v
509 pprTickCts (CaseIdentity v) = ppr v
510 pprTickCts (FillInCaseDefault v) = ppr v
511 pprTickCts other = empty
513 cmpTick :: Tick -> Tick -> Ordering
514 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
516 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
519 -- Always distinguish RuleFired, so that the stats
520 -- can report them even in non-verbose mode
522 cmpEqTick :: Tick -> Tick -> Ordering
523 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
524 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
525 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
526 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
527 cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b
528 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
529 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
530 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
531 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
532 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
533 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
534 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
535 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
536 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
537 cmpEqTick other1 other2 = EQ
541 %************************************************************************
543 \subsubsection{Command-line switches}
545 %************************************************************************
548 getSwitchChecker :: SimplM SwitchChecker
549 getSwitchChecker dflags env us sc = (seChkr env, us, sc)
551 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
552 getSimplIntSwitch chkr switch
553 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
557 @setBlackList@ is used to prepare the environment for simplifying
558 the RHS of an Id that's marked with an INLINE pragma. It is going to
559 be inlined wherever they are used, and then all the inlining will take
560 effect. Meanwhile, there isn't much point in doing anything to the
561 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
563 (a) not doing so will inline a worker straight back into its wrapper!
565 and (b) Consider the following example
570 in ...g...g...g...g...g...
572 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
573 and thence copied multiple times when g is inlined.
575 Andy disagrees! Example:
576 all xs = foldr (&&) True xs
577 any p = all . map p {-# INLINE any #-}
579 Problem: any won't get deforested, and so if it's exported and
580 the importer doesn't use the inlining, (eg passes it as an arg)
581 then we won't get deforestation at all.
582 We havn't solved this problem yet!
584 We prepare the envt by simply modifying the black list.
588 We *don't* prevent inlining from happening for identifiers
589 that are marked as IMustBeINLINEd. An example of where
590 doing this is crucial is:
592 class Bar a => Foo a where
598 If `f' needs to peer inside Foo's superclass, Bar, it refers
599 to the appropriate super class selector, which is marked as
600 must-inlineable. We don't generate any code for a superclass
601 selector, so failing to inline it in the RHS of `f' will
602 leave a reference to a non-existent id, with bad consequences.
604 ALSO NOTE that we do all this by modifing the black list
605 not by zapping the unfolding. The latter may still be useful for
606 knowing when something is evaluated.
609 setBlackList :: BlackList -> SimplM a -> SimplM a
610 setBlackList black_list m dflags env us sc
611 = m dflags (env { seBlackList = black_list }) us sc
613 getBlackList :: SimplM BlackList
614 getBlackList dflags env us sc = (seBlackList env, us, sc)
616 noInlineBlackList :: BlackList
617 -- Inside inlinings, black list anything that is in scope or imported.
618 -- except for things that must be unfolded (Compulsory)
619 -- and data con wrappers. The latter is a hack, like the one in
620 -- SimplCore.simplRules, to make wrappers inline in rule LHSs.
621 -- We may as well do the same here.
622 noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
623 not (isDataConWrapId v)
624 -- NB: this implementation means that even inlinings *completely within*
625 -- an INLINE won't happen, which is perhaps overkill.
626 -- An earlier verion had: (v `isInScope` subst) || not (isLocallyDefined v)
627 -- but it's more expensive, and it probably doesn't matter.
631 %************************************************************************
633 \subsubsection{The ``enclosing cost-centre''}
635 %************************************************************************
638 getEnclosingCC :: SimplM CostCentreStack
639 getEnclosingCC dflags env us sc = (seCC env, us, sc)
641 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
642 setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc
646 %************************************************************************
648 \subsubsection{The @SimplEnv@ type}
650 %************************************************************************
654 emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv
656 emptySimplEnv sw_chkr in_scope black_list
657 = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
658 seBlackList = black_list,
659 seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
660 -- The top level "enclosing CC" is "SUBSUMED".
662 getEnv :: SimplM SimplEnv
663 getEnv dflags env us sc = (env, us, sc)
665 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
666 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags
667 (SimplEnv {seSubst = old_subst}) us sc
668 = m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)})
671 getSubst :: SimplM Subst
672 getSubst dflags env us sc = (seSubst env, us, sc)
674 setSubst :: Subst -> SimplM a -> SimplM a
675 setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc
677 getSubstEnv :: SimplM SubstEnv
678 getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc)
680 addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
681 -- The new Ids are guaranteed to be freshly allocated
682 addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc
683 = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
685 getInScope :: SimplM InScopeSet
686 getInScope dflags env us sc = (substInScope (seSubst env), us, sc)
688 setInScope :: InScopeSet -> SimplM a -> SimplM a
689 setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc
690 = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc
692 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
693 modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc
694 = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc
696 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
697 extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc
698 = m dflags (env { seSubst = Subst.extendSubst subst var res }) us sc
700 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
701 extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc
702 = m dflags (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
704 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
705 setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc
706 = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc
708 zapSubstEnv :: SimplM a -> SimplM a
709 zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc
710 = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc
712 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
713 getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc
714 = ((subst, us), us, sc)
716 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
717 setSimplBinderStuff (subst, us) m dflags env _ sc
718 = m dflags (env {seSubst = subst}) us sc
723 newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
724 -- Extends the in-scope-env too
725 newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc
726 = case splitUniqSupply us of
727 (us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v})
730 v = mkSysLocal fs (uniqFromSupply us1) ty
732 newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
733 newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
734 = case splitUniqSupply us of
735 (us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs})
738 vs = zipWithEqual "newIds" (mkSysLocal fs)
739 (uniqsFromSupply (length tys) us1) tys