Commit | Line | Data |
---|---|---|
b9badc35 AW |
1 | ;;; trap-state.scm: a set of traps |
2 | ||
3 | ;; Copyright (C) 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 | ;;; Commentary: | |
20 | ;;; | |
21 | ;;; Code: | |
22 | ||
23 | (define-module (system vm trap-state) | |
24 | #:use-module (system base syntax) | |
65bce237 | 25 | #:use-module ((srfi srfi-1) #:select (fold)) |
b9badc35 AW |
26 | #:use-module (system vm vm) |
27 | #:use-module (system vm traps) | |
28 | #:export (list-traps | |
29 | trap-enabled? | |
30 | enable-trap! | |
31 | disable-trap! | |
32 | delete-trap! | |
33 | ||
34 | with-default-trap-handler | |
35 | install-trap-handler! | |
36 | ||
37 | add-trap-at-procedure-call!)) | |
38 | ||
39 | (define %default-trap-handler (make-fluid)) | |
40 | ||
b9badc35 | 41 | (define (default-trap-handler frame idx trap-name) |
e3667576 AW |
42 | (let ((default-handler (fluid-ref %default-trap-handler))) |
43 | (if default-handler | |
44 | (default-handler frame idx trap-name) | |
45 | (warn "Trap with no handler installed" frame idx trap-name)))) | |
b9badc35 AW |
46 | |
47 | (define-record <trap-wrapper> | |
48 | index | |
49 | enabled? | |
50 | trap | |
51 | name) | |
52 | ||
53 | (define-record <trap-state> | |
54 | (handler default-trap-handler) | |
55 | (next-idx 0) | |
56 | (wrappers '())) | |
57 | ||
58 | (define (trap-wrapper<? t1 t2) | |
59 | (< (trap-wrapper-index t1) (trap-wrapper-index t2))) | |
60 | ||
61 | ;; The interface that a trap provides to the outside world is that of a | |
62 | ;; procedure, which when called disables the trap, and returns a | |
63 | ;; procedure to enable the trap. Perhaps this is a bit too odd and we | |
64 | ;; should fix this. | |
65 | (define (enable-trap-wrapper! wrapper) | |
66 | (if (trap-wrapper-enabled? wrapper) | |
67 | (error "Trap already enabled" (trap-wrapper-index wrapper)) | |
68 | (let ((trap (trap-wrapper-trap wrapper))) | |
69 | (set! (trap-wrapper-trap wrapper) (trap)) | |
70 | (set! (trap-wrapper-enabled? wrapper) #t)))) | |
71 | ||
72 | (define (disable-trap-wrapper! wrapper) | |
73 | (if (not (trap-wrapper-enabled? wrapper)) | |
74 | (error "Trap already disabled" (trap-wrapper-index wrapper)) | |
75 | (let ((trap (trap-wrapper-trap wrapper))) | |
76 | (set! (trap-wrapper-trap wrapper) (trap)) | |
77 | (set! (trap-wrapper-enabled? wrapper) #f)))) | |
78 | ||
79 | (define (add-trap-wrapper! trap-state wrapper) | |
80 | (set! (trap-state-wrappers trap-state) | |
81 | (append (trap-state-wrappers trap-state) (list wrapper))) | |
82 | (trap-wrapper-index wrapper)) | |
83 | ||
84 | (define (remove-trap-wrapper! trap-state wrapper) | |
85 | (delq wrapper (trap-state-wrappers trap-state))) | |
86 | ||
65bce237 AW |
87 | (define (trap-state->trace-level trap-state) |
88 | (fold (lambda (wrapper level) | |
89 | (if (trap-wrapper-enabled? wrapper) | |
90 | (1+ level) | |
91 | level)) | |
92 | 0 | |
93 | (trap-state-wrappers trap-state))) | |
94 | ||
b9badc35 AW |
95 | (define (wrapper-at-index trap-state idx) |
96 | (let lp ((wrappers (trap-state-wrappers trap-state))) | |
97 | (cond | |
98 | ((null? wrappers) | |
99 | (warn "no wrapper found with index in trap-state" idx) | |
100 | #f) | |
101 | ((= (trap-wrapper-index (car wrappers)) idx) | |
102 | (car wrappers)) | |
103 | (else | |
104 | (lp (cdr wrappers)))))) | |
105 | ||
106 | (define (next-index! trap-state) | |
107 | (let ((idx (trap-state-next-idx trap-state))) | |
108 | (set! (trap-state-next-idx trap-state) (1+ idx)) | |
109 | idx)) | |
110 | ||
111 | (define (handler-for-index trap-state idx) | |
112 | (lambda (frame) | |
113 | (let ((wrapper (wrapper-at-index trap-state idx)) | |
114 | (handler (trap-state-handler trap-state))) | |
115 | (if wrapper | |
116 | (handler frame | |
117 | (trap-wrapper-index wrapper) | |
118 | (trap-wrapper-name wrapper)))))) | |
119 | ||
120 | \f | |
121 | ||
122 | ;;; | |
123 | ;;; VM-local trap states | |
124 | ;;; | |
125 | ||
126 | (define *trap-states* (make-weak-key-hash-table)) | |
127 | ||
128 | (define (trap-state-for-vm vm) | |
129 | (or (hashq-ref *trap-states* vm) | |
130 | (let ((ts (make-trap-state))) | |
131 | (hashq-set! *trap-states* vm ts) | |
132 | (trap-state-for-vm vm)))) | |
133 | ||
134 | (define (the-trap-state) | |
135 | (trap-state-for-vm (the-vm))) | |
136 | ||
137 | \f | |
138 | ||
139 | ;;; | |
140 | ;;; API | |
141 | ;;; | |
142 | ||
65bce237 AW |
143 | (define* (with-default-trap-handler handler thunk |
144 | #:optional (trap-state (the-trap-state))) | |
145 | (with-fluids ((%default-trap-handler handler)) | |
146 | (dynamic-wind | |
147 | (lambda () | |
b0e556d4 AW |
148 | ;; Don't enable hooks if the handler is #f. |
149 | (if handler | |
150 | (set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state)))) | |
65bce237 AW |
151 | thunk |
152 | (lambda () | |
b0e556d4 AW |
153 | (if handler |
154 | (set-vm-trace-level! (the-vm) 0)))))) | |
65bce237 | 155 | |
b9badc35 AW |
156 | (define* (list-traps #:optional (trap-state (the-trap-state))) |
157 | (map (lambda (wrapper) | |
158 | (cons (trap-wrapper-index wrapper) | |
159 | (trap-wrapper-name wrapper))) | |
160 | (trap-state-wrappers trap-state))) | |
161 | ||
162 | (define* (trap-enabled? idx #:optional (trap-state (the-trap-state))) | |
163 | (and=> (wrapper-at-index trap-state idx) | |
164 | trap-wrapper-enabled?)) | |
165 | ||
166 | (define* (enable-trap! idx #:optional (trap-state (the-trap-state))) | |
167 | (and=> (wrapper-at-index trap-state idx) | |
168 | enable-trap-wrapper!)) | |
169 | ||
170 | (define* (disable-trap! idx #:optional (trap-state (the-trap-state))) | |
171 | (and=> (wrapper-at-index trap-state idx) | |
172 | disable-trap-wrapper!)) | |
173 | ||
174 | (define* (delete-trap! idx #:optional (trap-state (the-trap-state))) | |
175 | (and=> (wrapper-at-index trap-state idx) | |
176 | (lambda (wrapper) | |
177 | (if (trap-wrapper-enabled? wrapper) | |
178 | (disable-trap-wrapper! wrapper)) | |
179 | (remove-trap-wrapper! trap-state wrapper)))) | |
180 | ||
181 | (define* (install-trap-handler! handler #:optional (trap-state (the-trap-state))) | |
182 | (set! (trap-state-handler trap-state) handler)) | |
183 | ||
184 | (define* (add-trap-at-procedure-call! proc #:optional (trap-state (the-trap-state))) | |
185 | (let* ((idx (next-index! trap-state)) | |
186 | (trap (trap-at-procedure-call | |
187 | proc | |
188 | (handler-for-index trap-state idx)))) | |
189 | (add-trap-wrapper! | |
190 | trap-state | |
191 | (make-trap-wrapper | |
192 | idx #t trap | |
193 | (format #f "breakpoint at ~a" proc))))) | |
1bc1800f AW |
194 | |
195 | (define* (add-trap! trap name #:optional (trap-state (the-trap-state))) | |
196 | (let* ((idx (next-index! trap-state))) | |
197 | (add-trap-wrapper! | |
198 | trap-state | |
199 | (make-trap-wrapper idx #t trap name)))) |