[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-54-g1c5e812

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=1c5e812258da4b002d309f969d722c86004ecf94

The branch, master has been updated
       via  1c5e812258da4b002d309f969d722c86004ecf94 (commit)
      from  b8596c08ac2ef2201c1e8559ac5f4d62ebde3d91 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 1c5e812258da4b002d309f969d722c86004ecf94
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 29 14:09:50 2009 +0100

    clean up (system vm frames), add locals command to debugger
    
    * libguile/frames.c (scm_init_frames): No need to bootstrap the VM here,
      it should be already bootstrapped by init.c.
      (scm_bootstrap_frames): No need to register an extension, as
      scm_init_frames is called by init.c.
    
    * module/system/vm/frame.scm: Don't load the scm_init_frames extension,
      as the primitives from frames.c are loaded by Guile's init.
      (frame-bindings): Change to return bindings, as can be accessed by the
      binding: accessors from program.scm.
      (frame-lookup-binding): Revive and make this one work with current
      code.
      (frame-binding-set!):
      (frame-binding-ref): Use the new frame-lookup-binding. Perhaps these
      should handle boxing and unboxing, though.
      (frame-source): New accessor, returns a source object.
      (frame-call-representation): Change to return a full list, as
      truncated-print can truncate for us.
      (frame-environment, frame-object-binding, frame-object-name): Update
      not to take an address, as the address is part of the frame.
      (frame-variable-exists?, frame-variable-ref, frame-variable-set!)
      (frame-local-variables, frame-program-name, print-frame)
      (print-frame-chain-as-backtrace, frame-file, frame-line-number)
      (make-frame-chain, bootstrap-frame?, frame-number, frame-address):
      Remove these outdated functions.
    
    * module/system/vm/debug.scm (debugger-repl): Use
      frame-call-representation, and address@hidden
      (locals): New command, prints local variables in a frame.

-----------------------------------------------------------------------

Summary of changes:
 libguile/frames.c          |    4 -
 module/system/vm/debug.scm |   25 +++++-
 module/system/vm/frame.scm |  188 +++++++++-----------------------------------
 3 files changed, 57 insertions(+), 160 deletions(-)

diff --git a/libguile/frames.c b/libguile/frames.c
index 5c61eb0..5d390ab 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -304,15 +304,11 @@ scm_bootstrap_frames (void)
 {
   scm_tc16_frame = scm_make_smob_type ("frame", 0);
   scm_set_smob_print (scm_tc16_frame, frame_print);
-  scm_c_register_extension ("libguile", "scm_init_frames",
-                            (scm_t_extension_init_func)scm_init_frames, NULL);
 }
 
 void
 scm_init_frames (void)
 {
-  scm_bootstrap_vm ();
-
 #ifndef SCM_MAGIC_SNARFER
 #include "libguile/frames.x"
 #endif
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 462af50..be232c4 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -115,11 +115,12 @@
          ((zero? idx) walk)
          (else (lp (1+ idx) (frame-previous walk))))))
     (define (show-frame)
-;      #2  0x009600e0 in do_std_select (args=0xbfffd9e0) at threads.c:1668
-;      1668        select (select_args->nfds,
-      (let ((p (frame-procedure cur)))
-        (format #t "#~2a 0x~8,'0x in ~s~%" index (frame-instruction-pointer 
cur)
-                (cons (or (procedure-name p) p) (frame-arguments cur)))))
+      ;;      #2  0x009600e0 in do_std_select (args=0xbfffd9e0) at 
threads.c:1668
+      ;;      1668         select (select_args->nfds,
+      (format #t "#~2a 0x~8,'0x in address@hidden"
+              index
+              (frame-instruction-pointer cur)
+              (frame-call-representation cur)))
 
     (define-syntax define-command
       (syntax-rules ()
@@ -207,6 +208,20 @@ With an argument, select a frame by index, then show it."
         "Show some information about locally-bound variables in the selected 
frame."
          (format #t "~a\n" (frame-bindings cur)))
       
+      (define-command ((commands locals))
+        "Show locally-bound variables in the selected frame."
+        (for-each
+         (lambda (binding)
+           (format #t "~4d: ~a~:[~; (boxed)~]: address@hidden"
+                   (binding:index binding)
+                   (binding:name binding)
+                   (binding:boxed? binding)
+                   (let ((x (frame-local-ref cur (binding:index binding))))
+                     (if (binding:boxed? binding)
+                         (variable-ref x)
+                         x))))
+         (frame-bindings cur)))
+      
       (define-command ((commands quit q continue cont c))
         "Quit the debugger and let the program continue executing."
         (throw 'quit))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 5aa5962..c28197b 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -24,45 +24,35 @@
   #:use-module (system vm instruction)
   #:use-module (system vm objcode)
   #:use-module ((srfi srfi-1) #:select (fold))
-  #:export (frame-local-ref frame-local-set!
-            frame-instruction-pointer
-            frame-return-address frame-mv-return-address
-            frame-dynamic-link
-            frame-num-locals
-
-            frame-bindings frame-binding-ref frame-binding-set!
-            ; frame-arguments
-
-            frame-number frame-address
-            make-frame-chain
-            print-frame print-frame-chain-as-backtrace
-            frame-local-variables
+  #:export (frame-bindings
+            frame-lookup-binding
+            frame-binding-ref frame-binding-set!
+            frame-source frame-call-representation
             frame-environment
-            frame-variable-exists? frame-variable-ref frame-variable-set!
-            frame-object-name
-            frame-local-ref frame-local-set!
-            frame-return-address frame-program
-            frame-dynamic-link heap-frame?))
-
-(load-extension "libguile" "scm_init_frames")
+            frame-object-binding frame-object-name))
 
 (define (frame-bindings frame)
-  (map (lambda (b)
-         (cons (binding:name b) (binding:index b)))
-       (program-bindings-for-ip (frame-procedure frame)
-                                (frame-instruction-pointer frame))))
+  (program-bindings-for-ip (frame-procedure frame)
+                           (frame-instruction-pointer frame)))
+
+(define (frame-lookup-binding frame var)
+  (let lp ((bindings (frame-bindings frame)))
+    (cond ((null? bindings)
+           (error "variable not bound in frame" var frame))
+          ((eq? (binding:name (car bindings)) var)
+           (car bindings))
+          (else
+           (lp (cdr bindings))))))
 
 (define (frame-binding-set! frame var val)
-  (let ((i (assq-ref (frame-bindings frame) var)))
-    (if i
-        (frame-local-set! frame i val)
-        (error "variable not bound in frame" var frame))))
+  (frame-local-set! frame
+                    (binding:index (frame-lookup-binding frame var))
+                    val))
 
 (define (frame-binding-ref frame var)
-  (let ((i (assq-ref (frame-bindings frame) var)))
-    (if i
-        (frame-local-ref frame i)
-        (error "variable not bound in frame" var frame))))
+  (frame-local-ref frame
+                   (binding:index (frame-lookup-binding frame var))))
+
 
 ;; Basically there are two cases to deal with here:
 ;;
@@ -103,138 +93,34 @@
            (frame-local-ref frame i))
          (iota (frame-num-locals frame))))))
 
-;;;
-;;; Frame chain
-;;;
-
-(define frame-number (make-object-property))
-(define frame-address (make-object-property))
-
-;; FIXME: the header.
-(define (bootstrap-frame? frame)
-  (let ((code (objcode->bytecode (program-objcode (frame-program frame)))))
-    (and (= (uniform-vector-ref code (1- (uniform-vector-length code)))
-            (instruction->opcode 'halt)))))
-
-(define (make-frame-chain frame addr)
-  (define (make-rest)
-    (make-frame-chain (frame-dynamic-link frame)
-                      (frame-return-address frame)))
-  (cond
-   ((or (eq? frame #t) (eq? frame #f))
-    ;; handle #f or #t dynamic links
-    '())
-   ((bootstrap-frame? frame)
-    (make-rest))
-   (else
-    (let ((chain (make-rest)))
-      (set! (frame-number frame) (length chain))
-      (set! (frame-address frame)
-            (- addr (program-base (frame-program frame))))
-      (cons frame chain)))))
-
 
 ;;;
 ;;; Pretty printing
 ;;;
 
-(define (frame-line-number frame)
-  (let ((addr (frame-address frame)))
-    (cond ((assv addr (program-sources (frame-program frame)))
-           => source:line)
-          (else (format #f "@~a" addr)))))
-
-(define (frame-file frame prev)
-  (let ((sources (program-sources (frame-program frame))))
-    (if (null? sources)
-        prev
-        (or (source:file (car sources))
-            "current input"))))
-
-(define (print-frame frame)
-  (format #t "address@hidden: ~a   ~s\n" (frame-line-number frame) 
(frame-number frame)
-          (frame-call-representation frame)))
-
+(define (frame-source frame)
+  (program-source (frame-procedure frame)
+                  (frame-instruction-pointer frame)))
 
 (define (frame-call-representation frame)
-  (define (abbrev x)
-    (cond ((list? x)
-           (if (> (length x) 4)
-               (list (abbrev (car x)) (abbrev (cadr x)) '...)
-               (map abbrev x)))
-         ((pair? x)
-           (cons (abbrev (car x)) (abbrev (cdr x))))
-         ((vector? x)
-           (case (vector-length x)
-             ((0) x)
-             ((1) (vector (abbrev (vector-ref x 0))))
-             (else (vector (abbrev (vector-ref x 0)) '...))))
-         (else x)))
-  (abbrev (cons (frame-program-name frame) (frame-arguments frame))))
-
-(define (print-frame-chain-as-backtrace frames)
-  (if (null? frames)
-      (format #t "No backtrace available.\n")
-      (begin
-        (format #t "VM backtrace:\n")
-        (fold (lambda (frame file)
-                (let ((new-file (frame-file frame file)))
-                  (if (not (equal? new-file file))
-                      (format #t "In ~a:\n" new-file))
-                  (print-frame frame)
-                  new-file))
-              'no-file
-              frames))))
-
-(define (frame-program-name frame)
-  (let ((prog (frame-program frame))
-       (link (frame-dynamic-link frame)))
-    (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 (and (variable-bound? v)
-                                            (eq? prog (variable-ref v)))
-                                       s d))
-                  prog (module-obarray (current-module))))))
+  (let ((p (frame-procedure frame)))
+    (cons (or (procedure-name p) p) (frame-arguments frame))))
+
 
 
-;;; Frames
+;;; Misc
 ;;;
 
-(define (frame-local-variables frame)
-  (let* ((prog (frame-program frame))
-        (arity (program-arity prog)))
-    (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
-        (l '() (cons (frame-local-ref frame n) l)))
-       ((< n 0) l))))
-
-(define (frame-lookup-binding frame addr sym)
-  (assq sym (reverse (frame-bindings frame addr))))
-
-(define (frame-object-binding frame addr obj)
-  (do ((bs (frame-bindings frame addr) (cdr bs)))
-      ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
-       (and (pair? bs) (car bs)))))
-
-(define (frame-environment frame addr)
+(define (frame-environment frame)
   (map (lambda (binding)
         (cons (binding:name binding) (frame-binding-ref frame binding)))
-       (frame-bindings frame addr)))
-
-(define (frame-variable-exists? frame addr sym)
-  (if (frame-lookup-binding frame addr sym) #t #f))
-
-(define (frame-variable-ref frame addr sym)
-  (cond ((frame-lookup-binding frame addr sym) =>
-        (lambda (binding) (frame-binding-ref frame binding)))
-       (else (error "Unknown variable:" sym))))
+       (frame-bindings frame)))
 
-(define (frame-variable-set! frame addr sym val)
-  (cond ((frame-lookup-binding frame addr sym) =>
-        (lambda (binding) (frame-binding-set! frame binding val)))
-       (else (error "Unknown variable:" sym))))
+(define (frame-object-binding frame obj)
+  (do ((bs (frame-bindings frame) (cdr bs)))
+      ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
+       (and (pair? bs) (car bs)))))
 
-(define (frame-object-name frame addr obj)
-  (cond ((frame-object-binding frame addr obj) => binding:name)
+(define (frame-object-name frame obj)
+  (cond ((frame-object-binding frame obj) => binding:name)
        (else #f)))


hooks/post-receive
-- 
GNU Guile