mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
1ad7fef524
* module/system/vm/debug.scm: Implement the skeleton of a debugger. Not very useful yet. * module/system/repl/repl.scm (call-with-backtrace): Have the pre-unwind hook drop the user into the debugger. Hopefully we can have something better within a couple weeks.
136 lines
4.7 KiB
Scheme
136 lines
4.7 KiB
Scheme
;;; Guile VM debugging facilities
|
||
|
||
;;; Copyright (C) 2001, 2009 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
|
||
|
||
;;; Code:
|
||
|
||
(define-module (system vm debug)
|
||
#:use-module (system base syntax)
|
||
#:use-module (system vm vm)
|
||
#:use-module (system vm frame)
|
||
#:use-module (ice-9 format)
|
||
#:export (run-debugger debug-pre-unwind-handler))
|
||
|
||
|
||
;;;
|
||
;;; Debugger
|
||
;;;
|
||
|
||
(define-record <debugger> vm level breakpoints module)
|
||
|
||
(define (make-debugger-module)
|
||
(let ((m (make-fresh-user-module)))
|
||
m))
|
||
|
||
(define vm-debugger
|
||
(let ((prop (make-object-property)))
|
||
(lambda (vm)
|
||
(or (prop vm)
|
||
(let ((debugger (make-debugger vm (make-fluid) '() (make-debugger-module))))
|
||
(set! (prop vm) debugger)
|
||
debugger)))))
|
||
|
||
(define* (run-debugger frame #:optional (vm (the-vm)))
|
||
(let* ((db (vm-debugger vm))
|
||
(level (debugger-level db)))
|
||
(with-fluids ((level (or (and=> (fluid-ref level) 1+) 0)))
|
||
(debugger-repl db frame))))
|
||
|
||
(define (debugger-repl db frame)
|
||
(let ((top frame))
|
||
(define (frame-index frame)
|
||
(let lp ((idx 0) (walk top))
|
||
(if (= (frame-return-address frame) (frame-return-address walk))
|
||
idx
|
||
(lp (1+ idx) (frame-previous walk)))))
|
||
(let loop ()
|
||
(let ((index (frame-index frame))
|
||
(level (fluid-ref (debugger-level db))))
|
||
(let ((cmd (repl-reader
|
||
(lambda ()
|
||
(format #f "debug[~a@~a]> " level index))
|
||
read)))
|
||
(if (not (or (eof-object? cmd)
|
||
(memq cmd '(q quit c continue))))
|
||
(begin
|
||
(case cmd
|
||
((bt)
|
||
(display-backtrace (make-stack frame) (current-output-port)))
|
||
((bindings)
|
||
(format #t "~a\n" (frame-bindings frame)))
|
||
((frame f)
|
||
(format #t "~s\n" frame))
|
||
((up)
|
||
(let ((prev (frame-previous frame)))
|
||
(if prev
|
||
(begin
|
||
(set! index (1+ index))
|
||
(set! frame prev)
|
||
(format #t "~s\n" frame))
|
||
(format #t "Already at outermost frame.\n"))))
|
||
((down)
|
||
(if (zero? index)
|
||
(format #t "Already at innermost frame.\n")
|
||
(begin
|
||
(set! frame (let lp ((n (1- index)) (frame top))
|
||
(if (zero? n)
|
||
frame
|
||
(lp (1- n) (frame-previous top)))))
|
||
(format #t "~s\n" frame))))
|
||
((help ?)
|
||
(format #t "Type `c' to continue.\n"))
|
||
(else
|
||
(format #t "Unknown command: ~A\n" cmd)))
|
||
(loop))))))))
|
||
|
||
;; things this debugger should do:
|
||
;;
|
||
;; eval expression in context of frame
|
||
;; up/down stack for inspecting
|
||
;; print procedure and args for frame
|
||
;; print local variables for frame
|
||
;; set local variable in frame
|
||
;; display backtrace
|
||
;; display full backtrace
|
||
;; step until next instruction
|
||
;; step until next function call/return
|
||
;; step until return from frame
|
||
;; step until different source line
|
||
;; step until greater source line
|
||
;; watch expression
|
||
;; break on a function
|
||
;; remove breakpoints
|
||
;; set printing width
|
||
;; display a truncated backtrace
|
||
;; go to a frame by index
|
||
;; (reuse gdb commands perhaps)
|
||
;; help
|
||
;; disassemble a function
|
||
;; disassemble the current function
|
||
;; inspect any object
|
||
;; hm, trace via reassigning global vars. tricksy.
|
||
;; (state associated with vm ?)
|
||
|
||
(define (debug-pre-unwind-handler key . args)
|
||
;; herald
|
||
(format #t "Throw to key `~a' with args `~s'.
|
||
Entering the debugger. Type `bt' for a backtrace or `c' to continue.
|
||
This debugger implementation is temporary. See system/vm/debug.scm for
|
||
some ideas on how to make it better.\n" key args)
|
||
(run-debugger (stack-ref (make-stack #t) 1))
|
||
(save-stack 1)
|
||
(apply throw key args))
|