Commit 9aa6d18b authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-19 10:06:46 by sewardj]

Fix simplifier stuff.
parent 9bb6b6d0
......@@ -6,7 +6,7 @@ module CprAnalyse ( cprAnalyse ) where
#include "HsVersions.h"
import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_cpranal )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CoreLint ( beginPass, endPass )
import CoreSyn
import CoreUtils ( exprIsValue )
......@@ -134,14 +134,13 @@ ids decorated with their CprInfo pragmas.
\begin{code}
cprAnalyse :: [CoreBind]
-> IO [CoreBind]
cprAnalyse binds
cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
cprAnalyse dflags binds
= do {
beginPass "Constructed Product analysis" ;
beginPass dflags "Constructed Product analysis" ;
let { binds_plus_cpr = do_prog binds } ;
endPass "Constructed Product analysis"
(opt_D_dump_cpranal || opt_D_verbose_core2core)
endPass dflags "Constructed Product analysis"
(dopt Opt_D_dump_cpranal dflags || dopt Opt_D_verbose_core2core dflags)
binds_plus_cpr
}
where
......
......@@ -10,12 +10,13 @@ module CSE (
#include "HsVersions.h"
import CmdLineOpts ( opt_D_dump_cse, opt_D_verbose_core2core )
import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import Id ( Id, idType )
import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
import DataCon ( isUnboxedTupleCon )
import Type ( splitTyConApp_maybe )
import Subst ( InScopeSet, uniqAway, emptyInScopeSet, extendInScopeSet, elemInScopeSet )
import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
extendInScopeSet, elemInScopeSet )
import CoreSyn
import VarEnv
import CoreLint ( beginPass, endPass )
......@@ -102,14 +103,14 @@ to the substitution
%************************************************************************
\begin{code}
cseProgram :: [CoreBind] -> IO [CoreBind]
cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
cseProgram binds
cseProgram dflags binds
= do {
beginPass "Common sub-expression";
beginPass dflags "Common sub-expression";
let { binds' = cseBinds emptyCSEnv binds };
endPass "Common sub-expression"
(opt_D_dump_cse || opt_D_verbose_core2core)
endPass dflags "Common sub-expression"
(dopt Opt_D_dump_cse dflags || dopt Opt_D_verbose_core2core dflags)
binds'
}
......
......@@ -16,7 +16,7 @@ module FloatIn ( floatInwards ) where
#include "HsVersions.h"
import CmdLineOpts ( opt_D_verbose_core2core )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import CoreUtils ( exprIsValue, exprIsDupable )
import CoreLint ( beginPass, endPass )
......@@ -33,14 +33,15 @@ Top-level interface function, @floatInwards@. Note that we do not
actually float any bindings downwards from the top-level.
\begin{code}
floatInwards :: [CoreBind] -> IO [CoreBind]
floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
floatInwards binds
floatInwards dflags binds
= do {
beginPass "Float inwards";
beginPass dflags "Float inwards";
let { binds' = map fi_top_bind binds };
endPass "Float inwards"
opt_D_verbose_core2core {- no specific flag for dumping float-in -}
endPass dflags "Float inwards"
(dopt Opt_D_verbose_core2core dflags)
{- no specific flag for dumping float-in -}
binds'
}
......
......@@ -13,8 +13,8 @@ module FloatOut ( floatOutwards ) where
import CoreSyn
import CoreUtils ( mkSCC )
import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_stats )
import ErrUtils ( dumpIfSet )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import ErrUtils ( dumpIfSet_dyn )
import CostCentre ( dupifyCC, CostCentre )
import Id ( Id, idType )
import VarEnv
......@@ -75,30 +75,32 @@ type FloatBinds = [FloatBind]
%************************************************************************
\begin{code}
floatOutwards :: Bool -- True <=> float lambdas to top level
floatOutwards :: DynFlags
-> Bool -- True <=> float lambdas to top level
-> UniqSupply
-> [CoreBind] -> IO [CoreBind]
floatOutwards float_lams us pgm
floatOutwards dflags float_lams us pgm
= do {
beginPass float_msg ;
beginPass dflags float_msg ;
let { annotated_w_levels = setLevels float_lams pgm us ;
(fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
} ;
dumpIfSet opt_D_verbose_core2core "Levels added:"
dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
(vcat (map ppr annotated_w_levels));
let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
dumpIfSet opt_D_dump_simpl_stats "FloatOut stats:"
dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
(hcat [ int tlets, ptext SLIT(" Lets floated to top level; "),
int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
int lams, ptext SLIT(" Lambda groups")]);
endPass float_msg
opt_D_verbose_core2core {- no specific flag for dumping float-out -}
endPass dflags float_msg
(dopt Opt_D_verbose_core2core dflags)
{- no specific flag for dumping float-out -}
(concat binds_s')
}
where
......
......@@ -8,7 +8,7 @@ module LiberateCase ( liberateCase ) where
#include "HsVersions.h"
import CmdLineOpts ( opt_D_verbose_core2core, opt_LiberateCaseThreshold )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_LiberateCaseThreshold )
import CoreLint ( beginPass, endPass )
import CoreSyn
import CoreUnfold ( couldBeSmallEnoughToInline )
......@@ -148,13 +148,14 @@ bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
Programs
~~~~~~~~
\begin{code}
liberateCase :: [CoreBind] -> IO [CoreBind]
liberateCase binds
liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind]
liberateCase dflags binds
= do {
beginPass "Liberate case" ;
beginPass dflags "Liberate case" ;
let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
endPass "Liberate case"
opt_D_verbose_core2core {- no specific flag for dumping -}
endPass dflags "Liberate case"
(dopt Opt_D_verbose_core2core dflags)
{- no specific flag for dumping -}
binds'
}
where
......
......@@ -10,13 +10,8 @@ module SimplCore ( core2core ) where
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
SwitchResult(..), intSwitchSet,
opt_D_dump_occur_anal, opt_D_dump_rules,
opt_D_dump_simpl_iterations,
opt_D_dump_simpl_stats,
opt_D_dump_rules,
opt_D_verbose_core2core,
opt_D_dump_occur_anal,
opt_UsageSPOn
opt_UsageSPOn,
DynFlags, DynFlag(..), dopt
)
import CoreLint ( beginPass, endPass )
import CoreSyn
......@@ -30,7 +25,7 @@ import CoreUtils ( exprIsTrivial, etaReduceExpr, coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplBinders )
import SimplMonad
import ErrUtils ( dumpIfSet )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import Id ( isDataConWrapId )
......@@ -57,29 +52,30 @@ import List ( partition )
%************************************************************************
\begin{code}
core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
core2core :: DynFlags
-> [CoreToDo] -- Spec of what core-to-core passes to do
-> [CoreBind] -- Binds in
-> [ProtoCoreRule] -- Rules in
-> IO ([CoreBind], RuleBase) -- binds, local orphan rules out
core2core core_todos binds rules
core2core dflags core_todos binds rules
= do
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
let (local_rules, imported_rules) = partition localRule rules
better_local_rules <- simplRules ru_us local_rules binds
better_local_rules <- simplRules dflags ru_us local_rules binds
let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules
imported_rule_base = prepareOrphanRuleBase imported_rules
-- Do the main business
(stats, processed_binds, processed_local_rules)
<- doCorePasses zeroSimplCount cp_us binds1 local_rule_base
<- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 local_rule_base
imported_rule_base Nothing core_todos
dumpIfSet opt_D_dump_simpl_stats
dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
(pprSimplCount stats)
......@@ -88,7 +84,8 @@ core2core core_todos binds rules
return (processed_binds, processed_local_rules)
doCorePasses :: SimplCount -- simplifier stats
doCorePasses :: DynFlags
-> SimplCount -- simplifier stats
-> UniqSupply -- uniques
-> [CoreBind] -- local binds in (with rules attached)
-> RuleBase -- local orphan rules
......@@ -97,43 +94,56 @@ doCorePasses :: SimplCount -- simplifier stats
-> [CoreToDo] -- which passes to do
-> IO (SimplCount, [CoreBind], RuleBase) -- stats, binds, local orphan rules
doCorePasses stats us binds lrb irb rb0 []
doCorePasses dflags stats us binds lrb irb rb0 []
= return (stats, binds, lrb)
doCorePasses stats us binds lrb irb rb0 (to_do : to_dos)
doCorePasses dflags stats us binds lrb irb rb0 (to_do : to_dos)
= do
let (us1, us2) = splitUniqSupply us
-- recompute rulebase if necessary
let rb = maybe (irb `unionRuleBase` lrb) id rb0
(stats1, binds1, mlrb1) <- doCorePass us1 binds lrb rb to_do
(stats1, binds1, mlrb1) <- doCorePass dflags us1 binds lrb rb to_do
-- request rulebase recomputation if pass returned a new local rulebase
let (lrb1,rb1) = maybe (lrb, Just rb) (\ lrb1 -> (lrb1, Nothing)) mlrb1
doCorePasses (stats `plusSimplCount` stats1) us2 binds1 lrb1 irb rb1 to_dos
doCorePass us binds lrb rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
doCorePass us binds lrb rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
doCorePass us binds lrb rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
doCorePass us binds lrb rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
doCorePass us binds lrb rb (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" noStats (floatOutwards f us binds)
doCorePass us binds lrb rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
doCorePass us binds lrb rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
doCorePass us binds lrb rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
doCorePass us binds lrb rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
doCorePass us binds lrb rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
doCorePass us binds lrb rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
doCorePass us binds lrb rb CoreDoGlomBinds = noStats (glomBinds binds)
doCorePass us binds lrb rb CoreDoUSPInf = _scc_ "CoreUsageSPInf" noStats (doUsageSPInf us binds lrb)
doCorePasses dflags (stats `plusSimplCount` stats1) us2 binds1 lrb1 irb rb1 to_dos
doCorePass dfs us binds lrb rb (CoreDoSimplify sw_chkr)
= _scc_ "Simplify" simplifyPgm dfs rb sw_chkr us binds
doCorePass dfs us binds lrb rb CoreCSE
= _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
doCorePass dfs us binds lrb rb CoreLiberateCase
= _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
doCorePass dfs us binds lrb rb CoreDoFloatInwards
= _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
doCorePass dfs us binds lrb rb (CoreDoFloatOutwards f)
= _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
doCorePass dfs us binds lrb rb CoreDoStaticArgs
= _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
doCorePass dfs us binds lrb rb CoreDoStrictness
= _scc_ "Stranal" noStats dfs (saBinds dfs binds)
doCorePass dfs us binds lrb rb CoreDoWorkerWrapper
= _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
doCorePass dfs us binds lrb rb CoreDoSpecialising
= _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
doCorePass dfs us binds lrb rb CoreDoCPResult
= _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
doCorePass dfs us binds lrb rb CoreDoPrintCore
= _scc_ "PrintCore" noStats dfs (printCore binds)
doCorePass dfs us binds lrb rb CoreDoUSPInf
= _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds lrb)
doCorePass dfs us binds lrb rb CoreDoGlomBinds
= noStats dfs (glomBinds dfs binds)
printCore binds = do dumpIfSet True "Print Core"
(pprCoreBindings binds)
return binds
-- most passes return no stats and don't change rules
noStats thing = do { binds <- thing; return (zeroSimplCount, binds, Nothing) }
noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds, Nothing) }
\end{code}
......@@ -144,18 +154,21 @@ noStats thing = do { binds <- thing; return (zeroSimplCount, binds, Nothing) }
%* *
%************************************************************************
We must do some gentle simplifiation on the template (but not the RHS)
We must do some gentle simplification on the template (but not the RHS)
of each rule. The case that forced me to add this was the fold/build rule,
which without simplification looked like:
fold k z (build (/\a. g a)) ==> ...
This doesn't match unless you do eta reduction on the build argument.
\begin{code}
simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
simplRules us rules binds
= do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
simplRules :: DynFlags -> UniqSupply -> [ProtoCoreRule] -> [CoreBind]
-> IO [ProtoCoreRule]
simplRules dflags us rules binds
= do let (better_rules,_)
= initSmpl dflags sw_chkr us bind_vars black_list_all
(mapSmpl simplRule rules)
dumpIfSet opt_D_dump_rules
dumpIfSet_dyn dflags Opt_D_dump_rules
"Transformation rules"
(vcat (map pprProtoCoreRule better_rules))
......@@ -197,7 +210,7 @@ simpl_arg e
\end{code}
\begin{code}
glomBinds :: [CoreBind] -> IO [CoreBind]
glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
-- Glom all binds together in one Rec, in case any
-- transformations have introduced any new dependencies
--
......@@ -223,8 +236,8 @@ glomBinds :: [CoreBind] -> IO [CoreBind]
-- by prepareLocalRuleBase and h would be regarded by the occurrency
-- analyser as free in f.
glomBinds binds
= do { beginPass "GlomBinds" ;
glomBinds dflags binds
= do { beginPass dflags "GlomBinds" ;
let { recd_binds = [Rec (flattenBinds binds)] } ;
return recd_binds }
-- Not much point in printing the result...
......@@ -238,27 +251,31 @@ glomBinds binds
%************************************************************************
\begin{code}
simplifyPgm :: RuleBase
simplifyPgm :: DynFlags
-> RuleBase
-> (SimplifierSwitch -> SwitchResult)
-> UniqSupply
-> [CoreBind] -- Input
-> IO (SimplCount, [CoreBind], Maybe RuleBase) -- New bindings
simplifyPgm (imported_rule_ids, rule_lhs_fvs)
simplifyPgm dflags (imported_rule_ids, rule_lhs_fvs)
sw_chkr us binds
= do {
beginPass "Simplify";
beginPass dflags "Simplify";
(termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount binds;
(termination_msg, it_count, counts_out, binds')
<- iteration us 1 (zeroSimplCount dflags) binds;
dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
dumpIfSet (dopt Opt_D_verbose_core2core dflags
&& dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics"
(vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
text "",
pprSimplCount counts_out]);
endPass "Simplify"
(opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
endPass dflags "Simplify"
(dopt Opt_D_verbose_core2core dflags
&& not (dopt Opt_D_dump_simpl_iterations dflags))
binds' ;
return (counts_out, binds', Nothing)
......@@ -275,7 +292,7 @@ simplifyPgm (imported_rule_ids, rule_lhs_fvs)
-- Occurrence analysis
let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
-- SIMPLIFY
......@@ -289,7 +306,7 @@ simplifyPgm (imported_rule_ids, rule_lhs_fvs)
-- case t of {(_,counts') -> if counts'=0 then ...
-- So the conditional didn't force counts', because the
-- selection got duplicated. Sigh!
case initSmpl sw_chkr us1 imported_rule_ids black_list_fn
case initSmpl dflags sw_chkr us1 imported_rule_ids black_list_fn
(simplTopBinds tagged_binds)
of { (binds', counts') -> do {
-- The imported_rule_ids are used by initSmpl to initialise
......@@ -305,14 +322,15 @@ simplifyPgm (imported_rule_ids, rule_lhs_fvs)
else do {
-- Dump the result of this iteration
dumpIfSet opt_D_dump_simpl_iterations
dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations
("Simplifier iteration " ++ show iteration_no
++ " out of " ++ show max_iterations)
(pprSimplCount counts') ;
if opt_D_dump_simpl_iterations then
endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
opt_D_verbose_core2core
if dopt Opt_D_dump_simpl_iterations dflags then
endPass dflags
("Simplifier iteration " ++ show iteration_no ++ " result")
(dopt Opt_D_verbose_core2core dflags)
binds'
else
return [] ;
......
......@@ -13,6 +13,7 @@ module SimplMonad (
SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
getDOptsSmpl,
-- The inlining black-list
setBlackList, getBlackList, noInlineBlackList,
......@@ -68,7 +69,8 @@ import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
)
import FiniteMap
import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
opt_PprStyle_Debug, opt_HistorySize, opt_D_dump_simpl_stats,
DynFlags, DynFlag(..), dopt,
opt_PprStyle_Debug, opt_HistorySize,
intSwitchSet
)
import Unique ( Unique )
......@@ -161,9 +163,10 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter.
(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
-> SimplEnv -- We thread the unique supply because
-> UniqSupply -- constantly splitting it is rather expensive
-> SimplCount
-> (result, UniqSupply, SimplCount)
......@@ -195,15 +198,17 @@ data SimplEnv
\end{code}
\begin{code}
initSmpl :: SwitchChecker
initSmpl :: DynFlags
-> SwitchChecker
-> UniqSupply -- No init count; set to 0
-> VarSet -- In scope (usually empty, but useful for nested calls)
-> BlackList -- Black-list function
-> SimplM a
-> (a, SimplCount)
initSmpl chkr us in_scope black_list m
= case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
initSmpl dflags chkr us in_scope black_list m
= case m dflags (emptySimplEnv chkr in_scope black_list) us
(zeroSimplCount dflags) of
(result, _, count) -> (result, count)
......@@ -212,18 +217,18 @@ initSmpl chkr us in_scope black_list m
{-# INLINE returnSmpl #-}
returnSmpl :: a -> SimplM a
returnSmpl e env us sc = (e, us, sc)
returnSmpl e dflags env 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 env us0 sc0
= case (m dflags env us0 sc0) of
(m_result, us1, sc1) -> k m_result dflags env us1 sc1
thenSmpl_ m k env us0 sc0
= case (m env us0 sc0) of
(_, us1, sc1) -> k env us1 sc1
thenSmpl_ m k dflags env us0 sc0
= case (m dflags env us0 sc0) of
(_, us1, sc1) -> k dflags env us1 sc1
\end{code}
......@@ -258,12 +263,18 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
\begin{code}
getUniqueSmpl :: SimplM Unique
getUniqueSmpl env us sc = case splitUniqSupply us of
(us1, us2) -> (uniqFromSupply us1, us2, sc)
getUniqueSmpl dflags env us sc
= case splitUniqSupply us of
(us1, us2) -> (uniqFromSupply us1, us2, sc)
getUniquesSmpl :: Int -> SimplM [Unique]
getUniquesSmpl n env us sc = case splitUniqSupply us of
(us1, us2) -> (uniqsFromSupply n us1, us2, sc)
getUniquesSmpl n dflags env us sc
= case splitUniqSupply us of
(us1, us2) -> (uniqsFromSupply n us1, us2, sc)
getDOptsSmpl :: SimplM DynFlags
getDOptsSmpl dflags env us sc
= (dflags, us, sc)
\end{code}
......@@ -275,25 +286,27 @@ getUniquesSmpl n env us sc = case splitUniqSupply us of
\begin{code}
getSimplCount :: SimplM SimplCount
getSimplCount env us sc = (sc, us, sc)
getSimplCount dflags env us sc = (sc, us, sc)
tick :: Tick -> SimplM ()
tick t env us sc = sc' `seq` ((), us, sc')
where
sc' = doTick t sc
tick t dflags env 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 env us sc = sc' `seq` ((), us, sc')
where
sc' = doFreeTick t sc
freeTick t dflags env us sc
= sc' `seq` ((), us, sc')
where
sc' = doFreeTick t sc
\end{code}
\begin{code}
verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
zeroSimplCount :: SimplCount
zeroSimplCount :: DynFlags -> SimplCount
isZeroSimplCount :: SimplCount -> Bool
pprSimplCount :: SimplCount -> SDoc
doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
......@@ -315,11 +328,14 @@ data SimplCount = VerySimplZero -- These two are used when
type TickCounts = FiniteMap Tick Int
zeroSimplCount -- This is where we decide whether to do
zeroSimplCount dflags
-- This is where we decide whether to do
-- the VerySimpl version or the full-stats version
| opt_D_dump_simpl_stats = SimplCount {ticks = 0, details = emptyFM,
n_log = 0, log1 = [], log2 = []}
| otherwise = VerySimplZero
| dopt Opt_D_dump_simpl_stats dflags
= SimplCount {ticks = 0, details = emptyFM,
n_log = 0, log1 = [], log2 = []}
| otherwise
= VerySimplZero
isZeroSimplCount VerySimplZero = True
isZeroSimplCount (SimplCount { ticks = 0 }) = True
......@@ -531,7 +547,7 @@ cmpEqTick other1 other2 = EQ
\begin{code}
getSwitchChecker :: SimplM SwitchChecker
getSwitchChecker env us sc = (seChkr env, us, sc)
getSwitchChecker dflags env us sc = (seChkr env, us, sc)
getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
getSimplIntSwitch chkr switch
......@@ -592,10 +608,11 @@ knowing when something is evaluated.
\begin{code}
setBlackList :: BlackList -> SimplM a -> SimplM a
setBlackList black_list m env us sc = m (env { seBlackList = black_list }) us sc
setBlackList black_list m dflags env us sc
= m dflags (env { seBlackList = black_list }) us sc
getBlackList :: SimplM BlackList
getBlackList env us sc = (seBlackList env, us, sc)
getBlackList dflags env us sc = (seBlackList env, us, sc)
noInlineBlackList :: BlackList
-- Inside inlinings, black list anything that is in scope or imported.
......@@ -620,10 +637,10 @@ noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
\begin{code}
getEnclosingCC :: SimplM CostCentreStack
getEnclosingCC env us sc = (seCC env, us, sc)
getEnclosingCC dflags env us sc = (seCC env, us, sc)
setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc
\end{code}
......@@ -644,77 +661,80 @@ emptySimplEnv sw_chkr in_scope black_list
-- The top level "enclosing CC" is "SUBSUMED".
getEnv :: SimplM SimplEnv
getEnv env us sc = (env, us, sc)
getEnv dflags env us sc = (env, us, sc)
setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m
setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags
(SimplEnv {seSubst = old_subst}) us sc
= m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
= m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)})
us sc
getSubst :: SimplM Subst
getSubst env us sc = (seSubst env, us, sc)
getSubst dflags env us sc = (seSubst env, us, sc)
setSubst :: Subst -> SimplM a -> SimplM a