module/system/vm/trace.scm

   1 ;;; Guile VM tracer
   2
   3 ;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
   4
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (system vm trace)
  22   #:use-module (system base syntax)
  23   #:use-module (system vm vm)
  24   #:use-module (system vm frame)
  25   #:use-module (system vm program)
  26   #:use-module (system vm traps)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (ice-9 format)
  29   #:export (trace-calls-in-procedure
  30             trace-calls-to-procedure
  31             trace-instructions-in-procedure
  32             call-with-trace))
  33
  34 (define (build-prefix prefix depth infix numeric-format max-indent)
  35   (let lp ((indent "") (n 0))
  36     (cond
  37      ((= n depth)
  38       (string-append prefix indent))
  39      ((< (+ (string-length indent) (string-length infix)) max-indent)
  40       (lp (string-append indent infix) (1+ n)))
  41      (else
  42       (string-append prefix indent (format #f numeric-format depth))))))
  43
  44 (define (print-application frame depth width prefix max-indent)
  45   (let ((prefix (build-prefix prefix depth "|  " "~d> " max-indent)))
  46     (format (current-error-port) "~a~v:@y\n"
  47             prefix
  48             width
  49             (frame-call-representation frame))))
  50
  51 (define* (print-return frame depth width prefix max-indent values)
  52   (let ((prefix (build-prefix prefix depth "|  " "~d< "max-indent)))
  53     (case (length values)
  54       ((0)
  55        (format (current-error-port) "~ano values\n" prefix))
  56       ((1)
  57        (format (current-error-port) "~a~v:@y\n"
  58                prefix
  59                width
  60                (car values)))
  61       (else
  62        ;; this should work, but there appears to be a bug
  63        ;; "~a~d values:~:{ ~v:@y~}\n"
  64        (format (current-error-port) "~a~d values:~{ ~a~}\n"
  65                prefix (length values)
  66                (map (lambda (val)
  67                       (format #f "~v:@y" width val))
  68                     values))))))
  69
  70 (define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
  71                                    (prefix "trace: ")
  72                                    (max-indent (- width 40)))
  73   (define (apply-handler frame depth)
  74     (print-application frame depth width prefix max-indent))
  75   (define (return-handler frame depth . values)
  76     (print-return frame depth width prefix max-indent values))
  77   (trap-calls-to-procedure proc apply-handler return-handler
  78                            #:vm vm))
  79
  80 (define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
  81                                    (prefix "trace: ")
  82                                    (max-indent (- width 40)))
  83   (define (apply-handler frame depth)
  84     (print-application frame depth width prefix max-indent))
  85   (define (return-handler frame depth . values)
  86     (print-return frame depth width prefix max-indent values))
  87   (trap-calls-in-dynamic-extent proc apply-handler return-handler
  88                                 #:vm vm))
  89
  90 (define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
  91                                           (max-indent (- width 40)))
  92   (define (trace-next frame)
  93     ;; FIXME: We could disassemble this instruction here.
  94     (let ((ip (frame-instruction-pointer frame)))
  95       (format #t "0x~x\n" ip)))
  96
  97   (trap-instructions-in-dynamic-extent proc trace-next
  98                                        #:vm vm))
  99
 100 ;; Note that because this procedure manipulates the VM trace level
 101 ;; directly, it doesn't compose well with traps at the REPL.
 102 ;;
 103 (define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
 104                           (width 80) (vm (the-vm)) (max-indent (- width 40)))
 105   (let ((call-trap #f)
 106         (inst-trap #f))
 107     (dynamic-wind
 108       (lambda ()
 109         (if calls?
 110             (set! call-trap
 111                   (trace-calls-in-procedure thunk #:vm vm #:width width
 112                                             #:max-indent max-indent)))
 113         (if instructions?
 114             (set! inst-trap
 115                   (trace-instructions-in-procedure thunk #:vm vm #:width width
 116                                                    #:max-indent max-indent)))
 117         (set-vm-trace-level! (1+ (vm-trace-level))))
 118       thunk
 119       (lambda ()
 120         (set-vm-trace-level! (1- (vm-trace-level)))
 121         (if call-trap (call-trap))
 122         (if inst-trap (inst-trap))
 123         (set! call-trap #f)
 124         (set! inst-trap #f)))))