From 1ec8eb14001a7b5b65f55734d8e54cc8f6fd6d81 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Thu, 5 Jun 1997 20:39:04 +0000
Subject: [PATCH] [project @ 1997-06-05 20:39:04 by sof] updated (and fixed!)
printing of scc labels
---
ghc/compiler/profiling/CostCentre.lhs | 49 +++++++++++++++++----------
1 file changed, 32 insertions(+), 17 deletions(-)
diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs
index f83f49c2eea1..b89166c3d1e9 100644
--- 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,10 @@ IMP_Ubiq(){-uitous-}
import Id ( externallyVisibleId, GenId, showId, SYN_IE(Id) )
import CStrings ( identToC, stringToC )
-import Name ( OccName, getOccString, moduleString )
+import Name ( OccName, getOccString, moduleString, nameString )
import Outputable ( PprStyle(..), codeStyle, ifaceStyle )
-import UniqSet
import Pretty
-import Util
+import Util ( panic, panic#, assertPanic, cmpPString, thenCmp, Ord3(..) )
pprIdInUnfolding = panic "Whoops"
\end{code}
@@ -151,6 +150,9 @@ preludeDictsCostCentre is_dupd
noCostCentreAttached NoCostCentre = True
noCostCentreAttached _ = False
+isCurrentCostCentre CurrentCC = True
+isCurrentCostCentre _ = False
+
costsAreSubsumed SubsumedCosts = True
costsAreSubsumed _ = False
@@ -388,18 +390,25 @@ 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 ++
- moduleString mod_name ++
- ('/' : _UNPK_ grp_name) ++
- ('/' : 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
- else
- basic_kind
+ case sty of
+ PprForC -> do_caf is_caf basic_kind
+ _ ->
+ if friendly_sty then
+ do_dupd is_dupd full_kind
+ else
+ 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 "")
@@ -416,8 +425,16 @@ uppCostCentre sty print_as_string cc
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.
@@ -446,9 +463,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_")
--
GitLab