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