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
 686         SimplPhase n    Used at all other times
 687
 688 The key thing about SimplGently is that it does no call-site inlining.
 689 Before full laziness we must be careful not to inline wrappers,
 690 because doing so inhibits floating
 691     e.g. ...(case f x of ...)...
 692     ==> ...(case (case x of I# x# -> fw x#) of ...)...
 693     ==> ...(case x of I# x# -> case fw x# of ...)...
 694 and now the redex (f x) isn't floatable any more.
 695
 696 INLINE pragmas
 697 ~~~~~~~~~~~~~~
 698 SimplGently is also used as the mode to simplify inside an InlineMe note.
 699
 700 \begin{code}
 701 inlineMode :: SimplifierMode
 702 inlineMode = SimplGently
 703 \end{code}
 704
 705 It really is important to switch off inlinings inside such
 706 expressions.  Consider the following example
 707
 708         let f = \pq -> BIG
 709         in
 710         let g = \y -> f y y
 711             {-# INLINE g #-}
 712         in ...g...g...g...g...g...
 713
 714 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
 715 and thence copied multiple times when g is inlined.
 716
 717
 718 This function may be inlinined in other modules, so we
 719 don't want to remove (by inlining) calls to functions that have
 720 specialisations, or that may have transformation rules in an importing
 721 scope.
 722
 723 E.g.    {-# INLINE f #-}
 724                 f x = ...g...
 725
 726 and suppose that g is strict *and* has specialisations.  If we inline
 727 g's wrapper, we deny f the chance of getting the specialised version
 728 of g when f is inlined at some call site (perhaps in some other
 729 module).
 730
 731 It's also important not to inline a worker back into a wrapper.
 732 A wrapper looks like
 733         wraper = inline_me (\x -> ...worker... )
 734 Normally, the inline_me prevents the worker getting inlined into
 735 the wrapper (initially, the worker's only call site!).  But,
 736 if the wrapper is sure to be called, the strictness analyser will
 737 mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
 738 continuation.  That's why the keep_inline predicate returns True for
 739 ArgOf continuations.  It shouldn't do any harm not to dissolve the
 740 inline-me note under these circumstances.
 741
 742 Note that the result is that we do very little simplification
 743 inside an InlineMe.
 744
 745         all xs = foldr (&&) True xs
 746         any p = all . map p  {-# INLINE any #-}
 747
 748 Problem: any won't get deforested, and so if it's exported and the
 749 importer doesn't use the inlining, (eg passes it as an arg) then we
 750 won't get deforestation at all.  We havn't solved this problem yet!
 751
 752
 753 preInlineUnconditionally
 754 ~~~~~~~~~~~~~~~~~~~~~~~~
 755 @preInlineUnconditionally@ examines a bndr to see if it is used just
 756 once in a completely safe way, so that it is safe to discard the
 757 binding inline its RHS at the (unique) usage site, REGARDLESS of how
 758 big the RHS might be.  If this is the case we don't simplify the RHS
 759 first, but just inline it un-simplified.
 760
 761 This is much better than first simplifying a perhaps-huge RHS and then
 762 inlining and re-simplifying it.  Indeed, it can be at least quadratically
 763 better.  Consider
 764
 765         x1 = e1
 766         x2 = e2[x1]
 767         x3 = e3[x2]
 768         ...etc...
 769         xN = eN[xN-1]
 770
 771 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
 772
 773 NB: we don't even look at the RHS to see if it's trivial
 774 We might have
 775                         x = y
 776 where x is used many times, but this is the unique occurrence of y.
 777 We should NOT inline x at all its uses, because then we'd do the same
 778 for y -- aargh!  So we must base this pre-rhs-simplification decision
 779 solely on x's occurrences, not on its rhs.
 780
 781 Evne RHSs labelled InlineMe aren't caught here, because there might be
 782 no benefit from inlining at the call site.
 783
 784 [Sept 01] Don't unconditionally inline a top-level thing, because that
 785 can simply make a static thing into something built dynamically.  E.g.
 786         x = (a,b)
 787         main = \s -> h x
 788
 789 [Remember that we treat \s as a one-shot lambda.]  No point in
 790 inlining x unless there is something interesting about the call site.
 791
 792 But watch out: if you aren't careful, some useful foldr/build fusion
 793 can be lost (most notably in spectral/hartel/parstof) because the
 794 foldr didn't see the build.  Doing the dynamic allocation isn't a big
 795 deal, in fact, but losing the fusion can be.  But the right thing here
 796 seems to be to do a callSiteInline based on the fact that there is
 797 something interesting about the call site (it's strict).  Hmm.  That
 798 seems a bit fragile.
 799
 800 Conclusion: inline top level things gaily until Phase 0 (the last
 801 phase), at which point don't.
 802
 803 \begin{code}
 804 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
 805 preInlineUnconditionally env top_lvl bndr
 806   | isTopLevel top_lvl, SimplPhase 0 <- phase = False
 807 -- If we don't have this test, consider
 808 --      x = length [1,2,3]
 809 -- The full laziness pass carefully floats all the cons cells to
 810 -- top level, and preInlineUnconditionally floats them all back in.
 811 -- Result is (a) static allocation replaced by dynamic allocation
 812 --           (b) many simplifier iterations because this tickles
 813 --               a related problem; only one inlining per pass
 814 --
 815 -- On the other hand, I have seen cases where top-level fusion is
 816 -- lost if we don't inline top level thing (e.g. string constants)
 817 -- Hence the test for phase zero (which is the phase for all the final
 818 -- simplifications).  Until phase zero we take no special notice of
 819 -- top level things, but then we become more leery about inlining
 820 -- them.
 821
 822   | not active             = False
 823   | opt_SimplNoPreInlining = False
 824   | otherwise = case idOccInfo bndr of
 825                   IAmDead            -> True    -- Happens in ((\x.1) v)
 826                   OneOcc in_lam once -> not in_lam && once
 827                         -- Not inside a lambda, one occurrence ==> safe!
 828                   other              -> False
 829   where
 830     phase = getMode env
 831     active = case phase of
 832                    SimplGently  -> isAlwaysActive prag
 833                    SimplPhase n -> isActive n prag
 834     prag = idInlinePragma bndr
 835 \end{code}
 836
 837 postInlineUnconditionally
 838 ~~~~~~~~~~~~~~~~~~~~~~~~~
 839 @postInlineUnconditionally@ decides whether to unconditionally inline
 840 a thing based on the form of its RHS; in particular if it has a
 841 trivial RHS.  If so, we can inline and discard the binding altogether.
 842
 843 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
 844 only have *forward* references Hence, it's safe to discard the binding
 845
 846 NOTE: This isn't our last opportunity to inline.  We're at the binding
 847 site right now, and we'll get another opportunity when we get to the
 848 ocurrence(s)
 849
 850 Note that we do this unconditional inlining only for trival RHSs.
 851 Don't inline even WHNFs inside lambdas; doing so may simply increase
 852 allocation when the function is called. This isn't the last chance; see
 853 NOTE above.
 854
 855 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
 856 Because we don't even want to inline them into the RHS of constructor
 857 arguments. See NOTE above
 858
 859 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
 860 it's best to inline it anyway.  We often get a=E; b=a from desugaring,
 861 with both a and b marked NOINLINE.  But that seems incompatible with
 862 our new view that inlining is like a RULE, so I'm sticking to the 'active'
 863 story for now.
 864
 865 \begin{code}
 866 postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
 867 postInlineUnconditionally env bndr occ_info rhs
 868   =  exprIsTrivial rhs
 869   && active
 870   && not (isLoopBreaker occ_info)
 871   && not (isExportedId bndr)
 872         -- We used to have (isOneOcc occ_info) instead of
 873         -- not (isLoopBreaker occ_info) && not (isExportedId bndr)
 874         -- That was because a rather fragile use of rules got confused
 875         -- if you inlined even a binding f=g  e.g. We used to have
 876         --      map = mapList
 877         -- But now a more precise use of phases has eliminated this problem,
 878         -- so the is_active test will do the job.  I think.
 879         --
 880         -- OLD COMMENT: (delete soon)
 881         -- Indeed, you might suppose that
 882         -- there is nothing wrong with substituting for a trivial RHS, even
 883         -- if it occurs many times.  But consider
 884         --      x = y
 885         --      h = _inline_me_ (...x...)
 886         -- Here we do *not* want to have x inlined, even though the RHS is
 887         -- trivial, becuase the contract for an INLINE pragma is "no inlining".
 888         -- This is important in the rules for the Prelude
 889   where
 890     active = case getMode env of
 891                    SimplGently  -> isAlwaysActive prag
 892                    SimplPhase n -> isActive n prag
 893     prag = idInlinePragma bndr
 894 \end{code}
 895
 896 blackListInline tells if we must not inline at a call site because the
 897 Id's inline pragma says not to do so.
 898
 899 However, blackListInline is ignored for things with with Compulsory inlinings,
 900 because they don't have bindings, so we must inline them no matter how
 901 gentle we are being.
 902
 903 \begin{code}
 904 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
 905 activeInline env id occ
 906   = case getMode env of
 907       SimplGently -> isAlwaysActive prag && isOneOcc occ
 908         -- No inlining at all when doing gentle stuff,
 909         -- except for things that occur once
 910         -- The reason is that too little clean-up happens if you
 911         -- don't inline use-once things.   Also a bit of inlining is *good* for
 912         -- full laziness; it can expose constant sub-expressions.
 913         -- Example in spectral/mandel/Mandel.hs, where the mandelset
 914         -- function gets a useful let-float if you inline windowToViewport
 915
 916         -- NB: we used to have a second exception, for data con wrappers.
 917         -- On the grounds that we use gentle mode for rule LHSs, and
 918         -- they match better when data con wrappers are inlined.
 919         -- But that only really applies to the trivial wrappers (like (:)),
 920         -- and they are now constructed as Compulsory unfoldings (in MkId)
 921         -- so they'll happen anyway.
 922
 923       SimplPhase n -> isActive n prag
 924   where
 925     prag = idInlinePragma id
 926
 927 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
 928 -- Nothing => No rules at all
 929 activeRule env
 930   = case getMode env of
 931         SimplGently  -> Nothing         -- No rules in gentle mode
 932         SimplPhase n -> Just (isActive n)
 933 \end{code}
 934
 935
 936 %************************************************************************
 937 %*                                                                      *
 938 \subsubsection{Command-line switches}
 939 %*                                                                      *
 940 %************************************************************************
 941
 942 \begin{code}
 943 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 944 getSimplIntSwitch chkr switch
 945   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 946
 947 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 948
 949 switchIsOn lookup_fn switch
 950   = case (lookup_fn switch) of
 951       SwBool False -> False
 952       _            -> True
 953
 954 intSwitchSet :: (switch -> SwitchResult)
 955              -> (Int -> switch)
 956              -> Maybe Int
 957
 958 intSwitchSet lookup_fn switch
 959   = case (lookup_fn (switch (panic "intSwitchSet"))) of
 960       SwInt int -> Just int
 961       _         -> Nothing
 962 \end{code}
 963
 964
 965 \begin{code}
 966 type SwitchChecker = SimplifierSwitch -> SwitchResult
 967
 968 data SwitchResult
 969   = SwBool      Bool            -- on/off
 970   | SwString    FastString      -- nothing or a String
 971   | SwInt       Int             -- nothing or an Int
 972
 973 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 974 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
 975                                         -- in the list; defaults right at the end.
 976   = let
 977         tidied_on_switches = foldl rm_dups [] on_switches
 978                 -- The fold*l* ensures that we keep the latest switches;
 979                 -- ie the ones that occur earliest in the list.
 980
 981         sw_tbl :: Array Int SwitchResult
 982         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
 983                         all_undefined)
 984                  // defined_elems
 985
 986         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
 987
 988         defined_elems = map mk_assoc_elem tidied_on_switches
 989     in
 990     -- (avoid some unboxing, bounds checking, and other horrible things:)
 991     case sw_tbl of { Array _ _ stuff ->
 992     \ switch ->
 993         case (indexArray# stuff (tagOf_SimplSwitch switch)) of
 994           (# v #) -> v
 995     }
 996   where
 997     mk_assoc_elem k@(MaxSimplifierIterations lvl)
 998         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
 999     mk_assoc_elem k
1000         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
1001
1002     -- cannot have duplicates if we are going to use the array thing
1003     rm_dups switches_so_far switch
1004       = if switch `is_elem` switches_so_far
1005         then switches_so_far
1006         else switch : switches_so_far
1007       where
1008         sw `is_elem` []     = False
1009         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
1010                             || sw `is_elem` ss
1011 \end{code}
1012
1013 These things behave just like enumeration types.
1014
1015 \begin{code}
1016 instance Eq SimplifierSwitch where
1017     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
1018
1019 instance Ord SimplifierSwitch where
1020     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
1021     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
1022
1023
1024 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
1025 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
1026
1027 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
1028
1029 lAST_SIMPL_SWITCH_TAG = 2
1030 \end{code}
1031