Commit c8c44fd9 authored by Simon Marlow's avatar Simon Marlow

Maintain cost-centre stacks in the interpreter

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

How can you get a stack trace?

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

Other related changes in this diff:

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

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

Test Plan: validate

Reviewers: ezyang, bgamari, austin, hvr

Subscribers: thomie

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

GHC Trac Issues: #11047
parent ee6fba89
......@@ -277,7 +277,7 @@ emitSetCCC cc tick push
= do dflags <- getDynFlags
if not (gopt Opt_SccProfilingOn dflags)
then return ()
else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW
else do tmp <- newTemp (ccsType dflags)
pushCostCentre tmp curCCS cc
when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
......
......@@ -3,10 +3,14 @@
(c) University of Glasgow, 2007
-}
{-# LANGUAGE CPP, NondecreasingIndentation #-}
{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-}
module Coverage (addTicksToBinds, hpcInitCode) where
#ifdef GHCI
import qualified GHCi
import GHCi.RemoteTypes
#endif
import Type
import HsSyn
import Module
......@@ -53,7 +57,7 @@ import qualified Data.Map as Map
-}
addTicksToBinds
:: DynFlags
:: HscEnv
-> Module
-> ModLocation -- ... off the current module
-> NameSet -- Exported Ids. When we call addTicksToBinds,
......@@ -63,8 +67,9 @@ addTicksToBinds
-> LHsBinds Id
-> IO (LHsBinds Id, HpcInfo, ModBreaks)
addTicksToBinds dflags mod mod_loc exports tyCons binds
| let passes = coveragePasses dflags, not (null passes),
addTicksToBinds hsc_env mod mod_loc exports tyCons binds
| let dflags = hsc_dflags hsc_env
passes = coveragePasses dflags, not (null passes),
Just orig_file <- ml_hs_file mod_loc = do
if "boot" `isSuffixOf` orig_file
......@@ -94,17 +99,15 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds
initState = TT { tickBoxCount = 0
, mixEntries = []
, breakCount = 0
, breaks = []
, uniqSupply = us
}
(binds1,st) = foldr tickPass (binds, initState) passes
let tickCount = tickBoxCount st
hashNo <- writeMixEntries dflags mod tickCount (reverse $ mixEntries st)
orig_file2
modBreaks <- mkModBreaks dflags (breakCount st) (reverse $ breaks st)
entries = reverse $ mixEntries st
hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
modBreaks <- mkModBreaks hsc_env mod tickCount entries
when (dopt Opt_D_dump_ticked dflags) $
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
......@@ -127,24 +130,56 @@ guessSourceFile binds orig_file =
_ -> orig_file
mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks dflags count entries = do
breakArray <- newBreakArray dflags $ length entries
let
locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]
varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]
declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
modBreaks = emptyModBreaks
{ modBreaks_flags = breakArray
, modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
, modBreaks_decls = declsTicks
}
--
return modBreaks
writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks hsc_env mod count entries
| HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
breakArray <- newBreakArray (length entries)
#ifdef GHCI
ccs <- mkCCSArray hsc_env mod count entries
#endif
let
locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]
varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]
declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
return emptyModBreaks
{ modBreaks_flags = breakArray
, modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
, modBreaks_decls = declsTicks
#ifdef GHCI
, modBreaks_ccs = ccs
#endif
}
| otherwise = return emptyModBreaks
#ifdef GHCI
mkCCSArray
:: HscEnv -> Module -> Int -> [MixEntry_]
-> IO (Array BreakIndex RemotePtr {- CCostCentre -})
mkCCSArray hsc_env modul count entries = do
if interpreterProfiled (hsc_dflags hsc_env)
then do
let module_bs = fastStringToByteString (moduleNameFS (moduleName modul))
c_module <- GHCi.mallocData hsc_env module_bs
costcentres <- mapM (mkCostCentre hsc_env (toRemotePtr c_module)) entries
return (listArray (0,count-1) costcentres)
else do
return (listArray (0,-1) [])
where
mkCostCentre
:: HscEnv
-> RemotePtr {- CChar -}
-> MixEntry_
-> IO (RemotePtr {- CCostCentre -})
mkCostCentre hsc_env@HscEnv{..} c_module (srcspan, decl_path, _, _) = do
let name = concat (intersperse "." decl_path)
src = showSDoc hsc_dflags (ppr srcspan)
GHCi.mkCostCentre hsc_env c_module name src
#endif
writeMixEntries
:: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
writeMixEntries dflags mod count entries filename
| not (gopt Opt_Hpc dflags) = return 0
| otherwise = do
......@@ -156,7 +191,8 @@ writeMixEntries dflags mod count entries filename
| moduleUnitId mod == mainUnitId = hpc_dir
| otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.
tabStop = 8 -- <tab> counts as a normal char in GHC's
-- location ranges.
createDirectoryIfMissing True hpc_mod_dir
modTime <- getModificationUTCTime filename
......@@ -203,9 +239,9 @@ shouldTickBind :: TickDensity
-> Bool -- INLINE pragma?
-> Bool
shouldTickBind density top_lev exported simple_pat inline
shouldTickBind density top_lev exported _simple_pat inline
= case density of
TickForBreakPoints -> not simple_pat
TickForBreakPoints -> False
-- we never add breakpoints to simple pattern bindings
-- (there's always a tick on the rhs anyway).
TickAllFunctions -> not inline
......@@ -296,7 +332,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
, fun_tick = tick `mbCons` fun_tick funBind }
where
-- a binding is a simple pattern binding if it is a funbind with zero patterns
-- a binding is a simple pattern binding if it is a funbind with
-- zero patterns
isSimplePatBind :: HsBind a -> Bool
isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
......@@ -329,7 +366,8 @@ addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
bindTick
:: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
bindTick density name pos fvs = do
decl_path <- getPathEntry
let
......@@ -425,18 +463,11 @@ addTickLHsExprNever (L pos e0) = do
e1 <- addTickHsExpr e0
return $ L pos e1
-- general heuristic: expressions which do not denote values are good break points
-- general heuristic: expressions which do not denote values are good
-- break points
isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr (HsApp {}) = True
isGoodBreakExpr (OpApp {}) = True
isGoodBreakExpr (NegApp {}) = True
isGoodBreakExpr (HsIf {}) = True
isGoodBreakExpr (HsMultiIf {}) = True
isGoodBreakExpr (HsCase {}) = True
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {}) = True
isGoodBreakExpr (PArrSeq {}) = True
isGoodBreakExpr _other = False
isCallSite :: HsExpr Id -> Bool
......@@ -957,8 +988,6 @@ liftL f (L loc a) = do
data TickTransState = TT { tickBoxCount:: Int
, mixEntries :: [MixEntry_]
, breakCount :: Int
, breaks :: [MixEntry_]
, uniqSupply :: UniqSupply
}
......@@ -1174,9 +1203,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
return $ ProfNote cc count True{-scopes-}
Breakpoints -> do
c <- liftM breakCount getState
setState $ \st -> st { breakCount = c + 1
, breaks = me:breaks st }
c <- liftM tickBoxCount getState
setState $ \st -> st { tickBoxCount = c + 1
, mixEntries = me:mixEntries st }
return $ Breakpoint c ids
SourceNotes | RealSrcSpan pos' <- pos ->
......
......@@ -300,8 +300,8 @@ deSugar hsc_env
; (binds_cvr, ds_hpc_info, modBreaks)
<- if not (isHsBootOrSig hsc_src)
then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds
then addTicksToBinds hsc_env mod mod_loc
export_set (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
......
......@@ -18,6 +18,7 @@ module ByteCodeAsm (
import ByteCodeInstr
import ByteCodeItbls
import ByteCodeTypes
import GHCi.RemoteTypes
import HscTypes
import Name
......@@ -359,9 +360,11 @@ assembleI dflags i = case i of
RETURN_UBX rep -> emit (return_ubx rep) []
CCALL off m_addr i -> do np <- addr m_addr
emit bci_CCALL [SmallOp off, Op np, SmallOp i]
BRK_FUN array index info -> do p1 <- ptr (BCOPtrArray array)
p2 <- ptr (BCOPtrBreakInfo info)
emit bci_BRK_FUN [Op p1, SmallOp index, Op p2]
BRK_FUN array index info cc -> do p1 <- ptr (BCOPtrArray array)
p2 <- ptr (BCOPtrBreakInfo info)
np <- addr cc
emit bci_BRK_FUN [Op p1, SmallOp index,
Op p2, Op np]
where
literal (MachLabel fs (Just sz) _)
......@@ -383,7 +386,7 @@ assembleI dflags i = case i of
literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger"
litlabel fs = lit [BCONPtrLbl fs]
addr = words . mkLitPtr
addr (RemotePtr a) = words [fromIntegral a]
float = words . mkLitF
double = words . mkLitD dflags
int = words . mkLitI
......@@ -422,7 +425,6 @@ return_ubx V64 = error "return_ubx: vector"
mkLitI :: Int -> [Word]
mkLitF :: Float -> [Word]
mkLitD :: DynFlags -> Double -> [Word]
mkLitPtr :: Ptr () -> [Word]
mkLitI64 :: DynFlags -> Int64 -> [Word]
mkLitF f
......@@ -485,14 +487,5 @@ mkLitI i
return [w0 :: Word]
)
mkLitPtr a
= runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 a
a_arr <- castSTUArray arr
w0 <- readArray a_arr 0
return [w0 :: Word]
)
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
......@@ -60,6 +60,7 @@ import Data.Maybe
import Module
import Control.Arrow ( second )
import Data.Array
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
......@@ -334,7 +335,8 @@ schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeER_wrk d p rhs
| AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
= do code <- schemeE (fromIntegral d) 0 p newRhs
arr <- getBreakArray
flag_arr <- getBreakArray
cc_arr <- getCCArray
this_mod <- getCurrentModule
let idOffSets = getVarOffSets d p fvs
let breakInfo = BreakInfo
......@@ -343,9 +345,12 @@ schemeER_wrk d p rhs
, breakInfo_vars = idOffSets
, breakInfo_resty = exprType (deAnnotate' newRhs)
}
let breakInstr = case arr of
dflags <- getDynFlags
let cc | interpreterProfiled dflags = cc_arr ! tick_no
| otherwise = toRemotePtr nullPtr
let breakInstr = case flag_arr of
BA arr# ->
BRK_FUN arr# (fromIntegral tick_no) breakInfo
BRK_FUN arr# (fromIntegral tick_no) breakInfo cc
return $ breakInstr `consOL` code
| otherwise = schemeE (fromIntegral d) 0 p rhs
......@@ -782,6 +787,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
= do
dflags <- getDynFlags
let
profiling
| gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
| otherwise = rtsIsProfiled
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
-- When an alt is entered, it assumes the returned value is
......@@ -789,6 +798,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
ret_frame_sizeW :: Word
ret_frame_sizeW = 2
-- The extra frame we push to save/restor the CCCS when profiling
save_ccs_sizeW | profiling = 2
| otherwise = 0
-- An unlifted value gets an extra info table pushed on top
-- when it is returned.
unlifted_itbl_sizeW :: Word
......@@ -904,8 +917,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
0{-no arity-} bitmap_size bitmap True{-is alts-}
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
-- "\n bitmap = " ++ show bitmap) $ do
scrut_code <- schemeE (d + ret_frame_sizeW)
(d + ret_frame_sizeW)
scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW)
(d + ret_frame_sizeW + save_ccs_sizeW)
p scrut
alt_bco' <- emitBc alt_bco
let push_alts
......@@ -1105,8 +1119,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
let ffires = primRepToFFIType dflags r_rep
ffiargs = map (primRepToFFIType dflags) a_reps
hsc_env <- getHscEnv
rp <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
let token = fromRemotePtr rp
token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
recordFFIBc token
let
......@@ -1633,7 +1646,7 @@ data BcM_State
, nextlabel :: Word16 -- for generating local labels
, ffis :: [FFIInfo] -- ffi info blocks, to free later
-- Should be free()d when it is GCd
, breakArray :: BreakArray -- array of breakpoint flags
, modBreaks :: ModBreaks -- info about breakpoints
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
......@@ -1646,9 +1659,7 @@ ioToBc io = BcM $ \st -> do
runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r
-> IO (BcM_State, r)
runBc hsc_env us this_mod modBreaks (BcM m)
= m (BcM_State hsc_env us this_mod 0 [] breakArray)
where
breakArray = modBreaks_flags modBreaks
= m (BcM_State hsc_env us this_mod 0 [] modBreaks)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
......@@ -1689,7 +1700,7 @@ emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
= BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
recordFFIBc :: Ptr () -> BcM ()
recordFFIBc :: RemotePtr -> BcM ()
recordFFIBc a
= BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
......@@ -1706,7 +1717,10 @@ getLabelsBc n
in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
getBreakArray :: BcM BreakArray
getBreakArray = BcM $ \st -> return (st, breakArray st)
getBreakArray = BcM $ \st -> return (st, modBreaks_flags (modBreaks st))
getCCArray :: BcM (Array BreakIndex RemotePtr {- CCostCentre -})
getCCArray = BcM $ \st -> return (st, modBreaks_ccs (modBreaks st))
newUnique :: BcM Unique
newUnique = BcM $
......
......@@ -13,6 +13,7 @@ module ByteCodeInstr (
#include "../includes/MachDeps.h"
import ByteCodeTypes
import GHCi.RemoteTypes
import StgCmmLayout ( ArgRep(..) )
import PprCore
import Outputable
......@@ -124,7 +125,7 @@ data BCInstr
-- For doing calls to C (via glue code generated by libffi)
| CCALL Word16 -- stack frame size
(Ptr ()) -- addr of the glue code
RemotePtr -- addr of the glue code
Word16 -- whether or not the call is interruptible
-- (XXX: inefficient, but I don't know
-- what the alignment constraints are.)
......@@ -139,7 +140,7 @@ data BCInstr
| RETURN_UBX ArgRep -- return an unlifted value, here's its rep
-- Breakpoints
| BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo
| BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo RemotePtr
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
......@@ -239,7 +240,7 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr RETURN = text "RETURN"
ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info
ppr (BRK_FUN _breakArray index info _cc) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info <+> text "<cc>"
-- -----------------------------------------------------------------------------
-- The stack use, in words, of each bytecode insn. These _must_ be
......
......@@ -20,6 +20,7 @@ import Outputable
import PrimOp
import SizedSeq
import Type
import GHCi.RemoteTypes
import Foreign
import Data.Array.Base ( UArray(..) )
......@@ -33,7 +34,7 @@ data CompiledByteCode
[FFIInfo] -- ffi blocks we allocated
-- ToDo: we're not tracking strings that we malloc'd
newtype FFIInfo = FFIInfo (Ptr ())
newtype FFIInfo = FFIInfo RemotePtr
deriving Show
instance Outputable CompiledByteCode where
......
......@@ -13,6 +13,8 @@ module GHCi
, evalString
, evalStringToIOString
, mallocData
, mkCostCentre
, costCentreStackInfo
-- * The object-code linker
, initObjLinker
......@@ -207,7 +209,7 @@ handleEvalStatus
:: HscEnv -> EvalStatus [HValueRef] -> IO (EvalStatus [ForeignHValue])
handleEvalStatus hsc_env status =
case status of
EvalBreak a b c d -> return (EvalBreak a b c d)
EvalBreak a b c d e -> return (EvalBreak a b c d e)
EvalComplete alloc res ->
EvalComplete alloc <$> addFinalizer res
where
......@@ -239,6 +241,16 @@ evalStringToIOString hsc_env fhv str = do
mallocData :: HscEnv -> ByteString -> IO (Ptr ())
mallocData hsc_env bs = fromRemotePtr <$> iservCmd hsc_env (MallocData bs)
mkCostCentre
:: HscEnv -> RemotePtr {- CChar -} -> String -> String
-> IO RemotePtr {- CCostCentre -}
mkCostCentre hsc_env c_module name src =
iservCmd hsc_env (MkCostCentre c_module name src)
costCentreStackInfo :: HscEnv -> RemotePtr {- CCostCentreStack -} -> IO [String]
costCentreStackInfo hsc_env ccs =
iservCmd hsc_env (CostCentreStackInfo ccs)
-- -----------------------------------------------------------------------------
-- Interface to the object-code linker
......
......@@ -820,7 +820,7 @@ dynLinkObjs hsc_env pls objs = do
unlinkeds = concatMap linkableUnlinked new_objs
wanted_objs = map nameOfObject unlinkeds
if loadingDynamicHSLibs (hsc_dflags hsc_env)
if interpreterDynamic (hsc_dflags hsc_env)
then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
return (pls2, Succeeded)
else do mapM_ (loadObj hsc_env) wanted_objs
......@@ -1248,16 +1248,6 @@ loadFrameworks hsc_env platform pkg
Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" ))
loadingDynamicHSLibs :: DynFlags -> Bool
loadingDynamicHSLibs dflags
| gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags
| otherwise = dynamicGhc
loadingProfiledHSLibs :: DynFlags -> Bool
loadingProfiledHSLibs dflags
| gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
| otherwise = rtsIsProfiled
-- Try to find an object file for a given library in the given paths.
-- If it isn't present, we assume that addDLL in the RTS can find it,
-- which generally means that it should be a dynamic library in the
......@@ -1306,8 +1296,8 @@ locateLib hsc_env is_hs dirs lib
arch_file = "lib" ++ lib ++ lib_tag <.> "a"
lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
loading_profiled_hs_libs = loadingProfiledHSLibs dflags
loading_dynamic_hs_libs = loadingDynamicHSLibs dflags
loading_profiled_hs_libs = interpreterProfiled dflags
loading_dynamic_hs_libs = interpreterDynamic dflags
hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
......
......@@ -2,13 +2,16 @@
-------------------------------------------------------------------------------
--
-- | Break Arrays in the IO monad
-- (c) The University of Glasgow 2007
--
-- Entries in the array are Word sized Conceptually, a zero-indexed IOArray of
-- Bools, initially False. They're represented as Words with 0==False, 1==True.
-- They're used to determine whether GHCI breakpoints are on or off.
-- | Break Arrays
--
-- (c) The University of Glasgow 2007
-- An array of bytes, indexed by a breakpoint number (breakpointId in Tickish)
-- There is one of these arrays per module.
--
-- Each byte is
-- 1 if the corresponding breakpoint is enabled
-- 0 otherwise
--
-------------------------------------------------------------------------------
......@@ -27,10 +30,10 @@ module BreakArray
#endif
) where
import DynFlags
#ifdef GHCI
import Control.Monad
import Data.Word
import GHC.Word
import GHC.Exts
import GHC.IO ( IO(..) )
......@@ -38,43 +41,43 @@ import System.IO.Unsafe ( unsafeDupablePerformIO )
data BreakArray = BA (MutableByteArray# RealWorld)
breakOff, breakOn :: Word
breakOff, breakOn :: Word8
breakOn = 1
breakOff = 0
showBreakArray :: DynFlags -> BreakArray -> IO ()
showBreakArray dflags array = do
forM_ [0 .. (size dflags array - 1)] $ \i -> do
showBreakArray :: BreakArray -> IO ()
showBreakArray array = do
forM_ [0 .. (size array - 1)] $ \i -> do
val <- readBreakArray array i
putStr $ ' ' : show val
putStr "\n"
setBreakOn :: DynFlags -> BreakArray -> Int -> IO Bool
setBreakOn dflags array index
| safeIndex dflags array index = do
setBreakOn :: BreakArray -> Int -> IO Bool
setBreakOn array index
| safeIndex array index = do
writeBreakArray array index breakOn
return True
| otherwise = return False
setBreakOff :: DynFlags -> BreakArray -> Int -> IO Bool
setBreakOff dflags array index
| safeIndex dflags array index = do
setBreakOff :: BreakArray -> Int -> IO Bool
setBreakOff array index
| safeIndex array index = do
writeBreakArray array index breakOff
return True
| otherwise = return False
getBreak :: DynFlags -> BreakArray -> Int -> IO (Maybe Word)
getBreak dflags array index
| safeIndex dflags array index = do
getBreak :: BreakArray -> Int -> IO (Maybe Word8)
getBreak array index
| safeIndex array index = do
val <- readBreakArray array index
return $ Just val
| otherwise = return Nothing
safeIndex :: DynFlags -> BreakArray -> Int -> Bool
safeIndex dflags array index = index < size dflags array && index >= 0
safeIndex :: BreakArray -> Int -> Bool
safeIndex array index = index < size array && index >= 0
size :: DynFlags -> BreakArray -> Int
size dflags (BA array) = size `div` wORD_SIZE dflags
size :: BreakArray -> Int
size (BA array) = size
where
-- We want to keep this operation pure. The mutable byte array
-- is never resized so this is safe.
......@@ -90,30 +93,28 @@ allocBA (I# sz) = IO $ \s1 ->
case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) }
-- create a new break array and initialise elements to zero
newBreakArray :: DynFlags -> Int -> IO BreakArray
newBreakArray dflags entries@(I# sz) = do
BA array <- allocBA (entries * wORD_SIZE dflags)
newBreakArray :: Int -> IO BreakArray
newBreakArray entries@(I# sz) = do
BA array <- allocBA entries
case breakOff of
W# off -> do -- Todo: there must be a better way to write zero as a Word!
let loop n | isTrue# (n ==# sz) = return ()
| otherwise = do
writeBA# array n off
loop (n +# 1#)
loop 0#
W8# off -> do
let loop n | isTrue# (n ==# sz) = return ()
| otherwise = do writeBA# array n off; loop (n +# 1#)
loop 0#
return $ BA array
writeBA# :: MutableByteArray# RealWorld -> Int# -> Word# -> IO ()
writeBA# array i word = IO $ \s ->
case writeWordArray# array i word s of { s -> (# s, () #) }
case writeWord8Array# array i word s of { s -> (# s, () #) }
writeBreakArray :: BreakArray -> Int -> Word -> IO ()
writeBreakArray (BA array) (I# i) (W# word) = writeBA# array i word
writeBreakArray :: BreakArray -> Int -> Word8 -> IO ()
writeBreakArray (BA array) (I# i) (W8# word) = writeBA# array i word
readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word
readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word8
readBA# array i = IO $ \s ->
case readWordArray# array i s of { (# s, c #) -> (# s, W# c #) }
case readWord8Array# array i s of { (# s, c #) -> (# s, W8# c #) }
readBreakArray :: BreakArray -> Int -> IO Word
readBreakArray :: BreakArray -> Int -> IO Word8
readBreakArray (BA array) (I# i) = readBA# array i