mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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 ~@y. (locals): New command, prints local variables in a frame.
This commit is contained in:
Andy Wingo
parent
b8596c08ac
commit
1c5e812258
3 changed files with 56 additions and 159 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ~60@y~%"
|
||||
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)~]: ~20t~60@y\n"
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -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 "~4@a: ~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))))
|
||||
(let ((p (frame-procedure frame)))
|
||||
(cons (or (procedure-name p) p) (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))))))
|
||||
|
||||
|
||||
;;; 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-environment frame)
|
||||
(map (lambda (binding)
|
||||
(cons (binding:name binding) (frame-binding-ref frame binding)))
|
||||
(frame-bindings frame)))
|
||||
|
||||
(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)))
|
||||
(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-environment frame addr)
|
||||
(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))))
|
||||
|
||||
(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-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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue