update to current master againwip/T13904

4 files changed, 166 insertions, 364 deletions

diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs
index 4dd54dcc6c..91a4ef0ec7 100644
--- a/compiler/profiling/CostCentre.hs
+++ b/compiler/profiling/CostCentre.hs
@@ -1,12 +1,12 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module CostCentre (
-        CostCentre(..), CcName, IsCafCC(..),
+        CostCentre(..), CcName, CCFlavour(..),
                 -- All abstract except to friend: ParseIface.y
 
         CostCentreStack,
-        CollectedCCs,
-        noCCS, currentCCS, dontCareCCS,
-        noCCSAttached, isCurrentCCS,
+        CollectedCCs, emptyCollectedCCs, collectCC,
+        currentCCS, dontCareCCS,
+        isCurrentCCS,
         maybeSingletonCCS,
 
         mkUserCC, mkAutoCC, mkAllCafsCC,
@@ -20,6 +20,8 @@ module CostCentre (
         cmpCostCentre   -- used for removing dups in a list
     ) where
 
+import GhcPrelude
+
 import Binary
 import Var
 import Name
@@ -29,6 +31,7 @@ import Outputable
 import SrcLoc
 import FastString
 import Util
+import CostCentreState
 
 import Data.Data
 
@@ -39,21 +42,18 @@ import Data.Data
 
 data CostCentre
   = NormalCC {
-                cc_key  :: {-# UNPACK #-} !Int,
+                cc_flavour  :: CCFlavour,
                  -- ^ Two cost centres may have the same name and
                  -- module but different SrcSpans, so we need a way to
                  -- distinguish them easily and give them different
-                 -- object-code labels.  So every CostCentre has a
-                 -- Unique that is distinct from every other
-                 -- CostCentre in the same module.
-                 --
-                 -- XXX: should really be using Unique here, but we
-                 -- need to derive Data below and there's no Data
-                 -- instance for Unique.
+                 -- object-code labels.  So every CostCentre has an
+                 -- associated flavour that indicates how it was
+                 -- generated, and flavours that allow multiple instances
+                 -- of the same name and module have a deterministic 0-based
+                 -- index.
                 cc_name :: CcName,      -- ^ Name of the cost centre itself
                 cc_mod  :: Module,      -- ^ Name of module defining this CC.
-                cc_loc  :: SrcSpan,
-                cc_is_caf  :: IsCafCC   -- see below
+                cc_loc  :: SrcSpan
     }
 
   | AllCafsCC {
@@ -64,9 +64,22 @@ data CostCentre
 
 type CcName = FastString
 
-data IsCafCC = NotCafCC | CafCC
-  deriving (Eq, Ord, Data)
-
+-- | The flavour of a cost centre.
+--
+-- Index fields represent 0-based indices giving source-code ordering of
+-- centres with the same module, name, and flavour.
+data CCFlavour = CafCC -- ^ Auto-generated top-level thunk
+               | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression
+               | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration
+               | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage
+               deriving (Eq, Ord, Data)
+
+-- | Extract the index from a flavour
+flavourIndex :: CCFlavour -> Int
+flavourIndex CafCC = 0
+flavourIndex (ExprCC x) = unCostCentreIndex x
+flavourIndex (DeclCC x) = unCostCentreIndex x
+flavourIndex (HpcCC x) = unCostCentreIndex x
 
 instance Eq CostCentre where
         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
@@ -79,10 +92,10 @@ cmpCostCentre :: CostCentre -> CostCentre -> Ordering
 cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})
   = m1 `compare` m2
 
-cmpCostCentre NormalCC {cc_key = n1, cc_mod =  m1}
-              NormalCC {cc_key = n2, cc_mod =  m2}
-    -- first key is module name, then the integer key
-  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)
+cmpCostCentre NormalCC {cc_flavour = f1, cc_mod =  m1, cc_name = n1}
+              NormalCC {cc_flavour = f2, cc_mod =  m2, cc_name = n2}
+    -- first key is module name, then centre name, then flavour
+  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)
 
 cmpCostCentre other_1 other_2
   = let
@@ -100,9 +113,9 @@ cmpCostCentre other_1 other_2
 -- Predicates on CostCentre
 
 isCafCC :: CostCentre -> Bool
-isCafCC (AllCafsCC {})                 = True
-isCafCC (NormalCC {cc_is_caf = CafCC}) = True
-isCafCC _                              = False
+isCafCC (AllCafsCC {})                  = True
+isCafCC (NormalCC {cc_flavour = CafCC}) = True
+isCafCC _                               = False
 
 -- | Is this a cost-centre which records scc counts
 isSccCountCC :: CostCentre -> Bool
@@ -121,18 +134,17 @@ ccFromThisModule cc m = cc_mod cc == m
 -----------------------------------------------------------------------------
 -- Building cost centres
 
-mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre
-mkUserCC cc_name mod loc key
-  = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod =  mod, cc_loc = loc,
-               cc_is_caf = NotCafCC {-might be changed-}
+mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
+mkUserCC cc_name mod loc flavour
+  = NormalCC { cc_name = cc_name, cc_mod =  mod, cc_loc = loc,
+               cc_flavour = flavour
     }
 
-mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
-mkAutoCC id mod is_caf
-  = NormalCC { cc_key = getKey (getUnique id),
-               cc_name = str, cc_mod =  mod,
+mkAutoCC :: Id -> Module -> CostCentre
+mkAutoCC id mod
+  = NormalCC { cc_name = str, cc_mod =  mod,
                cc_loc = nameSrcSpan (getName id),
-               cc_is_caf = is_caf
+               cc_flavour = CafCC
     }
   where
         name = getName id
@@ -158,9 +170,7 @@ mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
 --        pre-defined CCSs, see below).
 
 data CostCentreStack
-  = NoCCS
-
-  | CurrentCCS          -- Pinned on a let(rec)-bound
+  = CurrentCCS          -- Pinned on a let(rec)-bound
                         -- thunk/function/constructor, this says that the
                         -- cost centre to be attached to the object, when it
                         -- is allocated, is whatever is in the
@@ -180,24 +190,23 @@ data CostCentreStack
 -- code for a module.
 type CollectedCCs
   = ( [CostCentre]       -- local cost-centres that need to be decl'd
-    , [CostCentre]       -- "extern" cost-centres
     , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
     )
 
+emptyCollectedCCs :: CollectedCCs
+emptyCollectedCCs = ([], [])
 
-noCCS, currentCCS, dontCareCCS :: CostCentreStack
+collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
+collectCC cc ccs (c, cs) = (cc : c, ccs : cs)
+
+currentCCS, dontCareCCS :: CostCentreStack
 
-noCCS                   = NoCCS
 currentCCS              = CurrentCCS
 dontCareCCS             = DontCareCCS
 
 -----------------------------------------------------------------------------
 -- Predicates on Cost-Centre Stacks
 
-noCCSAttached :: CostCentreStack -> Bool
-noCCSAttached NoCCS                     = True
-noCCSAttached _                         = False
-
 isCurrentCCS :: CostCentreStack -> Bool
 isCurrentCCS CurrentCCS                 = True
 isCurrentCCS _                          = False
@@ -221,7 +230,6 @@ mkSingletonCCS cc = SingletonCCS cc
 -- expression.
 
 instance Outputable CostCentreStack where
-  ppr NoCCS             = text "NO_CCS"
   ppr CurrentCCS        = text "CCCS"
   ppr DontCareCCS       = text "CCS_DONT_CARE"
   ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
@@ -251,26 +259,44 @@ instance Outputable CostCentre where
 pprCostCentreCore :: CostCentre -> SDoc
 pprCostCentreCore (AllCafsCC {cc_mod = m})
   = text "__sccC" <+> braces (ppr m)
-pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
-                             cc_is_caf = caf})
+pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,
+                             cc_mod = m, cc_loc = loc})
   = text "__scc" <+> braces (hsep [
         ppr m <> char '.' <> ftext n,
-        ifPprDebug (ppr key),
-        pp_caf caf,
-        ifPprDebug (ppr loc)
+        pprFlavourCore flavour,
+        whenPprDebug (ppr loc)
     ])
 
-pp_caf :: IsCafCC -> SDoc
-pp_caf CafCC = text "__C"
-pp_caf _     = empty
+-- ^ Print a flavour in Core
+pprFlavourCore :: CCFlavour -> SDoc
+pprFlavourCore CafCC = text "__C"
+pprFlavourCore f     = pprIdxCore $ flavourIndex f
+
+-- ^ Print a flavour's index in Core
+pprIdxCore :: Int -> SDoc
+pprIdxCore 0 = empty
+pprIdxCore idx = whenPprDebug $ ppr idx
 
 -- Printing as a C label
 ppCostCentreLbl :: CostCentre -> SDoc
 ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
-ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
-                           cc_is_caf = is_caf})
+ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
   = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
-        case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
+        ppFlavourLblComponent f <> text "_cc"
+
+-- ^ Print the flavour component of a C label
+ppFlavourLblComponent :: CCFlavour -> SDoc
+ppFlavourLblComponent CafCC = text "CAF"
+ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i
+ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i
+ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i
+
+-- ^ Print the flavour index component of a C label
+ppIdxLblComponent :: CostCentreIndex -> SDoc
+ppIdxLblComponent n =
+  case unCostCentreIndex n of
+    0 -> empty
+    n -> ppr n
 
 -- This is the name to go in the user-displayed string,
 -- recorded in the cost centre declaration
@@ -279,7 +305,7 @@ costCentreUserName = unpackFS . costCentreUserNameFS
 
 costCentreUserNameFS :: CostCentre -> FastString
 costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"
-costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
+costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf})
   =  case is_caf of
       CafCC -> mkFastString "CAF:" `appendFS` name
       _     -> name
@@ -287,24 +313,32 @@ costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
 costCentreSrcSpan :: CostCentre -> SrcSpan
 costCentreSrcSpan = cc_loc
 
-instance Binary IsCafCC where
+instance Binary CCFlavour where
     put_ bh CafCC = do
             putByte bh 0
-    put_ bh NotCafCC = do
+    put_ bh (ExprCC i) = do
             putByte bh 1
+            put_ bh i
+    put_ bh (DeclCC i) = do
+            putByte bh 2
+            put_ bh i
+    put_ bh (HpcCC i) = do
+            putByte bh 3
+            put_ bh i
     get bh = do
             h <- getByte bh
             case h of
               0 -> do return CafCC
-              _ -> do return NotCafCC
+              1 -> ExprCC <$> get bh
+              2 -> DeclCC <$> get bh
+              _ -> HpcCC <$> get bh
 
 instance Binary CostCentre where
-    put_ bh (NormalCC aa ab ac _ad ae) = do
+    put_ bh (NormalCC aa ab ac _ad) = do
             putByte bh 0
             put_ bh aa
             put_ bh ab
             put_ bh ac
-            put_ bh ae
     put_ bh (AllCafsCC ae _af) = do
             putByte bh 1
             put_ bh ae
@@ -314,8 +348,7 @@ instance Binary CostCentre where
               0 -> do aa <- get bh
                       ab <- get bh
                       ac <- get bh
-                      ae <- get bh
-                      return (NormalCC aa ab ac noSrcSpan ae)
+                      return (NormalCC aa ab ac noSrcSpan)
               _ -> do ae <- get bh
                       return (AllCafsCC ae noSrcSpan)
 
diff --git a/compiler/profiling/CostCentreState.hs b/compiler/profiling/CostCentreState.hs
new file mode 100644
index 0000000000..0050c1d033
--- /dev/null
+++ b/compiler/profiling/CostCentreState.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module CostCentreState ( CostCentreState, newCostCentreState
+                       , CostCentreIndex, unCostCentreIndex, getCCIndex
+                       ) where
+
+import GhcPrelude
+import FastString
+import FastStringEnv
+
+import Data.Data
+import Binary
+
+-- | Per-module state for tracking cost centre indices.
+--
+-- See documentation of 'CostCentre.cc_flavour' for more details.
+newtype CostCentreState = CostCentreState (FastStringEnv Int)
+
+-- | Initialize cost centre state.
+newCostCentreState :: CostCentreState
+newCostCentreState = CostCentreState emptyFsEnv
+
+-- | An index into a given cost centre module,name,flavour set
+newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int }
+  deriving (Eq, Ord, Data, Binary)
+
+-- | Get a new index for a given cost centre name.
+getCCIndex :: FastString
+           -> CostCentreState
+           -> (CostCentreIndex, CostCentreState)
+getCCIndex nm (CostCentreState m) =
+    (CostCentreIndex idx, CostCentreState m')
+  where
+    m_idx = lookupFsEnv m nm
+    idx = maybe 0 id m_idx
+    m' = extendFsEnv m nm (idx + 1)
diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
index 9add61e561..931299a655 100644
--- a/compiler/profiling/ProfInit.hs
+++ b/compiler/profiling/ProfInit.hs
@@ -8,11 +8,12 @@
 
 module ProfInit (profilingInitCode) where
 
+import GhcPrelude
+
 import CLabel
 import CostCentre
 import DynFlags
 import Outputable
-import FastString
 import Module
 
 -- -----------------------------------------------------------------------------
@@ -22,25 +23,42 @@ import Module
 -- module;
 
 profilingInitCode :: Module -> CollectedCCs -> SDoc
-profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
+profilingInitCode this_mod (local_CCs, singleton_CCSs)
  = sdocWithDynFlags $ \dflags ->
    if not (gopt Opt_SccProfilingOn dflags)
    then empty
    else vcat
-    [ text "static void prof_init_" <> ppr this_mod
-         <> text "(void) __attribute__((constructor));"
-    , text "static void prof_init_" <> ppr this_mod <> text "(void)"
-    , braces (vcat (
-         map emitRegisterCC           local_CCs ++
-         map emitRegisterCCS          singleton_CCSs
-       ))
-    ]
+    $  map emit_cc_decl local_CCs
+    ++ map emit_ccs_decl singleton_CCSs
+    ++ [emit_cc_list local_CCs]
+    ++ [emit_ccs_list singleton_CCSs]
+    ++ [ text "static void prof_init_" <> ppr this_mod
+            <> text "(void) __attribute__((constructor));"
+       , text "static void prof_init_" <> ppr this_mod <> text "(void)"
+       , braces (vcat
+                 [ text "registerCcList" <> parens local_cc_list_label <> semi
+                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi
+                 ])
+       ]
  where
-   emitRegisterCC cc   =
-      text "extern CostCentre " <> cc_lbl <> ptext (sLit "[];") $$
-      text "REGISTER_CC(" <> cc_lbl <> char ')' <> semi
+   emit_cc_decl cc =
+       text "extern CostCentre" <+> cc_lbl <> text "[];"
      where cc_lbl = ppr (mkCCLabel cc)
-   emitRegisterCCS ccs =
-      text "extern CostCentreStack " <> ccs_lbl <> ptext (sLit "[];") $$
-      text "REGISTER_CCS(" <> ccs_lbl <> char ')' <> semi
+   local_cc_list_label = text "local_cc_" <> ppr this_mod
+   emit_cc_list ccs =
+      text "static CostCentre *" <> local_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
+
+   emit_ccs_decl ccs =
+       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
      where ccs_lbl = ppr (mkCCSLabel ccs)
+   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
+   emit_ccs_list ccs =
+      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs
deleted file mode 100644
index 9704e0b132..0000000000
--- a/compiler/profiling/SCCfinal.hs
+++ /dev/null
@@ -1,285 +0,0 @@
--- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-{-# LANGUAGE CPP #-}
-
------------------------------------------------------------------------------
--- Modify and collect code generation for final STG program
-
-{-
- This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
-
-  - Traverses the STG program collecting the cost centres. These are required
-    to declare the cost centres at the start of code generation.
-
-    Note: because of cross-module unfolding, some of these cost centres may be
-    from other modules.
-
-  - Puts on CAF cost-centres if the user has asked for individual CAF
-    cost-centres.
--}
-
-module SCCfinal ( stgMassageForProfiling ) where
-
-#include "HsVersions.h"
-
-import StgSyn
-
-import CostCentre       -- lots of things
-import Id
-import Name
-import Module
-import UniqSupply       ( UniqSupply )
-import ListSetOps       ( removeDups )
-import Outputable
-import DynFlags
-import CoreSyn          ( Tickish(..) )
-import FastString
-import SrcLoc
-import Util
-
-import Control.Monad (liftM, ap)
-
-stgMassageForProfiling
-        :: DynFlags
-        -> Module                       -- module name
-        -> UniqSupply                   -- unique supply
-        -> [StgTopBinding]              -- input
-        -> (CollectedCCs, [StgTopBinding])
-
-stgMassageForProfiling dflags mod_name _us stg_binds
-  = let
-        ((local_ccs, extern_ccs, cc_stacks),
-         stg_binds2)
-          = initMM mod_name (do_top_bindings stg_binds)
-
-        (fixed_ccs, fixed_cc_stacks)
-          = if gopt Opt_AutoSccsOnIndividualCafs dflags
-            then ([],[])  -- don't need "all CAFs" CC
-            else ([all_cafs_cc], [all_cafs_ccs])
-
-        local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
-        extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
-    in
-    ((fixed_ccs ++ local_ccs_no_dups,
-      extern_ccs_no_dups,
-      fixed_cc_stacks ++ cc_stacks), stg_binds2)
-  where
-
-    span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
-    all_cafs_cc  = mkAllCafsCC mod_name span
-    all_cafs_ccs = mkSingletonCCS all_cafs_cc
-
-    ----------
-    do_top_bindings :: [StgTopBinding] -> MassageM [StgTopBinding]
-
-    do_top_bindings [] = return []
-
-    do_top_bindings (StgTopLifted (StgNonRec b rhs) : bs) = do
-        rhs' <- do_top_rhs b rhs
-        bs' <- do_top_bindings bs
-        return (StgTopLifted (StgNonRec b rhs') : bs')
-
-    do_top_bindings (StgTopLifted (StgRec pairs) : bs) = do
-        pairs2 <- mapM do_pair pairs
-        bs' <- do_top_bindings bs
-        return (StgTopLifted (StgRec pairs2) : bs')
-      where
-        do_pair (b, rhs) = do
-             rhs2 <- do_top_rhs b rhs
-             return (b, rhs2)
-
-    do_top_bindings (b@StgTopStringLit{} : bs) = do
-        bs' <- do_top_bindings bs
-        return (b : bs')
-
-    ----------
-    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
-
-    do_top_rhs _ (StgRhsClosure _ _ _ _ []
-                     (StgTick (ProfNote _cc False{-not tick-} _push)
-                              (StgConApp con args _)))
-      | not (isDllConApp dflags mod_name con args)
-        -- Trivial _scc_ around nothing but static data
-        -- Eliminate _scc_ ... and turn into StgRhsCon
-
-        -- isDllConApp checks for LitLit args too
-      = return (StgRhsCon dontCareCCS con args)
-
-    do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
-      = do
-        -- Top level CAF without a cost centre attached
-        -- Attach CAF cc (collect if individual CAF ccs)
-        caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags
-                   then let cc = mkAutoCC binder modl CafCC
-                            ccs = mkSingletonCCS cc
-                                   -- careful: the binder might be :Main.main,
-                                   -- which doesn't belong to module mod_name.
-                                   -- bug #249, tests prof001, prof002
-                            modl | Just m <- nameModule_maybe (idName binder) = m
-                                 | otherwise = mod_name
-                        in do
-                        collectNewCC  cc
-                        collectCCS ccs
-                        return ccs
-                   else
-                        return all_cafs_ccs
-        body' <- do_expr body
-        return (StgRhsClosure caf_ccs bi fv u [] body')
-
-    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
-      = do body' <- do_expr body
-           return (StgRhsClosure dontCareCCS bi fv u args body')
-
-    do_top_rhs _ (StgRhsCon _ con args)
-        -- Top-level (static) data is not counted in heap
-        -- profiles; nor do we set CCCS from it; so we
-        -- just slam in dontCareCostCentre
-      = return (StgRhsCon dontCareCCS con args)
-
-    ------
-    do_expr :: StgExpr -> MassageM StgExpr
-
-    do_expr (StgLit l) = return (StgLit l)
-
-    do_expr (StgApp fn args)
-      = return (StgApp fn args)
-
-    do_expr (StgConApp con args ty_args)
-      = return (StgConApp con args ty_args)
-
-    do_expr (StgOpApp con args res_ty)
-      = return (StgOpApp con args res_ty)
-
-    do_expr (StgTick note@(ProfNote cc _ _) expr) = do
-        -- Ha, we found a cost centre!
-        collectCC cc
-        expr' <- do_expr expr
-        return (StgTick note expr')
-
-    do_expr (StgTick ti expr) = do
-        expr' <- do_expr expr
-        return (StgTick ti expr')
-
-    do_expr (StgCase expr bndr alt_type alts) = do
-        expr' <- do_expr expr
-        alts' <- mapM do_alt alts
-        return (StgCase expr' bndr alt_type alts')
-      where
-        do_alt (id, bs, e) = do
-            e' <- do_expr e
-            return (id, bs, e')
-
-    do_expr (StgLet b e) = do
-          (b,e) <- do_let b e
-          return (StgLet b e)
-
-    do_expr (StgLetNoEscape b e) = do
-          (b,e) <- do_let b e
-          return (StgLetNoEscape b e)
-
-    do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
-
-    ----------------------------------
-
-    do_let (StgNonRec b rhs) e = do
-        rhs' <- do_rhs rhs
-        e' <- do_expr e
-        return (StgNonRec b rhs',e')
-
-    do_let (StgRec pairs) e = do
-        pairs' <- mapM do_pair pairs
-        e' <- do_expr e
-        return (StgRec pairs', e')
-      where
-        do_pair (b, rhs) = do
-             rhs2 <- do_rhs rhs
-             return (b, rhs2)
-
-    ----------------------------------
-    do_rhs :: StgRhs -> MassageM StgRhs
-        -- We play much the same game as we did in do_top_rhs above;
-        -- but we don't have to worry about cafs etc.
-
-        -- throw away the SCC if we don't have to count entries.  This
-        -- is a little bit wrong, because we're attributing the
-        -- allocation of the constructor to the wrong place (XXX)
-        -- We should really attach (PushCC cc CurrentCCS) to the rhs,
-        -- but need to reinstate PushCC for that.
-    do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
-               (StgTick (ProfNote cc False{-not tick-} _push)
-                        (StgConApp con args _)))
-      = do collectCC cc
-           return (StgRhsCon currentCCS con args)
-
-    do_rhs (StgRhsClosure _ bi fv u args expr) = do
-        expr' <- do_expr expr
-        return (StgRhsClosure currentCCS bi fv u args expr')
-
-    do_rhs (StgRhsCon _ con args)
-      = return (StgRhsCon currentCCS con args)
-
-
--- -----------------------------------------------------------------------------
--- Boring monad stuff for this
-
-newtype MassageM result
-  = MassageM {
-      unMassageM :: Module              -- module name
-                 -> CollectedCCs
-                 -> (CollectedCCs, result)
-    }
-
-instance Functor MassageM where
-      fmap = liftM
-
-instance Applicative MassageM where
-      pure x = MassageM (\_ ccs -> (ccs, x))
-      (<*>) = ap
-      (*>) = thenMM_
-
-instance Monad MassageM where
-    (>>=) = thenMM
-    (>>)  = (*>)
-
--- the initMM function also returns the final CollectedCCs
-
-initMM :: Module        -- module name, which we may consult
-       -> MassageM a
-       -> (CollectedCCs, a)
-
-initMM mod_name (MassageM m) = m mod_name ([],[],[])
-
-thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
-thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
-
-thenMM expr cont = MassageM $ \mod ccs ->
-    case unMassageM expr mod ccs of { (ccs2, result) ->
-    unMassageM (cont result) mod ccs2 }
-
-thenMM_ expr cont = MassageM $ \mod ccs ->
-    case unMassageM expr mod ccs of { (ccs2, _) ->
-    unMassageM cont mod ccs2 }
-
-
-collectCC :: CostCentre -> MassageM ()
-collectCC cc
- = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
-  -> if (cc `ccFromThisModule` mod_name) then
-        ((cc : local_ccs, extern_ccs, ccss), ())
-     else -- must declare it "extern"
-        ((local_ccs, cc : extern_ccs, ccss), ())
-
--- Version of collectCC used when we definitely want to declare this
--- CC as local, even if its module name is not the same as the current
--- module name (eg. the special :Main module) see bug #249, #1472,
--- test prof001,prof002.
-collectNewCC :: CostCentre -> MassageM ()
-collectNewCC cc
- = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
-              -> ((cc : local_ccs, extern_ccs, ccss), ())
-
-collectCCS :: CostCentreStack -> MassageM ()
-
-collectCCS ccs
- = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
-              -> ASSERT(not (noCCSAttached ccs))
-                       ((local_ccs, extern_ccs, ccs : ccss), ())