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 monad
  13         SimplM,
  14         initSmpl, returnSmpl, thenSmpl, thenSmpl_,
  15         mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
  16
  17         -- The inlining black-list
  18         getBlackList,
  19
  20         -- Unique supply
  21         getUniqueSmpl, getUniquesSmpl,
  22         newId, newIds,
  23
  24         -- Counting
  25         SimplCount, Tick(..),
  26         tick, freeTick,
  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         getEnv, setAllExceptInScope,
  38         getSubst, setSubst,
  39         getSubstEnv, extendSubst, extendSubstList,
  40         getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
  41         setSubstEnv, zapSubstEnv,
  42         getSimplBinderStuff, setSimplBinderStuff,
  43         switchOffInlining
  44     ) where
  45
  46 #include "HsVersions.h"
  47
  48 import Id               ( Id, mkSysLocal, idUnfolding, isDataConWrapId )
  49 import IdInfo           ( InlinePragInfo(..) )
  50 import Demand           ( Demand )
  51 import CoreSyn
  52 import CoreUnfold       ( isCompulsoryUnfolding, isEvaldUnfolding )
  53 import PprCore          ()      -- Instances
  54 import Rules            ( RuleBase )
  55 import CostCentre       ( CostCentreStack, subsumedCCS )
  56 import Name             ( isLocallyDefined )
  57 import Var              ( TyVar )
  58 import VarEnv
  59 import VarSet
  60 import qualified Subst
  61 import Subst            ( Subst, emptySubst, mkSubst,
  62                           substTy, substEnv,
  63                           InScopeSet, substInScope, isInScope
  64                         )
  65 import Type             ( Type, TyVarSubst, applyTy )
  66 import UniqSupply       ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
  67                           UniqSupply
  68                         )
  69 import FiniteMap
  70 import CmdLineOpts      ( SimplifierSwitch(..), SwitchResult(..),
  71                           opt_PprStyle_Debug, opt_HistorySize, opt_D_dump_simpl_stats,
  72                           intSwitchSet
  73                         )
  74 import Unique           ( Unique )
  75 import Maybes           ( expectJust )
  76 import Util             ( zipWithEqual )
  77 import Outputable
  78
  79 infixr 0  `thenSmpl`, `thenSmpl_`
  80 \end{code}
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection[Simplify-types]{Type declarations}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 type InBinder  = CoreBndr
  90 type InId      = Id                     -- Not yet cloned
  91 type InType    = Type                   -- Ditto
  92 type InBind    = CoreBind
  93 type InExpr    = CoreExpr
  94 type InAlt     = CoreAlt
  95 type InArg     = CoreArg
  96
  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
 104
 105 type SwitchChecker = SimplifierSwitch -> SwitchResult
 106
 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
 112 \end{code}
 113
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection{Monad plumbing}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
 122 (Command-line switches move around through the explicitly-passed SimplEnv.)
 123
 124 \begin{code}
 125 type SimplM result              -- We thread the unique supply because
 126   =  SimplEnv                   -- constantly splitting it is rather expensive
 127   -> UniqSupply
 128   -> SimplCount
 129   -> (result, UniqSupply, SimplCount)
 130
 131 data SimplEnv
 132   = SimplEnv {
 133         seChkr      :: SwitchChecker,
 134         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 135         seBlackList :: Id -> Bool,      -- True =>  don't inline this Id
 136         seSubst     :: Subst            -- The current substitution
 137     }
 138         -- The range of the substitution is OutType and OutExpr resp
 139         --
 140         -- The substitution is idempotent
 141         -- It *must* be applied; things in its domain simply aren't
 142         -- bound in the result.
 143         --
 144         -- The substitution usually maps an Id to its clone,
 145         -- but if the orig defn is a let-binding, and
 146         -- the RHS of the let simplifies to an atom,
 147         -- we just add the binding to the substitution and elide the let.
 148
 149         -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
 150         -- The elements of the set may have better IdInfo than the
 151         -- occurrences of in-scope Ids, and (more important) they will
 152         -- have a correctly-substituted type.  So we use a lookup in this
 153         -- set to replace occurrences
 154 \end{code}
 155
 156 \begin{code}
 157 initSmpl :: SwitchChecker
 158          -> UniqSupply          -- No init count; set to 0
 159          -> VarSet              -- In scope (usually empty, but useful for nested calls)
 160          -> (Id -> Bool)        -- Black-list function
 161          -> SimplM a
 162          -> (a, SimplCount)
 163
 164 initSmpl chkr us in_scope black_list m
 165   = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
 166         (result, _, count) -> (result, count)
 167
 168
 169 {-# INLINE thenSmpl #-}
 170 {-# INLINE thenSmpl_ #-}
 171 {-# INLINE returnSmpl #-}
 172
 173 returnSmpl :: a -> SimplM a
 174 returnSmpl e env us sc = (e, us, sc)
 175
 176 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
 177 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
 178
 179 thenSmpl m k env us0 sc0
 180   = case (m env us0 sc0) of
 181         (m_result, us1, sc1) -> k m_result env us1 sc1
 182
 183 thenSmpl_ m k env us0 sc0
 184   = case (m env us0 sc0) of
 185         (_, us1, sc1) -> k env us1 sc1
 186 \end{code}
 187
 188
 189 \begin{code}
 190 mapSmpl         :: (a -> SimplM b) -> [a] -> SimplM [b]
 191 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
 192
 193 mapSmpl f [] = returnSmpl []
 194 mapSmpl f (x:xs)
 195   = f x             `thenSmpl` \ x'  ->
 196     mapSmpl f xs    `thenSmpl` \ xs' ->
 197     returnSmpl (x':xs')
 198
 199 mapAndUnzipSmpl f [] = returnSmpl ([],[])
 200 mapAndUnzipSmpl f (x:xs)
 201   = f x                     `thenSmpl` \ (r1,  r2)  ->
 202     mapAndUnzipSmpl f xs    `thenSmpl` \ (rs1, rs2) ->
 203     returnSmpl (r1:rs1, r2:rs2)
 204
 205 mapAccumLSmpl f acc []     = returnSmpl (acc, [])
 206 mapAccumLSmpl f acc (x:xs) = f acc x    `thenSmpl` \ (acc', x') ->
 207                              mapAccumLSmpl f acc' xs    `thenSmpl` \ (acc'', xs') ->
 208                              returnSmpl (acc'', x':xs')
 209 \end{code}
 210
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsection{The unique supply}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 \begin{code}
 219 getUniqueSmpl :: SimplM Unique
 220 getUniqueSmpl env us sc = case splitUniqSupply us of
 221                                 (us1, us2) -> (uniqFromSupply us1, us2, sc)
 222
 223 getUniquesSmpl :: Int -> SimplM [Unique]
 224 getUniquesSmpl n env us sc = case splitUniqSupply us of
 225                                 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
 226 \end{code}
 227
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \subsection{Counting up what we've done}
 232 %*                                                                      *
 233 %************************************************************************
 234
 235 \begin{code}
 236 getSimplCount :: SimplM SimplCount
 237 getSimplCount env us sc = (sc, us, sc)
 238
 239 tick :: Tick -> SimplM ()
 240 tick t env us sc = sc' `seq` ((), us, sc')
 241                  where
 242                    sc' = doTick t sc
 243
 244 freeTick :: Tick -> SimplM ()
 245 -- Record a tick, but don't add to the total tick count, which is
 246 -- used to decide when nothing further has happened
 247 freeTick t env us sc = sc' `seq` ((), us, sc')
 248                  where
 249                    sc' = doFreeTick t sc
 250 \end{code}
 251
 252 \begin{code}
 253 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
 254
 255 zeroSimplCount     :: SimplCount
 256 isZeroSimplCount   :: SimplCount -> Bool
 257 pprSimplCount      :: SimplCount -> SDoc
 258 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
 259 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 260 \end{code}
 261
 262 \begin{code}
 263 data SimplCount = VerySimplZero         -- These two are used when
 264                 | VerySimplNonZero      -- we are only interested in
 265                                         -- termination info
 266
 267                 | SimplCount    {
 268                         ticks   :: !Int,                -- Total ticks
 269                         details :: !TickCounts,         -- How many of each type
 270                         n_log   :: !Int,                -- N
 271                         log1    :: [Tick],              -- Last N events; <= opt_HistorySize
 272                         log2    :: [Tick]               -- Last opt_HistorySize events before that
 273                   }
 274
 275 type TickCounts = FiniteMap Tick Int
 276
 277 zeroSimplCount  -- This is where we decide whether to do
 278                 -- the VerySimpl version or the full-stats version
 279   | opt_D_dump_simpl_stats = SimplCount {ticks = 0, details = emptyFM,
 280                                          n_log = 0, log1 = [], log2 = []}
 281   | otherwise              = VerySimplZero
 282
 283 isZeroSimplCount VerySimplZero              = True
 284 isZeroSimplCount (SimplCount { ticks = 0 }) = True
 285 isZeroSimplCount other                      = False
 286
 287 doFreeTick tick sc@SimplCount { details = dts }
 288   = dts' `seqFM` sc { details = dts' }
 289   where
 290     dts' = dts `addTick` tick
 291 doFreeTick tick sc = sc
 292
 293 -- Gross hack to persuade GHC 3.03 to do this important seq
 294 seqFM fm x | isEmptyFM fm = x
 295            | otherwise    = x
 296
 297 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
 298   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 299   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
 300   where
 301     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 302
 303 doTick tick sc = VerySimplNonZero       -- The very simple case
 304
 305
 306 -- Don't use plusFM_C because that's lazy, and we want to
 307 -- be pretty strict here!
 308 addTick :: TickCounts -> Tick -> TickCounts
 309 addTick fm tick = case lookupFM fm tick of
 310                         Nothing -> addToFM fm tick 1
 311                         Just n  -> n1 `seq` addToFM fm tick n1
 312                                 where
 313                                    n1 = n+1
 314
 315
 316 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 317                sc2@(SimplCount { ticks = tks2, details = dts2 })
 318   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
 319   where
 320         -- A hackish way of getting recent log info
 321     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
 322              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 323              | otherwise       = sc2
 324
 325 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
 326 plusSimplCount sc1           sc2           = VerySimplNonZero
 327
 328 pprSimplCount VerySimplZero    = ptext SLIT("Total ticks: ZERO!")
 329 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
 330 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 331   = vcat [ptext SLIT("Total ticks:    ") <+> int tks,
 332           text "",
 333           pprTickCounts (fmToList dts),
 334           if verboseSimplStats then
 335                 vcat [text "",
 336                       ptext SLIT("Log (most recent first)"),
 337                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 338           else empty
 339     ]
 340
 341 pprTickCounts :: [(Tick,Int)] -> SDoc
 342 pprTickCounts [] = empty
 343 pprTickCounts ((tick1,n1):ticks)
 344   = vcat [int tot_n <+> text (tickString tick1),
 345           pprTCDetails real_these,
 346           pprTickCounts others
 347     ]
 348   where
 349     tick1_tag           = tickToTag tick1
 350     (these, others)     = span same_tick ticks
 351     real_these          = (tick1,n1):these
 352     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
 353     tot_n               = sum [n | (_,n) <- real_these]
 354
 355 pprTCDetails ticks@((tick,_):_)
 356   | verboseSimplStats || isRuleFired tick
 357   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 358   | otherwise
 359   = empty
 360 \end{code}
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection{Ticks}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 \begin{code}
 369 data Tick
 370   = PreInlineUnconditionally    Id
 371   | PostInlineUnconditionally   Id
 372
 373   | UnfoldingDone               Id
 374   | RuleFired                   FAST_STRING     -- Rule name
 375
 376   | LetFloatFromLet             Id      -- Thing floated out
 377   | EtaExpansion                Id      -- LHS binder
 378   | EtaReduction                Id      -- Binder on outer lambda
 379   | BetaReduction               Id      -- Lambda binder
 380
 381
 382   | CaseOfCase                  Id      -- Bndr on *inner* case
 383   | KnownBranch                 Id      -- Case binder
 384   | CaseMerge                   Id      -- Binder on outer case
 385   | CaseElim                    Id      -- Case binder
 386   | CaseIdentity                Id      -- Case binder
 387   | FillInCaseDefault           Id      -- Case binder
 388
 389   | BottomFound
 390   | SimplifierDone              -- Ticked at each iteration of the simplifier
 391
 392 isRuleFired (RuleFired _) = True
 393 isRuleFired other         = False
 394
 395 instance Outputable Tick where
 396   ppr tick = text (tickString tick) <+> pprTickCts tick
 397
 398 instance Eq Tick where
 399   a == b = case a `cmpTick` b of { EQ -> True; other -> False }
 400
 401 instance Ord Tick where
 402   compare = cmpTick
 403
 404 tickToTag :: Tick -> Int
 405 tickToTag (PreInlineUnconditionally _)  = 0
 406 tickToTag (PostInlineUnconditionally _) = 1
 407 tickToTag (UnfoldingDone _)             = 2
 408 tickToTag (RuleFired _)                 = 3
 409 tickToTag (LetFloatFromLet _)           = 4
 410 tickToTag (EtaExpansion _)              = 5
 411 tickToTag (EtaReduction _)              = 6
 412 tickToTag (BetaReduction _)             = 7
 413 tickToTag (CaseOfCase _)                = 8
 414 tickToTag (KnownBranch _)               = 9
 415 tickToTag (CaseMerge _)                 = 10
 416 tickToTag (CaseElim _)                  = 11
 417 tickToTag (CaseIdentity _)              = 12
 418 tickToTag (FillInCaseDefault _)         = 13
 419 tickToTag BottomFound                   = 14
 420 tickToTag SimplifierDone                = 16
 421
 422 tickString :: Tick -> String
 423 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
 424 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 425 tickString (UnfoldingDone _)            = "UnfoldingDone"
 426 tickString (RuleFired _)                = "RuleFired"
 427 tickString (LetFloatFromLet _)          = "LetFloatFromLet"
 428 tickString (EtaExpansion _)             = "EtaExpansion"
 429 tickString (EtaReduction _)             = "EtaReduction"
 430 tickString (BetaReduction _)            = "BetaReduction"
 431 tickString (CaseOfCase _)               = "CaseOfCase"
 432 tickString (KnownBranch _)              = "KnownBranch"
 433 tickString (CaseMerge _)                = "CaseMerge"
 434 tickString (CaseElim _)                 = "CaseElim"
 435 tickString (CaseIdentity _)             = "CaseIdentity"
 436 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
 437 tickString BottomFound                  = "BottomFound"
 438 tickString SimplifierDone               = "SimplifierDone"
 439
 440 pprTickCts :: Tick -> SDoc
 441 pprTickCts (PreInlineUnconditionally v) = ppr v
 442 pprTickCts (PostInlineUnconditionally v)= ppr v
 443 pprTickCts (UnfoldingDone v)            = ppr v
 444 pprTickCts (RuleFired v)                = ppr v
 445 pprTickCts (LetFloatFromLet v)          = ppr v
 446 pprTickCts (EtaExpansion v)             = ppr v
 447 pprTickCts (EtaReduction v)             = ppr v
 448 pprTickCts (BetaReduction v)            = ppr v
 449 pprTickCts (CaseOfCase v)               = ppr v
 450 pprTickCts (KnownBranch v)              = ppr v
 451 pprTickCts (CaseMerge v)                = ppr v
 452 pprTickCts (CaseElim v)                 = ppr v
 453 pprTickCts (CaseIdentity v)             = ppr v
 454 pprTickCts (FillInCaseDefault v)        = ppr v
 455 pprTickCts other                        = empty
 456
 457 cmpTick :: Tick -> Tick -> Ordering
 458 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 459                 GT -> GT
 460                 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
 461                    | otherwise                          -> EQ
 462                 LT -> LT
 463         -- Always distinguish RuleFired, so that the stats
 464         -- can report them even in non-verbose mode
 465
 466 cmpEqTick :: Tick -> Tick -> Ordering
 467 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
 468 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
 469 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
 470 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
 471 cmpEqTick (LetFloatFromLet a)           (LetFloatFromLet b)             = a `compare` b
 472 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
 473 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
 474 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
 475 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
 476 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
 477 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
 478 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
 479 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 480 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 481 cmpEqTick other1                        other2                          = EQ
 482 \end{code}
 483
 484
 485 %************************************************************************
 486 %*                                                                      *
 487 \subsubsection{Command-line switches}
 488 %*                                                                      *
 489 %************************************************************************
 490
 491 \begin{code}
 492 getSwitchChecker :: SimplM SwitchChecker
 493 getSwitchChecker env us sc = (seChkr env, us, sc)
 494
 495 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 496 getSimplIntSwitch chkr switch
 497   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 498 \end{code}
 499
 500
 501 @switchOffInlining@ is used to prepare the environment for simplifying
 502 the RHS of an Id that's marked with an INLINE pragma.  It is going to
 503 be inlined wherever they are used, and then all the inlining will take
 504 effect.  Meanwhile, there isn't much point in doing anything to the
 505 as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
 506 inlining!  because
 507         (a) not doing so will inline a worker straight back into its wrapper!
 508
 509 and     (b) Consider the following example
 510                 let f = \pq -> BIG
 511                 in
 512                 let g = \y -> f y y
 513                     {-# INLINE g #-}
 514                 in ...g...g...g...g...g...
 515
 516         Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 517         and thence copied multiple times when g is inlined.
 518
 519         Andy disagrees! Example:
 520                 all xs = foldr (&&) True xs
 521                 any p = all . map p  {-# INLINE any #-}
 522
 523         Problem: any won't get deforested, and so if it's exported and
 524         the importer doesn't use the inlining, (eg passes it as an arg)
 525         then we won't get deforestation at all.
 526         We havn't solved this problem yet!
 527
 528 We prepare the envt by simply modifying the in_scope_env, which has all the
 529 unfolding info. At one point we did it by modifying the chkr so that
 530 it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
 531 important, simplifications happening in the body of the RHS.
 532
 533 6/98 update:
 534
 535 We *don't* prevent inlining from happening for identifiers
 536 that are marked as IMustBeINLINEd. An example of where
 537 doing this is crucial is:
 538
 539    class Bar a => Foo a where
 540      ...g....
 541    {-# INLINE f #-}
 542    f :: Foo a => a -> b
 543    f x = ....Foo_sc1...
 544
 545 If `f' needs to peer inside Foo's superclass, Bar, it refers
 546 to the appropriate super class selector, which is marked as
 547 must-inlineable. We don't generate any code for a superclass
 548 selector, so failing to inline it in the RHS of `f' will
 549 leave a reference to a non-existent id, with bad consequences.
 550
 551 ALSO NOTE that we do all this by modifing the inline-pragma,
 552 not by zapping the unfolding.  The latter may still be useful for
 553 knowing when something is evaluated.
 554
 555 June 98 update: I've gone back to dealing with this by adding
 556 the EssentialUnfoldingsOnly switch.  That doesn't stop essential
 557 unfoldings, nor inlineUnconditionally stuff; and the thing's going
 558 to be inlined at every call site anyway.  Running over the whole
 559 environment seems like wild overkill.
 560
 561 \begin{code}
 562 switchOffInlining :: SimplM a -> SimplM a
 563 switchOffInlining m env us sc
 564   = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (idUnfolding v)) &&
 565                                  not (isDataConWrapId v) &&
 566                                  ((v `isInScope` subst) || not (isLocallyDefined v))
 567            }) us sc
 568
 569         -- Inside inlinings, black list anything that is in scope or imported.
 570         -- except for things that must be unfolded (Compulsory)
 571         -- and data con wrappers.  The latter is a hack, like the one in
 572         -- SimplCore.simplRules, to make wrappers inline in rule LHSs.  We
 573         -- may as well do the same here.
 574   where
 575     subst          = seSubst env
 576     old_black_list = seBlackList env
 577 \end{code}
 578
 579
 580 %************************************************************************
 581 %*                                                                      *
 582 \subsubsection{The ``enclosing cost-centre''}
 583 %*                                                                      *
 584 %************************************************************************
 585
 586 \begin{code}
 587 getEnclosingCC :: SimplM CostCentreStack
 588 getEnclosingCC env us sc = (seCC env, us, sc)
 589
 590 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
 591 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
 592 \end{code}
 593
 594
 595 %************************************************************************
 596 %*                                                                      *
 597 \subsubsection{The @SimplEnv@ type}
 598 %*                                                                      *
 599 %************************************************************************
 600
 601
 602 \begin{code}
 603 emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
 604
 605 emptySimplEnv sw_chkr in_scope black_list
 606   = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
 607                seBlackList = black_list,
 608                seSubst = mkSubst in_scope emptySubstEnv }
 609         -- The top level "enclosing CC" is "SUBSUMED".
 610
 611 getEnv :: SimplM SimplEnv
 612 getEnv env us sc = (env, us, sc)
 613
 614 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
 615 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m
 616                             (SimplEnv {seSubst = old_subst}) us sc
 617   = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
 618
 619 getSubst :: SimplM Subst
 620 getSubst env us sc = (seSubst env, us, sc)
 621
 622 getBlackList :: SimplM (Id -> Bool)
 623 getBlackList env us sc = (seBlackList env, us, sc)
 624
 625 setSubst :: Subst -> SimplM a -> SimplM a
 626 setSubst subst m env us sc = m (env {seSubst = subst}) us sc
 627
 628 getSubstEnv :: SimplM SubstEnv
 629 getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
 630
 631 extendInScope :: CoreBndr -> SimplM a -> SimplM a
 632 extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
 633   = m (env {seSubst = Subst.extendInScope subst v}) us sc
 634
 635 extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
 636 extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
 637   = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
 638
 639 getInScope :: SimplM InScopeSet
 640 getInScope env us sc = (substInScope (seSubst env), us, sc)
 641
 642 setInScope :: InScopeSet -> SimplM a -> SimplM a
 643 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
 644   = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
 645
 646 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
 647 modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc
 648   = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
 649
 650 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
 651 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
 652   = m (env { seSubst = Subst.extendSubst subst var res  }) us sc
 653
 654 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
 655 extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
 656   = m (env { seSubst = Subst.extendSubstList subst vars ress  }) us sc
 657
 658 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
 659 setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
 660   = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
 661
 662 zapSubstEnv :: SimplM a -> SimplM a
 663 zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
 664   = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
 665
 666 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
 667 getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
 668   = ((subst, us), us, sc)
 669
 670 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
 671 setSimplBinderStuff (subst, us) m env _ sc
 672   = m (env {seSubst = subst}) us sc
 673 \end{code}
 674
 675
 676 \begin{code}
 677 newId :: Type -> (Id -> SimplM a) -> SimplM a
 678         -- Extends the in-scope-env too
 679 newId ty m env@(SimplEnv {seSubst = subst}) us sc
 680   =  case splitUniqSupply us of
 681         (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
 682                    where
 683                       v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
 684
 685 newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
 686 newIds tys m env@(SimplEnv {seSubst = subst}) us sc
 687   =  case splitUniqSupply us of
 688         (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
 689                    where
 690                       vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
 691                                         (uniqsFromSupply (length tys) us1) tys
 692
 693 \end{code}