3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
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)
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.
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.
22 (define-module (system repl command)
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 core)
28 :autoload (system base language) (lookup-language)
29 :autoload (system il glil) (pprint-glil)
30 :autoload (system vm disasm) (disassemble-program disassemble-objcode)
31 :autoload (system vm debug) (vm-debugger vm-backtrace)
32 :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
33 :autoload (system vm profile) (vm-profile)
34 :use-module (ice-9 format)
35 :use-module (ice-9 session)
36 :use-module (ice-9 documentation)
37 :use-module (ice-9 and-let-star)
38 :export (meta-command))
42 ;;; Meta command interface
45 (define *command-table*
46 '((help (help h) (apropos a) (describe d) (option o) (quit q))
47 (module (module m) (import i) (load l) (binding b))
48 (language (language L))
49 (compile (compile c) (compile-file cc)
50 (disassemble x) (disassemble-file xx))
51 (profile (time t) (profile pr))
52 (debug (backtrace bt) (debugger db) (trace tr) (step st))
53 (system (gc) (statistics stat))))
55 (define (group-name g) (car g))
56 (define (group-commands g) (cdr g))
58 (define *command-module* (current-module))
59 (define (command-name c) (car c))
60 (define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
61 (define (command-procedure c) (module-ref *command-module* (command-name c)))
62 (define (command-doc c) (procedure-documentation (command-procedure c)))
64 (define (command-usage c)
65 (let ((doc (command-doc c)))
66 (substring doc 0 (string-index doc #\newline))))
68 (define (command-summary c)
69 (let* ((doc (command-doc c))
70 (start (1+ (string-index doc #\newline))))
71 (cond ((string-index doc #\newline start)
72 => (lambda (end) (substring doc start end)))
73 (else (substring doc start)))))
75 (define (lookup-group name)
76 (assq name *command-table*))
78 (define (lookup-command key)
79 (let loop ((groups *command-table*) (commands '()))
80 (cond ((and (null? groups) (null? commands)) #f)
82 (loop (cdr groups) (cdar groups)))
83 ((memq key (car commands)) (car commands))
84 (else (loop groups (cdr commands))))))
86 (define (display-group group . opts)
87 (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
89 (display-summary (command-usage c)
92 (group-commands group))
95 (define (display-command command)
97 (display (command-doc command))
100 (define (display-summary usage abbrev summary)
101 (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
102 (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
104 (define (meta-command repl line)
105 (let ((input (call-with-input-string (string-append "(" line ")") read)))
106 (if (not (null? input))
107 (do ((key (car input))
108 (args (cdr input) (cdr args))
109 (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
111 (not (symbol? (car args)))
112 (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
113 (let ((c (lookup-command key)))
115 (cond ((memq :h opts) (display-command c))
116 (else (apply (command-procedure c)
117 repl (append! args (reverse! opts)))))
118 (user-error "Unknown meta command: ~A" key))))))))
125 (define (help repl . args)
127 List available meta commands.
128 A command group name can be given as an optional argument.
129 Without any argument, a list of help commands and command groups
130 are displayed, as you have already seen ;)"
133 (display-group (lookup-group 'help))
134 (display "Command Groups:\n\n")
135 (display-summary "help all" #f "List all commands")
136 (for-each (lambda (g)
137 (let* ((name (symbol->string (group-name g)))
138 (usage (string-append "help " name))
139 (header (string-append "List " name " commands")))
140 (display-summary usage #f header)))
141 (cdr *command-table*))
143 (display "Type `,COMMAND -h' to show documentation of each command.")
146 (for-each display-group *command-table*))
147 ((,group) (guard (lookup-group group))
148 (display-group (lookup-group group)))
150 (user-error "Unknown command group: ~A" (car args)))))
152 (define guile:apropos apropos)
153 (define (apropos repl regexp)
155 Find bindings/modules/packages."
156 (guile:apropos (->string regexp)))
158 (define (describe repl obj)
160 Show description/documentation."
161 (display (object-documentation (repl-eval repl obj)))
164 (define (option repl . args)
166 List/show/set options."
169 (for-each (lambda (key+val)
170 (format #t "~A\t~A\n" (car key+val) (cdr key+val)))
171 (repl-options repl)))
173 (display (repl-option-ref repl key))
176 (repl-option-set! repl key val)
179 (let ((vm (repl-vm repl)))
181 (apply vm-trace-on vm val)
182 (vm-trace-off vm))))))))
194 (define (module repl . args)
196 Change modules / Show current module."
198 (() (puts (module-name (current-module))))
199 ((,mod-name) (set-current-module (resolve-module mod-name)))))
201 (define (import repl . args)
203 Import modules / List those imported."
206 (let ((mod (resolve-interface name)))
208 (module-use! (current-module) mod)
209 (user-error "No such module: ~A" name))))
211 (for-each puts (map module-name (module-uses (current-module))))
212 (for-each use args))))
214 (define (load repl file . opts)
216 Load a file in the current module.
218 -f Load source file (see `compile')"
219 (let* ((file (->string file))
220 (objcode (if (memq :f opts)
221 (apply load-source-file file opts)
222 (apply load-file file opts))))
223 (vm-load (repl-vm repl) objcode)))
225 (define (binding repl . opts)
227 List current bindings."
228 (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
233 ;;; Language commands
236 (define (language repl name)
239 (set! (repl-language repl) (lookup-language name))
247 (define (compile repl form . opts)
249 Generate compiled code.
251 -e Stop after expanding syntax/macro
252 -t Stop after translating into GHIL
253 -c Stop after generating GLIL
255 -O Enable optimization
256 -D Add debug information"
257 (let ((x (apply repl-compile repl form opts)))
258 (cond ((or (memq :e opts) (memq :t opts)) (puts x))
259 ((memq :c opts) (pprint-glil x))
260 (else (disassemble-objcode x)))))
262 (define guile:compile-file compile-file)
263 (define (compile-file repl file . opts)
266 (apply guile:compile-file (->string file) opts))
268 (define (disassemble repl prog)
270 Disassemble a program."
271 (disassemble-program (repl-eval repl prog)))
273 (define (disassemble-file repl file)
274 "disassemble-file FILE
276 (disassemble-objcode (load-objcode (->string file))))
283 (define (time repl form)
286 (let* ((vms-start (vm-stats (repl-vm repl)))
287 (gc-start (gc-run-time))
289 (result (repl-eval repl form))
291 (gc-end (gc-run-time))
292 (vms-end (vm-stats (repl-vm repl))))
293 (define (get proc start end)
294 (/ (- (proc end) (proc start)) internal-time-units-per-second))
295 (repl-print repl result)
296 (display "clock utime stime cutime cstime gctime\n")
297 (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
298 (get tms:clock tms-start tms-end)
299 (get tms:utime tms-start tms-end)
300 (get tms:stime tms-start tms-end)
301 (get tms:cutime tms-start tms-end)
302 (get tms:cstime tms-start tms-end)
303 (get identity gc-start gc-end))
306 (define (profile repl form . opts)
311 (repl-compile repl form)
319 (define (backtrace repl)
322 (vm-backtrace (repl-vm repl)))
324 (define (debugger repl)
327 (vm-debugger (repl-vm repl)))
329 (define (trace repl form . opts)
334 -l Display local variables
335 -e Display external variables
336 -b Bytecode level trace"
337 (apply vm-trace (repl-vm repl) (repl-compile repl form) opts))
342 (display "Not implemented yet\n"))
355 (define (statistics repl)
358 (let ((this-tms (times))
359 (this-vms (vm-stats (repl-vm repl)))
360 (this-gcs (gc-stats))
361 (last-tms (repl-tm-stats repl))
362 (last-vms (repl-vm-stats repl))
363 (last-gcs (repl-gc-stats repl)))
365 (let ((this-times (assq-ref this-gcs 'gc-times))
366 (last-times (assq-ref last-gcs 'gc-times)))
367 (display-diff-stat "GC times:" #t this-times last-times "times")
370 (let ((this-cells (assq-ref this-gcs 'cells-allocated))
371 (this-heap (assq-ref this-gcs 'cell-heap-size))
372 (this-bytes (assq-ref this-gcs 'bytes-malloced))
373 (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
374 (display-stat-title "Memory size:" "current" "limit")
375 (display-stat "heap" #f this-cells this-heap "cells")
376 (display-stat "malloc" #f this-bytes this-malloc "bytes")
379 (let ((this-marked (assq-ref this-gcs 'cells-marked))
380 (last-marked (assq-ref last-gcs 'cells-marked))
381 (this-swept (assq-ref this-gcs 'cells-swept))
382 (last-swept (assq-ref last-gcs 'cells-swept)))
383 (display-stat-title "Cells collected:" "diff" "total")
384 (display-diff-stat "marked" #f this-marked last-marked "cells")
385 (display-diff-stat "swept" #f this-swept last-swept "cells")
388 (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken))
389 (last-mark (assq-ref last-gcs 'gc-mark-time-taken))
390 (this-sweep (assq-ref this-gcs 'gc-sweep-time-taken))
391 (last-sweep (assq-ref last-gcs 'gc-sweep-time-taken))
392 (this-total (assq-ref this-gcs 'gc-time-taken))
393 (last-total (assq-ref last-gcs 'gc-time-taken)))
394 (display-stat-title "GC time taken:" "diff" "total")
395 (display-time-stat "mark" this-mark last-mark)
396 (display-time-stat "sweep" this-sweep last-sweep)
397 (display-time-stat "total" this-total last-total)
399 ;; Process time spent
400 (let ((this-utime (tms:utime this-tms))
401 (last-utime (tms:utime last-tms))
402 (this-stime (tms:stime this-tms))
403 (last-stime (tms:stime last-tms))
404 (this-cutime (tms:cutime this-tms))
405 (last-cutime (tms:cutime last-tms))
406 (this-cstime (tms:cstime this-tms))
407 (last-cstime (tms:cstime last-tms)))
408 (display-stat-title "Process time spent:" "diff" "total")
409 (display-time-stat "user" this-utime last-utime)
410 (display-time-stat "system" this-stime last-stime)
411 (display-time-stat "child user" this-cutime last-cutime)
412 (display-time-stat "child system" this-cstime last-cstime)
415 (let ((this-time (vms:time this-vms))
416 (last-time (vms:time last-vms))
417 (this-clock (vms:clock this-vms))
418 (last-clock (vms:clock last-vms)))
419 (display-stat-title "VM statistics:" "diff" "total")
420 (display-time-stat "time spent" this-time last-time)
421 (display-diff-stat "bogoclock" #f this-clock last-clock "clock")
422 (display-mips-stat "bogomips" this-time this-clock last-time last-clock)
426 (set! (repl-tm-stats repl) this-tms)
427 (set! (repl-vm-stats repl) this-vms)
428 (set! (repl-gc-stats repl) this-gcs)))
430 (define (display-stat title flag field1 field2 unit)
431 (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
432 (format #t str title field1 field2 unit)))
434 (define (display-stat-title title field1 field2)
435 (display-stat title #t field1 field2 ""))
437 (define (display-diff-stat title flag this last unit)
438 (display-stat title flag (- this last) this unit))
440 (define (display-time-stat title this last)
442 (format #f "~10,2F" (/ num internal-time-units-per-second)))
443 (display-stat title #f (conv (- this last)) (conv this) "s"))
445 (define (display-mips-stat title this-time this-clock last-time last-clock)
446 (define (mips time clock)
447 (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
448 (display-stat title #f
449 (mips (- this-time last-time) (- this-clock last-clock))
450 (mips this-time this-clock) "mips"))