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, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
  10         FloatsWith, FloatsWithExpr,
  11
  12         -- The monad
  13         SimplM,
  14         initSmpl, returnSmpl, thenSmpl, thenSmpl_,
  15         mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
  16         getDOptsSmpl,
  17
  18         -- The simplifier mode
  19         setMode, getMode,
  20
  21         -- Unique supply
  22         getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
  23
  24         -- Counting
  25         SimplCount, Tick(..),
  26         tick, freeTick,
  27         getSimplCount, zeroSimplCount, pprSimplCount,
  28         plusSimplCount, isZeroSimplCount,
  29
  30         -- Switch checker
  31         SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
  32         isAmongSimpl, intSwitchSet, switchIsOn,
  33
  34         -- Cost centres
  35         getEnclosingCC, setEnclosingCC,
  36
  37         -- Environments
  38         SimplEnv, emptySimplEnv, getSubst, setSubst, extendIdSubst, extendTvSubst,
  39         zapSubstEnv, setSubstEnv, getTvSubst, setTvSubstEnv,
  40         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
  41
  42         -- Floats
  43         Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
  44         allLifted, wrapFloats, floatBinds,
  45         addAuxiliaryBind,
  46
  47         -- Inlining,
  48         preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
  49         inlineMode
  50     ) where
  51
  52 #include "HsVersions.h"
  53
  54 import Id               ( Id, idType, idOccInfo, idInlinePragma )
  55 import CoreSyn
  56 import CoreUtils        ( needsCaseBinding, exprIsTrivial )
  57 import PprCore          ()      -- Instances
  58 import CostCentre       ( CostCentreStack, subsumedCCS )
  59 import Var
  60 import VarEnv
  61 import OrdList
  62 import qualified Subst
  63 import Subst            ( Subst, SubstResult, emptySubst, substInScope, isInScope )
  64 import Type             ( Type, TvSubst, TvSubstEnv, isUnLiftedType )
  65 import UniqSupply       ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
  66                           UniqSupply
  67                         )
  68 import FiniteMap
  69 import BasicTypes       ( TopLevelFlag, isTopLevel, isLoopBreaker,
  70                           Activation, isActive, isAlwaysActive,
  71                           OccInfo(..), isOneOcc
  72                         )
  73 import CmdLineOpts      ( SimplifierSwitch(..), SimplifierMode(..),
  74                           DynFlags, DynFlag(..), dopt,
  75                           opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
  76                         )
  77 import Unique           ( Unique )
  78 import Outputable
  79 import FastTypes
  80 import FastString
  81 import Maybes           ( expectJust )
  82
  83 import GLAEXTS          ( indexArray# )
  84
  85 #if __GLASGOW_HASKELL__ < 503
  86 import PrelArr  ( Array(..) )
  87 #else
  88 import GHC.Arr  ( Array(..) )
  89 #endif
  90
  91 import Array            ( array, (//) )
  92
  93 infixr 0  `thenSmpl`, `thenSmpl_`
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection[Simplify-types]{Type declarations}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 \begin{code}
 103 type InBinder  = CoreBndr
 104 type InId      = Id                     -- Not yet cloned
 105 type InType    = Type                   -- Ditto
 106 type InBind    = CoreBind
 107 type InExpr    = CoreExpr
 108 type InAlt     = CoreAlt
 109 type InArg     = CoreArg
 110
 111 type OutBinder  = CoreBndr
 112 type OutId      = Id                    -- Cloned
 113 type OutTyVar   = TyVar                 -- Cloned
 114 type OutType    = Type                  -- Cloned
 115 type OutBind    = CoreBind
 116 type OutExpr    = CoreExpr
 117 type OutAlt     = CoreAlt
 118 type OutArg     = CoreArg
 119 \end{code}
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsection{Floats}
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 \begin{code}
 128 type FloatsWithExpr = FloatsWith OutExpr
 129 type FloatsWith a   = (Floats, a)
 130         -- We return something equivalent to (let b in e), but
 131         -- in pieces to avoid the quadratic blowup when floating
 132         -- incrementally.  Comments just before simplExprB in Simplify.lhs
 133
 134 data Floats = Floats (OrdList OutBind)
 135                      InScopeSet         -- Environment "inside" all the floats
 136                      Bool               -- True <=> All bindings are lifted
 137
 138 allLifted :: Floats -> Bool
 139 allLifted (Floats _ _ is_lifted) = is_lifted
 140
 141 wrapFloats :: Floats -> OutExpr -> OutExpr
 142 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
 143
 144 isEmptyFloats :: Floats -> Bool
 145 isEmptyFloats (Floats bs _ _) = isNilOL bs
 146
 147 floatBinds :: Floats -> [OutBind]
 148 floatBinds (Floats bs _ _) = fromOL bs
 149
 150 flattenFloats :: Floats -> Floats
 151 -- Flattens into a single Rec group
 152 flattenFloats (Floats bs is is_lifted)
 153   = ASSERT2( is_lifted, ppr (fromOL bs) )
 154     Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
 155 \end{code}
 156
 157 \begin{code}
 158 emptyFloats :: SimplEnv -> Floats
 159 emptyFloats env = Floats nilOL (getInScope env) True
 160
 161 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
 162 -- A single non-rec float; extend the in-scope set
 163 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
 164                                (extendInScopeSet (getInScope env) var)
 165                                (not (isUnLiftedType (idType var)))
 166
 167 addFloats :: SimplEnv -> Floats
 168           -> (SimplEnv -> SimplM (FloatsWith a))
 169           -> SimplM (FloatsWith a)
 170 addFloats env (Floats b1 is1 l1) thing_inside
 171   | isNilOL b1
 172   = thing_inside env
 173   | otherwise
 174   = thing_inside (setInScopeSet env is1)        `thenSmpl` \ (Floats b2 is2 l2, res) ->
 175     returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
 176
 177 addLetBind :: OutBind -> Floats -> Floats
 178 addLetBind bind (Floats binds in_scope lifted)
 179   = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
 180
 181 is_lifted_bind (Rec _)      = True
 182 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
 183
 184 -- addAuxiliaryBind     * takes already-simplified things (bndr and rhs)
 185 --                      * extends the in-scope env
 186 --                      * assumes it's a let-bindable thing
 187 addAuxiliaryBind :: SimplEnv -> OutBind
 188                  -> (SimplEnv -> SimplM (FloatsWith a))
 189                  -> SimplM (FloatsWith a)
 190         -- Extends the in-scope environment as well as wrapping the bindings
 191 addAuxiliaryBind env bind thing_inside
 192   = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
 193     thing_inside (addNewInScopeIds env (bindersOf bind))        `thenSmpl` \ (floats, x) ->
 194     returnSmpl (addLetBind bind floats, x)
 195 \end{code}
 196
 197
 198 %************************************************************************
 199 %*                                                                      *
 200 \subsection{Monad plumbing}
 201 %*                                                                      *
 202 %************************************************************************
 203
 204 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
 205 (Command-line switches move around through the explicitly-passed SimplEnv.)
 206
 207 \begin{code}
 208 type SimplM result
 209   =  DynFlags           -- We thread the unique supply because
 210   -> UniqSupply         -- constantly splitting it is rather expensive
 211   -> SimplCount
 212   -> (result, UniqSupply, SimplCount)
 213 \end{code}
 214
 215 \begin{code}
 216 initSmpl :: DynFlags
 217          -> UniqSupply          -- No init count; set to 0
 218          -> SimplM a
 219          -> (a, SimplCount)
 220
 221 initSmpl dflags us m
 222   = case m dflags us (zeroSimplCount dflags) of
 223         (result, _, count) -> (result, count)
 224
 225
 226 {-# INLINE thenSmpl #-}
 227 {-# INLINE thenSmpl_ #-}
 228 {-# INLINE returnSmpl #-}
 229
 230 returnSmpl :: a -> SimplM a
 231 returnSmpl e dflags us sc = (e, us, sc)
 232
 233 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
 234 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
 235
 236 thenSmpl m k dflags us0 sc0
 237   = case (m dflags us0 sc0) of
 238         (m_result, us1, sc1) -> k m_result dflags us1 sc1
 239
 240 thenSmpl_ m k dflags us0 sc0
 241   = case (m dflags us0 sc0) of
 242         (_, us1, sc1) -> k dflags us1 sc1
 243 \end{code}
 244
 245
 246 \begin{code}
 247 mapSmpl         :: (a -> SimplM b) -> [a] -> SimplM [b]
 248 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
 249
 250 mapSmpl f [] = returnSmpl []
 251 mapSmpl f (x:xs)
 252   = f x             `thenSmpl` \ x'  ->
 253     mapSmpl f xs    `thenSmpl` \ xs' ->
 254     returnSmpl (x':xs')
 255
 256 mapAndUnzipSmpl f [] = returnSmpl ([],[])
 257 mapAndUnzipSmpl f (x:xs)
 258   = f x                     `thenSmpl` \ (r1,  r2)  ->
 259     mapAndUnzipSmpl f xs    `thenSmpl` \ (rs1, rs2) ->
 260     returnSmpl (r1:rs1, r2:rs2)
 261
 262 mapAccumLSmpl f acc []     = returnSmpl (acc, [])
 263 mapAccumLSmpl f acc (x:xs) = f acc x    `thenSmpl` \ (acc', x') ->
 264                              mapAccumLSmpl f acc' xs    `thenSmpl` \ (acc'', xs') ->
 265                              returnSmpl (acc'', x':xs')
 266 \end{code}
 267
 268
 269 %************************************************************************
 270 %*                                                                      *
 271 \subsection{The unique supply}
 272 %*                                                                      *
 273 %************************************************************************
 274
 275 \begin{code}
 276 getUniqSupplySmpl :: SimplM UniqSupply
 277 getUniqSupplySmpl dflags us sc
 278    = case splitUniqSupply us of
 279         (us1, us2) -> (us1, us2, sc)
 280
 281 getUniqueSmpl :: SimplM Unique
 282 getUniqueSmpl dflags us sc
 283    = case splitUniqSupply us of
 284         (us1, us2) -> (uniqFromSupply us1, us2, sc)
 285
 286 getUniquesSmpl :: SimplM [Unique]
 287 getUniquesSmpl dflags us sc
 288    = case splitUniqSupply us of
 289         (us1, us2) -> (uniqsFromSupply us1, us2, sc)
 290
 291 getDOptsSmpl :: SimplM DynFlags
 292 getDOptsSmpl dflags us sc
 293    = (dflags, us, sc)
 294 \end{code}
 295
 296
 297 %************************************************************************
 298 %*                                                                      *
 299 \subsection{Counting up what we've done}
 300 %*                                                                      *
 301 %************************************************************************
 302
 303 \begin{code}
 304 getSimplCount :: SimplM SimplCount
 305 getSimplCount dflags us sc = (sc, us, sc)
 306
 307 tick :: Tick -> SimplM ()
 308 tick t dflags us sc
 309    = sc' `seq` ((), us, sc')
 310      where
 311         sc' = doTick t sc
 312
 313 freeTick :: Tick -> SimplM ()
 314 -- Record a tick, but don't add to the total tick count, which is
 315 -- used to decide when nothing further has happened
 316 freeTick t dflags us sc
 317    = sc' `seq` ((), us, sc')
 318         where
 319            sc' = doFreeTick t sc
 320 \end{code}
 321
 322 \begin{code}
 323 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
 324
 325 zeroSimplCount     :: DynFlags -> SimplCount
 326 isZeroSimplCount   :: SimplCount -> Bool
 327 pprSimplCount      :: SimplCount -> SDoc
 328 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
 329 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 330 \end{code}
 331
 332 \begin{code}
 333 data SimplCount = VerySimplZero         -- These two are used when
 334                 | VerySimplNonZero      -- we are only interested in
 335                                         -- termination info
 336
 337                 | SimplCount    {
 338                         ticks   :: !Int,                -- Total ticks
 339                         details :: !TickCounts,         -- How many of each type
 340                         n_log   :: !Int,                -- N
 341                         log1    :: [Tick],              -- Last N events; <= opt_HistorySize
 342                         log2    :: [Tick]               -- Last opt_HistorySize events before that
 343                   }
 344
 345 type TickCounts = FiniteMap Tick Int
 346
 347 zeroSimplCount dflags
 348                 -- This is where we decide whether to do
 349                 -- the VerySimpl version or the full-stats version
 350   | dopt Opt_D_dump_simpl_stats dflags
 351   = SimplCount {ticks = 0, details = emptyFM,
 352                 n_log = 0, log1 = [], log2 = []}
 353   | otherwise
 354   = VerySimplZero
 355
 356 isZeroSimplCount VerySimplZero              = True
 357 isZeroSimplCount (SimplCount { ticks = 0 }) = True
 358 isZeroSimplCount other                      = False
 359
 360 doFreeTick tick sc@SimplCount { details = dts }
 361   = dts' `seqFM` sc { details = dts' }
 362   where
 363     dts' = dts `addTick` tick
 364 doFreeTick tick sc = sc
 365
 366 -- Gross hack to persuade GHC 3.03 to do this important seq
 367 seqFM fm x | isEmptyFM fm = x
 368            | otherwise    = x
 369
 370 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
 371   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 372   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
 373   where
 374     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 375
 376 doTick tick sc = VerySimplNonZero       -- The very simple case
 377
 378
 379 -- Don't use plusFM_C because that's lazy, and we want to
 380 -- be pretty strict here!
 381 addTick :: TickCounts -> Tick -> TickCounts
 382 addTick fm tick = case lookupFM fm tick of
 383                         Nothing -> addToFM fm tick 1
 384                         Just n  -> n1 `seq` addToFM fm tick n1
 385                                 where
 386                                    n1 = n+1
 387
 388
 389 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 390                sc2@(SimplCount { ticks = tks2, details = dts2 })
 391   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
 392   where
 393         -- A hackish way of getting recent log info
 394     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
 395              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 396              | otherwise       = sc2
 397
 398 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
 399 plusSimplCount sc1           sc2           = VerySimplNonZero
 400
 401 pprSimplCount VerySimplZero    = ptext SLIT("Total ticks: ZERO!")
 402 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
 403 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 404   = vcat [ptext SLIT("Total ticks:    ") <+> int tks,
 405           text "",
 406           pprTickCounts (fmToList dts),
 407           if verboseSimplStats then
 408                 vcat [text "",
 409                       ptext SLIT("Log (most recent first)"),
 410                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 411           else empty
 412     ]
 413
 414 pprTickCounts :: [(Tick,Int)] -> SDoc
 415 pprTickCounts [] = empty
 416 pprTickCounts ((tick1,n1):ticks)
 417   = vcat [int tot_n <+> text (tickString tick1),
 418           pprTCDetails real_these,
 419           pprTickCounts others
 420     ]
 421   where
 422     tick1_tag           = tickToTag tick1
 423     (these, others)     = span same_tick ticks
 424     real_these          = (tick1,n1):these
 425     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
 426     tot_n               = sum [n | (_,n) <- real_these]
 427
 428 pprTCDetails ticks@((tick,_):_)
 429   | verboseSimplStats || isRuleFired tick
 430   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 431   | otherwise
 432   = empty
 433 \end{code}
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsection{Ticks}
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 \begin{code}
 442 data Tick
 443   = PreInlineUnconditionally    Id
 444   | PostInlineUnconditionally   Id
 445
 446   | UnfoldingDone               Id
 447   | RuleFired                   FastString      -- Rule name
 448
 449   | LetFloatFromLet
 450   | EtaExpansion                Id      -- LHS binder
 451   | EtaReduction                Id      -- Binder on outer lambda
 452   | BetaReduction               Id      -- Lambda binder
 453
 454
 455   | CaseOfCase                  Id      -- Bndr on *inner* case
 456   | KnownBranch                 Id      -- Case binder
 457   | CaseMerge                   Id      -- Binder on outer case
 458   | AltMerge                    Id      -- Case binder
 459   | CaseElim                    Id      -- Case binder
 460   | CaseIdentity                Id      -- Case binder
 461   | FillInCaseDefault           Id      -- Case binder
 462
 463   | BottomFound
 464   | SimplifierDone              -- Ticked at each iteration of the simplifier
 465
 466 isRuleFired (RuleFired _) = True
 467 isRuleFired other         = False
 468
 469 instance Outputable Tick where
 470   ppr tick = text (tickString tick) <+> pprTickCts tick
 471
 472 instance Eq Tick where
 473   a == b = case a `cmpTick` b of { EQ -> True; other -> False }
 474
 475 instance Ord Tick where
 476   compare = cmpTick
 477
 478 tickToTag :: Tick -> Int
 479 tickToTag (PreInlineUnconditionally _)  = 0
 480 tickToTag (PostInlineUnconditionally _) = 1
 481 tickToTag (UnfoldingDone _)             = 2
 482 tickToTag (RuleFired _)                 = 3
 483 tickToTag LetFloatFromLet               = 4
 484 tickToTag (EtaExpansion _)              = 5
 485 tickToTag (EtaReduction _)              = 6
 486 tickToTag (BetaReduction _)             = 7
 487 tickToTag (CaseOfCase _)                = 8
 488 tickToTag (KnownBranch _)               = 9
 489 tickToTag (CaseMerge _)                 = 10
 490 tickToTag (CaseElim _)                  = 11
 491 tickToTag (CaseIdentity _)              = 12
 492 tickToTag (FillInCaseDefault _)         = 13
 493 tickToTag BottomFound                   = 14
 494 tickToTag SimplifierDone                = 16
 495 tickToTag (AltMerge _)                  = 17
 496
 497 tickString :: Tick -> String
 498 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
 499 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 500 tickString (UnfoldingDone _)            = "UnfoldingDone"
 501 tickString (RuleFired _)                = "RuleFired"
 502 tickString LetFloatFromLet              = "LetFloatFromLet"
 503 tickString (EtaExpansion _)             = "EtaExpansion"
 504 tickString (EtaReduction _)             = "EtaReduction"
 505 tickString (BetaReduction _)            = "BetaReduction"
 506 tickString (CaseOfCase _)               = "CaseOfCase"
 507 tickString (KnownBranch _)              = "KnownBranch"
 508 tickString (CaseMerge _)                = "CaseMerge"
 509 tickString (AltMerge _)                 = "AltMerge"
 510 tickString (CaseElim _)                 = "CaseElim"
 511 tickString (CaseIdentity _)             = "CaseIdentity"
 512 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
 513 tickString BottomFound                  = "BottomFound"
 514 tickString SimplifierDone               = "SimplifierDone"
 515
 516 pprTickCts :: Tick -> SDoc
 517 pprTickCts (PreInlineUnconditionally v) = ppr v
 518 pprTickCts (PostInlineUnconditionally v)= ppr v
 519 pprTickCts (UnfoldingDone v)            = ppr v
 520 pprTickCts (RuleFired v)                = ppr v
 521 pprTickCts LetFloatFromLet              = empty
 522 pprTickCts (EtaExpansion v)             = ppr v
 523 pprTickCts (EtaReduction v)             = ppr v
 524 pprTickCts (BetaReduction v)            = ppr v
 525 pprTickCts (CaseOfCase v)               = ppr v
 526 pprTickCts (KnownBranch v)              = ppr v
 527 pprTickCts (CaseMerge v)                = ppr v
 528 pprTickCts (AltMerge v)                 = ppr v
 529 pprTickCts (CaseElim v)                 = ppr v
 530 pprTickCts (CaseIdentity v)             = ppr v
 531 pprTickCts (FillInCaseDefault v)        = ppr v
 532 pprTickCts other                        = empty
 533
 534 cmpTick :: Tick -> Tick -> Ordering
 535 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 536                 GT -> GT
 537                 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
 538                    | otherwise                          -> EQ
 539                 LT -> LT
 540         -- Always distinguish RuleFired, so that the stats
 541         -- can report them even in non-verbose mode
 542
 543 cmpEqTick :: Tick -> Tick -> Ordering
 544 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
 545 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
 546 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
 547 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
 548 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
 549 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
 550 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
 551 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
 552 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
 553 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
 554 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
 555 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
 556 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 557 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 558 cmpEqTick other1                        other2                          = EQ
 559 \end{code}
 560
 561
 562
 563 %************************************************************************
 564 %*                                                                      *
 565 \subsubsection{The @SimplEnv@ type}
 566 %*                                                                      *
 567 %************************************************************************
 568
 569
 570 \begin{code}
 571 data SimplEnv
 572   = SimplEnv {
 573         seMode      :: SimplifierMode,
 574         seChkr      :: SwitchChecker,
 575         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 576         seSubst     :: Subst            -- The current substitution
 577     }
 578         -- The range of the substitution is OutType and OutExpr resp
 579         --
 580         -- The substitution is idempotent
 581         -- It *must* be applied; things in its domain simply aren't
 582         -- bound in the result.
 583         --
 584         -- The substitution usually maps an Id to its clone,
 585         -- but if the orig defn is a let-binding, and
 586         -- the RHS of the let simplifies to an atom,
 587         -- we just add the binding to the substitution and elide the let.
 588
 589         -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
 590         -- The elements of the set may have better IdInfo than the
 591         -- occurrences of in-scope Ids, and (more important) they will
 592         -- have a correctly-substituted type.  So we use a lookup in this
 593         -- set to replace occurrences
 594
 595 emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> SimplEnv
 596 emptySimplEnv mode switches
 597   = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS,
 598                seMode = mode, seSubst = emptySubst }
 599         -- The top level "enclosing CC" is "SUBSUMED".
 600
 601 ---------------------
 602 getSwitchChecker :: SimplEnv -> SwitchChecker
 603 getSwitchChecker env = seChkr env
 604
 605 ---------------------
 606 getMode :: SimplEnv -> SimplifierMode
 607 getMode env = seMode env
 608
 609 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
 610 setMode mode env = env { seMode = mode }
 611
 612 ---------------------
 613 getEnclosingCC :: SimplEnv -> CostCentreStack
 614 getEnclosingCC env = seCC env
 615
 616 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
 617 setEnclosingCC env cc = env {seCC = cc}
 618
 619 ---------------------
 620 getSubst :: SimplEnv -> Subst
 621 getSubst env = seSubst env
 622
 623 getTvSubst :: SimplEnv -> TvSubst
 624 getTvSubst env = Subst.getTvSubst (seSubst env)
 625
 626 setTvSubstEnv :: SimplEnv -> TvSubstEnv -> SimplEnv
 627 setTvSubstEnv env@(SimplEnv {seSubst = subst}) tv_subst_env
 628   = env {seSubst = Subst.setTvSubstEnv subst tv_subst_env}
 629
 630 setSubst :: SimplEnv -> Subst -> SimplEnv
 631 setSubst env subst = env {seSubst = subst}
 632
 633 extendIdSubst :: SimplEnv -> Id -> SubstResult -> SimplEnv
 634 extendIdSubst env@(SimplEnv {seSubst = subst}) var res
 635   = env {seSubst = Subst.extendIdSubst subst var res}
 636
 637 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 638 extendTvSubst env@(SimplEnv {seSubst = subst}) var res
 639   = env {seSubst = Subst.extendTvSubst subst var res}
 640
 641 ---------------------
 642 getInScope :: SimplEnv -> InScopeSet
 643 getInScope env = substInScope (seSubst env)
 644
 645 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
 646 setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
 647
 648 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 649 setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
 650   = env {seSubst = Subst.setInScopeSet subst in_scope}
 651
 652 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
 653         -- The new Ids are guaranteed to be freshly allocated
 654 addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
 655   = env {seSubst = Subst.extendInScopeIds subst vs}
 656
 657 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
 658 modifyInScope env@(SimplEnv {seSubst = subst}) v v'
 659   = env {seSubst = Subst.modifyInScope subst v v'}
 660
 661 ---------------------
 662 zapSubstEnv :: SimplEnv -> SimplEnv
 663 zapSubstEnv env@(SimplEnv {seSubst = subst})
 664   = env {seSubst = Subst.zapSubstEnv subst}
 665
 666 setSubstEnv :: SimplEnv -> Subst -> SimplEnv
 667 setSubstEnv env@(SimplEnv {seSubst = subst}) subst_with_env
 668   = env {seSubst = Subst.setSubstEnv subst subst_with_env}
 669 \end{code}
 670
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsection{Decisions about inlining}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 Inlining is controlled partly by the SimplifierMode switch.  This has two
 679 settings:
 680
 681         SimplGently     (a) Simplifying before specialiser/full laziness
 682                         (b) Simplifiying inside INLINE pragma
 683                         (c) Simplifying the LHS of a rule
 684                         (d) Simplifying a GHCi expression or Template
 685                                 Haskell splice
 686
 687         SimplPhase n    Used at all other times
 688
 689 The key thing about SimplGently is that it does no call-site inlining.
 690 Before full laziness we must be careful not to inline wrappers,
 691 because doing so inhibits floating
 692     e.g. ...(case f x of ...)...
 693     ==> ...(case (case x of I# x# -> fw x#) of ...)...
 694     ==> ...(case x of I# x# -> case fw x# of ...)...
 695 and now the redex (f x) isn't floatable any more.
 696
 697 The no-inling thing is also important for Template Haskell.  You might be
 698 compiling in one-shot mode with -O2; but when TH compiles a splice before
 699 running it, we don't want to use -O2.  Indeed, we don't want to inline
 700 anything, because the byte-code interpreter might get confused about
 701 unboxed tuples and suchlike.
 702
 703 INLINE pragmas
 704 ~~~~~~~~~~~~~~
 705 SimplGently is also used as the mode to simplify inside an InlineMe note.
 706
 707 \begin{code}
 708 inlineMode :: SimplifierMode
 709 inlineMode = SimplGently
 710 \end{code}
 711
 712 It really is important to switch off inlinings inside such
 713 expressions.  Consider the following example
 714
 715         let f = \pq -> BIG
 716         in
 717         let g = \y -> f y y
 718             {-# INLINE g #-}
 719         in ...g...g...g...g...g...
 720
 721 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 722 and thence copied multiple times when g is inlined.
 723
 724
 725 This function may be inlinined in other modules, so we
 726 don't want to remove (by inlining) calls to functions that have
 727 specialisations, or that may have transformation rules in an importing
 728 scope.
 729
 730 E.g.    {-# INLINE f #-}
 731                 f x = ...g...
 732
 733 and suppose that g is strict *and* has specialisations.  If we inline
 734 g's wrapper, we deny f the chance of getting the specialised version
 735 of g when f is inlined at some call site (perhaps in some other
 736 module).
 737
 738 It's also important not to inline a worker back into a wrapper.
 739 A wrapper looks like
 740         wraper = inline_me (\x -> ...worker... )
 741 Normally, the inline_me prevents the worker getting inlined into
 742 the wrapper (initially, the worker's only call site!).  But,
 743 if the wrapper is sure to be called, the strictness analyser will
 744 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
 745 continuation.  That's why the keep_inline predicate returns True for
 746 ArgOf continuations.  It shouldn't do any harm not to dissolve the
 747 inline-me note under these circumstances.
 748
 749 Note that the result is that we do very little simplification
 750 inside an InlineMe.
 751
 752         all xs = foldr (&&) True xs
 753         any p = all . map p  {-# INLINE any #-}
 754
 755 Problem: any won't get deforested, and so if it's exported and the
 756 importer doesn't use the inlining, (eg passes it as an arg) then we
 757 won't get deforestation at all.  We havn't solved this problem yet!
 758
 759
 760 preInlineUnconditionally
 761 ~~~~~~~~~~~~~~~~~~~~~~~~
 762 @preInlineUnconditionally@ examines a bndr to see if it is used just
 763 once in a completely safe way, so that it is safe to discard the
 764 binding inline its RHS at the (unique) usage site, REGARDLESS of how
 765 big the RHS might be.  If this is the case we don't simplify the RHS
 766 first, but just inline it un-simplified.
 767
 768 This is much better than first simplifying a perhaps-huge RHS and then
 769 inlining and re-simplifying it.  Indeed, it can be at least quadratically
 770 better.  Consider
 771
 772         x1 = e1
 773         x2 = e2[x1]
 774         x3 = e3[x2]
 775         ...etc...
 776         xN = eN[xN-1]
 777
 778 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
 779
 780 NB: we don't even look at the RHS to see if it's trivial
 781 We might have
 782                         x = y
 783 where x is used many times, but this is the unique occurrence of y.
 784 We should NOT inline x at all its uses, because then we'd do the same
 785 for y -- aargh!  So we must base this pre-rhs-simplification decision
 786 solely on x's occurrences, not on its rhs.
 787
 788 Evne RHSs labelled InlineMe aren't caught here, because there might be
 789 no benefit from inlining at the call site.
 790
 791 [Sept 01] Don't unconditionally inline a top-level thing, because that
 792 can simply make a static thing into something built dynamically.  E.g.
 793         x = (a,b)
 794         main = \s -> h x
 795
 796 [Remember that we treat \s as a one-shot lambda.]  No point in
 797 inlining x unless there is something interesting about the call site.
 798
 799 But watch out: if you aren't careful, some useful foldr/build fusion
 800 can be lost (most notably in spectral/hartel/parstof) because the
 801 foldr didn't see the build.  Doing the dynamic allocation isn't a big
 802 deal, in fact, but losing the fusion can be.  But the right thing here
 803 seems to be to do a callSiteInline based on the fact that there is
 804 something interesting about the call site (it's strict).  Hmm.  That
 805 seems a bit fragile.
 806
 807 Conclusion: inline top level things gaily until Phase 0 (the last
 808 phase), at which point don't.
 809
 810 \begin{code}
 811 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
 812 preInlineUnconditionally env top_lvl bndr
 813   | isTopLevel top_lvl, SimplPhase 0 <- phase = False
 814 -- If we don't have this test, consider
 815 --      x = length [1,2,3]
 816 -- The full laziness pass carefully floats all the cons cells to
 817 -- top level, and preInlineUnconditionally floats them all back in.
 818 -- Result is (a) static allocation replaced by dynamic allocation
 819 --           (b) many simplifier iterations because this tickles
 820 --               a related problem; only one inlining per pass
 821 --
 822 -- On the other hand, I have seen cases where top-level fusion is
 823 -- lost if we don't inline top level thing (e.g. string constants)
 824 -- Hence the test for phase zero (which is the phase for all the final
 825 -- simplifications).  Until phase zero we take no special notice of
 826 -- top level things, but then we become more leery about inlining
 827 -- them.
 828
 829   | not active             = False
 830   | opt_SimplNoPreInlining = False
 831   | otherwise = case idOccInfo bndr of
 832                   IAmDead            -> True    -- Happens in ((\x.1) v)
 833                   OneOcc in_lam once -> not in_lam && once
 834                         -- Not inside a lambda, one occurrence ==> safe!
 835                   other              -> False
 836   where
 837     phase = getMode env
 838     active = case phase of
 839                    SimplGently  -> isAlwaysActive prag
 840                    SimplPhase n -> isActive n prag
 841     prag = idInlinePragma bndr
 842 \end{code}
 843
 844 postInlineUnconditionally
 845 ~~~~~~~~~~~~~~~~~~~~~~~~~
 846 @postInlineUnconditionally@ decides whether to unconditionally inline
 847 a thing based on the form of its RHS; in particular if it has a
 848 trivial RHS.  If so, we can inline and discard the binding altogether.
 849
 850 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
 851 only have *forward* references Hence, it's safe to discard the binding
 852
 853 NOTE: This isn't our last opportunity to inline.  We're at the binding
 854 site right now, and we'll get another opportunity when we get to the
 855 ocurrence(s)
 856
 857 Note that we do this unconditional inlining only for trival RHSs.
 858 Don't inline even WHNFs inside lambdas; doing so may simply increase
 859 allocation when the function is called. This isn't the last chance; see
 860 NOTE above.
 861
 862 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
 863 Because we don't even want to inline them into the RHS of constructor
 864 arguments. See NOTE above
 865
 866 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
 867 it's best to inline it anyway.  We often get a=E; b=a from desugaring,
 868 with both a and b marked NOINLINE.  But that seems incompatible with
 869 our new view that inlining is like a RULE, so I'm sticking to the 'active'
 870 story for now.
 871
 872 \begin{code}
 873 postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
 874 postInlineUnconditionally env bndr occ_info rhs
 875   =  exprIsTrivial rhs
 876   && active
 877   && not (isLoopBreaker occ_info)
 878   && not (isExportedId bndr)
 879         -- We used to have (isOneOcc occ_info) instead of
 880         -- not (isLoopBreaker occ_info) && not (isExportedId bndr)
 881         -- That was because a rather fragile use of rules got confused
 882         -- if you inlined even a binding f=g  e.g. We used to have
 883         --      map = mapList
 884         -- But now a more precise use of phases has eliminated this problem,
 885         -- so the is_active test will do the job.  I think.
 886         --
 887         -- OLD COMMENT: (delete soon)
 888         -- Indeed, you might suppose that
 889         -- there is nothing wrong with substituting for a trivial RHS, even
 890         -- if it occurs many times.  But consider
 891         --      x = y
 892         --      h = _inline_me_ (...x...)
 893         -- Here we do *not* want to have x inlined, even though the RHS is
 894         -- trivial, becuase the contract for an INLINE pragma is "no inlining".
 895         -- This is important in the rules for the Prelude
 896   where
 897     active = case getMode env of
 898                    SimplGently  -> isAlwaysActive prag
 899                    SimplPhase n -> isActive n prag
 900     prag = idInlinePragma bndr
 901
 902 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
 903 activeInline env id occ
 904   = case getMode env of
 905       SimplGently -> isOneOcc occ && isAlwaysActive prag
 906         -- No inlining at all when doing gentle stuff,
 907         -- except for local things that occur once
 908         -- The reason is that too little clean-up happens if you
 909         -- don't inline use-once things.   Also a bit of inlining is *good* for
 910         -- full laziness; it can expose constant sub-expressions.
 911         -- Example in spectral/mandel/Mandel.hs, where the mandelset
 912         -- function gets a useful let-float if you inline windowToViewport
 913
 914         -- NB: we used to have a second exception, for data con wrappers.
 915         -- On the grounds that we use gentle mode for rule LHSs, and
 916         -- they match better when data con wrappers are inlined.
 917         -- But that only really applies to the trivial wrappers (like (:)),
 918         -- and they are now constructed as Compulsory unfoldings (in MkId)
 919         -- so they'll happen anyway.
 920
 921       SimplPhase n -> isActive n prag
 922   where
 923     prag = idInlinePragma id
 924
 925 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
 926 -- Nothing => No rules at all
 927 activeRule env
 928   | opt_RulesOff = Nothing
 929   | otherwise
 930   = case getMode env of
 931         SimplGently  -> Just isAlwaysActive
 932                         -- Used to be Nothing (no rules in gentle mode)
 933                         -- Main motivation for changing is that I wanted
 934                         --      lift String ===> ...
 935                         -- to work in Template Haskell when simplifying
 936                         -- splices, so we get simpler code for literal strings
 937         SimplPhase n -> Just (isActive n)
 938 \end{code}
 939
 940
 941 %************************************************************************
 942 %*                                                                      *
 943 \subsubsection{Command-line switches}
 944 %*                                                                      *
 945 %************************************************************************
 946
 947 \begin{code}
 948 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 949 getSimplIntSwitch chkr switch
 950   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 951
 952 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 953
 954 switchIsOn lookup_fn switch
 955   = case (lookup_fn switch) of
 956       SwBool False -> False
 957       _            -> True
 958
 959 intSwitchSet :: (switch -> SwitchResult)
 960              -> (Int -> switch)
 961              -> Maybe Int
 962
 963 intSwitchSet lookup_fn switch
 964   = case (lookup_fn (switch (panic "intSwitchSet"))) of
 965       SwInt int -> Just int
 966       _         -> Nothing
 967 \end{code}
 968
 969
 970 \begin{code}
 971 type SwitchChecker = SimplifierSwitch -> SwitchResult
 972
 973 data SwitchResult
 974   = SwBool      Bool            -- on/off
 975   | SwString    FastString      -- nothing or a String
 976   | SwInt       Int             -- nothing or an Int
 977
 978 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 979 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
 980                                         -- in the list; defaults right at the end.
 981   = let
 982         tidied_on_switches = foldl rm_dups [] on_switches
 983                 -- The fold*l* ensures that we keep the latest switches;
 984                 -- ie the ones that occur earliest in the list.
 985
 986         sw_tbl :: Array Int SwitchResult
 987         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
 988                         all_undefined)
 989                  // defined_elems
 990
 991         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
 992
 993         defined_elems = map mk_assoc_elem tidied_on_switches
 994     in
 995     -- (avoid some unboxing, bounds checking, and other horrible things:)
 996     case sw_tbl of { Array _ _ stuff ->
 997     \ switch ->
 998         case (indexArray# stuff (tagOf_SimplSwitch switch)) of
 999           (# v #) -> v
1000     }
1001   where
1002     mk_assoc_elem k@(MaxSimplifierIterations lvl)
1003         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
1004     mk_assoc_elem k
1005         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
1006
1007     -- cannot have duplicates if we are going to use the array thing
1008     rm_dups switches_so_far switch
1009       = if switch `is_elem` switches_so_far
1010         then switches_so_far
1011         else switch : switches_so_far
1012       where
1013         sw `is_elem` []     = False
1014         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
1015                             || sw `is_elem` ss
1016 \end{code}
1017
1018 These things behave just like enumeration types.
1019
1020 \begin{code}
1021 instance Eq SimplifierSwitch where
1022     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
1023
1024 instance Ord SimplifierSwitch where
1025     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
1026     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
1027
1028
1029 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
1030 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
1031
1032 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
1033
1034 lAST_SIMPL_SWITCH_TAG = 2
1035 \end{code}
1036