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)
  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
  79 (define* (trace-calls-in-procedure proc #:key (width 80)
  80                                    (prefix "trace: ")
  81                                    (max-indent (- width 40)))
  82   (define (apply-handler frame depth)
  83     (print-application frame depth width prefix max-indent))
  84   (define (return-handler frame depth . values)
  85     (print-return frame depth width prefix max-indent values))
  86   (trap-calls-in-dynamic-extent proc apply-handler return-handler))
  87
  88 (define* (trace-instructions-in-procedure proc #:key (width 80)
  89                                           (max-indent (- width 40)))
  90   (define (trace-next frame)
  91     ;; FIXME: We could disassemble this instruction here.
  92     (let ((ip (frame-instruction-pointer frame)))
  93       (format #t "0x~x\n" ip)))
  94
  95   (trap-instructions-in-dynamic-extent proc trace-next))
  96
  97 ;; Note that because this procedure manipulates the VM trace level
  98 ;; directly, it doesn't compose well with traps at the REPL.
  99 ;;
 100 (define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
 101                           (width 80) (max-indent (- width 40)))
 102   (let ((call-trap #f)
 103         (inst-trap #f))
 104     (dynamic-wind
 105       (lambda ()
 106         (if calls?
 107             (set! call-trap
 108                   (trace-calls-in-procedure thunk #:width width
 109                                             #:max-indent max-indent)))
 110         (if instructions?
 111             (set! inst-trap
 112                   (trace-instructions-in-procedure thunk #:width width
 113                                                    #:max-indent max-indent)))
 114         (set-vm-trace-level! (1+ (vm-trace-level))))
 115       thunk
 116       (lambda ()
 117         (set-vm-trace-level! (1- (vm-trace-level)))
 118         (if call-trap (call-trap))
 119         (if inst-trap (inst-trap))
 120         (set! call-trap #f)
 121         (set! inst-trap #f)))))