summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/DynFlags.hs3
-rw-r--r--compiler/simplCore/CoreMonad.lhs44
-rw-r--r--compiler/simplCore/SimplCore.lhs10
-rw-r--r--compiler/simplCore/SimplMonad.lhs341
-rw-r--r--compiler/simplCore/Simplify.lhs4
5 files changed, 223 insertions, 179 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 105c5920d1..5e2f25a4d5 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -444,6 +444,7 @@ data DynFlags = DynFlags {
ruleCheck :: Maybe String,
strictnessBefore :: [Int], -- ^ Additional demand analysis
+ simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks
specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr
specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function
liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase
@@ -800,6 +801,7 @@ defaultDynFlags mySettings =
maxSimplIterations = 4,
shouldDumpSimplPhase = Nothing,
ruleCheck = Nothing,
+ simplTickFactor = 100,
specConstrThreshold = Just 2000,
specConstrCount = Just 3,
liberateCaseThreshold = Just 2000,
@@ -1545,6 +1547,7 @@ dynamic_flags = [
, flagA "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n }))
, flagA "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n }))
+ , flagA "fsimpl-tick-factor" (intSuffix (\n d -> d{ simplTickFactor = n }))
, flagA "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n }))
, flagA "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing }))
, flagA "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n }))
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 8b4b4e382e..df515d1d52 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -19,7 +19,8 @@ module CoreMonad (
-- * Counting
SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
- pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
+ pprSimplCount, plusSimplCount, zeroSimplCount,
+ isZeroSimplCount, hasDetailedCounts, Tick(..),
-- * The monad
CoreM, runCoreM,
@@ -87,7 +88,8 @@ import UniqSupply
import UniqFM ( UniqFM, mapUFM, filterUFM )
import MonadUtils
-import Util ( split )
+import Util ( split, sortLe )
+import ListSetOps ( runs )
import Data.List ( intersperse )
import Data.Dynamic
import Data.IORef
@@ -461,6 +463,7 @@ verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
zeroSimplCount :: DynFlags -> SimplCount
isZeroSimplCount :: SimplCount -> Bool
+hasDetailedCounts :: SimplCount -> Bool
pprSimplCount :: SimplCount -> SDoc
doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
plusSimplCount :: SimplCount -> SimplCount -> SimplCount
@@ -500,6 +503,9 @@ zeroSimplCount dflags
isZeroSimplCount (VerySimplCount n) = n==0
isZeroSimplCount (SimplCount { ticks = n }) = n==0
+hasDetailedCounts (VerySimplCount {}) = False
+hasDetailedCounts (SimplCount {}) = True
+
doFreeSimplTick tick sc@SimplCount { details = dts }
= sc { details = dts `addTick` tick }
doFreeSimplTick _ sc = sc
@@ -540,7 +546,7 @@ pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
= vcat [ptext (sLit "Total ticks: ") <+> int tks,
blankLine,
- pprTickCounts (Map.toList dts),
+ pprTickCounts dts,
if verboseSimplStats then
vcat [blankLine,
ptext (sLit "Log (most recent first)"),
@@ -548,23 +554,23 @@ pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = 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
- ]
+pprTickCounts :: Map Tick Int -> SDoc
+pprTickCounts counts
+ = vcat (map pprTickGroup groups)
+ where
+ groups :: [[(Tick,Int)]] -- Each group shares a comon tag
+ -- toList returns common tags adjacent
+ groups = runs same_tag (Map.toList counts)
+ same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
+
+pprTickGroup :: [(Tick, Int)] -> SDoc
+pprTickGroup group@((tick1,_):_)
+ = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
+ 2 (vcat [ int n <+> pprTickCts tick
+ | (tick,n) <- sortLe le group])
where
- 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 :: [(Tick, Int)] -> SDoc
-pprTCDetails ticks
- = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
+ le (_,n1) (_,n2) = n2 <= n1 -- We want largest first
+pprTickGroup [] = panic "pprTickGroup"
\end{code}
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 20425db8f6..3c89b0fa5d 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -18,7 +18,7 @@ import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo
-import CoreUtils ( coreBindsSize )
+import CoreUtils ( coreBindsSize, exprSize )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplEnvForGHCi, activeRule )
import SimplEnv
@@ -478,7 +478,8 @@ simplifyExpr dflags expr
; us <- mkSplitUniqSupply 's'
- ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+ ; let sz = exprSize expr
+ (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
simplExprGently (simplEnvForGHCi dflags) expr
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
@@ -581,7 +582,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
- | let sz = coreBindsSize binds in sz == sz
+ | let sz = coreBindsSize binds
+ , sz == sz -- Force it
= do {
-- Occurrence analysis
let { -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
@@ -620,7 +622,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- case t of {(_,counts1) -> if counts1=0 then ... }
-- So the conditional didn't force counts1, because the
-- selection got duplicated. Sigh!
- case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
+ case initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds of {
(env1, counts1) -> do {
let { binds1 = getFloats env1
diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index 1781d56bfb..0b6aaac3df 100644
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -1,154 +1,187 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-\section[SimplMonad]{The simplifier Monad}
-
-\begin{code}
-module SimplMonad (
- -- The monad
- SimplM,
- initSmpl,
- getDOptsSmpl, getSimplRules, getFamEnvs,
-
- -- Unique supply
- MonadUnique(..), newId,
-
- -- Counting
- SimplCount, tick, freeTick,
- getSimplCount, zeroSimplCount, pprSimplCount,
- plusSimplCount, isZeroSimplCount
- ) where
-
-import Id ( Id, mkSysLocal )
-import Type ( Type )
-import FamInstEnv ( FamInstEnv )
-import Rules ( RuleBase )
-import UniqSupply
-import DynFlags ( DynFlags )
-import CoreMonad
-import FastString
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Monad plumbing}
-%* *
-%************************************************************************
-
-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}
-newtype SimplM result
- = SM { unSM :: SimplTopEnv -- Envt that does not change much
- -> UniqSupply -- We thread the unique supply because
- -- constantly splitting it is rather expensive
- -> SimplCount
- -> (result, UniqSupply, SimplCount)}
-
-data SimplTopEnv = STE { st_flags :: DynFlags
- , st_rules :: RuleBase
- , st_fams :: (FamInstEnv, FamInstEnv) }
-\end{code}
-
-\begin{code}
-initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
- -> UniqSupply -- No init count; set to 0
- -> SimplM a
- -> (a, SimplCount)
-
-initSmpl dflags rules fam_envs us m
- = case unSM m env us (zeroSimplCount dflags) of
- (result, _, count) -> (result, count)
- where
- env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
-
-{-# INLINE thenSmpl #-}
-{-# INLINE thenSmpl_ #-}
-{-# INLINE returnSmpl #-}
-
-instance Monad SimplM where
- (>>) = thenSmpl_
- (>>=) = thenSmpl
- return = returnSmpl
-
-returnSmpl :: a -> SimplM a
-returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
-
-thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
-thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
-
-thenSmpl m k
- = SM (\ st_env us0 sc0 ->
- case (unSM m st_env us0 sc0) of
- (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
-
-thenSmpl_ m k
- = SM (\st_env us0 sc0 ->
- case (unSM m st_env us0 sc0) of
- (_, us1, sc1) -> unSM k st_env us1 sc1)
-
--- TODO: this specializing is not allowed
--- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
--- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
--- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The unique supply}
-%* *
-%************************************************************************
-
-\begin{code}
-instance MonadUnique SimplM where
- getUniqueSupplyM
- = SM (\_st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (us1, us2, sc))
-
- getUniqueM
- = SM (\_st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (uniqFromSupply us1, us2, sc))
-
- getUniquesM
- = SM (\_st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (uniqsFromSupply us1, us2, sc))
-
-getDOptsSmpl :: SimplM DynFlags
-getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
-
-getSimplRules :: SimplM RuleBase
-getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
-
-getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
-getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
-
-newId :: FastString -> Type -> SimplM Id
-newId fs ty = do uniq <- getUniqueM
- return (mkSysLocal fs uniq ty)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Counting up what we've done}
-%* *
-%************************************************************************
-
-\begin{code}
-getSimplCount :: SimplM SimplCount
-getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
-
-tick :: Tick -> SimplM ()
-tick t
- = SM (\_st_env us sc -> let sc' = doSimplTick t sc
- in sc' `seq` ((), us, 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
- = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
- in sc' `seq` ((), us, sc'))
-\end{code}
+%
+% (c) The AQUA Project, Glasgow University, 1993-1998
+%
+\section[SimplMonad]{The simplifier Monad}
+
+\begin{code}
+module SimplMonad (
+ -- The monad
+ SimplM,
+ initSmpl,
+ getDOptsSmpl, getSimplRules, getFamEnvs,
+
+ -- Unique supply
+ MonadUnique(..), newId,
+
+ -- Counting
+ SimplCount, tick, freeTick, checkedTick,
+ getSimplCount, zeroSimplCount, pprSimplCount,
+ plusSimplCount, isZeroSimplCount
+ ) where
+
+import Id ( Id, mkSysLocal )
+import Type ( Type )
+import FamInstEnv ( FamInstEnv )
+import Rules ( RuleBase )
+import UniqSupply
+import DynFlags ( DynFlags( simplTickFactor ) )
+import CoreMonad
+import Outputable
+import FastString
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Monad plumbing}
+%* *
+%************************************************************************
+
+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}
+newtype SimplM result
+ = SM { unSM :: SimplTopEnv -- Envt that does not change much
+ -> UniqSupply -- We thread the unique supply because
+ -- constantly splitting it is rather expensive
+ -> SimplCount
+ -> (result, UniqSupply, SimplCount)}
+
+data SimplTopEnv
+ = STE { st_flags :: DynFlags
+ , st_max_ticks :: Int -- Max #ticks in this simplifier run
+ -- Zero means infinity!
+ , st_rules :: RuleBase
+ , st_fams :: (FamInstEnv, FamInstEnv) }
+\end{code}
+
+\begin{code}
+initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
+ -> UniqSupply -- No init count; set to 0
+ -> Int -- Size of the bindings
+ -> SimplM a
+ -> (a, SimplCount)
+
+initSmpl dflags rules fam_envs us size m
+ = case unSM m env us (zeroSimplCount dflags) of
+ (result, _, count) -> (result, count)
+ where
+ -- Compute the max simplifier ticks as
+ -- pgm-size * k * tick-factor/100
+ -- where k is a constant that gives reasonable results
+ max_ticks = fromInteger ((toInteger size * toInteger (simplTickFactor dflags * k))
+ `div` 100)
+ k = 20 -- MAGIC NUMBER, multiplies the simplTickFactor
+ -- We can afford to be generous; this is really
+ -- just checking for loops, and shouldn't usually fire
+
+ env = STE { st_flags = dflags, st_rules = rules
+ , st_max_ticks = max_ticks
+ , st_fams = fam_envs }
+
+{-# INLINE thenSmpl #-}
+{-# INLINE thenSmpl_ #-}
+{-# INLINE returnSmpl #-}
+
+instance Monad SimplM where
+ (>>) = thenSmpl_
+ (>>=) = thenSmpl
+ return = returnSmpl
+
+returnSmpl :: a -> SimplM a
+returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
+
+thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
+
+thenSmpl m k
+ = SM (\ st_env us0 sc0 ->
+ case (unSM m st_env us0 sc0) of
+ (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
+
+thenSmpl_ m k
+ = SM (\st_env us0 sc0 ->
+ case (unSM m st_env us0 sc0) of
+ (_, us1, sc1) -> unSM k st_env us1 sc1)
+
+-- TODO: this specializing is not allowed
+-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
+-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
+-- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The unique supply}
+%* *
+%************************************************************************
+
+\begin{code}
+instance MonadUnique SimplM where
+ getUniqueSupplyM
+ = SM (\_st_env us sc -> case splitUniqSupply us of
+ (us1, us2) -> (us1, us2, sc))
+
+ getUniqueM
+ = SM (\_st_env us sc -> case splitUniqSupply us of
+ (us1, us2) -> (uniqFromSupply us1, us2, sc))
+
+ getUniquesM
+ = SM (\_st_env us sc -> case splitUniqSupply us of
+ (us1, us2) -> (uniqsFromSupply us1, us2, sc))
+
+getDOptsSmpl :: SimplM DynFlags
+getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
+
+getSimplRules :: SimplM RuleBase
+getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
+
+getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
+getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
+
+newId :: FastString -> Type -> SimplM Id
+newId fs ty = do uniq <- getUniqueM
+ return (mkSysLocal fs uniq ty)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Counting up what we've done}
+%* *
+%************************************************************************
+
+\begin{code}
+getSimplCount :: SimplM SimplCount
+getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
+
+tick :: Tick -> SimplM ()
+tick t = SM (\_st_env us sc -> let sc' = doSimplTick t sc
+ in sc' `seq` ((), us, sc'))
+
+checkedTick :: Tick -> SimplM ()
+-- Try to take a tick, but fail if too many
+checkedTick t
+ = SM (\st_env us sc -> if st_max_ticks st_env <= simplCountN sc
+ then pprPanic "Simplifier ticks exhausted" (msg sc)
+ else let sc' = doSimplTick t sc
+ in sc' `seq` ((), us, sc'))
+ where
+ msg sc = vcat [ ptext (sLit "When trying") <+> ppr t
+ , ptext (sLit "To increase the limit, use -fsimpl-tick-factor=N (default 100)")
+ , ptext (sLit "If you need to do this, let GHC HQ know, and what factor you needed")
+ , pp_details sc
+ , pprSimplCount sc ]
+ pp_details sc
+ | hasDetailedCounts sc = empty
+ | otherwise = ptext (sLit "To see detailed counts use -ddump-simpl-stats")
+
+
+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
+ = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
+ in sc' `seq` ((), us, sc'))
+\end{code}
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 5bf97b6cbd..bc04d4878c 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1260,7 +1260,7 @@ completeCall env var cont
lone_variable arg_infos interesting_cont
; case maybe_inline of {
Just expr -- There is an inlining!
- -> do { tick (UnfoldingDone var)
+ -> do { checkedTick (UnfoldingDone var)
; trace_inline dflags expr cont $
simplExprF (zapSubstEnv env) expr cont }
@@ -1420,7 +1420,7 @@ tryRules env rules fn args call_cont
Nothing -> return Nothing ; -- No rule matches
Just (rule, rule_rhs) ->
- do { tick (RuleFired (ru_name rule))
+ do { checkedTick (RuleFired (ru_name rule))
; dflags <- getDOptsSmpl
; trace_dump dflags rule rule_rhs $
return (Just (ruleArity rule, rule_rhs)) }}}
View Lorry Controller Status