Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/5f894374fbdcac959211a7c5e24cdf8454f8e137 >--------------------------------------------------------------- commit 5f894374fbdcac959211a7c5e24cdf8454f8e137 Author: Simon Peyton Jones <[email protected]> Date: Thu Apr 26 18:06:36 2012 +0100 Use coreBindsStats more than coreBindsSize >--------------------------------------------------------------- compiler/coreSyn/CoreUtils.lhs | 95 ++++++++++++++++++++----------------- compiler/simplCore/CoreMonad.lhs | 7 ++- compiler/simplCore/SimplCore.lhs | 4 +- compiler/simplCore/SimplMonad.lhs | 3 +- 4 files changed, 59 insertions(+), 50 deletions(-) diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index df72778..8ec132f 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -1329,50 +1329,9 @@ locallyBoundR rn_env v = inRnEnvR rn_env v %************************************************************************ \begin{code} -coreBindsSize :: [CoreBind] -> Int -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 --- 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 (Lam b e) = varSize b + exprSize e -exprSize (Let b e) = bindSize b + exprSize e -exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as -exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e -exprSize (Tick n e) = tickSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 -exprSize (Coercion co) = seqCo co `seq` 1 - -tickSize :: Tickish Id -> Int -tickSize (ProfNote cc _ _) = cc `seq` 1 -tickSize _ = 1 -- the rest are strict - -varSize :: Var -> Int -varSize b | isTyVar b = 1 - | otherwise = seqType (idType b) `seq` - megaSeqIdInfo (idInfo b) `seq` - 1 - -varsSize :: [Var] -> Int -varsSize = sum . map varSize - -bindSize :: CoreBind -> Int -bindSize (NonRec b e) = varSize b + exprSize e -bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs - -pairSize :: (Var, CoreExpr) -> Int -pairSize (b,e) = varSize b + exprSize e - -altSize :: CoreAlt -> Int -altSize (c,bs,e) = c `seq` varsSize bs + exprSize e -\end{code} - -\begin{code} -data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int } +data CoreStats = CS { cs_tm :: Int -- Terms + , cs_ty :: Int -- Types + , cs_co :: Int } -- Coercions instance Outputable CoreStats where @@ -1428,6 +1387,54 @@ coStats :: Coercion -> CoreStats coStats co = zeroCS { cs_co = coercionSize co } \end{code} + +\begin{code} +coreBindsSize :: [CoreBind] -> Int +-- We use coreBindStats for user printout +-- but this one is a quick and dirty basis for +-- the simplifier's tick limit +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 +-- 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 (Lam b e) = varSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as +exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type t) = seqType t `seq` 1 +exprSize (Coercion co) = seqCo co `seq` 1 + +tickSize :: Tickish Id -> Int +tickSize (ProfNote cc _ _) = cc `seq` 1 +tickSize _ = 1 -- the rest are strict + +varSize :: Var -> Int +varSize b | isTyVar b = 1 + | otherwise = seqType (idType b) `seq` + megaSeqIdInfo (idInfo b) `seq` + 1 + +varsSize :: [Var] -> Int +varsSize = sum . map varSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = varSize b + exprSize e +bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = varSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (c,bs,e) = c `seq` varsSize bs + exprSize e +\end{code} + + %************************************************************************ %* * \subsection{Hashing} diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 4af626d..c3a3dce 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -161,14 +161,15 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc | otherwise - = Err.debugTraceMsg dflags 2 $ - (sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]) + = Err.debugTraceMsg dflags 2 size_doc -- Report result size -- This has the side effect of forcing the intermediate to be evaluated where + size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + dump_doc = vcat [ nest 2 extra_info - , nest 2 (text "Result size =" <+> int (coreBindsSize binds)) + , size_doc , blankLine , pprCoreBindings binds , ppUnless (null rules) pp_rules ] diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 03ffb47..daadcb7 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -25,7 +25,7 @@ import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo -import CoreUtils ( coreBindsSize, exprSize ) +import CoreUtils ( coreBindsSize, coreBindsStats, exprSize ) import Simplify ( simplTopBinds, simplExpr ) import SimplUtils ( simplEnvForGHCi, activeRule ) import SimplEnv @@ -585,7 +585,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) <+> ptext (sLit "iterations") <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far)) - <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) ) + <+> ptext (sLit "Size =") <+> ppr (coreBindsStats binds) ) -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index e025e6c..3b18540 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -65,7 +65,8 @@ data SimplTopEnv \begin{code} initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) -> UniqSupply -- No init count; set to 0 - -> Int -- Size of the bindings + -> Int -- Size of the bindings, used to limit + -- the number of ticks we allow -> SimplM a -> (a, SimplCount) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
