Commit | Line | Data |
---|---|---|
33df2ec7 AW |
1 | ;;; Guile VM debugging facilities |
2 | ||
3 | ;;; Copyright (C) 2001, 2009, 2010 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 repl debug) | |
22 | #:use-module (system base pmatch) | |
23 | #:use-module (system base syntax) | |
24 | #:use-module (system base language) | |
25 | #:use-module (system vm vm) | |
26 | #:use-module (system vm frame) | |
27 | #:use-module (ice-9 rdelim) | |
28 | #:use-module (ice-9 pretty-print) | |
29 | #:use-module (ice-9 format) | |
30 | #:use-module ((system vm inspect) #:select ((inspect . %inspect))) | |
31 | #:use-module (system vm program) | |
32 | #:export (<debug> | |
54d9a994 | 33 | make-debug debug? debug-frames debug-index debug-error-message |
542f975e | 34 | print-registers print-locals print-frame print-frames frame->module |
33df2ec7 AW |
35 | stack->vector narrow-stack->vector)) |
36 | ||
2e67eb6f AW |
37 | ;; TODO: |
38 | ;; | |
2e67eb6f AW |
39 | ;; eval expression in context of frame |
40 | ;; set local variable in frame | |
41 | ;; step until next instruction | |
42 | ;; step until next function call/return | |
43 | ;; step until return from frame | |
44 | ;; step until different source line | |
45 | ;; step until greater source line | |
46 | ;; watch expression | |
2e67eb6f | 47 | ;; set printing width |
2e67eb6f AW |
48 | ;; disassemble the current function |
49 | ;; inspect any object | |
2e67eb6f | 50 | ;; (state associated with vm ?) |
33df2ec7 AW |
51 | |
52 | ;;; | |
53 | ;;; Debugger | |
54 | ;;; | |
55 | ;;; The actual interaction loop of the debugger is run by the repl. This module | |
56 | ;;; simply exports a data structure to hold the debugger state, along with its | |
57 | ;;; accessors, and provides some helper functions. | |
58 | ;;; | |
59 | ||
54d9a994 | 60 | (define-record <debug> frames index error-message) |
33df2ec7 AW |
61 | |
62 | \f | |
63 | ||
64 | (define (reverse-hashq h) | |
65 | (let ((ret (make-hash-table))) | |
66 | (hash-for-each | |
67 | (lambda (k v) | |
68 | (hashq-set! ret v (cons k (hashq-ref ret v '())))) | |
69 | h) | |
70 | ret)) | |
71 | ||
542f975e AW |
72 | (define* (print-registers frame #:optional (port (current-output-port)) |
73 | #:key (per-line-prefix " ")) | |
74 | (define (print fmt val) | |
75 | (display per-line-prefix port) | |
76 | (run-hook before-print-hook val) | |
77 | (format port fmt val)) | |
78 | ||
79 | (format port "~aRegisters:~%" per-line-prefix) | |
80 | (print "ip = ~d\n" (frame-instruction-pointer frame)) | |
81 | (print "sp = #x~x\n" (frame-stack-pointer frame)) | |
82 | (print "fp = #x~x\n" (frame-address frame))) | |
83 | ||
33df2ec7 | 84 | (define* (print-locals frame #:optional (port (current-output-port)) |
97b3800e | 85 | #:key (width 72) (per-line-prefix " ")) |
33df2ec7 AW |
86 | (let ((bindings (frame-bindings frame))) |
87 | (cond | |
88 | ((null? bindings) | |
89 | (format port "~aNo local variables.~%" per-line-prefix)) | |
90 | (else | |
91 | (format port "~aLocal variables:~%" per-line-prefix) | |
92 | (for-each | |
93 | (lambda (binding) | |
97b3800e AW |
94 | (let ((v (let ((x (frame-local-ref frame (binding:index binding)))) |
95 | (if (binding:boxed? binding) | |
96 | (variable-ref x) | |
97 | x)))) | |
98 | (display per-line-prefix port) | |
99 | (run-hook before-print-hook v) | |
100 | (format port "~a~:[~; (boxed)~] = ~v:@y\n" | |
101 | (binding:name binding) (binding:boxed? binding) width v))) | |
33df2ec7 AW |
102 | (frame-bindings frame)))))) |
103 | ||
104 | (define* (print-frame frame #:optional (port (current-output-port)) | |
105 | #:key index (width 72) (full? #f) (last-source #f)) | |
106 | (define (source:pretty-file source) | |
107 | (if source | |
108 | (or (source:file source) "current input") | |
109 | "unknown file")) | |
110 | (let* ((source (frame-source frame)) | |
111 | (file (source:pretty-file source)) | |
08039143 AW |
112 | (line (and=> source source:line)) |
113 | (col (and=> source source:column))) | |
33df2ec7 AW |
114 | (if (and file (not (equal? file (source:pretty-file last-source)))) |
115 | (format port "~&In ~a:~&" file)) | |
08039143 AW |
116 | (format port "~9@a~:[~*~3_~;~3d~] ~v:@y~%" |
117 | (if line (format #f "~a:~a" line col) "") | |
118 | index index width (frame-call-representation frame)) | |
33df2ec7 AW |
119 | (if full? |
120 | (print-locals frame #:width width | |
121 | #:per-line-prefix " ")))) | |
122 | ||
123 | (define* (print-frames frames | |
124 | #:optional (port (current-output-port)) | |
125 | #:key (width 72) (full? #f) (forward? #f) count) | |
126 | (let* ((len (vector-length frames)) | |
127 | (lower-idx (if (or (not count) (positive? count)) | |
128 | 0 | |
129 | (max 0 (+ len count)))) | |
130 | (upper-idx (if (and count (negative? count)) | |
131 | (1- len) | |
132 | (1- (if count (min count len) len)))) | |
133 | (inc (if forward? 1 -1))) | |
134 | (let lp ((i (if forward? lower-idx upper-idx)) | |
135 | (last-source #f)) | |
136 | (if (<= lower-idx i upper-idx) | |
137 | (let* ((frame (vector-ref frames i))) | |
138 | (print-frame frame port #:index i #:width width #:full? full? | |
139 | #:last-source last-source) | |
140 | (lp (+ i inc) (frame-source frame))))))) | |
141 | ||
142 | ;; Ideally here we would have something much more syntactic, in that a set! to a | |
143 | ;; local var that is not settable would raise an error, and export etc forms | |
144 | ;; would modify the module in question: but alack, this is what we have now. | |
145 | ;; Patches welcome! | |
146 | (define (frame->module frame) | |
147 | (let ((proc (frame-procedure frame))) | |
148 | (if (program? proc) | |
149 | (let* ((mod (or (program-module proc) (current-module))) | |
150 | (mod* (make-module))) | |
151 | (module-use! mod* mod) | |
152 | (for-each | |
153 | (lambda (binding) | |
154 | (let* ((x (frame-local-ref frame (binding:index binding))) | |
155 | (var (if (binding:boxed? binding) x (make-variable x)))) | |
156 | (format #t | |
157 | "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n" | |
158 | (binding:boxed? binding) | |
159 | (binding:name binding) | |
160 | (if (variable-bound? var) (variable-ref var) var)) | |
161 | (module-add! mod* (binding:name binding) var))) | |
162 | (frame-bindings frame)) | |
163 | mod*) | |
164 | (current-module)))) | |
165 | ||
166 | ||
33df2ec7 AW |
167 | (define (stack->vector stack) |
168 | (let* ((len (stack-length stack)) | |
169 | (v (make-vector len))) | |
170 | (if (positive? len) | |
171 | (let lp ((i 0) (frame (stack-ref stack 0))) | |
172 | (if (< i len) | |
173 | (begin | |
174 | (vector-set! v i frame) | |
175 | (lp (1+ i) (frame-previous frame)))))) | |
176 | v)) | |
177 | ||
178 | (define (narrow-stack->vector stack . args) | |
3d4f8e3c AW |
179 | (let ((narrowed (apply make-stack (stack-ref stack 0) args))) |
180 | (if narrowed | |
181 | (stack->vector narrowed) | |
182 | #()))) ; ? Can be the case for a tail-call to `throw' tho | |
183 | ||
33df2ec7 | 184 | |
2e67eb6f AW |
185 | ;; (define (debug) |
186 | ;; (run-debugger | |
187 | ;; (narrow-stack->vector | |
188 | ;; (make-stack #t) | |
189 | ;; ;; Narrow the `make-stack' frame and the `debug' frame | |
190 | ;; 2 | |
191 | ;; ;; Narrow the end of the stack to the most recent start-stack. | |
192 | ;; (and (pair? (fluid-ref %stacks)) | |
193 | ;; (cdar (fluid-ref %stacks)))))) | |
194 |