Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Guile VM tracer |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
e1203ea0 LC |
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 | |
17e90c5e KN |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (system vm trace) | |
8239263f | 22 | #:use-module (system base syntax) |
1a1a10d3 AW |
23 | #:use-module (system vm vm) |
24 | #:use-module (system vm frame) | |
25 | #:use-module (ice-9 format) | |
26 | #:export (vm-trace vm-trace-on vm-trace-off)) | |
17e90c5e | 27 | |
77046be3 | 28 | (define (vm-trace vm objcode . opts) |
46cd9a34 | 29 | (dynamic-wind |
75b55db5 | 30 | (lambda () (apply vm-trace-on vm opts)) |
ac99cb0c | 31 | (lambda () (vm-load vm objcode)) |
75b55db5 KN |
32 | (lambda () (apply vm-trace-off vm opts)))) |
33 | ||
77046be3 | 34 | (define (vm-trace-on vm . opts) |
75b55db5 | 35 | (set-vm-option! vm 'trace-first #t) |
1a1a10d3 | 36 | (if (memq #:b opts) (add-hook! (vm-next-hook vm) trace-next)) |
75b55db5 KN |
37 | (set-vm-option! vm 'trace-options opts) |
38 | (add-hook! (vm-apply-hook vm) trace-apply) | |
39 | (add-hook! (vm-return-hook vm) trace-return)) | |
40 | ||
77046be3 | 41 | (define (vm-trace-off vm . opts) |
1a1a10d3 | 42 | (if (memq #:b opts) (remove-hook! (vm-next-hook vm) trace-next)) |
75b55db5 KN |
43 | (remove-hook! (vm-apply-hook vm) trace-apply) |
44 | (remove-hook! (vm-return-hook vm) trace-return)) | |
17e90c5e KN |
45 | |
46 | (define (trace-next vm) | |
af988bbf | 47 | (define (puts x) (display #\tab) (write x)) |
a6df585a KN |
48 | (define (truncate! x n) |
49 | (if (> (length x) n) | |
50 | (list-cdr-set! x (1- n) '(...))) x) | |
51 | ;; main | |
af988bbf | 52 | (format #t "0x~8X ~16S" (vm:ip vm) (vm-fetch-code vm)) |
ac99cb0c KN |
53 | (do ((opts (vm-option vm 'trace-options) (cdr opts))) |
54 | ((null? opts) (newline)) | |
55 | (case (car opts) | |
a6df585a | 56 | ((:s) (puts (truncate! (vm-fetch-stack vm) 3))) |
af988bbf KN |
57 | ((:l) (puts (vm-fetch-locals vm))) |
58 | ((:e) (puts (vm-fetch-externals vm)))))) | |
17e90c5e KN |
59 | |
60 | (define (trace-apply vm) | |
af988bbf KN |
61 | (if (vm-option vm 'trace-first) |
62 | (set-vm-option! vm 'trace-first #f) | |
63 | (let ((chain (vm-current-frame-chain vm))) | |
64 | (print-indent chain) | |
65 | (print-frame-call (car chain)) | |
66 | (newline)))) | |
17e90c5e KN |
67 | |
68 | (define (trace-return vm) | |
af988bbf KN |
69 | (let ((chain (vm-current-frame-chain vm))) |
70 | (print-indent chain) | |
ac99cb0c | 71 | (write (vm-return-value vm)) |
17e90c5e KN |
72 | (newline))) |
73 | ||
af988bbf KN |
74 | (define (print-indent chain) |
75 | (cond ((pair? (cdr chain)) | |
76 | (display "| ") | |
77 | (print-indent (cdr chain))))) |