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