1 ;;; trap-state.scm: a set of traps
3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
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.
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.
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
23 (define-module (system vm trap-state)
24 #:use-module (system base syntax)
25 #:use-module ((srfi srfi-1) #:select (fold))
26 #:use-module (system vm vm)
27 #:use-module (system vm traps)
28 #:use-module (system vm trace)
29 #:use-module (system vm frame)
30 #:use-module (system vm program)
39 with-default-trap-handler
42 add-trap-at-procedure-call!
43 add-trace-at-procedure-call!
44 add-trap-at-source-location!
45 add-ephemeral-trap-at-frame-finish!
46 add-ephemeral-stepping-trap!))
48 (define %default-trap-handler (make-fluid))
50 (define (default-trap-handler frame idx trap-name)
51 (let ((default-handler (fluid-ref %default-trap-handler)))
53 (default-handler frame idx trap-name)
54 (warn "Trap with no handler installed" frame idx trap-name))))
56 (define-record <trap-wrapper>
62 (define-record <trap-state>
63 (handler default-trap-handler)
65 (next-ephemeral-idx -1)
68 (define (trap-wrapper<? t1 t2)
69 (< (trap-wrapper-index t1) (trap-wrapper-index t2)))
71 ;; The interface that a trap provides to the outside world is that of a
72 ;; procedure, which when called disables the trap, and returns a
73 ;; procedure to enable the trap. Perhaps this is a bit too odd and we
75 (define (enable-trap-wrapper! wrapper)
76 (if (trap-wrapper-enabled? wrapper)
77 (error "Trap already enabled" (trap-wrapper-index wrapper))
78 (let ((trap (trap-wrapper-trap wrapper)))
79 (set! (trap-wrapper-trap wrapper) (trap))
80 (set! (trap-wrapper-enabled? wrapper) #t))))
82 (define (disable-trap-wrapper! wrapper)
83 (if (not (trap-wrapper-enabled? wrapper))
84 (error "Trap already disabled" (trap-wrapper-index wrapper))
85 (let ((trap (trap-wrapper-trap wrapper)))
86 (set! (trap-wrapper-trap wrapper) (trap))
87 (set! (trap-wrapper-enabled? wrapper) #f))))
89 (define (add-trap-wrapper! trap-state wrapper)
90 (set! (trap-state-wrappers trap-state)
91 (append (trap-state-wrappers trap-state) (list wrapper)))
92 (trap-wrapper-index wrapper))
94 (define (remove-trap-wrapper! trap-state wrapper)
95 (set! (trap-state-wrappers trap-state)
96 (delq wrapper (trap-state-wrappers trap-state))))
98 (define (trap-state->trace-level trap-state)
99 (fold (lambda (wrapper level)
100 (if (trap-wrapper-enabled? wrapper)
104 (trap-state-wrappers trap-state)))
106 (define (wrapper-at-index trap-state idx)
107 (let lp ((wrappers (trap-state-wrappers trap-state)))
110 (warn "no wrapper found with index in trap-state" idx)
112 ((eqv? (trap-wrapper-index (car wrappers)) idx)
115 (lp (cdr wrappers))))))
117 (define (next-index! trap-state)
118 (let ((idx (trap-state-next-idx trap-state)))
119 (set! (trap-state-next-idx trap-state) (1+ idx))
122 (define (next-ephemeral-index! trap-state)
123 (let ((idx (trap-state-next-ephemeral-idx trap-state)))
124 (set! (trap-state-next-ephemeral-idx trap-state) (1- idx))
127 (define (handler-for-index trap-state idx)
129 (let ((wrapper (wrapper-at-index trap-state idx))
130 (handler (trap-state-handler trap-state)))
133 (trap-wrapper-index wrapper)
134 (trap-wrapper-name wrapper))))))
136 (define (ephemeral-handler-for-index trap-state idx handler)
138 (let ((wrapper (wrapper-at-index trap-state idx)))
141 (if (trap-wrapper-enabled? wrapper)
142 (disable-trap-wrapper! wrapper))
143 (remove-trap-wrapper! trap-state wrapper)
149 ;;; VM-local trap states
152 (define *trap-states* (make-weak-key-hash-table))
154 (define (trap-state-for-vm vm)
155 (or (hashq-ref *trap-states* vm)
156 (let ((ts (make-trap-state)))
157 (hashq-set! *trap-states* vm ts)
158 (trap-state-for-vm vm))))
160 (define (the-trap-state)
161 (trap-state-for-vm (the-vm)))
169 (define* (with-default-trap-handler handler thunk
170 #:optional (trap-state (the-trap-state)))
171 (with-fluids ((%default-trap-handler handler))
174 ;; Don't enable hooks if the handler is #f.
176 (set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state))))
180 (set-vm-trace-level! (the-vm) 0))))))
182 (define* (list-traps #:optional (trap-state (the-trap-state)))
183 (map trap-wrapper-index (trap-state-wrappers trap-state)))
185 (define* (trap-name idx #:optional (trap-state (the-trap-state)))
186 (and=> (wrapper-at-index trap-state idx)
189 (define* (trap-enabled? idx #:optional (trap-state (the-trap-state)))
190 (and=> (wrapper-at-index trap-state idx)
191 trap-wrapper-enabled?))
193 (define* (enable-trap! idx #:optional (trap-state (the-trap-state)))
194 (and=> (wrapper-at-index trap-state idx)
195 enable-trap-wrapper!))
197 (define* (disable-trap! idx #:optional (trap-state (the-trap-state)))
198 (and=> (wrapper-at-index trap-state idx)
199 disable-trap-wrapper!))
201 (define* (delete-trap! idx #:optional (trap-state (the-trap-state)))
202 (and=> (wrapper-at-index trap-state idx)
204 (if (trap-wrapper-enabled? wrapper)
205 (disable-trap-wrapper! wrapper))
206 (remove-trap-wrapper! trap-state wrapper))))
208 (define* (install-trap-handler! handler #:optional (trap-state (the-trap-state)))
209 (set! (trap-state-handler trap-state) handler))
211 (define* (add-trap-at-procedure-call! proc #:optional (trap-state (the-trap-state)))
212 (let* ((idx (next-index! trap-state))
213 (trap (trap-at-procedure-call
215 (handler-for-index trap-state idx))))
220 (format #f "Breakpoint at ~a" proc)))))
222 (define* (add-trace-at-procedure-call! proc
223 #:optional (trap-state (the-trap-state)))
224 (let* ((idx (next-index! trap-state))
225 (trap (trace-calls-to-procedure
227 #:prefix (format #f "Trap ~a: " idx))))
232 (format #f "Tracepoint at ~a" proc)))))
234 (define* (add-trap-at-source-location! file user-line
235 #:optional (trap-state (the-trap-state)))
236 (let* ((idx (next-index! trap-state))
237 (trap (trap-at-source-location file user-line
238 (handler-for-index trap-state idx))))
243 (format #f "Breakpoint at ~a:~a" file user-line)))))
245 ;; handler := frame -> nothing
246 (define* (add-ephemeral-trap-at-frame-finish! frame handler
247 #:optional (trap-state
249 (let* ((idx (next-ephemeral-index! trap-state))
250 (trap (trap-frame-finish
252 (ephemeral-handler-for-index trap-state idx handler)
253 (lambda (frame) (delete-trap! idx trap-state)))))
258 (format #f "Return from ~a" frame)))))
260 (define (source-string source)
262 (format #f "~a:~a:~a" (or (source:file source) "unknown file")
263 (source:line-for-user source) (source:column source))
264 "unknown source location"))
266 (define* (add-ephemeral-stepping-trap! frame handler
267 #:optional (trap-state
269 #:key (into? #t) (instruction? #f))
270 (define (wrap-predicate-according-to-into predicate)
273 (let ((fp (frame-address frame)))
275 (and (<= (frame-address f) fp)
278 (let* ((source (frame-next-source frame))
279 (idx (next-ephemeral-index! trap-state))
280 (trap (trap-matching-instructions
281 (wrap-predicate-according-to-into
284 (lambda (f) (not (equal? (frame-next-source f) source)))))
285 (ephemeral-handler-for-index trap-state idx handler))))
292 "Step to different instruction"
293 (format #f "Step to different instruction in ~a" frame))
295 (format #f "Step into ~a" (source-string source))
296 (format #f "Step out of ~a" (source-string source))))))))
298 (define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
299 (let* ((idx (next-index! trap-state)))
302 (make-trap-wrapper idx #t trap name))))