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