summaryrefslogtreecommitdiff
path: root/module/system/vm/program.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/program.scm')
-rw-r--r--module/system/vm/program.scm59
1 files changed, 58 insertions, 1 deletions
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)