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