ghc/compiler/simplCore/SimplMonad.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[SimplMonad]{The simplifier Monad}
   5
   6 \begin{code}
   7 module SimplMonad (
   8         InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
   9         OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
  10         OutExprStuff, OutStuff,
  11
  12         -- The continuation type
  13         SimplCont(..), DupFlag(..), contIsDupable, contResultType,
  14
  15         -- The monad
  16         SimplM,
  17         initSmpl, returnSmpl, thenSmpl, thenSmpl_,
  18         mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
  19
  20         -- Unique supply
  21         getUniqueSmpl, getUniquesSmpl,
  22         newId, newIds,
  23
  24         -- Counting
  25         SimplCount, TickType(..), TickCounts,
  26         tick, tickUnfold,
  27         getSimplCount, zeroSimplCount, pprSimplCount,
  28         plusSimplCount, isZeroSimplCount,
  29
  30         -- Switch checker
  31         SwitchChecker, getSwitchChecker, getSimplIntSwitch,
  32
  33         -- Cost centres
  34         getEnclosingCC, setEnclosingCC,
  35
  36         -- Environments
  37         InScopeEnv, SubstEnv,
  38         getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
  39         emptySubstEnv, getSubstEnv, setSubstEnv, zapSubstEnv,
  40         extendIdSubst, extendTySubst,
  41         getTyEnv, getValEnv,
  42         getSimplBinderStuff, setSimplBinderStuff,
  43         switchOffInlining
  44     ) where
  45
  46 #include "HsVersions.h"
  47
  48 import Id               ( Id, mkSysLocal, idMustBeINLINEd )
  49 import IdInfo           ( InlinePragInfo(..) )
  50 import Demand           ( Demand )
  51 import CoreSyn
  52 import CoreUtils        ( IdSubst, SubstCoreExpr, coreExprType, coreAltsType )
  53 import CostCentre       ( CostCentreStack, subsumedCCS )
  54 import Var              ( TyVar )
  55 import VarEnv
  56 import VarSet
  57 import Type             ( Type, TyVarSubst, funResultTy, fullSubstTy, applyTy )
  58 import UniqSupply       ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
  59                           UniqSupply
  60                         )
  61 import CmdLineOpts      ( SimplifierSwitch(..), SwitchResult(..), intSwitchSet )
  62 import Unique           ( Unique )
  63 import Maybes           ( expectJust )
  64 import Util             ( zipWithEqual )
  65 import Outputable
  66
  67 infixr 9  `thenSmpl`, `thenSmpl_`
  68 \end{code}
  69
  70 %************************************************************************
  71 %*                                                                      *
  72 \subsection[Simplify-types]{Type declarations}
  73 %*                                                                      *
  74 %************************************************************************
  75
  76 \begin{code}
  77 type InBinder  = CoreBndr
  78 type InId      = Id                     -- Not yet cloned
  79 type InType    = Type                   -- Ditto
  80 type InBind    = CoreBind
  81 type InExpr    = CoreExpr
  82 type InAlt     = CoreAlt
  83 type InArg     = CoreArg
  84
  85 type OutBinder  = CoreBndr
  86 type OutId      = Id                    -- Cloned
  87 type OutType    = Type                  -- Cloned
  88 type OutBind    = CoreBind
  89 type OutExpr    = CoreExpr
  90 type OutAlt     = CoreAlt
  91 type OutArg     = CoreArg
  92
  93 type SwitchChecker = SimplifierSwitch -> SwitchResult
  94 \end{code}
  95
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection{The continuation data type}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103 \begin{code}
 104 type OutExprStuff = OutStuff (InScopeEnv, OutExpr)
 105 type OutStuff a   = ([OutBind], a)
 106         -- We return something equivalent to (let b in e), but
 107         -- in pieces to avoid the quadratic blowup when floating
 108         -- incrementally.  Comments just before simplExprB in Simplify.lhs
 109
 110 data SimplCont          -- Strict contexts
 111   = Stop
 112
 113   | CoerceIt DupFlag
 114              InType SubstEnv
 115              SimplCont
 116
 117   | ApplyTo  DupFlag
 118              InExpr SubstEnv            -- The argument, as yet unsimplified,
 119              SimplCont                  -- and its subst-env
 120
 121   | Select   DupFlag
 122              InId [InAlt] SubstEnv      -- The case binder, alts, and subst-env
 123              SimplCont
 124
 125   | ArgOf    DupFlag                            -- An arbitrary strict context: the argument
 126              (OutExpr -> SimplM OutExprStuff)   -- of a strict function, or a primitive-arg fn
 127                                                 -- or a PrimOp
 128              OutType                            -- Type of the result of the whole thing
 129
 130 instance Outputable SimplCont where
 131   ppr Stop                           = ptext SLIT("Stop")
 132   ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
 133   ppr (ArgOf   dup cont_fn _)        = ptext SLIT("ArgOf...") <+> ppr dup
 134   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
 135                                        (nest 4 (ppr alts)) $$ ppr cont
 136   ppr (CoerceIt dup ty se cont)      = (ptext SLIT("CoerceIt") <+> ppr dup <+> ppr ty) $$ ppr cont
 137
 138 data DupFlag = OkToDup | NoDup
 139
 140 instance Outputable DupFlag where
 141   ppr OkToDup = ptext SLIT("ok")
 142   ppr NoDup   = ptext SLIT("nodup")
 143
 144 contIsDupable :: SimplCont -> Bool
 145 contIsDupable Stop                       = True
 146 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
 147 contIsDupable (ArgOf    OkToDup _ _)     = True
 148 contIsDupable (Select   OkToDup _ _ _ _) = True
 149 contIsDupable (CoerceIt OkToDup _ _ _)   = True
 150 contIsDupable other                      = False
 151
 152 contResultType :: InScopeEnv -> Type -> SimplCont -> Type
 153 contResultType in_scope e_ty cont
 154   = go e_ty cont
 155   where
 156     go e_ty Stop                          = e_ty
 157     go e_ty (ApplyTo _ (Type ty) se cont) = go (applyTy e_ty (simpl se ty))     cont
 158     go e_ty (ApplyTo _ val_arg _ cont)    = go (funResultTy e_ty)               cont
 159     go e_ty (ArgOf _ fun cont_ty)         = cont_ty
 160     go e_ty (CoerceIt _ ty se cont)       = go (simpl se ty)                    cont
 161     go e_ty (Select _ _ alts se cont)     = go (simpl se (coreAltsType alts))   cont
 162
 163     simpl (ty_subst, _) ty = fullSubstTy ty_subst in_scope ty
 164 \end{code}
 165
 166
 167 %************************************************************************
 168 %*                                                                      *
 169 \subsection{Monad plumbing}
 170 %*                                                                      *
 171 %************************************************************************
 172
 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.)
 175
 176 \begin{code}
 177 type SimplM result              -- We thread the unique supply because
 178   =  SimplEnv                   -- constantly splitting it is rather expensive
 179   -> UniqSupply
 180   -> SimplCount
 181   -> (result, UniqSupply, SimplCount)
 182
 183 data SimplEnv
 184   = SimplEnv {
 185         seChkr     :: SwitchChecker,
 186         seCC       :: CostCentreStack,  -- The enclosing CCS (when profiling)
 187         seSubst    :: SubstEnv,         -- The current substitution
 188         seInScope  :: InScopeEnv        -- Says what's in scope and gives info about it
 189     }
 190 \end{code}
 191
 192 \begin{code}
 193 initSmpl :: SwitchChecker
 194          -> UniqSupply          -- No init count; set to 0
 195          -> SimplM a
 196          -> (a, SimplCount)
 197
 198 initSmpl chkr us m = case m (emptySimplEnv chkr) us zeroSimplCount of
 199                         (result, _, count) -> (result, count)
 200
 201
 202 {-# INLINE thenSmpl #-}
 203 {-# INLINE thenSmpl_ #-}
 204 {-# INLINE returnSmpl #-}
 205
 206 returnSmpl :: a -> SimplM a
 207 returnSmpl e env us sc = (e, us, sc)
 208
 209 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
 210 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
 211
 212 thenSmpl m k env us0 sc0
 213   = case (m env us0 sc0) of
 214         (m_result, us1, sc1) -> k m_result env us1 sc1
 215
 216 thenSmpl_ m k env us0 sc0
 217   = case (m env us0 sc0) of
 218         (_, us1, sc1) -> k env us1 sc1
 219 \end{code}
 220
 221
 222 \begin{code}
 223 mapSmpl         :: (a -> SimplM b) -> [a] -> SimplM [b]
 224 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
 225
 226 mapSmpl f [] = returnSmpl []
 227 mapSmpl f (x:xs)
 228   = f x             `thenSmpl` \ x'  ->
 229     mapSmpl f xs    `thenSmpl` \ xs' ->
 230     returnSmpl (x':xs')
 231
 232 mapAndUnzipSmpl f [] = returnSmpl ([],[])
 233 mapAndUnzipSmpl f (x:xs)
 234   = f x                     `thenSmpl` \ (r1,  r2)  ->
 235     mapAndUnzipSmpl f xs    `thenSmpl` \ (rs1, rs2) ->
 236     returnSmpl (r1:rs1, r2:rs2)
 237
 238 mapAccumLSmpl f acc []     = returnSmpl (acc, [])
 239 mapAccumLSmpl f acc (x:xs) = f acc x    `thenSmpl` \ (acc', x') ->
 240                              mapAccumLSmpl f acc' xs    `thenSmpl` \ (acc'', xs') ->
 241                              returnSmpl (acc'', x':xs')
 242 \end{code}
 243
 244
 245 %************************************************************************
 246 %*                                                                      *
 247 \subsection{The unique supply}
 248 %*                                                                      *
 249 %************************************************************************
 250
 251 \begin{code}
 252 getUniqueSmpl :: SimplM Unique
 253 getUniqueSmpl env us sc = case splitUniqSupply us of
 254                                 (us1, us2) -> (uniqFromSupply us1, us2, sc)
 255
 256 getUniquesSmpl :: Int -> SimplM [Unique]
 257 getUniquesSmpl n env us sc = case splitUniqSupply us of
 258                                 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
 259 \end{code}
 260
 261
 262 %************************************************************************
 263 %*                                                                      *
 264 \subsection{Counting up what we've done}
 265 %*                                                                      *
 266 %************************************************************************
 267
 268 \begin{code}
 269 doTickSmpl :: (SimplCount -> SimplCount) -> SimplM ()
 270 doTickSmpl f env us sc = sc' `seq` ((), us, sc')
 271                        where
 272                          sc' = f sc
 273
 274 getSimplCount :: SimplM SimplCount
 275 getSimplCount env us sc = (sc, us, sc)
 276 \end{code}
 277
 278
 279 The assoc list isn't particularly costly, because we only use
 280 the number of ticks in ``real life.''
 281
 282 The right thing to do, if you want that to go fast, is thread
 283 a mutable array through @SimplM@.
 284
 285 \begin{code}
 286 data SimplCount
 287   = SimplCount  !TickCounts
 288                 !UnfoldingHistory
 289
 290 type TickCounts = [(TickType, Int)]     -- Assoc list of all diff kinds of ticks
 291                                         -- Kept in increasing order of TickType
 292                                         -- Zeros not present
 293
 294 type UnfoldingHistory = (Int,           -- N
 295                          [Id],          -- Last N unfoldings
 296                          [Id])          -- The MaxUnfoldHistory unfoldings before that
 297
 298 data TickType
 299   = PreInlineUnconditionally
 300   | PostInlineUnconditionally
 301   | UnfoldingDone
 302   | MagicUnfold
 303   | CaseOfCase
 304   | LetFloatFromLet
 305   | KnownBranch
 306   | Let2Case
 307   | Case2Let
 308   | CaseMerge
 309   | CaseElim
 310   | CaseIdentity
 311   | EtaExpansion
 312   | CaseOfError
 313   | BetaReduction
 314   | SpecialisationDone
 315   | FillInCaseDefault
 316   | LeavesExamined
 317   deriving (Eq, Ord, Show)
 318
 319 pprSimplCount :: SimplCount -> SDoc
 320 pprSimplCount (SimplCount stuff (_, unf1, unf2))
 321   = vcat (map ppr_item stuff)
 322     $$ (text "Most recent unfoldings (most recent at top):"
 323         $$ nest 4 (vcat (map ppr (unf1 ++ unf2))))
 324   where
 325     ppr_item (t,n) = text (show t) <+> char '\t' <+> ppr n
 326
 327 zeroSimplCount :: SimplCount
 328 zeroSimplCount = SimplCount [] (0, [], [])
 329
 330 isZeroSimplCount :: SimplCount -> Bool
 331 isZeroSimplCount (SimplCount []                   _) = True
 332 isZeroSimplCount (SimplCount [(LeavesExamined,_)] _) = True
 333 isZeroSimplCount other                               = False
 334
 335 -- incTick is careful to be pretty strict, so we don't
 336 -- get a huge buildup of thunks
 337 incTick :: TickType -> FAST_INT -> TickCounts -> TickCounts
 338 incTick tick_type n []
 339   = [(tick_type, IBOX(n))]
 340
 341 incTick tick_type n (x@(ttype, I# cnt#) : xs)
 342   = case tick_type `compare` ttype of
 343         LT ->   -- Insert here
 344                 (tick_type, IBOX(n)) : x : xs
 345
 346         EQ ->   -- Increment
 347                 case cnt# +# n of
 348                    incd -> (ttype, IBOX(incd)) : xs
 349
 350         GT ->   -- Move on
 351                 rest `seq` x : rest
 352            where
 353                 rest = incTick tick_type n xs
 354
 355 -- Second argument is more recent stuff
 356 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
 357 plusSimplCount (SimplCount tc1 uh1) (SimplCount tc2 uh2)
 358   = SimplCount (plusTickCounts tc1 tc2) (plusUnfolds uh1 uh2)
 359
 360 plusTickCounts :: TickCounts -> TickCounts -> TickCounts
 361 plusTickCounts ts1 [] = ts1
 362 plusTickCounts [] ts2 = ts2
 363 plusTickCounts ((tt1,n1) : ts1) ((tt2,n2) : ts2)
 364   = case tt1 `compare` tt2 of
 365         LT -> (tt1,n1)    : plusTickCounts ts1              ((tt2,n2) : ts2)
 366         EQ -> (tt1,n1+n2) : plusTickCounts ts1              ts2
 367         GT -> (tt2,n2)    : plusTickCounts ((tt1,n1) : ts1) ts2
 368
 369 -- Second argument is the more recent stuff
 370 plusUnfolds uh1          (0, h2, t2)  = uh1                     -- Nothing recent
 371 plusUnfolds (n1, h1, t1) (n2, h2, []) = (n2, h2, (h1++t1))      -- Small amount recent
 372 plusUnfolds (n1, h1, t1) uh2          = uh2                     -- Decent batch recent
 373 \end{code}
 374
 375
 376 Counting-related monad functions:
 377
 378 \begin{code}
 379 tick :: TickType -> SimplM ()
 380
 381 tick tick_type
 382   = doTickSmpl f
 383   where
 384     f (SimplCount stuff unf) = SimplCount (incTick tick_type ILIT(1) stuff) unf
 385
 386 maxUnfoldHistory :: Int
 387 maxUnfoldHistory = 20
 388
 389 tickUnfold :: Id -> SimplM ()
 390 tickUnfold id
 391   = doTickSmpl f
 392   where
 393     f (SimplCount stuff (n_unf, unf1, unf2))
 394       | n_unf >= maxUnfoldHistory = SimplCount new_stuff (1, [id], unf1)
 395       | otherwise                 = SimplCount new_stuff (n_unf+1, id:unf1, unf2)
 396       where
 397         new_stuff = incTick UnfoldingDone ILIT(1) stuff
 398 \end{code}
 399
 400
 401 %************************************************************************
 402 %*                                                                      *
 403 \subsubsection{Command-line switches}
 404 %*                                                                      *
 405 %************************************************************************
 406
 407 \begin{code}
 408 getSwitchChecker :: SimplM SwitchChecker
 409 getSwitchChecker env us sc = (seChkr env, us, sc)
 410
 411 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 412 getSimplIntSwitch chkr switch
 413   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 414 \end{code}
 415
 416
 417 @switchOffInlining@ is used to prepare the environment for simplifying
 418 the RHS of an Id that's marked with an INLINE pragma.  It is going to
 419 be inlined wherever they are used, and then all the inlining will take
 420 effect.  Meanwhile, there isn't much point in doing anything to the
 421 as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
 422 inlining!  because
 423         (a) not doing so will inline a worker straight back into its wrapper!
 424
 425 and     (b) Consider the following example
 426                 let f = \pq -> BIG
 427                 in
 428                 let g = \y -> f y y
 429                     {-# INLINE g #-}
 430                 in ...g...g...g...g...g...
 431
 432         Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 433         and thence copied multiple times when g is inlined.
 434
 435         Andy disagrees! Example:
 436                 all xs = foldr (&&) True xs
 437                 any p = all . map p  {-# INLINE any #-}
 438
 439         Problem: any won't get deforested, and so if it's exported and
 440         the importer doesn't use the inlining, (eg passes it as an arg)
 441         then we won't get deforestation at all.
 442         We havn't solved this problem yet!
 443
 444 We prepare the envt by simply modifying the in_scope_env, which has all the
 445 unfolding info. At one point we did it by modifying the chkr so that
 446 it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
 447 important, simplifications happening in the body of the RHS.
 448
 449 6/98 update:
 450
 451 We *don't* prevent inlining from happening for identifiers
 452 that are marked as IMustBeINLINEd. An example of where
 453 doing this is crucial is:
 454
 455    class Bar a => Foo a where
 456      ...g....
 457    {-# INLINE f #-}
 458    f :: Foo a => a -> b
 459    f x = ....Foo_sc1...
 460
 461 If `f' needs to peer inside Foo's superclass, Bar, it refers
 462 to the appropriate super class selector, which is marked as
 463 must-inlineable. We don't generate any code for a superclass
 464 selector, so failing to inline it in the RHS of `f' will
 465 leave a reference to a non-existent id, with bad consequences.
 466
 467 ALSO NOTE that we do all this by modifing the inline-pragma,
 468 not by zapping the unfolding.  The latter may still be useful for
 469 knowing when something is evaluated.
 470
 471 June 98 update: I've gone back to dealing with this by adding
 472 the EssentialUnfoldingsOnly switch.  That doesn't stop essential
 473 unfoldings, nor inlineUnconditionally stuff; and the thing's going
 474 to be inlined at every call site anyway.  Running over the whole
 475 environment seems like wild overkill.
 476
 477 \begin{code}
 478 switchOffInlining :: SimplM a -> SimplM a
 479 switchOffInlining m env@(SimplEnv { seChkr = sw_chkr }) us sc
 480   = m (env { seChkr = new_chkr  }) us sc
 481   where
 482     new_chkr EssentialUnfoldingsOnly = SwBool True
 483     new_chkr other                   = sw_chkr other
 484 \end{code}
 485
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \subsubsection{The ``enclosing cost-centre''}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493 \begin{code}
 494 getEnclosingCC :: SimplM CostCentreStack
 495 getEnclosingCC env us sc = (seCC env, us, sc)
 496
 497 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
 498 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
 499 \end{code}
 500
 501
 502 %************************************************************************
 503 %*                                                                      *
 504 \subsubsection{The @SimplEnv@ type}
 505 %*                                                                      *
 506 %************************************************************************
 507
 508 \begin{code}
 509 type SubstEnv = (TyVarSubst, IdSubst)
 510         -- The range of these substitutions is OutType and OutExpr resp
 511         --
 512         -- The substitution is idempotent
 513         -- It *must* be applied; things in its domain simply aren't
 514         -- bound in the result.
 515         --
 516         -- The substitution usually maps an Id to its clone,
 517         -- but if the orig defn is a let-binding, and
 518         -- the RHS of the let simplifies to an atom,
 519         -- we just add the binding to the substitution and elide the let.
 520
 521 type InScopeEnv = IdOrTyVarSet
 522         -- Domain includes *all* in-scope TyVars and Ids
 523         --
 524         -- The elements of the set may have better IdInfo than the
 525         -- occurrences of in-scope Ids, and (more important) they will
 526         -- have a correctly-substituted type.  So we use a lookup in this
 527         -- set to replace occurrences
 528
 529 -- INVARIANT:   If t is in the in-scope set, it certainly won't be
 530 --              in the domain of the SubstEnv, and vice versa
 531 \end{code}
 532
 533
 534 \begin{code}
 535 emptySubstEnv :: SubstEnv
 536 emptySubstEnv = (emptyVarEnv, emptyVarEnv)
 537
 538 emptySimplEnv :: SwitchChecker -> SimplEnv
 539
 540 emptySimplEnv sw_chkr
 541   = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
 542                seSubst   = emptySubstEnv,
 543                seInScope = emptyVarSet }
 544
 545         -- The top level "enclosing CC" is "SUBSUMED".
 546
 547 getTyEnv :: SimplM (TyVarSubst, InScopeEnv)
 548 getTyEnv (SimplEnv {seSubst = (ty_subst,_), seInScope = in_scope}) us sc
 549   = ((ty_subst, in_scope), us, sc)
 550
 551 getValEnv :: SimplM (IdSubst, InScopeEnv)
 552 getValEnv (SimplEnv {seSubst = (_, id_subst), seInScope = in_scope}) us sc
 553   = ((id_subst, in_scope), us, sc)
 554
 555 getInScope :: SimplM InScopeEnv
 556 getInScope env us sc = (seInScope env, us, sc)
 557
 558 setInScope :: InScopeEnv -> SimplM a -> SimplM a
 559 setInScope in_scope m env us sc = m (env {seInScope = in_scope}) us sc
 560
 561 extendInScope :: CoreBndr -> SimplM a -> SimplM a
 562 extendInScope v m env@(SimplEnv {seInScope = in_scope}) us sc
 563   = m (env {seInScope = extendVarSet in_scope v}) us sc
 564
 565 extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
 566 extendInScopes vs m env@(SimplEnv {seInScope = in_scope}) us sc
 567   = m (env {seInScope = foldl extendVarSet in_scope vs}) us sc
 568
 569 modifyInScope :: CoreBndr -> SimplM a -> SimplM a
 570 modifyInScope v m env us sc
 571 #ifdef DEBUG
 572   | not (v `elemVarSet` seInScope env )
 573   = pprTrace "modifyInScope: not in scope:" (ppr v)
 574     m env us sc
 575 #endif
 576   | otherwise
 577   = extendInScope v m env us sc
 578
 579 getSubstEnv :: SimplM SubstEnv
 580 getSubstEnv env us sc = (seSubst env, us, sc)
 581
 582 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
 583 setSubstEnv subst_env m env us sc = m (env {seSubst = subst_env}) us sc
 584
 585 extendIdSubst :: Id -> SubstCoreExpr -> SimplM a -> SimplM a
 586 extendIdSubst id expr m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc
 587   = m (env { seSubst = (ty_subst, extendVarEnv id_subst id expr) }) us sc
 588
 589 extendTySubst :: TyVar -> OutType -> SimplM a -> SimplM a
 590 extendTySubst tv ty m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc
 591   = m (env { seSubst = (extendVarEnv ty_subst tv ty, id_subst) }) us sc
 592
 593 zapSubstEnv :: SimplM a -> SimplM a
 594 zapSubstEnv m env us sc = m (env {seSubst = emptySubstEnv}) us sc
 595
 596 getSimplBinderStuff :: SimplM (TyVarSubst, IdSubst, InScopeEnv, UniqSupply)
 597 getSimplBinderStuff (SimplEnv {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc
 598   = ((ty_subst, id_subst, in_scope, us), us, sc)
 599
 600 setSimplBinderStuff :: (TyVarSubst, IdSubst, InScopeEnv, UniqSupply)
 601                     -> SimplM a -> SimplM a
 602 setSimplBinderStuff (ty_subst, id_subst, in_scope, us) m env _ sc
 603   = m (env {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc
 604 \end{code}
 605
 606
 607 \begin{code}
 608 newId :: Type -> (Id -> SimplM a) -> SimplM a
 609         -- Extends the in-scope-env too
 610 newId ty m env@(SimplEnv {seInScope = in_scope}) us sc
 611   =  case splitUniqSupply us of
 612         (us1, us2) -> m v (env {seInScope = extendVarSet in_scope v}) us2 sc
 613                    where
 614                       v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
 615
 616 newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
 617 newIds tys m env@(SimplEnv {seInScope = in_scope}) us sc
 618   =  case splitUniqSupply us of
 619         (us1, us2) -> m vs (env {seInScope = foldl extendVarSet in_scope vs}) us2 sc
 620                    where
 621                       vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
 622                                         (uniqsFromSupply (length tys) us1) tys
 623 \end{code}
 624