diff options
Diffstat (limited to 'module/system')
-rw-r--r-- | module/system/vm/frame.scm | 15 | ||||
-rw-r--r-- | module/system/vm/program.scm | 59 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 56 |
3 files changed, 71 insertions, 59 deletions
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 57ae877ff..94619badf 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -26,7 +26,7 @@ #:export (frame-bindings frame-lookup-binding frame-binding-ref frame-binding-set! - frame-source frame-call-representation + frame-source frame-next-source frame-call-representation frame-environment frame-object-binding frame-object-name frame-return-values)) @@ -71,8 +71,17 @@ ;;; (define (frame-source frame) - (program-source (frame-procedure frame) - (frame-instruction-pointer frame))) + (let ((proc (frame-procedure frame))) + (program-source proc + (frame-instruction-pointer frame) + (program-sources proc)))) + +(define (frame-next-source frame) + (let ((proc (frame-procedure frame))) + (program-source proc + (frame-instruction-pointer frame) + (program-sources-pre-retire proc)))) + ;; Basically there are two cases to deal with here: ;; diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index a1e3ea4f0..02d5ec409 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -20,6 +20,9 @@ (define-module (system vm program) #:use-module (system base pmatch) + #:use-module (system vm instruction) + #:use-module (system vm objcode) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (make-program @@ -29,7 +32,7 @@ source:addr source:line source:column source:file source:line-for-user - program-sources program-source + program-sources program-sources-pre-retire program-source program-bindings program-bindings-by-index program-bindings-for-ip program-arities program-arity arity:start arity:end @@ -71,6 +74,60 @@ (define (source:line-for-user source) (1+ (source:line source))) +;; FIXME: pull this definition from elsewhere. +(define *bytecode-header-len* 8) + +;; We could decompile the program to get this, but that seems like a +;; waste. +(define (bytecode-instruction-length bytecode ip) + (let* ((idx (+ ip *bytecode-header-len*)) + (inst (opcode->instruction (bytevector-u8-ref bytecode idx)))) + ;; 1+ for the instruction itself. + (1+ (cond + ((eq? inst 'load-program) + (+ (bytevector-u32-native-ref bytecode (+ idx 1)) + (bytevector-u32-native-ref bytecode (+ idx 5)))) + ((< (instruction-length inst) 0) + ;; variable length instruction -- the length is encoded in the + ;; instruction stream. + (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16) + (ash (bytevector-u8-ref bytecode (+ idx 2)) 8) + (bytevector-u8-ref bytecode (+ idx 3)))) + (else + ;; fixed length + (instruction-length inst)))))) + +;; Source information could in theory be correlated with the ip of the +;; instruction, or the ip just after the instruction is retired. Guile +;; does the latter, to make backtraces easy -- an error produced while +;; running an opcode always happens after it has retired its arguments. +;; +;; But for breakpoints and such, we need the ip before the instruction +;; is retired -- before it has had a chance to do anything. So here we +;; change from the post-retire addresses given by program-sources to +;; pre-retire addresses. +;; +(define (program-sources-pre-retire proc) + (let ((bv (objcode->bytecode (program-objcode proc)))) + (let lp ((in (program-sources proc)) + (out '()) + (ip 0)) + (cond + ((null? in) + (reverse out)) + (else + (pmatch (car in) + ((,post-ip . ,source) + (let lp2 ((ip ip) + (next ip)) + (if (< next post-ip) + (lp2 next (+ next (bytecode-instruction-length bv next))) + (lp (cdr in) + (acons ip source out) + next)))) + (else + (error "unexpected")))))))) + (define (collapse-locals locs) (let lp ((ret '()) (locs locs)) (if (null? locs) diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index 627e6c581..cccd6eac9 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -309,68 +309,14 @@ #:current-frame current-frame #:vm vm #:our-frame? our-frame?))) -;; FIXME: pull this definition from elsewhere. -(define *bytecode-header-len* 8) - ;; 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)) -;; We could decompile the program to get this, but that seems like a -;; waste. -(define (bytecode-instruction-length bytecode ip) - (let* ((idx (+ ip *bytecode-header-len*)) - (inst (opcode->instruction (bytevector-u8-ref bytecode idx)))) - ;; 1+ for the instruction itself. - (1+ (cond - ((eq? inst 'load-program) - (+ (bytevector-u32-native-ref bytecode (+ idx 1)) - (bytevector-u32-native-ref bytecode (+ idx 5)))) - ((< (instruction-length inst) 0) - ;; variable length instruction -- the length is encoded in the - ;; instruction stream. - (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16) - (ash (bytevector-u8-ref bytecode (+ idx 2)) 8) - (bytevector-u8-ref bytecode (+ idx 3)))) - (else - ;; fixed length - (instruction-length inst)))))) - -;; Source information could in theory be correlated with the ip of the -;; instruction, or the ip just after the instruction is retired. Guile -;; does the latter, to make backtraces easy -- an error produced while -;; running an opcode always happens after it has retired its arguments. -;; -;; But for breakpoints and such, we need the ip before the instruction -;; is retired -- before it has had a chance to do anything. So here we -;; change from the post-retire addresses given by program-sources to -;; pre-retire addresses. -;; -(define (program-sources-before-retire proc) - (let ((bv (objcode->bytecode (program-objcode proc)))) - (let lp ((in (program-sources proc)) - (out '()) - (ip 0)) - (cond - ((null? in) - (reverse out)) - (else - (pmatch (car in) - ((,post-ip . ,source) - (let lp2 ((ip ip) - (next ip)) - (if (< next post-ip) - (lp2 next (+ next (bytecode-instruction-length bv next))) - (lp (cdr in) - (acons ip source out) - next)))) - (else - (error "unexpected")))))))) - (define (program-sources-by-line proc file) - (let lp ((sources (program-sources-before-retire proc)) + (let lp ((sources (program-sources-pre-retire proc)) (out '())) (if (pair? sources) (lp (cdr sources) |