ghc/compiler/simplCore/SimplMonad.lhs

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