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, 30 insertions, 41 deletions

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 462137ade8..1bdeafb411 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -35,7 +35,7 @@ module DsUtils (
         dsSyntaxTable, lookupEvidence,
 
 	selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-	mkTickBox, mkOptTickBox, mkBinaryTickBox
+        mkOptTickBox, mkBinaryTickBox
     ) where
 
 #include "HsVersions.h"
@@ -70,7 +70,8 @@ import SrcLoc
 import Util
 import ListSetOps
 import FastString
-import StaticFlags
+
+import Control.Monad    ( zipWithM )
 \end{code}
 
 
@@ -568,14 +569,17 @@ cases like
      (p,q) = e
 
 \begin{code}
-mkSelectorBinds :: LPat Id	-- The pattern
+mkSelectorBinds :: [Maybe (Tickish Id)]  -- ticks to add, possibly
+                -> LPat Id      -- The pattern
 		-> CoreExpr	-- Expression to which the pattern is bound
 		-> DsM [(Id,CoreExpr)]
 
-mkSelectorBinds (L _ (VarPat v)) val_expr
-  = return [(v, val_expr)]
+mkSelectorBinds ticks (L _ (VarPat v)) val_expr
+  = return [(v, case ticks of
+                  [t] -> mkOptTickBox t val_expr
+                  _   -> val_expr)]
 
-mkSelectorBinds pat val_expr
+mkSelectorBinds ticks pat val_expr
   | null binders 
   = return []
 
@@ -599,7 +603,7 @@ mkSelectorBinds pat val_expr
         -- But we need it at different types... so we use coerce for that
        ; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID  unitTy (ppr pat)
        ; err_var <- newSysLocalDs unitTy
-       ; binds <- mapM (mk_bind val_var err_var) binders
+       ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders
        ; return ( (val_var, val_expr) : 
                   (err_var, err_expr) :
                   binds ) }
@@ -608,22 +612,26 @@ mkSelectorBinds pat val_expr
   = do { error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
        ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
        ; tuple_var <- newSysLocalDs tuple_ty
-       ; let mk_tup_bind binder
-              = (binder, mkTupleSelector local_binders binder tuple_var (Var tuple_var))
-       ; return ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) }
+       ; let mk_tup_bind tick binder
+              = (binder, mkOptTickBox tick $
+                            mkTupleSelector local_binders binder
+                                            tuple_var (Var tuple_var))
+       ; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) }
   where
     binders       = collectPatBinders pat
-    local_binders = map localiseId binders	-- See Note [Localise pattern binders]
+    ticks'        = ticks ++ repeat Nothing
+
+    local_binders = map localiseId binders      -- See Note [Localise pattern binders]
     local_tuple   = mkBigCoreVarTup binders
     tuple_ty      = exprType local_tuple
 
-    mk_bind scrut_var err_var bndr_var = do
+    mk_bind scrut_var err_var tick bndr_var = do
     -- (mk_bind sv err_var) generates
     --          bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
     -- Remember, pat binds bv
         rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
                                 (Var bndr_var) error_expr
-        return (bndr_var, rhs_expr)
+        return (bndr_var, mkOptTickBox tick rhs_expr)
       where
         error_expr = mkCoerce co (Var err_var)
         co         = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
@@ -767,38 +775,19 @@ CPR-friendly.  This matters a lot: if you don't get it right, you lose
 the tail call property.  For example, see Trac #3403.
 
 \begin{code}
-mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
-mkOptTickBox Nothing e   = return e
-mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
-
-mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
-mkTickBox ix vars e = do
-       uq <- newUnique 	
-       mod <- getModuleDs
-       let tick | opt_Hpc   = mkTickBoxOpId uq mod ix
-                | otherwise = mkBreakPointOpId uq mod ix
-       uq2 <- newUnique 	
-       let occName = mkVarOcc "tick"
-       let name = mkInternalName uq2 occName noSrcSpan   -- use mkSysLocal?
-       let var  = Id.mkLocalId name realWorldStatePrimTy
-       scrut <- 
-          if opt_Hpc 
-            then return (Var tick)
-            else do
-              let tickVar = Var tick
-              let tickType = mkFunTys (map idType vars) realWorldStatePrimTy 
-              let scrutApTy = App tickVar (Type tickType)
-              return (mkApps scrutApTy (map Var vars) :: Expr Id)
-       return $ Case scrut var ty [(DEFAULT,[],e)]
-  where
-     ty = exprType e
+mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr
+mkOptTickBox Nothing e        = e
+mkOptTickBox (Just tickish) e = Tick tickish e
 
 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
 mkBinaryTickBox ixT ixF e = do
        uq <- newUnique 	
-       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy 
-       falseBox <- mkTickBox ixF [] $ Var falseDataConId
-       trueBox  <- mkTickBox ixT [] $ Var trueDataConId
+       this_mod <- getModuleDs
+       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
+       let
+           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
+           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
+       --
        return $ Case e bndr1 boolTy
                        [ (DataAlt falseDataCon, [], falseBox)
                        , (DataAlt trueDataCon,  [], trueBox)