dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Better breakpoints

Browse Source
This commit is contained in:
Dane Johnson 2025-06-15 13:02:56 -05:00
parent f939d1b08b
commit ce963c498c
1 changed files with 37 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
scmvm/debugger.scm
View File

@ -1,16 +1,17 @@
(define-module (scmvm debugger)
#:use-module (scmvm assembler)
#:use-module (scmvm vm)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (ice-9 control)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 exceptions)
#:export ((make-debugger* . make-debugger)
debugger-vm
debugger-source
#:use-module (ice-9 match)
#:export ((make-debugger* . make-debugger) debugger-vm debugger-source
debugger-breakpoints debugger-breakpoints-set!
debugger-breakpoint-add! debugger-breakpoint-ref
debugger-breakpoint-enable! debugger-breakpoint-disable!
debugger-breakpoint-delete!
debugger-continue))
(define-record-type <debugger>
@ -18,9 +19,29 @@
debugger?
(vm debugger-vm)
(source debugger-source)
(breakpoints debugger-breakpoints debugger-breakpoints-set!)
(breakpoints debugger-breakpoints)
(continuation debugger-continuation debugger-continuation-set!))
(define (make-breakpoints labels)
(define the-breakpoints '())
(define (->index index/label)
(if (number? index/label)
index/label
(assq-ref labels index/label)))
(define-syntax-rule (ilambda (i) e ...)
(lambda (v) (let ([i (->index v)]) e ...)))
(match-lambda
['add
(ilambda (i) (set! the-breakpoints (acons i #t the-breakpoints)))]
['delete
(ilambda (i) (set! the-breakpoints (assq-remove! the-breakpoints i)))]
['enable
(ilambda (i) (set! the-breakpoints (assq-set! the-breakpoints i #t)))]
['disable
(ilambda (i) (set! the-breakpoints (assq-set! the-breakpoints i #f)))]
['ref
(ilambda (i) (assq-ref the-breakpoints i))]))
(define (make-debugger* source)
(define-values (prgm symbols)
(call-with-values open-bytevector-output-port
@ -30,39 +51,29 @@
(define the-debugger #f)
(define (debug)
(shift k
(debugger-continuation-set! the-debugger k)
(when (not (assq-ref (debugger-breakpoints the-debugger)
(vm-pc (debugger-vm the-debugger))))
(k))))
(if (((debugger-breakpoints the-debugger) 'ref) (vm-pc (debugger-vm the-debugger)))
(debugger-continuation-set! the-debugger k)
(k))))
(define vm (make-vm #:debugger debug))
(vm-load-program! vm prgm)
(set! the-debugger (make-debugger vm source '((1 . #t)) #f))
(set! the-debugger (make-debugger vm source (make-breakpoints symbols) #f))
(reset (run-vm vm))
the-debugger)
(define (debugger-continue debugger)
((debugger-continuation debugger)))
(define* (debugger-breakpoint-add! debugger breakpoint #:key (enabled? #f))
(debugger-breakpoints-set!
debugger
(assq-set! (debugger-breakpoints debugger) breakpoint enabled?)))
(define (debugger-breakpoint-add! debugger breakpoint)
(((debugger-breakpoints debugger) 'add) breakpoint))
(define (debugger-breakpoint-ref debugger breakpoint)
(assq breakpoint (debugger-breakpoints debugger)))
(((debugger-breakpoints debugger) 'ref) breakpoint))
(define (debugger-breakpoint-enable! debugger breakpoint)
(define breakpoints (debugger-breakpoints debugger))
(if (pair? (assq breakpoints breakpoint))
(assq-set! breakpoints breakpoint #t)
(raise-exception (make-exception
(make-error)
(make-exception-with-message "Cannot enable nonexistant breakpoint")))))
(((debugger-breakpoints debugger) 'enable) breakpoint))
(define (debugger-breakpoint-disable! debugger breakpoint)
(define breakpoints (debugger-breakpoints debugger))
(if (pair? (assq breakpoints breakpoint))
(assq-set! breakpoints breakpoint #f)
(raise-exception (make-exception
(make-error)
(make-exception-with-message "Cannot disable nonexistant breakpoint")))))
(((debugger-breakpoints debugger) 'disable) breakpoint))
(define (debugger-breakpoint-delete! debugger breakpoint)
(((debugger-breakpoints debugger) 'delete) breakpoint))