remove heap links in VM frames, incorporate vm frames into normal backtraces

[bpt/guile.git] / module / system / vm / frame.scm

diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index d732309..85a223e 100644 (file)
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -20,10 +20,18 @@
 ;;; 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
@@ -32,21 +40,22 @@
            frame-object-name
            frame-local-ref frame-external-link frame-local-set!
            frame-return-address frame-program
-           frame-dynamic-link frame?))
+           frame-dynamic-link heap-frame?))
 
-(dynamic-call "scm_init_frames" (dynamic-link "libguile-vm"))
+;; fixme: avoid the dynamic-call?
+(dynamic-call "scm_init_frames" (dynamic-link "libguile"))
 
 ;;;
 ;;; 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)
@@ -92,7 +101,7 @@
 (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)
@@ -103,7 +112,7 @@
              ((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)
@@ -119,13 +128,16 @@
               '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 (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
@@ -166,16 +178,14 @@
     (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)))