1;;; inspect.ss 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16;;; todo 17 18; ---be sensitive to system mode 19; ---argument names for code objects 20; ---nesting level numbers for all variables 21; (sort variable displays by nesting and position) 22; ---add "loop" variable type 23; ---keep track of loop names? 24; ---information about foreign procedures 25; ---distinguish between user and compiler gensym variables? 26; (right now both are stripped) 27; ---disassembler 28; ---port info should include file descriptor, perhaps provide access 29; location in file 30 31(begin 32(let () 33 34(define-syntax make-dispatch-table 35 (lambda (x) 36 (syntax-case x () 37 [(_ [key message (ids e1 e2 ...) ...] ...) 38 (and (andmap (lambda (x) 39 (or (string? x) 40 (and (pair? x) (string? (car x)) (string? (cdr x))))) 41 (datum (key ...))) 42 (andmap string? (datum (message ...)))) 43 #'`([key message 44 ,(case-lambda 45 (ids e1 e2 ...) 46 ... 47 (l (invalid-command)))] 48 ...)]))) 49 50(define-record-type sfile 51 (fields (immutable path) (immutable port) (mutable line) (mutable line-valid?)) 52 (nongenerative) 53 (sealed #t)) 54 55(define-threaded source-files '()) 56 57(define find-source-file 58 (lambda (path line) 59 (define path=? 60 ; trivial definition for now 61 (lambda (p1 p2) 62 (string=? p1 p2))) 63 (let f ((ls source-files)) 64 (if (null? ls) 65 (guard (c [#t #f]) 66 (let ((line (or line 1))) 67 (set! source-files 68 (cons (make-sfile path (open-input-file path) 69 line 70 (= line 1)) 71 source-files))) 72 #t) 73 (if (path=? path (sfile-path (car ls))) 74 (let ((sf (car ls))) 75 (when line 76 (unless (= line (sfile-line sf)) 77 (sfile-line-valid?-set! sf #f) 78 (sfile-line-set! sf line))) 79 (set! source-files 80 (cons sf (remq sf source-files))) 81 #t) 82 (f (cdr ls))))))) 83 84(define open-source-file 85 (case-lambda 86 [(path) (open-source-file path #f)] 87 [(path line) 88 (or (if ($fixed-path? path) 89 (find-source-file path line) 90 (let ([dir* (append (source-directories) (map car (library-directories)))]) 91 (let pathloop ([path path]) 92 (let dirloop ([dir* dir*]) 93 (if (null? dir*) 94 (let ([rest (path-rest path)]) 95 (and (not (string=? rest path)) 96 (pathloop rest))) 97 (or (find-source-file 98 (let* ((dir (car dir*)) (n (string-length dir))) 99 (format (if (and (fx> n 0) 100 (directory-separator? 101 (string-ref dir (fx- n 1)))) 102 "~a~a" 103 "~a/~a") 104 dir path)) 105 line) 106 (dirloop (cdr dir*)))))))) 107 (inspect-error "Cannot open ~a" path))])) 108 109(define open-recorded-source-file 110 (lambda (object) 111 (call-with-values 112 (lambda () (object 'source-path)) 113 (case-lambda 114 [() (inspect-error "Source file unknown.")] 115 [(path pos) 116 (inspect-error 117 "Cannot locate (unmodified) source file ~a.~%Try changing source-directories parameter.~%Source is at character ~s." 118 path pos)] 119 [(path line char) 120 (if (find-source-file path 121 (max (- line (quotient lines-to-list 2)) 1)) 122 (show "line ~d, character ~d of ~a" line char path) 123 (inspect-error "Cannot open ~a" path))])))) 124 125(define close-source-file 126 (lambda (sf) 127 (close-input-port (sfile-port sf)))) 128 129(define lines-to-list 10) 130 131(module (list-source-file) 132(define base10-length 133 (lambda (n) 134 (cond 135 [(fx< n 10) 1] 136 [(fx< n 100) 2] 137 [(fx< n 1000) 3] 138 [(fx< n 10000) 4] 139 [else (+ 4 (base10-length (quotient n 10000)))]))) 140 141(define list-source-file 142 (case-lambda 143 [() (list-source-file #f #f)] 144 [(line) (list-source-file line #f)] 145 [(line count) 146 (when (null? source-files) 147 (inspect-error "No source file open.")) 148 (let* ((sf (car source-files)) 149 (ip (sfile-port sf))) 150 (when line (require (fixnum? line))) 151 (when count (require (and (fixnum? count) (fx> count 0)))) 152 (let* ((line (cond [(not line) (sfile-line sf)] 153 [(fx> line 0) line] 154 [else (max (+ (sfile-line sf) line (- lines-to-list)) 155 1)])) 156 (count (if count 157 (begin (set! lines-to-list count) count) 158 lines-to-list))) 159 (let f ((new-line 160 (if (and (sfile-line-valid? sf) (fx>= line (sfile-line sf))) 161 (begin 162 (sfile-line-valid?-set! sf #f) 163 (sfile-line sf)) 164 (begin 165 (sfile-line-valid?-set! sf #f) 166 (file-position ip 0) 167 1)))) 168 (unless (fx= new-line line) 169 (let ((c (read-char ip))) 170 (cond 171 [(eof-object? c) 172 (inspect-error "Not that many lines in ~a." (sfile-path sf))] 173 [(char=? c #\newline) (f (fx+ new-line 1))] 174 [else (f new-line)])))) 175 (let ((line-chars (base10-length (+ line count -1)))) 176 (let f ((line line) (count count)) 177 (if (fx= count 0) 178 (begin 179 (sfile-line-set! sf line) 180 (sfile-line-valid?-set! sf #t)) 181 (let ((c (read-char ip))) 182 (if (eof-object? c) 183 (fprintf (console-output-port) "*** end of file ***~%") 184 (begin 185 (do ((n (base10-length line) (fx+ n 1))) 186 ((fx= n line-chars)) 187 (write-char #\space (console-output-port))) 188 (fprintf (console-output-port) "~d: " line) 189 (do ((c c (read-char ip))) 190 ((or (eof-object? c) (char=? c #\newline)) 191 (newline (console-output-port))) 192 (write-char c (console-output-port))) 193 (f (fx+ line 1) (fx- count 1))))))))))])) 194) 195 196(define (waiter-read) 197 (parameterize ([waiter-prompt-string ""]) 198 ((waiter-prompt-and-read) 1))) 199 200(define show 201 (lambda (s . args) 202 (apply fprintf (console-output-port) s args) 203 (newline (console-output-port)))) 204 205(define inspect-error 206 (lambda (s . args) 207 (apply show s args) 208 (reset))) 209 210(define invalid-command 211 (lambda () 212 (inspect-error "Invalid command or argument. Type ? for options."))) 213 214(define invalid-movement 215 (lambda () 216 (inspect-error "Invalid movement."))) 217 218(define line-indent " ") 219 220(define prompt-line-limit 65) 221 222(define display-line-limit 80) 223 224(define descrip-limit 25) 225 226(define-threaded marks) 227 228(define-threaded current-state) 229 230(define-record-type state 231 (fields (immutable object) (immutable level) (immutable position) (immutable link) (mutable find-next)) 232 (nongenerative) 233 (sealed #t) 234 (protocol 235 (lambda (new) 236 (case-lambda 237 [(object) (new object 0 #f #f #f)] 238 [(object level position link) (new object level position link #f)])))) 239 240(define object (lambda () (state-object current-state))) 241 242(define level (lambda () (state-level current-state))) 243 244(define position (lambda () (state-position current-state))) 245 246(define type? 247 (lambda (flag x) 248 (eq? (x 'type) flag))) 249 250(define default-mark (void)) 251 252(define make-mark 253 (lambda (m) 254 (if (string? m) 255 (string->symbol m) 256 m))) 257 258(define put-mark 259 (lambda (m) 260 (let ([a (eq-hashtable-cell marks m #f)]) 261 (set-cdr! a current-state)))) 262 263(define get-mark 264 (lambda (m) 265 (eq-hashtable-ref marks m #f))) 266 267(define to-mark 268 (lambda (m) 269 (let ([s (get-mark m)]) 270 (unless s (invalid-movement)) 271 (put-mark default-mark) 272 (set! current-state s)))) 273 274(define down 275 (lambda (x pos) 276 (set! current-state 277 (make-state (if (eq? (x 'type) 'variable) (x 'ref) x) 278 (+ (level) 1) 279 pos 280 current-state)))) 281 282(define up 283 (lambda () 284 (set! current-state (state-link current-state)) 285 (unless current-state (invalid-movement)))) 286 287(define display-links 288 (lambda (n) 289 (let loop ([i 0] [x (object)]) 290 (unless (= i n) 291 (when (type? 'continuation x) 292 (label-line-display x i) 293 (loop (+ i 1) (x 'link))))))) 294 295(define display-refs 296 (lambda (n) 297 (let ([x (object)]) 298 (let loop ([i 0]) 299 (unless (= i n) 300 (label-line-display (x 'ref i) i) 301 (loop (+ i 1))))))) 302 303(define display-variable-refs 304 (lambda (n) 305 (let ([x (object)]) 306 (if ((x 'code) 'info) 307 (let loop ([i 0]) 308 (unless (= i n) 309 (variable-line-display (x 'ref i) i) 310 (loop (+ i 1)))) 311 (display-refs n))))) 312 313(define display-list 314 (lambda (n) 315 (let ((x (object))) 316 (if (or (type? 'pair (x 'cdr)) 317 (and (type? 'simple (x 'cdr)) (null? ((x 'cdr) 'value)))) 318 (let loop ([i 0] [x x]) 319 (if (and (< i n) (type? 'pair x)) 320 (begin 321 (label-line-display (x 'car) i) 322 (loop (+ i 1) (x 'cdr))) 323 (unless (and (type? 'simple x) (null? (x 'value))) 324 (name-line-display x "tail")))) 325 (begin 326 (name-line-display (x 'car) "car") 327 (name-line-display (x 'cdr) "cdr")))))) 328 329(define charschemecode 330 (lambda (x) 331 (let ([x (format "~s" x)]) 332 (format "~a~a" x (spaces (- 11 (string-length x))))))) 333 334(define unicodehexcode 335 (lambda (x) 336 (format "~6,'0x " (char->integer x)))) 337 338(define asciihexcode 339 (lambda (x) 340 (let ([n (char->integer x)]) 341 (if (>= n 256) 342 "-- " 343 (format "~2,'0x " n))))) 344 345(define display-chars 346 (lambda (n former no/line) 347 (let ([x (object)]) 348 (let loop1 ([i 0]) 349 (unless (= i n) 350 (let ([label (format "~a~d: " line-indent i)]) 351 (let loop2 ([j 0] [i i] [strings '()]) 352 (if (or (= j no/line) (= i n)) 353 (begin 354 (show "~a~a~a" 355 label 356 (spaces (- 6 (string-length label))) 357 (apply string-append (reverse strings))) 358 (loop1 i)) 359 (loop2 (+ j 1) 360 (+ i 1) 361 (cons (former ((x 'ref i) 'value)) 362 strings)))))))))) 363 364(define label-line-display 365 (lambda (x n) 366 (let ([label (format "~a~d: " line-indent n)]) 367 (show "~a~a" 368 label 369 (form x (string-length label) display-line-limit))))) 370 371(define name-label-line-display 372 (lambda (x name n) 373 (let ([label (format "~a~d. ~a:" line-indent n name)]) 374 (let ([label (format "~a~a" 375 label 376 (spaces (- descrip-limit (string-length label))))]) 377 (show "~a~a" 378 label 379 (form x (string-length label) display-line-limit)))))) 380 381(define name-line-display 382 (lambda (x name) 383 (let ([label (format "~a~a:" line-indent name)]) 384 (let ([label (format "~a~a" 385 label 386 (spaces (- descrip-limit (string-length label))))]) 387 (show "~a~a" 388 label 389 (form x (string-length label) display-line-limit)))))) 390 391(define variable-line-display 392 (lambda (x n) 393 (if (x 'name) 394 (name-label-line-display (x 'ref) (x 'name) n) 395 (label-line-display (x 'ref) n)))) 396 397(define ref-list 398 (lambda (n) 399 (unless (and (fixnum? n) (>= n 0)) (invalid-movement)) 400 (let ref ([i n] [x (object)]) 401 (cond 402 [(not (type? 'pair x)) (invalid-movement)] 403 [(= i 0) (down (x 'car) n)] 404 [else (ref (- i 1) (x 'cdr))])))) 405 406(define ref 407 (lambda (n) 408 (unless (and (fixnum? n) (< -1 n ((object) 'length))) 409 (invalid-movement)) 410 (down ((object) 'ref n) n))) 411 412(define set 413 (lambda (n v) 414 (unless (and (fixnum? n) (< -1 n ((object) 'length))) 415 (invalid-movement)) 416 (let ([x ((object) 'ref n)]) 417 (unless (x 'assignable?) 418 (inspect-error "~s is not assignable" (or (x 'name) 'unnamed))) 419 (x 'set! v)))) 420 421(module (variable-ref variable-set) 422 (define get-var-obj 423 (lambda (sym) 424 (let ([n ((object) 'length)]) 425 (let loop ([i 0]) 426 (if (fx= i n) 427 (invalid-movement) 428 (let ([x ((object) 'ref i)]) 429 (if (let ([name (x 'name)]) 430 (and (symbol? name) 431 (string=? 432 (symbol->string name) 433 (symbol->string sym)))) 434 (values x i) 435 (loop (fx+ i 1))))))))) 436 (define variable-ref 437 (lambda (x) 438 (if (symbol? x) 439 (with-values (get-var-obj x) down) 440 (ref x)))) 441 (define variable-set 442 (lambda (x val) 443 (if (symbol? x) 444 (with-values (get-var-obj x) 445 (lambda (var-obj i) 446 (unless (var-obj 'assignable?) (inspect-error "~s is not assignable" x)) 447 (var-obj 'set! val))) 448 (set x val))))) 449 450(define move 451 (lambda (n) 452 (require (position)) 453 (let ([n (+ n (position))]) 454 (up) 455 (case ((object) 'type) 456 [(pair) (ref-list n)] 457 [(continuation procedure vector fxvector flvector bytevector string record 458 ftype-struct ftype-union ftype-array ftype-bits stencil-vector) 459 (ref n)] 460 [else (invalid-movement)])))) 461 462(define require 463 (lambda (x) 464 (unless x (invalid-command)))) 465 466(define range-check 467 (case-lambda 468 [(n) (require (and (fixnum? n) (fx<= 0 n)))] 469 [(n max) (require (and (fixnum? n) (fx<= 0 n max)))] 470 [(min n max) (require (and (fixnum? n) (fx<= min n max)))])) 471 472(define display-one-option 473 (lambda (key message) 474 (let ([s (if (pair? key) (format "~a(~a)" (car key) (cdr key)) key)]) 475 (show " ~a ~a ~a" 476 s 477 (make-string (max (- 20 (string-length s)) 0) #\.) 478 message)))) 479 480(define display-options 481 (lambda (table generic?) 482 (show "") 483 (for-each display-one-option (map car table) (map cadr table)) 484 (unless generic? (display-one-option "??" "display more options")) 485 (show ""))) 486 487(define select-dispatch-table 488 (lambda () 489 (case ((object) 'type) 490 [(pair) pair-dispatch-table] 491 [(symbol) (if (eq? (subset-mode) 'system) 492 system-symbol-dispatch-table 493 symbol-dispatch-table)] 494 [(vector) vector-dispatch-table] 495 [(fxvector) fxvector-dispatch-table] 496 [(flvector) flvector-dispatch-table] 497 [(bytevector) bytevector-dispatch-table] 498 [(stencil-vector) stencil-vector-dispatch-table] 499 [(record) record-dispatch-table] 500 [(string) string-dispatch-table] 501 [(box) box-dispatch-table] 502 [(continuation) continuation-dispatch-table] 503 [(procedure) procedure-dispatch-table] 504 [(code) code-dispatch-table] 505 [(port) port-dispatch-table] 506 [(simple) 507 (let ([x ((object) 'value)]) 508 (cond 509 [(char? x) char-dispatch-table] 510 [else empty-dispatch-table]))] 511 [(tlc) tlc-dispatch-table] 512 [(phantom-bytevector) phantom-dispatch-table] 513 [(ftype-struct) ftype-struct-dispatch-table] 514 [(ftype-union) ftype-union-dispatch-table] 515 [(ftype-array) ftype-array-dispatch-table] 516 [(ftype-*) ftype-pointer-dispatch-table] 517 [(ftype-bits) ftype-bits-dispatch-table] 518 [(ftype-base) ftype-pointer-dispatch-table] 519 [(ftype-function) ftype-function-dispatch-table] 520 [else empty-dispatch-table]))) 521 522(define inspector-read 523 (lambda (ip) 524 (let* ([ip (console-input-port)] [c (read-char ip)]) 525 (cond 526 [(eof-object? c) 527 (newline (console-output-port)) 528 '("quit")] 529 [(char=? c #\newline) 530 (set-port-bol! (console-output-port) #t) 531 '()] 532 [(char-whitespace? c) 533 (inspector-read ip)] 534 [else 535 (unread-char c ip) 536 (let ([first (inspector-read-command ip)]) 537 (cons first (inspector-read-tail ip)))])))) 538 539(define inspector-read-command 540 (lambda (ip) 541 (let ([p (open-output-string)]) 542 (let read-letters () 543 (let ([c (peek-char ip)]) 544 (if (and (char? c) 545 (not (char-numeric? c)) 546 (not (char-whitespace? c))) 547 (begin (read-char ip) 548 (write-char c p) 549 (read-letters)) 550 (get-output-string p))))))) 551 552(define inspector-read-tail 553 (lambda (ip) 554 (let ([c (peek-char ip)]) 555 (cond 556 [(char=? c #\newline) 557 (read-char ip) 558 (set-port-bol! (console-output-port) #t) 559 '()] 560 [(or (char-whitespace? c) ; [( 561 (memv c '(#\) #\]))) 562 (read-char ip) 563 (inspector-read-tail ip)] 564 [else 565 (let ([x (read ip)]) 566 (cons x (inspector-read-tail ip)))])))) 567 568(define dispatch 569 (lambda (c t) 570 (let ([handler (or (search-dispatch-table (car c) t) 571 (search-dispatch-table (car c) 572 generic-dispatch-table))]) 573 (if handler 574 (apply handler (cdr c)) 575 (invalid-command))))) 576 577(define search-dispatch-table 578 (lambda (s t) 579 (and (not (null? t)) 580 (let ([first (car t)]) 581 (let ([key (car first)]) 582 (if (if (string? key) 583 (string=? key s) 584 (or (string=? (car key) s) 585 (string=? (cdr key) s))) 586 (caddr first) 587 (search-dispatch-table s (cdr t)))))))) 588 589(define spaces 590 (lambda (n) 591 (if (> n 0) 592 (make-string n #\space) 593 ""))) 594 595(define write-to-string 596 (lambda (x) 597 (let ([p (open-output-string)]) 598 (x 'write p) 599 (get-output-string p)))) 600 601(define short-form-rec 602 (lambda (x limit) 603 (let try ([low 1] 604 [high #f] 605 [r (parameterize ([print-level 0] [print-length 0]) 606 (write-to-string x))]) 607 (let ([mid (+ low (if high (quotient (- high low) 2) low))]) 608 (if (= mid low) 609 r 610 (let ([s (parameterize ([print-level mid] [print-length mid]) 611 (write-to-string x))]) 612 (cond 613 [(string=? s r) s] 614 [(> (string-length s) limit) (try low mid r)] 615 [else (try mid high s)]))))))) 616 617(define short-form-lambda 618 ; x looks like "(lambda vars body)" 619 ; print the "lambda" and all of the vars that fit 620 (lambda (x limit) 621 (let ([first (format "(lambda ~a " ;) 622 (short-form-rec ((x 'cdr) 'car) (- limit 14)))]) 623 (let ([rest (short-form-rec ((x 'cdr) 'cdr) 624 (- limit (string-length first)))]) 625 (if (and (> (string-length rest) 0) 626 (char=? (string-ref rest 0) #\()) ;) 627 (string-append first (substring rest 1 (string-length rest))) 628 (short-form-rec x limit)))))) 629 630(define short-form 631 (lambda (x limit) 632 (case (x 'type) 633 [(pair) 634 (if (and (eq? ((x 'car) 'type) 'symbol) 635 (eq? ((x 'car) 'value) 'lambda) 636 (eq? ((x 'cdr) 'type) 'pair) 637 (eq? (((x 'cdr) 'cdr) 'type) 'pair)) 638 (short-form-lambda x limit) 639 (short-form-rec x limit))] 640 [(string) 641 (let ([s (format "~s" 642 ; avoid passing format the whole of a large string 643 (let ([s (x 'value)]) 644 (if (<= (string-length s) limit) 645 s 646 (substring s 0 limit))))]) 647 (if (<= (string-length s) limit) 648 s 649 (string-append 650 (substring s 0 (max (- limit 4) 1)) 651 "...\"")))] 652 [else (short-form-rec x limit)]))) 653 654(define form 655 (lambda (x used limit) 656 (short-form x (- limit used)))) 657 658(define inspector-prompt 659 (lambda () 660 (let ([obj (form (object) 0 prompt-line-limit)]) 661 (fprintf (console-output-port) 662 "~a~a : " 663 obj 664 (spaces (- prompt-line-limit (string-length obj))))))) 665 666(define outer-reset-handler ($make-thread-parameter values)) 667 668(define inspector 669 (lambda (last-command) 670 (inspector 671 (let ([saved-state current-state]) 672 (parameterize ([reset-handler (call/cc 673 (lambda (k) 674 (rec f 675 (lambda () 676 (clear-output-port (console-output-port)) 677 (set! current-state saved-state) 678 (k f)))))]) 679 (let ([ip (console-input-port)]) 680 (clear-input-port ip) 681 (inspector-prompt) 682 (let ([cmd (let ([cmd (inspector-read ip)]) 683 (cond 684 [(null? cmd) 685 (if (equal? (car last-command) "list") 686 '("list") 687 last-command)] 688 [(number? (car cmd)) (cons "ref" cmd)] 689 [else cmd]))]) 690 (cond 691 [(equal? cmd '("?")) 692 (let ([t (select-dispatch-table)]) 693 (if (null? t) 694 (display-options generic-dispatch-table #t) 695 (display-options t #f)))] 696 [(equal? cmd '("??")) 697 (display-options generic-dispatch-table #t)] 698 [else 699 (guard (c [#t (let ([op (console-output-port)]) 700 (fresh-line op) 701 (display-condition c op) 702 (newline op) 703 (set! current-state saved-state))]) 704 (dispatch cmd (select-dispatch-table)))]) 705 cmd))))))) 706 707(define-syntax inspector-print 708 (syntax-rules () 709 [(_ e) 710 (call-with-values (lambda () e) 711 (case-lambda 712 [(x) (unless (eq? x (void)) (pretty-print x (console-output-port)))] 713 [args (for-each (lambda (x) (pretty-print x (console-output-port))) args)]))])) 714 715(module (inspector-find inspector-find-next) 716 (define down-path 717 (lambda (path) 718 (assert (and (list? path) (>= (length path) 1))) 719 (let f ([path path]) 720 (let ([x (car path)] [path (cdr path)]) 721 (if (null? path) 722 (assert (eq? x ((object) 'value))) 723 (begin 724 (f path) 725 (down ((object) 'make-me-a-child x) #f))))))) 726 (define inspector-find 727 (lambda (pred gen) 728 (state-find-next-set! current-state (make-object-finder pred ((object) 'value) gen)) 729 (let ([path ((state-find-next current-state))]) 730 (unless path (inspect-error "Not found")) 731 (down-path path)))) 732 (define inspector-find-next 733 (lambda () 734 (let loop ([state current-state]) 735 (cond 736 [(not state) (inspect-error "No current find.")] 737 [(state-find-next state) => 738 (lambda (find-next) 739 (let ([path (find-next)]) 740 (unless path (inspect-error "Not found")) 741 (set! current-state state) 742 (down-path path)))] 743 [else (loop (state-link state))]))))) 744 745(define generic-dispatch-table 746 (make-dispatch-table 747 748 [("print" . "p") 749 "pretty-print object" 750 (() 751 (newline (console-output-port)) 752 ((object) 'print (console-output-port)) 753 (newline (console-output-port)))] 754 755 [("write" . "w") 756 "write object" 757 (() 758 (newline (console-output-port)) 759 ((object) 'write (console-output-port)) 760 (newline (console-output-port)) 761 (newline (console-output-port)))] 762 763 ["size" 764 "recursively compute storage occupied by object" 765 (() (fprintf (console-output-port) "~s\n" ((object) 'size (collect-maximum-generation)))) 766 ((g) 767 (require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))) 768 (fprintf (console-output-port) "~s\n" ((object) 'size g)))] 769 770 ["find" 771 "find within object, given a predicate" 772 (() 773 (let ([x (waiter-read)]) 774 (unless (eof-object? x) 775 (let ([x (eval x)]) 776 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 777 (inspector-find x (collect-maximum-generation)))))) 778 ((x) 779 (let ([x (eval x)]) 780 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 781 (inspector-find x (collect-maximum-generation)))) 782 ((x g) 783 (require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))) 784 (let ([x (eval x)]) 785 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 786 (inspector-find x g)))] 787 788 ["find-next" 789 "repeat find" 790 (() 791 (inspector-find-next))] 792 793 [("up" . "u") 794 "return to [nth] previous level" 795 (() (up)) 796 ((n) 797 (range-check n) 798 (let backup ([n n]) 799 (unless (= n 0) 800 (up) 801 (backup (- n 1)))))] 802 803 [("top" . "t") 804 "return to initial object" 805 (() 806 (let top () 807 (let ([next (state-link current-state)]) 808 (when next 809 (set! current-state next) 810 (top)))))] 811 812 [("forward" . "f") 813 "move to [nth] next expression" 814 (() (move 1)) 815 ((n) 816 (range-check n) 817 (move n))] 818 819 [("back" . "b") 820 "move to [nth] previous expression" 821 (() (move -1)) 822 ((n) 823 (range-check n) 824 (move (- n)))] 825 826 ["=>" 827 "send object to procedure" 828 (() 829 (let ([x (waiter-read)]) 830 (unless (eof-object? x) 831 (let ([x (eval x)]) 832 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 833 (inspector-print (x ((object) 'value))))))) 834 ((x) 835 (let ([x (eval x)]) 836 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 837 (inspector-print (x ((object) 'value)))))] 838 839 ["file" 840 "switch to named source file" 841 ((path) 842 (unless (or (string? path) (symbol? path)) 843 (inspect-error "invalid path ~s" path)) 844 (open-source-file (if (symbol? path) (symbol->string path) path)))] 845 846 ["list" 847 "list the current source file [line [count]]" 848 (() (list-source-file)) 849 ((n) (list-source-file n)) 850 ((n m) (list-source-file n m))] 851 852 ["files" 853 "show open files" 854 (() 855 (for-each 856 (lambda (sf) (show "~a" (sfile-path sf))) 857 source-files))] 858 859 [("mark" . "m") 860 "mark location [with symbolic mark]" 861 (() (put-mark default-mark)) 862 ((m) (put-mark (make-mark m)))] 863 864 [("goto" . "g") 865 "go to marked location [mark]" 866 (() (to-mark default-mark)) 867 ((m) (to-mark (make-mark m)))] 868 869 [("new-cafe" . "n") 870 "enter a new cafe" 871 (() 872 (newline (console-output-port)) 873 (new-cafe) 874 (newline (console-output-port)))] 875 876 [("quit" . "q") 877 "exit inspector" 878 (() 879 (newline (console-output-port)) 880 (exit))] 881 882 [("reset" . "r") 883 "reset scheme" 884 (() 885 (newline (console-output-port)) 886 ((outer-reset-handler)))] 887 888 [("abort" . "a") 889 "abort scheme [with exit code n]" 890 (() 891 (newline (console-output-port)) 892 (abort)) 893 ((x) 894 (newline (console-output-port)) 895 (abort x))] 896 897 [("help" . "h") 898 "help" 899 (() 900 (show " 901 An overview of the current object is displayed as part of each 902 prompt. There are commands for displaying more of an object or 903 inspecting its components. \"?\" displays type-specific command 904 options and \"??\" displays command options that are always 905 available. Some commands take parameters, which are entered 906 following the command on the same line. An empty command line 907 repeats the previous command. To perform more complex actions, 908 enter the command \"n\", which creates a new top level with access 909 to the usual Scheme environment. The inspector is resumed upon 910 exit from the new top level. Enter \"quit\" (or end-of-file) to 911 exit from the inspector. 912"))] 913 914)) 915 916(define empty-dispatch-table (make-dispatch-table)) 917 918(define pair-dispatch-table 919 (make-dispatch-table 920 921 [("length" . "l") 922 "display list length" 923 (() 924 (apply (lambda (type len) 925 (case type 926 [(proper) (show " proper list, length ~d" len)] 927 [(improper) (show " improper list, length ~d" len)] 928 [(circular) (show " circular list, length ~d" len)])) 929 ((object) 'length)))] 930 931 ["car" 932 "inspect car of pair" 933 (() (ref-list 0))] 934 935 ["cdr" 936 "inspect cdr of pair" 937 (() (down ((object) 'cdr) #f))] 938 939 [("ref" . "r") 940 "inspect [nth] car" 941 (() (ref-list 0)) 942 ((n) (ref-list n))] 943 944 ["tail" 945 "inspect [nth] cdr" 946 (() (down ((object) 'cdr) #f)) 947 ((n) 948 (range-check n) 949 (let tail ([i n]) 950 (unless (= i 0) 951 (unless (type? 'pair (object)) (invalid-movement)) 952 (down ((object) 'cdr) #f) 953 (tail (- i 1)))))] 954 955 [("show" . "s") 956 "show [n] elements of list" 957 (() (display-list (cadr ((object) 'length)))) 958 ((n) 959 (range-check n) 960 (display-list n))] 961 962)) 963 964(define vector-dispatch-table 965 (make-dispatch-table 966 967 [("length" . "l") 968 "display vector length" 969 (() (show " ~d elements" ((object) 'length)))] 970 971 [("ref" . "r") 972 "inspect [nth] element" 973 (() (ref 0)) 974 ((n) (ref n))] 975 976 [("show" . "s") 977 "show [n] elements" 978 (() (display-refs ((object) 'length))) 979 ((n) 980 (range-check n ((object) 'length)) 981 (display-refs n))] 982 983)) 984 985(define fxvector-dispatch-table 986 (make-dispatch-table 987 988 [("length" . "l") 989 "display fxvector length" 990 (() (show " ~d elements" ((object) 'length)))] 991 992 [("ref" . "r") 993 "inspect [nth] element" 994 (() (ref 0)) 995 ((n) (ref n))] 996 997 [("show" . "s") 998 "show [n] elements" 999 (() (display-refs ((object) 'length))) 1000 ((n) 1001 (range-check n ((object) 'length)) 1002 (display-refs n))] 1003 1004)) 1005 1006(define flvector-dispatch-table 1007 (make-dispatch-table 1008 1009 [("length" . "l") 1010 "display flvector length" 1011 (() (show " ~d elements" ((object) 'length)))] 1012 1013 [("ref" . "r") 1014 "inspect [nth] element" 1015 (() (ref 0)) 1016 ((n) (ref n))] 1017 1018 [("show" . "s") 1019 "show [n] elements" 1020 (() (display-refs ((object) 'length))) 1021 ((n) 1022 (range-check n ((object) 'length)) 1023 (display-refs n))] 1024 1025)) 1026 1027(define bytevector-dispatch-table 1028 (make-dispatch-table 1029 1030 [("length" . "l") 1031 "display bytevector length" 1032 (() (show " ~d elements" ((object) 'length)))] 1033 1034 [("ref" . "r") 1035 "inspect [nth] element" 1036 (() (ref 0)) 1037 ((n) (ref n))] 1038 1039 [("show" . "s") 1040 "show [n] elements" 1041 (() (display-refs ((object) 'length))) 1042 ((n) 1043 (range-check n ((object) 'length)) 1044 (display-refs n))] 1045 1046)) 1047 1048(define stencil-vector-dispatch-table 1049 (make-dispatch-table 1050 1051 [("length" . "l") 1052 "display stencil vector length" 1053 (() (show " ~d elements" ((object) 'length)))] 1054 1055 [("mask" . "m") 1056 "display stencil vector mask" 1057 (() (show " #x~x" ((object) 'mask)))] 1058 1059 [("ref" . "r") 1060 "inspect [nth] element" 1061 (() (ref 0)) 1062 ((n) (ref n))] 1063 1064 [("show" . "s") 1065 "show [n] elements" 1066 (() (display-refs ((object) 'length))) 1067 ((n) 1068 (range-check n ((object) 'length)) 1069 (display-refs n))] 1070 1071)) 1072 1073(define ftype-struct-dispatch-table 1074 (make-dispatch-table 1075 ["fields" 1076 "inspect fields" 1077 (() (down ((object) 'fields) #f))] 1078 1079 [("ref" . "r") 1080 "inspect named or nth element" 1081 (() (down ((object) 'ref 0) 0)) 1082 ((f) (down ((object) 'ref f) (and (fixnum? f) f)))] 1083 1084 ["set!" 1085 "set named element, if assignable" 1086 ((f) 1087 (let ([x (waiter-read)]) 1088 (unless (eof-object? x) 1089 (let ((x (eval x))) 1090 ((object) 'set! f x))))) 1091 ((f v) ((object) 'set! f (eval v)))] 1092 1093 ["ftype" 1094 "inspect the ftype" 1095 (() (down ((object) 'ftype) #f))] 1096 1097 [("show" . "s") 1098 "show contents of struct" 1099 (() 1100 (let ([fields (((object) 'fields) 'value)]) 1101 (if (null? fields) 1102 (show "*** struct has no fields ***") 1103 (for-each 1104 (lambda (f i) 1105 (name-label-line-display 1106 ((object) 'ref i) 1107 f 1108 i)) 1109 fields 1110 (iota (length fields))))))])) 1111 1112(define ftype-union-dispatch-table 1113 (make-dispatch-table 1114 ["fields" 1115 "inspect fields" 1116 (() (down ((object) 'fields) #f))] 1117 1118 [("ref" . "r") 1119 "inspect named or nth element" 1120 (() (down ((object) 'ref 0) 0)) 1121 ((f) (down ((object) 'ref f) (and (fixnum? f) f)))] 1122 1123 ["set!" 1124 "set named element, if assignable" 1125 ((f) 1126 (let ([x (waiter-read)]) 1127 (unless (eof-object? x) 1128 (let ((x (eval x))) 1129 ((object) 'set! f x))))) 1130 ((f v) ((object) 'set! f (eval v)))] 1131 1132 ["ftype" 1133 "inspect the ftype" 1134 (() (down ((object) 'ftype) #f))] 1135 1136 [("show" . "s") 1137 "show contents of union" 1138 (() 1139 (let ([fields (((object) 'fields) 'value)]) 1140 (if (null? fields) 1141 (show "*** union has no fields ***") 1142 (for-each 1143 (lambda (f i) 1144 (name-label-line-display 1145 ((object) 'ref i) 1146 f 1147 i)) 1148 fields 1149 (iota (length fields))))))])) 1150 1151(define ftype-array-dispatch-table 1152 (make-dispatch-table 1153 [("length" . "l") 1154 "display array length" 1155 (() (show " ~d elements" ((object) 'length)))] 1156 1157 [("ref" . "r") 1158 "inspect [nth] element" 1159 (() (ref 0)) 1160 ((n) (ref n))] 1161 1162 ["set!" 1163 "set [nth] element, if assignable" 1164 ((f) 1165 (let ([x (waiter-read)]) 1166 (unless (eof-object? x) 1167 (let ((x (eval x))) 1168 ((object) 'set! f x))))) 1169 ((f v) ((object) 'set! f (eval v)))] 1170 1171 ["ftype" 1172 "inspect the ftype" 1173 (() (down ((object) 'ftype) #f))] 1174 1175 [("show" . "s") 1176 "show [n] elements" 1177 (() (display-refs ((object) 'length))) 1178 ((n) 1179 (range-check n ((object) 'length)) 1180 (display-refs n))] 1181 )) 1182 1183(define ftype-pointer-dispatch-table 1184 (make-dispatch-table 1185 [("ref" . "r") 1186 "inspect target of pointer" 1187 (() (down ((object) 'ref) #f)) 1188 ((n) 1189 (unless (memv n '(* 0)) (invalid-movement)) 1190 (down ((object) 'ref) #f))] 1191 1192 ["set!" 1193 "set target of pointer, if assignable" 1194 (() 1195 (let ([x (waiter-read)]) 1196 (unless (eof-object? x) 1197 (let ((x (eval x))) 1198 ((object) 'set! x))))) 1199 ((v) ((object) 'set! (eval v)))] 1200 1201 ["ftype" 1202 "inspect ftype of target" 1203 (() (down ((object) 'ftype) #f))] 1204 1205 [("show" . "s") 1206 "show the target" 1207 (() (label-line-display ((object) 'ref) 0))] 1208 )) 1209 1210(define ftype-function-dispatch-table 1211 (make-dispatch-table 1212 ["name" 1213 "inspect foreign-function name" 1214 (() (down ((object) 'name) #f))] 1215 1216 ["address" 1217 "inspect foreign-function address" 1218 (() (down ((object) 'address) #f))] 1219 1220 ["ftype" 1221 "inspect ftype of target" 1222 (() (down ((object) 'ftype) #f))] 1223 1224 [("show" . "s") 1225 "show the target" 1226 (() (label-line-display ((object) 'name) 0) 1227 (label-line-display ((object) 'address) 1))] 1228 )) 1229 1230(define ftype-bits-dispatch-table 1231 (make-dispatch-table 1232 ["fields" 1233 "inspect fields" 1234 (() (down ((object) 'fields) #f))] 1235 1236 [("ref" . "r") 1237 "inspect named or nth element" 1238 (() (down ((object) 'ref 0) 0)) 1239 ((f) (down ((object) 'ref f) (and (fixnum? f) f)))] 1240 1241 ["set!" 1242 "set named element, if assignable" 1243 ((f) 1244 (let ([x (waiter-read)]) 1245 (unless (eof-object? x) 1246 (let ((x (eval x))) 1247 ((object) 'set! f x))))) 1248 ((f v) ((object) 'set! f (eval v)))] 1249 1250 ["ftype" 1251 "inspect the ftype" 1252 (() (down ((object) 'ftype) #f))] 1253 1254 [("show" . "s") 1255 "show bit fields" 1256 (() 1257 (let ([fields (((object) 'fields) 'value)]) 1258 (if (null? fields) 1259 (show "*** no fields ***") 1260 (for-each 1261 (lambda (f i) 1262 (name-label-line-display 1263 ((object) 'ref i) 1264 f 1265 i)) 1266 fields 1267 (iota (length fields))))))])) 1268 1269(define record-dispatch-table 1270 (make-dispatch-table 1271 1272 ["fields" 1273 "inspect fields" 1274 (() (down ((object) 'fields) #f))] 1275 1276 ["name" 1277 "inspect record name" 1278 (() (down ((object) 'name) #f))] 1279 1280 ["rtd" 1281 "inspect record-type descriptor" 1282 (() (down ((object) 'rtd) #f))] 1283 1284 [("ref" . "r") 1285 "inspect named or nth element" 1286 ((f) (down ((object) 'ref f) (and (fixnum? f) f)))] 1287 1288 ["set!" 1289 "set named element, if assignable" 1290 ((f) 1291 (let ([x (waiter-read)]) 1292 (unless (eof-object? x) 1293 (let ((x (eval x))) 1294 ((object) 'set! f x))))) 1295 ((f v) ((object) 'set! f (eval v)))] 1296 1297 [("show" . "s") 1298 "show contents of record" 1299 (() 1300 (when (and (eq? (subset-mode) 'system) 1301 (record-type-opaque? (((object) 'rtd) 'value))) 1302 (show "*** inspecting opaque record ***")) 1303 (let ([fields (((object) 'fields) 'value)]) 1304 (if (null? fields) 1305 (show "*** record has no fields ***") 1306 (for-each 1307 (lambda (f i) 1308 (name-label-line-display 1309 (if ((object) 'accessible? i) 1310 ((object) 'ref i) 1311 (inspect/object "*** inaccessible ***")) 1312 f 1313 i)) 1314 fields 1315 (iota (length fields))))))] 1316)) 1317 1318 1319(define string-dispatch-table 1320 (make-dispatch-table 1321 1322 [("length" . "l") 1323 "display string length" 1324 (() (show " ~d characters" ((object) 'length)))] 1325 1326 [("ref" . "r") 1327 "inspect [nth] character" 1328 (() (ref 0)) 1329 ((n) (ref n))] 1330 1331 [("show" . "s") 1332 "show [n] characters" 1333 (() (display-chars ((object) 'length) charschemecode 5)) 1334 ((n) 1335 (range-check n ((object) 'length)) 1336 (display-chars n charschemecode 5))] 1337 1338 ["unicode" 1339 "display [n] characters as hexadecimal unicode codes" 1340 (() (display-chars ((object) 'length) unicodehexcode 8)) 1341 ((n) 1342 (range-check n ((object) 'length)) 1343 (display-chars n unicodehexcode 8))] 1344 1345 ["ascii" 1346 "display [n] characters as hexadecimal ascii codes" 1347 (() (display-chars ((object) 'length) asciihexcode 16)) 1348 ((n) 1349 (range-check n ((object) 'length)) 1350 (display-chars n asciihexcode 16))] 1351)) 1352 1353(define char-dispatch-table 1354 (make-dispatch-table 1355 1356 ["unicode" 1357 "display character as hexadecimal ascii code" 1358 (() (show " U+~x" (unicodehexcode ((object) 'value))))] 1359 1360 ["ascii" 1361 "display character as hexadecimal ascii code" 1362 (() (show " ~x" (asciihexcode ((object) 'value))))] 1363 1364)) 1365 1366(define box-dispatch-table 1367 (make-dispatch-table 1368 1369 ["unbox" 1370 "inspect contents of box" 1371 (() (down ((object) 'unbox) #f))] 1372 1373 [("ref" . "r") 1374 "inspect contents of box" 1375 (() (down ((object) 'unbox) #f))] 1376 1377 [("show" . "s") 1378 "show contents of box" 1379 (() (label-line-display ((object) 'unbox) 0)) 1380 ((n) 1381 (range-check n 0) 1382 (label-line-display ((object) 'unbox) 0))] 1383)) 1384 1385 1386(define system-symbol-dispatch-table 1387 (make-dispatch-table 1388 1389 [("ref" . "r") 1390 "inspect value field [n] of symbol" 1391 (() 1392 (down ((object) 'top-level-value) 0)) 1393 ((n) 1394 (range-check n 5) 1395 (down ((object) 1396 (case n 1397 [(0) 'top-level-value] 1398 [(1) '$top-level-value] 1399 [(2) 'name] 1400 [(3) 'property-list] 1401 [(4) 'system-property-list] 1402 [(5) 'symbol-hash])) 1403 n))] 1404 1405 [("value" . "v") 1406 "inspect top-level-value of symbol" 1407 (() (down ((object) 'top-level-value) 0))] 1408 1409 [("value-slot" . "vs") 1410 "inspect value slot of symbol" 1411 (() (down ((object) '$top-level-value) 0))] 1412 1413 [("name" . "n") 1414 "inspect name of symbol" 1415 (() (down ((object) 'name) 1))] 1416 1417 [("property-list" . "pl") 1418 "inspect property-list of symbol" 1419 (() (down ((object) 'property-list) 2))] 1420 1421 [("system-property-list" . "spl") 1422 "inspect system property-list of symbol" 1423 (() (down ((object) 'system-property-list) 4))] 1424 1425 [("symbol-hash" . "sh") 1426 "inspect hash code" 1427 (() (down ((object) 'symbol-hash) 5))] 1428 1429 [("show" . "s") 1430 "show fields of symbol" 1431 (() 1432 (name-label-line-display ((object) 'top-level-value) "top-level value" 0) 1433 (name-label-line-display ((object) '$top-level-value) "value slot" 1) 1434 (name-label-line-display ((object) 'name) "name" 2) 1435 (name-label-line-display ((object) 'property-list) "properties" 3) 1436 (name-label-line-display ((object) 'system-property-list) "system properties" 4) 1437 (name-label-line-display ((object) 'symbol-hash) "hash code" 5))] 1438)) 1439 1440(define symbol-dispatch-table 1441 (make-dispatch-table 1442 1443 [("ref" . "r") 1444 "inspect value field [n] of symbol" 1445 (() 1446 (down ((object) 'top-level-value) 0)) 1447 ((n) 1448 (range-check n 2) 1449 (down ((object) 1450 (case n 1451 [(0) 'top-level-value] 1452 [(1) 'name] 1453 [(2) 'property-list])) 1454 n))] 1455 1456 [("value" . "v") 1457 "inspect top-level-value of symbol" 1458 (() (down ((object) 'top-level-value) 0))] 1459 1460 [("name" . "n") 1461 "inspect name of symbol" 1462 (() (down ((object) 'name) 1))] 1463 1464 [("property-list" . "pl") 1465 "inspect property-list of symbol" 1466 (() (down ((object) 'property-list) 2))] 1467 1468 [("show" . "s") 1469 "show fields of symbol" 1470 (() 1471 (name-label-line-display ((object) 'top-level-value) "top level value" 0) 1472 (name-label-line-display ((object) 'name) "name" 1) 1473 (name-label-line-display ((object) 'property-list) "properties" 2))] 1474)) 1475 1476(define procedure-dispatch-table 1477 (make-dispatch-table 1478 1479 [("length" . "l") 1480 "display number of free variables" 1481 (() (show " ~d free variables" ((object) 'length)))] 1482 1483 [("ref" . "r") 1484 "inspect [nth] free variable" 1485 (() (ref 0)) 1486 ((x) (variable-ref x))] 1487 1488 [("set!" . "!") 1489 "set [nth or named] free variable to value, if assignable" 1490 (() 1491 (let ([e (waiter-read)]) 1492 (unless (eof-object? e) 1493 (set 0 ((object) 'eval e))))) 1494 ((x) 1495 (let ([e (waiter-read)]) 1496 (unless (eof-object? e) 1497 (variable-set x ((object) 'eval e))))) 1498 ((x e) (variable-set x ((object) 'eval e)))] 1499 1500 [("eval" . "e") 1501 "evaluate expression in context of procedure environment" 1502 (() 1503 (let ([x (waiter-read)]) 1504 (unless (eof-object? x) 1505 (inspector-print ((object) 'eval x))))) 1506 ((x) 1507 (inspector-print ((object) 'eval x)))] 1508 1509 [("show" . "s") 1510 "show code and free variables" 1511 (() 1512 (let ([source (((object) 'code) 'source)]) 1513 (when source (name-line-display source "code"))) 1514 (when (> ((object) 'length) 0) 1515 (show "~afree variables:" line-indent) 1516 (display-variable-refs ((object) 'length))))] 1517 1518 [("code" . "c") 1519 "inspect the code for the procedure" 1520 (() 1521 (let ([source (((object) 'code) 'source)]) 1522 (if source 1523 (down source #f) 1524 (show "source code not available"))))] 1525 1526 ["file" 1527 "switch to source file containing the procedure" 1528 (() (open-recorded-source-file ((object) 'code))) 1529 ((path) 1530 (unless (or (string? path) (symbol? path)) 1531 (inspect-error "invalid path ~s" path)) 1532 (open-source-file (if (symbol? path) (symbol->string path) path)))] 1533)) 1534 1535(define code-dispatch-table 1536 (make-dispatch-table 1537 1538 [("length" . "l") 1539 "display number of free variables" 1540 (() (show " ~d free variables" ((object) 'free-count)))] 1541 1542 [("show" . "s") 1543 "show code" 1544 (() 1545 (let ([source ((object) 'source)]) 1546 (when source (name-line-display source "code"))))] 1547 1548 [("code" . "c") 1549 "inspect the code" 1550 (() 1551 (let ([source ((object) 'source)]) 1552 (if source 1553 (down source #f) 1554 (show "source code not available"))))] 1555 1556 ["file" 1557 "switch to source file containing the procedure" 1558 (() (open-recorded-source-file (object))) 1559 ((path) 1560 (unless (or (string? path) (symbol? path)) 1561 (inspect-error "invalid path ~s" path)) 1562 (open-source-file (if (symbol? path) (symbol->string path) path)))] 1563)) 1564 1565 1566(define continuation-dispatch-table 1567 (let () 1568 (define reposition 1569 (lambda (incr) 1570 (let ([old-pos ((object) 'pos)]) 1571 (unless (fx= old-pos 0) (up)) 1572 (let ([pos (fx+ old-pos incr)]) 1573 (when (fx>= pos ((object) 'depth)) (invalid-movement)) 1574 (if (fx> pos 0) 1575 (let ((link ((object) 'reposition pos))) 1576 (unless (type? 'continuation link) (invalid-movement)) 1577 (down link #f)) 1578 (unless (fx= pos 0) (invalid-movement))))))) 1579 1580 (define continuation-show 1581 (lambda (free?) 1582 (name-line-display ((object) 'link) "continuation") 1583 (let ([source (((object) 'code) 'source)]) 1584 (when source (name-line-display source "procedure code"))) 1585 (let ([source ((object) 'source)]) 1586 (when source (name-line-display source "call code"))) 1587 (let ([cp ((object) 'closure)]) 1588 (when cp (name-line-display cp "closure"))) 1589 (let ([len ((object) (if free? 'length 'frame-length))]) 1590 (when (> len 0) 1591 (show "~a~a:" line-indent (if free? "frame and free variables" "frame variables")) 1592 (display-variable-refs len))))) 1593 1594 (make-dispatch-table 1595 1596 [("length" . "l") 1597 "display number of frame and closure variables" 1598 (() (show " ~d variables" ((object) 'length)))] 1599 1600 ["depth" 1601 "display number of frames in continuation stack" 1602 (() (let ((d ((object) 'depth))) 1603 (show (if (= d 1) " ~d frame" " ~d frames") d)))] 1604 1605 [("ref" . "r") 1606 "inspect [named or nth] variable" 1607 (() (ref 0)) 1608 ((x) (variable-ref x))] 1609 1610 [("set!" . "!") 1611 "set [named or nth] variable to value, if assignable" 1612 (() 1613 (let ([e (waiter-read)]) 1614 (unless (eof-object? e) 1615 (set 0 ((object) 'eval e))))) 1616 ((x) 1617 (let ([e (waiter-read)]) 1618 (unless (eof-object? e) 1619 (variable-set x ((object) 'eval e))))) 1620 ((x e) (variable-set x ((object) 'eval e)))] 1621 1622 [("forward" . "f") 1623 "move to [nth] next frame" 1624 (() (reposition 1)) 1625 ((pos) 1626 (range-check pos) 1627 (reposition pos))] 1628 1629 [("back" . "b") 1630 "move to [nth] previous frame" 1631 (() (reposition -1)) 1632 ((pos) 1633 (range-check pos) 1634 (reposition (fx- pos)))] 1635 1636 [("down" . "d") 1637 "inspect [nth] next frame" 1638 (() (let ((link ((object) 'link))) 1639 (unless (type? 'continuation link) (invalid-movement)) 1640 (down link #f))) 1641 ((n) 1642 (range-check n (- ((object) 'depth) 1)) 1643 (let ((link ((object) 'link* n))) 1644 (unless (type? 'continuation link) (invalid-movement)) 1645 (down link #f)))] 1646 1647 [("closure" . "cp") 1648 "inspect the frame's closure, if any" 1649 (() (let ([cp ((object) 'closure)]) 1650 (unless cp (inspect-error "this frame has no closure")) 1651 (down cp #f)))] 1652 1653 [("eval" . "e") 1654 "evaluate expression in context of current frame" 1655 (() 1656 (let ([x (waiter-read)]) 1657 (unless (eof-object? x) 1658 (inspector-print ((object) 'eval x))))) 1659 ((x) 1660 (inspector-print ((object) 'eval x)))] 1661 1662 [("show" . "s") 1663 "show frame with free variables" 1664 (() (continuation-show #t))] 1665 1666 [("show-local" . "sl") 1667 "show frame without free variables" 1668 (() (continuation-show #f))] 1669 1670 [("show-frames" . "sf") 1671 "show the next [n] frames" 1672 (() (display-links (most-positive-fixnum))) 1673 ((n) 1674 (range-check n) 1675 (display-links n))] 1676 1677 ["call" 1678 "inspect the code for the pending call" 1679 (() 1680 (let ([source ((object) 'source)]) 1681 (if source 1682 (down source #f) 1683 (show "source code not available"))))] 1684 1685 [("code" . "c") 1686 "inspect the code for the pending procedure" 1687 (() 1688 (let ([source (((object) 'code) 'source)]) 1689 (if source 1690 (down source #f) 1691 (show "source code not available"))))] 1692 1693 ["file" 1694 "switch to source file containing the pending call" 1695 (() (open-recorded-source-file (object))) 1696 ((path) 1697 (unless (or (string? path) (symbol? path)) 1698 (inspect-error "invalid path ~s" path)) 1699 (open-source-file (if (symbol? path) (symbol->string path) path)))] 1700 1701 ))) 1702 1703(define port-dispatch-table 1704 (make-dispatch-table 1705 1706 [("show" . "s") 1707 "show port contents" 1708 (() 1709 (name-line-display ((object) 'name) "name") 1710 (name-line-display ((object) 'handler) "handler") 1711 (when ((object) 'input?) 1712 (show "~ainput size: ~s" line-indent ((object) 'input-size)) 1713 (show "~ainput index: ~s" line-indent ((object) 'input-index))) 1714 (when ((object) 'output?) 1715 (show "~aoutput size: ~s" line-indent ((object) 'output-size)) 1716 (show "~aoutput index: ~s" line-indent ((object) 'output-index))))] 1717 1718 ["name" 1719 "inspect port name" 1720 (() (down ((object) 'name) #f))] 1721 1722 ["handler" 1723 "inspect port handler" 1724 (() (down ((object) 'handler) #f))] 1725 1726 [("output-buffer" . "ob") 1727 "inspect output buffer" 1728 (() (if ((object) 'output?) 1729 (down ((object) 'output-buffer) #f) 1730 (show "not an output port")))] 1731 1732 [("input-buffer" . "ib") 1733 "inspect input buffer" 1734 (() (if ((object) 'input?) 1735 (down ((object) 'input-buffer) #f) 1736 (show "not an input port")))] 1737)) 1738 1739(define tlc-dispatch-table 1740 (make-dispatch-table 1741 1742 ["keyval" 1743 "inspect keyval field" 1744 (() (down ((object) 'keyval) #f))] 1745 1746 ["ht" 1747 "inspect ht field" 1748 (() (down ((object) 'ht) #f))] 1749 1750 ["next" 1751 "inspect next field" 1752 (() (down ((object) 'next) #f))] 1753 1754 [("ref" . "r") 1755 "inspect named field" 1756 ((x) 1757 (down ((object) 1758 (case x 1759 [(keyval) 'keyval] 1760 [(ht) 'ht] 1761 [(next) 'next] 1762 [else (invalid-command)])) 1763 x))] 1764 1765 [("show" . "s") 1766 "show fields of tlc" 1767 (() 1768 (name-line-display ((object) 'keyval) "keyval") 1769 (name-line-display ((object) 'ht) "ht") 1770 (name-line-display ((object) 'next) "next"))] 1771)) 1772 1773(define phantom-dispatch-table 1774 (make-dispatch-table 1775 1776 ["content-size" 1777 "show size field" 1778 (() (name-line-display ((object) 'content-size) "content-size"))] 1779 1780)) 1781 1782(set! inspect 1783 (lambda (x) 1784 (let ([t (set-timer 0)]) 1785 (call/cc 1786 (lambda (k) 1787 (fluid-let ([current-state (make-state (inspect/object x))] 1788 [marks (make-eq-hashtable)] 1789 [source-files '()]) 1790 (parameterize ([outer-reset-handler (reset-handler)] 1791 [exit-handler k] 1792 [$interrupt reset]) 1793 (put-mark default-mark) 1794 (dynamic-wind 1795 void 1796 (lambda () (inspector '("?"))) 1797 (lambda () (for-each close-source-file source-files))))))) 1798 (set-timer t)) 1799 (void))) 1800 1801) 1802 1803(define inspect/object 1804 (lambda (x) 1805 (define compute-size 1806 (let ([size-ht #f]) 1807 (lambda (x g) 1808 (unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)) 1809 ($oops 'inspector-object "invalid generation ~s" g)) 1810 ; using a common size-ht for a single inspect/object call means: 1811 ; (inspect (let ([x (list 1 2)]) (set-car! x x) (set-car! (cdr x) x) (set-cdr! (cdr x) x) x)) 1812 ; size => 16 1813 ; cdr, size => 8 1814 ; might be what we want, might not be 1815 (unless size-ht (set! size-ht (make-eq-hashtable))) 1816 ($compute-size x (if (eq? g 'static) (constant static-generation) g) size-ht)))) 1817 1818 (define-syntax make-object-maker 1819 (lambda (x) 1820 (syntax-case x () 1821 [(_ object-name inits [method args e1 e2 ...] ...) 1822 (andmap identifier? #'(object-name method ...)) 1823 #'(lambda inits 1824 (let ([method (lambda args e1 e2 ...)] ...) 1825 (lambda (m . rest) 1826 (case m 1827 [(type) 'object-name] 1828 [(make-me-a-child) (make-object (car rest))] 1829 [(method) (#2%apply method rest)] 1830 ... 1831 [else ($oops 'inspector-object 1832 "invalid message ~s to object type ~s" 1833 m 1834 'object-name)]))))]))) 1835 1836 (define frame-eval 1837 (lambda (vars expr) 1838 (define frame-name 1839 (let ((ls '(%0 %1 %2 %3 %4 %5 %6 %7))) 1840 (let ((n (length ls))) 1841 (lambda (i) 1842 (if (< i n) 1843 (list-ref ls i) 1844 (string->symbol (format "%~d" i))))))) 1845 (define ->nongensym 1846 (lambda (name) 1847 (if (gensym? name) 1848 (string->symbol (symbol->string name)) 1849 name))) 1850 (let ((n (vector-length vars))) 1851 (eval (let f ((i 0)) 1852 (if (= i n) 1853 expr 1854 (let ([var (vector-ref vars i)] 1855 [body (f (+ i 1))]) 1856 (let ([raw-val (var 'raw-value)] 1857 [name (var 'name)] 1858 [fv (frame-name i)] 1859 [t (gensym)]) 1860 `(let ([,t (quote ,raw-val)]) 1861 (let-syntax ([,fv ,(if (assignable? raw-val) 1862 `(identifier-syntax [id (car ,t)] [(set! id e) (set-car! ,t e)]) 1863 `(identifier-syntax 1864 [id ,t] 1865 [(set! id e) 1866 (syntax-error #'id "cannot set non-assigned variable")]))]) 1867 ,(if name `(begin (alias ,(->nongensym name) ,fv) ,body) body))))))))))) 1868 1869 (define make-pair-object 1870 (make-object-maker pair (x) 1871 [value () x] 1872 [car () (make-object (car x))] 1873 [cdr () (make-object (cdr x))] 1874 [length () 1875 (let ([ht (make-eq-hashtable)]) 1876 (let length ([x x] [n 0]) 1877 (cond 1878 [(null? x) `(proper ,n)] 1879 [(not (pair? x)) `(improper ,n)] 1880 [else 1881 (let ([a (eq-hashtable-cell ht x #f)]) 1882 (if (cdr a) 1883 `(circular ,n) 1884 (begin (set-cdr! a #t) 1885 (length (cdr x) (+ n 1)))))])))] 1886 [size (g) (compute-size x g)] 1887 [write (p) (write x p)] 1888 [print (p) (pretty-print x p)])) 1889 1890 (define make-box-object 1891 (make-object-maker box (x) 1892 [value () x] 1893 [unbox () (make-object (unbox x))] 1894 [size (g) (compute-size x g)] 1895 [write (p) (write x p)] 1896 [print (p) (pretty-print x p)])) 1897 1898 (define make-tlc-object 1899 (make-object-maker tlc (x) 1900 [value () x] 1901 [keyval () (make-object ($tlc-keyval x))] 1902 [ht () (make-object ($tlc-ht x))] 1903 [next () (make-object ($tlc-next x))] 1904 [size (g) (compute-size x g)] 1905 [write (p) (write x p)] 1906 [print (p) (pretty-print x p)])) 1907 1908 (define make-vector-object 1909 (make-object-maker vector (x) 1910 [value () x] 1911 [length () (vector-length x)] 1912 [ref (i) 1913 (unless (and (fixnum? i) (fx< -1 i (vector-length x))) 1914 ($oops 'vector-object "invalid index ~s" i)) 1915 (make-object (vector-ref x i))] 1916 [size (g) (compute-size x g)] 1917 [write (p) (write x p)] 1918 [print (p) (pretty-print x p)])) 1919 1920 (define make-fxvector-object 1921 (make-object-maker fxvector (x) 1922 [value () x] 1923 [length () (fxvector-length x)] 1924 [ref (i) 1925 (unless (and (fixnum? i) (fx< -1 i (fxvector-length x))) 1926 ($oops 'fxvector-object "invalid index ~s" i)) 1927 (make-object (fxvector-ref x i))] 1928 [size (g) (compute-size x g)] 1929 [write (p) (write x p)] 1930 [print (p) (pretty-print x p)])) 1931 1932 (define make-flvector-object 1933 (make-object-maker flvector (x) 1934 [value () x] 1935 [length () (flvector-length x)] 1936 [ref (i) 1937 (unless (and (flonum? i) (fx< -1 i (flvector-length x))) 1938 ($oops 'flvector-object "invalid index ~s" i)) 1939 (make-object (flvector-ref x i))] 1940 [size (g) (compute-size x g)] 1941 [write (p) (write x p)] 1942 [print (p) (pretty-print x p)])) 1943 1944 (define make-bytevector-object 1945 (make-object-maker bytevector (x) 1946 [value () x] 1947 [length () (bytevector-length x)] 1948 [ref (i) 1949 (unless (and (fixnum? i) (fx< -1 i (bytevector-length x))) 1950 ($oops 'bytevector-object "invalid index ~s" i)) 1951 (make-object (bytevector-u8-ref x i))] 1952 [size (g) (compute-size x g)] 1953 [write (p) (write x p)] 1954 [print (p) (pretty-print x p)])) 1955 1956 (define make-stencil-vector-object 1957 (make-object-maker stencil-vector (x) 1958 [value () x] 1959 [length () (stencil-vector-length x)] 1960 [mask () (stencil-vector-mask x)] 1961 [ref (i) 1962 (unless (and (fixnum? i) (fx< -1 i (stencil-vector-length x))) 1963 ($oops 'stencil-vector-object "invalid index ~s" i)) 1964 (make-object (stencil-vector-ref x i))] 1965 [size (g) (compute-size x g)] 1966 [write (p) (write x p)] 1967 [print (p) (pretty-print x p)])) 1968 1969 (define make-phantom-object 1970 (make-object-maker phantom-bytevector (x) 1971 [value () x] 1972 [length () (phantom-bytevector-length x)] 1973 [size (g) (compute-size x g)] 1974 [write (p) (write x p)] 1975 [print (p) (pretty-print x p)])) 1976 1977 (define make-ftype-pointer-object 1978 (lambda (x) 1979 (define (unrecognized-ux ux) 1980 ($oops 'ftype-pointer-object "unrecognized ftype-pointer type ~s" x)) 1981 (define (invalid-field-specifier f) 1982 ($oops 'ftype-pointer-object "invalid field specifier ~s" f)) 1983 (define (invalid-index f) 1984 ($oops 'ftype-pointer-object "invalid index ~s" f)) 1985 (define (get-field f field*) 1986 (cond 1987 [(assq f field*) => cdr] 1988 [(and (fixnum? f) (#%$fxu< f (length field*))) 1989 (cdr (list-ref field* f))] 1990 [else (invalid-field-specifier f)])) 1991 (define (deref x) 1992 (let ([ux ($unwrap-ftype-pointer x)]) 1993 (record-case ux 1994 [(struct union array * bits) ignore (make-object x)] 1995 [(base) (type getter setter) (make-object (getter))] 1996 [else (unrecognized-ux ux)]))) 1997 (define (deset! who x v) 1998 (let ([ux ($unwrap-ftype-pointer x)]) 1999 (record-case ux 2000 [(struct union array bits) ignore ($oops who "cannot assign struct, union, or array")] 2001 [(*) (get-fptr set-fptr!) (set-fptr! who v)] 2002 [(base) (type getter setter) (setter v)] 2003 [else (unrecognized-ux ux)]))) 2004 (let ([ux ($unwrap-ftype-pointer x)]) 2005 (record-case ux 2006 [(struct) field* 2007 ((make-object-maker ftype-struct (x) 2008 [value () x] 2009 [ftype () (make-object (ftype-pointer-ftype x))] 2010 [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))] 2011 [length () (length field*)] 2012 [ref (f) (deref (get-field f field*))] 2013 [set! (f v) (deset! 'ftype-struct-object (get-field f field*) v)] 2014 [size (g) (compute-size x g)] 2015 [write (p) (write `(ftype struct ...) p)] 2016 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 2017 x)] 2018 [(union) field* 2019 ((make-object-maker ftype-union (x) 2020 [value () x] 2021 [ftype () (make-object (ftype-pointer-ftype x))] 2022 [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))] 2023 [length () (length field*)] 2024 [ref (f) (deref (get-field f field*))] 2025 [set! (f v) (deset! 'ftype-union-object (get-field f field*) v)] 2026 [size (g) (compute-size x g)] 2027 [write (p) (write `(ftype union ...) p)] 2028 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 2029 x)] 2030 [(array) (n get-fptr) 2031 ((make-object-maker ftype-array (x) 2032 [value () x] 2033 [ftype () (make-object (ftype-pointer-ftype x))] 2034 [length () n] 2035 [ref (f) 2036 (unless (and (integer? f) (exact? f) (#%$fxu< f n)) 2037 (invalid-index f)) 2038 (deref (get-fptr f))] 2039 [set! (f v) 2040 (unless (and (integer? f) (exact? f) (#%$fxu< f n)) 2041 (invalid-index f)) 2042 (deset! 'ftype-array-object (get-fptr f) v)] 2043 [size (g) (compute-size x g)] 2044 [write (p) (write `(ftype array ...) p)] 2045 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 2046 x)] 2047 [(*) (get-fptr set-fptr!) 2048 ((make-object-maker ftype-* (x) 2049 [value () x] 2050 [ftype () (make-object (ftype-pointer-ftype x))] 2051 [ref () (deref (get-fptr))] 2052 [set! (v) (deset! 'ftype-*-object (get-fptr) v)] 2053 [size (g) (compute-size x g)] 2054 [write (p) (write `(ftype * ...) p)] 2055 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 2056 x)] 2057 [(bits) field* 2058 ((make-object-maker ftype-bits (x) 2059 [value () x] 2060 [ftype () (make-object (ftype-pointer-ftype x))] 2061 [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))] 2062 [length () (length field*)] 2063 [ref (f) (apply (lambda (getter setter) (make-object (getter))) 2064 (get-field f field*))] 2065 [set! (f v) (apply (lambda (getter setter) (make-object (setter v))) 2066 (get-field f field*))] 2067 [size (g) (compute-size x g)] 2068 [write (p) (write `(ftype bits ...) p)] 2069 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 2070 x)] 2071 [(base) (type getter setter) 2072 ((make-object-maker ftype-base (x) 2073 [value () x] 2074 [ftype () (make-object (ftype-pointer-ftype x))] 2075 [ref () (make-object (getter))] 2076 [set! (v) (setter v)] 2077 [size (g) (compute-size x g)] 2078 [write (p) (write `(ftype ,type ...) p)] 2079 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 2080 x)] 2081 [(function) (name) 2082 ((make-object-maker ftype-function (x) 2083 [value () x] 2084 [ftype () (make-object (ftype-pointer-ftype x))] 2085 [address () (make-object (ftype-pointer-address x))] 2086 [name () (make-object name)] 2087 [size (g) (compute-size x g)] 2088 [write (p) (write `(ftype function ...) p)] 2089 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 2090 x)] 2091 [else (unrecognized-ux ux)])))) 2092 2093 (define make-record-object 2094 (lambda (x) 2095 (let* ((rtd ($record-type-descriptor x)) 2096 (fields (if (record-type-named-fields? rtd) 2097 (csv7:record-type-field-names rtd) 2098 (csv7:record-type-field-indices rtd)))) 2099 (define check-field 2100 (lambda (f) 2101 (unless (or (and (symbol? f) (memq f fields)) 2102 (and (fixnum? f) (fx>= f 0) (fx< f (length fields)))) 2103 ($oops 'record-object "invalid field specifier ~s" f)))) 2104 ((make-object-maker record (x) 2105 [value () x] 2106 [length () (length fields)] 2107 [fields () (make-object fields)] 2108 [accessible? (f) 2109 (check-field f) 2110 (csv7:record-field-accessible? rtd f)] 2111 [mutable? (f) 2112 (check-field f) 2113 (csv7:record-field-mutable? rtd f)] 2114 [name () (make-object (csv7:record-type-name rtd))] 2115 [rtd () (make-object rtd)] 2116 [ref (f) 2117 (check-field f) 2118 (unless (csv7:record-field-accessible? rtd f) 2119 ($oops 'record-object "field ~s is inaccessible" f)) 2120 (make-object ((csv7:record-field-accessor rtd f) x))] 2121 [set! (f v) 2122 (check-field f) 2123 (unless (csv7:record-field-mutable? rtd f) 2124 ($oops 'record-object "field ~s is immutable" f)) 2125 ((csv7:record-field-mutator rtd f) x v)] 2126 [size (g) (compute-size x g)] 2127 [write (p) (write x p)] 2128 [print (p) (pretty-print x p)]) 2129 x)))) 2130 2131 (define make-string-object 2132 (make-object-maker string (x) 2133 [value () x] 2134 [length () (string-length x)] 2135 [ref (i) 2136 (unless (and (fixnum? i) (< -1 i (string-length x))) 2137 ($oops 'string-object "invalid index ~s" i)) 2138 (make-object (string-ref x i))] 2139 [size (g) (compute-size x g)] 2140 [write (p) (write x p)] 2141 [print (p) (pretty-print x p)])) 2142 2143 (define make-simple-object 2144 (make-object-maker simple (x) 2145 [value () x] 2146 [size (g) (compute-size x g)] 2147 [write (p) (write x p)] 2148 [print (p) (pretty-print x p)])) 2149 2150 (define make-unbound-object 2151 (make-object-maker unbound (x) 2152 [value () x] 2153 [size (g) (compute-size x g)] 2154 [write (p) (write x p)] 2155 [print (p) (pretty-print x p)])) 2156 2157 (define make-procedure-object 2158 (lambda (x) 2159 (real-make-procedure-object x (list->vector (make-procedure-vars x))))) 2160 2161 (define real-make-procedure-object 2162 (make-object-maker procedure (x vars) 2163 [value () x] 2164 [length () (vector-length vars)] 2165 [ref (i) 2166 (unless (and (fixnum? i) (fx< -1 i (vector-length vars))) 2167 ($oops 'procedure-object "invalid index ~s" i)) 2168 (vector-ref vars i)] 2169 [eval (x) (frame-eval vars x)] 2170 [code () (make-object ($closure-code x))] 2171 [size (g) (compute-size x g)] 2172 [write (p) (write x p)] 2173 [print (p) (pretty-print x p)])) 2174 2175 (define make-procedure-vars 2176 (lambda (x) 2177 (include "types.ss") 2178 (let ([code ($closure-code x)]) 2179 (let ([info ($code-info code)] 2180 [len ($code-free-count code)]) 2181 (let ([free (and (code-info? info) (code-info-free info))]) 2182 (unless (or (not free) (fx= (vector-length free) len)) 2183 ($oops 'inspector "invalid info structure ~s" info)) 2184 (let vars ([i 0]) 2185 (if (= i len) 2186 '() 2187 (cons (make-variable-object 2188 ($closure-ref x i) 2189 (and free (vector-ref free i))) 2190 (vars (+ i 1)))))))))) 2191 2192 (define assignable? 2193 (lambda (raw-val) 2194 (and (pair? raw-val) ($unbound-object? (cdr raw-val))))) 2195 2196 (define make-variable-object 2197 (make-object-maker variable (x name) 2198 [name () name] 2199 [assignable? () (assignable? x)] 2200 [raw-value () x] 2201 [ref () (make-object 2202 (if (assignable? x) 2203 (car x) 2204 x))] 2205 [set! (v) (make-object 2206 (if (assignable? x) 2207 (set-car! x v) 2208 ($oops 'variable-object "unassignable variable")))] 2209 [size (g) 2210 (if (assignable? x) 2211 (fx+ (constant size-pair) (compute-size (car x) g)) 2212 (compute-size x g))] 2213 [write (p) (display "#<variable>" p)] 2214 [print (p) (display "#<variable>" p) (newline p)])) 2215 2216 (define get-reloc-objs 2217 (foreign-procedure "(cs)s_get_reloc" 2218 (scheme-object boolean) scheme-object)) 2219 2220 (module (get-code-src get-code-sexpr) 2221 (include "types.ss") 2222 (define get-code-src 2223 (lambda (x) 2224 (let ([info ($code-info x)]) 2225 (and (code-info? info) (code-info-src info))))) 2226 (define get-code-sexpr 2227 (lambda (x) 2228 (let ([info ($code-info x)]) 2229 (and (code-info? info) (code-info-sexpr info)))))) 2230 2231 (define make-code-object 2232 (make-object-maker code (x) 2233 [value () x] 2234 [name () ($code-name x)] 2235 [info () (make-object ($code-info x))] 2236 [free-count () ($code-free-count x)] 2237 [arity-mask () ($code-arity-mask x)] 2238 [source () 2239 (cond 2240 [(get-code-sexpr x) => make-object] 2241 [else #f])] 2242 [source-path () (return-source (get-code-src x))] 2243 [source-object () (get-code-src x)] 2244 [reloc () (make-object (get-reloc-objs x #f))] 2245 [reloc+offset () (make-object (get-reloc-objs x #t))] 2246 [size (g) (compute-size x g)] 2247 [write (p) (write x p)] 2248 [print (p) (pretty-print x p)])) 2249 2250 (define return-source 2251 (lambda (src) 2252 (include "types.ss") 2253 (if src 2254 (call-with-values 2255 (lambda () ((current-locate-source-object-source) src #t #f)) 2256 (case-lambda 2257 [() (let ([sfd (source-sfd src)] [fp (source-bfp src)]) 2258 (values (source-file-descriptor-name sfd) fp))] 2259 [(path line char) (values path line char)])) 2260 (values)))) 2261 2262 (define-who make-continuation-object 2263 (lambda (x pos) 2264 (include "types.ss") 2265 (define find-rpi 2266 (lambda (offset rpis) 2267 (let f ([start 0] [end (fx1- (vector-length rpis))]) 2268 (if (fx< end start) 2269 #f 2270 (let* ([curr (fx+ (fx/ (fx- end start) 2) start)] 2271 [rpi (vector-ref rpis curr)] 2272 [rpi-offset (rp-info-offset rpi)]) 2273 (cond 2274 [(fx= offset rpi-offset) rpi] 2275 [(fx< offset rpi-offset) (f start (fx1- curr))] 2276 [else (f (fx1+ curr) end)])))))) 2277 ($split-continuation x 0) 2278 (let ([info ($code-info ($continuation-return-code x))] 2279 [offset ($continuation-return-offset x)] 2280 [len ($continuation-stack-length x)] 2281 [lpm ($continuation-return-livemask x)]) 2282 (cond 2283 [(and (code-info? info) (code-info-rpis info) (find-rpi offset (code-info-rpis info))) => 2284 (lambda (rpi) 2285 (let ([cookie '(chocolate . chip)]) 2286 (let ([vals (make-vector len cookie)] [vars (make-vector len '())] [live (code-info-live info)]) 2287 ; fill vals based on live-pointer mask 2288 (let f ([i 1] [lpm lpm]) 2289 (unless (>= i len) 2290 (when (odd? lpm) 2291 (vector-set! vals (fx1- i) ($continuation-stack-ref x i))) 2292 (f (fx1+ i) (ash lpm -1)))) 2293 ; fill vars based on code-info variable mask 2294 (let f ([i 0] [mask (rp-info-mask rpi)]) 2295 (unless (eqv? mask 0) 2296 (when (odd? mask) 2297 (let ([p (vector-ref live i)]) 2298 (let ([index (fx1- (cdr p))]) 2299 (vector-set! vars index (cons (car p) (vector-ref vars index)))))) 2300 (f (+ i 1) (ash mask -1)))) 2301 ; create return vector 2302 (with-values 2303 (let f ([i 0] [count 0] [cp #f] [cpvar* '()]) 2304 (if (fx= i len) 2305 (if cp 2306 (let ([v (let f ([count count] [cpvar* cpvar*]) 2307 (if (null? cpvar*) 2308 (make-vector count) 2309 (let ([v (f (fx+ count 1) (cdr cpvar*))]) 2310 (vector-set! v count (car cpvar*)) 2311 v)))]) 2312 (values v count cp)) 2313 (values (make-vector count) count cp)) 2314 (let ([obj (vector-ref vals i)] [var* (vector-ref vars i)]) 2315 (cond 2316 [(and (eq? obj cookie) 2317 (or (null? var*) 2318 ;; unboxed variable? 2319 (not (and (pair? var*) (box? (car var*)) (null? (cdr var*)))))) 2320 (unless (null? var*) 2321 ($oops who "expected value for ~s but it was not in lpm" (car var*))) 2322 (f (fx1+ i) count cp cpvar*)] 2323 [(null? var*) 2324 (let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)]) 2325 (vector-set! v count (make-variable-object obj #f)) 2326 (values v frame-count cp))] 2327 [else 2328 (let g ([var* var*] [count count] [cp cp] [cpvar* cpvar*]) 2329 (if (null? var*) 2330 (f (fx1+ i) count cp cpvar*) 2331 (let ([var (car var*)]) 2332 (if (eq? var cpsymbol) 2333 (g (cdr var*) count obj (if (procedure? obj) (make-procedure-vars obj) '())) 2334 (cond 2335 [(pair? var) ; closure environment represented as a pair 2336 (unless (pair? obj) 2337 ($oops who "expected pair value for paired environment, not ~s" obj)) 2338 (g (cdr var*) count obj (list 2339 (make-variable-object (car obj) (car var)) 2340 (make-variable-object (cdr obj) (cdr var))))] 2341 [(vector? var) ; closure environment represented as a vector 2342 (unless (vector? obj) 2343 ($oops who "expected vector value for vector environment, not ~s" obj)) 2344 (g (cdr var*) count obj (map (lambda (obj var) (make-variable-object obj var)) 2345 (vector->list obj) 2346 (vector->list var)))] 2347 [else 2348 (let-values ([(v frame-count cp) (g (cdr var*) (fx1+ count) cp cpvar*)]) 2349 (vector-set! v count (cond 2350 [(box? var) 2351 ;; unboxed variable 2352 (make-variable-object '<unboxed-flonum> (unbox var))] 2353 [else 2354 (make-variable-object obj var)])) 2355 (values v frame-count cp))])))))])))) 2356 (lambda (v frame-count cp) 2357 (real-make-continuation-object x (rp-info-src rpi) (rp-info-sexpr rpi) cp v frame-count pos))))))] 2358 [else 2359 (let ([v (list->vector 2360 (let f ([i 1] [lpm lpm]) 2361 (cond 2362 [(>= i len) '()] 2363 [(odd? lpm) 2364 (cons (make-variable-object ($continuation-stack-ref x i) #f) 2365 (f (fx1+ i) (ash lpm -1)))] 2366 [else (f (fx1+ i) (ash lpm -1))])))]) 2367 (real-make-continuation-object x #f #f #f v (vector-length v) pos))])))) 2368 2369 (define real-make-continuation-object 2370 (let ((continuation-depth 2371 (foreign-procedure "(cs)continuation_depth" (scheme-object) 2372 iptr))) 2373 (make-object-maker continuation (x src sexpr cp vars frame-count pos) 2374 [value () x] 2375 [length () (vector-length vars)] 2376 [closure () (and cp (make-object cp))] 2377 [frame-length () frame-count] 2378 [depth () (continuation-depth x)] 2379 [ref (i) 2380 (unless (and (fixnum? i) (fx< -1 i (vector-length vars))) 2381 ($oops 'continuation-object "invalid index ~s" i)) 2382 (vector-ref vars i)] 2383 [pos () pos] 2384 [reposition (pos) 2385 (let ((k (and (fixnum? pos) (fx> pos 0) ($split-continuation x pos)))) 2386 (unless k ($oops 'continuation-object "invalid position ~s" pos)) 2387 (make-continuation-object k pos))] 2388 [link () (make-object ($continuation-link x))] 2389 [link* (i) 2390 (let ((k (and (fixnum? i) (fx>= i 0) ($split-continuation x i)))) 2391 (unless k ($oops 'continuation-object "invalid link* depth ~s" i)) 2392 (make-object k))] 2393 [eval (x) (frame-eval vars x)] 2394 [code () (make-object ($continuation-return-code x))] 2395 [source () (and sexpr (make-object sexpr))] 2396 [source-object () src] 2397 [source-path () (return-source src)] 2398 [size (g) (compute-size x g)] 2399 [write (p) (write x p)] 2400 [print (p) (pretty-print x p)]))) 2401 2402 (define make-port-object 2403 (make-object-maker port (x) 2404 [value () x] 2405 [input? () (input-port? x)] 2406 [output? () (output-port? x)] 2407 [binary? () (binary-port? x)] 2408 [closed? () (port-closed? x)] 2409 [handler () (make-object ($port-handler x))] 2410 [output-buffer () (and (output-port? x) 2411 (make-object 2412 (if (textual-port? x) 2413 (textual-port-output-buffer x) 2414 (binary-port-output-buffer x))))] 2415 [output-size () (and (output-port? x) 2416 (if (textual-port? x) 2417 (textual-port-output-size x) 2418 (binary-port-output-size x)))] 2419 [output-index () (and (output-port? x) 2420 (if (textual-port? x) 2421 (textual-port-output-index x) 2422 (binary-port-output-index x)))] 2423 [input-buffer () (and (input-port? x) 2424 (make-object 2425 (if (textual-port? x) 2426 (textual-port-input-buffer x) 2427 (binary-port-input-buffer x))))] 2428 [input-size () (and (input-port? x) 2429 (if (textual-port? x) 2430 (textual-port-input-size x) 2431 (binary-port-input-size x)))] 2432 [input-index () (and (input-port? x) 2433 (if (textual-port? x) 2434 (textual-port-input-index x) 2435 (binary-port-input-index x)))] 2436 [info () (make-object ($port-info x))] 2437 [name () (make-object (port-name x))] 2438 [size (g) (compute-size x g)] 2439 [write (p) (write x p)] 2440 [print (p) (pretty-print x p)])) 2441 2442 (define make-symbol-object 2443 (make-object-maker symbol (x) 2444 [value () x] 2445 [gensym? () (gensym? x)] 2446 [top-level-value () 2447 (if (top-level-bound? x) 2448 (make-object (top-level-value x)) 2449 (make-object ($unbound-object)))] 2450 [$top-level-value () 2451 (if ($top-level-bound? x) 2452 (make-object ($top-level-value x)) 2453 (make-object ($unbound-object)))] 2454 [system-property-list () (make-object ($system-property-list x))] 2455 [symbol-hash () (make-object ($symbol-hash x))] 2456 [name () (make-object (symbol->string x))] 2457 [property-list () (make-object ($symbol-property-list x))] 2458 [size (g) (compute-size x g)] 2459 [write (p) (write x p)] 2460 [print (p) (pretty-print x p)])) 2461 2462 (define make-object 2463 (lambda (x) 2464 (cond 2465 [(pair? x) (make-pair-object x)] 2466 [(symbol? x) (make-symbol-object x)] 2467 [(vector? x) (make-vector-object x)] 2468 [(fxvector? x) (make-fxvector-object x)] 2469 [(flvector? x) (make-flvector-object x)] 2470 [(bytevector? x) (make-bytevector-object x)] 2471 [(stencil-vector? x) (make-stencil-vector-object x)] 2472 ; ftype-pointer? test must come before record? test 2473 [($ftype-pointer? x) (make-ftype-pointer-object x)] 2474 [(or (record? x) (and (eq? (subset-mode) 'system) ($record? x))) 2475 (make-record-object x)] 2476 [(string? x) (make-string-object x)] 2477 [(box? x) (make-box-object x)] 2478 [(procedure? x) 2479 (if ($continuation? x) 2480 (if (= ($continuation-stack-length x) 2481 (constant unscaled-shot-1-shot-flag)) 2482 (make-simple-object x) 2483 (make-continuation-object x 0)) 2484 (make-procedure-object x))] 2485 [($code? x) (make-code-object x)] 2486 [(port? x) (make-port-object x)] 2487 [($unbound-object? x) (make-unbound-object x)] 2488 [($tlc? x) (make-tlc-object x)] 2489 [(phantom-bytevector? x) (make-phantom-object x)] 2490 [else (make-simple-object x)]))) 2491 2492 (make-object x))) 2493 2494(let () 2495 (define rtd-size (csv7:record-field-accessor #!base-rtd 'size)) 2496 (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) 2497 (define $get-code-obj (foreign-procedure "(cs)get_code_obj" (int ptr iptr iptr) ptr)) 2498 (define $code-reloc-size 2499 (lambda (x) 2500 (let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))]) 2501 (if (eqv? reloc-table 0) 2502 0 2503 ($object-ref 'iptr reloc-table (constant reloc-table-size-disp)))))) 2504 (define $code-length 2505 (lambda (x) 2506 ($object-ref 'iptr x (constant code-length-disp)))) 2507 (define $get-reloc 2508 (lambda (x i) 2509 (let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))]) 2510 (and (not (eqv? reloc-table 0)) 2511 ($object-ref 'uptr reloc-table 2512 (fx+ (constant reloc-table-data-disp) 2513 (fx* i (constant ptr-bytes)))))))) 2514 (define-syntax tc-ptr-offsets 2515 (lambda (x) 2516 #`'#,(datum->syntax #'* 2517 (fold-left 2518 (lambda (ls fld) 2519 (apply (lambda (name type disp len) 2520 (if (eq? type 'ptr) 2521 (if len 2522 (do ([len len (fx- len 1)] 2523 [disp disp (fx+ disp (constant ptr-bytes))] 2524 [ls ls (cons disp ls)]) 2525 ((fx= len 0) ls)) 2526 (cons disp ls)) 2527 ls)) 2528 fld)) 2529 '() 2530 (or (getprop 'tc '*fields* #f) ($oops 'tc-ptr-offsets "missing fields for tc")))))) 2531 (define align 2532 (lambda (n) 2533 (fxlogand (fx+ n (fx- (constant byte-alignment) 1)) (fx- (constant byte-alignment))))) 2534 2535 (define (thread->stack-objects thread) 2536 (with-tc-mutex 2537 (let ([tc ($thread-tc thread)]) 2538 (cond 2539 [(eqv? tc 0) 2540 ;; Thread terminated 2541 '()] 2542 [(zero? ($object-ref 'integer-32 tc (constant tc-active-disp))) 2543 ;; Inactive, so we can traverse it while holding the tc mutex 2544 (let ([stack ($object-ref 'scheme-object tc (constant tc-scheme-stack-disp))]) 2545 (let loop ([frame ($object-ref 'scheme-object tc (constant tc-sfp-disp))] [x* '()]) 2546 (cond 2547 [(fx= frame stack) 2548 x*] 2549 [else 2550 (let* ([ret ($object-ref 'scheme-object frame 0)] 2551 [mask+size+mode ($object-ref 'iptr ret (constant compact-return-address-mask+size+mode-disp))] 2552 [compact? (fxlogtest mask+size+mode (constant compact-header-mask))] 2553 [size (if (not compact?) 2554 ($object-ref 'scheme-object ret (constant return-address-frame-size-disp)) 2555 (fxand (fxsrl mask+size+mode (constant compact-frame-words-offset)) 2556 (constant compact-frame-words-mask)))] 2557 [livemask (if (not compact?) 2558 ($object-ref 'scheme-object ret (constant return-address-livemask-disp)) 2559 (fxsrl mask+size+mode (constant compact-frame-mask-offset)))] 2560 [next-frame (fx- frame size)]) 2561 (let frame-loop ([p (fx+ next-frame 1)] [livemask livemask] [x* x*]) 2562 (if (eqv? livemask 0) 2563 (loop next-frame x*) 2564 (frame-loop (fx+ p 1) 2565 (bitwise-arithmetic-shift-right livemask 1) 2566 (if (bitwise-bit-set? livemask 0) 2567 (cons ($object-ref 'scheme-object p 0) x*) 2568 x*)))))])))] 2569 [else 2570 ;; Can't inspect active thread 2571 '()])))) 2572 2573 (define (thread->objects thread) 2574 ;; Get immediate content while holding the tc mutex to be sure 2575 ;; that the thread doesn't terminate while getting its content 2576 (with-tc-mutex 2577 (let ([tc ($thread-tc thread)]) 2578 (cond 2579 [(eqv? tc 0) 2580 ;; Thread terminated 2581 '()] 2582 [else 2583 (map (lambda (disp) ($object-ref 'scheme-object tc disp)) 2584 tc-ptr-offsets)])))) 2585 2586 (set-who! $compute-size 2587 (rec $compute-size 2588 (case-lambda 2589 [(x maxgen) ($compute-size x maxgen (make-eq-hashtable))] 2590 [(x maxgen size-ht) 2591 (define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size 2592 (define compute-size 2593 (lambda (x) 2594 (if (or (fixmediate? x) 2595 (let ([g ($generation x)]) 2596 (or (not g) (fx> g maxgen)))) 2597 0 2598 (let ([a (eq-hashtable-cell size-ht x #f)]) 2599 (cond 2600 [(cdr a) => 2601 (lambda (p) 2602 ; if we find our cookie, return 0 to avoid counting shared structure twice. 2603 ; otherwise, (car p) must be a cookie from an earlier call to $compute-size, 2604 ; so return the recorded size 2605 (if (eq? (car p) cookie) 2606 0 2607 (begin 2608 (set-car! p cookie) 2609 (cdr p))))] 2610 [else 2611 (let ([p (cons cookie 0)]) 2612 (set-cdr! a p) 2613 (let ([size (really-compute-size x)]) 2614 (set-cdr! p size) 2615 size))]))))) 2616 (define really-compute-size 2617 (lambda (x) 2618 (cond 2619 [(pair? x) 2620 (cond 2621 [(ephemeron-pair? x) 2622 (fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))] 2623 [else 2624 (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))])] 2625 [(symbol? x) 2626 (fx+ (constant size-symbol) 2627 (compute-size (#3%$top-level-value x)) 2628 (compute-size ($symbol-property-list x)) 2629 (compute-size ($system-property-list x)) 2630 (compute-size ($symbol-name x)))] 2631 [(vector? x) 2632 (let ([n (vector-length x)]) 2633 (do ([i 0 (fx+ i 1)] 2634 [size (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes)))) 2635 (fx+ size (compute-size (vector-ref x i)))]) 2636 ((fx= i n) size)))] 2637 [(fxvector? x) (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes))))] 2638 [(flvector? x) (align (fx+ (constant header-size-flvector) (fx* (flvector-length x) (constant ptr-bytes))))] 2639 [(bytevector? x) (align (fx+ (constant header-size-bytevector) (bytevector-length x)))] 2640 [(stencil-vector? x) 2641 (let ([n (stencil-vector-length x)]) 2642 (do ([i 0 (fx+ i 1)] 2643 [size (align (fx+ (constant header-size-stencil-vector) (fx* (stencil-vector-length x) (constant ptr-bytes)))) 2644 (fx+ size (compute-size (stencil-vector-ref x i)))]) 2645 ((fx= i n) size)))] 2646 [($record? x) 2647 (let ([rtd ($record-type-descriptor x)]) 2648 (let ([flds (rtd-flds rtd)]) 2649 (cond 2650 [(fixnum? flds) 2651 (let loop ([i 0] [size (fx+ (align (rtd-size rtd)) (compute-size rtd))]) 2652 (cond 2653 [(fx= i flds) size] 2654 [else (loop (fx+ i 1) 2655 (fx+ size (compute-size ($record-ref x i))))]))] 2656 [else 2657 (let loop ([size (fx+ (align (rtd-size rtd)) (compute-size rtd))] [flds flds]) 2658 (cond 2659 [(null? flds) size] 2660 [else 2661 (let ([fld (car flds)]) 2662 (loop (if (eq? (fld-type fld) 'scheme-object) 2663 (fx+ size (compute-size ($object-ref 'scheme-object x (fld-byte fld)))) 2664 size) 2665 (cdr flds)))]))])))] 2666 [(string? x) (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes))))] 2667 [(box? x) (fx+ (constant size-box) (compute-size (unbox x)))] 2668 [(flonum? x) (constant size-flonum)] 2669 [(bignum? x) (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes))))] 2670 [(ratnum? x) (fx+ (constant size-ratnum) (compute-size ($ratio-numerator x)) (compute-size ($ratio-denominator x)))] 2671 [($exactnum? x) (fx+ (constant size-exactnum) (compute-size ($exactnum-real-part x)) (compute-size ($exactnum-imag-part x)))] 2672 [($inexactnum? x) (constant size-inexactnum)] 2673 [(procedure? x) 2674 (if ($continuation? x) 2675 (if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag))) 2676 (constant size-continuation) 2677 (begin 2678 ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate 2679 ; NB: picture of the size prior to splitting. will add overhead to eventual invocation of 2680 ; NB: the continuation as well 2681 ($split-continuation x 0) 2682 ; not following RA slot at base of the frame, but this should always hold dounderflow, 2683 ; which will be in the static generation and therefore ignored anyway after compact heap 2684 (let ([len ($continuation-stack-length x)]) 2685 (let loop ([i 1] 2686 [lpm ($continuation-return-livemask x)] 2687 [size (fx+ (constant size-continuation) 2688 (align (fx* len (constant ptr-bytes))) 2689 (compute-size ($continuation-return-code x)) 2690 (compute-size ($closure-code x)) 2691 (compute-size ($continuation-link x)) 2692 (compute-size ($continuation-winders x)) 2693 (compute-size ($continuation-attachments x)))]) 2694 (if (fx>= i len) 2695 size 2696 (loop (fx+ i 1) (ash lpm -1) (if (odd? lpm) (fx+ size (compute-size ($continuation-stack-ref x i))) size))))))) 2697 (let ([n ($closure-length x)]) 2698 (do ([i 0 (fx+ i 1)] 2699 [size (fx+ (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes)))) (compute-size ($closure-code x))) 2700 (fx+ size (compute-size ($closure-ref x i)))]) 2701 ((fx= i n) size))))] 2702 [($code? x) 2703 (fx+ (align (fx+ (constant header-size-code) ($code-length x))) 2704 (let ([n ($code-reloc-size x)]) 2705 (let loop ([i 0] [size (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes))))] [addr 0]) 2706 (if (fx= i n) 2707 size 2708 (let ([r ($get-reloc x i)]) 2709 (if (not r) 2710 0 2711 (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))]) 2712 (if (logtest r (constant reloc-extended-format)) 2713 (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))]) 2714 (loop (fx+ i 3) 2715 (fx+ size 2716 (compute-size 2717 ($get-code-obj type x addr ($get-reloc x (fx+ i 1))))) 2718 addr)) 2719 (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))]) 2720 (loop (fx+ i 1) 2721 (fx+ size 2722 (compute-size 2723 ($get-code-obj type x addr 2724 (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask))))) 2725 addr))))))))) 2726 (compute-size ($code-name x)) 2727 (compute-size ($code-info x)) 2728 (compute-size ($code-pinfo* x)))] 2729 [(port? x) 2730 (fx+ (constant size-port) 2731 (compute-size ($port-handler x)) 2732 (if (input-port? x) (compute-size (port-input-buffer x)) 0) 2733 (if (output-port? x) (compute-size (port-output-buffer x)) 0) 2734 (compute-size ($port-info x)) 2735 (compute-size (port-name x)))] 2736 [(thread? x) 2737 (fx+ (fold-left (lambda (size x) 2738 (fx+ size (compute-size x))) 2739 (constant size-thread) 2740 (thread->objects x)) 2741 (fold-left (lambda (size x) (fx+ size (compute-size x))) 2742 0 2743 (thread->stack-objects x)))] 2744 [($tlc? x) 2745 (fx+ (constant size-tlc) 2746 (compute-size ($tlc-ht x)) 2747 (compute-size ($tlc-keyval x)) 2748 (compute-size ($tlc-next x)))] 2749 [($rtd-counts? x) (constant size-rtd-counts)] 2750 [(phantom-bytevector? x) 2751 (fx+ (constant size-tlc) 2752 (phantom-bytevector-length x))] 2753 [else ($oops who "missing case for ~s" x)]))) 2754 ; ensure size-ht isn't counted in the size of any object 2755 (eq-hashtable-set! size-ht size-ht (cons cookie 0)) 2756 (compute-size x)]))) 2757 2758 (set-who! $compute-composition 2759 (lambda (x maxgen) 2760 (define cookie (cons 'oatmeal 'raisin)) 2761 (define seen-ht (make-eq-hashtable)) 2762 (define rtd-ht (make-eq-hashtable)) 2763 (define-syntax define-counters 2764 (lambda (x) 2765 (syntax-case x () 2766 [(_ (name-vec count-vec incr!) type ...) 2767 (with-syntax ([(i ...) (enumerate #'(type ...))]) 2768 #'(begin 2769 (define name-vec (vector 'type ...)) 2770 (define count-vec (make-vector (length #'(type ...)) #f)) 2771 (define-syntax incr! 2772 (syntax-rules (type ...) 2773 [(_ type size) 2774 (let ([p (vector-ref count-vec i)]) 2775 (if p 2776 (begin 2777 (set-car! p (fx+ (car p) 1)) 2778 (set-cdr! p (fx+ (cdr p) size))) 2779 (vector-set! count-vec i (cons 1 size))))] 2780 ...))))]))) 2781 (define-counters (type-names type-counts incr!) 2782 pair symbol vector fxvector flvector bytevector stencil-vector string box flonum bignum ratnum exactnum 2783 inexactnum continuation stack procedure code-object reloc-table port thread tlc 2784 rtd-counts phantom) 2785 (define compute-composition! 2786 (lambda (x) 2787 (unless (or (fixmediate? x) 2788 (let ([g ($generation x)]) 2789 (or (not g) (fx> g maxgen)))) 2790 (let ([a (eq-hashtable-cell seen-ht x #f)]) 2791 (unless (cdr a) 2792 (set-cdr! a #t) 2793 (really-compute-composition! x)))))) 2794 (define really-compute-composition! 2795 (lambda (x) 2796 (cond 2797 [(pair? x) 2798 (incr! pair (constant size-pair)) 2799 (compute-composition! (car x)) 2800 (compute-composition! (cdr x))] 2801 [(symbol? x) 2802 (incr! symbol (constant size-symbol)) 2803 (compute-composition! (#3%$top-level-value x)) 2804 (compute-composition! ($symbol-property-list x)) 2805 (compute-composition! ($system-property-list x)) 2806 (compute-composition! ($symbol-name x))] 2807 [(vector? x) 2808 (incr! vector (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes))))) 2809 (vector-for-each compute-composition! x)] 2810 [(fxvector? x) (incr! fxvector (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes)))))] 2811 [(flvector? x) (incr! flvector (align (fx+ (constant header-size-flvector) (fx* (flvector-length x) (constant ptr-bytes)))))] 2812 [(bytevector? x) (incr! bytevector (align (fx+ (constant header-size-bytevector) (bytevector-length x))))] 2813 [(stencil-vector? x) 2814 (let ([len (stencil-vector-length x)]) 2815 (incr! stencil-vector (align (fx+ (constant header-size-stencil-vector) (fx* len (constant ptr-bytes))))) 2816 (let loop ([i len]) 2817 (unless (fx= i 0) 2818 (let ([i (fx- i 1)]) 2819 (compute-composition! (stencil-vector-ref x i)) 2820 (loop i)))))] 2821 [($record? x) 2822 (let ([rtd ($record-type-descriptor x)]) 2823 (let ([p (eq-hashtable-ref rtd-ht rtd #f)] [size (align (rtd-size rtd))]) 2824 (if p 2825 (begin 2826 (set-car! p (fx+ (car p) 1)) 2827 (set-cdr! p (fx+ (cdr p) size))) 2828 (eq-hashtable-set! rtd-ht rtd (cons 1 size)))) 2829 (compute-composition! rtd) 2830 (let ([flds (rtd-flds rtd)]) 2831 (cond 2832 [(fixnum? flds) 2833 (let loop ([i 0]) 2834 (unless (fx= i flds) 2835 (compute-composition! ($record-ref x i)) 2836 (loop (fx+ i 1))))] 2837 [else 2838 (for-each (lambda (fld) 2839 (when (eq? (fld-type fld) 'scheme-object) 2840 (compute-composition! ($object-ref 'scheme-object x (fld-byte fld))))) 2841 (rtd-flds rtd))])))] 2842 [(string? x) (incr! string (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes)))))] 2843 [(box? x) 2844 (incr! box (constant size-box)) 2845 (compute-composition! (unbox x))] 2846 [(flonum? x) (incr! flonum (constant size-flonum))] 2847 [(bignum? x) (incr! bignum (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes)))))] 2848 [(ratnum? x) 2849 (incr! ratnum (constant size-ratnum)) 2850 (compute-composition! ($ratio-numerator x)) 2851 (compute-composition! ($ratio-denominator x))] 2852 [($exactnum? x) 2853 (incr! exactnum (constant size-exactnum)) 2854 (compute-composition! ($exactnum-real-part x)) 2855 (compute-composition! ($exactnum-imag-part x))] 2856 [($inexactnum? x) (incr! inexactnum (constant size-inexactnum))] 2857 [(procedure? x) 2858 (if ($continuation? x) 2859 (begin 2860 (incr! continuation (constant size-continuation)) 2861 (unless (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag))) 2862 ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate 2863 ; NB: picture of the continuation counts & sizes prior to splitting. will add overhead to eventual invocation of 2864 ; NB: the continuation as well 2865 ($split-continuation x 0) 2866 (compute-composition! ($continuation-return-code x)) 2867 (compute-composition! ($closure-code x)) 2868 (compute-composition! ($continuation-link x)) 2869 (compute-composition! ($continuation-winders x)) 2870 (compute-composition! ($continuation-attachments x)) 2871 (let ([len ($continuation-stack-length x)]) 2872 (incr! stack (align (fx* len (constant ptr-bytes)))) 2873 (let loop ([i 1] [lpm ($continuation-return-livemask x)]) 2874 (unless (fx>= i len) 2875 (when (odd? lpm) (compute-composition! ($continuation-stack-ref x i))) 2876 (loop (fx+ i 1) (ash lpm -1))))))) 2877 (begin 2878 (compute-composition! ($closure-code x)) 2879 (let ([n ($closure-length x)]) 2880 (incr! procedure (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes))))) 2881 (do ([i 0 (fx+ i 1)]) 2882 ((fx= i n)) 2883 (compute-composition! ($closure-ref x i))))))] 2884 [($code? x) 2885 (incr! code-object (align (fx+ (constant header-size-code) ($code-length x)))) 2886 (let ([n ($code-reloc-size x)]) 2887 (incr! reloc-table (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes))))) 2888 (let loop ([i 0] [addr 0]) 2889 (unless (fx= i n) 2890 (let ([r ($get-reloc x i)]) 2891 (and r 2892 (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))]) 2893 (if (logtest r (constant reloc-extended-format)) 2894 (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))]) 2895 (compute-composition! ($get-code-obj type x addr ($get-reloc x (fx+ i 1)))) 2896 (loop (fx+ i 3) addr)) 2897 (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))]) 2898 (compute-composition! 2899 ($get-code-obj type x addr 2900 (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask)))) 2901 (loop (fx+ i 1) addr))))))))) 2902 (compute-composition! ($code-name x)) 2903 (compute-composition! ($code-info x)) 2904 (compute-composition! ($code-pinfo* x))] 2905 [(port? x) 2906 (incr! port (constant size-port)) 2907 (compute-composition! ($port-handler x)) 2908 (if (input-port? x) (compute-composition! (port-input-buffer x)) 0) 2909 (if (output-port? x) (compute-composition! (port-output-buffer x)) 0) 2910 (compute-composition! ($port-info x)) 2911 (compute-composition! (port-name x))] 2912 [(thread? x) 2913 (incr! thread (constant size-thread)) 2914 (for-each compute-composition! (thread->objects x)) 2915 (for-each compute-composition! (thread->stack-objects x))] 2916 [($tlc? x) 2917 (incr! tlc (constant size-tlc)) 2918 (compute-composition! ($tlc-ht x)) 2919 (compute-composition! ($tlc-keyval x)) 2920 (compute-composition! ($tlc-next x))] 2921 [($rtd-counts? x) (incr! rtd-counts (constant size-rtd-counts))] 2922 [(phantom-bytevector? x) (incr! phantom (fx+ (constant size-phantom) 2923 (phantom-bytevector-length x)))] 2924 [else ($oops who "missing case for ~s" x)]))) 2925 ; ensure hashtables aren't counted 2926 (eq-hashtable-set! seen-ht seen-ht #t) 2927 (eq-hashtable-set! seen-ht rtd-ht #t) 2928 (compute-composition! x) 2929 (append 2930 (filter cdr (vector->list (vector-map cons type-names type-counts))) 2931 (vector->list 2932 (let-values ([(keys vals) (hashtable-entries rtd-ht)]) 2933 (vector-map cons keys vals)))))) 2934 2935 (set-who! $make-object-finder 2936 ; pred object maxgen => object-finder procedure that returns 2937 ; next object satisfying pred 2938 ; or #f, if no object found 2939 (lambda (pred x maxgen) 2940 (let ([seen-ht (make-eq-hashtable)]) 2941 (define saved-next-proc 2942 (lambda () 2943 (find! x '() (lambda () #f)))) 2944 (define find! 2945 (lambda (x path next-proc) 2946 (let ([path (cons x path)]) 2947 (cond 2948 [(or (fixmediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen)))) 2949 (if (pred x) 2950 (begin (set! saved-next-proc next-proc) path) 2951 (next-proc))] 2952 [else 2953 (if (eq-hashtable-ref seen-ht x #f) 2954 (next-proc) ; detected a loop, so backtrack and keep looking 2955 (begin 2956 (eq-hashtable-set! seen-ht x #t) ; mark this node as visited 2957 (really-find! x path next-proc)))])))) 2958 ; We're visiting this node for the first time 2959 (define really-find! 2960 (lambda (x path next-proc) 2961 (define-syntax construct-proc 2962 (syntax-rules () 2963 [(_ ?next-proc) ?next-proc] 2964 [(_ ?e ?e* ... ?next-proc) 2965 (lambda () (find! ?e path (construct-proc ?e* ... ?next-proc)))])) 2966 (let ([next-proc 2967 (cond 2968 [(pair? x) (construct-proc (car x) (cdr x) next-proc)] 2969 [(symbol? x) 2970 (construct-proc 2971 (#3%$top-level-value x) 2972 ($symbol-property-list x) 2973 ($system-property-list x) 2974 ($symbol-name x) next-proc)] 2975 [(vector? x) 2976 (let ([n (vector-length x)]) 2977 (let f ([i 0]) 2978 (if (fx= i n) 2979 next-proc 2980 (construct-proc (vector-ref x i) (f (fx+ i 1))))))] 2981 [(stencil-vector? x) 2982 (let ([n (stencil-vector-length x)]) 2983 (let f ([i 0]) 2984 (if (fx= i n) 2985 next-proc 2986 (construct-proc (stencil-vector-ref x i) (f (fx+ i 1))))))] 2987 [($record? x) 2988 (let ([rtd ($record-type-descriptor x)]) 2989 (construct-proc rtd 2990 (let ([flds (rtd-flds rtd)]) 2991 (cond 2992 [(fixnum? flds) 2993 (let loop ([i 0]) 2994 (if (fx= i flds) 2995 next-proc 2996 (construct-proc ($record-ref x i) (loop (fx+ i 1)))))] 2997 [else 2998 (let f ([flds (rtd-flds rtd)]) 2999 (if (null? flds) 3000 next-proc 3001 (let ([fld (car flds)]) 3002 (if (eq? (fld-type fld) 'scheme-object) 3003 (construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds))) 3004 (f (cdr flds))))))]))))] 3005 [(or (fxvector? x) (flvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x) 3006 ($inexactnum? x) ($rtd-counts? x) (phantom-bytevector? x)) 3007 next-proc] 3008 [(box? x) (construct-proc (unbox x) next-proc)] 3009 [(ratnum? x) (construct-proc ($ratio-numerator x) ($ratio-denominator x) next-proc)] 3010 [($exactnum? x) (construct-proc ($exactnum-real-part x) ($exactnum-imag-part x) next-proc)] 3011 [(procedure? x) 3012 (if ($continuation? x) 3013 (if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag))) 3014 next-proc 3015 (begin 3016 ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate 3017 ; NB: picture of the size prior to splitting. will add overhead to eventual invocation of 3018 ; NB: the continuation as well 3019 ($split-continuation x 0) 3020 ; not following RA slot at base of the frame, but this should always hold dounderflow, 3021 ; which will be in the static generation and therefore ignored anyway after compact heap 3022 (let ([len ($continuation-stack-length x)]) 3023 (let loop ([i 1] [lpm ($continuation-return-livemask x)]) 3024 (if (fx>= i len) 3025 (construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x) 3026 ($continuation-winders x) ($continuation-attachments x) next-proc) 3027 (if (odd? lpm) 3028 (construct-proc ($continuation-stack-ref x i) (loop (fx+ i 1) (ash lpm -1))) 3029 (loop (fx+ i 1) (ash lpm -1)))))))) 3030 (construct-proc ($closure-code x) 3031 (let ([n ($closure-length x)]) 3032 (let f ([i 0]) 3033 (if (fx= i n) 3034 next-proc 3035 (construct-proc ($closure-ref x i) (f (fx+ i 1))))))))] 3036 [($code? x) 3037 (construct-proc ($code-name x) ($code-info x) ($code-pinfo* x) 3038 (let ([n ($code-reloc-size x)]) 3039 (let loop ([i 0] [addr 0]) 3040 (if (fx= i n) 3041 next-proc 3042 (let ([r ($get-reloc x i)]) 3043 (if (not r) 3044 next-proc 3045 (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))]) 3046 (if (logtest r (constant reloc-extended-format)) 3047 (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))]) 3048 (construct-proc ($get-code-obj type x addr ($get-reloc x (fx+ i 1))) 3049 (loop (fx+ i 3) addr))) 3050 (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))]) 3051 (construct-proc 3052 ($get-code-obj type x addr 3053 (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask))) 3054 (loop (fx+ i 1) addr)))))))))))] 3055 [(port? x) 3056 (construct-proc ($port-handler x) ($port-info x) (port-name x) 3057 (let ([th (lambda () (if (output-port? x) (construct-proc (port-output-buffer x) next-proc) next-proc))]) 3058 (if (input-port? x) (construct-proc (port-input-buffer x) (th)) (th))))] 3059 [(thread? x) 3060 (construct-proc (thread->objects x) (thread->stack-objects x) next-proc)] 3061 [($tlc? x) (construct-proc ($tlc-ht x) ($tlc-keyval x) ($tlc-next x) next-proc)] 3062 [else ($oops who "missing case for ~s" x)])]) 3063 ; check if this node is what we're looking for 3064 (if (pred x) 3065 (begin (set! saved-next-proc next-proc) path) 3066 (next-proc))))) 3067 (rec find-next (lambda () (saved-next-proc))))))) 3068 3069(let () 3070 (define filter-generation 3071 (lambda (who g) 3072 (unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)) 3073 ($oops who "invalid generation ~s" g)) 3074 (if (eq? g 'static) (constant static-generation) g))) 3075 3076 (set-who! make-object-finder 3077 (case-lambda 3078 [(pred) 3079 (unless (procedure? pred) ($oops who "~s is not a procedure" pred)) 3080 ($make-object-finder pred (oblist) (collect-maximum-generation))] 3081 [(pred x) 3082 (unless (procedure? pred) ($oops who "~s is not a procedure" pred)) 3083 ($make-object-finder pred x (collect-maximum-generation))] 3084 [(pred x g) 3085 (unless (procedure? pred) ($oops who "~s is not a procedure" pred)) 3086 ($make-object-finder pred x (filter-generation who g))])) 3087 3088 (set-who! compute-size 3089 (case-lambda 3090 [(x) ($compute-size x (collect-maximum-generation))] 3091 [(x g) ($compute-size x (filter-generation who g))])) 3092 3093 (set-who! compute-size-increments 3094 (let ([count_size_increments (foreign-procedure "(cs)count_size_increments" (ptr int) ptr)]) 3095 (rec compute-size-increments 3096 (case-lambda 3097 [(x*) (compute-size-increments x* (collect-maximum-generation))] 3098 [(x* g) 3099 (unless (list? x*) ($oops who "~s is not a list" x*)) 3100 (let ([g (filter-generation who g)]) 3101 (count_size_increments x* g))])))) 3102 3103 (set-who! compute-composition 3104 (case-lambda 3105 [(x) ($compute-composition x (collect-maximum-generation))] 3106 [(x g) ($compute-composition x (filter-generation who g))]))) 3107 3108(define object-counts (foreign-procedure "(cs)object_counts" () ptr)) 3109 3110(define object-backreferences (foreign-procedure "(cs)object_backreferences" () ptr)) 3111 3112) 3113