Skip to content

Commit

Permalink
Re-working of the breakpoint support
Browse files Browse the repository at this point in the history 
This is the result of Bernie Pope's internship work at MSR Cambridge,
with some subsequent improvements by me.  The main plan was to

 (a) Reduce the overhead for breakpoints, so we could enable 
     the feature by default without incurrent a significant penalty
 (b) Scatter more breakpoint sites throughout the code

Currently we can set a breakpoint on almost any subexpression, and the
overhead is around 1.5x slower than normal GHCi.  I hope to be able to
get this down further and/or allow breakpoints to be turned off.

This patch also fixes up :print following the recent changes to
constructor info tables.  (most of the :print tests now pass)

We now support single-stepping, which just enables all breakpoints.

  :step <expr>     executes <expr> with single-stepping turned on
  :step            single-steps from the current breakpoint

The mechanism is quite different to the previous implementation.  We
share code with the HPC (haskell program coverage) implementation now.
The coverage pass annotates source code with "tick" locations which
are tracked by the coverage tool.  In GHCi, each "tick" becomes a
potential breakpoint location.

Previously breakpoints were compiled into code that magically invoked
a nested instance of GHCi.  Now, a breakpoint causes the current
thread to block and control is returned to GHCi.

See the wiki page for more details and the current ToDo list:

  http://hackage.haskell.org/trac/ghc/wiki/NewGhciDebugger
  • Loading branch information
Simon Marlow committed Apr 17, 2007
1 parent dc8ffcb commit cdce647
Show file tree
Hide file tree
Showing 47 changed files with 1,377 additions and 1,200 deletions.
4 changes: 0 additions & 4 deletions compiler/Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -415,10 +415,6 @@ ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
SRC_HC_OPTS += -DGHCI -package template-haskell
PKG_DEPENDS += template-haskell

# Should the debugger commands be enabled?
ifeq "$(GhciWithDebugger)" "YES"
SRC_HC_OPTS += -DDEBUGGER
endif
# Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style
# or not?
ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO"
Expand Down
4 changes: 2 additions & 2 deletions compiler/basicTypes/IdInfo.lhs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -718,8 +718,8 @@ zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo
type TickBoxId = Int
data TickBoxOp
= TickBox Module !TickBoxId -- ^Tick box for Hpc-style coverage,
-- type = State# Void#
= TickBox Module {-# UNPACK #-} !TickBoxId
-- ^Tick box for Hpc-style coverage
instance Outputable TickBoxOp where
ppr (TickBox mod n) = ptext SLIT("tick") <+> ppr (mod,n)
Expand Down
25 changes: 18 additions & 7 deletions compiler/basicTypes/MkId.lhs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@ module MkId (
mkDataConIds,
mkRecordSelId,
mkPrimOpId, mkFCallId, mkTickBoxOpId,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
mkUnpackCase, mkProductBox,
Expand Down Expand Up @@ -905,17 +905,28 @@ mkFCallId uniq fcall ty
arity = length arg_tys
strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
mkTickBoxOpId :: Unique
-> Module
-> TickBoxId
-> Id
mkTickBoxOpId uniq mod ix = mkGlobalId (TickBoxOpId tickbox) name ty info
-- Tick boxes and breakpoints are both represented as TickBoxOpIds,
-- except for the type:
--
-- a plain HPC tick box has type (State# RealWorld)
-- a breakpoint Id has type forall a.a
--
-- The breakpoint Id will be applied to a list of arbitrary free variables,
-- which is why it needs a polymorphic type.
mkTickBoxOpId :: Unique -> Module -> TickBoxId -> Id
mkTickBoxOpId uniq mod ix = mkTickBox' uniq mod ix realWorldStatePrimTy
mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id
mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty
where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info
where
tickbox = TickBox mod ix
occ_str = showSDoc (braces (ppr tickbox))
name = mkTickBoxOpName uniq occ_str
info = noCafIdInfo
ty = realWorldStatePrimTy
\end{code}
Expand Down
1 change: 1 addition & 0 deletions compiler/cmm/CmmParse.y
View file
Original file line number Diff line number Diff line change
Expand Up @@ -607,6 +607,7 @@ stmtMacros = listToUFM [
( FSLIT("RET_NN"), \[a,b] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
( FSLIT("RET_NP"), \[a,b] -> emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
( FSLIT("RET_PPP"), \[a,b,c] -> emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
( FSLIT("RET_NPP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
( FSLIT("RET_NNP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
( FSLIT("RET_NNNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
( FSLIT("RET_NPNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
Expand Down
160 changes: 117 additions & 43 deletions compiler/deSugar/Coverage.lhs
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
%
% (c) Galois, 2006
% (c) University of Glasgow, 2007
%
\section[Coverage]{@coverage@: the main function}

Expand All @@ -20,7 +21,9 @@ import Bag
import Var
import Data.List
import FastString
import StaticFlags
import Data.Array
import System.Time (ClockTime(..))
import System.Directory (getModificationTime)
import System.IO (FilePath)
Expand All @@ -29,6 +32,9 @@ import Compat.Directory ( createDirectoryIfMissing )
#else
import System.Directory ( createDirectoryIfMissing )
#endif
import HscTypes
import BreakArray
\end{code}

%************************************************************************
Expand All @@ -38,15 +44,20 @@ import System.Directory ( createDirectoryIfMissing )
%************************************************************************

\begin{code}
addCoverageTicksToBinds
:: DynFlags
-> Module
-> ModLocation -- of the current module
-> LHsBinds Id
-> IO (LHsBinds Id, Int, ModBreaks)
addCoverageTicksToBinds dflags mod mod_loc binds = do
let orig_file =
case ml_hs_file mod_loc of
Just file -> file
Nothing -> panic "can not find the original file during hpc trans"
if "boot" `isSuffixOf` orig_file then return (binds, 0) else do
modTime <- getModificationTime' orig_file
if "boot" `isSuffixOf` orig_file then return (binds, 0, emptyModBreaks) else do
let mod_name = moduleNameString (moduleName mod)
Expand All @@ -58,19 +69,32 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do
, mixEntries = []
}
let hpc_dir = hpcDir dflags
let entries = reverse $ mixEntries st
-- write the mix entries for this module
let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
createDirectoryIfMissing True hpc_dir
mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st)
when opt_Hpc $ do
let hpc_dir = hpcDir dflags
let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
createDirectoryIfMissing True hpc_dir
modTime <- getModificationTime' orig_file
mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop entries)
-- Todo: use proper src span type
breakArray <- newBreakArray $ length entries
let fn = mkFastString orig_file
let locsTicks = listArray (0,tickBoxCount st-1)
[ mkSrcSpan (mkSrcLoc fn r1 c1) (mkSrcLoc fn r2 c2)
| (P r1 c1 r2 c2, _box) <- entries ]
let modBreaks = emptyModBreaks
{ modBreaks_array = breakArray
, modBreaks_ticks = locsTicks
}
doIfSet_dyn dflags Opt_D_dump_hpc $ do
printDump (pprLHsBinds binds1)
-- putStrLn (showSDocDebug (pprLHsBinds binds3))
return (binds1, tickBoxCount st)
return (binds1, tickBoxCount st, modBreaks)
\end{code}


Expand All @@ -87,20 +111,32 @@ addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
abs_binds' <- addTickLHsBinds abs_binds
return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
tick_no <- allocATickBox (if null decl_path
then TopLevelBox [name]
else LocalBox (name : decl_path))
pos
mg@(MatchGroup matches' ty) <- addPathEntry (getOccString id)
mg@(MatchGroup matches' ty) <- addPathEntry name
$ addTickMatchGroup (fun_matches funBind)
return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
, fun_tick = tick_no
}
-- Todo: we don't want redundant ticks on simple pattern bindings
if not opt_Hpc && isSimplePatBind funBind
then
return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
, fun_tick = Nothing
}
else do
tick_no <- allocATickBox (if null decl_path
then TopLevelBox [name]
else LocalBox (name : decl_path)) pos
return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
, fun_tick = tick_no
}
where
-- 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
-- TODO: Revisit this
addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
Expand All @@ -121,14 +157,47 @@ addTickLHsBind (VarBind var_id var_rhs) = do
-}
addTickLHsBind other = return other
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExpr (L pos e0) = do
-- add a tick to the expression no matter what it is
addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprAlways (L pos e0) = do
e1 <- addTickHsExpr e0
fn <- allocTickBox ExpBox pos
return $ fn $ L pos e1
-- always a breakpoint tick, maybe an HPC tick
addTickLHsExprBreakAlways :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprBreakAlways e
| opt_Hpc = addTickLHsExpr e
| otherwise = addTickLHsExprAlways e
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExpr (L pos e0) = do
e1 <- addTickHsExpr e0
if opt_Hpc || isGoodBreakExpr e0
then do
fn <- allocTickBox ExpBox pos
return $ fn $ L pos e1
else
return $ L pos e1
-- 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 (HsCase {}) = True
isGoodBreakExpr (HsIf {}) = True
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {}) = True
isGoodBreakExpr (PArrSeq {}) = True
isGoodBreakExpr other = False
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprOptAlt oneOfMany (L pos e0) = do
addTickLHsExprOptAlt oneOfMany (L pos e0)
| not opt_Hpc = addTickLHsExpr (L pos e0)
| otherwise = do
e1 <- addTickHsExpr e0
fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos
return $ fn $ L pos e1
Expand All @@ -145,7 +214,6 @@ addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addBinTickLHsExpr boxLabel (L pos e0) = do
e1 <- addTickHsExpr e0
allocBinTickBox boxLabel $ L pos e1
addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
addTickHsExpr e@(HsVar _) = return e
Expand All @@ -162,7 +230,7 @@ addTickHsExpr (OpApp e1 e2 fix e3) =
(addTickLHsExpr' e2)
(return fix)
(addTickLHsExpr e3)
addTickHsExpr ( NegApp e neg) =
addTickHsExpr (NegApp e neg) =
liftM2 NegApp
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg)
Expand Down Expand Up @@ -201,11 +269,11 @@ addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
addTickHsExpr (ExplicitList ty es) =
liftM2 ExplicitList
(return ty)
(mapM addTickLHsExpr es)
(mapM (addTickLHsExpr) es)
addTickHsExpr (ExplicitPArr {}) = error "addTickHsExpr: ExplicitPArr"
addTickHsExpr (ExplicitTuple es box) =
liftM2 ExplicitTuple
(mapM addTickLHsExpr es)
(mapM (addTickLHsExpr) es)
(return box)
addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon
Expand Down Expand Up @@ -242,7 +310,7 @@ addTickHsExpr e@(HsSpliceE {}) = return e
addTickHsExpr (HsProc pat cmdtop) =
liftM2 HsProc
(addTickLPat pat)
(liftL addTickHsCmdTop cmdtop)
(liftL (addTickHsCmdTop) cmdtop)
addTickHsExpr (HsWrap w e) =
liftM2 HsWrap
(return w)
Expand All @@ -258,7 +326,7 @@ addTickHsExpr (HsArrForm e fix cmdtop) =
liftM3 HsArrForm
(addTickLHsExpr e)
(return fix)
(mapM (liftL addTickHsCmdTop) cmdtop)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
addTickHsExpr e@(HsType ty) = return e
Expand Down Expand Up @@ -288,15 +356,15 @@ addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
addTickGRHS isOneOfMany (GRHS stmts expr) = do
stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts
expr' <- addTickLHsExprOptAlt isOneOfMany expr
expr' <- if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
else addTickLHsExprAlways expr
return $ GRHS stmts' expr'
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt isGuard (BindStmt pat e bind fail) =
liftM4 BindStmt
(addTickLPat pat)
(addTickLHsExpr e)
(addTickLHsExprBreakAlways e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' ty) =
Expand All @@ -305,8 +373,8 @@ addTickStmt isGuard (ExprStmt e bind' ty) =
(addTickSyntaxExpr hpcSrcSpan bind')
(return ty)
where
addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExpr e
addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprBreakAlways e
addTickStmt isGuard (LetStmt binds) =
liftM LetStmt
Expand Down Expand Up @@ -346,7 +414,7 @@ addTickHsValBinds (ValBindsOut binds sigs) =
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
liftM2 IPBinds
(mapM (liftL addTickIPBind) ipbinds)
(mapM (liftL (addTickIPBind)) ipbinds)
(addTickDictBinds dictbinds)
addTickIPBind :: IPBind Id -> TM (IPBind Id)
Expand All @@ -372,7 +440,7 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
(return ty)
(return syntaxtable)
addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
addTickLHsCmd x = addTickLHsExpr x
addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
Expand Down Expand Up @@ -461,12 +529,18 @@ allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st ->
meE = (hpcPos,ExpBox)
c = tickBoxCount st
mes = mixEntries st
in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
-- notice that F and T are reversed,
-- because we are building the list in
-- reverse...
, st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
)
in
if opt_Hpc
then ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
-- notice that F and T are reversed,
-- because we are building the list in
-- reverse...
, st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes}
)
else
( L pos $ HsTick c $ L pos e
, st {tickBoxCount=c+1,mixEntries=meE:mes}
)
allocBinTickBox boxLabel e = return e
Expand Down
Loading

0 comments on commit cdce647

Please sign in to comment.