module/system/vm/trace.scm

   1 ;;; Guile VM tracer
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program 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
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (system vm trace)
  23   :use-syntax (system base syntax)
  24   :use-module (system vm vm)
  25   :use-module (system vm frame)
  26   :use-module (ice-9 format)
  27   :export (vm-trace vm-trace-on vm-trace-off))
  28
  29 (define (vm-trace vm objcode . opts)
  30   (dynamic-wind
  31       (lambda () (apply vm-trace-on vm opts))
  32       (lambda () (vm-load vm objcode))
  33       (lambda () (apply vm-trace-off vm opts))))
  34
  35 (define (vm-trace-on vm . opts)
  36   (set-vm-option! vm 'trace-first #t)
  37   (if (memq :b opts) (add-hook! (vm-next-hook vm) trace-next))
  38   (set-vm-option! vm 'trace-options opts)
  39   (add-hook! (vm-apply-hook vm) trace-apply)
  40   (add-hook! (vm-return-hook vm) trace-return))
  41
  42 (define (vm-trace-off vm . opts)
  43   (if (memq :b opts) (remove-hook! (vm-next-hook vm) trace-next))
  44   (remove-hook! (vm-apply-hook vm) trace-apply)
  45   (remove-hook! (vm-return-hook vm) trace-return))
  46
  47 (define (trace-next vm)
  48   (define (puts x) (display #\tab) (write x))
  49   (define (truncate! x n)
  50     (if (> (length x) n)
  51       (list-cdr-set! x (1- n) '(...))) x)
  52   ;; main
  53   (format #t "0x~8X  ~16S" (vm:ip vm) (vm-fetch-code vm))
  54   (do ((opts (vm-option vm 'trace-options) (cdr opts)))
  55       ((null? opts) (newline))
  56     (case (car opts)
  57       ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
  58       ((:l) (puts (vm-fetch-locals vm)))
  59       ((:e) (puts (vm-fetch-externals vm))))))
  60
  61 (define (trace-apply vm)
  62   (if (vm-option vm 'trace-first)
  63     (set-vm-option! vm 'trace-first #f)
  64     (let ((chain (vm-current-frame-chain vm)))
  65       (print-indent chain)
  66       (print-frame-call (car chain))
  67       (newline))))
  68
  69 (define (trace-return vm)
  70   (let ((chain (vm-current-frame-chain vm)))
  71     (print-indent chain)
  72     (write (vm-return-value vm))
  73     (newline)))
  74
  75 (define (print-indent chain)
  76   (cond ((pair? (cdr chain))
  77          (display "| ")
  78          (print-indent (cdr chain)))))