module/system/repl/command.gs

   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)))