[project @ 1997-09-19 10:43:24 by simonm]

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

diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs
index 48f4f55..e48c058 100644 (file)
--- a/ghc/compiler/profiling/CostCentre.lhs
+++ b/ghc/compiler/profiling/CostCentre.lhs
@@ -10,7 +10,7 @@ module CostCentre (
        CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
        noCostCentre, subsumedCosts,
        useCurrentCostCentre,
-       noCostCentreAttached, costsAreSubsumed,
+       noCostCentreAttached, costsAreSubsumed, isCurrentCostCentre,
        currentOrSubsumedCosts,
        preludeCafsCostCentre, preludeDictsCostCentre,
        overheadCostCentre, dontCareCostCentre,
@@ -32,11 +32,11 @@ IMP_Ubiq(){-uitous-}
 
 import Id              ( externallyVisibleId, GenId, showId, SYN_IE(Id) )
 import CStrings                ( identToC, stringToC )
-import Name            ( OccName, getOccString, moduleString )
-import PprStyle                ( PprStyle(..), codeStyle, ifaceStyle )
-import UniqSet
+import Name            ( OccName, getOccString, moduleString, nameString )
+import Outputable      ( PprStyle(..), codeStyle, ifaceStyle )
 import Pretty
-import Util
+import Util            ( panic, panic#, assertPanic, cmpPString, thenCmp, Ord3(..) )
+import CmdLineOpts      ( all_toplev_ids_visible )
 
 pprIdInUnfolding = panic "Whoops"
 \end{code}
@@ -151,6 +151,9 @@ preludeDictsCostCentre is_dupd
 noCostCentreAttached NoCostCentre  = True
 noCostCentreAttached _            = False
 
+isCurrentCostCentre CurrentCC = True
+isCurrentCostCentre _        = False
+
 costsAreSubsumed SubsumedCosts = True
 costsAreSubsumed _             = False
 
@@ -388,32 +391,48 @@ uppCostCentre sty print_as_string cc
 
     do_cc (NormalCC kind mod_name grp_name is_dupd is_caf)
       = let
-           basic_kind = do_caf is_caf ++ do_kind kind
+            basic_kind  = do_kind kind
+           module_kind = do_caf is_caf (moduleString mod_name ++ '/':
+                                              basic_kind)
+            grp_str   = if (_NULL_ grp_name) then mod_name else grp_name
+            full_kind = do_caf is_caf
+                        (moduleString mod_name  ++ 
+                         ('/' : _UNPK_ grp_str) ++ 
+                         ('/' : basic_kind))
        in
-       if friendly_sty then
-           do_dupd is_dupd (basic_kind ++ ('/': moduleString mod_name) ++ ('/': _UNPK_ grp_name))
+        if friendly_sty then
+          do_dupd is_dupd full_kind
        else
-           basic_kind
+           module_kind
       where
-       do_caf IsCafCC = "CAF:"
-       do_caf _       = ""
+       do_caf IsCafCC ls = "CAF:" ++ ls
+       do_caf _       ls = ls
 
        do_kind (UserCC name) = _UNPK_ name
        do_kind (AutoCC id)   = do_id id ++ (if friendly_sty then "/AUTO" else "")
        do_kind (DictCC id)   = do_id id ++ (if friendly_sty then "/DICT" else "")
 
+        {-
+        do_id is only applied in a (not print_as_string) context for local ids,
+        hence using the occurrence name is enough.
+       -}
        do_id :: Id -> String
-       do_id id
-         = if print_as_string
-           then  getOccString id               -- use occ name
-           else showId sty id                  -- we really do
+       do_id id = getOccString id
 
     ---------------
     do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
     do_dupd _      str = str
 
 friendly_style sty -- i.e., probably for human consumption
+  = case sty of
+      PprForUser _ -> True
+      PprDebug   -> True
+      PprShowAll -> True
+      _         -> False
+{-
+friendly_style sty -- i.e., probably for human consumption
   = not (codeStyle sty || ifaceStyle sty)
+-}
 \end{code}
 
 Printing unfoldings is sufficiently weird that we do it separately.
@@ -442,9 +461,7 @@ upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
     pp_kind (AutoCC id)   = (<>) (ptext SLIT("_AUTO_CC_ ")) (show_id id)
     pp_kind (DictCC id)          = (<>) (ptext SLIT("_DICT_CC_ ")) (show_id id)
 
-    show_id id = pprIdInUnfolding no_in_scopes id
-       where
-         no_in_scopes = emptyUniqSet
+    show_id id = pprIdInUnfolding {-no_in_scopes-} id
 
     pp_caf IsCafCC    = ptext SLIT("_CAF_CC_")
     pp_caf IsNotCafCC = ptext SLIT("_N_")
@@ -472,7 +489,7 @@ uppCostCentreDecl sty is_local cc
            pp_str mod_name, comma,
            pp_str grp_name, comma,
            text is_subsumed, comma,
-           if externally_visible then empty else ptext SLIT("static"),
+           if externally_visible || all_toplev_ids_visible then empty else ptext SLIT("static"),
            text ");"]
     else
        hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ]