Commit | Line | Data |
---|---|---|
17e90c5e KN |
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) | |
41f248a8 | 23 | :use-syntax (system base syntax) |
07e56b27 | 24 | :use-module (system vm vm) |
ac99cb0c | 25 | :use-module (system vm frame) |
77046be3 AW |
26 | :use-module (ice-9 format) |
27 | :export (vm-trace vm-trace-on vm-trace-off)) | |
17e90c5e | 28 | |
77046be3 | 29 | (define (vm-trace vm objcode . opts) |
46cd9a34 | 30 | (dynamic-wind |
75b55db5 | 31 | (lambda () (apply vm-trace-on vm opts)) |
ac99cb0c | 32 | (lambda () (vm-load vm objcode)) |
75b55db5 KN |
33 | (lambda () (apply vm-trace-off vm opts)))) |
34 | ||
77046be3 | 35 | (define (vm-trace-on vm . opts) |
75b55db5 KN |
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 | ||
77046be3 | 42 | (define (vm-trace-off vm . opts) |
75b55db5 KN |
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)) | |
17e90c5e KN |
46 | |
47 | (define (trace-next vm) | |
af988bbf | 48 | (define (puts x) (display #\tab) (write x)) |
a6df585a KN |
49 | (define (truncate! x n) |
50 | (if (> (length x) n) | |
51 | (list-cdr-set! x (1- n) '(...))) x) | |
52 | ;; main | |
af988bbf | 53 | (format #t "0x~8X ~16S" (vm:ip vm) (vm-fetch-code vm)) |
ac99cb0c KN |
54 | (do ((opts (vm-option vm 'trace-options) (cdr opts))) |
55 | ((null? opts) (newline)) | |
56 | (case (car opts) | |
a6df585a | 57 | ((:s) (puts (truncate! (vm-fetch-stack vm) 3))) |
af988bbf KN |
58 | ((:l) (puts (vm-fetch-locals vm))) |
59 | ((:e) (puts (vm-fetch-externals vm)))))) | |
17e90c5e KN |
60 | |
61 | (define (trace-apply vm) | |
af988bbf KN |
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)))) | |
17e90c5e KN |
68 | |
69 | (define (trace-return vm) | |
af988bbf KN |
70 | (let ((chain (vm-current-frame-chain vm))) |
71 | (print-indent chain) | |
ac99cb0c | 72 | (write (vm-return-value vm)) |
17e90c5e KN |
73 | (newline))) |
74 | ||
af988bbf KN |
75 | (define (print-indent chain) |
76 | (cond ((pair? (cdr chain)) | |
77 | (display "| ") | |
78 | (print-indent (cdr chain))))) |