Add a transformation limit to the simplifier (Trac #5448)
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 23 Sep 2011 05:46:30 +0000 (06:46 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 23 Sep 2011 05:46:30 +0000 (06:46 +0100)
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.

compiler/main/DynFlags.hs
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplCore/SimplMonad.lhs
compiler/simplCore/Simplify.lhs

index 105c592..5e2f25a 100644 (file)
@@ -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 }))
index 8b4b4e3..df515d1 100644 (file)
@@ -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}
 
 
index 20425db..3c89b0f 100644 (file)
@@ -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
index 1781d56..0b6aaac 100644 (file)
-%
-% (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}
+%\r
+% (c) The AQUA Project, Glasgow University, 1993-1998\r
+%\r
+\section[SimplMonad]{The simplifier Monad}\r
+\r
+\begin{code}\r
+module SimplMonad (\r
+       -- The monad\r
+       SimplM,\r
+       initSmpl,\r
+       getDOptsSmpl, getSimplRules, getFamEnvs,\r
+\r
+        -- Unique supply\r
+        MonadUnique(..), newId,\r
+\r
+       -- Counting\r
+       SimplCount, tick, freeTick, checkedTick,\r
+       getSimplCount, zeroSimplCount, pprSimplCount, \r
+        plusSimplCount, isZeroSimplCount\r
+    ) where\r
+\r
+import Id              ( Id, mkSysLocal )\r
+import Type             ( Type )\r
+import FamInstEnv      ( FamInstEnv )\r
+import Rules           ( RuleBase )\r
+import UniqSupply\r
+import DynFlags                ( DynFlags( simplTickFactor ) )\r
+import CoreMonad\r
+import Outputable\r
+import FastString\r
+\end{code}\r
+\r
+%************************************************************************\r
+%*                                                                     *\r
+\subsection{Monad plumbing}\r
+%*                                                                     *\r
+%************************************************************************\r
+\r
+For the simplifier monad, we want to {\em thread} a unique supply and a counter.\r
+(Command-line switches move around through the explicitly-passed SimplEnv.)\r
+\r
+\begin{code}\r
+newtype SimplM result\r
+  =  SM  { unSM :: SimplTopEnv -- Envt that does not change much\r
+               -> UniqSupply   -- We thread the unique supply because\r
+                               -- constantly splitting it is rather expensive\r
+               -> SimplCount \r
+               -> (result, UniqSupply, SimplCount)}\r
+\r
+data SimplTopEnv \r
+  = STE        { st_flags :: DynFlags \r
+       , st_max_ticks :: Int  -- Max #ticks in this simplifier run\r
+                              -- Zero means infinity!\r
+       , st_rules :: RuleBase\r
+       , st_fams  :: (FamInstEnv, FamInstEnv) }\r
+\end{code}\r
+\r
+\begin{code}\r
+initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) \r
+        -> UniqSupply          -- No init count; set to 0\r
+        -> Int                 -- Size of the bindings\r
+        -> SimplM a\r
+        -> (a, SimplCount)\r
+\r
+initSmpl dflags rules fam_envs us size m\r
+  = case unSM m env us (zeroSimplCount dflags) of \r
+       (result, _, count) -> (result, count)\r
+  where\r
+    -- Compute the max simplifier ticks as\r
+    --     pgm-size * k * tick-factor/100\r
+    -- where k is a constant that gives reasonable results\r
+    max_ticks = fromInteger ((toInteger size * toInteger (simplTickFactor dflags * k)) \r
+                             `div` 100)\r
+    k = 20     -- MAGIC NUMBER, multiplies the simplTickFactor\r
+               -- We can afford to be generous; this is really\r
+               -- just checking for loops, and shouldn't usually fire\r
+\r
+    env = STE { st_flags = dflags, st_rules = rules\r
+             , st_max_ticks = max_ticks\r
+              , st_fams = fam_envs }\r
+\r
+{-# INLINE thenSmpl #-}\r
+{-# INLINE thenSmpl_ #-}\r
+{-# INLINE returnSmpl #-}\r
+\r
+instance Monad SimplM where\r
+   (>>)   = thenSmpl_\r
+   (>>=)  = thenSmpl\r
+   return = returnSmpl\r
+\r
+returnSmpl :: a -> SimplM a\r
+returnSmpl e = SM (\_st_env us sc -> (e, us, sc))\r
+\r
+thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b\r
+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b\r
+\r
+thenSmpl m k \r
+  = SM (\ st_env us0 sc0 ->\r
+         case (unSM m st_env us0 sc0) of \r
+               (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )\r
+\r
+thenSmpl_ m k \r
+  = SM (\st_env us0 sc0 ->\r
+        case (unSM m st_env us0 sc0) of \r
+               (_, us1, sc1) -> unSM k st_env us1 sc1)\r
+\r
+-- TODO: this specializing is not allowed\r
+-- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}\r
+-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}\r
+-- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%*                                                                     *\r
+\subsection{The unique supply}\r
+%*                                                                     *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+instance MonadUnique SimplM where\r
+    getUniqueSupplyM\r
+       = SM (\_st_env us sc -> case splitUniqSupply us of\r
+                                (us1, us2) -> (us1, us2, sc))\r
+\r
+    getUniqueM\r
+       = SM (\_st_env us sc -> case splitUniqSupply us of\r
+                                (us1, us2) -> (uniqFromSupply us1, us2, sc))\r
+\r
+    getUniquesM\r
+        = SM (\_st_env us sc -> case splitUniqSupply us of\r
+                                (us1, us2) -> (uniqsFromSupply us1, us2, sc))\r
+\r
+getDOptsSmpl :: SimplM DynFlags\r
+getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))\r
+\r
+getSimplRules :: SimplM RuleBase\r
+getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))\r
+\r
+getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)\r
+getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))\r
+\r
+newId :: FastString -> Type -> SimplM Id\r
+newId fs ty = do uniq <- getUniqueM\r
+                 return (mkSysLocal fs uniq ty)\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%*                                                                     *\r
+\subsection{Counting up what we've done}\r
+%*                                                                     *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+getSimplCount :: SimplM SimplCount\r
+getSimplCount = SM (\_st_env us sc -> (sc, us, sc))\r
+\r
+tick :: Tick -> SimplM ()\r
+tick t = SM (\_st_env us sc -> let sc' = doSimplTick t sc \r
+                               in sc' `seq` ((), us, sc'))\r
+\r
+checkedTick :: Tick -> SimplM ()\r
+-- Try to take a tick, but fail if too many\r
+checkedTick t \r
+  = SM (\st_env us sc -> if st_max_ticks st_env <= simplCountN sc\r
+                         then pprPanic "Simplifier ticks exhausted" (msg sc)\r
+                         else let sc' = doSimplTick t sc \r
+                              in sc' `seq` ((), us, sc'))\r
+  where\r
+    msg sc = vcat [ ptext (sLit "When trying") <+> ppr t\r
+                  , ptext (sLit "To increase the limit, use -fsimpl-tick-factor=N (default 100)")\r
+                  , ptext (sLit "If you need to do this, let GHC HQ know, and what factor you needed")\r
+                  , pp_details sc\r
+                  , pprSimplCount sc ]\r
+    pp_details sc\r
+      | hasDetailedCounts sc = empty\r
+      | otherwise = ptext (sLit "To see detailed counts use -ddump-simpl-stats")\r
+                   \r
+\r
+freeTick :: Tick -> SimplM ()\r
+-- Record a tick, but don't add to the total tick count, which is\r
+-- used to decide when nothing further has happened\r
+freeTick t \r
+   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc\r
+                           in sc' `seq` ((), us, sc'))\r
+\end{code}\r
index 5bf97b6..bc04d48 100644 (file)
@@ -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)) }}}