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