Skip to content

Commit d1bfe40

Browse files
csabahruskacsabahruska
committed
add Breakpoint type to model breakpoints ; add get-stg-state command
1 parent 18a452a commit d1bfe40

File tree

7 files changed

+68
-31
lines changed

7 files changed

+68
-31
lines changed

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

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ import System.IO
3434
import System.Directory
3535
import System.Exit
3636

37+
import Stg.IRLocation
3738
import Stg.Syntax
3839
import Stg.Program
3940
import Stg.JSON
@@ -176,7 +177,7 @@ buildCallGraph so hoName = do
176177
builtinStgEval :: HasCallStack => StaticOrigin -> Atom -> M [Atom]
177178
builtinStgEval so a@HeapPtr{} = do
178179
o <- readHeap a
179-
Debugger.checkBreakpoint "eval"
180+
Debugger.checkBreakpoint $ BkpCustom "eval"
180181
case o of
181182
ApStack{..} -> do
182183
mapM_ stackPush (reverse hoStack)
@@ -219,7 +220,7 @@ builtinStgEval so a@HeapPtr{} = do
219220
-- check breakpoints and region entering
220221
let closureName = binderUniqueName $ unId hoName
221222
markClosure closureName -- HINT: this list can be deleted by a debugger command, so this is not the same as `markExecutedId`
222-
Debugger.checkBreakpoint closureName
223+
Debugger.checkBreakpoint . BkpStgPoint $ SP_RhsClosureExpr hoName
223224
Debugger.checkRegion closureName
224225
GC.checkGC [a] -- HINT: add local env as GC root
225226

@@ -404,7 +405,7 @@ evalStackMachine result = do
404405
putStrLn $ " input result = " ++ show result
405406
putStrLn $ " stack-cont = " ++ showStackCont stackCont
406407

407-
Debugger.checkBreakpoint "stack"
408+
Debugger.checkBreakpoint $ BkpCustom "stack"
408409
nextResult <- evalStackContinuation result stackCont
409410
case stackCont of
410411
RunScheduler{} -> pure ()
@@ -636,7 +637,7 @@ evalExpr localEnv = \case
636637
evalExpr localEnv e
637638

638639
StgOpApp (StgPrimOp op) l t tc -> do
639-
Debugger.checkBreakpoint op
640+
Debugger.checkBreakpoint $ BkpPrimOp op
640641
Debugger.checkRegion op
641642
markPrimOp op
642643
args <- mapM (evalArg localEnv) l
@@ -649,7 +650,7 @@ evalExpr localEnv = \case
649650
-- check foreign target region and breakpoint
650651
case foreignCTarget foreignCall of
651652
StaticTarget _ targetName _ _ -> do
652-
Debugger.checkBreakpoint targetName
653+
Debugger.checkBreakpoint $ BkpFFISymbol targetName
653654
Debugger.checkRegion targetName
654655
_ -> pure ()
655656

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

Lines changed: 13 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ import GHC.Stack
3535
import Text.Printf
3636
import Debug.Trace
3737
import Stg.Syntax
38+
import Stg.IRLocation
3839

3940
type StgRhsClosure = Rhs -- NOTE: must be StgRhsClosure only!
4041

@@ -234,16 +235,23 @@ instance Show DebuggerChan where
234235
show _ = "DebuggerChan"
235236

236237
data DebugEvent
237-
= DbgEventHitBreakpoint !Name
238+
= DbgEventHitBreakpoint !Breakpoint
238239
| DbgEventStopped
239240
deriving (Show)
240241

242+
data Breakpoint
243+
= BkpStgPoint StgPoint
244+
| BkpPrimOp Name
245+
| BkpFFISymbol Name
246+
| BkpCustom Name
247+
deriving (Eq, Ord, Show)
248+
241249
data DebugCommand
242250
= CmdListClosures
243251
| CmdClearClosureList
244252
| CmdCurrentClosure
245-
| CmdAddBreakpoint Name Int
246-
| CmdRemoveBreakpoint Name
253+
| CmdAddBreakpoint Breakpoint Int
254+
| CmdRemoveBreakpoint Breakpoint
247255
| CmdStep
248256
| CmdContinue
249257
| CmdPeekHeap Addr
@@ -255,6 +263,7 @@ data DebugOutput
255263
= DbgOutCurrentClosure !(Maybe Id) !Addr !Env
256264
| DbgOutClosureList ![Name]
257265
| DbgOutThreadReport !Int !ThreadState !Name !Addr String
266+
| DbgOutStgState !StgState
258267
| DbgOutHeapObject !Addr !HeapObject
259268
| DbgOutResult ![Atom]
260269
| DbgOutString !String
@@ -412,7 +421,7 @@ data StgState
412421
, ssDebuggerChan :: DebuggerChan
413422

414423
, ssEvaluatedClosures :: !(Set Name)
415-
, ssBreakpoints :: !(Map Name Int)
424+
, ssBreakpoints :: !(Map Breakpoint Int)
416425
, ssStepCounter :: !Int
417426
, ssDebugFuel :: !(Maybe Int)
418427
, ssDebugState :: DebugState

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

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import Control.Concurrent.MVar
1111

1212
import Stg.Interpreter.Base
1313
import Stg.Syntax
14+
import Stg.IRLocation
1415

1516
import Stg.Interpreter.Debugger.Internal
1617

@@ -108,8 +109,8 @@ hasFuel = do
108109
modify' $ \s@StgState{..} -> s {ssDebugFuel = fmap pred ssDebugFuel, ssStepCounter = succ ssStepCounter}
109110
pure $ maybe True (> 0) fuel
110111

111-
checkBreakpoint :: Name -> M ()
112-
checkBreakpoint breakpointName = do
112+
checkBreakpoint :: Breakpoint -> M ()
113+
checkBreakpoint breakpoint = do
113114
dbgState <- gets ssDebugState
114115
exit <- processCommandsNonBlocking
115116
shouldStep <- hasFuel
@@ -120,16 +121,17 @@ checkBreakpoint breakpointName = do
120121
DbgRunProgram -> do
121122
unless shouldStep $ modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
122123
bkMap <- gets ssBreakpoints
123-
case Map.lookup breakpointName bkMap of
124+
case Map.lookup breakpoint bkMap of
124125
Nothing -> pure ()
125126
Just i
126127
| i > 0 -> do
127128
-- HINT: the breakpoint can postpone triggering for the requested time
128-
modify' $ \s@StgState{..} -> s {ssBreakpoints = Map.adjust pred breakpointName ssBreakpoints}
129+
modify' $ \s@StgState{..} -> s {ssBreakpoints = Map.adjust pred breakpoint ssBreakpoints}
129130

130131
| otherwise -> do
131132
-- HINT: trigger breakpoint
132-
liftIO $ putStrLn $ "hit breakpoint: " ++ show breakpointName
133-
sendDebugEvent $ DbgEventHitBreakpoint breakpointName
133+
liftIO $ putStrLn $ "hit breakpoint: " ++ show breakpoint
134+
Just currentClosure <- gets ssCurrentClosure
135+
sendDebugEvent $ DbgEventHitBreakpoint breakpoint
134136
modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
135137
unless exit processCommandsUntilExit

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

Lines changed: 21 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,12 @@ showOriginTrace i = do
3939
_ -> liftIO $ putStrLn str
4040
go i IntSet.empty
4141

42+
reportStgStateSync :: M ()
43+
reportStgStateSync = do
44+
DebuggerChan{..} <- gets ssDebuggerChan
45+
stgState <- get
46+
liftIO . putMVar dbgSyncResponse $ DbgOutStgState stgState
47+
4248
reportStateSync :: M ()
4349
reportStateSync = do
4450
DebuggerChan{..} <- gets ssDebuggerChan
@@ -164,7 +170,7 @@ dbgCommands =
164170
, "list breakpoints"
165171
, wrapWithDbgOut $ \_ -> do
166172
bks <- Map.toList <$> gets ssBreakpoints
167-
liftIO $ putStrLn $ unlines [printf "%-40s %d [fuel]" (BS8.unpack name) fuel | (name, fuel) <- bks]
173+
liftIO $ putStrLn $ unlines [printf "%-40s %d [fuel]" (show name) fuel | (name, fuel) <- bks]
168174
)
169175

170176
, ( ["?r"]
@@ -314,11 +320,25 @@ dbgCommands =
314320
_ -> pure ()
315321
)
316322

323+
, ( ["ret-tree", "rt"]
324+
, "ADDR - show the retainer tree of an object"
325+
, wrapWithDbgOut $ \case
326+
[addrS]
327+
| Just addr <- Text.readMaybe addrS
328+
-> showRetainerTree addr
329+
_ -> pure ()
330+
)
331+
317332
, ( ["get-current-thread-state"]
318333
, "reports the currently running thread state"
319334
, \_ -> reportStateSync
320335
)
321336

337+
, ( ["get-stg-state"]
338+
, "reports the stg state"
339+
, \_ -> reportStgStateSync
340+
)
341+
322342
]
323343

324344

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

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ import Data.Maybe
1717
import Stg.Interpreter.Base
1818
import Stg.Interpreter
1919
import Stg.Syntax
20+
import Stg.IRLocation
2021

2122
ppSrcSpan :: SrcSpan -> String
2223
ppSrcSpan = \case
@@ -108,6 +109,10 @@ printDebugOutput = \case
108109

109110
DbgOutByteString msg -> BS8.putStrLn msg
110111

112+
DbgOutStgState stgState -> do
113+
putStrLn $ "stg state: TODO"
114+
pure ()
115+
111116
DbgOut -> pure ()
112117

113118
printHeapObject :: HeapObject -> IO ()
@@ -163,9 +168,9 @@ parseDebugCommand :: String -> DebuggerChan -> IO ()
163168
parseDebugCommand line dbgChan@DebuggerChan{..} = do
164169
case words line of
165170
["help"] -> printHelp >> putMVar dbgSyncRequest (CmdInternal "?")
166-
["+b", name] -> putMVar dbgSyncRequest $ CmdAddBreakpoint (BS8.pack name) 0
167-
["+b", name, fuel] -> putMVar dbgSyncRequest $ CmdAddBreakpoint (BS8.pack name) (fromMaybe 0 $ readMaybe fuel)
168-
["-b", name] -> putMVar dbgSyncRequest $ CmdRemoveBreakpoint $ BS8.pack name
171+
--["+b", name] -> putMVar dbgSyncRequest $ CmdAddBreakpoint (BkpStgPoint . SP_RhsClosureExpr $ BS8.pack name) 0
172+
--["+b", name, fuel] -> putMVar dbgSyncRequest $ CmdAddBreakpoint (BkpStgPoint . SP_RhsClosureExpr $ BS8.pack name) (fromMaybe 0 $ readMaybe fuel)
173+
--["-b", name] -> putMVar dbgSyncRequest $ CmdRemoveBreakpoint $ BkpStgPoint . SP_RhsClosureExpr $ BS8.pack name
169174
["list"] -> putMVar dbgSyncRequest $ CmdListClosures
170175
["clear"] -> putMVar dbgSyncRequest $ CmdClearClosureList
171176
["step"] -> putMVar dbgSyncRequest $ CmdStep

‎external-stg-interpreter/lib/Stg/Interpreter/ThreadScheduler.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -225,7 +225,7 @@ stopIfThereIsNoRunnableThread = do
225225
putStrLn $ "[stopIfThereIsNoRunnableThread] - all thread status list: " ++ show [(tid, tsStatus ts) | (tid, ts) <- tsList]
226226
dumpStgState
227227
modify' $ \s@StgState{..} -> s {ssDebugState = DbgStepByStep}
228-
Debugger.checkBreakpoint "thread-scheduler"
228+
Debugger.checkBreakpoint $ BkpCustom "thread-scheduler"
229229

230230
{-
231231
IDEA:

‎external-stg/lib/Stg/Pretty.hs‎

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -344,10 +344,10 @@ instance Pretty Binder where
344344
pprExpr :: Expr -> Doc
345345
pprExpr = pprExpr' False
346346

347-
pprAlt :: Name -> Int -> Alt -> Doc
348-
pprAlt scrutName idx (Alt con bndrs rhs) =
347+
pprAlt :: Id -> Int -> Alt -> Doc
348+
pprAlt scrutId idx (Alt con bndrs rhs) =
349349
(hsep (pretty con : map (pprBinder) bndrs) <+> smallRArrow) <$$>
350-
indent 2 (withStgPoint (SP_AltExpr scrutName idx) $ pprExpr' False rhs)
350+
indent 2 (withStgPoint (SP_AltExpr scrutId idx) $ pprExpr' False rhs)
351351

352352
pprArg :: Arg -> Doc
353353
pprArg = \case
@@ -382,14 +382,14 @@ pprExpr' hasParens exp = do
382382
StgLit l -> pretty l
383383
StgCase x b at alts -> maybeParens hasParens
384384
$ sep [ hsep [ text "case"
385-
, withStgPoint (SP_CaseScrutineeExpr $ binderUniqueName b) $
385+
, withStgPoint (SP_CaseScrutineeExpr $ Id b) $
386386
pprExpr' False x
387387
, text "of"
388388
, pprBinder b
389389
, text ":"
390390
, parens (pretty at)
391391
, text "{" ]
392-
, indent 2 $ vcat $ [pprAlt (binderUniqueName b) idx a | (idx, a) <- zip [0..] alts]
392+
, indent 2 $ vcat $ [pprAlt (Id b) idx a | (idx, a) <- zip [0..] alts]
393393
, "}"
394394
]
395395
StgApp f args -> maybeParens hasParens $ (pprVar f) <+> (hsep $ map (pprArg) args)
@@ -402,18 +402,18 @@ pprExpr' hasParens exp = do
402402
instance Pretty Expr where
403403
pretty = pprExpr
404404

405-
pprRhs :: Name -> Rhs -> Doc
406-
pprRhs rhsBinderName = \case
407-
StgRhsClosure _ u bs e -> text "\\closure" <+> hsep (map pprBinder bs) <+> text "->" <+> braces (line <> (withStgPoint (SP_RhsClosureExpr rhsBinderName) $ pprExpr e))
408-
StgRhsCon d vs -> annotate (SP_RhsCon rhsBinderName) $ pretty d <+> (hsep $ map (pprArg) vs)
405+
pprRhs :: Id -> Rhs -> Doc
406+
pprRhs rhsId = \case
407+
StgRhsClosure _ u bs e -> text "\\closure" <+> hsep (map pprBinder bs) <+> text "->" <+> braces (line <> (withStgPoint (SP_RhsClosureExpr rhsId) $ pprExpr e))
408+
StgRhsCon d vs -> annotate (SP_RhsCon rhsId) $ pretty d <+> (hsep $ map (pprArg) vs)
409409

410410
pprBinding :: Binding -> Doc
411411
pprBinding = \case
412412
StgNonRec b r -> pprTopBind (b,r)
413413
StgRec bs -> text "rec" <+> braces (line <> vsep (map pprTopBind bs))
414414
where
415415
pprTopBind (b,rhs) =
416-
(pprBinder b <+> equals <$$> (indent 2 $ pprRhs (binderUniqueName b) rhs))
416+
(pprBinder b <+> equals <$$> (indent 2 $ pprRhs (Id b) rhs))
417417
<> line
418418

419419
pprTopBinding :: TopBinding -> Doc
@@ -424,7 +424,7 @@ pprTopBinding = \case
424424
where
425425
pprTopBind = pprTopBind' pprRhs
426426
pprTopBind' f (b,rhs) =
427-
(pprBinder b <+> equals <$$> (indent 2 $ f (binderUniqueName b) rhs))
427+
(pprBinder b <+> equals <$$> (indent 2 $ f (Id b) rhs))
428428
<> line
429429

430430
instance Pretty TopBinding where

0 commit comments

Comments
 (0)