module/system/repl/command.scm

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