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