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 ((null? opts)
 305            (disassemble-bootcode x))
 306           ((memq :c opts)
 307            (pprint-glil x))
 308           (else (puts x)))))
 309
 310 (define (compile-file repl file . opts)
 311   "compile-file [options] FILE
 312 Compile a file."
 313   (apply repl-compile-file repl (->string file) opts))
 314
 315 (define (disassemble repl prog)
 316   "disassemble PROGRAM
 317 Disassemble a program."
 318   (disassemble-program (repl-eval repl prog)))
 319
 320 (define (disassemble-file repl file)
 321   "disassemble-file FILE
 322 Disassemble a file."
 323   (disassemble-bootcode
 324    (load-file-in (->string file) repl.module repl.language)))
 325
 326 (define (->string x)
 327   (object->string x display))
 328
 329 \f
 330 ;;;
 331 ;;; Profile commands
 332 ;;;
 333
 334 (define (profile repl form . opts)
 335   "profile FORM
 336 Profile execution."
 337   (apply vm-profile repl.vm (repl-compile repl form) opts))
 338
 339 \f
 340 ;;;
 341 ;;; Debug commands
 342 ;;;
 343
 344 (define guile-backtrace backtrace)
 345 (define (backtrace repl)
 346   "backtrace
 347 Show backtrace (if any)."
 348   (guile-backtrace))
 349
 350 (define (debugger repl)
 351   "debugger
 352 Start debugger."
 353   (debug))
 354
 355 (define (trace repl form . opts)
 356   "trace [-b] FORM
 357 Trace execution."
 358   (apply vm-trace repl.vm (repl-compile repl form) opts))
 359
 360 (define (step repl)
 361   "step FORM
 362 Step execution."
 363   (display "Not implemented yet\n"))
 364
 365 \f
 366 ;;;
 367 ;;; System commands
 368 ;;;
 369
 370 (define (time repl form)
 371   "time FORM
 372 Time execution."
 373   (let* ((vms-start (vm-stats repl.vm))
 374          (gc-start (gc-run-time))
 375          (tms-start (times))
 376          (result (repl-eval repl form))
 377          (tms-end (times))
 378          (gc-end (gc-run-time))
 379          (vms-end (vm-stats repl.vm)))
 380     (define (get proc start end)
 381       (/ (- (proc end) (proc start)) internal-time-units-per-second))
 382     (repl-print repl result)
 383     (display "clock utime stime cutime cstime gctime\n")
 384     (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
 385             (get tms:clock tms-start tms-end)
 386             (get tms:utime tms-start tms-end)
 387             (get tms:stime tms-start tms-end)
 388             (get tms:cutime tms-start tms-end)
 389             (get tms:cstime tms-start tms-end)
 390             (get id gc-start gc-end))
 391     result))
 392
 393 ;;;
 394 ;;; Statistics
 395 ;;;
 396
 397 (define guile-gc gc)
 398 (define (gc repl)
 399   "gc
 400 Garbage collection."
 401   (guile-gc))
 402
 403 (define (display-stat title flag field1 field2 unit)
 404   (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
 405     (format #t str title field1 field2 unit)))
 406
 407 (define (display-stat-title title field1 field2)
 408   (display-stat title #t field1 field2 ""))
 409
 410 (define (display-diff-stat title flag this last unit)
 411   (display-stat title flag (- this last) this unit))
 412
 413 (define (display-time-stat title this last)
 414   (define (conv num)
 415     (format #f "~10,2F" (/ num internal-time-units-per-second)))
 416   (display-stat title #f (conv (- this last)) (conv this) "s"))
 417
 418 (define (display-mips-stat title this-time this-clock last-time last-clock)
 419   (define (mips time clock)
 420     (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
 421   (display-stat title #f
 422                 (mips (- this-time last-time) (- this-clock last-clock))
 423                 (mips this-time this-clock) "mips"))
 424
 425 (define (statistics repl)
 426   "statistics
 427 Display statistics."
 428   (let ((this-tms (times))
 429         (this-vms (vm-stats repl.vm))
 430         (this-gcs (gc-stats))
 431         (last-tms repl.tm-stats)
 432         (last-vms repl.vm-stats)
 433         (last-gcs repl.gc-stats))
 434     ;; GC times
 435     (let ((this-times  (assq-ref this-gcs 'gc-times))
 436           (last-times  (assq-ref last-gcs 'gc-times)))
 437       (display-diff-stat "GC times:" #t this-times last-times "times")
 438       (newline))
 439     ;; Memory size
 440     (let ((this-cells  (assq-ref this-gcs 'cells-allocated))
 441           (this-heap   (assq-ref this-gcs 'cell-heap-size))
 442           (this-bytes  (assq-ref this-gcs 'bytes-malloced))
 443           (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
 444       (display-stat-title "Memory size:" "current" "limit")
 445       (display-stat "heap" #f this-cells this-heap "cells")
 446       (display-stat "malloc" #f this-bytes this-malloc "bytes")
 447       (newline))
 448     ;; Cells collected
 449     (let ((this-marked (assq-ref this-gcs 'cells-marked))
 450           (last-marked (assq-ref last-gcs 'cells-marked))
 451           (this-swept  (assq-ref this-gcs 'cells-swept))
 452           (last-swept  (assq-ref last-gcs 'cells-swept)))
 453       (display-stat-title "Cells collected:" "diff" "total")
 454       (display-diff-stat "marked" #f this-marked last-marked "cells")
 455       (display-diff-stat "swept" #f this-swept last-swept "cells")
 456       (newline))
 457     ;; GC time taken
 458     (let ((this-mark  (assq-ref this-gcs 'gc-mark-time-taken))
 459           (last-mark  (assq-ref last-gcs 'gc-mark-time-taken))
 460           (this-sweep (assq-ref this-gcs 'gc-sweep-time-taken))
 461           (last-sweep (assq-ref last-gcs 'gc-sweep-time-taken))
 462           (this-total (assq-ref this-gcs 'gc-time-taken))
 463           (last-total (assq-ref last-gcs 'gc-time-taken)))
 464       (display-stat-title "GC time taken:" "diff" "total")
 465       (display-time-stat "mark" this-mark last-mark)
 466       (display-time-stat "sweep" this-sweep last-sweep)
 467       (display-time-stat "total" this-total last-total)
 468       (newline))
 469     ;; Process time spent
 470     (let ((this-utime  (tms:utime this-tms))
 471           (last-utime  (tms:utime last-tms))
 472           (this-stime  (tms:stime this-tms))
 473           (last-stime  (tms:stime last-tms))
 474           (this-cutime (tms:cutime this-tms))
 475           (last-cutime (tms:cutime last-tms))
 476           (this-cstime (tms:cstime this-tms))
 477           (last-cstime (tms:cstime last-tms)))
 478       (display-stat-title "Process time spent:" "diff" "total")
 479       (display-time-stat "user" this-utime last-utime)
 480       (display-time-stat "system" this-stime last-stime)
 481       (display-time-stat "child user" this-cutime last-cutime)
 482       (display-time-stat "child system" this-cstime last-cstime)
 483       (newline))
 484     ;; VM statistics
 485     (let ((this-time  (vms:time this-vms))
 486           (last-time  (vms:time last-vms))
 487           (this-clock (vms:clock this-vms))
 488           (last-clock (vms:clock last-vms)))
 489       (display-stat-title "VM statistics:" "diff" "total")
 490       (display-time-stat "time spent" this-time last-time)
 491       (display-diff-stat "bogoclock" #f this-clock last-clock "clock")
 492       (display-mips-stat "bogomips" this-time this-clock last-time last-clock)
 493       (newline))
 494     ;; Save statistics
 495     ;; Save statistics
 496     (set! repl.tm-stats this-tms)
 497     (set! repl.vm-stats this-vms)
 498     (set! repl.gc-stats this-gcs)))