summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/vm/debug.scm1
-rw-r--r--module/system/vm/traps.scm102
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)