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,
17 -- The inlining black-list
18 setBlackList, getBlackList, noInlineBlackList,
21 getUniqueSmpl, getUniquesSmpl,
27 getSimplCount, zeroSimplCount, pprSimplCount,
28 plusSimplCount, isZeroSimplCount,
31 SwitchChecker, getSwitchChecker, getSimplIntSwitch,
34 getEnclosingCC, setEnclosingCC,
37 getEnv, setAllExceptInScope,
39 getSubstEnv, extendSubst, extendSubstList,
40 getInScope, setInScope, modifyInScope, addNewInScopeIds,
41 setSubstEnv, zapSubstEnv,
42 getSimplBinderStuff, setSimplBinderStuff,
45 addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds,
46 addCaseBind, needsCaseBinding, addNonRecBind
49 #include "HsVersions.h"
51 import Id ( Id, mkSysLocal, idType, idUnfolding, isDataConWrapId )
53 import CoreUnfold ( isCompulsoryUnfolding )
54 import CoreUtils ( exprOkForSpeculation )
55 import PprCore () -- Instances
56 import CostCentre ( CostCentreStack, subsumedCCS )
57 import Name ( isLocallyDefined )
58 import OccName ( UserFS )
61 import qualified Subst
62 import Subst ( Subst, mkSubst, substEnv,
63 InScopeSet, mkInScopeSet, substInScope, isInScope
65 import Type ( Type, isUnLiftedType )
66 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
70 import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
71 opt_PprStyle_Debug, opt_HistorySize, opt_D_dump_simpl_stats,
74 import Unique ( Unique )
75 import Maybes ( expectJust )
76 import Util ( zipWithEqual )
79 infixr 0 `thenSmpl`, `thenSmpl_`
82 %************************************************************************
84 \subsection[Simplify-types]{Type declarations}
86 %************************************************************************
89 type InBinder = CoreBndr
90 type InId = Id -- Not yet cloned
91 type InType = Type -- Ditto
92 type InBind = CoreBind
93 type InExpr = CoreExpr
97 type OutBinder = CoreBndr
98 type OutId = Id -- Cloned
99 type OutType = Type -- Cloned
100 type OutBind = CoreBind
101 type OutExpr = CoreExpr
102 type OutAlt = CoreAlt
103 type OutArg = CoreArg
105 type SwitchChecker = SimplifierSwitch -> SwitchResult
107 type OutExprStuff = OutStuff (InScopeSet, OutExpr)
108 type OutStuff a = ([OutBind], a)
109 -- We return something equivalent to (let b in e), but
110 -- in pieces to avoid the quadratic blowup when floating
111 -- incrementally. Comments just before simplExprB in Simplify.lhs
115 addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
116 addLetBind bind thing_inside
117 = thing_inside `thenSmpl` \ (binds, res) ->
118 returnSmpl (bind : binds, res)
120 addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
121 addLetBinds binds1 thing_inside
122 = thing_inside `thenSmpl` \ (binds2, res) ->
123 returnSmpl (binds1 ++ binds2, res)
125 addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
126 -- Extends the in-scope environment as well as wrapping the bindings
127 addAuxiliaryBinds binds1 thing_inside
128 = addNewInScopeIds (bindersOfBinds binds1) $
129 addLetBinds binds1 thing_inside
131 addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
132 -- Extends the in-scope environment as well as wrapping the bindings
133 addAuxiliaryBind bind thing_inside
134 = addNewInScopeIds (bindersOf bind) $
135 addLetBind bind thing_inside
137 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
138 -- Make a case expression instead of a let
139 -- These can arise either from the desugarer,
140 -- or from beta reductions: (\x.e) (x +# y)
142 addCaseBind bndr rhs thing_inside
143 = getInScope `thenSmpl` \ in_scope ->
144 thing_inside `thenSmpl` \ (floats, (_, body)) ->
145 returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets floats body)]))
147 addNonRecBind bndr rhs thing_inside
148 -- Checks for needing a case binding
149 | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
150 | otherwise = addLetBind (NonRec bndr rhs) thing_inside
154 %************************************************************************
156 \subsection{Monad plumbing}
158 %************************************************************************
160 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
161 (Command-line switches move around through the explicitly-passed SimplEnv.)
164 type SimplM result -- We thread the unique supply because
165 = SimplEnv -- constantly splitting it is rather expensive
168 -> (result, UniqSupply, SimplCount)
170 type BlackList = Id -> Bool -- True => don't inline this Id
174 seChkr :: SwitchChecker,
175 seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
176 seBlackList :: BlackList,
177 seSubst :: Subst -- The current substitution
179 -- The range of the substitution is OutType and OutExpr resp
181 -- The substitution is idempotent
182 -- It *must* be applied; things in its domain simply aren't
183 -- bound in the result.
185 -- The substitution usually maps an Id to its clone,
186 -- but if the orig defn is a let-binding, and
187 -- the RHS of the let simplifies to an atom,
188 -- we just add the binding to the substitution and elide the let.
190 -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
191 -- The elements of the set may have better IdInfo than the
192 -- occurrences of in-scope Ids, and (more important) they will
193 -- have a correctly-substituted type. So we use a lookup in this
194 -- set to replace occurrences
198 initSmpl :: SwitchChecker
199 -> UniqSupply -- No init count; set to 0
200 -> VarSet -- In scope (usually empty, but useful for nested calls)
201 -> BlackList -- Black-list function
205 initSmpl chkr us in_scope black_list m
206 = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
207 (result, _, count) -> (result, count)
210 {-# INLINE thenSmpl #-}
211 {-# INLINE thenSmpl_ #-}
212 {-# INLINE returnSmpl #-}
214 returnSmpl :: a -> SimplM a
215 returnSmpl e env us sc = (e, us, sc)
217 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
218 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
220 thenSmpl m k env us0 sc0
221 = case (m env us0 sc0) of
222 (m_result, us1, sc1) -> k m_result env us1 sc1
224 thenSmpl_ m k env us0 sc0
225 = case (m env us0 sc0) of
226 (_, us1, sc1) -> k env us1 sc1
231 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
232 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
234 mapSmpl f [] = returnSmpl []
236 = f x `thenSmpl` \ x' ->
237 mapSmpl f xs `thenSmpl` \ xs' ->
240 mapAndUnzipSmpl f [] = returnSmpl ([],[])
241 mapAndUnzipSmpl f (x:xs)
242 = f x `thenSmpl` \ (r1, r2) ->
243 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
244 returnSmpl (r1:rs1, r2:rs2)
246 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
247 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
248 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
249 returnSmpl (acc'', x':xs')
253 %************************************************************************
255 \subsection{The unique supply}
257 %************************************************************************
260 getUniqueSmpl :: SimplM Unique
261 getUniqueSmpl env us sc = case splitUniqSupply us of
262 (us1, us2) -> (uniqFromSupply us1, us2, sc)
264 getUniquesSmpl :: Int -> SimplM [Unique]
265 getUniquesSmpl n env us sc = case splitUniqSupply us of
266 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
270 %************************************************************************
272 \subsection{Counting up what we've done}
274 %************************************************************************
277 getSimplCount :: SimplM SimplCount
278 getSimplCount env us sc = (sc, us, sc)
280 tick :: Tick -> SimplM ()
281 tick t env us sc = sc' `seq` ((), us, sc')
285 freeTick :: Tick -> SimplM ()
286 -- Record a tick, but don't add to the total tick count, which is
287 -- used to decide when nothing further has happened
288 freeTick t env us sc = sc' `seq` ((), us, sc')
290 sc' = doFreeTick t sc
294 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
296 zeroSimplCount :: SimplCount
297 isZeroSimplCount :: SimplCount -> Bool
298 pprSimplCount :: SimplCount -> SDoc
299 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
300 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
304 data SimplCount = VerySimplZero -- These two are used when
305 | VerySimplNonZero -- we are only interested in
309 ticks :: !Int, -- Total ticks
310 details :: !TickCounts, -- How many of each type
312 log1 :: [Tick], -- Last N events; <= opt_HistorySize
313 log2 :: [Tick] -- Last opt_HistorySize events before that
316 type TickCounts = FiniteMap Tick Int
318 zeroSimplCount -- This is where we decide whether to do
319 -- the VerySimpl version or the full-stats version
320 | opt_D_dump_simpl_stats = SimplCount {ticks = 0, details = emptyFM,
321 n_log = 0, log1 = [], log2 = []}
322 | otherwise = VerySimplZero
324 isZeroSimplCount VerySimplZero = True
325 isZeroSimplCount (SimplCount { ticks = 0 }) = True
326 isZeroSimplCount other = False
328 doFreeTick tick sc@SimplCount { details = dts }
329 = dts' `seqFM` sc { details = dts' }
331 dts' = dts `addTick` tick
332 doFreeTick tick sc = sc
334 -- Gross hack to persuade GHC 3.03 to do this important seq
335 seqFM fm x | isEmptyFM fm = x
338 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
339 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
340 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
342 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
344 doTick tick sc = VerySimplNonZero -- The very simple case
347 -- Don't use plusFM_C because that's lazy, and we want to
348 -- be pretty strict here!
349 addTick :: TickCounts -> Tick -> TickCounts
350 addTick fm tick = case lookupFM fm tick of
351 Nothing -> addToFM fm tick 1
352 Just n -> n1 `seq` addToFM fm tick n1
357 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
358 sc2@(SimplCount { ticks = tks2, details = dts2 })
359 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
361 -- A hackish way of getting recent log info
362 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
363 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
366 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
367 plusSimplCount sc1 sc2 = VerySimplNonZero
369 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
370 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
371 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
372 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
374 pprTickCounts (fmToList dts),
375 if verboseSimplStats then
377 ptext SLIT("Log (most recent first)"),
378 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
382 pprTickCounts :: [(Tick,Int)] -> SDoc
383 pprTickCounts [] = empty
384 pprTickCounts ((tick1,n1):ticks)
385 = vcat [int tot_n <+> text (tickString tick1),
386 pprTCDetails real_these,
390 tick1_tag = tickToTag tick1
391 (these, others) = span same_tick ticks
392 real_these = (tick1,n1):these
393 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
394 tot_n = sum [n | (_,n) <- real_these]
396 pprTCDetails ticks@((tick,_):_)
397 | verboseSimplStats || isRuleFired tick
398 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
403 %************************************************************************
407 %************************************************************************
411 = PreInlineUnconditionally Id
412 | PostInlineUnconditionally Id
415 | RuleFired FAST_STRING -- Rule name
417 | LetFloatFromLet Id -- Thing floated out
418 | EtaExpansion Id -- LHS binder
419 | EtaReduction Id -- Binder on outer lambda
420 | BetaReduction Id -- Lambda binder
423 | CaseOfCase Id -- Bndr on *inner* case
424 | KnownBranch Id -- Case binder
425 | CaseMerge Id -- Binder on outer case
426 | CaseElim Id -- Case binder
427 | CaseIdentity Id -- Case binder
428 | FillInCaseDefault Id -- Case binder
431 | SimplifierDone -- Ticked at each iteration of the simplifier
433 isRuleFired (RuleFired _) = True
434 isRuleFired other = False
436 instance Outputable Tick where
437 ppr tick = text (tickString tick) <+> pprTickCts tick
439 instance Eq Tick where
440 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
442 instance Ord Tick where
445 tickToTag :: Tick -> Int
446 tickToTag (PreInlineUnconditionally _) = 0
447 tickToTag (PostInlineUnconditionally _) = 1
448 tickToTag (UnfoldingDone _) = 2
449 tickToTag (RuleFired _) = 3
450 tickToTag (LetFloatFromLet _) = 4
451 tickToTag (EtaExpansion _) = 5
452 tickToTag (EtaReduction _) = 6
453 tickToTag (BetaReduction _) = 7
454 tickToTag (CaseOfCase _) = 8
455 tickToTag (KnownBranch _) = 9
456 tickToTag (CaseMerge _) = 10
457 tickToTag (CaseElim _) = 11
458 tickToTag (CaseIdentity _) = 12
459 tickToTag (FillInCaseDefault _) = 13
460 tickToTag BottomFound = 14
461 tickToTag SimplifierDone = 16
463 tickString :: Tick -> String
464 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
465 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
466 tickString (UnfoldingDone _) = "UnfoldingDone"
467 tickString (RuleFired _) = "RuleFired"
468 tickString (LetFloatFromLet _) = "LetFloatFromLet"
469 tickString (EtaExpansion _) = "EtaExpansion"
470 tickString (EtaReduction _) = "EtaReduction"
471 tickString (BetaReduction _) = "BetaReduction"
472 tickString (CaseOfCase _) = "CaseOfCase"
473 tickString (KnownBranch _) = "KnownBranch"
474 tickString (CaseMerge _) = "CaseMerge"
475 tickString (CaseElim _) = "CaseElim"
476 tickString (CaseIdentity _) = "CaseIdentity"
477 tickString (FillInCaseDefault _) = "FillInCaseDefault"
478 tickString BottomFound = "BottomFound"
479 tickString SimplifierDone = "SimplifierDone"
481 pprTickCts :: Tick -> SDoc
482 pprTickCts (PreInlineUnconditionally v) = ppr v
483 pprTickCts (PostInlineUnconditionally v)= ppr v
484 pprTickCts (UnfoldingDone v) = ppr v
485 pprTickCts (RuleFired v) = ppr v
486 pprTickCts (LetFloatFromLet v) = ppr v
487 pprTickCts (EtaExpansion v) = ppr v
488 pprTickCts (EtaReduction v) = ppr v
489 pprTickCts (BetaReduction v) = ppr v
490 pprTickCts (CaseOfCase v) = ppr v
491 pprTickCts (KnownBranch v) = ppr v
492 pprTickCts (CaseMerge v) = ppr v
493 pprTickCts (CaseElim v) = ppr v
494 pprTickCts (CaseIdentity v) = ppr v
495 pprTickCts (FillInCaseDefault v) = ppr v
496 pprTickCts other = empty
498 cmpTick :: Tick -> Tick -> Ordering
499 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
501 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
504 -- Always distinguish RuleFired, so that the stats
505 -- can report them even in non-verbose mode
507 cmpEqTick :: Tick -> Tick -> Ordering
508 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
509 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
510 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
511 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
512 cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b
513 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
514 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
515 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
516 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
517 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
518 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
519 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
520 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
521 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
522 cmpEqTick other1 other2 = EQ
526 %************************************************************************
528 \subsubsection{Command-line switches}
530 %************************************************************************
533 getSwitchChecker :: SimplM SwitchChecker
534 getSwitchChecker env us sc = (seChkr env, us, sc)
536 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
537 getSimplIntSwitch chkr switch
538 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
542 @setBlackList@ is used to prepare the environment for simplifying
543 the RHS of an Id that's marked with an INLINE pragma. It is going to
544 be inlined wherever they are used, and then all the inlining will take
545 effect. Meanwhile, there isn't much point in doing anything to the
546 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
548 (a) not doing so will inline a worker straight back into its wrapper!
550 and (b) Consider the following example
555 in ...g...g...g...g...g...
557 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
558 and thence copied multiple times when g is inlined.
560 Andy disagrees! Example:
561 all xs = foldr (&&) True xs
562 any p = all . map p {-# INLINE any #-}
564 Problem: any won't get deforested, and so if it's exported and
565 the importer doesn't use the inlining, (eg passes it as an arg)
566 then we won't get deforestation at all.
567 We havn't solved this problem yet!
569 We prepare the envt by simply modifying the black list.
573 We *don't* prevent inlining from happening for identifiers
574 that are marked as IMustBeINLINEd. An example of where
575 doing this is crucial is:
577 class Bar a => Foo a where
583 If `f' needs to peer inside Foo's superclass, Bar, it refers
584 to the appropriate super class selector, which is marked as
585 must-inlineable. We don't generate any code for a superclass
586 selector, so failing to inline it in the RHS of `f' will
587 leave a reference to a non-existent id, with bad consequences.
589 ALSO NOTE that we do all this by modifing the black list
590 not by zapping the unfolding. The latter may still be useful for
591 knowing when something is evaluated.
594 setBlackList :: BlackList -> SimplM a -> SimplM a
595 setBlackList black_list m env us sc = m (env { seBlackList = black_list }) us sc
597 getBlackList :: SimplM BlackList
598 getBlackList env us sc = (seBlackList env, us, sc)
600 noInlineBlackList :: BlackList
601 -- Inside inlinings, black list anything that is in scope or imported.
602 -- except for things that must be unfolded (Compulsory)
603 -- and data con wrappers. The latter is a hack, like the one in
604 -- SimplCore.simplRules, to make wrappers inline in rule LHSs.
605 -- We may as well do the same here.
606 noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
607 not (isDataConWrapId v)
608 -- NB: this implementation means that even inlinings *completely within*
609 -- an INLINE won't happen, which is perhaps overkill.
610 -- An earlier verion had: (v `isInScope` subst) || not (isLocallyDefined v)
611 -- but it's more expensive, and it probably doesn't matter.
615 %************************************************************************
617 \subsubsection{The ``enclosing cost-centre''}
619 %************************************************************************
622 getEnclosingCC :: SimplM CostCentreStack
623 getEnclosingCC env us sc = (seCC env, us, sc)
625 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
626 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
630 %************************************************************************
632 \subsubsection{The @SimplEnv@ type}
634 %************************************************************************
638 emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv
640 emptySimplEnv sw_chkr in_scope black_list
641 = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
642 seBlackList = black_list,
643 seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
644 -- The top level "enclosing CC" is "SUBSUMED".
646 getEnv :: SimplM SimplEnv
647 getEnv env us sc = (env, us, sc)
649 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
650 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m
651 (SimplEnv {seSubst = old_subst}) us sc
652 = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
654 getSubst :: SimplM Subst
655 getSubst env us sc = (seSubst env, us, sc)
657 setSubst :: Subst -> SimplM a -> SimplM a
658 setSubst subst m env us sc = m (env {seSubst = subst}) us sc
660 getSubstEnv :: SimplM SubstEnv
661 getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
663 addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
664 -- The new Ids are guaranteed to be freshly allocated
665 addNewInScopeIds vs m env@(SimplEnv {seSubst = subst}) us sc
666 = m (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
668 getInScope :: SimplM InScopeSet
669 getInScope env us sc = (substInScope (seSubst env), us, sc)
671 setInScope :: InScopeSet -> SimplM a -> SimplM a
672 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
673 = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
675 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
676 modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc
677 = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
679 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
680 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
681 = m (env { seSubst = Subst.extendSubst subst var res }) us sc
683 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
684 extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
685 = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
687 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
688 setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
689 = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
691 zapSubstEnv :: SimplM a -> SimplM a
692 zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
693 = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
695 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
696 getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
697 = ((subst, us), us, sc)
699 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
700 setSimplBinderStuff (subst, us) m env _ sc
701 = m (env {seSubst = subst}) us sc
706 newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
707 -- Extends the in-scope-env too
708 newId fs ty m env@(SimplEnv {seSubst = subst}) us sc
709 = case splitUniqSupply us of
710 (us1, us2) -> m v (env {seSubst = Subst.extendNewInScope subst v}) us2 sc
712 v = mkSysLocal fs (uniqFromSupply us1) ty
714 newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
715 newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc
716 = case splitUniqSupply us of
717 (us1, us2) -> m vs (env {seSubst = Subst.extendNewInScopeList subst vs}) us2 sc
719 vs = zipWithEqual "newIds" (mkSysLocal fs)
720 (uniqsFromSupply (length tys) us1) tys