1;;; Repl commands 2 3;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2020 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 disassembler) 29 #:use-module (system vm loader) 30 #:use-module (system vm program) 31 #:use-module (system vm trap-state) 32 #:use-module (system vm vm) 33 #:autoload (system base language) (lookup-language language-reader 34 language-title language-name) 35 #:autoload (system vm trace) (call-with-trace) 36 #:use-module (ice-9 format) 37 #:use-module (ice-9 session) 38 #:use-module (ice-9 documentation) 39 #:use-module (ice-9 and-let-star) 40 #:use-module (ice-9 rdelim) 41 #:use-module (ice-9 control) 42 #:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp))) 43 #:use-module ((system vm inspect) #:select ((inspect . %inspect))) 44 #:use-module (rnrs bytevectors) 45 #:use-module (statprof) 46 #:export (meta-command define-meta-command)) 47 48 49;;; 50;;; Meta command interface 51;;; 52 53(define *command-table* 54 '((help (help h) (show) (apropos a) (describe d)) 55 (module (module m) (import use) (load l) (reload re) (binding b) (in)) 56 (language (language L)) 57 (compile (compile c) (compile-file cc) 58 (expand exp) (optimize opt) 59 (disassemble x) (disassemble-file xx)) 60 (profile (time t) (profile pr) (trace tr)) 61 (debug (backtrace bt) (up) (down) (frame fr) 62 (locals) (error-message error) 63 (break br bp) (break-at-source break-at bs) 64 (step s) (step-instruction si) 65 (next n) (next-instruction ni) 66 (finish) 67 (tracepoint tp) 68 (traps) (delete del) (disable) (enable) 69 (registers regs)) 70 (inspect (inspect i) (pretty-print pp)) 71 (system (gc) (statistics stat) (option o) 72 (quit q continue cont)))) 73 74(define *show-table* 75 '((show (warranty w) (copying c) (version v)))) 76 77(define (group-name g) (car g)) 78(define (group-commands g) (cdr g)) 79 80(define *command-infos* (make-hash-table)) 81(define (command-name c) (car c)) 82(define (command-abbrevs c) (cdr c)) 83(define (command-info c) (hashq-ref *command-infos* (command-name c))) 84(define (command-procedure c) (command-info-procedure (command-info c))) 85(define (command-doc c) (procedure-documentation (command-procedure c))) 86 87(define (make-command-info proc arguments-reader) 88 (cons proc arguments-reader)) 89 90(define (command-info-procedure info) 91 (car info)) 92 93(define (command-info-arguments-reader info) 94 (cdr info)) 95 96(define (command-usage c) 97 (let ((doc (command-doc c))) 98 (substring doc 0 (string-index doc #\newline)))) 99 100(define (command-summary c) 101 (let* ((doc (command-doc c)) 102 (start (1+ (string-index doc #\newline)))) 103 (cond ((string-index doc #\newline start) 104 => (lambda (end) (substring doc start end))) 105 (else (substring doc start))))) 106 107(define (lookup-group name) 108 (assq name *command-table*)) 109 110(define* (lookup-command key #:optional (table *command-table*)) 111 (let loop ((groups table) (commands '())) 112 (cond ((and (null? groups) (null? commands)) #f) 113 ((null? commands) 114 (loop (cdr groups) (cdar groups))) 115 ((memq key (car commands)) (car commands)) 116 (else (loop groups (cdr commands)))))) 117 118(define* (display-group group #:optional (abbrev? #t)) 119 (format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?) 120 (for-each (lambda (c) 121 (display-summary (command-usage c) 122 (if abbrev? (command-abbrevs c) '()) 123 (command-summary c))) 124 (group-commands group)) 125 (newline)) 126 127(define (display-command command) 128 (display "Usage: ") 129 (display (command-doc command)) 130 (newline)) 131 132(define (display-summary usage abbrevs summary) 133 (let* ((usage-len (string-length usage)) 134 (abbrevs (if (pair? abbrevs) 135 (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs)) 136 "")) 137 (abbrevs-len (string-length abbrevs))) 138 (format #t " ,~A~A~A - ~A\n" 139 usage 140 (cond 141 ((> abbrevs-len 32) 142 (error "abbrevs too long" abbrevs)) 143 ((> (+ usage-len abbrevs-len) 32) 144 (format #f "~%~v_" (+ 2 (- 32 abbrevs-len)))) 145 (else 146 (format #f "~v_" (- 32 abbrevs-len usage-len)))) 147 abbrevs 148 summary))) 149 150(define (read-command repl) 151 (catch #t 152 (lambda () (read)) 153 (lambda (key . args) 154 (pmatch args 155 ((,subr ,msg ,args . ,rest) 156 (format #t "Throw to key `~a' while reading command:\n" key) 157 (display-error #f (current-output-port) subr msg args rest)) 158 (else 159 (format #t "Throw to key `~a' with args `~s' while reading command.\n" 160 key args))) 161 (force-output) 162 *unspecified*))) 163 164(define (read-command-arguments c repl) 165 ((command-info-arguments-reader (command-info c)) repl)) 166 167(define (meta-command repl) 168 (let ((command (read-command repl))) 169 (cond 170 ((eq? command *unspecified*)) ; read error, already signalled; pass. 171 ((not (symbol? command)) 172 (format #t "Meta-command not a symbol: ~s~%" command)) 173 ((lookup-command command) 174 => (lambda (c) 175 (and=> (read-command-arguments c repl) 176 (lambda (args) (apply (command-procedure c) repl args))))) 177 (else 178 (format #t "Unknown meta command: ~A~%" command))))) 179 180(define (add-meta-command! name category proc argument-reader) 181 (hashq-set! *command-infos* name (make-command-info proc argument-reader)) 182 (if category 183 (let ((entry (assq category *command-table*))) 184 (if entry 185 (set-cdr! entry (append (cdr entry) (list (list name)))) 186 (set! *command-table* 187 (append *command-table* 188 (list (list category (list name))))))))) 189 190(define-syntax define-meta-command 191 (syntax-rules () 192 ((_ ((name category) repl (expression0 ...) . datums) docstring b0 b1 ...) 193 (add-meta-command! 194 'name 195 'category 196 (lambda* (repl expression0 ... . datums) 197 docstring 198 b0 b1 ...) 199 (lambda (repl) 200 (define (handle-read-error form-name key args) 201 (pmatch args 202 ((,subr ,msg ,args . ,rest) 203 (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n" 204 key form-name 'name) 205 (display-error #f (current-output-port) subr msg args rest)) 206 (else 207 (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n" 208 key args form-name 'name))) 209 (abort)) 210 (% (let* ((expression0 211 (catch #t 212 (lambda () 213 (repl-reader 214 "" 215 (lambda* (#:optional (port (current-input-port))) 216 ((language-reader (repl-language repl)) 217 port (current-module))))) 218 (lambda (k . args) 219 (handle-read-error 'expression0 k args)))) 220 ...) 221 (append 222 (list expression0 ...) 223 (catch #t 224 (lambda () 225 (let ((port (open-input-string (read-line)))) 226 (let lp ((out '())) 227 (let ((x (read port))) 228 (if (eof-object? x) 229 (reverse out) 230 (lp (cons x out))))))) 231 (lambda (k . args) 232 (handle-read-error #f k args))))) 233 (lambda (k) #f))))) ; the abort handler 234 235 ((_ ((name category) repl . datums) docstring b0 b1 ...) 236 (define-meta-command ((name category) repl () . datums) 237 docstring b0 b1 ...)) 238 239 ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...) 240 (define-meta-command ((name #f) repl (expression0 ...) . datums) 241 docstring b0 b1 ...)) 242 243 ((_ (name repl . datums) docstring b0 b1 ...) 244 (define-meta-command ((name #f) repl () . datums) 245 docstring b0 b1 ...)))) 246 247 248 249;;; 250;;; Help commands 251;;; 252 253(define-meta-command (help repl . args) 254 "help [all | GROUP | [-c] COMMAND] 255Show help. 256 257With one argument, tries to look up the argument as a group name, giving 258help on that group if successful. Otherwise tries to look up the 259argument as a command, giving help on the command. 260 261If there is a command whose name is also a group name, use the ,help 262-c COMMAND form to give help on the command instead of the group. 263 264Without any argument, a list of help commands and command groups 265are displayed." 266 (pmatch args 267 (() 268 (display-group (lookup-group 'help)) 269 (display "Command Groups:\n\n") 270 (display-summary "help all" #f "List all commands") 271 (for-each (lambda (g) 272 (let* ((name (symbol->string (group-name g))) 273 (usage (string-append "help " name)) 274 (header (string-append "List " name " commands"))) 275 (display-summary usage #f header))) 276 (cdr *command-table*)) 277 (newline) 278 (display 279 "Type `,help -c COMMAND' to show documentation of a particular command.") 280 (newline)) 281 ((all) 282 (for-each display-group *command-table*)) 283 ((,group) (guard (lookup-group group)) 284 (display-group (lookup-group group))) 285 ((,command) (guard (lookup-command command)) 286 (display-command (lookup-command command))) 287 ((-c ,command) (guard (lookup-command command)) 288 (display-command (lookup-command command))) 289 ((,command) 290 (format #t "Unknown command or group: ~A~%" command)) 291 ((-c ,command) 292 (format #t "Unknown command: ~A~%" command)) 293 (else 294 (format #t "Bad arguments: ~A~%" args)))) 295 296(define-meta-command (show repl . args) 297 "show [TOPIC] 298Gives information about Guile. 299 300With one argument, tries to show a particular piece of information; 301 302currently supported topics are `warranty' (or `w'), `copying' (or `c'), 303and `version' (or `v'). 304 305Without any argument, a list of topics is displayed." 306 (pmatch args 307 (() 308 (display-group (car *show-table*) #f) 309 (newline)) 310 ((,topic) (guard (lookup-command topic *show-table*)) 311 ((command-procedure (lookup-command topic *show-table*)) repl)) 312 ((,command) 313 (format #t "Unknown topic: ~A~%" command)) 314 (else 315 (format #t "Bad arguments: ~A~%" args)))) 316 317;;; `warranty', `copying' and `version' are "hidden" meta-commands, only 318;;; accessible via `show'. They have an entry in *command-infos* but not 319;;; in *command-table*. 320 321(define-meta-command (warranty repl) 322 "show warranty 323Details on the lack of warranty." 324 (display *warranty*) 325 (newline)) 326 327(define-meta-command (copying repl) 328 "show copying 329Show the LGPLv3." 330 (display *copying*) 331 (newline)) 332 333(define-meta-command (version repl) 334 "show version 335Version information." 336 (display *version*) 337 (newline)) 338 339(define-meta-command (apropos repl regexp) 340 "apropos REGEXP 341Find bindings/modules/packages." 342 (apropos (->string regexp))) 343 344(define-meta-command (describe repl (form)) 345 "describe OBJ 346Show description/documentation." 347 (display 348 (object-documentation 349 (let ((input (repl-parse repl form))) 350 (if (symbol? input) 351 (module-ref (current-module) input) 352 (repl-eval repl input))))) 353 (newline)) 354 355(define-meta-command (option repl . args) 356 "option [NAME] [EXP] 357List/show/set options." 358 (pmatch args 359 (() 360 (for-each (lambda (spec) 361 (format #t " ~A~24t~A\n" (car spec) (cadr spec))) 362 (repl-options repl))) 363 ((,name) 364 (display (repl-option-ref repl name)) 365 (newline)) 366 ((,name ,exp) 367 ;; Would be nice to evaluate in the current language, but the REPL 368 ;; option parser doesn't permit that, currently. 369 (repl-option-set! repl name (eval exp (current-module)))))) 370 371(define-meta-command (quit repl) 372 "quit 373Quit this session." 374 (throw 'quit)) 375 376 377;;; 378;;; Module commands 379;;; 380 381(define-meta-command (module repl . args) 382 "module [MODULE] 383Change modules / Show current module." 384 (pmatch args 385 (() (puts (module-name (current-module)))) 386 ((,mod-name) (guard (list? mod-name)) 387 (set-current-module (resolve-module mod-name))) 388 (,mod-name (set-current-module (resolve-module mod-name))))) 389 390(define-meta-command (import repl . args) 391 "import [MODULE ...] 392Import modules / List those imported." 393 (let () 394 (define (use name) 395 (let ((mod (resolve-interface name))) 396 (if mod 397 (module-use! (current-module) mod) 398 (format #t "No such module: ~A~%" name)))) 399 (if (null? args) 400 (for-each puts (map module-name (module-uses (current-module)))) 401 (for-each use args)))) 402 403(define-meta-command (load repl file) 404 "load FILE 405Load a file in the current module." 406 (load (->string file))) 407 408(define-meta-command (reload repl . args) 409 "reload [MODULE] 410Reload the given module, or the current module if none was given." 411 (pmatch args 412 (() (reload-module (current-module))) 413 ((,mod-name) (guard (list? mod-name)) 414 (reload-module (resolve-module mod-name))) 415 (,mod-name (reload-module (resolve-module mod-name))))) 416 417(define-meta-command (binding repl) 418 "binding 419List current bindings." 420 (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v)) 421 (current-module))) 422 423(define-meta-command (in repl module command-or-expression . args) 424 "in MODULE COMMAND-OR-EXPRESSION 425Evaluate an expression or command in the context of module." 426 (let ((m (resolve-module module #:ensure #f))) 427 (if m 428 (pmatch command-or-expression 429 (('unquote ,command) (guard (lookup-command command)) 430 (save-module-excursion 431 (lambda () 432 (set-current-module m) 433 (apply (command-procedure (lookup-command command)) repl args)))) 434 (,expression 435 (guard (null? args)) 436 (repl-print repl (eval expression m))) 437 (else 438 (format #t "Invalid arguments to `in': expected a single expression or a command.\n"))) 439 (format #t "No such module: ~s\n" module)))) 440 441 442;;; 443;;; Language commands 444;;; 445 446(define-meta-command (language repl name) 447 "language LANGUAGE 448Change languages." 449 (let ((lang (lookup-language name)) 450 (cur (repl-language repl))) 451 (format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n" 452 (language-title lang) (language-name cur)) 453 (current-language lang) 454 (set! (repl-language repl) lang))) 455 456 457;;; 458;;; Compile commands 459;;; 460 461(define (load-image x) 462 (let ((thunk (load-thunk-from-memory x))) 463 (find-mapped-elf-image (program-code thunk)))) 464 465(define-meta-command (compile repl (form)) 466 "compile EXP 467Generate compiled code." 468 (let ((x (repl-compile repl (repl-parse repl form)))) 469 (cond ((bytevector? x) (disassemble-image (load-image x))) 470 (else (repl-print repl x))))) 471 472(define-meta-command (compile-file repl file . opts) 473 "compile-file FILE 474Compile a file." 475 (compile-file (->string file) #:opts opts)) 476 477(define-meta-command (expand repl (form)) 478 "expand EXP 479Expand any macros in a form." 480 (let ((x (repl-expand repl (repl-parse repl form)))) 481 (run-hook before-print-hook x) 482 (pp x))) 483 484(define-meta-command (optimize repl (form)) 485 "optimize EXP 486Run the optimizer on a piece of code and print the result." 487 (let ((x (repl-optimize repl (repl-parse repl form)))) 488 (run-hook before-print-hook x) 489 (pp x))) 490 491(define-meta-command (disassemble repl (form)) 492 "disassemble EXP 493Disassemble a compiled procedure." 494 (let ((obj (repl-eval repl (repl-parse repl form)))) 495 (cond 496 ((program? obj) 497 (disassemble-program obj)) 498 ((bytevector? obj) 499 (disassemble-image (load-image obj))) 500 (else 501 (format #t 502 "Argument to ,disassemble not a procedure or a bytevector: ~a~%" 503 obj))))) 504 505(define-meta-command (disassemble-file repl file) 506 "disassemble-file FILE 507Disassemble a file." 508 (disassemble-file (->string file))) 509 510 511;;; 512;;; Profile commands 513;;; 514 515(define-meta-command (time repl (form)) 516 "time EXP 517Time execution." 518 (let* ((gc-start (gc-run-time)) 519 (real-start (get-internal-real-time)) 520 (run-start (get-internal-run-time)) 521 (result (repl-eval repl (repl-parse repl form))) 522 (run-end (get-internal-run-time)) 523 (real-end (get-internal-real-time)) 524 (gc-end (gc-run-time))) 525 (define (diff start end) 526 (/ (- end start) 1.0 internal-time-units-per-second)) 527 (repl-print repl result) 528 (format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n" 529 (diff real-start real-end) 530 (diff run-start run-end) 531 (diff gc-start gc-end)) 532 result)) 533 534(define-meta-command (profile repl (form) . opts) 535 "profile EXP 536Profile execution." 537 ;; FIXME opts 538 (apply statprof 539 (repl-prepare-eval-thunk repl (repl-parse repl form)) 540 opts)) 541 542(define-meta-command (trace repl (form) . opts) 543 "trace EXP 544Trace execution." 545 ;; FIXME: doc options, or somehow deal with them better 546 (apply call-with-trace 547 (repl-prepare-eval-thunk repl (repl-parse repl form)) 548 (cons* #:width (terminal-width) opts))) 549 550 551;;; 552;;; Debug commands 553;;; 554 555(define-syntax define-stack-command 556 (lambda (x) 557 (syntax-case x () 558 ((_ (name repl . args) docstring body body* ...) 559 #`(define-meta-command (name repl . args) 560 docstring 561 (let ((debug (repl-debug repl))) 562 (if debug 563 (letrec-syntax 564 ((#,(datum->syntax #'repl 'frames) 565 (identifier-syntax (debug-frames debug))) 566 (#,(datum->syntax #'repl 'message) 567 (identifier-syntax (debug-error-message debug))) 568 (#,(datum->syntax #'repl 'index) 569 (identifier-syntax 570 (id (debug-index debug)) 571 ((set! id exp) (set! (debug-index debug) exp)))) 572 (#,(datum->syntax #'repl 'cur) 573 (identifier-syntax 574 (vector-ref #,(datum->syntax #'repl 'frames) 575 #,(datum->syntax #'repl 'index))))) 576 body body* ...) 577 (format #t "Nothing to debug.~%")))))))) 578 579(define-stack-command (backtrace repl #:optional count 580 #:key (width (terminal-width)) full?) 581 "backtrace [COUNT] [#:width W] [#:full? F] 582Print a backtrace. 583 584Print a backtrace of all stack frames, or innermost COUNT frames. 585If COUNT is negative, the last COUNT frames will be shown." 586 (print-frames frames 587 #:count count 588 #:width width 589 #:full? full?)) 590 591(define-stack-command (up repl #:optional (count 1)) 592 "up [COUNT] 593Select a calling stack frame. 594 595Select and print stack frames that called this one. 596An argument says how many frames up to go." 597 (cond 598 ((or (not (integer? count)) (<= count 0)) 599 (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%")) 600 ((>= (+ count index) (vector-length frames)) 601 (cond 602 ((= index (1- (vector-length frames))) 603 (format #t "Already at outermost frame.\n")) 604 (else 605 (set! index (1- (vector-length frames))) 606 (print-frame cur #:index index)))) 607 (else 608 (set! index (+ count index)) 609 (print-frame cur #:index index)))) 610 611(define-stack-command (down repl #:optional (count 1)) 612 "down [COUNT] 613Select a called stack frame. 614 615Select and print stack frames called by this one. 616An argument says how many frames down to go." 617 (cond 618 ((or (not (integer? count)) (<= count 0)) 619 (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%")) 620 ((< (- index count) 0) 621 (cond 622 ((zero? index) 623 (format #t "Already at innermost frame.\n")) 624 (else 625 (set! index 0) 626 (print-frame cur #:index index)))) 627 (else 628 (set! index (- index count)) 629 (print-frame cur #:index index)))) 630 631(define-stack-command (frame repl #:optional idx) 632 "frame [IDX] 633Show a frame. 634 635Show the selected frame. 636With an argument, select a frame by index, then show it." 637 (cond 638 (idx 639 (cond 640 ((or (not (integer? idx)) (< idx 0)) 641 (format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%")) 642 ((< idx (vector-length frames)) 643 (set! index idx) 644 (print-frame cur #:index index)) 645 (else 646 (format #t "No such frame.~%")))) 647 (else (print-frame cur #:index index)))) 648 649(define-stack-command (locals repl #:key (width (terminal-width))) 650 "locals 651Show local variables. 652 653Show locally-bound variables in the selected frame." 654 (print-locals cur #:width width)) 655 656(define-stack-command (error-message repl) 657 "error-message 658Show error message. 659 660Display the message associated with the error that started the current 661debugging REPL." 662 (format #t "~a~%" (if (string? message) message "No error message"))) 663 664(define-meta-command (break repl (form)) 665 "break PROCEDURE 666Break on calls to PROCEDURE. 667 668Starts a recursive prompt when PROCEDURE is called." 669 (let ((proc (repl-eval repl (repl-parse repl form)))) 670 (if (not (procedure? proc)) 671 (error "Not a procedure: ~a" proc) 672 (let ((idx (add-trap-at-procedure-call! proc))) 673 (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))) 674 675(define-meta-command (break-at-source repl file line) 676 "break-at-source FILE LINE 677Break when control reaches the given source location. 678 679Starts a recursive prompt when control reaches line LINE of file FILE. 680Note that the given source location must be inside a procedure." 681 (let ((file (if (symbol? file) (symbol->string file) file))) 682 (let ((idx (add-trap-at-source-location! file line))) 683 (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))) 684 685(define (repl-pop-continuation-resumer repl msg) 686 ;; Capture the dynamic environment with this prompt thing. The result 687 ;; is a procedure that takes a frame and number of values returned. 688 (% (call-with-values 689 (lambda () 690 (abort 691 (lambda (k) 692 ;; Call frame->stack-vector before reinstating the 693 ;; continuation, so that we catch the %stacks fluid at 694 ;; the time of capture. 695 (lambda (frame . values) 696 (k frame 697 (frame->stack-vector 698 (frame-previous frame)) 699 values))))) 700 (lambda (from stack values) 701 (format #t "~a~%" msg) 702 (if (null? values) 703 (format #t "No return values.~%") 704 (begin 705 (format #t "Return values:~%") 706 (for-each (lambda (x) (repl-print repl x)) values))) 707 ((module-ref (resolve-interface '(system repl repl)) 'start-repl) 708 #:debug (make-debug stack 0 msg)))))) 709 710(define-stack-command (finish repl) 711 "finish 712Run until the current frame finishes. 713 714Resume execution, breaking when the current frame finishes." 715 (let ((handler (repl-pop-continuation-resumer 716 repl (format #f "Return from ~a" cur)))) 717 (add-ephemeral-trap-at-frame-finish! cur handler) 718 (throw 'quit))) 719 720(define (repl-next-resumer msg) 721 ;; Capture the dynamic environment with this prompt thing. The 722 ;; result is a procedure that takes a frame. 723 (% (let ((stack (abort 724 (lambda (k) 725 ;; Call frame->stack-vector before reinstating the 726 ;; continuation, so that we catch the %stacks fluid 727 ;; at the time of capture. 728 (lambda (frame) 729 (k (frame->stack-vector frame))))))) 730 (format #t "~a~%" msg) 731 ((module-ref (resolve-interface '(system repl repl)) 'start-repl) 732 #:debug (make-debug stack 0 msg))))) 733 734(define-stack-command (step repl) 735 "step 736Step until control reaches a different source location. 737 738Step until control reaches a different source location." 739 (let ((msg (format #f "Step into ~a" cur))) 740 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg) 741 #:into? #t #:instruction? #f) 742 (throw 'quit))) 743 744(define-stack-command (step-instruction repl) 745 "step-instruction 746Step until control reaches a different instruction. 747 748Step until control reaches a different VM instruction." 749 (let ((msg (format #f "Step into ~a" cur))) 750 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg) 751 #:into? #t #:instruction? #t) 752 (throw 'quit))) 753 754(define-stack-command (next repl) 755 "next 756Step until control reaches a different source location in the current frame. 757 758Step until control reaches a different source location in the current frame." 759 (let ((msg (format #f "Step into ~a" cur))) 760 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg) 761 #:into? #f #:instruction? #f) 762 (throw 'quit))) 763 764(define-stack-command (next-instruction repl) 765 "next-instruction 766Step until control reaches a different instruction in the current frame. 767 768Step until control reaches a different VM instruction in the current frame." 769 (let ((msg (format #f "Step into ~a" cur))) 770 (add-ephemeral-stepping-trap! cur (repl-next-resumer msg) 771 #:into? #f #:instruction? #t) 772 (throw 'quit))) 773 774(define-meta-command (tracepoint repl (form)) 775 "tracepoint PROCEDURE 776Add a tracepoint to PROCEDURE. 777 778A tracepoint will print out the procedure and its arguments, when it is 779called, and its return value(s) when it returns." 780 (let ((proc (repl-eval repl (repl-parse repl form)))) 781 (if (not (procedure? proc)) 782 (error "Not a procedure: ~a" proc) 783 (let ((idx (add-trace-at-procedure-call! proc))) 784 (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))) 785 786(define-meta-command (traps repl) 787 "traps 788Show the set of currently attached traps. 789 790Show the set of currently attached traps (breakpoints and tracepoints)." 791 (let ((traps (list-traps))) 792 (if (null? traps) 793 (format #t "No traps set.~%") 794 (for-each (lambda (idx) 795 (format #t " ~a: ~a~a~%" 796 idx (trap-name idx) 797 (if (trap-enabled? idx) "" " (disabled)"))) 798 traps)))) 799 800(define-meta-command (delete repl idx) 801 "delete IDX 802Delete a trap. 803 804Delete a trap." 805 (if (not (integer? idx)) 806 (error "expected a trap index (a non-negative integer)" idx) 807 (delete-trap! idx))) 808 809(define-meta-command (disable repl idx) 810 "disable IDX 811Disable a trap. 812 813Disable a trap." 814 (if (not (integer? idx)) 815 (error "expected a trap index (a non-negative integer)" idx) 816 (disable-trap! idx))) 817 818(define-meta-command (enable repl idx) 819 "enable IDX 820Enable a trap. 821 822Enable a trap." 823 (if (not (integer? idx)) 824 (error "expected a trap index (a non-negative integer)" idx) 825 (enable-trap! idx))) 826 827(define-stack-command (registers repl) 828 "registers 829Print registers. 830 831Print the registers of the current frame." 832 (print-registers cur)) 833 834(define-meta-command (width repl #:optional x) 835 "width [X] 836Set debug output width. 837 838Set the number of screen columns in the output from `backtrace' and 839`locals'." 840 (terminal-width x) 841 (format #t "Set screen width to ~a columns.~%" (terminal-width))) 842 843 844 845;;; 846;;; Inspection commands 847;;; 848 849(define-meta-command (inspect repl (form)) 850 "inspect EXP 851Inspect the result(s) of evaluating EXP." 852 (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form)) 853 (lambda args 854 (for-each %inspect args)))) 855 856(define-meta-command (pretty-print repl (form)) 857 "pretty-print EXP 858Pretty-print the result(s) of evaluating EXP." 859 (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form)) 860 (lambda args 861 (for-each 862 (lambda (x) 863 (run-hook before-print-hook x) 864 (pp x)) 865 args)))) 866 867 868;;; 869;;; System commands 870;;; 871 872(define-meta-command (gc repl) 873 "gc 874Garbage collection." 875 (gc)) 876 877(define-meta-command (statistics repl) 878 "statistics 879Display statistics." 880 (let ((this-tms (times)) 881 (this-gcs (gc-stats)) 882 (last-tms (repl-tm-stats repl)) 883 (last-gcs (repl-gc-stats repl))) 884 ;; GC times 885 (let ((this-times (assq-ref this-gcs 'gc-times)) 886 (last-times (assq-ref last-gcs 'gc-times))) 887 (display-diff-stat "GC times:" #t this-times last-times "times") 888 (newline)) 889 ;; Memory size 890 (let ((this-heap (assq-ref this-gcs 'heap-size)) 891 (this-free (assq-ref this-gcs 'heap-free-size))) 892 (display-stat-title "Memory size:" "current" "limit") 893 (display-stat "heap" #f (- this-heap this-free) this-heap "bytes") 894 (newline)) 895 ;; Cells collected 896 (let ((this-alloc (assq-ref this-gcs 'heap-total-allocated)) 897 (last-alloc (assq-ref last-gcs 'heap-total-allocated))) 898 (display-stat-title "Bytes allocated:" "diff" "total") 899 (display-diff-stat "allocated" #f this-alloc last-alloc "bytes") 900 (newline)) 901 ;; GC time taken 902 (let ((this-total (assq-ref this-gcs 'gc-time-taken)) 903 (last-total (assq-ref last-gcs 'gc-time-taken))) 904 (display-stat-title "GC time taken:" "diff" "total") 905 (display-time-stat "total" this-total last-total) 906 (newline)) 907 ;; Process time spent 908 (let ((this-utime (tms:utime this-tms)) 909 (last-utime (tms:utime last-tms)) 910 (this-stime (tms:stime this-tms)) 911 (last-stime (tms:stime last-tms)) 912 (this-cutime (tms:cutime this-tms)) 913 (last-cutime (tms:cutime last-tms)) 914 (this-cstime (tms:cstime this-tms)) 915 (last-cstime (tms:cstime last-tms))) 916 (display-stat-title "Process time spent:" "diff" "total") 917 (display-time-stat "user" this-utime last-utime) 918 (display-time-stat "system" this-stime last-stime) 919 (display-time-stat "child user" this-cutime last-cutime) 920 (display-time-stat "child system" this-cstime last-cstime) 921 (newline)) 922 ;; Save statistics 923 ;; Save statistics 924 (set! (repl-tm-stats repl) this-tms) 925 (set! (repl-gc-stats repl) this-gcs))) 926 927(define (display-stat title flag field1 field2 unit) 928 (let ((fmt (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@")))) 929 (format #t fmt title field1 field2 unit))) 930 931(define (display-stat-title title field1 field2) 932 (display-stat title #t field1 field2 "")) 933 934(define (display-diff-stat title flag this last unit) 935 (display-stat title flag (- this last) this unit)) 936 937(define (display-time-stat title this last) 938 (define (conv num) 939 (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second)))) 940 (display-stat title #f (conv (- this last)) (conv this) "s")) 941 942(define (display-mips-stat title this-time this-clock last-time last-clock) 943 (define (mips time clock) 944 (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0)))) 945 (display-stat title #f 946 (mips (- this-time last-time) (- this-clock last-clock)) 947 (mips this-time this-clock) "mips")) 948