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.

3 files changed, 163 insertions, 67 deletions

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 197a71973b..a0a0262bcc 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -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
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index ff588e1276..44b207a293 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -1,4 +1,5 @@
-{-# 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
diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs
index 6ea1a25648..7aaf5f2cd8 100644
--- a/compiler/main/InteractiveEvalTypes.hs
+++ b/compiler/main/InteractiveEvalTypes.hs
@@ -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