X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fprofiling%2FCostCentre.lhs;h=444b8be1127528de9ec1d54c41f0652e727102a4;hb=e04195659aa59e83af80790c0179dd87e956a8b6;hp=4d13f102d2e9df909439d097843dc8ee8d13894d;hpb=3fc64886b53d4c0c6bd9731a04ed14a1d481d387;p=ghc-hetmet.git

diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs
index 4d13f10..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,
@@ -39,6 +39,7 @@ module CostCentre (
 import Var		( Id )
 import Name
 import Module		( Module )
+import Unique
 import Outputable	
 import FastTypes
 import FastString
@@ -208,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
@@ -226,12 +234,14 @@ mkAutoCC id mod is_caf
     }
   where 
         name = getName id
-        -- beware: we might be making an auto CC for a compiler-generated
-        -- thing (like a CAF when -caf-all is on), so include the uniq.
-        -- See bug #249, tests prof001, prof002
-        str | isSystemName name = mkFastString (showSDoc (ppr name))
-            | otherwise         = occNameFS (getOccName id)
-
+        -- beware: only external names are guaranteed to have unique
+        -- Occnames.  If the name is not external, we must append its
+        -- Unique.
+        -- See bug #249, tests prof001, prof002,  also #2411
+        str | isExternalName name = occNameFS (getOccName id)
+            | otherwise           = mkFastString $ showSDoc $
+                                      ftext (occNameFS (getOccName id))
+                                      <> char '_' <> pprUnique (getUnique name)
 mkAllCafsCC :: Module -> CostCentre
 mkAllCafsCC m = AllCafsCC  { cc_mod = m }
 
@@ -297,8 +307,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