You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2882 lines
107 KiB
Scheme
2882 lines
107 KiB
Scheme
;;; inspect.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; todo
|
|
|
|
; ---be sensitive to system mode
|
|
; ---argument names for code objects
|
|
; ---nesting level numbers for all variables
|
|
; (sort variable displays by nesting and position)
|
|
; ---add "loop" variable type
|
|
; ---keep track of loop names?
|
|
; ---information about foreign procedures
|
|
; ---distinguish between user and compiler gensym variables?
|
|
; (right now both are stripped)
|
|
; ---disassembler
|
|
; ---port info should include file descriptor, perhaps provide access
|
|
; location in file
|
|
|
|
(begin
|
|
(let ()
|
|
|
|
(define-syntax make-dispatch-table
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ [key message (ids e1 e2 ...) ...] ...)
|
|
(and (andmap (lambda (x)
|
|
(or (string? x)
|
|
(and (pair? x) (string? (car x)) (string? (cdr x)))))
|
|
(datum (key ...)))
|
|
(andmap string? (datum (message ...))))
|
|
#'`([key message
|
|
,(case-lambda
|
|
(ids e1 e2 ...)
|
|
...
|
|
(l (invalid-command)))]
|
|
...)])))
|
|
|
|
(define-record-type sfile
|
|
(fields (immutable path) (immutable port) (mutable line) (mutable line-valid?))
|
|
(nongenerative)
|
|
(sealed #t))
|
|
|
|
(define-threaded source-files '())
|
|
|
|
(define find-source-file
|
|
(lambda (path line)
|
|
(define path=?
|
|
; trivial definition for now
|
|
(lambda (p1 p2)
|
|
(string=? p1 p2)))
|
|
(let f ((ls source-files))
|
|
(if (null? ls)
|
|
(guard (c [#t #f])
|
|
(let ((line (or line 1)))
|
|
(set! source-files
|
|
(cons (make-sfile path (open-input-file path)
|
|
line
|
|
(= line 1))
|
|
source-files)))
|
|
#t)
|
|
(if (path=? path (sfile-path (car ls)))
|
|
(let ((sf (car ls)))
|
|
(when line
|
|
(unless (= line (sfile-line sf))
|
|
(sfile-line-valid?-set! sf #f)
|
|
(sfile-line-set! sf line)))
|
|
(set! source-files
|
|
(cons sf (remq sf source-files)))
|
|
#t)
|
|
(f (cdr ls)))))))
|
|
|
|
(define open-source-file
|
|
(case-lambda
|
|
[(path) (open-source-file path #f)]
|
|
[(path line)
|
|
(or (if ($fixed-path? path)
|
|
(find-source-file path line)
|
|
(let ([dir* (append (source-directories) (map car (library-directories)))])
|
|
(let pathloop ([path path])
|
|
(let dirloop ([dir* dir*])
|
|
(if (null? dir*)
|
|
(let ([rest (path-rest path)])
|
|
(and (not (string=? rest path))
|
|
(pathloop rest)))
|
|
(or (find-source-file
|
|
(let* ((dir (car dir*)) (n (string-length dir)))
|
|
(format (if (and (fx> n 0)
|
|
(directory-separator?
|
|
(string-ref dir (fx- n 1))))
|
|
"~a~a"
|
|
"~a/~a")
|
|
dir path))
|
|
line)
|
|
(dirloop (cdr dir*))))))))
|
|
(inspect-error "Cannot open ~a" path))]))
|
|
|
|
(define open-recorded-source-file
|
|
(lambda (object)
|
|
(call-with-values
|
|
(lambda () (object 'source-path))
|
|
(case-lambda
|
|
[() (inspect-error "Source file unknown.")]
|
|
[(path pos)
|
|
(inspect-error
|
|
"Cannot locate (unmodified) source file ~a.~%Try changing source-directories parameter.~%Source is at character ~s."
|
|
path pos)]
|
|
[(path line char)
|
|
(if (find-source-file path
|
|
(max (- line (quotient lines-to-list 2)) 1))
|
|
(show "line ~d, character ~d of ~a" line char path)
|
|
(inspect-error "Cannot open ~a" path))]))))
|
|
|
|
(define close-source-file
|
|
(lambda (sf)
|
|
(close-input-port (sfile-port sf))))
|
|
|
|
(define lines-to-list 10)
|
|
|
|
(module (list-source-file)
|
|
(define base10-length
|
|
(lambda (n)
|
|
(cond
|
|
[(fx< n 10) 1]
|
|
[(fx< n 100) 2]
|
|
[(fx< n 1000) 3]
|
|
[(fx< n 10000) 4]
|
|
[else (+ 4 (base10-length (quotient n 10000)))])))
|
|
|
|
(define list-source-file
|
|
(case-lambda
|
|
[() (list-source-file #f #f)]
|
|
[(line) (list-source-file line #f)]
|
|
[(line count)
|
|
(when (null? source-files)
|
|
(inspect-error "No source file open."))
|
|
(let* ((sf (car source-files))
|
|
(ip (sfile-port sf)))
|
|
(when line (require (fixnum? line)))
|
|
(when count (require (and (fixnum? count) (fx> count 0))))
|
|
(let* ((line (cond [(not line) (sfile-line sf)]
|
|
[(fx> line 0) line]
|
|
[else (max (+ (sfile-line sf) line (- lines-to-list))
|
|
1)]))
|
|
(count (if count
|
|
(begin (set! lines-to-list count) count)
|
|
lines-to-list)))
|
|
(let f ((new-line
|
|
(if (and (sfile-line-valid? sf) (fx>= line (sfile-line sf)))
|
|
(begin
|
|
(sfile-line-valid?-set! sf #f)
|
|
(sfile-line sf))
|
|
(begin
|
|
(sfile-line-valid?-set! sf #f)
|
|
(file-position ip 0)
|
|
1))))
|
|
(unless (fx= new-line line)
|
|
(let ((c (read-char ip)))
|
|
(cond
|
|
[(eof-object? c)
|
|
(inspect-error "Not that many lines in ~a." (sfile-path sf))]
|
|
[(char=? c #\newline) (f (fx+ new-line 1))]
|
|
[else (f new-line)]))))
|
|
(let ((line-chars (base10-length (+ line count -1))))
|
|
(let f ((line line) (count count))
|
|
(if (fx= count 0)
|
|
(begin
|
|
(sfile-line-set! sf line)
|
|
(sfile-line-valid?-set! sf #t))
|
|
(let ((c (read-char ip)))
|
|
(if (eof-object? c)
|
|
(fprintf (console-output-port) "*** end of file ***~%")
|
|
(begin
|
|
(do ((n (base10-length line) (fx+ n 1)))
|
|
((fx= n line-chars))
|
|
(write-char #\space (console-output-port)))
|
|
(fprintf (console-output-port) "~d: " line)
|
|
(do ((c c (read-char ip)))
|
|
((or (eof-object? c) (char=? c #\newline))
|
|
(newline (console-output-port)))
|
|
(write-char c (console-output-port)))
|
|
(f (fx+ line 1) (fx- count 1))))))))))]))
|
|
)
|
|
|
|
(define (waiter-read)
|
|
(parameterize ([waiter-prompt-string ""])
|
|
((waiter-prompt-and-read) 1)))
|
|
|
|
(define show
|
|
(lambda (s . args)
|
|
(apply fprintf (console-output-port) s args)
|
|
(newline (console-output-port))))
|
|
|
|
(define inspect-error
|
|
(lambda (s . args)
|
|
(apply show s args)
|
|
(reset)))
|
|
|
|
(define invalid-command
|
|
(lambda ()
|
|
(inspect-error "Invalid command or argument. Type ? for options.")))
|
|
|
|
(define invalid-movement
|
|
(lambda ()
|
|
(inspect-error "Invalid movement.")))
|
|
|
|
(define line-indent " ")
|
|
|
|
(define prompt-line-limit 65)
|
|
|
|
(define display-line-limit 80)
|
|
|
|
(define descrip-limit 25)
|
|
|
|
(define-threaded marks)
|
|
|
|
(define-threaded current-state)
|
|
|
|
(define-record-type state
|
|
(fields (immutable object) (immutable level) (immutable position) (immutable link) (mutable find-next))
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (new)
|
|
(case-lambda
|
|
[(object) (new object 0 #f #f #f)]
|
|
[(object level position link) (new object level position link #f)]))))
|
|
|
|
(define object (lambda () (state-object current-state)))
|
|
|
|
(define level (lambda () (state-level current-state)))
|
|
|
|
(define position (lambda () (state-position current-state)))
|
|
|
|
(define type?
|
|
(lambda (flag x)
|
|
(eq? (x 'type) flag)))
|
|
|
|
(define default-mark (void))
|
|
|
|
(define make-mark
|
|
(lambda (m)
|
|
(if (string? m)
|
|
(string->symbol m)
|
|
m)))
|
|
|
|
(define put-mark
|
|
(lambda (m)
|
|
(let ([a (eq-hashtable-cell marks m #f)])
|
|
(set-cdr! a current-state))))
|
|
|
|
(define get-mark
|
|
(lambda (m)
|
|
(eq-hashtable-ref marks m #f)))
|
|
|
|
(define to-mark
|
|
(lambda (m)
|
|
(let ([s (get-mark m)])
|
|
(unless s (invalid-movement))
|
|
(put-mark default-mark)
|
|
(set! current-state s))))
|
|
|
|
(define down
|
|
(lambda (x pos)
|
|
(set! current-state
|
|
(make-state (if (eq? (x 'type) 'variable) (x 'ref) x)
|
|
(+ (level) 1)
|
|
pos
|
|
current-state))))
|
|
|
|
(define up
|
|
(lambda ()
|
|
(set! current-state (state-link current-state))
|
|
(unless current-state (invalid-movement))))
|
|
|
|
(define display-links
|
|
(lambda (n)
|
|
(let loop ([i 0] [x (object)])
|
|
(unless (= i n)
|
|
(when (type? 'continuation x)
|
|
(label-line-display x i)
|
|
(loop (+ i 1) (x 'link)))))))
|
|
|
|
(define display-refs
|
|
(lambda (n)
|
|
(let ([x (object)])
|
|
(let loop ([i 0])
|
|
(unless (= i n)
|
|
(label-line-display (x 'ref i) i)
|
|
(loop (+ i 1)))))))
|
|
|
|
(define display-variable-refs
|
|
(lambda (n)
|
|
(let ([x (object)])
|
|
(if ((x 'code) 'info)
|
|
(let loop ([i 0])
|
|
(unless (= i n)
|
|
(variable-line-display (x 'ref i) i)
|
|
(loop (+ i 1))))
|
|
(display-refs n)))))
|
|
|
|
(define display-list
|
|
(lambda (n)
|
|
(let ((x (object)))
|
|
(if (or (type? 'pair (x 'cdr))
|
|
(and (type? 'simple (x 'cdr)) (null? ((x 'cdr) 'value))))
|
|
(let loop ([i 0] [x x])
|
|
(if (and (< i n) (type? 'pair x))
|
|
(begin
|
|
(label-line-display (x 'car) i)
|
|
(loop (+ i 1) (x 'cdr)))
|
|
(unless (and (type? 'simple x) (null? (x 'value)))
|
|
(name-line-display x "tail"))))
|
|
(begin
|
|
(name-line-display (x 'car) "car")
|
|
(name-line-display (x 'cdr) "cdr"))))))
|
|
|
|
(define charschemecode
|
|
(lambda (x)
|
|
(let ([x (format "~s" x)])
|
|
(format "~a~a" x (spaces (- 11 (string-length x)))))))
|
|
|
|
(define unicodehexcode
|
|
(lambda (x)
|
|
(format "~6,'0x " (char->integer x))))
|
|
|
|
(define asciihexcode
|
|
(lambda (x)
|
|
(let ([n (char->integer x)])
|
|
(if (>= n 256)
|
|
"-- "
|
|
(format "~2,'0x " n)))))
|
|
|
|
(define display-chars
|
|
(lambda (n former no/line)
|
|
(let ([x (object)])
|
|
(let loop1 ([i 0])
|
|
(unless (= i n)
|
|
(let ([label (format "~a~d: " line-indent i)])
|
|
(let loop2 ([j 0] [i i] [strings '()])
|
|
(if (or (= j no/line) (= i n))
|
|
(begin
|
|
(show "~a~a~a"
|
|
label
|
|
(spaces (- 6 (string-length label)))
|
|
(apply string-append (reverse strings)))
|
|
(loop1 i))
|
|
(loop2 (+ j 1)
|
|
(+ i 1)
|
|
(cons (former ((x 'ref i) 'value))
|
|
strings))))))))))
|
|
|
|
(define label-line-display
|
|
(lambda (x n)
|
|
(let ([label (format "~a~d: " line-indent n)])
|
|
(show "~a~a"
|
|
label
|
|
(form x (string-length label) display-line-limit)))))
|
|
|
|
(define name-label-line-display
|
|
(lambda (x name n)
|
|
(let ([label (format "~a~d. ~a:" line-indent n name)])
|
|
(let ([label (format "~a~a"
|
|
label
|
|
(spaces (- descrip-limit (string-length label))))])
|
|
(show "~a~a"
|
|
label
|
|
(form x (string-length label) display-line-limit))))))
|
|
|
|
(define name-line-display
|
|
(lambda (x name)
|
|
(let ([label (format "~a~a:" line-indent name)])
|
|
(let ([label (format "~a~a"
|
|
label
|
|
(spaces (- descrip-limit (string-length label))))])
|
|
(show "~a~a"
|
|
label
|
|
(form x (string-length label) display-line-limit))))))
|
|
|
|
(define variable-line-display
|
|
(lambda (x n)
|
|
(if (x 'name)
|
|
(name-label-line-display (x 'ref) (x 'name) n)
|
|
(label-line-display (x 'ref) n))))
|
|
|
|
(define ref-list
|
|
(lambda (n)
|
|
(unless (and (fixnum? n) (>= n 0)) (invalid-movement))
|
|
(let ref ([i n] [x (object)])
|
|
(cond
|
|
[(not (type? 'pair x)) (invalid-movement)]
|
|
[(= i 0) (down (x 'car) n)]
|
|
[else (ref (- i 1) (x 'cdr))]))))
|
|
|
|
(define ref
|
|
(lambda (n)
|
|
(unless (and (fixnum? n) (< -1 n ((object) 'length)))
|
|
(invalid-movement))
|
|
(down ((object) 'ref n) n)))
|
|
|
|
(define set
|
|
(lambda (n v)
|
|
(unless (and (fixnum? n) (< -1 n ((object) 'length)))
|
|
(invalid-movement))
|
|
(let ([x ((object) 'ref n)])
|
|
(unless (x 'assignable?)
|
|
(inspect-error "~s is not assignable" (or (x 'name) 'unnamed)))
|
|
(x 'set! v))))
|
|
|
|
(module (variable-ref variable-set)
|
|
(define get-var-obj
|
|
(lambda (sym)
|
|
(let ([n ((object) 'length)])
|
|
(let loop ([i 0])
|
|
(if (fx= i n)
|
|
(invalid-movement)
|
|
(let ([x ((object) 'ref i)])
|
|
(if (let ([name (x 'name)])
|
|
(and (symbol? name)
|
|
(string=?
|
|
(symbol->string name)
|
|
(symbol->string sym))))
|
|
(values x i)
|
|
(loop (fx+ i 1)))))))))
|
|
(define variable-ref
|
|
(lambda (x)
|
|
(if (symbol? x)
|
|
(with-values (get-var-obj x) down)
|
|
(ref x))))
|
|
(define variable-set
|
|
(lambda (x val)
|
|
(if (symbol? x)
|
|
(with-values (get-var-obj x)
|
|
(lambda (var-obj i)
|
|
(unless (var-obj 'assignable?) (inspect-error "~s is not assignable" x))
|
|
(var-obj 'set! val)))
|
|
(set x val)))))
|
|
|
|
(define move
|
|
(lambda (n)
|
|
(require (position))
|
|
(let ([n (+ n (position))])
|
|
(up)
|
|
(case ((object) 'type)
|
|
[(pair) (ref-list n)]
|
|
[(continuation procedure vector fxvector bytevector string record
|
|
ftype-struct ftype-union ftype-array ftype-bits)
|
|
(ref n)]
|
|
[else (invalid-movement)]))))
|
|
|
|
(define require
|
|
(lambda (x)
|
|
(unless x (invalid-command))))
|
|
|
|
(define range-check
|
|
(case-lambda
|
|
[(n) (require (and (fixnum? n) (fx<= 0 n)))]
|
|
[(n max) (require (and (fixnum? n) (fx<= 0 n max)))]
|
|
[(min n max) (require (and (fixnum? n) (fx<= min n max)))]))
|
|
|
|
(define display-one-option
|
|
(lambda (key message)
|
|
(let ([s (if (pair? key) (format "~a(~a)" (car key) (cdr key)) key)])
|
|
(show " ~a ~a ~a"
|
|
s
|
|
(make-string (max (- 20 (string-length s)) 0) #\.)
|
|
message))))
|
|
|
|
(define display-options
|
|
(lambda (table generic?)
|
|
(show "")
|
|
(for-each display-one-option (map car table) (map cadr table))
|
|
(unless generic? (display-one-option "??" "display more options"))
|
|
(show "")))
|
|
|
|
(define select-dispatch-table
|
|
(lambda ()
|
|
(case ((object) 'type)
|
|
[(pair) pair-dispatch-table]
|
|
[(symbol) (if (eq? (subset-mode) 'system)
|
|
system-symbol-dispatch-table
|
|
symbol-dispatch-table)]
|
|
[(vector) vector-dispatch-table]
|
|
[(fxvector) fxvector-dispatch-table]
|
|
[(bytevector) bytevector-dispatch-table]
|
|
[(record) record-dispatch-table]
|
|
[(string) string-dispatch-table]
|
|
[(box) box-dispatch-table]
|
|
[(continuation) continuation-dispatch-table]
|
|
[(procedure) procedure-dispatch-table]
|
|
[(code) code-dispatch-table]
|
|
[(port) port-dispatch-table]
|
|
[(simple)
|
|
(let ([x ((object) 'value)])
|
|
(cond
|
|
[(char? x) char-dispatch-table]
|
|
[else empty-dispatch-table]))]
|
|
[(tlc) tlc-dispatch-table]
|
|
[(ftype-struct) ftype-struct-dispatch-table]
|
|
[(ftype-union) ftype-union-dispatch-table]
|
|
[(ftype-array) ftype-array-dispatch-table]
|
|
[(ftype-*) ftype-pointer-dispatch-table]
|
|
[(ftype-bits) ftype-bits-dispatch-table]
|
|
[(ftype-base) ftype-pointer-dispatch-table]
|
|
[(ftype-function) ftype-function-dispatch-table]
|
|
[else empty-dispatch-table])))
|
|
|
|
(define inspector-read
|
|
(lambda (ip)
|
|
(let* ([ip (console-input-port)] [c (read-char ip)])
|
|
(cond
|
|
[(eof-object? c)
|
|
(newline (console-output-port))
|
|
'("quit")]
|
|
[(char=? c #\newline)
|
|
(set-port-bol! (console-output-port) #t)
|
|
'()]
|
|
[(char-whitespace? c)
|
|
(inspector-read ip)]
|
|
[else
|
|
(unread-char c ip)
|
|
(let ([first (inspector-read-command ip)])
|
|
(cons first (inspector-read-tail ip)))]))))
|
|
|
|
(define inspector-read-command
|
|
(lambda (ip)
|
|
(let ([p (open-output-string)])
|
|
(let read-letters ()
|
|
(let ([c (peek-char ip)])
|
|
(if (and (char? c)
|
|
(not (char-numeric? c))
|
|
(not (char-whitespace? c)))
|
|
(begin (read-char ip)
|
|
(write-char c p)
|
|
(read-letters))
|
|
(get-output-string p)))))))
|
|
|
|
(define inspector-read-tail
|
|
(lambda (ip)
|
|
(let ([c (peek-char ip)])
|
|
(cond
|
|
[(char=? c #\newline)
|
|
(read-char ip)
|
|
(set-port-bol! (console-output-port) #t)
|
|
'()]
|
|
[(or (char-whitespace? c) ; [(
|
|
(memv c '(#\) #\])))
|
|
(read-char ip)
|
|
(inspector-read-tail ip)]
|
|
[else
|
|
(let ([x (read ip)])
|
|
(cons x (inspector-read-tail ip)))]))))
|
|
|
|
(define dispatch
|
|
(lambda (c t)
|
|
(let ([handler (or (search-dispatch-table (car c) t)
|
|
(search-dispatch-table (car c)
|
|
generic-dispatch-table))])
|
|
(if handler
|
|
(apply handler (cdr c))
|
|
(invalid-command)))))
|
|
|
|
(define search-dispatch-table
|
|
(lambda (s t)
|
|
(and (not (null? t))
|
|
(let ([first (car t)])
|
|
(let ([key (car first)])
|
|
(if (if (string? key)
|
|
(string=? key s)
|
|
(or (string=? (car key) s)
|
|
(string=? (cdr key) s)))
|
|
(caddr first)
|
|
(search-dispatch-table s (cdr t))))))))
|
|
|
|
(define spaces
|
|
(lambda (n)
|
|
(if (> n 0)
|
|
(make-string n #\space)
|
|
"")))
|
|
|
|
(define write-to-string
|
|
(lambda (x)
|
|
(let ([p (open-output-string)])
|
|
(x 'write p)
|
|
(get-output-string p))))
|
|
|
|
(define short-form-rec
|
|
(lambda (x limit)
|
|
(let try ([low 1]
|
|
[high #f]
|
|
[r (parameterize ([print-level 0] [print-length 0])
|
|
(write-to-string x))])
|
|
(let ([mid (+ low (if high (quotient (- high low) 2) low))])
|
|
(if (= mid low)
|
|
r
|
|
(let ([s (parameterize ([print-level mid] [print-length mid])
|
|
(write-to-string x))])
|
|
(cond
|
|
[(string=? s r) s]
|
|
[(> (string-length s) limit) (try low mid r)]
|
|
[else (try mid high s)])))))))
|
|
|
|
(define short-form-lambda
|
|
; x looks like "(lambda vars body)"
|
|
; print the "lambda" and all of the vars that fit
|
|
(lambda (x limit)
|
|
(let ([first (format "(lambda ~a " ;)
|
|
(short-form-rec ((x 'cdr) 'car) (- limit 14)))])
|
|
(let ([rest (short-form-rec ((x 'cdr) 'cdr)
|
|
(- limit (string-length first)))])
|
|
(if (and (> (string-length rest) 0)
|
|
(char=? (string-ref rest 0) #\()) ;)
|
|
(string-append first (substring rest 1 (string-length rest)))
|
|
(short-form-rec x limit))))))
|
|
|
|
(define short-form
|
|
(lambda (x limit)
|
|
(case (x 'type)
|
|
[(pair)
|
|
(if (and (eq? ((x 'car) 'type) 'symbol)
|
|
(eq? ((x 'car) 'value) 'lambda)
|
|
(eq? ((x 'cdr) 'type) 'pair)
|
|
(eq? (((x 'cdr) 'cdr) 'type) 'pair))
|
|
(short-form-lambda x limit)
|
|
(short-form-rec x limit))]
|
|
[(string)
|
|
(let ([s (format "~s"
|
|
; avoid passing format the whole of a large string
|
|
(let ([s (x 'value)])
|
|
(if (<= (string-length s) limit)
|
|
s
|
|
(substring s 0 limit))))])
|
|
(if (<= (string-length s) limit)
|
|
s
|
|
(string-append
|
|
(substring s 0 (max (- limit 4) 1))
|
|
"...\"")))]
|
|
[else (short-form-rec x limit)])))
|
|
|
|
(define form
|
|
(lambda (x used limit)
|
|
(short-form x (- limit used))))
|
|
|
|
(define inspector-prompt
|
|
(lambda ()
|
|
(let ([obj (form (object) 0 prompt-line-limit)])
|
|
(fprintf (console-output-port)
|
|
"~a~a : "
|
|
obj
|
|
(spaces (- prompt-line-limit (string-length obj)))))))
|
|
|
|
(define outer-reset-handler ($make-thread-parameter values))
|
|
|
|
(define inspector
|
|
(lambda (last-command)
|
|
(inspector
|
|
(let ([saved-state current-state])
|
|
(parameterize ([reset-handler (call/cc
|
|
(lambda (k)
|
|
(rec f
|
|
(lambda ()
|
|
(clear-output-port (console-output-port))
|
|
(set! current-state saved-state)
|
|
(k f)))))])
|
|
(let ([ip (console-input-port)])
|
|
(clear-input-port ip)
|
|
(inspector-prompt)
|
|
(let ([cmd (let ([cmd (inspector-read ip)])
|
|
(cond
|
|
[(null? cmd)
|
|
(if (equal? (car last-command) "list")
|
|
'("list")
|
|
last-command)]
|
|
[(number? (car cmd)) (cons "ref" cmd)]
|
|
[else cmd]))])
|
|
(cond
|
|
[(equal? cmd '("?"))
|
|
(let ([t (select-dispatch-table)])
|
|
(if (null? t)
|
|
(display-options generic-dispatch-table #t)
|
|
(display-options t #f)))]
|
|
[(equal? cmd '("??"))
|
|
(display-options generic-dispatch-table #t)]
|
|
[else
|
|
(guard (c [#t (let ([op (console-output-port)])
|
|
(fresh-line op)
|
|
(display-condition c op)
|
|
(newline op)
|
|
(set! current-state saved-state))])
|
|
(dispatch cmd (select-dispatch-table)))])
|
|
cmd)))))))
|
|
|
|
(define-syntax inspector-print
|
|
(syntax-rules ()
|
|
[(_ e)
|
|
(call-with-values (lambda () e)
|
|
(case-lambda
|
|
[(x) (unless (eq? x (void)) (pretty-print x (console-output-port)))]
|
|
[args (for-each (lambda (x) (pretty-print x (console-output-port))) args)]))]))
|
|
|
|
(module (inspector-find inspector-find-next)
|
|
(define down-path
|
|
(lambda (path)
|
|
(assert (and (list? path) (>= (length path) 1)))
|
|
(let f ([path path])
|
|
(let ([x (car path)] [path (cdr path)])
|
|
(if (null? path)
|
|
(assert (eq? x ((object) 'value)))
|
|
(begin
|
|
(f path)
|
|
(down ((object) 'make-me-a-child x) #f)))))))
|
|
(define inspector-find
|
|
(lambda (pred gen)
|
|
(state-find-next-set! current-state (make-object-finder pred ((object) 'value) gen))
|
|
(let ([path ((state-find-next current-state))])
|
|
(unless path (inspect-error "Not found"))
|
|
(down-path path))))
|
|
(define inspector-find-next
|
|
(lambda ()
|
|
(let loop ([state current-state])
|
|
(cond
|
|
[(not state) (inspect-error "No current find.")]
|
|
[(state-find-next state) =>
|
|
(lambda (find-next)
|
|
(let ([path (find-next)])
|
|
(unless path (inspect-error "Not found"))
|
|
(set! current-state state)
|
|
(down-path path)))]
|
|
[else (loop (state-link state))])))))
|
|
|
|
(define generic-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("print" . "p")
|
|
"pretty-print object"
|
|
(()
|
|
(newline (console-output-port))
|
|
((object) 'print (console-output-port))
|
|
(newline (console-output-port)))]
|
|
|
|
[("write" . "w")
|
|
"write object"
|
|
(()
|
|
(newline (console-output-port))
|
|
((object) 'write (console-output-port))
|
|
(newline (console-output-port))
|
|
(newline (console-output-port)))]
|
|
|
|
["size"
|
|
"recursively compute storage occupied by object"
|
|
(() (fprintf (console-output-port) "~s\n" ((object) 'size (collect-maximum-generation))))
|
|
((g)
|
|
(require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)))
|
|
(fprintf (console-output-port) "~s\n" ((object) 'size g)))]
|
|
|
|
["find"
|
|
"find within object, given a predicate"
|
|
(()
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(let ([x (eval x)])
|
|
(unless (procedure? x) (inspect-error "~s is not a procedure" x))
|
|
(inspector-find x (collect-maximum-generation))))))
|
|
((x)
|
|
(let ([x (eval x)])
|
|
(unless (procedure? x) (inspect-error "~s is not a procedure" x))
|
|
(inspector-find x (collect-maximum-generation))))
|
|
((x g)
|
|
(require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)))
|
|
(let ([x (eval x)])
|
|
(unless (procedure? x) (inspect-error "~s is not a procedure" x))
|
|
(inspector-find x g)))]
|
|
|
|
["find-next"
|
|
"repeat find"
|
|
(()
|
|
(inspector-find-next))]
|
|
|
|
[("up" . "u")
|
|
"return to [nth] previous level"
|
|
(() (up))
|
|
((n)
|
|
(range-check n)
|
|
(let backup ([n n])
|
|
(unless (= n 0)
|
|
(up)
|
|
(backup (- n 1)))))]
|
|
|
|
[("top" . "t")
|
|
"return to initial object"
|
|
(()
|
|
(let top ()
|
|
(let ([next (state-link current-state)])
|
|
(when next
|
|
(set! current-state next)
|
|
(top)))))]
|
|
|
|
[("forward" . "f")
|
|
"move to [nth] next expression"
|
|
(() (move 1))
|
|
((n)
|
|
(range-check n)
|
|
(move n))]
|
|
|
|
[("back" . "b")
|
|
"move to [nth] previous expression"
|
|
(() (move -1))
|
|
((n)
|
|
(range-check n)
|
|
(move (- n)))]
|
|
|
|
["=>"
|
|
"send object to procedure"
|
|
(()
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(let ([x (eval x)])
|
|
(unless (procedure? x) (inspect-error "~s is not a procedure" x))
|
|
(inspector-print (x ((object) 'value)))))))
|
|
((x)
|
|
(let ([x (eval x)])
|
|
(unless (procedure? x) (inspect-error "~s is not a procedure" x))
|
|
(inspector-print (x ((object) 'value)))))]
|
|
|
|
["file"
|
|
"switch to named source file"
|
|
((path)
|
|
(unless (or (string? path) (symbol? path))
|
|
(inspect-error "invalid path ~s" path))
|
|
(open-source-file (if (symbol? path) (symbol->string path) path)))]
|
|
|
|
["list"
|
|
"list the current source file [line [count]]"
|
|
(() (list-source-file))
|
|
((n) (list-source-file n))
|
|
((n m) (list-source-file n m))]
|
|
|
|
["files"
|
|
"show open files"
|
|
(()
|
|
(for-each
|
|
(lambda (sf) (show "~a" (sfile-path sf)))
|
|
source-files))]
|
|
|
|
[("mark" . "m")
|
|
"mark location [with symbolic mark]"
|
|
(() (put-mark default-mark))
|
|
((m) (put-mark (make-mark m)))]
|
|
|
|
[("goto" . "g")
|
|
"go to marked location [mark]"
|
|
(() (to-mark default-mark))
|
|
((m) (to-mark (make-mark m)))]
|
|
|
|
[("new-cafe" . "n")
|
|
"enter a new cafe"
|
|
(()
|
|
(newline (console-output-port))
|
|
(new-cafe)
|
|
(newline (console-output-port)))]
|
|
|
|
[("quit" . "q")
|
|
"exit inspector"
|
|
(()
|
|
(newline (console-output-port))
|
|
(exit))]
|
|
|
|
[("reset" . "r")
|
|
"reset scheme"
|
|
(()
|
|
(newline (console-output-port))
|
|
((outer-reset-handler)))]
|
|
|
|
[("abort" . "a")
|
|
"abort scheme [with exit code n]"
|
|
(()
|
|
(newline (console-output-port))
|
|
(abort))
|
|
((x)
|
|
(newline (console-output-port))
|
|
(abort x))]
|
|
|
|
[("help" . "h")
|
|
"help"
|
|
(()
|
|
(show "
|
|
An overview of the current object is displayed as part of each
|
|
prompt. There are commands for displaying more of an object or
|
|
inspecting its components. \"?\" displays type-specific command
|
|
options and \"??\" displays command options that are always
|
|
available. Some commands take parameters, which are entered
|
|
following the command on the same line. An empty command line
|
|
repeats the previous command. To perform more complex actions,
|
|
enter the command \"n\", which creates a new top level with access
|
|
to the usual Scheme environment. The inspector is resumed upon
|
|
exit from the new top level. Enter \"quit\" (or end-of-file) to
|
|
exit from the inspector.
|
|
"))]
|
|
|
|
))
|
|
|
|
(define empty-dispatch-table (make-dispatch-table))
|
|
|
|
(define pair-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("length" . "l")
|
|
"display list length"
|
|
(()
|
|
(apply (lambda (type len)
|
|
(case type
|
|
[(proper) (show " proper list, length ~d" len)]
|
|
[(improper) (show " improper list, length ~d" len)]
|
|
[(circular) (show " circular list, length ~d" len)]))
|
|
((object) 'length)))]
|
|
|
|
["car"
|
|
"inspect car of pair"
|
|
(() (ref-list 0))]
|
|
|
|
["cdr"
|
|
"inspect cdr of pair"
|
|
(() (down ((object) 'cdr) #f))]
|
|
|
|
[("ref" . "r")
|
|
"inspect [nth] car"
|
|
(() (ref-list 0))
|
|
((n) (ref-list n))]
|
|
|
|
["tail"
|
|
"inspect [nth] cdr"
|
|
(() (down ((object) 'cdr) #f))
|
|
((n)
|
|
(range-check n)
|
|
(let tail ([i n])
|
|
(unless (= i 0)
|
|
(unless (type? 'pair (object)) (invalid-movement))
|
|
(down ((object) 'cdr) #f)
|
|
(tail (- i 1)))))]
|
|
|
|
[("show" . "s")
|
|
"show [n] elements of list"
|
|
(() (display-list (cadr ((object) 'length))))
|
|
((n)
|
|
(range-check n)
|
|
(display-list n))]
|
|
|
|
))
|
|
|
|
(define vector-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("length" . "l")
|
|
"display vector length"
|
|
(() (show " ~d elements" ((object) 'length)))]
|
|
|
|
[("ref" . "r")
|
|
"inspect [nth] element"
|
|
(() (ref 0))
|
|
((n) (ref n))]
|
|
|
|
[("show" . "s")
|
|
"show [n] elements"
|
|
(() (display-refs ((object) 'length)))
|
|
((n)
|
|
(range-check n ((object) 'length))
|
|
(display-refs n))]
|
|
|
|
))
|
|
|
|
(define fxvector-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("length" . "l")
|
|
"display fxvector length"
|
|
(() (show " ~d elements" ((object) 'length)))]
|
|
|
|
[("ref" . "r")
|
|
"inspect [nth] element"
|
|
(() (ref 0))
|
|
((n) (ref n))]
|
|
|
|
[("show" . "s")
|
|
"show [n] elements"
|
|
(() (display-refs ((object) 'length)))
|
|
((n)
|
|
(range-check n ((object) 'length))
|
|
(display-refs n))]
|
|
|
|
))
|
|
|
|
(define bytevector-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("length" . "l")
|
|
"display bytevector length"
|
|
(() (show " ~d elements" ((object) 'length)))]
|
|
|
|
[("ref" . "r")
|
|
"inspect [nth] element"
|
|
(() (ref 0))
|
|
((n) (ref n))]
|
|
|
|
[("show" . "s")
|
|
"show [n] elements"
|
|
(() (display-refs ((object) 'length)))
|
|
((n)
|
|
(range-check n ((object) 'length))
|
|
(display-refs n))]
|
|
|
|
))
|
|
|
|
(define ftype-struct-dispatch-table
|
|
(make-dispatch-table
|
|
["fields"
|
|
"inspect fields"
|
|
(() (down ((object) 'fields) #f))]
|
|
|
|
[("ref" . "r")
|
|
"inspect named or nth element"
|
|
(() (down ((object) 'ref 0) 0))
|
|
((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
|
|
|
|
["set!"
|
|
"set named element, if assignable"
|
|
((f)
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(let ((x (eval x)))
|
|
((object) 'set! f x)))))
|
|
((f v) ((object) 'set! f (eval v)))]
|
|
|
|
["ftype"
|
|
"inspect the ftype"
|
|
(() (down ((object) 'ftype) #f))]
|
|
|
|
[("show" . "s")
|
|
"show contents of struct"
|
|
(()
|
|
(let ([fields (((object) 'fields) 'value)])
|
|
(if (null? fields)
|
|
(show "*** struct has no fields ***")
|
|
(for-each
|
|
(lambda (f i)
|
|
(name-label-line-display
|
|
((object) 'ref i)
|
|
f
|
|
i))
|
|
fields
|
|
(iota (length fields))))))]))
|
|
|
|
(define ftype-union-dispatch-table
|
|
(make-dispatch-table
|
|
["fields"
|
|
"inspect fields"
|
|
(() (down ((object) 'fields) #f))]
|
|
|
|
[("ref" . "r")
|
|
"inspect named or nth element"
|
|
(() (down ((object) 'ref 0) 0))
|
|
((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
|
|
|
|
["set!"
|
|
"set named element, if assignable"
|
|
((f)
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(let ((x (eval x)))
|
|
((object) 'set! f x)))))
|
|
((f v) ((object) 'set! f (eval v)))]
|
|
|
|
["ftype"
|
|
"inspect the ftype"
|
|
(() (down ((object) 'ftype) #f))]
|
|
|
|
[("show" . "s")
|
|
"show contents of union"
|
|
(()
|
|
(let ([fields (((object) 'fields) 'value)])
|
|
(if (null? fields)
|
|
(show "*** union has no fields ***")
|
|
(for-each
|
|
(lambda (f i)
|
|
(name-label-line-display
|
|
((object) 'ref i)
|
|
f
|
|
i))
|
|
fields
|
|
(iota (length fields))))))]))
|
|
|
|
(define ftype-array-dispatch-table
|
|
(make-dispatch-table
|
|
[("length" . "l")
|
|
"display array length"
|
|
(() (show " ~d elements" ((object) 'length)))]
|
|
|
|
[("ref" . "r")
|
|
"inspect [nth] element"
|
|
(() (ref 0))
|
|
((n) (ref n))]
|
|
|
|
["set!"
|
|
"set [nth] element, if assignable"
|
|
((f)
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(let ((x (eval x)))
|
|
((object) 'set! f x)))))
|
|
((f v) ((object) 'set! f (eval v)))]
|
|
|
|
["ftype"
|
|
"inspect the ftype"
|
|
(() (down ((object) 'ftype) #f))]
|
|
|
|
[("show" . "s")
|
|
"show [n] elements"
|
|
(() (display-refs ((object) 'length)))
|
|
((n)
|
|
(range-check n ((object) 'length))
|
|
(display-refs n))]
|
|
))
|
|
|
|
(define ftype-pointer-dispatch-table
|
|
(make-dispatch-table
|
|
[("ref" . "r")
|
|
"inspect target of pointer"
|
|
(() (down ((object) 'ref) #f))
|
|
((n)
|
|
(unless (memv n '(* 0)) (invalid-movement))
|
|
(down ((object) 'ref) #f))]
|
|
|
|
["set!"
|
|
"set target of pointer, if assignable"
|
|
(()
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(let ((x (eval x)))
|
|
((object) 'set! x)))))
|
|
((v) ((object) 'set! (eval v)))]
|
|
|
|
["ftype"
|
|
"inspect ftype of target"
|
|
(() (down ((object) 'ftype) #f))]
|
|
|
|
[("show" . "s")
|
|
"show the target"
|
|
(() (label-line-display ((object) 'ref) 0))]
|
|
))
|
|
|
|
(define ftype-function-dispatch-table
|
|
(make-dispatch-table
|
|
["name"
|
|
"inspect foreign-function name"
|
|
(() (down ((object) 'name) #f))]
|
|
|
|
["address"
|
|
"inspect foreign-function address"
|
|
(() (down ((object) 'address) #f))]
|
|
|
|
["ftype"
|
|
"inspect ftype of target"
|
|
(() (down ((object) 'ftype) #f))]
|
|
|
|
[("show" . "s")
|
|
"show the target"
|
|
(() (label-line-display ((object) 'name) 0)
|
|
(label-line-display ((object) 'address) 1))]
|
|
))
|
|
|
|
(define ftype-bits-dispatch-table
|
|
(make-dispatch-table
|
|
["fields"
|
|
"inspect fields"
|
|
(() (down ((object) 'fields) #f))]
|
|
|
|
[("ref" . "r")
|
|
"inspect named or nth element"
|
|
(() (down ((object) 'ref 0) 0))
|
|
((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
|
|
|
|
["set!"
|
|
"set named element, if assignable"
|
|
((f)
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(let ((x (eval x)))
|
|
((object) 'set! f x)))))
|
|
((f v) ((object) 'set! f (eval v)))]
|
|
|
|
["ftype"
|
|
"inspect the ftype"
|
|
(() (down ((object) 'ftype) #f))]
|
|
|
|
[("show" . "s")
|
|
"show bit fields"
|
|
(()
|
|
(let ([fields (((object) 'fields) 'value)])
|
|
(if (null? fields)
|
|
(show "*** no fields ***")
|
|
(for-each
|
|
(lambda (f i)
|
|
(name-label-line-display
|
|
((object) 'ref i)
|
|
f
|
|
i))
|
|
fields
|
|
(iota (length fields))))))]))
|
|
|
|
(define record-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
["fields"
|
|
"inspect fields"
|
|
(() (down ((object) 'fields) #f))]
|
|
|
|
["name"
|
|
"inspect record name"
|
|
(() (down ((object) 'name) #f))]
|
|
|
|
["rtd"
|
|
"inspect record-type descriptor"
|
|
(() (down ((object) 'rtd) #f))]
|
|
|
|
[("ref" . "r")
|
|
"inspect named or nth element"
|
|
((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
|
|
|
|
["set!"
|
|
"set named element, if assignable"
|
|
((f)
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(let ((x (eval x)))
|
|
((object) 'set! f x)))))
|
|
((f v) ((object) 'set! f (eval v)))]
|
|
|
|
[("show" . "s")
|
|
"show contents of record"
|
|
(()
|
|
(when (and (eq? (subset-mode) 'system)
|
|
(record-type-opaque? (((object) 'rtd) 'value)))
|
|
(show "*** inspecting opaque record ***"))
|
|
(let ([fields (((object) 'fields) 'value)])
|
|
(if (null? fields)
|
|
(show "*** record has no fields ***")
|
|
(for-each
|
|
(lambda (f i)
|
|
(name-label-line-display
|
|
(if ((object) 'accessible? i)
|
|
((object) 'ref i)
|
|
(inspect/object "*** inaccessible ***"))
|
|
f
|
|
i))
|
|
fields
|
|
(iota (length fields))))))]
|
|
))
|
|
|
|
|
|
(define string-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("length" . "l")
|
|
"display string length"
|
|
(() (show " ~d characters" ((object) 'length)))]
|
|
|
|
[("ref" . "r")
|
|
"inspect [nth] character"
|
|
(() (ref 0))
|
|
((n) (ref n))]
|
|
|
|
[("show" . "s")
|
|
"show [n] characters"
|
|
(() (display-chars ((object) 'length) charschemecode 5))
|
|
((n)
|
|
(range-check n ((object) 'length))
|
|
(display-chars n charschemecode 5))]
|
|
|
|
["unicode"
|
|
"display [n] characters as hexadecimal unicode codes"
|
|
(() (display-chars ((object) 'length) unicodehexcode 8))
|
|
((n)
|
|
(range-check n ((object) 'length))
|
|
(display-chars n unicodehexcode 8))]
|
|
|
|
["ascii"
|
|
"display [n] characters as hexadecimal ascii codes"
|
|
(() (display-chars ((object) 'length) asciihexcode 16))
|
|
((n)
|
|
(range-check n ((object) 'length))
|
|
(display-chars n asciihexcode 16))]
|
|
))
|
|
|
|
(define char-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
["unicode"
|
|
"display character as hexadecimal ascii code"
|
|
(() (show " U+~x" (unicodehexcode ((object) 'value))))]
|
|
|
|
["ascii"
|
|
"display character as hexadecimal ascii code"
|
|
(() (show " ~x" (asciihexcode ((object) 'value))))]
|
|
|
|
))
|
|
|
|
(define box-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
["unbox"
|
|
"inspect contents of box"
|
|
(() (down ((object) 'unbox) #f))]
|
|
|
|
[("ref" . "r")
|
|
"inspect contents of box"
|
|
(() (down ((object) 'unbox) #f))]
|
|
|
|
[("show" . "s")
|
|
"show contents of box"
|
|
(() (label-line-display ((object) 'unbox) 0))
|
|
((n)
|
|
(range-check n 0)
|
|
(label-line-display ((object) 'unbox) 0))]
|
|
))
|
|
|
|
|
|
(define system-symbol-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("ref" . "r")
|
|
"inspect value field [n] of symbol"
|
|
(()
|
|
(down ((object) 'top-level-value) 0))
|
|
((n)
|
|
(range-check n 5)
|
|
(down ((object)
|
|
(case n
|
|
[(0) 'top-level-value]
|
|
[(1) '$top-level-value]
|
|
[(2) 'name]
|
|
[(3) 'property-list]
|
|
[(4) 'system-property-list]
|
|
[(5) 'symbol-hash]))
|
|
n))]
|
|
|
|
[("value" . "v")
|
|
"inspect top-level-value of symbol"
|
|
(() (down ((object) 'top-level-value) 0))]
|
|
|
|
[("value-slot" . "vs")
|
|
"inspect value slot of symbol"
|
|
(() (down ((object) '$top-level-value) 0))]
|
|
|
|
[("name" . "n")
|
|
"inspect name of symbol"
|
|
(() (down ((object) 'name) 1))]
|
|
|
|
[("property-list" . "pl")
|
|
"inspect property-list of symbol"
|
|
(() (down ((object) 'property-list) 2))]
|
|
|
|
[("system-property-list" . "spl")
|
|
"inspect system property-list of symbol"
|
|
(() (down ((object) 'system-property-list) 4))]
|
|
|
|
[("symbol-hash" . "sh")
|
|
"inspect hash code"
|
|
(() (down ((object) 'symbol-hash) 5))]
|
|
|
|
[("show" . "s")
|
|
"show fields of symbol"
|
|
(()
|
|
(name-label-line-display ((object) 'top-level-value) "top-level value" 0)
|
|
(name-label-line-display ((object) '$top-level-value) "value slot" 1)
|
|
(name-label-line-display ((object) 'name) "name" 2)
|
|
(name-label-line-display ((object) 'property-list) "properties" 3)
|
|
(name-label-line-display ((object) 'system-property-list) "system properties" 4)
|
|
(name-label-line-display ((object) 'symbol-hash) "hash code" 5))]
|
|
))
|
|
|
|
(define symbol-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("ref" . "r")
|
|
"inspect value field [n] of symbol"
|
|
(()
|
|
(down ((object) 'top-level-value) 0))
|
|
((n)
|
|
(range-check n 2)
|
|
(down ((object)
|
|
(case n
|
|
[(0) 'top-level-value]
|
|
[(1) 'name]
|
|
[(2) 'property-list]))
|
|
n))]
|
|
|
|
[("value" . "v")
|
|
"inspect top-level-value of symbol"
|
|
(() (down ((object) 'top-level-value) 0))]
|
|
|
|
[("name" . "n")
|
|
"inspect name of symbol"
|
|
(() (down ((object) 'name) 1))]
|
|
|
|
[("property-list" . "pl")
|
|
"inspect property-list of symbol"
|
|
(() (down ((object) 'property-list) 2))]
|
|
|
|
[("show" . "s")
|
|
"show fields of symbol"
|
|
(()
|
|
(name-label-line-display ((object) 'top-level-value) "top level value" 0)
|
|
(name-label-line-display ((object) 'name) "name" 1)
|
|
(name-label-line-display ((object) 'property-list) "properties" 2))]
|
|
))
|
|
|
|
(define procedure-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("length" . "l")
|
|
"display number of free variables"
|
|
(() (show " ~d free variables" ((object) 'length)))]
|
|
|
|
[("ref" . "r")
|
|
"inspect [nth] free variable"
|
|
(() (ref 0))
|
|
((x) (variable-ref x))]
|
|
|
|
[("set!" . "!")
|
|
"set [nth or named] free variable to value, if assignable"
|
|
(()
|
|
(let ([e (waiter-read)])
|
|
(unless (eof-object? e)
|
|
(set 0 ((object) 'eval e)))))
|
|
((x)
|
|
(let ([e (waiter-read)])
|
|
(unless (eof-object? e)
|
|
(variable-set x ((object) 'eval e)))))
|
|
((x e) (variable-set x ((object) 'eval e)))]
|
|
|
|
[("eval" . "e")
|
|
"evaluate expression in context of procedure environment"
|
|
(()
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(inspector-print ((object) 'eval x)))))
|
|
((x)
|
|
(inspector-print ((object) 'eval x)))]
|
|
|
|
[("show" . "s")
|
|
"show code and free variables"
|
|
(()
|
|
(let ([source (((object) 'code) 'source)])
|
|
(when source (name-line-display source "code")))
|
|
(when (> ((object) 'length) 0)
|
|
(show "~afree variables:" line-indent)
|
|
(display-variable-refs ((object) 'length))))]
|
|
|
|
[("code" . "c")
|
|
"inspect the code for the procedure"
|
|
(()
|
|
(let ([source (((object) 'code) 'source)])
|
|
(if source
|
|
(down source #f)
|
|
(show "source code not available"))))]
|
|
|
|
["file"
|
|
"switch to source file containing the procedure"
|
|
(() (open-recorded-source-file ((object) 'code)))
|
|
((path)
|
|
(unless (or (string? path) (symbol? path))
|
|
(inspect-error "invalid path ~s" path))
|
|
(open-source-file (if (symbol? path) (symbol->string path) path)))]
|
|
))
|
|
|
|
(define code-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("length" . "l")
|
|
"display number of free variables"
|
|
(() (show " ~d free variables" ((object) 'free-count)))]
|
|
|
|
[("show" . "s")
|
|
"show code"
|
|
(()
|
|
(let ([source ((object) 'source)])
|
|
(when source (name-line-display source "code"))))]
|
|
|
|
[("code" . "c")
|
|
"inspect the code"
|
|
(()
|
|
(let ([source ((object) 'source)])
|
|
(if source
|
|
(down source #f)
|
|
(show "source code not available"))))]
|
|
|
|
["file"
|
|
"switch to source file containing the procedure"
|
|
(() (open-recorded-source-file (object)))
|
|
((path)
|
|
(unless (or (string? path) (symbol? path))
|
|
(inspect-error "invalid path ~s" path))
|
|
(open-source-file (if (symbol? path) (symbol->string path) path)))]
|
|
))
|
|
|
|
|
|
(define continuation-dispatch-table
|
|
(let ()
|
|
(define reposition
|
|
(lambda (incr)
|
|
(let ([old-pos ((object) 'pos)])
|
|
(unless (fx= old-pos 0) (up))
|
|
(let ([pos (fx+ old-pos incr)])
|
|
(when (fx>= pos ((object) 'depth)) (invalid-movement))
|
|
(if (fx> pos 0)
|
|
(let ((link ((object) 'reposition pos)))
|
|
(unless (type? 'continuation link) (invalid-movement))
|
|
(down link #f))
|
|
(unless (fx= pos 0) (invalid-movement)))))))
|
|
|
|
(define continuation-show
|
|
(lambda (free?)
|
|
(name-line-display ((object) 'link) "continuation")
|
|
(let ([source (((object) 'code) 'source)])
|
|
(when source (name-line-display source "procedure code")))
|
|
(let ([source ((object) 'source)])
|
|
(when source (name-line-display source "call code")))
|
|
(let ([cp ((object) 'closure)])
|
|
(when cp (name-line-display cp "closure")))
|
|
(let ([len ((object) (if free? 'length 'frame-length))])
|
|
(when (> len 0)
|
|
(show "~a~a:" line-indent (if free? "frame and free variables" "frame variables"))
|
|
(display-variable-refs len)))))
|
|
|
|
(make-dispatch-table
|
|
|
|
[("length" . "l")
|
|
"display number of frame and closure variables"
|
|
(() (show " ~d variables" ((object) 'length)))]
|
|
|
|
["depth"
|
|
"display number of frames in continuation stack"
|
|
(() (let ((d ((object) 'depth)))
|
|
(show (if (= d 1) " ~d frame" " ~d frames") d)))]
|
|
|
|
[("ref" . "r")
|
|
"inspect [named or nth] variable"
|
|
(() (ref 0))
|
|
((x) (variable-ref x))]
|
|
|
|
[("set!" . "!")
|
|
"set [named or nth] variable to value, if assignable"
|
|
(()
|
|
(let ([e (waiter-read)])
|
|
(unless (eof-object? e)
|
|
(set 0 ((object) 'eval e)))))
|
|
((x)
|
|
(let ([e (waiter-read)])
|
|
(unless (eof-object? e)
|
|
(variable-set x ((object) 'eval e)))))
|
|
((x e) (variable-set x ((object) 'eval e)))]
|
|
|
|
[("forward" . "f")
|
|
"move to [nth] next frame"
|
|
(() (reposition 1))
|
|
((pos)
|
|
(range-check pos)
|
|
(reposition pos))]
|
|
|
|
[("back" . "b")
|
|
"move to [nth] previous frame"
|
|
(() (reposition -1))
|
|
((pos)
|
|
(range-check pos)
|
|
(reposition (fx- pos)))]
|
|
|
|
[("down" . "d")
|
|
"inspect [nth] next frame"
|
|
(() (let ((link ((object) 'link)))
|
|
(unless (type? 'continuation link) (invalid-movement))
|
|
(down link #f)))
|
|
((n)
|
|
(range-check n (- ((object) 'depth) 1))
|
|
(let ((link ((object) 'link* n)))
|
|
(unless (type? 'continuation link) (invalid-movement))
|
|
(down link #f)))]
|
|
|
|
[("closure" . "cp")
|
|
"inspect the frame's closure, if any"
|
|
(() (let ([cp ((object) 'closure)])
|
|
(unless cp (inspect-error "this frame has no closure"))
|
|
(down cp #f)))]
|
|
|
|
[("eval" . "e")
|
|
"evaluate expression in context of current frame"
|
|
(()
|
|
(let ([x (waiter-read)])
|
|
(unless (eof-object? x)
|
|
(inspector-print ((object) 'eval x)))))
|
|
((x)
|
|
(inspector-print ((object) 'eval x)))]
|
|
|
|
[("show" . "s")
|
|
"show frame with free variables"
|
|
(() (continuation-show #t))]
|
|
|
|
[("show-local" . "sl")
|
|
"show frame without free variables"
|
|
(() (continuation-show #f))]
|
|
|
|
[("show-frames" . "sf")
|
|
"show the next [n] frames"
|
|
(() (display-links (most-positive-fixnum)))
|
|
((n)
|
|
(range-check n)
|
|
(display-links n))]
|
|
|
|
["call"
|
|
"inspect the code for the pending call"
|
|
(()
|
|
(let ([source ((object) 'source)])
|
|
(if source
|
|
(down source #f)
|
|
(show "source code not available"))))]
|
|
|
|
[("code" . "c")
|
|
"inspect the code for the pending procedure"
|
|
(()
|
|
(let ([source (((object) 'code) 'source)])
|
|
(if source
|
|
(down source #f)
|
|
(show "source code not available"))))]
|
|
|
|
["file"
|
|
"switch to source file containing the pending call"
|
|
(() (open-recorded-source-file (object)))
|
|
((path)
|
|
(unless (or (string? path) (symbol? path))
|
|
(inspect-error "invalid path ~s" path))
|
|
(open-source-file (if (symbol? path) (symbol->string path) path)))]
|
|
|
|
)))
|
|
|
|
(define port-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
[("show" . "s")
|
|
"show port contents"
|
|
(()
|
|
(name-line-display ((object) 'name) "name")
|
|
(name-line-display ((object) 'handler) "handler")
|
|
(when ((object) 'input?)
|
|
(show "~ainput size: ~s" line-indent ((object) 'input-size))
|
|
(show "~ainput index: ~s" line-indent ((object) 'input-index)))
|
|
(when ((object) 'output?)
|
|
(show "~aoutput size: ~s" line-indent ((object) 'output-size))
|
|
(show "~aoutput index: ~s" line-indent ((object) 'output-index))))]
|
|
|
|
["name"
|
|
"inspect port name"
|
|
(() (down ((object) 'name) #f))]
|
|
|
|
["handler"
|
|
"inspect port handler"
|
|
(() (down ((object) 'handler) #f))]
|
|
|
|
[("output-buffer" . "ob")
|
|
"inspect output buffer"
|
|
(() (if ((object) 'output?)
|
|
(down ((object) 'output-buffer) #f)
|
|
(show "not an output port")))]
|
|
|
|
[("input-buffer" . "ib")
|
|
"inspect input buffer"
|
|
(() (if ((object) 'input?)
|
|
(down ((object) 'input-buffer) #f)
|
|
(show "not an input port")))]
|
|
))
|
|
|
|
(define tlc-dispatch-table
|
|
(make-dispatch-table
|
|
|
|
["keyval"
|
|
"inspect keyval field"
|
|
(() (down ((object) 'keyval) #f))]
|
|
|
|
["ht"
|
|
"inspect ht field"
|
|
(() (down ((object) 'ht) #f))]
|
|
|
|
["next"
|
|
"inspect next field"
|
|
(() (down ((object) 'next) #f))]
|
|
|
|
[("ref" . "r")
|
|
"inspect named field"
|
|
((x)
|
|
(down ((object)
|
|
(case x
|
|
[(keyval) 'keyval]
|
|
[(ht) 'ht]
|
|
[(next) 'next]
|
|
[else (invalid-command)]))
|
|
x))]
|
|
|
|
[("show" . "s")
|
|
"show fields of tlc"
|
|
(()
|
|
(name-line-display ((object) 'keyval) "keyval")
|
|
(name-line-display ((object) 'ht) "ht")
|
|
(name-line-display ((object) 'next) "next"))]
|
|
))
|
|
|
|
(set! inspect
|
|
(lambda (x)
|
|
(let ([t (set-timer 0)])
|
|
(call/cc
|
|
(lambda (k)
|
|
(fluid-let ([current-state (make-state (inspect/object x))]
|
|
[marks (make-eq-hashtable)]
|
|
[source-files '()])
|
|
(parameterize ([outer-reset-handler (reset-handler)]
|
|
[exit-handler k]
|
|
[$interrupt reset])
|
|
(put-mark default-mark)
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (inspector '("?")))
|
|
(lambda () (for-each close-source-file source-files)))))))
|
|
(set-timer t))
|
|
(void)))
|
|
|
|
)
|
|
|
|
(define inspect/object
|
|
(lambda (x)
|
|
(define compute-size
|
|
(let ([size-ht #f])
|
|
(lambda (x g)
|
|
(unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))
|
|
($oops 'inspector-object "invalid generation ~s" g))
|
|
; using a common size-ht for a single inspect/object call means:
|
|
; (inspect (let ([x (list 1 2)]) (set-car! x x) (set-car! (cdr x) x) (set-cdr! (cdr x) x) x))
|
|
; size => 16
|
|
; cdr, size => 8
|
|
; might be what we want, might not be
|
|
(unless size-ht (set! size-ht (make-eq-hashtable)))
|
|
($compute-size x (if (eq? g 'static) (constant static-generation) g) size-ht))))
|
|
|
|
(define-syntax make-object-maker
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ object-name inits [method args e1 e2 ...] ...)
|
|
(andmap identifier? #'(object-name method ...))
|
|
#'(lambda inits
|
|
(let ([method (lambda args e1 e2 ...)] ...)
|
|
(lambda (m . rest)
|
|
(case m
|
|
[(type) 'object-name]
|
|
[(make-me-a-child) (make-object (car rest))]
|
|
[(method) (#2%apply method rest)]
|
|
...
|
|
[else ($oops 'inspector-object
|
|
"invalid message ~s to object type ~s"
|
|
m
|
|
'object-name)]))))])))
|
|
|
|
(define frame-eval
|
|
(lambda (vars expr)
|
|
(define frame-name
|
|
(let ((ls '(%0 %1 %2 %3 %4 %5 %6 %7)))
|
|
(let ((n (length ls)))
|
|
(lambda (i)
|
|
(if (< i n)
|
|
(list-ref ls i)
|
|
(string->symbol (format "%~d" i)))))))
|
|
(define ->nongensym
|
|
(lambda (name)
|
|
(if (gensym? name)
|
|
(string->symbol (symbol->string name))
|
|
name)))
|
|
(let ((n (vector-length vars)))
|
|
(eval (let f ((i 0))
|
|
(if (= i n)
|
|
expr
|
|
(let ([var (vector-ref vars i)]
|
|
[body (f (+ i 1))])
|
|
(let ([raw-val (var 'raw-value)]
|
|
[name (var 'name)]
|
|
[fv (frame-name i)]
|
|
[t (gensym)])
|
|
`(let ([,t (quote ,raw-val)])
|
|
(let-syntax ([,fv ,(if (assignable? raw-val)
|
|
`(identifier-syntax [id (car ,t)] [(set! id e) (set-car! ,t e)])
|
|
`(identifier-syntax
|
|
[id ,t]
|
|
[(set! id e)
|
|
(syntax-error #'id "cannot set non-assigned variable")]))])
|
|
,(if name `(begin (alias ,(->nongensym name) ,fv) ,body) body)))))))))))
|
|
|
|
(define make-pair-object
|
|
(make-object-maker pair (x)
|
|
[value () x]
|
|
[car () (make-object (car x))]
|
|
[cdr () (make-object (cdr x))]
|
|
[length ()
|
|
(let ([ht (make-eq-hashtable)])
|
|
(let length ([x x] [n 0])
|
|
(cond
|
|
[(null? x) `(proper ,n)]
|
|
[(not (pair? x)) `(improper ,n)]
|
|
[else
|
|
(let ([a (eq-hashtable-cell ht x #f)])
|
|
(if (cdr a)
|
|
`(circular ,n)
|
|
(begin (set-cdr! a #t)
|
|
(length (cdr x) (+ n 1)))))])))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-box-object
|
|
(make-object-maker box (x)
|
|
[value () x]
|
|
[unbox () (make-object (unbox x))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-tlc-object
|
|
(make-object-maker tlc (x)
|
|
[value () x]
|
|
[keyval () (make-object ($tlc-keyval x))]
|
|
[ht () (make-object ($tlc-ht x))]
|
|
[next () (make-object ($tlc-next x))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-vector-object
|
|
(make-object-maker vector (x)
|
|
[value () x]
|
|
[length () (vector-length x)]
|
|
[ref (i)
|
|
(unless (and (fixnum? i) (fx< -1 i (vector-length x)))
|
|
($oops 'vector-object "invalid index ~s" i))
|
|
(make-object (vector-ref x i))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-fxvector-object
|
|
(make-object-maker fxvector (x)
|
|
[value () x]
|
|
[length () (fxvector-length x)]
|
|
[ref (i)
|
|
(unless (and (fixnum? i) (fx< -1 i (fxvector-length x)))
|
|
($oops 'fxvector-object "invalid index ~s" i))
|
|
(make-object (fxvector-ref x i))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-bytevector-object
|
|
(make-object-maker bytevector (x)
|
|
[value () x]
|
|
[length () (bytevector-length x)]
|
|
[ref (i)
|
|
(unless (and (fixnum? i) (fx< -1 i (bytevector-length x)))
|
|
($oops 'bytevector-object "invalid index ~s" i))
|
|
(make-object (bytevector-u8-ref x i))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-ftype-pointer-object
|
|
(lambda (x)
|
|
(define (unrecognized-ux ux)
|
|
($oops 'ftype-pointer-object "unrecognized ftype-pointer type ~s" x))
|
|
(define (invalid-field-specifier f)
|
|
($oops 'ftype-pointer-object "invalid field specifier ~s" f))
|
|
(define (invalid-index f)
|
|
($oops 'ftype-pointer-object "invalid index ~s" f))
|
|
(define (get-field f field*)
|
|
(cond
|
|
[(assq f field*) => cdr]
|
|
[(and (fixnum? f) (#%$fxu< f (length field*)))
|
|
(cdr (list-ref field* f))]
|
|
[else (invalid-field-specifier f)]))
|
|
(define (deref x)
|
|
(let ([ux ($unwrap-ftype-pointer x)])
|
|
(record-case ux
|
|
[(struct union array * bits) ignore (make-object x)]
|
|
[(base) (type getter setter) (make-object (getter))]
|
|
[else (unrecognized-ux ux)])))
|
|
(define (deset! who x v)
|
|
(let ([ux ($unwrap-ftype-pointer x)])
|
|
(record-case ux
|
|
[(struct union array bits) ignore ($oops who "cannot assign struct, union, or array")]
|
|
[(*) (get-fptr set-fptr!) (set-fptr! who v)]
|
|
[(base) (type getter setter) (setter v)]
|
|
[else (unrecognized-ux ux)])))
|
|
(let ([ux ($unwrap-ftype-pointer x)])
|
|
(record-case ux
|
|
[(struct) field*
|
|
((make-object-maker ftype-struct (x)
|
|
[value () x]
|
|
[ftype () (make-object (ftype-pointer-ftype x))]
|
|
[fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
|
|
[length () (length field*)]
|
|
[ref (f) (deref (get-field f field*))]
|
|
[set! (f v) (deset! 'ftype-struct-object (get-field f field*) v)]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write `(ftype struct ...) p)]
|
|
[print (p) (pretty-print (ftype-pointer->sexpr x) p)])
|
|
x)]
|
|
[(union) field*
|
|
((make-object-maker ftype-union (x)
|
|
[value () x]
|
|
[ftype () (make-object (ftype-pointer-ftype x))]
|
|
[fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
|
|
[length () (length field*)]
|
|
[ref (f) (deref (get-field f field*))]
|
|
[set! (f v) (deset! 'ftype-union-object (get-field f field*) v)]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write `(ftype union ...) p)]
|
|
[print (p) (pretty-print (ftype-pointer->sexpr x) p)])
|
|
x)]
|
|
[(array) (n get-fptr)
|
|
((make-object-maker ftype-array (x)
|
|
[value () x]
|
|
[ftype () (make-object (ftype-pointer-ftype x))]
|
|
[length () n]
|
|
[ref (f)
|
|
(unless (and (integer? f) (exact? f) (#%$fxu< f n))
|
|
(invalid-index f))
|
|
(deref (get-fptr f))]
|
|
[set! (f v)
|
|
(unless (and (integer? f) (exact? f) (#%$fxu< f n))
|
|
(invalid-index f))
|
|
(deset! 'ftype-array-object (get-fptr f) v)]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write `(ftype array ...) p)]
|
|
[print (p) (pretty-print (ftype-pointer->sexpr x) p)])
|
|
x)]
|
|
[(*) (get-fptr set-fptr!)
|
|
((make-object-maker ftype-* (x)
|
|
[value () x]
|
|
[ftype () (make-object (ftype-pointer-ftype x))]
|
|
[ref () (deref (get-fptr))]
|
|
[set! (v) (deset! 'ftype-*-object (get-fptr) v)]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write `(ftype * ...) p)]
|
|
[print (p) (pretty-print (ftype-pointer->sexpr x) p)])
|
|
x)]
|
|
[(bits) field*
|
|
((make-object-maker ftype-bits (x)
|
|
[value () x]
|
|
[ftype () (make-object (ftype-pointer-ftype x))]
|
|
[fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
|
|
[length () (length field*)]
|
|
[ref (f) (apply (lambda (getter setter) (make-object (getter)))
|
|
(get-field f field*))]
|
|
[set! (f v) (apply (lambda (getter setter) (make-object (setter v)))
|
|
(get-field f field*))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write `(ftype bits ...) p)]
|
|
[print (p) (pretty-print (ftype-pointer->sexpr x) p)])
|
|
x)]
|
|
[(base) (type getter setter)
|
|
((make-object-maker ftype-base (x)
|
|
[value () x]
|
|
[ftype () (make-object (ftype-pointer-ftype x))]
|
|
[ref () (make-object (getter))]
|
|
[set! (v) (setter v)]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write `(ftype ,type ...) p)]
|
|
[print (p) (pretty-print (ftype-pointer->sexpr x) p)])
|
|
x)]
|
|
[(function) (name)
|
|
((make-object-maker ftype-function (x)
|
|
[value () x]
|
|
[ftype () (make-object (ftype-pointer-ftype x))]
|
|
[address () (make-object (ftype-pointer-address x))]
|
|
[name () (make-object name)]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write `(ftype function ...) p)]
|
|
[print (p) (pretty-print (ftype-pointer->sexpr x) p)])
|
|
x)]
|
|
[else (unrecognized-ux ux)]))))
|
|
|
|
(define make-record-object
|
|
(lambda (x)
|
|
(let* ((rtd ($record-type-descriptor x))
|
|
(fields (csv7:record-type-field-names rtd)))
|
|
(define check-field
|
|
(lambda (f)
|
|
(unless (or (and (symbol? f) (memq f fields))
|
|
(and (fixnum? f) (fx>= f 0) (fx< f (length fields))))
|
|
($oops 'record-object "invalid field specifier ~s" f))))
|
|
((make-object-maker record (x)
|
|
[value () x]
|
|
[length () (length fields)]
|
|
[fields () (make-object fields)]
|
|
[accessible? (f)
|
|
(check-field f)
|
|
(csv7:record-field-accessible? rtd f)]
|
|
[mutable? (f)
|
|
(check-field f)
|
|
(csv7:record-field-mutable? rtd f)]
|
|
[name () (make-object (csv7:record-type-name rtd))]
|
|
[rtd () (make-object rtd)]
|
|
[ref (f)
|
|
(check-field f)
|
|
(unless (csv7:record-field-accessible? rtd f)
|
|
($oops 'record-object "field ~s is inaccessible" f))
|
|
(make-object ((csv7:record-field-accessor rtd f) x))]
|
|
[set! (f v)
|
|
(check-field f)
|
|
(unless (csv7:record-field-mutable? rtd f)
|
|
($oops 'record-object "field ~s is immutable" f))
|
|
((csv7:record-field-mutator rtd f) x v)]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)])
|
|
x))))
|
|
|
|
(define make-string-object
|
|
(make-object-maker string (x)
|
|
[value () x]
|
|
[length () (string-length x)]
|
|
[ref (i)
|
|
(unless (and (fixnum? i) (< -1 i (string-length x)))
|
|
($oops 'string-object "invalid index ~s" i))
|
|
(make-object (string-ref x i))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-simple-object
|
|
(make-object-maker simple (x)
|
|
[value () x]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-unbound-object
|
|
(make-object-maker unbound (x)
|
|
[value () x]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-procedure-object
|
|
(lambda (x)
|
|
(real-make-procedure-object x (list->vector (make-procedure-vars x)))))
|
|
|
|
(define real-make-procedure-object
|
|
(make-object-maker procedure (x vars)
|
|
[value () x]
|
|
[length () (vector-length vars)]
|
|
[ref (i)
|
|
(unless (and (fixnum? i) (fx< -1 i (vector-length vars)))
|
|
($oops 'procedure-object "invalid index ~s" i))
|
|
(vector-ref vars i)]
|
|
[eval (x) (frame-eval vars x)]
|
|
[code () (make-object ($closure-code x))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-procedure-vars
|
|
(lambda (x)
|
|
(include "types.ss")
|
|
(let ([code ($closure-code x)])
|
|
(let ([info ($code-info code)]
|
|
[len ($code-free-count code)])
|
|
(let ([free (and (code-info? info) (code-info-free info))])
|
|
(unless (or (not free) (fx= (vector-length free) len))
|
|
($oops 'inspector "invalid info structure ~s" info))
|
|
(let vars ([i 0])
|
|
(if (= i len)
|
|
'()
|
|
(cons (make-variable-object
|
|
($closure-ref x i)
|
|
(and free (vector-ref free i)))
|
|
(vars (+ i 1))))))))))
|
|
|
|
(define assignable?
|
|
(lambda (raw-val)
|
|
(and (pair? raw-val) ($unbound-object? (cdr raw-val)))))
|
|
|
|
(define make-variable-object
|
|
(make-object-maker variable (x name)
|
|
[name () name]
|
|
[assignable? () (assignable? x)]
|
|
[raw-value () x]
|
|
[ref () (make-object
|
|
(if (assignable? x)
|
|
(car x)
|
|
x))]
|
|
[set! (v) (make-object
|
|
(if (assignable? x)
|
|
(set-car! x v)
|
|
($oops 'variable-object "unassignable variable")))]
|
|
[size (g)
|
|
(if (assignable? x)
|
|
(fx+ (constant size-pair) (compute-size (car x) g))
|
|
(compute-size x g))]
|
|
[write (p) (display "#<variable>" p)]
|
|
[print (p) (display "#<variable>" p) (newline p)]))
|
|
|
|
(define get-reloc-objs
|
|
(foreign-procedure "(cs)s_get_reloc"
|
|
(scheme-object) scheme-object))
|
|
|
|
(module (get-code-src get-code-sexpr)
|
|
(include "types.ss")
|
|
(define get-code-src
|
|
(lambda (x)
|
|
(let ([info ($code-info x)])
|
|
(and (code-info? info) (code-info-src info)))))
|
|
(define get-code-sexpr
|
|
(lambda (x)
|
|
(let ([info ($code-info x)])
|
|
(and (code-info? info) (code-info-sexpr info))))))
|
|
|
|
(define make-code-object
|
|
(make-object-maker code (x)
|
|
[value () x]
|
|
[name () ($code-name x)]
|
|
[info () (make-object ($code-info x))]
|
|
[free-count () ($code-free-count x)]
|
|
[source ()
|
|
(cond
|
|
[(get-code-sexpr x) => make-object]
|
|
[else #f])]
|
|
[source-path () (return-source (get-code-src x))]
|
|
[source-object () (get-code-src x)]
|
|
[reloc () (make-object (get-reloc-objs x))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define return-source
|
|
(lambda (src)
|
|
(include "types.ss")
|
|
(if src
|
|
(call-with-values
|
|
(lambda () ((current-locate-source-object-source) src #t #f))
|
|
(case-lambda
|
|
[() (let ([sfd (source-sfd src)] [fp (source-bfp src)])
|
|
(values (source-file-descriptor-name sfd) fp))]
|
|
[(path line char) (values path line char)]))
|
|
(values))))
|
|
|
|
(define-who make-continuation-object
|
|
(lambda (x pos)
|
|
(include "types.ss")
|
|
(define find-rpi
|
|
(lambda (offset rpis)
|
|
(let f ([start 0] [end (fx1- (vector-length rpis))])
|
|
(if (fx< end start)
|
|
#f
|
|
(let* ([curr (fx+ (fx/ (fx- end start) 2) start)]
|
|
[rpi (vector-ref rpis curr)]
|
|
[rpi-offset (rp-info-offset rpi)])
|
|
(cond
|
|
[(fx= offset rpi-offset) rpi]
|
|
[(fx< offset rpi-offset) (f start (fx1- curr))]
|
|
[else (f (fx1+ curr) end)]))))))
|
|
($split-continuation x 0)
|
|
(let ([info ($code-info ($continuation-return-code x))]
|
|
[offset ($continuation-return-offset x)]
|
|
[len ($continuation-stack-length x)]
|
|
[lpm ($continuation-return-livemask x)])
|
|
(cond
|
|
[(and (code-info? info) (code-info-rpis info) (find-rpi offset (code-info-rpis info))) =>
|
|
(lambda (rpi)
|
|
(let ([cookie '(chocolate . chip)])
|
|
(let ([vals (make-vector len cookie)] [vars (make-vector len '())] [live (code-info-live info)])
|
|
; fill vals based on live-pointer mask
|
|
(let f ([i 1] [lpm lpm])
|
|
(unless (>= i len)
|
|
(when (odd? lpm)
|
|
(vector-set! vals (fx1- i) ($continuation-stack-ref x i)))
|
|
(f (fx1+ i) (ash lpm -1))))
|
|
; fill vars based on code-info variable mask
|
|
(let f ([i 0] [mask (rp-info-mask rpi)])
|
|
(unless (eqv? mask 0)
|
|
(when (odd? mask)
|
|
(let ([p (vector-ref live i)])
|
|
(let ([index (fx1- (cdr p))])
|
|
(vector-set! vars index (cons (car p) (vector-ref vars index))))))
|
|
(f (+ i 1) (ash mask -1))))
|
|
; create return vector
|
|
(with-values
|
|
(let f ([i 0] [count 0] [cp #f] [cpvar* '()])
|
|
(if (fx= i len)
|
|
(if cp
|
|
(let ([v (let f ([count count] [cpvar* cpvar*])
|
|
(if (null? cpvar*)
|
|
(make-vector count)
|
|
(let ([v (f (fx+ count 1) (cdr cpvar*))])
|
|
(vector-set! v count (car cpvar*))
|
|
v)))])
|
|
(values v count cp))
|
|
(values (make-vector count) count cp))
|
|
(let ([obj (vector-ref vals i)] [var* (vector-ref vars i)])
|
|
(cond
|
|
[(eq? obj cookie)
|
|
(unless (null? var*) ($oops who "expected value for ~s but it was not in lpm" (car var*)))
|
|
(f (fx1+ i) count cp cpvar*)]
|
|
[(null? var*)
|
|
(let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)])
|
|
(vector-set! v count (make-variable-object obj #f))
|
|
(values v frame-count cp))]
|
|
[else
|
|
(let g ([var* var*] [count count] [cp cp] [cpvar* cpvar*])
|
|
(if (null? var*)
|
|
(f (fx1+ i) count cp cpvar*)
|
|
(let ([var (car var*)])
|
|
(if (eq? var cpsymbol)
|
|
(g (cdr var*) count obj (if (procedure? obj) (make-procedure-vars obj) '()))
|
|
(cond
|
|
[(pair? var) ; closure environment represented as a pair
|
|
(unless (pair? obj)
|
|
($oops who "expected pair value for paired environment, not ~s" obj))
|
|
(g (cdr var*) count obj (list
|
|
(make-variable-object (car obj) (car var))
|
|
(make-variable-object (cdr obj) (cdr var))))]
|
|
[(vector? var) ; closure environment represented as a vector
|
|
(unless (vector? obj)
|
|
($oops who "expected vector value for vector environment, not ~s" obj))
|
|
(g (cdr var*) count obj (map (lambda (obj var) (make-variable-object obj var))
|
|
(vector->list obj)
|
|
(vector->list var)))]
|
|
[else
|
|
(let-values ([(v frame-count cp) (g (cdr var*) (fx1+ count) cp cpvar*)])
|
|
(vector-set! v count (make-variable-object obj var))
|
|
(values v frame-count cp))])))))]))))
|
|
(lambda (v frame-count cp)
|
|
(real-make-continuation-object x (rp-info-src rpi) (rp-info-sexpr rpi) cp v frame-count pos))))))]
|
|
[else
|
|
(let ([v (list->vector
|
|
(let f ([i 1] [lpm lpm])
|
|
(cond
|
|
[(>= i len) '()]
|
|
[(odd? lpm)
|
|
(cons (make-variable-object ($continuation-stack-ref x i) #f)
|
|
(f (fx1+ i) (ash lpm -1)))]
|
|
[else (f (fx1+ i) (ash lpm -1))])))])
|
|
(real-make-continuation-object x #f #f #f v (vector-length v) pos))]))))
|
|
|
|
(define real-make-continuation-object
|
|
(let ((continuation-depth
|
|
(foreign-procedure "(cs)continuation_depth" (scheme-object)
|
|
iptr)))
|
|
(make-object-maker continuation (x src sexpr cp vars frame-count pos)
|
|
[value () x]
|
|
[length () (vector-length vars)]
|
|
[closure () (and cp (make-object cp))]
|
|
[frame-length () frame-count]
|
|
[depth () (continuation-depth x)]
|
|
[ref (i)
|
|
(unless (and (fixnum? i) (fx< -1 i (vector-length vars)))
|
|
($oops 'continuation-object "invalid index ~s" i))
|
|
(vector-ref vars i)]
|
|
[pos () pos]
|
|
[reposition (pos)
|
|
(let ((k (and (fixnum? pos) (fx> pos 0) ($split-continuation x pos))))
|
|
(unless k ($oops 'continuation-object "invalid position ~s" pos))
|
|
(make-continuation-object k pos))]
|
|
[link () (make-object ($continuation-link x))]
|
|
[link* (i)
|
|
(let ((k (and (fixnum? i) (fx>= i 0) ($split-continuation x i))))
|
|
(unless k ($oops 'continuation-object "invalid link* depth ~s" i))
|
|
(make-object k))]
|
|
[eval (x) (frame-eval vars x)]
|
|
[code () (make-object ($continuation-return-code x))]
|
|
[source () (and sexpr (make-object sexpr))]
|
|
[source-object () src]
|
|
[source-path () (return-source src)]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)])))
|
|
|
|
(define make-port-object
|
|
(make-object-maker port (x)
|
|
[value () x]
|
|
[input? () (input-port? x)]
|
|
[output? () (output-port? x)]
|
|
[binary? () (binary-port? x)]
|
|
[closed? () (port-closed? x)]
|
|
[handler () (make-object ($port-handler x))]
|
|
[output-buffer () (and (output-port? x)
|
|
(make-object
|
|
(if (textual-port? x)
|
|
(textual-port-output-buffer x)
|
|
(binary-port-output-buffer x))))]
|
|
[output-size () (and (output-port? x)
|
|
(if (textual-port? x)
|
|
(textual-port-output-size x)
|
|
(binary-port-output-size x)))]
|
|
[output-index () (and (output-port? x)
|
|
(if (textual-port? x)
|
|
(textual-port-output-index x)
|
|
(binary-port-output-index x)))]
|
|
[input-buffer () (and (input-port? x)
|
|
(make-object
|
|
(if (textual-port? x)
|
|
(textual-port-input-buffer x)
|
|
(binary-port-input-buffer x))))]
|
|
[input-size () (and (input-port? x)
|
|
(if (textual-port? x)
|
|
(textual-port-input-size x)
|
|
(binary-port-input-size x)))]
|
|
[input-index () (and (input-port? x)
|
|
(if (textual-port? x)
|
|
(textual-port-input-index x)
|
|
(binary-port-input-index x)))]
|
|
[info () (make-object ($port-info x))]
|
|
[name () (make-object (port-name x))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-symbol-object
|
|
(make-object-maker symbol (x)
|
|
[value () x]
|
|
[gensym? () (gensym? x)]
|
|
[top-level-value ()
|
|
(if (top-level-bound? x)
|
|
(make-object (top-level-value x))
|
|
(make-object ($unbound-object)))]
|
|
[$top-level-value ()
|
|
(if ($top-level-bound? x)
|
|
(make-object ($top-level-value x))
|
|
(make-object ($unbound-object)))]
|
|
[system-property-list () (make-object ($system-property-list x))]
|
|
[symbol-hash () (make-object ($symbol-hash x))]
|
|
[name () (make-object (symbol->string x))]
|
|
[property-list () (make-object ($symbol-property-list x))]
|
|
[size (g) (compute-size x g)]
|
|
[write (p) (write x p)]
|
|
[print (p) (pretty-print x p)]))
|
|
|
|
(define make-object
|
|
(lambda (x)
|
|
(cond
|
|
[(pair? x) (make-pair-object x)]
|
|
[(symbol? x) (make-symbol-object x)]
|
|
[(vector? x) (make-vector-object x)]
|
|
[(fxvector? x) (make-fxvector-object x)]
|
|
[(bytevector? x) (make-bytevector-object x)]
|
|
; ftype-pointer? test must come before record? test
|
|
[($ftype-pointer? x) (make-ftype-pointer-object x)]
|
|
[(or (record? x) (and (eq? (subset-mode) 'system) ($record? x)))
|
|
(make-record-object x)]
|
|
[(string? x) (make-string-object x)]
|
|
[(box? x) (make-box-object x)]
|
|
[(procedure? x)
|
|
(if ($continuation? x)
|
|
(if (= ($continuation-stack-length x)
|
|
(constant unscaled-shot-1-shot-flag))
|
|
(make-simple-object x)
|
|
(make-continuation-object x 0))
|
|
(make-procedure-object x))]
|
|
[($code? x) (make-code-object x)]
|
|
[(port? x) (make-port-object x)]
|
|
[($unbound-object? x) (make-unbound-object x)]
|
|
[($tlc? x) (make-tlc-object x)]
|
|
[else (make-simple-object x)])))
|
|
|
|
(make-object x)))
|
|
|
|
(let ()
|
|
(define rtd-size (csv7:record-field-accessor #!base-rtd 'size))
|
|
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
|
|
(define $generation (foreign-procedure "(cs)generation" (ptr) ptr))
|
|
(define $get-code-obj (foreign-procedure "(cs)get_code_obj" (int ptr iptr iptr) ptr))
|
|
(define $code-reloc-size
|
|
(lambda (x)
|
|
(let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))])
|
|
(if (eqv? reloc-table 0)
|
|
0
|
|
($object-ref 'iptr reloc-table (constant reloc-table-size-disp))))))
|
|
(define $code-length
|
|
(lambda (x)
|
|
($object-ref 'iptr x (constant code-length-disp))))
|
|
(define $get-reloc
|
|
(lambda (x i)
|
|
(let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))])
|
|
(and (not (eqv? reloc-table 0))
|
|
($object-ref 'uptr reloc-table
|
|
(fx+ (constant reloc-table-data-disp)
|
|
(fx* i (constant ptr-bytes))))))))
|
|
(define-syntax tc-ptr-offsets
|
|
(lambda (x)
|
|
#`'#,(datum->syntax #'*
|
|
(fold-left
|
|
(lambda (ls fld)
|
|
(apply (lambda (name type disp len)
|
|
(if (eq? type 'ptr)
|
|
(if len
|
|
(do ([len len (fx- len 1)]
|
|
[disp disp (fx+ disp (constant ptr-bytes))]
|
|
[ls ls (cons disp ls)])
|
|
((fx= len 0) ls))
|
|
(cons disp ls))
|
|
ls))
|
|
fld))
|
|
'()
|
|
(or (getprop 'tc '*fields* #f) ($oops 'tc-ptr-offsets "missing fields for tc"))))))
|
|
(define align
|
|
(lambda (n)
|
|
(fxlogand (fx+ n (fx- (constant byte-alignment) 1)) (fx- (constant byte-alignment)))))
|
|
|
|
(set-who! $compute-size
|
|
(rec $compute-size
|
|
(case-lambda
|
|
[(x maxgen) ($compute-size x maxgen (make-eq-hashtable))]
|
|
[(x maxgen size-ht)
|
|
(define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size
|
|
(define compute-size
|
|
(lambda (x)
|
|
(if (or ($immediate? x)
|
|
(let ([g ($generation x)])
|
|
(or (not g) (fx> g maxgen))))
|
|
0
|
|
(let ([a (eq-hashtable-cell size-ht x #f)])
|
|
(cond
|
|
[(cdr a) =>
|
|
(lambda (p)
|
|
; if we find our cookie, return 0 to avoid counting shared structure twice.
|
|
; otherwise, (car p) must be a cookie from an earlier call to $compute-size,
|
|
; so return the recorded size
|
|
(if (eq? (car p) cookie)
|
|
0
|
|
(begin
|
|
(set-car! p cookie)
|
|
(cdr p))))]
|
|
[else
|
|
(let ([p (cons cookie 0)])
|
|
(set-cdr! a p)
|
|
(let ([size (really-compute-size x)])
|
|
(set-cdr! p size)
|
|
size))])))))
|
|
(define really-compute-size
|
|
(lambda (x)
|
|
(cond
|
|
[(pair? x) (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))]
|
|
[(symbol? x)
|
|
(fx+ (constant size-symbol)
|
|
(compute-size (#3%$top-level-value x))
|
|
(compute-size (property-list x))
|
|
(compute-size ($system-property-list x))
|
|
(compute-size ($symbol-name x)))]
|
|
[(vector? x)
|
|
(let ([n (vector-length x)])
|
|
(do ([i 0 (fx+ i 1)]
|
|
[size (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes))))
|
|
(fx+ size (compute-size (vector-ref x i)))])
|
|
((fx= i n) size)))]
|
|
[(fxvector? x) (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes))))]
|
|
[(bytevector? x) (align (fx+ (constant header-size-bytevector) (bytevector-length x)))]
|
|
[($record? x)
|
|
(let ([rtd ($record-type-descriptor x)])
|
|
(fold-left (lambda (size fld)
|
|
(if (eq? (fld-type fld) 'scheme-object)
|
|
(fx+ size (compute-size ($object-ref 'scheme-object x (fld-byte fld))))
|
|
size))
|
|
(fx+ (align (rtd-size rtd)) (compute-size rtd))
|
|
(rtd-flds rtd)))]
|
|
[(string? x) (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes))))]
|
|
[(box? x) (fx+ (constant size-box) (compute-size (unbox x)))]
|
|
[(flonum? x) (constant size-flonum)]
|
|
[(bignum? x) (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes))))]
|
|
[(ratnum? x) (fx+ (constant size-ratnum) (compute-size ($ratio-numerator x)) (compute-size ($ratio-denominator x)))]
|
|
[($exactnum? x) (fx+ (constant size-exactnum) (compute-size ($exactnum-real-part x)) (compute-size ($exactnum-imag-part x)))]
|
|
[($inexactnum? x) (constant size-inexactnum)]
|
|
[(procedure? x)
|
|
(if ($continuation? x)
|
|
(if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
|
|
(constant size-continuation)
|
|
(begin
|
|
; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
|
|
; NB: picture of the size prior to splitting. will add overhead to eventual invocation of
|
|
; NB: the continuation as well
|
|
($split-continuation x 0)
|
|
; not following RA slot at base of the frame, but this should always hold dounderflow,
|
|
; which will be in the static generation and therefore ignored anyway after compact heap
|
|
(let ([len ($continuation-stack-length x)])
|
|
(let loop ([i 1]
|
|
[lpm ($continuation-return-livemask x)]
|
|
[size (fx+ (constant size-continuation)
|
|
(align (fx* len (constant ptr-bytes)))
|
|
(compute-size ($continuation-return-code x))
|
|
(compute-size ($closure-code x))
|
|
(compute-size ($continuation-link x))
|
|
(compute-size ($continuation-winders x)))])
|
|
(if (fx>= i len)
|
|
size
|
|
(loop (fx+ i 1) (ash lpm -1) (if (odd? lpm) (fx+ size (compute-size ($continuation-stack-ref x i))) size)))))))
|
|
(let ([n ($closure-length x)])
|
|
(do ([i 0 (fx+ i 1)]
|
|
[size (fx+ (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes)))) (compute-size ($closure-code x)))
|
|
(fx+ size (compute-size ($closure-ref x i)))])
|
|
((fx= i n) size))))]
|
|
[($code? x)
|
|
(fx+ (align (fx+ (constant header-size-code) ($code-length x)))
|
|
(let ([n ($code-reloc-size x)])
|
|
(let loop ([i 0] [size (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes))))] [addr 0])
|
|
(if (fx= i n)
|
|
size
|
|
(let ([r ($get-reloc x i)])
|
|
(and r
|
|
(let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
|
|
(if (logtest r (constant reloc-extended-format))
|
|
(let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
|
|
(loop (fx+ i 3)
|
|
(fx+ size
|
|
(compute-size
|
|
($get-code-obj type x addr ($get-reloc x (fx+ i 1)))))
|
|
addr))
|
|
(let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
|
|
(loop (fx+ i 1)
|
|
(fx+ size
|
|
(compute-size
|
|
($get-code-obj type x addr
|
|
(logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask)))))
|
|
addr)))))))))
|
|
(compute-size ($code-name x))
|
|
(compute-size ($code-info x))
|
|
(compute-size ($code-pinfo* x)))]
|
|
[(port? x)
|
|
(fx+ (constant size-port)
|
|
(compute-size ($port-handler x))
|
|
(if (input-port? x) (compute-size (port-input-buffer x)) 0)
|
|
(if (output-port? x) (compute-size (port-output-buffer x)) 0)
|
|
(compute-size ($port-info x))
|
|
(compute-size (port-name x)))]
|
|
[(thread? x)
|
|
(let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))])
|
|
(fold-left
|
|
(lambda (size disp)
|
|
(fx+ size (compute-size ($object-ref 'scheme-object tc disp))))
|
|
(constant size-thread)
|
|
tc-ptr-offsets))]
|
|
[($tlc? x)
|
|
(fx+ (constant size-tlc)
|
|
(compute-size ($tlc-ht x))
|
|
(compute-size ($tlc-keyval x))
|
|
(compute-size ($tlc-next x)))]
|
|
[($rtd-counts? x) (constant size-rtd-counts)]
|
|
[else ($oops who "missing case for ~s" x)])))
|
|
; ensure size-ht isn't counted in the size of any object
|
|
(eq-hashtable-set! size-ht size-ht (cons cookie 0))
|
|
(compute-size x)])))
|
|
|
|
(set-who! $compute-composition
|
|
(lambda (x maxgen)
|
|
(define cookie (cons 'oatmeal 'raisin))
|
|
(define seen-ht (make-eq-hashtable))
|
|
(define rtd-ht (make-eq-hashtable))
|
|
(define-syntax define-counters
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ (name-vec count-vec incr!) type ...)
|
|
(with-syntax ([(i ...) (enumerate #'(type ...))])
|
|
#'(begin
|
|
(define name-vec (vector 'type ...))
|
|
(define count-vec (make-vector (length #'(type ...)) #f))
|
|
(define-syntax incr!
|
|
(syntax-rules (type ...)
|
|
[(_ type size)
|
|
(let ([p (vector-ref count-vec i)])
|
|
(if p
|
|
(begin
|
|
(set-car! p (fx+ (car p) 1))
|
|
(set-cdr! p (fx+ (cdr p) size)))
|
|
(vector-set! count-vec i (cons 1 size))))]
|
|
...))))])))
|
|
(define-counters (type-names type-counts incr!)
|
|
pair symbol vector fxvector bytevector string box flonum bignum ratnum exactnum
|
|
inexactnum continuation stack procedure code-object reloc-table port thread tlc
|
|
rtd-counts)
|
|
(define compute-composition!
|
|
(lambda (x)
|
|
(unless (or ($immediate? x)
|
|
(let ([g ($generation x)])
|
|
(or (not g) (fx> g maxgen))))
|
|
(let ([a (eq-hashtable-cell seen-ht x #f)])
|
|
(unless (cdr a)
|
|
(set-cdr! a #t)
|
|
(really-compute-composition! x))))))
|
|
(define really-compute-composition!
|
|
(lambda (x)
|
|
(cond
|
|
[(pair? x)
|
|
(incr! pair (constant size-pair))
|
|
(compute-composition! (car x))
|
|
(compute-composition! (cdr x))]
|
|
[(symbol? x)
|
|
(incr! symbol (constant size-symbol))
|
|
(compute-composition! (#3%$top-level-value x))
|
|
(compute-composition! (property-list x))
|
|
(compute-composition! ($system-property-list x))
|
|
(compute-composition! ($symbol-name x))]
|
|
[(vector? x)
|
|
(incr! vector (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes)))))
|
|
(vector-for-each compute-composition! x)]
|
|
[(fxvector? x) (incr! fxvector (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes)))))]
|
|
[(bytevector? x) (incr! bytevector (align (fx+ (constant header-size-bytevector) (bytevector-length x))))]
|
|
[($record? x)
|
|
(let ([rtd ($record-type-descriptor x)])
|
|
(let ([p (eq-hashtable-ref rtd-ht rtd #f)] [size (align (rtd-size rtd))])
|
|
(if p
|
|
(begin
|
|
(set-car! p (fx+ (car p) 1))
|
|
(set-cdr! p (fx+ (cdr p) size)))
|
|
(eq-hashtable-set! rtd-ht rtd (cons 1 size))))
|
|
(compute-composition! rtd)
|
|
(for-each (lambda (fld)
|
|
(when (eq? (fld-type fld) 'scheme-object)
|
|
(compute-composition! ($object-ref 'scheme-object x (fld-byte fld)))))
|
|
(rtd-flds rtd)))]
|
|
[(string? x) (incr! string (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes)))))]
|
|
[(box? x)
|
|
(incr! box (constant size-box))
|
|
(compute-composition! (unbox x))]
|
|
[(flonum? x) (incr! flonum (constant size-flonum))]
|
|
[(bignum? x) (incr! bignum (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes)))))]
|
|
[(ratnum? x)
|
|
(incr! ratnum (constant size-ratnum))
|
|
(compute-composition! ($ratio-numerator x))
|
|
(compute-composition! ($ratio-denominator x))]
|
|
[($exactnum? x)
|
|
(incr! exactnum (constant size-exactnum))
|
|
(compute-composition! ($exactnum-real-part x))
|
|
(compute-composition! ($exactnum-imag-part x))]
|
|
[($inexactnum? x) (incr! inexactnum (constant size-inexactnum))]
|
|
[(procedure? x)
|
|
(if ($continuation? x)
|
|
(begin
|
|
(incr! continuation (constant size-continuation))
|
|
(unless (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
|
|
; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
|
|
; NB: picture of the continuation counts & sizes prior to splitting. will add overhead to eventual invocation of
|
|
; NB: the continuation as well
|
|
($split-continuation x 0)
|
|
(compute-composition! ($continuation-return-code x))
|
|
(compute-composition! ($closure-code x))
|
|
(compute-composition! ($continuation-link x))
|
|
(compute-composition! ($continuation-winders x))
|
|
(let ([len ($continuation-stack-length x)])
|
|
(incr! stack (align (fx* len (constant ptr-bytes))))
|
|
(let loop ([i 1] [lpm ($continuation-return-livemask x)])
|
|
(unless (fx>= i len)
|
|
(when (odd? lpm) (compute-composition! ($continuation-stack-ref x i)))
|
|
(loop (fx+ i 1) (ash lpm -1)))))))
|
|
(begin
|
|
(compute-composition! ($closure-code x))
|
|
(let ([n ($closure-length x)])
|
|
(incr! procedure (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes)))))
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n))
|
|
(compute-composition! ($closure-ref x i))))))]
|
|
[($code? x)
|
|
(incr! code-object (align (fx+ (constant header-size-code) ($code-length x))))
|
|
(let ([n ($code-reloc-size x)])
|
|
(incr! reloc-table (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes)))))
|
|
(let loop ([i 0] [addr 0])
|
|
(unless (fx= i n)
|
|
(let ([r ($get-reloc x i)])
|
|
(and r
|
|
(let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
|
|
(if (logtest r (constant reloc-extended-format))
|
|
(let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
|
|
(compute-composition! ($get-code-obj type x addr ($get-reloc x (fx+ i 1))))
|
|
(loop (fx+ i 3) addr))
|
|
(let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
|
|
(compute-composition!
|
|
($get-code-obj type x addr
|
|
(logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask))))
|
|
(loop (fx+ i 1) addr)))))))))
|
|
(compute-composition! ($code-name x))
|
|
(compute-composition! ($code-info x))
|
|
(compute-composition! ($code-pinfo* x))]
|
|
[(port? x)
|
|
(incr! port (constant size-port))
|
|
(compute-composition! ($port-handler x))
|
|
(if (input-port? x) (compute-composition! (port-input-buffer x)) 0)
|
|
(if (output-port? x) (compute-composition! (port-output-buffer x)) 0)
|
|
(compute-composition! ($port-info x))
|
|
(compute-composition! (port-name x))]
|
|
[(thread? x)
|
|
(incr! thread (constant size-thread))
|
|
(let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))])
|
|
(for-each (lambda (disp) (compute-composition! ($object-ref 'scheme-object tc disp))) tc-ptr-offsets))]
|
|
[($tlc? x)
|
|
(incr! tlc (constant size-tlc))
|
|
(compute-composition! ($tlc-ht x))
|
|
(compute-composition! ($tlc-keyval x))
|
|
(compute-composition! ($tlc-next x))]
|
|
[($rtd-counts? x) (incr! rtd-counts (constant size-rtd-counts))]
|
|
[else ($oops who "missing case for ~s" x)])))
|
|
; ensure hashtables aren't counted
|
|
(eq-hashtable-set! seen-ht seen-ht #t)
|
|
(eq-hashtable-set! seen-ht rtd-ht #t)
|
|
(compute-composition! x)
|
|
(append
|
|
(filter cdr (vector->list (vector-map cons type-names type-counts)))
|
|
(vector->list
|
|
(let-values ([(keys vals) (hashtable-entries rtd-ht)])
|
|
(vector-map cons keys vals))))))
|
|
|
|
(set-who! $make-object-finder
|
|
; pred object maxgen => object-finder procedure that returns
|
|
; next object satisfying pred
|
|
; or #f, if no object found
|
|
(lambda (pred x maxgen)
|
|
(let ([seen-ht (make-eq-hashtable)])
|
|
(define saved-next-proc
|
|
(lambda ()
|
|
(find! x '() (lambda () #f))))
|
|
(define find!
|
|
(lambda (x path next-proc)
|
|
(let ([path (cons x path)])
|
|
(cond
|
|
[(or ($immediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen))))
|
|
(if (pred x)
|
|
(begin (set! saved-next-proc next-proc) path)
|
|
(next-proc))]
|
|
[else
|
|
(if (eq-hashtable-ref seen-ht x #f)
|
|
(next-proc) ; detected a loop, so backtrack and keep looking
|
|
(begin
|
|
(eq-hashtable-set! seen-ht x #t) ; mark this node as visited
|
|
(really-find! x path next-proc)))]))))
|
|
; We're visiting this node for the first time
|
|
(define really-find!
|
|
(lambda (x path next-proc)
|
|
(define-syntax construct-proc
|
|
(syntax-rules ()
|
|
[(_ ?next-proc) ?next-proc]
|
|
[(_ ?e ?e* ... ?next-proc)
|
|
(lambda () (find! ?e path (construct-proc ?e* ... ?next-proc)))]))
|
|
(let ([next-proc
|
|
(cond
|
|
[(pair? x) (construct-proc (car x) (cdr x) next-proc)]
|
|
[(symbol? x)
|
|
(construct-proc
|
|
(#3%$top-level-value x)
|
|
(property-list x)
|
|
($system-property-list x)
|
|
($symbol-name x) next-proc)]
|
|
[(vector? x)
|
|
(let ([n (vector-length x)])
|
|
(let f ([i 0])
|
|
(if (fx= i n)
|
|
next-proc
|
|
(construct-proc (vector-ref x i) (f (fx+ i 1))))))]
|
|
[($record? x)
|
|
(let ([rtd ($record-type-descriptor x)])
|
|
(construct-proc rtd
|
|
(let f ([flds (rtd-flds rtd)])
|
|
(if (null? flds)
|
|
next-proc
|
|
(let ([fld (car flds)])
|
|
(if (eq? (fld-type fld) 'scheme-object)
|
|
(construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds)))
|
|
(f (cdr flds))))))))]
|
|
[(or (fxvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x)
|
|
($inexactnum? x) ($rtd-counts? x))
|
|
next-proc]
|
|
[(box? x) (construct-proc (unbox x) next-proc)]
|
|
[(ratnum? x) (construct-proc ($ratio-numerator x) ($ratio-denominator x) next-proc)]
|
|
[($exactnum? x) (construct-proc ($exactnum-real-part x) ($exactnum-imag-part x) next-proc)]
|
|
[(procedure? x)
|
|
(if ($continuation? x)
|
|
(if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
|
|
next-proc
|
|
(begin
|
|
; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
|
|
; NB: picture of the size prior to splitting. will add overhead to eventual invocation of
|
|
; NB: the continuation as well
|
|
($split-continuation x 0)
|
|
; not following RA slot at base of the frame, but this should always hold dounderflow,
|
|
; which will be in the static generation and therefore ignored anyway after compact heap
|
|
(let ([len ($continuation-stack-length x)])
|
|
(let loop ([i 1] [lpm ($continuation-return-livemask x)])
|
|
(if (fx>= i len)
|
|
(construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x) ($continuation-winders x) next-proc)
|
|
(if (odd? lpm)
|
|
(construct-proc ($continuation-stack-ref x i) (loop (fx+ i 1) (ash lpm -1)))
|
|
(loop (fx+ i 1) (ash lpm -1))))))))
|
|
(construct-proc ($closure-code x)
|
|
(let ([n ($closure-length x)])
|
|
(let f ([i 0])
|
|
(if (fx= i n)
|
|
next-proc
|
|
(construct-proc ($closure-ref x i) (f (fx+ i 1))))))))]
|
|
[($code? x)
|
|
(construct-proc ($code-name x) ($code-info x) ($code-pinfo* x)
|
|
(let ([n ($code-reloc-size x)])
|
|
(let loop ([i 0] [addr 0])
|
|
(if (fx= i n)
|
|
next-proc
|
|
(let ([r ($get-reloc x i)])
|
|
(if (not r)
|
|
next-proc
|
|
(let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
|
|
(if (logtest r (constant reloc-extended-format))
|
|
(let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
|
|
(construct-proc ($get-code-obj type x addr ($get-reloc x (fx+ i 1)))
|
|
(loop (fx+ i 3) addr)))
|
|
(let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
|
|
(construct-proc
|
|
($get-code-obj type x addr
|
|
(logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask)))
|
|
(loop (fx+ i 1) addr)))))))))))]
|
|
[(port? x)
|
|
(construct-proc ($port-handler x) ($port-info x) (port-name x)
|
|
(let ([th (lambda () (if (output-port? x) (construct-proc (port-output-buffer x) next-proc) next-proc))])
|
|
(if (input-port? x) (construct-proc (port-input-buffer x) (th)) (th))))]
|
|
[(thread? x)
|
|
(let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))])
|
|
(let f ([disp-list tc-ptr-offsets])
|
|
(if (null? disp-list)
|
|
next-proc
|
|
(construct-proc ($object-ref 'scheme-object tc (car disp-list)) (f (cdr tc-ptr-offsets))))))]
|
|
[($tlc? x) (construct-proc ($tlc-ht x) ($tlc-keyval x) ($tlc-next x) next-proc)]
|
|
[else ($oops who "missing case for ~s" x)])])
|
|
; check if this node is what we're looking for
|
|
(if (pred x)
|
|
(begin (set! saved-next-proc next-proc) path)
|
|
(next-proc)))))
|
|
(rec find-next (lambda () (saved-next-proc)))))))
|
|
|
|
(let ()
|
|
(define filter-generation
|
|
(lambda (who g)
|
|
(unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))
|
|
($oops who "invalid generation ~s" g))
|
|
(if (eq? g 'static) (constant static-generation) g)))
|
|
|
|
(set-who! make-object-finder
|
|
(case-lambda
|
|
[(pred)
|
|
(unless (procedure? pred) ($oops who "~s is not a procedure" pred))
|
|
($make-object-finder pred (oblist) (collect-maximum-generation))]
|
|
[(pred x)
|
|
(unless (procedure? pred) ($oops who "~s is not a procedure" pred))
|
|
($make-object-finder pred x (collect-maximum-generation))]
|
|
[(pred x g)
|
|
(unless (procedure? pred) ($oops who "~s is not a procedure" pred))
|
|
($make-object-finder pred x (filter-generation who g))]))
|
|
|
|
(set-who! compute-size
|
|
(case-lambda
|
|
[(x) ($compute-size x (collect-maximum-generation))]
|
|
[(x g) ($compute-size x (filter-generation who g))]))
|
|
|
|
(set-who! compute-composition
|
|
(case-lambda
|
|
[(x) ($compute-composition x (collect-maximum-generation))]
|
|
[(x g) ($compute-composition x (filter-generation who g))])))
|
|
|
|
(define object-counts (foreign-procedure "(cs)object_counts" () ptr))
|
|
)
|