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, 39 insertions, 107 deletions

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 2b2b3229d7..f207074cd8 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,8 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-		 dsHsWrapper, dsTcEvBinds, dsEvBinds, 
-		 AutoScc(..)
+                 dsHsWrapper, dsTcEvBinds, dsEvBinds,
   ) where
 
 #include "HsVersions.h"
@@ -39,8 +38,6 @@ import TcType
 import Type
 import Coercion hiding (substCo)
 import TysWiredIn ( eqBoxDataCon, tupleCon )
-import CostCentre
-import Module
 import Id
 import Class
 import DataCon	( dataConWorkId )
@@ -69,70 +66,68 @@ import MonadUtils
 %************************************************************************
 
 \begin{code}
-dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
+dsTopLHsBinds binds = ds_lhs_binds binds
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
+dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
                       ; return (fromOL binds') }
 
 ------------------------
-ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
+ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 
-	 -- scc annotation policy (see below)
-ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
-                                 ; return (foldBag appOL id nilOL ds_bs) }
+ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
+                        ; return (foldBag appOL id nilOL ds_bs) }
 
-dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
-dsLHsBind auto_scc (L loc bind)
-  = putSrcSpanDs loc $ dsHsBind auto_scc bind
+dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind (L loc bind)
+  = putSrcSpanDs loc $ dsHsBind bind
 
-dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
 
-dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
+dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
   = do  { core_expr <- dsLExpr expr
 
 	        -- Dictionary bindings are always VarBinds,
 	        -- so we only need do this here
-	; core_expr' <- addDictScc var core_expr
-	; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
+        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
 	      	   | otherwise         = var
 
-	; return (unitOL (makeCorePair var' False 0 core_expr')) }
+        ; return (unitOL (makeCorePair var' False 0 core_expr)) }
 
-dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches
-		    , fun_co_fn = co_fn, fun_tick = tick 
-                    , fun_infix = inf }) 
+dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
+                  , fun_co_fn = co_fn, fun_tick = tick
+                  , fun_infix = inf })
  = do	{ (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
-	; body'    <- mkOptTickBox tick body
-	; wrap_fn' <- dsHsWrapper co_fn 
-	; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
-	; return (unitOL (makeCorePair fun False 0 rhs)) }
-
-dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+        ; let body' = mkOptTickBox tick body
+        ; wrap_fn' <- dsHsWrapper co_fn
+        ; let rhs = wrap_fn' (mkLams args body')
+        ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
+           return (unitOL (makeCorePair fun False 0 rhs)) }
+
+dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
+                  , pat_ticks = (rhs_tick, var_ticks) })
   = do	{ body_expr <- dsGuarded grhss ty
-	; sel_binds <- mkSelectorBinds pat body_expr
+        ; let body' = mkOptTickBox rhs_tick body_expr
+        ; sel_binds <- mkSelectorBinds var_ticks pat body'
 	  -- We silently ignore inline pragmas; no makeCorePair
 	  -- Not so cool, but really doesn't matter
-    ; let sel_binds' = [ (v, addAutoScc auto_scc v expr)
-                       | (v, expr) <- sel_binds ]
-	; return (toOL sel_binds') }
+    ; return (toOL sel_binds) }
 
 	-- A common case: one exported variable
 	-- Non-recursive bindings come through this way
 	-- So do self-recursive bindings, and recursive bindings
 	-- that have been chopped up with type signatures
-dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
-               		    , abs_exports = [export]
-               		    , abs_ev_binds = ev_binds, abs_binds = binds })
+dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+                   , abs_exports = [export]
+                   , abs_ev_binds = ev_binds, abs_binds = binds })
   | ABE { abe_wrap = wrap, abe_poly = global
         , abe_mono = local, abe_prags = prags } <- export
-  = do	{ bind_prs    <- ds_lhs_binds NoSccs binds
+  = do  { bind_prs    <- ds_lhs_binds binds
         ; ds_ev_binds <- dsTcEvBinds ev_binds
         ; wrap_fn <- dsHsWrapper wrap
 	; let	core_bind = Rec (fromOL bind_prs)
-	        rhs       = addAutoScc auto_scc global $
-			    wrap_fn $  -- Usually the identity
+                rhs       = wrap_fn $  -- Usually the identity
 			    mkLams tyvars $ mkLams dicts $ 
 	                    mkCoreLets ds_ev_binds $
                             Let core_bind $
@@ -146,17 +141,12 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
     
 	; return (main_bind `consOL` spec_binds) }
 
-dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
-                            , abs_exports = exports, abs_ev_binds = ev_binds
-                       	    , abs_binds = binds })
-  = do	{ bind_prs    <- ds_lhs_binds NoSccs binds
+dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+                   , abs_exports = exports, abs_ev_binds = ev_binds
+                   , abs_binds = binds })
+  = do  { bind_prs    <- ds_lhs_binds binds
         ; ds_ev_binds <- dsTcEvBinds ev_binds
-	; let env = mkABEnv exports
-	      do_one (lcl_id,rhs) | Just export <- lookupVarEnv env lcl_id
-			          = (lcl_id, addAutoScc auto_scc (abe_poly export) rhs)
-				  | otherwise = (lcl_id,rhs)
-	       
-	      core_bind = Rec (map do_one (fromOL bind_prs))
+        ; let core_bind = Rec (fromOL bind_prs)
 	      	-- Monomorphic recursion possible, hence Rec
 
 	      tup_expr     = mkBigCoreVarTup locals
@@ -181,8 +171,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
 		     ; let global' = addIdSpecialisations global rules
 		     ; return ((global', rhs) `consOL` spec_binds) }
 
-	; export_binds_s <- mapM mk_bind exports
-	     -- Don't scc (auto-)annotate the tuple itself.
+        ; export_binds_s <- mapM mk_bind exports
 
 	; return ((poly_tup_id, poly_tup_rhs) `consOL` 
 		    concatOL export_binds_s) }
@@ -310,17 +299,6 @@ makeCorePair gbl_id is_default_method dict_arity rhs
 dictArity :: [Var] -> Arity
 -- Don't count coercion variables in arity
 dictArity dicts = count isId dicts
-
-
-------------------------
-type AbsBindEnv = VarEnv (ABExport Id)
-	-- Maps the "lcl_id" for an AbsBind to
-	-- its "gbl_id" and associated pragmas, if any
-
-mkABEnv :: [ABExport Id] -> AbsBindEnv
--- Takes the exports of a AbsBinds, and returns a mapping
---	lcl_id -> (tyvars, gbl_id, lcl_id, prags)
-mkABEnv exports = mkVarEnv [ (abe_mono export, export) | export <- exports]
 \end{code}
 
 Note [Rules and inlining]
@@ -691,52 +669,6 @@ as the old one, but with an Internal name and no IdInfo.
 
 %************************************************************************
 %*									*
-\subsection[addAutoScc]{Adding automatic sccs}
-%*									*
-%************************************************************************
-
-\begin{code}
-data AutoScc = NoSccs 
-	     | AddSccs Module (Id -> Bool)
--- The (Id->Bool) says which Ids to add SCCs to 
--- But we never add a SCC to function marked INLINE
-
-addAutoScc :: AutoScc	
-	   -> Id	-- Binder
-	   -> CoreExpr 	-- Rhs
-	   -> CoreExpr	-- Scc'd Rhs
-
-addAutoScc NoSccs _ rhs
-  = rhs
-addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
-  = rhs
-addAutoScc (AddSccs mod add_scc) id rhs
-  | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
-  | otherwise  = rhs
-\end{code}
-
-If profiling and dealing with a dict binding,
-wrap the dict in @_scc_ DICT <dict>@:
-
-\begin{code}
-addDictScc :: Id -> CoreExpr -> DsM CoreExpr
-addDictScc _ rhs = return rhs
-
-{- DISABLED for now (need to somehow make up a name for the scc) -- SDM
-  | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
-    || not (isDictId var)
-  = return rhs				-- That's easy: do nothing
-
-  | otherwise
-  = do (mod, grp) <- getModuleAndGroupDs
-	-- ToDo: do -dicts-all flag (mark dict things with individual CCs)
-       return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
--}
-\end{code}
-
-
-%************************************************************************
-%*									*
 		Desugaring coercions
 %*									*
 %************************************************************************