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