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