module/system/repl/command.scm

   1 ;;; Repl commands
   2
   3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library 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 GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18 ;; 02110-1301 USA
  19
  20 ;;; Code:
  21
  22 (define-module (system repl command)
  23   #:use-module (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 objcode)
  28   #:use-module (system vm program)
  29   #:use-module (system vm vm)
  30   #:autoload (system base language) (lookup-language language-reader)
  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   #:use-module (ice-9 rdelim)
  39   #:use-module (statprof)
  40   #:export (meta-command))
  41
  42 \f
  43 ;;;
  44 ;;; Meta command interface
  45 ;;;
  46
  47 (define *command-table*
  48   '((help     (help h) (apropos a) (describe d) (option o) (quit q))
  49     (module   (module m) (import i) (load l) (binding b))
  50     (language (language L))
  51     (compile  (compile c) (compile-file cc)
  52               (disassemble x) (disassemble-file xx))
  53     (profile  (time t) (profile pr))
  54     (debug    (backtrace bt) (debugger db) (trace tr) (step st))
  55     (system   (gc) (statistics stat))))
  56
  57 (define (group-name g) (car g))
  58 (define (group-commands g) (cdr g))
  59
  60 ;; Hack, until core can be extended.
  61 (define procedure-documentation
  62   (let ((old-definition procedure-documentation))
  63     (lambda (p)
  64       (if (program? p)
  65           (program-documentation p)
  66           (old-definition p)))))
  67
  68 (define *command-module* (current-module))
  69 (define (command-name c) (car c))
  70 (define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
  71 (define (command-procedure c) (module-ref *command-module* (command-name c)))
  72 (define (command-doc c) (procedure-documentation (command-procedure c)))
  73
  74 (define (command-usage c)
  75   (let ((doc (command-doc c)))
  76     (substring doc 0 (string-index doc #\newline))))
  77
  78 (define (command-summary c)
  79   (let* ((doc (command-doc c))
  80          (start (1+ (string-index doc #\newline))))
  81     (cond ((string-index doc #\newline start)
  82            => (lambda (end) (substring doc start end)))
  83           (else (substring doc start)))))
  84
  85 (define (lookup-group name)
  86   (assq name *command-table*))
  87
  88 (define (lookup-command key)
  89   (let loop ((groups *command-table*) (commands '()))
  90     (cond ((and (null? groups) (null? commands)) #f)
  91           ((null? commands)
  92            (loop (cdr groups) (cdar groups)))
  93           ((memq key (car commands)) (car commands))
  94           (else (loop groups (cdr commands))))))
  95
  96 (define (display-group group . opts)
  97   (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
  98   (for-each (lambda (c)
  99               (display-summary (command-usage c)
 100                                (command-abbrev c)
 101                                (command-summary c)))
 102             (group-commands group))
 103   (newline))
 104
 105 (define (display-command command)
 106   (display "Usage: ")
 107   (display (command-doc command))
 108   (newline))
 109
 110 (define (display-summary usage abbrev summary)
 111   (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
 112     (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
 113
 114 (define (read-datum repl)
 115   (read))
 116
 117 (define read-line
 118   (let ((orig-read-line read-line))
 119     (lambda (repl)
 120       (orig-read-line))))
 121
 122 (define (meta-command repl)
 123   (let ((command (read-datum repl)))
 124     (if (not (symbol? command))
 125         (user-error "Meta-command not a symbol: ~s" command))
 126     (let ((c (lookup-command command)))
 127       (if c
 128           ((command-procedure c) repl)
 129           (user-error "Unknown meta command: ~A" command)))))
 130
 131 (define-syntax define-meta-command
 132   (syntax-rules ()
 133     ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
 134      (define (name repl)
 135        docstring
 136        (let* ((expression0
 137                (repl-reader ""
 138                             (lambda args
 139                               (let ((port (if (pair? args)
 140                                               (car args)
 141                                               (current-input-port))))
 142                                 ((language-reader (repl-language repl))
 143                                  port (current-module))))))
 144               ...)
 145          (apply (lambda datums b0 b1 ...)
 146                 (let ((port (open-input-string (read-line repl))))
 147                   (let lp ((out '()))
 148                     (let ((x (read port)))
 149                       (if (eof-object? x)
 150                           (reverse out)
 151                           (lp (cons x out))))))))))
 152     ((_ (name repl . datums) docstring b0 b1 ...)
 153      (define-meta-command (name repl () . datums)
 154        docstring b0 b1 ...))))
 155
 156
 157 \f
 158 ;;;
 159 ;;; Help commands
 160 ;;;
 161
 162 (define-meta-command (help repl . args)
 163   "help
 164 help GROUP
 165 help [-c] COMMAND
 166
 167 Gives help on the meta-commands available at the REPL.
 168
 169 With one argument, tries to look up the argument as a group name, giving
 170 help on that group if successful. Otherwise tries to look up the
 171 argument as a command, giving help on the command.
 172
 173 If there is a command whose name is also a group name, use the ,help
 174 -c COMMAND form to give help on the command instead of the group.
 175
 176 Without any argument, a list of help commands and command groups
 177 are displayed."
 178   (pmatch args
 179     (()
 180      (display-group (lookup-group 'help))
 181      (display "Command Groups:\n\n")
 182      (display-summary "help all" #f "List all commands")
 183      (for-each (lambda (g)
 184                  (let* ((name (symbol->string (group-name g)))
 185                         (usage (string-append "help " name))
 186                         (header (string-append "List " name " commands")))
 187                    (display-summary usage #f header)))
 188                (cdr *command-table*))
 189      (newline)
 190      (display "Type `,COMMAND -h' to show documentation of each command.")
 191      (newline))
 192     ((all)
 193      (for-each display-group *command-table*))
 194     ((,group) (guard (lookup-group group))
 195      (display-group (lookup-group group)))
 196     ((,command) (guard (lookup-command command))
 197      (display-command (lookup-command command)))
 198     ((-c ,command) (guard (lookup-command command))
 199      (display-command (lookup-command command)))
 200     ((,command)
 201      (user-error "Unknown command or group: ~A" command))
 202     ((-c ,command)
 203      (user-error "Unknown command: ~A" command))
 204     (else
 205      (user-error "Bad arguments: ~A" args))))
 206
 207 (define guile:apropos apropos)
 208 (define-meta-command (apropos repl regexp)
 209   "apropos REGEXP
 210 Find bindings/modules/packages."
 211   (guile:apropos (->string regexp)))
 212
 213 (define-meta-command (describe repl (form))
 214   "describe OBJ
 215 Show description/documentation."
 216   (display (object-documentation (repl-eval repl (repl-parse repl form))))
 217   (newline))
 218
 219 (define-meta-command (option repl . args)
 220   "option [KEY VALUE]
 221 List/show/set options."
 222   (pmatch args
 223     (()
 224      (for-each (lambda (key+val)
 225                  (format #t "~A\t~A\n" (car key+val) (cdr key+val)))
 226                (repl-options repl)))
 227     ((,key)
 228      (display (repl-option-ref repl key))
 229      (newline))
 230     ((,key ,val)
 231      (repl-option-set! repl key val)
 232      (case key
 233        ((trace)
 234         (let ((vm (repl-vm repl)))
 235           (if val
 236               (apply vm-trace-on! vm val)
 237               ;; fixme: asymmetry
 238               (vm-trace-off! vm))))))))
 239
 240 (define-meta-command (quit repl)
 241   "quit
 242 Quit this session."
 243   (throw 'quit))
 244
 245 \f
 246 ;;;
 247 ;;; Module commands
 248 ;;;
 249
 250 (define-meta-command (module repl . args)
 251   "module [MODULE]
 252 Change modules / Show current module."
 253   (pmatch args
 254     (() (puts (module-name (current-module))))
 255     ((,mod-name) (guard (list? mod-name))
 256      (set-current-module (resolve-module mod-name)))
 257     (,mod-name (set-current-module (resolve-module mod-name)))))
 258
 259 (define-meta-command (import repl . args)
 260   "import [MODULE ...]
 261 Import modules / List those imported."
 262   (let ()
 263     (define (use name)
 264       (let ((mod (resolve-interface name)))
 265         (if mod
 266             (module-use! (current-module) mod)
 267             (user-error "No such module: ~A" name))))
 268     (if (null? args)
 269         (for-each puts (map module-name (module-uses (current-module))))
 270         (for-each use args))))
 271
 272 (define guile:load load)
 273 (define-meta-command (load repl file . opts)
 274   "load FILE
 275 Load a file in the current module.
 276
 277   -f    Load source file (see `compile')"
 278   (let ((file (->string file)))
 279     (if (memq #:f opts)
 280         (primitive-load file)
 281         (guile:load file))))
 282
 283 (define-meta-command (binding repl)
 284   "binding
 285 List current bindings."
 286   (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
 287                    (current-module)))
 288
 289 \f
 290 ;;;
 291 ;;; Language commands
 292 ;;;
 293
 294 (define-meta-command (language repl name)
 295   "language LANGUAGE
 296 Change languages."
 297   (set! (repl-language repl) (lookup-language name))
 298   (repl-welcome repl))
 299
 300 \f
 301 ;;;
 302 ;;; Compile commands
 303 ;;;
 304
 305 (define-meta-command (compile repl (form) . opts)
 306   "compile FORM
 307 Generate compiled code.
 308
 309   -e    Stop after expanding syntax/macro
 310   -t    Stop after translating into GHIL
 311   -c    Stop after generating GLIL
 312
 313   -O    Enable optimization
 314   -D    Add debug information"
 315   (let ((x (apply repl-compile repl (repl-parse repl form) opts)))
 316     (cond ((objcode? x) (guile:disassemble x))
 317           (else (repl-print repl x)))))
 318
 319 (define guile:compile-file compile-file)
 320 (define-meta-command (compile-file repl file . opts)
 321   "compile-file FILE
 322 Compile a file."
 323   (guile:compile-file (->string file) #:opts opts))
 324
 325 (define (guile:disassemble x)
 326   ((@ (language assembly disassemble) disassemble) x))
 327
 328 (define-meta-command (disassemble repl (form))
 329   "disassemble PROGRAM
 330 Disassemble a program."
 331   (guile:disassemble (repl-eval repl (repl-parse repl form))))
 332
 333 (define-meta-command (disassemble-file repl file)
 334   "disassemble-file FILE
 335 Disassemble a file."
 336   (guile:disassemble (load-objcode (->string file))))
 337
 338 \f
 339 ;;;
 340 ;;; Profile commands
 341 ;;;
 342
 343 (define-meta-command (time repl (form))
 344   "time FORM
 345 Time execution."
 346   (let* ((gc-start (gc-run-time))
 347          (tms-start (times))
 348          (result (repl-eval repl (repl-parse repl form)))
 349          (tms-end (times))
 350          (gc-end (gc-run-time)))
 351     (define (get proc start end)
 352       (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
 353     (repl-print repl result)
 354     (display "clock utime stime cutime cstime gctime\n")
 355     (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
 356             (get tms:clock tms-start tms-end)
 357             (get tms:utime tms-start tms-end)
 358             (get tms:stime tms-start tms-end)
 359             (get tms:cutime tms-start tms-end)
 360             (get tms:cstime tms-start tms-end)
 361             (get identity gc-start gc-end))
 362     result))
 363
 364 (define-meta-command (profile repl (form) . opts)
 365   "profile FORM
 366 Profile execution."
 367   ;; FIXME opts
 368   (let ((vm (repl-vm repl))
 369         (proc (make-program (repl-compile repl (repl-parse repl form)))))
 370     (with-statprof #:hz 100 (vm proc))))
 371
 372
 373 \f
 374 ;;;
 375 ;;; Debug commands
 376 ;;;
 377
 378 (define-meta-command (backtrace repl)
 379   "backtrace
 380 Display backtrace."
 381   (vm-backtrace (repl-vm repl)))
 382
 383 (define-meta-command (debugger repl)
 384   "debugger
 385 Start debugger."
 386   (vm-debugger (repl-vm repl)))
 387
 388 (define-meta-command (trace repl form . opts)
 389   "trace FORM
 390 Trace execution."
 391   ;; FIXME: doc, or somehow deal with them better
 392   (apply vm-trace
 393          (repl-vm repl)
 394          (make-program (repl-compile repl (repl-parse repl form)))
 395          opts))
 396
 397 (define-meta-command (step repl)
 398   "step FORM
 399 Step execution."
 400   (display "Not implemented yet\n"))
 401
 402 \f
 403 ;;;
 404 ;;; System commands
 405 ;;;
 406
 407 (define guile:gc gc)
 408 (define-meta-command (gc repl)
 409   "gc
 410 Garbage collection."
 411   (guile:gc))
 412
 413 (define-meta-command (statistics repl)
 414   "statistics
 415 Display statistics."
 416   (let ((this-tms (times))
 417         (this-gcs (gc-stats))
 418         (last-tms (repl-tm-stats repl))
 419         (last-gcs (repl-gc-stats repl)))
 420     ;; GC times
 421     (let ((this-times  (assq-ref this-gcs 'gc-times))
 422           (last-times  (assq-ref last-gcs 'gc-times)))
 423       (display-diff-stat "GC times:" #t this-times last-times "times")
 424       (newline))
 425     ;; Memory size
 426     (let ((this-cells  (assq-ref this-gcs 'cells-allocated))
 427           (this-heap   (assq-ref this-gcs 'cell-heap-size))
 428           (this-bytes  (assq-ref this-gcs 'bytes-malloced))
 429           (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
 430       (display-stat-title "Memory size:" "current" "limit")
 431       (display-stat "heap" #f this-cells this-heap "cells")
 432       (display-stat "malloc" #f this-bytes this-malloc "bytes")
 433       (newline))
 434     ;; Cells collected
 435     (let ((this-marked (assq-ref this-gcs 'cells-marked))
 436           (last-marked (assq-ref last-gcs 'cells-marked))
 437           (this-swept  (assq-ref this-gcs 'cells-swept))
 438           (last-swept  (assq-ref last-gcs 'cells-swept)))
 439       (display-stat-title "Cells collected:" "diff" "total")
 440       (display-diff-stat "marked" #f this-marked last-marked "cells")
 441       (display-diff-stat "swept" #f this-swept last-swept "cells")
 442       (newline))
 443     ;; GC time taken
 444     (let ((this-mark  (assq-ref this-gcs 'gc-mark-time-taken))
 445           (last-mark  (assq-ref last-gcs 'gc-mark-time-taken))
 446           (this-total (assq-ref this-gcs 'gc-time-taken))
 447           (last-total (assq-ref last-gcs 'gc-time-taken)))
 448       (display-stat-title "GC time taken:" "diff" "total")
 449       (display-time-stat "mark" this-mark last-mark)
 450       (display-time-stat "total" this-total last-total)
 451       (newline))
 452     ;; Process time spent
 453     (let ((this-utime  (tms:utime this-tms))
 454           (last-utime  (tms:utime last-tms))
 455           (this-stime  (tms:stime this-tms))
 456           (last-stime  (tms:stime last-tms))
 457           (this-cutime (tms:cutime this-tms))
 458           (last-cutime (tms:cutime last-tms))
 459           (this-cstime (tms:cstime this-tms))
 460           (last-cstime (tms:cstime last-tms)))
 461       (display-stat-title "Process time spent:" "diff" "total")
 462       (display-time-stat "user" this-utime last-utime)
 463       (display-time-stat "system" this-stime last-stime)
 464       (display-time-stat "child user" this-cutime last-cutime)
 465       (display-time-stat "child system" this-cstime last-cstime)
 466       (newline))
 467     ;; Save statistics
 468     ;; Save statistics
 469     (set! (repl-tm-stats repl) this-tms)
 470     (set! (repl-gc-stats repl) 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" (exact->inexact (/ 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.0))))
 490   (display-stat title #f
 491                 (mips (- this-time last-time) (- this-clock last-clock))
 492                 (mips this-time this-clock) "mips"))