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