summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Runtime/Eval.hs8
-rw-r--r--compiler/GHC/Runtime/Heap/Inspect.hs11
-rw-r--r--compiler/GHC/Runtime/Interpreter.hs60
-rw-r--r--libraries/ghci/GHCi/Message.hs9
-rw-r--r--libraries/ghci/GHCi/Run.hs34
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T2950.script6
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T2950.stdout9
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T2950M.hs4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T2950S.hs8
-rw-r--r--testsuite/tests/ghci.debugger/scripts/all.T1
-rw-r--r--testsuite/tests/ghci.debugger/scripts/print020.stdout2
-rw-r--r--testsuite/tests/ghci/scripts/T17431.stdout6
12 files changed, 137 insertions, 21 deletions
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 7b5962e6bf..51acffec11 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -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
diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs
index 7842afcc5d..c9905b5801 100644
--- a/compiler/GHC/Runtime/Heap/Inspect.hs
+++ b/compiler/GHC/Runtime/Heap/Inspect.hs
@@ -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
diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index 3eb9c85a01..7f0df55b05 100644
--- a/compiler/GHC/Runtime/Interpreter.hs
+++ b/compiler/GHC/Runtime/Interpreter.hs
@@ -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
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 70c532fc94..7e96601b99 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -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
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index a931e620cc..37dc7f2f48 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -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
diff --git a/testsuite/tests/ghci.debugger/scripts/T2950.script b/testsuite/tests/ghci.debugger/scripts/T2950.script
new file mode 100644
index 0000000000..bf10ed0d14
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T2950.script
@@ -0,0 +1,6 @@
+:l T2950M.hs
+:br 4 19
+:br 4 26
+:br T2950S 3
+main
+:force _result
diff --git a/testsuite/tests/ghci.debugger/scripts/T2950.stdout b/testsuite/tests/ghci.debugger/scripts/T2950.stdout
new file mode 100644
index 0000000000..d2401849e5
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T2950.stdout
@@ -0,0 +1,9 @@
+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]"
diff --git a/testsuite/tests/ghci.debugger/scripts/T2950M.hs b/testsuite/tests/ghci.debugger/scripts/T2950M.hs
new file mode 100644
index 0000000000..fa49cda119
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T2950M.hs
@@ -0,0 +1,4 @@
+import T2950S
+
+main :: IO ()
+main = putStrLn $ show $ sort [6,2]
diff --git a/testsuite/tests/ghci.debugger/scripts/T2950S.hs b/testsuite/tests/ghci.debugger/scripts/T2950S.hs
new file mode 100644
index 0000000000..0685381f9f
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T2950S.hs
@@ -0,0 +1,8 @@
+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)
diff --git a/testsuite/tests/ghci.debugger/scripts/all.T b/testsuite/tests/ghci.debugger/scripts/all.T
index d38b3681ad..24939a942e 100644
--- a/testsuite/tests/ghci.debugger/scripts/all.T
+++ b/testsuite/tests/ghci.debugger/scripts/all.T
@@ -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'])
diff --git a/testsuite/tests/ghci.debugger/scripts/print020.stdout b/testsuite/tests/ghci.debugger/scripts/print020.stdout
index 991ed11c67..3614846f92 100644
--- a/testsuite/tests/ghci.debugger/scripts/print020.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/print020.stdout
@@ -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
diff --git a/testsuite/tests/ghci/scripts/T17431.stdout b/testsuite/tests/ghci/scripts/T17431.stdout
index e6fa548b1a..6879177c62 100644
--- a/testsuite/tests/ghci/scripts/T17431.stdout
+++ b/testsuite/tests/ghci/scripts/T17431.stdout
@@ -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]
View Lorry Controller Status