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