mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 01:30:27 +02:00
Code Activity

integrate the debugger into the repl

Browse source 
* module/system/repl/debug.scm: New file, defines a data type to hold
  state for a debugger stack, and some helper procedures to print the
  stack or print a frame. Most pieces are from (system vm debug).

* module/system/repl/error-handling.scm: New file, implements
  call-with-error-handling and with-error-handling, and instead of going
  into a debugger, we go into a recursive repl that happens to have
  debugging information. Will be removing the old debugger from (system
  vm debug) shortly.

* module/Makefile.am (SYSTEM_SOURCES): Add error-handling and debug scm
  files.

* module/system/repl/repl.scm (prompting-meta-read): Better error
  handling -- we don't want to go into a debugger when reading a
  command.
  (start-repl): Add #:debug keyword argument, and just dispatch to
  run-repl.
  (run-repl): New function, with the guts of the old start-repl. Added a
  prompt, to which a throw to 'quit will abort.

* module/system/repl/common.scm (repl-prepare-eval-thunk): New
  helper. In the future we will use this to not enter the debugger on
  errors that happen at compile time.
  (repl-eval): Use repl-prepare-eval-thunk.
  (repl-print): Run the before-print-hook when printing a value.

* module/system/repl/command.scm (*command-table*): Move `option' to the
  `system' group. Move `trace' to the `profile' group. Add `debug' and
  `inspect' groups.
  (command-abbrevs): Rename from command-abbrev, and allow multiple
  abbreviations.
  (display-group): Fix the case where abbrev? was #f.
  (display-summary): Fix alignment of the command and
  abbreviations. Allow multiple abbreviations.
  (read-command): Rename from read-datum, and have better error
  handling.
  (meta-command): Better error handling.
  (define-meta-command): Better error handling.
  (help, show, import, compile, disassemble, time, profile, trace): Fix
  docstrings and error messages.
  (define-stack-command): New helper, for commands that operate on a
  saved stack.
  (backtrace, up, down, frame, procedure, locals): New debugger
  commands, in the REPL now.
  (inspect, pretty-print): New "inspect" commands.
This commit is contained in:
Andy Wingo 2010-07-09 17:04:34 +02:00
parent ddfb5e2bb0
commit 33df2ec719
6 changed files with 619 additions and 121 deletions
Download patch file Download diff file Expand all files Collapse all files

299
module/system/repl/command.scm
View file

@ -24,6 +24,7 @@
#:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system repl common)
#:use-module (system repl debug)
#:use-module (system vm objcode)
#:use-module (system vm program)
#:use-module (system vm vm)
@ -35,6 +36,9 @@
#:use-module (ice-9 documentation)
#:use-module (ice-9 and-let-star)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 control)
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
#:use-module (statprof)
#:export (meta-command))
@ -44,14 +48,17 @@
;;;
(define *command-table*
'((help (help h) (show s) (apropos a) (describe d) (option o) (quit q))
(module (module m) (import i) (load l) (binding b))
'((help (help h) (show s) (apropos a) (describe d))
(module (module m) (import use) (load l) (binding b))
(language (language L))
(compile (compile c) (compile-file cc)
(disassemble x) (disassemble-file xx))
(profile (time t) (profile pr))
(debug (trace tr))
(system (gc) (statistics stat))))
(profile (time t) (profile pr) (trace tr))
(debug (backtrace bt) (up) (down) (frame fr)
(procedure proc) (locals))
(inspect (inspect i) (pretty-print pp))
(system (gc) (statistics stat) (option o)
(quit q continue cont))))
(define *show-table*
'((show (warranty w) (copying c) (version v))))
@ -61,7 +68,7 @@
(define *command-module* (current-module))
(define (command-name c) (car c))
(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
(define (command-abbrevs c) (cdr c))
(define (command-procedure c) (module-ref *command-module* (command-name c)))
(define (command-doc c) (procedure-documentation (command-procedure c)))
@ -88,10 +95,10 @@
(else (loop groups (cdr commands))))))
(define* (display-group group #:optional (abbrev? #t))
(format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
(format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?)
(for-each (lambda (c)
(display-summary (command-usage c)
(and abbrev? (command-abbrev c))
(if abbrev? (command-abbrevs c) '())
(command-summary c)))
(group-commands group))
(newline))
@ -101,12 +108,37 @@
(display (command-doc command))
(newline))
(define (display-summary usage abbrev summary)
(let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
(format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
(define (display-summary usage abbrevs summary)
(let* ((usage-len (string-length usage))
(abbrevs (if (pair? abbrevs)
(format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs))
""))
(abbrevs-len (string-length abbrevs)))
(format #t " ,~A~A~A - ~A\n"
usage
(cond
((> abbrevs-len 32)
(error "abbrevs too long" abbrevs))
((> (+ usage-len abbrevs-len) 32)
(format #f "~%~v_" (+ 2 (- 32 abbrevs-len))))
(else
(format #f "~v_" (- 32 abbrevs-len usage-len))))
abbrevs
summary)))
(define (read-datum repl)
(read (repl-inport repl)))
(define (read-command repl)
(catch #t
(lambda () (read (pk (repl-inport repl))))
(lambda (key . args)
(pmatch args
((,subr ,msg ,args . ,rest)
(format #t "Throw to key `~a' while reading command:\n" key)
(display-error #f (current-output-port) subr msg args rest))
(else
(format #t "Throw to key `~a' with args `~s' while reading command.\n"
key args)))
(force-output)
*unspecified*)))
(define read-line
(let ((orig-read-line read-line))
@ -114,34 +146,57 @@
(orig-read-line (repl-inport repl)))))
(define (meta-command repl)
(let ((command (read-datum repl)))
(if (not (symbol? command))
(user-error "Meta-command not a symbol: ~s" command))
(let ((c (lookup-command command)))
(if c
((command-procedure c) repl)
(user-error "Unknown meta command: ~A" command)))))
(let ((command (read-command repl)))
(cond
((eq? command *unspecified*)) ; read error, already signalled; pass.
((not (symbol? command))
(format #t "Meta-command not a symbol: ~s~%" command))
((lookup-command command)
=> (lambda (c) ((command-procedure c) repl)))
(else
(format #t "Unknown meta command: ~A~%" command)))))
(define-syntax define-meta-command
(syntax-rules ()
((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
(define (name repl)
docstring
(let* ((expression0
(repl-reader ""
(lambda* (#:optional (port (repl-inport repl)))
((language-reader (repl-language repl))
port (current-module)))))
...)
(apply (lambda* datums
(with-output-to-port (repl-outport repl)
(lambda () b0 b1 ...)))
(let ((port (open-input-string (read-line repl))))
(let lp ((out '()))
(let ((x (read port)))
(if (eof-object? x)
(reverse out)
(lp (cons x out))))))))))
(define (handle-read-error form-name key args)
(pmatch args
((,subr ,msg ,args . ,rest)
(format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
key form-name 'name)
(display-error #f (current-output-port) subr msg args rest))
(else
(format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
key args form-name 'name)))
(abort))
(% (let* ((expression0
(catch #t
(lambda ()
(repl-reader ""
(lambda* (#:optional (port (repl-inport repl)))
((language-reader (repl-language repl))
port (current-module)))))
(lambda (k . args)
(handle-read-error 'expression0 k args))))
...)
(apply (lambda* datums
(with-output-to-port (repl-outport repl)
(lambda () b0 b1 ...)))
(catch #t
(lambda ()
(let ((port (open-input-string (read-line repl))))
(let lp ((out '()))
(let ((x (read port)))
(if (eof-object? x)
(reverse out)
(lp (cons x out)))))))
(lambda (k . args)
(handle-read-error #f k args)))))
(lambda (k) #f)))) ; the abort handler
((_ (name repl . datums) docstring b0 b1 ...)
(define-meta-command (name repl () . datums)
docstring b0 b1 ...))))
@ -153,11 +208,8 @@
;;;
(define-meta-command (help repl . args)
"help
help GROUP
help [-c] COMMAND
Gives help on the meta-commands available at the REPL.
"help [all | GROUP | [-c] COMMAND]
Show help.
With one argument, tries to look up the argument as a group name, giving
help on that group if successful. Otherwise tries to look up the
@ -191,16 +243,14 @@ are displayed."
((-c ,command) (guard (lookup-command command))
(display-command (lookup-command command)))
((,command)
(user-error "Unknown command or group: ~A" command))
(format #t "Unknown command or group: ~A~%" command))
((-c ,command)
(user-error "Unknown command: ~A" command))
(format #t "Unknown command: ~A~%" command))
(else
(user-error "Bad arguments: ~A" args))))
(format #t "Bad arguments: ~A~%" args))))
(define-meta-command (show repl . args)
"show
show TOPIC
"show [TOPIC]
Gives information about Guile.
With one argument, tries to show a particular piece of information;
@ -216,9 +266,9 @@ Without any argument, a list of topics is displayed."
((,topic) (guard (lookup-command topic *show-table*))
((command-procedure (lookup-command topic *show-table*)) repl))
((,command)
(user-error "Unknown topic: ~A" command))
(format #t "Unknown topic: ~A~%" command))
(else
(user-error "Bad arguments: ~A" args))))
(format #t "Bad arguments: ~A~%" args))))
(define (warranty repl)
"show warranty
@ -291,7 +341,7 @@ Import modules / List those imported."
(let ((mod (resolve-interface name)))
(if mod
(module-use! (current-module) mod)
(user-error "No such module: ~A" name))))
(format #t "No such module: ~A~%" name))))
(if (null? args)
(for-each puts (map module-name (module-uses (current-module))))
(for-each use args))))
@ -333,7 +383,7 @@ Change languages."
;;;
(define-meta-command (compile repl (form))
"compile FORM
"compile EXP
Generate compiled code."
(let ((x (repl-compile repl (repl-parse repl form))))
(cond ((objcode? x) (guile:disassemble x))
@ -349,8 +399,8 @@ Compile a file."
((@ (language assembly disassemble) disassemble) x))
(define-meta-command (disassemble repl (form))
"disassemble PROGRAM
Disassemble a program."
"disassemble EXP
Disassemble a compiled procedure."
(guile:disassemble (repl-eval repl (repl-parse repl form))))
(define-meta-command (disassemble-file repl file)
@ -364,7 +414,7 @@ Disassemble a file."
;;;
(define-meta-command (time repl (form))
"time FORM
"time EXP
Time execution."
(let* ((gc-start (gc-run-time))
(tms-start (times))
@ -385,21 +435,15 @@ Time execution."
result))
(define-meta-command (profile repl (form) . opts)
"profile FORM
"profile EXP
Profile execution."
;; FIXME opts
(apply statprof
(make-program (repl-compile repl (repl-parse repl form)))
opts))
;;;
;;; Debug commands
;;;
(define-meta-command (trace repl (form) . opts)
"trace FORM
"trace EXP
Trace execution."
;; FIXME: doc options, or somehow deal with them better
(apply vm-trace
@ -407,6 +451,139 @@ Trace execution."
(make-program (repl-compile repl (repl-parse repl form)))
opts))
;;;
;;; Debug commands
;;;
(define-syntax define-stack-command
(lambda (x)
(syntax-case x ()
((_ (name repl . args) docstring body body* ...)
#`(define-meta-command (name repl . args)
docstring
(let ((debug (repl-debug repl)))
(if debug
(letrec-syntax
((#,(datum->syntax #'repl 'frames)
(identifier-syntax (debug-frames debug)))
(#,(datum->syntax #'repl 'index)
(identifier-syntax
(id (debug-index debug))
((set! id exp) (set! (debug-index debug) exp))))
(#,(datum->syntax #'repl 'cur)
(identifier-syntax
(vector-ref #,(datum->syntax #'repl 'frames)
#,(datum->syntax #'repl 'index)))))
body body* ...)
(format #t "Nothing to debug.~%"))))))))
(define-stack-command (backtrace repl #:optional count
#:key (width 72) full?)
"backtrace [COUNT] [#:width W] [#:full? F]
Print a backtrace.
Print a backtrace of all stack frames, or innermost COUNT frames.
If COUNT is negative, the last COUNT frames will be shown."
(print-frames frames
#:count count
#:width width
#:full? full?))
(define-stack-command (up repl #:optional (count 1))
"up [COUNT]
Select a calling stack frame.
Select and print stack frames that called this one.
An argument says how many frames up to go."
(cond
((or (not (integer? count)) (<= count 0))
(format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
((>= (+ count index) (vector-length frames))
(cond
((= index (1- (vector-length frames)))
(format #t "Already at outermost frame.\n"))
(else
(set! index (1- (vector-length frames)))
(print-frame cur #:index index))))
(else
(set! index (+ count index))
(print-frame cur #:index index))))
(define-stack-command (down repl #:optional (count 1))
"down [COUNT]
Select a called stack frame.
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 count) 0)
(cond
((zero? index)
(format #t "Already at innermost frame.\n"))
(else
(set! index 0)
(print-frame cur #:index index))))
(else
(set! index (- index count))
(print-frame cur #:index index))))
(define-stack-command (frame repl #:optional idx)
"frame [IDX]
Show a frame.
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.~%"))
((< idx (vector-length frames))
(set! index idx)
(print-frame cur #:index index))
(else
(format #t "No such frame.~%"))))
(else (print-frame cur #:index index))))
(define-stack-command (procedure repl)
"procedure
Print the procedure for the selected frame.
Foo."
(repl-print repl (frame-procedure cur)))
(define-stack-command (locals repl)
"locals
Show local variables.
Show locally-bound variables in the selected frame."
(print-locals cur))
;;;
;;; Inspection commands
;;;
(define-stack-command (inspect repl (form))
"inspect EXP
Inspect the result(s) of evaluating EXP."
(call-with-values (make-program (repl-compile repl (repl-parse repl form)))
(lambda args
(for-each %inspect args))))
(define-meta-command (pretty-print repl (form))
"pretty-print EXP
Pretty-print the result(s) of evaluating EXP."
(call-with-values (make-program (repl-compile repl (repl-parse repl form)))
(lambda args
(for-each
(lambda (x)
(run-hook before-print-hook x)
(pp x))
args))))
;;;