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