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)

1 files changed, 70 insertions, 215 deletions

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}