a3e43fe1804845d49d464700d74bd9f695d94b68
[bpt/guile.git] / module / system / repl / command.scm
1 ;;; Repl commands
2
3 ;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 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
18 ;; 02110-1301 USA
19
20 ;;; Code:
21
22 (define-module (system repl command)
23 #:use-module (system base syntax)
24 #:use-module (system base pmatch)
25 #:use-module (system base compile)
26 #:use-module (system repl common)
27 #:use-module (system repl debug)
28 #:use-module (system vm objcode)
29 #:use-module (system vm program)
30 #:use-module (system vm trap-state)
31 #:use-module (system vm vm)
32 #:use-module ((system vm frame) #:select (frame-return-values))
33 #:autoload (system base language) (lookup-language language-reader)
34 #:autoload (system vm trace) (call-with-trace)
35 #:use-module (ice-9 format)
36 #:use-module (ice-9 session)
37 #:use-module (ice-9 documentation)
38 #:use-module (ice-9 and-let-star)
39 #:use-module (ice-9 rdelim)
40 #:use-module (ice-9 control)
41 #:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
42 #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
43 #:use-module (statprof)
44 #:export (meta-command define-meta-command))
45
46 \f
47 ;;;
48 ;;; Meta command interface
49 ;;;
50
51 (define *command-table*
52 '((help (help h) (show) (apropos a) (describe d))
53 (module (module m) (import use) (load l) (reload re) (binding b) (in))
54 (language (language L))
55 (compile (compile c) (compile-file cc)
56 (expand exp) (optimize opt)
57 (disassemble x) (disassemble-file xx))
58 (profile (time t) (profile pr) (trace tr))
59 (debug (backtrace bt) (up) (down) (frame fr)
60 (procedure proc) (locals) (error-message error)
61 (break br bp) (break-at-source break-at bs)
62 (step s) (step-instruction si)
63 (next n) (next-instruction ni)
64 (finish)
65 (tracepoint tp)
66 (traps) (delete del) (disable) (enable)
67 (registers regs))
68 (inspect (inspect i) (pretty-print pp))
69 (system (gc) (statistics stat) (option o)
70 (quit q continue cont))))
71
72 (define *show-table*
73 '((show (warranty w) (copying c) (version v))))
74
75 (define (group-name g) (car g))
76 (define (group-commands g) (cdr g))
77
78 (define *command-infos* (make-hash-table))
79 (define (command-name c) (car c))
80 (define (command-abbrevs c) (cdr c))
81 (define (command-info c) (hashq-ref *command-infos* (command-name c)))
82 (define (command-procedure c) (command-info-procedure (command-info c)))
83 (define (command-doc c) (procedure-documentation (command-procedure c)))
84
85 (define (make-command-info proc arguments-reader)
86 (cons proc arguments-reader))
87
88 (define (command-info-procedure info)
89 (car info))
90
91 (define (command-info-arguments-reader info)
92 (cdr info))
93
94 (define (command-usage c)
95 (let ((doc (command-doc c)))
96 (substring doc 0 (string-index doc #\newline))))
97
98 (define (command-summary c)
99 (let* ((doc (command-doc c))
100 (start (1+ (string-index doc #\newline))))
101 (cond ((string-index doc #\newline start)
102 => (lambda (end) (substring doc start end)))
103 (else (substring doc start)))))
104
105 (define (lookup-group name)
106 (assq name *command-table*))
107
108 (define* (lookup-command key #:optional (table *command-table*))
109 (let loop ((groups table) (commands '()))
110 (cond ((and (null? groups) (null? commands)) #f)
111 ((null? commands)
112 (loop (cdr groups) (cdar groups)))
113 ((memq key (car commands)) (car commands))
114 (else (loop groups (cdr commands))))))
115
116 (define* (display-group group #:optional (abbrev? #t))
117 (format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?)
118 (for-each (lambda (c)
119 (display-summary (command-usage c)
120 (if abbrev? (command-abbrevs c) '())
121 (command-summary c)))
122 (group-commands group))
123 (newline))
124
125 (define (display-command command)
126 (display "Usage: ")
127 (display (command-doc command))
128 (newline))
129
130 (define (display-summary usage abbrevs summary)
131 (let* ((usage-len (string-length usage))
132 (abbrevs (if (pair? abbrevs)
133 (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs))
134 ""))
135 (abbrevs-len (string-length abbrevs)))
136 (format #t " ,~A~A~A - ~A\n"
137 usage
138 (cond
139 ((> abbrevs-len 32)
140 (error "abbrevs too long" abbrevs))
141 ((> (+ usage-len abbrevs-len) 32)
142 (format #f "~%~v_" (+ 2 (- 32 abbrevs-len))))
143 (else
144 (format #f "~v_" (- 32 abbrevs-len usage-len))))
145 abbrevs
146 summary)))
147
148 (define (read-command repl)
149 (catch #t
150 (lambda () (read))
151 (lambda (key . args)
152 (pmatch args
153 ((,subr ,msg ,args . ,rest)
154 (format #t "Throw to key `~a' while reading command:\n" key)
155 (display-error #f (current-output-port) subr msg args rest))
156 (else
157 (format #t "Throw to key `~a' with args `~s' while reading command.\n"
158 key args)))
159 (force-output)
160 *unspecified*)))
161
162 (define (read-command-arguments c repl)
163 ((command-info-arguments-reader (command-info c)) repl))
164
165 (define (meta-command repl)
166 (let ((command (read-command repl)))
167 (cond
168 ((eq? command *unspecified*)) ; read error, already signalled; pass.
169 ((not (symbol? command))
170 (format #t "Meta-command not a symbol: ~s~%" command))
171 ((lookup-command command)
172 => (lambda (c)
173 (and=> (read-command-arguments c repl)
174 (lambda (args) (apply (command-procedure c) repl args)))))
175 (else
176 (format #t "Unknown meta command: ~A~%" command)))))
177
178 (define (add-meta-command! name category proc argument-reader)
179 (hashq-set! *command-infos* name (make-command-info proc argument-reader))
180 (if category
181 (let ((entry (assq category *command-table*)))
182 (if entry
183 (set-cdr! entry (append (cdr entry) (list (list name))))
184 (set! *command-table*
185 (append *command-table*
186 (list (list category (list name)))))))))
187
188 (define-syntax define-meta-command
189 (syntax-rules ()
190 ((_ ((name category) repl (expression0 ...) . datums) docstring b0 b1 ...)
191 (add-meta-command!
192 'name
193 'category
194 (lambda* (repl expression0 ... . datums)
195 docstring
196 b0 b1 ...)
197 (lambda (repl)
198 (define (handle-read-error form-name key args)
199 (pmatch args
200 ((,subr ,msg ,args . ,rest)
201 (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
202 key form-name 'name)
203 (display-error #f (current-output-port) subr msg args rest))
204 (else
205 (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
206 key args form-name 'name)))
207 (abort))
208 (% (let* ((expression0
209 (catch #t
210 (lambda ()
211 (repl-reader
212 ""
213 (lambda* (#:optional (port (current-input-port)))
214 ((language-reader (repl-language repl))
215 port (current-module)))))
216 (lambda (k . args)
217 (handle-read-error 'expression0 k args))))
218 ...)
219 (append
220 (list expression0 ...)
221 (catch #t
222 (lambda ()
223 (let ((port (open-input-string (read-line))))
224 (let lp ((out '()))
225 (let ((x (read port)))
226 (if (eof-object? x)
227 (reverse out)
228 (lp (cons x out)))))))
229 (lambda (k . args)
230 (handle-read-error #f k args)))))
231 (lambda (k) #f))))) ; the abort handler
232
233 ((_ ((name category) repl . datums) docstring b0 b1 ...)
234 (define-meta-command ((name category) repl () . datums)
235 docstring b0 b1 ...))
236
237 ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
238 (define-meta-command ((name #f) repl (expression0 ...) . datums)
239 docstring b0 b1 ...))
240
241 ((_ (name repl . datums) docstring b0 b1 ...)
242 (define-meta-command ((name #f) repl () . datums)
243 docstring b0 b1 ...))))
244
245
246 \f
247 ;;;
248 ;;; Help commands
249 ;;;
250
251 (define-meta-command (help repl . args)
252 "help [all | GROUP | [-c] COMMAND]
253 Show help.
254
255 With one argument, tries to look up the argument as a group name, giving
256 help on that group if successful. Otherwise tries to look up the
257 argument as a command, giving help on the command.
258
259 If there is a command whose name is also a group name, use the ,help
260 -c COMMAND form to give help on the command instead of the group.
261
262 Without any argument, a list of help commands and command groups
263 are displayed."
264 (pmatch args
265 (()
266 (display-group (lookup-group 'help))
267 (display "Command Groups:\n\n")
268 (display-summary "help all" #f "List all commands")
269 (for-each (lambda (g)
270 (let* ((name (symbol->string (group-name g)))
271 (usage (string-append "help " name))
272 (header (string-append "List " name " commands")))
273 (display-summary usage #f header)))
274 (cdr *command-table*))
275 (newline)
276 (display
277 "Type `,help -c COMMAND' to show documentation of a particular command.")
278 (newline))
279 ((all)
280 (for-each display-group *command-table*))
281 ((,group) (guard (lookup-group group))
282 (display-group (lookup-group group)))
283 ((,command) (guard (lookup-command command))
284 (display-command (lookup-command command)))
285 ((-c ,command) (guard (lookup-command command))
286 (display-command (lookup-command command)))
287 ((,command)
288 (format #t "Unknown command or group: ~A~%" command))
289 ((-c ,command)
290 (format #t "Unknown command: ~A~%" command))
291 (else
292 (format #t "Bad arguments: ~A~%" args))))
293
294 (define-meta-command (show repl . args)
295 "show [TOPIC]
296 Gives information about Guile.
297
298 With one argument, tries to show a particular piece of information;
299
300 currently supported topics are `warranty' (or `w'), `copying' (or `c'),
301 and `version' (or `v').
302
303 Without any argument, a list of topics is displayed."
304 (pmatch args
305 (()
306 (display-group (car *show-table*) #f)
307 (newline))
308 ((,topic) (guard (lookup-command topic *show-table*))
309 ((command-procedure (lookup-command topic *show-table*)) repl))
310 ((,command)
311 (format #t "Unknown topic: ~A~%" command))
312 (else
313 (format #t "Bad arguments: ~A~%" args))))
314
315 ;;; `warranty', `copying' and `version' are "hidden" meta-commands, only
316 ;;; accessible via `show'. They have an entry in *command-infos* but not
317 ;;; in *command-table*.
318
319 (define-meta-command (warranty repl)
320 "show warranty
321 Details on the lack of warranty."
322 (display *warranty*)
323 (newline))
324
325 (define-meta-command (copying repl)
326 "show copying
327 Show the LGPLv3."
328 (display *copying*)
329 (newline))
330
331 (define-meta-command (version repl)
332 "show version
333 Version information."
334 (display *version*)
335 (newline))
336
337 (define-meta-command (apropos repl regexp)
338 "apropos REGEXP
339 Find bindings/modules/packages."
340 (apropos (->string regexp)))
341
342 (define-meta-command (describe repl (form))
343 "describe OBJ
344 Show description/documentation."
345 (display
346 (object-documentation
347 (let ((input (repl-parse repl form)))
348 (if (symbol? input)
349 (module-ref (current-module) input)
350 (repl-eval repl input)))))
351 (newline))
352
353 (define-meta-command (option repl . args)
354 "option [NAME] [EXP]
355 List/show/set options."
356 (pmatch args
357 (()
358 (for-each (lambda (spec)
359 (format #t " ~A~24t~A\n" (car spec) (cadr spec)))
360 (repl-options repl)))
361 ((,name)
362 (display (repl-option-ref repl name))
363 (newline))
364 ((,name ,exp)
365 ;; Would be nice to evaluate in the current language, but the REPL
366 ;; option parser doesn't permit that, currently.
367 (repl-option-set! repl name (eval exp (current-module))))))
368
369 (define-meta-command (quit repl)
370 "quit
371 Quit this session."
372 (throw 'quit))
373
374 \f
375 ;;;
376 ;;; Module commands
377 ;;;
378
379 (define-meta-command (module repl . args)
380 "module [MODULE]
381 Change modules / Show current module."
382 (pmatch args
383 (() (puts (module-name (current-module))))
384 ((,mod-name) (guard (list? mod-name))
385 (set-current-module (resolve-module mod-name)))
386 (,mod-name (set-current-module (resolve-module mod-name)))))
387
388 (define-meta-command (import repl . args)
389 "import [MODULE ...]
390 Import modules / List those imported."
391 (let ()
392 (define (use name)
393 (let ((mod (resolve-interface name)))
394 (if mod
395 (module-use! (current-module) mod)
396 (format #t "No such module: ~A~%" name))))
397 (if (null? args)
398 (for-each puts (map module-name (module-uses (current-module))))
399 (for-each use args))))
400
401 (define-meta-command (load repl file)
402 "load FILE
403 Load a file in the current module."
404 (load (->string file)))
405
406 (define-meta-command (reload repl . args)
407 "reload [MODULE]
408 Reload the given module, or the current module if none was given."
409 (pmatch args
410 (() (reload-module (current-module)))
411 ((,mod-name) (guard (list? mod-name))
412 (reload-module (resolve-module mod-name)))
413 (,mod-name (reload-module (resolve-module mod-name)))))
414
415 (define-meta-command (binding repl)
416 "binding
417 List current bindings."
418 (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
419 (current-module)))
420
421 (define-meta-command (in repl module command-or-expression . args)
422 "in MODULE COMMAND-OR-EXPRESSION
423 Evaluate an expression or command in the context of module."
424 (let ((m (resolve-module module #:ensure #f)))
425 (if m
426 (pmatch command-or-expression
427 (('unquote ,command) (guard (lookup-command command))
428 (save-module-excursion
429 (lambda ()
430 (set-current-module m)
431 (apply (command-procedure (lookup-command command)) repl args))))
432 (,expression
433 (guard (null? args))
434 (repl-print repl (eval expression m)))
435 (else
436 (format #t "Invalid arguments to `in': expected a single expression or a command.\n")))
437 (format #t "No such module: ~s\n" module))))
438
439 \f
440 ;;;
441 ;;; Language commands
442 ;;;
443
444 (define-meta-command (language repl name)
445 "language LANGUAGE
446 Change languages."
447 (let ((lang (lookup-language name))
448 (cur (repl-language repl)))
449 (format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n"
450 (language-title lang) (language-name cur))
451 (current-language lang)
452 (set! (repl-language repl) lang)))
453
454 \f
455 ;;;
456 ;;; Compile commands
457 ;;;
458
459 (define-meta-command (compile repl (form))
460 "compile EXP
461 Generate compiled code."
462 (let ((x (repl-compile repl (repl-parse repl form))))
463 (cond ((objcode? x) (guile:disassemble x))
464 (else (repl-print repl x)))))
465
466 (define-meta-command (compile-file repl file . opts)
467 "compile-file FILE
468 Compile a file."
469 (compile-file (->string file) #:opts opts))
470
471 (define-meta-command (expand repl (form))
472 "expand EXP
473 Expand any macros in a form."
474 (let ((x (repl-expand repl (repl-parse repl form))))
475 (run-hook before-print-hook x)
476 (pp x)))
477
478 (define-meta-command (optimize repl (form))
479 "optimize EXP
480 Run the optimizer on a piece of code and print the result."
481 (let ((x (repl-optimize repl (repl-parse repl form))))
482 (run-hook before-print-hook x)
483 (pp x)))
484
485 (define (guile:disassemble x)
486 ((@ (language assembly disassemble) disassemble) x))
487
488 (define-meta-command (disassemble repl (form))
489 "disassemble EXP
490 Disassemble a compiled procedure."
491 (let ((obj (repl-eval repl (repl-parse repl form))))
492 (if (or (program? obj) (objcode? obj))
493 (guile:disassemble obj)
494 (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
495 obj))))
496
497 (define-meta-command (disassemble-file repl file)
498 "disassemble-file FILE
499 Disassemble a file."
500 (guile:disassemble (load-thunk-from-file (->string file))))
501
502 \f
503 ;;;
504 ;;; Profile commands
505 ;;;
506
507 (define-meta-command (time repl (form))
508 "time EXP
509 Time execution."
510 (let* ((gc-start (gc-run-time))
511 (real-start (get-internal-real-time))
512 (run-start (get-internal-run-time))
513 (result (repl-eval repl (repl-parse repl form)))
514 (run-end (get-internal-run-time))
515 (real-end (get-internal-real-time))
516 (gc-end (gc-run-time)))
517 (define (diff start end)
518 (/ (- end start) 1.0 internal-time-units-per-second))
519 (repl-print repl result)
520 (format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n"
521 (diff real-start real-end)
522 (diff run-start run-end)
523 (diff gc-start gc-end))
524 result))
525
526 (define-meta-command (profile repl (form) . opts)
527 "profile EXP
528 Profile execution."
529 ;; FIXME opts
530 (apply statprof
531 (repl-prepare-eval-thunk repl (repl-parse repl form))
532 opts))
533
534 (define-meta-command (trace repl (form) . opts)
535 "trace EXP
536 Trace execution."
537 ;; FIXME: doc options, or somehow deal with them better
538 (apply call-with-trace
539 (repl-prepare-eval-thunk repl (repl-parse repl form))
540 (cons* #:width (terminal-width) opts)))
541
542 \f
543 ;;;
544 ;;; Debug commands
545 ;;;
546
547 (define-syntax define-stack-command
548 (lambda (x)
549 (syntax-case x ()
550 ((_ (name repl . args) docstring body body* ...)
551 #`(define-meta-command (name repl . args)
552 docstring
553 (let ((debug (repl-debug repl)))
554 (if debug
555 (letrec-syntax
556 ((#,(datum->syntax #'repl 'frames)
557 (identifier-syntax (debug-frames debug)))
558 (#,(datum->syntax #'repl 'message)
559 (identifier-syntax (debug-error-message debug)))
560 (#,(datum->syntax #'repl 'for-trap?)
561 (identifier-syntax (debug-for-trap? debug)))
562 (#,(datum->syntax #'repl 'index)
563 (identifier-syntax
564 (id (debug-index debug))
565 ((set! id exp) (set! (debug-index debug) exp))))
566 (#,(datum->syntax #'repl 'cur)
567 (identifier-syntax
568 (vector-ref #,(datum->syntax #'repl 'frames)
569 #,(datum->syntax #'repl 'index)))))
570 body body* ...)
571 (format #t "Nothing to debug.~%"))))))))
572
573 (define-stack-command (backtrace repl #:optional count
574 #:key (width (terminal-width)) full?)
575 "backtrace [COUNT] [#:width W] [#:full? F]
576 Print a backtrace.
577
578 Print a backtrace of all stack frames, or innermost COUNT frames.
579 If COUNT is negative, the last COUNT frames will be shown."
580 (print-frames frames
581 #:count count
582 #:width width
583 #:full? full?
584 #:for-trap? for-trap?))
585
586 (define-stack-command (up repl #:optional (count 1))
587 "up [COUNT]
588 Select a calling stack frame.
589
590 Select and print stack frames that called this one.
591 An argument says how many frames up to go."
592 (cond
593 ((or (not (integer? count)) (<= count 0))
594 (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
595 ((>= (+ count index) (vector-length frames))
596 (cond
597 ((= index (1- (vector-length frames)))
598 (format #t "Already at outermost frame.\n"))
599 (else
600 (set! index (1- (vector-length frames)))
601 (print-frame cur #:index index
602 #:next-source? (and (zero? index) for-trap?)))))
603 (else
604 (set! index (+ count index))
605 (print-frame cur #:index index
606 #:next-source? (and (zero? index) for-trap?)))))
607
608 (define-stack-command (down repl #:optional (count 1))
609 "down [COUNT]
610 Select a called stack frame.
611
612 Select and print stack frames called by this one.
613 An argument says how many frames down to go."
614 (cond
615 ((or (not (integer? count)) (<= count 0))
616 (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
617 ((< (- index count) 0)
618 (cond
619 ((zero? index)
620 (format #t "Already at innermost frame.\n"))
621 (else
622 (set! index 0)
623 (print-frame cur #:index index #:next-source? for-trap?))))
624 (else
625 (set! index (- index count))
626 (print-frame cur #:index index
627 #:next-source? (and (zero? index) for-trap?)))))
628
629 (define-stack-command (frame repl #:optional idx)
630 "frame [IDX]
631 Show a frame.
632
633 Show the selected frame.
634 With an argument, select a frame by index, then show it."
635 (cond
636 (idx
637 (cond
638 ((or (not (integer? idx)) (< idx 0))
639 (format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
640 ((< idx (vector-length frames))
641 (set! index idx)
642 (print-frame cur #:index index
643 #:next-source? (and (zero? index) for-trap?)))
644 (else
645 (format #t "No such frame.~%"))))
646 (else (print-frame cur #:index index
647 #:next-source? (and (zero? index) for-trap?)))))
648
649 (define-stack-command (procedure repl)
650 "procedure
651 Print the procedure for the selected frame."
652 (repl-print repl (frame-procedure cur)))
653
654 (define-stack-command (locals repl #:key (width (terminal-width)))
655 "locals
656 Show local variables.
657
658 Show locally-bound variables in the selected frame."
659 (print-locals cur #:width width))
660
661 (define-stack-command (error-message repl)
662 "error-message
663 Show error message.
664
665 Display the message associated with the error that started the current
666 debugging REPL."
667 (format #t "~a~%" (if (string? message) message "No error message")))
668
669 (define-meta-command (break repl (form))
670 "break PROCEDURE
671 Break on calls to PROCEDURE.
672
673 Starts a recursive prompt when PROCEDURE is called."
674 (let ((proc (repl-eval repl (repl-parse repl form))))
675 (if (not (procedure? proc))
676 (error "Not a procedure: ~a" proc)
677 (let ((idx (add-trap-at-procedure-call! proc)))
678 (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))))
679
680 (define-meta-command (break-at-source repl file line)
681 "break-at-source FILE LINE
682 Break when control reaches the given source location.
683
684 Starts a recursive prompt when control reaches line LINE of file FILE.
685 Note that the given source location must be inside a procedure."
686 (let ((file (if (symbol? file) (symbol->string file) file)))
687 (let ((idx (add-trap-at-source-location! file line)))
688 (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))
689
690 (define (repl-pop-continuation-resumer repl msg)
691 ;; Capture the dynamic environment with this prompt thing. The
692 ;; result is a procedure that takes a frame.
693 (% (call-with-values
694 (lambda ()
695 (abort
696 (lambda (k)
697 ;; Call frame->stack-vector before reinstating the
698 ;; continuation, so that we catch the %stacks fluid at
699 ;; the time of capture.
700 (lambda (frame)
701 (k frame
702 (frame->stack-vector
703 (frame-previous frame)))))))
704 (lambda (from stack)
705 (format #t "~a~%" msg)
706 (let ((vals (frame-return-values from)))
707 (if (null? vals)
708 (format #t "No return values.~%")
709 (begin
710 (format #t "Return values:~%")
711 (for-each (lambda (x) (repl-print repl x)) vals))))
712 ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
713 #:debug (make-debug stack 0 msg #t))))))
714
715 (define-stack-command (finish repl)
716 "finish
717 Run until the current frame finishes.
718
719 Resume execution, breaking when the current frame finishes."
720 (let ((handler (repl-pop-continuation-resumer
721 repl (format #f "Return from ~a" cur))))
722 (add-ephemeral-trap-at-frame-finish! cur handler)
723 (throw 'quit)))
724
725 (define (repl-next-resumer msg)
726 ;; Capture the dynamic environment with this prompt thing. The
727 ;; result is a procedure that takes a frame.
728 (% (let ((stack (abort
729 (lambda (k)
730 ;; Call frame->stack-vector before reinstating the
731 ;; continuation, so that we catch the %stacks fluid
732 ;; at the time of capture.
733 (lambda (frame)
734 (k (frame->stack-vector frame)))))))
735 (format #t "~a~%" msg)
736 ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
737 #:debug (make-debug stack 0 msg #t)))))
738
739 (define-stack-command (step repl)
740 "step
741 Step until control reaches a different source location.
742
743 Step until control reaches a different source location."
744 (let ((msg (format #f "Step into ~a" cur)))
745 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
746 #:into? #t #:instruction? #f)
747 (throw 'quit)))
748
749 (define-stack-command (step-instruction repl)
750 "step-instruction
751 Step until control reaches a different instruction.
752
753 Step until control reaches a different VM instruction."
754 (let ((msg (format #f "Step into ~a" cur)))
755 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
756 #:into? #t #:instruction? #t)
757 (throw 'quit)))
758
759 (define-stack-command (next repl)
760 "next
761 Step until control reaches a different source location in the current frame.
762
763 Step until control reaches a different source location in the current frame."
764 (let ((msg (format #f "Step into ~a" cur)))
765 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
766 #:into? #f #:instruction? #f)
767 (throw 'quit)))
768
769 (define-stack-command (next-instruction repl)
770 "next-instruction
771 Step until control reaches a different instruction in the current frame.
772
773 Step until control reaches a different VM instruction in the current frame."
774 (let ((msg (format #f "Step into ~a" cur)))
775 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
776 #:into? #f #:instruction? #t)
777 (throw 'quit)))
778
779 (define-meta-command (tracepoint repl (form))
780 "tracepoint PROCEDURE
781 Add a tracepoint to PROCEDURE.
782
783 A tracepoint will print out the procedure and its arguments, when it is
784 called, and its return value(s) when it returns."
785 (let ((proc (repl-eval repl (repl-parse repl form))))
786 (if (not (procedure? proc))
787 (error "Not a procedure: ~a" proc)
788 (let ((idx (add-trace-at-procedure-call! proc)))
789 (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))))
790
791 (define-meta-command (traps repl)
792 "traps
793 Show the set of currently attached traps.
794
795 Show the set of currently attached traps (breakpoints and tracepoints)."
796 (let ((traps (list-traps)))
797 (if (null? traps)
798 (format #t "No traps set.~%")
799 (for-each (lambda (idx)
800 (format #t " ~a: ~a~a~%"
801 idx (trap-name idx)
802 (if (trap-enabled? idx) "" " (disabled)")))
803 traps))))
804
805 (define-meta-command (delete repl idx)
806 "delete IDX
807 Delete a trap.
808
809 Delete a trap."
810 (if (not (integer? idx))
811 (error "expected a trap index (a non-negative integer)" idx)
812 (delete-trap! idx)))
813
814 (define-meta-command (disable repl idx)
815 "disable IDX
816 Disable a trap.
817
818 Disable a trap."
819 (if (not (integer? idx))
820 (error "expected a trap index (a non-negative integer)" idx)
821 (disable-trap! idx)))
822
823 (define-meta-command (enable repl idx)
824 "enable IDX
825 Enable a trap.
826
827 Enable a trap."
828 (if (not (integer? idx))
829 (error "expected a trap index (a non-negative integer)" idx)
830 (enable-trap! idx)))
831
832 (define-stack-command (registers repl)
833 "registers
834 Print registers.
835
836 Print the registers of the current frame."
837 (print-registers cur))
838
839 (define-meta-command (width repl #:optional x)
840 "width [X]
841 Set debug output width.
842
843 Set the number of screen columns in the output from `backtrace' and
844 `locals'."
845 (terminal-width x)
846 (format #t "Set screen width to ~a columns.~%" (terminal-width)))
847
848
849 \f
850 ;;;
851 ;;; Inspection commands
852 ;;;
853
854 (define-meta-command (inspect repl (form))
855 "inspect EXP
856 Inspect the result(s) of evaluating EXP."
857 (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
858 (lambda args
859 (for-each %inspect args))))
860
861 (define-meta-command (pretty-print repl (form))
862 "pretty-print EXP
863 Pretty-print the result(s) of evaluating EXP."
864 (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
865 (lambda args
866 (for-each
867 (lambda (x)
868 (run-hook before-print-hook x)
869 (pp x))
870 args))))
871
872 \f
873 ;;;
874 ;;; System commands
875 ;;;
876
877 (define-meta-command (gc repl)
878 "gc
879 Garbage collection."
880 (gc))
881
882 (define-meta-command (statistics repl)
883 "statistics
884 Display statistics."
885 (let ((this-tms (times))
886 (this-gcs (gc-stats))
887 (last-tms (repl-tm-stats repl))
888 (last-gcs (repl-gc-stats repl)))
889 ;; GC times
890 (let ((this-times (assq-ref this-gcs 'gc-times))
891 (last-times (assq-ref last-gcs 'gc-times)))
892 (display-diff-stat "GC times:" #t this-times last-times "times")
893 (newline))
894 ;; Memory size
895 (let ((this-heap (assq-ref this-gcs 'heap-size))
896 (this-free (assq-ref this-gcs 'heap-free-size)))
897 (display-stat-title "Memory size:" "current" "limit")
898 (display-stat "heap" #f (- this-heap this-free) this-heap "bytes")
899 (newline))
900 ;; Cells collected
901 (let ((this-alloc (assq-ref this-gcs 'heap-total-allocated))
902 (last-alloc (assq-ref last-gcs 'heap-total-allocated)))
903 (display-stat-title "Bytes allocated:" "diff" "total")
904 (display-diff-stat "allocated" #f this-alloc last-alloc "bytes")
905 (newline))
906 ;; GC time taken
907 (let ((this-total (assq-ref this-gcs 'gc-time-taken))
908 (last-total (assq-ref last-gcs 'gc-time-taken)))
909 (display-stat-title "GC time taken:" "diff" "total")
910 (display-time-stat "total" this-total last-total)
911 (newline))
912 ;; Process time spent
913 (let ((this-utime (tms:utime this-tms))
914 (last-utime (tms:utime last-tms))
915 (this-stime (tms:stime this-tms))
916 (last-stime (tms:stime last-tms))
917 (this-cutime (tms:cutime this-tms))
918 (last-cutime (tms:cutime last-tms))
919 (this-cstime (tms:cstime this-tms))
920 (last-cstime (tms:cstime last-tms)))
921 (display-stat-title "Process time spent:" "diff" "total")
922 (display-time-stat "user" this-utime last-utime)
923 (display-time-stat "system" this-stime last-stime)
924 (display-time-stat "child user" this-cutime last-cutime)
925 (display-time-stat "child system" this-cstime last-cstime)
926 (newline))
927 ;; Save statistics
928 ;; Save statistics
929 (set! (repl-tm-stats repl) this-tms)
930 (set! (repl-gc-stats repl) this-gcs)))
931
932 (define (display-stat title flag field1 field2 unit)
933 (let ((fmt (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
934 (format #t fmt title field1 field2 unit)))
935
936 (define (display-stat-title title field1 field2)
937 (display-stat title #t field1 field2 ""))
938
939 (define (display-diff-stat title flag this last unit)
940 (display-stat title flag (- this last) this unit))
941
942 (define (display-time-stat title this last)
943 (define (conv num)
944 (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second))))
945 (display-stat title #f (conv (- this last)) (conv this) "s"))
946
947 (define (display-mips-stat title this-time this-clock last-time last-clock)
948 (define (mips time clock)
949 (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0))))
950 (display-stat title #f
951 (mips (- this-time last-time) (- this-clock last-clock))
952 (mips this-time this-clock) "mips"))