Commit 3979485b authored by Roland Senn's avatar Roland Senn

Show breakpoint locations of breakpoints which were ignored during :force (#2950)

GHCi is split up into 2 major parts: The user-interface (UI)
and the byte-code interpreter. With `-fexternal-interpreter`
they even run in different processes. Communication between
the UI and the Interpreter (called `iserv`) is done using
messages over a pipe. This is called `Remote GHCI` and
explained in the Note [Remote GHCi] in `compiler/ghci/GHCi.hs`.

To process a `:force` command the UI sends a `Seq` message
to the `iserv` process. Then `iserv` does the effective
evaluation of the value. When during this process a breakpoint
is hit, the `iserv` process has no additional information to
enhance the `Ignoring breakpoint` output with the breakpoint
location.

To be able to print additional breakpoint information,
there are 2 possible implementation choices:
1. Store the needed information in the `iserv` process.
2. Print the `Ignoring breakpoint` from the UI process.

For option 1 we need to store the breakpoint info redundantely
in 2 places and this is bad. Therfore option 2 was implemented
in this MR:
- The user enters a `force` command
- The UI sends  a `Seq` message to the `iserv` process.
- If processing of the `Seq` message hits a breakpoint,
  the `iserv` process returns control to the UI process.
- The UI looks up the source location of the breakpoint,
  and prints the enhanced `Ignoring breakpoint` output.
- The UI sends a `ResumeSeq` message to the `iserv` process,
  to continue forcing.
parent 04d30137
Pipeline #16357 passed with stages
in 369 minutes and 24 seconds
......@@ -142,14 +142,6 @@ getHistorySpan hsc_env History{..} =
Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
_ -> panic "getHistorySpan"
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
| Just linkable <- hm_linkable hmi,
[BCOs cbc _] <- linkableUnlinked linkable
= fromMaybe emptyModBreaks (bc_breaks cbc)
| otherwise
= emptyModBreaks -- probably object code
{- | Finds the enclosing top level function name -}
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
-- by the coverage pass, which gives the list of lexically-enclosing bindings
......
......@@ -30,6 +30,7 @@ import GhcPrelude
import GHC.Runtime.Interpreter as GHCi
import GHCi.RemoteTypes
import GHC.Driver.Types
import GHCi.Message ( fromSerializableException )
import DataCon
import Type
......@@ -59,6 +60,7 @@ import Outputable as Ppr
import GHC.Char
import GHC.Exts.Heap
import GHC.Runtime.Heap.Layout ( roundUpTo )
import GHC.IO (throwIO)
import Control.Monad
import Data.Maybe
......@@ -717,8 +719,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- Thunks we may want to force
t | isThunk t && force -> do
traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
liftIO $ GHCi.seqHValue hsc_env a
go (pred max_depth) my_ty old_ty a
evalRslt <- liftIO $ GHCi.seqHValue hsc_env a
case evalRslt of -- #2950
EvalSuccess _ -> go (pred max_depth) my_ty old_ty a
EvalException ex -> do
-- Report the exception to the UI
traceTR $ text "Exception occured:" <+> text (show ex)
liftIO $ throwIO $ fromSerializableException ex
-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If
-- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as
-- the suspension so that entering it in GHCi will enter the BLACKHOLE instead
......
......@@ -2,8 +2,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
--
-- | Interacting with the interpreter, whether it is running on an
-- | Interacting with the iserv interpreter, whether it is running on an
-- external process or in the current process.
--
module GHC.Runtime.Interpreter
......@@ -24,6 +23,7 @@ module GHC.Runtime.Interpreter
, breakpointStatus
, getBreakpointVar
, getClosure
, getModBreaks
, seqHValue
-- * The object-code linker
......@@ -70,6 +70,13 @@ import Exception
import BasicTypes
import FastString
import Util
import GHC.Runtime.Eval.Types(BreakInfo(..))
import Outputable(brackets, ppr, showSDocUnqual)
import SrcLoc
import Maybes
import Module
import GHC.ByteCode.Types
import Unique
import Control.Concurrent
import Control.Monad
......@@ -78,12 +85,12 @@ import Data.Binary
import Data.Binary.Put
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Array ((!))
import Data.IORef
import Foreign hiding (void)
import GHC.Exts.Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Exit
import Data.Maybe
import GHC.IO.Handle.Types (Handle)
#if defined(mingw32_HOST_OS)
import Foreign.C
......@@ -373,10 +380,45 @@ getClosure hsc_env ref =
mb <- iservCmd hsc_env (GetClosure hval)
mapM (mkFinalizedHValue hsc_env) mb
seqHValue :: HscEnv -> ForeignHValue -> IO ()
-- | Send a Seq message to the iserv process to force a value #2950
seqHValue :: HscEnv -> ForeignHValue -> IO (EvalResult ())
seqHValue hsc_env ref =
withForeignRef ref $ \hval ->
iservCmd hsc_env (Seq hval) >>= fromEvalResult
iservCmd hsc_env (Seq hval) >>= handleSeqHValueStatus hsc_env
-- | Process the result of a Seq or ResumeSeq message. #2950
handleSeqHValueStatus :: HscEnv -> EvalStatus () -> IO (EvalResult ())
handleSeqHValueStatus hsc_env eval_status = do
case eval_status of
(EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do
-- A breakpoint was hit, inform the user and tell him
-- which breakpoint was hit.
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
let hmi = expectJust "handleRunStatus" $
lookupHptDirectly (hsc_HPT hsc_env)
(mkUniqueGrimily mod_uniq)
modl = mi_module (hm_iface hmi)
bp | is_exception = Nothing
| otherwise = Just (BreakInfo modl ix)
sdocBpLoc = brackets . ppr . getSeqBpSpan
putStrLn ("*** Ignoring breakpoint " ++
(showSDocUnqual (hsc_dflags hsc_env) $ sdocBpLoc bp))
-- resume the seq (:force) processing in the iserv process
withForeignRef resume_ctxt_fhv $ \hval ->
iservCmd hsc_env (ResumeSeq hval) >>= handleSeqHValueStatus hsc_env
(EvalComplete _ r) -> return r
where
getSeqBpSpan :: Maybe BreakInfo -> SrcSpan
-- Just case: Stopped at a breakpoint, extract SrcSpan information
-- from the breakpoint.
getSeqBpSpan (Just BreakInfo{..}) =
(modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number
-- Nothing case - should not occur!
-- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")
breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $
lookupHpt (hsc_HPT hsc_env) (moduleName mod)
-- -----------------------------------------------------------------------------
-- Interface to the object-code linker
......@@ -676,3 +718,11 @@ mkEvalOpts dflags step =
fromEvalResult :: EvalResult a -> IO a
fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
fromEvalResult (EvalSuccess a) = return a
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
| Just linkable <- hm_linkable hmi,
[BCOs cbc _] <- linkableUnlinked linkable
= fromMaybe emptyModBreaks (bc_breaks cbc)
| otherwise
= emptyModBreaks -- probably object code
......@@ -215,7 +215,12 @@ data Message a where
-- | Evaluate something. This is used to support :force in GHCi.
Seq
:: HValueRef
-> Message (EvalResult ())
-> Message (EvalStatus ())
-- | Resume forcing a free variable in a breakpoint (#2950)
ResumeSeq
:: RemoteRef (ResumeContext ())
-> Message (EvalStatus ())
deriving instance Show (Message a)
......@@ -492,6 +497,7 @@ getMessage = do
35 -> Msg <$> (GetClosure <$> get)
36 -> Msg <$> (Seq <$> get)
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
putMessage :: Message a -> Put
......@@ -534,6 +540,7 @@ putMessage m = case m of
GetClosure a -> putWord8 35 >> put a
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
-- -----------------------------------------------------------------------------
-- Reading/writing messages
......
......@@ -95,7 +95,8 @@ run m = case m of
GetClosure ref -> do
clos <- getClosureData =<< localRef ref
mapM (\(Box x) -> mkRemoteRef (HValue x)) clos
Seq ref -> tryEval (void $ evaluate =<< localRef ref)
Seq ref -> doSeq ref
ResumeSeq ref -> resumeSeq ref
_other -> error "GHCi.Run.run"
evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
......@@ -130,6 +131,37 @@ evalStringToString r str = do
r <- (unsafeCoerce io :: String -> IO String) str
evaluate (force r)
-- | Process the Seq message to force a value. #2950
-- If during this processing a breakpoint is hit, return
-- an EvalBreak value in the EvalStatus to the UI process,
-- otherwise return an EvalComplete.
-- The UI process has more and therefore also can show more
-- information about the breakpoint than the current iserv
-- process.
doSeq :: RemoteRef a -> IO (EvalStatus ())
doSeq ref = do
sandboxIO evalOptsSeq $ do
_ <- (void $ evaluate =<< localRef ref)
return ()
-- | Process a ResumeSeq message. Continue the :force processing #2950
-- after a breakpoint.
resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())
resumeSeq hvref = do
ResumeContext{..} <- localRef hvref
withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $
mask_ $ do
putMVar resumeBreakMVar () -- this awakens the stopped thread...
redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
evalOptsSeq :: EvalOpts
evalOptsSeq = EvalOpts
{ useSandboxThread = True
, singleStep = False
, breakOnException = False
, breakOnError = False
}
-- 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
......
:l T2950M.hs
:br 4 19
:br 4 26
:br T2950S 3
main
:force _result
Breakpoint 0 activated at T2950M.hs:4:19-35
Breakpoint 1 activated at T2950M.hs:4:26-35
Breakpoint 2 activated at T2950S.hs:3:11-12
Stopped in Main.main, T2950M.hs:4:19-35
_result :: String = _
*** Ignoring breakpoint [T2950M.hs:4:19-35]
*** Ignoring breakpoint [T2950M.hs:4:26-35]
*** Ignoring breakpoint [T2950S.hs:3:11-12]
_result = "[2,6]"
import T2950S
main :: IO ()
main = putStrLn $ show $ sort [6,2]
module T2950S where
sort :: Ord a => [a] -> [a]
sort [] = []
sort (x:xs) = insert x (sort xs)
where
insert x [] = [x]
insert x (y:ys) | x < y = x:y:ys
| otherwise = y:(insert x ys)
......@@ -107,6 +107,7 @@ test('hist002', [extra_files(['../Test3.hs']), extra_run_opts('+RTS -I0')],
test('T1620', extra_files(['T1620/', 'T1620/T1620.hs']),
ghci_script, ['T1620.script'])
test('T2740', normal, ghci_script, ['T2740.script'])
test('T2950', normal, ghci_script, ['T2950.script'])
test('getargs', extra_files(['../getargs.hs']), ghci_script, ['getargs.script'])
test('T7386', normal, ghci_script, ['T7386.script'])
......
......@@ -15,5 +15,5 @@ Breakpoint 13 activated at HappyTest.hs:237:18-35
Stopped in Main.lexer, HappyTest.hs:228:11-19
_result :: Bool = _
c :: Char = '1'
*** Ignoring breakpoint
*** Ignoring breakpoint [HappyTest.hs:228:11-19]
_result = False
......@@ -3,9 +3,9 @@ Stopped in T17431.sort, T17431.hs:5:15-32
_result :: [a] = _
x :: a = _
xs :: [a] = [_,_]
*** Ignoring breakpoint
*** Ignoring breakpoint
*** Ignoring breakpoint
*** Ignoring breakpoint [T17431.hs:5:15-32]
*** Ignoring breakpoint [T17431.hs:5:15-32]
*** Ignoring breakpoint [T17431.hs:5:15-32]
x = 3
xs = [2,1]
_result = [1,2,3]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment