-;;; Guile VM tracer
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (system vm trace)
- #:use-syntax (system base syntax)
- #:use-module (system vm vm)
- #:use-module (system vm frame)
- #:use-module (ice-9 format)
- #:export (vm-trace vm-trace-on vm-trace-off))
-
-(define (vm-trace vm objcode . opts)
- (dynamic-wind
- (lambda () (apply vm-trace-on vm opts))
- (lambda () (vm-load vm objcode))
- (lambda () (apply vm-trace-off vm opts))))
-
-(define (vm-trace-on vm . opts)
- (set-vm-option! vm 'trace-first #t)
- (if (memq #:b opts) (add-hook! (vm-next-hook vm) trace-next))
- (set-vm-option! vm 'trace-options opts)
- (add-hook! (vm-apply-hook vm) trace-apply)
- (add-hook! (vm-return-hook vm) trace-return))
-
-(define (vm-trace-off vm . opts)
- (if (memq #:b opts) (remove-hook! (vm-next-hook vm) trace-next))
- (remove-hook! (vm-apply-hook vm) trace-apply)
- (remove-hook! (vm-return-hook vm) trace-return))
-
-(define (trace-next vm)
- (define (puts x) (display #\tab) (write x))
- (define (truncate! x n)
- (if (> (length x) n)
- (list-cdr-set! x (1- n) '(...))) x)
- ;; main
- (format #t "0x~8X ~16S" (vm:ip vm) (vm-fetch-code vm))
- (do ((opts (vm-option vm 'trace-options) (cdr opts)))
- ((null? opts) (newline))
- (case (car opts)
- ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
- ((:l) (puts (vm-fetch-locals vm)))
- ((:e) (puts (vm-fetch-externals vm))))))
-
-(define (trace-apply vm)
- (if (vm-option vm 'trace-first)
- (set-vm-option! vm 'trace-first #f)
- (let ((chain (vm-current-frame-chain vm)))
- (print-indent chain)
- (print-frame-call (car chain))
- (newline))))
-
-(define (trace-return vm)
- (let ((chain (vm-current-frame-chain vm)))
- (print-indent chain)
- (write (vm-return-value vm))
- (newline)))
-
-(define (print-indent chain)
- (cond ((pair? (cdr chain))
- (display "| ")
- (print-indent (cdr chain)))))
+;;; Guile VM tracer
+
+;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm trace)
+ #:use-module (system base syntax)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
+ #:use-module (system vm traps)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm instruction)
+ #:use-module (ice-9 format)
+ #:export (trace-calls-in-procedure
+ trace-calls-to-procedure
+ trace-instructions-in-procedure
+ call-with-trace))
+
+(define (build-prefix prefix depth infix numeric-format max-indent)
+ (let lp ((indent "") (n 0))
+ (cond
+ ((= n depth)
+ (string-append prefix indent))
+ ((< (+ (string-length indent) (string-length infix)) max-indent)
+ (lp (string-append indent infix) (1+ n)))
+ (else
+ (string-append prefix indent (format #f numeric-format depth))))))
+
+(define (print-application frame depth width prefix max-indent)
+ (let ((prefix (build-prefix prefix depth "| " "~d> " max-indent)))
+ (format (current-error-port) "~a~v:@y\n"
+ prefix
+ width
+ (frame-call-representation frame))))
+
+(define* (print-return frame depth width prefix max-indent values)
+ (let ((prefix (build-prefix prefix depth "| " "~d< "max-indent)))
+ (case (length values)
+ ((0)
+ (format (current-error-port) "~ano values\n" prefix))
+ ((1)
+ (format (current-error-port) "~a~v:@y\n"
+ prefix
+ width
+ (car values)))
+ (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"
+ prefix (length values)
+ (map (lambda (val)
+ (format #f "~v:@y" width val))
+ values))))))
+
+(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
+ (prefix "trace: ")
+ (max-indent (- width 40)))
+ (define (apply-handler frame depth)
+ (print-application frame depth width prefix max-indent))
+ (define (return-handler frame depth . values)
+ (print-return frame depth width prefix max-indent values))
+ (trap-calls-to-procedure proc apply-handler return-handler
+ #:vm vm))
+
+(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
+ (prefix "trace: ")
+ (max-indent (- width 40)))
+ (define (apply-handler frame depth)
+ (print-application frame depth width prefix max-indent))
+ (define (return-handler frame depth . values)
+ (print-return frame depth width prefix max-indent values))
+ (trap-calls-in-dynamic-extent proc apply-handler return-handler
+ #:vm vm))
+
+(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
+ (max-indent (- width 40)))
+ (define (trace-next frame)
+ ;; FIXME: We could disassemble this instruction here.
+ (let ((ip (frame-instruction-pointer frame)))
+ (format #t "0x~x\n" ip)))
+
+ (trap-instructions-in-dynamic-extent proc trace-next
+ #:vm vm))
+
+;; Note that because this procedure manipulates the VM trace level
+;; directly, it doesn't compose well with traps at the REPL.
+;;
+(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
+ (width 80) (vm (the-vm)) (max-indent (- width 40)))
+ (let ((call-trap #f)
+ (inst-trap #f))
+ (dynamic-wind
+ (lambda ()
+ (if calls?
+ (set! call-trap
+ (trace-calls-in-procedure thunk #:vm vm #:width width
+ #:max-indent max-indent)))
+ (if instructions?
+ (set! inst-trap
+ (trace-instructions-in-procedure thunk #:vm vm #:width width
+ #:max-indent max-indent)))
+ (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
+ thunk
+ (lambda ()
+ (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+ (if call-trap (call-trap))
+ (if inst-trap (inst-trap))
+ (set! call-trap #f)
+ (set! inst-trap #f)))))