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