Better simplifier counting
authorsimonpj@microsoft.com <unknown>
Tue, 7 Sep 2010 21:48:40 +0000 (21:48 +0000)
committersimonpj@microsoft.com <unknown>
Tue, 7 Sep 2010 21:48:40 +0000 (21:48 +0000)
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/SimplCore.lhs

index 8e75a7b..7f43ce5 100644 (file)
@@ -15,7 +15,7 @@ module CoreMonad (
     getCoreToDo, dumpSimplPhase,
 
     -- * Counting
-    SimplCount, doSimplTick, doFreeSimplTick,
+    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
     pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
 
     -- * The monad
@@ -545,9 +545,7 @@ plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 
 \begin{code}
 data SimplCount 
-   = VerySimplZero             -- These two are used when 
-   | VerySimplNonZero  -- we are only interested in 
-                               -- termination info
+   = VerySimplCount !Int       -- Used when don't want detailed stats
 
    | SimplCount        {
        ticks   :: !Int,        -- Total ticks
@@ -563,6 +561,10 @@ data SimplCount
 
 type TickCounts = FiniteMap Tick Int
 
+simplCountN :: SimplCount -> Int
+simplCountN (VerySimplCount n)         = n
+simplCountN (SimplCount { ticks = n }) = n
+
 zeroSimplCount dflags
                -- This is where we decide whether to do
                -- the VerySimpl version or the full-stats version
@@ -570,11 +572,10 @@ zeroSimplCount dflags
   = SimplCount {ticks = 0, details = emptyFM,
                 n_log = 0, log1 = [], log2 = []}
   | otherwise
-  = VerySimplZero
+  = VerySimplCount 0
 
-isZeroSimplCount VerySimplZero             = True
-isZeroSimplCount (SimplCount { ticks = 0 }) = True
-isZeroSimplCount _                         = False
+isZeroSimplCount (VerySimplCount n)                = n==0
+isZeroSimplCount (SimplCount { ticks = n }) = n==0
 
 doFreeSimplTick tick sc@SimplCount { details = dts } 
   = sc { details = dts `addTick` tick }
@@ -586,7 +587,7 @@ doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 =
   where
     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 
-doSimplTick _ _ = VerySimplNonZero -- The very simple case
+doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
 
 
 -- Don't use plusFM_C because that's lazy, and we want to 
@@ -608,11 +609,11 @@ plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
             | null (log2 sc2) = sc2 { log2 = log1 sc1 }
             | otherwise       = sc2
 
-plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
-plusSimplCount _             _             = VerySimplNonZero
+plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
+plusSimplCount _                  _                  = panic "plusSimplCount"
+       -- We use one or the other consistently
 
-pprSimplCount VerySimplZero    = ptext (sLit "Total ticks: ZERO!")
-pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
+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,
index 4df489b..9eba8e1 100644 (file)
@@ -461,41 +461,42 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
               hsc_env us hpt_rule_base 
               guts@(ModGuts { mg_binds = binds, mg_rules = rules
                             , mg_fam_inst_env = fam_inst_env })
-  = do {
-       (termination_msg, it_count, counts_out, guts') 
-          <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
+  = do { (termination_msg, it_count, counts_out, guts') 
+          <- do_iteration us 1 [] binds rules 
 
-       Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
+       Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
                  "Simplifier statistics for following pass"
                  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
                         blankLine,
-                        pprSimplCount counts_out]);
+                        pprSimplCount counts_out])
 
-       return (counts_out, guts')
+       return (counts_out, guts')
     }
   where
     dflags              = hsc_dflags hsc_env
     dump_phase          = dumpSimplPhase dflags mode
     sw_chkr     = isAmongSimpl switches
     do_iteration :: UniqSupply
-                 -> Int                -- Counts iterations
-                -> SimplCount  -- Logs optimisations performed
-                -> [CoreBind]  -- Bindings in
-                -> [CoreRule]  -- and orphan rules
+                 -> Int                 -- Counts iterations
+                -> [SimplCount] -- Counts from earlier iterations, reversed
+                -> [CoreBind]   -- Bindings in
+                -> [CoreRule]   -- and orphan rules
                 -> IO (String, Int, SimplCount, ModGuts)
 
-    do_iteration us iteration_no counts binds rules
+    do_iteration us iteration_no counts_so_far binds rules
        -- iteration_no is the number of the iteration we are
        -- about to begin, with '1' for the first
       | iteration_no > max_iterations  -- Stop if we've run out of iterations
-      =  WARN(debugIsOn && (max_iterations > 2),
-                text ("Simplifier still going after " ++
-                               show max_iterations ++
-                               " iterations; bailing out.  Size = " ++ show (coreBindsSize binds) ++ "\n" ))
+      = WARN( debugIsOn && (max_iterations > 2)
+            , ptext (sLit "Simplifier baling out after") <+> int max_iterations
+              <+> ptext (sLit "iterations") 
+              <+> brackets (pprWithCommas (int . simplCountN) (reverse counts_so_far))
+              <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
+
                -- Subtract 1 from iteration_no to get the
                -- number of iterations we actually completed
-           return ("Simplifier bailed out", iteration_no - 1, counts, 
-                    guts { mg_binds = binds, mg_rules = rules })
+       return ("Simplifier baled out", iteration_no - 1, total_counts, 
+                 guts { mg_binds = binds, mg_rules = rules })
 
       -- Try and force thunks off the binds; significantly reduces
       -- space usage, especially with -O.  JRS, 000620.
@@ -526,22 +527,21 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
                -- With a let, we ended up with
                --   let
                --      t = initSmpl ...
-               --      counts' = snd t
+               --      counts1 = snd t
                --   in
-               --      case t of {(_,counts') -> if counts'=0 then ... }
-               -- So the conditional didn't force counts', because the
+               --      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 {
                (env1, counts1) -> do {
 
-          let  { all_counts = counts `plusSimplCount` counts1
-               ; binds1 = getFloats env1
+          let  { binds1 = getFloats env1
                 ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
                } ;
 
                -- Stop if nothing happened; don't dump output
           if isZeroSimplCount counts1 then
-               return ("Simplifier reached fixed point", iteration_no, all_counts,
+               return ("Simplifier reached fixed point", iteration_no, total_counts,
                        guts { mg_binds = binds1, mg_rules = rules1 })
           else do {
                -- Short out indirections
@@ -558,10 +558,14 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
           end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
 
                -- Loop
-          do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
+          do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
        }  } } }
       where
-         (us1, us2) = splitUniqSupply us
+       (us1, us2) = splitUniqSupply us
+
+       -- Remember the counts_so_far are reversed
+        total_counts = foldr (\c acc -> acc `plusSimplCount` c) 
+                             (zeroSimplCount dflags) counts_so_far
 
 -------------------
 end_iteration :: DynFlags -> CoreToDo -> Int