Commit | Line | Data |
---|---|---|
8746959c NJ |
1 | ;;;; (ice-9 debugging breakpoints) -- practical breakpoints |
2 | ||
30ce621c | 3 | ;;; Copyright (C) 2005, 2010 Neil Jerram |
8746959c | 4 | ;;; |
53befeb7 NJ |
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 | |
8746959c NJ |
18 | |
19 | ;;; This module provides a practical interface for setting and | |
20 | ;;; manipulating breakpoints. | |
21 | ||
22 | (define-module (ice-9 debugging breakpoints) | |
23 | #:use-module (ice-9 debugger) | |
24 | #:use-module (ice-9 ls) | |
25 | #:use-module (ice-9 optargs) | |
26 | #:use-module (ice-9 regex) | |
27 | #:use-module (oop goops) | |
8746959c NJ |
28 | #:use-module (ice-9 debugging traps) |
29 | #:use-module (ice-9 debugging trc) | |
30 | #:use-module (srfi srfi-1) | |
31 | #:use-module (srfi srfi-13) | |
32 | #:export (break-in | |
33 | break-at | |
34 | default-breakpoint-behaviour | |
35 | delete-breakpoint | |
36 | for-each-breakpoint | |
37 | setup-before-load | |
38 | setup-after-load | |
39 | setup-after-read | |
40 | setup-after-eval)) | |
41 | ||
42 | ;; If the running Guile does not provide before- and after- load hooks | |
43 | ;; itself, install them using the (ice-9 debugging load-hooks) module. | |
44 | (or (defined? 'after-load-hook) | |
45 | (begin | |
46 | (use-modules (ice-9 debugging load-hooks)) | |
47 | (install-load-hooks))) | |
48 | ||
49 | ;; Getter/setter for default breakpoint behaviour. | |
50 | (define default-breakpoint-behaviour | |
51 | (let ((behaviour debug-trap)) | |
52 | (make-procedure-with-setter | |
53 | ;; Getter: return current default behaviour. | |
54 | (lambda () | |
55 | behaviour) | |
56 | ;; Setter: set default behaviour to given procedure. | |
57 | (lambda (new-behaviour) | |
58 | (set! behaviour new-behaviour))))) | |
59 | ||
60 | ;; Base class for breakpoints. (We don't need to use GOOPS to | |
61 | ;; represent breakpoints, but it's a nice way to describe a composite | |
62 | ;; object.) | |
63 | (define-class <breakpoint> () | |
64 | ;; This breakpoint's trap options, which include its behaviour. | |
65 | (trap-options #:init-keyword #:trap-options) | |
66 | ;; All the traps relating to this breakpoint. | |
67 | (traps #:init-value '()) | |
68 | ;; Observer. This is a procedure that is called when the breakpoint | |
69 | ;; trap list changes. | |
70 | (observer #:init-value #f)) | |
71 | ||
72 | ;; Noop base class definitions of all the possible setup methods. | |
73 | (define-method (setup-before-load (bp <breakpoint>) filename) | |
74 | *unspecified*) | |
75 | (define-method (setup-after-load (bp <breakpoint>) filename) | |
76 | *unspecified*) | |
77 | (define-method (setup-after-read (bp <breakpoint>) x) | |
78 | *unspecified*) | |
79 | (define-method (setup-after-eval (bp <breakpoint>) filename) | |
80 | *unspecified*) | |
81 | ||
82 | ;; Call the breakpoint's observer, if it has one. | |
83 | (define-method (call-observer (bp <breakpoint>)) | |
84 | (cond ((slot-ref bp 'observer) | |
85 | => | |
86 | (lambda (proc) | |
87 | (proc))))) | |
88 | ||
89 | ;; Delete a breakpoint. | |
90 | (define (delete-breakpoint bp) | |
91 | ;; Remove this breakpoint from the global list. | |
92 | (set! breakpoints (delq! bp breakpoints)) | |
93 | ;; Uninstall and discard all its traps. | |
94 | (for-each uninstall-trap (slot-ref bp 'traps)) | |
95 | (slot-set! bp 'traps '())) | |
96 | ||
97 | ;; Class for `break-in' breakpoints. | |
98 | (define-class <break-in> (<breakpoint>) | |
99 | ;; The name of the procedure to break in. | |
100 | (procedure-name #:init-keyword #:procedure-name) | |
101 | ;; The name of the module or file that the procedure is defined in. | |
102 | ;; A module name is a list of symbols that exactly names the | |
103 | ;; relevant module. A file name is a string, which can in fact be | |
104 | ;; any substring of the relevant full file name. | |
105 | (module-or-file-name #:init-keyword #:module-or-file-name)) | |
106 | ||
107 | ;; Class for `break-at' breakpoints. | |
108 | (define-class <break-at> (<breakpoint>) | |
109 | ;; The name of the file to break in. This is a string, which can in | |
110 | ;; fact be any substring of the relevant full file name. | |
111 | (file-name #:init-keyword #:file-name) | |
112 | ;; Line and column number to break at. | |
113 | (line #:init-keyword #:line) | |
114 | (column #:init-keyword #:column)) | |
115 | ||
116 | ;; Global list of non-deleted breakpoints. | |
117 | (define breakpoints '()) | |
118 | ||
119 | ;; Add to the above list. | |
120 | (define-method (add-to-global-breakpoint-list (bp <breakpoint>)) | |
121 | (set! breakpoints (append! breakpoints (list bp)))) | |
122 | ||
123 | ;; break-in: create a `break-in' breakpoint. | |
124 | (define (break-in procedure-name . options) | |
125 | ;; Sort out the optional args. | |
126 | (let* ((module-or-file-name+options | |
127 | (cond ((and (not (null? options)) | |
128 | (or (string? (car options)) | |
129 | (list? (car options)))) | |
130 | options) | |
131 | (else | |
132 | (cons (module-name (current-module)) options)))) | |
133 | (module-or-file-name (car module-or-file-name+options)) | |
134 | (trap-options (cdr module-or-file-name+options)) | |
135 | ;; Create the new breakpoint object. | |
136 | (bp (make <break-in> | |
137 | #:procedure-name procedure-name | |
138 | #:module-or-file-name module-or-file-name | |
139 | #:trap-options (if (memq #:behaviour trap-options) | |
140 | trap-options | |
141 | (cons* #:behaviour | |
142 | (default-breakpoint-behaviour) | |
143 | trap-options))))) | |
144 | ;; Add it to the global breakpoint list. | |
145 | (add-to-global-breakpoint-list bp) | |
146 | ;; Set the new breakpoint, if possible, in already loaded code. | |
147 | (set-in-existing-code bp) | |
148 | ;; Return the breakpoint object to our caller. | |
149 | bp)) | |
150 | ||
151 | ;; break-at: create a `break-at' breakpoint. | |
152 | (define (break-at file-name line column . trap-options) | |
153 | ;; Create the new breakpoint object. | |
154 | (let* ((bp (make <break-at> | |
155 | #:file-name file-name | |
156 | #:line line | |
157 | #:column column | |
158 | #:trap-options (if (memq #:behaviour trap-options) | |
159 | trap-options | |
160 | (cons* #:behaviour | |
161 | (default-breakpoint-behaviour) | |
162 | trap-options))))) | |
163 | ;; Add it to the global breakpoint list. | |
164 | (add-to-global-breakpoint-list bp) | |
165 | ;; Set the new breakpoint, if possible, in already loaded code. | |
166 | (set-in-existing-code bp) | |
167 | ;; Return the breakpoint object to our caller. | |
168 | bp)) | |
169 | ||
170 | ;; Set a `break-in' breakpoint in already loaded code, if possible. | |
171 | (define-method (set-in-existing-code (bp <break-in>)) | |
172 | ;; Get the module or file name that was specified for this | |
173 | ;; breakpoint. | |
174 | (let ((module-or-file-name (slot-ref bp 'module-or-file-name))) | |
175 | ;; Handling is simpler for a module name. | |
176 | (cond ((list? module-or-file-name) | |
177 | ;; See if the named module exists yet. | |
178 | (let ((m (module-if-already-loaded module-or-file-name))) | |
179 | (maybe-break-in-module-proc m bp))) | |
180 | ((string? module-or-file-name) | |
181 | ;; Try all loaded modules. | |
182 | (or-map (lambda (m) | |
183 | (maybe-break-in-module-proc m bp)) | |
184 | (all-loaded-modules))) | |
185 | (else | |
186 | (error "Bad module-or-file-name:" module-or-file-name))))) | |
187 | ||
188 | (define (make-observer bp trap) | |
189 | (lambda (event) | |
190 | (trap-target-gone bp trap))) | |
191 | ||
192 | ;; Set a `break-at' breakpoint in already loaded code, if possible. | |
193 | (define-method (set-in-existing-code (bp <break-at>) . code) | |
194 | ;; Procedure to install a source trap on each expression that we | |
195 | ;; find matching this breakpoint. | |
196 | (define (install-source-trap x) | |
197 | (or (or-map (lambda (trap) | |
198 | (and (is-a? trap <source-trap>) | |
199 | (eq? (slot-ref trap 'expression) x))) | |
200 | (slot-ref bp 'traps)) | |
201 | (let ((trap (apply make <source-trap> | |
202 | #:expression x | |
203 | (slot-ref bp 'trap-options)))) | |
204 | (slot-set! trap 'observer (make-observer bp trap)) | |
205 | (install-trap trap) | |
206 | (trc 'install-source-trap (object-address trap) (object-address x)) | |
207 | (trap-installed bp trap #t)))) | |
208 | ;; Scan the source whash, and install a trap on all code matching | |
209 | ;; this breakpoint. | |
210 | (trc 'set-in-existing-code (length code)) | |
211 | (if (null? code) | |
212 | (scan-source-whash (slot-ref bp 'file-name) | |
213 | (slot-ref bp 'line) | |
214 | (slot-ref bp 'column) | |
215 | install-source-trap) | |
216 | (scan-code (car code) | |
217 | (slot-ref bp 'file-name) | |
218 | (slot-ref bp 'line) | |
219 | (slot-ref bp 'column) | |
220 | install-source-trap))) | |
221 | ||
222 | ;; Temporary implementation of scan-source-whash - this _really_ needs | |
223 | ;; to be implemented in C. | |
224 | (define (scan-source-whash file-name line column proc) | |
225 | ;; Procedure to call for each source expression in the whash. | |
226 | (define (folder x props acc) | |
227 | (if (and (= line (source-property x 'line)) | |
228 | (= column (source-property x 'column)) | |
229 | (let ((fn (source-property x 'filename))) | |
230 | (trc 'scan-source-whash fn) | |
231 | (and (string? fn) | |
232 | (string-contains fn file-name)))) | |
233 | (proc x))) | |
234 | ;; Tracing. | |
235 | (trc 'scan-source-whash file-name line column) | |
236 | ;; Apply this procedure to the whash. | |
237 | (hash-fold folder 0 source-whash)) | |
238 | ||
239 | (define (scan-code x file-name line column proc) | |
240 | (trc 'scan-code file-name line column) | |
241 | (if (pair? x) | |
242 | (begin | |
243 | (if (and (eq? line (source-property x 'line)) | |
244 | (eq? column (source-property x 'column)) | |
245 | (let ((fn (source-property x 'filename))) | |
246 | (trc 'scan-code fn) | |
247 | (and (string? fn) | |
248 | (string-contains fn file-name)))) | |
249 | (proc x)) | |
250 | (scan-code (car x) file-name line column proc) | |
251 | (scan-code (cdr x) file-name line column proc)))) | |
252 | ||
253 | ;; If a module named MODULE-NAME has been loaded, return its module | |
254 | ;; object; otherwise return #f. | |
255 | (define (module-if-already-loaded module-name) | |
30ce621c | 256 | (nested-ref the-root-module (append '(%app modules) module-name))) |
8746959c NJ |
257 | |
258 | ;; Construct and return a list of all loaded modules. | |
259 | (define (all-loaded-modules) | |
260 | ;; This is the list that accumulates known modules. It has to be | |
261 | ;; defined outside the following functions, and accumulated using | |
262 | ;; set!, so as to avoid infinite loops - because of the fact that | |
263 | ;; all non-pure modules have a variable `app'. | |
264 | (define known-modules '()) | |
265 | ;; Return an alist of submodules of the given PARENT-MODULE-NAME. | |
266 | ;; Each element of the alist is (NAME . MODULE), where NAME is the | |
267 | ;; module's leaf name (i.e. relative to PARENT-MODULE-NAME) and | |
268 | ;; MODULE is the module object. By a "submodule of a parent | |
269 | ;; module", we mean any module value that is bound to a symbol in | |
270 | ;; the parent module, and which is not an interface module. | |
271 | (define (direct-submodules parent-module-name) | |
272 | (filter (lambda (name+value) | |
273 | (and (module? (cdr name+value)) | |
274 | (not (eq? (module-kind (cdr name+value)) 'interface)))) | |
275 | (map (lambda (name) | |
276 | (cons name (local-ref (append parent-module-name | |
277 | (list name))))) | |
278 | (cdar (lls parent-module-name))))) | |
279 | ;; Add all submodules (direct and indirect) of the module named | |
280 | ;; PARENT-MODULE-NAME to `known-modules', if not already there. | |
281 | (define (add-submodules-of parent-module-name) | |
282 | (let ((ds (direct-submodules parent-module-name))) | |
283 | (for-each | |
284 | (lambda (name+module) | |
285 | (or (memq (cdr name+module) known-modules) | |
286 | (begin | |
287 | (set! known-modules (cons (cdr name+module) known-modules)) | |
288 | (add-submodules-of (append parent-module-name | |
289 | (list (car name+module))))))) | |
290 | ds))) | |
291 | ;; Add submodules recursively, starting from the root of all | |
292 | ;; modules. | |
30ce621c | 293 | (add-submodules-of '(%app modules)) |
8746959c NJ |
294 | ;; Return the result. |
295 | known-modules) | |
296 | ||
297 | ;; Before-load setup for `break-at' breakpoints. | |
298 | (define-method (setup-before-load (bp <break-at>) filename) | |
299 | (let ((trap (apply make <location-trap> | |
300 | #:file-regexp (regexp-quote (slot-ref bp 'file-name)) | |
301 | #:line (slot-ref bp 'line) | |
302 | #:column (slot-ref bp 'column) | |
303 | (slot-ref bp 'trap-options)))) | |
304 | (install-trap trap) | |
305 | (trap-installed bp trap #f) | |
306 | (letrec ((uninstaller | |
307 | (lambda (file-name) | |
308 | (uninstall-trap trap) | |
309 | (remove-hook! after-load-hook uninstaller)))) | |
310 | (add-hook! after-load-hook uninstaller)))) | |
311 | ||
312 | ;; After-load setup for `break-in' breakpoints. | |
313 | (define-method (setup-after-load (bp <break-in>) filename) | |
314 | ;; Get the module that the loaded file created or was loaded into, | |
315 | ;; and the module or file name that were specified for this | |
316 | ;; breakpoint. | |
317 | (let ((m (current-module)) | |
318 | (module-or-file-name (slot-ref bp 'module-or-file-name))) | |
319 | ;; Decide whether the breakpoint spec matches this load. | |
320 | (if (or (and (string? module-or-file-name) | |
321 | (string-contains filename module-or-file-name)) | |
322 | (and (list? module-or-file-name) | |
323 | (equal? (module-name (current-module)) module-or-file-name))) | |
324 | ;; It does, so try to install the breakpoint. | |
325 | (maybe-break-in-module-proc m bp)))) | |
326 | ||
327 | ;; After-load setup for `break-at' breakpoints. | |
328 | (define-method (setup-after-load (bp <break-at>) filename) | |
329 | (if (string-contains filename (slot-ref bp 'file-name)) | |
330 | (set-in-existing-code bp))) | |
331 | ||
332 | (define (maybe-break-in-module-proc m bp) | |
333 | "If module M defines a procedure matching the specification of | |
334 | breakpoint BP, install a trap on it." | |
335 | (let ((proc (module-ref m (slot-ref bp 'procedure-name) #f))) | |
336 | (if (and proc | |
337 | (procedure? proc) | |
338 | (let ((module-or-file-name (slot-ref bp 'module-or-file-name))) | |
339 | (if (string? module-or-file-name) | |
340 | (source-file-matches (procedure-source proc) | |
341 | module-or-file-name) | |
342 | #t)) | |
343 | (not (or-map (lambda (trap) | |
344 | (and (is-a? trap <procedure-trap>) | |
345 | (eq? (slot-ref trap 'procedure) proc))) | |
346 | (slot-ref bp 'traps)))) | |
347 | ;; There is, so install a <procedure-trap> on it. | |
348 | (letrec ((trap (apply make <procedure-trap> | |
349 | #:procedure proc | |
350 | (slot-ref bp 'trap-options)))) | |
351 | (slot-set! trap 'observer (make-observer bp trap)) | |
352 | (install-trap trap) | |
353 | (trap-installed bp trap #t) | |
354 | ;; Tell caller that we installed a trap. | |
355 | #t) | |
356 | ;; Tell caller that we did not install a trap. | |
357 | #f))) | |
358 | ||
359 | ;; After-read setup for `break-at' breakpoints. | |
360 | (define-method (setup-after-read (bp <break-at>) x) | |
361 | (set-in-existing-code bp x)) | |
362 | ||
363 | ;; Common code for associating a newly created and installed trap with | |
364 | ;; a breakpoint object. | |
365 | (define (trap-installed bp trap record?) | |
366 | (if record? | |
367 | ;; Remember this trap in the breakpoint object. | |
368 | (slot-set! bp 'traps (append! (slot-ref bp 'traps) (list trap)))) | |
369 | ;; Update the breakpoint status. | |
370 | (call-observer bp)) | |
371 | ||
372 | ;; Common code for handling when the target of one of a breakpoint's | |
373 | ;; traps is being GC'd. | |
374 | (define (trap-target-gone bp trap) | |
375 | (trc 'trap-target-gone (object-address trap)) | |
376 | ;; Remove this trap from the breakpoint's list. | |
377 | (slot-set! bp 'traps (delq! trap (slot-ref bp 'traps))) | |
378 | ;; Update the breakpoint status. | |
379 | (call-observer bp)) | |
380 | ||
381 | (define (source-file-matches source file-name) | |
382 | "Return #t if any of the expressions in SOURCE have a 'filename | |
383 | source property that includes FILE-NAME; otherwise return #f." | |
384 | (and (pair? source) | |
385 | (or (let ((source-file-name (source-property source 'filename))) | |
386 | (and source-file-name | |
387 | (string? source-file-name) | |
388 | (string-contains source-file-name file-name))) | |
389 | (let loop ((source source)) | |
390 | (and (pair? source) | |
391 | (or (source-file-matches (car source) file-name) | |
392 | (loop (cdr source)))))))) | |
393 | ||
394 | ;; Install load hook functions. | |
395 | (add-hook! before-load-hook | |
396 | (lambda (fn) | |
397 | (for-each-breakpoint setup-before-load fn))) | |
398 | ||
399 | (add-hook! after-load-hook | |
400 | (lambda (fn) | |
401 | (for-each-breakpoint setup-after-load fn))) | |
402 | ||
403 | ;;; Apply generic function GF to each breakpoint, passing the | |
404 | ;;; breakpoint object and ARGS as args on each call. | |
405 | (define (for-each-breakpoint gf . args) | |
406 | (for-each (lambda (bp) | |
407 | (apply gf bp args)) | |
408 | breakpoints)) | |
409 | ||
410 | ;; Make sure that recording of source positions is enabled. Without | |
411 | ;; this break-at breakpoints will obviously not work. | |
412 | (read-enable 'positions) | |
413 | ||
414 | ;;; (ice-9 debugging breakpoints) ends here. |