Commit cdce6477 authored by Simon Marlow's avatar Simon Marlow
Browse files

Re-working of the breakpoint support

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
parent dc8ffcb9
......@@ -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"
......
......@@ -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)
......
......@@ -18,7 +18,7 @@ module MkId (
mkDataConIds,
mkRecordSelId,
mkPrimOpId, mkFCallId, mkTickBoxOpId,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
mkUnpackCase, mkProductBox,
......@@ -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}
......
......@@ -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)])
......
%
% (c) Galois, 2006
% (c) University of Glasgow, 2007
%
\section[Coverage]{@coverage@: the main function}
......@@ -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)
......@@ -29,6 +32,9 @@ import Compat.Directory ( createDirectoryIfMissing )
#else
import System.Directory ( createDirectoryIfMissing )
#endif
import HscTypes
import BreakArray
\end{code}
%************************************************************************
......@@ -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)
......@@ -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}
......@@ -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
......@@ -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
......@@ -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
......@@ -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)
......@@ -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
......@@ -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)
......@@ -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
......@@ -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) =
......@@ -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
......@@ -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)
......@@ -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)
......@@ -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
......
......@@ -45,7 +45,6 @@ import Util
import Coverage
import IOEnv
import Data.IORef
\end{code}
%************************************************************************
......@@ -85,28 +84,24 @@ deSugar hsc_env
-- Desugar the program
; let export_set = availsToNameSet exports
; let auto_scc = mkAutoScc mod export_set
; let noDbgSites = []
; let target = hscTarget dflags
; mb_res <- case target of
HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites))
_ -> do (binds_cvr,ds_hpc_info)
<- if opt_Hpc
HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
_ -> do (binds_cvr,ds_hpc_info, modBreaks)
<- if opt_Hpc || target == HscInterpreted
then addCoverageTicksToBinds dflags mod mod_loc binds
else return (binds, noHpcInfo)
else return (binds, noHpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds_cvr
; (ds_fords, foreign_prs) <- dsForeigns fords
; let all_prs = foreign_prs ++ core_prs
local_bndrs = mkVarSet (map fst all_prs)
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info)
; dbgSites_var <- getBkptSitesDs
; dbgSites <- ioToIOEnv$ readIORef dbgSites_var
; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, dbgSites)
; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
}
; case mb_res of {
Nothing -> return Nothing ;
Just (all_prs, ds_rules, ds_fords,ds_hpc_info, dbgSites) -> do
Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
......@@ -177,7 +172,7 @@ deSugar hsc_env
mg_binds = ds_binds,
mg_foreign = ds_fords,
mg_hpc_info = ds_hpc_info,
mg_dbg_sites = dbgSites }
mg_modBreaks = modBreaks }
; return (Just mod_guts)
}}}
......
......@@ -23,7 +23,6 @@ import {-# SOURCE #-} Match( matchWrapper )
import DsMonad
import DsGRHSs
import DsUtils
import DsBreakpoint
import HsSyn -- lots of things
import CoreSyn -- lots of things
......@@ -63,23 +62,7 @@ import Data.List
\begin{code}
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
dsTopLHsBinds auto_scc binds = do
mb_mod_name_ref <- getModNameRefDs
debugging <- breakpoints_enabled
case mb_mod_name_ref of
Nothing | debugging -> do -- Inject a CAF with the module name as literal
mod <- getModuleDs
mod_name_ref <- do
u <- newUnique
let n = mkSystemName u (mkVarOcc "_module")
return (mkLocalId n stringTy)
let mod_name = moduleNameFS$ moduleName mod
mod_lit <- dsExpr (HsLit (HsString mod_name))
withModNameRefDs mod_name_ref $ do
res <- ds_lhs_binds auto_scc binds
return$ (mod_name_ref, mod_lit) : res
_ -> ds_lhs_binds auto_scc binds
dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsLHsBinds binds = ds_lhs_binds NoSccs binds
......
-----------------------------------------------------------------------------
--
-- Support code for instrumentation and expansion of the breakpoint combinator
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-----------------------------------------------------------------------------
\begin{code}
module DsBreakpoint( debug_enabled
, dsAndThenMaybeInsertBreakpoint
, maybeInsertBreakpoint
, breakpoints_enabled
, mkBreakpointExpr
) where
import TysPrim
import TysWiredIn
import PrelNames
import Module
import SrcLoc
import TyCon
import TypeRep
import DataCon
import Type
import Id
import IdInfo
import BasicTypes
import OccName
import TcRnMonad
import HsSyn
import HsLit
import CoreSyn
import CoreUtils
import Outputable
import ErrUtils
import FastString
import DynFlags
import MkId
import DsMonad
import {-#SOURCE#-}DsExpr ( dsLExpr )
import Control.Monad
import Data.IORef
import Foreign.StablePtr
import GHC.Exts
#ifdef GHCI
mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
mkBreakpointExpr loc bkptFuncId ty = do
scope <- getScope
mod <- getModuleDs
u <- newUnique
let valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc
when (not instrumenting) $
warnDs (text "Extracted ids:" <+> (ppr scope $$
ppr (map idType scope)))
stablePtr <- ioToIOEnv $ newStablePtr (valId:scope)
site <- if instrumenting
then recordBkpt (srcSpanStart loc)
else return 0
ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
jumpFuncId <- mkJumpFunc bkptFuncId
Just mod_name_ref <- getModNameRefDs
let [opaqueDataCon] = tyConDataCons opaqueTyCon
opaqueId = dataConWrapId opaqueDataCon
opaqueTy = mkTyConApp opaqueTyCon []
wrapInOpaque id =
l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId)))
(l(HsVar id)))
-- Yes, I know... I'm gonna burn in hell.
Ptr addr# = castStablePtrToPtr stablePtr
locals = ExplicitList opaqueTy (map wrapInOpaque scope)
locInfo = nlTuple [ HsVar mod_name_ref
, HsLit (HsInt (fromIntegral site))]
funE = l$ HsVar jumpFuncId
ptrE = (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
locE = locInfo
msgE = srcSpanLit loc
argsE = nlTuple [ptrE, locals, msgE]
lazy_argsE = HsApp (l$ HsWrap (WpTyApp argsT) (HsVar lazyId)) (l argsE)
argsT = mkTupleType [intTy, mkListTy opaqueTy, stringTy]
return $
l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE)
where l = L loc
nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
srcSpanLit :: SrcSpan -> HsExpr Id
srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
instrumenting = idName bkptFuncId == breakpointAutoName
mkTupleType tys = mkTupleTy Boxed (length tys) tys
#else
mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints
#endif
getScope :: DsM [Id]
getScope = getLocalBindsDs >>= return . filter(isValidType .idType )
where isValidType (FunTy a b) = isValidType a && isValidType b
isValidType (NoteTy _ t) = isValidType t
isValidType (AppTy a b) = isValidType a && isValidType b
isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) &&
all isValidType ts
-- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ?
isValidType _ = True
dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
#ifdef DEBUG
dynBreakpoint loc | not (isGoodSrcSpan loc) =
pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc)
#endif
dynBreakpoint loc = do
let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName
breakpointAutoTy vanillaIdInfo
dflags <- getDOptsDs
ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
return$ L loc (HsVar autoBreakpoint)
where breakpointAutoTy = (ForAllTy alphaTyVar
(FunTy (TyVarTy alphaTyVar)
(TyVarTy alphaTyVar)))
-- Records a breakpoint site and returns the site number
recordBkpt :: SrcLoc -> DsM (Int)
recordBkpt loc = do
sites_var <- getBkptSitesDs
sites <- ioToIOEnv$ readIORef sites_var
let site = length sites + 1
let coords = (srcLocLine loc, srcLocCol loc)
ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
return site
mkJumpFunc :: Id -> DsM Id
mkJumpFunc bkptFuncId
| idName bkptFuncId == breakpointName
= build breakpointJumpName id
| idName bkptFuncId == breakpointCondName
= build breakpointCondJumpName (FunTy boolTy)
| idName bkptFuncId == breakpointAutoName
= build breakpointAutoJumpName id
where
tyvar = alphaTyVar
basicType extra opaqueTy =
(FunTy (mkTupleType [stringTy, intTy])
(FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy])
(ForAllTy tyvar
(extra
(FunTy (TyVarTy tyvar)
(TyVarTy tyvar))))))
build name extra = do
ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
return$ Id.mkGlobalId VanillaGlobal name
(basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
mkTupleType tys = mkTupleTy Boxed (length tys) tys
debug_enabled, breakpoints_enabled :: DsM Bool
dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
#if defined(GHCI) && defined(DEBUGGER)
debug_enabled = do
debugging <- doptDs Opt_Debugging
b_enabled <- breakpoints_enabled
return (debugging && b_enabled)
breakpoints_enabled = do
ghcMode <- getGhcModeDs
currentModule <- getModuleDs
dflags <- getDOptsDs
ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
return ( not ignore_breakpoints
&& hscTarget dflags == HscInterpreted
&& currentModule /= iNTERACTIVE )
maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
instrumenting <- isInstrumentationSpot lhsexpr
scope <- getScope
if instrumenting && not(isUnLiftedType ty) &&
not(isEnabledNullScopeCoalescing && null scope)
then do L _ dynBkpt <- dynBreakpoint loc
return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
else return lhsexpr
where l = L loc
dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
coreExpr <- dsLExpr expr
instrumenting <- isInstrumentationSpot expr