module/system/vm/trace.scm

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