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.  Indeed, it can be at least quadratically
 760 better.  Consider
 761
 762         x1 = e1
 763         x2 = e2[x1]
 764         x3 = e3[x2]
 765         ...etc...
 766         xN = eN[xN-1]
 767
 768 We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
 769
 770 NB: we don't even look at the RHS to see if it's trivial
 771 We might have
 772                         x = y
 773 where x is used many times, but this is the unique occurrence of y.
 774 We should NOT inline x at all its uses, because then we'd do the same
 775 for y -- aargh!  So we must base this pre-rhs-simplification decision
 776 solely on x's occurrences, not on its rhs.
 777
 778 Evne RHSs labelled InlineMe aren't caught here, because there might be
 779 no benefit from inlining at the call site.
 780
 781 [Sept 01] Don't unconditionally inline a top-level thing, because that
 782 can simply make a static thing into something built dynamically.  E.g.
 783         x = (a,b)
 784         main = \s -> h x
 785
 786 [Remember that we treat \s as a one-shot lambda.]  No point in
 787 inlining x unless there is something interesting about the call site.
 788
 789 But watch out: if you aren't careful, some useful foldr/build fusion
 790 can be lost (most notably in spectral/hartel/parstof) because the
 791 foldr didn't see the build.  Doing the dynamic allocation isn't a big
 792 deal, in fact, but losing the fusion can be.  But the right thing here
 793 seems to be to do a callSiteInline based on the fact that there is
 794 something interesting about the call site (it's strict).  Hmm.  That
 795 seems a bit fragile.
 796
 797 Conclusion: inline top level things gaily until Phase 0 (the last
 798 phase), at which point don't.
 799
 800 \begin{code}
 801 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
 802 preInlineUnconditionally env top_lvl bndr
 803   | isTopLevel top_lvl, SimplPhase 0 <- phase = False
 804 -- If we don't have this test, consider
 805 --      x = length [1,2,3]
 806 -- The full laziness pass carefully floats all the cons cells to
 807 -- top level, and preInlineUnconditionally floats them all back in.
 808 -- Result is (a) static allocation replaced by dynamic allocation
 809 --           (b) many simplifier iterations because this tickles
 810 --               a related problem; only one inlining per pass
 811 --
 812 -- On the other hand, I have seen cases where top-level fusion is
 813 -- lost if we don't inline top level thing (e.g. string constants)
 814 -- Hence the test for phase zero (which is the phase for all the final
 815 -- simplifications).  Until phase zero we take no special notice of
 816 -- top level things, but then we become more leery about inlining
 817 -- them.
 818
 819   | not active             = False
 820   | opt_SimplNoPreInlining = False
 821   | otherwise = case idOccInfo bndr of
 822                   IAmDead            -> True    -- Happens in ((\x.1) v)
 823                   OneOcc in_lam once -> not in_lam && once
 824                         -- Not inside a lambda, one occurrence ==> safe!
 825                   other              -> False
 826   where
 827     phase = getMode env
 828     active = case phase of
 829                    SimplGently  -> isAlwaysActive prag
 830                    SimplPhase n -> isActive n prag
 831     prag = idInlinePragma bndr
 832 \end{code}
 833
 834 postInlineUnconditionally
 835 ~~~~~~~~~~~~~~~~~~~~~~~~~
 836 @postInlineUnconditionally@ decides whether to unconditionally inline
 837 a thing based on the form of its RHS; in particular if it has a
 838 trivial RHS.  If so, we can inline and discard the binding altogether.
 839
 840 NB: a loop breaker has must_keep_binding = True and non-loop-breakers
 841 only have *forward* references Hence, it's safe to discard the binding
 842
 843 NOTE: This isn't our last opportunity to inline.  We're at the binding
 844 site right now, and we'll get another opportunity when we get to the
 845 ocurrence(s)
 846
 847 Note that we do this unconditional inlining only for trival RHSs.
 848 Don't inline even WHNFs inside lambdas; doing so may simply increase
 849 allocation when the function is called. This isn't the last chance; see
 850 NOTE above.
 851
 852 NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
 853 Because we don't even want to inline them into the RHS of constructor
 854 arguments. See NOTE above
 855
 856 NB: At one time even NOINLINE was ignored here: if the rhs is trivial
 857 it's best to inline it anyway.  We often get a=E; b=a from desugaring,
 858 with both a and b marked NOINLINE.  But that seems incompatible with
 859 our new view that inlining is like a RULE, so I'm sticking to the 'active'
 860 story for now.
 861
 862 \begin{code}
 863 postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
 864 postInlineUnconditionally env bndr occ_info rhs
 865   =  exprIsTrivial rhs && active && isOneOcc occ_info
 866         -- We used to have (not loop_breaker && not (isExportedId bndr))
 867         -- instead of (isOneOcc occ_info).  Indeed, you might suppose that
 868         -- there is nothing wrong with substituting for a trivial RHS, even
 869         -- if it occurs many times.  But consider
 870         --      x = y
 871         --      h = _inline_me_ (...x...)
 872         -- Here we do *not* want to have x inlined, even though the RHS is
 873         -- trivial, becuase the contract for an INLINE pragma is "no inlining".
 874         -- This is important in the rules for the Prelude (e.g. PrelEnum.eftInt).
 875   where
 876     active = case getMode env of
 877                    SimplGently  -> isAlwaysActive prag
 878                    SimplPhase n -> isActive n prag
 879     prag = idInlinePragma bndr
 880 \end{code}
 881
 882 blackListInline tells if we must not inline at a call site because the
 883 Id's inline pragma says not to do so.
 884
 885 However, blackListInline is ignored for things with with Compulsory inlinings,
 886 because they don't have bindings, so we must inline them no matter how
 887 gentle we are being.
 888
 889 \begin{code}
 890 activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
 891 activeInline env id occ
 892   = case getMode env of
 893       SimplGently -> isAlwaysActive prag && isOneOcc occ
 894         -- No inlining at all when doing gentle stuff,
 895         -- except for things that occur once
 896         -- The reason is that too little clean-up happens if you
 897         -- don't inline use-once things.   Also a bit of inlining is *good* for
 898         -- full laziness; it can expose constant sub-expressions.
 899         -- Example in spectral/mandel/Mandel.hs, where the mandelset
 900         -- function gets a useful let-float if you inline windowToViewport
 901
 902         -- NB: we used to have a second exception, for data con wrappers.
 903         -- On the grounds that we use gentle mode for rule LHSs, and
 904         -- they match better when data con wrappers are inlined.
 905         -- But that only really applies to the trivial wrappers (like (:)),
 906         -- and they are now constructed as Compulsory unfoldings (in MkId)
 907         -- so they'll happen anyway.
 908
 909       SimplPhase n -> isActive n prag
 910   where
 911     prag = idInlinePragma id
 912
 913 activeRule :: SimplEnv -> Maybe (Activation -> Bool)
 914 -- Nothing => No rules at all
 915 activeRule env
 916   = case getMode env of
 917         SimplGently  -> Nothing         -- No rules in gentle mode
 918         SimplPhase n -> Just (isActive n)
 919 \end{code}
 920
 921
 922 %************************************************************************
 923 %*                                                                      *
 924 \subsubsection{Command-line switches}
 925 %*                                                                      *
 926 %************************************************************************
 927
 928 \begin{code}
 929 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 930 getSimplIntSwitch chkr switch
 931   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 932
 933 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 934
 935 switchIsOn lookup_fn switch
 936   = case (lookup_fn switch) of
 937       SwBool False -> False
 938       _            -> True
 939
 940 intSwitchSet :: (switch -> SwitchResult)
 941              -> (Int -> switch)
 942              -> Maybe Int
 943
 944 intSwitchSet lookup_fn switch
 945   = case (lookup_fn (switch (panic "intSwitchSet"))) of
 946       SwInt int -> Just int
 947       _         -> Nothing
 948 \end{code}
 949
 950
 951 \begin{code}
 952 type SwitchChecker = SimplifierSwitch -> SwitchResult
 953
 954 data SwitchResult
 955   = SwBool      Bool            -- on/off
 956   | SwString    FAST_STRING     -- nothing or a String
 957   | SwInt       Int             -- nothing or an Int
 958
 959 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 960 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
 961                                         -- in the list; defaults right at the end.
 962   = let
 963         tidied_on_switches = foldl rm_dups [] on_switches
 964                 -- The fold*l* ensures that we keep the latest switches;
 965                 -- ie the ones that occur earliest in the list.
 966
 967         sw_tbl :: Array Int SwitchResult
 968         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
 969                         all_undefined)
 970                  // defined_elems
 971
 972         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
 973
 974         defined_elems = map mk_assoc_elem tidied_on_switches
 975     in
 976     -- (avoid some unboxing, bounds checking, and other horrible things:)
 977 #if __GLASGOW_HASKELL__ < 405
 978     case sw_tbl of { Array bounds_who_needs_'em stuff ->
 979 #else
 980     case sw_tbl of { Array _ _ stuff ->
 981 #endif
 982     \ switch ->
 983         case (indexArray# stuff (tagOf_SimplSwitch switch)) of
 984 #if __GLASGOW_HASKELL__ < 400
 985           Lift v -> v
 986 #elif __GLASGOW_HASKELL__ < 403
 987           (# _, v #) -> v
 988 #else
 989           (# v #) -> v
 990 #endif
 991     }
 992   where
 993     mk_assoc_elem k@(MaxSimplifierIterations lvl)
 994         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
 995     mk_assoc_elem k
 996         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 997
 998     -- cannot have duplicates if we are going to use the array thing
 999     rm_dups switches_so_far switch
1000       = if switch `is_elem` switches_so_far
1001         then switches_so_far
1002         else switch : switches_so_far
1003       where
1004         sw `is_elem` []     = False
1005         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
1006                             || sw `is_elem` ss
1007 \end{code}
1008
1009 These things behave just like enumeration types.
1010
1011 \begin{code}
1012 instance Eq SimplifierSwitch where
1013     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
1014
1015 instance Ord SimplifierSwitch where
1016     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
1017     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
1018
1019
1020 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
1021 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
1022
1023 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
1024
1025 lAST_SIMPL_SWITCH_TAG = 2
1026 \end{code}
1027