mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 20:30:28 +02:00
391 lines
13 KiB
Scheme
391 lines
13 KiB
Scheme
;;; Guile VM debugging facilities
|
||
|
||
;;; Copyright (C) 2001, 2009, 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
|
||
|
||
;;; Code:
|
||
|
||
(define-module (system vm debug)
|
||
#:use-module (system base pmatch)
|
||
#:use-module (system base syntax)
|
||
#:use-module (system vm vm)
|
||
#:use-module (system vm frame)
|
||
#:use-module (ice-9 rdelim)
|
||
#:use-module (ice-9 pretty-print)
|
||
#:use-module (ice-9 format)
|
||
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
|
||
#:use-module (system vm program)
|
||
#:export (run-debugger debug-pre-unwind-handler))
|
||
|
||
|
||
(define (reverse-hashq h)
|
||
(let ((ret (make-hash-table)))
|
||
(hash-for-each
|
||
(lambda (k v)
|
||
(hashq-set! ret v (cons k (hashq-ref ret v '()))))
|
||
h)
|
||
ret))
|
||
|
||
(define (catch-bad-arguments thunk bad-args-thunk)
|
||
(catch 'wrong-number-of-args
|
||
(lambda ()
|
||
(catch 'keyword-argument-error
|
||
thunk
|
||
(lambda (k . args)
|
||
(bad-args-thunk))))
|
||
(lambda (k . args)
|
||
(bad-args-thunk))))
|
||
|
||
(define (read-args prompt)
|
||
(define (read* reader)
|
||
(repl-reader prompt reader))
|
||
(define (next)
|
||
(read* read-char))
|
||
(define (cmd chr)
|
||
(cond
|
||
((eof-object? chr) (list chr))
|
||
((char=? chr #\newline) (cmd (next)))
|
||
((char-whitespace? chr) (cmd (next)))
|
||
(else
|
||
(unread-char chr)
|
||
(let ((tok (read* read)))
|
||
(args (list tok) (next))))))
|
||
(define (args out chr)
|
||
(cond
|
||
((eof-object? chr) (reverse out))
|
||
((char=? chr #\newline) (reverse out))
|
||
((char-whitespace? chr) (args out (next)))
|
||
(else
|
||
(unread-char chr)
|
||
(let ((tok (read* read)))
|
||
(args (cons tok out) (next))))))
|
||
(cmd (next)))
|
||
|
||
(define* (print-locals frame #:optional (port (current-output-port))
|
||
#:key (width 72) (per-line-prefix ""))
|
||
(let ((bindings (frame-bindings frame)))
|
||
(cond
|
||
((null? bindings)
|
||
(format port "~aNo local variables.~%" per-line-prefix))
|
||
(else
|
||
(format port "~aLocal variables:~%" per-line-prefix)
|
||
(for-each
|
||
(lambda (binding)
|
||
(format port "~a~4d ~a~:[~; (boxed)~] = ~v:@y\n"
|
||
per-line-prefix
|
||
(binding:index binding)
|
||
(binding:name binding)
|
||
(binding:boxed? binding)
|
||
width
|
||
(let ((x (frame-local-ref frame (binding:index binding))))
|
||
(if (binding:boxed? binding)
|
||
(variable-ref x)
|
||
x))))
|
||
(frame-bindings frame))))))
|
||
|
||
(define* (collect-frames frame #:key count)
|
||
(cond
|
||
((not count)
|
||
(let lp ((frame frame) (out '()))
|
||
(if (not frame)
|
||
out
|
||
(lp (frame-previous frame) (cons frame out)))))
|
||
;; should also have a from-end option, either via negative count or
|
||
;; another kwarg
|
||
((>= count 0)
|
||
(let lp ((frame frame) (out '()) (count count))
|
||
(if (or (not frame) (zero? count))
|
||
out
|
||
(lp (frame-previous frame) (cons frame out) (1- count)))))))
|
||
|
||
(define* (print-frames frames #:optional (port (current-output-port))
|
||
#:key (start-index (1- (length frames))) (width 72)
|
||
(full? #f))
|
||
(let lp ((frames frames) (i start-index) (last-file ""))
|
||
(if (pair? frames)
|
||
(let* ((frame (car frames))
|
||
(source (frame-source frame))
|
||
(file (and source
|
||
(or (source:file source)
|
||
"current input")))
|
||
(line (and=> source source:line)))
|
||
(if (and file (not (equal? file last-file)))
|
||
(format port "~&In ~a:~&" file))
|
||
(format port "~:[~*~6_~;~5d:~]~3d ~v:@y~%" line line
|
||
i width (frame-call-representation frame))
|
||
(if full?
|
||
(print-locals frame #:width width
|
||
#:per-line-prefix " "))
|
||
(lp (cdr frames) (1- i) (or file last-file))))))
|
||
|
||
|
||
;;;
|
||
;;; 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 0 '() (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)))
|
||
(dynamic-wind
|
||
(lambda () (set! (debugger-level db) (1+ level)))
|
||
(lambda () (debugger-repl db frame))
|
||
(lambda () (set! (debugger-level db) level)))))
|
||
|
||
(define (debugger-repl db frame)
|
||
(let ((top frame)
|
||
(cur frame)
|
||
(index 0)
|
||
(level (debugger-level db))
|
||
(last #f))
|
||
(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)))))
|
||
(define (frame-at-index idx)
|
||
(let lp ((idx idx) (walk top))
|
||
(cond
|
||
((not walk) #f)
|
||
((zero? idx) walk)
|
||
(else (lp (1- idx) (frame-previous walk))))))
|
||
(define (show-frame)
|
||
;; #2 0x009600e0 in do_std_select (args=0xbfffd9e0) at threads.c:1668
|
||
;; 1668 select (select_args->nfds,
|
||
(format #t "#~2a 0x~8,'0x in ~60@y~%"
|
||
index
|
||
(frame-instruction-pointer cur)
|
||
(frame-call-representation cur)))
|
||
|
||
(define-syntax define-command
|
||
(syntax-rules ()
|
||
((_ ((mod cname alias ...) . args) body ...)
|
||
(define cname
|
||
(let ((c (lambda* args body ...)))
|
||
(set-procedure-property! c 'name 'cname)
|
||
(module-define! mod 'cname c)
|
||
(module-add! mod 'alias (module-local-variable mod 'cname))
|
||
...
|
||
c)))))
|
||
|
||
(let ((commands (make-module)))
|
||
(define (prompt)
|
||
(format #f "~a~a debug> "
|
||
(if (= level 1)
|
||
""
|
||
(format #f "~a:" level))
|
||
index))
|
||
|
||
(define (print* . vals)
|
||
(define (print x)
|
||
(run-hook before-print-hook x)
|
||
(set! last x)
|
||
(pretty-print x))
|
||
(if (and (pair? vals)
|
||
(not (and (null? (cdr vals))
|
||
(unspecified? (car vals)))))
|
||
(for-each print vals)))
|
||
|
||
(define-command ((commands backtrace bt) #:optional count
|
||
#:key (width 72) full?)
|
||
"Print a backtrace of all stack frames, or innermost COUNT frames."
|
||
(print-frames (collect-frames top #:count count)
|
||
#:width width
|
||
#:full? full?))
|
||
|
||
(define-command ((commands up) #:optional (count 1))
|
||
"Select and print stack frames that called this one.
|
||
An argument says how many frames up to go"
|
||
(if (or (not (integer? count)) (<= count 0))
|
||
(format #t "Invalid argument to `up': expected a positive integer for COUNT.~%")
|
||
(let lp ((n count))
|
||
(cond
|
||
((zero? n) (show-frame))
|
||
((frame-previous cur)
|
||
=> (lambda (new)
|
||
(set! cur new)
|
||
(set! index (1+ index))
|
||
(lp (1- n))))
|
||
((= n count)
|
||
(format #t "Already at outermost frame.\n"))
|
||
(else
|
||
(format #t "Reached outermost frame after walking ~a frames.\n"
|
||
(- count n))
|
||
(show-frame))))))
|
||
|
||
(define-command ((commands down) #:optional (count 1))
|
||
"Select and print stack frames called by this one.
|
||
An argument says how many frames down to go"
|
||
(cond
|
||
((or (not (integer? count)) (<= count 0))
|
||
(format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
|
||
((= index 0)
|
||
(format #t "Already at innermost frame.~%"))
|
||
(else
|
||
(set! index (max (- index count) 0))
|
||
(set! cur (frame-at-index index))
|
||
(show-frame))))
|
||
|
||
(define-command ((commands frame f) #:optional idx)
|
||
"Show the selected frame.
|
||
With an argument, select a frame by index, then show it."
|
||
(cond
|
||
(idx
|
||
(cond
|
||
((or (not (integer? idx)) (< idx 0))
|
||
(format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
|
||
((frame-at-index idx)
|
||
=> (lambda (f)
|
||
(set! cur f)
|
||
(set! index idx)
|
||
(show-frame)))
|
||
(else
|
||
(format #t "No such frame.~%"))))
|
||
(else (show-frame))))
|
||
|
||
(define-command ((commands procedure proc))
|
||
"Print the procedure for the selected frame."
|
||
(print* (frame-procedure cur)))
|
||
|
||
(define-command ((commands inspect i))
|
||
"Launch the inspector on the last-printed object."
|
||
(%inspect last))
|
||
|
||
(define-command ((commands locals))
|
||
"Show locally-bound variables in the selected frame."
|
||
(print-locals cur))
|
||
|
||
(define-command ((commands quit q continue cont c))
|
||
"Quit the debugger and let the program continue executing."
|
||
(throw 'quit))
|
||
|
||
(define-command ((commands help h ?) #:optional cmd)
|
||
"Show this help message."
|
||
(let ((rhash (reverse-hashq (module-obarray commands))))
|
||
(define (help-cmd cmd)
|
||
(let* ((v (module-local-variable commands cmd))
|
||
(p (variable-ref v))
|
||
(canonical-name (procedure-name p)))
|
||
;; la la la
|
||
(format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
|
||
canonical-name (program-lambda-list p)
|
||
"~#[~:;~40t(aliases: ~@{~a~^, ~})~]"
|
||
(delq canonical-name (hashq-ref rhash v))
|
||
(procedure-documentation p))))
|
||
(cond
|
||
(cmd
|
||
(cond
|
||
((and (symbol? cmd) (module-local-variable commands cmd))
|
||
(help-cmd cmd))
|
||
(else
|
||
(format #t "Invalid command ~s.~%" cmd)
|
||
(format #t "Try `help' for a list of commands~%"))))
|
||
(else
|
||
(let ((names (sort
|
||
(hash-map->list
|
||
(lambda (k v)
|
||
(procedure-name (variable-ref k)))
|
||
rhash)
|
||
(lambda (x y)
|
||
(string<? (symbol->string x)
|
||
(symbol->string y))))))
|
||
(format #t "Available commands:~%~%")
|
||
(for-each help-cmd names))))))
|
||
|
||
(define (handle cmd . args)
|
||
(cond
|
||
((and (symbol? cmd)
|
||
(module-local-variable commands cmd))
|
||
=> (lambda (var)
|
||
(let ((proc (variable-ref var)))
|
||
(catch-bad-arguments
|
||
(lambda ()
|
||
(apply (variable-ref var) args))
|
||
(lambda ()
|
||
(format (current-error-port)
|
||
"Invalid arguments to ~a. Try `help ~a'.~%"
|
||
(procedure-name proc) (procedure-name proc)))))))
|
||
((and (integer? cmd) (exact? cmd))
|
||
(frame cmd))
|
||
((eof-object? cmd)
|
||
(newline)
|
||
(throw 'quit))
|
||
(else
|
||
(format (current-error-port)
|
||
"~&Unknown command: ~a. Try `help'.~%" cmd)
|
||
*unspecified*)))
|
||
|
||
(catch 'quit
|
||
(lambda ()
|
||
(let loop ()
|
||
(apply
|
||
handle
|
||
(save-module-excursion
|
||
(lambda ()
|
||
(set-current-module commands)
|
||
(read-args prompt))))
|
||
(loop)))
|
||
(lambda (k . args)
|
||
(apply values args))))))
|
||
|
||
|
||
;; TODO:
|
||
;;
|
||
;; eval expression in context of frame
|
||
;; set local variable in frame
|
||
;; 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)
|
||
;; 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)
|
||
(let ((stack (make-stack #t 2)))
|
||
(pmatch args
|
||
((,subr ,msg ,args . ,rest)
|
||
(format #t "Throw to key `~a':\n" key)
|
||
(display-error stack (current-output-port) subr msg args rest))
|
||
(else
|
||
(format #t "Throw to key `~a' with args `~s'." key args)))
|
||
(format #t "Entering the debugger. Type `bt' for a backtrace or `c' to continue.\n")
|
||
(run-debugger (stack-ref stack 0)))
|
||
(save-stack debug-pre-unwind-handler)
|
||
(apply throw key args))
|