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