\begin{code}
module SimplMonad (
InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
- OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
- OutExprStuff, OutStuff,
-
- -- The continuation type
- SimplCont(..), DupFlag(..), contIsDupable, contResultType,
+ OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+ FloatsWith, FloatsWithExpr,
-- The monad
SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
+ getDOptsSmpl,
+
+ -- The simplifier mode
+ setMode, getMode,
-- Unique supply
- getUniqueSmpl, getUniquesSmpl,
- newId, newIds,
+ getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
-- Counting
- SimplCount, TickType(..), TickCounts,
- tick, tickUnfold,
+ SimplCount, Tick(..),
+ tick, freeTick,
getSimplCount, zeroSimplCount, pprSimplCount,
plusSimplCount, isZeroSimplCount,
-- Switch checker
- SwitchChecker, getSwitchChecker, getSimplIntSwitch,
+ SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
+ isAmongSimpl, intSwitchSet, switchIsOn,
-- Cost centres
getEnclosingCC, setEnclosingCC,
-- Environments
- InScopeEnv, SubstEnv,
- getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
- emptySubstEnv, getSubstEnv, setSubstEnv, zapSubstEnv,
- extendIdSubst, extendTySubst,
- getTyEnv, getValEnv,
- getSimplBinderStuff, setSimplBinderStuff,
- switchOffInlining
+ SimplEnv, emptySimplEnv, getSubst, setSubst,
+ getSubstEnv, extendSubst, extendSubstList,
+ getInScope, setInScope, modifyInScope, addNewInScopeIds,
+ setSubstEnv, zapSubstEnv,
+
+ -- Floats
+ Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
+ allLifted, wrapFloats, floatBinds,
+ addAuxiliaryBind,
+
+ -- Inlining,
+ preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
+ inlineMode
) where
#include "HsVersions.h"
-import Id ( Id, mkSysLocal, idMustBeINLINEd )
-import IdInfo ( InlinePragInfo(..) )
-import Demand ( Demand )
+import Id ( Id, idType, isDataConWrapId,
+ idOccInfo, idInlinePragma
+ )
import CoreSyn
-import CoreUtils ( IdSubst, SubstCoreExpr, coreExprType, coreAltsType )
+import CoreUtils ( needsCaseBinding, exprIsTrivial )
+import PprCore () -- Instances
import CostCentre ( CostCentreStack, subsumedCCS )
-import Var ( TyVar )
+import Var
import VarEnv
import VarSet
-import Type ( Type, TyVarSubst, funResultTy, fullSubstTy, applyTy )
+import OrdList
+import qualified Subst
+import Subst ( Subst, mkSubst, substEnv,
+ InScopeSet, mkInScopeSet, substInScope,
+ isInScope
+ )
+import Type ( Type, isUnLiftedType )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
-import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), intSwitchSet )
+import FiniteMap
+import BasicTypes ( TopLevelFlag, isTopLevel,
+ Activation, isActive, isAlwaysActive,
+ OccInfo(..)
+ )
+import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
+ DynFlags, DynFlag(..), dopt,
+ opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining,
+ )
import Unique ( Unique )
import Maybes ( expectJust )
-import Util ( zipWithEqual )
import Outputable
+import Array ( array, (//) )
+import FastTypes
+import GlaExts ( indexArray# )
+
+#if __GLASGOW_HASKELL__ < 301
+import ArrBase ( Array(..) )
+#else
+import PrelArr ( Array(..) )
+#endif
-infixr 9 `thenSmpl`, `thenSmpl_`
+infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
%************************************************************************
type OutBinder = CoreBndr
type OutId = Id -- Cloned
+type OutTyVar = TyVar -- Cloned
type OutType = Type -- Cloned
type OutBind = CoreBind
type OutExpr = CoreExpr
type OutAlt = CoreAlt
type OutArg = CoreArg
-
-type SwitchChecker = SimplifierSwitch -> SwitchResult
\end{code}
-
%************************************************************************
%* *
-\subsection{The continuation data type}
+\subsection{Floats}
%* *
%************************************************************************
\begin{code}
-type OutExprStuff = OutStuff (InScopeEnv, OutExpr)
-type OutStuff a = ([OutBind], a)
+type FloatsWithExpr = FloatsWith OutExpr
+type FloatsWith a = (Floats, a)
-- We return something equivalent to (let b in e), but
-- in pieces to avoid the quadratic blowup when floating
-- incrementally. Comments just before simplExprB in Simplify.lhs
-data SimplCont -- Strict contexts
- = Stop
-
- | CoerceIt DupFlag
- InType SubstEnv
- SimplCont
-
- | ApplyTo DupFlag
- InExpr SubstEnv -- The argument, as yet unsimplified,
- SimplCont -- and its subst-env
-
- | Select DupFlag
- InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
- SimplCont
-
- | ArgOf DupFlag -- An arbitrary strict context: the argument
- (OutExpr -> SimplM OutExprStuff) -- of a strict function, or a primitive-arg fn
- -- or a PrimOp
- OutType -- Type of the result of the whole thing
-
-instance Outputable SimplCont where
- ppr Stop = ptext SLIT("Stop")
- ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
- ppr (ArgOf dup cont_fn _) = ptext SLIT("ArgOf...") <+> ppr dup
- ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
- (nest 4 (ppr alts)) $$ ppr cont
- ppr (CoerceIt dup ty se cont) = (ptext SLIT("CoerceIt") <+> ppr dup <+> ppr ty) $$ ppr cont
-
-data DupFlag = OkToDup | NoDup
-
-instance Outputable DupFlag where
- ppr OkToDup = ptext SLIT("ok")
- ppr NoDup = ptext SLIT("nodup")
-
-contIsDupable :: SimplCont -> Bool
-contIsDupable Stop = True
-contIsDupable (ApplyTo OkToDup _ _ _) = True
-contIsDupable (ArgOf OkToDup _ _) = True
-contIsDupable (Select OkToDup _ _ _ _) = True
-contIsDupable (CoerceIt OkToDup _ _ _) = True
-contIsDupable other = False
-
-contResultType :: InScopeEnv -> Type -> SimplCont -> Type
-contResultType in_scope e_ty cont
- = go e_ty cont
- where
- go e_ty Stop = e_ty
- go e_ty (ApplyTo _ (Type ty) se cont) = go (applyTy e_ty (simpl se ty)) cont
- go e_ty (ApplyTo _ val_arg _ cont) = go (funResultTy e_ty) cont
- go e_ty (ArgOf _ fun cont_ty) = cont_ty
- go e_ty (CoerceIt _ ty se cont) = go (simpl se ty) cont
- go e_ty (Select _ _ alts se cont) = go (simpl se (coreAltsType alts)) cont
-
- simpl (ty_subst, _) ty = fullSubstTy ty_subst in_scope ty
+data Floats = Floats (OrdList OutBind)
+ InScopeSet -- Environment "inside" all the floats
+ Bool -- True <=> All bindings are lifted
+
+allLifted :: Floats -> Bool
+allLifted (Floats _ _ is_lifted) = is_lifted
+
+wrapFloats :: Floats -> OutExpr -> OutExpr
+wrapFloats (Floats bs _ _) body = foldrOL Let body bs
+
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats bs _ _) = isNilOL bs
+
+floatBinds :: Floats -> [OutBind]
+floatBinds (Floats bs _ _) = fromOL bs
+
+flattenFloats :: Floats -> Floats
+-- Flattens into a single Rec group
+flattenFloats (Floats bs is is_lifted)
+ = ASSERT2( is_lifted, ppr (fromOL bs) )
+ Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
+\end{code}
+
+\begin{code}
+emptyFloats :: SimplEnv -> Floats
+emptyFloats env = Floats nilOL (getInScope env) True
+
+unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
+-- A single non-rec float; extend the in-scope set
+unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
+ (Subst.extendInScopeSet (getInScope env) var)
+ (not (isUnLiftedType (idType var)))
+
+addFloats :: SimplEnv -> Floats
+ -> (SimplEnv -> SimplM (FloatsWith a))
+ -> SimplM (FloatsWith a)
+addFloats env (Floats b1 is1 l1) thing_inside
+ | isNilOL b1
+ = thing_inside env
+ | otherwise
+ = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
+ returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
+
+addLetBind :: OutBind -> Floats -> Floats
+addLetBind bind (Floats binds in_scope lifted)
+ = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
+
+is_lifted_bind (Rec _) = True
+is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
+
+-- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
+-- * extends the in-scope env
+-- * assumes it's a let-bindable thing
+addAuxiliaryBind :: SimplEnv -> OutBind
+ -> (SimplEnv -> SimplM (FloatsWith a))
+ -> SimplM (FloatsWith a)
+ -- Extends the in-scope environment as well as wrapping the bindings
+addAuxiliaryBind env bind thing_inside
+ = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
+ thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
+ returnSmpl (addLetBind bind floats, x)
\end{code}
(Command-line switches move around through the explicitly-passed SimplEnv.)
\begin{code}
-type SimplM result -- We thread the unique supply because
- = SimplEnv -- constantly splitting it is rather expensive
- -> UniqSupply
+type SimplM result
+ = DynFlags -- We thread the unique supply because
+ -> UniqSupply -- constantly splitting it is rather expensive
-> SimplCount
-> (result, UniqSupply, SimplCount)
-
-data SimplEnv
- = SimplEnv {
- seChkr :: SwitchChecker,
- seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
- seSubst :: SubstEnv, -- The current substitution
- seInScope :: InScopeEnv -- Says what's in scope and gives info about it
- }
\end{code}
\begin{code}
-initSmpl :: SwitchChecker
+initSmpl :: DynFlags
-> UniqSupply -- No init count; set to 0
-> SimplM a
-> (a, SimplCount)
-initSmpl chkr us m = case m (emptySimplEnv chkr) us zeroSimplCount of
- (result, _, count) -> (result, count)
+initSmpl dflags us m
+ = case m dflags us (zeroSimplCount dflags) of
+ (result, _, count) -> (result, count)
{-# INLINE thenSmpl #-}
{-# INLINE returnSmpl #-}
returnSmpl :: a -> SimplM a
-returnSmpl e env us sc = (e, us, sc)
+returnSmpl e dflags us sc = (e, us, sc)
thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
-thenSmpl m k env us0 sc0
- = case (m env us0 sc0) of
- (m_result, us1, sc1) -> k m_result env us1 sc1
+thenSmpl m k dflags us0 sc0
+ = case (m dflags us0 sc0) of
+ (m_result, us1, sc1) -> k m_result dflags us1 sc1
-thenSmpl_ m k env us0 sc0
- = case (m env us0 sc0) of
- (_, us1, sc1) -> k env us1 sc1
+thenSmpl_ m k dflags us0 sc0
+ = case (m dflags us0 sc0) of
+ (_, us1, sc1) -> k dflags us1 sc1
\end{code}
%************************************************************************
\begin{code}
-getUniqueSmpl :: SimplM Unique
-getUniqueSmpl env us sc = case splitUniqSupply us of
- (us1, us2) -> (uniqFromSupply us1, us2, sc)
+getUniqSupplySmpl :: SimplM UniqSupply
+getUniqSupplySmpl dflags us sc
+ = case splitUniqSupply us of
+ (us1, us2) -> (us1, us2, sc)
-getUniquesSmpl :: Int -> SimplM [Unique]
-getUniquesSmpl n env us sc = case splitUniqSupply us of
- (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
+getUniqueSmpl :: SimplM Unique
+getUniqueSmpl dflags us sc
+ = case splitUniqSupply us of
+ (us1, us2) -> (uniqFromSupply us1, us2, sc)
+
+getUniquesSmpl :: SimplM [Unique]
+getUniquesSmpl dflags us sc
+ = case splitUniqSupply us of
+ (us1, us2) -> (uniqsFromSupply us1, us2, sc)
+
+getDOptsSmpl :: SimplM DynFlags
+getDOptsSmpl dflags us sc
+ = (dflags, us, sc)
\end{code}
%************************************************************************
\begin{code}
-doTickSmpl :: (SimplCount -> SimplCount) -> SimplM ()
-doTickSmpl f env us sc = sc' `seq` ((), us, sc')
- where
- sc' = f sc
-
getSimplCount :: SimplM SimplCount
-getSimplCount env us sc = (sc, us, sc)
-\end{code}
-
-
-The assoc list isn't particularly costly, because we only use
-the number of ticks in ``real life.''
-
-The right thing to do, if you want that to go fast, is thread
-a mutable array through @SimplM@.
-
-\begin{code}
-data SimplCount
- = SimplCount !TickCounts
- !UnfoldingHistory
-
-type TickCounts = [(TickType, Int)] -- Assoc list of all diff kinds of ticks
- -- Kept in increasing order of TickType
- -- Zeros not present
-
-type UnfoldingHistory = (Int, -- N
- [Id], -- Last N unfoldings
- [Id]) -- The MaxUnfoldHistory unfoldings before that
-
-data TickType
- = PreInlineUnconditionally
- | PostInlineUnconditionally
- | UnfoldingDone
- | MagicUnfold
- | CaseOfCase
- | LetFloatFromLet
- | KnownBranch
- | Let2Case
- | Case2Let
- | CaseMerge
- | CaseElim
- | CaseIdentity
- | EtaExpansion
- | CaseOfError
- | BetaReduction
- | SpecialisationDone
- | FillInCaseDefault
- | LeavesExamined
- deriving (Eq, Ord, Show)
-
-pprSimplCount :: SimplCount -> SDoc
-pprSimplCount (SimplCount stuff (_, unf1, unf2))
- = vcat (map ppr_item stuff)
- $$ (text "Most recent unfoldings (most recent at top):"
- $$ nest 4 (vcat (map ppr (unf1 ++ unf2))))
- where
- ppr_item (t,n) = text (show t) <+> char '\t' <+> ppr n
-
-zeroSimplCount :: SimplCount
-zeroSimplCount = SimplCount [] (0, [], [])
-
-isZeroSimplCount :: SimplCount -> Bool
-isZeroSimplCount (SimplCount [] _) = True
-isZeroSimplCount (SimplCount [(LeavesExamined,_)] _) = True
-isZeroSimplCount other = False
-
--- incTick is careful to be pretty strict, so we don't
--- get a huge buildup of thunks
-incTick :: TickType -> FAST_INT -> TickCounts -> TickCounts
-incTick tick_type n []
- = [(tick_type, IBOX(n))]
-
-incTick tick_type n (x@(ttype, I# cnt#) : xs)
- = case tick_type `compare` ttype of
- LT -> -- Insert here
- (tick_type, IBOX(n)) : x : xs
-
- EQ -> -- Increment
- case cnt# +# n of
- incd -> (ttype, IBOX(incd)) : xs
-
- GT -> -- Move on
- rest `seq` x : rest
- where
- rest = incTick tick_type n xs
-
--- Second argument is more recent stuff
-plusSimplCount :: SimplCount -> SimplCount -> SimplCount
-plusSimplCount (SimplCount tc1 uh1) (SimplCount tc2 uh2)
- = SimplCount (plusTickCounts tc1 tc2) (plusUnfolds uh1 uh2)
-
-plusTickCounts :: TickCounts -> TickCounts -> TickCounts
-plusTickCounts ts1 [] = ts1
-plusTickCounts [] ts2 = ts2
-plusTickCounts ((tt1,n1) : ts1) ((tt2,n2) : ts2)
- = case tt1 `compare` tt2 of
- LT -> (tt1,n1) : plusTickCounts ts1 ((tt2,n2) : ts2)
- EQ -> (tt1,n1+n2) : plusTickCounts ts1 ts2
- GT -> (tt2,n2) : plusTickCounts ((tt1,n1) : ts1) ts2
-
--- Second argument is the more recent stuff
-plusUnfolds uh1 (0, h2, t2) = uh1 -- Nothing recent
-plusUnfolds (n1, h1, t1) (n2, h2, []) = (n2, h2, (h1++t1)) -- Small amount recent
-plusUnfolds (n1, h1, t1) uh2 = uh2 -- Decent batch recent
+getSimplCount dflags us sc = (sc, us, sc)
+
+tick :: Tick -> SimplM ()
+tick t dflags us sc
+ = sc' `seq` ((), us, sc')
+ where
+ sc' = doTick t sc
+
+freeTick :: Tick -> SimplM ()
+-- Record a tick, but don't add to the total tick count, which is
+-- used to decide when nothing further has happened
+freeTick t dflags us sc
+ = sc' `seq` ((), us, sc')
+ where
+ sc' = doFreeTick t sc
\end{code}
-
-Counting-related monad functions:
-
\begin{code}
-tick :: TickType -> SimplM ()
+verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
-tick tick_type
- = doTickSmpl f
- where
- f (SimplCount stuff unf) = SimplCount (incTick tick_type ILIT(1) stuff) unf
-
-maxUnfoldHistory :: Int
-maxUnfoldHistory = 20
-
-tickUnfold :: Id -> SimplM ()
-tickUnfold id
- = doTickSmpl f
- where
- f (SimplCount stuff (n_unf, unf1, unf2))
- | n_unf >= maxUnfoldHistory = SimplCount new_stuff (1, [id], unf1)
- | otherwise = SimplCount new_stuff (n_unf+1, id:unf1, unf2)
- where
- new_stuff = incTick UnfoldingDone ILIT(1) stuff
+zeroSimplCount :: DynFlags -> SimplCount
+isZeroSimplCount :: SimplCount -> Bool
+pprSimplCount :: SimplCount -> SDoc
+doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
+plusSimplCount :: SimplCount -> SimplCount -> SimplCount
\end{code}
+\begin{code}
+data SimplCount = VerySimplZero -- These two are used when
+ | VerySimplNonZero -- we are only interested in
+ -- termination info
+
+ | SimplCount {
+ ticks :: !Int, -- Total ticks
+ details :: !TickCounts, -- How many of each type
+ n_log :: !Int, -- N
+ log1 :: [Tick], -- Last N events; <= opt_HistorySize
+ log2 :: [Tick] -- Last opt_HistorySize events before that
+ }
+
+type TickCounts = FiniteMap Tick Int
+
+zeroSimplCount dflags
+ -- This is where we decide whether to do
+ -- the VerySimpl version or the full-stats version
+ | dopt Opt_D_dump_simpl_stats dflags
+ = SimplCount {ticks = 0, details = emptyFM,
+ n_log = 0, log1 = [], log2 = []}
+ | otherwise
+ = VerySimplZero
-%************************************************************************
-%* *
-\subsubsection{Command-line switches}
-%* *
-%************************************************************************
+isZeroSimplCount VerySimplZero = True
+isZeroSimplCount (SimplCount { ticks = 0 }) = True
+isZeroSimplCount other = False
-\begin{code}
-getSwitchChecker :: SimplM SwitchChecker
-getSwitchChecker env us sc = (seChkr env, us, sc)
+doFreeTick tick sc@SimplCount { details = dts }
+ = dts' `seqFM` sc { details = dts' }
+ where
+ dts' = dts `addTick` tick
+doFreeTick tick sc = sc
-getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
-getSimplIntSwitch chkr switch
- = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-\end{code}
+-- Gross hack to persuade GHC 3.03 to do this important seq
+seqFM fm x | isEmptyFM fm = x
+ | otherwise = x
+doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
+ | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
+ | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
+ where
+ sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
-@switchOffInlining@ is used to prepare the environment for simplifying
-the RHS of an Id that's marked with an INLINE pragma. It is going to
-be inlined wherever they are used, and then all the inlining will take
-effect. Meanwhile, there isn't much point in doing anything to the
-as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
-inlining! because
- (a) not doing so will inline a worker straight back into its wrapper!
+doTick tick sc = VerySimplNonZero -- The very simple case
-and (b) Consider the following example
- let f = \pq -> BIG
- in
- let g = \y -> f y y
- {-# INLINE g #-}
- in ...g...g...g...g...g...
- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
- and thence copied multiple times when g is inlined.
+-- Don't use plusFM_C because that's lazy, and we want to
+-- be pretty strict here!
+addTick :: TickCounts -> Tick -> TickCounts
+addTick fm tick = case lookupFM fm tick of
+ Nothing -> addToFM fm tick 1
+ Just n -> n1 `seq` addToFM fm tick n1
+ where
+ n1 = n+1
- Andy disagrees! Example:
- all xs = foldr (&&) True xs
- any p = all . map p {-# INLINE any #-}
-
- Problem: any won't get deforested, and so if it's exported and
- the importer doesn't use the inlining, (eg passes it as an arg)
- then we won't get deforestation at all.
- We havn't solved this problem yet!
-
-We prepare the envt by simply modifying the in_scope_env, which has all the
-unfolding info. At one point we did it by modifying the chkr so that
-it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
-important, simplifications happening in the body of the RHS.
-
-6/98 update:
-
-We *don't* prevent inlining from happening for identifiers
-that are marked as IMustBeINLINEd. An example of where
-doing this is crucial is:
-
- class Bar a => Foo a where
- ...g....
- {-# INLINE f #-}
- f :: Foo a => a -> b
- f x = ....Foo_sc1...
-
-If `f' needs to peer inside Foo's superclass, Bar, it refers
-to the appropriate super class selector, which is marked as
-must-inlineable. We don't generate any code for a superclass
-selector, so failing to inline it in the RHS of `f' will
-leave a reference to a non-existent id, with bad consequences.
-
-ALSO NOTE that we do all this by modifing the inline-pragma,
-not by zapping the unfolding. The latter may still be useful for
-knowing when something is evaluated.
-
-June 98 update: I've gone back to dealing with this by adding
-the EssentialUnfoldingsOnly switch. That doesn't stop essential
-unfoldings, nor inlineUnconditionally stuff; and the thing's going
-to be inlined at every call site anyway. Running over the whole
-environment seems like wild overkill.
-\begin{code}
-switchOffInlining :: SimplM a -> SimplM a
-switchOffInlining m env@(SimplEnv { seChkr = sw_chkr }) us sc
- = m (env { seChkr = new_chkr }) us sc
+plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
+ sc2@(SimplCount { ticks = tks2, details = dts2 })
+ = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
+ where
+ -- A hackish way of getting recent log info
+ log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
+ | null (log2 sc2) = sc2 { log2 = log1 sc1 }
+ | otherwise = sc2
+
+plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
+plusSimplCount sc1 sc2 = VerySimplNonZero
+
+pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
+pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
+ = vcat [ptext SLIT("Total ticks: ") <+> int tks,
+ text "",
+ pprTickCounts (fmToList dts),
+ if verboseSimplStats then
+ vcat [text "",
+ ptext SLIT("Log (most recent first)"),
+ nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
+ else empty
+ ]
+
+pprTickCounts :: [(Tick,Int)] -> SDoc
+pprTickCounts [] = empty
+pprTickCounts ((tick1,n1):ticks)
+ = vcat [int tot_n <+> text (tickString tick1),
+ pprTCDetails real_these,
+ pprTickCounts others
+ ]
where
- new_chkr EssentialUnfoldingsOnly = SwBool True
- new_chkr other = sw_chkr other
+ tick1_tag = tickToTag tick1
+ (these, others) = span same_tick ticks
+ real_these = (tick1,n1):these
+ same_tick (tick2,_) = tickToTag tick2 == tick1_tag
+ tot_n = sum [n | (_,n) <- real_these]
+
+pprTCDetails ticks@((tick,_):_)
+ | verboseSimplStats || isRuleFired tick
+ = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
+ | otherwise
+ = empty
\end{code}
-
%************************************************************************
%* *
-\subsubsection{The ``enclosing cost-centre''}
+\subsection{Ticks}
%* *
%************************************************************************
\begin{code}
-getEnclosingCC :: SimplM CostCentreStack
-getEnclosingCC env us sc = (seCC env, us, sc)
+data Tick
+ = PreInlineUnconditionally Id
+ | PostInlineUnconditionally Id
-setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
-setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
+ | UnfoldingDone Id
+ | RuleFired FAST_STRING -- Rule name
+
+ | LetFloatFromLet
+ | EtaExpansion Id -- LHS binder
+ | EtaReduction Id -- Binder on outer lambda
+ | BetaReduction Id -- Lambda binder
+
+
+ | CaseOfCase Id -- Bndr on *inner* case
+ | KnownBranch Id -- Case binder
+ | CaseMerge Id -- Binder on outer case
+ | AltMerge Id -- Case binder
+ | CaseElim Id -- Case binder
+ | CaseIdentity Id -- Case binder
+ | FillInCaseDefault Id -- Case binder
+
+ | BottomFound
+ | SimplifierDone -- Ticked at each iteration of the simplifier
+
+isRuleFired (RuleFired _) = True
+isRuleFired other = False
+
+instance Outputable Tick where
+ ppr tick = text (tickString tick) <+> pprTickCts tick
+
+instance Eq Tick where
+ a == b = case a `cmpTick` b of { EQ -> True; other -> False }
+
+instance Ord Tick where
+ compare = cmpTick
+
+tickToTag :: Tick -> Int
+tickToTag (PreInlineUnconditionally _) = 0
+tickToTag (PostInlineUnconditionally _) = 1
+tickToTag (UnfoldingDone _) = 2
+tickToTag (RuleFired _) = 3
+tickToTag LetFloatFromLet = 4
+tickToTag (EtaExpansion _) = 5
+tickToTag (EtaReduction _) = 6
+tickToTag (BetaReduction _) = 7
+tickToTag (CaseOfCase _) = 8
+tickToTag (KnownBranch _) = 9
+tickToTag (CaseMerge _) = 10
+tickToTag (CaseElim _) = 11
+tickToTag (CaseIdentity _) = 12
+tickToTag (FillInCaseDefault _) = 13
+tickToTag BottomFound = 14
+tickToTag SimplifierDone = 16
+tickToTag (AltMerge _) = 17
+
+tickString :: Tick -> String
+tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
+tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
+tickString (UnfoldingDone _) = "UnfoldingDone"
+tickString (RuleFired _) = "RuleFired"
+tickString LetFloatFromLet = "LetFloatFromLet"
+tickString (EtaExpansion _) = "EtaExpansion"
+tickString (EtaReduction _) = "EtaReduction"
+tickString (BetaReduction _) = "BetaReduction"
+tickString (CaseOfCase _) = "CaseOfCase"
+tickString (KnownBranch _) = "KnownBranch"
+tickString (CaseMerge _) = "CaseMerge"
+tickString (AltMerge _) = "AltMerge"
+tickString (CaseElim _) = "CaseElim"
+tickString (CaseIdentity _) = "CaseIdentity"
+tickString (FillInCaseDefault _) = "FillInCaseDefault"
+tickString BottomFound = "BottomFound"
+tickString SimplifierDone = "SimplifierDone"
+
+pprTickCts :: Tick -> SDoc
+pprTickCts (PreInlineUnconditionally v) = ppr v
+pprTickCts (PostInlineUnconditionally v)= ppr v
+pprTickCts (UnfoldingDone v) = ppr v
+pprTickCts (RuleFired v) = ppr v
+pprTickCts LetFloatFromLet = empty
+pprTickCts (EtaExpansion v) = ppr v
+pprTickCts (EtaReduction v) = ppr v
+pprTickCts (BetaReduction v) = ppr v
+pprTickCts (CaseOfCase v) = ppr v
+pprTickCts (KnownBranch v) = ppr v
+pprTickCts (CaseMerge v) = ppr v
+pprTickCts (AltMerge v) = ppr v
+pprTickCts (CaseElim v) = ppr v
+pprTickCts (CaseIdentity v) = ppr v
+pprTickCts (FillInCaseDefault v) = ppr v
+pprTickCts other = empty
+
+cmpTick :: Tick -> Tick -> Ordering
+cmpTick a b = case (tickToTag a `compare` tickToTag b) of
+ GT -> GT
+ EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
+ | otherwise -> EQ
+ LT -> LT
+ -- Always distinguish RuleFired, so that the stats
+ -- can report them even in non-verbose mode
+
+cmpEqTick :: Tick -> Tick -> Ordering
+cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
+cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
+cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
+cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
+cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
+cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
+cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
+cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
+cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
+cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
+cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
+cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
+cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
+cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
+cmpEqTick other1 other2 = EQ
\end{code}
+
%************************************************************************
%* *
\subsubsection{The @SimplEnv@ type}
%* *
%************************************************************************
+
\begin{code}
-type SubstEnv = (TyVarSubst, IdSubst)
- -- The range of these substitutions is OutType and OutExpr resp
+data SimplEnv
+ = SimplEnv {
+ seMode :: SimplifierMode,
+ seChkr :: SwitchChecker,
+ seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
+ seSubst :: Subst -- The current substitution
+ }
+ -- The range of the substitution is OutType and OutExpr resp
--
-- The substitution is idempotent
-- It *must* be applied; things in its domain simply aren't
-- the RHS of the let simplifies to an atom,
-- we just add the binding to the substitution and elide the let.
-type InScopeEnv = IdOrTyVarSet
- -- Domain includes *all* in-scope TyVars and Ids
- --
+ -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
-- The elements of the set may have better IdInfo than the
-- occurrences of in-scope Ids, and (more important) they will
-- have a correctly-substituted type. So we use a lookup in this
-- set to replace occurrences
--- INVARIANT: If t is in the in-scope set, it certainly won't be
--- in the domain of the SubstEnv, and vice versa
+emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> VarSet -> SimplEnv
+emptySimplEnv mode switches in_scope
+ = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, seMode = mode,
+ seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
+ -- The top level "enclosing CC" is "SUBSUMED".
+
+---------------------
+getSwitchChecker :: SimplEnv -> SwitchChecker
+getSwitchChecker env = seChkr env
+
+---------------------
+getMode :: SimplEnv -> SimplifierMode
+getMode env = seMode env
+
+setMode :: SimplifierMode -> SimplEnv -> SimplEnv
+setMode mode env = env { seMode = mode }
+
+---------------------
+getEnclosingCC :: SimplEnv -> CostCentreStack
+getEnclosingCC env = seCC env
+
+setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
+setEnclosingCC env cc = env {seCC = cc}
+
+---------------------
+getSubst :: SimplEnv -> Subst
+getSubst env = seSubst env
+
+setSubst :: SimplEnv -> Subst -> SimplEnv
+setSubst env subst = env {seSubst = subst}
+
+extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv
+extendSubst env@(SimplEnv {seSubst = subst}) var res
+ = env {seSubst = Subst.extendSubst subst var res}
+
+extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv
+extendSubstList env@(SimplEnv {seSubst = subst}) vars ress
+ = env {seSubst = Subst.extendSubstList subst vars ress}
+
+---------------------
+getInScope :: SimplEnv -> InScopeSet
+getInScope env = substInScope (seSubst env)
+
+setInScope :: SimplEnv -> SimplEnv -> SimplEnv
+setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
+
+setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
+setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
+ = env {seSubst = Subst.setInScope subst in_scope}
+
+addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
+ -- The new Ids are guaranteed to be freshly allocated
+addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
+ = env {seSubst = Subst.extendNewInScopeList subst vs}
+
+modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
+modifyInScope env@(SimplEnv {seSubst = subst}) v v'
+ = env {seSubst = Subst.modifyInScope subst v v'}
+
+---------------------
+getSubstEnv :: SimplEnv -> SubstEnv
+getSubstEnv env = substEnv (seSubst env)
+
+setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv
+setSubstEnv env@(SimplEnv {seSubst = subst}) senv
+ = env {seSubst = Subst.setSubstEnv subst senv}
+
+zapSubstEnv :: SimplEnv -> SimplEnv
+zapSubstEnv env@(SimplEnv {seSubst = subst})
+ = env {seSubst = Subst.zapSubstEnv subst}
\end{code}
+%************************************************************************
+%* *
+\subsection{Decisions about inlining}
+%* *
+%************************************************************************
+
+Inlining is controlled partly by the SimplifierMode switch. This has two
+settings:
+
+ SimplGently (a) Simplifying before specialiser/full laziness
+ (b) Simplifiying inside INLINE pragma
+ (c) Simplifying the LHS of a rule
+
+ SimplPhase n Used at all other times
+
+The key thing about SimplGently is that it does no call-site inlining.
+Before full laziness we must be careful not to inline wrappers,
+because doing so inhibits floating
+ e.g. ...(case f x of ...)...
+ ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ ==> ...(case x of I# x# -> case fw x# of ...)...
+and now the redex (f x) isn't floatable any more.
+
+INLINE pragmas
+~~~~~~~~~~~~~~
+SimplGently is also used as the mode to simplify inside an InlineMe note.
+
\begin{code}
-emptySubstEnv :: SubstEnv
-emptySubstEnv = (emptyVarEnv, emptyVarEnv)
+inlineMode :: SimplifierMode
+inlineMode = SimplGently
+\end{code}
-emptySimplEnv :: SwitchChecker -> SimplEnv
+It really is important to switch off inlinings inside such
+expressions. Consider the following example
+
+ let f = \pq -> BIG
+ in
+ let g = \y -> f y y
+ {-# INLINE g #-}
+ in ...g...g...g...g...g...
+
+Now, if that's the ONLY occurrence of f, it will be inlined inside g,
+and thence copied multiple times when g is inlined.
+
+
+This function may be inlinined in other modules, so we
+don't want to remove (by inlining) calls to functions that have
+specialisations, or that may have transformation rules in an importing
+scope.
+
+E.g. {-# INLINE f #-}
+ f x = ...g...
+
+and suppose that g is strict *and* has specialisations. If we inline
+g's wrapper, we deny f the chance of getting the specialised version
+of g when f is inlined at some call site (perhaps in some other
+module).
+
+It's also important not to inline a worker back into a wrapper.
+A wrapper looks like
+ wraper = inline_me (\x -> ...worker... )
+Normally, the inline_me prevents the worker getting inlined into
+the wrapper (initially, the worker's only call site!). But,
+if the wrapper is sure to be called, the strictness analyser will
+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+continuation. That's why the keep_inline predicate returns True for
+ArgOf continuations. It shouldn't do any harm not to dissolve the
+inline-me note under these circumstances.
+
+Note that the result is that we do very little simplification
+inside an InlineMe.
+
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+
+Problem: any won't get deforested, and so if it's exported and the
+importer doesn't use the inlining, (eg passes it as an arg) then we
+won't get deforestation at all. We havn't solved this problem yet!
+
+
+preInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~
+@preInlineUnconditionally@ examines a bndr to see if it is used just
+once in a completely safe way, so that it is safe to discard the
+binding inline its RHS at the (unique) usage site, REGARDLESS of how
+big the RHS might be. If this is the case we don't simplify the RHS
+first, but just inline it un-simplified.
+
+This is much better than first simplifying a perhaps-huge RHS and then
+inlining and re-simplifying it.
+
+NB: we don't even look at the RHS to see if it's trivial
+We might have
+ x = y
+where x is used many times, but this is the unique occurrence of y.
+We should NOT inline x at all its uses, because then we'd do the same
+for y -- aargh! So we must base this pre-rhs-simplification decision
+solely on x's occurrences, not on its rhs.
+
+Evne RHSs labelled InlineMe aren't caught here, because there might be
+no benefit from inlining at the call site.
+
+[Sept 01] Don't unconditionally inline a top-level thing, because that
+can simply make a static thing into something built dynamically. E.g.
+ x = (a,b)
+ main = \s -> h x
+
+[Remember that we treat \s as a one-shot lambda.] No point in
+inlining x unless there is something interesting about the call site.
+
+But watch out: if you aren't careful, some useful foldr/build fusion
+can be lost (most notably in spectral/hartel/parstof) because the
+foldr didn't see the build. Doing the dynamic allocation isn't a big
+deal, in fact, but losing the fusion can be. But the right thing here
+seems to be to do a callSiteInline based on the fact that there is
+something interesting about the call site (it's strict). Hmm. That
+seems a bit fragile.
-emptySimplEnv sw_chkr
- = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
- seSubst = emptySubstEnv,
- seInScope = emptyVarSet }
+\begin{code}
+preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
+preInlineUnconditionally env top_lvl bndr
+-- | isTopLevel top_lvl = False
+-- Top-level fusion lost if we do this for (e.g. string constants)
+ | not active = False
+ | opt_SimplNoPreInlining = False
+ | otherwise = case idOccInfo bndr of
+ IAmDead -> True -- Happens in ((\x.1) v)
+ OneOcc in_lam once -> not in_lam && once
+ -- Not inside a lambda, one occurrence ==> safe!
+ other -> False
+ where
+ active = case getMode env of
+ SimplGently -> isAlwaysActive prag
+ SimplPhase n -> isActive n prag
+ prag = idInlinePragma bndr
+\end{code}
- -- The top level "enclosing CC" is "SUBSUMED".
+postInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~~
+@postInlineUnconditionally@ decides whether to unconditionally inline
+a thing based on the form of its RHS; in particular if it has a
+trivial RHS. If so, we can inline and discard the binding altogether.
-getTyEnv :: SimplM (TyVarSubst, InScopeEnv)
-getTyEnv (SimplEnv {seSubst = (ty_subst,_), seInScope = in_scope}) us sc
- = ((ty_subst, in_scope), us, sc)
+NB: a loop breaker has must_keep_binding = True and non-loop-breakers
+only have *forward* references Hence, it's safe to discard the binding
+
+NOTE: This isn't our last opportunity to inline. We're at the binding
+site right now, and we'll get another opportunity when we get to the
+ocurrence(s)
-getValEnv :: SimplM (IdSubst, InScopeEnv)
-getValEnv (SimplEnv {seSubst = (_, id_subst), seInScope = in_scope}) us sc
- = ((id_subst, in_scope), us, sc)
+Note that we do this unconditional inlining only for trival RHSs.
+Don't inline even WHNFs inside lambdas; doing so may simply increase
+allocation when the function is called. This isn't the last chance; see
+NOTE above.
-getInScope :: SimplM InScopeEnv
-getInScope env us sc = (seInScope env, us, sc)
+NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
+Because we don't even want to inline them into the RHS of constructor
+arguments. See NOTE above
-setInScope :: InScopeEnv -> SimplM a -> SimplM a
-setInScope in_scope m env us sc = m (env {seInScope = in_scope}) us sc
+NB: At one time even NOINLINE was ignored here: if the rhs is trivial
+it's best to inline it anyway. We often get a=E; b=a from desugaring,
+with both a and b marked NOINLINE. But that seems incompatible with
+our new view that inlining is like a RULE, so I'm sticking to the 'active'
+story for now.
-extendInScope :: CoreBndr -> SimplM a -> SimplM a
-extendInScope v m env@(SimplEnv {seInScope = in_scope}) us sc
- = m (env {seInScope = extendVarSet in_scope v}) us sc
+\begin{code}
+postInlineUnconditionally :: SimplEnv -> OutId -> Bool -> OutExpr -> Bool
+postInlineUnconditionally env bndr loop_breaker rhs
+ = exprIsTrivial rhs
+ && active
+ && not loop_breaker
+ && not (isExportedId bndr)
+ where
+ active = case getMode env of
+ SimplGently -> isAlwaysActive prag
+ SimplPhase n -> isActive n prag
+ prag = idInlinePragma bndr
+\end{code}
-extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
-extendInScopes vs m env@(SimplEnv {seInScope = in_scope}) us sc
- = m (env {seInScope = foldl extendVarSet in_scope vs}) us sc
+blackListInline tells if we must not inline at a call site because the
+Id's inline pragma says not to do so.
-modifyInScope :: CoreBndr -> SimplM a -> SimplM a
-modifyInScope v m env us sc
-#ifdef DEBUG
- | not (v `elemVarSet` seInScope env )
- = pprTrace "modifyInScope: not in scope:" (ppr v)
- m env us sc
-#endif
- | otherwise
- = extendInScope v m env us sc
+However, blackListInline is ignored for things with with Compulsory inlinings,
+because they don't have bindings, so we must inline them no matter how
+gentle we are being.
-getSubstEnv :: SimplM SubstEnv
-getSubstEnv env us sc = (seSubst env, us, sc)
+\begin{code}
+activeInline :: SimplEnv -> OutId -> Bool
+activeInline env id
+ = case getMode env of
+ SimplGently -> isDataConWrapId id
+ -- No inlining at all when doing gentle stuff,
+ -- except (hack alert) for data con wrappers
+ -- We want to inline data con wrappers even in gentle mode
+ -- because rule LHSs match better then
+ SimplPhase n -> isActive n (idInlinePragma id)
+
+activeRule :: SimplEnv -> Maybe (Activation -> Bool)
+-- Nothing => No rules at all
+activeRule env
+ = case getMode env of
+ SimplGently -> Nothing -- No rules in gentle mode
+ SimplPhase n -> Just (isActive n)
+\end{code}
-setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
-setSubstEnv subst_env m env us sc = m (env {seSubst = subst_env}) us sc
-extendIdSubst :: Id -> SubstCoreExpr -> SimplM a -> SimplM a
-extendIdSubst id expr m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc
- = m (env { seSubst = (ty_subst, extendVarEnv id_subst id expr) }) us sc
+%************************************************************************
+%* *
+\subsubsection{Command-line switches}
+%* *
+%************************************************************************
+
+\begin{code}
+getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
+getSimplIntSwitch chkr switch
+ = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-extendTySubst :: TyVar -> OutType -> SimplM a -> SimplM a
-extendTySubst tv ty m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc
- = m (env { seSubst = (extendVarEnv ty_subst tv ty, id_subst) }) us sc
+switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
-zapSubstEnv :: SimplM a -> SimplM a
-zapSubstEnv m env us sc = m (env {seSubst = emptySubstEnv}) us sc
+switchIsOn lookup_fn switch
+ = case (lookup_fn switch) of
+ SwBool False -> False
+ _ -> True
-getSimplBinderStuff :: SimplM (TyVarSubst, IdSubst, InScopeEnv, UniqSupply)
-getSimplBinderStuff (SimplEnv {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc
- = ((ty_subst, id_subst, in_scope, us), us, sc)
+intSwitchSet :: (switch -> SwitchResult)
+ -> (Int -> switch)
+ -> Maybe Int
-setSimplBinderStuff :: (TyVarSubst, IdSubst, InScopeEnv, UniqSupply)
- -> SimplM a -> SimplM a
-setSimplBinderStuff (ty_subst, id_subst, in_scope, us) m env _ sc
- = m (env {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc
+intSwitchSet lookup_fn switch
+ = case (lookup_fn (switch (panic "intSwitchSet"))) of
+ SwInt int -> Just int
+ _ -> Nothing
\end{code}
\begin{code}
-newId :: Type -> (Id -> SimplM a) -> SimplM a
- -- Extends the in-scope-env too
-newId ty m env@(SimplEnv {seInScope = in_scope}) us sc
- = case splitUniqSupply us of
- (us1, us2) -> m v (env {seInScope = extendVarSet in_scope v}) us2 sc
- where
- v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
-
-newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
-newIds tys m env@(SimplEnv {seInScope = in_scope}) us sc
- = case splitUniqSupply us of
- (us1, us2) -> m vs (env {seInScope = foldl extendVarSet in_scope vs}) us2 sc
- where
- vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
- (uniqsFromSupply (length tys) us1) tys
+type SwitchChecker = SimplifierSwitch -> SwitchResult
+
+data SwitchResult
+ = SwBool Bool -- on/off
+ | SwString FAST_STRING -- nothing or a String
+ | SwInt Int -- nothing or an Int
+
+isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
+isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
+ -- in the list; defaults right at the end.
+ = let
+ tidied_on_switches = foldl rm_dups [] on_switches
+ -- The fold*l* ensures that we keep the latest switches;
+ -- ie the ones that occur earliest in the list.
+
+ sw_tbl :: Array Int SwitchResult
+ sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
+ all_undefined)
+ // defined_elems
+
+ all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
+
+ defined_elems = map mk_assoc_elem tidied_on_switches
+ in
+ -- (avoid some unboxing, bounds checking, and other horrible things:)
+#if __GLASGOW_HASKELL__ < 405
+ case sw_tbl of { Array bounds_who_needs_'em stuff ->
+#else
+ case sw_tbl of { Array _ _ stuff ->
+#endif
+ \ switch ->
+ case (indexArray# stuff (tagOf_SimplSwitch switch)) of
+#if __GLASGOW_HASKELL__ < 400
+ Lift v -> v
+#elif __GLASGOW_HASKELL__ < 403
+ (# _, v #) -> v
+#else
+ (# v #) -> v
+#endif
+ }
+ where
+ mk_assoc_elem k@(MaxSimplifierIterations lvl)
+ = (iBox (tagOf_SimplSwitch k), SwInt lvl)
+ mk_assoc_elem k
+ = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
+
+ -- cannot have duplicates if we are going to use the array thing
+ rm_dups switches_so_far switch
+ = if switch `is_elem` switches_so_far
+ then switches_so_far
+ else switch : switches_so_far
+ where
+ sw `is_elem` [] = False
+ sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
+ || sw `is_elem` ss
+\end{code}
+
+These things behave just like enumeration types.
+
+\begin{code}
+instance Eq SimplifierSwitch where
+ a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
+
+instance Ord SimplifierSwitch where
+ a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
+ a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
+
+
+tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
+tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
+
+-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
+
+lAST_SIMPL_SWITCH_TAG = 2
\end{code}
projects / ghc-hetmet.git / blobdiff