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