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,
  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 -- Defined both with and without debugging
 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 #ifndef DEBUG
 265 ----------------------------------------------------------
 266 --                      Debugging OFF
 267 ----------------------------------------------------------
 268 type SimplCount = Int
 269
 270 zeroSimplCount = 0
 271
 272 isZeroSimplCount n = n==0
 273
 274 doTick     t n = n+1    -- Very basic when not debugging
 275 doFreeTick t n = n      -- Don't count leaf visits
 276
 277 pprSimplCount n = ptext SLIT("Total ticks:") <+> int n
 278
 279 plusSimplCount n m = n+m
 280
 281 #else
 282 ----------------------------------------------------------
 283 --                      Debugging ON
 284 ----------------------------------------------------------
 285
 286 data SimplCount = SimplCount    {
 287                         ticks   :: !Int,                -- Total ticks
 288                         details :: !TickCounts,         -- How many of each type
 289                         n_log   :: !Int,                -- N
 290                         log1    :: [Tick],              -- Last N events; <= opt_HistorySize
 291                         log2    :: [Tick]               -- Last opt_HistorySize events before that
 292                   }
 293
 294 type TickCounts = FiniteMap Tick Int
 295
 296 zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
 297                              n_log = 0, log1 = [], log2 = []}
 298
 299 isZeroSimplCount sc = ticks sc == 0
 300
 301 doFreeTick tick sc@SimplCount { details = dts }
 302   = dts' `seqFM` sc { details = dts' }
 303   where
 304     dts' = dts `addTick` tick
 305
 306 -- Gross hack to persuade GHC 3.03 to do this important seq
 307 seqFM fm x | isEmptyFM fm = x
 308            | otherwise    = x
 309
 310 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
 311   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 312   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
 313   where
 314     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 315
 316 -- Don't use plusFM_C because that's lazy, and we want to
 317 -- be pretty strict here!
 318 addTick :: TickCounts -> Tick -> TickCounts
 319 addTick fm tick = case lookupFM fm tick of
 320                         Nothing -> addToFM fm tick 1
 321                         Just n  -> n1 `seq` addToFM fm tick n1
 322                                 where
 323                                    n1 = n+1
 324
 325 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 326                sc2@(SimplCount { ticks = tks2, details = dts2 })
 327   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
 328   where
 329         -- A hackish way of getting recent log info
 330     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
 331              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 332              | otherwise       = sc2
 333
 334
 335 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 336   = vcat [ptext SLIT("Total ticks:    ") <+> int tks,
 337           text "",
 338           pprTickCounts (fmToList dts),
 339           if verboseSimplStats then
 340                 vcat [text "",
 341                       ptext SLIT("Log (most recent first)"),
 342                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 343           else empty
 344     ]
 345
 346 pprTickCounts :: [(Tick,Int)] -> SDoc
 347 pprTickCounts [] = empty
 348 pprTickCounts ((tick1,n1):ticks)
 349   = vcat [int tot_n <+> text (tickString tick1),
 350           pprTCDetails real_these,
 351           pprTickCounts others
 352     ]
 353   where
 354     tick1_tag           = tickToTag tick1
 355     (these, others)     = span same_tick ticks
 356     real_these          = (tick1,n1):these
 357     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
 358     tot_n               = sum [n | (_,n) <- real_these]
 359
 360 pprTCDetails ticks@((tick,_):_)
 361   | verboseSimplStats || isRuleFired tick
 362   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 363   | otherwise
 364   = empty
 365 #endif
 366 \end{code}
 367
 368 %************************************************************************
 369 %*                                                                      *
 370 \subsection{Ticks}
 371 %*                                                                      *
 372 %************************************************************************
 373
 374 \begin{code}
 375 data Tick
 376   = PreInlineUnconditionally    Id
 377   | PostInlineUnconditionally   Id
 378
 379   | UnfoldingDone               Id
 380   | RuleFired                   FAST_STRING     -- Rule name
 381
 382   | LetFloatFromLet             Id      -- Thing floated out
 383   | EtaExpansion                Id      -- LHS binder
 384   | EtaReduction                Id      -- Binder on outer lambda
 385   | BetaReduction               Id      -- Lambda binder
 386
 387
 388   | CaseOfCase                  Id      -- Bndr on *inner* case
 389   | KnownBranch                 Id      -- Case binder
 390   | CaseMerge                   Id      -- Binder on outer case
 391   | CaseElim                    Id      -- Case binder
 392   | CaseIdentity                Id      -- Case binder
 393   | FillInCaseDefault           Id      -- Case binder
 394
 395   | BottomFound
 396   | SimplifierDone              -- Ticked at each iteration of the simplifier
 397
 398 isRuleFired (RuleFired _) = True
 399 isRuleFired other         = False
 400
 401 instance Outputable Tick where
 402   ppr tick = text (tickString tick) <+> pprTickCts tick
 403
 404 instance Eq Tick where
 405   a == b = case a `cmpTick` b of { EQ -> True; other -> False }
 406
 407 instance Ord Tick where
 408   compare = cmpTick
 409
 410 tickToTag :: Tick -> Int
 411 tickToTag (PreInlineUnconditionally _)  = 0
 412 tickToTag (PostInlineUnconditionally _) = 1
 413 tickToTag (UnfoldingDone _)             = 2
 414 tickToTag (RuleFired _)                 = 3
 415 tickToTag (LetFloatFromLet _)           = 4
 416 tickToTag (EtaExpansion _)              = 5
 417 tickToTag (EtaReduction _)              = 6
 418 tickToTag (BetaReduction _)             = 7
 419 tickToTag (CaseOfCase _)                = 8
 420 tickToTag (KnownBranch _)               = 9
 421 tickToTag (CaseMerge _)                 = 10
 422 tickToTag (CaseElim _)                  = 11
 423 tickToTag (CaseIdentity _)              = 12
 424 tickToTag (FillInCaseDefault _)         = 13
 425 tickToTag BottomFound                   = 14
 426 tickToTag SimplifierDone                = 16
 427
 428 tickString :: Tick -> String
 429 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
 430 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 431 tickString (UnfoldingDone _)            = "UnfoldingDone"
 432 tickString (RuleFired _)                = "RuleFired"
 433 tickString (LetFloatFromLet _)          = "LetFloatFromLet"
 434 tickString (EtaExpansion _)             = "EtaExpansion"
 435 tickString (EtaReduction _)             = "EtaReduction"
 436 tickString (BetaReduction _)            = "BetaReduction"
 437 tickString (CaseOfCase _)               = "CaseOfCase"
 438 tickString (KnownBranch _)              = "KnownBranch"
 439 tickString (CaseMerge _)                = "CaseMerge"
 440 tickString (CaseElim _)                 = "CaseElim"
 441 tickString (CaseIdentity _)             = "CaseIdentity"
 442 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
 443 tickString BottomFound                  = "BottomFound"
 444 tickString SimplifierDone               = "SimplifierDone"
 445
 446 pprTickCts :: Tick -> SDoc
 447 pprTickCts (PreInlineUnconditionally v) = ppr v
 448 pprTickCts (PostInlineUnconditionally v)= ppr v
 449 pprTickCts (UnfoldingDone v)            = ppr v
 450 pprTickCts (RuleFired v)                = ppr v
 451 pprTickCts (LetFloatFromLet v)          = ppr v
 452 pprTickCts (EtaExpansion v)             = ppr v
 453 pprTickCts (EtaReduction v)             = ppr v
 454 pprTickCts (BetaReduction v)            = ppr v
 455 pprTickCts (CaseOfCase v)               = ppr v
 456 pprTickCts (KnownBranch v)              = ppr v
 457 pprTickCts (CaseMerge v)                = ppr v
 458 pprTickCts (CaseElim v)                 = ppr v
 459 pprTickCts (CaseIdentity v)             = ppr v
 460 pprTickCts (FillInCaseDefault v)        = ppr v
 461 pprTickCts other                        = empty
 462
 463 cmpTick :: Tick -> Tick -> Ordering
 464 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 465                 GT -> GT
 466                 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
 467                    | otherwise                          -> EQ
 468                 LT -> LT
 469         -- Always distinguish RuleFired, so that the stats
 470         -- can report them even in non-verbose mode
 471
 472 cmpEqTick :: Tick -> Tick -> Ordering
 473 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
 474 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
 475 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
 476 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
 477 cmpEqTick (LetFloatFromLet a)           (LetFloatFromLet b)             = a `compare` b
 478 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
 479 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
 480 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
 481 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
 482 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
 483 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
 484 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
 485 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 486 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 487 cmpEqTick other1                        other2                          = EQ
 488 \end{code}
 489
 490
 491 %************************************************************************
 492 %*                                                                      *
 493 \subsubsection{Command-line switches}
 494 %*                                                                      *
 495 %************************************************************************
 496
 497 \begin{code}
 498 getSwitchChecker :: SimplM SwitchChecker
 499 getSwitchChecker env us sc = (seChkr env, us, sc)
 500
 501 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 502 getSimplIntSwitch chkr switch
 503   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 504 \end{code}
 505
 506
 507 @switchOffInlining@ is used to prepare the environment for simplifying
 508 the RHS of an Id that's marked with an INLINE pragma.  It is going to
 509 be inlined wherever they are used, and then all the inlining will take
 510 effect.  Meanwhile, there isn't much point in doing anything to the
 511 as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
 512 inlining!  because
 513         (a) not doing so will inline a worker straight back into its wrapper!
 514
 515 and     (b) Consider the following example
 516                 let f = \pq -> BIG
 517                 in
 518                 let g = \y -> f y y
 519                     {-# INLINE g #-}
 520                 in ...g...g...g...g...g...
 521
 522         Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 523         and thence copied multiple times when g is inlined.
 524
 525         Andy disagrees! Example:
 526                 all xs = foldr (&&) True xs
 527                 any p = all . map p  {-# INLINE any #-}
 528
 529         Problem: any won't get deforested, and so if it's exported and
 530         the importer doesn't use the inlining, (eg passes it as an arg)
 531         then we won't get deforestation at all.
 532         We havn't solved this problem yet!
 533
 534 We prepare the envt by simply modifying the in_scope_env, which has all the
 535 unfolding info. At one point we did it by modifying the chkr so that
 536 it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
 537 important, simplifications happening in the body of the RHS.
 538
 539 6/98 update:
 540
 541 We *don't* prevent inlining from happening for identifiers
 542 that are marked as IMustBeINLINEd. An example of where
 543 doing this is crucial is:
 544
 545    class Bar a => Foo a where
 546      ...g....
 547    {-# INLINE f #-}
 548    f :: Foo a => a -> b
 549    f x = ....Foo_sc1...
 550
 551 If `f' needs to peer inside Foo's superclass, Bar, it refers
 552 to the appropriate super class selector, which is marked as
 553 must-inlineable. We don't generate any code for a superclass
 554 selector, so failing to inline it in the RHS of `f' will
 555 leave a reference to a non-existent id, with bad consequences.
 556
 557 ALSO NOTE that we do all this by modifing the inline-pragma,
 558 not by zapping the unfolding.  The latter may still be useful for
 559 knowing when something is evaluated.
 560
 561 June 98 update: I've gone back to dealing with this by adding
 562 the EssentialUnfoldingsOnly switch.  That doesn't stop essential
 563 unfoldings, nor inlineUnconditionally stuff; and the thing's going
 564 to be inlined at every call site anyway.  Running over the whole
 565 environment seems like wild overkill.
 566
 567 \begin{code}
 568 switchOffInlining :: SimplM a -> SimplM a
 569 switchOffInlining m env us sc
 570   = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (idUnfolding v)) &&
 571                                  not (isDataConWrapId v) &&
 572                                  ((v `isInScope` subst) || not (isLocallyDefined v))
 573            }) us sc
 574
 575         -- Inside inlinings, black list anything that is in scope or imported.
 576         -- except for things that must be unfolded (Compulsory)
 577         -- and data con wrappers.  The latter is a hack, like the one in
 578         -- SimplCore.simplRules, to make wrappers inline in rule LHSs.  We
 579         -- may as well do the same here.
 580   where
 581     subst          = seSubst env
 582     old_black_list = seBlackList env
 583 \end{code}
 584
 585
 586 %************************************************************************
 587 %*                                                                      *
 588 \subsubsection{The ``enclosing cost-centre''}
 589 %*                                                                      *
 590 %************************************************************************
 591
 592 \begin{code}
 593 getEnclosingCC :: SimplM CostCentreStack
 594 getEnclosingCC env us sc = (seCC env, us, sc)
 595
 596 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
 597 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
 598 \end{code}
 599
 600
 601 %************************************************************************
 602 %*                                                                      *
 603 \subsubsection{The @SimplEnv@ type}
 604 %*                                                                      *
 605 %************************************************************************
 606
 607
 608 \begin{code}
 609 emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
 610
 611 emptySimplEnv sw_chkr in_scope black_list
 612   = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
 613                seBlackList = black_list,
 614                seSubst = mkSubst in_scope emptySubstEnv }
 615         -- The top level "enclosing CC" is "SUBSUMED".
 616
 617 getEnv :: SimplM SimplEnv
 618 getEnv env us sc = (env, us, sc)
 619
 620 setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
 621 setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m
 622                             (SimplEnv {seSubst = old_subst}) us sc
 623   = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
 624
 625 getSubst :: SimplM Subst
 626 getSubst env us sc = (seSubst env, us, sc)
 627
 628 getBlackList :: SimplM (Id -> Bool)
 629 getBlackList env us sc = (seBlackList env, us, sc)
 630
 631 setSubst :: Subst -> SimplM a -> SimplM a
 632 setSubst subst m env us sc = m (env {seSubst = subst}) us sc
 633
 634 getSubstEnv :: SimplM SubstEnv
 635 getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
 636
 637 extendInScope :: CoreBndr -> SimplM a -> SimplM a
 638 extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
 639   = m (env {seSubst = Subst.extendInScope subst v}) us sc
 640
 641 extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
 642 extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
 643   = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
 644
 645 getInScope :: SimplM InScopeSet
 646 getInScope env us sc = (substInScope (seSubst env), us, sc)
 647
 648 setInScope :: InScopeSet -> SimplM a -> SimplM a
 649 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
 650   = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
 651
 652 modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
 653 modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc
 654   = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
 655
 656 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
 657 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
 658   = m (env { seSubst = Subst.extendSubst subst var res  }) us sc
 659
 660 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
 661 extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
 662   = m (env { seSubst = Subst.extendSubstList subst vars ress  }) us sc
 663
 664 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
 665 setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
 666   = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
 667
 668 zapSubstEnv :: SimplM a -> SimplM a
 669 zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
 670   = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
 671
 672 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
 673 getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
 674   = ((subst, us), us, sc)
 675
 676 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
 677 setSimplBinderStuff (subst, us) m env _ sc
 678   = m (env {seSubst = subst}) us sc
 679 \end{code}
 680
 681
 682 \begin{code}
 683 newId :: Type -> (Id -> SimplM a) -> SimplM a
 684         -- Extends the in-scope-env too
 685 newId ty m env@(SimplEnv {seSubst = subst}) us sc
 686   =  case splitUniqSupply us of
 687         (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
 688                    where
 689                       v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
 690
 691 newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
 692 newIds tys m env@(SimplEnv {seSubst = subst}) us sc
 693   =  case splitUniqSupply us of
 694         (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
 695                    where
 696                       vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
 697                                         (uniqsFromSupply (length tys) us1) tys
 698
 699 \end{code}