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"
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)
mkDataConIds,
mkRecordSelId,
- mkPrimOpId, mkFCallId, mkTickBoxOpId,
+ mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
mkUnpackCase, mkProductBox,
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}
( 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}
import Var
import Data.List
import FastString
+import StaticFlags
+import Data.Array
import System.Time (ClockTime(..))
import System.Directory (getModificationTime)
import System.IO (FilePath)
#else
import System.Directory ( createDirectoryIfMissing )
#endif
+
+import HscTypes
+import BreakArray
\end{code}
%************************************************************************
%************************************************************************
\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)
, 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}
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
-}
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
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
(addTickLHsExpr' e2)
(return fix)
(addTickLHsExpr e3)
-addTickHsExpr ( NegApp e neg) =
+addTickHsExpr (NegApp e neg) =
liftM2 NegApp
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg)
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
addTickHsExpr (HsProc pat cmdtop) =
liftM2 HsProc
(addTickLPat pat)
- (liftL addTickHsCmdTop cmdtop)
+ (liftL (addTickHsCmdTop) cmdtop)
addTickHsExpr (HsWrap w e) =
liftM2 HsWrap
(return w)
liftM3 HsArrForm
(addTickLHsExpr e)
(return fix)
- (mapM (liftL addTickHsCmdTop) cmdtop)
+ (mapM (liftL (addTickHsCmdTop)) cmdtop)
addTickHsExpr e@(HsType ty) = return e
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) =
(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
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
liftM2 IPBinds
- (mapM (liftL addTickIPBind) ipbinds)
+ (mapM (liftL (addTickIPBind)) ipbinds)
(addTickDictBinds dictbinds)
addTickIPBind :: IPBind Id -> TM (IPBind Id)
(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)
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
import Coverage
import IOEnv
import Data.IORef
-
\end{code}
%************************************************************************
-- 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
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)
}}}
import DsMonad
import DsGRHSs
import DsUtils
-import DsBreakpoint
import HsSyn -- lots of things
import CoreSyn -- lots of things
\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
+++ /dev/null
------------------------------------------------------------------------------
---
--- 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
- scope <- getScope
- let ty = exprType coreExpr
- if instrumenting && not (isUnLiftedType (exprType coreExpr)) &&
- not(isEnabledNullScopeCoalescing && null scope)
- then do L _ dynBkpt<- dynBreakpoint loc
- bkptCore <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt)
- return (bkptCore `App` coreExpr)
- else return coreExpr
- where l = L loc
-#else
-maybeInsertBreakpoint expr _ = return expr
-dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
-breakpoints_enabled = return False
-debug_enabled = return False
-#endif
-
-
-isInstrumentationSpot (L loc e) = do
- ghcmode <- getGhcModeDs
- instrumenting <- debug_enabled
- return$ instrumenting
- && isGoodSrcSpan loc -- Avoids 'derived' code
- && (not$ isRedundant e)
-
-isEnabledNullScopeCoalescing = True
-isRedundant HsLet {} = True
-isRedundant HsDo {} = True
-isRedundant HsCase {} = False
-isRedundant _ = False
-
-\end{code}
#ifdef GHCI
import PrelNames
-import DsBreakpoint
-- Template Haskell stuff iff bootstrapped
import DsMeta
-#else
-import DsBreakpoint
#endif
import HsSyn
import Bag
import Outputable
import FastString
-
-import Data.Maybe
\end{code}
\begin{code}
dsLExpr :: LHsExpr Id -> DsM CoreExpr
-#if defined(GHCI)
-dsLExpr (L loc expr@(HsWrap w (HsVar v)))
- | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName]
- , WpTyApp ty <- simpWrapper w
- = do areBreakpointsEnabled <- breakpoints_enabled
- if areBreakpointsEnabled
- then do
- L _ breakpointExpr <- mkBreakpointExpr loc v ty
- dsLExpr (L loc $ HsWrap w breakpointExpr)
- else putSrcSpanDs loc $ dsExpr expr
- where simpWrapper (WpCompose w1 WpHole) = w1
- simpWrapper (WpCompose WpHole w1) = w1
- simpWrapper w = w
-#endif
-
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
dsExpr :: HsExpr Id -> DsM CoreExpr
-- This is to avoid silliness in breakpoints
dsExpr (HsLet binds body)
= (bindLocalsDs (map unLoc $ collectLocalBinders binds) $
- dsAndThenMaybeInsertBreakpoint body) `thenDs` \ body' ->
+ dsLExpr body) `thenDs` \ body' ->
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
dsDo stmts body result_ty
= go (map unLoc stmts)
where
- go [] = dsAndThenMaybeInsertBreakpoint body
+ go [] = dsLExpr body
go (ExprStmt rhs then_expr _ : stmts)
- = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
+ = do { rhs2 <- dsLExpr rhs
; then_expr2 <- dsExpr then_expr
; rest <- go stmts
; returnDs (mkApps then_expr2 [rhs2, rest]) }
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
result_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
- ; rhs' <- dsAndThenMaybeInsertBreakpoint rhs
+ ; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
; dsLocalBinds binds rest }
go (ExprStmt rhs _ rhs_ty : stmts)
- = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
+ = do { rhs2 <- dsLExpr rhs
; rest <- go stmts
; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
; match_code <- extractMatchResult match fail_expr
- ; rhs' <- dsAndThenMaybeInsertBreakpoint rhs
+ ; rhs' <- dsLExpr rhs
; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
import DsMonad
import DsUtils
-import DsBreakpoint
import Unique
import PrelInfo
import TysWiredIn
patsBinders = collectPatsBinders (map (L undefined) pats)
dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
- = do rhs' <- maybeInsertBreakpoint rhs rhs_ty
- matchGuards (map unLoc guards) hs_ctx rhs' rhs_ty
+ = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
\end{code}
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
- bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs,
+ bindLocalsDs, getLocalBindsDs,
-- Warnings
DsWarning, warnDs, failWithDs,
import DynFlags
import ErrUtils
import Bag
-import Breakpoints
import OccName
import Data.IORef
ds_mod :: Module, -- For SCC profiling
ds_unqual :: PrintUnqualified,
ds_msgs :: IORef Messages, -- Warning messages
- ds_if_env :: (IfGblEnv, IfLclEnv), -- Used for looking up global,
+ ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
- ds_bkptSites :: IORef SiteMap -- Inserted Breakpoints sites
}
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings
ds_loc :: SrcSpan, -- to put in pattern-matching error msgs
- ds_locals :: OccEnv Id, -- For locals in breakpoints
- ds_mod_name_ref :: Maybe Id -- The Id used to store the Module name
- -- used by the breakpoint desugaring
+ ds_locals :: OccEnv Id -- For locals in breakpoints
}
-- Inside [| |] brackets, the desugarer looks
gbl_env = DsGblEnv { ds_mod = mod,
ds_if_env = (if_genv, if_lenv),
ds_unqual = mkPrintUnqualified rdr_env,
- ds_msgs = msg_var,
- ds_bkptSites = sites_var}
+ ds_msgs = msg_var}
lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcSpan,
- ds_locals = emptyOccEnv,
- ds_mod_name_ref = Nothing }
+ ds_locals = emptyOccEnv }
return (gbl_env, lcl_env)
getLocalBindsDs :: DsM [Id]
getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) }
-getModNameRefDs :: DsM (Maybe Id)
-getModNameRefDs = do { env <- getLclEnv; return (ds_mod_name_ref env) }
-
-withModNameRefDs :: Id -> DsM a -> DsM a
-withModNameRefDs id thing_inside =
- updLclEnv (\env -> env {ds_mod_name_ref = Just id}) thing_inside
-
bindLocalsDs :: [Id] -> DsM a -> DsM a
bindLocalsDs new_ids enclosed_scope =
updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids})
enclosed_scope
where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ]
-
-getBkptSitesDs :: DsM (IORef SiteMap)
-getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) }
-
\end{code}
import Util
import ListSetOps
import FastString
+import StaticFlags
+
import Data.Char
infixl 4 `mkDsApp`, `mkDsApps`
mkTickBox ix e = do
uq <- newUnique
mod <- getModuleDs
- let tick = mkTickBoxOpId uq mod ix
+ let tick | opt_Hpc = mkTickBoxOpId uq mod ix
+ | otherwise = mkBreakPointOpId uq mod ix
uq2 <- newUnique
let occName = mkVarOcc "tick"
let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal?
let var = Id.mkLocalId name realWorldStatePrimTy
- return $ Case (Var tick)
- var
- ty
- [(DEFAULT,[],e)]
+ scrut <-
+ if opt_Hpc
+ then return (Var tick)
+ else do
+ locals <- getLocalBindsDs
+ let tickVar = Var tick
+ let tickType = mkFunTys (map idType locals) realWorldStatePrimTy
+ let scrutApTy = App tickVar (Type tickType)
+ return (mkApps scrutApTy (map Var locals) :: Expr Id)
+ return $ Case scrut var ty [(DEFAULT,[],e)]
where
ty = exprType e
[ (DataAlt falseDataCon, [], falseBox)
, (DataAlt trueDataCon, [], trueBox)
]
-\end{code}
\ No newline at end of file
+\end{code}
import Data.Int ( Int64 )
import Data.Char ( ord )
-import GHC.Base ( ByteArray# )
+import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..) )
unlinkedBCOInstrs :: ByteArray#, -- insns
unlinkedBCOBitmap :: ByteArray#, -- bitmap
unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs
- unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
+ unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
}
data BCOPtr
= BCOPtrName Name
| BCOPtrPrimOp PrimOp
| BCOPtrBCO UnlinkedBCO
+ | BCOPtrBreakInfo BreakInfo
+ | BCOPtrArray (MutableByteArray# RealWorld)
data BCONPtr
= BCONPtrWord Word
bitmap_arr = mkBitmapArray bsize bitmap
bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
- let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits
- final_ptrs
+ let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
RETURN_UBX rep -> instr1 st (return_ubx rep)
CCALL off m_addr -> do (np, st2) <- addr st m_addr
instr3 st2 bci_CCALL off np
+ BRK_FUN array index info -> do
+ (p1, st2) <- ptr st (BCOPtrArray array)
+ (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
+ instr4 st3 bci_BRK_FUN p1 index p2
+ PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
i2s :: Int -> Word16
i2s = fromIntegral
RETURN_UBX{} -> 1
CCALL{} -> 3
SWIZZLE{} -> 3
+ BRK_FUN{} -> 4
-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
import Data.List ( intersperse, sortBy, zip4, zip6, partition )
import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
- withForeignPtr, castFunPtrToPtr )
+ withForeignPtr, castFunPtrToPtr, nullPtr, plusPtr )
import Foreign.C
import Control.Exception ( throwDyn )
import Control.Monad ( when )
import Data.Char ( ord, chr )
+import UniqSupply
+import BreakArray
+import Data.Maybe
+import Module
+import IdInfo
+
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
byteCodeGen :: DynFlags
-> [CoreBind]
-> [TyCon]
+ -> ModBreaks
-> IO CompiledByteCode
-byteCodeGen dflags binds tycs
+byteCodeGen dflags binds tycs modBreaks
= do showPass dflags "ByteCodeGen"
let flatBinds = [ (bndr, freeVars rhs)
| (bndr, rhs) <- flattenBinds binds]
- (BcM_State final_ctr mallocd, proto_bcos)
- <- runBc (mapM schemeTopBind flatBinds)
+ us <- mkSplitUniqSupply 'y'
+ (BcM_State _us final_ctr mallocd _, proto_bcos)
+ <- runBc us modBreaks (mapM schemeTopBind flatBinds)
when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
- (BcM_State final_ctr mallocd, proto_bco)
- <- runBc (schemeTopBind (invented_id, freeVars expr))
+ -- the uniques are needed to generate fresh variables when we introduce new
+ -- let bindings for ticked expressions
+ us <- mkSplitUniqSupply 'y'
+ (BcM_State _us final_ctr mallocd _ , proto_bco)
+ <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
when (notNull mallocd)
(panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
-> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
-> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
- is_ret mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
-schemeTopBind (id, rhs)
+schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
- isNullaryRepDataCon data_con
- = -- Special case for the worker of a nullary data con.
+ isNullaryRepDataCon data_con = do
+ -- Special case for the worker of a nullary data con.
-- It'll look like this: Nil = /\a -> Nil a
-- If we feed it into schemeR, we'll get
-- Nil = Nil
-- because mkConAppCode treats nullary constructor applications
-- by just re-using the single top-level definition. So
-- for the worker itself, we must allocate it directly.
+ -- ioToBc (putStrLn $ "top level BCO")
emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
- (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
= schemeR [{- No free variables -}] (id, rhs)
+
-- -----------------------------------------------------------------------------
-- schemeR
-- top-level things, which have no free vars.
-> (Id, AnnExpr Id VarSet)
-> BcM (ProtoBCO Name)
-schemeR fvs (nm, rhs)
+schemeR fvs (nm, rhs)
{-
| trace (showSDoc (
(char ' '
-}
= schemeR_wrk fvs nm rhs (collect [] rhs)
+collect :: [Var] -> AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
collect xs (_, AnnNote note e) = collect xs e
collect xs (_, AnnCast e _) = collect xs e
collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e
collect xs (_, not_lambda) = (reverse xs, not_lambda)
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
= let
all_args = reverse args ++ fvs
bitmap_size = length bits
bitmap = mkBitmap bits
in do
- body_code <- schemeE szw_args 0 p_init body
+ body_code <- schemeER_wrk szw_args p_init body
+
emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
arity bitmap_size bitmap False{-not alts-})
+-- introduce break instructions for ticked expressions
+schemeER_wrk :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeER_wrk d p rhs
+ | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
+ code <- schemeE d 0 p newRhs
+ arr <- getBreakArray
+ let idOffSets = getVarOffSets d p tickInfo
+ let tickNumber = tickInfo_number tickInfo
+ let breakInfo = BreakInfo
+ { breakInfo_module = tickInfo_module tickInfo
+ , breakInfo_number = tickNumber
+ , breakInfo_vars = idOffSets
+ }
+ let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo
+ return $ breakInstr `consOL` code
+ | otherwise = schemeE d 0 p rhs
+
+getVarOffSets :: Int -> BCEnv -> TickInfo -> [(Id, Int)]
+getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
+
+getOffSet :: Int -> BCEnv -> Id -> Maybe (Id, Int)
+getOffSet d env id
+ = case lookupBCEnv_maybe env id of
+ Nothing -> Nothing
+ Just offset -> Just (id, d - offset)
fvsToEnv :: BCEnv -> VarSet -> [Id]
-- Takes the free variables of a right-hand side, and
-- -----------------------------------------------------------------------------
-- schemeE
+data TickInfo
+ = TickInfo
+ { tickInfo_number :: Int -- the (module) unique number of the tick
+ , tickInfo_module :: Module -- the origin of the ticked expression
+ , tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression
+ }
+
+instance Outputable TickInfo where
+ ppr info = text "TickInfo" <+>
+ parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
+ ppr (tickInfo_locals info))
+
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
thunk_codes <- sequence compile_binds
return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
-
+-- introduce a let binding for a ticked case expression. This rule *should* only fire when the
+-- expression was not already let-bound (the code gen for let bindings should take care of that).
+-- Todo: we call exprFreeVars on a deAnnotated expression, this may not be the best way
+-- to calculate the free vars but it seemed like the least intrusive thing to do
+schemeE d s p exp@(AnnCase {})
+ | Just (tickInfo, _exp) <- isTickedExp' exp = do
+ let fvs = exprFreeVars $ deAnnotate' exp
+ let ty = exprType $ deAnnotate' exp
+ id <- newId ty
+ -- Todo: is emptyVarSet correct on the next line?
+ let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
+ schemeE d s p letExp
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
-- envt (it won't be bound now) because we never look such things up.
= --trace "automagic mashing of case alts (# VoidArg, a #)" $
- doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
= --trace "automagic mashing of case alts (# a, VoidArg #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
-- to
-- case .... of a { DEFAULT -> ... }
= --trace "automagic mashing of case alts (# a #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+ = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
schemeE d s p (AnnNote note (_, body))
= schemeE d s p body
= pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' other))
+{-
+ Ticked Expressions
+ ------------------
+
+ A ticked expression looks like this:
+
+ case tick<n> var1 ... varN of DEFAULT -> e
+
+ (*) <n> is the number of the tick, which is unique within a module
+ (*) var1 ... varN are the local variables in scope at the tick site
+
+ If we find a ticked expression we return:
+
+ Just ((n, [var1 ... varN]), e)
+
+ otherwise we return Nothing.
+
+ The idea is that the "case tick<n> ..." is really just an annotation on
+ the code. When we find such a thing, we pull out the useful information,
+ and then compile the code as if it was just the expression "e".
+
+-}
+
+isTickedExp :: AnnExpr Id a -> Maybe (TickInfo, AnnExpr Id a)
+isTickedExp (annot, expr) = isTickedExp' expr
+
+isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
+isTickedExp' (AnnCase scrut _bndr _type alts)
+ | Just tickInfo <- isTickedScrut scrut,
+ [(DEFAULT, _bndr, rhs)] <- alts
+ = Just (tickInfo, rhs)
+ where
+ isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
+ isTickedScrut expr
+ | Var id <- f,
+ Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
+ = Just $ TickInfo { tickInfo_number = tickNumber
+ , tickInfo_module = modName
+ , tickInfo_locals = idsOfArgs args
+ }
+ | otherwise = Nothing
+ where
+ (f, args) = collectArgs $ deAnnotate expr
+ idsOfArgs :: [Expr Id] -> [Id]
+ idsOfArgs = catMaybes . map exprId
+ exprId :: Expr Id -> Maybe Id
+ exprId (Var id) = Just id
+ exprId other = Nothing
+
+isTickedExp' other = Nothing
-- Compile code to do a tail call. Specifically, push the fn,
-- slide the on-stack app back down to the sequel depth,
-> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
-> Bool -- True <=> is an unboxed tuple case, don't enter the result
-> BcM BCInstrList
-doCase d s p (_,scrut)
- bndr alts is_unboxed_tuple
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
= let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
-- given an alt, return a discr and code for it.
- codeALt alt@(DEFAULT, _, (_,rhs))
+ codeAlt alt@(DEFAULT, _, (_,rhs))
= do rhs_code <- schemeE d_alts s p_alts rhs
return (NoDiscr, rhs_code)
+
codeAlt alt@(discr, bndrs, (_,rhs))
-- primitive or nullary constructor alt: no need to UNPACK
| null real_bndrs = do
where
real_bndrs = filter (not.isTyVar) bndrs
-
my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-}
my_discr (DataAlt dc, binds, rhs)
| isUnboxedTupleCon dc
in do
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
+
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
data BcM_State
= BcM_State {
+ uniqSupply :: UniqSupply, -- for generating fresh variable names
nextlabel :: Int, -- for generating local labels
- malloced :: [BcPtr] } -- thunks malloced for current BCO
+ malloced :: [BcPtr], -- thunks malloced for current BCO
-- Should be free()d when it is GCd
+ breakArray :: BreakArray -- array of breakpoint flags
+ }
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
x <- io
return (st, x)
-runBc :: BcM r -> IO (BcM_State, r)
-runBc (BcM m) = m (BcM_State 0 [])
+runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
+runBc us modBreaks (BcM m)
+ = m (BcM_State us 0 [] breakArray)
+ where
+ breakArray = modBreaks_array modBreaks
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+
+getBreakArray :: BcM BreakArray
+getBreakArray = BcM $ \st -> return (st, breakArray st)
+
+newUnique :: BcM Unique
+newUnique = BcM $
+ \st -> case splitUniqSupply (uniqSupply st) of
+ (us1, us2) -> let newState = st { uniqSupply = us2 }
+ in return (newState, uniqFromSupply us1)
+
+newId :: Type -> BcM Id
+newId ty = do
+ uniq <- newUnique
+ return $ mkSysLocal FSLIT("ticked") uniq ty
\end{code}
\begin{code}
module ByteCodeInstr (
- BCInstr(..), ProtoBCO(..), bciStackUse
+ BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..)
) where
#include "HsVersions.h"
import GHC.Ptr
+import Module (Module)
+import GHC.Prim
+
+
-- ----------------------------------------------------------------------------
-- Bytecode instructions
| RETURN -- return a lifted value
| RETURN_UBX CgRep -- return an unlifted value, here's its rep
+ -- Breakpoints
+ | BRK_FUN (MutableByteArray# RealWorld) Int BreakInfo
+
+data BreakInfo
+ = BreakInfo
+ { breakInfo_module :: Module
+ , breakInfo_number :: Int
+ , breakInfo_vars :: [(Id,Int)]
+ }
+
+instance Outputable BreakInfo where
+ ppr info = text "BreakInfo" <+>
+ parens (ppr (breakInfo_module info) <+>
+ ppr (breakInfo_number info) <+>
+ ppr (breakInfo_vars info))
+
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
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>" <+> int index <+> ppr info
-- -----------------------------------------------------------------------------
-- The stack use, in words, of each bytecode insn. These _must_ be
bciStackUse RETURN_UBX{} = 1
bciStackUse CCALL{} = 0
bciStackUse SWIZZLE{} = 0
+bciStackUse BRK_FUN{} = 0
-- These insns actually reduce stack use, but we need the high-tide level,
-- so can't use this info. Not that it matters much.
import CgHeapery ( mkVirtHeapOffsets )
import FastString ( FastString(..) )
import Util ( lengthIs, listLengthCmp )
+import Outputable
import Foreign
import Foreign.C
import GHC.Ptr ( Ptr(..) )
import GHC.Prim
-import Outputable
+import Debug.Trace
+import Text.Printf
\end{code}
%************************************************************************
itblCode (ItblPtr ptr)
= (castPtr ptr)
#ifdef GHCI_TABLES_NEXT_TO_CODE
- `plusPtr` (3 * wORD_SIZE)
+ `plusPtr` conInfoTableSizeB
#endif
+-- XXX bogus
+conInfoTableSizeB = 3 * wORD_SIZE
+
type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
StgConInfoTable
{
#ifdef GHCI_TABLES_NEXT_TO_CODE
- conDesc = castPtr $ ptr `plusPtr` wORD_SIZE `plusPtr` desc
+ conDesc = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc
#else
conDesc = desc
#endif
poke ptr itbl
= runState (castPtr ptr) $ do
#ifdef GHCI_TABLES_NEXT_TO_CODE
- store (conDesc itbl `minusPtr` (ptr `plusPtr` wORD_SIZE))
+ store (conDesc itbl `minusPtr` (ptr `plusPtr` conInfoTableSizeB))
#endif
store (infoTable itbl)
#ifndef GHCI_TABLES_NEXT_TO_CODE
import PackageConfig
import FastString
import Panic
-import Breakpoints
#ifdef DEBUG
import Outputable
import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..), castPtr )
-import GHC.Base ( writeArray#, RealWorld, Int(..) )
+import GHC.Base ( writeArray#, RealWorld, Int(..), Word# )
\end{code}
fill (BCOPtrBCO ul_bco) i = do
BCO bco# <- linkBCO' ie ce ul_bco
writeArrayBCO marr i bco#
+ fill (BCOPtrBreakInfo brkInfo) i =
+ unsafeWrite marr i (unsafeCoerce# brkInfo)
+ fill (BCOPtrArray brkArray) i =
+ unsafeWrite marr i (unsafeCoerce# brkArray)
zipWithM fill ptrs [0..]
unsafeFreeze marr
case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
(# s#, () #) }
+{-
+writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
+writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
+ case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
+ (# s#, () #) }
+-}
+
data BCO = BCO BCO#
-newBCO :: ByteArray# -> ByteArray# -> Array# a
- -> Int# -> ByteArray# -> IO BCO
+newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
newBCO instrs lits ptrs arity bitmap
= IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
(# s1, bco #) -> (# s1, BCO bco #)
lookupName ce nm
= case lookupNameEnv ce nm of
Just (_,aa) -> return aa
- Nothing | Just bk <- lookupBogusBreakpointVal nm
- -> return bk
Nothing
-> ASSERT2(isExternalName nm, ppr nm)
do let sym_to_find = nameToCLabel nm "closure"
--
-----------------------------------------------------------------------------
-module Debugger where
+module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where
import Linker
-import Breakpoints
import RtClosureInspect
import PrelNames
import Name
import NameEnv
import RdrName
-import Module
-import Finder
import UniqSupply
import Type
import TyCon
import TcGadt
import GHC
import GhciMonad
-import PackageConfig
import Outputable
import Pretty ( Mode(..), showDocWith )
-import ErrUtils
import FastString
import SrcLoc
-import Util
-import Maybes
import Control.Exception
import Control.Monad
-import qualified Data.Map as Map
-import Data.Array.Unboxed
-import Data.Array.Base
import Data.List
-import Data.Typeable ( Typeable )
import Data.Maybe
import Data.IORef
kind1 = mkArrowKind liftedTypeKind liftedTypeKind
kind2 = mkArrowKind kind1 liftedTypeKind
kind3 = mkArrowKind kind2 liftedTypeKind
-
------------------------------
--- | The :breakpoint command
------------------------------
-bkptOptions :: String -> GHCi Bool
-bkptOptions "continue" = -- We want to quit if in an inferior session
- liftM not isTopLevel
-bkptOptions "stop" = do
- inside_break <- liftM not isTopLevel
- when inside_break $ throwDyn StopChildSession
- return False
-
-bkptOptions cmd = do
- dflags <- getDynFlags
- bt <- getBkptTable
- sess <- getSession
- bkptOptions' sess (words cmd) bt
- return False
- where
- bkptOptions' _ ["list"] bt = do
- let msgs = [ ppr mod <+> colon <+> ppr coords
- | (mod,site) <- btList bt
- , let coords = getSiteCoords bt mod site]
- num_msgs = [parens (int n) <+> msg | (n,msg) <- zip [1..] msgs]
- msg <- showForUser$ if null num_msgs
- then text "There are no enabled breakpoints"
- else vcat num_msgs
- io$ putStrLn msg
-
- bkptOptions' s ("add":cmds) bt
- | [line] <- cmds
- , [(lineNum,[])] <- reads line
- = do (toplevel,_) <- io$ GHC.getContext s
- case toplevel of
- (m:_) -> handleAdd (\mod->addBkptByLine mod lineNum) m
- [] -> throwDyn $ CmdLineError $ "No module loaded in debugging mode"
-
- | [mod_name,line]<- cmds
- , [(lineNum,[])] <- reads line
- = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
- handleAdd (\mod->addBkptByLine mod lineNum)
-
- | [mod_name,line,col] <- cmds
- = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
- handleAdd (\mod->addBkptByCoord mod (read line, read col))
-
- | otherwise = throwDyn $ CmdLineError $
- "syntax: :breakpoint add Module line [col]"
- where
- handleAdd f mod =
- either
- (handleBkptEx s mod)
- (\(newTable, site) -> do
- setBkptTable newTable
- let (x,y) = getSiteCoords newTable mod site
- io (putStrLn ("Breakpoint set at " ++ showSDoc (ppr mod)
- ++ ':' : show x ++ ':' : show y)))
- (f mod bt)
-
- bkptOptions' s ("del":cmds) bt
- | [i'] <- cmds
- , [(i,[])] <- reads i'
- , bkpts <- btList bt
- = if i > length bkpts
- then throwDyn $ CmdLineError
- "Not a valid breakpoint #. Use :breakpoint list to see the current breakpoints."
- else
- let (mod, site) = bkpts !! (i-1)
- in handleDel mod $ delBkptBySite mod site
-
- | [fn,line] <- cmds
- , [(lineNum,[])] <- reads line
- , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
- = handleDel mod $ delBkptByLine mod lineNum
-
- | [fn,line,col] <- cmds
- , [(lineNum,[])] <- reads line
- , [(colNum,[])] <- reads col
- , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
- = handleDel mod $ delBkptByCoord mod (lineNum, colNum)
-
- | otherwise = throwDyn $ CmdLineError $
- "syntax: :breakpoint del (breakpoint # | [Module] line [col])"
-
- where delMsg = "Breakpoint deleted"
- handleDel mod f = either (handleBkptEx s mod)
- (\newtable-> setBkptTable newtable >> io (putStrLn delMsg))
- (f bt)
-
- bkptOptions' _ _ _ = throwDyn $ CmdLineError $
- "syntax: :breakpoint (list|continue|stop|add|del)"
-
--- Error messages
--- handleBkptEx :: Session -> Module -> Debugger.BkptException -> a
- handleBkptEx s m NotHandled = io$ do
- isInterpreted <- findModSummary m >>= isModuleInterpreted s
- if isInterpreted
- then error$ "Module " ++ showSDoc (ppr m) ++ " was not loaded under debugging mode.\n"
- ++ "Enable debugging mode with -fdebugging (and reload your module)"
- else error$ "Module " ++ showSDoc (ppr m) ++ " was loaded in compiled (.o) mode.\n"
- ++ "You must load a module in interpreted mode and with -fdebugging on to debug it."
- where findModSummary m = do
- mod_graph <- getModuleGraph s
- return$ head [ modsum | modsum <- mod_graph, ms_mod modsum == m]
- handleBkptEx _ _ e = error (show e)
-
--------------------------
--- Breakpoint Tables
--------------------------
-
-data BkptTable a = BkptTable {
- -- | An array of breaks, indexed by site number
- breakpoints :: Map.Map a (UArray Int Bool)
- -- | A list of lines, each line can have zero or more sites, which are annotated with a column number
- , sites :: Map.Map a [[(SiteNumber, Int)]]
- }
- deriving Show
-
-sitesOf :: Ord a => BkptTable a -> a -> Maybe [[(SiteNumber, Int)]]
-sitesOf bt fn = Map.lookup fn (sites bt)
-bkptsOf bt fn = Map.lookup fn (breakpoints bt)
-
-
-data BkptError =
- NotHandled -- Trying to manipulate a element not handled by this BkptTable
- | NoBkptFound
- | NotNeeded -- Used when a breakpoint was already enabled
- deriving Typeable
-
-instance Show BkptError where
- show NoBkptFound = "No suitable breakpoint site found"
- show NotNeeded = "Nothing to do"
- show NotHandled = "BkptTable: Element not controlled by this table"
-
-emptyBkptTable :: Ord a => BkptTable a
-addModule :: Ord a => a -> [(SiteNumber,Coord)] -> BkptTable a -> BkptTable a
--- | Lines start at index 1
-addBkptByLine :: Ord a => a -> Int -> BkptTable a -> Either BkptError (BkptTable a, SiteNumber)
-addBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> Either BkptError (BkptTable a, SiteNumber)
-delBkptByLine :: Ord a => a -> Int -> BkptTable a -> Either BkptError (BkptTable a)
-delBkptBySite :: Ord a => a -> SiteNumber -> BkptTable a -> Either BkptError (BkptTable a)
-delBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> Either BkptError (BkptTable a)
-
-isBkptEnabled :: Ord a => BkptTable a -> BkptLocation a -> Bool
-btElems :: Ord a => BkptTable a -> [(a, [SiteNumber])]
-btList :: Ord a => BkptTable a -> [BkptLocation a]
-sitesList :: Ord a => BkptTable a -> [(a, [Coord])]
-getSiteCoords :: Ord a => BkptTable a -> a -> SiteNumber -> Coord
-
-emptyBkptTable = BkptTable Map.empty Map.empty
-
-addBkptByLine a i bt
- | Just lines <- sitesOf bt a
- , Just bkptsArr <- bkptsOf bt a
- , i < length lines
- = case [line | line <- drop i lines, not (null line)] of
- ((x:_):_) -> let (siteNum,col) = x
- wasAlreadyOn = bkptsArr ! siteNum
- newArr = bkptsArr // [(siteNum, True)]
- newTable = Map.insert a newArr (breakpoints bt)
- in if wasAlreadyOn
- then Left NotNeeded
- else Right (bt{breakpoints=newTable}, siteNum)
- otherwise -> Left NoBkptFound
-
- | Just sites <- sitesOf bt a
- = Left NoBkptFound
- | otherwise = Left NotHandled
-
-addBkptByCoord a (r,c) bt
- | Just lines <- sitesOf bt a
- , Just bkptsArr <- bkptsOf bt a
- , r < length lines
- = case [ (sn,col) | (sn,col)<-lines!!r, col>=c] of
- [] -> Left NoBkptFound
- (x:_) -> let (siteNum, col) = x
- wasAlreadyOn = bkptsArr ! siteNum
- newArr = bkptsArr // [(siteNum, True)]
- newTable = Map.insert a newArr (breakpoints bt)
- in if wasAlreadyOn
- then Left NotNeeded
- else Right (bt{breakpoints=newTable}, siteNum)
-
- | Just sites <- sitesOf bt a
- = Left NoBkptFound
- | otherwise = Left NotHandled
-
-delBkptBySite a i bt
- | Just bkptsArr <- bkptsOf bt a
- , not (inRange (bounds bkptsArr) i)
- = Left NoBkptFound
-
- | Just bkptsArr <- bkptsOf bt a
- , bkptsArr ! i -- Check that there was a enabled bkpt here
- , newArr <- bkptsArr // [(i,False)]
- , newTable <- Map.insert a newArr (breakpoints bt)
- = Right bt {breakpoints=newTable}
-
- | Just sites <- sitesOf bt a
- = Left NotNeeded
-
- | otherwise = Left NotHandled
-
-delBkptByLine a l bt
- | Just sites <- sitesOf bt a
- , (site:_) <- [s | (s,c') <- sites !! l]
- = delBkptBySite a site bt
-
- | Just sites <- sitesOf bt a
- = Left NoBkptFound
-
- | otherwise = Left NotHandled
-
-delBkptByCoord a (r,c) bt
- | Just sites <- sitesOf bt a
- , (site:_) <- [s | (s,c') <- sites !! r, c>=c', isBkptEnabled bt (a,s)]
- = delBkptBySite a site bt
-
- | Just sites <- sitesOf bt a
- = Left NoBkptFound
-
- | otherwise = Left NotHandled
-
-btElems bt = [ (a, [i | (i,True) <- assocs siteArr])
- | (a, siteArr) <- Map.assocs (breakpoints bt) ]
-
-btList bt = [(a,site) | (a, sites) <- btElems bt, site <- sites]
-
-sitesList bt = [ (a, sitesCoords sitesCols) | (a, sitesCols) <- Map.assocs (sites bt) ]
- where sitesCoords sitesCols =
- [ (row,col)
- | (row, cols) <- zip [0..] sitesCols, (_,col) <- cols ]
-
-getSiteCoords bt a site
- | Just rows <- sitesOf bt a
- = head [ (r,c) | (r,row) <- zip [0..] rows
- , (s,c) <- row
- , s == site ]
-
--- addModule is dumb and inefficient, but it does the job
-addModule a [] bt = bt {sites = Map.insert a [] (sites bt)}
-addModule a siteCoords bt
- | nrows <- maximum$ [i | (_,(i,j)) <- siteCoords ]
- , sitesByRow <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i]
- | i <- [0..nrows] ]
- , nsites <- length siteCoords
- , initialBkpts <- listArray (0, nsites+1) (repeat False)
- = bt{ sites = Map.insert a sitesByRow (sites bt)
- , breakpoints = Map.insert a initialBkpts (breakpoints bt) }
-
--- This MUST be fast
-isBkptEnabled bt site | bt `seq` site `seq` False = undefined
-isBkptEnabled bt (a,site)
- | Just bkpts <- bkptsOf bt a
- = ASSERT (inRange (bounds bkpts) site)
- unsafeAt bkpts site
-
------------------
--- Other stuff
------------------
-refreshBkptTable :: Session -> BkptTable Module -> [ModSummary] -> IO (BkptTable Module)
-refreshBkptTable sess = foldM updIfDebugging
- where
- updIfDebugging bt ms = do
- isDebugging <- isDebuggingM ms
- if isDebugging
- then addModuleGHC sess bt (GHC.ms_mod ms)
- else return bt
- addModuleGHC sess bt mod = do
- Just mod_info <- GHC.getModuleInfo sess mod
- dflags <- GHC.getSessionDynFlags sess
- let sites = GHC.modInfoBkptSites mod_info
- debugTraceMsg dflags 2
- (ppr mod <> text ": inserted " <> int (length sites) <>
- text " breakpoints")
- return$ addModule mod sites bt
-#if defined(GHCI) && defined(DEBUGGER)
- isDebuggingM ms = isModuleInterpreted sess ms >>= \isInterpreted ->
- return (Opt_Debugging `elem` dflags &&
- target == HscInterpreted && isInterpreted)
- where dflags = flags (GHC.ms_hspp_opts ms)
- target = hscTarget (GHC.ms_hspp_opts ms)
-#else
- isDebuggingM _ = return False
-#endif
+++ /dev/null
-module Debugger where
-import Breakpoints
-import qualified Data.Map as Map
-import Data.Array.Unboxed
-
-
-data BkptTable a = BkptTable {
- -- | An array of breaks, indexed by site number
- breakpoints :: Map.Map a (UArray Int Bool)
- -- | A list of lines, each line can have zero or more sites, which are annotated with a column number
- , sites :: Map.Map a [[(SiteNumber, Int)]]
- }
#include "HsVersions.h"
import qualified GHC
-import {-#SOURCE#-} Debugger
-import Breakpoints
import Outputable
import Panic hiding (showException)
import Util
import DynFlags
+import HscTypes
+import SrcLoc
import Numeric
import Control.Exception as Exception
session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module,
- bkptTable :: IORef (BkptTable GHC.Module),
- topLevel :: Bool
+ topLevel :: Bool,
+ resume :: [IO GHC.RunResult],
+ breaks :: !ActiveBreakPoints
}
data GHCiOption
| RevertCAFs -- revert CAFs after every evaluation
deriving Eq
+data ActiveBreakPoints
+ = ActiveBreakPoints
+ { breakCounter :: !Int
+ , breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered
+ }
+
+instance Outputable ActiveBreakPoints where
+ ppr activeBrks = prettyLocations $ breakLocations activeBrks
+
+emptyActiveBreakPoints :: ActiveBreakPoints
+emptyActiveBreakPoints
+ = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
+
+data BreakLocation
+ = BreakLocation
+ { breakModule :: !GHC.Module
+ , breakLoc :: !SrcSpan
+ , breakTick :: {-# UNPACK #-} !Int
+ }
+ deriving Eq
+
+prettyLocations :: [(Int, BreakLocation)] -> SDoc
+prettyLocations [] = text "No active breakpoints."
+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
+
+instance Outputable BreakLocation where
+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
+
+getActiveBreakPoints :: GHCi ActiveBreakPoints
+getActiveBreakPoints = liftM breaks getGHCiState
+
+-- don't reset the counter back to zero?
+clearActiveBreakPoints :: GHCi ()
+clearActiveBreakPoints = do
+ st <- getGHCiState
+ let oldActiveBreaks = breaks st
+ newActiveBreaks = oldActiveBreaks { breakLocations = [] }
+ setGHCiState $ st { breaks = newActiveBreaks }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+ st <- getGHCiState
+ let oldActiveBreaks = breaks st
+ oldLocations = breakLocations oldActiveBreaks
+ newLocations = filter (\loc -> fst loc /= identity) oldLocations
+ newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }
+ setGHCiState $ st { breaks = newActiveBreaks }
+
+recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+ st <- getGHCiState
+ let oldActiveBreaks = breaks st
+ let oldLocations = breakLocations oldActiveBreaks
+ -- don't store the same break point twice
+ case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
+ (nm:_) -> return (True, nm)
+ [] -> do
+ let oldCounter = breakCounter oldActiveBreaks
+ newCounter = oldCounter + 1
+ newActiveBreaks =
+ oldActiveBreaks
+ { breakCounter = newCounter
+ , breakLocations = (oldCounter, brkLoc) : oldLocations
+ }
+ setGHCiState $ st { breaks = newActiveBreaks }
+ return (False, oldCounter)
+
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
startGHCi :: GHCi a -> GHCiState -> IO a
isTopLevel :: GHCi Bool
isTopLevel = getGHCiState >>= return . topLevel
-getBkptTable :: GHCi (BkptTable GHC.Module)
-getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
- io$ readIORef table_ref
-
-setBkptTable :: BkptTable GHC.Module -> GHCi ()
-setBkptTable new_table = do
- table_ref <- getGHCiState >>= return . bkptTable
- io$ writeIORef table_ref new_table
-
-modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
-modifyBkptTable f = do
- bt <- getBkptTable
- new_bt <- io . evaluate$ f bt
- setBkptTable new_bt
+getResume :: GHCi (Maybe (IO GHC.RunResult))
+getResume = do
+ st <- getGHCiState
+ case (resume st) of
+ [] -> return Nothing
+ (x:_) -> return $ Just x
+
+popResume :: GHCi ()
+popResume = do
+ st <- getGHCiState
+ case (resume st) of
+ [] -> return ()
+ (_:xs) -> setGHCiState $ st { resume = xs }
+
+pushResume :: IO GHC.RunResult -> GHCi ()
+pushResume resumeAction = do
+ st <- getGHCiState
+ let oldResume = resume st
+ setGHCiState $ st { resume = resumeAction : oldResume }
showForUser :: SDoc -> GHCi String
showForUser doc = do
return $! showSDocForUser unqual doc
-- --------------------------------------------------------------------------
--- Inferior Sessions Exceptions (used by the debugger)
-
-data InfSessionException =
- StopChildSession -- A child session requests to be stopped
- | StopParentSession -- A child session requests to be stopped
- -- AND that the parent session quits after that
- | ChildSessionStopped String -- A child session has stopped
- deriving Typeable
-
-
--- --------------------------------------------------------------------------
-- timing & statistics
timeIt :: GHCi a -> GHCi a
import Util
-- The debugger
-import Breakpoints
-import Debugger hiding ( addModule )
+import Debugger
import HscTypes
import Id
import Var ( globaliseId )
import Control.Exception as Exception
-- import Control.Concurrent
-import Numeric
import Data.List
-import Data.Int ( Int64 )
import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
import System.Cmd
import System.Environment
import System.IO.Error as IO
import Data.Char
import Data.Dynamic
+import Data.Array
import Control.Monad as Monad
-import Foreign.StablePtr ( newStablePtr )
+import Foreign.StablePtr ( StablePtr, newStablePtr, deRefStablePtr, freeStablePtr )
import GHC.Exts ( unsafeCoerce# )
-import GHC.IOBase ( IOErrorType(InvalidArgument) )
+import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) )
-import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Data.IORef ( IORef, readIORef, writeIORef )
import System.Posix.Internals ( setNonBlockingFD )
+-- these are needed by the new ghci debugger
+import ByteCodeLink (HValue)
+import ByteCodeInstr (BreakInfo (..))
+import BreakArray
+import TickTree
+
-----------------------------------------------------------------------------
ghciWelcomeMsg =
builtin_commands :: [Command]
builtin_commands = [
+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+ ("?", keepGoing help, False, completeNone),
("add", tlC$ keepGoingPaths addModule, False, completeFilename),
+ ("break", breakCmd, False, completeNone),
("browse", keepGoing browseCmd, False, completeModule),
-#ifdef DEBUGGER
- -- I think that :c should mean :continue rather than :cd, makes more sense
- -- (pepe 01.11.07)
- ("continue", const(bkptOptions "continue"), False, completeNone),
-#endif
("cd", tlC$ keepGoing changeDirectory, False, completeFilename),
+ ("check", keepGoing checkModule, False, completeHomeModule),
+ ("continue", continueCmd, False, completeNone),
+ ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
+ ("delete", deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
- -- Hugs users are accustomed to :e, so make sure it doesn't overlap
("edit", keepGoing editFile, False, completeFilename),
+ ("etags", keepGoing createETagsFileCmd, False, completeFilename),
+ ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
("help", keepGoing help, False, completeNone),
- ("?", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
+ ("kind", keepGoing kindOfType, False, completeIdentifier),
("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
("module", keepGoing setContext, False, completeModule),
("main", tlC$ keepGoing runMain, False, completeIdentifier),
+ ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+ ("quit", quit, False, completeNone),
("reload", tlC$ keepGoing reloadModule, False, completeNone),
- ("check", keepGoing checkModule, False, completeHomeModule),
("set", keepGoing setCmd, True, completeSetOptions),
("show", keepGoing showCmd, False, completeNone),
- ("etags", keepGoing createETagsFileCmd, False, completeFilename),
- ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
- ("type", keepGoing typeOfExpr, False, completeIdentifier),
-#if defined(DEBUGGER)
- ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
- ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
- ("breakpoint",bkptOptions, False, completeBkpt),
-#endif
- ("kind", keepGoing kindOfType, False, completeIdentifier),
- ("unset", keepGoing unsetOptions, True, completeSetOptions),
+ ("step", stepCmd, False, completeNone),
+ ("type", keepGoing typeOfExpr, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
- ("quit", quit, False, completeNone)
+ ("unset", keepGoing unsetOptions, True, completeSetOptions)
]
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
"\n" ++
" <stmt> evaluate/run <stmt>\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :breakpoint <option> commands for the GHCi debugger\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
- " :continue equivalent to ':breakpoint continue'\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
" :edit <file> edit file\n" ++
" :edit edit last module\n" ++
" +t print type after evaluation\n" ++
" -<flags> most GHC command line flags can also be set here\n" ++
" (eg. -v2, -fglasgow-exts, etc.)\n" ++
- "\n" ++
- " Options for ':breakpoint':\n" ++
- " list list the current breakpoints\n" ++
- " add [Module] line [col] add a new breakpoint\n" ++
- " del (breakpoint# | Module line [col]) delete a breakpoint\n" ++
- " continue continue execution\n" ++
- " stop Stop a computation and return to the top level\n" ++
- " step [count] Step by step execution (DISABLED)\n"
+ "\n"
+-- Todo: add help for breakpoint commands here
findEditor = do
getEnv "EDITOR"
Readline.setCompleterWordBreakCharacters word_break_chars
#endif
- bkptTable <- newIORef emptyBkptTable
- GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
default_editor <- findEditor
startGHCi (runGHCi srcs maybe_expr)
session = session,
options = [],
prelude = prel_mod,
- bkptTable = bkptTable,
- topLevel = True
+ topLevel = True,
+ resume = [],
+ breaks = emptyActiveBreakPoints
}
#ifdef USE_READLINE
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt
- case result of
- GHC.RunFailed -> return Nothing
- GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
- GHC.RunOk names -> return (Just names)
+ switchOnRunResult result
+
+switchOnRunResult :: GHC.RunResult -> GHCi (Maybe [Name])
+switchOnRunResult GHC.RunFailed = return Nothing
+switchOnRunResult (GHC.RunException e) = throw e
+switchOnRunResult (GHC.RunOk names) = return $ Just names
+switchOnRunResult (GHC.RunBreak apStack _threadId info resume) = do -- Todo: we don't use threadID, perhaps delete?
+ session <- getSession
+ Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let ticks = modBreaks_ticks modBreaks
+ io $ displayBreakInfo session ticks info
+ io $ extendEnvironment session apStack (breakInfo_vars info)
+ pushResume resume
+ return Nothing
+
+displayBreakInfo :: Session -> Array Int SrcSpan -> BreakInfo -> IO ()
+displayBreakInfo session ticks info = do
+ unqual <- GHC.getPrintUnqual session
+ let location = ticks ! breakInfo_number info
+ printForUser stdout unqual $
+ ptext SLIT("Stopped at") <+> ppr location $$ localsMsg
+ where
+ vars = map fst $ breakInfo_vars info
+ localsMsg = if null vars
+ then text "No locals in scope."
+ else text "Locals:" <+> (pprWithCommas showId vars)
+ showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
+
+-- Todo: turn this into a primop, and provide special version(s) for unboxed things
+foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
+
+getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
+getIdValFromApStack apStack (identifier, stackDepth) = do
+ -- ToDo: check the type of the identifer and decide whether it is unboxed or not
+ apSptr <- newStablePtr apStack
+ resultSptr <- getApStackVal apSptr (stackDepth - 1)
+ result <- deRefStablePtr resultSptr
+ freeStablePtr apSptr
+ freeStablePtr resultSptr
+ return (identifier, unsafeCoerce# result)
+
+extendEnvironment :: Session -> a -> [(Id, Int)] -> IO ()
+extendEnvironment s@(Session ref) apStack idsOffsets = do
+ idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
+ let (ids, hValues) = unzip idsVals
+ let names = map idName ids
+ let global_ids = map globaliseAndTidy ids
+ typed_ids <- mapM instantiateIdType global_ids
+ hsc_env <- readIORef ref
+ let ictxt = hsc_IC hsc_env
+ rn_env = ic_rn_local_env ictxt
+ type_env = ic_type_env ictxt
+ bound_names = map idName typed_ids
+ new_rn_env = extendLocalRdrEnv rn_env bound_names
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+ filtered_type_env = delListFromNameEnv type_env shadowed
+ new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ writeIORef ref (hsc_env { hsc_IC = new_ic })
+ extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
+ where
+ globaliseAndTidy :: Id -> Id
+ globaliseAndTidy id
+ = let tidied_type = tidyTopType$ idType id
+ in setIdType (globaliseId VanillaGlobal id) tidied_type
+
+ -- | Instantiate the tyVars with GHC.Base.Unknown
+ instantiateIdType :: Id -> IO Id
+ instantiateIdType id = do
+ instantiatedType <- instantiateTyVarsToUnknown s (idType id)
+ return$ setIdType id instantiatedType
-- possibly print the type and revert CAFs after evaluating an expression
finishEvalExpr mb_names
graph <- io (GHC.getModuleGraph session)
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
setContextAfterLoad session graph'
- do
- bt <- getBkptTable
- bt' <- io$ refreshBkptTable session bt graph'
- setBkptTable bt'
modulesLoadedMsg ok (map GHC.ms_mod_name graph')
setContextAfterLoad session [] = do
Nothing -> return ()
Just ty -> do tystr <- showForUser (ppr ty)
io (putStrLn (str ++ " :: " ++ tystr))
-
-quit :: String -> GHCi Bool
-quit _ = do in_inferior_session <- liftM not isTopLevel
- if in_inferior_session
- then throwDyn StopParentSession
- else return True
+quit :: String -> GHCi Bool
+quit _ = return True
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
["modules" ] -> showModules
["bindings"] -> showBindings
["linker"] -> io showLinkerState
- ["breakpoints"] -> showBkptTable
+ ["breaks"] -> showBkptTable
_ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
showModules = do
showBkptTable :: GHCi ()
showBkptTable = do
- bt <- getBkptTable
- msg <- showForUser . vcat $
- [ ppr mod <> colon <+> fcat
- [ parens(int row <> comma <> int col) | (row,col) <- sites]
- | (mod, sites) <- sitesList bt ]
- io (putStrLn msg)
+ activeBreaks <- getActiveBreakPoints
+ str <- showForUser $ ppr activeBreaks
+ io $ putStrLn str
+
-- -----------------------------------------------------------------------------
-- Completion
return (filter (w `isPrefixOf`) options)
where options = "args":"prog":allFlags
-completeBkpt = unionComplete completeModule completeBkptCmds
-
-completeBkptCmds w = do
- return (filter (w `isPrefixOf`) options)
- where options = ["add","del","list","stop"]
-
completeFilename = Readline.filenameCompletionFunction
completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
-- handler arond the flushing operation, so if stderr is closed
-- GHCi will just die gracefully rather than going into an infinite loop.
handler :: Exception -> GHCi Bool
-handler (DynException dyn)
- | Just StopChildSession <- fromDynamic dyn
- -- propagate to the parent session
- = do ASSERTM (liftM not isTopLevel)
- throwDyn StopChildSession
-
- | Just StopParentSession <- fromDynamic dyn
- = do at_topLevel <- isTopLevel
- if at_topLevel then return True else throwDyn StopParentSession
-
- | Just (ChildSessionStopped msg) <- fromDynamic dyn
- = io(putStrLn msg) >> return False
handler exception = do
flushInterpBuffers
#endif
return ()
+-- commands for debugger
+foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
+
+stepCmd :: String -> GHCi Bool
+stepCmd [] = doContinue setStepFlag
+stepCmd expression = do
+ io $ setStepFlag
+ runCommand expression
+
+continueCmd :: String -> GHCi Bool
+continueCmd [] = doContinue $ return ()
+continueCmd other = do
+ io $ putStrLn "The continue command accepts no arguments."
+ return False
+
+doContinue :: IO () -> GHCi Bool
+doContinue actionBeforeCont = do
+ resumeAction <- getResume
+ popResume
+ case resumeAction of
+ Nothing -> do
+ io $ putStrLn "There is no computation running."
+ return False
+ Just action -> do
+ io $ actionBeforeCont
+ runResult <- io action
+ names <- switchOnRunResult runResult
+ finishEvalExpr names
+ return False
+
+deleteCmd :: String -> GHCi Bool
+deleteCmd argLine = do
+ deleteSwitch $ words argLine
+ return False
+ where
+ deleteSwitch :: [String] -> GHCi ()
+ deleteSwitch [] =
+ io $ putStrLn "The delete command requires at least one argument."
+ -- delete all break points
+ deleteSwitch ("*":_rest) = clearActiveBreakPoints
+ deleteSwitch idents = do
+ mapM_ deleteOneBreak idents
+ where
+ deleteOneBreak :: String -> GHCi ()
+ deleteOneBreak str
+ | all isDigit str = deleteBreak (read str)
+ | otherwise = return ()
+
+-- handle the "break" command
+breakCmd :: String -> GHCi Bool
+breakCmd argLine = do
+ session <- getSession
+ breakSwitch session $ words argLine
+
+breakSwitch :: Session -> [String] -> GHCi Bool
+breakSwitch _session [] = do
+ io $ putStrLn "The break command requires at least one argument."
+ return False
+breakSwitch session args@(arg1:rest)
+ | looksLikeModule arg1 = do
+ mod <- lookupModule session arg1
+ breakByModule mod rest
+ return False
+ | otherwise = do
+ (toplevel, _) <- io $ GHC.getContext session
+ case toplevel of
+ (mod : _) -> breakByModule mod args
+ [] -> do
+ io $ putStrLn "Cannot find default module for breakpoint."
+ io $ putStrLn "Perhaps no modules are loaded for debugging?"
+ return False
+ where
+ -- Todo there may be a nicer way to test this
+ looksLikeModule :: String -> Bool
+ looksLikeModule [] = False
+ looksLikeModule (x:_) = isUpper x
+
+breakByModule :: Module -> [String] -> GHCi ()
+breakByModule mod args@(arg1:rest)
+ | all isDigit arg1 = do -- looks like a line number
+ breakByModuleLine mod (read arg1) rest
+ | looksLikeVar arg1 = do
+ -- break by a function definition
+ io $ putStrLn "Break by function definition not implemented."
+ | otherwise = io $ putStrLn "Invalid arguments to break command."
+ where
+ -- Todo there may be a nicer way to test this
+ looksLikeVar :: String -> Bool
+ looksLikeVar [] = False
+ looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
+
+breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine mod line args
+ | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line
+ | [col] <- args, all isDigit col =
+ findBreakAndSet mod $ lookupTickTreeCoord (line, read col)
+ | otherwise = io $ putStrLn "Invalid arguments to break command."
+
+findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet mod lookupTickTree = do
+ (breakArray, ticks) <- getModBreak mod
+ let tickTree = tickTreeFromList (assocs ticks)
+ case lookupTickTree tickTree of
+ Nothing -> io $ putStrLn $ "No breakpoints found at that location."
+ Just (tick, span) -> do
+ success <- io $ setBreakFlag True breakArray tick
+ session <- getSession
+ unqual <- io $ GHC.getPrintUnqual session
+ if success
+ then do
+ (alreadySet, nm) <-
+ recordBreak $ BreakLocation
+ { breakModule = mod
+ , breakLoc = span
+ , breakTick = tick
+ }
+ io $ printForUser stdout unqual $
+ text "Breakpoint " <> ppr nm <>
+ if alreadySet
+ then text " was already set at " <> ppr span
+ else text " activated at " <> ppr span
+ else do
+ str <- showForUser $ text "Breakpoint could not be activated at"
+ <+> ppr span
+ io $ putStrLn str
+
+getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
+getModBreak mod = do
+ session <- getSession
+ Just mod_info <- io $ GHC.getModuleInfo session mod
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let array = modBreaks_array modBreaks
+ let ticks = modBreaks_ticks modBreaks
+ return (array, ticks)
-instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
-instrumentationBkptHandler ref_bkptTable = BkptHandler {
- isAutoBkptEnabled = \sess bkptLoc -> do
- bktpTable <- readIORef ref_bkptTable
- return$ isBkptEnabled bktpTable bkptLoc
-
- , handleBreakpoint = doBreakpoint ref_bkptTable
- }
-
-doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
-doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
- let (ids, hValues) = unzip values
- names = map idName ids
- ASSERT (length names == length hValues) return ()
- let global_ids = map globaliseAndTidy ids
- printScopeMsg locMsg global_ids
- typed_ids <- mapM instantiateIdType global_ids
- hsc_env <- readIORef ref
- let ictxt = hsc_IC hsc_env
- rn_env = ic_rn_local_env ictxt
- type_env = ic_type_env ictxt
- bound_names = map idName typed_ids
- new_rn_env = extendLocalRdrEnv rn_env bound_names
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
- filtered_type_env = delListFromNameEnv type_env shadowed
- new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- writeIORef ref (hsc_env { hsc_IC = new_ic })
- is_tty <- hIsTerminalDevice stdin
- prel_mod <- GHC.findModule s prel_name Nothing
- withExtendedLinkEnv (zip names hValues) $
- startGHCi (interactiveLoop is_tty True) GHCiState{
- progname = "<interactive>",
- args = [],
- prompt = locMsg ++ "> ",
- session = s,
- options = [],
- bkptTable= ref_bkptTable,
- prelude = prel_mod,
- topLevel = False }
- `catchDyn` (\e -> case e of
- StopChildSession -> evaluate$
- throwDyn (ChildSessionStopped "")
- StopParentSession -> throwDyn StopParentSession
- ) `finally` do
- writeIORef ref hsc_env
- putStrLn $ "Returning to normal execution..."
- return b
- where
- printScopeMsg :: String -> [Id] -> IO ()
- printScopeMsg location ids = do
- unqual <- GHC.getPrintUnqual s
- printForUser stdout unqual $
- text "Stopped at a breakpoint in " <> text (stripColumn location) <>
- char '.' <+> text "Local bindings in scope:" $$
- nest 2 (pprWithCommas showId ids)
- where
- showId id =
- ppr (idName id) <+> dcolon <+> ppr (idType id)
- stripColumn = reverse . tail . dropWhile (/= ':') . reverse
-
--- | Give the Id a Global Name, and tidy its type
- globaliseAndTidy :: Id -> Id
- globaliseAndTidy id
- = let tidied_type = tidyTopType$ idType id
- in setIdType (globaliseId VanillaGlobal id) tidied_type
+lookupModule :: Session -> String -> GHCi Module
+lookupModule session modName
+ = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool
+setBreakFlag toggle array index
+ | toggle = setBreakOn array index
+ | otherwise = setBreakOff array index
+
+
+{- these should probably go to the GHC API at some point -}
+enableBreakPoint :: Session -> Module -> Int -> IO ()
+enableBreakPoint session mod index = return ()
+
+disableBreakPoint :: Session -> Module -> Int -> IO ()
+disableBreakPoint session mod index = return ()
--- | Instantiate the tyVars with GHC.Base.Unknown
- instantiateIdType :: Id -> IO Id
- instantiateIdType id = do
- instantiatedType <- instantiateTyVarsToUnknown s (idType id)
- return$ setIdType id instantiatedType
+activeBreakPoints :: Session -> IO [(Module,Int)]
+activeBreakPoints session = return []
+enableSingleStep :: Session -> IO ()
+enableSingleStep session = return ()
+disableSingleStep :: Session -> IO ()
+disableSingleStep session = return ()
linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
extendLoadedPkgs,
linkPackages,initDynLinker,
- recoverDataCon
+ dataConInfoPtrToName
) where
#include "HsVersions.h"
import ByteCodeItbls
import ByteCodeAsm
import RtClosureInspect
+import CgInfoTbls
+import SMRep
import IfaceEnv
-import OccName
import TcRnMonad
import Packages
import DriverPhases
import Name
import NameEnv
import NameSet
+import qualified OccName
import UniqFM
import Module
import ListSetOps
import DriverPhases
import SrcLoc
import UniqSet
+import Constants
-- Standard libraries
import Control.Monad
-- We use this string to lookup the interpreter's internal representation of the name
-- using the lookupOrig.
-recoverDataCon :: a -> TcM Name
-recoverDataCon x = do
+dataConInfoPtrToName :: Ptr () -> TcM Name
+dataConInfoPtrToName x = do
theString <- ioToTcRn $ do
- let ptr = getInfoTablePtr x
+ let ptr = castPtr x :: Ptr StgInfoTable
conDescAddress <- getConDescAddress ptr
- peekCString conDescAddress
+ str <- peekCString conDescAddress
+ return str
let (pkg, mod, occ) = parse theString
occName = mkOccName OccName.dataName occ
modName = mkModule (stringToPackageId pkg) (mkModuleName mod)
getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
getConDescAddress ptr = do
#ifdef GHCI_TABLES_NEXT_TO_CODE
- offsetToString <- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
- return $ ptr `plusPtr` offsetToString
- where
- -- subtract a word number of bytes
- offset = negate (fromIntegral SIZEOF_VOID_P)
-#endif
-#ifndef GHCI_TABLES_NEXT_TO_CODE
- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
- where
- -- add the standard info table size in bytes
- infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE
- offset = infoTableSizeBytes
+ offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
+ return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+#else
+ peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB
#endif
-- parsing names is a little bit fiddly because we have a string in the form:
ClosureType(..),
getClosureData, -- :: a -> IO Closure
- Closure ( tipe, infoTable, ptrs, nonPtrs ),
- getClosureType, -- :: a -> IO ClosureType
+ Closure ( tipe, infoPtr, ptrs, nonPtrs ),
isConstr, -- :: ClosureType -> Bool
isIndirection, -- :: ClosureType -> Bool
- getInfoTablePtr, -- :: a -> Ptr StgInfoTable
Term(..),
printTerm,
import Data.List ( partition )
import Foreign.Storable
+import IO
+
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------
deriving (Show, Eq)
data Closure = Closure { tipe :: ClosureType
+ , infoPtr :: Ptr ()
, infoTable :: StgInfoTable
, ptrs :: Array Int HValue
-- What would be the type here? HValue is ok? Should I build a Ptr?
instance Outputable ClosureType where
ppr = text . show
-getInfoTablePtr :: a -> Ptr StgInfoTable
-getInfoTablePtr x =
- case infoPtr# x of
- itbl_ptr -> castPtr ( Ptr itbl_ptr )
-
-getClosureType :: a -> IO ClosureType
-getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr
-
#include "../includes/ClosureTypes.h"
aP_CODE = AP
#undef PAP
getClosureData :: a -> IO Closure
-getClosureData a = do
- itbl <- peek (getInfoTablePtr a)
- let tipe = readCType (BCI.tipe itbl)
- case closurePayload# a of
- (# ptrs, nptrs #) ->
- let elems = BCI.ptrs itbl
+getClosureData a =
+ case unpackClosure# a of
+ (# iptr, ptrs, nptrs #) -> do
+ itbl <- peek (Ptr iptr)
+ let tipe = readCType (BCI.tipe itbl)
+ elems = BCI.ptrs itbl
ptrsList = Array 0 (fromIntegral$ elems) ptrs
- in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)
+ ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
readCType :: Integral a => a -> ClosureType
readCType i
trd (x,y,z) = z
cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty a =
- -- Obtain the term and tidy the type before returning it
- cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes
+cvObtainTerm hsc_env force mb_ty a = do
+ -- Obtain the term and tidy the type before returning it
+ term <- cvObtainTerm1 hsc_env force mb_ty a
+ return $ tidyTypes term
where
tidyTypes = foldTerm idTermFold {
fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
go tv hval
where
go tv a = do
- ctype <- trIO$ getClosureType a
- case ctype of
+ clos <- trIO $ getClosureData a
+ case tipe clos of
-- Thunks we may want to force
Thunk _ | force -> seq a $ go tv a
-- We always follow indirections
- _ | isIndirection ctype -> do
- clos <- trIO$ getClosureData a
- (go tv $! (ptrs clos ! 0))
+ Indirection _ -> go tv $! (ptrs clos ! 0)
-- The interesting case
Constr -> do
- m_dc <- trIO$ tcRnRecoverDataCon hsc_env a
+ m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
case m_dc of
Nothing -> panic "Can't find the DataCon for a term"
Just dc -> do
- clos <- trIO$ getClosureData a
let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
subTtypes = drop extra_args (dataConRepArgTys dc)
(subTtypesP, subTtypesNP) = partition isPointed subTtypes
return (Term tv dc a subTerms)
-- The otherwise case: can be a Thunk,AP,PAP,etc.
otherwise -> do
- return (Suspension ctype (Just tv) a Nothing)
+ return (Suspension (tipe clos) (Just tv) a Nothing)
-- Access the array of pointers and recurse down. Needs to be done with
-- care of no introducing a thunk! or go will fail to do its job
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Trees of source spans used by the breakpoint machinery
+--
+-- (c) The University of Glasgow 2007
+--
+-----------------------------------------------------------------------------
+
+module TickTree
+ ( TickTree, lookupTickTreeCoord, lookupTickTreeLine, tickTreeFromList )
+ where
+
+import SrcLoc
+
+import Data.List (partition, foldl')
+
+type TickNumber = Int
+
+newtype TickTree = Root [SpanTree]
+
+data SpanTree
+ = Node
+ { spanTreeTick :: TickNumber
+ , spanTreeLoc :: SrcSpan
+ , spanTreeChildren :: [SpanTree]
+ }
+
+mkNode :: TickNumber -> SrcSpan -> [SpanTree] -> SpanTree
+mkNode tick loc kids
+ = Node { spanTreeTick = tick, spanTreeLoc = loc, spanTreeChildren = kids }
+
+emptyTickTree :: TickTree
+emptyTickTree = Root []
+
+tickTreeFromList :: [(TickNumber, SrcSpan)] -> TickTree
+tickTreeFromList
+ = foldl' (\tree (tick,loc) -> insertTickTree tick loc tree) emptyTickTree
+
+insertTickTree :: TickNumber -> SrcSpan -> TickTree -> TickTree
+insertTickTree tick loc (Root children)
+ = Root $ insertSpanTree tick loc children
+
+insertSpanTree :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree]
+insertSpanTree tick loc [] = [mkNode tick loc []]
+insertSpanTree tick loc children@(kid:siblings)
+ | null containedKids = insertDeeper tick loc children
+ | otherwise = mkNode tick loc children : rest
+ where
+ (containedKids, rest) = getContainedKids loc children
+ insertDeeper :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree]
+ insertDeeper tick loc [] = [mkNode tick loc []]
+ insertDeeper tick loc nodes@(kid:siblings)
+ | srcSpanStart loc < srcSpanStart kidLoc = newBranch : nodes
+ | kidLoc `contains` loc = newKid : siblings
+ | otherwise = kid : insertDeeper tick loc siblings
+ where
+ newBranch = mkNode tick loc []
+ kidLoc = spanTreeLoc kid
+ newKid = mkNode (spanTreeTick kid) (spanTreeLoc kid)
+ (insertSpanTree tick loc $ spanTreeChildren kid)
+
+getContainedKids :: SrcSpan -> [SpanTree] -> ([SpanTree], [SpanTree])
+getContainedKids loc = Data.List.partition (\tree -> loc `contains` (spanTreeLoc tree))
+
+-- True if the left loc contains the right loc
+contains :: SrcSpan -> SrcSpan -> Bool
+contains span1 span2
+ = srcSpanStart span1 <= srcSpanStart span2 &&
+ srcSpanEnd span1 <= srcSpanEnd span2
+
+type TickLoc = (TickNumber, SrcSpan)
+type LineNumber = Int
+type ColumnNumber = Int
+type Coord = (LineNumber, ColumnNumber)
+
+srcSpanStartLine = srcLocLine . srcSpanStart
+
+lookupTickTreeLine :: LineNumber -> TickTree -> Maybe TickLoc
+lookupTickTreeLine line (Root children) = lookupSpanTreeLine line children
+
+lookupSpanTreeLine :: LineNumber -> [SpanTree] -> Maybe TickLoc
+lookupSpanTreeLine line [] = Nothing
+lookupSpanTreeLine line (node:nodes)
+ | startLine == line && endLine == line
+ = Just (spanTreeTick node, spanTreeLoc node)
+ | startLine > line
+ = lookupSpanTreeLine line nodes
+ | otherwise =
+ case lookupSpanTreeLine line (spanTreeChildren node) of
+ Nothing -> lookupSpanTreeLine line nodes
+ x@(Just _) -> x
+ where
+ startLine = srcSpanStartLine (spanTreeLoc node)
+ endLine = srcSpanEndLine (spanTreeLoc node)
+
+lookupTickTreeCoord :: Coord -> TickTree -> Maybe TickLoc
+lookupTickTreeCoord coord (Root children) = lookupSpanTreeCoord coord children Nothing
+
+lookupSpanTreeCoord :: Coord -> [SpanTree] -> Maybe TickLoc -> Maybe TickLoc
+lookupSpanTreeCoord coord [] acc = acc
+lookupSpanTreeCoord coord (kid:siblings) acc
+ | spanTreeLoc kid `spans` coord
+ = lookupSpanTreeCoord coord (spanTreeChildren kid)
+ (Just (spanTreeTick kid, spanTreeLoc kid))
+ | otherwise
+ = lookupSpanTreeCoord coord siblings acc
+ where
+ spans :: SrcSpan -> Coord -> Bool
+ spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
+ where loc = mkSrcLoc (srcSpanFile span) l c
import SrcLoc
import Util
import DynFlags
-import Breakpoints
import Control.Monad
import Data.List
, md_fam_insts = fam_insts
, md_rules = rules
, md_exports = exports
- , md_dbg_sites = noDbgSites
+ , md_modBreaks = emptyModBreaks
}
}
\end{code}
--- /dev/null
+--
+-- Break Arrays in the IO monad
+-- Entries in the array are Word sized
+--
+
+module BreakArray
+ ( BreakArray (BA)
+ , newBreakArray
+ , getBreak
+ , setBreakOn
+ , setBreakOff
+ , showBreakArray
+ ) where
+
+import GHC.Exts
+import GHC.IOBase
+import GHC.Prim
+import GHC.Word
+import Constants
+
+data BreakArray = BA (MutableByteArray# RealWorld)
+
+breakOff, breakOn :: Word
+breakOn = fromIntegral 1
+breakOff = fromIntegral 0
+
+-- XXX crude
+showBreakArray :: BreakArray -> IO ()
+showBreakArray array = do
+ let loop count sz
+ | count == sz = return ()
+ | otherwise = do
+ val <- readBreakArray array count
+ putStr $ " " ++ show val
+ loop (count + 1) sz
+ loop 0 (size array)
+ putStr "\n"
+
+setBreakOn :: BreakArray -> Int -> IO Bool
+setBreakOn array index
+ | safeIndex array index = do
+ writeBreakArray array index breakOn
+ return True
+ | otherwise = return False
+
+setBreakOff :: BreakArray -> Int -> IO Bool
+setBreakOff array index
+ | safeIndex array index = do
+ writeBreakArray array index breakOff
+ return True
+ | otherwise = return False
+
+getBreak :: BreakArray -> Int -> IO (Maybe Word)
+getBreak array index
+ | safeIndex array index = do
+ val <- readBreakArray array index
+ return $ Just val
+ | otherwise = return Nothing
+
+safeIndex :: BreakArray -> Int -> Bool
+safeIndex array index = index < size array && index >= 0
+
+size :: BreakArray -> Int
+size (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE
+
+allocBA :: Int -> IO BreakArray
+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 :: Int -> IO BreakArray
+newBreakArray entries@(I# sz) = do
+ BA array <- allocBA (entries * wORD_SIZE)
+ case breakOff of
+ W# off -> do -- Todo: there must be a better way to write zero as a Word!
+ let loop n
+ | 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, () #) }
+
+writeBreakArray :: BreakArray -> Int -> Word -> IO ()
+writeBreakArray (BA array) (I# i) (W# word) = writeBA# array i word
+
+readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word
+readBA# array i = IO $ \s ->
+ case readWordArray# array i s of { (# s, c #) -> (# s, W# c #) }
+
+readBreakArray :: BreakArray -> Int -> IO Word
+readBreakArray (BA array) (I# i) = readBA# array i
+++ /dev/null
------------------------------------------------------------------------------\r
---\r
--- GHC API breakpoints. This module includes the main API (BkptHandler) and\r
--- utility code for implementing a client to this API used in GHCi \r
---\r
--- Pepe Iborra (supported by Google SoC) 2006\r
---\r
------------------------------------------------------------------------------\r
-\r
-module Breakpoints where\r
-\r
-#ifdef GHCI\r
-import {-#SOURCE#-} ByteCodeLink ( HValue ) \r
-#endif\r
-\r
-import {-#SOURCE#-} HscTypes ( Session )\r
-import Name\r
-import Var ( Id )\r
-import PrelNames\r
-\r
-import GHC.Exts\r
-\r
-#ifdef GHCI\r
-data BkptHandler a = BkptHandler {\r
- handleBreakpoint :: forall b. Session -> [(Id,HValue)] -> BkptLocation a -> String -> b -> IO b\r
- , isAutoBkptEnabled :: Session -> BkptLocation a -> IO Bool\r
- }\r
-\r
-nullBkptHandler = BkptHandler {\r
- isAutoBkptEnabled = \ _ _ -> return False,\r
- handleBreakpoint = \_ _ _ _ b -> putStrLn "null Bkpt Handler" >> return b\r
- }\r
-#endif\r
-\r
-type BkptLocation a = (a, SiteNumber)\r
-type SiteNumber = Int\r
-\r
-type SiteMap = [(SiteNumber, Coord)]\r
-type Coord = (Int, Int)\r
-\r
-noDbgSites :: SiteMap\r
-noDbgSites = []\r
-\r
--- | Returns the 'identity' jumps\r
--- Used to deal with spliced code, where we don't want breakpoints\r
-#ifdef GHCI\r
-lookupBogusBreakpointVal :: Name -> Maybe HValue\r
-lookupBogusBreakpointVal name \r
- | name == breakpointJumpName = Just$ unsafeCoerce# (\_ _ a->a)\r
- | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ a->a)\r
- | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ a->a)\r
- | otherwise = Nothing\r
-#else \r
-lookupBogusBreakpointVal _ = Nothing\r
-#endif /* GHCI */\r
-\r
import Data.Char ( isUpper )
import System.IO ( hPutStrLn, stderr )
-#ifdef GHCI
-import Breakpoints ( BkptHandler )
-import Module ( ModuleName )
-#endif
-- -----------------------------------------------------------------------------
-- DynFlags
| Opt_SplitObjs
| Opt_StgStats
| Opt_HideAllPackages
-#if defined(GHCI) && defined(DEBUGGER)
- | Opt_Debugging
-#endif
| Opt_PrintBindResult
| Opt_Haddock
| Opt_Hpc_No_Auto
-- message output
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()
-
-#ifdef GHCI
- -- breakpoint handling
- ,bkptHandler :: Maybe (BkptHandler Module)
-#endif
}
data HscTarget
packageFlags = [],
pkgDatabase = Nothing,
pkgState = panic "no package state yet: call GHC.setSessionDynFlags",
-#ifdef GHCI
- bkptHandler = Nothing,
-#endif
flags = [
Opt_ReadUserPackageConf,
( "excess-precision", Opt_ExcessPrecision ),
( "asm-mangling", Opt_DoAsmMangling ),
( "print-bind-result", Opt_PrintBindResult ),
-#if defined(GHCI) && defined(DEBUGGER)
- ( "debugging", Opt_Debugging),
-#endif
( "force-recomp", Opt_ForceRecomp ),
( "hpc-no-auto", Opt_Hpc_No_Auto )
]
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
-#if defined(GHCI)
- modInfoBkptSites,
-#endif
lookupGlobalName,
-- * Printing
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
-
- getBreakpointHandler, setBreakpointHandler,
obtainTerm, obtainTerm1,
+ modInfoModBreaks,
#endif
-- * Abstract syntax elements
import Type ( tidyType )
import Var ( varName )
import VarEnv ( emptyTidyEnv )
-import GHC.Exts ( unsafeCoerce# )
-
--- For breakpoints
-import Breakpoints ( SiteNumber, Coord, nullBkptHandler,
- BkptHandler(..), BkptLocation, noDbgSites )
-import Linker ( initDynLinker )
-import PrelNames ( breakpointJumpName, breakpointCondJumpName,
- breakpointAutoJumpName )
-
-import GHC.Exts ( Int(..), Ptr(..), int2Addr#, indexArray# )
-import GHC.Base ( Opaque(..) )
-import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr )
-import Foreign ( unsafePerformIO )
+import GHC.Exts ( unsafeCoerce#, Ptr )
+import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr, StablePtr, newStablePtr, freeStablePtr )
+import Foreign ( poke )
import Data.Maybe ( fromMaybe)
import qualified Linker
import Data.Dynamic ( Dynamic )
import Linker ( HValue, getHValue, extendLinkEnv )
+
+import ByteCodeInstr (BreakInfo)
#endif
import Packages ( initPackages )
minf_rdr_env = Just rdr_env,
minf_instances = md_insts details
#ifdef GHCI
- ,minf_dbg_sites = noDbgSites
+ ,minf_modBreaks = emptyModBreaks
#endif
}
return (Just (CheckedModule {
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [Instance]
#ifdef GHCI
- ,minf_dbg_sites :: [(SiteNumber,Coord)]
+ ,minf_modBreaks :: ModBreaks
#endif
-- ToDo: this should really contain the ModIface too
}
minf_exports = names,
minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
minf_instances = error "getModuleInfo: instances for package module unimplemented",
- minf_dbg_sites = noDbgSites
+ minf_modBreaks = emptyModBreaks
}))
#else
-- bogusly different for non-GHCI (ToDo)
minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details
#ifdef GHCI
- ,minf_dbg_sites = md_dbg_sites details
+ ,minf_modBreaks = md_modBreaks details
#endif
}))
(hsc_HPT hsc_env) (eps_PTE eps) name
#ifdef GHCI
-modInfoBkptSites = minf_dbg_sites
+modInfoModBreaks = minf_modBreaks
#endif
isDictonaryId :: Id -> Bool
writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
ic_exports = export_mods,
ic_rn_gbl_env = all_env }}
- reinstallBreakpointHandlers sess
-- Make a GlobalRdrEnv based on the exports of the modules only.
mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
= RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation
| RunException Exception -- ^ statement raised an exception
+ | forall a . RunBreak a ThreadId BreakInfo (IO RunResult)
+
+data Status a
+ = Break RunResult -- ^ the computation hit a breakpoint
+ | Complete (Either Exception a) -- ^ the computation completed with either an exception or a value
--- | Run a statement in the current interactive context. Statemenet
+-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: Session -> String -> IO RunResult
runStmt (Session ref) expr
= do
hsc_env <- readIORef ref
+ breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint
+ statusMVar <- newEmptyMVar -- wait on this when a computation is running
+
-- Turn off -fwarn-unused-bindings when running a statement, to hide
-- warnings about the implicit bindings we introduce.
let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
Nothing -> return RunFailed
Just (new_hsc_env, names, hval) -> do
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- either_hvals <- sandboxIO thing_to_run
-
+ -- resume says what to do when we continue execution from a breakpoint
+ -- onBreakAction says what to do when we hit a breakpoint
+ -- they are mutually recursive, hence the strange use tuple let-binding
+ let (resume, onBreakAction)
+ = ( do stablePtr <- newStablePtr onBreakAction
+ poke breakPointIOAction stablePtr
+ putMVar breakMVar ()
+ status <- takeMVar statusMVar
+ switchOnStatus ref new_hsc_env names status
+ , \ids apStack -> do
+ tid <- myThreadId
+ putMVar statusMVar (Break (RunBreak apStack tid ids resume))
+ takeMVar breakMVar
+ )
+
+ -- set the onBreakAction to be performed when we hit a breakpoint
+ -- this is visible in the Byte Code Interpreter, thus it is a global
+ -- variable, implemented with stable pointers
+ stablePtr <- newStablePtr onBreakAction
+ poke breakPointIOAction stablePtr
+
+ let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+ status <- sandboxIO statusMVar thing_to_run
+ freeStablePtr stablePtr -- be careful not to leak stable pointers!
+ switchOnStatus ref new_hsc_env names status
+ where
+ switchOnStatus ref hs_env names status =
+ case status of
+ -- did we hit a breakpoint or did we complete?
+ (Break result) -> return result
+ (Complete either_hvals) ->
case either_hvals of
- Left e -> do
- -- on error, keep the *old* interactive context,
- -- so that 'it' is not bound to something
- -- that doesn't exist.
- return (RunException e)
-
+ Left e -> return (RunException e)
Right hvals -> do
- -- Get the newly bound things, and bind them.
- -- Don't need to delete any shadowed bindings;
- -- the new ones override the old ones.
extendLinkEnv (zip names hvals)
-
- writeIORef ref new_hsc_env
+ writeIORef ref hs_env
return (RunOk names)
+
+-- this points to the IO action that is executed when a breakpoint is hit
+foreign import ccall "&breakPointIOAction"
+ breakPointIOAction :: Ptr (StablePtr (a -> BreakInfo -> IO ()))
-- When running a computation, we redirect ^C exceptions to the running
-- thread. ToDo: we might want a way to continue even if the target
-- thread doesn't die when it receives the exception... "this thread
-- is not responding".
-sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = do
- m <- newEmptyMVar
+sandboxIO :: MVar (Status a) -> IO a -> IO (Status a)
+sandboxIO statusMVar thing = do
ts <- takeMVar interruptTargetThread
- child <- forkIO (do res <- Exception.try thing; putMVar m res)
+ child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))
putMVar interruptTargetThread (child:ts)
- takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
+ takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
{-
-- This version of sandboxIO runs the expression in a completely new
where
obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
------------------------------------------------------------------------------
--- Breakpoint handlers
-
-getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module))
-getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler
-
-setBreakpointHandler :: Session -> BkptHandler Module -> IO ()
-setBreakpointHandler session handler = do
- dflags <- getSessionDynFlags session
- setSessionDynFlags session dflags{ bkptHandler = Just handler }
- let linkEnv = [ ( breakpointJumpName
- , unsafeCoerce# (jumpFunction session handler))
- , ( breakpointCondJumpName
- , unsafeCoerce# (jumpCondFunction session handler))
- , ( breakpointAutoJumpName
- , unsafeCoerce# (jumpAutoFunction session handler))
- ]
- writeIORef v_bkptLinkEnv linkEnv
- dflags <- getSessionDynFlags session
- reinstallBreakpointHandlers session
-
-reinstallBreakpointHandlers :: Session -> IO ()
-reinstallBreakpointHandlers session = do
- dflags <- getSessionDynFlags session
- let mode = ghcMode dflags
- when (ghcLink dflags == LinkInMemory) $ do
- linkEnv <- readIORef v_bkptLinkEnv
- initDynLinker dflags
- extendLinkEnv linkEnv
-
------------------------------------------------------------------------
--- Jump functions
-
-type SiteInfo = (String, SiteNumber)
-jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> b -> b
-jumpCondFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> Bool -> b -> b
-jumpFunctionM :: Session -> BkptHandler a -> BkptLocation a -> (Int, [Opaque], String) -> b -> IO b
-
-jumpCondFunction _ _ _ _ False b = b
-jumpCondFunction session handler site args True b
- = jumpFunction session handler site args b
-
-jumpFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ jumpFunctionM session handler site args b
-
-jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b =
- do
- ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
- let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues]
- handleBreakpoint handler session (zip ids hValues) site locmsg b
-
-jumpAutoFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ do
- break <- isAutoBkptEnabled handler session site
- if break
- then jumpFunctionM session handler site args b
- else return b
-
-jumpStepByStepFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ do
- jumpFunctionM session handler site args b
-
-mkSite :: SiteInfo -> BkptLocation Module
-mkSite ( modName, sitenum) =
- (mkModule mainPackageId (mkModuleName modName), sitenum)
-
obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
import CmmParse ( parseCmmFile )
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
-import Breakpoints ( noDbgSites )
import DynFlags
import ErrUtils
prepd_binds <- {-# SCC "CorePrep" #-}
corePrepPgm dflags core_binds data_tycons ;
----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen dflags prepd_binds data_tycons
+ comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details)
------------------ Create f-x-dynamic C-side stuff ---
(istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
md_exports = tcg_exports tc_result,
md_insts = tcg_insts tc_result,
md_fam_insts = tcg_fam_insts tc_result,
- md_dbg_sites = noDbgSites,
+ md_modBreaks = emptyModBreaks,
md_rules = [panic "no rules"] }
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
Linkable(..), isObjectLinkable,
Unlinked(..), CompiledByteCode,
isObject, nameOfObject, isInterpretable, byteCodeOfObject,
- HpcInfo, noHpcInfo
+ HpcInfo, noHpcInfo,
+
+ -- Breakpoints
+ ModBreaks (..), emptyModBreaks
) where
#include "HsVersions.h"
-import Breakpoints ( SiteNumber, Coord, noDbgSites )
#ifdef GHCI
import ByteCodeAsm ( CompiledByteCode )
#endif
import CoreSyn ( CoreRule )
import Maybes ( orElse, expectJust, catMaybes, seqMaybe )
import Outputable
+import BreakArray
import SrcLoc ( SrcSpan, Located )
import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import System.Time ( ClockTime )
import Data.IORef ( IORef, readIORef )
+import Data.Array ( Array, array )
\end{code}
md_insts :: ![Instance], -- Dfun-ids for the instances in this module
md_fam_insts :: ![FamInst],
md_rules :: ![CoreRule], -- Domain may include Ids from other modules
- md_dbg_sites :: ![(SiteNumber, Coord)] -- Breakpoint sites inserted by the renamer
+ md_modBreaks :: !ModBreaks -- breakpoint information for this module
}
emptyModDetails = ModDetails { md_types = emptyTypeEnv,
md_insts = [],
md_rules = [],
md_fam_insts = [],
- md_dbg_sites = noDbgSites}
+ md_modBreaks = emptyModBreaks }
-- A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
mg_foreign :: !ForeignStubs,
mg_deprecs :: !Deprecations, -- Deprecations declared in the module
mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes
- mg_dbg_sites :: ![(SiteNumber, Coord)] -- Bkpts inserted by the renamer
+ mg_modBreaks :: !ModBreaks
}
-- The ModGuts takes on several slightly different forms:
= showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
char '(', text (msHsFilePath mod_summary) <> comma,
case target of
-#if defined(GHCI) && defined(DEBUGGER)
- HscInterpreted | recomp &&
- Opt_Debugging `elem` modflags
- -> text "interpreted(debugging)"
-#endif
HscInterpreted | recomp
-> text "interpreted"
HscNothing -> text "nothing"
where
mod = moduleName (ms_mod mod_summary)
mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary)
- modflags= flags(ms_hspp_opts mod_summary)
\end{code}
byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
\end{code}
+%************************************************************************
+%* *
+\subsection{Breakpoint Support}
+%* *
+%************************************************************************
+\begin{code}
+-- all the information about the breakpoints for a given module
+data ModBreaks
+ = ModBreaks
+ { modBreaks_array :: BreakArray
+ -- the array of breakpoint flags indexed by tick number
+ , modBreaks_ticks :: !(Array Int SrcSpan)
+ }
+emptyModBreaks :: ModBreaks
+emptyModBreaks = ModBreaks
+ { modBreaks_array = error "ModBreaks.modBreaks_array not initialised"
+ -- Todo: can we avoid this?
+ , modBreaks_ticks = array (0,-1) []
+ }
+\end{code}
, mg_exports = exports
, mg_types = type_env
, mg_insts = insts
- , mg_fam_insts = fam_insts,
- mg_dbg_sites = sites })
+ , mg_fam_insts = fam_insts
+ , mg_modBreaks = modBreaks
+ })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy [hoot] type env"
, md_fam_insts = fam_insts
, md_rules = []
, md_exports = exports
- , md_dbg_sites = sites})
+ , md_modBreaks = modBreaks
+ })
}
where
mg_dir_imps = dir_imps, mg_deps = deps,
mg_foreign = foreign_stubs,
mg_hpc_info = hpc_info,
- mg_dbg_sites = sites })
+ mg_modBreaks = modBreaks })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy Core"
md_insts = tidy_insts,
md_fam_insts = fam_insts,
md_exports = exports,
- md_dbg_sites = sites })
+ md_modBreaks = modBreaks })
+
}
lookup_dfun type_env dfun_id
DriverPipeline
DsArrows
DsBinds
- DsBreakpoint
DsCCall
DsExpr
DsForeign
has_side_effects = True
out_of_line = True
-primop InfoPtrOp "infoPtr#" GenPrimOp
- a -> Addr#
- with
- out_of_line = True
-
-primop ClosurePayloadOp "closurePayload#" GenPrimOp
- a -> (# Array# b, ByteArr# #)
+primop UnpackClosureOp "unpackClosure#" GenPrimOp
+ a -> (# Addr#, Array# b, ByteArr# #)
with
out_of_line = True
import HscTypes
import ListSetOps
import Outputable
-import Breakpoints
#ifdef GHCI
import Linker
import Bag
import Control.Monad ( unless )
+import Data.Maybe ( isJust )
+import Foreign.Ptr ( Ptr )
+
\end{code}
mg_deprecs = NoDeprecs,
mg_foreign = NoStubs,
mg_hpc_info = noHpcInfo,
- mg_dbg_sites = noDbgSites
+ mg_modBreaks = emptyModBreaks
} } ;
tcCoreDump mod_guts ;
return good_names
}
-tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon)
-tcRnRecoverDataCon hsc_env a
+tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon)
+tcRnRecoverDataCon hsc_env ptr
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext hsc_env (hsc_IC hsc_env) $
- do name <- recoverDataCon a
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $ do
+ name <- dataConInfoPtrToName ptr
tcLookupDataCon name
tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
>module TcRnDriver where
>import HscTypes
>import DataCon
+>import Foreign.Ptr
>
->tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon)
\ No newline at end of file
+>tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon)
-> TcM hs_syn -- Of type t
runMeta convert expr
= do { -- Desugar
-#if defined(GHCI) && defined(DEBUGGER)
- ds_expr <- unsetOptM Opt_Debugging $ initDsTc (dsLExpr expr)
-#else
ds_expr <- initDsTc (dsLExpr expr)
-#endif
-- Compile and link it; might fail if linking fails
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
#define bci_RETURN_D 50
#define bci_RETURN_L 51
#define bci_RETURN_V 52
+#define bci_BRK_FUN 53
/* If you need to go past 255 then you will run into the flags */
/* If you need to go below 0x0100 then you will run into the instructions */
*
* TSO_INTERRUPTIBLE: the TSO can be interrupted if it blocks
* interruptibly (eg. with BlockedOnMVar).
+ *
+ * TSO_STOPPED_ON_BREAKPOINT: the thread is currently stopped in a breakpoint
*/
#define TSO_BLOCKEX 4
#define TSO_INTERRUPTIBLE 8
+#define TSO_STOPPED_ON_BREAKPOINT 16
/* -----------------------------------------------------------------------------
RET_DYN stack frames
RTS_FUN(writeTVarzh_fast);
RTS_FUN(checkzh_fast);
-RTS_FUN(infoPtrzh_fast);
-RTS_FUN(closurePayloadzh_fast);
+RTS_FUN(unpackClosurezh_fast);
+RTS_FUN(getApStackValzh_fast);
RTS_FUN(noDuplicatezh_fast);
HscIfaceFileVersion=6
-# Building with debugger?
-GhciWithDebugger=YES
-
#------------------------------------------------------------------------------
# Options for Libraries
instr = instrs[pc++];
switch (instr) {
+ 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;
+ break;
case bci_SWIZZLE:
debugBelch("SWIZZLE stkoff %d by %d\n",
instrs[pc], (signed int)instrs[pc+1]);
return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
}
+rtsBool stop_next_breakpoint = rtsFalse;
#ifdef INTERP_STATS
int it_oofreq[27][27];
int it_lastopc;
+
#define INTERP_TICK(n) (n)++
void interp_startup ( void )
(W_)&stg_ap_pppppp_info,
};
+HsStablePtr breakPointIOAction; // points to the IO action which is executed on a breakpoint
+ // it is set in main/GHC.hs:runStmt
+
Capability *
interpretBCO (Capability* cap)
{
// +---------------+
//
if (Sp[0] == (W_)&stg_enter_info) {
- Sp++;
- goto eval;
+ Sp++;
+ goto eval;
}
// ------------------------------------------------------------------------
break;
case BCO:
+ {
ASSERT(((StgBCO *)obj)->arity > 0);
break;
+ }
case AP: /* Copied from stg_AP_entry. */
{
// Sadly we have three different kinds of stack/heap/cswitch check
// to do:
+
run_BCO_return:
// Heap check
if (doYouWantToGC()) {
}
// Stack checks aren't necessary at return points, the stack use
// is aggregated into the enclosing function entry point.
+
goto run_BCO;
run_BCO_return_unboxed:
}
// Stack checks aren't necessary at return points, the stack use
// is aggregated into the enclosing function entry point.
+
goto run_BCO;
run_BCO_fun:
Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
}
+
goto run_BCO;
// Now, actually interpret the BCO... (no returning to the
INTERP_TICK(it_BCO_entries);
{
register int bciPtr = 1; /* instruction pointer */
- register StgWord16 bci;
+ register StgWord16 bci;
register StgBCO* bco = (StgBCO*)obj;
register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
//if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
);
+
INTERP_TICK(it_insns);
#ifdef INTERP_STATS
switch (bci & 0xFF) {
+ /* check for a breakpoint on the beginning of a let binding */
+ case bci_BRK_FUN:
+ {
+ int arg1_brk_array, arg2_array_index, arg3_freeVars;
+ StgArrWords *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
+
+ StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap
+ int i;
+ int size_words;
+
+ arg1_brk_array = BCO_NEXT; /* first argument of break instruction */
+ arg2_array_index = BCO_NEXT; /* second dargument of break instruction */
+ arg3_freeVars = BCO_NEXT; /* third argument of break instruction */
+
+ // 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;
+
+ // if we are returning from a break then skip this section and continue executing
+ if (!returning_from_break)
+ {
+ breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
+
+ // stop the current thread if either the "stop_next_breakpoint" flag is true
+ // OR if the breakpoint flag for this particular expression is true
+ if (stop_next_breakpoint == rtsTrue || breakPoints->payload[arg2_array_index] == rtsTrue)
+ {
+ stop_next_breakpoint = rtsFalse; // make sure we don't automatically stop at the next breakpoint
+
+ // allocate memory for a new AP_STACK, enough to store the top stack frame
+ // plus an stg_apply_interp_info pointer and a pointer to the BCO
+ size_words = BCO_BITMAP_SIZE(obj) + 2;
+ new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
+ SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
+ new_aps->size = size_words;
+ // we should never enter new_aps->fun, so it is assigned to a dummy value
+ // ToDo: fixme to something that explodes with an error if you enter it
+ new_aps->fun = &stg_dummy_ret_closure;
+
+ // fill in the payload of the AP_STACK
+ new_aps->payload[0] = (W_)&stg_apply_interp_info;
+ new_aps->payload[1] = (W_)obj;
+
+ // copy the contents of the top stack frame into the AP_STACK
+ for (i = 2; i < size_words; i++)
+ {
+ new_aps->payload[i] = (W_)Sp[i-2];
+ }
+
+ // prepare the stack so that we can call the breakPointIOAction
+ // and ensure that the stack is in a reasonable state for the GC
+ // and so that execution of this BCO can continue when we resume
+ ioAction = (StgClosure *) deRefStablePtr (breakPointIOAction);
+ Sp -= 7;
+ Sp[6] = (W_)obj;
+ Sp[5] = (W_)&stg_apply_interp_info;
+ Sp[4] = (W_)new_aps; /* the AP_STACK */
+ Sp[3] = (W_)BCO_PTR(arg3_freeVars); /* the info about local vars of the breakpoint */
+ Sp[2] = (W_)&stg_ap_ppv_info;
+ Sp[1] = (W_)ioAction; /* apply the IO action to its two arguments above */
+ Sp[0] = (W_)&stg_enter_info; /* get ready to run the IO action */
+
+ // set the flag in the TSO to say that we are now stopping at a breakpoint
+ // so that when we resume we don't stop on the same breakpoint that we already
+ // stopped at just now
+ cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
+
+ // stop this thread and return to the scheduler - eventually we will come back
+ // and the IO action on the top of the stack will be executed
+ RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
+ }
+ }
+ // record that this thread is not stopped at a breakpoint anymore
+ cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
+
+ // continue normal execution of the byte code instructions
+ goto nextInsn;
+ }
+
case bci_STKCHECK: {
// Explicit stack check at the beginning of a function
// *only* (stack checks in case alternatives are
bciPtr = nextpc;
goto nextInsn;
}
-
+
case bci_CASEFAIL:
barf("interpretBCO: hit a CASEFAIL");
barf("interpretBCO: fell off end of the interpreter");
}
+
+/* temporary code for peeking inside a AP_STACK and pulling out values
+ based on their stack offset - used in the debugger for inspecting
+ the local values of a breakpoint
+*/
+HsStablePtr rts_getApStackVal (HsStablePtr, int);
+HsStablePtr rts_getApStackVal (HsStablePtr apStackSptr, int offset)
+{
+ HsStablePtr resultSptr;
+ StgAP_STACK *apStack;
+ StgClosure **payload;
+ StgClosure *val;
+
+ apStack = (StgAP_STACK *) deRefStablePtr (apStackSptr);
+ payload = apStack->payload;
+ val = (StgClosure *) payload[offset+2];
+ resultSptr = getStablePtr (val);
+ return resultSptr;
+}
+
+/* set the single step flag for the debugger to True -
+ it gets set back to false in the interpreter everytime
+ we hit a breakpoint
+*/
+void rts_setStepFlag (void);
+void rts_setStepFlag (void)
+{
+ stop_next_breakpoint = rtsTrue;
+}
SymX(hs_free_stable_ptr) \
SymX(hs_free_fun_ptr) \
SymX(initLinker) \
- SymX(infoPtrzh_fast) \
- SymX(closurePayloadzh_fast) \
+ SymX(unpackClosurezh_fast) \
+ SymX(getApStackValzh_fast) \
SymX(int2Integerzh_fast) \
SymX(integer2Intzh_fast) \
SymX(integer2Wordzh_fast) \
W_ bco, bitmap_arr, bytes, words;
bitmap_arr = R5;
+
words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
bytes = WDS(words);
RET_P(ap);
}
-infoPtrzh_fast
-{
-/* args: R1 = closure to analyze */
-
- MAYBE_GC(R1_PTR, infoPtrzh_fast);
-
- W_ info;
- info = %GET_STD_INFO(R1);
- RET_N(info);
-}
-
-closurePayloadzh_fast
+unpackClosurezh_fast
{
/* args: R1 = closure to analyze */
// TODO: Consider the absence of ptrs or nonptrs as a special case ?
- MAYBE_GC(R1_PTR, closurePayloadzh_fast);
-
W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
info = %GET_STD_INFO(R1);
ptrs = TO_W_(%INFO_PTRS(info));
nptrs = TO_W_(%INFO_NPTRS(info));
- p = 0;
- ALLOC_PRIM (SIZEOF_StgMutArrPtrs + WDS(ptrs), R1_PTR, closurePayloadzh_fast);
- ptrs_arr = Hp - SIZEOF_StgMutArrPtrs - WDS(ptrs) + WDS(1);
+ // Some closures have non-standard layout, so we omit those here.
+ W_ type;
+ type = TO_W_(%INFO_TYPE(info));
+ switch [0 .. N_CLOSURE_TYPES] type {
+ case THUNK_SELECTOR : {
+ ptrs = 1;
+ nptrs = 0;
+ goto out;
+ }
+ case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,
+ THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
+ ptrs = 0;
+ nptrs = 0;
+ goto out;
+ }
+ default: {
+ goto out;
+ }}
+out:
+
+ W_ ptrs_arr_sz, nptrs_arr_sz;
+ nptrs_arr_sz = SIZEOF_StgArrWords + WDS(nptrs);
+ ptrs_arr_sz = SIZEOF_StgMutArrPtrs + WDS(ptrs);
+
+ ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, unpackClosurezh_fast);
+
+ ptrs_arr = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
+ nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
+
SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);
StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
+ p = 0;
for:
if(p < ptrs) {
W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(R1,p);
goto for;
}
- ALLOC_PRIM (SIZEOF_StgArrWords + WDS(nptrs), R1_PTR, closurePayloadzh_fast);
- nptrs_arr = Hp - SIZEOF_StgArrWords - WDS(nptrs) + WDS(1);
SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
StgArrWords_words(nptrs_arr) = nptrs;
p = 0;
p = p + 1;
goto for2;
}
- RET_PP(ptrs_arr, nptrs_arr);
+ RET_NPP(info, ptrs_arr, nptrs_arr);
}
/* -----------------------------------------------------------------------------
jump %ENTRY_CODE(Sp(0));
}
}
+
+getApStackValzh_fast
+{
+ W_ ap_stack, offset, val;
+
+ /* args: R1 = tso, R2 = offset */
+ ap_stack = R1;
+ offset = R2;
+
+ val = StgClosure_payload(ap_stack,offset);
+
+ RET_P(val);
+}
case CONSTR_NOCAF_STATIC:
{
StgWord i, j;
+
#ifdef PROFILING
debugBelch("%s(", info->prof.closure_desc);
debugBelch("%s", obj->header.prof.ccs->cc->label);
}
}
+/* prettyPrintClosure() is for printing out a closure using the data constructor
+ names found in the info tables. Closures are printed in a fashion that resembles
+ their Haskell representation. Useful during debugging.
+
+ Todo: support for more closure types, and support for non pointer fields in the
+ payload.
+*/
+
+void prettyPrintClosure_ (StgClosure *);
+
+void prettyPrintClosure (StgClosure *obj)
+{
+ prettyPrintClosure_ (obj);
+ debugBelch ("\n");
+}
+
+void prettyPrintClosure_ (StgClosure *obj)
+{
+ StgInfoTable *info;
+ StgConInfoTable *con_info;
+
+ /* collapse any indirections */
+ unsigned int type;
+ type = get_itbl(obj)->type;
+
+ while (type == IND ||
+ type == IND_STATIC ||
+ type == IND_OLDGEN ||
+ type == IND_PERM ||
+ type == IND_OLDGEN_PERM)
+ {
+ obj = ((StgInd *)obj)->indirectee;
+ type = get_itbl(obj)->type;
+ }
+
+ /* find the info table for this object */
+ info = get_itbl(obj);
+
+ /* determine what kind of object we have */
+ switch (info->type)
+ {
+ /* full applications of data constructors */
+ case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_2_0:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ {
+ int i;
+ char *descriptor;
+
+ /* find the con_info for the constructor */
+ con_info = get_con_itbl (obj);
+
+ /* obtain the name of the constructor */
+ descriptor = con_info->con_desc;
+
+ debugBelch ("(%s", descriptor);
+
+ /* process the payload of the closure */
+ /* we don't handle non pointers at the moment */
+ for (i = 0; i < info->layout.payload.ptrs; i++)
+ {
+ debugBelch (" ");
+ prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
+ }
+ debugBelch (")");
+ break;
+ }
+
+ /* if it isn't a constructor then just print the closure type */
+ default:
+ {
+ debugBelch ("<%s>", info_type(obj));
+ break;
+ }
+ }
+}
+
#else /* DEBUG */
void printPtr( StgPtr p )
{
{
debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
}
+
+
#endif /* DEBUG */
extern void printObj ( StgClosure *obj );
#ifdef DEBUG
+extern void prettyPrintClosure (StgClosure *obj);
extern void printClosure ( StgClosure *obj );
extern StgStackPtr printStackObj ( StgStackPtr sp );
extern void printStackChunk ( StgStackPtr sp, StgStackPtr spLim );
projects / ghc-hetmet.git / commitdiff