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