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