mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +02:00
Code Activity

vm-trace prints return values

Browse source 
* module/system/vm/trace.scm (vm-trace): Add a #:width argument. Print
  return values, as Chez Scheme does.
This commit is contained in:
Andy Wingo 2010-01-14 00:09:54 +01:00
parent 45cc48673a
commit 7ea3e4ff28
1 changed files with 32 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

47
module/system/vm/trace.scm
View file

@ -25,10 +25,9 @@
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:export (vm-trace)) #:export (vm-trace))
(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f)) (define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
(define *call-depth* #f) (define *call-depth* #f)
(define *saved-call-depth* #f) (define *saved-call-depth* #f)
(define *last-printed-call-depth* 0)
(define (trace-enter frame) (define (trace-enter frame)
(cond (cond
@ -38,29 +37,47 @@
(define (trace-exit frame) (define (trace-exit frame)
(cond (cond
((not *call-depth*)) ((not *call-depth*))
((< *call-depth* 0)
;; leaving the thunk
(set! *call-depth* #f))
(else (else
(set! *call-depth* (1- *call-depth*))))) (set! *call-depth* (1- *call-depth*)))))
(define (trace-apply frame) (define (trace-apply frame)
(cond (cond
(*call-depth* (*call-depth*
(let ((last-depth *last-printed-call-depth*)) (format (current-error-port) "~a~v:@y\n"
(set! *last-printed-call-depth* *call-depth*) (make-string (1- *call-depth*) #\|)
(format (current-error-port) "~a ~a~{ ~a~}\n" (max (- width *call-depth* 1) 1)
(make-string *call-depth* #\*) (frame-call-representation frame)))
(let ((p (frame-procedure frame)))
(or (procedure-name p) p))
(frame-arguments frame))))
((eq? (frame-procedure frame) thunk) ((eq? (frame-procedure frame) thunk)
(set! *call-depth* 0)))) (set! *call-depth* 1))))
(define (trace-return frame) (define (trace-return frame)
;; nop, though we could print the return i guess ;; nop, though we could print the return i guess
#t) (cond
((and *call-depth* (< *call-depth* 0))
;; leaving the thunk
(set! *call-depth* #f))
(*call-depth*
(let* ((len (frame-num-locals frame))
(nvalues (frame-local-ref frame (1- len))))
(cond
((= nvalues 1)
(format (current-error-port) "~a~v:@y\n"
(make-string *call-depth* #\|)
width (frame-local-ref frame (- len 2))))
(else
;; this should work, but there appears to be a bug
;; "~a~d values:~:{ ~v:@y~}\n"
(format (current-error-port) "~a~d values:~{ ~a~}\n"
(make-string *call-depth* #\|)
nvalues
(let lp ((vals '()) (i 0))
(if (= i nvalues)
vals
(lp (cons (format #f "~v:@y" width
(frame-local-ref frame (- len 2 i)))
vals)
(1+ i)))))))))))
(define (trace-next frame) (define (trace-next frame)
(format #t "0x~8X" (frame-instruction-pointer frame)) (format #t "0x~8X" (frame-instruction-pointer frame))
;; should disassemble the thingy; could print stack, or stack trace, ;; should disassemble the thingy; could print stack, or stack trace,