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 Name ( isLocallyDefined )
59 import OccName ( UserFS )
62 import qualified Subst
63 import Subst ( Subst, mkSubst, substEnv,
64 InScopeSet, mkInScopeSet, substInScope, isInScope
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 (InScopeSet, OutExpr)
110 type OutStuff a = ([OutBind], 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 addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
118 addLetBind bind thing_inside
119 = thing_inside `thenSmpl` \ (binds, res) ->
120 returnSmpl (bind : binds, res)
122 addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
123 addLetBinds binds1 thing_inside
124 = thing_inside `thenSmpl` \ (binds2, res) ->
125 returnSmpl (binds1 ++ binds2, res)
127 addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
128 -- Extends the in-scope environment as well as wrapping the bindings
129 addAuxiliaryBinds binds1 thing_inside
130 = addNewInScopeIds (bindersOfBinds binds1) $
131 addLetBinds binds1 thing_inside
133 addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
134 -- Extends the in-scope environment as well as wrapping the bindings
135 addAuxiliaryBind bind thing_inside
136 = addNewInScopeIds (bindersOf bind) $
137 addLetBind bind thing_inside
139 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
140 -- Make a case expression instead of a let
141 -- These can arise either from the desugarer,
142 -- or from beta reductions: (\x.e) (x +# y)
144 addCaseBind bndr rhs thing_inside
145 = getInScope `thenSmpl` \ in_scope ->
146 thing_inside `thenSmpl` \ (floats, (_, body)) ->
147 returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets floats body)]))
149 addNonRecBind bndr rhs thing_inside
150 -- Checks for needing a case binding
151 | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
152 | otherwise = addLetBind (NonRec bndr rhs) thing_inside
156 %************************************************************************
158 \subsection{Monad plumbing}
160 %************************************************************************
162 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
163 (Command-line switches move around through the explicitly-passed SimplEnv.)
168 -> SimplEnv -- We thread the unique supply because
169 -> UniqSupply -- constantly splitting it is rather expensive
171 -> (result, UniqSupply, SimplCount)
173 type BlackList = Id -> Bool -- True => don't inline this Id
177 seChkr :: SwitchChecker,
178 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
179 seBlackList :: BlackList,
180 seSubst :: Subst -- The current substitution
182 -- The range of the substitution is OutType and OutExpr resp
184 -- The substitution is idempotent
185 -- It *must* be applied; things in its domain simply aren't
186 -- bound in the result.
188 -- The substitution usually maps an Id to its clone,
189 -- but if the orig defn is a let-binding, and
190 -- the RHS of the let simplifies to an atom,
191 -- we just add the binding to the substitution and elide the let.
193 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
194 -- The elements of the set may have better IdInfo than the
195 -- occurrences of in-scope Ids, and (more important) they will
196 -- have a correctly-substituted type. So we use a lookup in this
197 -- set to replace occurrences
203 -> UniqSupply -- No init count; set to 0
204 -> VarSet -- In scope (usually empty, but useful for nested calls)
205 -> BlackList -- Black-list function
209 initSmpl dflags chkr us in_scope black_list m
210 = case m dflags (emptySimplEnv chkr in_scope black_list) us
211 (zeroSimplCount dflags) of
212 (result, _, count) -> (result, count)
215 {-# INLINE thenSmpl #-}
216 {-# INLINE thenSmpl_ #-}
217 {-# INLINE returnSmpl #-}
219 returnSmpl :: a -> SimplM a
220 returnSmpl e dflags env us sc = (e, us, sc)
222 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
223 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
225 thenSmpl m k dflags env us0 sc0
226 = case (m dflags env us0 sc0) of
227 (m_result, us1, sc1) -> k m_result dflags env us1 sc1
229 thenSmpl_ m k dflags env us0 sc0
230 = case (m dflags env us0 sc0) of
231 (_, us1, sc1) -> k dflags env us1 sc1
236 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
237 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
239 mapSmpl f [] = returnSmpl []
241 = f x `thenSmpl` \ x' ->
242 mapSmpl f xs `thenSmpl` \ xs' ->
245 mapAndUnzipSmpl f [] = returnSmpl ([],[])
246 mapAndUnzipSmpl f (x:xs)
247 = f x `thenSmpl` \ (r1, r2) ->
248 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
249 returnSmpl (r1:rs1, r2:rs2)
251 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
252 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
253 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
254 returnSmpl (acc'', x':xs')
258 %************************************************************************
260 \subsection{The unique supply}
262 %************************************************************************
265 getUniqueSmpl :: SimplM Unique
266 getUniqueSmpl dflags env us sc
267 = case splitUniqSupply us of
268 (us1, us2) -> (uniqFromSupply us1, us2, sc)
270 getUniquesSmpl :: Int -> SimplM [Unique]
271 getUniquesSmpl n dflags env us sc
272 = case splitUniqSupply us of
273 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
275 getDOptsSmpl :: SimplM DynFlags
276 getDOptsSmpl dflags env us sc
281 %************************************************************************
283 \subsection{Counting up what we've done}
285 %************************************************************************
288 getSimplCount :: SimplM SimplCount
289 getSimplCount dflags env us sc = (sc, us, sc)
291 tick :: Tick -> SimplM ()
292 tick t dflags env us sc
293 = sc' `seq` ((), us, sc')
297 freeTick :: Tick -> SimplM ()
298 -- Record a tick, but don't add to the total tick count, which is
299 -- used to decide when nothing further has happened
300 freeTick t dflags env us sc
301 = sc' `seq` ((), us, sc')
303 sc' = doFreeTick t sc
307 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
309 zeroSimplCount :: DynFlags -> SimplCount
310 isZeroSimplCount :: SimplCount -> Bool
311 pprSimplCount :: SimplCount -> SDoc
312 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
313 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
317 data SimplCount = VerySimplZero -- These two are used when
318 | VerySimplNonZero -- we are only interested in
322 ticks :: !Int, -- Total ticks
323 details :: !TickCounts, -- How many of each type
325 log1 :: [Tick], -- Last N events; <= opt_HistorySize
326 log2 :: [Tick] -- Last opt_HistorySize events before that
329 type TickCounts = FiniteMap Tick Int
331 zeroSimplCount dflags
332 -- This is where we decide whether to do
333 -- the VerySimpl version or the full-stats version
334 | dopt Opt_D_dump_simpl_stats dflags
335 = SimplCount {ticks = 0, details = emptyFM,
336 n_log = 0, log1 = [], log2 = []}
340 isZeroSimplCount VerySimplZero = True
341 isZeroSimplCount (SimplCount { ticks = 0 }) = True
342 isZeroSimplCount other = False
344 doFreeTick tick sc@SimplCount { details = dts }
345 = dts' `seqFM` sc { details = dts' }
347 dts' = dts `addTick` tick
348 doFreeTick tick sc = sc
350 -- Gross hack to persuade GHC 3.03 to do this important seq
351 seqFM fm x | isEmptyFM fm = x
354 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
355 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
356 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
358 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
360 doTick tick sc = VerySimplNonZero -- The very simple case
363 -- Don't use plusFM_C because that's lazy, and we want to
364 -- be pretty strict here!
365 addTick :: TickCounts -> Tick -> TickCounts
366 addTick fm tick = case lookupFM fm tick of
367 Nothing -> addToFM fm tick 1
368 Just n -> n1 `seq` addToFM fm tick n1
373 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
374 sc2@(SimplCount { ticks = tks2, details = dts2 })
375 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
377 -- A hackish way of getting recent log info
378 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
379 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
382 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
383 plusSimplCount sc1 sc2 = VerySimplNonZero
385 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
386 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
387 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
388 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
390 pprTickCounts (fmToList dts),
391 if verboseSimplStats then
393 ptext SLIT("Log (most recent first)"),
394 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
398 pprTickCounts :: [(Tick,Int)] -> SDoc
399 pprTickCounts [] = empty
400 pprTickCounts ((tick1,n1):ticks)
401 = vcat [int tot_n <+> text (tickString tick1),
402 pprTCDetails real_these,
406 tick1_tag = tickToTag tick1
407 (these, others) = span same_tick ticks
408 real_these = (tick1,n1):these
409 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
410 tot_n = sum [n | (_,n) <- real_these]
412 pprTCDetails ticks@((tick,_):_)
413 | verboseSimplStats || isRuleFired tick
414 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
419 %************************************************************************
423 %************************************************************************
427 = PreInlineUnconditionally Id
428 | PostInlineUnconditionally Id
431 | RuleFired FAST_STRING -- Rule name
433 | LetFloatFromLet Id -- Thing floated out
434 | EtaExpansion Id -- LHS binder
435 | EtaReduction Id -- Binder on outer lambda
436 | BetaReduction Id -- Lambda binder
439 | CaseOfCase Id -- Bndr on *inner* case
440 | KnownBranch Id -- Case binder
441 | CaseMerge Id -- Binder on outer case
442 | CaseElim Id -- Case binder
443 | CaseIdentity Id -- Case binder
444 | FillInCaseDefault Id -- Case binder
447 | SimplifierDone -- Ticked at each iteration of the simplifier
449 isRuleFired (RuleFired _) = True
450 isRuleFired other = False
452 instance Outputable Tick where
453 ppr tick = text (tickString tick) <+> pprTickCts tick
455 instance Eq Tick where
456 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
458 instance Ord Tick where
461 tickToTag :: Tick -> Int
462 tickToTag (PreInlineUnconditionally _) = 0
463 tickToTag (PostInlineUnconditionally _) = 1
464 tickToTag (UnfoldingDone _) = 2
465 tickToTag (RuleFired _) = 3
466 tickToTag (LetFloatFromLet _) = 4
467 tickToTag (EtaExpansion _) = 5
468 tickToTag (EtaReduction _) = 6
469 tickToTag (BetaReduction _) = 7
470 tickToTag (CaseOfCase _) = 8
471 tickToTag (KnownBranch _) = 9
472 tickToTag (CaseMerge _) = 10
473 tickToTag (CaseElim _) = 11
474 tickToTag (CaseIdentity _) = 12
475 tickToTag (FillInCaseDefault _) = 13
476 tickToTag BottomFound = 14
477 tickToTag SimplifierDone = 16
479 tickString :: Tick -> String
480 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
481 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
482 tickString (UnfoldingDone _) = "UnfoldingDone"
483 tickString (RuleFired _) = "RuleFired"
484 tickString (LetFloatFromLet _) = "LetFloatFromLet"
485 tickString (EtaExpansion _) = "EtaExpansion"
486 tickString (EtaReduction _) = "EtaReduction"
487 tickString (BetaReduction _) = "BetaReduction"
488 tickString (CaseOfCase _) = "CaseOfCase"
489 tickString (KnownBranch _) = "KnownBranch"
490 tickString (CaseMerge _) = "CaseMerge"
491 tickString (CaseElim _) = "CaseElim"
492 tickString (CaseIdentity _) = "CaseIdentity"
493 tickString (FillInCaseDefault _) = "FillInCaseDefault"
494 tickString BottomFound = "BottomFound"
495 tickString SimplifierDone = "SimplifierDone"
497 pprTickCts :: Tick -> SDoc
498 pprTickCts (PreInlineUnconditionally v) = ppr v
499 pprTickCts (PostInlineUnconditionally v)= ppr v
500 pprTickCts (UnfoldingDone v) = ppr v
501 pprTickCts (RuleFired v) = ppr v
502 pprTickCts (LetFloatFromLet v) = ppr v
503 pprTickCts (EtaExpansion v) = ppr v
504 pprTickCts (EtaReduction v) = ppr v
505 pprTickCts (BetaReduction v) = ppr v
506 pprTickCts (CaseOfCase v) = ppr v
507 pprTickCts (KnownBranch v) = ppr v
508 pprTickCts (CaseMerge v) = ppr v
509 pprTickCts (CaseElim v) = ppr v
510 pprTickCts (CaseIdentity v) = ppr v
511 pprTickCts (FillInCaseDefault v) = ppr v
512 pprTickCts other = empty
514 cmpTick :: Tick -> Tick -> Ordering
515 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
517 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
520 -- Always distinguish RuleFired, so that the stats
521 -- can report them even in non-verbose mode
523 cmpEqTick :: Tick -> Tick -> Ordering
524 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
525 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
526 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
527 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
528 cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b
529 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
530 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
531 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
532 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
533 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
534 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
535 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
536 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
537 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
538 cmpEqTick other1 other2 = EQ
542 %************************************************************************
544 \subsubsection{Command-line switches}
546 %************************************************************************
549 getSwitchChecker :: SimplM SwitchChecker
550 getSwitchChecker dflags env us sc = (seChkr env, us, sc)
552 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
553 getSimplIntSwitch chkr switch
554 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
558 @setBlackList@ is used to prepare the environment for simplifying
559 the RHS of an Id that's marked with an INLINE pragma. It is going to
560 be inlined wherever they are used, and then all the inlining will take
561 effect. Meanwhile, there isn't much point in doing anything to the
562 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
564 (a) not doing so will inline a worker straight back into its wrapper!
566 and (b) Consider the following example
571 in ...g...g...g...g...g...
573 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
574 and thence copied multiple times when g is inlined.
576 Andy disagrees! Example:
577 all xs = foldr (&&) True xs
578 any p = all . map p {-# INLINE any #-}
580 Problem: any won't get deforested, and so if it's exported and
581 the importer doesn't use the inlining, (eg passes it as an arg)
582 then we won't get deforestation at all.
583 We havn't solved this problem yet!
585 We prepare the envt by simply modifying the black list.
589 We *don't* prevent inlining from happening for identifiers
590 that are marked as IMustBeINLINEd. An example of where
591 doing this is crucial is:
593 class Bar a => Foo a where
599 If `f' needs to peer inside Foo's superclass, Bar, it refers
600 to the appropriate super class selector, which is marked as
601 must-inlineable. We don't generate any code for a superclass
602 selector, so failing to inline it in the RHS of `f' will
603 leave a reference to a non-existent id, with bad consequences.
605 ALSO NOTE that we do all this by modifing the black list
606 not by zapping the unfolding. The latter may still be useful for
607 knowing when something is evaluated.
610 setBlackList :: BlackList -> SimplM a -> SimplM a
611 setBlackList black_list m dflags env us sc
612 = m dflags (env { seBlackList = black_list }) us sc
614 getBlackList :: SimplM BlackList
615 getBlackList dflags env us sc = (seBlackList env, us, sc)
617 noInlineBlackList :: BlackList
618 -- Inside inlinings, black list anything that is in scope or imported.
619 -- except for things that must be unfolded (Compulsory)
620 -- and data con wrappers. The latter is a hack, like the one in
621 -- SimplCore.simplRules, to make wrappers inline in rule LHSs.
622 -- We may as well do the same here.
623 noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
624 not (isDataConWrapId v)
625 -- NB: this implementation means that even inlinings *completely within*
626 -- an INLINE won't happen, which is perhaps overkill.
627 -- An earlier verion had: (v `isInScope` subst) || not (isLocallyDefined v)
628 -- but it's more expensive, and it probably doesn't matter.
632 %************************************************************************
634 \subsubsection{The ``enclosing cost-centre''}
636 %************************************************************************
639 getEnclosingCC :: SimplM CostCentreStack
640 getEnclosingCC dflags env us sc = (seCC env, us, sc)
642 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
643 setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc
647 %************************************************************************
649 \subsubsection{The @SimplEnv@ type}
651 %************************************************************************
655 emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv
657 emptySimplEnv sw_chkr in_scope black_list
658 = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
659 seBlackList = black_list,
660 seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
661 -- The top level "enclosing CC" is "SUBSUMED".
663 getEnv :: SimplM SimplEnv
664 getEnv dflags env us sc = (env, us, sc)
666 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
667 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags
668 (SimplEnv {seSubst = old_subst}) us sc
669 = m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)})
672 getSubst :: SimplM Subst
673 getSubst dflags env us sc = (seSubst env, us, sc)
675 setSubst :: Subst -> SimplM a -> SimplM a
676 setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc
678 getSubstEnv :: SimplM SubstEnv
679 getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc)
681 addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
682 -- The new Ids are guaranteed to be freshly allocated
683 addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc
684 = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
686 getInScope :: SimplM InScopeSet
687 getInScope dflags env us sc = (substInScope (seSubst env), us, sc)
689 setInScope :: InScopeSet -> SimplM a -> SimplM a
690 setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc
691 = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc
693 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
694 modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc
695 = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc
697 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
698 extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc
699 = m dflags (env { seSubst = Subst.extendSubst subst var res }) us sc
701 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
702 extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc
703 = m dflags (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
705 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
706 setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc
707 = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc
709 zapSubstEnv :: SimplM a -> SimplM a
710 zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc
711 = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc
713 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
714 getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc
715 = ((subst, us), us, sc)
717 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
718 setSimplBinderStuff (subst, us) m dflags env _ sc
719 = m dflags (env {seSubst = subst}) us sc
724 newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
725 -- Extends the in-scope-env too
726 newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc
727 = case splitUniqSupply us of
728 (us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v})
731 v = mkSysLocal fs (uniqFromSupply us1) ty
733 newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
734 newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
735 = case splitUniqSupply us of
736 (us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs})
739 vs = zipWithEqual "newIds" (mkSysLocal fs)
740 (uniqsFromSupply (length tys) us1) tys