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 bytevector string record 458 ftype-struct ftype-union ftype-array ftype-bits) 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 [(bytevector) bytevector-dispatch-table] 497 [(record) record-dispatch-table] 498 [(string) string-dispatch-table] 499 [(box) box-dispatch-table] 500 [(continuation) continuation-dispatch-table] 501 [(procedure) procedure-dispatch-table] 502 [(code) code-dispatch-table] 503 [(port) port-dispatch-table] 504 [(simple) 505 (let ([x ((object) 'value)]) 506 (cond 507 [(char? x) char-dispatch-table] 508 [else empty-dispatch-table]))] 509 [(tlc) tlc-dispatch-table] 510 [(ftype-struct) ftype-struct-dispatch-table] 511 [(ftype-union) ftype-union-dispatch-table] 512 [(ftype-array) ftype-array-dispatch-table] 513 [(ftype-*) ftype-pointer-dispatch-table] 514 [(ftype-bits) ftype-bits-dispatch-table] 515 [(ftype-base) ftype-pointer-dispatch-table] 516 [(ftype-function) ftype-function-dispatch-table] 517 [else empty-dispatch-table]))) 518 519(define inspector-read 520 (lambda (ip) 521 (let* ([ip (console-input-port)] [c (read-char ip)]) 522 (cond 523 [(eof-object? c) 524 (newline (console-output-port)) 525 '("quit")] 526 [(char=? c #\newline) 527 (set-port-bol! (console-output-port) #t) 528 '()] 529 [(char-whitespace? c) 530 (inspector-read ip)] 531 [else 532 (unread-char c ip) 533 (let ([first (inspector-read-command ip)]) 534 (cons first (inspector-read-tail ip)))])))) 535 536(define inspector-read-command 537 (lambda (ip) 538 (let ([p (open-output-string)]) 539 (let read-letters () 540 (let ([c (peek-char ip)]) 541 (if (and (char? c) 542 (not (char-numeric? c)) 543 (not (char-whitespace? c))) 544 (begin (read-char ip) 545 (write-char c p) 546 (read-letters)) 547 (get-output-string p))))))) 548 549(define inspector-read-tail 550 (lambda (ip) 551 (let ([c (peek-char ip)]) 552 (cond 553 [(char=? c #\newline) 554 (read-char ip) 555 (set-port-bol! (console-output-port) #t) 556 '()] 557 [(or (char-whitespace? c) ; [( 558 (memv c '(#\) #\]))) 559 (read-char ip) 560 (inspector-read-tail ip)] 561 [else 562 (let ([x (read ip)]) 563 (cons x (inspector-read-tail ip)))])))) 564 565(define dispatch 566 (lambda (c t) 567 (let ([handler (or (search-dispatch-table (car c) t) 568 (search-dispatch-table (car c) 569 generic-dispatch-table))]) 570 (if handler 571 (apply handler (cdr c)) 572 (invalid-command))))) 573 574(define search-dispatch-table 575 (lambda (s t) 576 (and (not (null? t)) 577 (let ([first (car t)]) 578 (let ([key (car first)]) 579 (if (if (string? key) 580 (string=? key s) 581 (or (string=? (car key) s) 582 (string=? (cdr key) s))) 583 (caddr first) 584 (search-dispatch-table s (cdr t)))))))) 585 586(define spaces 587 (lambda (n) 588 (if (> n 0) 589 (make-string n #\space) 590 ""))) 591 592(define write-to-string 593 (lambda (x) 594 (let ([p (open-output-string)]) 595 (x 'write p) 596 (get-output-string p)))) 597 598(define short-form-rec 599 (lambda (x limit) 600 (let try ([low 1] 601 [high #f] 602 [r (parameterize ([print-level 0] [print-length 0]) 603 (write-to-string x))]) 604 (let ([mid (+ low (if high (quotient (- high low) 2) low))]) 605 (if (= mid low) 606 r 607 (let ([s (parameterize ([print-level mid] [print-length mid]) 608 (write-to-string x))]) 609 (cond 610 [(string=? s r) s] 611 [(> (string-length s) limit) (try low mid r)] 612 [else (try mid high s)]))))))) 613 614(define short-form-lambda 615 ; x looks like "(lambda vars body)" 616 ; print the "lambda" and all of the vars that fit 617 (lambda (x limit) 618 (let ([first (format "(lambda ~a " ;) 619 (short-form-rec ((x 'cdr) 'car) (- limit 14)))]) 620 (let ([rest (short-form-rec ((x 'cdr) 'cdr) 621 (- limit (string-length first)))]) 622 (if (and (> (string-length rest) 0) 623 (char=? (string-ref rest 0) #\()) ;) 624 (string-append first (substring rest 1 (string-length rest))) 625 (short-form-rec x limit)))))) 626 627(define short-form 628 (lambda (x limit) 629 (case (x 'type) 630 [(pair) 631 (if (and (eq? ((x 'car) 'type) 'symbol) 632 (eq? ((x 'car) 'value) 'lambda) 633 (eq? ((x 'cdr) 'type) 'pair) 634 (eq? (((x 'cdr) 'cdr) 'type) 'pair)) 635 (short-form-lambda x limit) 636 (short-form-rec x limit))] 637 [(string) 638 (let ([s (format "~s" 639 ; avoid passing format the whole of a large string 640 (let ([s (x 'value)]) 641 (if (<= (string-length s) limit) 642 s 643 (substring s 0 limit))))]) 644 (if (<= (string-length s) limit) 645 s 646 (string-append 647 (substring s 0 (max (- limit 4) 1)) 648 "...\"")))] 649 [else (short-form-rec x limit)]))) 650 651(define form 652 (lambda (x used limit) 653 (short-form x (- limit used)))) 654 655(define inspector-prompt 656 (lambda () 657 (let ([obj (form (object) 0 prompt-line-limit)]) 658 (fprintf (console-output-port) 659 "~a~a : " 660 obj 661 (spaces (- prompt-line-limit (string-length obj))))))) 662 663(define outer-reset-handler ($make-thread-parameter values)) 664 665(define inspector 666 (lambda (last-command) 667 (inspector 668 (let ([saved-state current-state]) 669 (parameterize ([reset-handler (call/cc 670 (lambda (k) 671 (rec f 672 (lambda () 673 (clear-output-port (console-output-port)) 674 (set! current-state saved-state) 675 (k f)))))]) 676 (let ([ip (console-input-port)]) 677 (clear-input-port ip) 678 (inspector-prompt) 679 (let ([cmd (let ([cmd (inspector-read ip)]) 680 (cond 681 [(null? cmd) 682 (if (equal? (car last-command) "list") 683 '("list") 684 last-command)] 685 [(number? (car cmd)) (cons "ref" cmd)] 686 [else cmd]))]) 687 (cond 688 [(equal? cmd '("?")) 689 (let ([t (select-dispatch-table)]) 690 (if (null? t) 691 (display-options generic-dispatch-table #t) 692 (display-options t #f)))] 693 [(equal? cmd '("??")) 694 (display-options generic-dispatch-table #t)] 695 [else 696 (guard (c [#t (let ([op (console-output-port)]) 697 (fresh-line op) 698 (display-condition c op) 699 (newline op) 700 (set! current-state saved-state))]) 701 (dispatch cmd (select-dispatch-table)))]) 702 cmd))))))) 703 704(define-syntax inspector-print 705 (syntax-rules () 706 [(_ e) 707 (call-with-values (lambda () e) 708 (case-lambda 709 [(x) (unless (eq? x (void)) (pretty-print x (console-output-port)))] 710 [args (for-each (lambda (x) (pretty-print x (console-output-port))) args)]))])) 711 712(module (inspector-find inspector-find-next) 713 (define down-path 714 (lambda (path) 715 (assert (and (list? path) (>= (length path) 1))) 716 (let f ([path path]) 717 (let ([x (car path)] [path (cdr path)]) 718 (if (null? path) 719 (assert (eq? x ((object) 'value))) 720 (begin 721 (f path) 722 (down ((object) 'make-me-a-child x) #f))))))) 723 (define inspector-find 724 (lambda (pred gen) 725 (state-find-next-set! current-state (make-object-finder pred ((object) 'value) gen)) 726 (let ([path ((state-find-next current-state))]) 727 (unless path (inspect-error "Not found")) 728 (down-path path)))) 729 (define inspector-find-next 730 (lambda () 731 (let loop ([state current-state]) 732 (cond 733 [(not state) (inspect-error "No current find.")] 734 [(state-find-next state) => 735 (lambda (find-next) 736 (let ([path (find-next)]) 737 (unless path (inspect-error "Not found")) 738 (set! current-state state) 739 (down-path path)))] 740 [else (loop (state-link state))]))))) 741 742(define generic-dispatch-table 743 (make-dispatch-table 744 745 [("print" . "p") 746 "pretty-print object" 747 (() 748 (newline (console-output-port)) 749 ((object) 'print (console-output-port)) 750 (newline (console-output-port)))] 751 752 [("write" . "w") 753 "write object" 754 (() 755 (newline (console-output-port)) 756 ((object) 'write (console-output-port)) 757 (newline (console-output-port)) 758 (newline (console-output-port)))] 759 760 ["size" 761 "recursively compute storage occupied by object" 762 (() (fprintf (console-output-port) "~s\n" ((object) 'size (collect-maximum-generation)))) 763 ((g) 764 (require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))) 765 (fprintf (console-output-port) "~s\n" ((object) 'size g)))] 766 767 ["find" 768 "find within object, given a predicate" 769 (() 770 (let ([x (waiter-read)]) 771 (unless (eof-object? x) 772 (let ([x (eval x)]) 773 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 774 (inspector-find x (collect-maximum-generation)))))) 775 ((x) 776 (let ([x (eval x)]) 777 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 778 (inspector-find x (collect-maximum-generation)))) 779 ((x g) 780 (require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))) 781 (let ([x (eval x)]) 782 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 783 (inspector-find x g)))] 784 785 ["find-next" 786 "repeat find" 787 (() 788 (inspector-find-next))] 789 790 [("up" . "u") 791 "return to [nth] previous level" 792 (() (up)) 793 ((n) 794 (range-check n) 795 (let backup ([n n]) 796 (unless (= n 0) 797 (up) 798 (backup (- n 1)))))] 799 800 [("top" . "t") 801 "return to initial object" 802 (() 803 (let top () 804 (let ([next (state-link current-state)]) 805 (when next 806 (set! current-state next) 807 (top)))))] 808 809 [("forward" . "f") 810 "move to [nth] next expression" 811 (() (move 1)) 812 ((n) 813 (range-check n) 814 (move n))] 815 816 [("back" . "b") 817 "move to [nth] previous expression" 818 (() (move -1)) 819 ((n) 820 (range-check n) 821 (move (- n)))] 822 823 ["=>" 824 "send object to procedure" 825 (() 826 (let ([x (waiter-read)]) 827 (unless (eof-object? x) 828 (let ([x (eval x)]) 829 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 830 (inspector-print (x ((object) 'value))))))) 831 ((x) 832 (let ([x (eval x)]) 833 (unless (procedure? x) (inspect-error "~s is not a procedure" x)) 834 (inspector-print (x ((object) 'value)))))] 835 836 ["file" 837 "switch to named source file" 838 ((path) 839 (unless (or (string? path) (symbol? path)) 840 (inspect-error "invalid path ~s" path)) 841 (open-source-file (if (symbol? path) (symbol->string path) path)))] 842 843 ["list" 844 "list the current source file [line [count]]" 845 (() (list-source-file)) 846 ((n) (list-source-file n)) 847 ((n m) (list-source-file n m))] 848 849 ["files" 850 "show open files" 851 (() 852 (for-each 853 (lambda (sf) (show "~a" (sfile-path sf))) 854 source-files))] 855 856 [("mark" . "m") 857 "mark location [with symbolic mark]" 858 (() (put-mark default-mark)) 859 ((m) (put-mark (make-mark m)))] 860 861 [("goto" . "g") 862 "go to marked location [mark]" 863 (() (to-mark default-mark)) 864 ((m) (to-mark (make-mark m)))] 865 866 [("new-cafe" . "n") 867 "enter a new cafe" 868 (() 869 (newline (console-output-port)) 870 (new-cafe) 871 (newline (console-output-port)))] 872 873 [("quit" . "q") 874 "exit inspector" 875 (() 876 (newline (console-output-port)) 877 (exit))] 878 879 [("reset" . "r") 880 "reset scheme" 881 (() 882 (newline (console-output-port)) 883 ((outer-reset-handler)))] 884 885 [("abort" . "a") 886 "abort scheme [with exit code n]" 887 (() 888 (newline (console-output-port)) 889 (abort)) 890 ((x) 891 (newline (console-output-port)) 892 (abort x))] 893 894 [("help" . "h") 895 "help" 896 (() 897 (show " 898 An overview of the current object is displayed as part of each 899 prompt. There are commands for displaying more of an object or 900 inspecting its components. \"?\" displays type-specific command 901 options and \"??\" displays command options that are always 902 available. Some commands take parameters, which are entered 903 following the command on the same line. An empty command line 904 repeats the previous command. To perform more complex actions, 905 enter the command \"n\", which creates a new top level with access 906 to the usual Scheme environment. The inspector is resumed upon 907 exit from the new top level. Enter \"quit\" (or end-of-file) to 908 exit from the inspector. 909"))] 910 911)) 912 913(define empty-dispatch-table (make-dispatch-table)) 914 915(define pair-dispatch-table 916 (make-dispatch-table 917 918 [("length" . "l") 919 "display list length" 920 (() 921 (apply (lambda (type len) 922 (case type 923 [(proper) (show " proper list, length ~d" len)] 924 [(improper) (show " improper list, length ~d" len)] 925 [(circular) (show " circular list, length ~d" len)])) 926 ((object) 'length)))] 927 928 ["car" 929 "inspect car of pair" 930 (() (ref-list 0))] 931 932 ["cdr" 933 "inspect cdr of pair" 934 (() (down ((object) 'cdr) #f))] 935 936 [("ref" . "r") 937 "inspect [nth] car" 938 (() (ref-list 0)) 939 ((n) (ref-list n))] 940 941 ["tail" 942 "inspect [nth] cdr" 943 (() (down ((object) 'cdr) #f)) 944 ((n) 945 (range-check n) 946 (let tail ([i n]) 947 (unless (= i 0) 948 (unless (type? 'pair (object)) (invalid-movement)) 949 (down ((object) 'cdr) #f) 950 (tail (- i 1)))))] 951 952 [("show" . "s") 953 "show [n] elements of list" 954 (() (display-list (cadr ((object) 'length)))) 955 ((n) 956 (range-check n) 957 (display-list n))] 958 959)) 960 961(define vector-dispatch-table 962 (make-dispatch-table 963 964 [("length" . "l") 965 "display vector length" 966 (() (show " ~d elements" ((object) 'length)))] 967 968 [("ref" . "r") 969 "inspect [nth] element" 970 (() (ref 0)) 971 ((n) (ref n))] 972 973 [("show" . "s") 974 "show [n] elements" 975 (() (display-refs ((object) 'length))) 976 ((n) 977 (range-check n ((object) 'length)) 978 (display-refs n))] 979 980)) 981 982(define fxvector-dispatch-table 983 (make-dispatch-table 984 985 [("length" . "l") 986 "display fxvector length" 987 (() (show " ~d elements" ((object) 'length)))] 988 989 [("ref" . "r") 990 "inspect [nth] element" 991 (() (ref 0)) 992 ((n) (ref n))] 993 994 [("show" . "s") 995 "show [n] elements" 996 (() (display-refs ((object) 'length))) 997 ((n) 998 (range-check n ((object) 'length)) 999 (display-refs n))] 1000 1001)) 1002 1003(define bytevector-dispatch-table 1004 (make-dispatch-table 1005 1006 [("length" . "l") 1007 "display bytevector length" 1008 (() (show " ~d elements" ((object) 'length)))] 1009 1010 [("ref" . "r") 1011 "inspect [nth] element" 1012 (() (ref 0)) 1013 ((n) (ref n))] 1014 1015 [("show" . "s") 1016 "show [n] elements" 1017 (() (display-refs ((object) 'length))) 1018 ((n) 1019 (range-check n ((object) 'length)) 1020 (display-refs n))] 1021 1022)) 1023 1024(define ftype-struct-dispatch-table 1025 (make-dispatch-table 1026 ["fields" 1027 "inspect fields" 1028 (() (down ((object) 'fields) #f))] 1029 1030 [("ref" . "r") 1031 "inspect named or nth element" 1032 (() (down ((object) 'ref 0) 0)) 1033 ((f) (down ((object) 'ref f) (and (fixnum? f) f)))] 1034 1035 ["set!" 1036 "set named element, if assignable" 1037 ((f) 1038 (let ([x (waiter-read)]) 1039 (unless (eof-object? x) 1040 (let ((x (eval x))) 1041 ((object) 'set! f x))))) 1042 ((f v) ((object) 'set! f (eval v)))] 1043 1044 ["ftype" 1045 "inspect the ftype" 1046 (() (down ((object) 'ftype) #f))] 1047 1048 [("show" . "s") 1049 "show contents of struct" 1050 (() 1051 (let ([fields (((object) 'fields) 'value)]) 1052 (if (null? fields) 1053 (show "*** struct has no fields ***") 1054 (for-each 1055 (lambda (f i) 1056 (name-label-line-display 1057 ((object) 'ref i) 1058 f 1059 i)) 1060 fields 1061 (iota (length fields))))))])) 1062 1063(define ftype-union-dispatch-table 1064 (make-dispatch-table 1065 ["fields" 1066 "inspect fields" 1067 (() (down ((object) 'fields) #f))] 1068 1069 [("ref" . "r") 1070 "inspect named or nth element" 1071 (() (down ((object) 'ref 0) 0)) 1072 ((f) (down ((object) 'ref f) (and (fixnum? f) f)))] 1073 1074 ["set!" 1075 "set named element, if assignable" 1076 ((f) 1077 (let ([x (waiter-read)]) 1078 (unless (eof-object? x) 1079 (let ((x (eval x))) 1080 ((object) 'set! f x))))) 1081 ((f v) ((object) 'set! f (eval v)))] 1082 1083 ["ftype" 1084 "inspect the ftype" 1085 (() (down ((object) 'ftype) #f))] 1086 1087 [("show" . "s") 1088 "show contents of union" 1089 (() 1090 (let ([fields (((object) 'fields) 'value)]) 1091 (if (null? fields) 1092 (show "*** union has no fields ***") 1093 (for-each 1094 (lambda (f i) 1095 (name-label-line-display 1096 ((object) 'ref i) 1097 f 1098 i)) 1099 fields 1100 (iota (length fields))))))])) 1101 1102(define ftype-array-dispatch-table 1103 (make-dispatch-table 1104 [("length" . "l") 1105 "display array length" 1106 (() (show " ~d elements" ((object) 'length)))] 1107 1108 [("ref" . "r") 1109 "inspect [nth] element" 1110 (() (ref 0)) 1111 ((n) (ref n))] 1112 1113 ["set!" 1114 "set [nth] element, if assignable" 1115 ((f) 1116 (let ([x (waiter-read)]) 1117 (unless (eof-object? x) 1118 (let ((x (eval x))) 1119 ((object) 'set! f x))))) 1120 ((f v) ((object) 'set! f (eval v)))] 1121 1122 ["ftype" 1123 "inspect the ftype" 1124 (() (down ((object) 'ftype) #f))] 1125 1126 [("show" . "s") 1127 "show [n] elements" 1128 (() (display-refs ((object) 'length))) 1129 ((n) 1130 (range-check n ((object) 'length)) 1131 (display-refs n))] 1132 )) 1133 1134(define ftype-pointer-dispatch-table 1135 (make-dispatch-table 1136 [("ref" . "r") 1137 "inspect target of pointer" 1138 (() (down ((object) 'ref) #f)) 1139 ((n) 1140 (unless (memv n '(* 0)) (invalid-movement)) 1141 (down ((object) 'ref) #f))] 1142 1143 ["set!" 1144 "set target of pointer, if assignable" 1145 (() 1146 (let ([x (waiter-read)]) 1147 (unless (eof-object? x) 1148 (let ((x (eval x))) 1149 ((object) 'set! x))))) 1150 ((v) ((object) 'set! (eval v)))] 1151 1152 ["ftype" 1153 "inspect ftype of target" 1154 (() (down ((object) 'ftype) #f))] 1155 1156 [("show" . "s") 1157 "show the target" 1158 (() (label-line-display ((object) 'ref) 0))] 1159 )) 1160 1161(define ftype-function-dispatch-table 1162 (make-dispatch-table 1163 ["name" 1164 "inspect foreign-function name" 1165 (() (down ((object) 'name) #f))] 1166 1167 ["address" 1168 "inspect foreign-function address" 1169 (() (down ((object) 'address) #f))] 1170 1171 ["ftype" 1172 "inspect ftype of target" 1173 (() (down ((object) 'ftype) #f))] 1174 1175 [("show" . "s") 1176 "show the target" 1177 (() (label-line-display ((object) 'name) 0) 1178 (label-line-display ((object) 'address) 1))] 1179 )) 1180 1181(define ftype-bits-dispatch-table 1182 (make-dispatch-table 1183 ["fields" 1184 "inspect fields" 1185 (() (down ((object) 'fields) #f))] 1186 1187 [("ref" . "r") 1188 "inspect named or nth element" 1189 (() (down ((object) 'ref 0) 0)) 1190 ((f) (down ((object) 'ref f) (and (fixnum? f) f)))] 1191 1192 ["set!" 1193 "set named element, if assignable" 1194 ((f) 1195 (let ([x (waiter-read)]) 1196 (unless (eof-object? x) 1197 (let ((x (eval x))) 1198 ((object) 'set! f x))))) 1199 ((f v) ((object) 'set! f (eval v)))] 1200 1201 ["ftype" 1202 "inspect the ftype" 1203 (() (down ((object) 'ftype) #f))] 1204 1205 [("show" . "s") 1206 "show bit fields" 1207 (() 1208 (let ([fields (((object) 'fields) 'value)]) 1209 (if (null? fields) 1210 (show "*** no fields ***") 1211 (for-each 1212 (lambda (f i) 1213 (name-label-line-display 1214 ((object) 'ref i) 1215 f 1216 i)) 1217 fields 1218 (iota (length fields))))))])) 1219 1220(define record-dispatch-table 1221 (make-dispatch-table 1222 1223 ["fields" 1224 "inspect fields" 1225 (() (down ((object) 'fields) #f))] 1226 1227 ["name" 1228 "inspect record name" 1229 (() (down ((object) 'name) #f))] 1230 1231 ["rtd" 1232 "inspect record-type descriptor" 1233 (() (down ((object) 'rtd) #f))] 1234 1235 [("ref" . "r") 1236 "inspect named or nth element" 1237 ((f) (down ((object) 'ref f) (and (fixnum? f) f)))] 1238 1239 ["set!" 1240 "set named element, if assignable" 1241 ((f) 1242 (let ([x (waiter-read)]) 1243 (unless (eof-object? x) 1244 (let ((x (eval x))) 1245 ((object) 'set! f x))))) 1246 ((f v) ((object) 'set! f (eval v)))] 1247 1248 [("show" . "s") 1249 "show contents of record" 1250 (() 1251 (when (and (eq? (subset-mode) 'system) 1252 (record-type-opaque? (((object) 'rtd) 'value))) 1253 (show "*** inspecting opaque record ***")) 1254 (let ([fields (((object) 'fields) 'value)]) 1255 (if (null? fields) 1256 (show "*** record has no fields ***") 1257 (for-each 1258 (lambda (f i) 1259 (name-label-line-display 1260 (if ((object) 'accessible? i) 1261 ((object) 'ref i) 1262 (inspect/object "*** inaccessible ***")) 1263 f 1264 i)) 1265 fields 1266 (iota (length fields))))))] 1267)) 1268 1269 1270(define string-dispatch-table 1271 (make-dispatch-table 1272 1273 [("length" . "l") 1274 "display string length" 1275 (() (show " ~d characters" ((object) 'length)))] 1276 1277 [("ref" . "r") 1278 "inspect [nth] character" 1279 (() (ref 0)) 1280 ((n) (ref n))] 1281 1282 [("show" . "s") 1283 "show [n] characters" 1284 (() (display-chars ((object) 'length) charschemecode 5)) 1285 ((n) 1286 (range-check n ((object) 'length)) 1287 (display-chars n charschemecode 5))] 1288 1289 ["unicode" 1290 "display [n] characters as hexadecimal unicode codes" 1291 (() (display-chars ((object) 'length) unicodehexcode 8)) 1292 ((n) 1293 (range-check n ((object) 'length)) 1294 (display-chars n unicodehexcode 8))] 1295 1296 ["ascii" 1297 "display [n] characters as hexadecimal ascii codes" 1298 (() (display-chars ((object) 'length) asciihexcode 16)) 1299 ((n) 1300 (range-check n ((object) 'length)) 1301 (display-chars n asciihexcode 16))] 1302)) 1303 1304(define char-dispatch-table 1305 (make-dispatch-table 1306 1307 ["unicode" 1308 "display character as hexadecimal ascii code" 1309 (() (show " U+~x" (unicodehexcode ((object) 'value))))] 1310 1311 ["ascii" 1312 "display character as hexadecimal ascii code" 1313 (() (show " ~x" (asciihexcode ((object) 'value))))] 1314 1315)) 1316 1317(define box-dispatch-table 1318 (make-dispatch-table 1319 1320 ["unbox" 1321 "inspect contents of box" 1322 (() (down ((object) 'unbox) #f))] 1323 1324 [("ref" . "r") 1325 "inspect contents of box" 1326 (() (down ((object) 'unbox) #f))] 1327 1328 [("show" . "s") 1329 "show contents of box" 1330 (() (label-line-display ((object) 'unbox) 0)) 1331 ((n) 1332 (range-check n 0) 1333 (label-line-display ((object) 'unbox) 0))] 1334)) 1335 1336 1337(define system-symbol-dispatch-table 1338 (make-dispatch-table 1339 1340 [("ref" . "r") 1341 "inspect value field [n] of symbol" 1342 (() 1343 (down ((object) 'top-level-value) 0)) 1344 ((n) 1345 (range-check n 5) 1346 (down ((object) 1347 (case n 1348 [(0) 'top-level-value] 1349 [(1) '$top-level-value] 1350 [(2) 'name] 1351 [(3) 'property-list] 1352 [(4) 'system-property-list] 1353 [(5) 'symbol-hash])) 1354 n))] 1355 1356 [("value" . "v") 1357 "inspect top-level-value of symbol" 1358 (() (down ((object) 'top-level-value) 0))] 1359 1360 [("value-slot" . "vs") 1361 "inspect value slot of symbol" 1362 (() (down ((object) '$top-level-value) 0))] 1363 1364 [("name" . "n") 1365 "inspect name of symbol" 1366 (() (down ((object) 'name) 1))] 1367 1368 [("property-list" . "pl") 1369 "inspect property-list of symbol" 1370 (() (down ((object) 'property-list) 2))] 1371 1372 [("system-property-list" . "spl") 1373 "inspect system property-list of symbol" 1374 (() (down ((object) 'system-property-list) 4))] 1375 1376 [("symbol-hash" . "sh") 1377 "inspect hash code" 1378 (() (down ((object) 'symbol-hash) 5))] 1379 1380 [("show" . "s") 1381 "show fields of symbol" 1382 (() 1383 (name-label-line-display ((object) 'top-level-value) "top-level value" 0) 1384 (name-label-line-display ((object) '$top-level-value) "value slot" 1) 1385 (name-label-line-display ((object) 'name) "name" 2) 1386 (name-label-line-display ((object) 'property-list) "properties" 3) 1387 (name-label-line-display ((object) 'system-property-list) "system properties" 4) 1388 (name-label-line-display ((object) 'symbol-hash) "hash code" 5))] 1389)) 1390 1391(define symbol-dispatch-table 1392 (make-dispatch-table 1393 1394 [("ref" . "r") 1395 "inspect value field [n] of symbol" 1396 (() 1397 (down ((object) 'top-level-value) 0)) 1398 ((n) 1399 (range-check n 2) 1400 (down ((object) 1401 (case n 1402 [(0) 'top-level-value] 1403 [(1) 'name] 1404 [(2) 'property-list])) 1405 n))] 1406 1407 [("value" . "v") 1408 "inspect top-level-value of symbol" 1409 (() (down ((object) 'top-level-value) 0))] 1410 1411 [("name" . "n") 1412 "inspect name of symbol" 1413 (() (down ((object) 'name) 1))] 1414 1415 [("property-list" . "pl") 1416 "inspect property-list of symbol" 1417 (() (down ((object) 'property-list) 2))] 1418 1419 [("show" . "s") 1420 "show fields of symbol" 1421 (() 1422 (name-label-line-display ((object) 'top-level-value) "top level value" 0) 1423 (name-label-line-display ((object) 'name) "name" 1) 1424 (name-label-line-display ((object) 'property-list) "properties" 2))] 1425)) 1426 1427(define procedure-dispatch-table 1428 (make-dispatch-table 1429 1430 [("length" . "l") 1431 "display number of free variables" 1432 (() (show " ~d free variables" ((object) 'length)))] 1433 1434 [("ref" . "r") 1435 "inspect [nth] free variable" 1436 (() (ref 0)) 1437 ((x) (variable-ref x))] 1438 1439 [("set!" . "!") 1440 "set [nth or named] free variable to value, if assignable" 1441 (() 1442 (let ([e (waiter-read)]) 1443 (unless (eof-object? e) 1444 (set 0 ((object) 'eval e))))) 1445 ((x) 1446 (let ([e (waiter-read)]) 1447 (unless (eof-object? e) 1448 (variable-set x ((object) 'eval e))))) 1449 ((x e) (variable-set x ((object) 'eval e)))] 1450 1451 [("eval" . "e") 1452 "evaluate expression in context of procedure environment" 1453 (() 1454 (let ([x (waiter-read)]) 1455 (unless (eof-object? x) 1456 (inspector-print ((object) 'eval x))))) 1457 ((x) 1458 (inspector-print ((object) 'eval x)))] 1459 1460 [("show" . "s") 1461 "show code and free variables" 1462 (() 1463 (let ([source (((object) 'code) 'source)]) 1464 (when source (name-line-display source "code"))) 1465 (when (> ((object) 'length) 0) 1466 (show "~afree variables:" line-indent) 1467 (display-variable-refs ((object) 'length))))] 1468 1469 [("code" . "c") 1470 "inspect the code for the procedure" 1471 (() 1472 (let ([source (((object) 'code) 'source)]) 1473 (if source 1474 (down source #f) 1475 (show "source code not available"))))] 1476 1477 ["file" 1478 "switch to source file containing the procedure" 1479 (() (open-recorded-source-file ((object) 'code))) 1480 ((path) 1481 (unless (or (string? path) (symbol? path)) 1482 (inspect-error "invalid path ~s" path)) 1483 (open-source-file (if (symbol? path) (symbol->string path) path)))] 1484)) 1485 1486(define code-dispatch-table 1487 (make-dispatch-table 1488 1489 [("length" . "l") 1490 "display number of free variables" 1491 (() (show " ~d free variables" ((object) 'free-count)))] 1492 1493 [("show" . "s") 1494 "show code" 1495 (() 1496 (let ([source ((object) 'source)]) 1497 (when source (name-line-display source "code"))))] 1498 1499 [("code" . "c") 1500 "inspect the code" 1501 (() 1502 (let ([source ((object) 'source)]) 1503 (if source 1504 (down source #f) 1505 (show "source code not available"))))] 1506 1507 ["file" 1508 "switch to source file containing the procedure" 1509 (() (open-recorded-source-file (object))) 1510 ((path) 1511 (unless (or (string? path) (symbol? path)) 1512 (inspect-error "invalid path ~s" path)) 1513 (open-source-file (if (symbol? path) (symbol->string path) path)))] 1514)) 1515 1516 1517(define continuation-dispatch-table 1518 (let () 1519 (define reposition 1520 (lambda (incr) 1521 (let ([old-pos ((object) 'pos)]) 1522 (unless (fx= old-pos 0) (up)) 1523 (let ([pos (fx+ old-pos incr)]) 1524 (when (fx>= pos ((object) 'depth)) (invalid-movement)) 1525 (if (fx> pos 0) 1526 (let ((link ((object) 'reposition pos))) 1527 (unless (type? 'continuation link) (invalid-movement)) 1528 (down link #f)) 1529 (unless (fx= pos 0) (invalid-movement))))))) 1530 1531 (define continuation-show 1532 (lambda (free?) 1533 (name-line-display ((object) 'link) "continuation") 1534 (let ([source (((object) 'code) 'source)]) 1535 (when source (name-line-display source "procedure code"))) 1536 (let ([source ((object) 'source)]) 1537 (when source (name-line-display source "call code"))) 1538 (let ([cp ((object) 'closure)]) 1539 (when cp (name-line-display cp "closure"))) 1540 (let ([len ((object) (if free? 'length 'frame-length))]) 1541 (when (> len 0) 1542 (show "~a~a:" line-indent (if free? "frame and free variables" "frame variables")) 1543 (display-variable-refs len))))) 1544 1545 (make-dispatch-table 1546 1547 [("length" . "l") 1548 "display number of frame and closure variables" 1549 (() (show " ~d variables" ((object) 'length)))] 1550 1551 ["depth" 1552 "display number of frames in continuation stack" 1553 (() (let ((d ((object) 'depth))) 1554 (show (if (= d 1) " ~d frame" " ~d frames") d)))] 1555 1556 [("ref" . "r") 1557 "inspect [named or nth] variable" 1558 (() (ref 0)) 1559 ((x) (variable-ref x))] 1560 1561 [("set!" . "!") 1562 "set [named or nth] variable to value, if assignable" 1563 (() 1564 (let ([e (waiter-read)]) 1565 (unless (eof-object? e) 1566 (set 0 ((object) 'eval e))))) 1567 ((x) 1568 (let ([e (waiter-read)]) 1569 (unless (eof-object? e) 1570 (variable-set x ((object) 'eval e))))) 1571 ((x e) (variable-set x ((object) 'eval e)))] 1572 1573 [("forward" . "f") 1574 "move to [nth] next frame" 1575 (() (reposition 1)) 1576 ((pos) 1577 (range-check pos) 1578 (reposition pos))] 1579 1580 [("back" . "b") 1581 "move to [nth] previous frame" 1582 (() (reposition -1)) 1583 ((pos) 1584 (range-check pos) 1585 (reposition (fx- pos)))] 1586 1587 [("down" . "d") 1588 "inspect [nth] next frame" 1589 (() (let ((link ((object) 'link))) 1590 (unless (type? 'continuation link) (invalid-movement)) 1591 (down link #f))) 1592 ((n) 1593 (range-check n (- ((object) 'depth) 1)) 1594 (let ((link ((object) 'link* n))) 1595 (unless (type? 'continuation link) (invalid-movement)) 1596 (down link #f)))] 1597 1598 [("closure" . "cp") 1599 "inspect the frame's closure, if any" 1600 (() (let ([cp ((object) 'closure)]) 1601 (unless cp (inspect-error "this frame has no closure")) 1602 (down cp #f)))] 1603 1604 [("eval" . "e") 1605 "evaluate expression in context of current frame" 1606 (() 1607 (let ([x (waiter-read)]) 1608 (unless (eof-object? x) 1609 (inspector-print ((object) 'eval x))))) 1610 ((x) 1611 (inspector-print ((object) 'eval x)))] 1612 1613 [("show" . "s") 1614 "show frame with free variables" 1615 (() (continuation-show #t))] 1616 1617 [("show-local" . "sl") 1618 "show frame without free variables" 1619 (() (continuation-show #f))] 1620 1621 [("show-frames" . "sf") 1622 "show the next [n] frames" 1623 (() (display-links (most-positive-fixnum))) 1624 ((n) 1625 (range-check n) 1626 (display-links n))] 1627 1628 ["call" 1629 "inspect the code for the pending call" 1630 (() 1631 (let ([source ((object) 'source)]) 1632 (if source 1633 (down source #f) 1634 (show "source code not available"))))] 1635 1636 [("code" . "c") 1637 "inspect the code for the pending procedure" 1638 (() 1639 (let ([source (((object) 'code) 'source)]) 1640 (if source 1641 (down source #f) 1642 (show "source code not available"))))] 1643 1644 ["file" 1645 "switch to source file containing the pending call" 1646 (() (open-recorded-source-file (object))) 1647 ((path) 1648 (unless (or (string? path) (symbol? path)) 1649 (inspect-error "invalid path ~s" path)) 1650 (open-source-file (if (symbol? path) (symbol->string path) path)))] 1651 1652 ))) 1653 1654(define port-dispatch-table 1655 (make-dispatch-table 1656 1657 [("show" . "s") 1658 "show port contents" 1659 (() 1660 (name-line-display ((object) 'name) "name") 1661 (name-line-display ((object) 'handler) "handler") 1662 (when ((object) 'input?) 1663 (show "~ainput size: ~s" line-indent ((object) 'input-size)) 1664 (show "~ainput index: ~s" line-indent ((object) 'input-index))) 1665 (when ((object) 'output?) 1666 (show "~aoutput size: ~s" line-indent ((object) 'output-size)) 1667 (show "~aoutput index: ~s" line-indent ((object) 'output-index))))] 1668 1669 ["name" 1670 "inspect port name" 1671 (() (down ((object) 'name) #f))] 1672 1673 ["handler" 1674 "inspect port handler" 1675 (() (down ((object) 'handler) #f))] 1676 1677 [("output-buffer" . "ob") 1678 "inspect output buffer" 1679 (() (if ((object) 'output?) 1680 (down ((object) 'output-buffer) #f) 1681 (show "not an output port")))] 1682 1683 [("input-buffer" . "ib") 1684 "inspect input buffer" 1685 (() (if ((object) 'input?) 1686 (down ((object) 'input-buffer) #f) 1687 (show "not an input port")))] 1688)) 1689 1690(define tlc-dispatch-table 1691 (make-dispatch-table 1692 1693 ["keyval" 1694 "inspect keyval field" 1695 (() (down ((object) 'keyval) #f))] 1696 1697 ["ht" 1698 "inspect ht field" 1699 (() (down ((object) 'ht) #f))] 1700 1701 ["next" 1702 "inspect next field" 1703 (() (down ((object) 'next) #f))] 1704 1705 [("ref" . "r") 1706 "inspect named field" 1707 ((x) 1708 (down ((object) 1709 (case x 1710 [(keyval) 'keyval] 1711 [(ht) 'ht] 1712 [(next) 'next] 1713 [else (invalid-command)])) 1714 x))] 1715 1716 [("show" . "s") 1717 "show fields of tlc" 1718 (() 1719 (name-line-display ((object) 'keyval) "keyval") 1720 (name-line-display ((object) 'ht) "ht") 1721 (name-line-display ((object) 'next) "next"))] 1722)) 1723 1724(set! inspect 1725 (lambda (x) 1726 (let ([t (set-timer 0)]) 1727 (call/cc 1728 (lambda (k) 1729 (fluid-let ([current-state (make-state (inspect/object x))] 1730 [marks (make-eq-hashtable)] 1731 [source-files '()]) 1732 (parameterize ([outer-reset-handler (reset-handler)] 1733 [exit-handler k] 1734 [$interrupt reset]) 1735 (put-mark default-mark) 1736 (dynamic-wind 1737 void 1738 (lambda () (inspector '("?"))) 1739 (lambda () (for-each close-source-file source-files))))))) 1740 (set-timer t)) 1741 (void))) 1742 1743) 1744 1745(define inspect/object 1746 (lambda (x) 1747 (define compute-size 1748 (let ([size-ht #f]) 1749 (lambda (x g) 1750 (unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)) 1751 ($oops 'inspector-object "invalid generation ~s" g)) 1752 ; using a common size-ht for a single inspect/object call means: 1753 ; (inspect (let ([x (list 1 2)]) (set-car! x x) (set-car! (cdr x) x) (set-cdr! (cdr x) x) x)) 1754 ; size => 16 1755 ; cdr, size => 8 1756 ; might be what we want, might not be 1757 (unless size-ht (set! size-ht (make-eq-hashtable))) 1758 ($compute-size x (if (eq? g 'static) (constant static-generation) g) size-ht)))) 1759 1760 (define-syntax make-object-maker 1761 (lambda (x) 1762 (syntax-case x () 1763 [(_ object-name inits [method args e1 e2 ...] ...) 1764 (andmap identifier? #'(object-name method ...)) 1765 #'(lambda inits 1766 (let ([method (lambda args e1 e2 ...)] ...) 1767 (lambda (m . rest) 1768 (case m 1769 [(type) 'object-name] 1770 [(make-me-a-child) (make-object (car rest))] 1771 [(method) (#2%apply method rest)] 1772 ... 1773 [else ($oops 'inspector-object 1774 "invalid message ~s to object type ~s" 1775 m 1776 'object-name)]))))]))) 1777 1778 (define frame-eval 1779 (lambda (vars expr) 1780 (define frame-name 1781 (let ((ls '(%0 %1 %2 %3 %4 %5 %6 %7))) 1782 (let ((n (length ls))) 1783 (lambda (i) 1784 (if (< i n) 1785 (list-ref ls i) 1786 (string->symbol (format "%~d" i))))))) 1787 (define ->nongensym 1788 (lambda (name) 1789 (if (gensym? name) 1790 (string->symbol (symbol->string name)) 1791 name))) 1792 (let ((n (vector-length vars))) 1793 (eval (let f ((i 0)) 1794 (if (= i n) 1795 expr 1796 (let ([var (vector-ref vars i)] 1797 [body (f (+ i 1))]) 1798 (let ([raw-val (var 'raw-value)] 1799 [name (var 'name)] 1800 [fv (frame-name i)] 1801 [t (gensym)]) 1802 `(let ([,t (quote ,raw-val)]) 1803 (let-syntax ([,fv ,(if (assignable? raw-val) 1804 `(identifier-syntax [id (car ,t)] [(set! id e) (set-car! ,t e)]) 1805 `(identifier-syntax 1806 [id ,t] 1807 [(set! id e) 1808 (syntax-error #'id "cannot set non-assigned variable")]))]) 1809 ,(if name `(begin (alias ,(->nongensym name) ,fv) ,body) body))))))))))) 1810 1811 (define make-pair-object 1812 (make-object-maker pair (x) 1813 [value () x] 1814 [car () (make-object (car x))] 1815 [cdr () (make-object (cdr x))] 1816 [length () 1817 (let ([ht (make-eq-hashtable)]) 1818 (let length ([x x] [n 0]) 1819 (cond 1820 [(null? x) `(proper ,n)] 1821 [(not (pair? x)) `(improper ,n)] 1822 [else 1823 (let ([a (eq-hashtable-cell ht x #f)]) 1824 (if (cdr a) 1825 `(circular ,n) 1826 (begin (set-cdr! a #t) 1827 (length (cdr x) (+ n 1)))))])))] 1828 [size (g) (compute-size x g)] 1829 [write (p) (write x p)] 1830 [print (p) (pretty-print x p)])) 1831 1832 (define make-box-object 1833 (make-object-maker box (x) 1834 [value () x] 1835 [unbox () (make-object (unbox x))] 1836 [size (g) (compute-size x g)] 1837 [write (p) (write x p)] 1838 [print (p) (pretty-print x p)])) 1839 1840 (define make-tlc-object 1841 (make-object-maker tlc (x) 1842 [value () x] 1843 [keyval () (make-object ($tlc-keyval x))] 1844 [ht () (make-object ($tlc-ht x))] 1845 [next () (make-object ($tlc-next x))] 1846 [size (g) (compute-size x g)] 1847 [write (p) (write x p)] 1848 [print (p) (pretty-print x p)])) 1849 1850 (define make-vector-object 1851 (make-object-maker vector (x) 1852 [value () x] 1853 [length () (vector-length x)] 1854 [ref (i) 1855 (unless (and (fixnum? i) (fx< -1 i (vector-length x))) 1856 ($oops 'vector-object "invalid index ~s" i)) 1857 (make-object (vector-ref x i))] 1858 [size (g) (compute-size x g)] 1859 [write (p) (write x p)] 1860 [print (p) (pretty-print x p)])) 1861 1862 (define make-fxvector-object 1863 (make-object-maker fxvector (x) 1864 [value () x] 1865 [length () (fxvector-length x)] 1866 [ref (i) 1867 (unless (and (fixnum? i) (fx< -1 i (fxvector-length x))) 1868 ($oops 'fxvector-object "invalid index ~s" i)) 1869 (make-object (fxvector-ref x i))] 1870 [size (g) (compute-size x g)] 1871 [write (p) (write x p)] 1872 [print (p) (pretty-print x p)])) 1873 1874 (define make-bytevector-object 1875 (make-object-maker bytevector (x) 1876 [value () x] 1877 [length () (bytevector-length x)] 1878 [ref (i) 1879 (unless (and (fixnum? i) (fx< -1 i (bytevector-length x))) 1880 ($oops 'bytevector-object "invalid index ~s" i)) 1881 (make-object (bytevector-u8-ref x i))] 1882 [size (g) (compute-size x g)] 1883 [write (p) (write x p)] 1884 [print (p) (pretty-print x p)])) 1885 1886 (define make-ftype-pointer-object 1887 (lambda (x) 1888 (define (unrecognized-ux ux) 1889 ($oops 'ftype-pointer-object "unrecognized ftype-pointer type ~s" x)) 1890 (define (invalid-field-specifier f) 1891 ($oops 'ftype-pointer-object "invalid field specifier ~s" f)) 1892 (define (invalid-index f) 1893 ($oops 'ftype-pointer-object "invalid index ~s" f)) 1894 (define (get-field f field*) 1895 (cond 1896 [(assq f field*) => cdr] 1897 [(and (fixnum? f) (#%$fxu< f (length field*))) 1898 (cdr (list-ref field* f))] 1899 [else (invalid-field-specifier f)])) 1900 (define (deref x) 1901 (let ([ux ($unwrap-ftype-pointer x)]) 1902 (record-case ux 1903 [(struct union array * bits) ignore (make-object x)] 1904 [(base) (type getter setter) (make-object (getter))] 1905 [else (unrecognized-ux ux)]))) 1906 (define (deset! who x v) 1907 (let ([ux ($unwrap-ftype-pointer x)]) 1908 (record-case ux 1909 [(struct union array bits) ignore ($oops who "cannot assign struct, union, or array")] 1910 [(*) (get-fptr set-fptr!) (set-fptr! who v)] 1911 [(base) (type getter setter) (setter v)] 1912 [else (unrecognized-ux ux)]))) 1913 (let ([ux ($unwrap-ftype-pointer x)]) 1914 (record-case ux 1915 [(struct) field* 1916 ((make-object-maker ftype-struct (x) 1917 [value () x] 1918 [ftype () (make-object (ftype-pointer-ftype x))] 1919 [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))] 1920 [length () (length field*)] 1921 [ref (f) (deref (get-field f field*))] 1922 [set! (f v) (deset! 'ftype-struct-object (get-field f field*) v)] 1923 [size (g) (compute-size x g)] 1924 [write (p) (write `(ftype struct ...) p)] 1925 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 1926 x)] 1927 [(union) field* 1928 ((make-object-maker ftype-union (x) 1929 [value () x] 1930 [ftype () (make-object (ftype-pointer-ftype x))] 1931 [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))] 1932 [length () (length field*)] 1933 [ref (f) (deref (get-field f field*))] 1934 [set! (f v) (deset! 'ftype-union-object (get-field f field*) v)] 1935 [size (g) (compute-size x g)] 1936 [write (p) (write `(ftype union ...) p)] 1937 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 1938 x)] 1939 [(array) (n get-fptr) 1940 ((make-object-maker ftype-array (x) 1941 [value () x] 1942 [ftype () (make-object (ftype-pointer-ftype x))] 1943 [length () n] 1944 [ref (f) 1945 (unless (and (integer? f) (exact? f) (#%$fxu< f n)) 1946 (invalid-index f)) 1947 (deref (get-fptr f))] 1948 [set! (f v) 1949 (unless (and (integer? f) (exact? f) (#%$fxu< f n)) 1950 (invalid-index f)) 1951 (deset! 'ftype-array-object (get-fptr f) v)] 1952 [size (g) (compute-size x g)] 1953 [write (p) (write `(ftype array ...) p)] 1954 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 1955 x)] 1956 [(*) (get-fptr set-fptr!) 1957 ((make-object-maker ftype-* (x) 1958 [value () x] 1959 [ftype () (make-object (ftype-pointer-ftype x))] 1960 [ref () (deref (get-fptr))] 1961 [set! (v) (deset! 'ftype-*-object (get-fptr) v)] 1962 [size (g) (compute-size x g)] 1963 [write (p) (write `(ftype * ...) p)] 1964 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 1965 x)] 1966 [(bits) field* 1967 ((make-object-maker ftype-bits (x) 1968 [value () x] 1969 [ftype () (make-object (ftype-pointer-ftype x))] 1970 [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))] 1971 [length () (length field*)] 1972 [ref (f) (apply (lambda (getter setter) (make-object (getter))) 1973 (get-field f field*))] 1974 [set! (f v) (apply (lambda (getter setter) (make-object (setter v))) 1975 (get-field f field*))] 1976 [size (g) (compute-size x g)] 1977 [write (p) (write `(ftype bits ...) p)] 1978 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 1979 x)] 1980 [(base) (type getter setter) 1981 ((make-object-maker ftype-base (x) 1982 [value () x] 1983 [ftype () (make-object (ftype-pointer-ftype x))] 1984 [ref () (make-object (getter))] 1985 [set! (v) (setter v)] 1986 [size (g) (compute-size x g)] 1987 [write (p) (write `(ftype ,type ...) p)] 1988 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 1989 x)] 1990 [(function) (name) 1991 ((make-object-maker ftype-function (x) 1992 [value () x] 1993 [ftype () (make-object (ftype-pointer-ftype x))] 1994 [address () (make-object (ftype-pointer-address x))] 1995 [name () (make-object name)] 1996 [size (g) (compute-size x g)] 1997 [write (p) (write `(ftype function ...) p)] 1998 [print (p) (pretty-print (ftype-pointer->sexpr x) p)]) 1999 x)] 2000 [else (unrecognized-ux ux)])))) 2001 2002 (define make-record-object 2003 (lambda (x) 2004 (let* ((rtd ($record-type-descriptor x)) 2005 (fields (csv7:record-type-field-names rtd))) 2006 (define check-field 2007 (lambda (f) 2008 (unless (or (and (symbol? f) (memq f fields)) 2009 (and (fixnum? f) (fx>= f 0) (fx< f (length fields)))) 2010 ($oops 'record-object "invalid field specifier ~s" f)))) 2011 ((make-object-maker record (x) 2012 [value () x] 2013 [length () (length fields)] 2014 [fields () (make-object fields)] 2015 [accessible? (f) 2016 (check-field f) 2017 (csv7:record-field-accessible? rtd f)] 2018 [mutable? (f) 2019 (check-field f) 2020 (csv7:record-field-mutable? rtd f)] 2021 [name () (make-object (csv7:record-type-name rtd))] 2022 [rtd () (make-object rtd)] 2023 [ref (f) 2024 (check-field f) 2025 (unless (csv7:record-field-accessible? rtd f) 2026 ($oops 'record-object "field ~s is inaccessible" f)) 2027 (make-object ((csv7:record-field-accessor rtd f) x))] 2028 [set! (f v) 2029 (check-field f) 2030 (unless (csv7:record-field-mutable? rtd f) 2031 ($oops 'record-object "field ~s is immutable" f)) 2032 ((csv7:record-field-mutator rtd f) x v)] 2033 [size (g) (compute-size x g)] 2034 [write (p) (write x p)] 2035 [print (p) (pretty-print x p)]) 2036 x)))) 2037 2038 (define make-string-object 2039 (make-object-maker string (x) 2040 [value () x] 2041 [length () (string-length x)] 2042 [ref (i) 2043 (unless (and (fixnum? i) (< -1 i (string-length x))) 2044 ($oops 'string-object "invalid index ~s" i)) 2045 (make-object (string-ref x i))] 2046 [size (g) (compute-size x g)] 2047 [write (p) (write x p)] 2048 [print (p) (pretty-print x p)])) 2049 2050 (define make-simple-object 2051 (make-object-maker simple (x) 2052 [value () x] 2053 [size (g) (compute-size x g)] 2054 [write (p) (write x p)] 2055 [print (p) (pretty-print x p)])) 2056 2057 (define make-unbound-object 2058 (make-object-maker unbound (x) 2059 [value () x] 2060 [size (g) (compute-size x g)] 2061 [write (p) (write x p)] 2062 [print (p) (pretty-print x p)])) 2063 2064 (define make-procedure-object 2065 (lambda (x) 2066 (real-make-procedure-object x (list->vector (make-procedure-vars x))))) 2067 2068 (define real-make-procedure-object 2069 (make-object-maker procedure (x vars) 2070 [value () x] 2071 [length () (vector-length vars)] 2072 [ref (i) 2073 (unless (and (fixnum? i) (fx< -1 i (vector-length vars))) 2074 ($oops 'procedure-object "invalid index ~s" i)) 2075 (vector-ref vars i)] 2076 [eval (x) (frame-eval vars x)] 2077 [code () (make-object ($closure-code x))] 2078 [size (g) (compute-size x g)] 2079 [write (p) (write x p)] 2080 [print (p) (pretty-print x p)])) 2081 2082 (define make-procedure-vars 2083 (lambda (x) 2084 (include "types.ss") 2085 (let ([code ($closure-code x)]) 2086 (let ([info ($code-info code)] 2087 [len ($code-free-count code)]) 2088 (let ([free (and (code-info? info) (code-info-free info))]) 2089 (unless (or (not free) (fx= (vector-length free) len)) 2090 ($oops 'inspector "invalid info structure ~s" info)) 2091 (let vars ([i 0]) 2092 (if (= i len) 2093 '() 2094 (cons (make-variable-object 2095 ($closure-ref x i) 2096 (and free (vector-ref free i))) 2097 (vars (+ i 1)))))))))) 2098 2099 (define assignable? 2100 (lambda (raw-val) 2101 (and (pair? raw-val) ($unbound-object? (cdr raw-val))))) 2102 2103 (define make-variable-object 2104 (make-object-maker variable (x name) 2105 [name () name] 2106 [assignable? () (assignable? x)] 2107 [raw-value () x] 2108 [ref () (make-object 2109 (if (assignable? x) 2110 (car x) 2111 x))] 2112 [set! (v) (make-object 2113 (if (assignable? x) 2114 (set-car! x v) 2115 ($oops 'variable-object "unassignable variable")))] 2116 [size (g) 2117 (if (assignable? x) 2118 (fx+ (constant size-pair) (compute-size (car x) g)) 2119 (compute-size x g))] 2120 [write (p) (display "#<variable>" p)] 2121 [print (p) (display "#<variable>" p) (newline p)])) 2122 2123 (define get-reloc-objs 2124 (foreign-procedure "(cs)s_get_reloc" 2125 (scheme-object) scheme-object)) 2126 2127 (module (get-code-src get-code-sexpr) 2128 (include "types.ss") 2129 (define get-code-src 2130 (lambda (x) 2131 (let ([info ($code-info x)]) 2132 (and (code-info? info) (code-info-src info))))) 2133 (define get-code-sexpr 2134 (lambda (x) 2135 (let ([info ($code-info x)]) 2136 (and (code-info? info) (code-info-sexpr info)))))) 2137 2138 (define make-code-object 2139 (make-object-maker code (x) 2140 [value () x] 2141 [name () ($code-name x)] 2142 [info () (make-object ($code-info x))] 2143 [free-count () ($code-free-count x)] 2144 [source () 2145 (cond 2146 [(get-code-sexpr x) => make-object] 2147 [else #f])] 2148 [source-path () (return-source (get-code-src x))] 2149 [source-object () (get-code-src x)] 2150 [reloc () (make-object (get-reloc-objs x))] 2151 [size (g) (compute-size x g)] 2152 [write (p) (write x p)] 2153 [print (p) (pretty-print x p)])) 2154 2155 (define return-source 2156 (lambda (src) 2157 (include "types.ss") 2158 (if src 2159 (call-with-values 2160 (lambda () ((current-locate-source-object-source) src #t #f)) 2161 (case-lambda 2162 [() (let ([sfd (source-sfd src)] [fp (source-bfp src)]) 2163 (values (source-file-descriptor-name sfd) fp))] 2164 [(path line char) (values path line char)])) 2165 (values)))) 2166 2167 (define-who make-continuation-object 2168 (lambda (x pos) 2169 (include "types.ss") 2170 (define find-rpi 2171 (lambda (offset rpis) 2172 (let f ([start 0] [end (fx1- (vector-length rpis))]) 2173 (if (fx< end start) 2174 #f 2175 (let* ([curr (fx+ (fx/ (fx- end start) 2) start)] 2176 [rpi (vector-ref rpis curr)] 2177 [rpi-offset (rp-info-offset rpi)]) 2178 (cond 2179 [(fx= offset rpi-offset) rpi] 2180 [(fx< offset rpi-offset) (f start (fx1- curr))] 2181 [else (f (fx1+ curr) end)])))))) 2182 ($split-continuation x 0) 2183 (let ([info ($code-info ($continuation-return-code x))] 2184 [offset ($continuation-return-offset x)] 2185 [len ($continuation-stack-length x)] 2186 [lpm ($continuation-return-livemask x)]) 2187 (cond 2188 [(and (code-info? info) (code-info-rpis info) (find-rpi offset (code-info-rpis info))) => 2189 (lambda (rpi) 2190 (let ([cookie '(chocolate . chip)]) 2191 (let ([vals (make-vector len cookie)] [vars (make-vector len '())] [live (code-info-live info)]) 2192 ; fill vals based on live-pointer mask 2193 (let f ([i 1] [lpm lpm]) 2194 (unless (>= i len) 2195 (when (odd? lpm) 2196 (vector-set! vals (fx1- i) ($continuation-stack-ref x i))) 2197 (f (fx1+ i) (ash lpm -1)))) 2198 ; fill vars based on code-info variable mask 2199 (let f ([i 0] [mask (rp-info-mask rpi)]) 2200 (unless (eqv? mask 0) 2201 (when (odd? mask) 2202 (let ([p (vector-ref live i)]) 2203 (let ([index (fx1- (cdr p))]) 2204 (vector-set! vars index (cons (car p) (vector-ref vars index)))))) 2205 (f (+ i 1) (ash mask -1)))) 2206 ; create return vector 2207 (with-values 2208 (let f ([i 0] [count 0] [cp #f] [cpvar* '()]) 2209 (if (fx= i len) 2210 (if cp 2211 (let ([v (let f ([count count] [cpvar* cpvar*]) 2212 (if (null? cpvar*) 2213 (make-vector count) 2214 (let ([v (f (fx+ count 1) (cdr cpvar*))]) 2215 (vector-set! v count (car cpvar*)) 2216 v)))]) 2217 (values v count cp)) 2218 (values (make-vector count) count cp)) 2219 (let ([obj (vector-ref vals i)] [var* (vector-ref vars i)]) 2220 (cond 2221 [(eq? obj cookie) 2222 (unless (null? var*) ($oops who "expected value for ~s but it was not in lpm" (car var*))) 2223 (f (fx1+ i) count cp cpvar*)] 2224 [(null? var*) 2225 (let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)]) 2226 (vector-set! v count (make-variable-object obj #f)) 2227 (values v frame-count cp))] 2228 [else 2229 (let g ([var* var*] [count count] [cp cp] [cpvar* cpvar*]) 2230 (if (null? var*) 2231 (f (fx1+ i) count cp cpvar*) 2232 (let ([var (car var*)]) 2233 (if (eq? var cpsymbol) 2234 (g (cdr var*) count obj (if (procedure? obj) (make-procedure-vars obj) '())) 2235 (cond 2236 [(pair? var) ; closure environment represented as a pair 2237 (unless (pair? obj) 2238 ($oops who "expected pair value for paired environment, not ~s" obj)) 2239 (g (cdr var*) count obj (list 2240 (make-variable-object (car obj) (car var)) 2241 (make-variable-object (cdr obj) (cdr var))))] 2242 [(vector? var) ; closure environment represented as a vector 2243 (unless (vector? obj) 2244 ($oops who "expected vector value for vector environment, not ~s" obj)) 2245 (g (cdr var*) count obj (map (lambda (obj var) (make-variable-object obj var)) 2246 (vector->list obj) 2247 (vector->list var)))] 2248 [else 2249 (let-values ([(v frame-count cp) (g (cdr var*) (fx1+ count) cp cpvar*)]) 2250 (vector-set! v count (make-variable-object obj var)) 2251 (values v frame-count cp))])))))])))) 2252 (lambda (v frame-count cp) 2253 (real-make-continuation-object x (rp-info-src rpi) (rp-info-sexpr rpi) cp v frame-count pos))))))] 2254 [else 2255 (let ([v (list->vector 2256 (let f ([i 1] [lpm lpm]) 2257 (cond 2258 [(>= i len) '()] 2259 [(odd? lpm) 2260 (cons (make-variable-object ($continuation-stack-ref x i) #f) 2261 (f (fx1+ i) (ash lpm -1)))] 2262 [else (f (fx1+ i) (ash lpm -1))])))]) 2263 (real-make-continuation-object x #f #f #f v (vector-length v) pos))])))) 2264 2265 (define real-make-continuation-object 2266 (let ((continuation-depth 2267 (foreign-procedure "(cs)continuation_depth" (scheme-object) 2268 iptr))) 2269 (make-object-maker continuation (x src sexpr cp vars frame-count pos) 2270 [value () x] 2271 [length () (vector-length vars)] 2272 [closure () (and cp (make-object cp))] 2273 [frame-length () frame-count] 2274 [depth () (continuation-depth x)] 2275 [ref (i) 2276 (unless (and (fixnum? i) (fx< -1 i (vector-length vars))) 2277 ($oops 'continuation-object "invalid index ~s" i)) 2278 (vector-ref vars i)] 2279 [pos () pos] 2280 [reposition (pos) 2281 (let ((k (and (fixnum? pos) (fx> pos 0) ($split-continuation x pos)))) 2282 (unless k ($oops 'continuation-object "invalid position ~s" pos)) 2283 (make-continuation-object k pos))] 2284 [link () (make-object ($continuation-link x))] 2285 [link* (i) 2286 (let ((k (and (fixnum? i) (fx>= i 0) ($split-continuation x i)))) 2287 (unless k ($oops 'continuation-object "invalid link* depth ~s" i)) 2288 (make-object k))] 2289 [eval (x) (frame-eval vars x)] 2290 [code () (make-object ($continuation-return-code x))] 2291 [source () (and sexpr (make-object sexpr))] 2292 [source-object () src] 2293 [source-path () (return-source src)] 2294 [size (g) (compute-size x g)] 2295 [write (p) (write x p)] 2296 [print (p) (pretty-print x p)]))) 2297 2298 (define make-port-object 2299 (make-object-maker port (x) 2300 [value () x] 2301 [input? () (input-port? x)] 2302 [output? () (output-port? x)] 2303 [binary? () (binary-port? x)] 2304 [closed? () (port-closed? x)] 2305 [handler () (make-object ($port-handler x))] 2306 [output-buffer () (and (output-port? x) 2307 (make-object 2308 (if (textual-port? x) 2309 (textual-port-output-buffer x) 2310 (binary-port-output-buffer x))))] 2311 [output-size () (and (output-port? x) 2312 (if (textual-port? x) 2313 (textual-port-output-size x) 2314 (binary-port-output-size x)))] 2315 [output-index () (and (output-port? x) 2316 (if (textual-port? x) 2317 (textual-port-output-index x) 2318 (binary-port-output-index x)))] 2319 [input-buffer () (and (input-port? x) 2320 (make-object 2321 (if (textual-port? x) 2322 (textual-port-input-buffer x) 2323 (binary-port-input-buffer x))))] 2324 [input-size () (and (input-port? x) 2325 (if (textual-port? x) 2326 (textual-port-input-size x) 2327 (binary-port-input-size x)))] 2328 [input-index () (and (input-port? x) 2329 (if (textual-port? x) 2330 (textual-port-input-index x) 2331 (binary-port-input-index x)))] 2332 [info () (make-object ($port-info x))] 2333 [name () (make-object (port-name x))] 2334 [size (g) (compute-size x g)] 2335 [write (p) (write x p)] 2336 [print (p) (pretty-print x p)])) 2337 2338 (define make-symbol-object 2339 (make-object-maker symbol (x) 2340 [value () x] 2341 [gensym? () (gensym? x)] 2342 [top-level-value () 2343 (if (top-level-bound? x) 2344 (make-object (top-level-value x)) 2345 (make-object ($unbound-object)))] 2346 [$top-level-value () 2347 (if ($top-level-bound? x) 2348 (make-object ($top-level-value x)) 2349 (make-object ($unbound-object)))] 2350 [system-property-list () (make-object ($system-property-list x))] 2351 [symbol-hash () (make-object ($symbol-hash x))] 2352 [name () (make-object (symbol->string x))] 2353 [property-list () (make-object ($symbol-property-list x))] 2354 [size (g) (compute-size x g)] 2355 [write (p) (write x p)] 2356 [print (p) (pretty-print x p)])) 2357 2358 (define make-object 2359 (lambda (x) 2360 (cond 2361 [(pair? x) (make-pair-object x)] 2362 [(symbol? x) (make-symbol-object x)] 2363 [(vector? x) (make-vector-object x)] 2364 [(fxvector? x) (make-fxvector-object x)] 2365 [(bytevector? x) (make-bytevector-object x)] 2366 ; ftype-pointer? test must come before record? test 2367 [($ftype-pointer? x) (make-ftype-pointer-object x)] 2368 [(or (record? x) (and (eq? (subset-mode) 'system) ($record? x))) 2369 (make-record-object x)] 2370 [(string? x) (make-string-object x)] 2371 [(box? x) (make-box-object x)] 2372 [(procedure? x) 2373 (if ($continuation? x) 2374 (if (= ($continuation-stack-length x) 2375 (constant unscaled-shot-1-shot-flag)) 2376 (make-simple-object x) 2377 (make-continuation-object x 0)) 2378 (make-procedure-object x))] 2379 [($code? x) (make-code-object x)] 2380 [(port? x) (make-port-object x)] 2381 [($unbound-object? x) (make-unbound-object x)] 2382 [($tlc? x) (make-tlc-object x)] 2383 [else (make-simple-object x)]))) 2384 2385 (make-object x))) 2386 2387(let () 2388 (define rtd-size (csv7:record-field-accessor #!base-rtd 'size)) 2389 (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) 2390 (define $generation (foreign-procedure "(cs)generation" (ptr) ptr)) 2391 (define $get-code-obj (foreign-procedure "(cs)get_code_obj" (int ptr iptr iptr) ptr)) 2392 (define $code-reloc-size 2393 (lambda (x) 2394 (let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))]) 2395 (if (eqv? reloc-table 0) 2396 0 2397 ($object-ref 'iptr reloc-table (constant reloc-table-size-disp)))))) 2398 (define $code-length 2399 (lambda (x) 2400 ($object-ref 'iptr x (constant code-length-disp)))) 2401 (define $get-reloc 2402 (lambda (x i) 2403 (let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))]) 2404 (and (not (eqv? reloc-table 0)) 2405 ($object-ref 'uptr reloc-table 2406 (fx+ (constant reloc-table-data-disp) 2407 (fx* i (constant ptr-bytes)))))))) 2408 (define-syntax tc-ptr-offsets 2409 (lambda (x) 2410 #`'#,(datum->syntax #'* 2411 (fold-left 2412 (lambda (ls fld) 2413 (apply (lambda (name type disp len) 2414 (if (eq? type 'ptr) 2415 (if len 2416 (do ([len len (fx- len 1)] 2417 [disp disp (fx+ disp (constant ptr-bytes))] 2418 [ls ls (cons disp ls)]) 2419 ((fx= len 0) ls)) 2420 (cons disp ls)) 2421 ls)) 2422 fld)) 2423 '() 2424 (or (getprop 'tc '*fields* #f) ($oops 'tc-ptr-offsets "missing fields for tc")))))) 2425 (define align 2426 (lambda (n) 2427 (fxlogand (fx+ n (fx- (constant byte-alignment) 1)) (fx- (constant byte-alignment))))) 2428 2429 (set-who! $compute-size 2430 (rec $compute-size 2431 (case-lambda 2432 [(x maxgen) ($compute-size x maxgen (make-eq-hashtable))] 2433 [(x maxgen size-ht) 2434 (define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size 2435 (define compute-size 2436 (lambda (x) 2437 (if (or ($immediate? x) 2438 (let ([g ($generation x)]) 2439 (or (not g) (fx> g maxgen)))) 2440 0 2441 (let ([a (eq-hashtable-cell size-ht x #f)]) 2442 (cond 2443 [(cdr a) => 2444 (lambda (p) 2445 ; if we find our cookie, return 0 to avoid counting shared structure twice. 2446 ; otherwise, (car p) must be a cookie from an earlier call to $compute-size, 2447 ; so return the recorded size 2448 (if (eq? (car p) cookie) 2449 0 2450 (begin 2451 (set-car! p cookie) 2452 (cdr p))))] 2453 [else 2454 (let ([p (cons cookie 0)]) 2455 (set-cdr! a p) 2456 (let ([size (really-compute-size x)]) 2457 (set-cdr! p size) 2458 size))]))))) 2459 (define really-compute-size 2460 (lambda (x) 2461 (cond 2462 [(pair? x) (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))] 2463 [(symbol? x) 2464 (fx+ (constant size-symbol) 2465 (compute-size (#3%$top-level-value x)) 2466 (compute-size (property-list x)) 2467 (compute-size ($system-property-list x)) 2468 (compute-size ($symbol-name x)))] 2469 [(vector? x) 2470 (let ([n (vector-length x)]) 2471 (do ([i 0 (fx+ i 1)] 2472 [size (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes)))) 2473 (fx+ size (compute-size (vector-ref x i)))]) 2474 ((fx= i n) size)))] 2475 [(fxvector? x) (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes))))] 2476 [(bytevector? x) (align (fx+ (constant header-size-bytevector) (bytevector-length x)))] 2477 [($record? x) 2478 (let ([rtd ($record-type-descriptor x)]) 2479 (fold-left (lambda (size fld) 2480 (if (eq? (fld-type fld) 'scheme-object) 2481 (fx+ size (compute-size ($object-ref 'scheme-object x (fld-byte fld)))) 2482 size)) 2483 (fx+ (align (rtd-size rtd)) (compute-size rtd)) 2484 (rtd-flds rtd)))] 2485 [(string? x) (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes))))] 2486 [(box? x) (fx+ (constant size-box) (compute-size (unbox x)))] 2487 [(flonum? x) (constant size-flonum)] 2488 [(bignum? x) (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes))))] 2489 [(ratnum? x) (fx+ (constant size-ratnum) (compute-size ($ratio-numerator x)) (compute-size ($ratio-denominator x)))] 2490 [($exactnum? x) (fx+ (constant size-exactnum) (compute-size ($exactnum-real-part x)) (compute-size ($exactnum-imag-part x)))] 2491 [($inexactnum? x) (constant size-inexactnum)] 2492 [(procedure? x) 2493 (if ($continuation? x) 2494 (if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag))) 2495 (constant size-continuation) 2496 (begin 2497 ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate 2498 ; NB: picture of the size prior to splitting. will add overhead to eventual invocation of 2499 ; NB: the continuation as well 2500 ($split-continuation x 0) 2501 ; not following RA slot at base of the frame, but this should always hold dounderflow, 2502 ; which will be in the static generation and therefore ignored anyway after compact heap 2503 (let ([len ($continuation-stack-length x)]) 2504 (let loop ([i 1] 2505 [lpm ($continuation-return-livemask x)] 2506 [size (fx+ (constant size-continuation) 2507 (align (fx* len (constant ptr-bytes))) 2508 (compute-size ($continuation-return-code x)) 2509 (compute-size ($closure-code x)) 2510 (compute-size ($continuation-link x)) 2511 (compute-size ($continuation-winders x)))]) 2512 (if (fx>= i len) 2513 size 2514 (loop (fx+ i 1) (ash lpm -1) (if (odd? lpm) (fx+ size (compute-size ($continuation-stack-ref x i))) size))))))) 2515 (let ([n ($closure-length x)]) 2516 (do ([i 0 (fx+ i 1)] 2517 [size (fx+ (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes)))) (compute-size ($closure-code x))) 2518 (fx+ size (compute-size ($closure-ref x i)))]) 2519 ((fx= i n) size))))] 2520 [($code? x) 2521 (fx+ (align (fx+ (constant header-size-code) ($code-length x))) 2522 (let ([n ($code-reloc-size x)]) 2523 (let loop ([i 0] [size (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes))))] [addr 0]) 2524 (if (fx= i n) 2525 size 2526 (let ([r ($get-reloc x i)]) 2527 (and r 2528 (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))]) 2529 (if (logtest r (constant reloc-extended-format)) 2530 (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))]) 2531 (loop (fx+ i 3) 2532 (fx+ size 2533 (compute-size 2534 ($get-code-obj type x addr ($get-reloc x (fx+ i 1))))) 2535 addr)) 2536 (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))]) 2537 (loop (fx+ i 1) 2538 (fx+ size 2539 (compute-size 2540 ($get-code-obj type x addr 2541 (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask))))) 2542 addr))))))))) 2543 (compute-size ($code-name x)) 2544 (compute-size ($code-info x)) 2545 (compute-size ($code-pinfo* x)))] 2546 [(port? x) 2547 (fx+ (constant size-port) 2548 (compute-size ($port-handler x)) 2549 (if (input-port? x) (compute-size (port-input-buffer x)) 0) 2550 (if (output-port? x) (compute-size (port-output-buffer x)) 0) 2551 (compute-size ($port-info x)) 2552 (compute-size (port-name x)))] 2553 [(thread? x) 2554 (let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))]) 2555 (fold-left 2556 (lambda (size disp) 2557 (fx+ size (compute-size ($object-ref 'scheme-object tc disp)))) 2558 (constant size-thread) 2559 tc-ptr-offsets))] 2560 [($tlc? x) 2561 (fx+ (constant size-tlc) 2562 (compute-size ($tlc-ht x)) 2563 (compute-size ($tlc-keyval x)) 2564 (compute-size ($tlc-next x)))] 2565 [($rtd-counts? x) (constant size-rtd-counts)] 2566 [else ($oops who "missing case for ~s" x)]))) 2567 ; ensure size-ht isn't counted in the size of any object 2568 (eq-hashtable-set! size-ht size-ht (cons cookie 0)) 2569 (compute-size x)]))) 2570 2571 (set-who! $compute-composition 2572 (lambda (x maxgen) 2573 (define cookie (cons 'oatmeal 'raisin)) 2574 (define seen-ht (make-eq-hashtable)) 2575 (define rtd-ht (make-eq-hashtable)) 2576 (define-syntax define-counters 2577 (lambda (x) 2578 (syntax-case x () 2579 [(_ (name-vec count-vec incr!) type ...) 2580 (with-syntax ([(i ...) (enumerate #'(type ...))]) 2581 #'(begin 2582 (define name-vec (vector 'type ...)) 2583 (define count-vec (make-vector (length #'(type ...)) #f)) 2584 (define-syntax incr! 2585 (syntax-rules (type ...) 2586 [(_ type size) 2587 (let ([p (vector-ref count-vec i)]) 2588 (if p 2589 (begin 2590 (set-car! p (fx+ (car p) 1)) 2591 (set-cdr! p (fx+ (cdr p) size))) 2592 (vector-set! count-vec i (cons 1 size))))] 2593 ...))))]))) 2594 (define-counters (type-names type-counts incr!) 2595 pair symbol vector fxvector bytevector string box flonum bignum ratnum exactnum 2596 inexactnum continuation stack procedure code-object reloc-table port thread tlc 2597 rtd-counts) 2598 (define compute-composition! 2599 (lambda (x) 2600 (unless (or ($immediate? x) 2601 (let ([g ($generation x)]) 2602 (or (not g) (fx> g maxgen)))) 2603 (let ([a (eq-hashtable-cell seen-ht x #f)]) 2604 (unless (cdr a) 2605 (set-cdr! a #t) 2606 (really-compute-composition! x)))))) 2607 (define really-compute-composition! 2608 (lambda (x) 2609 (cond 2610 [(pair? x) 2611 (incr! pair (constant size-pair)) 2612 (compute-composition! (car x)) 2613 (compute-composition! (cdr x))] 2614 [(symbol? x) 2615 (incr! symbol (constant size-symbol)) 2616 (compute-composition! (#3%$top-level-value x)) 2617 (compute-composition! (property-list x)) 2618 (compute-composition! ($system-property-list x)) 2619 (compute-composition! ($symbol-name x))] 2620 [(vector? x) 2621 (incr! vector (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes))))) 2622 (vector-for-each compute-composition! x)] 2623 [(fxvector? x) (incr! fxvector (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes)))))] 2624 [(bytevector? x) (incr! bytevector (align (fx+ (constant header-size-bytevector) (bytevector-length x))))] 2625 [($record? x) 2626 (let ([rtd ($record-type-descriptor x)]) 2627 (let ([p (eq-hashtable-ref rtd-ht rtd #f)] [size (align (rtd-size rtd))]) 2628 (if p 2629 (begin 2630 (set-car! p (fx+ (car p) 1)) 2631 (set-cdr! p (fx+ (cdr p) size))) 2632 (eq-hashtable-set! rtd-ht rtd (cons 1 size)))) 2633 (compute-composition! rtd) 2634 (for-each (lambda (fld) 2635 (when (eq? (fld-type fld) 'scheme-object) 2636 (compute-composition! ($object-ref 'scheme-object x (fld-byte fld))))) 2637 (rtd-flds rtd)))] 2638 [(string? x) (incr! string (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes)))))] 2639 [(box? x) 2640 (incr! box (constant size-box)) 2641 (compute-composition! (unbox x))] 2642 [(flonum? x) (incr! flonum (constant size-flonum))] 2643 [(bignum? x) (incr! bignum (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes)))))] 2644 [(ratnum? x) 2645 (incr! ratnum (constant size-ratnum)) 2646 (compute-composition! ($ratio-numerator x)) 2647 (compute-composition! ($ratio-denominator x))] 2648 [($exactnum? x) 2649 (incr! exactnum (constant size-exactnum)) 2650 (compute-composition! ($exactnum-real-part x)) 2651 (compute-composition! ($exactnum-imag-part x))] 2652 [($inexactnum? x) (incr! inexactnum (constant size-inexactnum))] 2653 [(procedure? x) 2654 (if ($continuation? x) 2655 (begin 2656 (incr! continuation (constant size-continuation)) 2657 (unless (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag))) 2658 ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate 2659 ; NB: picture of the continuation counts & sizes prior to splitting. will add overhead to eventual invocation of 2660 ; NB: the continuation as well 2661 ($split-continuation x 0) 2662 (compute-composition! ($continuation-return-code x)) 2663 (compute-composition! ($closure-code x)) 2664 (compute-composition! ($continuation-link x)) 2665 (compute-composition! ($continuation-winders x)) 2666 (let ([len ($continuation-stack-length x)]) 2667 (incr! stack (align (fx* len (constant ptr-bytes)))) 2668 (let loop ([i 1] [lpm ($continuation-return-livemask x)]) 2669 (unless (fx>= i len) 2670 (when (odd? lpm) (compute-composition! ($continuation-stack-ref x i))) 2671 (loop (fx+ i 1) (ash lpm -1))))))) 2672 (begin 2673 (compute-composition! ($closure-code x)) 2674 (let ([n ($closure-length x)]) 2675 (incr! procedure (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes))))) 2676 (do ([i 0 (fx+ i 1)]) 2677 ((fx= i n)) 2678 (compute-composition! ($closure-ref x i))))))] 2679 [($code? x) 2680 (incr! code-object (align (fx+ (constant header-size-code) ($code-length x)))) 2681 (let ([n ($code-reloc-size x)]) 2682 (incr! reloc-table (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes))))) 2683 (let loop ([i 0] [addr 0]) 2684 (unless (fx= i n) 2685 (let ([r ($get-reloc x i)]) 2686 (and r 2687 (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))]) 2688 (if (logtest r (constant reloc-extended-format)) 2689 (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))]) 2690 (compute-composition! ($get-code-obj type x addr ($get-reloc x (fx+ i 1)))) 2691 (loop (fx+ i 3) addr)) 2692 (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))]) 2693 (compute-composition! 2694 ($get-code-obj type x addr 2695 (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask)))) 2696 (loop (fx+ i 1) addr))))))))) 2697 (compute-composition! ($code-name x)) 2698 (compute-composition! ($code-info x)) 2699 (compute-composition! ($code-pinfo* x))] 2700 [(port? x) 2701 (incr! port (constant size-port)) 2702 (compute-composition! ($port-handler x)) 2703 (if (input-port? x) (compute-composition! (port-input-buffer x)) 0) 2704 (if (output-port? x) (compute-composition! (port-output-buffer x)) 0) 2705 (compute-composition! ($port-info x)) 2706 (compute-composition! (port-name x))] 2707 [(thread? x) 2708 (incr! thread (constant size-thread)) 2709 (let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))]) 2710 (for-each (lambda (disp) (compute-composition! ($object-ref 'scheme-object tc disp))) tc-ptr-offsets))] 2711 [($tlc? x) 2712 (incr! tlc (constant size-tlc)) 2713 (compute-composition! ($tlc-ht x)) 2714 (compute-composition! ($tlc-keyval x)) 2715 (compute-composition! ($tlc-next x))] 2716 [($rtd-counts? x) (incr! rtd-counts (constant size-rtd-counts))] 2717 [else ($oops who "missing case for ~s" x)]))) 2718 ; ensure hashtables aren't counted 2719 (eq-hashtable-set! seen-ht seen-ht #t) 2720 (eq-hashtable-set! seen-ht rtd-ht #t) 2721 (compute-composition! x) 2722 (append 2723 (filter cdr (vector->list (vector-map cons type-names type-counts))) 2724 (vector->list 2725 (let-values ([(keys vals) (hashtable-entries rtd-ht)]) 2726 (vector-map cons keys vals)))))) 2727 2728 (set-who! $make-object-finder 2729 ; pred object maxgen => object-finder procedure that returns 2730 ; next object satisfying pred 2731 ; or #f, if no object found 2732 (lambda (pred x maxgen) 2733 (let ([seen-ht (make-eq-hashtable)]) 2734 (define saved-next-proc 2735 (lambda () 2736 (find! x '() (lambda () #f)))) 2737 (define find! 2738 (lambda (x path next-proc) 2739 (let ([path (cons x path)]) 2740 (cond 2741 [(or ($immediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen)))) 2742 (if (pred x) 2743 (begin (set! saved-next-proc next-proc) path) 2744 (next-proc))] 2745 [else 2746 (if (eq-hashtable-ref seen-ht x #f) 2747 (next-proc) ; detected a loop, so backtrack and keep looking 2748 (begin 2749 (eq-hashtable-set! seen-ht x #t) ; mark this node as visited 2750 (really-find! x path next-proc)))])))) 2751 ; We're visiting this node for the first time 2752 (define really-find! 2753 (lambda (x path next-proc) 2754 (define-syntax construct-proc 2755 (syntax-rules () 2756 [(_ ?next-proc) ?next-proc] 2757 [(_ ?e ?e* ... ?next-proc) 2758 (lambda () (find! ?e path (construct-proc ?e* ... ?next-proc)))])) 2759 (let ([next-proc 2760 (cond 2761 [(pair? x) (construct-proc (car x) (cdr x) next-proc)] 2762 [(symbol? x) 2763 (construct-proc 2764 (#3%$top-level-value x) 2765 (property-list x) 2766 ($system-property-list x) 2767 ($symbol-name x) next-proc)] 2768 [(vector? x) 2769 (let ([n (vector-length x)]) 2770 (let f ([i 0]) 2771 (if (fx= i n) 2772 next-proc 2773 (construct-proc (vector-ref x i) (f (fx+ i 1))))))] 2774 [($record? x) 2775 (let ([rtd ($record-type-descriptor x)]) 2776 (construct-proc rtd 2777 (let f ([flds (rtd-flds rtd)]) 2778 (if (null? flds) 2779 next-proc 2780 (let ([fld (car flds)]) 2781 (if (eq? (fld-type fld) 'scheme-object) 2782 (construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds))) 2783 (f (cdr flds))))))))] 2784 [(or (fxvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x) 2785 ($inexactnum? x) ($rtd-counts? x)) 2786 next-proc] 2787 [(box? x) (construct-proc (unbox x) next-proc)] 2788 [(ratnum? x) (construct-proc ($ratio-numerator x) ($ratio-denominator x) next-proc)] 2789 [($exactnum? x) (construct-proc ($exactnum-real-part x) ($exactnum-imag-part x) next-proc)] 2790 [(procedure? x) 2791 (if ($continuation? x) 2792 (if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag))) 2793 next-proc 2794 (begin 2795 ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate 2796 ; NB: picture of the size prior to splitting. will add overhead to eventual invocation of 2797 ; NB: the continuation as well 2798 ($split-continuation x 0) 2799 ; not following RA slot at base of the frame, but this should always hold dounderflow, 2800 ; which will be in the static generation and therefore ignored anyway after compact heap 2801 (let ([len ($continuation-stack-length x)]) 2802 (let loop ([i 1] [lpm ($continuation-return-livemask x)]) 2803 (if (fx>= i len) 2804 (construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x) ($continuation-winders x) next-proc) 2805 (if (odd? lpm) 2806 (construct-proc ($continuation-stack-ref x i) (loop (fx+ i 1) (ash lpm -1))) 2807 (loop (fx+ i 1) (ash lpm -1)))))))) 2808 (construct-proc ($closure-code x) 2809 (let ([n ($closure-length x)]) 2810 (let f ([i 0]) 2811 (if (fx= i n) 2812 next-proc 2813 (construct-proc ($closure-ref x i) (f (fx+ i 1))))))))] 2814 [($code? x) 2815 (construct-proc ($code-name x) ($code-info x) ($code-pinfo* x) 2816 (let ([n ($code-reloc-size x)]) 2817 (let loop ([i 0] [addr 0]) 2818 (if (fx= i n) 2819 next-proc 2820 (let ([r ($get-reloc x i)]) 2821 (if (not r) 2822 next-proc 2823 (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))]) 2824 (if (logtest r (constant reloc-extended-format)) 2825 (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))]) 2826 (construct-proc ($get-code-obj type x addr ($get-reloc x (fx+ i 1))) 2827 (loop (fx+ i 3) addr))) 2828 (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))]) 2829 (construct-proc 2830 ($get-code-obj type x addr 2831 (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask))) 2832 (loop (fx+ i 1) addr)))))))))))] 2833 [(port? x) 2834 (construct-proc ($port-handler x) ($port-info x) (port-name x) 2835 (let ([th (lambda () (if (output-port? x) (construct-proc (port-output-buffer x) next-proc) next-proc))]) 2836 (if (input-port? x) (construct-proc (port-input-buffer x) (th)) (th))))] 2837 [(thread? x) 2838 (let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))]) 2839 (let f ([disp-list tc-ptr-offsets]) 2840 (if (null? disp-list) 2841 next-proc 2842 (construct-proc ($object-ref 'scheme-object tc (car disp-list)) (f (cdr tc-ptr-offsets))))))] 2843 [($tlc? x) (construct-proc ($tlc-ht x) ($tlc-keyval x) ($tlc-next x) next-proc)] 2844 [else ($oops who "missing case for ~s" x)])]) 2845 ; check if this node is what we're looking for 2846 (if (pred x) 2847 (begin (set! saved-next-proc next-proc) path) 2848 (next-proc))))) 2849 (rec find-next (lambda () (saved-next-proc))))))) 2850 2851(let () 2852 (define filter-generation 2853 (lambda (who g) 2854 (unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)) 2855 ($oops who "invalid generation ~s" g)) 2856 (if (eq? g 'static) (constant static-generation) g))) 2857 2858 (set-who! make-object-finder 2859 (case-lambda 2860 [(pred) 2861 (unless (procedure? pred) ($oops who "~s is not a procedure" pred)) 2862 ($make-object-finder pred (oblist) (collect-maximum-generation))] 2863 [(pred x) 2864 (unless (procedure? pred) ($oops who "~s is not a procedure" pred)) 2865 ($make-object-finder pred x (collect-maximum-generation))] 2866 [(pred x g) 2867 (unless (procedure? pred) ($oops who "~s is not a procedure" pred)) 2868 ($make-object-finder pred x (filter-generation who g))])) 2869 2870 (set-who! compute-size 2871 (case-lambda 2872 [(x) ($compute-size x (collect-maximum-generation))] 2873 [(x g) ($compute-size x (filter-generation who g))])) 2874 2875 (set-who! compute-composition 2876 (case-lambda 2877 [(x) ($compute-composition x (collect-maximum-generation))] 2878 [(x g) ($compute-composition x (filter-generation who g))]))) 2879 2880(define object-counts (foreign-procedure "(cs)object_counts" () ptr)) 2881) 2882