ice-9/debugger/trap-hooks.scm

   1 ;;;; (ice-9 debugger trap-hooks) -- abstraction of libguile's traps interface
   2
   3 ;;; Copyright (C) 2002 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18
  19 ;;; This module provides an abstraction around Guile's low level trap
  20 ;;; handler interface; its aim is to make the low level trap mechanism
  21 ;;; shareable between the debugger and other applications, and to
  22 ;;; insulate the rest of the debugger code a bit from changes that may
  23 ;;; occur in the low level trap interface in future.
  24
  25 (define-module (ice-9 debugger trap-hooks)
  26   #:use-module (ice-9 debugger trc)
  27   #:export (add-trapped-stack-id!
  28             remove-trapped-stack-id!
  29             before-apply-frame-hook
  30             before-enter-frame-hook
  31             before-exit-frame-hook
  32             after-apply-frame-hook
  33             after-enter-frame-hook
  34             after-exit-frame-hook
  35             add-apply-frame-hook!
  36             add-breakpoint-hook!
  37             add-enter-frame-hook!
  38             add-exit-frame-hook!
  39             add-trace-hook!
  40             remove-apply-frame-hook!
  41             remove-breakpoint-hook!
  42             remove-enter-frame-hook!
  43             remove-exit-frame-hook!
  44             remove-trace-hook!))
  45
  46 ;;; The current low level traps interface is as follows.
  47 ;;;
  48 ;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled
  49 ;;; by the `traps' setting of `(evaluator-traps-interface)' but also
  50 ;;; (and more relevant in most cases) by the `with-traps' procedure.
  51 ;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of
  52 ;;; its thunk parameter.
  53 ;;;
  54 ;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0
  55 ;;; for the duration of the call, to avoid nasty recursive trapping
  56 ;;; loops.  If a trap handler knows what it is doing, it can override
  57 ;;; this by `(trap-enable traps)'.
  58 ;;;
  59 ;;; The apply-frame handler is called when Guile is about to perform
  60 ;;; an application if EITHER the `apply-frame' evaluator trap option
  61 ;;; is set, OR the `trace' debug option is set and the procedure to
  62 ;;; apply has its `trace' procedure property set.  The arguments
  63 ;;; passed are:
  64 ;;;
  65 ;;; - the symbol 'apply-frame
  66 ;;;
  67 ;;; - a continuation or debug object describing the current stack
  68 ;;;
  69 ;;; - a boolean indicating whether the application is tail-recursive.
  70 ;;;
  71 ;;; The enter-frame handler is called when the evaluator begins a new
  72 ;;; evaluation frame if EITHER the `enter-frame' evaluator trap option
  73 ;;; is set, OR the `breakpoints' debug option is set and the code to
  74 ;;; be evaluated has its `breakpoint' source property set.  The
  75 ;;; arguments passed are:
  76 ;;;
  77 ;;; - the symbol 'enter-frame
  78 ;;;
  79 ;;; - a continuation or debug object describing the current stack
  80 ;;;
  81 ;;; - a boolean indicating whether the application is tail-recursive.
  82 ;;;
  83 ;;; - an unmemoized copy of the expression to be evaluated.
  84 ;;;
  85 ;;; If the `enter-frame' evaluator trap option is set, the enter-frame
  86 ;;; handler is also called when about to perform an application in
  87 ;;; SCM_APPLY, immediately before possible calling the apply-frame
  88 ;;; handler.  (I don't totally understand this.)  In this case, the
  89 ;;; arguments passed are:
  90 ;;;
  91 ;;; - the symbol 'enter-frame
  92 ;;;
  93 ;;; - a continuation or debug object describing the current stack.
  94 ;;;
  95 ;;; The exit-frame handler is called when Guile exits an evaluation
  96 ;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if
  97 ;;; EITHER the `exit-frame' evaluator trap option is set, OR the
  98 ;;; `trace' debug option is set and the frame is marked as having been
  99 ;;; traced.  The frame will be marked as having been traced if the
 100 ;;; apply-frame handler was called for this frame.  (This is trickier
 101 ;;; than it sounds because of tail recursion: the same debug frame
 102 ;;; could have been used for multiple applications, only some of which
 103 ;;; were traced - I think.)  The arguments passed are:
 104 ;;;
 105 ;;; - the symbol 'exit-frame
 106 ;;;
 107 ;;; - a continuation or debug object describing the current stack
 108 ;;;
 109 ;;; - the result of the evaluation or application.
 110
 111 ;;; {Stack IDs}
 112 ;;;
 113 ;;; Mechanism for limiting trapping to contexts whose stack ID matches
 114 ;;; one of a registered set.  The default set up is to limit trapping
 115 ;;; to events in the contexts of the Guile REPL and of file loading.
 116
 117 (define trapped-stack-ids (list 'repl-stack 'load-stack))
 118 (define all-stack-ids-trapped? #f)
 119
 120 (define (add-trapped-stack-id! id)
 121   "Add ID to the set of stack ids for which traps are active.
 122 If `#t' is in this set, traps are active regardless of stack context.
 123 To remove ID again, use `remove-trapped-stack-id!'.  If you add the
 124 same ID twice using `add-trapped-stack-id!', you will need to remove
 125 it twice."
 126   (set! trapped-stack-ids (cons id trapped-stack-ids))
 127   (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
 128
 129 (define (remove-trapped-stack-id! id)
 130   "Remove ID from the set of stack ids for which traps are active."
 131   (set! trapped-stack-ids (delq1! id trapped-stack-ids))
 132   (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
 133
 134 (define (trap-here? cont)
 135   ;; Return true if the stack id of the specified continuation (or
 136   ;; debug object) is in the set that we should trap for; otherwise
 137   ;; false.
 138   (or all-stack-ids-trapped?
 139       (memq (stack-id cont) trapped-stack-ids)))
 140
 141 ;;; {Global State}
 142 ;;;
 143 ;;; Variables tracking registered handlers, relevant procedures, and
 144 ;;; what's turned on as regards the evaluator's debugging options.
 145
 146 (define before-enter-frame-hook (make-hook 3))
 147 (define enter-frame-hook (make-hook))
 148 (define breakpoint-hook (make-hook))
 149 (define after-enter-frame-hook (make-hook))
 150
 151 (define before-exit-frame-hook (make-hook 2))
 152 (define exit-frame-hook (make-hook))
 153 (define after-exit-frame-hook (make-hook))
 154
 155 (define before-apply-frame-hook (make-hook 2))
 156 (define apply-frame-hook (make-hook))
 157 (define trace-hook (make-hook))
 158 (define after-apply-frame-hook (make-hook))
 159
 160 (define (hook-not-empty? hook)
 161   (not (hook-empty? hook)))
 162
 163 (define set-debug-and-trap-options
 164   (let ((dopts (debug-options))
 165         (topts (evaluator-traps-interface))
 166         (setting (lambda (key opts)
 167                    (let ((l (memq key opts)))
 168                      (and l
 169                           (not (null? (cdr l)))
 170                           (cadr l)))))
 171         (debug-set-boolean! (lambda (key value)
 172                               ((if value debug-enable debug-disable) key)))
 173         (trap-set-boolean! (lambda (key value)
 174                              ((if value trap-enable trap-disable) key))))
 175     (let ((save-debug (memq 'debug dopts))
 176           (save-trace (memq 'trace dopts))
 177           (save-breakpoints (memq 'breakpoints dopts))
 178           (save-enter-frame (memq 'enter-frame topts))
 179           (save-apply-frame (memq 'apply-frame topts))
 180           (save-exit-frame (memq 'exit-frame topts))
 181           (save-enter-frame-handler (setting 'enter-frame-handler topts))
 182           (save-apply-frame-handler (setting 'apply-frame-handler topts))
 183           (save-exit-frame-handler (setting 'exit-frame-handler topts)))
 184       (lambda ()
 185         (let ((need-trace (hook-not-empty? trace-hook))
 186               (need-breakpoints (hook-not-empty? breakpoint-hook))
 187               (need-enter-frame (hook-not-empty? enter-frame-hook))
 188               (need-apply-frame (hook-not-empty? apply-frame-hook))
 189               (need-exit-frame (hook-not-empty? exit-frame-hook)))
 190           (debug-set-boolean! 'debug
 191                               (or need-trace
 192                                   need-breakpoints
 193                                   need-enter-frame
 194                                   need-apply-frame
 195                                   need-exit-frame
 196                                   save-debug))
 197           (debug-set-boolean! 'trace
 198                               (or need-trace
 199                                   save-trace))
 200           (debug-set-boolean! 'breakpoints
 201                               (or need-breakpoints
 202                                   save-breakpoints))
 203           (trap-set-boolean! 'enter-frame
 204                              (or need-enter-frame
 205                                  save-enter-frame))
 206           (trap-set-boolean! 'apply-frame
 207                              (or need-apply-frame
 208                                  save-apply-frame))
 209           (trap-set-boolean! 'exit-frame
 210                              (or need-exit-frame
 211                                  save-exit-frame))
 212           (trap-set! enter-frame-handler
 213                      (cond ((or need-breakpoints
 214                                 need-enter-frame)
 215                             enter-frame-handler)
 216                            (else save-enter-frame-handler)))
 217           (trap-set! apply-frame-handler
 218                      (cond ((or need-trace
 219                                 need-apply-frame)
 220                             apply-frame-handler)
 221                            (else save-apply-frame-handler)))
 222           (trap-set! exit-frame-handler
 223                      (cond ((or need-exit-frame)
 224                             exit-frame-handler)
 225                            (else save-exit-frame-handler))))
 226         ;;(write (evaluator-traps-interface))
 227         *unspecified*))))
 228
 229 (define (enter-frame-handler key cont . args)
 230   ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an
 231   ;; unmemoized copy of the source expression.  For an application
 232   ;; entry, ARGS is empty.
 233   (if (trap-here? cont)
 234       (let ((application-entry? (null? args)))
 235         (trc 'enter-frame-handler)
 236         (if application-entry?
 237             (run-hook before-enter-frame-hook cont #f #f)
 238             (run-hook before-enter-frame-hook cont (car args) (cadr args)))
 239         (run-hook enter-frame-hook)
 240         (or application-entry?
 241             (run-hook breakpoint-hook))
 242         (run-hook after-enter-frame-hook))))
 243
 244 (define (exit-frame-handler key cont retval)
 245   (if (trap-here? cont)
 246       (begin
 247         (trc 'exit-frame-handler retval (stack-length (make-stack cont)))
 248         (run-hook before-exit-frame-hook cont retval)
 249         (run-hook exit-frame-hook)
 250         (run-hook after-exit-frame-hook))))
 251
 252 (define (apply-frame-handler key cont tail?)
 253   (if (trap-here? cont)
 254       (begin
 255         (trc 'apply-frame-handler tail?)
 256         (run-hook before-apply-frame-hook cont tail?)
 257         (run-hook apply-frame-hook)
 258         (run-hook trace-hook)
 259         (run-hook after-apply-frame-hook))))
 260
 261 (define-public (add-enter-frame-hook! proc)
 262   (add-hook! enter-frame-hook proc)
 263   (set-debug-and-trap-options))
 264
 265 (define-public (add-breakpoint-hook! proc)
 266   (add-hook! breakpoint-hook proc)
 267   (set-debug-and-trap-options))
 268
 269 (define-public (add-exit-frame-hook! proc)
 270   (add-hook! exit-frame-hook proc)
 271   (set-debug-and-trap-options))
 272
 273 (define-public (add-apply-frame-hook! proc)
 274   (add-hook! apply-frame-hook proc)
 275   (set-debug-and-trap-options))
 276
 277 (define-public (add-trace-hook! proc)
 278   (add-hook! trace-hook proc)
 279   (set-debug-and-trap-options))
 280
 281 (define-public (remove-enter-frame-hook! proc)
 282   (remove-hook! enter-frame-hook proc)
 283   (set-debug-and-trap-options))
 284
 285 (define-public (remove-breakpoint-hook! proc)
 286   (remove-hook! breakpoint-hook proc)
 287   (set-debug-and-trap-options))
 288
 289 (define-public (remove-exit-frame-hook! proc)
 290   (remove-hook! exit-frame-hook proc)
 291   (set-debug-and-trap-options))
 292
 293 (define-public (remove-apply-frame-hook! proc)
 294   (remove-hook! apply-frame-hook proc)
 295   (set-debug-and-trap-options))
 296
 297 (define-public (remove-trace-hook! proc)
 298   (remove-hook! trace-hook proc)
 299   (set-debug-and-trap-options))
 300
 301 ;;; (ice-9 debugger trap-hooks) ends here.