mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
9f0e9918f4
* module/ice-9/boot-9.scm (default-pre-unwind-handler): Rename from default-lazy-handler. (pre-unwind-handler-dispatch): Rename from lazy-hadler-dispatch. (error-catching-loop): Adjust caller. * module/system/repl/repl.scm (default-pre-unwind-handler): Remove this definition, in favor of the default one in boot-9. (default-catch-handler): Don't do a vm-backtrace, as we will soon be relying on core machinery to do that for us. (call-with-backtrace): Start a new stack for the thunk. (with-backtrace): Macro version of call-with-backtrace. (start-repl): Use with-backtrace for brevity. Start a stack with #t as the tag instead of repl-eval, because all traces of repl-eval are gone after it does a tail-call. * module/ice-9/debugger.scm: * module/ice-9/debugging/traps.scm: * module/ice-9/stack-catch.scm: Adapt to s/lazy/pre-unwind/ in boot-9.scm.
1037 lines
38 KiB
Scheme
Executable file
1037 lines
38 KiB
Scheme
Executable file
;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface
|
|
|
|
;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
|
|
;;; Copyright (C) 2005 Neil Jerram
|
|
;;;
|
|
;; This library is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU Lesser General Public
|
|
;; License as published by the Free Software Foundation; either
|
|
;; version 2.1 of the License, or (at your option) any later version.
|
|
;;
|
|
;; This library is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; Lesser General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Lesser General Public
|
|
;; License along with this library; if not, write to the Free Software
|
|
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
;;; This module provides an abstraction around Guile's low level trap
|
|
;;; handler interface; its aim is to make the low level trap mechanism
|
|
;;; shareable between the debugger and other applications, and to
|
|
;;; insulate the rest of the debugger code a bit from changes that may
|
|
;;; occur in the low level trap interface in future.
|
|
|
|
(define-module (ice-9 debugging traps)
|
|
#:use-module (ice-9 regex)
|
|
#:use-module (oop goops)
|
|
#:use-module (oop goops describe)
|
|
#:use-module (ice-9 debugging trc)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-2)
|
|
#:export (tc:type
|
|
tc:continuation
|
|
tc:expression
|
|
tc:return-value
|
|
tc:stack
|
|
tc:frame
|
|
tc:depth
|
|
tc:real-depth
|
|
tc:exit-depth
|
|
tc:fired-traps
|
|
;; Interface for users of <trap> subclasses defined in
|
|
;; this module.
|
|
add-trapped-stack-id!
|
|
remove-trapped-stack-id!
|
|
<procedure-trap>
|
|
<exit-trap>
|
|
<entry-trap>
|
|
<apply-trap>
|
|
<step-trap>
|
|
<source-trap>
|
|
<location-trap>
|
|
install-trap
|
|
uninstall-trap
|
|
all-traps
|
|
get-trap
|
|
list-traps
|
|
trap-ordering
|
|
behaviour-ordering
|
|
throw->trap-context
|
|
on-pre-unwind-handler-dispatch
|
|
;; Interface for authors of new <trap> subclasses.
|
|
<trap-context>
|
|
<trap>
|
|
trap->behaviour
|
|
trap-runnable?
|
|
install-apply-frame-trap
|
|
install-breakpoint-trap
|
|
install-enter-frame-trap
|
|
install-exit-frame-trap
|
|
install-trace-trap
|
|
uninstall-apply-frame-trap
|
|
uninstall-breakpoint-trap
|
|
uninstall-enter-frame-trap
|
|
uninstall-exit-frame-trap
|
|
uninstall-trace-trap
|
|
frame->source-position
|
|
frame-file-name
|
|
without-traps
|
|
guile-trap-features)
|
|
#:re-export (make)
|
|
#:export-syntax (trap-here))
|
|
|
|
;; How to debug the debugging infrastructure, when needed. Grep for
|
|
;; "(trc " to find other symbols that can be passed to trc-add.
|
|
;; (trc-add 'after-gc-hook)
|
|
|
|
;; In Guile 1.7 onwards, weak-vector and friends are provided by the
|
|
;; (ice-9 weak-vector) module.
|
|
(cond ((string>=? (version) "1.7")
|
|
(use-modules (ice-9 weak-vector))))
|
|
|
|
;;; The current low level traps interface is as follows.
|
|
;;;
|
|
;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled
|
|
;;; by the `traps' setting of `(evaluator-traps-interface)' but also
|
|
;;; (and more relevant in most cases) by the `with-traps' procedure.
|
|
;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of
|
|
;;; its thunk parameter.
|
|
;;;
|
|
;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0
|
|
;;; for the duration of the call, to avoid nasty recursive trapping
|
|
;;; loops. If a trap handler knows what it is doing, it can override
|
|
;;; this by `(trap-enable traps)'.
|
|
;;;
|
|
;;; The apply-frame handler is called when Guile is about to perform
|
|
;;; an application if EITHER the `apply-frame' evaluator trap option
|
|
;;; is set, OR the `trace' debug option is set and the procedure to
|
|
;;; apply has its `trace' procedure property set. The arguments
|
|
;;; passed are:
|
|
;;;
|
|
;;; - the symbol 'apply-frame
|
|
;;;
|
|
;;; - a continuation or debug object describing the current stack
|
|
;;;
|
|
;;; - a boolean indicating whether the application is tail-recursive.
|
|
;;;
|
|
;;; The enter-frame handler is called when the evaluator begins a new
|
|
;;; evaluation frame if EITHER the `enter-frame' evaluator trap option
|
|
;;; is set, OR the `breakpoints' debug option is set and the code to
|
|
;;; be evaluated has its `breakpoint' source property set. The
|
|
;;; arguments passed are:
|
|
;;;
|
|
;;; - the symbol 'enter-frame
|
|
;;;
|
|
;;; - a continuation or debug object describing the current stack
|
|
;;;
|
|
;;; - a boolean indicating whether the application is tail-recursive.
|
|
;;;
|
|
;;; - an unmemoized copy of the expression to be evaluated.
|
|
;;;
|
|
;;; If the `enter-frame' evaluator trap option is set, the enter-frame
|
|
;;; handler is also called when about to perform an application in
|
|
;;; SCM_APPLY, immediately before possibly calling the apply-frame
|
|
;;; handler. (I don't totally understand this.) In this case, the
|
|
;;; arguments passed are:
|
|
;;;
|
|
;;; - the symbol 'enter-frame
|
|
;;;
|
|
;;; - a continuation or debug object describing the current stack.
|
|
;;;
|
|
;;; The exit-frame handler is called when Guile exits an evaluation
|
|
;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if
|
|
;;; EITHER the `exit-frame' evaluator trap option is set, OR the
|
|
;;; `trace' debug option is set and the frame is marked as having been
|
|
;;; traced. The frame will be marked as having been traced if the
|
|
;;; apply-frame handler was called for this frame. (This is trickier
|
|
;;; than it sounds because of tail recursion: the same debug frame
|
|
;;; could have been used for multiple applications, only some of which
|
|
;;; were traced - I think.) The arguments passed are:
|
|
;;;
|
|
;;; - the symbol 'exit-frame
|
|
;;;
|
|
;;; - a continuation or debug object describing the current stack
|
|
;;;
|
|
;;; - the result of the evaluation or application.
|
|
|
|
;;; {Trap Context}
|
|
;;;
|
|
;;; A trap context is a GOOPS object that encapsulates all the useful
|
|
;;; information about a particular trap. Encapsulating this
|
|
;;; information in a single object also allows us:
|
|
;;;
|
|
;;; - to defer the calculation of information that is time-consuming
|
|
;;; to calculate, such as the stack, and to cache such information so
|
|
;;; that it is only ever calculated once per trap
|
|
;;;
|
|
;;; - to pass all interesting information to trap behaviour procedures
|
|
;;; in a single parameter, which (i) is convenient and (ii) makes for
|
|
;;; a more future-proof interface.
|
|
;;;
|
|
;;; It also allows us - where very carefully documented! - to pass
|
|
;;; information from one behaviour procedure to another.
|
|
|
|
(define-class <trap-context> ()
|
|
;; Information provided directly by the trap calls from the
|
|
;; evaluator. The "type" slot holds a keyword indicating the type
|
|
;; of the trap: one of #:evaluation, #:application, #:return,
|
|
;; #:error.
|
|
(type #:getter tc:type
|
|
#:init-keyword #:type)
|
|
;; The "continuation" slot holds the continuation (or debug object,
|
|
;; if "cheap" traps are enabled, which is the default) at the point
|
|
;; of the trap. For an error trap it is #f.
|
|
(continuation #:getter tc:continuation
|
|
#:init-keyword #:continuation)
|
|
;; The "expression" slot holds the source code expression, for an
|
|
;; evaluation trap.
|
|
(expression #:getter tc:expression
|
|
#:init-keyword #:expression
|
|
#:init-value #f)
|
|
;; The "return-value" slot holds the return value, for a return
|
|
;; trap, or the error args, for an error trap.
|
|
(return-value #:getter tc:return-value
|
|
#:init-keyword #:return-value
|
|
#:init-value #f)
|
|
;; The list of trap objects which fired in this trap context.
|
|
(fired-traps #:getter tc:fired-traps
|
|
#:init-value '())
|
|
;; The set of symbols which, if one of them is set in the CAR of the
|
|
;; handler-return-value slot, will cause the CDR of that slot to
|
|
;; have an effect.
|
|
(handler-return-syms #:init-value '())
|
|
;; The value which the trap handler should return to the evaluator.
|
|
(handler-return-value #:init-value #f)
|
|
;; Calculated and cached information. "stack" is the stack
|
|
;; (computed from the continuation (or debug object) by make-stack,
|
|
;; or else (in the case of an error trap) by (make-stack #t ...).
|
|
(stack #:init-value #f)
|
|
(frame #:init-value #f)
|
|
(depth #:init-value #f)
|
|
(real-depth #:init-value #f)
|
|
(exit-depth #:init-value #f))
|
|
|
|
(define-method (tc:stack (ctx <trap-context>))
|
|
(or (slot-ref ctx 'stack)
|
|
(let ((stack (make-stack (tc:continuation ctx))))
|
|
(slot-set! ctx 'stack stack)
|
|
stack)))
|
|
|
|
(define-method (tc:frame (ctx <trap-context>))
|
|
(or (slot-ref ctx 'frame)
|
|
(let ((frame (cond ((tc:continuation ctx) => last-stack-frame)
|
|
(else (stack-ref (tc:stack ctx) 0)))))
|
|
(slot-set! ctx 'frame frame)
|
|
frame)))
|
|
|
|
(define-method (tc:depth (ctx <trap-context>))
|
|
(or (slot-ref ctx 'depth)
|
|
(let ((depth (stack-length (tc:stack ctx))))
|
|
(slot-set! ctx 'depth depth)
|
|
depth)))
|
|
|
|
(define-method (tc:real-depth (ctx <trap-context>))
|
|
(or (slot-ref ctx 'real-depth)
|
|
(let* ((stack (tc:stack ctx))
|
|
(real-depth (apply +
|
|
(map (lambda (i)
|
|
(if (frame-real? (stack-ref stack i))
|
|
1
|
|
0))
|
|
(iota (tc:depth ctx))))))
|
|
(slot-set! ctx 'real-depth real-depth)
|
|
real-depth)))
|
|
|
|
(define-method (tc:exit-depth (ctx <trap-context>))
|
|
(or (slot-ref ctx 'exit-depth)
|
|
(let* ((stack (tc:stack ctx))
|
|
(depth (tc:depth ctx))
|
|
(exit-depth (let loop ((exit-depth depth))
|
|
(if (or (zero? exit-depth)
|
|
(frame-real? (stack-ref stack
|
|
(- depth
|
|
exit-depth))))
|
|
exit-depth
|
|
(loop (- exit-depth 1))))))
|
|
(slot-set! ctx 'exit-depth exit-depth)
|
|
exit-depth)))
|
|
|
|
;;; {Stack IDs}
|
|
;;;
|
|
;;; Mechanism for limiting trapping to contexts whose stack ID matches
|
|
;;; one of a registered set. The default is for traps to fire
|
|
;;; regardless of stack ID.
|
|
|
|
(define trapped-stack-ids (list #t))
|
|
(define all-stack-ids-trapped? #t)
|
|
|
|
(define (add-trapped-stack-id! id)
|
|
"Add ID to the set of stack ids for which traps are active.
|
|
If `#t' is in this set, traps are active regardless of stack context.
|
|
To remove ID again, use `remove-trapped-stack-id!'. If you add the
|
|
same ID twice using `add-trapped-stack-id!', you will need to remove
|
|
it twice."
|
|
(set! trapped-stack-ids (cons id trapped-stack-ids))
|
|
(set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
|
|
|
|
(define (remove-trapped-stack-id! id)
|
|
"Remove ID from the set of stack ids for which traps are active."
|
|
(set! trapped-stack-ids (delq1! id trapped-stack-ids))
|
|
(set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
|
|
|
|
(define (trap-here? cont)
|
|
;; Return true if the stack id of the specified continuation (or
|
|
;; debug object) is in the set that we should trap for; otherwise
|
|
;; false.
|
|
(or all-stack-ids-trapped?
|
|
(memq (stack-id cont) trapped-stack-ids)))
|
|
|
|
;;; {Global State}
|
|
;;;
|
|
;;; Variables tracking registered handlers, relevant procedures, and
|
|
;;; what's turned on as regards the evaluator's debugging options.
|
|
|
|
(define enter-frame-traps '())
|
|
(define apply-frame-traps '())
|
|
(define exit-frame-traps '())
|
|
(define breakpoint-traps '())
|
|
(define trace-traps '())
|
|
|
|
(define (non-null? hook)
|
|
(not (null? hook)))
|
|
|
|
;; The low level frame handlers must all be initialized to something
|
|
;; harmless. Otherwise we hit a problem immediately when trying to
|
|
;; enable one of these handlers.
|
|
(trap-set! enter-frame-handler noop)
|
|
(trap-set! apply-frame-handler noop)
|
|
(trap-set! exit-frame-handler noop)
|
|
|
|
(define set-debug-and-trap-options
|
|
(let ((dopts (debug-options))
|
|
(topts (evaluator-traps-interface))
|
|
(setting (lambda (key opts)
|
|
(let ((l (memq key opts)))
|
|
(and l
|
|
(not (null? (cdr l)))
|
|
(cadr l)))))
|
|
(debug-set-boolean! (lambda (key value)
|
|
((if value debug-enable debug-disable) key)))
|
|
(trap-set-boolean! (lambda (key value)
|
|
((if value trap-enable trap-disable) key))))
|
|
(let ((save-debug (memq 'debug dopts))
|
|
(save-trace (memq 'trace dopts))
|
|
(save-breakpoints (memq 'breakpoints dopts))
|
|
(save-enter-frame (memq 'enter-frame topts))
|
|
(save-apply-frame (memq 'apply-frame topts))
|
|
(save-exit-frame (memq 'exit-frame topts))
|
|
(save-enter-frame-handler (setting 'enter-frame-handler topts))
|
|
(save-apply-frame-handler (setting 'apply-frame-handler topts))
|
|
(save-exit-frame-handler (setting 'exit-frame-handler topts)))
|
|
(lambda ()
|
|
(let ((need-trace (non-null? trace-traps))
|
|
(need-breakpoints (non-null? breakpoint-traps))
|
|
(need-enter-frame (non-null? enter-frame-traps))
|
|
(need-apply-frame (non-null? apply-frame-traps))
|
|
(need-exit-frame (non-null? exit-frame-traps)))
|
|
(debug-set-boolean! 'debug
|
|
(or need-trace
|
|
need-breakpoints
|
|
need-enter-frame
|
|
need-apply-frame
|
|
need-exit-frame
|
|
save-debug))
|
|
(debug-set-boolean! 'trace
|
|
(or need-trace
|
|
save-trace))
|
|
(debug-set-boolean! 'breakpoints
|
|
(or need-breakpoints
|
|
save-breakpoints))
|
|
(trap-set-boolean! 'enter-frame
|
|
(or need-enter-frame
|
|
save-enter-frame))
|
|
(trap-set-boolean! 'apply-frame
|
|
(or need-apply-frame
|
|
save-apply-frame))
|
|
(trap-set-boolean! 'exit-frame
|
|
(or need-exit-frame
|
|
save-exit-frame))
|
|
(trap-set! enter-frame-handler
|
|
(cond ((or need-breakpoints
|
|
need-enter-frame)
|
|
enter-frame-handler)
|
|
(else save-enter-frame-handler)))
|
|
(trap-set! apply-frame-handler
|
|
(cond ((or need-trace
|
|
need-apply-frame)
|
|
apply-frame-handler)
|
|
(else save-apply-frame-handler)))
|
|
(trap-set! exit-frame-handler
|
|
(cond ((or need-exit-frame)
|
|
exit-frame-handler)
|
|
(else save-exit-frame-handler))))
|
|
;;(write (evaluator-traps-interface))
|
|
*unspecified*))))
|
|
|
|
(define (enter-frame-handler key cont . args)
|
|
;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an
|
|
;; unmemoized copy of the source expression. For an application
|
|
;; entry, ARGS is empty.
|
|
(if (trap-here? cont)
|
|
(let* ((application-entry? (null? args))
|
|
(trap-context (make <trap-context>
|
|
#:type #:evaluation
|
|
#:continuation cont
|
|
#:expression (if application-entry?
|
|
#f
|
|
(cadr args)))))
|
|
(trc 'enter-frame-handler)
|
|
(if (and (not application-entry?)
|
|
(memq 'tweaking guile-trap-features))
|
|
(slot-set! trap-context 'handler-return-syms '(instead)))
|
|
(run-traps (if application-entry?
|
|
enter-frame-traps
|
|
(append enter-frame-traps breakpoint-traps))
|
|
trap-context)
|
|
(slot-ref trap-context 'handler-return-value))))
|
|
|
|
(define (apply-frame-handler key cont tail?)
|
|
(if (trap-here? cont)
|
|
(let ((trap-context (make <trap-context>
|
|
#:type #:application
|
|
#:continuation cont)))
|
|
(trc 'apply-frame-handler tail?)
|
|
(run-traps (append apply-frame-traps trace-traps) trap-context)
|
|
(slot-ref trap-context 'handler-return-value))))
|
|
|
|
(define (exit-frame-handler key cont retval)
|
|
(if (trap-here? cont)
|
|
(let ((trap-context (make <trap-context>
|
|
#:type #:return
|
|
#:continuation cont
|
|
#:return-value retval)))
|
|
(trc 'exit-frame-handler retval (tc:depth trap-context))
|
|
(if (memq 'tweaking guile-trap-features)
|
|
(slot-set! trap-context 'handler-return-syms '(instead)))
|
|
(run-traps exit-frame-traps trap-context)
|
|
(slot-ref trap-context 'handler-return-value))))
|
|
|
|
(define-macro (trap-installer trap-list)
|
|
`(lambda (trap)
|
|
(set! ,trap-list (cons trap ,trap-list))
|
|
(set-debug-and-trap-options)))
|
|
|
|
(define install-enter-frame-trap (trap-installer enter-frame-traps))
|
|
(define install-apply-frame-trap (trap-installer apply-frame-traps))
|
|
(define install-exit-frame-trap (trap-installer exit-frame-traps))
|
|
(define install-breakpoint-trap (trap-installer breakpoint-traps))
|
|
(define install-trace-trap (trap-installer trace-traps))
|
|
|
|
(define-macro (trap-uninstaller trap-list)
|
|
`(lambda (trap)
|
|
(or (memq trap ,trap-list)
|
|
(error "Trap list does not include the specified trap"))
|
|
(set! ,trap-list (delq1! trap ,trap-list))
|
|
(set-debug-and-trap-options)))
|
|
|
|
(define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps))
|
|
(define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps))
|
|
(define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps))
|
|
(define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps))
|
|
(define uninstall-trace-trap (trap-uninstaller trace-traps))
|
|
|
|
(define trap-ordering (make-object-property))
|
|
(define behaviour-ordering (make-object-property))
|
|
|
|
(define (run-traps traps trap-context)
|
|
(let ((behaviours (apply append
|
|
(map (lambda (trap)
|
|
(trap->behaviour trap trap-context))
|
|
(sort traps
|
|
(lambda (t1 t2)
|
|
(< (or (trap-ordering t1) 0)
|
|
(or (trap-ordering t2) 0))))))))
|
|
(for-each (lambda (proc)
|
|
(proc trap-context))
|
|
(sort (delete-duplicates behaviours)
|
|
(lambda (b1 b2)
|
|
(< (or (behaviour-ordering b1) 0)
|
|
(or (behaviour-ordering b2) 0)))))))
|
|
|
|
;;; {Pseudo-Traps for Non-Trap Events}
|
|
|
|
;;; Once there is a body of code to do with responding to (debugging,
|
|
;;; tracing, etc.) traps, it makes sense to be able to leverage that
|
|
;;; same code for certain events that are trap-like, but not actually
|
|
;;; traps in the sense of the calls made by libguile's evaluator.
|
|
|
|
;;; The main example of this is when an error is signalled. Guile
|
|
;;; doesn't yet have a 100% reliable way of hooking into errors, but in
|
|
;;; practice most errors go through a catch whose pre-unwind handler is
|
|
;;; pre-unwind-handler-dispatch (defined in ice-9/boot-9.scm), which in
|
|
;;; turn calls default-pre-unwind-handler. So we can present most errors
|
|
;;; as pseudo-traps by modifying default-pre-unwind-handler.
|
|
|
|
(define default-default-pre-unwind-handler default-pre-unwind-handler)
|
|
|
|
(define (throw->trap-context key args . stack-args)
|
|
(let ((ctx (make <trap-context>
|
|
#:type #:error
|
|
#:continuation #f
|
|
#:return-value (cons key args))))
|
|
(slot-set! ctx 'stack
|
|
(let ((caller-stack (and (= (length stack-args) 1)
|
|
(car stack-args))))
|
|
(if (stack? caller-stack)
|
|
caller-stack
|
|
(apply make-stack #t stack-args))))
|
|
ctx))
|
|
|
|
(define (on-pre-unwind-handler-dispatch behaviour . ignored-keys)
|
|
(set! default-pre-unwind-handler
|
|
(if behaviour
|
|
(lambda (key . args)
|
|
(or (memq key ignored-keys)
|
|
(behaviour (throw->trap-context key
|
|
args
|
|
pre-unwind-handler-dispatch)))
|
|
(apply default-default-pre-unwind-handler key args))
|
|
default-default-pre-unwind-handler)))
|
|
|
|
;;; {Trap Classes}
|
|
|
|
;;; Class: <trap>
|
|
;;;
|
|
;;; <trap> is the base class for traps. Any actual trap should be an
|
|
;;; instance of a class derived from <trap>, not of <trap> itself,
|
|
;;; because there is no base class method for the install-trap,
|
|
;;; trap-runnable? and uninstall-trap GFs.
|
|
(define-class <trap> ()
|
|
;; "number" slot: the number of this trap (assigned automatically).
|
|
(number)
|
|
;; "installed" slot: whether this trap is installed.
|
|
(installed #:init-value #f)
|
|
;; "condition" slot: if non-#f, this is a thunk which is called when
|
|
;; the trap fires, to determine whether trap processing should
|
|
;; proceed any further.
|
|
(condition #:init-value #f #:init-keyword #:condition)
|
|
;; "skip-count" slot: a count of valid (after "condition"
|
|
;; processing) firings of this trap to skip.
|
|
(skip-count #:init-value 0 #:init-keyword #:skip-count)
|
|
;; "single-shot" slot: if non-#f, this trap is removed after it has
|
|
;; successfully fired (after "condition" and "skip-count"
|
|
;; processing) for the first time.
|
|
(single-shot #:init-value #f #:init-keyword #:single-shot)
|
|
;; "behaviour" slot: procedure or list of procedures to call
|
|
;; (passing the trap context as parameter) if we finally decide
|
|
;; (after "condition" and "skip-count" processing) to run this
|
|
;; trap's behaviour.
|
|
(behaviour #:init-value '() #:init-keyword #:behaviour)
|
|
;; "repeat-identical-behaviour" slot: normally, if multiple <trap>
|
|
;; objects are triggered by the same low level trap, and they
|
|
;; request the same behaviour, it's only useful to do that behaviour
|
|
;; once (per low level trap); so by default multiple requests for
|
|
;; the same behaviour are coalesced. If this slot is non-#f, the
|
|
;; contents of the "behaviour" slot are uniquified so that they
|
|
;; avoid being coalesced in this way.
|
|
(repeat-identical-behaviour #:init-value #f
|
|
#:init-keyword #:repeat-identical-behaviour)
|
|
;; "observer" slot: this is a procedure that is called with one
|
|
;; EVENT argument when the trap status changes in certain
|
|
;; interesting ways, currently the following. (1) When the trap is
|
|
;; uninstalled because of the target becoming inaccessible; EVENT in
|
|
;; this case is 'target-gone.
|
|
(observer #:init-value #f #:init-keyword #:observer))
|
|
|
|
(define last-assigned-trap-number 0)
|
|
(define all-traps (make-weak-value-hash-table 7))
|
|
|
|
(define-method (initialize (trap <trap>) initargs)
|
|
(next-method)
|
|
;; Assign a trap number, and store in the hash of all traps.
|
|
(set! last-assigned-trap-number (+ last-assigned-trap-number 1))
|
|
(slot-set! trap 'number last-assigned-trap-number)
|
|
(hash-set! all-traps last-assigned-trap-number trap)
|
|
;; Listify the behaviour slot, if not a list already.
|
|
(let ((behaviour (slot-ref trap 'behaviour)))
|
|
(if (procedure? behaviour)
|
|
(slot-set! trap 'behaviour (list behaviour)))))
|
|
|
|
(define-generic install-trap) ; provided mostly by subclasses
|
|
(define-generic uninstall-trap) ; provided mostly by subclasses
|
|
(define-generic trap->behaviour) ; provided by <trap>
|
|
(define-generic trap-runnable?) ; provided by subclasses
|
|
|
|
(define-method (install-trap (trap <trap>))
|
|
(if (slot-ref trap 'installed)
|
|
(error "Trap is already installed"))
|
|
(slot-set! trap 'installed #t))
|
|
|
|
(define-method (uninstall-trap (trap <trap>))
|
|
(or (slot-ref trap 'installed)
|
|
(error "Trap is not installed"))
|
|
(slot-set! trap 'installed #f))
|
|
|
|
;;; uniquify-behaviour
|
|
;;;
|
|
;;; Uniquify BEHAVIOUR by wrapping it in a new lambda.
|
|
(define (uniquify-behaviour behaviour)
|
|
(lambda (trap-context)
|
|
(behaviour trap-context)))
|
|
|
|
;;; trap->behaviour
|
|
;;;
|
|
;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of
|
|
;;; behaviour procs to call with TRAP-CONTEXT as a parameter.
|
|
;;; Otherwise return the empty list.
|
|
(define-method (trap->behaviour (trap <trap>) (trap-context <trap-context>))
|
|
(if (and
|
|
;; Check that the trap is runnable. Runnability is implemented
|
|
;; by the subclass and allows us to check, for example, that
|
|
;; the procedure being applied in an apply-frame trap matches
|
|
;; this trap's procedure.
|
|
(trap-runnable? trap trap-context)
|
|
;; Check the additional condition, if specified.
|
|
(let ((condition (slot-ref trap 'condition)))
|
|
(or (not condition)
|
|
((condition))))
|
|
;; Check for a skip count.
|
|
(let ((skip-count (slot-ref trap 'skip-count)))
|
|
(if (zero? skip-count)
|
|
#t
|
|
(begin
|
|
(slot-set! trap 'skip-count (- skip-count 1))
|
|
#f))))
|
|
;; All checks passed, so we will return the contents of this
|
|
;; trap's behaviour slot.
|
|
(begin
|
|
;; First, though, remove this trap if its single-shot slot
|
|
;; indicates that it should fire only once.
|
|
(if (slot-ref trap 'single-shot)
|
|
(uninstall-trap trap))
|
|
;; Add this trap object to the context's list of traps which
|
|
;; fired here.
|
|
(slot-set! trap-context 'fired-traps
|
|
(cons trap (tc:fired-traps trap-context)))
|
|
;; Return trap behaviour, uniquified if necessary.
|
|
(if (slot-ref trap 'repeat-identical-behaviour)
|
|
(map uniquify-behaviour (slot-ref trap 'behaviour))
|
|
(slot-ref trap 'behaviour)))
|
|
'()))
|
|
|
|
;;; Class: <procedure-trap>
|
|
;;;
|
|
;;; An installed instance of <procedure-trap> triggers on invocation
|
|
;;; of a specific procedure.
|
|
(define-class <procedure-trap> (<trap>)
|
|
;; "procedure" slot: the procedure to trap on. This is implemented
|
|
;; virtually, using the following weak vector slot, so as to avoid
|
|
;; this trap preventing the GC of the target procedure.
|
|
(procedure #:init-keyword #:procedure
|
|
#:allocation #:virtual
|
|
#:slot-ref
|
|
(lambda (trap)
|
|
(vector-ref (slot-ref trap 'procedure-wv) 0))
|
|
#:slot-set!
|
|
(lambda (trap proc)
|
|
(if (slot-bound? trap 'procedure-wv)
|
|
(vector-set! (slot-ref trap 'procedure-wv) 0 proc)
|
|
(slot-set! trap 'procedure-wv (weak-vector proc)))))
|
|
(procedure-wv))
|
|
|
|
;; Customization of the initialize method: set up to handle what
|
|
;; should happen when the procedure is GC'd.
|
|
(define-method (initialize (trap <procedure-trap>) initargs)
|
|
(next-method)
|
|
(let* ((proc (slot-ref trap 'procedure))
|
|
(existing-traps (volatile-target-traps proc)))
|
|
;; If this is the target's first trap, give the target procedure
|
|
;; to the volatile-target-guardian, so we can find out if it
|
|
;; becomes inaccessible.
|
|
(or existing-traps (volatile-target-guardian proc))
|
|
;; Add this trap to the target procedure's list of traps.
|
|
(set! (volatile-target-traps proc)
|
|
(cons trap (or existing-traps '())))))
|
|
|
|
(define procedure-trace-count (make-object-property))
|
|
|
|
(define-method (install-trap (trap <procedure-trap>))
|
|
(next-method)
|
|
(let* ((proc (slot-ref trap 'procedure))
|
|
(trace-count (or (procedure-trace-count proc) 0)))
|
|
(set-procedure-property! proc 'trace #t)
|
|
(set! (procedure-trace-count proc) (+ trace-count 1)))
|
|
(install-trace-trap trap))
|
|
|
|
(define-method (uninstall-trap (trap <procedure-trap>))
|
|
(next-method)
|
|
(let* ((proc (slot-ref trap 'procedure))
|
|
(trace-count (or (procedure-trace-count proc) 0)))
|
|
(if (= trace-count 1)
|
|
(set-procedure-property! proc 'trace #f))
|
|
(set! (procedure-trace-count proc) (- trace-count 1)))
|
|
(uninstall-trace-trap trap))
|
|
|
|
(define-method (trap-runnable? (trap <procedure-trap>)
|
|
(trap-context <trap-context>))
|
|
(eq? (slot-ref trap 'procedure)
|
|
(frame-procedure (tc:frame trap-context))))
|
|
|
|
;;; Class: <exit-trap>
|
|
;;;
|
|
;;; An installed instance of <exit-trap> triggers on stack frame exit
|
|
;;; past a specified stack depth.
|
|
(define-class <exit-trap> (<trap>)
|
|
;; "depth" slot: the reference depth for the trap.
|
|
(depth #:init-keyword #:depth))
|
|
|
|
(define-method (install-trap (trap <exit-trap>))
|
|
(next-method)
|
|
(install-exit-frame-trap trap))
|
|
|
|
(define-method (uninstall-trap (trap <exit-trap>))
|
|
(next-method)
|
|
(uninstall-exit-frame-trap trap))
|
|
|
|
(define-method (trap-runnable? (trap <exit-trap>)
|
|
(trap-context <trap-context>))
|
|
(<= (tc:exit-depth trap-context)
|
|
(slot-ref trap 'depth)))
|
|
|
|
;;; Class: <entry-trap>
|
|
;;;
|
|
;;; An installed instance of <entry-trap> triggers on any frame entry.
|
|
(define-class <entry-trap> (<trap>))
|
|
|
|
(define-method (install-trap (trap <entry-trap>))
|
|
(next-method)
|
|
(install-enter-frame-trap trap))
|
|
|
|
(define-method (uninstall-trap (trap <entry-trap>))
|
|
(next-method)
|
|
(uninstall-enter-frame-trap trap))
|
|
|
|
(define-method (trap-runnable? (trap <entry-trap>)
|
|
(trap-context <trap-context>))
|
|
#t)
|
|
|
|
;;; Class: <apply-trap>
|
|
;;;
|
|
;;; An installed instance of <apply-trap> triggers on any procedure
|
|
;;; application.
|
|
(define-class <apply-trap> (<trap>))
|
|
|
|
(define-method (install-trap (trap <apply-trap>))
|
|
(next-method)
|
|
(install-apply-frame-trap trap))
|
|
|
|
(define-method (uninstall-trap (trap <apply-trap>))
|
|
(next-method)
|
|
(uninstall-apply-frame-trap trap))
|
|
|
|
(define-method (trap-runnable? (trap <apply-trap>)
|
|
(trap-context <trap-context>))
|
|
#t)
|
|
|
|
;;; Class: <step-trap>
|
|
;;;
|
|
;;; An installed instance of <step-trap> triggers on the next frame
|
|
;;; entry, exit or application, optionally with source location inside
|
|
;;; a specified file.
|
|
(define-class <step-trap> (<exit-trap>)
|
|
;; "file-name" slot: if non-#f, indicates that this trap should
|
|
;; trigger only for steps in source code from the specified file.
|
|
(file-name #:init-value #f #:init-keyword #:file-name)
|
|
;; "exit-depth" slot: when non-#f, indicates that the next step may
|
|
;; be a frame exit past this depth; otherwise, indicates that the
|
|
;; next step must be an application or a frame entry.
|
|
(exit-depth #:init-value #f #:init-keyword #:exit-depth))
|
|
|
|
(define-method (initialize (trap <step-trap>) initargs)
|
|
(next-method)
|
|
(slot-set! trap 'depth (slot-ref trap 'exit-depth)))
|
|
|
|
(define-method (install-trap (trap <step-trap>))
|
|
(next-method)
|
|
(install-enter-frame-trap trap)
|
|
(install-apply-frame-trap trap))
|
|
|
|
(define-method (uninstall-trap (trap <step-trap>))
|
|
(next-method)
|
|
(uninstall-enter-frame-trap trap)
|
|
(uninstall-apply-frame-trap trap))
|
|
|
|
(define-method (trap-runnable? (trap <step-trap>)
|
|
(trap-context <trap-context>))
|
|
(if (eq? (tc:type trap-context) #:return)
|
|
;; We're in the context of an exit-frame trap. Trap should only
|
|
;; be run if exit-depth is set and this exit-frame has returned
|
|
;; past the set depth.
|
|
(and (slot-ref trap 'exit-depth)
|
|
(next-method)
|
|
;; OK to run the trap here, but we should first reset the
|
|
;; exit-depth slot to indicate that the step after this one
|
|
;; must be an application or frame entry.
|
|
(begin
|
|
(slot-set! trap 'exit-depth #f)
|
|
#t))
|
|
;; We're in the context of an application or frame entry trap.
|
|
;; Check whether trap is limited to a specified file.
|
|
(let ((file-name (slot-ref trap 'file-name)))
|
|
(and (or (not file-name)
|
|
(equal? (frame-file-name (tc:frame trap-context)) file-name))
|
|
;; Trap should run here, but we should also set exit-depth to
|
|
;; the current stack length, so that - if we don't stop at any
|
|
;; other steps first - the next step shows the return value of
|
|
;; the current application or evaluation.
|
|
(begin
|
|
(slot-set! trap 'exit-depth (tc:depth trap-context))
|
|
(slot-set! trap 'depth (tc:depth trap-context))
|
|
#t)))))
|
|
|
|
(define (frame->source-position frame)
|
|
(let ((source (if (frame-procedure? frame)
|
|
(or (frame-source frame)
|
|
(let ((proc (frame-procedure frame)))
|
|
(and proc
|
|
(procedure? proc)
|
|
(procedure-source proc))))
|
|
(frame-source frame))))
|
|
(and source
|
|
(string? (source-property source 'filename))
|
|
(list (source-property source 'filename)
|
|
(source-property source 'line)
|
|
(source-property source 'column)))))
|
|
|
|
(define (frame-file-name frame)
|
|
(cond ((frame->source-position frame) => car)
|
|
(else #f)))
|
|
|
|
;;; Class: <source-trap>
|
|
;;;
|
|
;;; An installed instance of <source-trap> triggers upon evaluation of
|
|
;;; a specified source expression.
|
|
(define-class <source-trap> (<trap>)
|
|
;; "expression" slot: the expression to trap on. This is
|
|
;; implemented virtually, using the following weak vector slot, so
|
|
;; as to avoid this trap preventing the GC of the target source
|
|
;; code.
|
|
(expression #:init-keyword #:expression
|
|
#:allocation #:virtual
|
|
#:slot-ref
|
|
(lambda (trap)
|
|
(vector-ref (slot-ref trap 'expression-wv) 0))
|
|
#:slot-set!
|
|
(lambda (trap expr)
|
|
(if (slot-bound? trap 'expression-wv)
|
|
(vector-set! (slot-ref trap 'expression-wv) 0 expr)
|
|
(slot-set! trap 'expression-wv (weak-vector expr)))))
|
|
(expression-wv)
|
|
;; source property slots - for internal use only
|
|
(filename)
|
|
(line)
|
|
(column))
|
|
|
|
;; Customization of the initialize method: get and save the
|
|
;; expression's source properties, or signal an error if it doesn't
|
|
;; have the necessary properties.
|
|
(define-method (initialize (trap <source-trap>) initargs)
|
|
(next-method)
|
|
(let* ((expr (slot-ref trap 'expression))
|
|
(filename (source-property expr 'filename))
|
|
(line (source-property expr 'line))
|
|
(column (source-property expr 'column))
|
|
(existing-traps (volatile-target-traps expr)))
|
|
(or (and filename line column)
|
|
(error "Specified source does not have the necessary properties"
|
|
filename line column))
|
|
(slot-set! trap 'filename filename)
|
|
(slot-set! trap 'line line)
|
|
(slot-set! trap 'column column)
|
|
;; If this is the target's first trap, give the target expression
|
|
;; to the volatile-target-guardian, so we can find out if it
|
|
;; becomes inaccessible.
|
|
(or existing-traps (volatile-target-guardian expr))
|
|
;; Add this trap to the target expression's list of traps.
|
|
(set! (volatile-target-traps expr)
|
|
(cons trap (or existing-traps '())))))
|
|
|
|
;; Just in case more than one trap is installed on the same source
|
|
;; expression ... so that we can still get the setting and resetting
|
|
;; of the 'breakpoint source property correct.
|
|
(define source-breakpoint-count (make-object-property))
|
|
|
|
(define-method (install-trap (trap <source-trap>))
|
|
(next-method)
|
|
(let* ((expr (slot-ref trap 'expression))
|
|
(breakpoint-count (or (source-breakpoint-count expr) 0)))
|
|
(set-source-property! expr 'breakpoint #t)
|
|
(set! (source-breakpoint-count expr) (+ breakpoint-count 1)))
|
|
(install-breakpoint-trap trap))
|
|
|
|
(define-method (uninstall-trap (trap <source-trap>))
|
|
(next-method)
|
|
(let* ((expr (slot-ref trap 'expression))
|
|
(breakpoint-count (or (source-breakpoint-count expr) 0)))
|
|
(if (= breakpoint-count 1)
|
|
(set-source-property! expr 'breakpoint #f))
|
|
(set! (source-breakpoint-count expr) (- breakpoint-count 1)))
|
|
(uninstall-breakpoint-trap trap))
|
|
|
|
(define-method (trap-runnable? (trap <source-trap>)
|
|
(trap-context <trap-context>))
|
|
(or (eq? (slot-ref trap 'expression)
|
|
(tc:expression trap-context))
|
|
(let ((trap-location (frame->source-position (tc:frame trap-context))))
|
|
(and trap-location
|
|
(string=? (car trap-location) (slot-ref trap 'filename))
|
|
(= (cadr trap-location) (slot-ref trap 'line))
|
|
(= (caddr trap-location) (slot-ref trap 'column))))))
|
|
|
|
;; (trap-here EXPRESSION . OPTIONS)
|
|
(define trap-here
|
|
(procedure->memoizing-macro
|
|
(lambda (expr env)
|
|
(let ((trap (apply make
|
|
<source-trap>
|
|
#:expression expr
|
|
(local-eval `(list ,@(cddr expr))
|
|
env))))
|
|
(install-trap trap)
|
|
(set-car! expr 'begin)
|
|
(set-cdr! (cdr expr) '())
|
|
expr))))
|
|
|
|
;;; Class: <location-trap>
|
|
;;;
|
|
;;; An installed instance of <location-trap> triggers on entry to a
|
|
;;; frame with a more-or-less precisely specified source location.
|
|
(define-class <location-trap> (<trap>)
|
|
;; "file-regexp" slot: regexp matching the name(s) of the file(s) to
|
|
;; trap in.
|
|
(file-regexp #:init-keyword #:file-regexp)
|
|
;; "line" and "column" slots: position to trap at (0-based).
|
|
(line #:init-value #f #:init-keyword #:line)
|
|
(column #:init-value #f #:init-keyword #:column)
|
|
;; "compiled-regexp" slot - self explanatory, internal use only
|
|
(compiled-regexp))
|
|
|
|
(define-method (initialize (trap <location-trap>) initargs)
|
|
(next-method)
|
|
(slot-set! trap 'compiled-regexp
|
|
(make-regexp (slot-ref trap 'file-regexp))))
|
|
|
|
(define-method (install-trap (trap <location-trap>))
|
|
(next-method)
|
|
(install-enter-frame-trap trap))
|
|
|
|
(define-method (uninstall-trap (trap <location-trap>))
|
|
(next-method)
|
|
(uninstall-enter-frame-trap trap))
|
|
|
|
(define-method (trap-runnable? (trap <location-trap>)
|
|
(trap-context <trap-context>))
|
|
(and-let* ((trap-location (frame->source-position (tc:frame trap-context)))
|
|
(tcline (cadr trap-location))
|
|
(tccolumn (caddr trap-location)))
|
|
(and (= tcline (slot-ref trap 'line))
|
|
(= tccolumn (slot-ref trap 'column))
|
|
(regexp-exec (slot-ref trap 'compiled-regexp)
|
|
(car trap-location) 0))))
|
|
|
|
;;; {Misc Trap Utilities}
|
|
|
|
(define (get-trap number)
|
|
(hash-ref all-traps number))
|
|
|
|
(define (list-traps)
|
|
(for-each describe
|
|
(map cdr (sort (hash-fold acons '() all-traps)
|
|
(lambda (x y) (< (car x) (car y)))))))
|
|
|
|
;;; {Volatile Traps}
|
|
;;;
|
|
;;; Some traps are associated with Scheme objects that are likely to
|
|
;;; be GC'd, such as procedures and read expressions. When those
|
|
;;; objects are GC'd, we want to allow their traps to evaporate as
|
|
;;; well, or at least not to prevent them from doing so because they
|
|
;;; are (now pointlessly) included on the various installed trap
|
|
;;; lists.
|
|
|
|
;; An object property that maps each volatile target to the list of
|
|
;; traps that are installed on it.
|
|
(define volatile-target-traps (make-object-property))
|
|
|
|
;; A guardian that tells us when a volatile target is no longer
|
|
;; accessible.
|
|
(define volatile-target-guardian (make-guardian))
|
|
|
|
;; An after GC hook that checks for newly inaccessible targets.
|
|
(add-hook! after-gc-hook
|
|
(lambda ()
|
|
(trc 'after-gc-hook)
|
|
(let loop ((target (volatile-target-guardian)))
|
|
(if target
|
|
;; We have a target which is now inaccessible. Get
|
|
;; the list of traps installed on it.
|
|
(begin
|
|
(trc 'after-gc-hook "got target")
|
|
;; Uninstall all the traps that are installed on
|
|
;; this target.
|
|
(for-each (lambda (trap)
|
|
(trc 'after-gc-hook "got trap")
|
|
;; If the trap is still installed,
|
|
;; uninstall it.
|
|
(if (slot-ref trap 'installed)
|
|
(uninstall-trap trap))
|
|
;; If the trap has an observer, tell
|
|
;; it that the target has gone.
|
|
(cond ((slot-ref trap 'observer)
|
|
=>
|
|
(lambda (proc)
|
|
(trc 'after-gc-hook "call obs")
|
|
(proc 'target-gone)))))
|
|
(or (volatile-target-traps target) '()))
|
|
;; Check for any more inaccessible targets.
|
|
(loop (volatile-target-guardian)))))))
|
|
|
|
(define (without-traps thunk)
|
|
(with-traps (lambda ()
|
|
(trap-disable 'traps)
|
|
(thunk))))
|
|
|
|
(define guile-trap-features
|
|
;; Helper procedure, to test whether a specific possible Guile
|
|
;; feature is supported.
|
|
(let ((supported?
|
|
(lambda (test-feature)
|
|
(case test-feature
|
|
((tweaking)
|
|
;; Tweaking is supported if the description of the cheap
|
|
;; traps option includes the word "obsolete", or if the
|
|
;; option isn't there any more.
|
|
(and (string>=? (version) "1.7")
|
|
(let ((cheap-opt-desc
|
|
(assq 'cheap (debug-options-interface 'help))))
|
|
(or (not cheap-opt-desc)
|
|
(string-match "obsolete" (caddr cheap-opt-desc))))))
|
|
(else
|
|
(error "Unexpected feature name:" test-feature))))))
|
|
;; Compile the list of actually supported features from all
|
|
;; possible features.
|
|
(let loop ((possible-features '(tweaking))
|
|
(actual-features '()))
|
|
(if (null? possible-features)
|
|
(reverse! actual-features)
|
|
(let ((test-feature (car possible-features)))
|
|
(loop (cdr possible-features)
|
|
(if (supported? test-feature)
|
|
(cons test-feature actual-features)
|
|
actual-features)))))))
|
|
|
|
;; Make sure that traps are enabled.
|
|
(trap-enable 'traps)
|
|
|
|
;;; (ice-9 debugging traps) ends here.
|