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 (system vm instruction)
  29   #:use-module (ice-9 format)
  30   #:export (trace-calls-in-procedure
  31             trace-calls-to-procedure
  32             trace-instructions-in-procedure
  33             call-with-trace))
  34
  35 (define (build-prefix prefix depth infix numeric-format max-indent)
  36   (let lp ((indent "") (n 0))
  37     (cond
  38      ((= n depth)
  39       (string-append prefix indent))
  40      ((< (+ (string-length indent) (string-length infix)) max-indent)
  41       (lp (string-append indent infix) (1+ n)))
  42      (else
  43       (string-append prefix indent (format #f numeric-format depth))))))
  44
  45 (define (print-application frame depth width prefix max-indent)
  46   (let ((prefix (build-prefix prefix depth "|  " "~d> " max-indent)))
  47     (format (current-error-port) "~a~v:@y\n"
  48             prefix
  49             width
  50             (frame-call-representation frame))))
  51
  52 (define* (print-return frame depth width prefix max-indent values)
  53   (let ((prefix (build-prefix prefix depth "|  " "~d< "max-indent)))
  54     (case (length values)
  55       ((0)
  56        (format (current-error-port) "~ano values\n" prefix))
  57       ((1)
  58        (format (current-error-port) "~a~v:@y\n"
  59                prefix
  60                width
  61                (car values)))
  62       (else
  63        ;; this should work, but there appears to be a bug
  64        ;; "~a~d values:~:{ ~v:@y~}\n"
  65        (format (current-error-port) "~a~d values:~{ ~a~}\n"
  66                prefix (length values)
  67                (map (lambda (val)
  68                       (format #f "~v:@y" width val))
  69                     values))))))
  70
  71 (define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
  72                                    (prefix "trace: ")
  73                                    (max-indent (- width 40)))
  74   (define (apply-handler frame depth)
  75     (print-application frame depth width prefix max-indent))
  76   (define (return-handler frame depth . values)
  77     (print-return frame depth width prefix max-indent values))
  78   (trap-calls-to-procedure proc apply-handler return-handler
  79                            #:vm vm))
  80
  81 (define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
  82                                    (prefix "trace: ")
  83                                    (max-indent (- width 40)))
  84   (define (apply-handler frame depth)
  85     (print-application frame depth width prefix max-indent))
  86   (define (return-handler frame depth . values)
  87     (print-return frame depth width prefix max-indent values))
  88   (trap-calls-in-dynamic-extent proc apply-handler return-handler
  89                                 #:vm vm))
  90
  91 (define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
  92                                           (max-indent (- width 40)))
  93   (define (trace-next frame)
  94     ;; FIXME: We could disassemble this instruction here.
  95     (let ((ip (frame-instruction-pointer frame)))
  96       (format #t "0x~x\n" ip)))
  97
  98   (trap-instructions-in-dynamic-extent proc trace-next
  99                                        #:vm vm))
 100
 101 ;; Note that because this procedure manipulates the VM trace level
 102 ;; directly, it doesn't compose well with traps at the REPL.
 103 ;;
 104 (define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
 105                           (width 80) (vm (the-vm)) (max-indent (- width 40)))
 106   (let ((call-trap #f)
 107         (inst-trap #f))
 108     (dynamic-wind
 109       (lambda ()
 110         (if calls?
 111             (set! call-trap
 112                   (trace-calls-in-procedure thunk #:vm vm #:width width
 113                                             #:max-indent max-indent)))
 114         (if instructions?
 115             (set! inst-trap
 116                   (trace-instructions-in-procedure thunk #:vm vm #:width width
 117                                                    #:max-indent max-indent)))
 118         (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
 119       thunk
 120       (lambda ()
 121         (set-vm-trace-level! vm (1- (vm-trace-level vm)))
 122         (if call-trap (call-trap))
 123         (if inst-trap (inst-trap))
 124         (set! call-trap #f)
 125         (set! inst-trap #f)))))