;;; Code:
(define-module (system vm frame)
- :use-module (system vm program)
- :use-module (system vm instruction)
- :use-module ((srfi srfi-1) :select (fold))
- :export (frame-number frame-address
+ #:use-module (system vm program)
+ #:use-module (system vm instruction)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export (vm-frame?
+ vm-frame-program
+ vm-frame-local-ref vm-frame-local-set!
+ vm-frame-return-address vm-frame-mv-return-address
+ vm-frame-dynamic-link vm-frame-external-link
+ vm-frame-stack
+
+
+ vm-frame-number vm-frame-address
make-frame-chain
print-frame print-frame-chain-as-backtrace
frame-arguments frame-local-variables frame-external-variables
;;; Frame chain
;;;
-(define frame-number (make-object-property))
-(define frame-address (make-object-property))
+(define vm-frame-number (make-object-property))
+(define vm-frame-address (make-object-property))
(define (bootstrap-frame? frame)
(let ((code (program-bytecode (frame-program frame))))
- (and (= (uniform-vector-length code) 3)
- (= (uniform-vector-ref code 2)
+ (and (= (uniform-vector-length code) 6)
+ (= (uniform-vector-ref code 5)
(instruction->opcode 'halt)))))
(define (make-frame-chain frame addr)
(define (frame-call-representation frame)
(define (abbrev x)
(cond ((list? x)
- (if (> (length x) 3)
+ (if (> (length x) 4)
(list (abbrev (car x)) (abbrev (cadr x)) '...)
(map abbrev x)))
((pair? x)
((1) (vector (abbrev (vector-ref x 0))))
(else (vector (abbrev (vector-ref x 0)) '...))))
(else x)))
- (abbrev (cons (program-name frame) (frame-arguments frame))))
+ (abbrev (cons (frame-program-name frame) (frame-arguments frame))))
(define (print-frame-chain-as-backtrace frames)
(if (null? frames)
'no-file
frames))))
-(define (program-name frame)
+(define (frame-program-name frame)
(let ((prog (frame-program frame))
(link (frame-dynamic-link frame)))
- (or (object-property prog 'name)
- (and (heap-frame? link)
+ (or (program-name prog)
+ (object-property prog 'name)
+ (and (heap-frame? link) (frame-address link)
(frame-object-name link (1- (frame-address link)) prog))
- (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
+ (hash-fold (lambda (s v d) (if (and (variable-bound? v)
+ (eq? prog (variable-ref v)))
+ s d))
prog (module-obarray (current-module))))))
\f
(frame-external-set! frame (binding:index binding) val)
(frame-local-set! frame (binding:index binding) val)))
+;; FIXME handle #f program-bindings return
(define (frame-bindings frame addr)
- (do ((bs (program-bindings (frame-program frame)) (cdr bs))
- (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
- ((or (null? bs) (> (caar bs) addr))
- (apply append ls))))
+ (filter (lambda (b) (and (>= addr (binding:start b))
+ (<= addr (binding:end b))))
+ (program-bindings (frame-program frame))))
(define (frame-lookup-binding frame addr sym)
- (do ((bs (frame-bindings frame addr) (cdr bs)))
- ((or (null? bs) (eq? sym (binding:name (car bs))))
- (and (pair? bs) (car bs)))))
+ (assq sym (reverse (frame-bindings frame addr))))
(define (frame-object-binding frame addr obj)
(do ((bs (frame-bindings frame addr) (cdr bs)))