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