From: simonpj@microsoft.com <unknown>
Date: Fri, 11 Sep 2009 11:56:30 +0000 (+0000)
Subject: Improve optimisation of cost centres
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e04195659aa59e83af80790c0179dd87e956a8b6

Improve optimisation of cost centres

This patch fixes test failures for the profiling way for drv001.
The problem was that the arity of a function was decreasing during
"optimisation" because of interaction with SCC annotations.
In particular
      f = /\a. scc "f" (h x)    -- where h had arity 2
and h gets inlined, led to
      f = /\a. scc "f" let v = scc "f" x in \y. <blah>

Two main changes:

1.  exprIsTrivial now says True for (scc "f" x)
    See Note [SCCs are trivial] in CoreUtils

2.  The simplifier eliminates nested pushing of the same cost centre:
  	scc "f" (...(scc "f" e)...)
  	==>  scc "f" (...e...)
---

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 869f356..d48d69e 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -430,6 +430,8 @@ filters down the matching alternatives in Simplify.rebuildCase.
 		applications.  Note that primop Ids aren't considered
 		trivial unless 
 
+Note [Variable are trivial]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
 There used to be a gruesome test for (hasNoBinding v) in the
 Var case:
 	exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
@@ -441,19 +443,22 @@ completely un-applied primops and foreign-call Ids are sufficiently
 rare that I plan to allow them to be duplicated and put up with
 saturating them.
 
-SCC notes.  We do not treat (_scc_ "foo" x) as trivial, because 
-  a) it really generates code, (and a heap object when it's 
-     a function arg) to capture the cost centre
-  b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
+Note [SCCs are trivial]
+~~~~~~~~~~~~~~~~~~~~~~~
+We used not to treat (_scc_ "foo" x) as trivial, because it really
+generates code, (and a heap object when it's a function arg) to
+capture the cost centre.  However, the profiling system discounts the
+allocation costs for such "boxing thunks" whereas the extra costs of
+*not* inlining otherwise-trivial bindings can be high, and are hard to
+discount.
 
 \begin{code}
 exprIsTrivial :: CoreExpr -> Bool
-exprIsTrivial (Var _)          = True        -- See notes above
+exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
 exprIsTrivial (Type _)         = True
 exprIsTrivial (Lit lit)        = litIsTrivial lit
 exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note (SCC _) _) = False       -- See notes above
-exprIsTrivial (Note _       e) = exprIsTrivial e
+exprIsTrivial (Note _       e) = exprIsTrivial e  -- See Note [SCCs are trivial]
 exprIsTrivial (Cast e _)       = exprIsTrivial e
 exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
 exprIsTrivial _                = False
diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs
index aff29d8..444b8be 100644
--- a/compiler/profiling/CostCentre.lhs
+++ b/compiler/profiling/CostCentre.lhs
@@ -21,7 +21,7 @@ module CostCentre (
 	noCostCentre, noCCAttached,
 	noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
 	isDerivedFromCurrentCCS, maybeSingletonCCS,
-	decomposeCCS,
+	decomposeCCS, pushCCisNop,
 
 	mkUserCC, mkAutoCC, mkAllCafsCC, 
 	mkSingletonCCS, dupifyCC, pushCCOnCCS,
@@ -209,6 +209,13 @@ currentOrSubsumedCCS _			= False
 maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
 maybeSingletonCCS (PushCC cc NoCCS)	= Just cc
 maybeSingletonCCS _			= Nothing
+
+pushCCisNop :: CostCentre -> CostCentreStack -> Bool
+-- (pushCCisNop cc ccs) = True => pushing cc on ccs is a no-op
+-- It's safe to return False, but the optimiser can remove
+-- redundant pushes if this function returns True.
+pushCCisNop cc (PushCC cc' _) = cc == cc'
+pushCCisNop _ _ = False
 \end{code}
 
 Building cost centres
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index d90c5db..69ac95b 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -29,7 +29,7 @@ import CoreUtils
 import CoreArity	( exprArity )
 import Rules            ( lookupRule, getRules )
 import BasicTypes       ( isMarkedStrict, Arity )
-import CostCentre       ( currentCCS )
+import CostCentre       ( currentCCS, pushCCisNop )
 import TysPrim          ( realWorldStatePrimTy )
 import PrelInfo         ( realWorldPrimId )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel,
@@ -1004,6 +1004,9 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
 simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
           -> SimplM (SimplEnv, OutExpr)
 simplNote env (SCC cc) e cont
+  | pushCCisNop cc (getEnclosingCC env)  -- scc "f" (...(scc "f" e)...) 
+  = simplExprF env e cont	         -- ==>  scc "f" (...e...)
+  | otherwise
   = do  { e' <- simplExpr (setEnclosingCC env currentCCS) e
         ; rebuild env (mkSCC cc e') cont }