swap <[]> and <{}> syntax

[ghc-hetmet.git] / compiler / profiling / CostCentre.lhs

diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs
index 5ccdaf8..9e08831 100644 (file)
--- 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,
@@ -36,15 +37,16 @@ module CostCentre (
        cmpCostCentre   -- used for removing dups in a list
     ) where
 
-#include "HsVersions.h"
-
 import Var             ( Id )
 import Name
 import Module          ( Module )
+import Unique
 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.
@@ -124,6 +126,7 @@ data CostCentre
   | AllCafsCC {        
                cc_mod  :: Module       -- Name of module defining this CC.
     }
+  deriving (Data, Typeable)
 
 type CcName = FastString
 
@@ -142,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.
@@ -210,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
@@ -228,12 +240,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 }
 
@@ -299,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
@@ -333,15 +347,15 @@ non-constant C expression.
 
 \begin{code}
 instance Outputable CostCentreStack where
-  ppr NoCCS            = ptext SLIT("NO_CCS")
-  ppr CurrentCCS       = ptext SLIT("CCCS")
-  ppr OverheadCCS      = ptext SLIT("CCS_OVERHEAD")
-  ppr DontCareCCS      = ptext SLIT("CCS_DONT_CARE")
-  ppr SubsumedCCS      = ptext SLIT("CCS_SUBSUMED")
-  ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
-  ppr (PushCC cc ccs)   = ptext SLIT("PushCostCentre") <> 
+  ppr NoCCS            = ptext (sLit "NO_CCS")
+  ppr CurrentCCS       = ptext (sLit "CCCS")
+  ppr OverheadCCS      = ptext (sLit "CCS_OVERHEAD")
+  ppr DontCareCCS      = ptext (sLit "CCS_DONT_CARE")
+  ppr SubsumedCCS      = ptext (sLit "CCS_SUBSUMED")
+  ppr (PushCC cc NoCCS) = ppr cc <> ptext (sLit "_ccs")
+  ppr (PushCC cc ccs)   = ptext (sLit "PushCostCentre") <> 
                           parens (ppr ccs <> comma <> 
-                          parens(ptext SLIT("void *")) <> ppr cc)
+                          parens(ptext (sLit "void *")) <> ppr cc)
 \end{code}
 
 -----------------------------------------------------------------------------