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 continuation type
  13         SimplCont(..), DupFlag(..), contIsDupable, contResultType,
  14         contIsInteresting, pushArgs, discardCont, countValArgs, countArgs,
  15         contArgs, contIsInline, discardInline,
  16
  17         -- The monad
  18         SimplM,
  19         initSmpl, returnSmpl, thenSmpl, thenSmpl_,
  20         mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
  21
  22         -- The inlining black-list
  23         getBlackList,
  24
  25         -- Unique supply
  26         getUniqueSmpl, getUniquesSmpl,
  27         newId, newIds,
  28
  29         -- Counting
  30         SimplCount, Tick(..),
  31         tick, freeTick,
  32         getSimplCount, zeroSimplCount, pprSimplCount,
  33         plusSimplCount, isZeroSimplCount,
  34
  35         -- Switch checker
  36         SwitchChecker, getSwitchChecker, getSimplIntSwitch,
  37
  38         -- Cost centres
  39         getEnclosingCC, setEnclosingCC,
  40
  41         -- Environments
  42         getSubst, setSubst,
  43         getSubstEnv, extendSubst, extendSubstList,
  44         getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
  45         setSubstEnv, zapSubstEnv,
  46         getSimplBinderStuff, setSimplBinderStuff,
  47         switchOffInlining
  48     ) where
  49
  50 #include "HsVersions.h"
  51
  52 import Const            ( Con(DEFAULT) )
  53 import Id               ( Id, mkSysLocal, idMustBeINLINEd )
  54 import IdInfo           ( InlinePragInfo(..) )
  55 import Demand           ( Demand )
  56 import CoreSyn
  57 import PprCore          ()      -- Instances
  58 import Rules            ( RuleBase )
  59 import CostCentre       ( CostCentreStack, subsumedCCS )
  60 import Var              ( TyVar )
  61 import VarEnv
  62 import VarSet
  63 import qualified Subst
  64 import Subst            ( Subst, emptySubst, mkSubst,
  65                           substTy, substEnv, substExpr,
  66                           InScopeSet, substInScope, isInScope, lookupInScope
  67                         )
  68 import Type             ( Type, TyVarSubst, applyTy )
  69 import UniqSupply       ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
  70                           UniqSupply
  71                         )
  72 import FiniteMap
  73 import CmdLineOpts      ( SimplifierSwitch(..), SwitchResult(..),
  74                           opt_PprStyle_Debug, opt_HistorySize,
  75                           intSwitchSet
  76                         )
  77 import Unique           ( Unique )
  78 import Maybes           ( expectJust )
  79 import Util             ( zipWithEqual )
  80 import Outputable
  81
  82 infixr 9  `thenSmpl`, `thenSmpl_`
  83 \end{code}
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsection[Simplify-types]{Type declarations}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 \begin{code}
  92 type InBinder  = CoreBndr
  93 type InId      = Id                     -- Not yet cloned
  94 type InType    = Type                   -- Ditto
  95 type InBind    = CoreBind
  96 type InExpr    = CoreExpr
  97 type InAlt     = CoreAlt
  98 type InArg     = CoreArg
  99
 100 type OutBinder  = CoreBndr
 101 type OutId      = Id                    -- Cloned
 102 type OutType    = Type                  -- Cloned
 103 type OutBind    = CoreBind
 104 type OutExpr    = CoreExpr
 105 type OutAlt     = CoreAlt
 106 type OutArg     = CoreArg
 107
 108 type SwitchChecker = SimplifierSwitch -> SwitchResult
 109 \end{code}
 110
 111
 112 %************************************************************************
 113 %*                                                                      *
 114 \subsection{The continuation data type}
 115 %*                                                                      *
 116 %************************************************************************
 117
 118 \begin{code}
 119 type OutExprStuff = OutStuff (InScopeSet, OutExpr)
 120 type OutStuff a   = ([OutBind], a)
 121         -- We return something equivalent to (let b in e), but
 122         -- in pieces to avoid the quadratic blowup when floating
 123         -- incrementally.  Comments just before simplExprB in Simplify.lhs
 124
 125 data SimplCont          -- Strict contexts
 126   = Stop OutType                -- Type of the result
 127
 128   | CoerceIt OutType                    -- The To-type, simplified
 129              SimplCont
 130
 131   | InlinePlease                        -- This continuation makes a function very
 132              SimplCont                  -- keen to inline itelf
 133
 134   | ApplyTo  DupFlag
 135              InExpr SubstEnv            -- The argument, as yet unsimplified,
 136              SimplCont                  -- and its subst-env
 137
 138   | Select   DupFlag
 139              InId [InAlt] SubstEnv      -- The case binder, alts, and subst-env
 140              SimplCont
 141
 142   | ArgOf    DupFlag            -- An arbitrary strict context: the argument
 143                                 --      of a strict function, or a primitive-arg fn
 144                                 --      or a PrimOp
 145              OutType            -- The type of the expression being sought by the context
 146                                 --      f (error "foo") ==> coerce t (error "foo")
 147                                 -- when f is strict
 148                                 -- We need to know the type t, to which to coerce.
 149             (OutExpr -> SimplM OutExprStuff)    -- What to do with the result
 150
 151 instance Outputable SimplCont where
 152   ppr (Stop _)                       = ptext SLIT("Stop")
 153   ppr (ApplyTo dup arg se cont)      = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
 154   ppr (ArgOf   dup _ _)              = ptext SLIT("ArgOf...") <+> ppr dup
 155   ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
 156                                        (nest 4 (ppr alts)) $$ ppr cont
 157   ppr (CoerceIt ty cont)             = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
 158   ppr (InlinePlease cont)            = ptext SLIT("InlinePlease") $$ ppr cont
 159
 160 data DupFlag = OkToDup | NoDup
 161
 162 instance Outputable DupFlag where
 163   ppr OkToDup = ptext SLIT("ok")
 164   ppr NoDup   = ptext SLIT("nodup")
 165
 166 contIsDupable :: SimplCont -> Bool
 167 contIsDupable (Stop _)                   = True
 168 contIsDupable (ApplyTo  OkToDup _ _ _)   = True
 169 contIsDupable (ArgOf    OkToDup _ _)     = True
 170 contIsDupable (Select   OkToDup _ _ _ _) = True
 171 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
 172 contIsDupable (InlinePlease cont)        = contIsDupable cont
 173 contIsDupable other                      = False
 174
 175 contArgs :: InScopeSet -> SimplCont -> ([OutExpr], SimplCont)
 176         -- Get the arguments from the continuation
 177         -- Apply the appropriate substitution first;
 178         -- this is done lazily and typically only the bit at the top is used
 179 contArgs in_scope (ApplyTo _ e s cont)
 180   = case contArgs in_scope cont of
 181         (args, result) -> (substExpr (mkSubst in_scope s) e : args, result)
 182 contArgs in_scope result_cont
 183    = ([], result_cont)
 184
 185 contIsInline :: SimplCont -> Bool
 186 contIsInline (InlinePlease cont) = True
 187 contIsInline other               = False
 188
 189 discardInline :: SimplCont -> SimplCont
 190 discardInline (InlinePlease cont)  = cont
 191 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
 192 discardInline cont                 = cont
 193 \end{code}
 194
 195
 196 Comment about contIsInteresting
 197 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 198 We want to avoid inlining an expression where there can't possibly be
 199 any gain, such as in an argument position.  Hence, if the continuation
 200 is interesting (eg. a case scrutinee, application etc.) then we
 201 inline, otherwise we don't.
 202
 203 Previously some_benefit used to return True only if the variable was
 204 applied to some value arguments.  This didn't work:
 205
 206         let x = _coerce_ (T Int) Int (I# 3) in
 207         case _coerce_ Int (T Int) x of
 208                 I# y -> ....
 209
 210 we want to inline x, but can't see that it's a constructor in a case
 211 scrutinee position, and some_benefit is False.
 212
 213 Another example:
 214
 215 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
 216
 217 ....  case dMonadST _@_ x0 of (a,b,c) -> ....
 218
 219 we'd really like to inline dMonadST here, but we *don't* want to
 220 inline if the case expression is just
 221
 222         case x of y { DEFAULT -> ... }
 223
 224 since we can just eliminate this case instead (x is in WHNF).  Similar
 225 applies when x is bound to a lambda expression.  Hence
 226 contIsInteresting looks for case expressions with just a single
 227 default case.
 228
 229 \begin{code}
 230 contIsInteresting :: SimplCont -> Bool
 231 contIsInteresting (Select _ _ alts _ _)       = not (just_default alts)
 232 contIsInteresting (CoerceIt _ cont)           = contIsInteresting cont
 233 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
 234 contIsInteresting (ApplyTo _ _        _ _)    = True
 235
 236 contIsInteresting (ArgOf _ _ _)               = False
 237         -- If this call is the arg of a strict function, the context
 238         -- is a bit interesting.  If we inline here, we may get useful
 239         -- evaluation information to avoid repeated evals: e.g.
 240         --      x + (y * z)
 241         -- Here the contIsInteresting makes the '*' keener to inline,
 242         -- which in turn exposes a constructor which makes the '+' inline.
 243         -- Assuming that +,* aren't small enough to inline regardless.
 244         --
 245         -- HOWEVER, I put this back to False when I discovered that strings
 246         -- were getting inlined straight back into applications of 'error'
 247         -- because the latter is strict.
 248         --      s = "foo"
 249         --      f = \x -> ...(error s)...
 250
 251 contIsInteresting (InlinePlease _)            = True
 252 contIsInteresting other                       = False
 253
 254 just_default [(DEFAULT,_,_)] = True     -- See notes below for why we look
 255 just_default alts            = False    -- for this special case
 256 \end{code}
 257
 258
 259 \begin{code}
 260 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
 261 pushArgs se []         cont = cont
 262 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
 263
 264 discardCont :: SimplCont        -- A continuation, expecting
 265             -> SimplCont        -- Replace the continuation with a suitable coerce
 266 discardCont (Stop to_ty) = Stop to_ty
 267 discardCont cont         = CoerceIt to_ty (Stop to_ty)
 268                          where
 269                            to_ty = contResultType cont
 270
 271 contResultType :: SimplCont -> OutType
 272 contResultType (Stop to_ty)          = to_ty
 273 contResultType (ArgOf _ to_ty _)     = to_ty
 274 contResultType (ApplyTo _ _ _ cont)  = contResultType cont
 275 contResultType (CoerceIt _ cont)     = contResultType cont
 276 contResultType (InlinePlease cont)   = contResultType cont
 277 contResultType (Select _ _ _ _ cont) = contResultType cont
 278
 279 countValArgs :: SimplCont -> Int
 280 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
 281 countValArgs (ApplyTo _ val_arg   se cont) = 1 + countValArgs cont
 282 countValArgs other                         = 0
 283
 284 countArgs :: SimplCont -> Int
 285 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
 286 countArgs other                   = 0
 287 \end{code}
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{Monad plumbing}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
 297 (Command-line switches move around through the explicitly-passed SimplEnv.)
 298
 299 \begin{code}
 300 type SimplM result              -- We thread the unique supply because
 301   =  SimplEnv                   -- constantly splitting it is rather expensive
 302   -> UniqSupply
 303   -> SimplCount
 304   -> (result, UniqSupply, SimplCount)
 305
 306 data SimplEnv
 307   = SimplEnv {
 308         seChkr      :: SwitchChecker,
 309         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 310         seBlackList :: Id -> Bool,      -- True =>  don't inline this Id
 311         seSubst     :: Subst            -- The current substitution
 312     }
 313         -- The range of the substitution is OutType and OutExpr resp
 314         --
 315         -- The substitution is idempotent
 316         -- It *must* be applied; things in its domain simply aren't
 317         -- bound in the result.
 318         --
 319         -- The substitution usually maps an Id to its clone,
 320         -- but if the orig defn is a let-binding, and
 321         -- the RHS of the let simplifies to an atom,
 322         -- we just add the binding to the substitution and elide the let.
 323
 324         -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
 325         -- The elements of the set may have better IdInfo than the
 326         -- occurrences of in-scope Ids, and (more important) they will
 327         -- have a correctly-substituted type.  So we use a lookup in this
 328         -- set to replace occurrences
 329 \end{code}
 330
 331 \begin{code}
 332 initSmpl :: SwitchChecker
 333          -> UniqSupply          -- No init count; set to 0
 334          -> VarSet              -- In scope (usually empty, but useful for nested calls)
 335          -> (Id -> Bool)        -- Black-list function
 336          -> SimplM a
 337          -> (a, SimplCount)
 338
 339 initSmpl chkr us in_scope black_list m
 340   = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
 341         (result, _, count) -> (result, count)
 342
 343
 344 {-# INLINE thenSmpl #-}
 345 {-# INLINE thenSmpl_ #-}
 346 {-# INLINE returnSmpl #-}
 347
 348 returnSmpl :: a -> SimplM a
 349 returnSmpl e env us sc = (e, us, sc)
 350
 351 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
 352 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
 353
 354 thenSmpl m k env us0 sc0
 355   = case (m env us0 sc0) of
 356         (m_result, us1, sc1) -> k m_result env us1 sc1
 357
 358 thenSmpl_ m k env us0 sc0
 359   = case (m env us0 sc0) of
 360         (_, us1, sc1) -> k env us1 sc1
 361 \end{code}
 362
 363
 364 \begin{code}
 365 mapSmpl         :: (a -> SimplM b) -> [a] -> SimplM [b]
 366 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
 367
 368 mapSmpl f [] = returnSmpl []
 369 mapSmpl f (x:xs)
 370   = f x             `thenSmpl` \ x'  ->
 371     mapSmpl f xs    `thenSmpl` \ xs' ->
 372     returnSmpl (x':xs')
 373
 374 mapAndUnzipSmpl f [] = returnSmpl ([],[])
 375 mapAndUnzipSmpl f (x:xs)
 376   = f x                     `thenSmpl` \ (r1,  r2)  ->
 377     mapAndUnzipSmpl f xs    `thenSmpl` \ (rs1, rs2) ->
 378     returnSmpl (r1:rs1, r2:rs2)
 379
 380 mapAccumLSmpl f acc []     = returnSmpl (acc, [])
 381 mapAccumLSmpl f acc (x:xs) = f acc x    `thenSmpl` \ (acc', x') ->
 382                              mapAccumLSmpl f acc' xs    `thenSmpl` \ (acc'', xs') ->
 383                              returnSmpl (acc'', x':xs')
 384 \end{code}
 385
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection{The unique supply}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 \begin{code}
 394 getUniqueSmpl :: SimplM Unique
 395 getUniqueSmpl env us sc = case splitUniqSupply us of
 396                                 (us1, us2) -> (uniqFromSupply us1, us2, sc)
 397
 398 getUniquesSmpl :: Int -> SimplM [Unique]
 399 getUniquesSmpl n env us sc = case splitUniqSupply us of
 400                                 (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
 401 \end{code}
 402
 403
 404 %************************************************************************
 405 %*                                                                      *
 406 \subsection{Counting up what we've done}
 407 %*                                                                      *
 408 %************************************************************************
 409
 410 \begin{code}
 411 getSimplCount :: SimplM SimplCount
 412 getSimplCount env us sc = (sc, us, sc)
 413
 414 tick :: Tick -> SimplM ()
 415 tick t env us sc = sc' `seq` ((), us, sc')
 416                  where
 417                    sc' = doTick t sc
 418
 419 freeTick :: Tick -> SimplM ()
 420 -- Record a tick, but don't add to the total tick count, which is
 421 -- used to decide when nothing further has happened
 422 freeTick t env us sc = sc' `seq` ((), us, sc')
 423                  where
 424                    sc' = doFreeTick t sc
 425 \end{code}
 426
 427 \begin{code}
 428 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
 429
 430 -- Defined both with and without debugging
 431 zeroSimplCount     :: SimplCount
 432 isZeroSimplCount   :: SimplCount -> Bool
 433 pprSimplCount      :: SimplCount -> SDoc
 434 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
 435 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 436 \end{code}
 437
 438 \begin{code}
 439 #ifndef DEBUG
 440 ----------------------------------------------------------
 441 --                      Debugging OFF
 442 ----------------------------------------------------------
 443 type SimplCount = Int
 444
 445 zeroSimplCount = 0
 446
 447 isZeroSimplCount n = n==0
 448
 449 doTick     t n = n+1    -- Very basic when not debugging
 450 doFreeTick t n = n      -- Don't count leaf visits
 451
 452 pprSimplCount n = ptext SLIT("Total ticks:") <+> int n
 453
 454 plusSimplCount n m = n+m
 455
 456 #else
 457 ----------------------------------------------------------
 458 --                      Debugging ON
 459 ----------------------------------------------------------
 460
 461 data SimplCount = SimplCount    {
 462                         ticks   :: !Int,                -- Total ticks
 463                         details :: !TickCounts,         -- How many of each type
 464                         n_log   :: !Int,                -- N
 465                         log1    :: [Tick],              -- Last N events; <= opt_HistorySize
 466                         log2    :: [Tick]               -- Last opt_HistorySize events before that
 467                   }
 468
 469 type TickCounts = FiniteMap Tick Int
 470
 471 zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
 472                              n_log = 0, log1 = [], log2 = []}
 473
 474 isZeroSimplCount sc = ticks sc == 0
 475
 476 doFreeTick tick sc@SimplCount { details = dts }
 477   = dts' `seqFM` sc { details = dts' }
 478   where
 479     dts' = dts `addTick` tick
 480
 481 -- Gross hack to persuade GHC 3.03 to do this important seq
 482 seqFM fm x | isEmptyFM fm = x
 483            | otherwise    = x
 484
 485 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
 486   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 487   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
 488   where
 489     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 490
 491 -- Don't use plusFM_C because that's lazy, and we want to
 492 -- be pretty strict here!
 493 addTick :: TickCounts -> Tick -> TickCounts
 494 addTick fm tick = case lookupFM fm tick of
 495                         Nothing -> addToFM fm tick 1
 496                         Just n  -> n1 `seq` addToFM fm tick n1
 497                                 where
 498                                    n1 = n+1
 499
 500 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 501                sc2@(SimplCount { ticks = tks2, details = dts2 })
 502   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
 503   where
 504         -- A hackish way of getting recent log info
 505     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
 506              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 507              | otherwise       = sc2
 508
 509
 510 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 511   = vcat [ptext SLIT("Total ticks:    ") <+> int tks,
 512           text "",
 513           pprTickCounts (fmToList dts),
 514           if verboseSimplStats then
 515                 vcat [text "",
 516                       ptext SLIT("Log (most recent first)"),
 517                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 518           else empty
 519     ]
 520
 521 pprTickCounts :: [(Tick,Int)] -> SDoc
 522 pprTickCounts [] = empty
 523 pprTickCounts ((tick1,n1):ticks)
 524   = vcat [int tot_n <+> text (tickString tick1),
 525           pprTCDetails real_these,
 526           pprTickCounts others
 527     ]
 528   where
 529     tick1_tag           = tickToTag tick1
 530     (these, others)     = span same_tick ticks
 531     real_these          = (tick1,n1):these
 532     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
 533     tot_n               = sum [n | (_,n) <- real_these]
 534
 535 pprTCDetails ticks@((tick,_):_)
 536   | verboseSimplStats || isRuleFired tick
 537   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 538   | otherwise
 539   = empty
 540 #endif
 541 \end{code}
 542
 543 %************************************************************************
 544 %*                                                                      *
 545 \subsection{Ticks}
 546 %*                                                                      *
 547 %************************************************************************
 548
 549 \begin{code}
 550 data Tick
 551   = PreInlineUnconditionally    Id
 552   | PostInlineUnconditionally   Id
 553
 554   | UnfoldingDone               Id
 555   | RuleFired                   FAST_STRING     -- Rule name
 556
 557   | LetFloatFromLet             Id      -- Thing floated out
 558   | EtaExpansion                Id      -- LHS binder
 559   | EtaReduction                Id      -- Binder on outer lambda
 560   | BetaReduction               Id      -- Lambda binder
 561
 562
 563   | CaseOfCase                  Id      -- Bndr on *inner* case
 564   | KnownBranch                 Id      -- Case binder
 565   | CaseMerge                   Id      -- Binder on outer case
 566   | CaseElim                    Id      -- Case binder
 567   | CaseIdentity                Id      -- Case binder
 568   | FillInCaseDefault           Id      -- Case binder
 569
 570   | BottomFound
 571   | LeafVisit
 572   | SimplifierDone              -- Ticked at each iteration of the simplifier
 573
 574 isRuleFired (RuleFired _) = True
 575 isRuleFired other         = False
 576
 577 instance Outputable Tick where
 578   ppr tick = text (tickString tick) <+> pprTickCts tick
 579
 580 instance Eq Tick where
 581   a == b = case a `cmpTick` b of { EQ -> True; other -> False }
 582
 583 instance Ord Tick where
 584   compare = cmpTick
 585
 586 tickToTag :: Tick -> Int
 587 tickToTag (PreInlineUnconditionally _)  = 0
 588 tickToTag (PostInlineUnconditionally _) = 1
 589 tickToTag (UnfoldingDone _)             = 2
 590 tickToTag (RuleFired _)                 = 3
 591 tickToTag (LetFloatFromLet _)           = 4
 592 tickToTag (EtaExpansion _)              = 5
 593 tickToTag (EtaReduction _)              = 6
 594 tickToTag (BetaReduction _)             = 7
 595 tickToTag (CaseOfCase _)                = 8
 596 tickToTag (KnownBranch _)               = 9
 597 tickToTag (CaseMerge _)                 = 10
 598 tickToTag (CaseElim _)                  = 11
 599 tickToTag (CaseIdentity _)              = 12
 600 tickToTag (FillInCaseDefault _)         = 13
 601 tickToTag BottomFound                   = 14
 602 tickToTag LeafVisit                     = 15
 603 tickToTag SimplifierDone                = 16
 604
 605 tickString :: Tick -> String
 606 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
 607 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 608 tickString (UnfoldingDone _)            = "UnfoldingDone"
 609 tickString (RuleFired _)                = "RuleFired"
 610 tickString (LetFloatFromLet _)          = "LetFloatFromLet"
 611 tickString (EtaExpansion _)             = "EtaExpansion"
 612 tickString (EtaReduction _)             = "EtaReduction"
 613 tickString (BetaReduction _)            = "BetaReduction"
 614 tickString (CaseOfCase _)               = "CaseOfCase"
 615 tickString (KnownBranch _)              = "KnownBranch"
 616 tickString (CaseMerge _)                = "CaseMerge"
 617 tickString (CaseElim _)                 = "CaseElim"
 618 tickString (CaseIdentity _)             = "CaseIdentity"
 619 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
 620 tickString BottomFound                  = "BottomFound"
 621 tickString SimplifierDone               = "SimplifierDone"
 622 tickString LeafVisit                    = "LeafVisit"
 623
 624 pprTickCts :: Tick -> SDoc
 625 pprTickCts (PreInlineUnconditionally v) = ppr v
 626 pprTickCts (PostInlineUnconditionally v)= ppr v
 627 pprTickCts (UnfoldingDone v)            = ppr v
 628 pprTickCts (RuleFired v)                = ppr v
 629 pprTickCts (LetFloatFromLet v)          = ppr v
 630 pprTickCts (EtaExpansion v)             = ppr v
 631 pprTickCts (EtaReduction v)             = ppr v
 632 pprTickCts (BetaReduction v)            = ppr v
 633 pprTickCts (CaseOfCase v)               = ppr v
 634 pprTickCts (KnownBranch v)              = ppr v
 635 pprTickCts (CaseMerge v)                = ppr v
 636 pprTickCts (CaseElim v)                 = ppr v
 637 pprTickCts (CaseIdentity v)             = ppr v
 638 pprTickCts (FillInCaseDefault v)        = ppr v
 639 pprTickCts other                        = empty
 640
 641 cmpTick :: Tick -> Tick -> Ordering
 642 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 643                 GT -> GT
 644                 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
 645                    | otherwise                          -> EQ
 646                 LT -> LT
 647         -- Always distinguish RuleFired, so that the stats
 648         -- can report them even in non-verbose mode
 649
 650 cmpEqTick :: Tick -> Tick -> Ordering
 651 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
 652 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
 653 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
 654 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
 655 cmpEqTick (LetFloatFromLet a)           (LetFloatFromLet b)             = a `compare` b
 656 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
 657 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
 658 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
 659 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
 660 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
 661 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
 662 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
 663 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 664 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 665 cmpEqTick other1                        other2                          = EQ
 666 \end{code}
 667
 668
 669 %************************************************************************
 670 %*                                                                      *
 671 \subsubsection{Command-line switches}
 672 %*                                                                      *
 673 %************************************************************************
 674
 675 \begin{code}
 676 getSwitchChecker :: SimplM SwitchChecker
 677 getSwitchChecker env us sc = (seChkr env, us, sc)
 678
 679 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 680 getSimplIntSwitch chkr switch
 681   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 682 \end{code}
 683
 684
 685 @switchOffInlining@ is used to prepare the environment for simplifying
 686 the RHS of an Id that's marked with an INLINE pragma.  It is going to
 687 be inlined wherever they are used, and then all the inlining will take
 688 effect.  Meanwhile, there isn't much point in doing anything to the
 689 as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
 690 inlining!  because
 691         (a) not doing so will inline a worker straight back into its wrapper!
 692
 693 and     (b) Consider the following example
 694                 let f = \pq -> BIG
 695                 in
 696                 let g = \y -> f y y
 697                     {-# INLINE g #-}
 698                 in ...g...g...g...g...g...
 699
 700         Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 701         and thence copied multiple times when g is inlined.
 702
 703         Andy disagrees! Example:
 704                 all xs = foldr (&&) True xs
 705                 any p = all . map p  {-# INLINE any #-}
 706
 707         Problem: any won't get deforested, and so if it's exported and
 708         the importer doesn't use the inlining, (eg passes it as an arg)
 709         then we won't get deforestation at all.
 710         We havn't solved this problem yet!
 711
 712 We prepare the envt by simply modifying the in_scope_env, which has all the
 713 unfolding info. At one point we did it by modifying the chkr so that
 714 it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
 715 important, simplifications happening in the body of the RHS.
 716
 717 6/98 update:
 718
 719 We *don't* prevent inlining from happening for identifiers
 720 that are marked as IMustBeINLINEd. An example of where
 721 doing this is crucial is:
 722
 723    class Bar a => Foo a where
 724      ...g....
 725    {-# INLINE f #-}
 726    f :: Foo a => a -> b
 727    f x = ....Foo_sc1...
 728
 729 If `f' needs to peer inside Foo's superclass, Bar, it refers
 730 to the appropriate super class selector, which is marked as
 731 must-inlineable. We don't generate any code for a superclass
 732 selector, so failing to inline it in the RHS of `f' will
 733 leave a reference to a non-existent id, with bad consequences.
 734
 735 ALSO NOTE that we do all this by modifing the inline-pragma,
 736 not by zapping the unfolding.  The latter may still be useful for
 737 knowing when something is evaluated.
 738
 739 June 98 update: I've gone back to dealing with this by adding
 740 the EssentialUnfoldingsOnly switch.  That doesn't stop essential
 741 unfoldings, nor inlineUnconditionally stuff; and the thing's going
 742 to be inlined at every call site anyway.  Running over the whole
 743 environment seems like wild overkill.
 744
 745 \begin{code}
 746 switchOffInlining :: SimplM a -> SimplM a
 747 switchOffInlining m env us sc
 748   = m (env { seBlackList = \v -> True  }) us sc
 749 \end{code}
 750
 751
 752 %************************************************************************
 753 %*                                                                      *
 754 \subsubsection{The ``enclosing cost-centre''}
 755 %*                                                                      *
 756 %************************************************************************
 757
 758 \begin{code}
 759 getEnclosingCC :: SimplM CostCentreStack
 760 getEnclosingCC env us sc = (seCC env, us, sc)
 761
 762 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
 763 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
 764 \end{code}
 765
 766
 767 %************************************************************************
 768 %*                                                                      *
 769 \subsubsection{The @SimplEnv@ type}
 770 %*                                                                      *
 771 %************************************************************************
 772
 773
 774 \begin{code}
 775 emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
 776
 777 emptySimplEnv sw_chkr in_scope black_list
 778   = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
 779                seBlackList = black_list,
 780                seSubst = mkSubst in_scope emptySubstEnv }
 781         -- The top level "enclosing CC" is "SUBSUMED".
 782
 783 getSubst :: SimplM Subst
 784 getSubst env us sc = (seSubst env, us, sc)
 785
 786 getBlackList :: SimplM (Id -> Bool)
 787 getBlackList env us sc = (seBlackList env, us, sc)
 788
 789 setSubst :: Subst -> SimplM a -> SimplM a
 790 setSubst subst m env us sc = m (env {seSubst = subst}) us sc
 791
 792 getSubstEnv :: SimplM SubstEnv
 793 getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
 794
 795 extendInScope :: CoreBndr -> SimplM a -> SimplM a
 796 extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
 797   = m (env {seSubst = Subst.extendInScope subst v}) us sc
 798
 799 extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
 800 extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
 801   = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
 802
 803 getInScope :: SimplM InScopeSet
 804 getInScope env us sc = (substInScope (seSubst env), us, sc)
 805
 806 setInScope :: InScopeSet -> SimplM a -> SimplM a
 807 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
 808   = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
 809
 810 modifyInScope :: CoreBndr -> SimplM a -> SimplM a
 811 modifyInScope v m env us sc
 812 #ifdef DEBUG
 813   | not (v `isInScope` seSubst env)
 814   = pprTrace "modifyInScope: not in scope:" (ppr v)
 815     m env us sc
 816 #endif
 817   | otherwise
 818   = extendInScope v m env us sc
 819
 820 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
 821 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
 822   = m (env { seSubst = Subst.extendSubst subst var res  }) us sc
 823
 824 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
 825 extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
 826   = m (env { seSubst = Subst.extendSubstList subst vars ress  }) us sc
 827
 828 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
 829 setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
 830   = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
 831
 832 zapSubstEnv :: SimplM a -> SimplM a
 833 zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
 834   = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
 835
 836 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
 837 getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
 838   = ((subst, us), us, sc)
 839
 840 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
 841 setSimplBinderStuff (subst, us) m env _ sc
 842   = m (env {seSubst = subst}) us sc
 843 \end{code}
 844
 845
 846 \begin{code}
 847 newId :: Type -> (Id -> SimplM a) -> SimplM a
 848         -- Extends the in-scope-env too
 849 newId ty m env@(SimplEnv {seSubst = subst}) us sc
 850   =  case splitUniqSupply us of
 851         (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
 852                    where
 853                       v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
 854
 855 newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
 856 newIds tys m env@(SimplEnv {seSubst = subst}) us sc
 857   =  case splitUniqSupply us of
 858         (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
 859                    where
 860                       vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
 861                                         (uniqsFromSupply (length tys) us1) tys
 862
 863 \end{code}