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.

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]