Overhaul of infrastructure for profiling, coverage (HPC) and breakpoints

User visible changes
====================

Profilng
--------

Flags renamed (the old ones are still accepted for now):

  OLD            NEW
  ---------      ------------
  -auto-all      -fprof-auto
  -auto          -fprof-exported
  -caf-all       -fprof-cafs

New flags:

  -fprof-auto              Annotates all bindings (not just top-level
                           ones) with SCCs

  -fprof-top               Annotates just top-level bindings with SCCs

  -fprof-exported          Annotates just exported bindings with SCCs

  -fprof-no-count-entries  Do not maintain entry counts when profiling
                           (can make profiled code go faster; useful with
                           heap profiling where entry counts are not used)

Cost-centre stacks have a new semantics, which should in most cases
result in more useful and intuitive profiles.  If you find this not to
be the case, please let me know.  This is the area where I have been
experimenting most, and the current solution is probably not the
final version, however it does address all the outstanding bugs and
seems to be better than GHC 7.2.

Stack traces
------------

+RTS -xc now gives more information.  If the exception originates from
a CAF (as is common, because GHC tends to lift exceptions out to the
top-level), then the RTS walks up the stack and reports the stack in
the enclosing update frame(s).

Result: +RTS -xc is much more useful now - but you still have to
compile for profiling to get it.  I've played around a little with
adding 'head []' to GHC itself, and +RTS -xc does pinpoint the problem
quite accurately.

I plan to add more facilities for stack tracing (e.g. in GHCi) in the
future.

Coverage (HPC)
--------------

 * derived instances are now coloured yellow if they weren't used
 * likewise record field names
 * entry counts are more accurate (hpc --fun-entry-count)
 * tab width is now correct (markup was previously off in source with
   tabs)

Internal changes
================

In Core, the Note constructor has been replaced by

        Tick (Tickish b) (Expr b)

which is used to represent all the kinds of source annotation we
support: profiling SCCs, HPC ticks, and GHCi breakpoints.

Depending on the properties of the Tickish, different transformations
apply to Tick.  See CoreUtils.mkTick for details.

Tickets
=======

This commit closes the following tickets, test cases to follow:

  - Close #2552: not a bug, but the behaviour is now more intuitive
    (test is T2552)

  - Close #680 (test is T680)

  - Close #1531 (test is result001)

  - Close #949 (test is T949)

  - Close #2466: test case has bitrotted (doesn't compile against current
    version of vector-space package)

2 files changed, 205 insertions, 487 deletions

diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs
index 9e08831c97..8c2d938b8e 100644
--- a/compiler/profiling/CostCentre.lhs
+++ b/compiler/profiling/CostCentre.lhs
@@ -1,35 +1,20 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CostCentre]{The @CostCentre@ data type}
-
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- 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(..),
+        CostCentre(..), CcName, IsCafCC(..),
 		-- All abstract except to friend: ParseIface.y
 
 	CostCentreStack,
 	CollectedCCs,
-	noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
+        noCCS, currentCCS, dontCareCCS,
 	noCostCentre, noCCAttached,
-	noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
-	isDerivedFromCurrentCCS, maybeSingletonCCS,
-	decomposeCCS, pushCCisNop,
+        noCCSAttached, isCurrentCCS,
+        maybeSingletonCCS,
 
 	mkUserCC, mkAutoCC, mkAllCafsCC, 
-	mkSingletonCCS, dupifyCC, pushCCOnCCS,
-	isCafCCS, isCafCC,
-	isSccCountCostCentre,
-	sccAbleCostCentre,
-	ccFromThisModule,
+        mkSingletonCCS,
+        isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,
 
 	pprCostCentreCore,
 	costCentreUserName,
@@ -37,81 +22,22 @@ module CostCentre (
 	cmpCostCentre	-- used for removing dups in a list
     ) where
 
-import Var		( Id )
+import Var
 import Name
-import Module		( Module )
+import Module
 import Unique
 import Outputable	
 import FastTypes
 import FastString
-import Util	        ( thenCmp )
+import Util
 
 import Data.Data
-\end{code}
-
-A Cost Centre Stack is something that can be attached to a closure.
-This is either:
-	
-	- the current cost centre stack (CCCS)
-	- a pre-defined cost centre stack (there are several
-	  pre-defined CCSs, see below).
-
-\begin{code}
-data CostCentreStack
-  = NoCCS
 
-  | 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 
-			-- current-cost-centre-stack register.
-
-  | SubsumedCCS		-- Cost centre stack for top-level subsumed functions
-			-- (CAFs get an AllCafsCC).
-			-- Its execution costs get subsumed into the caller.
-			-- This guy is *only* ever pinned on static closures,
-			-- and is *never* the cost centre for an SCC construct.
-
-  | OverheadCCS		-- We charge costs due to the profiling-system
-  			-- doing its work to "overhead".
-			--
-			-- Objects whose CCS is "Overhead"
-			-- have their *allocation* charged to "overhead",
-			-- but have the current CCS put into the object
-			-- itself.
-
-			-- For example, if we transform "f g" to "let
-			-- g' = g in f g'" (so that something about
-			-- profiling works better...), then we charge
-			-- the *allocation* of g' to OverheadCCS, but
-			-- we put the cost-centre of the call to f
-			-- (i.e., current CCS) into the g' object.  When
-			-- g' is entered, the CCS of the call
-			-- to f will be set.
-
-  | DontCareCCS		-- We need a CCS to stick in static closures
-			-- (for data), but we *don't* expect them to
-			-- accumulate any costs.  But we still need
-			-- the placeholder.  This CCS is it.
-
-  | PushCC CostCentre CostCentreStack
-		-- These are used during code generation as the CCSs
-		-- attached to closures.  A PushCC never appears as
-		-- the argument to an _scc_.
-		--
-		-- The tail (2nd argument) is either NoCCS, indicating
-		-- a staticly allocated CCS, or CurrentCCS indicating
-		-- a dynamically created CCS.  We only support
-		-- statically allocated *singleton* CCSs at the
-		-- moment, for the purposes of initialising the CCS
-		-- field of a CAF.
-
-  deriving (Eq, Ord)	-- needed for Ord on CLabel
-\end{code}
+-----------------------------------------------------------------------------
+-- Cost Centres
 
-A Cost Centre is the argument of an _scc_ expression.
+-- | A Cost Centre is the argument of an _scc_ expression.
  
-\begin{code}
 data CostCentre
   = NoCostCentre	-- Having this constructor avoids having
 			-- to use "Maybe CostCentre" all the time.
@@ -119,8 +45,7 @@ data CostCentre
   | NormalCC {  
 		cc_name :: CcName,	-- Name of the cost centre itself
 		cc_mod  :: Module,	-- Name of module defining this CC.
-		cc_is_dupd :: IsDupdCC,	-- see below
-		cc_is_caf  :: IsCafCC	-- see below
+                cc_is_caf  :: IsCafCC   -- see below
     }
 
   | AllCafsCC {	
@@ -130,113 +55,77 @@ data CostCentre
 
 type CcName = FastString
 
-data IsDupdCC
-  = OriginalCC	-- This says how the CC is *used*.  Saying that
-  | DupdCC		-- it is DupdCC doesn't make it a different
-			-- CC, just that it a sub-expression which has
-			-- been moved ("dupd") into a different scope.
-			--
-			-- The point about a dupd SCC is that we don't
-			-- count entries to it, because it's not the
-			-- "original" one.
-			--
-			-- In the papers, it's called "SCCsub",
-			--  i.e. SCCsub CC == SCC DupdCC,
-			-- 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.
-type CollectedCCs
-  = ( [CostCentre]       -- local cost-centres that need to be decl'd
-    , [CostCentre]       -- "extern" cost-centres
-    , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
-    )
-\end{code}
+data IsCafCC = NotCafCC | CafCC
+  deriving (Eq, Ord, Data, Typeable)
 
-WILL: Would there be any merit to recording ``I am now using a
-cost-centre from another module''?  I don't know if this would help a
-user; it might be interesting to us to know how much computation is
-being moved across module boundaries.
+noCostCentre :: CostCentre
+noCostCentre = NoCostCentre
 
-SIMON: Maybe later...
 
-\begin{code}
-noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack
+instance Eq CostCentre where
+	c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
 
-noCCS 			= NoCCS
-subsumedCCS 		= SubsumedCCS
-currentCCS	 	= CurrentCCS
-overheadCCS	 	= OverheadCCS
-dontCareCCS	 	= DontCareCCS
+instance Ord CostCentre where
+	compare = cmpCostCentre
 
-noCostCentre :: CostCentre
-noCostCentre  		= NoCostCentre
-\end{code}
+cmpCostCentre :: CostCentre -> CostCentre -> Ordering
 
-Predicates on Cost-Centre Stacks
+cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})
+  = m1 `compare` m2
 
-\begin{code}
-noCCSAttached :: CostCentreStack -> Bool
-noCCSAttached NoCCS			= True
-noCCSAttached _				= False
+cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1}) 
+	      (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = c2}) 
+    -- first key is module name, then the name, then the cafness
+  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `compare` c2)
 
-noCCAttached :: CostCentre -> Bool
-noCCAttached NoCostCentre		= True
-noCCAttached _				= False
+cmpCostCentre other_1 other_2
+  = let
+	!tag1 = tag_CC other_1
+	!tag2 = tag_CC other_2
+    in
+    if tag1 <# tag2 then LT else GT
+  where
+    tag_CC NoCostCentre    = _ILIT(0)
+    tag_CC (NormalCC   {}) = _ILIT(1)
+    tag_CC (AllCafsCC  {}) = _ILIT(2)
 
-isCurrentCCS :: CostCentreStack -> Bool
-isCurrentCCS CurrentCCS			= True
-isCurrentCCS _	      			= False
 
-isSubsumedCCS :: CostCentreStack -> Bool
-isSubsumedCCS SubsumedCCS 		= True
-isSubsumedCCS _		     		= False
+-----------------------------------------------------------------------------
+-- Predicates on CostCentre
 
-isCafCCS :: CostCentreStack -> Bool
-isCafCCS (PushCC cc NoCCS)		= isCafCC cc
-isCafCCS _				= False
+isCafCC :: CostCentre -> Bool
+isCafCC (AllCafsCC {})                   = True
+isCafCC (NormalCC {cc_is_caf = CafCC}) = True
+isCafCC _		                 = False
 
-isDerivedFromCurrentCCS :: CostCentreStack -> Bool
-isDerivedFromCurrentCCS CurrentCCS	= True
-isDerivedFromCurrentCCS (PushCC _ ccs)	= isDerivedFromCurrentCCS ccs
-isDerivedFromCurrentCCS _		= False
+-- | Is this a cost-centre which records scc counts
+isSccCountCC :: CostCentre -> Bool
+isSccCountCC cc | isCafCC cc  = False
+                | otherwise   = True
 
-currentOrSubsumedCCS :: CostCentreStack -> Bool
-currentOrSubsumedCCS SubsumedCCS	= True
-currentOrSubsumedCCS CurrentCCS		= True
-currentOrSubsumedCCS _			= False
+-- | Is this a cost-centre which can be sccd ?
+sccAbleCC :: CostCentre -> Bool
+sccAbleCC NoCostCentre  = panic "sccAbleCC:NoCostCentre"
+sccAbleCC cc | isCafCC cc = False
+             | otherwise  = True
 
-maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
-maybeSingletonCCS (PushCC cc NoCCS)	= Just cc
-maybeSingletonCCS _			= Nothing
+ccFromThisModule :: CostCentre -> Module -> Bool
+ccFromThisModule cc m = cc_mod cc == m
 
-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
+-----------------------------------------------------------------------------
+-- Building cost centres
 
-\begin{code}
 mkUserCC :: FastString -> Module -> CostCentre
 mkUserCC cc_name mod
   = NormalCC { cc_name = cc_name, cc_mod =  mod,
-	       cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
+               cc_is_caf = NotCafCC {-might be changed-}
     }
 
 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
 mkAutoCC id mod is_caf
   = NormalCC { cc_name = str, cc_mod =  mod,
-	       cc_is_dupd = OriginalCC, cc_is_caf = is_caf
+               cc_is_caf = is_caf
     }
   where 
         name = getName id
@@ -249,153 +138,126 @@ mkAutoCC id mod is_caf
                                       ftext (occNameFS (getOccName id))
                                       <> char '_' <> pprUnique (getUnique name)
 mkAllCafsCC :: Module -> CostCentre
-mkAllCafsCC m = AllCafsCC  { cc_mod = m }
+mkAllCafsCC m = AllCafsCC { cc_mod = m }
 
+-----------------------------------------------------------------------------
+-- Cost Centre Stacks
 
+-- | A Cost Centre Stack is something that can be attached to a closure.
+-- This is either:
+-- 	
+--      * the current cost centre stack (CCCS)
+--      * a pre-defined cost centre stack (there are several
+-- 	  pre-defined CCSs, see below).
 
-mkSingletonCCS :: CostCentre -> CostCentreStack
-mkSingletonCCS cc = pushCCOnCCS cc NoCCS
+data CostCentreStack
+  = NoCCS
 
-pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
-pushCCOnCCS = PushCC
+  | 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 
+			-- current-cost-centre-stack register.
 
-dupifyCC :: CostCentre -> CostCentre
-dupifyCC cc = cc {cc_is_dupd = DupdCC}
+  | DontCareCCS         -- We need a CCS to stick in static closures
+			-- (for data), but we *don't* expect them to
+			-- accumulate any costs.  But we still need
+			-- the placeholder.  This CCS is it.
 
-isCafCC, isDupdCC :: CostCentre -> Bool
+  | SingletonCCS CostCentre
 
-isCafCC (AllCafsCC {})		         = True
-isCafCC (NormalCC {cc_is_caf = CafCC}) = True
-isCafCC _		                 = False
+  deriving (Eq, Ord)	-- needed for Ord on CLabel
 
-isDupdCC (NormalCC   {cc_is_dupd = DupdCC}) = True
-isDupdCC _		                     = False
 
-isSccCountCostCentre :: CostCentre -> Bool
-  -- Is this a cost-centre which records scc counts
+-- synonym for triple which describes the cost centre info in the generated
+-- 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
+    )
 
-#if DEBUG
-isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
-#endif
-isSccCountCostCentre cc | isCafCC cc  = False
-                        | isDupdCC cc = False
-			| otherwise   = True
 
-sccAbleCostCentre :: CostCentre -> Bool
-  -- Is this a cost-centre which can be sccd ?
+noCCS, currentCCS, dontCareCCS :: CostCentreStack
 
-#if DEBUG
-sccAbleCostCentre NoCostCentre  = panic "sccAbleCC:NoCostCentre"
-#endif
-sccAbleCostCentre cc | isCafCC cc = False
-		     | otherwise  = True
+noCCS 			= NoCCS
+currentCCS              = CurrentCCS
+dontCareCCS             = DontCareCCS
 
-ccFromThisModule :: CostCentre -> Module -> Bool
-ccFromThisModule cc m = cc_mod cc == m
-\end{code}
+-----------------------------------------------------------------------------
+-- Predicates on Cost-Centre Stacks
 
-\begin{code}
-instance Eq CostCentre where
-	c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
+noCCSAttached :: CostCentreStack -> Bool
+noCCSAttached NoCCS			= True
+noCCSAttached _				= False
 
-instance Ord CostCentre where
-	compare = cmpCostCentre
+noCCAttached :: CostCentre -> Bool
+noCCAttached NoCostCentre		= True
+noCCAttached _				= False
 
-cmpCostCentre :: CostCentre -> CostCentre -> Ordering
+isCurrentCCS :: CostCentreStack -> Bool
+isCurrentCCS CurrentCCS			= True
+isCurrentCCS _	      			= False
 
-cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2}) = m1 `compare` m2
+isCafCCS :: CostCentreStack -> Bool
+isCafCCS (SingletonCCS cc)              = isCafCC cc
+isCafCCS _				= False
 
-cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1}) 
-	      (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = c2}) 
-    -- first key is module name, then we use "kinds" (which include
-    -- names) and finally the caf flag
-  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
+maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
+maybeSingletonCCS (SingletonCCS cc)     = Just cc
+maybeSingletonCCS _			= Nothing
 
-cmpCostCentre other_1 other_2
-  = let
-	!tag1 = tag_CC other_1
-	!tag2 = tag_CC other_2
-    in
-    if tag1 <# tag2 then LT else GT
-  where
-    tag_CC (NormalCC   {}) = _ILIT(1)
-    tag_CC (AllCafsCC  {}) = _ILIT(2)
+mkSingletonCCS :: CostCentre -> CostCentreStack
+mkSingletonCCS cc = SingletonCCS cc
 
--- TODO: swap order of IsCafCC, add deriving Ord
-cmp_caf :: IsCafCC -> IsCafCC -> Ordering
-cmp_caf NotCafCC CafCC     = LT
-cmp_caf NotCafCC NotCafCC  = EQ
-cmp_caf CafCC    CafCC     = EQ
-cmp_caf CafCC    NotCafCC  = GT
-
-decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack)
-decomposeCCS (PushCC cc ccs) = (cc:more, ccs') 
-  where (more,ccs') = decomposeCCS ccs
-decomposeCCS ccs = ([],ccs)
-\end{code}
 
 -----------------------------------------------------------------------------
-Printing Cost Centre Stacks.
-
-The outputable instance for CostCentreStack prints the CCS as a C
-expression.
+-- Printing Cost Centre Stacks.
 
-NOTE: Not all cost centres are suitable for using in a static
-initializer.  In particular, the PushCC forms where the tail is CCCS
-may only be used in inline C code because they expand to a
-non-constant C expression.
+-- The outputable instance for CostCentreStack prints the CCS as a 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") <> 
-			   parens (ppr ccs <> comma <> 
-			   parens(ptext (sLit "void *")) <> ppr cc)
-\end{code}
-
------------------------------------------------------------------------------
-Printing Cost Centres.
-
-There are several different ways in which we might want to print a
-cost centre:
+  ppr DontCareCCS       = ptext (sLit "CCS_DONT_CARE")
+  ppr (SingletonCCS cc) = ppr cc <> ptext (sLit "_ccs")
 
-	- the name of the cost centre, for profiling output (a C string)
-	- the label, i.e. C label for cost centre in .hc file.
-	- the debugging name, for output in -ddump things
-	- the interface name, for printing in _scc_ exprs in iface files.
 
-The last 3 are derived from costCentreStr below.  The first is given
-by costCentreName.
+-----------------------------------------------------------------------------
+-- Printing Cost Centres
+-- 
+-- There are several different ways in which we might want to print a
+-- cost centre:
+-- 
+-- 	- the name of the cost centre, for profiling output (a C string)
+-- 	- the label, i.e. C label for cost centre in .hc file.
+-- 	- the debugging name, for output in -ddump things
+-- 	- the interface name, for printing in _scc_ exprs in iface files.
+-- 
+-- The last 3 are derived from costCentreStr below.  The first is given
+-- by costCentreName.
 
-\begin{code}
 instance Outputable CostCentre where
   ppr cc = getPprStyle $ \ sty ->
 	   if codeStyle sty
   	   then ppCostCentreLbl cc
 	   else text (costCentreUserName cc)
 
--- Printing in an interface file or in Core generally
+-- Printing in Core
 pprCostCentreCore :: CostCentre -> SDoc
+pprCostCentreCore NoCostCentre
+  = text "__no_cc"
 pprCostCentreCore (AllCafsCC {cc_mod = m})
   = text "__sccC" <+> braces (ppr m)
 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
-			     cc_is_caf = caf, cc_is_dupd = dup})
+                             cc_is_caf = caf})
   = text "__scc" <+> braces (hsep [
 	ftext (zEncodeFS n),
 	ppr m,
-	pp_dup dup,
-	pp_caf caf
+        pp_caf caf
     ])
 
-pp_dup :: IsDupdCC -> SDoc
-pp_dup DupdCC = char '!'
-pp_dup _      = empty
-
 pp_caf :: IsCafCC -> SDoc
 pp_caf CafCC = text "__C"
 pp_caf _     = empty
@@ -415,4 +277,5 @@ costCentreUserName (NoCostCentre)  = "NO_CC"
 costCentreUserName (AllCafsCC {})  = "CAF"
 costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
   =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ unpackFS name
+
 \end{code}
diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs
index f09b291db7..96a21eb056 100644
--- a/compiler/profiling/SCCfinal.lhs
+++ b/compiler/profiling/SCCfinal.lhs
@@ -1,27 +1,23 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[SCCfinal]{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.  But will still have to give them "extern"
-   declarations.
-
- - Puts on CAF cost-centres if the user has asked for individual CAF
-   cost-centres.
-
- - Ditto for individual DICT cost-centres.
-
- - Boxes top-level inherited functions passed as arguments.
+\begin{code}
+-----------------------------------------------------------------------------
+-- Modify and collect code generation for final STG program
 
- - "Distributes" given cost-centres to all as-yet-unmarked RHSs.
+{-
+ 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.
+-}
 
-\begin{code}
 module SCCfinal ( stgMassageForProfiling ) where
 
 #include "HsVersions.h"
@@ -32,17 +28,12 @@ import CostCentre       -- lots of things
 import Id
 import Name
 import Module
-import UniqSupply       ( splitUniqSupply, UniqSupply )
-#ifdef PROF_DO_BOXING
-import UniqSupply       ( uniqFromSupply )
-#endif
-import VarSet
+import UniqSupply       ( UniqSupply )
 import ListSetOps       ( removeDups )
 import Outputable
 import DynFlags
-\end{code}
 
-\begin{code}
+
 stgMassageForProfiling
         :: DynFlags
         -> Module                       -- module name
@@ -50,16 +41,15 @@ stgMassageForProfiling
         -> [StgBinding]                 -- input
         -> (CollectedCCs, [StgBinding])
 
-stgMassageForProfiling dflags mod_name us stg_binds
+stgMassageForProfiling dflags mod_name _us stg_binds
   = let
         ((local_ccs, extern_ccs, cc_stacks),
          stg_binds2)
-          = initMM mod_name us (do_top_bindings stg_binds)
+          = initMM mod_name (do_top_bindings stg_binds)
 
         (fixed_ccs, fixed_cc_stacks)
           = if dopt Opt_AutoSccsOnIndividualCafs dflags
             then ([],[])  -- don't need "all CAFs" CC
-                          -- (for Prelude, we use PreludeCC)
             else ([all_cafs_cc], [all_cafs_ccs])
 
         local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
@@ -80,17 +70,14 @@ stgMassageForProfiling dflags mod_name us stg_binds
 
     do_top_bindings (StgNonRec b rhs : bs) = do
         rhs' <- do_top_rhs b rhs
-        addTopLevelIshId b $ do
-           bs' <- do_top_bindings bs
-           return (StgNonRec b rhs' : bs')
-
-    do_top_bindings (StgRec pairs : bs)
-      = addTopLevelIshIds binders $ do
-           pairs2 <- mapM do_pair pairs
-           bs' <- do_top_bindings bs
-           return (StgRec pairs2 : bs')
+        bs' <- do_top_bindings bs
+        return (StgNonRec b rhs' : bs')
+
+    do_top_bindings (StgRec pairs : bs) = do
+        pairs2 <- mapM do_pair pairs
+        bs' <- do_top_bindings bs
+        return (StgRec pairs2 : bs')
       where
-        binders = map fst pairs
         do_pair (b, rhs) = do
              rhs2 <- do_top_rhs b rhs
              return (b, rhs2)
@@ -98,27 +85,17 @@ stgMassageForProfiling dflags mod_name us stg_binds
     ----------
     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
 
-    do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] (StgSCC cc (StgConApp con args)))
-      | not (isSccCountCostCentre cc) && not (isDllConApp dflags con args)
+    do_top_rhs _ (StgRhsClosure _ _ _ _ _ []
+                     (StgSCC _cc False{-not tick-} _push (StgConApp con args)))
+      | not (isDllConApp dflags 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)
 
-{- Can't do this one with cost-centre stacks:  --SDM
-    do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
-      | (noCCSAttached no_cc || currentOrSubsumedCCS no_cc)
-        && not (isSccCountCostCentre cc)
-        -- Top level CAF without a cost centre attached
-        -- Attach and collect cc of trivial _scc_ in body
-      = do collectCC cc
-           expr' <- set_prevailing_cc cc (do_expr expr)
-           return (StgRhsClosure cc bi fv u [] expr')
--}
-
-    do_top_rhs binder (StgRhsClosure no_cc bi fv u srt [] body)
-      | noCCSAttached no_cc || currentOrSubsumedCCS no_cc = do
+    do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body)
+      = do
         -- Top level CAF without a cost centre attached
         -- Attach CAF cc (collect if individual CAF ccs)
         caf_ccs <- if dopt Opt_AutoSccsOnIndividualCafs dflags
@@ -135,22 +112,12 @@ stgMassageForProfiling dflags mod_name us stg_binds
                         return ccs
                    else
                         return all_cafs_ccs
-        body' <- set_prevailing_cc caf_ccs (do_expr body)
+        body' <- do_expr body
         return (StgRhsClosure caf_ccs bi fv u srt [] body')
 
-    do_top_rhs _ (StgRhsClosure cc _ _ _ _ [] _)
-        -- Top level CAF with cost centre attached
-        -- Should this be a CAF cc ??? Does this ever occur ???
-      = pprPanic "SCCfinal: CAF with cc:" (ppr cc)
-
-    do_top_rhs _ (StgRhsClosure no_ccs bi fv u srt args body)
-        -- Top level function, probably subsumed
-      | noCCSAttached no_ccs
-      = do body' <- set_lambda_cc (do_expr body)
-           return (StgRhsClosure subsumedCCS bi fv u srt args body')
-
-      | otherwise
-      = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs)
+    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body)
+      = do body' <- do_expr body
+           return (StgRhsClosure dontCareCCS bi fv u srt args body')
 
     do_top_rhs _ (StgRhsCon _ con args)
         -- Top-level (static) data is not counted in heap
@@ -164,18 +131,18 @@ stgMassageForProfiling dflags mod_name us stg_binds
     do_expr (StgLit l) = return (StgLit l)
 
     do_expr (StgApp fn args)
-      = boxHigherOrderArgs (StgApp fn) args
+      = return (StgApp fn args)
 
     do_expr (StgConApp con args)
-      = boxHigherOrderArgs (\args -> StgConApp con args) args
+      = return (StgConApp con args)
 
     do_expr (StgOpApp con args res_ty)
-      = boxHigherOrderArgs (\args -> StgOpApp con args res_ty) args
+      = return (StgOpApp con args res_ty)
 
-    do_expr (StgSCC cc expr) = do -- Ha, we found a cost centre!
+    do_expr (StgSCC cc tick push expr) = do -- Ha, we found a cost centre!
         collectCC cc
         expr' <- do_expr expr
-        return (StgSCC cc expr')
+        return (StgSCC cc tick push expr')
 
     do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
         expr' <- do_expr expr
@@ -204,17 +171,14 @@ stgMassageForProfiling dflags mod_name us stg_binds
 
     do_let (StgNonRec b rhs) e = do
         rhs' <- do_rhs rhs
-        addTopLevelIshId b $ do
-          e' <- do_expr e
-          return (StgNonRec b rhs',e')
-
-    do_let (StgRec pairs) e
-      = addTopLevelIshIds binders $ do
-           pairs' <- mapM do_pair pairs
-           e' <- do_expr e
-           return (StgRec pairs', e')
+        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
-        binders = map fst pairs
         do_pair (b, rhs) = do
              rhs2 <- do_rhs rhs
              return (b, rhs2)
@@ -224,171 +188,62 @@ stgMassageForProfiling dflags mod_name us stg_binds
         -- We play much the same game as we did in do_top_rhs above;
         -- but we don't have to worry about cafs etc.
 
-{-
-    do_rhs (StgRhsClosure closure_cc bi fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
-      | not (isSccCountCostCentre cc)
+        -- 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 _srt []
+               (StgSCC cc False{-not tick-} _push (StgConApp con args)))
       = do collectCC cc
-           return (StgRhsCon cc con args)
--}
+           return (StgRhsCon currentCCS con args)
 
     do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
-        (expr', ccs) <- slurpSCCs currentCCS expr
-        expr'' <- do_expr expr'
-        return (StgRhsClosure ccs bi fv u srt args expr'')
-      where
-        slurpSCCs ccs (StgSCC cc e)
-             = do collectCC cc
-                  slurpSCCs (cc `pushCCOnCCS` ccs) e
-        slurpSCCs ccs e
-             = return (e, ccs)
+        expr' <- do_expr expr
+        return (StgRhsClosure currentCCS bi fv u srt args expr')
 
     do_rhs (StgRhsCon _ con args)
       = return (StgRhsCon currentCCS con args)
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection{Boxing higher-order args}
-%*                                                                      *
-%************************************************************************
-
-Boxing is *turned off* at the moment, until we can figure out how to
-do it properly in general.
-
-\begin{code}
-boxHigherOrderArgs
-    :: ([StgArg] -> StgExpr)
-                        -- An application lacking its arguments
-    -> [StgArg]         -- arguments which we might box
-    -> MassageM StgExpr
-
-#ifndef PROF_DO_BOXING
-boxHigherOrderArgs almost_expr args
-   = return (almost_expr args)
-#else
-boxHigherOrderArgs almost_expr args = do
-    ids <- getTopLevelIshIds
-    (let_bindings, new_args) <- mapAccumLM (do_arg ids) [] args
-    return (foldr (mk_stg_let currentCCS) (almost_expr new_args) let_bindings)
-  where
-    ---------------
-
-    do_arg ids bindings arg@(StgVarArg old_var)
-        |  (not (isLocalVar old_var) || elemVarSet old_var ids)
-        && isFunTy (dropForAlls var_type)
-      = do    -- make a trivial let-binding for the top-level function
-        uniq <- getUniqueMM
-        let
-            new_var = mkSysLocal (fsLit "sf") uniq var_type
-        return ( (new_var, old_var) : bindings, StgVarArg new_var )
-      where
-        var_type = idType old_var
-
-    do_arg ids bindings arg = return (bindings, arg)
-
-    ---------------
-    mk_stg_let :: CostCentreStack -> (Id, Id) -> StgExpr -> StgExpr
 
-    mk_stg_let cc (new_var, old_var) body
-      = let
-            rhs_body    = StgApp old_var [{-args-}]
-            rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant NoSRT{-eeek!!!-} [{-args-}] rhs_body
-        in
-        StgLet (StgNonRec new_var rhs_closure) body
-      where
-        bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
-#endif
-\end{code}
 
-%************************************************************************
-%*                                                                      *
-\subsection{Boring monad stuff for this}
-%*                                                                      *
-%************************************************************************
+-- -----------------------------------------------------------------------------
+-- Boring monad stuff for this
 
-\begin{code}
 newtype MassageM result
   = MassageM {
       unMassageM :: Module              -- module name
-                 -> CostCentreStack     -- prevailing CostCentre
-                                        -- if none, subsumedCosts at top-level
-                                        -- currentCostCentre at nested levels
-                 -> UniqSupply
-                 -> VarSet              -- toplevel-ish Ids for boxing
                  -> CollectedCCs
                  -> (CollectedCCs, result)
     }
 
 instance Monad MassageM where
-    return x = MassageM (\_ _ _ _ ccs -> (ccs, x))
+    return x = MassageM (\_ ccs -> (ccs, x))
     (>>=) = thenMM
     (>>)  = thenMM_
 
 -- the initMM function also returns the final CollectedCCs
 
 initMM :: Module        -- module name, which we may consult
-       -> UniqSupply
        -> MassageM a
        -> (CollectedCCs, a)
 
-initMM mod_name init_us (MassageM m) = m mod_name noCCS init_us emptyVarSet ([],[],[])
+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 scope_cc us ids ccs ->
-    case splitUniqSupply us of { (s1, s2) ->
-    case unMassageM expr mod scope_cc s1 ids ccs of { (ccs2, result) ->
-    unMassageM (cont result) mod scope_cc s2 ids ccs2 }}
-
-thenMM_ expr cont = MassageM $ \mod scope_cc us ids ccs ->
-    case splitUniqSupply us of { (s1, s2) ->
-    case unMassageM expr mod scope_cc s1 ids ccs of { (ccs2, _) ->
-    unMassageM cont mod scope_cc s2 ids ccs2 }}
-
-#ifdef PROF_DO_BOXING
-getUniqueMM :: MassageM Unique
-getUniqueMM = MassageM \mod scope_cc us ids ccs -> (ccs, uniqFromSupply us)
-#endif
-
-addTopLevelIshId :: Id -> MassageM a -> MassageM a
-addTopLevelIshId id scope
-   = MassageM $ \mod scope_cc us ids ccs ->
-      if isCurrentCCS scope_cc then unMassageM scope mod scope_cc us ids ccs
-                               else unMassageM scope mod scope_cc us (extendVarSet ids id) ccs
-
-addTopLevelIshIds :: [Id] -> MassageM a -> MassageM a
-addTopLevelIshIds [] cont = cont
-addTopLevelIshIds (id:ids) cont
-  = addTopLevelIshId id (addTopLevelIshIds ids cont)
-
-#ifdef PROF_DO_BOXING
-getTopLevelIshIds :: MassageM VarSet
-getTopLevelIshIds = MassageM $ \_mod _scope_cc _us ids ccs -> (ccs, ids)
-#endif
-\end{code}
+thenMM expr cont = MassageM $ \mod ccs ->
+    case unMassageM expr mod ccs of { (ccs2, result) ->
+    unMassageM (cont result) mod ccs2 }
 
-The prevailing CCS is used to tell whether we're in a top-levelish
-position, where top-levelish is defined as "not inside a lambda".
-Prevailing CCs used to be used for something much more complicated,
-I'm sure --SDM
+thenMM_ expr cont = MassageM $ \mod ccs ->
+    case unMassageM expr mod ccs of { (ccs2, _) ->
+    unMassageM cont mod ccs2 }
 
-\begin{code}
-set_lambda_cc :: MassageM a -> MassageM a
-set_lambda_cc action
-   =    MassageM $     \mod _scope_cc  us ids ccs
-   -> unMassageM action mod currentCCS us ids ccs
-
-set_prevailing_cc :: CostCentreStack -> MassageM a -> MassageM a
-set_prevailing_cc cc_to_set_to action
-   =    MassageM $     \mod _scope_cc    us ids ccs
-   -> unMassageM action mod cc_to_set_to us ids ccs
-\end{code}
 
-\begin{code}
 collectCC :: CostCentre -> MassageM ()
 collectCC cc
- = MassageM $ \mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
+ = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
   -> ASSERT(not (noCCAttached cc))
      if (cc `ccFromThisModule` mod_name) then
         ((cc : local_ccs, extern_ccs, ccss), ())
@@ -401,13 +256,13 @@ collectCC cc
 -- test prof001,prof002.
 collectNewCC :: CostCentre -> MassageM ()
 collectNewCC cc
- = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
+ = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
               -> ((cc : local_ccs, extern_ccs, ccss), ())
 
 collectCCS :: CostCentreStack -> MassageM ()
 
 collectCCS ccs
- = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
+ = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
               -> ASSERT(not (noCCSAttached ccs))
                        ((local_ccs, extern_ccs, ccs : ccss), ())
 \end{code}