mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 05:50:26 +02:00
implement breakpoints in the repl
* module/system/vm/trap-state.scm: New file, tracks a VM-specific set of traps. * module/Makefile.am: Add trap-state.scm. * module/system/repl/error-handling.scm: While in a with-error-handling block, bind a default trap handler that invokes a recursive prompt. * module/system/repl/command.scm: Add a `break' repl meta-command.
This commit is contained in:
parent
c939b1275b
commit
b9badc35ab
4 changed files with 226 additions and 10 deletions
|
@ -314,6 +314,7 @@ SYSTEM_SOURCES = \
|
|||
system/vm/program.scm \
|
||||
system/vm/trace.scm \
|
||||
system/vm/traps.scm \
|
||||
system/vm/trap-state.scm \
|
||||
system/vm/vm.scm \
|
||||
system/foreign.scm \
|
||||
system/xref.scm \
|
||||
|
|
|
@ -27,6 +27,7 @@
|
|||
#:use-module (system repl debug)
|
||||
#:use-module (system vm objcode)
|
||||
#:use-module (system vm program)
|
||||
#:use-module (system vm trap-state)
|
||||
#:use-module (system vm vm)
|
||||
#:autoload (system base language) (lookup-language language-reader)
|
||||
#:autoload (system vm trace) (vm-trace)
|
||||
|
@ -55,7 +56,8 @@
|
|||
(disassemble x) (disassemble-file xx))
|
||||
(profile (time t) (profile pr) (trace tr))
|
||||
(debug (backtrace bt) (up) (down) (frame fr)
|
||||
(procedure proc) (locals) (error-message error))
|
||||
(procedure proc) (locals) (error-message error)
|
||||
(break br))
|
||||
(inspect (inspect i) (pretty-print pp))
|
||||
(system (gc) (statistics stat) (option o)
|
||||
(quit q continue cont))))
|
||||
|
@ -476,14 +478,6 @@ Trace execution."
|
|||
body body* ...)
|
||||
(format #t "Nothing to debug.~%"))))))))
|
||||
|
||||
(define-stack-command (error-message repl)
|
||||
"error-message
|
||||
Show error message.
|
||||
|
||||
Display the message associated with the error that started the current
|
||||
debugging REPL."
|
||||
(format #t "~a~%" (if (string? message) message "No error message")))
|
||||
|
||||
(define-stack-command (backtrace repl #:optional count
|
||||
#:key (width 72) full?)
|
||||
"backtrace [COUNT] [#:width W] [#:full? F]
|
||||
|
@ -566,6 +560,26 @@ Show local variables.
|
|||
Show locally-bound variables in the selected frame."
|
||||
(print-locals cur))
|
||||
|
||||
(define-stack-command (error-message repl)
|
||||
"error-message
|
||||
Show error message.
|
||||
|
||||
Display the message associated with the error that started the current
|
||||
debugging REPL."
|
||||
(format #t "~a~%" (if (string? message) message "No error message")))
|
||||
|
||||
(define-meta-command (break repl (form))
|
||||
"break PROCEDURE
|
||||
Break on calls to PROCEDURE.
|
||||
|
||||
Starts a recursive prompt when PROCEDURE is called."
|
||||
(let ((proc (repl-eval repl (repl-parse repl form))))
|
||||
(if (not (procedure? proc))
|
||||
(error "Not a procedure: ~a" proc)
|
||||
(let ((idx (add-trap-at-procedure-call! proc)))
|
||||
(format #t "Added breakpoint ~a at ~a.~%" idx proc)))))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Inspection commands
|
||||
|
|
|
@ -21,6 +21,7 @@
|
|||
|
||||
(define-module (system repl error-handling)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system vm trap-state)
|
||||
#:use-module (system repl debug)
|
||||
#:export (call-with-error-handling
|
||||
with-error-handling))
|
||||
|
@ -56,8 +57,34 @@
|
|||
(with-error-to-port err
|
||||
thunk))))))
|
||||
|
||||
(define (debug-trap-handler frame trap-idx trap-name)
|
||||
(let* ((tag (and (pair? (fluid-ref %stacks))
|
||||
(cdar (fluid-ref %stacks))))
|
||||
(stack (narrow-stack->vector
|
||||
(make-stack frame)
|
||||
;; Take the stack from the given frame, cutting 0
|
||||
;; frames.
|
||||
0
|
||||
;; Narrow the end of the stack to the most recent
|
||||
;; start-stack.
|
||||
tag
|
||||
;; And one more frame, because %start-stack
|
||||
;; invoking the start-stack thunk has its own frame
|
||||
;; too.
|
||||
0 (and tag 1)))
|
||||
(error-msg (format #f "Trap ~d: ~a" trap-idx trap-name))
|
||||
(debug (make-debug stack 0 error-msg)))
|
||||
(with-saved-ports
|
||||
(lambda ()
|
||||
(format #t "~a~%" error-msg)
|
||||
(format #t "Entering a new prompt. ")
|
||||
(format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
|
||||
((@ (system repl repl) start-repl) #:debug debug)))))
|
||||
|
||||
(catch #t
|
||||
(lambda () (%start-stack #t thunk))
|
||||
(lambda ()
|
||||
(with-default-trap-handler debug-trap-handler
|
||||
(lambda () (%start-stack #t thunk))))
|
||||
|
||||
(case post-error
|
||||
((report)
|
||||
|
|
174
module/system/vm/trap-state.scm
Normal file
174
module/system/vm/trap-state.scm
Normal file
|
@ -0,0 +1,174 @@
|
|||
;;; trap-state.scm: a set of traps
|
||||
|
||||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||||
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Lesser General Public
|
||||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; This library is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; Lesser General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;; License along with this library; if not, write to the Free Software
|
||||
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (system vm trap-state)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (system vm vm)
|
||||
#:use-module (system vm traps)
|
||||
#:export (list-traps
|
||||
trap-enabled?
|
||||
enable-trap!
|
||||
disable-trap!
|
||||
delete-trap!
|
||||
|
||||
with-default-trap-handler
|
||||
install-trap-handler!
|
||||
|
||||
add-trap-at-procedure-call!))
|
||||
|
||||
(define %default-trap-handler (make-fluid))
|
||||
|
||||
(define (with-default-trap-handler handler thunk)
|
||||
(with-fluids ((%default-trap-handler handler))
|
||||
(thunk)))
|
||||
|
||||
(define (default-trap-handler frame idx trap-name)
|
||||
(if %default-trap-handler
|
||||
((fluid-ref %default-trap-handler) frame idx trap-name)
|
||||
(warn "Trap with no handler installed" frame idx trap-name)))
|
||||
|
||||
(define-record <trap-wrapper>
|
||||
index
|
||||
enabled?
|
||||
trap
|
||||
name)
|
||||
|
||||
(define-record <trap-state>
|
||||
(handler default-trap-handler)
|
||||
(next-idx 0)
|
||||
(wrappers '()))
|
||||
|
||||
(define (trap-wrapper<? t1 t2)
|
||||
(< (trap-wrapper-index t1) (trap-wrapper-index t2)))
|
||||
|
||||
;; The interface that a trap provides to the outside world is that of a
|
||||
;; procedure, which when called disables the trap, and returns a
|
||||
;; procedure to enable the trap. Perhaps this is a bit too odd and we
|
||||
;; should fix this.
|
||||
(define (enable-trap-wrapper! wrapper)
|
||||
(if (trap-wrapper-enabled? wrapper)
|
||||
(error "Trap already enabled" (trap-wrapper-index wrapper))
|
||||
(let ((trap (trap-wrapper-trap wrapper)))
|
||||
(set! (trap-wrapper-trap wrapper) (trap))
|
||||
(set! (trap-wrapper-enabled? wrapper) #t))))
|
||||
|
||||
(define (disable-trap-wrapper! wrapper)
|
||||
(if (not (trap-wrapper-enabled? wrapper))
|
||||
(error "Trap already disabled" (trap-wrapper-index wrapper))
|
||||
(let ((trap (trap-wrapper-trap wrapper)))
|
||||
(set! (trap-wrapper-trap wrapper) (trap))
|
||||
(set! (trap-wrapper-enabled? wrapper) #f))))
|
||||
|
||||
(define (add-trap-wrapper! trap-state wrapper)
|
||||
(set! (trap-state-wrappers trap-state)
|
||||
(append (trap-state-wrappers trap-state) (list wrapper)))
|
||||
(trap-wrapper-index wrapper))
|
||||
|
||||
(define (remove-trap-wrapper! trap-state wrapper)
|
||||
(delq wrapper (trap-state-wrappers trap-state)))
|
||||
|
||||
(define (wrapper-at-index trap-state idx)
|
||||
(let lp ((wrappers (trap-state-wrappers trap-state)))
|
||||
(cond
|
||||
((null? wrappers)
|
||||
(warn "no wrapper found with index in trap-state" idx)
|
||||
#f)
|
||||
((= (trap-wrapper-index (car wrappers)) idx)
|
||||
(car wrappers))
|
||||
(else
|
||||
(lp (cdr wrappers))))))
|
||||
|
||||
(define (next-index! trap-state)
|
||||
(let ((idx (trap-state-next-idx trap-state)))
|
||||
(set! (trap-state-next-idx trap-state) (1+ idx))
|
||||
idx))
|
||||
|
||||
(define (handler-for-index trap-state idx)
|
||||
(lambda (frame)
|
||||
(let ((wrapper (wrapper-at-index trap-state idx))
|
||||
(handler (trap-state-handler trap-state)))
|
||||
(if wrapper
|
||||
(handler frame
|
||||
(trap-wrapper-index wrapper)
|
||||
(trap-wrapper-name wrapper))))))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; VM-local trap states
|
||||
;;;
|
||||
|
||||
(define *trap-states* (make-weak-key-hash-table))
|
||||
|
||||
(define (trap-state-for-vm vm)
|
||||
(or (hashq-ref *trap-states* vm)
|
||||
(let ((ts (make-trap-state)))
|
||||
(hashq-set! *trap-states* vm ts)
|
||||
(trap-state-for-vm vm))))
|
||||
|
||||
(define (the-trap-state)
|
||||
(trap-state-for-vm (the-vm)))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; API
|
||||
;;;
|
||||
|
||||
(define* (list-traps #:optional (trap-state (the-trap-state)))
|
||||
(map (lambda (wrapper)
|
||||
(cons (trap-wrapper-index wrapper)
|
||||
(trap-wrapper-name wrapper)))
|
||||
(trap-state-wrappers trap-state)))
|
||||
|
||||
(define* (trap-enabled? idx #:optional (trap-state (the-trap-state)))
|
||||
(and=> (wrapper-at-index trap-state idx)
|
||||
trap-wrapper-enabled?))
|
||||
|
||||
(define* (enable-trap! idx #:optional (trap-state (the-trap-state)))
|
||||
(and=> (wrapper-at-index trap-state idx)
|
||||
enable-trap-wrapper!))
|
||||
|
||||
(define* (disable-trap! idx #:optional (trap-state (the-trap-state)))
|
||||
(and=> (wrapper-at-index trap-state idx)
|
||||
disable-trap-wrapper!))
|
||||
|
||||
(define* (delete-trap! idx #:optional (trap-state (the-trap-state)))
|
||||
(and=> (wrapper-at-index trap-state idx)
|
||||
(lambda (wrapper)
|
||||
(if (trap-wrapper-enabled? wrapper)
|
||||
(disable-trap-wrapper! wrapper))
|
||||
(remove-trap-wrapper! trap-state wrapper))))
|
||||
|
||||
(define* (install-trap-handler! handler #:optional (trap-state (the-trap-state)))
|
||||
(set! (trap-state-handler trap-state) handler))
|
||||
|
||||
(define* (add-trap-at-procedure-call! proc #:optional (trap-state (the-trap-state)))
|
||||
(let* ((idx (next-index! trap-state))
|
||||
(trap (trap-at-procedure-call
|
||||
proc
|
||||
(handler-for-index trap-state idx))))
|
||||
(add-trap-wrapper!
|
||||
trap-state
|
||||
(make-trap-wrapper
|
||||
idx #t trap
|
||||
(format #f "breakpoint at ~a" proc)))))
|
Loading…
Add table
Add a link
Reference in a new issue