guile/ice-9/debugger/trap-hooks.scm

;;;; (ice-9 debugger trap-hooks) -- abstraction of libguile's traps interface

;;; Copyright (C) 2002 Free Software Foundation, Inc.
;;;
;; 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 debugger trap-hooks)
  #:use-module (ice-9 debugger trc)
  #:export (add-trapped-stack-id!
	    remove-trapped-stack-id!
	    before-apply-frame-hook
	    before-enter-frame-hook
	    before-exit-frame-hook
	    after-apply-frame-hook
	    after-enter-frame-hook
	    after-exit-frame-hook
	    add-apply-frame-hook!
	    add-breakpoint-hook!
	    add-enter-frame-hook!
	    add-exit-frame-hook!
	    add-trace-hook!
	    remove-apply-frame-hook!
	    remove-breakpoint-hook!
	    remove-enter-frame-hook!
	    remove-exit-frame-hook!
	    remove-trace-hook!
	    debug-hook-membership))

;;; 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 possible 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.

;;; {Stack IDs}
;;;
;;; Mechanism for limiting trapping to contexts whose stack ID matches
;;; one of a registered set.  The default set up is to limit trapping
;;; to events in the contexts of the Guile REPL and of file loading.

(define trapped-stack-ids (list 'repl-stack 'load-stack))
(define all-stack-ids-trapped? #f)

(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 before-enter-frame-hook (make-hook 3))
(define enter-frame-hook (make-hook))
(define breakpoint-hook (make-hook))
(define after-enter-frame-hook (make-hook))

(define before-exit-frame-hook (make-hook 2))
(define exit-frame-hook (make-hook))
(define after-exit-frame-hook (make-hook))

(define before-apply-frame-hook (make-hook 2))
(define apply-frame-hook (make-hook))
(define trace-hook (make-hook))
(define after-apply-frame-hook (make-hook))

(define (hook-not-empty? hook)
  (not (hook-empty? hook)))

(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 (hook-not-empty? trace-hook))
	      (need-breakpoints (hook-not-empty? breakpoint-hook))
	      (need-enter-frame (hook-not-empty? enter-frame-hook))
	      (need-apply-frame (hook-not-empty? apply-frame-hook))
	      (need-exit-frame (hook-not-empty? exit-frame-hook)))
	  (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)))
	(trc 'enter-frame-handler)
	(if application-entry?
	    (run-hook before-enter-frame-hook cont #f #f)
	    (run-hook before-enter-frame-hook cont (car args) (cadr args)))
	(run-hook enter-frame-hook)
	(or application-entry?
	    (run-hook breakpoint-hook))
	(run-hook after-enter-frame-hook))))

(define (exit-frame-handler key cont retval)
  (if (trap-here? cont)
      (begin
	(trc 'exit-frame-handler retval (stack-length (make-stack cont)))
	(run-hook before-exit-frame-hook cont retval)
	(run-hook exit-frame-hook)
	(run-hook after-exit-frame-hook))))

(define (apply-frame-handler key cont tail?)
  (if (trap-here? cont)
      (begin
	(trc 'apply-frame-handler tail?)
	(run-hook before-apply-frame-hook cont tail?)
	(run-hook apply-frame-hook)
	(run-hook trace-hook)
	(run-hook after-apply-frame-hook))))

(define-public (add-enter-frame-hook! proc)
  (add-hook! enter-frame-hook proc)
  (set-debug-and-trap-options))

(define-public (add-breakpoint-hook! proc)
  (add-hook! breakpoint-hook proc)
  (set-debug-and-trap-options))

(define-public (add-exit-frame-hook! proc)
  (add-hook! exit-frame-hook proc)
  (set-debug-and-trap-options))

(define-public (add-apply-frame-hook! proc)
  (add-hook! apply-frame-hook proc)
  (set-debug-and-trap-options))

(define-public (add-trace-hook! proc)
  (add-hook! trace-hook proc)
  (set-debug-and-trap-options))

(define-public (remove-enter-frame-hook! proc)
  (remove-hook! enter-frame-hook proc)
  (set-debug-and-trap-options))

(define-public (remove-breakpoint-hook! proc)
  (remove-hook! breakpoint-hook proc)
  (set-debug-and-trap-options))

(define-public (remove-exit-frame-hook! proc)
  (remove-hook! exit-frame-hook proc)
  (set-debug-and-trap-options))

(define-public (remove-apply-frame-hook! proc)
  (remove-hook! apply-frame-hook proc)
  (set-debug-and-trap-options))

(define-public (remove-trace-hook! proc)
  (remove-hook! trace-hook proc)
  (set-debug-and-trap-options))

(define-public (debug-hook-membership)
  (for-each (lambda (name+hook)
	      (format #t "~A:\n" (car name+hook))
	      (for-each (lambda (proc)
			  (format #t "  ~S\n" proc))
			(hook->list (cdr name+hook))))
	    `((before-enter-frame-hook . ,before-enter-frame-hook)
	      (enter-frame-hook	       . ,enter-frame-hook       )
	      (breakpoint-hook	       . ,breakpoint-hook        )
	      (after-enter-frame-hook  . ,after-enter-frame-hook )
	      (before-exit-frame-hook  . ,before-exit-frame-hook )
	      (exit-frame-hook	       . ,exit-frame-hook        )
	      (after-exit-frame-hook   . ,after-exit-frame-hook  )
	      (before-apply-frame-hook . ,before-apply-frame-hook)
	      (apply-frame-hook	       . ,apply-frame-hook       )
	      (trace-hook	       . ,trace-hook             )
	      (after-apply-frame-hook  . ,after-apply-frame-hook ))))

;;; (ice-9 debugger trap-hooks) ends here.