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 (system vm vm)
  26   #:use-module (system vm traps)
  27   #:export (list-traps
  28             trap-enabled?
  29             enable-trap!
  30             disable-trap!
  31             delete-trap!
  32
  33             with-default-trap-handler
  34             install-trap-handler!
  35
  36             add-trap-at-procedure-call!))
  37
  38 (define %default-trap-handler (make-fluid))
  39
  40 (define (with-default-trap-handler handler thunk)
  41   (with-fluids ((%default-trap-handler handler))
  42     (thunk)))
  43
  44 (define (default-trap-handler frame idx trap-name)
  45   (if %default-trap-handler
  46       ((fluid-ref %default-trap-handler) frame idx trap-name)
  47       (warn "Trap with no handler installed" frame idx trap-name)))
  48
  49 (define-record <trap-wrapper>
  50   index
  51   enabled?
  52   trap
  53   name)
  54
  55 (define-record <trap-state>
  56   (handler default-trap-handler)
  57   (next-idx 0)
  58   (wrappers '()))
  59
  60 (define (trap-wrapper<? t1 t2)
  61   (< (trap-wrapper-index t1) (trap-wrapper-index t2)))
  62
  63 ;; The interface that a trap provides to the outside world is that of a
  64 ;; procedure, which when called disables the trap, and returns a
  65 ;; procedure to enable the trap. Perhaps this is a bit too odd and we
  66 ;; should fix this.
  67 (define (enable-trap-wrapper! wrapper)
  68   (if (trap-wrapper-enabled? wrapper)
  69       (error "Trap already enabled" (trap-wrapper-index wrapper))
  70       (let ((trap (trap-wrapper-trap wrapper)))
  71         (set! (trap-wrapper-trap wrapper) (trap))
  72         (set! (trap-wrapper-enabled? wrapper) #t))))
  73
  74 (define (disable-trap-wrapper! wrapper)
  75   (if (not (trap-wrapper-enabled? wrapper))
  76       (error "Trap already disabled" (trap-wrapper-index wrapper))
  77       (let ((trap (trap-wrapper-trap wrapper)))
  78         (set! (trap-wrapper-trap wrapper) (trap))
  79         (set! (trap-wrapper-enabled? wrapper) #f))))
  80
  81 (define (add-trap-wrapper! trap-state wrapper)
  82   (set! (trap-state-wrappers trap-state)
  83         (append (trap-state-wrappers trap-state) (list wrapper)))
  84   (trap-wrapper-index wrapper))
  85
  86 (define (remove-trap-wrapper! trap-state wrapper)
  87   (delq wrapper (trap-state-wrappers trap-state)))
  88
  89 (define (wrapper-at-index trap-state idx)
  90   (let lp ((wrappers (trap-state-wrappers trap-state)))
  91     (cond
  92      ((null? wrappers)
  93       (warn "no wrapper found with index in trap-state" idx)
  94       #f)
  95      ((= (trap-wrapper-index (car wrappers)) idx)
  96       (car wrappers))
  97      (else
  98       (lp (cdr wrappers))))))
  99
 100 (define (next-index! trap-state)
 101   (let ((idx (trap-state-next-idx trap-state)))
 102     (set! (trap-state-next-idx trap-state) (1+ idx))
 103     idx))
 104
 105 (define (handler-for-index trap-state idx)
 106   (lambda (frame)
 107     (let ((wrapper (wrapper-at-index trap-state idx))
 108           (handler (trap-state-handler trap-state)))
 109       (if wrapper
 110           (handler frame
 111                    (trap-wrapper-index wrapper)
 112                    (trap-wrapper-name wrapper))))))
 113
 114 \f
 115
 116 ;;;
 117 ;;; VM-local trap states
 118 ;;;
 119
 120 (define *trap-states* (make-weak-key-hash-table))
 121
 122 (define (trap-state-for-vm vm)
 123   (or (hashq-ref *trap-states* vm)
 124       (let ((ts (make-trap-state)))
 125         (hashq-set! *trap-states* vm ts)
 126         (trap-state-for-vm vm))))
 127
 128 (define (the-trap-state)
 129   (trap-state-for-vm (the-vm)))
 130
 131 \f
 132
 133 ;;;
 134 ;;; API
 135 ;;;
 136
 137 (define* (list-traps #:optional (trap-state (the-trap-state)))
 138   (map (lambda (wrapper)
 139          (cons (trap-wrapper-index wrapper)
 140                (trap-wrapper-name wrapper)))
 141        (trap-state-wrappers trap-state)))
 142
 143 (define* (trap-enabled? idx #:optional (trap-state (the-trap-state)))
 144   (and=> (wrapper-at-index trap-state idx)
 145          trap-wrapper-enabled?))
 146
 147 (define* (enable-trap! idx #:optional (trap-state (the-trap-state)))
 148   (and=> (wrapper-at-index trap-state idx)
 149          enable-trap-wrapper!))
 150
 151 (define* (disable-trap! idx #:optional (trap-state (the-trap-state)))
 152   (and=> (wrapper-at-index trap-state idx)
 153          disable-trap-wrapper!))
 154
 155 (define* (delete-trap! idx #:optional (trap-state (the-trap-state)))
 156   (and=> (wrapper-at-index trap-state idx)
 157          (lambda (wrapper)
 158            (if (trap-wrapper-enabled? wrapper)
 159                (disable-trap-wrapper! wrapper))
 160            (remove-trap-wrapper! trap-state wrapper))))
 161
 162 (define* (install-trap-handler! handler #:optional (trap-state (the-trap-state)))
 163   (set! (trap-state-handler trap-state) handler))
 164
 165 (define* (add-trap-at-procedure-call! proc #:optional (trap-state (the-trap-state)))
 166   (let* ((idx (next-index! trap-state))
 167          (trap (trap-at-procedure-call
 168                 proc
 169                 (handler-for-index trap-state idx))))
 170     (add-trap-wrapper!
 171      trap-state
 172      (make-trap-wrapper
 173       idx #t trap
 174       (format #f "breakpoint at ~a" proc)))))