Skip to content

Commit 7075f48

Browse files
csabahruskadmjio
csabahruska
and
dmjio
authored
Breakpoint support (#8)
* support serializable concurrency for Adaptor state monad * allow application domain specific state updates * update wpc dep * implement async breakpoint and stopped event handling * Update registerDebugSession event handler thread to take callback function. (#9) - Relocate 'runAdaptorWith' to Adaptor.hs - Add some comments for 'registerDebugSession' --------- Co-authored-by: David Johnson <djohnson.m@gmail.com>
1 parent 3e5dea6 commit 7075f48

File tree

5 files changed

+168
-92
lines changed

5 files changed

+168
-92
lines changed

‎dap/exe/Main.hs

Lines changed: 79 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -25,28 +25,34 @@ import Data.List
2525
import Data.String.Conversions (cs)
2626
import Text.PrettyPrint.ANSI.Leijen (pretty, plain)
2727
import Codec.Archive.Zip (withArchive, unEntrySelector, getEntries)
28+
import Data.IntSet ( IntSet )
29+
import qualified Data.IntSet as IntSet
2830
import qualified Data.Set as Set
2931
import Control.Arrow
3032
import Data.IORef
3133
import Control.Exception hiding (catch)
3234
import Control.Monad.IO.Class (liftIO)
3335
import Control.Exception.Lifted (catch)
36+
import Control.Monad.State.Strict ( gets )
3437
import Control.Monad
3538
import Data.Aeson ( Value(Null), FromJSON )
3639
import qualified Data.IntMap.Strict as I
3740
import qualified Data.Map.Strict as M
41+
import Data.Map.Strict ( Map )
3842
import qualified Data.Text.Encoding as T
3943
import Data.Text ( Text )
4044
import qualified Data.Text as T
4145
import Data.Typeable ( typeOf )
42-
import Data.Maybe ( fromMaybe )
46+
import Data.Maybe ( fromMaybe, catMaybes )
4347
import Data.List ( sortOn )
4448
import GHC.Generics ( Generic )
4549
import System.Environment ( lookupEnv )
4650
import System.FilePath ((</>), takeDirectory, takeExtension, dropExtension, splitFileName)
4751
import Text.Read ( readMaybe )
4852
import qualified Data.ByteString.Lazy.Char8 as BL8 ( pack, unpack, fromStrict, toStrict )
4953
import qualified Control.Concurrent.Chan.Unagi.Bounded as Unagi
54+
import Control.Concurrent.MVar ( MVar )
55+
import qualified Control.Concurrent.MVar as MVar
5056
----------------------------------------------------------------------------
5157
import Stg.Syntax hiding (sourceName, Scope)
5258
import Stg.IRLocation
@@ -105,26 +111,62 @@ data AttachArgs
105111
-- | External STG Interpreter application internal state
106112
data ESTG
107113
= ESTG
108-
{ inChan :: Unagi.InChan DebugCommand
109-
, outChan :: Unagi.OutChan DebugOutput
110-
, fullPakPath :: String
114+
{ debuggerChan :: DebuggerChan
115+
, fullPakPath :: String
116+
, breakpointMap :: Map StgPoint IntSet
111117
}
112118
----------------------------------------------------------------------------
113119
-- | Intialize ESTG interpreter
114120
----------------------------------------------------------------------------
115121
initESTG :: AttachArgs -> Adaptor ESTG ()
116122
initESTG AttachArgs {..} = do
117-
(dbgCmdI, dbgCmdO) <- liftIO (Unagi.newChan 100)
118-
(dbgOutI, dbgOutO) <- liftIO (Unagi.newChan 100)
119-
let dbgChan = DebuggerChan (dbgCmdO, dbgOutI)
123+
(dbgAsyncI, dbgAsyncO) <- liftIO (Unagi.newChan 100)
124+
dbgRequestMVar <- liftIO MVar.newEmptyMVar
125+
dbgResponseMVar <- liftIO MVar.newEmptyMVar
126+
let dbgChan = DebuggerChan
127+
{ dbgSyncRequest = dbgRequestMVar
128+
, dbgSyncResponse = dbgResponseMVar
129+
, dbgAsyncEventIn = dbgAsyncI
130+
, dbgAsyncEventOut = dbgAsyncO
131+
}
132+
estg = ESTG
133+
{ debuggerChan = dbgChan
134+
, fullPakPath = program
135+
, breakpointMap = mempty
136+
}
120137
flip catch handleDebuggerExceptions
121-
$ registerNewDebugSession __sessionId (ESTG dbgCmdI dbgOutO program)
122-
(liftIO $ loadAndRunProgram True True program [] dbgChan DbgStepByStep False defaultDebugSettings)
123-
(pure ())
124-
-- (forever $ do
125-
-- message <- liftIO (Unagi.readChan dbgOutO)
126-
-- -- logic goes here for conversion to 'OutputEvent'
127-
-- sendOutputEvent defaultOutputEvent)
138+
$ registerNewDebugSession __sessionId estg
139+
(loadAndRunProgram True True program [] dbgChan DbgStepByStep False defaultDebugSettings)
140+
(handleDebugEvents dbgChan)
141+
142+
----------------------------------------------------------------------------
143+
-- | Debug Event Handler
144+
handleDebugEvents :: DebuggerChan -> (Adaptor ESTG () -> IO ()) -> IO ()
145+
handleDebugEvents DebuggerChan{..} withAdaptor = forever $ do
146+
dbgEvent <- liftIO (Unagi.readChan dbgAsyncEventOut)
147+
withAdaptor $ do
148+
ESTG {..} <- getDebugSession
149+
let sendEvent ev = sendSuccesfulEvent ev . setBody
150+
case dbgEvent of
151+
DbgEventStopped -> do
152+
resetObjectLifetimes
153+
sendEvent EventTypeStopped $ object
154+
[ "reason" .= String "step"
155+
, "allThreadsStopped" .= True
156+
]
157+
158+
DbgEventHitBreakpoint bkpName -> do
159+
resetObjectLifetimes
160+
sendEvent EventTypeStopped . object $
161+
[ "reason" .= String "breakpoint"
162+
, "allThreadsStopped" .= True
163+
] ++
164+
catMaybes
165+
[ do
166+
idSet <- M.lookup (SP_RhsClosureExpr bkpName) breakpointMap
167+
Just ("hitBreakpointIds" .= idSet)
168+
]
169+
128170
----------------------------------------------------------------------------
129171
-- | Exception Handler
130172
handleDebuggerExceptions :: SomeException -> Adaptor ESTG ()
@@ -136,17 +178,6 @@ handleDebuggerExceptions e = do
136178
sendTerminatedEvent (TerminatedEvent False)
137179
sendExitedEvent (ExitedEvent 1)
138180

139-
sendStop =
140-
sendStoppedEvent $
141-
StoppedEvent
142-
StoppedEventReasonPause
143-
(Just "paused")
144-
(Just 0)
145-
False
146-
(Just "starting now?")
147-
False
148-
[]
149-
150181
pathToName path =
151182
case splitFileName (cs path) of
152183
(init -> moduleName, takeExtension -> ".ghccore") ->
@@ -156,6 +187,20 @@ pathToName path =
156187
(init -> moduleName, takeExtension -> ext) ->
157188
cs (moduleName <> ext)
158189

190+
----------------------------------------------------------------------------
191+
-- | Clears the currently known breakpoint set
192+
clearBreakpoints :: Adaptor ESTG ()
193+
clearBreakpoints = do
194+
updateDebugSession $ \estg -> estg {breakpointMap = mempty}
195+
196+
----------------------------------------------------------------------------
197+
-- | Adds new BreakpointId for a givent StgPoint
198+
addNewBreakpoint :: StgPoint -> Adaptor ESTG BreakpointId
199+
addNewBreakpoint stgPoint = do
200+
bkpId <- getNextBreakpointId
201+
updateDebugSession $ \estg@ESTG{..} -> estg {breakpointMap = M.insertWith mappend stgPoint (IntSet.singleton bkpId) breakpointMap}
202+
pure bkpId
203+
159204
----------------------------------------------------------------------------
160205
-- | Main function where requests are received and Events + Responses are returned.
161206
-- The core logic of communicating between the client <-> adaptor <-> debugger
@@ -173,32 +218,12 @@ talk CommandAttach = do
173218
----------------------------------------------------------------------------
174219
talk CommandContinue = do
175220
ESTG {..} <- getDebugSession
176-
send CmdContinue
221+
sendAndWait CmdContinue
177222
sendContinueResponse (ContinueResponse True)
178223

179-
ESTG {..} <- getDebugSession
180-
_ <- liftIO $ Unagi.readChan outChan
181-
resetObjectLifetimes
182-
sendStoppedEvent defaultStoppedEvent
183-
{ stoppedEventReason = StoppedEventReasonBreakpoint
184-
, stoppedEventThreadId = Just 0
185-
}
186-
{-
187-
data StoppedEvent
188-
= StoppedEvent
189-
{ stoppedEventReason :: StoppedEventReason
190-
, stoppedEventDescription :: Maybe Text
191-
, stoppedEventThreadId :: Maybe Int
192-
, stoppedEventPreserveFocusHint :: Bool
193-
, stoppedEventText :: Maybe Text
194-
, stoppedEventAllThreadsStopped :: Bool
195-
, stoppedEventHitBreakpointIds :: [Int]
196-
-}
197-
198224
----------------------------------------------------------------------------
199225
talk CommandConfigurationDone = do
200226
sendConfigurationDoneResponse
201-
sendStop
202227
----------------------------------------------------------------------------
203228
talk CommandDisconnect = do
204229
destroyDebugSession
@@ -326,6 +351,7 @@ talk CommandPause = sendPauseResponse
326351
talk CommandSetBreakpoints = do
327352
SetBreakpointsArguments {..} <- getArguments
328353
let maybeSourceRef = sourceSourceReference setBreakpointsArgumentsSource
354+
clearBreakpoints
329355
case (setBreakpointsArgumentsBreakpoints, maybeSourceRef) of
330356
(Just sourceBreakpoints, Just sourceRef) -> do
331357
(_sourceCodeText, locations) <- getSourceFromFullPak sourceRef
@@ -357,14 +383,16 @@ talk CommandSetBreakpoints = do
357383
case sortOn snd relevantLocations of
358384
(stgPoint@(SP_RhsClosureExpr closureName), ((startRow, startCol), (endRow, endCol))) : _ -> do
359385
let hitCount = fromMaybe 0 (sourceBreakpointHitCondition >>= readMaybe . T.unpack) :: Int
360-
send (CmdAddBreakpoint closureName hitCount)
386+
sendAndWait (CmdAddBreakpoint closureName hitCount)
387+
bkpId <- addNewBreakpoint stgPoint
361388
pure $ defaultBreakpoint
362389
{ breakpointVerified = True
363390
, breakpointSource = Just setBreakpointsArgumentsSource
364391
, breakpointLine = Just startRow
365392
, breakpointColumn = Just startCol
366393
, breakpointEndLine = Just endRow
367394
, breakpointEndColumn = Just endCol
395+
, breakpointId = Just bkpId
368396
}
369397
_ ->
370398
pure $ defaultBreakpoint
@@ -429,12 +457,7 @@ talk CommandVariables = do
429457
talk CommandNext = do
430458
NextArguments {..} <- getArguments
431459
sendAndWait CmdStep
432-
resetObjectLifetimes
433-
sendStoppedEvent defaultStoppedEvent
434-
{ stoppedEventReason = StoppedEventReasonStep
435-
, stoppedEventText = Just "Stepping..."
436-
, stoppedEventThreadId = Just 0
437-
}
460+
pure ()
438461
----------------------------------------------------------------------------
439462
talk CommandBreakpointLocations = sendBreakpointLocationsResponse []
440463
talk CommandSetDataBreakpoints = sendSetDataBreakpointsResponse []
@@ -508,21 +531,14 @@ getSourceFromFullPak sourceId = do
508531
ir <- readModpakS fullPakPath sourcePath T.decodeUtf8
509532
pure (ir, [])
510533
----------------------------------------------------------------------------
511-
-- | Asynchronous call to Debugger, sends message, does not wait for response
512-
send
513-
:: DebugCommand
514-
-> Adaptor ESTG ()
515-
send cmd = do
516-
ESTG {..} <- getDebugSession
517-
liftIO (Unagi.writeChan inChan cmd)
518-
----------------------------------------------------------------------------
519534
-- | Synchronous call to Debugger, sends message and waits for response
520535
sendAndWait :: DebugCommand -> Adaptor ESTG DebugOutput
521536
sendAndWait cmd = do
522537
ESTG {..} <- getDebugSession
538+
let DebuggerChan{..} = debuggerChan
523539
liftIO $ do
524-
Unagi.writeChan inChan cmd
525-
Unagi.readChan outChan
540+
MVar.putMVar dbgSyncRequest cmd
541+
MVar.takeMVar dbgSyncResponse
526542
----------------------------------------------------------------------------
527543
-- | Receive Thread Report
528544
-- Fails if anything but 'DbgOutThreadReport' is returned

‎dap/src/DAP/Adaptor.hs

Lines changed: 56 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ module DAP.Adaptor
3333
, getRequestSeqNum
3434
-- * Debug Session
3535
, registerNewDebugSession
36+
, updateDebugSession
3637
, getDebugSession
3738
, getDebugSessionId
3839
, destroyDebugSession
@@ -63,28 +64,38 @@ module DAP.Adaptor
6364
, setCurrentVariableId
6465
, getCurrentVariableId
6566
, getNextVariableId
67+
-- * Breakpoint handling
68+
, getNextBreakpointId
6669
-- * Source handling
6770
, getNextSourceReferenceId
6871
, getSourcePathBySourceReferenceId
6972
, addSourcePathBySourceReferenceId
7073
-- * Internal use
7174
, send
7275
, sendRaw
76+
-- * Internal function used to execute actions on behalf of the DAP server
77+
-- from child threads (useful for handling asynchronous debugger events).
78+
, runAdaptorWith
7379
) where
7480
----------------------------------------------------------------------------
7581
import Control.Concurrent ( ThreadId )
82+
import Control.Concurrent.MVar ( newMVar, newEmptyMVar, modifyMVar_
83+
, takeMVar, putMVar, readMVar, MVar )
7684
import Control.Concurrent.Lifted ( fork, killThread )
7785
import Control.Exception ( throwIO )
7886
import Control.Concurrent.STM ( atomically, readTVarIO, modifyTVar' )
7987
import Control.Monad ( when, unless )
80-
import Control.Monad.Except ( throwError )
81-
import Control.Monad.State.Strict ( MonadIO(liftIO), gets, modify', put )
88+
import Control.Monad.Except ( runExceptT, throwError )
89+
import Control.Monad.State ( evalStateT, runStateT, execStateT, gets
90+
, MonadIO(liftIO), gets, modify', put )
8291
import Data.Aeson ( FromJSON, Result (..), fromJSON )
8392
import Data.Maybe ( fromMaybe )
8493
import Data.Aeson.Encode.Pretty ( encodePretty )
8594
import Data.Aeson.Types ( object, Key, KeyValue((.=)), ToJSON )
8695
import qualified Data.IntMap.Strict as I
8796
import Data.IntMap.Strict (IntMap)
97+
import qualified Data.IntSet as IntSet
98+
import Data.IntSet (IntSet)
8899
import Data.Text ( unpack, Text, pack )
89100
import Network.Socket ( SockAddr )
90101
import System.IO ( Handle )
@@ -171,24 +182,42 @@ setDebugSessionId session = modify' $ \s -> s { sessionId = Just session }
171182
registerNewDebugSession
172183
:: SessionId
173184
-> app
174-
-> Adaptor app ()
185+
-> IO ()
175186
-- ^ Action to run debugger (operates in a forked thread that gets killed when disconnect is set)
176-
-> Adaptor app ()
187+
-> ((Adaptor app () -> IO ()) -> IO ())
177188
-- ^ Long running operation, meant to be used as a sink for
178189
-- the debugger to emit events and for the adaptor to forward to the editor
179190
-- This function should be in a 'forever' loop waiting on the read end of
180191
-- a debugger channel.
192+
--
193+
-- This event handler thread also takes an argument that allows any child thread to execute
194+
-- events on behalf of the DAP server (in 'Adaptor app ()'). This function should always be
195+
-- used when sending events to the editor from the debugger (or from any forked thread).
196+
--
197+
-- >
198+
-- > registerNewDebugSession sessionId appState loadDebugger $ \withAdaptor ->
199+
-- > forever $ getDebuggerOutput >>= \output -> do
200+
-- > withAdaptor $ sendOutputEvent defaultOutputEvent { outputEventOutput = output }
201+
-- >
202+
--
181203
-> Adaptor app ()
182204
registerNewDebugSession k v debuggerExecution outputEventSink = do
183205
store <- gets appStore
184-
debuggerThreadState <-
206+
adaptorStateMVar <- gets adaptorStateMVar
207+
debuggerThreadState <- liftIO $
185208
DebuggerThreadState
186-
<$> fork (resetAdaptorStatePayload >> debuggerExecution)
187-
<*> fork (resetAdaptorStatePayload >> outputEventSink)
209+
<$> fork debuggerExecution
210+
<*> fork (outputEventSink (runAdaptorWith adaptorStateMVar))
188211
liftIO . atomically $ modifyTVar' store (H.insert k (debuggerThreadState, v))
189212
setDebugSessionId k
190213
logInfo $ BL8.pack $ "Registered new debug session: " <> unpack k
191214
----------------------------------------------------------------------------
215+
updateDebugSession :: (app -> app) -> Adaptor app ()
216+
updateDebugSession updateFun = do
217+
sessionId <- getDebugSessionId
218+
store <- gets appStore
219+
liftIO . atomically $ modifyTVar' store (H.adjust (fmap updateFun) sessionId)
220+
----------------------------------------------------------------------------
192221
getDebugSession :: Adaptor a a
193222
getDebugSession = do
194223
(_, _, app) <- getDebugSessionWithThreadIdAndSessionId
@@ -494,6 +523,11 @@ getNextVariableId = do
494523
modify' $ \s -> s { currentVariableId = currentVariableId s + 1 }
495524
gets currentVariableId
496525

526+
getNextBreakpointId :: Adaptor app BreakpointId
527+
getNextBreakpointId = do
528+
modify' $ \s -> s { currentBreakpointId = currentBreakpointId s + 1 }
529+
gets currentBreakpointId
530+
497531
getNextSourceReferenceId :: Adaptor app SourceId
498532
getNextSourceReferenceId = do
499533
modify' $ \s -> s { currentSourceReferenceId = currentSourceReferenceId s + 1 }
@@ -517,3 +551,18 @@ addSourcePathBySourceReferenceId path sourceId =
517551
modify' $ \s -> s
518552
{ sourceReferencesMap = I.insert sourceId path (sourceReferencesMap s)
519553
}
554+
555+
----------------------------------------------------------------------------
556+
-- | Evaluates Adaptor action by using and updating the state in the MVar
557+
runAdaptorWith :: MVar (AdaptorState app) -> Adaptor app () -> IO ()
558+
runAdaptorWith adaptorStateMVar action = do
559+
modifyMVar_ adaptorStateMVar (flip runAdaptor (resetAdaptorStatePayload >> action))
560+
561+
----------------------------------------------------------------------------
562+
-- | Utility for evaluating a monad transformer stack
563+
runAdaptor :: AdaptorState app -> Adaptor app () -> IO (AdaptorState app)
564+
runAdaptor adaptorState (Adaptor client) =
565+
runStateT (runExceptT client) adaptorState >>= \case
566+
(Left (errorMessage, maybeMessage), nextState) ->
567+
runAdaptor nextState (sendErrorResponse errorMessage maybeMessage)
568+
(Right (), nextState) -> pure nextState

0 commit comments

Comments
 (0)