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