all debug command return result

Author: csabahruska

external-stg-interpreter/lib/Stg/Interpreter/Base.hs

@@ -223,8 +223,8 @@ instance Show (PrintableMVar a) where
 
 data DebuggerChan
   = DebuggerChan
-  { dbgSyncRequest    :: MVar DebugRequest
-  , dbgSyncResponse   :: MVar DebugResponse
+  { dbgSyncRequest    :: MVar DebugCommand
+  , dbgSyncResponse   :: MVar DebugOutput
   , dbgAsyncEventIn   :: InChan DebugEvent
   , dbgAsyncEventOut  :: OutChan DebugEvent
   }
@@ -233,9 +233,10 @@ data DebuggerChan
 instance Show DebuggerChan where
   show _ = "DebuggerChan"
 
-type DebugRequest = DebugCommand
-type DebugResponse = DebugOutput
-type DebugEvent = DebugOutput
+data DebugEvent
+  = DbgEventHitBreakpoint !Name
+  | DbgEventStopped
+  deriving (Show)
 
 data DebugCommand
   = CmdListClosures
@@ -256,6 +257,8 @@ data DebugOutput
   | DbgOutThreadReport    !Int !ThreadState !Name !Addr String
   | DbgOutHeapObject      !Addr !HeapObject
   | DbgOutResult          ![Atom]
+  | DbgOutString          !String
+  | DbgOutByteString      !ByteString
   | DbgOut
   deriving (Show)
 

external-stg-interpreter/lib/Stg/Interpreter/Debugger.hs

@@ -14,6 +14,11 @@ import Stg.Syntax
 
 import Stg.Interpreter.Debugger.Internal
 
+sendDebugEvent :: DebugEvent -> M ()
+sendDebugEvent dbgEvent = do
+  DebuggerChan{..} <- gets ssDebuggerChan
+  liftIO $ Unagi.writeChan dbgAsyncEventIn dbgEvent
+
 getNextDebugCommand :: M DebugCommand
 getNextDebugCommand = do
   DebuggerChan{..} <- gets ssDebuggerChan
@@ -37,30 +42,38 @@ runDebugCommand cmd = do
 
     CmdClearClosureList -> do
       modify' $ \s@StgState{..} -> s {ssEvaluatedClosures = Set.empty}
+      liftIO $ putMVar dbgSyncResponse DbgOut
 
     CmdListClosures -> do
       closures <- gets ssEvaluatedClosures
       liftIO $ putMVar dbgSyncResponse $ DbgOutClosureList $ Set.toList closures
 
     CmdAddBreakpoint n i -> do
       modify' $ \s@StgState{..} -> s {ssBreakpoints = Map.insert n i ssBreakpoints}
+      liftIO $ putMVar dbgSyncResponse DbgOut
 
     CmdRemoveBreakpoint n -> do
       modify' $ \s@StgState{..} -> s {ssBreakpoints = Map.delete n ssBreakpoints}
+      liftIO $ putMVar dbgSyncResponse DbgOut
 
-    CmdStep -> pure ()
+    CmdStep -> liftIO $ putMVar dbgSyncResponse DbgOut
 
     CmdContinue -> do
       modify' $ \s@StgState{..} -> s {ssDebugState = DbgRunProgram}
+      liftIO $ putMVar dbgSyncResponse DbgOut
 
     CmdPeekHeap addr -> do
       heap <- gets ssHeap
-      when (IntMap.member addr heap) $ do
-        ho <- readHeap $ HeapPtr addr
-        liftIO $ putMVar dbgSyncResponse $ DbgOutHeapObject addr ho
+      case IntMap.member addr heap of
+        True -> do
+          ho <- readHeap $ HeapPtr addr
+          liftIO $ putMVar dbgSyncResponse $ DbgOutHeapObject addr ho
+        False -> do
+          liftIO $ putMVar dbgSyncResponse DbgOut
 
     CmdStop -> do
       modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
+      liftIO $ putMVar dbgSyncResponse DbgOut
 
     CmdInternal cmd -> do
       runInternalCommand cmd
@@ -102,7 +115,7 @@ checkBreakpoint breakpointName = do
   shouldStep <- hasFuel
   case dbgState of
     DbgStepByStep -> do
-      reportStateAsync
+      sendDebugEvent DbgEventStopped
       unless exit processCommandsUntilExit
     DbgRunProgram -> do
       unless shouldStep $ modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
@@ -117,6 +130,6 @@ checkBreakpoint breakpointName = do
           | otherwise -> do
               -- HINT: trigger breakpoint
               liftIO $ putStrLn $ "hit breakpoint: " ++ show breakpointName
-              reportStateAsync
+              sendDebugEvent $ DbgEventHitBreakpoint breakpointName
               modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
               unless exit processCommandsUntilExit

external-stg-interpreter/lib/Stg/Interpreter/Debugger/Internal.hs

@@ -45,12 +45,6 @@ reportStateSync = do
   msg <- getThreadReport
   liftIO $ putMVar dbgSyncResponse msg
 
-reportStateAsync :: M ()
-reportStateAsync = do
-  DebuggerChan{..} <- gets ssDebuggerChan
-  msg <- getThreadReport
-  liftIO $ Unagi.writeChan dbgAsyncEventIn msg
-
 getThreadReport :: M DebugOutput
 getThreadReport = do
   tid <- gets ssCurrentThreadId
@@ -120,40 +114,46 @@ showRetainerTree i = do
   tree <- getRetainerTree i
   liftIO $ putStrLn $ drawTree tree
 
+wrapWithDbgOut :: ([String] -> M ()) -> [String] -> M ()
+wrapWithDbgOut cmdM args = do
+  cmdM args
+  DebuggerChan{..} <- gets ssDebuggerChan
+  liftIO $ putMVar dbgSyncResponse DbgOut
+
 dbgCommands :: [([String], String, [String] -> M ())]
 dbgCommands =
   [ ( ["gc"]
     , "run sync. garbage collector"
-    , \_ -> do
+    , wrapWithDbgOut $ \_ -> do
         curClosureAddr <- gets ssCurrentClosureAddr
         GC.runGCSync [HeapPtr curClosureAddr]
     )
   , ( ["cleardb"]
     , "clear retainer db"
-    , \_ -> clearRetanerDb
+    , wrapWithDbgOut $ \_ -> clearRetanerDb
     )
 
   , ( ["loaddb"]
     , "load retainer db"
-    , \_ -> loadRetainerDb2
+    , wrapWithDbgOut $ \_ -> loadRetainerDb2
     )
 
   , ( ["?"]
     , "show debuggers' all internal commands"
-    , \_ -> printHelp
+    , wrapWithDbgOut $ \_ -> printHelp
     )
 
   , ( ["report"]
     , "report some internal data"
-    , \_ -> do
+    , wrapWithDbgOut $ \_ -> do
         heapStart <- gets ssHeapStartAddress
         liftIO $ do
           putStrLn $ "heap start address: " ++ show heapStart
     )
 
   , ( ["query", "??"]
     , "queries a given list of NAME_PATTERNs in static global env as substring"
-    , \patterns -> do
+    , wrapWithDbgOut $ \patterns -> do
         env <- gets ssStaticGlobalEnv
         let filterPattern pat resultList = [n | n <- resultList, List.isInfixOf pat n]
             matches = foldr filterPattern (map show $ Map.keys env) patterns
@@ -162,14 +162,14 @@ dbgCommands =
 
   , ( ["?b"]
     , "list breakpoints"
-    , \_ -> do
+    , wrapWithDbgOut $ \_ -> do
         bks <- Map.toList <$> gets ssBreakpoints
         liftIO $ putStrLn $ unlines [printf "%-40s  %d [fuel]" (BS8.unpack name) fuel | (name, fuel) <- bks]
     )
 
   , ( ["?r"]
     , "[START] [END] list a given region or all regions if the arguments are omitted"
-    , \case
+    , wrapWithDbgOut $ \case
       [] -> do
         regions <- Map.keys <$> gets ssRegions
         liftIO $ putStrLn $ unlines $ map show regions
@@ -180,31 +180,31 @@ dbgCommands =
 
   , ( ["?r-dump"]
     , "[START] [END] dump all heap object from the given region"
-    , \case
+    , wrapWithDbgOut $ \case
       [start]       -> showRegion True start start
       [start, end]  -> showRegion True start end
       _ -> pure ()
     )
 
   , ( ["+r"]
     , "add region: +r START_CLOSURE_NAME [END_CLOSURE_NAME] ; if only the start is provided then it will be the end marker also"
-    , \case
+    , wrapWithDbgOut $ \case
         [start]       -> addRegion start start
         [start, end]  -> addRegion start end
         _             -> pure ()
     )
 
   , ( ["-r"]
     , "del region: -r START_CLOSURE_NAME [END_CLOSURE_NAME] ; if only the start is provided then it will be the end marker also"
-    , \case
+    , wrapWithDbgOut $ \case
         [start]       -> delRegion start start
         [start, end]  -> delRegion start end
         _             -> pure ()
     )
 
   , ( ["peek-range", "pr"]
     , "ADDR_START ADDR_END [COUNT] - list all heap objects in the given heap address region, optionally show only the first (COUNT) elements"
-    , \case
+    , wrapWithDbgOut $ \case
       [start, end]
         | Just s <- Text.readMaybe start
         , Just e <- Text.readMaybe end
@@ -223,7 +223,7 @@ dbgCommands =
 
   , ( ["count-range", "cr"]
     , "ADDR_START ADDR_END - count heap objects in the given heap address region"
-    , \case
+    , wrapWithDbgOut $ \case
       [start, end]
         | Just s <- Text.readMaybe start
         , Just e <- Text.readMaybe end
@@ -235,7 +235,7 @@ dbgCommands =
 
   , ( ["retainer", "ret"]
     , "ADDR - show the retainer objects (heap objects that refer to the queried object"
-    , \case
+    , wrapWithDbgOut $ \case
         [addrS]
           | Just addr <- Text.readMaybe addrS
           -> showRetainer addr
@@ -244,7 +244,7 @@ dbgCommands =
 
   , ( ["ret-tree", "rt"]
     , "ADDR - show the retainer tree of an object"
-    , \case
+    , wrapWithDbgOut $ \case
         [addrS]
           | Just addr <- Text.readMaybe addrS
           -> showRetainerTree addr
@@ -253,7 +253,7 @@ dbgCommands =
 
   , ( ["trace-origin", "to"]
     , "ADDR - traces back heap object origin until the first dead object"
-    , \case
+    , wrapWithDbgOut $ \case
         [addrS]
           | Just addr <- Text.readMaybe addrS
           -> showOriginTrace addr
@@ -262,14 +262,14 @@ dbgCommands =
 
   , ( ["?e"]
     , "list all trace events and heap address state"
-    , \_-> do
+    , wrapWithDbgOut $ \_-> do
         events <- gets ssTraceEvents
         forM_ (reverse events) $ \(msg, AddressState{..}) -> liftIO $ printf "%-10d  %s\n" asNextHeapAddr (show msg)
     )
 
   , ( ["?e-dump"]
     , "list all trace events and the whole address state"
-    , \_-> do
+    , wrapWithDbgOut $ \_-> do
         events <- gets ssTraceEvents
         forM_ (reverse events) $ \(msg, a) -> liftIO $ do
           print msg
@@ -278,14 +278,14 @@ dbgCommands =
 
   , ( ["?m"]
     , "list all trace markers and heap address state"
-    , \_-> do
+    , wrapWithDbgOut $ \_-> do
         markers <- gets ssTraceMarkers
         forM_ (reverse markers) $ \(msg, AddressState{..}) -> liftIO $ printf "%-10d  %s\n" asNextHeapAddr (show msg)
     )
 
   , ( ["?m-dump"]
     , "list all trace markers and the whole address state"
-    , \_-> do
+    , wrapWithDbgOut $ \_-> do
         markers <- gets ssTraceMarkers
         forM_ (reverse markers) $ \(msg, a) -> liftIO $ do
           print msg
@@ -294,7 +294,7 @@ dbgCommands =
 
   , ( ["save-state"]
     , "DIR_NAME - save stg state as datalog facts to the given directory"
-    , \case
+    , wrapWithDbgOut $ \case
         [dirName] -> do
           s <- get
           liftIO $ do
@@ -305,7 +305,7 @@ dbgCommands =
 
   , ( ["fuel"]
     , "STEP-COUNT - make multiple steps ; 'fuel -' - turn off step count check"
-    , \case
+    , wrapWithDbgOut $ \case
       ["-"]
         -> modify' $ \s@StgState{..} -> s {ssDebugFuel = Nothing}
       [countS]

external-stg-interpreter/lib/Stg/Interpreter/Debugger/UI.hs

@@ -104,6 +104,12 @@ printDebugOutput = \case
     putStrLn $ "addr: " ++ show addr
     printHeapObject heapObj
 
+  DbgOutString msg -> putStrLn msg
+
+  DbgOutByteString msg -> BS8.putStrLn msg
+
+  DbgOut -> pure ()
+
 printHeapObject :: HeapObject -> IO ()
 printHeapObject = \case
   Con{..} -> do
@@ -182,9 +188,10 @@ runDebugScript :: DebuggerChan -> [String] -> IO ()
 runDebugScript dbgChan@DebuggerChan{..} lines = do
   let waitBreakpoint = do
         msg <- Unagi.readChan dbgAsyncEventOut
+        print msg
         case msg of
-          DbgOutThreadReport{}  -> printDebugOutput msg
-          _                     -> printDebugOutput msg >> waitBreakpoint
+          DbgEventHitBreakpoint{} -> putMVar dbgSyncRequest $ CmdInternal "get-current-thread-state"
+          _                       -> waitBreakpoint
 
   forM_ lines $ \cmd -> do
     putStrLn cmd