-- * Expression and bindings size
coreBindsSize, exprSize,
+ CoreStats(..), coreBindsStats,
-- * Hashing
hashExpr,
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
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}
%************************************************************************
%* *
| 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
, 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)
import Util
import FastString
+import Control.Monad ( when )
import Data.List ( sortBy )
import Data.IORef ( IORef, readIORef, writeIORef )
\end{code}
(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,
-- * Type free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- expandTypeSynonyms,
+ expandTypeSynonyms,
+ typeSize,
-- * Type comparison
coreEqType, coreEqType2,
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************