Fix simplifier stuff.
#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 )
\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
#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 )
%************************************************************************
\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'
}
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import CoreUtils ( exprIsValue, exprIsDupable )
import CoreLint ( beginPass, endPass )
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'
}
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
%************************************************************************
\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
#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 )
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
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
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 )
%************************************************************************
\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)
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
-> [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}
%* *
%************************************************************************
-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))
\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
--
-- 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...
%************************************************************************
\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)
-- 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
-- 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
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 [] ;
SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
+ getDOptsSmpl,
-- The inlining black-list
setBlackList, getBlackList, noInlineBlackList,
)
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 )
(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)
\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)
{-# 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}
\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}
\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
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
\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
\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.
\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}
-- 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
-setSubst subst m env us sc = m (env {seSubst = subst}) us sc
+setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc
getSubstEnv :: SimplM SubstEnv
-getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
+getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc)
addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
-- The new Ids are guaranteed to be freshly allocated
-addNewInScopeIds vs m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
+addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
getInScope :: SimplM InScopeSet
-getInScope env us sc = (substInScope (seSubst env), us, sc)
+getInScope dflags env us sc = (substInScope (seSubst env), us, sc)
setInScope :: InScopeSet -> SimplM a -> SimplM a
-setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
+setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc
modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
-modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
+modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc
extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
-extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
- = m (env { seSubst = Subst.extendSubst subst var res }) us sc
+extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env { seSubst = Subst.extendSubst subst var res }) us sc
extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
-extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
- = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
+extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
-setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
+setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc
zapSubstEnv :: SimplM a -> SimplM a
-zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
+zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc
getSimplBinderStuff :: SimplM (Subst, UniqSupply)
-getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
+getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc
= ((subst, us), us, sc)
setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
-setSimplBinderStuff (subst, us) m env _ sc
- = m (env {seSubst = subst}) us sc
+setSimplBinderStuff (subst, us) m dflags env _ sc
+ = m dflags (env {seSubst = subst}) us sc
\end{code}
\begin{code}
newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
-- Extends the in-scope-env too
-newId fs ty m env@(SimplEnv {seSubst = subst}) us sc
+newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m v (env {seSubst = Subst.extendNewInScope subst v}) us2 sc
+ (us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v})
+ us2 sc
where
v = mkSysLocal fs (uniqFromSupply us1) ty
newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
-newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc
+newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m vs (env {seSubst = Subst.extendNewInScopeList subst vs}) us2 sc
+ (us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs})
+ us2 sc
where
vs = zipWithEqual "newIds" (mkSysLocal fs)
(uniqsFromSupply (length tys) us1) tys
= getBlackList `thenSmpl` \ black_list_fn ->
getInScope `thenSmpl` \ in_scope ->
getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) ->
+ getDOptsSmpl `thenSmpl` \ dflags ->
let
black_listed = black_list_fn var
arg_infos = [ interestingArg in_scope arg subst
inline_cont | inline_call = discardInline cont
| otherwise = cont
- maybe_inline = callSiteInline black_listed inline_call occ
+ maybe_inline = callSiteInline dflags black_listed inline_call occ
var arg_infos interesting_cont
in
-- First, look for an inlining
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec, opt_D_dump_rules )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal,
idSpecialisation, setIdNoDiscard, isExportedId,
modifyIdInfo, idUnfolding
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
import Maybes ( MaybeErr(..), catMaybes, maybeToBool )
-import ErrUtils ( dumpIfSet )
+import ErrUtils ( dumpIfSet_dyn )
import Bag
import List ( partition )
import Util ( zipEqual, zipWithEqual, mapAccumL )
%************************************************************************
\begin{code}
-specProgram :: UniqSupply -> [CoreBind] -> IO [CoreBind]
-specProgram us binds
+specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
+specProgram dflags us binds
= do
- beginPass "Specialise"
+ beginPass dflags "Specialise"
let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
returnSM (dumpAllDictBinds uds' binds'))
- endPass "Specialise" (opt_D_dump_spec || opt_D_verbose_core2core) binds'
+ endPass dflags "Specialise"
+ (dopt Opt_D_dump_spec dflags
+ || dopt Opt_D_verbose_core2core dflags) binds'
- dumpIfSet opt_D_dump_rules "Top-level specialisations"
+ dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
(vcat (map dump_specs (concat (map bindersOf binds'))))
return binds'
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_stranal, opt_D_dump_simpl_stats, opt_D_verbose_core2core )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import Id ( setIdStrictness, setInlinePragma,
idDemandInfo, setIdDemandInfo, isBottomingId,
)
import IdInfo ( neverInlinePrag )
import CoreLint ( beginPass, endPass )
-import ErrUtils ( dumpIfSet )
+import ErrUtils ( dumpIfSet_dyn )
import SaAbsInt
import SaLib
import Demand ( Demand, wwStrict, isStrict, isLazy )
import Util ( zipWith3Equal, stretchZipWith )
import Outputable
+import FastTypes
\end{code}
%************************************************************************
strict workers.
\begin{code}
-saBinds ::[CoreBind]
- -> IO [CoreBind]
+saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
-saBinds binds
+saBinds dflags binds
= do {
- beginPass "Strictness analysis";
+ beginPass dflags "Strictness analysis";
-- Mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
- dumpIfSet opt_D_dump_simpl_stats "Strictness analysis statistics"
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics"
(pp_stats sa_stats);
#else
let { binds_w_strictness = saTopBindsBinds binds };
#endif
- endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds_w_strictness
+ endPass dflags "Strictness analysis"
+ (dopt Opt_D_dump_stranal dflags || dopt Opt_D_verbose_core2core dflags)
+ binds_w_strictness
}
\end{code}
FastInt FastInt -- total/marked-demanded let-bound
-- (excl. top-level; excl. letrecs)
-nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0)
+nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0)
thenSa :: SaM a -> (a -> SaM b) -> SaM b
thenSa_ :: SaM a -> SaM b -> SaM b
returnSa x stats = (x, stats)
tickLambda var (SaStats tlam dlam tc dc tlet dlet)
- = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
+ = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
+ let tot = iUnbox totB ; demanded = iUnbox demandedB
+ in
((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) }
tickCases vars (SaStats tlam dlam tc dc tlet dlet)
- = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
+ = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) ->
+ let tot = iUnbox totB ; demanded = iUnbox demandedB
+ in
((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) }
tickLet var (SaStats tlam dlam tc dc tlet dlet)
- = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) ->
+ = case (tick_demanded var (0,0)) of { (totB, demandedB) ->
+ let tot = iUnbox totB ; demanded = iUnbox demandedB
+ in
((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) }
tick_demanded var (tot, demanded)
else demanded)
pp_stats (SaStats tlam dlam tc dc tlet dlet)
- = hcat [ptext SLIT("Lambda vars: "), int IBOX(dlam), char '/', int IBOX(tlam),
- ptext SLIT("; Case vars: "), int IBOX(dc), char '/', int IBOX(tc),
- ptext SLIT("; Let vars: "), int IBOX(dlet), char '/', int IBOX(tlet)
+ = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam),
+ ptext SLIT("; Case vars: "), int (iBox dc), char '/', int (iBox tc),
+ ptext SLIT("; Let vars: "), int (iBox dlet), char '/', int (iBox tlet)
]
#else {-OMIT_STRANAL_STATS-}
import Outputable
import Maybes ( expectJust )
import List ( unzip4 )
-import CmdLineOpts ( opt_D_dump_usagesp, opt_DoUSPLinting, opt_UsageSPOn )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_UsageSPOn )
import CoreLint ( beginPass, endPass )
-import ErrUtils ( doIfSet, dumpIfSet )
+import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn )
import PprCore ( pprCoreBindings )
\end{code}
monad.
\begin{code}
-doUsageSPInf :: UniqSupply
+doUsageSPInf :: DynFlags
+ -> UniqSupply
-> [CoreBind]
-> RuleBase
-> IO [CoreBind]
-doUsageSPInf us binds local_rules
+doUsageSPInf dflags us binds local_rules
| not opt_UsageSPOn
= do { printErrs (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ;
return binds
= do
let binds1 = doUnAnnotBinds binds
- beginPass "UsageSPInf"
+ beginPass dflags "UsageSPInf"
- dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $
+ dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf unannot'd" $
pprCoreBindings binds1
let ((binds2,ucs,_),_) = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
- dumpIfSet opt_D_dump_usagesp "UsageSPInf annot'd" $
+ dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf annot'd" $
pprCoreBindings binds2
let ms = solveUCS ucs
Nothing -> panic "doUsageSPInf: insol. conset!"
binds3 = appUSubstBinds s binds2
- doIfSet opt_DoUSPLinting $
+ doIfSet_dyn dflags Opt_DoUSPLinting $
do doLintUSPAnnotsBinds binds3 -- lint check 1
doLintUSPConstBinds binds3 -- lint check 2 (force solution)
doCheckIfWorseUSP binds binds3 -- check for worsening of usages
- endPass "UsageSPInf" opt_D_dump_usagesp binds3
+ endPass dflags "UsageSPInf" (dopt Opt_D_dump_usagesp dflags) binds3
return binds3
\end{code}
projects / ghc-hetmet.git / commitdiff