X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprofiling%2FCostCentre.lhs;h=9e08831c97cb8e4b4d8d7a1c9f6866b1e792af49;hp=dc93a1fcbb5e2bf8605b23ac0c996cb81d79c94b;hb=5289f5d85610f71625a439747a09384876655eb5;hpb=e0ff87e4c56e8caf94b95e927ebd743ad3995a31

diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs
index dc93a1f..9e08831 100644
--- a/compiler/profiling/CostCentre.lhs
+++ b/compiler/profiling/CostCentre.lhs
@@ -10,6 +10,7 @@
 -- any warnings in the module. See
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
+{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
 
 module CostCentre (
 	CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
@@ -21,7 +22,7 @@ module CostCentre (
 	noCostCentre, noCCAttached,
 	noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
 	isDerivedFromCurrentCCS, maybeSingletonCCS,
-	decomposeCCS,
+	decomposeCCS, pushCCisNop,
 
 	mkUserCC, mkAutoCC, mkAllCafsCC, 
 	mkSingletonCCS, dupifyCC, pushCCOnCCS,
@@ -44,6 +45,8 @@ import Outputable
 import FastTypes
 import FastString
 import Util	        ( thenCmp )
+
+import Data.Data
 \end{code}
 
 A Cost Centre Stack is something that can be attached to a closure.
@@ -123,6 +126,7 @@ data CostCentre
   | AllCafsCC {	
 		cc_mod  :: Module	-- Name of module defining this CC.
     }
+  deriving (Data, Typeable)
 
 type CcName = FastString
 
@@ -141,8 +145,10 @@ data IsDupdCC
 			-- but we are trying to avoid confusion between
 			-- "subd" and "subsumed".  So we call the former
 			-- "dupd".
+  deriving (Data, Typeable)
 
 data IsCafCC = CafCC | NotCafCC
+  deriving (Data, Typeable)
 
 -- synonym for triple which describes the cost centre info in the generated
 -- code for a module.
@@ -209,6 +215,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
@@ -300,8 +313,8 @@ cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1})
 
 cmpCostCentre other_1 other_2
   = let
-	tag1 = tag_CC other_1
-	tag2 = tag_CC other_2
+	!tag1 = tag_CC other_1
+	!tag2 = tag_CC other_2
     in
     if tag1 <# tag2 then LT else GT
   where