3 ;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
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.
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.
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
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 #:use-module ((system vm frame) #:select (frame-return-values))
33 #:autoload (system base language) (lookup-language language-reader)
34 #:autoload (system vm trace) (call-with-trace)
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 define-meta-command))
48 ;;; Meta command interface
51 (define *command-table*
52 '((help (help h) (show) (apropos a) (describe d))
53 (module (module m) (import use) (load l) (reload re) (binding b) (in))
54 (language (language L))
55 (compile (compile c) (compile-file cc)
56 (expand exp) (optimize opt)
57 (disassemble x) (disassemble-file xx))
58 (profile (time t) (profile pr) (trace tr))
59 (debug (backtrace bt) (up) (down) (frame fr)
60 (procedure proc) (locals) (error-message error)
61 (break br bp) (break-at-source break-at bs)
62 (step s) (step-instruction si)
63 (next n) (next-instruction ni)
66 (traps) (delete del) (disable) (enable)
68 (inspect (inspect i) (pretty-print pp))
69 (system (gc) (statistics stat) (option o)
70 (quit q continue cont))))
73 '((show (warranty w) (copying c) (version v))))
75 (define (group-name g) (car g))
76 (define (group-commands g) (cdr g))
78 (define *command-infos* (make-hash-table))
79 (define (command-name c) (car c))
80 (define (command-abbrevs c) (cdr c))
81 (define (command-info c) (hashq-ref *command-infos* (command-name c)))
82 (define (command-procedure c) (command-info-procedure (command-info c)))
83 (define (command-doc c) (procedure-documentation (command-procedure c)))
85 (define (make-command-info proc arguments-reader)
86 (cons proc arguments-reader))
88 (define (command-info-procedure info)
91 (define (command-info-arguments-reader info)
94 (define (command-usage c)
95 (let ((doc (command-doc c)))
96 (substring doc 0 (string-index doc #\newline))))
98 (define (command-summary c)
99 (let* ((doc (command-doc c))
100 (start (1+ (string-index doc #\newline))))
101 (cond ((string-index doc #\newline start)
102 => (lambda (end) (substring doc start end)))
103 (else (substring doc start)))))
105 (define (lookup-group name)
106 (assq name *command-table*))
108 (define* (lookup-command key #:optional (table *command-table*))
109 (let loop ((groups table) (commands '()))
110 (cond ((and (null? groups) (null? commands)) #f)
112 (loop (cdr groups) (cdar groups)))
113 ((memq key (car commands)) (car commands))
114 (else (loop groups (cdr commands))))))
116 (define* (display-group group #:optional (abbrev? #t))
117 (format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?)
118 (for-each (lambda (c)
119 (display-summary (command-usage c)
120 (if abbrev? (command-abbrevs c) '())
121 (command-summary c)))
122 (group-commands group))
125 (define (display-command command)
127 (display (command-doc command))
130 (define (display-summary usage abbrevs summary)
131 (let* ((usage-len (string-length usage))
132 (abbrevs (if (pair? abbrevs)
133 (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs))
135 (abbrevs-len (string-length abbrevs)))
136 (format #t " ,~A~A~A - ~A\n"
140 (error "abbrevs too long" abbrevs))
141 ((> (+ usage-len abbrevs-len) 32)
142 (format #f "~%~v_" (+ 2 (- 32 abbrevs-len))))
144 (format #f "~v_" (- 32 abbrevs-len usage-len))))
148 (define (read-command repl)
153 ((,subr ,msg ,args . ,rest)
154 (format #t "Throw to key `~a' while reading command:\n" key)
155 (display-error #f (current-output-port) subr msg args rest))
157 (format #t "Throw to key `~a' with args `~s' while reading command.\n"
162 (define (read-command-arguments c repl)
163 ((command-info-arguments-reader (command-info c)) repl))
165 (define (meta-command repl)
166 (let ((command (read-command repl)))
168 ((eq? command *unspecified*)) ; read error, already signalled; pass.
169 ((not (symbol? command))
170 (format #t "Meta-command not a symbol: ~s~%" command))
171 ((lookup-command command)
173 (and=> (read-command-arguments c repl)
174 (lambda (args) (apply (command-procedure c) repl args)))))
176 (format #t "Unknown meta command: ~A~%" command)))))
178 (define (add-meta-command! name category proc argument-reader)
179 (hashq-set! *command-infos* name (make-command-info proc argument-reader))
181 (let ((entry (assq category *command-table*)))
183 (set-cdr! entry (append (cdr entry) (list (list name))))
184 (set! *command-table*
185 (append *command-table*
186 (list (list category (list name)))))))))
188 (define-syntax define-meta-command
190 ((_ ((name category) repl (expression0 ...) . datums) docstring b0 b1 ...)
194 (lambda* (repl expression0 ... . datums)
198 (define (handle-read-error form-name key args)
200 ((,subr ,msg ,args . ,rest)
201 (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
203 (display-error #f (current-output-port) subr msg args rest))
205 (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
206 key args form-name 'name)))
208 (% (let* ((expression0
213 (lambda* (#:optional (port (current-input-port)))
214 ((language-reader (repl-language repl))
215 port (current-module)))))
217 (handle-read-error 'expression0 k args))))
220 (list expression0 ...)
223 (let ((port (open-input-string (read-line))))
225 (let ((x (read port)))
228 (lp (cons x out)))))))
230 (handle-read-error #f k args)))))
231 (lambda (k) #f))))) ; the abort handler
233 ((_ ((name category) repl . datums) docstring b0 b1 ...)
234 (define-meta-command ((name category) repl () . datums)
235 docstring b0 b1 ...))
237 ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
238 (define-meta-command ((name #f) repl (expression0 ...) . datums)
239 docstring b0 b1 ...))
241 ((_ (name repl . datums) docstring b0 b1 ...)
242 (define-meta-command ((name #f) repl () . datums)
243 docstring b0 b1 ...))))
251 (define-meta-command (help repl . args)
252 "help [all | GROUP | [-c] COMMAND]
255 With one argument, tries to look up the argument as a group name, giving
256 help on that group if successful. Otherwise tries to look up the
257 argument as a command, giving help on the command.
259 If there is a command whose name is also a group name, use the ,help
260 -c COMMAND form to give help on the command instead of the group.
262 Without any argument, a list of help commands and command groups
266 (display-group (lookup-group 'help))
267 (display "Command Groups:\n\n")
268 (display-summary "help all" #f "List all commands")
269 (for-each (lambda (g)
270 (let* ((name (symbol->string (group-name g)))
271 (usage (string-append "help " name))
272 (header (string-append "List " name " commands")))
273 (display-summary usage #f header)))
274 (cdr *command-table*))
277 "Type `,help -c COMMAND' to show documentation of a particular command.")
280 (for-each display-group *command-table*))
281 ((,group) (guard (lookup-group group))
282 (display-group (lookup-group group)))
283 ((,command) (guard (lookup-command command))
284 (display-command (lookup-command command)))
285 ((-c ,command) (guard (lookup-command command))
286 (display-command (lookup-command command)))
288 (format #t "Unknown command or group: ~A~%" command))
290 (format #t "Unknown command: ~A~%" command))
292 (format #t "Bad arguments: ~A~%" args))))
294 (define-meta-command (show repl . args)
296 Gives information about Guile.
298 With one argument, tries to show a particular piece of information;
300 currently supported topics are `warranty' (or `w'), `copying' (or `c'),
301 and `version' (or `v').
303 Without any argument, a list of topics is displayed."
306 (display-group (car *show-table*) #f)
308 ((,topic) (guard (lookup-command topic *show-table*))
309 ((command-procedure (lookup-command topic *show-table*)) repl))
311 (format #t "Unknown topic: ~A~%" command))
313 (format #t "Bad arguments: ~A~%" args))))
315 ;;; `warranty', `copying' and `version' are "hidden" meta-commands, only
316 ;;; accessible via `show'. They have an entry in *command-infos* but not
317 ;;; in *command-table*.
319 (define-meta-command (warranty repl)
321 Details on the lack of warranty."
325 (define-meta-command (copying repl)
331 (define-meta-command (version repl)
333 Version information."
337 (define-meta-command (apropos repl regexp)
339 Find bindings/modules/packages."
340 (apropos (->string regexp)))
342 (define-meta-command (describe repl (form))
344 Show description/documentation."
346 (object-documentation
347 (let ((input (repl-parse repl form)))
349 (module-ref (current-module) input)
350 (repl-eval repl input)))))
353 (define-meta-command (option repl . args)
355 List/show/set options."
358 (for-each (lambda (spec)
359 (format #t " ~A~24t~A\n" (car spec) (cadr spec)))
360 (repl-options repl)))
362 (display (repl-option-ref repl name))
365 ;; Would be nice to evaluate in the current language, but the REPL
366 ;; option parser doesn't permit that, currently.
367 (repl-option-set! repl name (eval exp (current-module))))))
369 (define-meta-command (quit repl)
379 (define-meta-command (module repl . args)
381 Change modules / Show current module."
383 (() (puts (module-name (current-module))))
384 ((,mod-name) (guard (list? mod-name))
385 (set-current-module (resolve-module mod-name)))
386 (,mod-name (set-current-module (resolve-module mod-name)))))
388 (define-meta-command (import repl . args)
390 Import modules / List those imported."
393 (let ((mod (resolve-interface name)))
395 (module-use! (current-module) mod)
396 (format #t "No such module: ~A~%" name))))
398 (for-each puts (map module-name (module-uses (current-module))))
399 (for-each use args))))
401 (define-meta-command (load repl file)
403 Load a file in the current module."
404 (load (->string file)))
406 (define-meta-command (reload repl . args)
408 Reload the given module, or the current module if none was given."
410 (() (reload-module (current-module)))
411 ((,mod-name) (guard (list? mod-name))
412 (reload-module (resolve-module mod-name)))
413 (,mod-name (reload-module (resolve-module mod-name)))))
415 (define-meta-command (binding repl)
417 List current bindings."
418 (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
421 (define-meta-command (in repl module command-or-expression . args)
422 "in MODULE COMMAND-OR-EXPRESSION
423 Evaluate an expression or command in the context of module."
424 (let ((m (resolve-module module #:ensure #f)))
426 (pmatch command-or-expression
427 (('unquote ,command) (guard (lookup-command command))
428 (save-module-excursion
430 (set-current-module m)
431 (apply (command-procedure (lookup-command command)) repl args))))
434 (repl-print repl (eval expression m)))
436 (format #t "Invalid arguments to `in': expected a single expression or a command.\n")))
437 (format #t "No such module: ~s\n" module))))
441 ;;; Language commands
444 (define-meta-command (language repl name)
447 (let ((lang (lookup-language name))
448 (cur (repl-language repl)))
449 (format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n"
450 (language-title lang) (language-name cur))
451 (current-language lang)
452 (set! (repl-language repl) lang)))
459 (define-meta-command (compile repl (form))
461 Generate compiled code."
462 (let ((x (repl-compile repl (repl-parse repl form))))
463 (cond ((objcode? x) (guile:disassemble x))
464 (else (repl-print repl x)))))
466 (define-meta-command (compile-file repl file . opts)
469 (compile-file (->string file) #:opts opts))
471 (define-meta-command (expand repl (form))
473 Expand any macros in a form."
474 (let ((x (repl-expand repl (repl-parse repl form))))
475 (run-hook before-print-hook x)
478 (define-meta-command (optimize repl (form))
480 Run the optimizer on a piece of code and print the result."
481 (let ((x (repl-optimize repl (repl-parse repl form))))
482 (run-hook before-print-hook x)
485 (define (guile:disassemble x)
486 ((@ (language assembly disassemble) disassemble) x))
488 (define-meta-command (disassemble repl (form))
490 Disassemble a compiled procedure."
491 (let ((obj (repl-eval repl (repl-parse repl form))))
492 (if (or (program? obj) (objcode? obj))
493 (guile:disassemble obj)
494 (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
497 (define-meta-command (disassemble-file repl file)
498 "disassemble-file FILE
500 (guile:disassemble (load-thunk-from-file (->string file))))
507 (define-meta-command (time repl (form))
510 (let* ((gc-start (gc-run-time))
511 (real-start (get-internal-real-time))
512 (run-start (get-internal-run-time))
513 (result (repl-eval repl (repl-parse repl form)))
514 (run-end (get-internal-run-time))
515 (real-end (get-internal-real-time))
516 (gc-end (gc-run-time)))
517 (define (diff start end)
518 (/ (- end start) 1.0 internal-time-units-per-second))
519 (repl-print repl result)
520 (format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n"
521 (diff real-start real-end)
522 (diff run-start run-end)
523 (diff gc-start gc-end))
526 (define-meta-command (profile repl (form) . opts)
531 (repl-prepare-eval-thunk repl (repl-parse repl form))
534 (define-meta-command (trace repl (form) . opts)
537 ;; FIXME: doc options, or somehow deal with them better
538 (apply call-with-trace
539 (repl-prepare-eval-thunk repl (repl-parse repl form))
540 (cons* #:width (terminal-width) opts)))
547 (define-syntax define-stack-command
550 ((_ (name repl . args) docstring body body* ...)
551 #`(define-meta-command (name repl . args)
553 (let ((debug (repl-debug repl)))
556 ((#,(datum->syntax #'repl 'frames)
557 (identifier-syntax (debug-frames debug)))
558 (#,(datum->syntax #'repl 'message)
559 (identifier-syntax (debug-error-message debug)))
560 (#,(datum->syntax #'repl 'for-trap?)
561 (identifier-syntax (debug-for-trap? debug)))
562 (#,(datum->syntax #'repl 'index)
564 (id (debug-index debug))
565 ((set! id exp) (set! (debug-index debug) exp))))
566 (#,(datum->syntax #'repl 'cur)
568 (vector-ref #,(datum->syntax #'repl 'frames)
569 #,(datum->syntax #'repl 'index)))))
571 (format #t "Nothing to debug.~%"))))))))
573 (define-stack-command (backtrace repl #:optional count
574 #:key (width (terminal-width)) full?)
575 "backtrace [COUNT] [#:width W] [#:full? F]
578 Print a backtrace of all stack frames, or innermost COUNT frames.
579 If COUNT is negative, the last COUNT frames will be shown."
584 #:for-trap? for-trap?))
586 (define-stack-command (up repl #:optional (count 1))
588 Select a calling stack frame.
590 Select and print stack frames that called this one.
591 An argument says how many frames up to go."
593 ((or (not (integer? count)) (<= count 0))
594 (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
595 ((>= (+ count index) (vector-length frames))
597 ((= index (1- (vector-length frames)))
598 (format #t "Already at outermost frame.\n"))
600 (set! index (1- (vector-length frames)))
601 (print-frame cur #:index index
602 #:next-source? (and (zero? index) for-trap?)))))
604 (set! index (+ count index))
605 (print-frame cur #:index index
606 #:next-source? (and (zero? index) for-trap?)))))
608 (define-stack-command (down repl #:optional (count 1))
610 Select a called stack frame.
612 Select and print stack frames called by this one.
613 An argument says how many frames down to go."
615 ((or (not (integer? count)) (<= count 0))
616 (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
617 ((< (- index count) 0)
620 (format #t "Already at innermost frame.\n"))
623 (print-frame cur #:index index #:next-source? for-trap?))))
625 (set! index (- index count))
626 (print-frame cur #:index index
627 #:next-source? (and (zero? index) for-trap?)))))
629 (define-stack-command (frame repl #:optional idx)
633 Show the selected frame.
634 With an argument, select a frame by index, then show it."
638 ((or (not (integer? idx)) (< idx 0))
639 (format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
640 ((< idx (vector-length frames))
642 (print-frame cur #:index index
643 #:next-source? (and (zero? index) for-trap?)))
645 (format #t "No such frame.~%"))))
646 (else (print-frame cur #:index index
647 #:next-source? (and (zero? index) for-trap?)))))
649 (define-stack-command (procedure repl)
651 Print the procedure for the selected frame."
652 (repl-print repl (frame-procedure cur)))
654 (define-stack-command (locals repl #:key (width (terminal-width)))
656 Show local variables.
658 Show locally-bound variables in the selected frame."
659 (print-locals cur #:width width))
661 (define-stack-command (error-message repl)
665 Display the message associated with the error that started the current
667 (format #t "~a~%" (if (string? message) message "No error message")))
669 (define-meta-command (break repl (form))
671 Break on calls to PROCEDURE.
673 Starts a recursive prompt when PROCEDURE is called."
674 (let ((proc (repl-eval repl (repl-parse repl form))))
675 (if (not (procedure? proc))
676 (error "Not a procedure: ~a" proc)
677 (let ((idx (add-trap-at-procedure-call! proc)))
678 (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))))
680 (define-meta-command (break-at-source repl file line)
681 "break-at-source FILE LINE
682 Break when control reaches the given source location.
684 Starts a recursive prompt when control reaches line LINE of file FILE.
685 Note that the given source location must be inside a procedure."
686 (let ((file (if (symbol? file) (symbol->string file) file)))
687 (let ((idx (add-trap-at-source-location! file line)))
688 (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))
690 (define (repl-pop-continuation-resumer repl msg)
691 ;; Capture the dynamic environment with this prompt thing. The
692 ;; result is a procedure that takes a frame.
697 ;; Call frame->stack-vector before reinstating the
698 ;; continuation, so that we catch the %stacks fluid at
699 ;; the time of capture.
703 (frame-previous frame)))))))
705 (format #t "~a~%" msg)
706 (let ((vals (frame-return-values from)))
708 (format #t "No return values.~%")
710 (format #t "Return values:~%")
711 (for-each (lambda (x) (repl-print repl x)) vals))))
712 ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
713 #:debug (make-debug stack 0 msg #t))))))
715 (define-stack-command (finish repl)
717 Run until the current frame finishes.
719 Resume execution, breaking when the current frame finishes."
720 (let ((handler (repl-pop-continuation-resumer
721 repl (format #f "Return from ~a" cur))))
722 (add-ephemeral-trap-at-frame-finish! cur handler)
725 (define (repl-next-resumer msg)
726 ;; Capture the dynamic environment with this prompt thing. The
727 ;; result is a procedure that takes a frame.
728 (% (let ((stack (abort
730 ;; Call frame->stack-vector before reinstating the
731 ;; continuation, so that we catch the %stacks fluid
732 ;; at the time of capture.
734 (k (frame->stack-vector frame)))))))
735 (format #t "~a~%" msg)
736 ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
737 #:debug (make-debug stack 0 msg #t)))))
739 (define-stack-command (step repl)
741 Step until control reaches a different source location.
743 Step until control reaches a different source location."
744 (let ((msg (format #f "Step into ~a" cur)))
745 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
746 #:into? #t #:instruction? #f)
749 (define-stack-command (step-instruction repl)
751 Step until control reaches a different instruction.
753 Step until control reaches a different VM instruction."
754 (let ((msg (format #f "Step into ~a" cur)))
755 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
756 #:into? #t #:instruction? #t)
759 (define-stack-command (next repl)
761 Step until control reaches a different source location in the current frame.
763 Step until control reaches a different source location in the current frame."
764 (let ((msg (format #f "Step into ~a" cur)))
765 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
766 #:into? #f #:instruction? #f)
769 (define-stack-command (next-instruction repl)
771 Step until control reaches a different instruction in the current frame.
773 Step until control reaches a different VM instruction in the current frame."
774 (let ((msg (format #f "Step into ~a" cur)))
775 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
776 #:into? #f #:instruction? #t)
779 (define-meta-command (tracepoint repl (form))
780 "tracepoint PROCEDURE
781 Add a tracepoint to PROCEDURE.
783 A tracepoint will print out the procedure and its arguments, when it is
784 called, and its return value(s) when it returns."
785 (let ((proc (repl-eval repl (repl-parse repl form))))
786 (if (not (procedure? proc))
787 (error "Not a procedure: ~a" proc)
788 (let ((idx (add-trace-at-procedure-call! proc)))
789 (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))))
791 (define-meta-command (traps repl)
793 Show the set of currently attached traps.
795 Show the set of currently attached traps (breakpoints and tracepoints)."
796 (let ((traps (list-traps)))
798 (format #t "No traps set.~%")
799 (for-each (lambda (idx)
800 (format #t " ~a: ~a~a~%"
802 (if (trap-enabled? idx) "" " (disabled)")))
805 (define-meta-command (delete repl idx)
810 (if (not (integer? idx))
811 (error "expected a trap index (a non-negative integer)" idx)
814 (define-meta-command (disable repl idx)
819 (if (not (integer? idx))
820 (error "expected a trap index (a non-negative integer)" idx)
821 (disable-trap! idx)))
823 (define-meta-command (enable repl idx)
828 (if (not (integer? idx))
829 (error "expected a trap index (a non-negative integer)" idx)
832 (define-stack-command (registers repl)
836 Print the registers of the current frame."
837 (print-registers cur))
839 (define-meta-command (width repl #:optional x)
841 Set debug output width.
843 Set the number of screen columns in the output from `backtrace' and
846 (format #t "Set screen width to ~a columns.~%" (terminal-width)))
851 ;;; Inspection commands
854 (define-meta-command (inspect repl (form))
856 Inspect the result(s) of evaluating EXP."
857 (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
859 (for-each %inspect args))))
861 (define-meta-command (pretty-print repl (form))
863 Pretty-print the result(s) of evaluating EXP."
864 (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
868 (run-hook before-print-hook x)
877 (define-meta-command (gc repl)
882 (define-meta-command (statistics repl)
885 (let ((this-tms (times))
886 (this-gcs (gc-stats))
887 (last-tms (repl-tm-stats repl))
888 (last-gcs (repl-gc-stats repl)))
890 (let ((this-times (assq-ref this-gcs 'gc-times))
891 (last-times (assq-ref last-gcs 'gc-times)))
892 (display-diff-stat "GC times:" #t this-times last-times "times")
895 (let ((this-heap (assq-ref this-gcs 'heap-size))
896 (this-free (assq-ref this-gcs 'heap-free-size)))
897 (display-stat-title "Memory size:" "current" "limit")
898 (display-stat "heap" #f (- this-heap this-free) this-heap "bytes")
901 (let ((this-alloc (assq-ref this-gcs 'heap-total-allocated))
902 (last-alloc (assq-ref last-gcs 'heap-total-allocated)))
903 (display-stat-title "Bytes allocated:" "diff" "total")
904 (display-diff-stat "allocated" #f this-alloc last-alloc "bytes")
907 (let ((this-total (assq-ref this-gcs 'gc-time-taken))
908 (last-total (assq-ref last-gcs 'gc-time-taken)))
909 (display-stat-title "GC time taken:" "diff" "total")
910 (display-time-stat "total" this-total last-total)
912 ;; Process time spent
913 (let ((this-utime (tms:utime this-tms))
914 (last-utime (tms:utime last-tms))
915 (this-stime (tms:stime this-tms))
916 (last-stime (tms:stime last-tms))
917 (this-cutime (tms:cutime this-tms))
918 (last-cutime (tms:cutime last-tms))
919 (this-cstime (tms:cstime this-tms))
920 (last-cstime (tms:cstime last-tms)))
921 (display-stat-title "Process time spent:" "diff" "total")
922 (display-time-stat "user" this-utime last-utime)
923 (display-time-stat "system" this-stime last-stime)
924 (display-time-stat "child user" this-cutime last-cutime)
925 (display-time-stat "child system" this-cstime last-cstime)
929 (set! (repl-tm-stats repl) this-tms)
930 (set! (repl-gc-stats repl) this-gcs)))
932 (define (display-stat title flag field1 field2 unit)
933 (let ((fmt (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
934 (format #t fmt title field1 field2 unit)))
936 (define (display-stat-title title field1 field2)
937 (display-stat title #t field1 field2 ""))
939 (define (display-diff-stat title flag this last unit)
940 (display-stat title flag (- this last) this unit))
942 (define (display-time-stat title this last)
944 (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second))))
945 (display-stat title #f (conv (- this last)) (conv this) "s"))
947 (define (display-mips-stat title this-time this-clock last-time last-clock)
948 (define (mips time clock)
949 (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0))))
950 (display-stat title #f
951 (mips (- this-time last-time) (- this-clock last-clock))
952 (mips this-time this-clock) "mips"))