module/system/vm/trap-state.scm

   1 ;;; trap-state.scm: a set of traps
   2
   3 ;; Copyright (C)  2010 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; Code:
  22
  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   #:export (list-traps
  30             trap-enabled?
  31             trap-name
  32             enable-trap!
  33             disable-trap!
  34             delete-trap!
  35
  36             with-default-trap-handler
  37             install-trap-handler!
  38
  39             add-trap-at-procedure-call!
  40             add-trace-at-procedure-call!
  41             add-trap-at-source-location!))
  42
  43 (define %default-trap-handler (make-fluid))
  44
  45 (define (default-trap-handler frame idx trap-name)
  46   (let ((default-handler (fluid-ref %default-trap-handler)))
  47     (if default-handler
  48         (default-handler frame idx trap-name)
  49         (warn "Trap with no handler installed" frame idx trap-name))))
  50
  51 (define-record <trap-wrapper>
  52   index
  53   enabled?
  54   trap
  55   name)
  56
  57 (define-record <trap-state>
  58   (handler default-trap-handler)
  59   (next-idx 0)
  60   (wrappers '()))
  61
  62 (define (trap-wrapper<? t1 t2)
  63   (< (trap-wrapper-index t1) (trap-wrapper-index t2)))
  64
  65 ;; The interface that a trap provides to the outside world is that of a
  66 ;; procedure, which when called disables the trap, and returns a
  67 ;; procedure to enable the trap. Perhaps this is a bit too odd and we
  68 ;; should fix this.
  69 (define (enable-trap-wrapper! wrapper)
  70   (if (trap-wrapper-enabled? wrapper)
  71       (error "Trap already enabled" (trap-wrapper-index wrapper))
  72       (let ((trap (trap-wrapper-trap wrapper)))
  73         (set! (trap-wrapper-trap wrapper) (trap))
  74         (set! (trap-wrapper-enabled? wrapper) #t))))
  75
  76 (define (disable-trap-wrapper! wrapper)
  77   (if (not (trap-wrapper-enabled? wrapper))
  78       (error "Trap already disabled" (trap-wrapper-index wrapper))
  79       (let ((trap (trap-wrapper-trap wrapper)))
  80         (set! (trap-wrapper-trap wrapper) (trap))
  81         (set! (trap-wrapper-enabled? wrapper) #f))))
  82
  83 (define (add-trap-wrapper! trap-state wrapper)
  84   (set! (trap-state-wrappers trap-state)
  85         (append (trap-state-wrappers trap-state) (list wrapper)))
  86   (trap-wrapper-index wrapper))
  87
  88 (define (remove-trap-wrapper! trap-state wrapper)
  89   (delq wrapper (trap-state-wrappers trap-state)))
  90
  91 (define (trap-state->trace-level trap-state)
  92   (fold (lambda (wrapper level)
  93           (if (trap-wrapper-enabled? wrapper)
  94               (1+ level)
  95               level))
  96         0
  97         (trap-state-wrappers trap-state)))
  98
  99 (define (wrapper-at-index trap-state idx)
 100   (let lp ((wrappers (trap-state-wrappers trap-state)))
 101     (cond
 102      ((null? wrappers)
 103       (warn "no wrapper found with index in trap-state" idx)
 104       #f)
 105      ((= (trap-wrapper-index (car wrappers)) idx)
 106       (car wrappers))
 107      (else
 108       (lp (cdr wrappers))))))
 109
 110 (define (next-index! trap-state)
 111   (let ((idx (trap-state-next-idx trap-state)))
 112     (set! (trap-state-next-idx trap-state) (1+ idx))
 113     idx))
 114
 115 (define (handler-for-index trap-state idx)
 116   (lambda (frame)
 117     (let ((wrapper (wrapper-at-index trap-state idx))
 118           (handler (trap-state-handler trap-state)))
 119       (if wrapper
 120           (handler frame
 121                    (trap-wrapper-index wrapper)
 122                    (trap-wrapper-name wrapper))))))
 123
 124 \f
 125
 126 ;;;
 127 ;;; VM-local trap states
 128 ;;;
 129
 130 (define *trap-states* (make-weak-key-hash-table))
 131
 132 (define (trap-state-for-vm vm)
 133   (or (hashq-ref *trap-states* vm)
 134       (let ((ts (make-trap-state)))
 135         (hashq-set! *trap-states* vm ts)
 136         (trap-state-for-vm vm))))
 137
 138 (define (the-trap-state)
 139   (trap-state-for-vm (the-vm)))
 140
 141 \f
 142
 143 ;;;
 144 ;;; API
 145 ;;;
 146
 147 (define* (with-default-trap-handler handler thunk
 148                                     #:optional (trap-state (the-trap-state)))
 149   (with-fluids ((%default-trap-handler handler))
 150     (dynamic-wind
 151       (lambda ()
 152         ;; Don't enable hooks if the handler is #f.
 153         (if handler
 154             (set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state))))
 155       thunk
 156       (lambda ()
 157         (if handler
 158             (set-vm-trace-level! (the-vm) 0))))))
 159
 160 (define* (list-traps #:optional (trap-state (the-trap-state)))
 161   (map trap-wrapper-index (trap-state-wrappers trap-state)))
 162
 163 (define* (trap-name idx #:optional (trap-state (the-trap-state)))
 164   (and=> (wrapper-at-index trap-state idx)
 165          trap-wrapper-name))
 166
 167 (define* (trap-enabled? idx #:optional (trap-state (the-trap-state)))
 168   (and=> (wrapper-at-index trap-state idx)
 169          trap-wrapper-enabled?))
 170
 171 (define* (enable-trap! idx #:optional (trap-state (the-trap-state)))
 172   (and=> (wrapper-at-index trap-state idx)
 173          enable-trap-wrapper!))
 174
 175 (define* (disable-trap! idx #:optional (trap-state (the-trap-state)))
 176   (and=> (wrapper-at-index trap-state idx)
 177          disable-trap-wrapper!))
 178
 179 (define* (delete-trap! idx #:optional (trap-state (the-trap-state)))
 180   (and=> (wrapper-at-index trap-state idx)
 181          (lambda (wrapper)
 182            (if (trap-wrapper-enabled? wrapper)
 183                (disable-trap-wrapper! wrapper))
 184            (remove-trap-wrapper! trap-state wrapper))))
 185
 186 (define* (install-trap-handler! handler #:optional (trap-state (the-trap-state)))
 187   (set! (trap-state-handler trap-state) handler))
 188
 189 (define* (add-trap-at-procedure-call! proc #:optional (trap-state (the-trap-state)))
 190   (let* ((idx (next-index! trap-state))
 191          (trap (trap-at-procedure-call
 192                 proc
 193                 (handler-for-index trap-state idx))))
 194     (add-trap-wrapper!
 195      trap-state
 196      (make-trap-wrapper
 197       idx #t trap
 198       (format #f "Breakpoint at ~a" proc)))))
 199
 200 (define* (add-trace-at-procedure-call! proc
 201                                        #:optional (trap-state (the-trap-state)))
 202   (let* ((idx (next-index! trap-state))
 203          (trap (trace-calls-to-procedure
 204                 proc
 205                 #:prefix (format #f "Trap ~a: " idx))))
 206     (add-trap-wrapper!
 207      trap-state
 208      (make-trap-wrapper
 209       idx #t trap
 210       (format #f "Tracepoint at ~a" proc)))))
 211
 212 (define* (add-trap-at-source-location! file user-line
 213                                        #:optional (trap-state (the-trap-state)))
 214   (let* ((idx (next-index! trap-state))
 215          (trap (trap-at-source-location file user-line
 216                                         (handler-for-index trap-state idx))))
 217     (add-trap-wrapper!
 218      trap-state
 219      (make-trap-wrapper
 220       idx #t trap
 221       (format #f "Breakpoint at ~a:~a" file user-line)))))
 222
 223 (define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
 224   (let* ((idx (next-index! trap-state)))
 225     (add-trap-wrapper!
 226      trap-state
 227      (make-trap-wrapper idx #t trap name))))