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