Commit 24a2353a authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Add a transformation limit to the simplifier (Trac #5448)

This addresses the rare cases where the simplifier diverges
(see the above ticket).  We were already counting how many simplifier
steps were taking place, but with no limit.  This patch adds a limit;
at which point we halt compilation, and print out useful stats. The
stats show what is begin inlined, and how often, which points you
directly to the problem.  The limit is set based on the size of the
program.

Instead of halting compilation, we could instead just inhibit
inlining, which would let compilation of the module complete. This is
a bit harder to implement, and it's likely to mean that you unrolled
the function 1143 times and then ran out of ticks; you probably don't
want to complete parsing on this highly-unrolled program.

Flags: -dsimpl-tick-factor=N.  Default is 100 (percent).
       A bigger number increases the allowed maximum tick count.
parent 730f6c6e
......@@ -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 }))
......
......@@ -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}
......
......@@ -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
......
%
% (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}
......@@ -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)) }}}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment