diff options
-rw-r--r-- | module/system/vm/debug.scm | 1 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 102 |
2 files changed, 50 insertions, 53 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index af99a54d9..ca6fe07a0 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -42,6 +42,7 @@ program-debug-info-context program-debug-info-image program-debug-info-offset + program-debug-info-size program-debug-info-addr program-debug-info-u32-offset program-debug-info-u32-offset-end diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index af7443396..f1dcc29b2 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -57,9 +57,9 @@ (define-module (system vm traps) #:use-module (system base pmatch) #:use-module (system vm vm) + #:use-module (system vm debug) #:use-module (system vm frame) #:use-module (system vm program) - #:use-module (system vm objcode) #:use-module (system vm instruction) #:use-module (system xref) #:use-module (rnrs bytevectors) @@ -108,24 +108,20 @@ (define (new-enabled-trap vm frame enable disable) ((new-disabled-trap vm enable disable) frame)) -(define (frame-matcher proc match-objcode?) - (if match-objcode? - (cond - ((program? proc) - (lambda (frame) - (let ((frame-proc (frame-procedure frame))) - (or (eq? frame-proc proc) - (and (program? frame-proc) - (eq? (program-objcode frame-proc) - (program-objcode proc))))))) - ((rtl-program? proc) - (lambda (frame) - (let ((frame-proc (frame-procedure frame))) - (or (eq? frame-proc proc) - (and (rtl-program? frame-proc) - (eqv? (rtl-program-code frame-proc) - (rtl-program-code proc))))))) - (else (lambda (frame) #f))) +;; Returns an absolute IP. +(define (program-last-ip prog) + (let ((pdi (find-program-debug-info (rtl-program-code prog)))) + (and pdi (program-debug-info-size pdi)))) + +(define (frame-matcher proc match-code?) + (if match-code? + (if (rtl-program? proc) + (let ((start (rtl-program-code proc)) + (end (program-last-ip proc))) + (lambda (frame) + (let ((ip (frame-instruction-pointer frame))) + (and (<= start ip) (< ip end))))) + (lambda (frame) #f)) (lambda (frame) (eq? (frame-procedure frame) proc)))) @@ -319,41 +315,41 @@ #:current-frame current-frame #:vm vm #:our-frame? our-frame?))) -;; FIXME: define this in objcode somehow. We are reffing the first -;; uint32 in the objcode, which is the length of the program (without -;; the meta). -(define (program-last-ip prog) - (bytevector-u32-native-ref (objcode->bytecode (program-objcode prog)) 0)) - (define (program-sources-by-line proc file) - (let lp ((sources (program-sources-pre-retire proc)) - (out '())) - (if (pair? sources) - (lp (cdr sources) - (pmatch (car sources) - ((,start-ip ,start-file ,start-line . ,start-col) - (if (equal? start-file file) - (cons (cons start-line - (if (pair? (cdr sources)) - (pmatch (cadr sources) - ((,end-ip . _) - (cons start-ip end-ip)) - (else (error "unexpected"))) - (cons start-ip (program-last-ip proc)))) - out) - out)) - (else (error "unexpected")))) - (let ((alist '())) - (for-each - (lambda (pair) - (set! alist - (assv-set! alist (car pair) - (cons (cdr pair) - (or (assv-ref alist (car pair)) - '()))))) - out) - (sort! alist (lambda (x y) (< (car x) (car y)))) - alist)))) + (cond + ((rtl-program? proc) + (let ((code (rtl-program-code proc))) + (let lp ((sources (program-sources proc)) + (out '())) + (if (pair? sources) + (lp (cdr sources) + (pmatch (car sources) + ((,start-ip ,start-file ,start-line . ,start-col) + (if (equal? start-file file) + (acons start-line + (if (pair? (cdr sources)) + (pmatch (cadr sources) + ((,end-ip . _) + (cons (+ start-ip code) + (+ end-ip code))) + (else (error "unexpected"))) + (cons (+ start-ip code) + (program-last-ip proc))) + out) + out)) + (else (error "unexpected")))) + (let ((alist '())) + (for-each + (lambda (pair) + (set! alist + (assv-set! alist (car pair) + (cons (cdr pair) + (or (assv-ref alist (car pair)) + '()))))) + out) + (sort! alist (lambda (x y) (< (car x) (car y)))) + alist))))) + (else '()))) (define (source->ip-range proc file line) (or (or-map (lambda (line-and-ranges) |