Skip to content

Commit 2e97d0f

Browse files
alt-romesalt-romes
committed
Refactor Debugger.Runtime.Threads to use new abstractions
Namely, the evaluation utils from Debugger.Runtime.Eval and the TermParser from Runtime.Term.Parser
1 parent bd4481d commit 2e97d0f

File tree

1 file changed

+68
-82
lines changed
  • haskell-debugger/GHC/Debugger/Runtime

1 file changed

+68
-82
lines changed

‎haskell-debugger/GHC/Debugger/Runtime/Thread.hs‎

Lines changed: 68 additions & 82 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE OrPatterns #-}
12
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE ViewPatterns #-}
34
-- |
@@ -12,100 +13,89 @@ module GHC.Debugger.Runtime.Thread
1213
) where
1314

1415
import Data.Maybe
16+
import Data.Functor
17+
import Control.Applicative
1518
import Control.Concurrent
16-
import Control.Exception
1719
import Control.Monad
1820
import Control.Monad.IO.Class
1921
import Control.Monad.Reader
2022
import Data.IORef
23+
import GHC.Conc.Sync
2124

2225
import GHC
23-
import GHC.Core.DataCon
24-
import GHC.Types.Name
2526
import GHC.Builtin.Types
2627
import GHC.Runtime.Heap.Inspect
2728

2829
import GHC.Driver.Config
2930
import GHC.Driver.Env
3031
import GHC.Runtime.Interpreter as Interp
32+
import GHC.Utils.Outputable
3133

3234
import GHCi.Message
3335
import GHCi.RemoteTypes
3436

37+
import GHC.Debugger.Logger as Logger
3538
import GHC.Debugger.Monad
3639
import GHC.Debugger.Interface.Messages
40+
import GHC.Debugger.Runtime.Term.Parser
3741
import GHC.Debugger.Runtime.Thread.Map
42+
import GHC.Debugger.Runtime.Eval
3843

3944
-- | Get a 'RemoteThreadId' from a remote 'ResumeContext' gotten from an 'ExecBreak'
4045
getRemoteThreadIdFromRemoteContext :: ForeignRef (ResumeContext [HValueRef]) -> Debugger RemoteThreadId
4146
getRemoteThreadIdFromRemoteContext fctxt = do
42-
hsc_env <- getSession
43-
4447
-- Get the ResumeContext term and fetch the resumeContextThreadId field
45-
liftIO (cvObtainTerm hsc_env 2 True anyTy (castForeignRef fctxt)) >>= \case
46-
Term{subTerms=[_mvar1, _mvar2, threadIdTerm@Term{}]} -> do
47-
48-
getRemoteThreadId (castForeignRef (val threadIdTerm))
49-
50-
_ -> error "Expecting ResumeContext term!!"
51-
48+
parsed_threadid <- obtainParsedTerm "RemoteContext's ThreadId" 2 True anyTy (castForeignRef fctxt)
49+
(subtermWith 2{-RemoteContext's ThreadId-} anyTerm)
50+
case parsed_threadid of
51+
Left errs -> do
52+
logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))
53+
liftIO $ fail "Failed to parse remote ResumeContext's thread id"
54+
Right Term{val=threadIdVal} -> do
55+
getRemoteThreadId (castForeignRef threadIdVal)
56+
_ -> liftIO $ fail "Expected threadIdTerm to be a Term!"
5257

5358
getRemoteThreadId :: ForeignRef ThreadId -> Debugger RemoteThreadId
5459
getRemoteThreadId threadIdRef = do
55-
hsc_env <- getSession
60+
from_thread_id_fv <- compileExprRemote "GHC.Conc.Sync.fromThreadId"
61+
thread_id_fv <- evalApplication from_thread_id_fv (castForeignRef threadIdRef)
5662

57-
-- evalStmt takes an IO [a] and evals it into a [ForeignHValue]
58-
from_thread_id_fv <- compileExprRemote "(pure @IO . (:[]) . GHC.Conc.Sync.fromThreadId)"
63+
parsed_int <-
64+
obtainParsedTerm "ThreadId's Int value" 2 True wordTy{-really, Word64, but we won't look at the type-} thread_id_fv intParser
5965

60-
let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
61-
interp = hscInterp hsc_env
66+
case parsed_int of
67+
Left errs -> do
68+
logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))
69+
liftIO $ fail "Failed to parse remote thread id on fromThreadId result!"
70+
Right tid_int -> do
6271

63-
handleSingleStatus [func_fv] = return func_fv
64-
handleSingleStatus l = fail $
65-
"Unexpected result when loading \"fromThreadId\" function (" ++ show (length l) ++ ")"
72+
tmap_ref <- asks threadMap
73+
-- unconditionally write to the map the foreign ref (it should always
74+
-- refer to the same ThreadId as a possible existing entry)
75+
liftIO $ modifyIORef' tmap_ref $
76+
insertThreadMap tid_int threadIdRef
6677

67-
r_term <- liftIO $
68-
cvObtainTerm hsc_env 2 True wordTy{-really, Word64, but we won't look at the type-}
69-
=<< handleSingleStatus =<< handleStatus hsc_env =<<
70-
evalStmt interp eval_opts
71-
(EvalApp (EvalThis from_thread_id_fv) (EvalThis (castForeignRef threadIdRef)))
72-
73-
case r_term of
74-
Term{subTerms=[Prim{valRaw=[w64_tid]}]} -> do
75-
76-
let i_tid = fromIntegral w64_tid :: Int
77-
78-
tmap_ref <- asks threadMap
79-
-- unconditionally write to the map the foreign ref (it should always
80-
-- refer to the same ThreadId as a possible existing entry)
81-
liftIO $ modifyIORef' tmap_ref $
82-
insertThreadMap i_tid threadIdRef
83-
84-
return (RemoteThreadId i_tid)
85-
_ -> liftIO $ fail $ "Unexpected term result from \"fromThreadId\""
78+
return (RemoteThreadId tid_int)
8679

8780
-- | Is the remote thread running or blocked (NOT finished NOR dead)?
88-
isRemoteThreadLive :: ForeignRef ThreadId -> Debugger Bool
89-
isRemoteThreadLive threadIdRef = do
90-
hsc_env <- getSession
81+
getRemoteThreadStatus :: ForeignRef ThreadId -> Debugger ThreadStatus
82+
getRemoteThreadStatus threadIdRef = do
83+
thread_status_fv <- compileExprRemote "GHC.Conc.Sync.threadStatus"
9184

92-
thread_status_fv <- compileExprRemote "fmap (:[]) . GHC.Conc.Sync.threadStatus"
85+
status_fv <- evalApplicationIO thread_status_fv (castForeignRef threadIdRef)
86+
status_parsed <- obtainParsedTerm "ThreadStatus" 2 True anyTy{-..no..-} status_fv threadStatusParser
9387

94-
let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
95-
interp = hscInterp hsc_env
96-
97-
liftIO $ evalStmt interp eval_opts
98-
(EvalApp (EvalThis thread_status_fv) (EvalThis (castForeignRef threadIdRef)))
99-
>>= handleStatus hsc_env >>= \case
100-
[status_fv] -> do
101-
status_term <- cvObtainTerm hsc_env 2 True anyTy{-..no..-} status_fv
102-
case status_term of
103-
Term{dc=Left dc} -> return $ dc == "ThreadRunning" || dc == "ThreadBlocked"
104-
Term{dc=Right (occNameString . nameOccName . dataConName -> dc)}
105-
-> return $ dc == "ThreadRunning" || dc == "ThreadBlocked"
106-
_ -> return False
107-
_ -> fail "Unexpected result from evaluating \"threadLabel\""
88+
case status_parsed of
89+
Left errs -> do
90+
logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))
91+
liftIO $ fail "Failed to parse ThreadStatus"
92+
Right thrdStatus ->
93+
return thrdStatus
10894

95+
isRemoteThreadLive :: ForeignRef ThreadId -> Debugger Bool
96+
isRemoteThreadLive r = getRemoteThreadStatus r <&> \case
97+
(ThreadRunning ; ThreadBlocked{}) -> True
98+
(ThreadDied ; ThreadFinished) -> False
10999

110100
-- | Call 'listThreads' on the (possibly) remote debuggee process to get the
111101
-- list of threads running on the debuggee. Filter by running threads
@@ -114,20 +104,18 @@ listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ForeignRef ThreadId)]
114104
listAllLiveRemoteThreads = do
115105
hsc_env <- getSession
116106

117-
-- evalStmt will take this IO [ThreadId] and eval it to [ForeignHValue]
118107
list_threads_fv <- compileExprRemote "GHC.Conc.Sync.listThreads"
119108

120109
let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
121110
interp = hscInterp hsc_env
122111

123112
liftIO (evalStmt interp eval_opts (EvalThis list_threads_fv))
124-
>>= liftIO . handleStatus hsc_env >>= \case
113+
>>= liftIO . handleMultiStatus >>= \case
125114
threads_fvs -> catMaybes <$> do
126115

127116
forM threads_fvs $ \(castForeignRef -> thread_fv) -> do
128117
isLive <- isRemoteThreadLive thread_fv
129118
if isLive then do
130-
-- TODO: awful to compile the expression to get the remote id every single time...
131119
tid <- getRemoteThreadId thread_fv
132120
pure $ Just (tid, thread_fv)
133121
else do
@@ -150,7 +138,7 @@ getRemoteThreadsLabels threadIdRefs = do
150138
forM threadIdRefs $ \threadIdRef -> liftIO $
151139
evalStmt interp eval_opts
152140
(EvalApp (EvalThis thread_label_fv) (EvalThis (castForeignRef threadIdRef)))
153-
>>= handleStatus hsc_env >>= \case
141+
>>= handleMultiStatus >>= \case
154142
[] -> pure Nothing
155143
[io_lbl_fv] -> Just <$> evalString interp io_lbl_fv
156144
_ -> fail "Unexpected result from evaluating \"threadLabel\""
@@ -160,35 +148,33 @@ getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger Term
160148
getRemoteThreadStackCopy threadIdRef = do
161149
hsc_env <- getSession
162150

163-
-- evalStmt takes an IO [a] and evals it into a [ForeignHValue]. Represent the Maybe as an empty list
164-
thread_stack_fv <- compileExprRemote "fmap (:[]) . GHC.Exts.Stack.decodeStack Control.Monad.<=< GHC.Stack.CloneStack.cloneThreadStack"
151+
thread_stack_fv <- compileExprRemote "GHC.Exts.Stack.decodeStack Control.Monad.<=< GHC.Stack.CloneStack.cloneThreadStack"
165152

166153
-- TODO: Currently, GHC.Stack.CloneStack.decode, which uses the IPE
167154
-- information to report source locations of the callstacks, does not work
168155
-- for a stack with interpreter return frames. We would probably also like to
169156
-- use that.
170157

171-
let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
172-
interp = hscInterp hsc_env
158+
stack_frames_fv <- evalApplicationIO thread_stack_fv (castForeignRef threadIdRef)
173159

174-
liftIO $ evalStmt interp eval_opts
175-
(EvalApp (EvalThis thread_stack_fv) (EvalThis (castForeignRef threadIdRef)))
176-
>>= handleStatus hsc_env >>= \case
177-
[stack_frames_fv] ->
178-
cvObtainTerm hsc_env 2 True anyTy{-todo:stackframety-} stack_frames_fv
179-
_ -> fail "Unexpected result from evaluating \"threadLabel\""
160+
liftIO $ cvObtainTerm hsc_env 2 True anyTy{-todo:stackframety-} stack_frames_fv
180161

181162
--------------------------------------------------------------------------------
182-
-- * Utilities
163+
-- * TermParsers
183164
--------------------------------------------------------------------------------
184165

185-
handleStatus :: HscEnv -> EvalStatus_ [ForeignHValue] [HValueRef] -> IO [ForeignHValue]
186-
handleStatus hsc_env (EvalBreak _ _ resume_ctxt _) = do
187-
let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
188-
interp = hscInterp hsc_env
189-
resume_ctxt_fhv <- mkFinalizedHValue interp resume_ctxt
190-
handleStatus hsc_env =<< Interp.resumeStmt interp eval_opts resume_ctxt_fhv
191-
handleStatus _ (EvalComplete _ (GHCi.Message.EvalException e)) =
192-
throwIO (fromSerializableException e)
193-
handleStatus _ (EvalComplete _ (EvalSuccess ls)) =
194-
return ls
166+
threadStatusParser :: TermParser ThreadStatus
167+
threadStatusParser = do
168+
(matchConstructorTerm "ThreadRunning" $> ThreadRunning)
169+
<|> (matchConstructorTerm "ThreadFinished" $> ThreadFinished)
170+
<|> (matchConstructorTerm "ThreadDied" $> ThreadDied)
171+
<|> (matchConstructorTerm "ThreadBlocked" *> (ThreadBlocked <$> subtermWith 0 blockedReasonParser))
172+
173+
blockedReasonParser :: TermParser BlockReason
174+
blockedReasonParser = do
175+
(matchConstructorTerm "BlockedOnMVar" $> BlockedOnMVar)
176+
<|> (matchConstructorTerm "BlockedOnBlackHole" $> BlockedOnBlackHole)
177+
<|> (matchConstructorTerm "BlockedOnException" $> BlockedOnException)
178+
<|> (matchConstructorTerm "BlockedOnSTM" $> BlockedOnSTM)
179+
<|> (matchConstructorTerm "BlockedOnForeignCall" $> BlockedOnForeignCall)
180+
<|> (matchConstructorTerm "BlockedOnOther" $> BlockedOnOther)

0 commit comments

Comments
 (0)