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(..), TickCounts,
  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 :: SimplCount
 427 zeroSimplCount = 0
 428
 429 isZeroSimplCount n = n==0
 430
 431 doTick     t n = n+1    -- Very basic when not debugging
 432 doFreeTick t n = n      -- Don't count leaf visits
 433
 434 pprSimplCount n = ptext SLIT("Total ticks:") <+> int n
 435
 436 plusSimplCount n m = n+m
 437
 438 #else
 439 ----------------------------------------------------------
 440 --                      Debugging ON
 441 ----------------------------------------------------------
 442
 443 data SimplCount = SimplCount    {
 444                         ticks   :: !Int,                -- Total ticks
 445                         details :: !TickCounts,         -- How many of each type
 446                         n_log   :: !Int,                -- N
 447                         log1    :: [Tick],              -- Last N events; <= opt_HistorySize
 448                         log2    :: [Tick]               -- Last opt_HistorySize events before that
 449                   }
 450
 451 type TickCounts = FiniteMap Tick Int
 452
 453 zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
 454                              n_log = 0, log1 = [], log2 = []}
 455
 456 isZeroSimplCount sc = ticks sc == 0
 457
 458 doFreeTick tick sc@SimplCount { details = dts }
 459   = dts' `seqFM` sc { details = dts' }
 460   where
 461     dts' = dts `addTick` tick
 462
 463 -- Gross hack to persuade GHC 3.03 to do this important seq
 464 seqFM fm x | isEmptyFM fm = x
 465            | otherwise    = x
 466
 467 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
 468   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 469   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
 470   where
 471     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 472
 473 -- Don't use plusFM_C because that's lazy, and we want to
 474 -- be pretty strict here!
 475 addTick :: TickCounts -> Tick -> TickCounts
 476 addTick fm tick = case lookupFM fm tick of
 477                         Nothing -> addToFM fm tick 1
 478                         Just n  -> n1 `seq` addToFM fm tick n1
 479                                 where
 480                                    n1 = n+1
 481
 482 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 483                sc2@(SimplCount { ticks = tks2, details = dts2 })
 484   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
 485   where
 486         -- A hackish way of getting recent log info
 487     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
 488              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 489              | otherwise       = sc2
 490
 491
 492 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 493   = vcat [ptext SLIT("Total ticks:    ") <+> int tks,
 494           text "",
 495           pprTickCounts (fmToList dts),
 496           if verboseSimplStats then
 497                 vcat [text "",
 498                       ptext SLIT("Log (most recent first)"),
 499                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 500           else empty
 501     ]
 502
 503 pprTickCounts :: [(Tick,Int)] -> SDoc
 504 pprTickCounts [] = empty
 505 pprTickCounts ((tick1,n1):ticks)
 506   = vcat [int tot_n <+> text (tickString tick1),
 507           pprTCDetails real_these,
 508           pprTickCounts others
 509     ]
 510   where
 511     tick1_tag           = tickToTag tick1
 512     (these, others)     = span same_tick ticks
 513     real_these          = (tick1,n1):these
 514     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
 515     tot_n               = sum [n | (_,n) <- real_these]
 516
 517 pprTCDetails ticks@((tick,_):_)
 518   | verboseSimplStats || isRuleFired tick
 519   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 520   | otherwise
 521   = empty
 522 #endif
 523 \end{code}
 524
 525 %************************************************************************
 526 %*                                                                      *
 527 \subsection{Ticks}
 528 %*                                                                      *
 529 %************************************************************************
 530
 531 \begin{code}
 532 data Tick
 533   = PreInlineUnconditionally    Id
 534   | PostInlineUnconditionally   Id
 535
 536   | UnfoldingDone               Id
 537   | RuleFired                   FAST_STRING     -- Rule name
 538
 539   | LetFloatFromLet             Id      -- Thing floated out
 540   | EtaExpansion                Id      -- LHS binder
 541   | EtaReduction                Id      -- Binder on outer lambda
 542   | BetaReduction               Id      -- Lambda binder
 543
 544
 545   | CaseOfCase                  Id      -- Bndr on *inner* case
 546   | KnownBranch                 Id      -- Case binder
 547   | CaseMerge                   Id      -- Binder on outer case
 548   | CaseElim                    Id      -- Case binder
 549   | CaseIdentity                Id      -- Case binder
 550   | FillInCaseDefault           Id      -- Case binder
 551
 552   | BottomFound
 553   | LeafVisit
 554   | SimplifierDone              -- Ticked at each iteration of the simplifier
 555
 556 isRuleFired (RuleFired _) = True
 557 isRuleFired other         = False
 558
 559 instance Outputable Tick where
 560   ppr tick = text (tickString tick) <+> pprTickCts tick
 561
 562 instance Eq Tick where
 563   a == b = case a `cmpTick` b of { EQ -> True; other -> False }
 564
 565 instance Ord Tick where
 566   compare = cmpTick
 567
 568 tickToTag :: Tick -> Int
 569 tickToTag (PreInlineUnconditionally _)  = 0
 570 tickToTag (PostInlineUnconditionally _) = 1
 571 tickToTag (UnfoldingDone _)             = 2
 572 tickToTag (RuleFired _)                 = 3
 573 tickToTag (LetFloatFromLet _)           = 4
 574 tickToTag (EtaExpansion _)              = 5
 575 tickToTag (EtaReduction _)              = 6
 576 tickToTag (BetaReduction _)             = 7
 577 tickToTag (CaseOfCase _)                = 8
 578 tickToTag (KnownBranch _)               = 9
 579 tickToTag (CaseMerge _)                 = 10
 580 tickToTag (CaseElim _)                  = 11
 581 tickToTag (CaseIdentity _)              = 12
 582 tickToTag (FillInCaseDefault _)         = 13
 583 tickToTag BottomFound                   = 14
 584 tickToTag LeafVisit                     = 15
 585 tickToTag SimplifierDone                = 16
 586
 587 tickString :: Tick -> String
 588 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
 589 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 590 tickString (UnfoldingDone _)            = "UnfoldingDone"
 591 tickString (RuleFired _)                = "RuleFired"
 592 tickString (LetFloatFromLet _)          = "LetFloatFromLet"
 593 tickString (EtaExpansion _)             = "EtaExpansion"
 594 tickString (EtaReduction _)             = "EtaReduction"
 595 tickString (BetaReduction _)            = "BetaReduction"
 596 tickString (CaseOfCase _)               = "CaseOfCase"
 597 tickString (KnownBranch _)              = "KnownBranch"
 598 tickString (CaseMerge _)                = "CaseMerge"
 599 tickString (CaseElim _)                 = "CaseElim"
 600 tickString (CaseIdentity _)             = "CaseIdentity"
 601 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
 602 tickString BottomFound                  = "BottomFound"
 603 tickString SimplifierDone               = "SimplifierDone"
 604 tickString LeafVisit                    = "LeafVisit"
 605
 606 pprTickCts :: Tick -> SDoc
 607 pprTickCts (PreInlineUnconditionally v) = ppr v
 608 pprTickCts (PostInlineUnconditionally v)= ppr v
 609 pprTickCts (UnfoldingDone v)            = ppr v
 610 pprTickCts (RuleFired v)                = ppr v
 611 pprTickCts (LetFloatFromLet v)          = ppr v
 612 pprTickCts (EtaExpansion v)             = ppr v
 613 pprTickCts (EtaReduction v)             = ppr v
 614 pprTickCts (BetaReduction v)            = ppr v
 615 pprTickCts (CaseOfCase v)               = ppr v
 616 pprTickCts (KnownBranch v)              = ppr v
 617 pprTickCts (CaseMerge v)                = ppr v
 618 pprTickCts (CaseElim v)                 = ppr v
 619 pprTickCts (CaseIdentity v)             = ppr v
 620 pprTickCts (FillInCaseDefault v)        = ppr v
 621 pprTickCts other                        = empty
 622
 623 cmpTick :: Tick -> Tick -> Ordering
 624 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 625                 GT -> GT
 626                 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
 627                    | otherwise                          -> EQ
 628                 LT -> LT
 629         -- Always distinguish RuleFired, so that the stats
 630         -- can report them even in non-verbose mode
 631
 632 cmpEqTick :: Tick -> Tick -> Ordering
 633 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
 634 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
 635 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
 636 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
 637 cmpEqTick (LetFloatFromLet a)           (LetFloatFromLet b)             = a `compare` b
 638 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
 639 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
 640 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
 641 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
 642 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
 643 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
 644 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
 645 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 646 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 647 cmpEqTick other1                        other2                          = EQ
 648 \end{code}
 649
 650
 651 %************************************************************************
 652 %*                                                                      *
 653 \subsubsection{Command-line switches}
 654 %*                                                                      *
 655 %************************************************************************
 656
 657 \begin{code}
 658 getSwitchChecker :: SimplM SwitchChecker
 659 getSwitchChecker env us sc = (seChkr env, us, sc)
 660
 661 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 662 getSimplIntSwitch chkr switch
 663   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 664 \end{code}
 665
 666
 667 @switchOffInlining@ is used to prepare the environment for simplifying
 668 the RHS of an Id that's marked with an INLINE pragma.  It is going to
 669 be inlined wherever they are used, and then all the inlining will take
 670 effect.  Meanwhile, there isn't much point in doing anything to the
 671 as-yet-un-INLINEd rhs.  Furthremore, it's very important to switch off
 672 inlining!  because
 673         (a) not doing so will inline a worker straight back into its wrapper!
 674
 675 and     (b) Consider the following example
 676                 let f = \pq -> BIG
 677                 in
 678                 let g = \y -> f y y
 679                     {-# INLINE g #-}
 680                 in ...g...g...g...g...g...
 681
 682         Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 683         and thence copied multiple times when g is inlined.
 684
 685         Andy disagrees! Example:
 686                 all xs = foldr (&&) True xs
 687                 any p = all . map p  {-# INLINE any #-}
 688
 689         Problem: any won't get deforested, and so if it's exported and
 690         the importer doesn't use the inlining, (eg passes it as an arg)
 691         then we won't get deforestation at all.
 692         We havn't solved this problem yet!
 693
 694 We prepare the envt by simply modifying the in_scope_env, which has all the
 695 unfolding info. At one point we did it by modifying the chkr so that
 696 it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
 697 important, simplifications happening in the body of the RHS.
 698
 699 6/98 update:
 700
 701 We *don't* prevent inlining from happening for identifiers
 702 that are marked as IMustBeINLINEd. An example of where
 703 doing this is crucial is:
 704
 705    class Bar a => Foo a where
 706      ...g....
 707    {-# INLINE f #-}
 708    f :: Foo a => a -> b
 709    f x = ....Foo_sc1...
 710
 711 If `f' needs to peer inside Foo's superclass, Bar, it refers
 712 to the appropriate super class selector, which is marked as
 713 must-inlineable. We don't generate any code for a superclass
 714 selector, so failing to inline it in the RHS of `f' will
 715 leave a reference to a non-existent id, with bad consequences.
 716
 717 ALSO NOTE that we do all this by modifing the inline-pragma,
 718 not by zapping the unfolding.  The latter may still be useful for
 719 knowing when something is evaluated.
 720
 721 June 98 update: I've gone back to dealing with this by adding
 722 the EssentialUnfoldingsOnly switch.  That doesn't stop essential
 723 unfoldings, nor inlineUnconditionally stuff; and the thing's going
 724 to be inlined at every call site anyway.  Running over the whole
 725 environment seems like wild overkill.
 726
 727 \begin{code}
 728 switchOffInlining :: SimplM a -> SimplM a
 729 switchOffInlining m env us sc
 730   = m (env { seBlackList = \v -> True  }) us sc
 731 \end{code}
 732
 733
 734 %************************************************************************
 735 %*                                                                      *
 736 \subsubsection{The ``enclosing cost-centre''}
 737 %*                                                                      *
 738 %************************************************************************
 739
 740 \begin{code}
 741 getEnclosingCC :: SimplM CostCentreStack
 742 getEnclosingCC env us sc = (seCC env, us, sc)
 743
 744 setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
 745 setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
 746 \end{code}
 747
 748
 749 %************************************************************************
 750 %*                                                                      *
 751 \subsubsection{The @SimplEnv@ type}
 752 %*                                                                      *
 753 %************************************************************************
 754
 755
 756 \begin{code}
 757 emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
 758
 759 emptySimplEnv sw_chkr in_scope black_list
 760   = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
 761                seBlackList = black_list,
 762                seSubst = mkSubst in_scope emptySubstEnv }
 763         -- The top level "enclosing CC" is "SUBSUMED".
 764
 765 getSubst :: SimplM Subst
 766 getSubst env us sc = (seSubst env, us, sc)
 767
 768 getBlackList :: SimplM (Id -> Bool)
 769 getBlackList env us sc = (seBlackList env, us, sc)
 770
 771 setSubst :: Subst -> SimplM a -> SimplM a
 772 setSubst subst m env us sc = m (env {seSubst = subst}) us sc
 773
 774 getSubstEnv :: SimplM SubstEnv
 775 getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
 776
 777 extendInScope :: CoreBndr -> SimplM a -> SimplM a
 778 extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
 779   = m (env {seSubst = Subst.extendInScope subst v}) us sc
 780
 781 extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
 782 extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
 783   = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
 784
 785 getInScope :: SimplM InScopeSet
 786 getInScope env us sc = (substInScope (seSubst env), us, sc)
 787
 788 setInScope :: InScopeSet -> SimplM a -> SimplM a
 789 setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
 790   = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
 791
 792 modifyInScope :: CoreBndr -> SimplM a -> SimplM a
 793 modifyInScope v m env us sc
 794 #ifdef DEBUG
 795   | not (v `isInScope` seSubst env)
 796   = pprTrace "modifyInScope: not in scope:" (ppr v)
 797     m env us sc
 798 #endif
 799   | otherwise
 800   = extendInScope v m env us sc
 801
 802 extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
 803 extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
 804   = m (env { seSubst = Subst.extendSubst subst var res  }) us sc
 805
 806 extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
 807 extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
 808   = m (env { seSubst = Subst.extendSubstList subst vars ress  }) us sc
 809
 810 setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
 811 setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
 812   = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
 813
 814 zapSubstEnv :: SimplM a -> SimplM a
 815 zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
 816   = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
 817
 818 getSimplBinderStuff :: SimplM (Subst, UniqSupply)
 819 getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
 820   = ((subst, us), us, sc)
 821
 822 setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
 823 setSimplBinderStuff (subst, us) m env _ sc
 824   = m (env {seSubst = subst}) us sc
 825 \end{code}
 826
 827
 828 \begin{code}
 829 newId :: Type -> (Id -> SimplM a) -> SimplM a
 830         -- Extends the in-scope-env too
 831 newId ty m env@(SimplEnv {seSubst = subst}) us sc
 832   =  case splitUniqSupply us of
 833         (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
 834                    where
 835                       v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
 836
 837 newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
 838 newIds tys m env@(SimplEnv {seSubst = subst}) us sc
 839   =  case splitUniqSupply us of
 840         (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
 841                    where
 842                       vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
 843                                         (uniqsFromSupply (length tys) us1) tys
 844
 845 \end{code}