Maintain cost-centre stacks in the interpreter

Summary:
Breakpoints become SCCs, so we have detailed call-stack info for
interpreted code.  Currently this only works when GHC is compiled with
-prof, but D1562 (Remote GHCi) removes this constraint so that in the
future call stacks will be available without building your own GHCi.

How can you get a stack trace?

* programmatically: GHC.Stack.currentCallStack
* I've added an experimental :where command that shows the stack when
  stopped at a breakpoint
* `error` attaches a call stack automatically, although since calls to
  `error` are often lifted out to the top level, this is less useful
  than it might be (ImplicitParams still works though).
* Later we might attach call stacks to all exceptions

Other related changes in this diff:

* I reduced the number of places that get ticks attached for
  breakpoints.  In particular there was a breakpoint around the whole
  declaration, which was often redundant because it bound no variables.
  This reduces clutter in the stack traces and speeds up compilation.

* I tidied up some RealSrcSpan stuff in InteractiveUI, and made a few
  other small cleanups

Test Plan: validate

Reviewers: ezyang, bgamari, austin, hvr

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1595

GHC Trac Issues: #11047

1 files changed, 27 insertions, 13 deletions

diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index f74b4c439a..fc72084292 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -60,6 +60,7 @@ import Data.Maybe
 import Module
 import Control.Arrow ( second )
 
+import Data.Array
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
@@ -334,7 +335,8 @@ schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 schemeER_wrk d p rhs
   | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
   = do  code <- schemeE (fromIntegral d) 0 p newRhs
-        arr <- getBreakArray
+        flag_arr <- getBreakArray
+        cc_arr <- getCCArray
         this_mod <- getCurrentModule
         let idOffSets = getVarOffSets d p fvs
         let breakInfo = BreakInfo
@@ -343,9 +345,12 @@ schemeER_wrk d p rhs
                         , breakInfo_vars = idOffSets
                         , breakInfo_resty = exprType (deAnnotate' newRhs)
                         }
-        let breakInstr = case arr of
+        dflags <- getDynFlags
+        let cc | interpreterProfiled dflags = cc_arr ! tick_no
+               | otherwise = toRemotePtr nullPtr
+        let breakInstr = case flag_arr of
                          BA arr# ->
-                             BRK_FUN arr# (fromIntegral tick_no) breakInfo
+                             BRK_FUN arr# (fromIntegral tick_no) breakInfo cc
         return $ breakInstr `consOL` code
    | otherwise = schemeE (fromIntegral d) 0 p rhs
 
@@ -782,6 +787,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
   = do
      dflags <- getDynFlags
      let
+        profiling
+          | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+          | otherwise = rtsIsProfiled
+
         -- Top of stack is the return itbl, as usual.
         -- underneath it is the pointer to the alt_code BCO.
         -- When an alt is entered, it assumes the returned value is
@@ -789,6 +798,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         ret_frame_sizeW :: Word
         ret_frame_sizeW = 2
 
+        -- The extra frame we push to save/restor the CCCS when profiling
+        save_ccs_sizeW | profiling = 2
+                       | otherwise = 0
+
         -- An unlifted value gets an extra info table pushed on top
         -- when it is returned.
         unlifted_itbl_sizeW :: Word
@@ -904,8 +917,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                        0{-no arity-} bitmap_size bitmap True{-is alts-}
 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 --            "\n      bitmap = " ++ show bitmap) $ do
-     scrut_code <- schemeE (d + ret_frame_sizeW)
-                           (d + ret_frame_sizeW)
+
+     scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW)
+                           (d + ret_frame_sizeW + save_ccs_sizeW)
                            p scrut
      alt_bco' <- emitBc alt_bco
      let push_alts
@@ -1105,8 +1119,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
      let ffires = primRepToFFIType dflags r_rep
          ffiargs = map (primRepToFFIType dflags) a_reps
      hsc_env <- getHscEnv
-     rp <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
-     let token = fromRemotePtr rp
+     token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
      recordFFIBc token
 
      let
@@ -1633,7 +1646,7 @@ data BcM_State
         , nextlabel   :: Word16          -- for generating local labels
         , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
                                          -- Should be free()d when it is GCd
-        , breakArray :: BreakArray       -- array of breakpoint flags
+        , modBreaks :: ModBreaks         -- info about breakpoints
         }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
@@ -1646,9 +1659,7 @@ ioToBc io = BcM $ \st -> do
 runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r
       -> IO (BcM_State, r)
 runBc hsc_env us this_mod modBreaks (BcM m)
-   = m (BcM_State hsc_env us this_mod 0 [] breakArray)
-   where
-   breakArray = modBreaks_flags modBreaks
+   = m (BcM_State hsc_env us this_mod 0 [] modBreaks)
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -1689,7 +1700,7 @@ emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
 emitBc bco
   = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
 
-recordFFIBc :: Ptr () -> BcM ()
+recordFFIBc :: RemotePtr -> BcM ()
 recordFFIBc a
   = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
 
@@ -1706,7 +1717,10 @@ getLabelsBc n
                  in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
 
 getBreakArray :: BcM BreakArray
-getBreakArray = BcM $ \st -> return (st, breakArray st)
+getBreakArray = BcM $ \st -> return (st, modBreaks_flags (modBreaks st))
+
+getCCArray :: BcM (Array BreakIndex RemotePtr {- CCostCentre -})
+getCCArray = BcM $ \st -> return (st, modBreaks_ccs (modBreaks st))
 
 newUnique :: BcM Unique
 newUnique = BcM $