Commit | Line | Data |
---|---|---|
ea9c5dab | 1 | ;;; Repl commands |
17e90c5e KN |
2 | |
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (system repl command) | |
1a1a10d3 AW |
23 | #:use-syntax (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 vm objcode) | |
28 | #:use-module (system vm program) | |
29 | #:use-module (system vm vm) | |
30 | #:autoload (system base language) (lookup-language) | |
31 | #:autoload (system il glil) (pprint-glil) | |
32 | #:autoload (system vm disasm) (disassemble-program disassemble-objcode) | |
33 | #:autoload (system vm debug) (vm-debugger vm-backtrace) | |
34 | #:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off) | |
35 | #:autoload (system vm profile) (vm-profile) | |
36 | #:use-module (ice-9 format) | |
37 | #:use-module (ice-9 session) | |
38 | #:use-module (ice-9 documentation) | |
39 | #:use-module (ice-9 and-let-star) | |
40 | #:export (meta-command)) | |
4bfb26f5 KN |
41 | |
42 | \f | |
43 | ;;; | |
8f5cfc81 | 44 | ;;; Meta command interface |
4bfb26f5 KN |
45 | ;;; |
46 | ||
47 | (define *command-table* | |
48 | '((help (help h) (apropos a) (describe d) (option o) (quit q)) | |
db917b41 | 49 | (module (module m) (import i) (load l) (binding b)) |
4bfb26f5 KN |
50 | (language (language L)) |
51 | (compile (compile c) (compile-file cc) | |
52 | (disassemble x) (disassemble-file xx)) | |
53 | (profile (time t) (profile pr)) | |
ac99cb0c | 54 | (debug (backtrace bt) (debugger db) (trace tr) (step st)) |
f21dfea6 | 55 | (system (gc) (statistics stat)))) |
4bfb26f5 KN |
56 | |
57 | (define (group-name g) (car g)) | |
58 | (define (group-commands g) (cdr g)) | |
59 | ||
659b4611 AW |
60 | ;; Hack, until core can be extended. |
61 | (define procedure-documentation | |
62 | (let ((old-definition procedure-documentation)) | |
63 | (lambda (p) | |
64 | (if (program? p) | |
65 | (program-documentation p) | |
07e56b27 | 66 | (old-definition p))))) |
659b4611 | 67 | |
4bfb26f5 KN |
68 | (define *command-module* (current-module)) |
69 | (define (command-name c) (car c)) | |
70 | (define (command-abbrev c) (if (null? (cdr c)) #f (cadr c))) | |
71 | (define (command-procedure c) (module-ref *command-module* (command-name c))) | |
72 | (define (command-doc c) (procedure-documentation (command-procedure c))) | |
73 | ||
74 | (define (command-usage c) | |
75 | (let ((doc (command-doc c))) | |
76 | (substring doc 0 (string-index doc #\newline)))) | |
77 | ||
78 | (define (command-summary c) | |
79 | (let* ((doc (command-doc c)) | |
80 | (start (1+ (string-index doc #\newline)))) | |
81 | (cond ((string-index doc #\newline start) | |
82 | => (lambda (end) (substring doc start end))) | |
83 | (else (substring doc start))))) | |
84 | ||
85 | (define (lookup-group name) | |
86 | (assq name *command-table*)) | |
87 | ||
88 | (define (lookup-command key) | |
89 | (let loop ((groups *command-table*) (commands '())) | |
90 | (cond ((and (null? groups) (null? commands)) #f) | |
91 | ((null? commands) | |
92 | (loop (cdr groups) (cdar groups))) | |
93 | ((memq key (car commands)) (car commands)) | |
94 | (else (loop groups (cdr commands)))))) | |
95 | ||
96 | (define (display-group group . opts) | |
97 | (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group)) | |
98 | (for-each (lambda (c) | |
99 | (display-summary (command-usage c) | |
100 | (command-abbrev c) | |
101 | (command-summary c))) | |
102 | (group-commands group)) | |
103 | (newline)) | |
104 | ||
105 | (define (display-command command) | |
106 | (display "Usage: ") | |
107 | (display (command-doc command)) | |
108 | (newline)) | |
109 | ||
110 | (define (display-summary usage abbrev summary) | |
111 | (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) ""))) | |
112 | (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary))) | |
113 | ||
b79f118f | 114 | (define (meta-command repl line) |
4bfb26f5 KN |
115 | (let ((input (call-with-input-string (string-append "(" line ")") read))) |
116 | (if (not (null? input)) | |
117 | (do ((key (car input)) | |
118 | (args (cdr input) (cdr args)) | |
119 | (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts))) | |
120 | ((or (null? args) | |
121 | (not (symbol? (car args))) | |
122 | (not (eq? (string-ref (symbol->string (car args)) 0) #\-))) | |
123 | (let ((c (lookup-command key))) | |
124 | (if c | |
1a1a10d3 | 125 | (cond ((memq #:h opts) (display-command c)) |
4bfb26f5 | 126 | (else (apply (command-procedure c) |
f21dfea6 | 127 | repl (append! args (reverse! opts))))) |
4bfb26f5 KN |
128 | (user-error "Unknown meta command: ~A" key)))))))) |
129 | ||
130 | \f | |
131 | ;;; | |
132 | ;;; Help commands | |
133 | ;;; | |
134 | ||
135 | (define (help repl . args) | |
136 | "help [GROUP] | |
8f5cfc81 KN |
137 | List available meta commands. |
138 | A command group name can be given as an optional argument. | |
139 | Without any argument, a list of help commands and command groups | |
140 | are displayed, as you have already seen ;)" | |
e429de1e | 141 | (pmatch args |
4bfb26f5 KN |
142 | (() |
143 | (display-group (lookup-group 'help)) | |
144 | (display "Command Groups:\n\n") | |
145 | (display-summary "help all" #f "List all commands") | |
146 | (for-each (lambda (g) | |
147 | (let* ((name (symbol->string (group-name g))) | |
148 | (usage (string-append "help " name)) | |
149 | (header (string-append "List " name " commands"))) | |
150 | (display-summary usage #f header))) | |
151 | (cdr *command-table*)) | |
152 | (newline) | |
8f5cfc81 | 153 | (display "Type `,COMMAND -h' to show documentation of each command.") |
4bfb26f5 | 154 | (newline)) |
e429de1e | 155 | ((all) |
4bfb26f5 | 156 | (for-each display-group *command-table*)) |
e429de1e | 157 | ((,group) (guard (lookup-group group)) |
4bfb26f5 | 158 | (display-group (lookup-group group))) |
8f5cfc81 KN |
159 | (else |
160 | (user-error "Unknown command group: ~A" (car args))))) | |
4bfb26f5 | 161 | |
8f5cfc81 | 162 | (define guile:apropos apropos) |
4bfb26f5 | 163 | (define (apropos repl regexp) |
8f5cfc81 | 164 | "apropos REGEXP |
4bfb26f5 | 165 | Find bindings/modules/packages." |
8f5cfc81 | 166 | (guile:apropos (->string regexp))) |
4bfb26f5 KN |
167 | |
168 | (define (describe repl obj) | |
169 | "describe OBJ | |
170 | Show description/documentation." | |
8f5cfc81 KN |
171 | (display (object-documentation (repl-eval repl obj))) |
172 | (newline)) | |
4bfb26f5 KN |
173 | |
174 | (define (option repl . args) | |
8f5cfc81 | 175 | "option [KEY VALUE] |
4bfb26f5 | 176 | List/show/set options." |
e429de1e | 177 | (pmatch args |
f21dfea6 KN |
178 | (() |
179 | (for-each (lambda (key+val) | |
180 | (format #t "~A\t~A\n" (car key+val) (cdr key+val))) | |
ce0925e1 | 181 | (repl-options repl))) |
e429de1e | 182 | ((,key) |
f21dfea6 KN |
183 | (display (repl-option-ref repl key)) |
184 | (newline)) | |
e429de1e | 185 | ((,key ,val) |
f21dfea6 KN |
186 | (repl-option-set! repl key val) |
187 | (case key | |
188 | ((trace) | |
db917b41 | 189 | (let ((vm (repl-vm repl))) |
ce0925e1 AW |
190 | (if val |
191 | (apply vm-trace-on vm val) | |
192 | (vm-trace-off vm)))))))) | |
4bfb26f5 KN |
193 | |
194 | (define (quit repl) | |
195 | "quit | |
196 | Quit this session." | |
197 | (throw 'quit)) | |
198 | ||
199 | \f | |
200 | ;;; | |
201 | ;;; Module commands | |
202 | ;;; | |
203 | ||
204 | (define (module repl . args) | |
205 | "module [MODULE] | |
206 | Change modules / Show current module." | |
e429de1e | 207 | (pmatch args |
db917b41 | 208 | (() (puts (module-name (current-module)))) |
482015af AW |
209 | ((,mod-name) (guard (list? mod-name)) |
210 | (set-current-module (resolve-module mod-name))) | |
211 | (,mod-name (set-current-module (resolve-module mod-name))))) | |
4bfb26f5 KN |
212 | |
213 | (define (import repl . args) | |
214 | "import [MODULE ...] | |
215 | Import modules / List those imported." | |
9246a486 AW |
216 | (let () |
217 | (define (use name) | |
218 | (let ((mod (resolve-interface name))) | |
219 | (if mod | |
220 | (module-use! (current-module) mod) | |
221 | (user-error "No such module: ~A" name)))) | |
222 | (if (null? args) | |
223 | (for-each puts (map module-name (module-uses (current-module)))) | |
224 | (for-each use args)))) | |
4bfb26f5 KN |
225 | |
226 | (define (load repl file . opts) | |
8f5cfc81 KN |
227 | "load FILE |
228 | Load a file in the current module. | |
229 | ||
f21dfea6 | 230 | -f Load source file (see `compile')" |
8f5cfc81 | 231 | (let* ((file (->string file)) |
1a1a10d3 | 232 | (objcode (if (memq #:f opts) |
8f5cfc81 KN |
233 | (apply load-source-file file opts) |
234 | (apply load-file file opts)))) | |
db917b41 | 235 | (vm-load (repl-vm repl) objcode))) |
4bfb26f5 KN |
236 | |
237 | (define (binding repl . opts) | |
8f5cfc81 | 238 | "binding |
4bfb26f5 | 239 | List current bindings." |
db917b41 AW |
240 | (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v)) |
241 | (current-module))) | |
4bfb26f5 KN |
242 | |
243 | \f | |
244 | ;;; | |
245 | ;;; Language commands | |
246 | ;;; | |
247 | ||
248 | (define (language repl name) | |
249 | "language LANGUAGE | |
250 | Change languages." | |
db917b41 | 251 | (set! (repl-language repl) (lookup-language name)) |
4bfb26f5 KN |
252 | (repl-welcome repl)) |
253 | ||
254 | \f | |
255 | ;;; | |
256 | ;;; Compile commands | |
257 | ;;; | |
258 | ||
259 | (define (compile repl form . opts) | |
8f5cfc81 | 260 | "compile FORM |
4bfb26f5 KN |
261 | Generate compiled code. |
262 | ||
263 | -e Stop after expanding syntax/macro | |
264 | -t Stop after translating into GHIL | |
265 | -c Stop after generating GLIL | |
266 | ||
267 | -O Enable optimization | |
268 | -D Add debug information" | |
269 | (let ((x (apply repl-compile repl form opts))) | |
1a1a10d3 AW |
270 | (cond ((or (memq #:e opts) (memq #:t opts)) (puts x)) |
271 | ((memq #:c opts) (pprint-glil x)) | |
8f5cfc81 | 272 | (else (disassemble-objcode x))))) |
4bfb26f5 | 273 | |
f21dfea6 | 274 | (define guile:compile-file compile-file) |
4bfb26f5 | 275 | (define (compile-file repl file . opts) |
8f5cfc81 | 276 | "compile-file FILE |
4bfb26f5 | 277 | Compile a file." |
f21dfea6 | 278 | (apply guile:compile-file (->string file) opts)) |
4bfb26f5 KN |
279 | |
280 | (define (disassemble repl prog) | |
281 | "disassemble PROGRAM | |
282 | Disassemble a program." | |
283 | (disassemble-program (repl-eval repl prog))) | |
284 | ||
285 | (define (disassemble-file repl file) | |
286 | "disassemble-file FILE | |
287 | Disassemble a file." | |
8f5cfc81 | 288 | (disassemble-objcode (load-objcode (->string file)))) |
4bfb26f5 KN |
289 | |
290 | \f | |
291 | ;;; | |
292 | ;;; Profile commands | |
293 | ;;; | |
294 | ||
8f5cfc81 KN |
295 | (define (time repl form) |
296 | "time FORM | |
297 | Time execution." | |
db917b41 | 298 | (let* ((vms-start (vm-stats (repl-vm repl))) |
8f5cfc81 KN |
299 | (gc-start (gc-run-time)) |
300 | (tms-start (times)) | |
301 | (result (repl-eval repl form)) | |
302 | (tms-end (times)) | |
303 | (gc-end (gc-run-time)) | |
db917b41 | 304 | (vms-end (vm-stats (repl-vm repl)))) |
8f5cfc81 | 305 | (define (get proc start end) |
17d1b4bf | 306 | (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second))) |
8f5cfc81 KN |
307 | (repl-print repl result) |
308 | (display "clock utime stime cutime cstime gctime\n") | |
309 | (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" | |
310 | (get tms:clock tms-start tms-end) | |
311 | (get tms:utime tms-start tms-end) | |
312 | (get tms:stime tms-start tms-end) | |
313 | (get tms:cutime tms-start tms-end) | |
314 | (get tms:cstime tms-start tms-end) | |
315 | (get identity gc-start gc-end)) | |
316 | result)) | |
317 | ||
4bfb26f5 KN |
318 | (define (profile repl form . opts) |
319 | "profile FORM | |
320 | Profile execution." | |
ce0925e1 | 321 | (apply vm-profile |
db917b41 | 322 | (repl-vm repl) |
ce0925e1 AW |
323 | (repl-compile repl form) |
324 | opts)) | |
4bfb26f5 KN |
325 | |
326 | \f | |
327 | ;;; | |
328 | ;;; Debug commands | |
329 | ;;; | |
330 | ||
4bfb26f5 KN |
331 | (define (backtrace repl) |
332 | "backtrace | |
ac99cb0c | 333 | Display backtrace." |
db917b41 | 334 | (vm-backtrace (repl-vm repl))) |
4bfb26f5 KN |
335 | |
336 | (define (debugger repl) | |
337 | "debugger | |
338 | Start debugger." | |
db917b41 | 339 | (vm-debugger (repl-vm repl))) |
4bfb26f5 KN |
340 | |
341 | (define (trace repl form . opts) | |
8f5cfc81 KN |
342 | "trace FORM |
343 | Trace execution. | |
344 | ||
345 | -s Display stack | |
346 | -l Display local variables | |
347 | -e Display external variables | |
348 | -b Bytecode level trace" | |
db917b41 | 349 | (apply vm-trace (repl-vm repl) (repl-compile repl form) opts)) |
4bfb26f5 KN |
350 | |
351 | (define (step repl) | |
352 | "step FORM | |
353 | Step execution." | |
354 | (display "Not implemented yet\n")) | |
355 | ||
356 | \f | |
357 | ;;; | |
358 | ;;; System commands | |
359 | ;;; | |
360 | ||
8f5cfc81 | 361 | (define guile:gc gc) |
4bfb26f5 KN |
362 | (define (gc repl) |
363 | "gc | |
364 | Garbage collection." | |
8f5cfc81 | 365 | (guile:gc)) |
4bfb26f5 KN |
366 | |
367 | (define (statistics repl) | |
368 | "statistics | |
369 | Display statistics." | |
370 | (let ((this-tms (times)) | |
db917b41 | 371 | (this-vms (vm-stats (repl-vm repl))) |
4bfb26f5 | 372 | (this-gcs (gc-stats)) |
ce0925e1 AW |
373 | (last-tms (repl-tm-stats repl)) |
374 | (last-vms (repl-vm-stats repl)) | |
375 | (last-gcs (repl-gc-stats repl))) | |
4bfb26f5 KN |
376 | ;; GC times |
377 | (let ((this-times (assq-ref this-gcs 'gc-times)) | |
378 | (last-times (assq-ref last-gcs 'gc-times))) | |
379 | (display-diff-stat "GC times:" #t this-times last-times "times") | |
380 | (newline)) | |
381 | ;; Memory size | |
382 | (let ((this-cells (assq-ref this-gcs 'cells-allocated)) | |
383 | (this-heap (assq-ref this-gcs 'cell-heap-size)) | |
384 | (this-bytes (assq-ref this-gcs 'bytes-malloced)) | |
385 | (this-malloc (assq-ref this-gcs 'gc-malloc-threshold))) | |
386 | (display-stat-title "Memory size:" "current" "limit") | |
387 | (display-stat "heap" #f this-cells this-heap "cells") | |
388 | (display-stat "malloc" #f this-bytes this-malloc "bytes") | |
389 | (newline)) | |
390 | ;; Cells collected | |
391 | (let ((this-marked (assq-ref this-gcs 'cells-marked)) | |
392 | (last-marked (assq-ref last-gcs 'cells-marked)) | |
393 | (this-swept (assq-ref this-gcs 'cells-swept)) | |
394 | (last-swept (assq-ref last-gcs 'cells-swept))) | |
395 | (display-stat-title "Cells collected:" "diff" "total") | |
396 | (display-diff-stat "marked" #f this-marked last-marked "cells") | |
397 | (display-diff-stat "swept" #f this-swept last-swept "cells") | |
398 | (newline)) | |
399 | ;; GC time taken | |
400 | (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken)) | |
401 | (last-mark (assq-ref last-gcs 'gc-mark-time-taken)) | |
4bfb26f5 KN |
402 | (this-total (assq-ref this-gcs 'gc-time-taken)) |
403 | (last-total (assq-ref last-gcs 'gc-time-taken))) | |
404 | (display-stat-title "GC time taken:" "diff" "total") | |
405 | (display-time-stat "mark" this-mark last-mark) | |
4bfb26f5 KN |
406 | (display-time-stat "total" this-total last-total) |
407 | (newline)) | |
408 | ;; Process time spent | |
409 | (let ((this-utime (tms:utime this-tms)) | |
410 | (last-utime (tms:utime last-tms)) | |
411 | (this-stime (tms:stime this-tms)) | |
412 | (last-stime (tms:stime last-tms)) | |
413 | (this-cutime (tms:cutime this-tms)) | |
414 | (last-cutime (tms:cutime last-tms)) | |
415 | (this-cstime (tms:cstime this-tms)) | |
416 | (last-cstime (tms:cstime last-tms))) | |
417 | (display-stat-title "Process time spent:" "diff" "total") | |
418 | (display-time-stat "user" this-utime last-utime) | |
419 | (display-time-stat "system" this-stime last-stime) | |
420 | (display-time-stat "child user" this-cutime last-cutime) | |
421 | (display-time-stat "child system" this-cstime last-cstime) | |
422 | (newline)) | |
423 | ;; VM statistics | |
424 | (let ((this-time (vms:time this-vms)) | |
425 | (last-time (vms:time last-vms)) | |
426 | (this-clock (vms:clock this-vms)) | |
427 | (last-clock (vms:clock last-vms))) | |
428 | (display-stat-title "VM statistics:" "diff" "total") | |
429 | (display-time-stat "time spent" this-time last-time) | |
430 | (display-diff-stat "bogoclock" #f this-clock last-clock "clock") | |
431 | (display-mips-stat "bogomips" this-time this-clock last-time last-clock) | |
432 | (newline)) | |
433 | ;; Save statistics | |
434 | ;; Save statistics | |
ce0925e1 AW |
435 | (set! (repl-tm-stats repl) this-tms) |
436 | (set! (repl-vm-stats repl) this-vms) | |
437 | (set! (repl-gc-stats repl) this-gcs))) | |
cb4cca12 KN |
438 | |
439 | (define (display-stat title flag field1 field2 unit) | |
440 | (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@")))) | |
441 | (format #t str title field1 field2 unit))) | |
442 | ||
443 | (define (display-stat-title title field1 field2) | |
444 | (display-stat title #t field1 field2 "")) | |
445 | ||
446 | (define (display-diff-stat title flag this last unit) | |
447 | (display-stat title flag (- this last) this unit)) | |
448 | ||
449 | (define (display-time-stat title this last) | |
450 | (define (conv num) | |
b9d8ed05 | 451 | (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second)))) |
cb4cca12 KN |
452 | (display-stat title #f (conv (- this last)) (conv this) "s")) |
453 | ||
454 | (define (display-mips-stat title this-time this-clock last-time last-clock) | |
455 | (define (mips time clock) | |
b9d8ed05 | 456 | (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0)))) |
cb4cca12 KN |
457 | (display-stat title #f |
458 | (mips (- this-time last-time) (- this-clock last-clock)) | |
459 | (mips this-time this-clock) "mips")) |