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