Maintain cost-centre stacks in the interpreter
authorSimon Marlow <marlowsd@gmail.com>
Sat, 31 Oct 2015 17:38:34 +0000 (17:38 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 21 Dec 2015 18:51:26 +0000 (18:51 +0000)
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

92 files changed:
compiler/codeGen/StgCmmProf.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/Desugar.hs
compiler/ghci/ByteCodeAsm.hs
compiler/ghci/ByteCodeGen.hs
compiler/ghci/ByteCodeInstr.hs
compiler/ghci/ByteCodeTypes.hs
compiler/ghci/GHCi.hs
compiler/ghci/Linker.hs
compiler/main/BreakArray.hs
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscTypes.hs
compiler/main/InteractiveEval.hs
compiler/main/InteractiveEvalTypes.hs
compiler/prelude/primops.txt.pp
ghc/GhciMonad.hs
ghc/InteractiveUI.hs
includes/rts/prof/CCS.h
includes/stg/MiscClosures.h
libraries/base/GHC/Stack.hs
libraries/base/GHC/Stack/CCS.hsc
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/Run.hs
rts/Disassembler.c
rts/Interpreter.c
rts/PrimOps.cmm
rts/Printer.c
rts/Printer.h
rts/Profiling.c
rts/RtsSymbols.c
testsuite/tests/ghci.debugger/scripts/T2740.script
testsuite/tests/ghci.debugger/scripts/T2740.stdout
testsuite/tests/ghci.debugger/scripts/break001.script
testsuite/tests/ghci.debugger/scripts/break001.stdout
testsuite/tests/ghci.debugger/scripts/break003.stdout
testsuite/tests/ghci.debugger/scripts/break005.stdout
testsuite/tests/ghci.debugger/scripts/break006.script
testsuite/tests/ghci.debugger/scripts/break006.stderr
testsuite/tests/ghci.debugger/scripts/break006.stdout
testsuite/tests/ghci.debugger/scripts/break008.stdout
testsuite/tests/ghci.debugger/scripts/break009.stdout
testsuite/tests/ghci.debugger/scripts/break010.stdout
testsuite/tests/ghci.debugger/scripts/break011.stdout
testsuite/tests/ghci.debugger/scripts/break012.script
testsuite/tests/ghci.debugger/scripts/break012.stdout
testsuite/tests/ghci.debugger/scripts/break013.script
testsuite/tests/ghci.debugger/scripts/break013.stdout
testsuite/tests/ghci.debugger/scripts/break014.stdout
testsuite/tests/ghci.debugger/scripts/break017.stdout
testsuite/tests/ghci.debugger/scripts/break018.script
testsuite/tests/ghci.debugger/scripts/break018.stdout
testsuite/tests/ghci.debugger/scripts/break020.stdout
testsuite/tests/ghci.debugger/scripts/break021.script
testsuite/tests/ghci.debugger/scripts/break021.stdout
testsuite/tests/ghci.debugger/scripts/break022/break022.script
testsuite/tests/ghci.debugger/scripts/break022/break022.stdout
testsuite/tests/ghci.debugger/scripts/break023/break023.stdout
testsuite/tests/ghci.debugger/scripts/break024.stdout
testsuite/tests/ghci.debugger/scripts/break025.stdout
testsuite/tests/ghci.debugger/scripts/break026.script
testsuite/tests/ghci.debugger/scripts/break026.stdout
testsuite/tests/ghci.debugger/scripts/break027.script
testsuite/tests/ghci.debugger/scripts/break027.stdout
testsuite/tests/ghci.debugger/scripts/break028.stdout
testsuite/tests/ghci.debugger/scripts/dynbrk002.stdout
testsuite/tests/ghci.debugger/scripts/dynbrk007.stdout
testsuite/tests/ghci.debugger/scripts/dynbrk008.script
testsuite/tests/ghci.debugger/scripts/dynbrk008.stdout
testsuite/tests/ghci.debugger/scripts/dynbrk009.script
testsuite/tests/ghci.debugger/scripts/dynbrk009.stdout
testsuite/tests/ghci.debugger/scripts/getargs.stdout
testsuite/tests/ghci.debugger/scripts/hist001.stdout
testsuite/tests/ghci.debugger/scripts/listCommand001.stdout
testsuite/tests/ghci.debugger/scripts/listCommand002.stdout
testsuite/tests/ghci.debugger/scripts/print005.stdout
testsuite/tests/ghci.debugger/scripts/print018.script
testsuite/tests/ghci.debugger/scripts/print018.stdout
testsuite/tests/ghci.debugger/scripts/print020.stdout
testsuite/tests/ghci.debugger/scripts/print022.script
testsuite/tests/ghci.debugger/scripts/print022.stdout
testsuite/tests/ghci.debugger/scripts/print025.script
testsuite/tests/ghci.debugger/scripts/print025.stdout
testsuite/tests/ghci.debugger/scripts/print029.script
testsuite/tests/ghci.debugger/scripts/print029.stdout
testsuite/tests/ghci.debugger/scripts/print030.script
testsuite/tests/ghci.debugger/scripts/print030.stdout
testsuite/tests/ghci.debugger/scripts/print031.script
testsuite/tests/ghci.debugger/scripts/print031.stdout
testsuite/tests/ghci.debugger/scripts/print032.script
testsuite/tests/ghci.debugger/scripts/print032.stdout
testsuite/tests/ghci.debugger/scripts/result001.stdout

index efad805..c1b149d 100644 (file)
@@ -277,7 +277,7 @@ emitSetCCC cc tick push
  = do dflags <- getDynFlags
       if not (gopt Opt_SccProfilingOn dflags)
           then return ()
-          else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW
+          else do tmp <- newTemp (ccsType dflags)
                   pushCostCentre tmp curCCS cc
                   when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
                   when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
index 958aa12..57d77c7 100644 (file)
@@ -3,10 +3,14 @@
 (c) University of Glasgow, 2007
 -}
 
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-}
 
 module Coverage (addTicksToBinds, hpcInitCode) where
 
+#ifdef GHCI
+import qualified GHCi
+import GHCi.RemoteTypes
+#endif
 import Type
 import HsSyn
 import Module
@@ -53,7 +57,7 @@ import qualified Data.Map as Map
 -}
 
 addTicksToBinds
-        :: DynFlags
+        :: HscEnv
         -> Module
         -> ModLocation          -- ... off the current module
         -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
@@ -63,8 +67,9 @@ addTicksToBinds
         -> LHsBinds Id
         -> IO (LHsBinds Id, HpcInfo, ModBreaks)
 
-addTicksToBinds dflags mod mod_loc exports tyCons binds
-  | let passes = coveragePasses dflags, not (null passes),
+addTicksToBinds hsc_env mod mod_loc exports tyCons binds
+  | let dflags = hsc_dflags hsc_env
+        passes = coveragePasses dflags, not (null passes),
     Just orig_file <- ml_hs_file mod_loc = do
 
      if "boot" `isSuffixOf` orig_file
@@ -94,17 +99,15 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds
 
           initState = TT { tickBoxCount = 0
                          , mixEntries   = []
-                         , breakCount   = 0
-                         , breaks       = []
                          , uniqSupply   = us
                          }
 
           (binds1,st) = foldr tickPass (binds, initState) passes
 
      let tickCount = tickBoxCount st
-     hashNo <- writeMixEntries dflags mod tickCount (reverse $ mixEntries st)
-                               orig_file2
-     modBreaks <- mkModBreaks dflags (breakCount st) (reverse $ breaks st)
+         entries = reverse $ mixEntries st
+     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
+     modBreaks <- mkModBreaks hsc_env mod tickCount entries
 
      when (dopt Opt_D_dump_ticked dflags) $
          log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
@@ -127,24 +130,56 @@ guessSourceFile binds orig_file =
         _ -> orig_file
 
 
-mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks
-mkModBreaks dflags count entries = do
-  breakArray <- newBreakArray dflags $ length entries
-  let
-         locsTicks = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
-         varsTicks = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
-         declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
-         modBreaks = emptyModBreaks
-                     { modBreaks_flags = breakArray
-                     , modBreaks_locs  = locsTicks
-                     , modBreaks_vars  = varsTicks
-                     , modBreaks_decls = declsTicks
-                     }
-  --
-  return modBreaks
-
-
-writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
+mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
+mkModBreaks hsc_env mod count entries
+  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
+    breakArray <- newBreakArray (length entries)
+#ifdef GHCI
+    ccs <- mkCCSArray hsc_env mod count entries
+#endif
+    let
+           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
+           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
+           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
+    return emptyModBreaks
+                       { modBreaks_flags = breakArray
+                       , modBreaks_locs  = locsTicks
+                       , modBreaks_vars  = varsTicks
+                       , modBreaks_decls = declsTicks
+#ifdef GHCI
+                       , modBreaks_ccs   = ccs
+#endif
+                       }
+  | otherwise = return emptyModBreaks
+
+#ifdef GHCI
+mkCCSArray
+  :: HscEnv -> Module -> Int -> [MixEntry_]
+  -> IO (Array BreakIndex RemotePtr {- CCostCentre -})
+mkCCSArray hsc_env modul count entries = do
+  if interpreterProfiled (hsc_dflags hsc_env)
+    then do
+      let module_bs = fastStringToByteString (moduleNameFS (moduleName modul))
+      c_module <- GHCi.mallocData hsc_env module_bs
+      costcentres <- mapM (mkCostCentre hsc_env (toRemotePtr c_module)) entries
+      return (listArray (0,count-1) costcentres)
+    else do
+      return (listArray (0,-1) [])
+ where
+    mkCostCentre
+     :: HscEnv
+     -> RemotePtr {- CChar -}
+     -> MixEntry_
+     -> IO (RemotePtr {- CCostCentre -})
+    mkCostCentre hsc_env@HscEnv{..}  c_module (srcspan, decl_path, _, _) = do
+      let name = concat (intersperse "." decl_path)
+          src = showSDoc hsc_dflags (ppr srcspan)
+      GHCi.mkCostCentre hsc_env c_module name src
+#endif
+
+
+writeMixEntries
+  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
 writeMixEntries dflags mod count entries filename
   | not (gopt Opt_Hpc dflags) = return 0
   | otherwise   = do
@@ -156,7 +191,8 @@ writeMixEntries dflags mod count entries filename
               | moduleUnitId mod == mainUnitId  = hpc_dir
               | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
 
-            tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.
+            tabStop = 8 -- <tab> counts as a normal char in GHC's
+                        -- location ranges.
 
         createDirectoryIfMissing True hpc_mod_dir
         modTime <- getModificationUTCTime filename
@@ -203,9 +239,9 @@ shouldTickBind  :: TickDensity
                 -> Bool         -- INLINE pragma?
                 -> Bool
 
-shouldTickBind density top_lev exported simple_pat inline
+shouldTickBind density top_lev exported _simple_pat inline
  = case density of
-      TickForBreakPoints    -> not simple_pat
+      TickForBreakPoints    -> False
         -- we never add breakpoints to simple pattern bindings
         -- (there's always a tick on the rhs anyway).
       TickAllFunctions      -> not inline
@@ -296,7 +332,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
                            , fun_tick = tick `mbCons` fun_tick funBind }
 
    where
-   -- a binding is a simple pattern binding if it is a funbind with zero patterns
+   -- a binding is a simple pattern binding if it is a funbind with
+   -- zero patterns
    isSimplePatBind :: HsBind a -> Bool
    isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
 
@@ -329,7 +366,8 @@ addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
 addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
 
 
-bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
+bindTick
+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
 bindTick density name pos fvs = do
   decl_path <- getPathEntry
   let
@@ -425,18 +463,11 @@ addTickLHsExprNever (L pos e0) = do
     e1 <- addTickHsExpr e0
     return $ L pos e1
 
--- general heuristic: expressions which do not denote values are good break points
+-- general heuristic: expressions which do not denote values are good
+-- break points
 isGoodBreakExpr :: HsExpr Id -> Bool
 isGoodBreakExpr (HsApp {})     = True
 isGoodBreakExpr (OpApp {})     = True
-isGoodBreakExpr (NegApp {})    = True
-isGoodBreakExpr (HsIf {})      = True
-isGoodBreakExpr (HsMultiIf {}) = True
-isGoodBreakExpr (HsCase {})    = True
-isGoodBreakExpr (RecordCon {}) = True
-isGoodBreakExpr (RecordUpd {}) = True
-isGoodBreakExpr (ArithSeq {})  = True
-isGoodBreakExpr (PArrSeq {})   = True
 isGoodBreakExpr _other         = False
 
 isCallSite :: HsExpr Id -> Bool
@@ -957,8 +988,6 @@ liftL f (L loc a) = do
 
 data TickTransState = TT { tickBoxCount:: Int
                          , mixEntries  :: [MixEntry_]
-                         , breakCount  :: Int
-                         , breaks      :: [MixEntry_]
                          , uniqSupply  :: UniqSupply
                          }
 
@@ -1174,9 +1203,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
       return $ ProfNote cc count True{-scopes-}
 
     Breakpoints -> do
-      c <- liftM breakCount getState
-      setState $ \st -> st { breakCount = c + 1
-                           , breaks = me:breaks st }
+      c <- liftM tickBoxCount getState
+      setState $ \st -> st { tickBoxCount = c + 1
+                           , mixEntries = me:mixEntries st }
       return $ Breakpoint c ids
 
     SourceNotes | RealSrcSpan pos' <- pos ->
index e69cc6e..d7fff69 100644 (file)
@@ -300,8 +300,8 @@ deSugar hsc_env
 
         ; (binds_cvr, ds_hpc_info, modBreaks)
                          <- if not (isHsBootOrSig hsc_src)
-                              then addTicksToBinds dflags mod mod_loc export_set
-                                          (typeEnvTyCons type_env) binds
+                              then addTicksToBinds hsc_env mod mod_loc
+                                       export_set (typeEnvTyCons type_env) binds
                               else return (binds, hpcInfo, emptyModBreaks)
 
         ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
index 875de87..ea30666 100644 (file)
@@ -18,6 +18,7 @@ module ByteCodeAsm (
 import ByteCodeInstr
 import ByteCodeItbls
 import ByteCodeTypes
+import GHCi.RemoteTypes
 
 import HscTypes
 import Name
@@ -359,9 +360,11 @@ assembleI dflags i = case i of
   RETURN_UBX rep           -> emit (return_ubx rep) []
   CCALL off m_addr i       -> do np <- addr m_addr
                                  emit bci_CCALL [SmallOp off, Op np, SmallOp i]
-  BRK_FUN array index info -> do p1 <- ptr (BCOPtrArray array)
-                                 p2 <- ptr (BCOPtrBreakInfo info)
-                                 emit bci_BRK_FUN [Op p1, SmallOp index, Op p2]
+  BRK_FUN array index info cc -> do p1 <- ptr (BCOPtrArray array)
+                                    p2 <- ptr (BCOPtrBreakInfo info)
+                                    np <- addr cc
+                                    emit bci_BRK_FUN [Op p1, SmallOp index,
+                                                      Op p2, Op np]
 
   where
     literal (MachLabel fs (Just sz) _)
@@ -383,7 +386,7 @@ assembleI dflags i = case i of
     literal LitInteger{}       = panic "ByteCodeAsm.literal: LitInteger"
 
     litlabel fs = lit [BCONPtrLbl fs]
-    addr = words . mkLitPtr
+    addr (RemotePtr a) = words [fromIntegral a]
     float = words . mkLitF
     double = words . mkLitD dflags
     int = words . mkLitI
@@ -422,7 +425,6 @@ return_ubx V64 = error "return_ubx: vector"
 mkLitI   ::             Int    -> [Word]
 mkLitF   ::             Float  -> [Word]
 mkLitD   :: DynFlags -> Double -> [Word]
-mkLitPtr ::             Ptr () -> [Word]
 mkLitI64 :: DynFlags -> Int64  -> [Word]
 
 mkLitF f
@@ -485,14 +487,5 @@ mkLitI i
         return [w0 :: Word]
      )
 
-mkLitPtr a
-   = runST (do
-        arr <- newArray_ ((0::Int),0)
-        writeArray arr 0 a
-        a_arr <- castSTUArray arr
-        w0 <- readArray a_arr 0
-        return [w0 :: Word]
-     )
-
 iNTERP_STACK_CHECK_THRESH :: Int
 iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
index f74b4c4..fc72084 100644 (file)
@@ -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 $
index 4f2b82b..74c4f96 100644 (file)
@@ -13,6 +13,7 @@ module ByteCodeInstr (
 #include "../includes/MachDeps.h"
 
 import ByteCodeTypes
+import GHCi.RemoteTypes
 import StgCmmLayout     ( ArgRep(..) )
 import PprCore
 import Outputable
@@ -124,7 +125,7 @@ data BCInstr
 
    -- For doing calls to C (via glue code generated by libffi)
    | CCALL            Word16    -- stack frame size
-                      (Ptr ())  -- addr of the glue code
+                      RemotePtr -- addr of the glue code
                       Word16    -- whether or not the call is interruptible
                                 -- (XXX: inefficient, but I don't know
                                 -- what the alignment constraints are.)
@@ -139,7 +140,7 @@ data BCInstr
    | RETURN_UBX ArgRep -- return an unlifted value, here's its rep
 
    -- Breakpoints
-   | BRK_FUN          (MutableByteArray# RealWorld) Word16 BreakInfo
+   | BRK_FUN          (MutableByteArray# RealWorld) Word16 BreakInfo RemotePtr
 
 -- -----------------------------------------------------------------------------
 -- Printing bytecode instructions
@@ -239,7 +240,7 @@ instance Outputable BCInstr where
    ppr ENTER                 = text "ENTER"
    ppr RETURN                = text "RETURN"
    ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk
-   ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info
+   ppr (BRK_FUN _breakArray index info _cc) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info <+> text "<cc>"
 
 -- -----------------------------------------------------------------------------
 -- The stack use, in words, of each bytecode insn.  These _must_ be
index 0a8dd30..500fd77 100644 (file)
@@ -20,6 +20,7 @@ import Outputable
 import PrimOp
 import SizedSeq
 import Type
+import GHCi.RemoteTypes
 
 import Foreign
 import Data.Array.Base  ( UArray(..) )
@@ -33,7 +34,7 @@ data CompiledByteCode
              [FFIInfo]     -- ffi blocks we allocated
                 -- ToDo: we're not tracking strings that we malloc'd
 
-newtype FFIInfo = FFIInfo (Ptr ())
+newtype FFIInfo = FFIInfo RemotePtr
   deriving Show
 
 instance Outputable CompiledByteCode where
index d9c26c1..b7e0eb3 100644 (file)
@@ -13,6 +13,8 @@ module GHCi
   , evalString
   , evalStringToIOString
   , mallocData
+  , mkCostCentre
+  , costCentreStackInfo
 
   -- * The object-code linker
   , initObjLinker
@@ -207,7 +209,7 @@ handleEvalStatus
   :: HscEnv -> EvalStatus [HValueRef] -> IO (EvalStatus [ForeignHValue])
 handleEvalStatus hsc_env status =
   case status of
-    EvalBreak a b c d -> return (EvalBreak a b c d)
+    EvalBreak a b c d e -> return (EvalBreak a b c d e)
     EvalComplete alloc res ->
       EvalComplete alloc <$> addFinalizer res
  where
@@ -239,6 +241,16 @@ evalStringToIOString hsc_env fhv str = do
 mallocData :: HscEnv -> ByteString -> IO (Ptr ())
 mallocData hsc_env bs = fromRemotePtr <$> iservCmd hsc_env (MallocData bs)
 
+mkCostCentre
+  :: HscEnv -> RemotePtr {- CChar -} -> String -> String
+  -> IO RemotePtr {- CCostCentre -}
+mkCostCentre hsc_env c_module name src =
+  iservCmd hsc_env (MkCostCentre c_module name src)
+
+
+costCentreStackInfo :: HscEnv -> RemotePtr {- CCostCentreStack -} -> IO [String]
+costCentreStackInfo hsc_env ccs =
+  iservCmd hsc_env (CostCentreStackInfo ccs)
 
 -- -----------------------------------------------------------------------------
 -- Interface to the object-code linker
index 11936c7..a95120d 100644 (file)
@@ -820,7 +820,7 @@ dynLinkObjs hsc_env pls objs = do
             unlinkeds                = concatMap linkableUnlinked new_objs
             wanted_objs              = map nameOfObject unlinkeds
 
-        if loadingDynamicHSLibs (hsc_dflags hsc_env)
+        if interpreterDynamic (hsc_dflags hsc_env)
             then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
                     return (pls2, Succeeded)
             else do mapM_ (loadObj hsc_env) wanted_objs
@@ -1248,16 +1248,6 @@ loadFrameworks hsc_env platform pkg
                     Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
                                                         ++ fw ++ " (" ++ err ++ ")" ))
 
-loadingDynamicHSLibs :: DynFlags -> Bool
-loadingDynamicHSLibs dflags
-  | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags
-  | otherwise = dynamicGhc
-
-loadingProfiledHSLibs :: DynFlags -> Bool
-loadingProfiledHSLibs dflags
-  | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
-  | otherwise = rtsIsProfiled
-
 -- Try to find an object file for a given library in the given paths.
 -- If it isn't present, we assume that addDLL in the RTS can find it,
 -- which generally means that it should be a dynamic library in the
@@ -1306,8 +1296,8 @@ locateLib hsc_env is_hs dirs lib
      arch_file = "lib" ++ lib ++ lib_tag <.> "a"
      lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
 
-     loading_profiled_hs_libs = loadingProfiledHSLibs dflags
-     loading_dynamic_hs_libs  = loadingDynamicHSLibs dflags
+     loading_profiled_hs_libs = interpreterProfiled dflags
+     loading_dynamic_hs_libs  = interpreterDynamic dflags
 
      hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
      hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
index 9b84931..4474902 100644 (file)
@@ -2,13 +2,16 @@
 
 -------------------------------------------------------------------------------
 --
--- | Break Arrays in the IO monad
+-- (c) The University of Glasgow 2007
 --
--- Entries in the array are Word sized Conceptually, a zero-indexed IOArray of
--- Bools, initially False.  They're represented as Words with 0==False, 1==True.
--- They're used to determine whether GHCI breakpoints are on or off.
+-- | Break Arrays
 --
--- (c) The University of Glasgow 2007
+-- An array of bytes, indexed by a breakpoint number (breakpointId in Tickish)
+-- There is one of these arrays per module.
+--
+-- Each byte is
+--   1 if the corresponding breakpoint is enabled
+--   0 otherwise
 --
 -------------------------------------------------------------------------------
 
@@ -27,10 +30,10 @@ module BreakArray
 #endif
     ) where
 
-import DynFlags
-
 #ifdef GHCI
 import Control.Monad
+import Data.Word
+import GHC.Word
 
 import GHC.Exts
 import GHC.IO ( IO(..) )
@@ -38,43 +41,43 @@ import System.IO.Unsafe ( unsafeDupablePerformIO )
 
 data BreakArray = BA (MutableByteArray# RealWorld)
 
-breakOff, breakOn :: Word
+breakOff, breakOn :: Word8
 breakOn  = 1
 breakOff = 0
 
-showBreakArray :: DynFlags -> BreakArray -> IO ()
-showBreakArray dflags array = do
-    forM_ [0 .. (size dflags array - 1)] $ \i -> do
+showBreakArray :: BreakArray -> IO ()
+showBreakArray array = do
+    forM_ [0 .. (size array - 1)] $ \i -> do
         val <- readBreakArray array i
         putStr $ ' ' : show val
     putStr "\n"
 
-setBreakOn :: DynFlags -> BreakArray -> Int -> IO Bool
-setBreakOn dflags array index
-    | safeIndex dflags array index = do
+setBreakOn :: BreakArray -> Int -> IO Bool
+setBreakOn array index
+    | safeIndex array index = do
           writeBreakArray array index breakOn
           return True
     | otherwise = return False
 
-setBreakOff :: DynFlags -> BreakArray -> Int -> IO Bool
-setBreakOff dflags array index
-    | safeIndex dflags array index = do
+setBreakOff :: BreakArray -> Int -> IO Bool
+setBreakOff array index
+    | safeIndex array index = do
           writeBreakArray array index breakOff
           return True
     | otherwise = return False
 
-getBreak :: DynFlags -> BreakArray -> Int -> IO (Maybe Word)
-getBreak dflags array index
-    | safeIndex dflags array index = do
+getBreak :: BreakArray -> Int -> IO (Maybe Word8)
+getBreak array index
+    | safeIndex array index = do
           val <- readBreakArray array index
           return $ Just val
     | otherwise = return Nothing
 
-safeIndex :: DynFlags -> BreakArray -> Int -> Bool
-safeIndex dflags array index = index < size dflags array && index >= 0
+safeIndex :: BreakArray -> Int -> Bool
+safeIndex array index = index < size array && index >= 0
 
-size :: DynFlags -> BreakArray -> Int
-size dflags (BA array) = size `div` wORD_SIZE dflags
+size :: BreakArray -> Int
+size (BA array) = size
   where
     -- We want to keep this operation pure. The mutable byte array
     -- is never resized so this is safe.
@@ -90,30 +93,28 @@ allocBA (I# sz) = IO $ \s1 ->
     case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) }
 
 -- create a new break array and initialise elements to zero
-newBreakArray :: DynFlags -> Int -> IO BreakArray
-newBreakArray dflags entries@(I# sz) = do
-    BA array <- allocBA (entries * wORD_SIZE dflags)
+newBreakArray :: Int -> IO BreakArray
+newBreakArray entries@(I# sz) = do
+    BA array <- allocBA entries
     case breakOff of
-        W# off -> do    -- Todo: there must be a better way to write zero as a Word!
-            let loop n | isTrue# (n ==# sz) = return ()
-                       | otherwise = do
-                             writeBA# array n off
-                             loop (n +# 1#)
-            loop 0#
+        W8# off -> do
+           let loop n | isTrue# (n ==# sz) = return ()
+                      | otherwise = do writeBA# array n off; loop (n +# 1#)
+           loop 0#
     return $ BA array
 
 writeBA# :: MutableByteArray# RealWorld -> Int# -> Word# -> IO ()
 writeBA# array i word = IO $ \s ->
-    case writeWordArray# array i word s of { s -> (# s, () #) }
+    case writeWord8Array# array i word s of { s -> (# s, () #) }
 
-writeBreakArray :: BreakArray -> Int -> Word -> IO ()
-writeBreakArray (BA array) (I# i) (W# word) = writeBA# array i word
+writeBreakArray :: BreakArray -> Int -> Word8 -> IO ()
+writeBreakArray (BA array) (I# i) (W8# word) = writeBA# array i word
 
-readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word
+readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word8
 readBA# array i = IO $ \s ->
-    case readWordArray# array i s of { (# s, c #) -> (# s, W# c #) }
+    case readWord8Array# array i s of { (# s, c #) -> (# s, W8# c #) }
 
-readBreakArray :: BreakArray -> Int -> IO Word
+readBreakArray :: BreakArray -> Int -> IO Word8
 readBreakArray (BA array) (I# i) = readBA# array i
 
 #else /* !GHCI */
@@ -124,8 +125,8 @@ readBreakArray (BA array) (I# i) = readBA# array i
 -- presumably have a different representation.
 data BreakArray = Unspecified
 
-newBreakArray :: DynFlags -> Int -> IO BreakArray
-newBreakArray _ = return Unspecified
+newBreakArray :: Int -> IO BreakArray
+newBreakArray _ = return Unspecified
 
 #endif /* GHCI */
 
index a23ecfa..556175c 100644 (file)
@@ -81,6 +81,7 @@ module DynFlags (
         defaultDynFlags,                -- Settings -> DynFlags
         defaultWays,
         interpWays,
+        interpreterProfiled, interpreterDynamic,
         initDynFlags,                   -- DynFlags -> IO DynFlags
         defaultFatalMessager,
         defaultLogAction,
@@ -1522,6 +1523,16 @@ interpWays
   | rtsIsProfiled = [WayProf]
   | otherwise = []
 
+interpreterProfiled :: DynFlags -> Bool
+interpreterProfiled dflags
+  | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+  | otherwise = rtsIsProfiled
+
+interpreterDynamic :: DynFlags -> Bool
+interpreterDynamic dflags
+  | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags
+  | otherwise = dynamicGhc
+
 --------------------------------------------------------------------------
 
 type FatalMessager = String -> IO ()
index 4bf9a58..0ac1331 100644 (file)
@@ -136,8 +136,7 @@ module GHC (
 
         -- ** The debugger
         SingleStep(..),
-        Resume(resumeStmt, resumeBreakInfo, resumeSpan,
-               resumeHistory, resumeHistoryIx),
+        Resume(..),
         History(historyBreakInfo, historyEnclosingDecls),
         GHC.getHistorySpan, getHistoryModule,
         abandon, abandonAll,
index 3766b57..ea921fe 100644 (file)
@@ -112,6 +112,7 @@ module HscTypes (
 
         -- * Breakpoints
         ModBreaks (..), BreakIndex, emptyModBreaks,
+        CCostCentre,
 
         -- * Vectorisation information
         VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
@@ -136,7 +137,7 @@ module HscTypes (
 import ByteCodeTypes        ( CompiledByteCode )
 import InteractiveEvalTypes ( Resume )
 import GHCi.Message         ( Pipe )
-import GHCi.RemoteTypes     ( HValueRef )
+import GHCi.RemoteTypes
 #endif
 
 import HsSyn
@@ -191,15 +192,14 @@ import Platform
 import Util
 import GHC.Serialized   ( Serialized )
 
+import Foreign
 import Control.Monad    ( guard, liftM, when, ap )
 import Control.Concurrent
 import Data.Array       ( Array, array )
 import Data.IORef
 import Data.Time
-import Data.Word
 import Data.Typeable    ( Typeable )
 import Exception
-import Foreign
 import System.FilePath
 import System.Process   ( ProcessHandle )
 
@@ -2872,6 +2872,9 @@ byteCodeOfObject other       = pprPanic "byteCodeOfObject" (ppr other)
 -- | Breakpoint index
 type BreakIndex = Int
 
+-- | C CostCentre type
+data CCostCentre
+
 -- | All the information about the breakpoints for a given module
 data ModBreaks
    = ModBreaks
@@ -2884,6 +2887,10 @@ data ModBreaks
         -- ^ An array giving the names of the free variables at each breakpoint.
    , modBreaks_decls :: !(Array BreakIndex [String])
         -- ^ An array giving the names of the declarations enclosing each breakpoint.
+#ifdef GHCI
+   , modBreaks_ccs :: !(Array BreakIndex (RemotePtr {- CCostCentre -}))
+        -- ^ Array pointing to cost centre for each breakpoint
+#endif
    }
 
 -- | Construct an empty ModBreaks
@@ -2894,4 +2901,7 @@ emptyModBreaks = ModBreaks
    , modBreaks_locs  = array (0,-1) []
    , modBreaks_vars  = array (0,-1) []
    , modBreaks_decls = array (0,-1) []
+#ifdef GHCI
+   , modBreaks_ccs = array (0,-1) []
+#endif
    }
index 2f819e4..eb23a60 100644 (file)
@@ -94,7 +94,7 @@ import qualified Parser (parseStmt, parseModule, parseDeclaration)
 import System.Directory
 import Data.Dynamic
 import Data.Either
-import Data.List (find)
+import Data.List (find,intercalate)
 import StringBuffer (stringToStringBuffer)
 import Control.Monad
 import GHC.Exts
@@ -293,7 +293,7 @@ handleRunStatus step expr bindings final_ids status history
   | otherwise              = not_tracing
  where
   tracing
-    | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status
+    | EvalBreak is_exception apStack_ref info_ref resume_ctxt _ccs <- status
     , not is_exception
     = do
        hsc_env <- getSession
@@ -320,7 +320,7 @@ handleRunStatus step expr bindings final_ids status history
 
   not_tracing
     -- Hit a breakpoint
-    | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status
+    | EvalBreak is_exception apStack_ref info_ref resume_ctxt ccs <- status
     = do
          hsc_env <- getSession
          let dflags = hsc_dflags hsc_env
@@ -330,7 +330,7 @@ handleRunStatus step expr bindings final_ids status history
          apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
          let mb_info | is_exception = Nothing
                      | otherwise    = Just info
-         (hsc_env1, names, span) <- liftIO $
+         (hsc_env1, names, span, decl) <- liftIO $
            bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info
          let
            resume = Resume
@@ -338,6 +338,8 @@ handleRunStatus step expr bindings final_ids status history
              , resumeBindings = bindings, resumeFinalIds = final_ids
              , resumeApStack = apStack_fhv, resumeBreakInfo = mb_info
              , resumeSpan = span, resumeHistory = toListBL history
+             , resumeDecl = decl
+             , resumeCCS = ccs
              , resumeHistoryIx = 0 }
            hsc_env2 = pushResume hsc_env1 resume
 
@@ -365,8 +367,7 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
 isBreakEnabled hsc_env inf =
    case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
        Just hmi -> do
-         w <- getBreak (hsc_dflags hsc_env)
-                       (modBreaks_flags (getModBreaks hmi))
+         w <- getBreak (modBreaks_flags (getModBreaks hmi))
                        (breakInfo_number inf)
          case w of Just n -> return (n /= 0); _other -> return False
        _ ->
@@ -419,13 +420,13 @@ resumeExec canLogSpan step
                                                         fromListBL 50 hist
                 handleRunStatus step expr bindings final_ids status hist'
 
-back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
+back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
 back n = moveHist (+n)
 
-forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
+forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
 forward n = moveHist (subtract n)
 
-moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
+moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
 moveHist fn = do
   hsc_env <- getSession
   case ic_resume (hsc_IC hsc_env) of
@@ -443,15 +444,15 @@ moveHist fn = do
 
         let
           update_ic apStack mb_info = do
-            (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
-                                                apStack mb_info
+            (hsc_env1, names, span, decl) <-
+              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
             let ic = hsc_IC hsc_env1
                 r' = r { resumeHistoryIx = new_ix }
                 ic' = ic { ic_resume = r':rs }
 
             modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
 
-            return (names, new_ix, span)
+            return (names, new_ix, span, decl)
 
         -- careful: we want apStack to be the AP_STACK itself, not a thunk
         -- around it, hence the cases are carefully constructed below to
@@ -474,7 +475,7 @@ bindLocalsAtBreakpoint
         :: HscEnv
         -> ForeignHValue
         -> Maybe BreakInfo
-        -> IO (HscEnv, [Name], SrcSpan)
+        -> IO (HscEnv, [Name], SrcSpan, String)
 
 -- Nothing case: we stopped when an exception was raised, not at a
 -- breakpoint.  We have no location information or local variables to
@@ -482,7 +483,7 @@ bindLocalsAtBreakpoint
 -- value.
 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
    let exn_occ = mkVarOccFS (fsLit "_exception")
-       span    = mkGeneralSrcSpan (fsLit "<exception thrown>")
+       span    = mkGeneralSrcSpan (fsLit "<unknown>")
    exn_name <- newInteractiveBinder hsc_env exn_occ span
 
    let e_fs    = fsLit "e"
@@ -495,7 +496,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 
    --
    Linker.extendLinkEnv [(exn_name, apStack)]
-   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
+   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
 
 -- Just case: we stopped at a breakpoint, we have information about the location
 -- of the breakpoint and the free variables of the expression.
@@ -510,6 +511,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do
        result_ty = breakInfo_resty info
        occs      = modBreaks_vars breaks ! index
        span      = modBreaks_locs breaks ! index
+       decl      = intercalate "." $ modBreaks_decls breaks ! index
 
            -- Filter out any unboxed ids;
            -- we can't bind these at the prompt
@@ -556,7 +558,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do
    Linker.extendLinkEnv (zip names fhvs)
    when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
-   return (hsc_env1, if result_ok then result_name:names else names, span)
+   return (hsc_env1, if result_ok then result_name:names else names, span, decl)
   where
         -- We need a fresh Unique for each Id we bind, because the linker
         -- state is single-threaded and otherwise we'd spam old bindings
index 98090bb..4372891 100644 (file)
@@ -17,7 +17,7 @@ module InteractiveEvalTypes (
 
 #ifdef GHCI
 
-import GHCi.RemoteTypes (ForeignHValue)
+import GHCi.RemoteTypes
 import GHCi.Message (EvalExpr)
 import Id
 import Name
@@ -67,9 +67,13 @@ data Resume
        resumeBreakInfo :: Maybe BreakInfo,
                                         -- the breakpoint we stopped at
                                         -- (Nothing <=> exception)
-       resumeSpan      :: SrcSpan,      -- just a cache, otherwise it's a pain
-                                        -- to fetch the ModDetails & ModBreaks
-                                        -- to get this.
+       resumeSpan      :: SrcSpan,      -- just a copy of the SrcSpan
+                                        -- from the ModBreaks,
+                                        -- otherwise it's a pain to
+                                        -- fetch the ModDetails &
+                                        -- ModBreaks to get this.
+       resumeDecl      :: String,       -- ditto
+       resumeCCS       :: RemotePtr {- CostCentreStack -},
        resumeHistory   :: [History],
        resumeHistoryIx :: Int           -- 0 <==> at the top of the history
    }
@@ -81,4 +85,3 @@ data History
         historyEnclosingDecls :: [String]  -- declarations enclosing the breakpoint
    }
 #endif
-
index de14e30..dc85a20 100644 (file)
@@ -2558,6 +2558,14 @@ primop  GetCurrentCCSOp "getCurrentCCS#" GenPrimOp
      simplifier, which would result in an uninformative stack
      ("CAF"). }
 
+primop  ClearCCSOp "clearCCS#" GenPrimOp
+   (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #)
+   { Run the supplied IO action with an empty CCS.  For example, this
+     is used by the interpreter to run an interpreted computation
+     without the call stack showing that it was invoked from GHC. }
+   with
+   out_of_line = True
+
 ------------------------------------------------------------------------
 section "Etc"
         {Miscellaneous built-ins}
index 0b22d1e..993a758 100644 (file)
@@ -118,7 +118,7 @@ data GHCiState = GHCiState
         noBuffering :: ForeignHValue
      }
 
-type TickArray = Array Int [(BreakIndex,SrcSpan)]
+type TickArray = Array Int [(BreakIndex,RealSrcSpan)]
 
 -- | A GHCi command
 data Command
index 1742253..9e22560 100644 (file)
@@ -58,6 +58,7 @@ import PrelNames
 import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )
 import SrcLoc
 import qualified Lexer
+import ByteCodeTypes (BreakInfo(..))
 
 import StringBuffer
 import Outputable hiding ( printForUser, printForUserPartWay, bold )
@@ -97,6 +98,7 @@ import qualified Data.Map as M
 
 import Exception hiding (catch)
 import Foreign
+import GHC.Stack hiding (SrcLoc(..))
 
 import System.Directory
 import System.Environment
@@ -197,7 +199,8 @@ ghciCommands = map mkCmd [
   ("type",      keepGoing' typeOfExpr,          completeExpression),
   ("trace",     keepGoing traceCmd,             completeExpression),
   ("undef",     keepGoing undefineMacro,        completeMacro),
-  ("unset",     keepGoing unsetOptions,         completeSetOptions)
+  ("unset",     keepGoing unsetOptions,         completeSetOptions),
+  ("where",     keepGoing whereCmd,             noCompletion)
   ] ++ map mkCmdHidden [ -- hidden commands
   ("all-types", keepGoing' allTypesCmd),
   ("complete",  keepGoing completeCmd),
@@ -1017,8 +1020,7 @@ toBreakIdAndLocation (Just inf) = do
 
 printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
 printStoppedAtBreakInfo res names = do
-  printForUser $ ptext (sLit "Stopped at") <+>
-    ppr (GHC.resumeSpan res)
+  printForUser $ pprStopped res
   --  printTypeOfNames session names
   let namesSorted = sortBy compareNames names
   tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
@@ -1118,6 +1120,15 @@ getCurrentBreakSpan = do
                 pan <- GHC.getHistorySpan hist
                 return (Just pan)
 
+getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])
+getCallStackAtCurrentBreakpoint = do
+  resumes <- GHC.getResumeContext
+  case resumes of
+    [] -> return Nothing
+    (r:_) -> do
+       hsc_env <- GHC.getSession
+       Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))
+
 getCurrentBreakModule :: GHCi (Maybe Module)
 getCurrentBreakModule = do
   resumes <- GHC.getResumeContext
@@ -2623,7 +2634,18 @@ showContext = do
   where
    pp_resume res =
         ptext (sLit "--> ") <> text (GHC.resumeStmt res)
-        $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res))
+        $$ nest 2 (pprStopped res)
+
+pprStopped :: GHC.Resume -> SDoc
+pprStopped res =
+  ptext (sLit "Stopped in")
+    <+> ((case mb_mod_name of
+           Nothing -> empty
+           Just mod_name -> text (moduleNameString mod_name) <> char '.')
+         <> text (GHC.resumeDecl res))
+    <> char ',' <+> ppr (GHC.resumeSpan res)
+ where
+  mb_mod_name = moduleName <$> breakInfo_module <$> GHC.resumeBreakInfo res
 
 showPackages :: GHCi ()
 showPackages = do
@@ -2875,7 +2897,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
         Just loc -> do
            Just md <- getCurrentBreakModule
            current_toplevel_decl <- enclosingTickSpan md loc
-           doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
+           doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
 
 stepModuleCmd :: String -> GHCi ()
 stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
@@ -2891,17 +2913,22 @@ stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
            doContinue f GHC.SingleStep
 
 -- | Returns the span of the largest tick containing the srcspan given
-enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
+enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan
 enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
 enclosingTickSpan md (RealSrcSpan src) = do
   ticks <- getTickArray md
   let line = srcSpanStartLine src
   ASSERT(inRange (bounds ticks) line) do
-  let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
-      toRealSrcSpan (RealSrcSpan s) = s
-      enclosing_spans = [ pan | (_,pan) <- ticks ! line
-                               , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src]
-  return . head . sortBy leftmost_largest $ enclosing_spans
+  let enclosing_spans = [ pan | (_,pan) <- ticks ! line
+                               , realSrcSpanEnd pan >= realSrcSpanEnd src]
+  return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
+ where
+
+leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
+leftmostLargestRealSrcSpan a b =
+  (realSrcSpanStart a `compare` realSrcSpanStart b)
+     `thenCmp`
+  (realSrcSpanEnd b `compare` realSrcSpanEnd a)
 
 traceCmd :: String -> GHCi ()
 traceCmd arg
@@ -2980,7 +3007,7 @@ backCmd arg
   | otherwise       = liftIO $ putStrLn "Syntax:  :back [num]"
   where
   back num = withSandboxOnly ":back" $ do
-      (names, _, pan) <- GHC.back num
+      (names, _, pan, _) <- GHC.back num
       printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
       printTypeOfNames names
        -- run the command set with ":set stop <cmd>"
@@ -2994,7 +3021,7 @@ forwardCmd arg
   | otherwise       = liftIO $ putStrLn "Syntax:  :back [num]"
   where
   forward num = withSandboxOnly ":forward" $ do
-      (names, ix, pan) <- GHC.forward num
+      (names, ix, pan, _) <- GHC.forward num
       printForUser $ (if (ix == 0)
                         then ptext (sLit "Stopped at")
                         else ptext (sLit "Logged breakpoint at")) <+> ppr pan
@@ -3024,16 +3051,13 @@ breakSwitch (arg1:rest)
               liftIO $ putStrLn "No modules are loaded with debugging support."
    | otherwise = do -- try parsing it as an identifier
         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
-        let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
-        case loc of
-            RealSrcLoc l ->
+        maybe_info <- GHC.getModuleInfo (GHC.nameModule name)
+        case maybe_info of
+          Nothing -> noCanDo name (ptext (sLit "cannot get module info"))
+          Just minf ->
                ASSERT( isExternalName name )
                     findBreakAndSet (GHC.nameModule name) $
-                         findBreakByCoord (Just (GHC.srcLocFile l))
-                                          (GHC.srcLocLine l,
-                                           GHC.srcLocCol l)
-            UnhelpfulLoc _ ->
-                noCanDo name $ text "can't find its location: " <> ppr loc
+                       findBreakForBind name (GHC.modInfoModBreaks minf)
        where
           noCanDo n why = printForUser $
                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
@@ -3047,29 +3071,30 @@ breakByModule _ _
 
 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
 breakByModuleLine md line args
-   | [] <- args = findBreakAndSet md $ findBreakByLine line
+   | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line
    | [col] <- args, all isDigit col =
-        findBreakAndSet md $ findBreakByCoord Nothing (line, read col)
+        findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)
    | otherwise = breakSyntax
 
 breakSyntax :: a
 breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
 
-findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()
 findBreakAndSet md lookupTickTree = do
-   dflags <- getDynFlags
    tickArray <- getTickArray md
    (breakArray, _) <- getModBreak md
    case lookupTickTree tickArray of
-      Nothing  -> liftIO $ putStrLn $ "No breakpoints found at that location."
-      Just (tick, pan) -> do
-         success <- liftIO $ setBreakFlag dflags True breakArray tick
+      []  -> liftIO $ putStrLn $ "No breakpoints found at that location."
+      some -> mapM_ (breakAt breakArray) some
+ where
+   breakAt breakArray (tick, pan) = do
+         success <- liftIO $ setBreakFlag True breakArray tick
          if success
             then do
                (alreadySet, nm) <-
                      recordBreak $ BreakLocation
                              { breakModule = md
-                             , breakLoc = pan
+                             , breakLoc = RealSrcSpan pan
                              , breakTick = tick
                              , onBreakCmd = ""
                              }
@@ -3088,49 +3113,61 @@ findBreakAndSet md lookupTickTree = do
 --    - the leftmost subexpression starting on the specified line, or
 --    - the rightmost subexpression enclosing the specified line
 --
-findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)
 findBreakByLine line arr
   | not (inRange (bounds arr) line) = Nothing
   | otherwise =
-    listToMaybe (sortBy (leftmost_largest `on` snd)  comp)   `mplus`
-    listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus`
-    listToMaybe (sortBy (rightmost `on` snd) ticks)
+    listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd)  comp)   `mplus`
+    listToMaybe (sortBy (compare `on` snd) incomp) `mplus`
+    listToMaybe (sortBy (flip compare `on` snd) ticks)
   where
         ticks = arr ! line
 
-        starts_here = [ tick | tick@(_,pan) <- ticks,
-                               GHC.srcSpanStartLine (toRealSpan pan) == line ]
+        starts_here = [ (ix,pan) | (ix, pan) <- ticks,
+                        GHC.srcSpanStartLine pan == line ]
 
         (comp, incomp) = partition ends_here starts_here
-            where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line
-        toRealSpan (RealSrcSpan pan) = pan
-        toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
+            where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
+
+-- The aim is to find the breakpionts for all the RHSs of the
+-- equations corresponding to a binding.  So we find all breakpoints
+-- for
+--   (a) this binder only (not a nested declaration)
+--   (b) that do not have an enclosing breakpoint
+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray
+                 -> [(BreakIndex,RealSrcSpan)]
+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks
+  where
+    ticks = [ (index, span)
+            | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),
+              n == occNameString (nameOccName name),
+              RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]
+    enclosed (_,sp0) = any subspan ticks
+      where subspan (_,sp) = sp /= sp0 &&
+                         realSrcSpanStart sp <= realSrcSpanStart sp0 &&
+                         realSrcSpanEnd sp0 <= realSrcSpanEnd sp
 
 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
-                 -> Maybe (BreakIndex,SrcSpan)
+                 -> Maybe (BreakIndex,RealSrcSpan)
 findBreakByCoord mb_file (line, col) arr
   | not (inRange (bounds arr) line) = Nothing
   | otherwise =
-    listToMaybe (sortBy (rightmost `on` snd) contains ++
-                 sortBy (leftmost_smallest `on` snd) after_here)
+    listToMaybe (sortBy (flip compare `on` snd) contains ++
+                 sortBy (compare `on` snd) after_here)
   where
         ticks = arr ! line
 
         -- the ticks that span this coordinate
-        contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col),
+        contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),
                             is_correct_file pan ]
 
         is_correct_file pan
-                 | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f
+                 | Just f <- mb_file = GHC.srcSpanFile pan == f
                  | otherwise         = True
 
         after_here = [ tick | tick@(_,pan) <- ticks,
-                              let pan' = toRealSpan pan,
-                              GHC.srcSpanStartLine pan' == line,
-                              GHC.srcSpanStartCol pan' >= col ]
-
-        toRealSpan (RealSrcSpan pan) = pan
-        toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
+                              GHC.srcSpanStartLine pan == line,
+                              GHC.srcSpanStartCol pan >= col ]
 
 -- For now, use ANSI bold on terminals that we know support it.
 -- Otherwise, we add a line of carets under the active expression instead.
@@ -3147,6 +3184,15 @@ start_bold = "\ESC[1m"
 end_bold :: String
 end_bold   = "\ESC[0m"
 
+-----------------------------------------------------------------------------
+-- :where
+
+whereCmd :: String -> GHCi ()
+whereCmd = noArgs $ do
+  mstrs <- getCallStackAtCurrentBreakpoint
+  case mstrs of
+    Nothing -> return ()
+    Just strs -> liftIO $ putStrLn (renderStack strs)
 
 -----------------------------------------------------------------------------
 -- :list
@@ -3199,8 +3245,7 @@ list2 [arg] = do
                                         tickArray
                   case mb_span of
                     Nothing       -> listAround (realSrcLocSpan l) False
-                    Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
-                    Just (_, RealSrcSpan pan) -> listAround pan False
+                    Just (_, pan) -> listAround pan False
             UnhelpfulLoc _ ->
                   noCanDo name $ text "can't find its location: " <>
                                  ppr loc
@@ -3315,14 +3360,10 @@ discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
 mkTickArray ticks
   = accumArray (flip (:)) [] (1, max_line)
-        [ (line, (nm,pan)) | (nm,pan) <- ticks,
-                              let pan' = toRealSpan pan,
-                              line <- srcSpanLines pan' ]
+        [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]
     where
-        max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
+        max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]
         srcSpanLines pan = [ GHC.srcSpanStartLine pan ..  GHC.srcSpanEndLine pan ]
-        toRealSpan (RealSrcSpan pan) = pan
-        toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
 
 -- don't reset the counter back to zero?
 discardActiveBreakPoints :: GHCi ()
@@ -3345,9 +3386,8 @@ deleteBreak identity = do
 
 turnOffBreak :: BreakLocation -> GHCi Bool
 turnOffBreak loc = do
-  dflags <- getDynFlags
   (arr, _) <- getModBreak (breakModule loc)
-  liftIO $ setBreakFlag dflags False arr (breakTick loc)
+  liftIO $ setBreakFlag False arr (breakTick loc)
 
 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
 getModBreak m = do
@@ -3357,10 +3397,10 @@ getModBreak m = do
    let ticks      = GHC.modBreaks_locs  modBreaks
    return (arr, ticks)
 
-setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool
-setBreakFlag dflags toggle arr i
-   | toggle    = GHC.setBreakOn  dflags arr i
-   | otherwise = GHC.setBreakOff dflags arr i
+setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
+setBreakFlag toggle arr i
+   | toggle    = GHC.setBreakOn  arr i
+   | otherwise = GHC.setBreakOff arr i
 
 
 -- ---------------------------------------------------------------------------
index 607931d..f3c158d 100644 (file)
@@ -174,6 +174,7 @@ extern unsigned int RTS_VAR(era);
 
 CostCentreStack * pushCostCentre (CostCentreStack *, CostCentre *);
 void              enterFunCCS    (StgRegTable *reg, CostCentreStack *);
+CostCentre *mkCostCentre (char *label, char *module, char *srcloc);
 
 /* -----------------------------------------------------------------------------
    Registering CCs and CCSs
index 06d937a..1236d73 100644 (file)
@@ -446,6 +446,7 @@ RTS_FUN_DECL(stg_numSparkszh);
 RTS_FUN_DECL(stg_noDuplicatezh);
 
 RTS_FUN_DECL(stg_traceCcszh);
+RTS_FUN_DECL(stg_clearCCSzh);
 RTS_FUN_DECL(stg_traceEventzh);
 RTS_FUN_DECL(stg_traceMarkerzh);
 
index 8f57239..d7c5c94 100644 (file)
@@ -33,6 +33,7 @@ module GHC.Stack (
     CostCentre,
     getCurrentCCS,
     getCCSOf,
+    clearCCS,
     ccsCC,
     ccsParent,
     ccLabel,
index b62c80a..d40d92d 100644 (file)
@@ -26,6 +26,7 @@ module GHC.Stack.CCS (
     CostCentre,
     getCurrentCCS,
     getCCSOf,
+    clearCCS,
     ccsCC,
     ccsParent,
     ccLabel,
@@ -60,6 +61,9 @@ getCCSOf obj = IO $ \s ->
    case getCCSOf## obj s of
      (## s', addr ##) -> (## s', Ptr addr ##)
 
+clearCCS :: IO a -> IO a
+clearCCS (IO m) = IO $ \s -> clearCCS## m s
+
 ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
 ccsCC p = (# peek CostCentreStack, cc) p
 
index 0d28c68..5406854 100644 (file)
@@ -114,6 +114,18 @@ data Message a where
    :: HValueRef {- IO a -}
    -> Message (EvalResult ())
 
+  -- | Create a CostCentre
+  MkCostCentre
+   :: RemotePtr    -- module, RemotePtr so it can be shared
+   -> String       -- name
+   -> String       -- SrcSpan
+   -> Message RemotePtr
+
+  -- | Show a 'CostCentreStack' as a @[String]@
+  CostCentreStackInfo
+   :: RemotePtr {- from EvalBreak -}
+   -> Message [String]
+
   -- Template Haskell -------------------------------------------
 
   -- | Start a new TH module, return a state token that should be
@@ -191,6 +203,7 @@ data EvalStatus a
        HValueRef{- AP_STACK -}
        HValueRef{- BreakInfo -}
        HValueRef{- ResumeContext -}
+       RemotePtr -- Cost centre stack
   deriving (Generic, Show)
 
 instance Binary a => Binary (EvalStatus a)
@@ -264,24 +277,26 @@ getMessage = do
       21 -> Msg <$> (EvalString <$> get)
       22 -> Msg <$> (EvalStringToString <$> get <*> get)
       23 -> Msg <$> (EvalIO <$> get)
-      24 -> Msg <$> return StartTH
-      25 -> Msg <$> FinishTH <$> get
-      26 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
-      27 -> Msg <$> NewName <$> get
-      28 -> Msg <$> (Report <$> get <*> get)
-      29 -> Msg <$> (LookupName <$> get <*> get)
-      30 -> Msg <$> Reify <$> get
-      31 -> Msg <$> ReifyFixity <$> get
-      32 -> Msg <$> (ReifyInstances <$> get <*> get)
-      33 -> Msg <$> ReifyRoles <$> get
-      34 -> Msg <$> (ReifyAnnotations <$> get <*> get)
-      35 -> Msg <$> ReifyModule <$> get
-      36 -> Msg <$> AddDependentFile <$> get
-      37 -> Msg <$> AddTopDecls <$> get
-      38 -> Msg <$> (IsExtEnabled <$> get)
-      39 -> Msg <$> return ExtsEnabled
-      40 -> Msg <$> return QDone
-      41 -> Msg <$> QException <$> get
+      24 -> Msg <$> (MkCostCentre <$> get <*> get <*> get)
+      25 -> Msg <$> (CostCentreStackInfo <$> get)
+      26 -> Msg <$> return StartTH
+      27 -> Msg <$> FinishTH <$> get
+      28 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
+      29 -> Msg <$> NewName <$> get
+      30 -> Msg <$> (Report <$> get <*> get)
+      31 -> Msg <$> (LookupName <$> get <*> get)
+      32 -> Msg <$> Reify <$> get
+      33 -> Msg <$> ReifyFixity <$> get
+      34 -> Msg <$> (ReifyInstances <$> get <*> get)
+      35 -> Msg <$> ReifyRoles <$> get
+      36 -> Msg <$> (ReifyAnnotations <$> get <*> get)
+      37 -> Msg <$> ReifyModule <$> get
+      38 -> Msg <$> AddDependentFile <$> get
+      39 -> Msg <$> AddTopDecls <$> get
+      40 -> Msg <$> (IsExtEnabled <$> get)
+      41 -> Msg <$> return ExtsEnabled
+      42 -> Msg <$> return QDone
+      43 -> Msg <$> QException <$> get
       _  -> Msg <$> QFail <$> get
 
 putMessage :: Message a -> Put
@@ -310,25 +325,27 @@ putMessage m = case m of
   EvalString val              -> putWord8 21 >> put val
   EvalStringToString str val  -> putWord8 22 >> put str >> put val
   EvalIO val                  -> putWord8 23 >> put val
-  StartTH                     -> putWord8 24
-  FinishTH val                -> putWord8 25 >> put val
-  RunTH st q loc ty           -> putWord8 26 >> put st >> put q >> put loc >> put ty
-  NewName a                   -> putWord8 27 >> put a
-  Report a b                  -> putWord8 28 >> put a >> put b
-  LookupName a b              -> putWord8 29 >> put a >> put b
-  Reify a                     -> putWord8 30 >> put a
-  ReifyFixity a               -> putWord8 31 >> put a
-  ReifyInstances a b          -> putWord8 32 >> put a >> put b
-  ReifyRoles a                -> putWord8 33 >> put a
-  ReifyAnnotations a b        -> putWord8 34 >> put a >> put b
-  ReifyModule a               -> putWord8 35 >> put a
-  AddDependentFile a          -> putWord8 36 >> put a
-  AddTopDecls a               -> putWord8 37 >> put a
-  IsExtEnabled a              -> putWord8 38 >> put a
-  ExtsEnabled                 -> putWord8 39
-  QDone                       -> putWord8 40
-  QException a                -> putWord8 41 >> put a
-  QFail a                     -> putWord8 42 >> put a
+  MkCostCentre name mod src   -> putWord8 24 >> put name >> put mod >> put src
+  CostCentreStackInfo ptr     -> putWord8 25 >> put ptr
+  StartTH                     -> putWord8 26
+  FinishTH val                -> putWord8 27 >> put val
+  RunTH st q loc ty           -> putWord8 28 >> put st >> put q >> put loc >> put ty
+  NewName a                   -> putWord8 29 >> put a
+  Report a b                  -> putWord8 30 >> put a >> put b
+  LookupName a b              -> putWord8 31 >> put a >> put b
+  Reify a                     -> putWord8 32 >> put a
+  ReifyFixity a               -> putWord8 33 >> put a
+  ReifyInstances a b          -> putWord8 34 >> put a >> put b
+  ReifyRoles a                -> putWord8 35 >> put a
+  ReifyAnnotations a b        -> putWord8 36 >> put a >> put b
+  ReifyModule a               -> putWord8 37 >> put a
+  AddDependentFile a          -> putWord8 38 >> put a
+  AddTopDecls a               -> putWord8 39 >> put a
+  IsExtEnabled a              -> putWord8 40 >> put a
+  ExtsEnabled                 -> putWord8 41
+  QDone                       -> putWord8 42
+  QException a                -> putWord8 43 >> put a
+  QFail a                     -> putWord8 44 >> put a
 
 -- -----------------------------------------------------------------------------
 -- Reading/writing messages
index fc142a2..8934437 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables #-}
+{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 -- |
@@ -24,6 +24,7 @@ import Control.Monad
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Unsafe as B
 import GHC.Exts
+import GHC.Stack
 import Foreign
 import Foreign.C
 import GHC.Conc.Sync
@@ -56,6 +57,9 @@ run m = case m of
   EvalString r -> evalString r
   EvalStringToString r s -> evalStringToString r s
   EvalIO r -> evalIO r
+  MkCostCentre name mod src ->
+    toRemotePtr <$> mkCostCentre (fromRemotePtr name) mod src
+  CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
   MallocData bs -> mkString bs
   PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
   FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
@@ -112,7 +116,7 @@ sandboxIO opts io = do
   breakMVar <- newEmptyMVar
   statusMVar <- newEmptyMVar
   withBreakAction opts breakMVar statusMVar $ do
-    let runIt = measureAlloc $ tryEval $ rethrow opts io
+    let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
     if useSandboxThread opts
        then do
          tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
@@ -237,7 +241,8 @@ withBreakAction opts breakMVar statusMVar act
      resume_r <- mkHValueRef (unsafeCoerce resume)
      apStack_r <- mkHValueRef apStack
      info_r <- mkHValueRef info
-     putMVar statusMVar (EvalBreak is_exception apStack_r info_r resume_r)
+     ccs <- toRemotePtr <$> getCCSOf apStack
+     putMVar statusMVar $ EvalBreak is_exception apStack_r info_r resume_r ccs
      takeMVar breakMVar
 
    resetBreakAction stablePtr = do
@@ -305,3 +310,18 @@ mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
   ptr <- mallocBytes len
   copyBytes ptr cstr len
   return (toRemotePtr ptr)
+
+data CCostCentre
+
+mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CCostCentre)
+#if defined(PROFILING)
+mkCostCentre c_module srcspan decl_path = do
+  c_name <- newCString decl_path
+  c_srcspan <- newCString srcspan
+  c_mkCostCentre c_name c_module c_srcspan
+
+foreign import ccall unsafe "mkCostCentre"
+  c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CCostCentre)
+#else
+mkCostCentre _ _ _ = return nullPtr
+#endif
index 7e3529b..2e1790e 100644 (file)
@@ -67,8 +67,9 @@ disInstr ( StgBCO *bco, int pc )
    switch (instr & 0xff) {
       case bci_BRK_FUN:
          debugBelch ("BRK_FUN  " );  printPtr( ptrs[instrs[pc]] );
-         debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] ); debugBelch("\n" );
-         pc += 3;
+         debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] );
+         debugBelch(" %s\n", ((CostCentre*)(literals[instrs[pc+3]]))->label);
+         pc += 4;
          break;
       case bci_SWIZZLE:
          debugBelch("SWIZZLE stkoff %d by %d\n",
index e1510db..37fef9c 100644 (file)
@@ -18,6 +18,7 @@
 #include "Prelude.h"
 #include "Stable.h"
 #include "Printer.h"
+#include "Profiling.h"
 #include "Disassembler.h"
 #include "Interpreter.h"
 #include "ThreadPaused.h"
     SpLim = tso_SpLim(cap->r.rCurrentTSO);
 
 #define SAVE_STACK_POINTERS                     \
-    cap->r.rCurrentTSO->stackobj->sp = Sp
+    cap->r.rCurrentTSO->stackobj->sp = Sp;
+
+#ifdef PROFILING
+#define LOAD_THREAD_STATE()                     \
+    LOAD_STACK_POINTERS                         \
+    cap->r.rCCCS = cap->r.rCurrentTSO->prof.cccs;
+#else
+#define LOAD_THREAD_STATE()                     \
+    LOAD_STACK_POINTERS
+#endif
+
+#ifdef PROFILING
+#define SAVE_THREAD_STATE()                     \
+    SAVE_STACK_POINTERS                         \
+    cap->r.rCurrentTSO->prof.cccs = cap->r.rCCCS;
+#else
+#define SAVE_THREAD_STATE()                     \
+    SAVE_STACK_POINTERS
+#endif
 
 // Note [Not true: ASSERT(Sp > SpLim)]
 //
 // less than SpLim both when leaving to return to the scheduler.
 
 #define RETURN_TO_SCHEDULER(todo,retcode)       \
-   SAVE_STACK_POINTERS;                         \
+   SAVE_THREAD_STATE();                         \
    cap->r.rCurrentTSO->what_next = (todo);      \
-   threadPaused(cap,cap->r.rCurrentTSO);                \
+   threadPaused(cap,cap->r.rCurrentTSO);        \
    cap->r.rRet = (retcode);                     \
    return cap;
 
 #define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode)      \
-   SAVE_STACK_POINTERS;                                 \
+   SAVE_THREAD_STATE();                                 \
    cap->r.rCurrentTSO->what_next = (todo);              \
    cap->r.rRet = (retcode);                             \
    return cap;
@@ -217,11 +236,24 @@ interpretBCO (Capability* cap)
     register StgClosure   *tagged_obj = 0, *obj;
     nat n, m;
 
-    LOAD_STACK_POINTERS;
+    LOAD_THREAD_STATE();
 
     cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
                            // goes to zero we must return to the scheduler.
 
+    IF_DEBUG(interpreter,
+             debugBelch(
+             "\n---------------------------------------------------------------\n");
+             debugBelch("Entering the interpreter, Sp = %p\n", Sp);
+#ifdef PROFILING
+             fprintCCS(stderr, cap->r.rCCCS);
+             debugBelch("\n");
+#endif
+             debugBelch("\n");
+             printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
+             debugBelch("\n\n");
+            );
+
     // ------------------------------------------------------------------------
     // Case 1:
     //
@@ -231,6 +263,8 @@ interpretBCO (Capability* cap)
     //          +---------------+
     //       Sp |      -------------------> closure
     //          +---------------+
+    //          |   stg_enter   |
+    //          +---------------+
     //
     if (Sp[0] == (W_)&stg_enter_info) {
        Sp++;
@@ -280,6 +314,10 @@ eval_obj:
              "\n---------------------------------------------------------------\n");
              debugBelch("Evaluating: "); printObj(obj);
              debugBelch("Sp = %p\n", Sp);
+#ifdef PROFILING
+             fprintCCS(stderr, cap->r.rCCCS);
+             debugBelch("\n");
+#endif
              debugBelch("\n" );
 
              printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
@@ -333,16 +371,20 @@ eval_obj:
         words = ap->n_args;
 
         // Stack check
-        if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) {
+        if (Sp - (words+sizeofW(StgUpdateFrame)+2) < SpLim) {
             Sp -= 2;
             Sp[1] = (W_)tagged_obj;
             Sp[0] = (W_)&stg_enter_info;
             RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
         }
 
-        ENTER_CCS_THUNK(cap,ap);
+#ifdef PROFILING
+        // restore the CCCS after evaluating the AP
+        Sp -= 2;
+        Sp[1] = (W_)cap->r.rCCCS;
+        Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
 
-        /* Ok; we're safe.  Party on.  Push an update frame. */
         Sp -= sizeofW(StgUpdateFrame);
         {
             StgUpdateFrame *__frame;
@@ -351,6 +393,8 @@ eval_obj:
             __frame->updatee = (StgClosure *)(ap);
         }
 
+        ENTER_CCS_THUNK(cap,ap);
+
         /* Reload the stack */
         Sp -= words;
         for (i=0; i < words; i++) {
@@ -379,6 +423,12 @@ eval_obj:
                  debugBelch("evaluating unknown closure -- yielding to sched\n");
                  printObj(obj);
             );
+#ifdef PROFILING
+        // restore the CCCS after evaluating the closure
+        Sp -= 2;
+        Sp[1] = (W_)cap->r.rCCCS;
+        Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
         Sp -= 2;
         Sp[1] = (W_)tagged_obj;
         Sp[0] = (W_)&stg_enter_info;
@@ -398,7 +448,11 @@ do_return:
              "\n---------------------------------------------------------------\n");
              debugBelch("Returning: "); printObj(obj);
              debugBelch("Sp = %p\n", Sp);
-             debugBelch("\n" );
+#ifdef PROFILING
+             fprintCCS(stderr, cap->r.rCCCS);
+             debugBelch("\n");
+#endif
+             debugBelch("\n");
              printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
              debugBelch("\n\n");
             );
@@ -412,6 +466,13 @@ do_return:
 
         // NOTE: not using get_itbl().
         info = ((StgClosure *)Sp)->header.info;
+
+        if (info == (StgInfoTable *)&stg_restore_cccs_info) {
+            cap->r.rCCCS = (CostCentreStack*)Sp[1];
+            Sp += 2;
+            goto do_return;
+        }
+
         if (info == (StgInfoTable *)&stg_ap_v_info) {
             n = 1; m = 0; goto do_apply;
         }
@@ -528,6 +589,20 @@ do_return_unboxed:
                 || Sp[0] == (W_)&stg_ret_l_info
             );
 
+        IF_DEBUG(interpreter,
+             debugBelch(
+             "\n---------------------------------------------------------------\n");
+             debugBelch("Returning: "); printObj(obj);
+             debugBelch("Sp = %p\n", Sp);
+#ifdef PROFILING
+             fprintCCS(stderr, cap->r.rCCCS);
+             debugBelch("\n");
+#endif
+             debugBelch("\n");
+             printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
+             debugBelch("\n\n");
+            );
+
         // get the offset of the stg_ctoi_ret_XXX itbl
         offset = stack_frame_sizeW((StgClosure *)Sp);
 
@@ -610,6 +685,10 @@ do_apply:
                     Sp[i] = (W_)pap->payload[i];
                 }
                 obj = UNTAG_CLOSURE(pap->fun);
+
+#ifdef PROFILING
+                enterFunCCS(&cap->r, pap->header.prof.ccs);
+#endif
                 goto run_BCO_fun;
             }
             else if (arity == n) {
@@ -618,6 +697,9 @@ do_apply:
                     Sp[i] = (W_)pap->payload[i];
                 }
                 obj = UNTAG_CLOSURE(pap->fun);
+#ifdef PROFILING
+                enterFunCCS(&cap->r, pap->header.prof.ccs);
+#endif
                 goto run_BCO_fun;
             }
             else /* arity > n */ {
@@ -685,6 +767,8 @@ do_apply:
         // No point in us applying machine-code functions
         default:
         defer_apply_to_sched:
+            IF_DEBUG(interpreter,
+                     debugBelch("Cannot apply compiled function; yielding to scheduler\n"));
             Sp -= 2;
             Sp[1] = (W_)tagged_obj;
             Sp[0] = (W_)&stg_enter_info;
@@ -845,22 +929,40 @@ run_BCO:
         case bci_BRK_FUN:
         {
             int arg1_brk_array, arg2_array_index, arg3_freeVars;
+#ifdef PROFILING
+            int arg4_cc;
+#endif
             StgArrBytes *breakPoints;
-            int returning_from_break;     // are we resuming execution from a breakpoint?
-                                          //  if yes, then don't break this time around
-            StgClosure *ioAction;         // the io action to run at a breakpoint
+            int returning_from_break;
+
+            // the io action to run at a breakpoint
+            StgClosure *ioAction;
+
+            // a closure to save the top stack frame on the heap
+            StgAP_STACK *new_aps;
 
-            StgAP_STACK *new_aps;         // a closure to save the top stack frame on the heap
             int i;
             int size_words;
 
-            arg1_brk_array      = BCO_GET_LARGE_ARG;  // 1st arg of break instruction
-            arg2_array_index    = BCO_NEXT;           // 2nd arg of break instruction
-            arg3_freeVars       = BCO_GET_LARGE_ARG;  // 3rd arg of break instruction
+            arg1_brk_array      = BCO_GET_LARGE_ARG;
+            arg2_array_index    = BCO_NEXT;
+            arg3_freeVars       = BCO_GET_LARGE_ARG;
+#ifdef PROFILING
+            arg4_cc             = BCO_GET_LARGE_ARG;
+#else
+            BCO_GET_LARGE_ARG;
+#endif
 
             // check if we are returning from a breakpoint - this info
-            // is stored in the flags field of the current TSO
-            returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
+            // is stored in the flags field of the current TSO. If true,
+            // then don't break this time around.
+            returning_from_break =
+                cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT;
+
+#ifdef PROFILING
+            cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
+                                          (CostCentre*)BCO_LIT(arg4_cc));
+#endif
 
             // if we are returning from a break then skip this section
             // and continue executing
@@ -873,7 +975,8 @@ run_BCO:
                // breakpoint flag for this particular expression is
                // true
                if (rts_stop_next_breakpoint == rtsTrue ||
-                   breakPoints->payload[arg2_array_index] == rtsTrue)
+                   ((StgWord8*)breakPoints->payload)[arg2_array_index]
+                     == rtsTrue)
                {
                   // make sure we don't automatically stop at the
                   // next breakpoint
@@ -983,9 +1086,14 @@ run_BCO:
 
         case bci_PUSH_ALTS: {
             int o_bco  = BCO_GET_LARGE_ARG;
-            Sp[-2] = (W_)&stg_ctoi_R1p_info;
-            Sp[-1] = BCO_PTR(o_bco);
             Sp -= 2;
+            Sp[1] = BCO_PTR(o_bco);
+            Sp[0] = (W_)&stg_ctoi_R1p_info;
+#ifdef PROFILING
+            Sp -= 2;
+            Sp[1] = (W_)cap->r.rCCCS;
+            Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
             goto nextInsn;
         }
 
@@ -994,6 +1102,11 @@ run_BCO:
             Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
             Sp[-1] = BCO_PTR(o_bco);
             Sp -= 2;
+#ifdef PROFILING
+            Sp -= 2;
+            Sp[1] = (W_)cap->r.rCCCS;
+            Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
             goto nextInsn;
         }
 
@@ -1002,6 +1115,11 @@ run_BCO:
             Sp[-2] = (W_)&stg_ctoi_R1n_info;
             Sp[-1] = BCO_PTR(o_bco);
             Sp -= 2;
+#ifdef PROFILING
+            Sp -= 2;
+            Sp[1] = (W_)cap->r.rCCCS;
+            Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
             goto nextInsn;
         }
 
@@ -1010,6 +1128,11 @@ run_BCO:
             Sp[-2] = (W_)&stg_ctoi_F1_info;
             Sp[-1] = BCO_PTR(o_bco);
             Sp -= 2;
+#ifdef PROFILING
+            Sp -= 2;
+            Sp[1] = (W_)cap->r.rCCCS;
+            Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
             goto nextInsn;
         }
 
@@ -1018,6 +1141,11 @@ run_BCO:
             Sp[-2] = (W_)&stg_ctoi_D1_info;
             Sp[-1] = BCO_PTR(o_bco);
             Sp -= 2;
+#ifdef PROFILING
+            Sp -= 2;
+            Sp[1] = (W_)cap->r.rCCCS;
+            Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
             goto nextInsn;
         }
 
@@ -1026,6 +1154,11 @@ run_BCO:
             Sp[-2] = (W_)&stg_ctoi_L1_info;
             Sp[-1] = BCO_PTR(o_bco);
             Sp -= 2;
+#ifdef PROFILING
+            Sp -= 2;
+            Sp[1] = (W_)cap->r.rCCCS;
+            Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
             goto nextInsn;
         }
 
@@ -1034,6 +1167,11 @@ run_BCO:
             Sp[-2] = (W_)&stg_ctoi_V_info;
             Sp[-1] = BCO_PTR(o_bco);
             Sp -= 2;
+#ifdef PROFILING
+            Sp -= 2;
+            Sp[1] = (W_)cap->r.rCCCS;
+            Sp[0] = (W_)&stg_restore_cccs_info;
+#endif
             goto nextInsn;
         }
 
@@ -1469,7 +1607,7 @@ run_BCO:
             Sp[1] = (W_)obj;
             Sp[0] = (W_)&stg_ret_p_info;
 
-            SAVE_STACK_POINTERS;
+            SAVE_THREAD_STATE();
             tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);
 
             // We already made a copy of the arguments above.
@@ -1477,7 +1615,7 @@ run_BCO:
 
             // And restart the thread again, popping the stg_ret_p frame.
             cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
-            LOAD_STACK_POINTERS;
+            LOAD_THREAD_STATE();
 
             if (Sp[0] != (W_)&stg_ret_p_info) {
                 // the stack is not how we left it.  This probably
index 7d0c661..2989f29 100644 (file)
@@ -1243,7 +1243,6 @@ stg_catchRetryzh (P_ first_code, /* :: STM a */
         (first_code);
 }
 
-
 stg_retryzh /* no arg list: explicit stack layout */
 {
     W_ frame_type;
@@ -1914,7 +1913,7 @@ stg_newBCOzh ( P_ instrs,
     ALLOC_PRIM (bytes);
 
     bco = Hp - bytes + WDS(1);
-    SET_HDR(bco, stg_BCO_info, CCCS);
+    SET_HDR(bco, stg_BCO_info, CCS_MAIN);
 
     StgBCO_instrs(bco)     = instrs;
     StgBCO_literals(bco)   = literals;
@@ -1950,7 +1949,7 @@ stg_mkApUpd0zh ( P_ bco )
     CCCS_ALLOC(SIZEOF_StgAP);
 
     ap = Hp - SIZEOF_StgAP + WDS(1);
-    SET_HDR(ap, stg_AP_info, CCCS);
+    SET_HDR(ap, stg_AP_info, CCS_MAIN);
 
     StgAP_n_args(ap) = HALF_W_(0);
     StgAP_fun(ap) = bco;
@@ -2351,6 +2350,14 @@ stg_getSparkzh ()
 #endif
 }
 
+stg_clearCCSzh (P_ arg)
+{
+#ifdef PROFILING
+    CCCS = CCS_MAIN;
+#endif
+    jump stg_ap_v_fast(arg);
+}
+
 stg_numSparkszh ()
 {
     W_ n;
index 637cd9a..e2fa57c 100644 (file)
 #include "Printer.h"
 #include "RtsUtils.h"
 
+#ifdef PROFILING
+#include "Profiling.h"
+#endif
+
 #include <string.h>
 
 #ifdef DEBUG
@@ -422,42 +426,6 @@ void printGraph( StgClosure *obj )
 }
 */
 
-StgPtr
-printStackObj( StgPtr sp )
-{
-    /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */
-
-        StgClosure* c = (StgClosure*)(*sp);
-        printPtr((StgPtr)*sp);
-        if (c == (StgClosure*)&stg_ctoi_R1p_info) {
-           debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" );
-        } else
-        if (c == (StgClosure*)&stg_ctoi_R1n_info) {
-           debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" );
-        } else
-        if (c == (StgClosure*)&stg_ctoi_F1_info) {
-           debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" );
-        } else
-        if (c == (StgClosure*)&stg_ctoi_D1_info) {
-           debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" );
-        } else
-        if (c == (StgClosure*)&stg_ctoi_V_info) {
-           debugBelch("\t\t\tstg_ctoi_ret_V_info\n" );
-        } else
-        if (get_itbl(c)->type == BCO) {
-           debugBelch("\t\t\t");
-           debugBelch("BCO(...)\n");
-        }
-        else {
-           debugBelch("\t\t\t");
-           printClosure ( (StgClosure*)(*sp));
-        }
-        sp += 1;
-
-    return sp;
-
-}
-
 static void
 printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
 {
@@ -513,15 +481,58 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
         case CATCH_FRAME:
         case UNDERFLOW_FRAME:
         case STOP_FRAME:
-            printObj((StgClosure*)sp);
+            printClosure((StgClosure*)sp);
             continue;
 
-        case RET_SMALL:
-            debugBelch("RET_SMALL (%p)\n", info);
+        case RET_SMALL: {
+            StgWord c = *sp;
+            if (c == (StgWord)&stg_ctoi_R1p_info) {
+                debugBelch("tstg_ctoi_ret_R1p_info\n" );
+            } else if (c == (StgWord)&stg_ctoi_R1n_info) {
+                debugBelch("stg_ctoi_ret_R1n_info\n" );
+            } else if (c == (StgWord)&stg_ctoi_F1_info) {
+                debugBelch("stg_ctoi_ret_F1_info\n" );
+            } else if (c == (StgWord)&stg_ctoi_D1_info) {
+                debugBelch("stg_ctoi_ret_D1_info\n" );
+            } else if (c == (StgWord)&stg_ctoi_V_info) {
+                debugBelch("stg_ctoi_ret_V_info\n" );
+            } else if (c == (StgWord)&stg_ap_v_info) {
+                debugBelch("stg_ap_v_info\n" );
+            } else if (c == (StgWord)&stg_ap_f_info) {
+                debugBelch("stg_ap_f_info\n" );
+            } else if (c == (StgWord)&stg_ap_d_info) {
+                debugBelch("stg_ap_d_info\n" );
+            } else if (c == (StgWord)&stg_ap_l_info) {
+                debugBelch("stg_ap_l_info\n" );
+            } else if (c == (StgWord)&stg_ap_n_info) {
+                debugBelch("stg_ap_n_info\n" );
+            } else if (c == (StgWord)&stg_ap_p_info) {
+                debugBelch("stg_ap_p_info\n" );
+            } else if (c == (StgWord)&stg_ap_pp_info) {
+                debugBelch("stg_ap_pp_info\n" );
+            } else if (c == (StgWord)&stg_ap_ppp_info) {
+                debugBelch("stg_ap_ppp_info\n" );
+            } else if (c == (StgWord)&stg_ap_pppp_info) {
+                debugBelch("stg_ap_pppp_info\n" );
+            } else if (c == (StgWord)&stg_ap_ppppp_info) {
+                debugBelch("stg_ap_ppppp_info\n" );
+            } else if (c == (StgWord)&stg_ap_pppppp_info) {
+                debugBelch("stg_ap_pppppp_info\n" );
+#ifdef PROFILING
+            } else if (c == (StgWord)&stg_restore_cccs_info) {
+                debugBelch("stg_restore_cccs_info\n" );
+                fprintCCS(stderr, (CostCentreStack*)sp[1]);
+                debugBelch("\n" );
+                continue;
+#endif
+            } else {
+                debugBelch("RET_SMALL (%p)\n", info);
+            }
             bitmap = info->layout.bitmap;
             printSmallBitmap(spBottom, sp+1,
                              BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap));
             continue;
+        }
 
         case RET_BCO: {
             StgBCO *bco;
@@ -963,4 +974,3 @@ void
 info_hdr_type(StgClosure *closure, char *res){
   strcpy(res,closure_type_names[get_itbl(closure)->type]);
 }
-
index 96656c4..31185aa 100644 (file)
@@ -24,7 +24,6 @@ char  *            info_update_frame ( StgClosure *closure );
 #ifdef DEBUG
 extern void        prettyPrintClosure (StgClosure *obj);
 extern void        printClosure    ( StgClosure *obj );
-extern StgPtr      printStackObj   ( StgPtr sp );
 extern void        printStackChunk ( StgPtr sp, StgPtr spLim );
 extern void        printTSO        ( StgTSO *tso );
 
index 982b946..2c2981a 100644 (file)
@@ -227,6 +227,15 @@ freeProfiling (void)
     arenaFree(prof_arena);
 }
 
+CostCentre *mkCostCentre (char *label, char *module, char *srcloc)
+{
+    CostCentre *cc = stgMallocBytes (sizeof(CostCentre), "mkCostCentre");
+    cc->label = label;
+    cc->module = module;
+    cc->srcloc = srcloc;
+    return cc;
+}
+
 static void
 initProfilingLogFile(void)
 {
index 4b0a1d5..ffb5c39 100644 (file)
       SymI_HasProto(stg_restore_cccs_info)      \
       SymI_HasProto(enterFunCCS)                \
       SymI_HasProto(pushCostCentre)             \
+      SymI_HasProto(mkCostCentre)               \
       SymI_HasProto(era)
 #else
 #define RTS_PROF_SYMBOLS /* empty */
       SymI_HasProto(stg_catchRetryzh)                                   \
       SymI_HasProto(stg_catchSTMzh)                                     \
       SymI_HasProto(stg_checkzh)                                        \
+      SymI_HasProto(stg_clearCCSzh)                                     \
       SymI_HasProto(closure_flags)                                      \
       SymI_HasProto(cmp_thread)                                         \
       SymI_HasProto(createAdjustor)                                     \
index a7bd833..68554ec 100644 (file)
@@ -1,7 +1,6 @@
 :seti -XMonomorphismRestriction
 :l T2740.hs
 :step f 1 2 3
-:step
 :print x
 :print y
 :force x
index 1f3e6d9..efa5b1d 100644 (file)
@@ -1,6 +1,4 @@
-Stopped at T2740.hs:(3,1)-(4,25)
-_result :: a2 = _
-Stopped at T2740.hs:3:11-13
+Stopped in Test.f, T2740.hs:3:11-13
 _result :: Bool = _
 x :: Integer = 1
 y :: Integer = 2
index ec02c70..a4d2634 100644 (file)
@@ -3,8 +3,6 @@
 :b 5
 f (1 :: Integer)
 :st
-:st
-:st
 -- Test that the binding for x is now gone
 :show bindings
 y
index 02ba1bb..99ffda0 100644 (file)
@@ -1,13 +1,9 @@
-Breakpoint 0 activated at ../Test2.hs:3:1-9
-Breakpoint 1 activated at ../Test2.hs:5:1-7
-Stopped at ../Test2.hs:3:1-9
-_result :: r = _
-Stopped at ../Test2.hs:3:7-9
+Breakpoint 0 activated at ../Test2.hs:3:7-9
+Breakpoint 1 activated at ../Test2.hs:5:7
+Stopped in Test2.f, ../Test2.hs:3:7-9
 _result :: Integer = _
 x :: Integer = 1
-Stopped at ../Test2.hs:5:1-7
-_result :: r = _
-Stopped at ../Test2.hs:5:7
+Stopped in Test2.g, ../Test2.hs:5:7
 _result :: Integer = _
 y :: Integer = 1
 y :: Integer = 1
index b1aa8ba..1d0844c 100644 (file)
@@ -1,5 +1,5 @@
 Breakpoint 0 activated at ../Test3.hs:2:18-31
-Stopped at ../Test3.hs:2:18-31
+Stopped in Main.mymap, ../Test3.hs:2:18-31
 _result :: [t] = _
 f :: t1 -> t = _
 x :: t1 = _
index 65eeb56..81eae63 100644 (file)
@@ -1,9 +1,10 @@
-Stopped at ../QSort.hs:(4,1)-(6,55)
-_result :: [t] = _
-Stopped at ../QSort.hs:5:16-51
+Stopped in QSort.qsort, ../QSort.hs:5:16-51
 _result :: [Integer] = _
 a :: Integer = 1
 left :: [Integer] = _
 right :: [Integer] = _
+Stopped in QSort.qsort, ../QSort.hs:5:17-26
+_result :: [t] = _
+left :: [t] = _
 ()
 left = []
index 38cd1e1..6cbc050 100644 (file)
@@ -1,6 +1,5 @@
 :l ../Test3.hs
 :st mymap (+1) [1::Integer,2,3]
-:st
 :show bindings
 f x -- should fail, unknown return type
 let y = f x
@@ -11,4 +10,3 @@ y
 -- we know the result is Integer now
 f x
 -- should work now
-
index 58faa69..3b57eb3 100644 (file)
@@ -1,9 +1,9 @@
 
-<interactive>:5:1: error:
+<interactive>:4:1: error:
     • No instance for (Show t) arising from a use of ‘print’
       Cannot resolve unknown runtime type ‘t’
       Use :print or :force to determine these types
-      Relevant bindings include it :: t (bound at <interactive>:5:1)
+      Relevant bindings include it :: t (bound at <interactive>:4:1)
       These potential instances exist:
         instance (Show a, Show b) => Show (Either a b)
           -- Defined in ‘Data.Either’
         (use -fprint-potential-instances to see them all)
     • In a stmt of an interactive GHCi command: print it
 
-<interactive>:7:1: error:
+<interactive>:6:1: error:
     • No instance for (Show t) arising from a use of ‘print’
       Cannot resolve unknown runtime type ‘t’
       Use :print or :force to determine these types
-      Relevant bindings include it :: t (bound at <interactive>:7:1)
+      Relevant bindings include it :: t (bound at <interactive>:6:1)
       These potential instances exist:
         instance (Show a, Show b) => Show (Either a b)
           -- Defined in ‘Data.Either’
index 374fffd..d8f1b65 100644 (file)
@@ -1,6 +1,4 @@
-Stopped at ../Test3.hs:(1,1)-(2,31)
-_result :: [t] = _
-Stopped at ../Test3.hs:2:18-31
+Stopped in Main.mymap, ../Test3.hs:2:18-31
 _result :: [t] = _
 f :: Integer -> t = _
 x :: Integer = 1
index 6961fa3..1a8427f 100644 (file)
@@ -1,3 +1,3 @@
 Breakpoint 0 activated at ../Test3.hs:1:14-15
-Stopped at ../Test3.hs:1:14-15
+Stopped in Main.mymap, ../Test3.hs:1:14-15
 _result :: [a] = _
index 9a4fa56..49515cf 100644 (file)
@@ -1,5 +1,5 @@
 Breakpoint 0 activated at ../Test6.hs:5:8-11
-Stopped at ../Test6.hs:5:8-11
+Stopped in Main.main, ../Test6.hs:5:8-11
 _result :: a2 = _
 *** Exception: Prelude.head: empty list
 CallStack (from ImplicitParams):
index 682f4c3..0bc0da7 100644 (file)
@@ -1,5 +1,5 @@
 Breakpoint 0 activated at ../Test6.hs:5:8-11
-Stopped at ../Test6.hs:5:8-11
+Stopped in Main.main, ../Test6.hs:5:8-11
 _result :: a2 = _
-Stopped at ../Test6.hs:5:8-11
+Stopped in Main.main, ../Test6.hs:5:8-11
 _result :: a2 = _
index ec0b3e9..5839067 100644 (file)
@@ -1,9 +1,9 @@
 *** Exception: foo
 CallStack (from ImplicitParams):
   error, called at <interactive>:2:1 in interactive:Ghci1
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = _
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = _
 -1  : main (../Test7.hs:2:18-28)
 -2  : main (../Test7.hs:2:8-29)
@@ -15,7 +15,7 @@ _result :: IO a3
 no more logged breakpoints
 Logged breakpoint at ../Test7.hs:2:18-28
 _result :: a3
-Stopped at <exception thrown>
+Stopped at <unknown>
 _exception :: e
 already at the beginning of the history
 _exception = SomeException
@@ -32,13 +32,13 @@ _exception :: SomeException = SomeException
 *** Exception: foo
 CallStack (from ImplicitParams):
   error, called at ../Test7.hs:2:18 in main:Main
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = SomeException
                     (ErrorCallWithLocation
                        "foo"
                        "CallStack (from ImplicitParams):
   error, called at ../Test7.hs:2:18 in main:Main")
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = SomeException
                     (ErrorCallWithLocation
                        "foo"
index 749947a..acb5230 100644 (file)
@@ -1,9 +1,8 @@
 -- Test polymorphic types in a breakpoint
 :l break012
 :st g 5 `seq` ()
-:st
-:t a 
-:t b 
-:t c 
+:t a
+:t b
+:t c
 :t d
 :p a b c d
index 6b02371..4eed1e6 100644 (file)
@@ -1,6 +1,4 @@
-Stopped at break012.hs:(1,1)-(5,18)
-_result :: (r, a3 -> a3, (), a2 -> a2 -> a2) = _
-Stopped at break012.hs:5:10-18
+Stopped in Main.g, break012.hs:5:10-18
 _result :: (r, a3 -> a3, (), a2 -> a2 -> a2) = _
 a :: r = _
 b :: a4 -> a4 = _
index b14e4c1..1b0a842 100644 (file)
@@ -1,5 +1,4 @@
 -- Available bindings at where(s)
 :l break013
 :st g 1 `seq` ()
-:st
 :show bindings
index 13d203f..52aa48e 100644 (file)
@@ -1,6 +1,4 @@
-Stopped at break013.hs:(1,1)-(4,18)
-_result :: (Bool, Bool, ()) = _
-Stopped at break013.hs:1:7-13
+Stopped in Main.g, break013.hs:1:7-13
 _result :: (Bool, Bool, ()) = _
 a :: Bool = _
 b :: Bool = _
index 3d284bf..9197622 100644 (file)
@@ -1,5 +1,5 @@
 Breakpoint 0 activated at break014.hs:3:15-19
-Stopped at break014.hs:3:15-19
+Stopped in Main.g.c, break014.hs:3:15-19
 _result :: (Bool, Bool) = _
 a :: Bool = _
 b :: Bool = _
index e7e1817..6c8513f 100644 (file)
@@ -1,4 +1,4 @@
-"Stopped at <exception thrown>
+"Stopped in <exception thrown>, <unknown>
 _exception :: e = _
 Logged breakpoint at ../QSort.hs:6:24-38
 _result :: [Char]
index 0a4c70e..a30af6b 100644 (file)
@@ -1,9 +1,8 @@
 -- Check mdo statements: availability of local bindings.
--- Maybe we should not want to put in scope the things binded in the mdo scope, to avoid silliness. 
+-- Maybe we should not want to put in scope the things binded in the mdo scope, to avoid silliness.
 
 :set -XRecursiveDo
 :l ../mdo.hs
 :st l2dll "hello world"
 :st
 :st
-:st
index d9c6b6e..4ca3d6a 100644 (file)
@@ -1,13 +1,14 @@
-Stopped at ../mdo.hs:(30,1)-(32,27)
-_result :: IO (N a7) = _
-Stopped at ../mdo.hs:(30,16)-(32,27)
+Stopped in Main.l2dll, ../mdo.hs:(30,16)-(32,27)
 _result :: IO (N Char) = _
 x :: Char = 'h'
 xs :: [Char] = _
-Stopped at ../mdo.hs:30:30-42
+Stopped in Main.l2dll, ../mdo.hs:30:30-42
 _result :: IO (N Char) = _
 f :: N Char = _
 l :: N Char = _
 x :: Char = 'h'
-Stopped at ../mdo.hs:(8,1)-(9,42)
-_result :: IO (N a7) = _
+Stopped in Main.newNode, ../mdo.hs:(8,17)-(9,42)
+_result :: IO (N Char) = _
+b :: N Char = _
+c :: Char = 'h'
+f :: N Char = _
index 0c7b0a4..cab4e5e 100644 (file)
@@ -1,4 +1,4 @@
-Stopped at break020.hs:(9,8)-(15,11)
+Stopped in Main.main, break020.hs:(9,8)-(15,11)
 _result :: IO () = _
 8  
         vv
@@ -10,31 +10,31 @@ _result :: IO () = _
 14    line2 1
 15    return ()
                ^^
-Stopped at break020.hs:10:3-9
+Stopped in Main.main, break020.hs:10:3-9
 _result :: IO () = _
 9  main = do
 10    line1 0
       ^^^^^^^
 11    line2 0
-Stopped at break020.hs:11:3-9
+Stopped in Main.main, break020.hs:11:3-9
 _result :: IO () = _
 10    line1 0
 11    line2 0
       ^^^^^^^
 12    in_another_decl 0
-Stopped at break020.hs:12:3-19
+Stopped in Main.main, break020.hs:12:3-19
 _result :: IO () = _
 11    line2 0
 12    in_another_decl 0
       ^^^^^^^^^^^^^^^^^
 13    in_another_module 0
-Stopped at break020.hs:13:3-21
+Stopped in Main.main, break020.hs:13:3-21
 _result :: IO () = _
 12    in_another_decl 0
 13    in_another_module 0
       ^^^^^^^^^^^^^^^^^^^
 14    line2 1
-Stopped at break020.hs:14:3-9
+Stopped in Main.main, break020.hs:14:3-9
 _result :: IO () = _
 13    in_another_module 0
 14    line2 1
index e9251d6..c72831d 100644 (file)
@@ -16,8 +16,3 @@
 :stepmodule
 :stepmodule
 :stepmodule
-:stepmodule
-:stepmodule
-:stepmodule
-:stepmodule
-:stepmodule
\ No newline at end of file
index 3a78eaf..cc680a5 100644 (file)
@@ -1,4 +1,4 @@
-Stopped at break020.hs:(9,8)-(15,11)
+Stopped in Main.main, break020.hs:(9,8)-(15,11)
 _result :: IO () = _
 8  
         vv
@@ -10,57 +10,37 @@ _result :: IO () = _
 14    line2 1
 15    return ()
                ^^
-Stopped at break020.hs:10:3-9
+Stopped in Main.main, break020.hs:10:3-9
 _result :: IO () = _
 9  main = do
 10    line1 0
       ^^^^^^^
 11    line2 0
-Stopped at break020.hs:3:1-19
-_result :: IO () = _
-2  
-3  line1 _ = return ()
-   ^^^^^^^^^^^^^^^^^^^
-4  line2 _ = return ()
-Stopped at break020.hs:3:11-19
+Stopped in Main.line1, break020.hs:3:11-19
 _result :: IO () = _
 2  
 3  line1 _ = return ()
              ^^^^^^^^^
 4  line2 _ = return ()
-Stopped at break020.hs:11:3-9
+Stopped in Main.main, break020.hs:11:3-9
 _result :: IO () = _
 10    line1 0
 11    line2 0
       ^^^^^^^
 12    in_another_decl 0
-Stopped at break020.hs:4:1-19
-_result :: IO () = _
-3  line1 _ = return ()
-4  line2 _ = return ()
-   ^^^^^^^^^^^^^^^^^^^
-5  
-Stopped at break020.hs:4:11-19
+Stopped in Main.line2, break020.hs:4:11-19
 _result :: IO () = _
 3  line1 _ = return ()
 4  line2 _ = return ()
              ^^^^^^^^^
 5  
-Stopped at break020.hs:12:3-19
+Stopped in Main.main, break020.hs:12:3-19
 _result :: IO () = _
 11    line2 0
 12    in_another_decl 0
       ^^^^^^^^^^^^^^^^^
 13    in_another_module 0
-Stopped at break020.hs:(6,1)-(7,30)
-_result :: m () = _
-5  
-   vv
-6  in_another_decl _ = do line1 0
-7                         line2 0
-                                 ^^
-8  
-Stopped at break020.hs:(6,21)-(7,30)
+Stopped in Main.in_another_decl, break020.hs:(6,21)-(7,30)
 _result :: m () = _
 5  
                      vv
@@ -68,67 +48,49 @@ _result :: m () = _
 7                         line2 0
                                  ^^
 8  
-Stopped at break020.hs:6:24-30
+Stopped in Main.in_another_decl, break020.hs:6:24-30
 _result :: m () = _
 5  
 6  in_another_decl _ = do line1 0
                           ^^^^^^^
 7                         line2 0
-Stopped at break020.hs:3:1-19
-_result :: m () = _
-2  
-3  line1 _ = return ()
-   ^^^^^^^^^^^^^^^^^^^
-4  line2 _ = return ()
-Stopped at break020.hs:3:11-19
+Stopped in Main.line1, break020.hs:3:11-19
 _result :: m () = _
 2  
 3  line1 _ = return ()
              ^^^^^^^^^
 4  line2 _ = return ()
-Stopped at break020.hs:7:24-30
+Stopped in Main.in_another_decl, break020.hs:7:24-30
 _result :: m () = _
 6  in_another_decl _ = do line1 0
 7                         line2 0
                           ^^^^^^^
 8  
-Stopped at break020.hs:4:1-19
-_result :: m () = _
-3  line1 _ = return ()
-4  line2 _ = return ()
-   ^^^^^^^^^^^^^^^^^^^
-5  
-Stopped at break020.hs:4:11-19
+Stopped in Main.line2, break020.hs:4:11-19
 _result :: m () = _
 3  line1 _ = return ()
 4  line2 _ = return ()
              ^^^^^^^^^
 5  
-Stopped at break020.hs:13:3-21
+Stopped in Main.main, break020.hs:13:3-21
 _result :: IO () = _
 12    in_another_decl 0
 13    in_another_module 0
       ^^^^^^^^^^^^^^^^^^^
 14    line2 1
-Stopped at break020.hs:14:3-9
+Stopped in Main.main, break020.hs:14:3-9
 _result :: IO () = _
 13    in_another_module 0
 14    line2 1
       ^^^^^^^
 15    return ()
-Stopped at break020.hs:4:1-19
-_result :: IO () = _
-3  line1 _ = return ()
-4  line2 _ = return ()
-   ^^^^^^^^^^^^^^^^^^^
-5  
-Stopped at break020.hs:4:11-19
+Stopped in Main.line2, break020.hs:4:11-19
 _result :: IO () = _
 3  line1 _ = return ()
 4  line2 _ = return ()
              ^^^^^^^^^
 5  
-Stopped at break020.hs:15:3-11
+Stopped in Main.main, break020.hs:15:3-11
 _result :: IO () = _
 14    line2 1
 15    return ()
index 15e505f..33780a1 100644 (file)
@@ -6,7 +6,7 @@
 -- B.boot (imports A)
 -- C (imports A and B)
 
--- And we load C, to debug some function in A which enters B. 
+-- And we load C, to debug some function in A which enters B.
 -- But first we touch A, and reload. B.boot will be reloaded, but not B,  which will end up with an empty modbreaks. When we :step into B, ghci will die with an out of bounds access in B's break array.
 -- The effect we want is B.boot being reloaded while B is not.
 
@@ -17,5 +17,4 @@
 :break a
 a ()
 :st
-:st  
-:st -- here we step into B, and produce the exception
\ No newline at end of file
+:st -- here we step into B, and produce the exception
index f4b8042..b74e590 100644 (file)
@@ -1,8 +1,7 @@
-Breakpoint 0 activated at A.hs:4:1-9
-Stopped at A.hs:4:1-9
-_result :: a3 = _
-Stopped at A.hs:4:7-9
+Breakpoint 0 activated at A.hs:4:7-9
+Stopped in A.a, A.hs:4:7-9
+_result :: () = _
+x :: () = ()
+Stopped in B.b, B.hs:5:7
 _result :: () = _
 x :: () = ()
-Stopped at B.hs:5:1-7
-_result :: r = _
index 2b6c85d..e43c7ce 100644 (file)
@@ -1,2 +1,2 @@
-Breakpoint 0 activated at B.hs:5:1-7
-Breakpoint 1 activated at B.hs:5:1-7
+Breakpoint 0 activated at B.hs:5:7
+Breakpoint 1 activated at B.hs:5:7
index 548e7a4..8c09cb5 100644 (file)
@@ -1,19 +1,19 @@
 Left user error (error)
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = _
 _exception = SomeException
                (GHC.IO.Exception.IOError
                   Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
 *** Exception: user error (error)
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = _
 _exception = SomeException
                (GHC.IO.Exception.IOError
                   Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = SomeException
                     (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....)
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = _
 _exception = SomeException
                (GHC.IO.Exception.IOError
index e38f173..f3ddd73 100644 (file)
@@ -1,3 +1,3 @@
-Stopped at <exception thrown>
+Stopped in <exception thrown>, <unknown>
 _exception :: e = _
 ()
index b2dd79e..3d1da54 100644 (file)
@@ -2,9 +2,6 @@
 :step foldl (+) 0 [1::Integer .. 5]
 :step
 :step
-:step
-:step
-:step
 :force c
         -- answer should be 1
 
@@ -12,9 +9,6 @@
 :step foldl (+) 0 [1::Integer .. 5]
 :step
 :step
-:step
-:step
-:step
 -- a diversion to single-step the evaluation of c:
 :step c `seq` ()
 :step
index 9afc3f4..90c1f2e 100644 (file)
@@ -1,55 +1,39 @@
-Stopped at break026.hs:(5,1)-(7,35)
-_result :: t = _
-Stopped at break026.hs:5:16-22
+Stopped in Test.foldl, break026.hs:5:16-22
 _result :: Integer = _
 c :: Integer = 0
 go :: Integer -> [t1] -> Integer = _
 xs :: [t1] = _
-Stopped at break026.hs:(6,9)-(7,35)
-_result :: t = _
-f :: t -> t1 -> t = _
-Stopped at break026.hs:7:23-35
+Stopped in Test.foldl.go, break026.hs:7:23-35
 _result :: Integer = _
 c :: Integer = 0
 f :: Integer -> Integer -> Integer = _
 x :: Integer = 1
 xs :: [Integer] = _
-Stopped at break026.hs:(6,9)-(7,35)
-_result :: t = _
-f :: t -> t1 -> t = _
-Stopped at break026.hs:7:23-35
+Stopped in Test.foldl.go, break026.hs:7:23-35
 _result :: t = _
 c :: t = _
 f :: t -> Integer -> t = _
 x :: Integer = 2
 xs :: [Integer] = _
 c = 1
-Stopped at break026.hs:(5,1)-(7,35)
-_result :: t = _
-Stopped at break026.hs:5:16-22
+Stopped in Test.foldl, break026.hs:5:16-22
 _result :: Integer = _
 c :: Integer = 0
 go :: Integer -> [t1] -> Integer = _
 xs :: [t1] = _
-Stopped at break026.hs:(6,9)-(7,35)
-_result :: t = _
-f :: t -> t1 -> t = _
-Stopped at break026.hs:7:23-35
+Stopped in Test.foldl.go, break026.hs:7:23-35
 _result :: Integer = _
 c :: Integer = 0
 f :: Integer -> Integer -> Integer = _
 x :: Integer = 1
 xs :: [Integer] = _
-Stopped at break026.hs:(6,9)-(7,35)
-_result :: t = _
-f :: t -> t1 -> t = _
-Stopped at break026.hs:7:23-35
+Stopped in Test.foldl.go, break026.hs:7:23-35
 _result :: t = _
 c :: t = _
 f :: t -> Integer -> t = _
 x :: Integer = 2
 xs :: [Integer] = _
-Stopped at break026.hs:7:27-31
+Stopped in Test.foldl.go, break026.hs:7:27-31
 _result :: Integer = _
 c :: Integer = 0
 f :: Integer -> Integer -> Integer = _
index 903b7b7..895ce8b 100644 (file)
@@ -1,9 +1,8 @@
-Breakpoint 0 activated at ..\QSort.hs:(4,1)-(6,55)\r
-Stopped at ..\QSort.hs:(4,1)-(6,55)\r
-_result :: [t] = _\r
-Stopped at ..\QSort.hs:5:16-51\r
-_result :: [Integer] = _\r
-a :: Integer = 3\r
-left :: [Integer] = _\r
-right :: [Integer] = _\r
-a :: Integer   -- Defined in ‘interactive:Ghci2’\r
+Breakpoint 0 activated at ../QSort.hs:4:12-13
+Breakpoint 1 activated at ../QSort.hs:5:16-51
+Stopped in QSort.qsort, ../QSort.hs:5:16-51
+_result :: [Integer] = _
+a :: Integer = 3
+left :: [Integer] = _
+right :: [Integer] = _
+a :: Integer   -- Defined in ‘interactive:Ghci1’
index bbe4726..7907956 100644 (file)
@@ -1,5 +1,6 @@
-Stopped at break028.hs:15:1-24
-_result :: Id a4 = _
-Stopped at break028.hs:15:23-24
+Stopped in Main.g, break028.hs:15:23-24
 _result :: Id a4 = _
 x' :: Id a4 = _
+Stopped in Main.g.x', break028.hs:15:16-18
+_result :: Id Bool = _
+x :: Bool = False
index 4eda16e..f4d7444 100644 (file)
@@ -1,5 +1,5 @@
 Breakpoint 0 activated at ../QSort.hs:5:16-51
-Stopped at ../QSort.hs:5:16-51
+Stopped in QSort.qsort, ../QSort.hs:5:16-51
 _result :: [Integer] = _
 a :: Integer = 8
 left :: [Integer] = _
index 22adee0..f9d5281 100644 (file)
@@ -1,11 +1,11 @@
-Stopped at dynbrk007.hs:(2,5)-(6,11)
+Stopped in Main.f, dynbrk007.hs:(2,5)-(6,11)
 _result :: Maybe Int = _
-Stopped at dynbrk007.hs:3:9-16
+Stopped in Main.f, dynbrk007.hs:3:9-16
 _result :: Maybe Int = _
-Stopped at dynbrk007.hs:4:9-16
+Stopped in Main.f, dynbrk007.hs:4:9-16
 _result :: Maybe Integer = _
-Stopped at dynbrk007.hs:5:9-16
+Stopped in Main.f, dynbrk007.hs:5:9-16
 _result :: Maybe Integer = _
-Stopped at dynbrk007.hs:6:4-11
+Stopped in Main.f, dynbrk007.hs:6:4-11
 _result :: Maybe Int = _
 i :: Int = 1
index 722f299..88a7964 100644 (file)
@@ -1,15 +1,13 @@
-Stopped at dynbrk008.hs:2:1-41
-_result :: [Int] = _
-Stopped at dynbrk008.hs:2:7-41
+Stopped in Main.f, dynbrk008.hs:2:7-41
 _result :: [Int] = _
 i :: Int = 42
-Stopped at dynbrk008.hs:2:18-20
+Stopped in Main.f, dynbrk008.hs:2:18-20
 _result :: [Int] = _
 i :: Int = 42
-Stopped at dynbrk008.hs:2:28-30
+Stopped in Main.f, dynbrk008.hs:2:28-30
 _result :: [Int] = _
 j :: Int = 42
-Stopped at dynbrk008.hs:2:38-40
+Stopped in Main.f, dynbrk008.hs:2:38-40
 _result :: [Int] = _
 h :: Int = 42
 [42]
index 65ab5e6..96a086f 100644 (file)
@@ -1,8 +1,7 @@
-Stopped at dynbrk009.hs:8:22
+Stopped in Main.test.(...), dynbrk009.hs:8:22
 _result :: Int = _
-Stopped at dynbrk009.hs:8:27-36
+Stopped in Main.test, dynbrk009.hs:8:27-36
 _result :: Int = _
-Stopped at dynbrk009.hs:8:31-35
-Stopped at dynbrk009.hs:6:1-9
-Stopped at dynbrk009.hs:6:9
+Stopped in Main.test, dynbrk009.hs:8:31-35
+Stopped in Main.f, dynbrk009.hs:6:9
 3
index 659308c..3169eb6 100644 (file)
@@ -1,3 +1,3 @@
-Stopped at ..\getargs.hs:3:8-24
+Stopped in Main.main, ../getargs.hs:3:8-24
 _result :: IO () = _
 ["42"]
index 3a70f6a..7ef5dc1 100644 (file)
@@ -1,19 +1,13 @@
 Breakpoint 0 activated at ../Test3.hs:1:14-15
-[2,3Stopped at ../Test3.hs:1:14-15
+[2,3Stopped in Main.mymap, ../Test3.hs:1:14-15
 _result :: [a] = _
--1  : mymap (../Test3.hs:(1,1)-(2,31))
--2  : mymap (../Test3.hs:2:22-31)
--3  : mymap (../Test3.hs:2:18-20)
--4  : mymap (../Test3.hs:2:18-31)
--5  : mymap (../Test3.hs:(1,1)-(2,31))
--6  : mymap (../Test3.hs:2:22-31)
--7  : mymap (../Test3.hs:2:18-20)
--8  : mymap (../Test3.hs:2:18-31)
--9  : mymap (../Test3.hs:(1,1)-(2,31))
+-1  : mymap (../Test3.hs:2:22-31)
+-2  : mymap (../Test3.hs:2:18-20)
+-3  : mymap (../Test3.hs:2:18-31)
+-4  : mymap (../Test3.hs:2:22-31)
+-5  : mymap (../Test3.hs:2:18-20)
+-6  : mymap (../Test3.hs:2:18-31)
 <end of history>
-Logged breakpoint at ../Test3.hs:(1,1)-(2,31)
-_result :: [t]
-_result :: [t] = _
 Logged breakpoint at ../Test3.hs:2:22-31
 _result :: [t]
 f :: t1 -> t
@@ -21,11 +15,19 @@ xs :: [t1]
 xs :: [t1] = []
 f :: t1 -> t = _
 _result :: [t] = _
-*** Ignoring breakpoint
-_result = []
 Logged breakpoint at ../Test3.hs:2:18-20
 _result :: t
 f :: Integer -> t
 x :: Integer
-Logged breakpoint at ../Test3.hs:2:22-31
+xs :: [t1] = []
+x :: Integer = 2
+f :: Integer -> t = _
+_result :: t = _
+_result = 3
+Logged breakpoint at ../Test3.hs:2:18-31
 _result :: [t]
+f :: Integer -> t
+x :: Integer
+xs :: [Integer]
+Logged breakpoint at ../Test3.hs:2:18-20
+_result :: t
index 26a27ac..956ae6a 100644 (file)
@@ -5,7 +5,6 @@ cannot list source code for map: module GHC.Base is not interpreted
 1  mymap f [] = []
 2  mymap f (x:xs) = f x:mymap f xs
 3  
-3  
 4  main = mapM_ putStrLn $ mymap ('a':) ["hello","bye"] 
 5  
 3  
index 9585488..574f3e3 100644 (file)
@@ -1,6 +1,6 @@
-Stopped at listCommand002.hs:(3,8)-(5,24)
+Stopped in Main.main, listCommand002.hs:(3,8)-(5,24)
 _result :: IO () = _
-Stopped at listCommand002.hs:4:3-26
+Stopped in Main.main, listCommand002.hs:4:3-26
 _result :: IO () = _
-Stopped at listCommand002.hs:5:3-24
+Stopped in Main.main, listCommand002.hs:5:3-24
 _result :: IO () = _
index b193d13..171055a 100644 (file)
@@ -1,5 +1,5 @@
 Breakpoint 0 activated at ../QSort.hs:5:16-51
-Stopped at ../QSort.hs:5:16-51
+Stopped in QSort.qsort, ../QSort.hs:5:16-51
 _result :: [Integer] = _
 a :: Integer = 8
 left :: [Integer] = _
@@ -12,7 +12,7 @@ left = (_t2::[Integer])
 left = 4 : (_t3::[Integer])
 1
 left = [4]
-Stopped at ../QSort.hs:5:16-51
+Stopped in QSort.qsort, ../QSort.hs:5:16-51
 _result :: [Integer] = _
 a :: Integer = 4
 left :: [Integer] = _
index 614b7d3..65e4302 100644 (file)
@@ -1,7 +1,5 @@
-Breakpoint 0 activated at ../Test.hs:40:1-17
-Stopped at ../Test.hs:40:1-17
-_result :: () = _
-Stopped at ../Test.hs:40:10-17
+Breakpoint 0 activated at ../Test.hs:40:10-17
+Stopped in Test.Test2.poly, ../Test.hs:40:10-17
 _result :: () = _
 x :: a41 = _
 x = (_t1::a41)
index 80e9473..bbeeae1 100644 (file)
@@ -1,14 +1,19 @@
-Breakpoint 0 activated at ../HappyTest.hs:(226,1)-(237,35)
-Stopped at ../HappyTest.hs:(226,1)-(237,35)
-_result :: [Token] = _
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-*** Ignoring breakpoint
-_result = [TokenInt 1,TokenPlus,TokenInt 2,TokenPlus,TokenInt 3]
+Breakpoint 0 activated at ../HappyTest.hs:226:12-13
+Breakpoint 1 activated at ../HappyTest.hs:228:11-19
+Breakpoint 2 activated at ../HappyTest.hs:228:23-30
+Breakpoint 3 activated at ../HappyTest.hs:229:11-19
+Breakpoint 4 activated at ../HappyTest.hs:229:23-35
+Breakpoint 5 activated at ../HappyTest.hs:230:11-19
+Breakpoint 6 activated at ../HappyTest.hs:230:23-35
+Breakpoint 7 activated at ../HappyTest.hs:231:18-35
+Breakpoint 8 activated at ../HappyTest.hs:232:18-37
+Breakpoint 9 activated at ../HappyTest.hs:233:18-38
+Breakpoint 10 activated at ../HappyTest.hs:234:18-38
+Breakpoint 11 activated at ../HappyTest.hs:235:18-36
+Breakpoint 12 activated at ../HappyTest.hs:236:18-35
+Breakpoint 13 activated at ../HappyTest.hs:237:18-35
+Stopped in Main.lexer, ../HappyTest.hs:228:11-19
+_result :: Bool = _
+c :: Char = '1'
+*** Ignoring breakpoint
+_result = False
index cfed803..66f3ef8 100644 (file)
@@ -4,6 +4,5 @@ seq test ()
 :print test
 :break f
 f test2
-:step
 :fo x
-:t x
\ No newline at end of file
+:t x
index 85111a2..47c1483 100644 (file)
@@ -1,9 +1,7 @@
 ()
 test = C 1 32 1.2 1.23 'x' 1 1.2 1.23
-Breakpoint 0 activated at print022.hs:11:1-7
-Stopped at print022.hs:11:1-7
-_result :: r = _
-Stopped at print022.hs:11:7
+Breakpoint 0 activated at print022.hs:11:7
+Stopped in Main.f, print022.hs:11:7
 _result :: r = _
 x :: r = _
 x = C2 1 (W# 32) (TwoFields 'a' 3)
index 926890f..6552673 100644 (file)
@@ -5,4 +5,3 @@ i
 f i
 -- RTTI happens implicitly when the bindings at f come into context
 :step
-:step
\ No newline at end of file
index 3936640..5dbd12b 100644 (file)
@@ -1,8 +1,6 @@
 T 1
-Breakpoint 0 activated at print025.hs:2:1-7
-Stopped at print025.hs:2:1-7
-_result :: r = _
-Stopped at print025.hs:2:7
+Breakpoint 0 activated at print025.hs:2:7
+Stopped in Main.f, print025.hs:2:7
 _result :: T Int s = _
 x :: T Int s = T 1
 T 1
index b320153..6e350fd 100644 (file)
@@ -3,8 +3,7 @@ let a = MkT2 [Just (1::Int)]
 a
 :break f
 f a
-:step
 -- Unsound! A false type is assigned to x
--- reconstructType decides to stop too soon because 
+-- reconstructType decides to stop too soon because
 -- its BFS has recovered a monomorphic type
-:p x
\ No newline at end of file
+:p x
index 366d1d4..838570f 100644 (file)
@@ -1,8 +1,6 @@
 MkT2 [Just 1]
-Breakpoint 0 activated at print029.hs:4:1-7
-MkT2 Stopped at print029.hs:4:1-7
-_result :: t Int = _
-Stopped at print029.hs:4:7
+Breakpoint 0 activated at print029.hs:4:7
+MkT2 Stopped in Main.f, print029.hs:4:7
 _result :: t Int = _
 x :: t Int = [Just 1]
 x = [Just 1]
index 9296c90..d3042d0 100644 (file)
@@ -3,7 +3,6 @@ let a = MkT2 (map Just [(1::Int)])
 :break f
 seq a ()
 f a
-:step
 -- Unsound! A false type is assigned to x
 -- reconstructType is forced to stop too soon
 -- because the elements of the list in x are not evaluated yet
index a67d049..1c7bf3c 100644 (file)
@@ -1,7 +1,5 @@
-Breakpoint 0 activated at print029.hs:4:1-7
+Breakpoint 0 activated at print029.hs:4:7
 ()
-MkT2 Stopped at print029.hs:4:1-7
-_result :: t Int = _
-Stopped at print029.hs:4:7
+MkT2 Stopped in Main.f, print029.hs:4:7
 _result :: t Int = _
 x :: t Int = _ : _
index fb6308f..2e3223e 100644 (file)
@@ -3,8 +3,7 @@ let a = MkT2 [Just (Phantom 1)]
 :break f
 a
 f a
-:step
--- ghc crashes now when the type for x is recovered 
+-- ghc crashes now when the type for x is recovered
 -- and unifyRTTI fails to compute a substitution
-:p x  
+:p x
 :q
index 81a2518..6a326a6 100644 (file)
@@ -1,8 +1,6 @@
-Breakpoint 0 activated at print031.hs:7:1-19
+Breakpoint 0 activated at print031.hs:7:7-19
 MkT2 [Just (Phantom 1)]
-Stopped at print031.hs:7:1-19
-_result :: Bool = _
-Stopped at print031.hs:7:7-19
+Stopped in Print031.f, print031.hs:7:7-19
 _result :: Bool = _
 x :: t (Phantom a6) = [Just (Phantom 1)]
 x = [Just (Phantom 1)]
index fa872af..25abb37 100644 (file)
@@ -5,4 +5,3 @@ let b = MkT2 (map Just [2::Int]) -- Want to obtain a thunk
 :break f2
 f2 a b
 :step
-
index 766139f..9fe9911 100644 (file)
@@ -1,8 +1,7 @@
 MkT2 [Just 1]
-Breakpoint 0 activated at print029.hs:7:1-14
-Stopped at print029.hs:7:1-14
-_result :: (t Int, t Int) = _
-Stopped at print029.hs:7:10-14
+Breakpoint 0 activated at print029.hs:7:10-14
+Stopped in Main.f2, print029.hs:7:10-14
 _result :: (t Int, t Int) = _
 x :: t Int = [Just 1]
 y :: t Int = _
+(MkT2 [Just 1],MkT2 [Just 2])
index 0d2173d..2ff2838 100644 (file)
@@ -1,4 +1,4 @@
 Breakpoint 0 activated at result001.hs:1:13-21
-Stopped at result001.hs:1:13-21
+Stopped in Main.f, result001.hs:1:13-21
 _result :: [b] = _
 xs :: [b] = _