module/system/vm/trap-state.scm

   1 ;;; trap-state.scm: a set of traps
   2
   3 ;; Copyright (C)  2010, 2013 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   #:use-module (system vm frame)
  30   #:use-module (system vm program)
  31   #:export (add-trap!
  32             list-traps
  33             trap-enabled?
  34             trap-name
  35             enable-trap!
  36             disable-trap!
  37             delete-trap!
  38
  39             with-default-trap-handler
  40             install-trap-handler!
  41
  42             add-trap-at-procedure-call!
  43             add-trace-at-procedure-call!
  44             add-trap-at-source-location!
  45             add-ephemeral-trap-at-frame-finish!
  46             add-ephemeral-stepping-trap!))
  47
  48 (define %default-trap-handler (make-fluid))
  49
  50 (define (default-trap-handler frame idx trap-name)
  51   (let ((default-handler (fluid-ref %default-trap-handler)))
  52     (if default-handler
  53         (default-handler frame idx trap-name)
  54         (warn "Trap with no handler installed" frame idx trap-name))))
  55
  56 (define-record <trap-wrapper>
  57   index
  58   enabled?
  59   trap
  60   name)
  61
  62 (define-record <trap-state>
  63   (handler default-trap-handler)
  64   (next-idx 0)
  65   (next-ephemeral-idx -1)
  66   (wrappers '()))
  67
  68 (define (trap-wrapper<? t1 t2)
  69   (< (trap-wrapper-index t1) (trap-wrapper-index t2)))
  70
  71 ;; The interface that a trap provides to the outside world is that of a
  72 ;; procedure, which when called disables the trap, and returns a
  73 ;; procedure to enable the trap. Perhaps this is a bit too odd and we
  74 ;; should fix this.
  75 (define (enable-trap-wrapper! wrapper)
  76   (if (trap-wrapper-enabled? wrapper)
  77       (error "Trap already enabled" (trap-wrapper-index wrapper))
  78       (let ((trap (trap-wrapper-trap wrapper)))
  79         (set! (trap-wrapper-trap wrapper) (trap))
  80         (set! (trap-wrapper-enabled? wrapper) #t))))
  81
  82 (define (disable-trap-wrapper! wrapper)
  83   (if (not (trap-wrapper-enabled? wrapper))
  84       (error "Trap already disabled" (trap-wrapper-index wrapper))
  85       (let ((trap (trap-wrapper-trap wrapper)))
  86         (set! (trap-wrapper-trap wrapper) (trap))
  87         (set! (trap-wrapper-enabled? wrapper) #f))))
  88
  89 (define (add-trap-wrapper! trap-state wrapper)
  90   (set! (trap-state-wrappers trap-state)
  91         (append (trap-state-wrappers trap-state) (list wrapper)))
  92   (trap-wrapper-index wrapper))
  93
  94 (define (remove-trap-wrapper! trap-state wrapper)
  95   (set! (trap-state-wrappers trap-state)
  96         (delq wrapper (trap-state-wrappers trap-state))))
  97
  98 (define (trap-state->trace-level trap-state)
  99   (fold (lambda (wrapper level)
 100           (if (trap-wrapper-enabled? wrapper)
 101               (1+ level)
 102               level))
 103         0
 104         (trap-state-wrappers trap-state)))
 105
 106 (define (wrapper-at-index trap-state idx)
 107   (let lp ((wrappers (trap-state-wrappers trap-state)))
 108     (cond
 109      ((null? wrappers)
 110       (warn "no wrapper found with index in trap-state" idx)
 111       #f)
 112      ((eqv? (trap-wrapper-index (car wrappers)) idx)
 113       (car wrappers))
 114      (else
 115       (lp (cdr wrappers))))))
 116
 117 (define (next-index! trap-state)
 118   (let ((idx (trap-state-next-idx trap-state)))
 119     (set! (trap-state-next-idx trap-state) (1+ idx))
 120     idx))
 121
 122 (define (next-ephemeral-index! trap-state)
 123   (let ((idx (trap-state-next-ephemeral-idx trap-state)))
 124     (set! (trap-state-next-ephemeral-idx trap-state) (1- idx))
 125     idx))
 126
 127 (define (handler-for-index trap-state idx)
 128   (lambda (frame)
 129     (let ((wrapper (wrapper-at-index trap-state idx))
 130           (handler (trap-state-handler trap-state)))
 131       (if wrapper
 132           (handler frame
 133                    (trap-wrapper-index wrapper)
 134                    (trap-wrapper-name wrapper))))))
 135
 136 (define (ephemeral-handler-for-index trap-state idx handler)
 137   (lambda (frame)
 138     (let ((wrapper (wrapper-at-index trap-state idx)))
 139       (if wrapper
 140           (begin
 141             (if (trap-wrapper-enabled? wrapper)
 142                 (disable-trap-wrapper! wrapper))
 143             (remove-trap-wrapper! trap-state wrapper)
 144             (handler frame))))))
 145
 146 \f
 147
 148 ;;;
 149 ;;; Per-thread trap states
 150 ;;;
 151
 152 ;; FIXME: This should be thread-local -- not something you can inherit
 153 ;; from a dynamic state.
 154
 155 (define %trap-state (make-parameter #f))
 156
 157 (define (the-trap-state)
 158   (or (%trap-state)
 159       (let ((ts (make-trap-state)))
 160         (%trap-state ts)
 161         ts)))
 162
 163 \f
 164
 165 ;;;
 166 ;;; API
 167 ;;;
 168
 169 (define* (with-default-trap-handler handler thunk
 170                                     #:optional (trap-state (the-trap-state)))
 171   (with-fluids ((%default-trap-handler handler))
 172     (dynamic-wind
 173       (lambda ()
 174         ;; Don't enable hooks if the handler is #f.
 175         (if handler
 176             (set-vm-trace-level! (trap-state->trace-level trap-state))))
 177       thunk
 178       (lambda ()
 179         (if handler
 180             (set-vm-trace-level! 0))))))
 181
 182 (define* (list-traps #:optional (trap-state (the-trap-state)))
 183   (map trap-wrapper-index (trap-state-wrappers trap-state)))
 184
 185 (define* (trap-name idx #:optional (trap-state (the-trap-state)))
 186   (and=> (wrapper-at-index trap-state idx)
 187          trap-wrapper-name))
 188
 189 (define* (trap-enabled? idx #:optional (trap-state (the-trap-state)))
 190   (and=> (wrapper-at-index trap-state idx)
 191          trap-wrapper-enabled?))
 192
 193 (define* (enable-trap! idx #:optional (trap-state (the-trap-state)))
 194   (and=> (wrapper-at-index trap-state idx)
 195          enable-trap-wrapper!))
 196
 197 (define* (disable-trap! idx #:optional (trap-state (the-trap-state)))
 198   (and=> (wrapper-at-index trap-state idx)
 199          disable-trap-wrapper!))
 200
 201 (define* (delete-trap! idx #:optional (trap-state (the-trap-state)))
 202   (and=> (wrapper-at-index trap-state idx)
 203          (lambda (wrapper)
 204            (if (trap-wrapper-enabled? wrapper)
 205                (disable-trap-wrapper! wrapper))
 206            (remove-trap-wrapper! trap-state wrapper))))
 207
 208 (define* (install-trap-handler! handler #:optional (trap-state (the-trap-state)))
 209   (set! (trap-state-handler trap-state) handler))
 210
 211 (define* (add-trap-at-procedure-call! proc #:optional (trap-state (the-trap-state)))
 212   (let* ((idx (next-index! trap-state))
 213          (trap (trap-at-procedure-call
 214                 proc
 215                 (handler-for-index trap-state idx))))
 216     (add-trap-wrapper!
 217      trap-state
 218      (make-trap-wrapper
 219       idx #t trap
 220       (format #f "Breakpoint at ~a" proc)))))
 221
 222 (define* (add-trace-at-procedure-call! proc
 223                                        #:optional (trap-state (the-trap-state)))
 224   (let* ((idx (next-index! trap-state))
 225          (trap (trace-calls-to-procedure
 226                 proc
 227                 #:prefix (format #f "Trap ~a: " idx))))
 228     (add-trap-wrapper!
 229      trap-state
 230      (make-trap-wrapper
 231       idx #t trap
 232       (format #f "Tracepoint at ~a" proc)))))
 233
 234 (define* (add-trap-at-source-location! file user-line
 235                                        #:optional (trap-state (the-trap-state)))
 236   (let* ((idx (next-index! trap-state))
 237          (trap (trap-at-source-location file user-line
 238                                         (handler-for-index trap-state idx))))
 239     (add-trap-wrapper!
 240      trap-state
 241      (make-trap-wrapper
 242       idx #t trap
 243       (format #f "Breakpoint at ~a:~a" file user-line)))))
 244
 245 ;; handler := frame -> nothing
 246 (define* (add-ephemeral-trap-at-frame-finish! frame handler
 247                                               #:optional (trap-state
 248                                                           (the-trap-state)))
 249   (let* ((idx (next-ephemeral-index! trap-state))
 250          (trap (trap-frame-finish
 251                 frame
 252                 (ephemeral-handler-for-index trap-state idx handler)
 253                 (lambda (frame) (delete-trap! idx trap-state)))))
 254     (add-trap-wrapper!
 255      trap-state
 256      (make-trap-wrapper
 257       idx #t trap
 258       (format #f "Return from ~a" frame)))))
 259
 260 (define (source-string source)
 261   (if source
 262       (format #f "~a:~a:~a" (or (source:file source) "unknown file")
 263               (source:line-for-user source) (source:column source))
 264       "unknown source location"))
 265
 266 (define* (add-ephemeral-stepping-trap! frame handler
 267                                        #:optional (trap-state
 268                                                    (the-trap-state))
 269                                        #:key (into? #t) (instruction? #f))
 270   (define (wrap-predicate-according-to-into predicate)
 271     (if into?
 272         predicate
 273         (let ((fp (frame-address frame)))
 274           (lambda (f)
 275             (and (<= (frame-address f) fp)
 276                  (predicate f))))))
 277
 278   (let* ((source (frame-source frame))
 279          (idx (next-ephemeral-index! trap-state))
 280          (trap (trap-matching-instructions
 281                 (wrap-predicate-according-to-into
 282                  (if instruction?
 283                      (lambda (f) #t)
 284                      (lambda (f) (not (equal? (frame-source f) source)))))
 285                 (ephemeral-handler-for-index trap-state idx handler))))
 286     (add-trap-wrapper!
 287      trap-state
 288      (make-trap-wrapper
 289       idx #t trap
 290       (if instruction?
 291           (if into?
 292               "Step to different instruction"
 293               (format #f "Step to different instruction in ~a" frame))
 294           (if into?
 295               (format #f "Step into ~a" (source-string source))
 296               (format #f "Step out of ~a" (source-string source))))))))
 297
 298 (define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
 299   (let* ((idx (next-index! trap-state)))
 300     (add-trap-wrapper!
 301      trap-state
 302      (make-trap-wrapper idx #t trap name))))