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