New statistics flags -ddump-core-stats

This dumps a (one-line) listing of the size of the Core program,
just after tidying

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 0eab695..70e1db7 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -32,6 +32,7 @@ module CoreUtils (
 
        -- * Expression and bindings size
        coreBindsSize, exprSize,
 
        -- * Expression and bindings size
        coreBindsSize, exprSize,

+        CoreStats(..), coreBindsStats, 

 
        -- * Hashing
        hashExpr,
 
        -- * Hashing
        hashExpr,

@@ -1120,6 +1121,7 @@ coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 exprSize :: CoreExpr -> Int
 -- ^ A measure of the size of the expressions, strictly greater than 0
 -- It also forces the expression pretty drastically as a side effect
 exprSize :: CoreExpr -> Int
 -- ^ A measure of the size of the expressions, strictly greater than 0
 -- It also forces the expression pretty drastically as a side effect

+-- Counts *leaves*, not internal nodes. Types and coercions are not counted.

 exprSize (Var v)         = v `seq` 1
 exprSize (Lit lit)       = lit `seq` 1
 exprSize (App f a)       = exprSize f + exprSize a
 exprSize (Var v)         = v `seq` 1
 exprSize (Lit lit)       = lit `seq` 1
 exprSize (App f a)       = exprSize f + exprSize a

@@ -1154,6 +1156,62 @@ altSize :: CoreAlt -> Int
 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 \end{code}
 
 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 \end{code}
 

+\begin{code}
+data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int }
+
+plusCS :: CoreStats -> CoreStats -> CoreStats
+plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 })
+       (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 })
+  = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 }
+  
+zeroCS, oneTM :: CoreStats
+zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 }
+oneTM  = zeroCS { cs_tm = 1 }
+
+sumCS :: (a -> CoreStats) -> [a] -> CoreStats
+sumCS f = foldr (plusCS . f) zeroCS 
+ 
+coreBindsStats :: [CoreBind] -> CoreStats
+coreBindsStats = sumCS bindStats
+
+bindStats :: CoreBind -> CoreStats
+bindStats (NonRec v r) = bindingStats v r
+bindStats (Rec prs)    = sumCS (\(v,r) -> bindingStats v r) prs
+
+bindingStats :: Var -> CoreExpr -> CoreStats
+bindingStats v r = bndrStats v `plusCS` exprStats r
+
+bndrStats :: Var -> CoreStats
+bndrStats v = oneTM `plusCS` tyStats (varType v)
+
+exprStats :: CoreExpr -> CoreStats
+exprStats (Var {})        = oneTM
+exprStats (Lit {})        = oneTM
+exprStats (App f (Type t))= tyCoStats (exprType f) t
+exprStats (App f a)       = exprStats f `plusCS` exprStats a 
+exprStats (Lam b e)       = bndrStats b `plusCS` exprStats e 
+exprStats (Let b e)       = bindStats b `plusCS` exprStats e 
+exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as
+exprStats (Cast e co)     = coStats co `plusCS` exprStats e
+exprStats (Note _ e)      = exprStats e
+exprStats (Type ty)       = zeroCS { cs_ty = typeSize ty }
+         -- Ugh (might be a co)
+
+altStats :: CoreAlt -> CoreStats
+altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
+
+tyCoStats :: Type -> Type -> CoreStats
+tyCoStats fun_ty arg
+  = case splitForAllTy_maybe fun_ty of
+      Just (tv,_) | isCoVar tv -> coStats arg
+      _                        -> tyStats arg
+
+tyStats :: Type -> CoreStats
+tyStats ty = zeroCS { cs_ty = typeSize ty }
+
+coStats :: Coercion -> CoreStats
+coStats co = zeroCS { cs_co = typeSize co }
+\end{code}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index fe65839..706ded8 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -128,6 +128,7 @@ data DynFlag
    | Opt_D_dump_asm_stats
    | Opt_D_dump_asm_expanded
    | Opt_D_dump_llvm
    | Opt_D_dump_asm_stats
    | Opt_D_dump_asm_expanded
    | Opt_D_dump_llvm

+   | Opt_D_dump_core_stats

    | Opt_D_dump_cpranal
    | Opt_D_dump_deriv
    | Opt_D_dump_ds
    | Opt_D_dump_cpranal
    | Opt_D_dump_deriv
    | Opt_D_dump_ds

@@ -1218,6 +1219,7 @@ dynamic_flags = [
   , Flag "ddump-raw-cmm"           (setDumpFlag Opt_D_dump_raw_cmm)
   , Flag "ddump-cmmz"              (setDumpFlag Opt_D_dump_cmmz)
   , Flag "ddump-cmmz-pretty"       (setDumpFlag Opt_D_dump_cmmz_pretty)
   , Flag "ddump-raw-cmm"           (setDumpFlag Opt_D_dump_raw_cmm)
   , Flag "ddump-cmmz"              (setDumpFlag Opt_D_dump_cmmz)
   , Flag "ddump-cmmz-pretty"       (setDumpFlag Opt_D_dump_cmmz_pretty)

+  , Flag "ddump-core-stats"        (setDumpFlag Opt_D_dump_core_stats)

   , Flag "ddump-cps-cmm"           (setDumpFlag Opt_D_dump_cps_cmm)
   , Flag "ddump-cvt-cmm"           (setDumpFlag Opt_D_dump_cvt_cmm)
   , Flag "ddump-asm"               (setDumpFlag Opt_D_dump_asm)
   , Flag "ddump-cps-cmm"           (setDumpFlag Opt_D_dump_cps_cmm)
   , Flag "ddump-cvt-cmm"           (setDumpFlag Opt_D_dump_cvt_cmm)
   , Flag "ddump-asm"               (setDumpFlag Opt_D_dump_asm)

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 98fbeb3..b78c0db 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -46,6 +46,7 @@ import FastBool hiding ( fastOr )
 import Util
 import FastString
 
 import Util
 import FastString
 

+import Control.Monad   ( when )

 import Data.List       ( sortBy )
 import Data.IORef      ( IORef, readIORef, writeIORef )
 \end{code}
 import Data.List       ( sortBy )
 import Data.IORef      ( IORef, readIORef, writeIORef )
 \end{code}

@@ -353,6 +354,15 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                     (ptext (sLit "rules"))
                     (pprRulesForUser tidy_rules)
 
                     (ptext (sLit "rules"))
                     (pprRulesForUser tidy_rules)
 

+          -- Print one-line size info
+        ; let cs = coreBindsStats tidy_binds
+        ; when (dopt Opt_D_dump_core_stats dflags)
+              (printDump (ptext (sLit "Tidy size (terms,types,coercions)") 
+                           <+> ppr (moduleName mod) <> colon 
+                           <+> int (cs_tm cs) 
+                           <+> int (cs_ty cs) 
+                           <+> int (cs_co cs) ))
+

         ; let dir_imp_mods = moduleEnvKeys dir_imps
 
        ; return (CgGuts { cg_module   = mod, 
         ; let dir_imp_mods = moduleEnvKeys dir_imps
 
        ; return (CgGuts { cg_module   = mod, 

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 8ff78fb..5f348ef 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -74,7 +74,8 @@ module Type (
 
        -- * Type free variables
        tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
 
        -- * Type free variables
        tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,

-       expandTypeSynonyms,
+       expandTypeSynonyms, 
+       typeSize,

 
        -- * Type comparison
        coreEqType, coreEqType2,
 
        -- * Type comparison
        coreEqType, coreEqType2,

@@ -857,6 +858,28 @@ tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

+                   Size                                                                        
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+typeSize :: Type -> Int
+typeSize (TyVarTy _)     = 1
+typeSize (AppTy t1 t2)   = typeSize t1 + typeSize t2
+typeSize (FunTy t1 t2)   = typeSize t1 + typeSize t2
+typeSize (PredTy p)      = predSize p
+typeSize (ForAllTy _ t)  = 1 + typeSize t
+typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
+
+predSize :: PredType -> Int
+predSize (IParam _ t)   = 1 + typeSize t
+predSize (ClassP _ ts)  = 1 + sum (map typeSize ts)
+predSize (EqPred t1 t2) = typeSize t1 + typeSize t2
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *

 \subsection{Type families}
 %*                                                                     *
 %************************************************************************
 \subsection{Type families}
 %*                                                                     *
 %************************************************************************

diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml
index 4db79af..6fc1413 100644 (file)
--- a/docs/users_guide/debugging.xml
+++ b/docs/users_guide/debugging.xml
@@ -437,6 +437,17 @@
 
       <varlistentry>
        <term>
 
       <varlistentry>
        <term>

+          <option>-ddump-core-stats</option>
+          <indexterm><primary><option>-ddump-core-stats</option></primary></indexterm>
+        </term>
+       <listitem>
+         <para>Print a one-line summary of the size of the Core program
+                     at the end of the optimisation pipeline.</para>
+       </listitem>
+      </varlistentry>
+
+      <varlistentry>
+       <term>

           <option>-dfaststring-stats</option>
           <indexterm><primary><option>-dfaststring-stats</option></primary></indexterm>
         </term>
           <option>-dfaststring-stats</option>
           <indexterm><primary><option>-dfaststring-stats</option></primary></indexterm>
         </term>

diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 1a5e67e..f5f949a 100644 (file)
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -2244,6 +2244,13 @@ phase <replaceable>n</replaceable></entry>
              <entry>-</entry>
            </row>
            <row>
              <entry>-</entry>
            </row>
            <row>

+             <entry><option>-ddump-core-stats</option></entry>
+             <entry>Print a one-line summary of the size of the Core program
+                     at the end of the optimisation pipeline </entry>
+             <entry>dynamic</entry>
+             <entry>-</entry>
+           </row>
+           <row>

              <entry><option>-ddump-cpranal</option></entry>
              <entry>Dump output from CPR analysis</entry>
              <entry>dynamic</entry>
              <entry><option>-ddump-cpranal</option></entry>
              <entry>Dump output from CPR analysis</entry>
              <entry>dynamic</entry>