mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 16:30:19 +02:00
Code Activity

tracepoints print their trap number

Browse source 
* module/system/vm/trace.scm (print-application, print-return): Add a
  prefix before the printout.
  (trace-calls-to-procedure, trace-calls-in-procedure): Add prefix
  keyword args.

* module/system/vm/trap-state.scm (add-trace-at-procedure-call!): Give a
  useful prefix for tracepoint printouts.
This commit is contained in:
Andy Wingo 2010-09-23 17:17:16 +02:00
parent 25361a80fe
commit abb4b5cbbd
2 changed files with 19 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -43,43 +43,45 @@
(frame-local-ref frame (+ (- len nvalues) i))) (frame-local-ref frame (+ (- len nvalues) i)))
(iota nvalues)))) (iota nvalues))))
(define (print-application frame depth width) (define (print-application frame depth width prefix)
(format (current-error-port) "~a~v:@y\n" (format (current-error-port) "~a~a~v:@y\n"
(make-string depth #\|) prefix (make-string depth #\|)
(max (- width depth) 1) (max (- width depth) 1)
(frame-call-representation frame))) (frame-call-representation frame)))
(define (print-return frame depth width) (define (print-return frame depth width prefix)
(let* ((len (frame-num-locals frame)) (let* ((len (frame-num-locals frame))
(nvalues (frame-local-ref frame (1- len)))) (nvalues (frame-local-ref frame (1- len))))
(cond (cond
((= nvalues 1) ((= nvalues 1)
(format (current-error-port) "~a~v:@y\n" (format (current-error-port) "~a~a~v:@y\n"
(make-string depth #\|) prefix (make-string depth #\|)
width (frame-local-ref frame (- len 2)))) width (frame-local-ref frame (- len 2))))
(else (else
;; this should work, but there appears to be a bug ;; this should work, but there appears to be a bug
;; "~a~d values:~:{ ~v:@y~}\n" ;; "~a~d values:~:{ ~v:@y~}\n"
(format (current-error-port) "~a~d values:~{ ~a~}\n" (format (current-error-port) "~a ~a~d values:~{ ~a~}\n"
(make-string depth #\|) prefix (make-string depth #\|)
nvalues nvalues
(map (lambda (val) (map (lambda (val)
(format #f "~v:@y" width val)) (format #f "~v:@y" width val))
(frame-return-values frame))))))) (frame-return-values frame)))))))
(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))) (define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
(prefix "trace: "))
(define (apply-handler frame depth) (define (apply-handler frame depth)
(print-application frame depth width)) (print-application frame depth width prefix))
(define (return-handler frame depth) (define (return-handler frame depth)
(print-return frame depth width)) (print-return frame depth width prefix))
(trap-calls-to-procedure proc apply-handler return-handler (trap-calls-to-procedure proc apply-handler return-handler
#:vm vm)) #:vm vm))
(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))) (define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
(prefix "trace: "))
(define (apply-handler frame depth) (define (apply-handler frame depth)
(print-application frame depth width)) (print-application frame depth width prefix))
(define (return-handler frame depth) (define (return-handler frame depth)
(print-return frame depth width)) (print-return frame depth width prefix))
(trap-calls-in-dynamic-extent proc apply-handler return-handler (trap-calls-in-dynamic-extent proc apply-handler return-handler
#:vm vm)) #:vm vm))

4
module/system/vm/trap-state.scm
View file

@ -197,7 +197,9 @@
(define* (add-trace-at-procedure-call! proc (define* (add-trace-at-procedure-call! proc
#:optional (trap-state (the-trap-state))) #:optional (trap-state (the-trap-state)))
(let* ((idx (next-index! trap-state)) (let* ((idx (next-index! trap-state))
(trap (trace-calls-to-procedure proc))) (trap (trace-calls-to-procedure
proc
#:prefix (format #f "trace trap ~a: " idx))))
(add-trap-wrapper! (add-trap-wrapper!
trap-state trap-state
(make-trap-wrapper (make-trap-wrapper