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