module/system/repl/command.scm

   1 ;;; Repl commands
   2
   3 ;; Copyright (C) 2001, 2009, 2010 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 repl debug)
  28   #:use-module (system vm objcode)
  29   #:use-module (system vm program)
  30   #:use-module (system vm trap-state)
  31   #:use-module (system vm vm)
  32   #:autoload (system base language) (lookup-language language-reader)
  33   #:autoload (system vm trace) (vm-trace)
  34   #:autoload (system vm profile) (vm-profile)
  35   #:use-module (ice-9 format)
  36   #:use-module (ice-9 session)
  37   #:use-module (ice-9 documentation)
  38   #:use-module (ice-9 and-let-star)
  39   #:use-module (ice-9 rdelim)
  40   #:use-module (ice-9 control)
  41   #:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
  42   #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
  43   #:use-module (statprof)
  44   #:export (meta-command))
  45
  46 \f
  47 ;;;
  48 ;;; Meta command interface
  49 ;;;
  50
  51 (define *command-table*
  52   '((help     (help h) (show s) (apropos a) (describe d))
  53     (module   (module m) (import use) (load l) (binding b))
  54     (language (language L))
  55     (compile  (compile c) (compile-file cc)
  56               (disassemble x) (disassemble-file xx))
  57     (profile  (time t) (profile pr) (trace tr))
  58     (debug    (backtrace bt) (up) (down) (frame fr)
  59               (procedure proc) (locals) (error-message error)
  60               (break br bp) (break-at-source break-at bs)
  61               (tracepoint tp)
  62               (traps) (delete del) (disable) (enable))
  63     (inspect  (inspect i) (pretty-print pp))
  64     (system   (gc) (statistics stat) (option o)
  65               (quit q continue cont))))
  66
  67 (define *show-table*
  68   '((show (warranty w) (copying c) (version v))))
  69
  70 (define (group-name g) (car g))
  71 (define (group-commands g) (cdr g))
  72
  73 (define *command-module* (current-module))
  74 (define (command-name c) (car c))
  75 (define (command-abbrevs c) (cdr c))
  76 (define (command-procedure c) (module-ref *command-module* (command-name c)))
  77 (define (command-doc c) (procedure-documentation (command-procedure c)))
  78
  79 (define (command-usage c)
  80   (let ((doc (command-doc c)))
  81     (substring doc 0 (string-index doc #\newline))))
  82
  83 (define (command-summary c)
  84   (let* ((doc (command-doc c))
  85          (start (1+ (string-index doc #\newline))))
  86     (cond ((string-index doc #\newline start)
  87            => (lambda (end) (substring doc start end)))
  88           (else (substring doc start)))))
  89
  90 (define (lookup-group name)
  91   (assq name *command-table*))
  92
  93 (define* (lookup-command key #:optional (table *command-table*))
  94   (let loop ((groups table) (commands '()))
  95     (cond ((and (null? groups) (null? commands)) #f)
  96           ((null? commands)
  97            (loop (cdr groups) (cdar groups)))
  98           ((memq key (car commands)) (car commands))
  99           (else (loop groups (cdr commands))))))
 100
 101 (define* (display-group group #:optional (abbrev? #t))
 102   (format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?)
 103   (for-each (lambda (c)
 104               (display-summary (command-usage c)
 105                                (if abbrev? (command-abbrevs c) '())
 106                                (command-summary c)))
 107             (group-commands group))
 108   (newline))
 109
 110 (define (display-command command)
 111   (display "Usage: ")
 112   (display (command-doc command))
 113   (newline))
 114
 115 (define (display-summary usage abbrevs summary)
 116   (let* ((usage-len (string-length usage))
 117          (abbrevs (if (pair? abbrevs)
 118                       (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs))
 119                       ""))
 120          (abbrevs-len (string-length abbrevs)))
 121     (format #t " ,~A~A~A - ~A\n"
 122             usage
 123             (cond
 124              ((> abbrevs-len 32)
 125               (error "abbrevs too long" abbrevs))
 126              ((> (+ usage-len abbrevs-len) 32)
 127               (format #f "~%~v_" (+ 2 (- 32 abbrevs-len))))
 128              (else
 129               (format #f "~v_" (- 32 abbrevs-len usage-len))))
 130             abbrevs
 131             summary)))
 132
 133 (define (read-command repl)
 134   (catch #t
 135     (lambda () (read (repl-inport repl)))
 136     (lambda (key . args)
 137       (pmatch args
 138         ((,subr ,msg ,args . ,rest)
 139          (format #t "Throw to key `~a' while reading command:\n" key)
 140          (display-error #f (current-output-port) subr msg args rest))
 141         (else
 142          (format #t "Throw to key `~a' with args `~s' while reading command.\n"
 143                  key args)))
 144       (force-output)
 145       *unspecified*)))
 146
 147 (define read-line
 148   (let ((orig-read-line read-line))
 149     (lambda (repl)
 150       (orig-read-line (repl-inport repl)))))
 151
 152 (define (meta-command repl)
 153   (let ((command (read-command repl)))
 154     (cond
 155      ((eq? command *unspecified*)) ; read error, already signalled; pass.
 156      ((not (symbol? command))
 157       (format #t "Meta-command not a symbol: ~s~%" command))
 158      ((lookup-command command)
 159       => (lambda (c) ((command-procedure c) repl)))
 160      (else
 161       (format #t "Unknown meta command: ~A~%" command)))))
 162
 163 (define-syntax define-meta-command
 164   (syntax-rules ()
 165     ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
 166      (define (name repl)
 167        docstring
 168        (define (handle-read-error form-name key args)
 169          (pmatch args
 170            ((,subr ,msg ,args . ,rest)
 171             (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
 172                     key form-name 'name)
 173             (display-error #f (current-output-port) subr msg args rest))
 174            (else
 175             (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
 176                     key args form-name 'name)))
 177          (abort))
 178
 179        (% (let* ((expression0
 180                   (catch #t
 181                     (lambda ()
 182                       (repl-reader ""
 183                                    (lambda* (#:optional (port (repl-inport repl)))
 184                                      ((language-reader (repl-language repl))
 185                                       port (current-module)))))
 186                     (lambda (k . args)
 187                       (handle-read-error 'expression0 k args))))
 188                  ...)
 189             (apply (lambda* datums
 190                      (with-output-to-port (repl-outport repl)
 191                        (lambda () b0 b1 ...)))
 192                    (catch #t
 193                      (lambda ()
 194                        (let ((port (open-input-string (read-line repl))))
 195                          (let lp ((out '()))
 196                            (let ((x (read port)))
 197                              (if (eof-object? x)
 198                                  (reverse out)
 199                                  (lp (cons x out)))))))
 200                      (lambda (k . args)
 201                        (handle-read-error #f k args)))))
 202           (lambda (k) #f)))) ; the abort handler
 203
 204     ((_ (name repl . datums) docstring b0 b1 ...)
 205      (define-meta-command (name repl () . datums)
 206        docstring b0 b1 ...))))
 207
 208
 209 \f
 210 ;;;
 211 ;;; Help commands
 212 ;;;
 213
 214 (define-meta-command (help repl . args)
 215   "help [all | GROUP | [-c] COMMAND]
 216 Show help.
 217
 218 With one argument, tries to look up the argument as a group name, giving
 219 help on that group if successful. Otherwise tries to look up the
 220 argument as a command, giving help on the command.
 221
 222 If there is a command whose name is also a group name, use the ,help
 223 -c COMMAND form to give help on the command instead of the group.
 224
 225 Without any argument, a list of help commands and command groups
 226 are displayed."
 227   (pmatch args
 228     (()
 229      (display-group (lookup-group 'help))
 230      (display "Command Groups:\n\n")
 231      (display-summary "help all" #f "List all commands")
 232      (for-each (lambda (g)
 233                  (let* ((name (symbol->string (group-name g)))
 234                         (usage (string-append "help " name))
 235                         (header (string-append "List " name " commands")))
 236                    (display-summary usage #f header)))
 237                (cdr *command-table*))
 238      (newline)
 239      (display
 240       "Type `,help -c COMMAND' to show documentation of a particular command.")
 241      (newline))
 242     ((all)
 243      (for-each display-group *command-table*))
 244     ((,group) (guard (lookup-group group))
 245      (display-group (lookup-group group)))
 246     ((,command) (guard (lookup-command command))
 247      (display-command (lookup-command command)))
 248     ((-c ,command) (guard (lookup-command command))
 249      (display-command (lookup-command command)))
 250     ((,command)
 251      (format #t "Unknown command or group: ~A~%" command))
 252     ((-c ,command)
 253      (format #t "Unknown command: ~A~%" command))
 254     (else
 255      (format #t "Bad arguments: ~A~%" args))))
 256
 257 (define-meta-command (show repl . args)
 258   "show [TOPIC]
 259 Gives information about Guile.
 260
 261 With one argument, tries to show a particular piece of information;
 262
 263 currently supported topics are `warranty' (or `w'), `copying' (or `c'),
 264 and `version' (or `v').
 265
 266 Without any argument, a list of topics is displayed."
 267   (pmatch args
 268     (()
 269      (display-group (car *show-table*) #f)
 270      (newline))
 271     ((,topic) (guard (lookup-command topic *show-table*))
 272      ((command-procedure (lookup-command topic *show-table*)) repl))
 273     ((,command)
 274      (format #t "Unknown topic: ~A~%" command))
 275     (else
 276      (format #t "Bad arguments: ~A~%" args))))
 277
 278 (define (warranty repl)
 279   "show warranty
 280 Details on the lack of warranty."
 281   (display *warranty*)
 282   (newline))
 283
 284 (define (copying repl)
 285   "show copying
 286 Show the LGPLv3."
 287   (display *copying*)
 288   (newline))
 289
 290 (define (version repl)
 291   "show version
 292 Version information."
 293   (display *version*)
 294   (newline))
 295
 296 (define guile:apropos apropos)
 297 (define-meta-command (apropos repl regexp)
 298   "apropos REGEXP
 299 Find bindings/modules/packages."
 300   (guile:apropos (->string regexp)))
 301
 302 (define-meta-command (describe repl (form))
 303   "describe OBJ
 304 Show description/documentation."
 305   (display (object-documentation (repl-eval repl (repl-parse repl form))))
 306   (newline))
 307
 308 (define-meta-command (option repl . args)
 309   "option [KEY VALUE]
 310 List/show/set options."
 311   (pmatch args
 312     (()
 313      (for-each (lambda (spec)
 314                  (format #t "  ~A~24t~A\n" (car spec) (cadr spec)))
 315                (repl-options repl)))
 316     ((,key)
 317      (display (repl-option-ref repl key))
 318      (newline))
 319     ((,key ,val)
 320      (repl-option-set! repl key val))))
 321
 322 (define-meta-command (quit repl)
 323   "quit
 324 Quit this session."
 325   (throw 'quit))
 326
 327 \f
 328 ;;;
 329 ;;; Module commands
 330 ;;;
 331
 332 (define-meta-command (module repl . args)
 333   "module [MODULE]
 334 Change modules / Show current module."
 335   (pmatch args
 336     (() (puts (module-name (current-module))))
 337     ((,mod-name) (guard (list? mod-name))
 338      (set-current-module (resolve-module mod-name)))
 339     (,mod-name (set-current-module (resolve-module mod-name)))))
 340
 341 (define-meta-command (import repl . args)
 342   "import [MODULE ...]
 343 Import modules / List those imported."
 344   (let ()
 345     (define (use name)
 346       (let ((mod (resolve-interface name)))
 347         (if mod
 348             (module-use! (current-module) mod)
 349             (format #t "No such module: ~A~%" name))))
 350     (if (null? args)
 351         (for-each puts (map module-name (module-uses (current-module))))
 352         (for-each use args))))
 353
 354 (define guile:load load)
 355 (define-meta-command (load repl file)
 356   "load FILE
 357 Load a file in the current module."
 358   (guile:load (->string file)))
 359
 360 (define-meta-command (binding repl)
 361   "binding
 362 List current bindings."
 363   (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
 364                    (current-module)))
 365
 366 \f
 367 ;;;
 368 ;;; Language commands
 369 ;;;
 370
 371 (define-meta-command (language repl name)
 372   "language LANGUAGE
 373 Change languages."
 374   (let ((lang (lookup-language name))
 375         (cur (repl-language repl)))
 376     (format #t "Happy hacking with ~a!  To switch back, type `,L ~a'.\n"
 377             (language-title lang) (language-name cur))
 378     (set! (repl-language repl) lang)))
 379
 380 \f
 381 ;;;
 382 ;;; Compile commands
 383 ;;;
 384
 385 (define-meta-command (compile repl (form))
 386   "compile EXP
 387 Generate compiled code."
 388   (let ((x (repl-compile repl (repl-parse repl form))))
 389     (cond ((objcode? x) (guile:disassemble x))
 390           (else (repl-print repl x)))))
 391
 392 (define guile:compile-file compile-file)
 393 (define-meta-command (compile-file repl file . opts)
 394   "compile-file FILE
 395 Compile a file."
 396   (guile:compile-file (->string file) #:opts opts))
 397
 398 (define (guile:disassemble x)
 399   ((@ (language assembly disassemble) disassemble) x))
 400
 401 (define-meta-command (disassemble repl (form))
 402   "disassemble EXP
 403 Disassemble a compiled procedure."
 404   (guile:disassemble (repl-eval repl (repl-parse repl form))))
 405
 406 (define-meta-command (disassemble-file repl file)
 407   "disassemble-file FILE
 408 Disassemble a file."
 409   (guile:disassemble (load-objcode (->string file))))
 410
 411 \f
 412 ;;;
 413 ;;; Profile commands
 414 ;;;
 415
 416 (define-meta-command (time repl (form))
 417   "time EXP
 418 Time execution."
 419   (let* ((gc-start (gc-run-time))
 420          (tms-start (times))
 421          (result (repl-eval repl (repl-parse repl form)))
 422          (tms-end (times))
 423          (gc-end (gc-run-time)))
 424     (define (get proc start end)
 425       (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
 426     (repl-print repl result)
 427     (display "clock utime stime cutime cstime gctime\n")
 428     (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
 429             (get tms:clock tms-start tms-end)
 430             (get tms:utime tms-start tms-end)
 431             (get tms:stime tms-start tms-end)
 432             (get tms:cutime tms-start tms-end)
 433             (get tms:cstime tms-start tms-end)
 434             (get identity gc-start gc-end))
 435     result))
 436
 437 (define-meta-command (profile repl (form) . opts)
 438   "profile EXP
 439 Profile execution."
 440   ;; FIXME opts
 441   (apply statprof
 442          (repl-prepare-eval-thunk repl (repl-parse repl form))
 443          opts))
 444
 445 (define-meta-command (trace repl (form) . opts)
 446   "trace EXP
 447 Trace execution."
 448   ;; FIXME: doc options, or somehow deal with them better
 449   (apply vm-trace
 450          (the-vm)
 451          (repl-prepare-eval-thunk repl (repl-parse repl form))
 452          opts))
 453
 454 \f
 455 ;;;
 456 ;;; Debug commands
 457 ;;;
 458
 459 (define-syntax define-stack-command
 460   (lambda (x)
 461     (syntax-case x ()
 462       ((_ (name repl . args) docstring body body* ...)
 463        #`(define-meta-command (name repl . args)
 464            docstring
 465            (let ((debug (repl-debug repl)))
 466              (if debug
 467                  (letrec-syntax
 468                      ((#,(datum->syntax #'repl 'frames)
 469                        (identifier-syntax (debug-frames debug)))
 470                       (#,(datum->syntax #'repl 'message)
 471                        (identifier-syntax (debug-error-message debug)))
 472                       (#,(datum->syntax #'repl 'index)
 473                        (identifier-syntax
 474                         (id (debug-index debug))
 475                         ((set! id exp) (set! (debug-index debug) exp))))
 476                       (#,(datum->syntax #'repl 'cur)
 477                        (identifier-syntax
 478                         (vector-ref #,(datum->syntax #'repl 'frames)
 479                                     #,(datum->syntax #'repl 'index)))))
 480                    body body* ...)
 481                  (format #t "Nothing to debug.~%"))))))))
 482
 483 (define-stack-command (backtrace repl #:optional count
 484                                  #:key (width 72) full?)
 485   "backtrace [COUNT] [#:width W] [#:full? F]
 486 Print a backtrace.
 487
 488 Print a backtrace of all stack frames, or innermost COUNT frames.
 489 If COUNT is negative, the last COUNT frames will be shown."
 490   (print-frames frames
 491                 #:count count
 492                 #:width width
 493                 #:full? full?))
 494
 495 (define-stack-command (up repl #:optional (count 1))
 496   "up [COUNT]
 497 Select a calling stack frame.
 498
 499 Select and print stack frames that called this one.
 500 An argument says how many frames up to go."
 501   (cond
 502    ((or (not (integer? count)) (<= count 0))
 503     (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
 504    ((>= (+ count index) (vector-length frames))
 505     (cond
 506      ((= index (1- (vector-length frames)))
 507       (format #t "Already at outermost frame.\n"))
 508      (else
 509       (set! index (1- (vector-length frames)))
 510       (print-frame cur #:index index))))
 511    (else
 512     (set! index (+ count index))
 513     (print-frame cur #:index index))))
 514
 515 (define-stack-command (down repl #:optional (count 1))
 516   "down [COUNT]
 517 Select a called stack frame.
 518
 519 Select and print stack frames called by this one.
 520 An argument says how many frames down to go."
 521   (cond
 522    ((or (not (integer? count)) (<= count 0))
 523     (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
 524    ((< (- index count) 0)
 525     (cond
 526      ((zero? index)
 527       (format #t "Already at innermost frame.\n"))
 528      (else
 529       (set! index 0)
 530       (print-frame cur #:index index))))
 531    (else
 532     (set! index (- index count))
 533     (print-frame cur #:index index))))
 534
 535 (define-stack-command (frame repl #:optional idx)
 536   "frame [IDX]
 537 Show a frame.
 538
 539 Show the selected frame.
 540 With an argument, select a frame by index, then show it."
 541   (cond
 542    (idx
 543     (cond
 544      ((or (not (integer? idx)) (< idx 0))
 545       (format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
 546      ((< idx (vector-length frames))
 547       (set! index idx)
 548       (print-frame cur #:index index))
 549      (else
 550       (format #t "No such frame.~%"))))
 551    (else (print-frame cur #:index index))))
 552
 553 (define-stack-command (procedure repl)
 554   "procedure
 555 Print the procedure for the selected frame."
 556   (repl-print repl (frame-procedure cur)))
 557
 558 (define-stack-command (locals repl)
 559   "locals
 560 Show local variables.
 561
 562 Show locally-bound variables in the selected frame."
 563   (print-locals cur))
 564
 565 (define-stack-command (error-message repl)
 566   "error-message
 567 Show error message.
 568
 569 Display the message associated with the error that started the current
 570 debugging REPL."
 571   (format #t "~a~%" (if (string? message) message "No error message")))
 572
 573 (define-meta-command (break repl (form))
 574   "break PROCEDURE
 575 Break on calls to PROCEDURE.
 576
 577 Starts a recursive prompt when PROCEDURE is called."
 578   (let ((proc (repl-eval repl (repl-parse repl form))))
 579     (if (not (procedure? proc))
 580         (error "Not a procedure: ~a" proc)
 581         (let ((idx (add-trap-at-procedure-call! proc)))
 582           (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))))
 583
 584 (define-meta-command (break-at-source repl file line)
 585   "break-at-source FILE LINE
 586 Break when control reaches the given source location.
 587
 588 Starts a recursive prompt when control reaches line LINE of file FILE.
 589 Note that the given source location must be inside a procedure."
 590   (let ((file (if (symbol? file) (symbol->string file) file)))
 591     (let ((idx (add-trap-at-source-location! file line)))
 592       (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))
 593
 594 (define-meta-command (tracepoint repl (form))
 595   "tracepoint PROCEDURE
 596 Add a tracepoint to PROCEDURE.
 597
 598 A tracepoint will print out the procedure and its arguments, when it is
 599 called, and its return value(s) when it returns."
 600   (let ((proc (repl-eval repl (repl-parse repl form))))
 601     (if (not (procedure? proc))
 602         (error "Not a procedure: ~a" proc)
 603         (let ((idx (add-trace-at-procedure-call! proc)))
 604           (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))))
 605
 606 (define-meta-command (traps repl)
 607   "traps
 608 Show the set of currently attached traps.
 609
 610 Show the set of currently attached traps (breakpoints and tracepoints)."
 611   (let ((traps (list-traps)))
 612     (if (null? traps)
 613         (format #t "No traps set.~%")
 614         (for-each (lambda (idx)
 615                     (format #t "  ~a: ~a~a~%"
 616                             idx (trap-name idx)
 617                             (if (trap-enabled? idx) "" " (disabled)")))
 618                   traps))))
 619
 620 (define-meta-command (delete repl idx)
 621   "delete IDX
 622 Delete a trap.
 623
 624 Delete a trap."
 625   (if (not (integer? idx))
 626       (error "expected a trap index (a non-negative integer)" idx)
 627       (delete-trap! idx)))
 628
 629 (define-meta-command (disable repl idx)
 630   "disable IDX
 631 Disable a trap.
 632
 633 Disable a trap."
 634   (if (not (integer? idx))
 635       (error "expected a trap index (a non-negative integer)" idx)
 636       (disable-trap! idx)))
 637
 638 (define-meta-command (enable repl idx)
 639   "enable IDX
 640 Enable a trap.
 641
 642 Enable a trap."
 643   (if (not (integer? idx))
 644       (error "expected a trap index (a non-negative integer)" idx)
 645       (enable-trap! idx)))
 646
 647
 648 \f
 649 ;;;
 650 ;;; Inspection commands
 651 ;;;
 652
 653 (define-stack-command (inspect repl (form))
 654   "inspect EXP
 655 Inspect the result(s) of evaluating EXP."
 656   (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
 657     (lambda args
 658       (for-each %inspect args))))
 659
 660 (define-meta-command (pretty-print repl (form))
 661   "pretty-print EXP
 662 Pretty-print the result(s) of evaluating EXP."
 663   (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
 664     (lambda args
 665       (for-each
 666        (lambda (x)
 667          (run-hook before-print-hook x)
 668          (pp x))
 669        args))))
 670
 671 \f
 672 ;;;
 673 ;;; System commands
 674 ;;;
 675
 676 (define guile:gc gc)
 677 (define-meta-command (gc repl)
 678   "gc
 679 Garbage collection."
 680   (guile:gc))
 681
 682 (define-meta-command (statistics repl)
 683   "statistics
 684 Display statistics."
 685   (let ((this-tms (times))
 686         (this-gcs (gc-stats))
 687         (last-tms (repl-tm-stats repl))
 688         (last-gcs (repl-gc-stats repl)))
 689     ;; GC times
 690     (let ((this-times  (assq-ref this-gcs 'gc-times))
 691           (last-times  (assq-ref last-gcs 'gc-times)))
 692       (display-diff-stat "GC times:" #t this-times last-times "times")
 693       (newline))
 694     ;; Memory size
 695     (let ((this-cells  (assq-ref this-gcs 'cells-allocated))
 696           (this-heap   (assq-ref this-gcs 'cell-heap-size))
 697           (this-bytes  (assq-ref this-gcs 'bytes-malloced))
 698           (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
 699       (display-stat-title "Memory size:" "current" "limit")
 700       (display-stat "heap" #f this-cells this-heap "cells")
 701       (display-stat "malloc" #f this-bytes this-malloc "bytes")
 702       (newline))
 703     ;; Cells collected
 704     (let ((this-marked (assq-ref this-gcs 'cells-marked))
 705           (last-marked (assq-ref last-gcs 'cells-marked))
 706           (this-swept  (assq-ref this-gcs 'cells-swept))
 707           (last-swept  (assq-ref last-gcs 'cells-swept)))
 708       (display-stat-title "Cells collected:" "diff" "total")
 709       (display-diff-stat "marked" #f this-marked last-marked "cells")
 710       (display-diff-stat "swept" #f this-swept last-swept "cells")
 711       (newline))
 712     ;; GC time taken
 713     (let ((this-mark  (assq-ref this-gcs 'gc-mark-time-taken))
 714           (last-mark  (assq-ref last-gcs 'gc-mark-time-taken))
 715           (this-total (assq-ref this-gcs 'gc-time-taken))
 716           (last-total (assq-ref last-gcs 'gc-time-taken)))
 717       (display-stat-title "GC time taken:" "diff" "total")
 718       (display-time-stat "mark" this-mark last-mark)
 719       (display-time-stat "total" this-total last-total)
 720       (newline))
 721     ;; Process time spent
 722     (let ((this-utime  (tms:utime this-tms))
 723           (last-utime  (tms:utime last-tms))
 724           (this-stime  (tms:stime this-tms))
 725           (last-stime  (tms:stime last-tms))
 726           (this-cutime (tms:cutime this-tms))
 727           (last-cutime (tms:cutime last-tms))
 728           (this-cstime (tms:cstime this-tms))
 729           (last-cstime (tms:cstime last-tms)))
 730       (display-stat-title "Process time spent:" "diff" "total")
 731       (display-time-stat "user" this-utime last-utime)
 732       (display-time-stat "system" this-stime last-stime)
 733       (display-time-stat "child user" this-cutime last-cutime)
 734       (display-time-stat "child system" this-cstime last-cstime)
 735       (newline))
 736     ;; Save statistics
 737     ;; Save statistics
 738     (set! (repl-tm-stats repl) this-tms)
 739     (set! (repl-gc-stats repl) this-gcs)))
 740
 741 (define (display-stat title flag field1 field2 unit)
 742   (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
 743     (format #t str title field1 field2 unit)))
 744
 745 (define (display-stat-title title field1 field2)
 746   (display-stat title #t field1 field2 ""))
 747
 748 (define (display-diff-stat title flag this last unit)
 749   (display-stat title flag (- this last) this unit))
 750
 751 (define (display-time-stat title this last)
 752   (define (conv num)
 753     (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second))))
 754   (display-stat title #f (conv (- this last)) (conv this) "s"))
 755
 756 (define (display-mips-stat title this-time this-clock last-time last-clock)
 757   (define (mips time clock)
 758     (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0))))
 759   (display-stat title #f
 760                 (mips (- this-time last-time) (- this-clock last-clock))
 761                 (mips this-time this-clock) "mips"))