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

More accurate allocation stats for :set +s

The point of this commit is to make the memory allocation statistic
from :set +s in GHCi a lot more accurate.  Currently it uses the total
allocation figure calculated by the RTS, which is only updated during
GC, so can be wrong by an arbitrary amount.  The fix is to the the
per-thread allocation counter that was introduced for allocation
limits.

This required changes to the GHC API, because we now have to return
the allocation value from each evaluation.  Rather than just change
the API, I introduced a new API and deprecated the old one.  The new
one is simpler and more extensible, so hopefully we won't need to make
this transition in the future.  See GHC.hs for details.
parent 2666ba36
......@@ -87,47 +87,68 @@ module GHC (
PrintUnqualified, alwaysQualify,
-- * Interactive evaluation
#ifdef GHCI
-- ** Executing statements
execStmt, ExecOptions(..), execOptions, ExecResult(..),
resumeExec,
-- ** Adding new declarations
runDecls, runDeclsWithLocation,
-- ** Get/set the current context
parseImportDecl,
setContext, getContext,
setGHCiMonad,
#endif
-- ** Inspecting the current context
getBindings, getInsts, getPrintUnqual,
findModule, lookupModule,
#ifdef GHCI
isModuleTrusted,
moduleTrustReqs,
setContext, getContext,
isModuleTrusted, moduleTrustReqs,
getNamesInScope,
getRdrNamesInScope,
getGRE,
moduleIsInterpreted,
getInfo,
showModule,
isModuleInterpreted,
-- ** Inspecting types and kinds
exprType,
typeKind,
-- ** Looking up a Name
parseName,
RunResult(..),
runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
#endif
lookupName,
#ifdef GHCI
-- ** Compiling expressions
InteractiveEval.compileExpr, HValue, dynCompileExpr,
-- ** Other
runTcInteractive, -- Desired by some clients (Trac #8878)
parseImportDecl, SingleStep(..),
resume,
-- ** The debugger
SingleStep(..),
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
History(historyBreakInfo, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
getResumeContext,
abandon, abandonAll,
InteractiveEval.back,
InteractiveEval.forward,
showModule,
isModuleInterpreted,
InteractiveEval.compileExpr, HValue, dynCompileExpr,
getResumeContext,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
BreakArray, setBreakOn, setBreakOff, getBreak,
#endif
lookupName,
InteractiveEval.back,
InteractiveEval.forward,
#ifdef GHCI
-- ** EXPERIMENTAL
setGHCiMonad,
-- ** Deprecated API
RunResult(..),
runStmt, runStmtWithLocation,
resume,
#endif
-- * Abstract syntax elements
......@@ -1416,14 +1437,11 @@ moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageKey])
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
-- | EXPERIMENTAL: DO NOT USE.
--
-- Set the monad GHCi lifts user statements into.
-- | Set the monad GHCi lifts user statements into.
--
-- Checks that a type (in string form) is an instance of the
-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
-- throws an error otherwise.
{-# WARNING setGHCiMonad "This is experimental! Don't use." #-}
setGHCiMonad :: GhcMonad m => String -> m ()
setGHCiMonad name = withSession $ \hsc_env -> do
ty <- liftIO $ hscIsGHCiMonad hsc_env name
......
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples #-}
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
RecordWildCards #-}
-- -----------------------------------------------------------------------------
--
......@@ -10,8 +11,9 @@
module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
Status(..), Resume(..), History(..),
execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
runDecls, runDeclsWithLocation,
parseImportDecl, SingleStep(..),
resume,
abandon, abandonAll,
......@@ -32,7 +34,9 @@ module InteractiveEval (
showModule,
isModuleInterpreted,
compileExpr, dynCompileExpr,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
-- * Depcreated API (remove in GHC 7.14)
RunResult(..), runStmt, runStmtWithLocation,
#endif
) where
......@@ -93,6 +97,7 @@ import Data.Array
import Exception
import Control.Concurrent
import System.IO.Unsafe
import GHC.Conc ( setAllocationCounter, getAllocationCounter )
-- -----------------------------------------------------------------------------
-- running a statement interactively
......@@ -100,15 +105,6 @@ import System.IO.Unsafe
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
data SingleStep
= RunToCompletion
| SingleStep
| RunAndLogSteps
isStep :: SingleStep -> Bool
isStep RunToCompletion = False
isStep _ = True
mkHistory :: HscEnv -> HValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
decls = findEnclosingDecls hsc_env bi
......@@ -152,21 +148,30 @@ updateFixityEnv fix_env = do
let ic = hsc_IC hsc_env
setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
runStmt = runStmtWithLocation "<interactive>" 1
-- | Run a statement in the current interactive context. Passing debug information
-- Statement may bind multple values.
runStmtWithLocation :: GhcMonad m => String -> Int ->
String -> SingleStep -> m RunResult
runStmtWithLocation source linenumber expr step =
do
-- -----------------------------------------------------------------------------
-- execStmt
-- | default ExecOptions
execOptions :: ExecOptions
execOptions = ExecOptions
{ execSingleStep = RunToCompletion
, execSourceFile = "<interactive>"
, execLineNumber = 1
}
-- | Run a statement in the current interactive context.
execStmt
:: GhcMonad m
=> String -- ^ a statement (bind or expression)
-> ExecOptions
-> m ExecResult
execStmt stmt ExecOptions{..} = do
hsc_env <- getSession
breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint
statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running
-- wait on this when we hit a breakpoint
breakMVar <- liftIO $ newEmptyMVar
-- wait on this when a computation is running
statusMVar <- liftIO $ newEmptyMVar
-- Turn off -fwarn-unused-local-binds when running a statement, to hide
-- warnings about the implicit bindings we introduce.
......@@ -175,28 +180,63 @@ runStmtWithLocation source linenumber expr step =
hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }
-- compile to value (IO [HValue]), don't run
r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
r <- liftIO $ hscStmtWithLocation hsc_env' stmt
execSourceFile execLineNumber
case r of
-- empty statement / comment
Nothing -> return (RunOk [])
Nothing -> return (ExecComplete (Right []) 0)
Just (tyThings, hval, fix_env) -> do
updateFixityEnv fix_env
status <-
withVirtualCWD $
withBreakAction (isStep step) idflags' breakMVar statusMVar $ do
liftIO $ sandboxIO idflags' statusMVar hval
withBreakAction (isStep execSingleStep) idflags'
breakMVar statusMVar $ do
liftIO $ sandboxIO idflags' statusMVar hval
let ic = hsc_IC hsc_env
bindings = (ic_tythings ic, ic_rn_gbl_env ic)
size = ghciHistSize idflags'
handleRunStatus step expr bindings tyThings
handleRunStatus execSingleStep stmt bindings tyThings
breakMVar statusMVar status (emptyHistory size)
-- | The type returned by the deprecated 'runStmt' and
-- 'runStmtWithLocation' API
data RunResult
= RunOk [Name] -- ^ names bound by this evaluation
| RunException SomeException -- ^ statement raised an exception
| RunBreak ThreadId [Name] (Maybe BreakInfo)
-- | Conver the old result type to the new result type
execResultToRunResult :: ExecResult -> RunResult
execResultToRunResult r =
case r of
ExecComplete{ execResult = Left ex } -> RunException ex
ExecComplete{ execResult = Right names } -> RunOk names
ExecBreak{..} -> RunBreak breakThreadId breakNames breakInfo
-- Remove in GHC 7.14
{-# DEPRECATED runStmt "use execStmt" #-}
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
runStmt stmt step =
execResultToRunResult <$> execStmt stmt execOptions { execSingleStep = step }
-- Remove in GHC 7.14
{-# DEPRECATED runStmtWithLocation "use execStmtWithLocation" #-}
runStmtWithLocation :: GhcMonad m => String -> Int ->
String -> SingleStep -> m RunResult
runStmtWithLocation source linenumber expr step = do
execResultToRunResult <$>
execStmt expr execOptions { execSingleStep = step
, execSourceFile = source
, execLineNumber = linenumber }
runDecls :: GhcMonad m => String -> m [Name]
runDecls = runDeclsWithLocation "<interactive>" 1
......@@ -243,7 +283,7 @@ emptyHistory size = nilBL size
handleRunStatus :: GhcMonad m
=> SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
-> MVar () -> MVar Status -> Status -> BoundedList History
-> m RunResult
-> m ExecResult
handleRunStatus step expr bindings final_ids
breakMVar statusMVar status history
......@@ -296,21 +336,21 @@ handleRunStatus step expr bindings final_ids
hsc_env2 = pushResume hsc_env1 resume
modifySession (\_ -> hsc_env2)
return (RunBreak tid names mb_info)
return (ExecBreak tid names mb_info)
-- Completed with an exception
| Complete (Left e) <- status
= return (RunException e)
| Complete (Left e) alloc <- status
= return (ExecComplete (Left e) alloc)
-- Completed successfully
| Complete (Right hvals) <- status
| Complete (Right hvals) allocs <- status
= do hsc_env <- getSession
let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
final_names = map getName final_ids
liftIO $ Linker.extendLinkEnv (zip final_names hvals)
hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
modifySession (\_ -> hsc_env')
return (RunOk final_names)
return (ExecComplete (Right final_names) allocs)
| otherwise
= panic "handleRunStatus" -- The above cases are in fact exhaustive
......@@ -351,7 +391,10 @@ foreign import ccall "&rts_breakpoint_io_action"
sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
sandboxIO dflags statusMVar thing =
mask $ \restore -> -- fork starts blocked
let runIt = liftM Complete $ try (restore $ rethrow dflags thing)
let runIt =
liftM (uncurry Complete) $
measureAlloc $
try $ restore $ rethrow dflags $ thing
in if gopt Opt_GhciSandbox dflags
then do tid <- forkIO $ do res <- runIt
putMVar statusMVar res -- empty: can't block
......@@ -398,6 +441,13 @@ redirectInterrupts target wait
Nothing -> wait
Just target -> do throwTo target (e :: SomeException); wait
measureAlloc :: IO a -> IO (a,Word64)
measureAlloc io = do
setAllocationCounter maxBound
a <- io
allocs <- getAllocationCounter
return (a, fromIntegral (maxBound::Int64) - fromIntegral allocs)
-- We want to turn ^C into a break when -fbreak-on-exception is on,
-- but it's an async exception and we only break for sync exceptions.
-- Idea: if we catch and re-throw it, then the re-throw will trigger
......@@ -460,7 +510,10 @@ noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
noBreakAction True _ _ = return () -- exception: just continue
resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
resume canLogSpan step
resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step
resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
resumeExec canLogSpan step
= do
hsc_env <- getSession
let ic = hsc_IC hsc_env
......
......@@ -10,7 +10,8 @@
module InteractiveEvalTypes (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
Status(..), Resume(..), History(..), ExecResult(..),
SingleStep(..), isStep, ExecOptions(..)
#endif
) where
......@@ -26,15 +27,39 @@ import SrcLoc
import Exception
import Control.Concurrent
data RunResult
= RunOk [Name] -- ^ names bound by this evaluation
| RunException SomeException -- ^ statement raised an exception
| RunBreak ThreadId [Name] (Maybe BreakInfo)
import Data.Word
data ExecOptions
= ExecOptions
{ execSingleStep :: SingleStep -- ^ stepping mode
, execSourceFile :: String -- ^ filename (for errors)
, execLineNumber :: Int -- ^ line number (for errors)
}
data SingleStep
= RunToCompletion
| SingleStep
| RunAndLogSteps
isStep :: SingleStep -> Bool
isStep RunToCompletion = False
isStep _ = True
data ExecResult
= ExecComplete
{ execResult :: Either SomeException [Name]
, execAllocation :: Word64
}
| ExecBreak
{ breakThreadId :: ThreadId
, breakNames :: [Name]
, breakInfo :: Maybe BreakInfo
}
data Status
= Break Bool HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint (Bool <=> was an exception)
| Complete (Either SomeException [HValue])
| Complete (Either SomeException [HValue]) Word64
-- ^ the computation completed with either an exception or a value
data Resume
......
......@@ -43,7 +43,6 @@ import Linker
import Exception
import Numeric
import Data.Array
import Data.Int ( Int64 )
import Data.IORef
import System.CPUTime
import System.Environment
......@@ -265,7 +264,7 @@ printForUserPartWay doc = do
liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
-- | Run a single Haskell expression
runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
runStmt expr step = do
st <- getGHCiState
reifyGHCi $ \x ->
......@@ -274,7 +273,11 @@ runStmt expr step = do
reflectGHCi x $ do
GHC.handleSourceError (\e -> do GHC.printException e;
return Nothing) $ do
r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
let opts = GHC.execOptions
{ GHC.execSourceFile = progname st
, GHC.execLineNumber = line_number st
, GHC.execSingleStep = step }
r <- GHC.execStmt expr opts
return (Just r)
runDecls :: String -> GHCi (Maybe [GHC.Name])
......@@ -289,43 +292,41 @@ runDecls decls = do
r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
return (Just r)
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult
resume canLogSpan step = do
st <- getGHCiState
reifyGHCi $ \x ->
withProgName (progname st) $
withArgs (args st) $
reflectGHCi x $ do
GHC.resume canLogSpan step
GHC.resumeExec canLogSpan step
-- --------------------------------------------------------------------------
-- timing & statistics
timeIt :: InputT GHCi a -> InputT GHCi a
timeIt action
timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a
timeIt getAllocs action
= do b <- lift $ isOptionSet ShowTiming
if not b
then action
else do allocs1 <- liftIO $ getAllocations
time1 <- liftIO $ getCPUTime
else do time1 <- liftIO $ getCPUTime
a <- action
allocs2 <- liftIO $ getAllocations
let allocs = getAllocs a
time2 <- liftIO $ getCPUTime
dflags <- getDynFlags
liftIO $ printTimes dflags (fromIntegral (allocs2 - allocs1))
(time2 - time1)
liftIO $ printTimes dflags allocs (time2 - time1)
return a
foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
-- defined in ghc/rts/Stats.c
printTimes :: DynFlags -> Integer -> Integer -> IO ()
printTimes dflags allocs psecs
printTimes :: DynFlags -> Maybe Integer -> Integer -> IO ()
printTimes dflags mallocs psecs
= do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
secs_str = showFFloat (Just 2) secs
putStrLn (showSDoc dflags (
parens (text (secs_str "") <+> text "secs" <> comma <+>
text (separateThousands allocs) <+> text "bytes")))
case mallocs of
Nothing -> empty
Just allocs ->
text (separateThousands allocs) <+> text "bytes")))
where
separateThousands n = reverse . sep . reverse . show $ n
where sep n'
......
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections #-}
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections,
RecordWildCards #-}
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
......@@ -807,9 +808,10 @@ runOneCommand eh gCmd = do
Nothing -> return $ Just True
Just ml_stmt -> do
-- temporarily compensate line-number for multi-line input
result <- timeIt $ lift $ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
return $ Just result
else do -- single line input and :{-multiline input
result <- timeIt runAllocs $ lift $
runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
return $ Just (runSuccess result)
else do -- single line input and :{ - multiline input
last_line_num <- lift (line_number <$> getGHCiState)
-- reconstruct first line num from last line num and stmt
let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
......@@ -817,11 +819,13 @@ runOneCommand eh gCmd = do
stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]
stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines
-- temporarily compensate line-number for multi-line input
result <- timeIt $ lift $ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
return $ Just result
result <- timeIt runAllocs $ lift $
runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
return $ Just (runSuccess result)
-- runStmt wrapper for temporarily overridden line-number
runStmtWithLineNum :: Int -> String -> SingleStep -> GHCi Bool
runStmtWithLineNum :: Int -> String -> SingleStep
-> GHCi (Maybe GHC.ExecResult)
runStmtWithLineNum lnum stmt step = do
st0 <- getGHCiState
setGHCiState st0 { line_number = lnum }
......@@ -899,16 +903,16 @@ declPrefixes dflags = keywords ++ concat opt_keywords
-- | Entry point to execute some haskell code from user.
-- The return value True indicates success, as in `runOneCommand`.
runStmt :: String -> SingleStep -> GHCi Bool
runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)
runStmt stmt step
-- empty; this should be impossible anyways since we filtered out
-- whitespace-only input in runOneCommand's noSpace
| null (filter (not.isSpace) stmt)
= return True
= return Nothing
-- import
| stmt `looks_like` "import "
= do addImportToContext stmt; return True
= do addImportToContext stmt; return (Just (GHC.ExecComplete (Right []) 0))
| otherwise
= do dflags <- getDynFlags
......@@ -920,8 +924,10 @@ runStmt stmt step
do _ <- liftIO $ tryIO $ hFlushAll stdin
m_result <- GhciMonad.runDecls stmt
case m_result of
Nothing -> return False
Just result -> afterRunStmt (const True) (GHC.RunOk result)
Nothing -> return Nothing
Just result ->
Just <$> afterRunStmt (const True)
(GHC.ExecComplete (Right result) 0)
run_stmt =
do -- In the new IO library, read handles buffer data even if the Handle
......@@ -932,8 +938,8 @@ runStmt stmt step
_ <- liftIO $ tryIO $ hFlushAll stdin
m_result <- GhciMonad.runStmt stmt step
case m_result of
Nothing -> return False
Just result -> afterRunStmt (const True) result
Nothing -> return Nothing
Just result -> Just <$> afterRunStmt (const True) result
s `looks_like` prefix = prefix `isPrefixOf` dropWhile isSpace s
-- Ignore leading spaces (see Trac #9914), so that
......@@ -941,15 +947,17 @@ runStmt stmt step
-- (note leading spaces) works properly
-- | Clean up the GHCi environment after a statement has run
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e
afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult
afterRunStmt step_here run_result = do
resumes <- GHC.getResumeContext
case run_result of
GHC.RunOk names -> do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames names
GHC.RunBreak _ names mb_info
GHC.ExecComplete{..} ->
case execResult of
Left ex -> liftIO $ Exception.throwIO ex
Right names -> do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames names
GHC.ExecBreak _ names mb_info
| isNothing mb_info ||
step_here (GHC.resumeSpan $ head resumes) -> do
mb_id_loc <- toBreakIdAndLocation mb_info
......@@ -963,14 +971,25 @@ afterRunStmt step_here run_result = do
return ()
| otherwise -> resume step_here GHC.SingleStep >>=
afterRunStmt step_here >> return ()
_ -> return ()
flushInterpBuffers
liftIO installSignalHandlers
b <- isOptionSet RevertCAFs
when b revertCAFs
return (case run_result of GHC.RunOk _ -> True; _ -> False)
return run_result
runSuccess :: Maybe GHC.ExecResult -> Bool
runSuccess run_result
| Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True
| otherwise = False
runAllocs :: Maybe GHC.ExecResult -> Maybe Integer
runAllocs m = do
res <- m
case res of
GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)
_ -> Nothing
toBreakIdAndLocation ::
Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
......@@ -1369,7 +1388,7 @@ checkModule m = do
-- :load, :add, :reload
loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
loadModule fs = timeIt (loadModule' fs)