suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

move linklet bundle and directory to expander layer

Browse Source 
The Racket and RacketCS implementations had separate copies of
linklet-directory and linklet-bundle reading and writing. Move the
implementation into the expander layer.

The primitive '#%linklet instance now omits directory and bundle
operations and `read-compiled-linklet`. It intead must provide
`write-linklet-bundle-hash`, `read-linklet-bundle-hash`, and
`linklet-virtual-machine-bytes`.
This commit is contained in:
Matthew Flatt 2018-11-21 06:44:21 -07:00
parent 8cee5a09da
commit 6f6d121611
49 changed files with 2405 additions and 2189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.1.0.2")
(define version "7.1.0.4")
(define deps `("racket-lib"
["racket" #:version ,version]))

14
pkgs/racket-test-core/tests/racket/fasl.rktl
View File

@ -15,15 +15,18 @@
#hasheqv((24 . 25) (26 . 27))
#s(twenty-eight 29 30 "31")
-32
-275
3300
34000
350000
3600000
370000000
-370000001
38000000000
390000000000000
4000000000000000000
15511210043330985984000000
-15511210043330985984000000
41.0
4.2
43/100
@ -34,7 +37,7 @@
;; The fasl format is meant to be forward-compatible:
(define immutables-regression-bstr
#"racket/fasl:\0\200\35\1\34#n\4\3\6\ao\r2\16\5three\23\4four\25\4five\21\3six\"u \3vwx\36yz\35\2{|\16\afifteen%\1\2\16\bnineteen\200\16\asixteen\177%\0\2\202\23\ntwenty-one\204\23\ftwenty-three%\2\2\206\207\210\211#\16\ftwenty-eight\3\213\214\23\00231\b\340\b\200\344\f\b\201\320\204\0\0\b\2010W\5\0\b\201\200\3566\0\b\201\200\300\r\26\b\202\0\374\371\330\b\0\0\0\b\202\0`v\363\263b\1\0\b\202\0\0\220\235\316\332\2027\b\203\25cd4a0619fb0907bc00000\t\0\0\0\0\0\200D@\t\315\314\314\314\314\314\20@\v\231\322\f\232\322\f\t\0\0\0\0\0\200F@\t\0\0\0\0\0\0Y@\34\6\16\6srcloc\23\1xopqr")
#"racket/fasl:\0\200@\1\34&n\4\3\6\ao\r2\16\5three\23\4four\25\4five\21\3six\"u \3vwx\36yz\35\2{|\16\afifteen%\1\2\16\bnineteen\200\16\asixteen\177%\0\2\202\23\ntwenty-one\204\23\ftwenty-three%\2\2\206\207\210\211#\16\ftwenty-eight\3\213\214\23\00231\b\340\b\200\355\376\b\200\344\f\b\201\320\204\0\0\b\2010W\5\0\b\201\200\3566\0\b\201\200\300\r\26\b\201\177?\362\351\b\202\0\374\371\330\b\0\0\0\b\202\0`v\363\263b\1\0\b\202\0\0\220\235\316\332\2027\b\203\25cd4a0619fb0907bc00000\b\203\26-cd4a0619fb0907bc00000\t\0\0\0\0\0\200D@\t\315\314\314\314\314\314\20@\v\231\322\f\232\322\f\t\0\0\0\0\0\200F@\t\0\0\0\0\0\0Y@\34\6\16\6srcloc\23\1xopqr")
(for ([i (in-list immutables)])
(test i fasl->s-exp (s-exp->fasl i)))
@ -42,6 +45,8 @@
(test 46f0 fasl->s-exp (s-exp->fasl 46f0))
(test (vector #t 46f0) fasl->s-exp (s-exp->fasl (vector #t 46f0)))
(test "4.5t0" format "~a" (fasl->s-exp (s-exp->fasl 4.5t0)))
(test immutables fasl->s-exp (s-exp->fasl immutables))
(test (list immutables immutables) fasl->s-exp (s-exp->fasl (list immutables immutables)))
@ -58,7 +63,6 @@
(test #t eq? u (car s-exp))
(test #t eq? u (cadr s-exp)))
(let* ([u (string->uninterned-symbol "unread")])
(define vs-exp (vector-ref (fasl->s-exp (s-exp->fasl (vector (cons u u)))) 0))
;; these are not `eq?` to the original symbol, but are `eq? to each other
@ -66,6 +70,12 @@
(define hs-exp (hash-ref (fasl->s-exp (s-exp->fasl (hasheq 0 (cons u u)))) 0))
(test #t eq? (car hs-exp) (cdr hs-exp)))
(let ()
;; Check that a prefab struct key is not duplicated in fasled form
(define s (s-exp->fasl (list #s(look-for-this-prefab-key 1)
#s(look-for-this-prefab-key 2))))
(test #f regexp-match? #rx"look-for-this-prefab-key.*look-for-this-prefab-key" s))
;; check uses datum-intern-literal:
(test #t eq? "hello" (fasl->s-exp (s-exp->fasl "hello")))
(test #t eq? #"hello" (fasl->s-exp (s-exp->fasl #"hello")))

24
racket/collects/racket/fasl.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require (for-syntax racket/base)
(require '#%extfl
(for-syntax racket/base)
"private/truncate-path.rkt"
"private/relative-path.rkt"
(rename-in racket/base
@ -94,6 +95,8 @@
(fasl-srcloc 38)
(fasl-extflonum-type 39)
;; Unallocated numbers here are for future extensions
;; 100 to 255 is used for small integers:
@ -145,7 +148,10 @@
[(box? v)
(loop (unbox v))]
[(prefab-struct-key v)
(loop (struct->vector v))]
=> (lambda (k)
(loop k)
(for ([e (in-vector (struct->vector v) 1)])
(loop e)))]
[else (void)]))
(define (treat-immutable? v) (or (not keep-mutable?) (immutable? v)))
(define path->relative-path-elements (make-path->relative-path-elements))
@ -193,6 +199,11 @@
[(single-flonum? v)
(write-byte fasl-single-flonum-type o)
(write-bytes (real->floating-point-bytes v 4 #f) o)]
[(extflonum? v)
(write-byte fasl-extflonum-type o)
(define bstr (string->bytes/utf-8 (format "~a" v)))
(write-fasl-integer (bytes-length bstr) o)
(write-bytes bstr o)]
[(rational? v)
(write-byte fasl-rational-type o)
(loop (numerator v))
@ -374,6 +385,9 @@
[(fasl-integer-type) (intern (read-fasl-integer i))]
[(fasl-flonum-type) (floating-point-bytes->real (read-bytes/exactly 8 i) #f)]
[(fasl-single-flonum-type) (real->single-flonum (floating-point-bytes->real (read-bytes/exactly 4 i) #f))]
[(fasl-extflonum-type)
(define bstr (read-bytes/exactly (read-fasl-integer i) i))
(string->number (bytes->string/utf-8 bstr) 10 'read)]
[(fasl-rational-type) (intern (/ (loop) (loop)))]
[(fasl-complex-type) (intern (make-rectangular (loop) (loop)))]
[(fasl-char-type) (intern (integer->char (read-fasl-integer i)))]
@ -537,11 +551,11 @@
[(<= b 127) b]
[(>= b 132) (- b 256)]
[(eqv? b 128)
(integer-bytes->integer (read-bytes/exactly 2 i) #f #f)]
(integer-bytes->integer (read-bytes/exactly 2 i) #t #f)]
[(eqv? b 129)
(integer-bytes->integer (read-bytes/exactly 4 i) #f #f)]
(integer-bytes->integer (read-bytes/exactly 4 i) #t #f)]
[(eqv? b 130)
(integer-bytes->integer (read-bytes/exactly 8 i) #f #f)]
(integer-bytes->integer (read-bytes/exactly 8 i) #t #f)]
[(eqv? b 131)
(define len (read-fasl-integer i))
(define str (read-fasl-string i len))

6
racket/src/cs/c/configure vendored
View File

@ -2475,6 +2475,11 @@ show_explicitly_set "${enable_racket}" "Racket"
show_explicitly_set "${enable_scheme}" "Chez Scheme build directory"
show_explicitly_set "${enable_mach}" "machine type"
if test "${enable_csonly}" = "yes" ; then
enable_csdefault=yes
fi
show_explicitly_enabled "${enable_csdefault}" "executables without suffix"
show_explicitly_disabled "${enable_mac64}" "64-bit Mac OS"
show_explicitly_enabled "${enable_libfw}" "Frameworks-to-system"
@ -2555,6 +2560,7 @@ fi
SUB_CONFIGURE_EXTRAS=
CS_INSTALLED=cs
if test "${enable_csdefault}" = "yes" ; then
CS_INSTALLED=""

6
racket/src/cs/c/configure.ac
View File

@ -61,6 +61,11 @@ show_explicitly_set "${enable_racket}" "Racket"
show_explicitly_set "${enable_scheme}" "Chez Scheme build directory"
show_explicitly_set "${enable_mach}" "machine type"
if test "${enable_csonly}" = "yes" ; then
enable_csdefault=yes
fi
show_explicitly_enabled "${enable_csdefault}" "executables without suffix"
m4_include(../ac/sdk_show.m4)
m4_include(../ac/strip_show.m4)
@ -76,6 +81,7 @@ m4_include(../ac/path_pkgscope.m4)
SUB_CONFIGURE_EXTRAS=
CS_INSTALLED=cs
if test "${enable_csdefault}" = "yes" ; then
CS_INSTALLED=""

1
racket/src/cs/io.sls
View File

@ -370,6 +370,7 @@
"argument" arg))
(cond
[(and (record? arg)
(not (extflonum? arg))
(or (not (impersonator? arg))
(record? (unsafe-struct*-ref arg 0))))
(let ([arg (if (impersonator? arg)

39
racket/src/cs/linklet.sls
View File

@ -3,7 +3,6 @@
compile-linklet
recompile-linklet
eval-linklet
read-compiled-linklet
instantiate-linklet
read-on-demand-source
@ -20,13 +19,9 @@
instance-set-variable-value!
instance-unset-variable!
linklet-directory?
hash->linklet-directory
linklet-directory->hash
linklet-bundle?
hash->linklet-bundle
linklet-bundle->hash
linklet-virtual-machine-bytes
write-linklet-bundle-hash
read-linklet-bundle-hash
variable-reference?
variable-reference->instance
@ -773,30 +768,6 @@
;; --------------------------------------------------
(define-record-type linklet-directory
(fields hash)
(nongenerative #{linklet-directory cvqw30w53xy6hsjsc5ipep-0}))
(define (hash->linklet-directory ht)
(make-linklet-directory ht))
(define (linklet-directory->hash ld)
(linklet-directory-hash ld))
(define-record-type (linklet-bundle make-linklet-bundle linklet-bundle?)
(fields (immutable hash))
(nongenerative #{linklet-bundle chqh4u4pk0me3osmzzx8pq-0}))
(define (install-linklet-bundle-write!)
(struct-property-set! prop:custom-write (record-type-descriptor linklet-bundle) write-linklet-bundle)
(struct-property-set! prop:custom-write (record-type-descriptor linklet-directory) write-linklet-directory))
(define (hash->linklet-bundle ht)
(make-linklet-bundle ht))
(define (linklet-bundle->hash b)
(linklet-bundle-hash b))
(define-record variable-reference (instance ; the use-site instance
var-or-info)) ; the referenced variable, 'constant, 'mutable, #f, or 'primitive
@ -888,6 +859,4 @@
(set-foreign-eval! eval/foreign)
(expand-omit-library-invocations #t)
(install-linklet-bundle-write!))
(expand-omit-library-invocations #t))

200
racket/src/cs/linklet/read.ss
View File

@ -1,173 +1,11 @@
(define (read-compiled-linklet in)
(define (read-linklet-bundle-hash in)
(performance-region
'read-bundle
(read-compiled-linklet-or-directory in #t)))
(define (read-compiled-linklet-or-directory in initial?)
;; `#~` has already been read
(let ([start-pos (- (file-position in) 2)])
(let* ([vers-len (min 63 (read-byte in))]
[vers (read-bytes vers-len in)])
(unless (equal? vers version-bytes)
(raise-arguments-error 'read-compiled-linklet
"version mismatch"
"expected" (version)
"found" (bytes->string/utf-8 vers #\?)
"in" (let ([n (object-name in)])
(if (path? n)
(unquoted-printing-string
(path->string n))
in)))))
(let* ([vm-len (min 63 (read-byte in))]
[vm (read-bytes vm-len in)])
(unless (equal? vm vm-bytes)
(raise-arguments-error 'read-compiled-linklet
"virtual-machine mismatch"
"expected" (symbol->string (system-type 'vm))
"found" (bytes->string/utf-8 vm #\?)
"in" (let ([n (object-name in)])
(if (path? n)
(unquoted-printing-string
(path->string n))
in)))))
(let ([tag (read-byte in)])
(cond
[(equal? tag (char->integer #\B))
(let ([sha-1 (read-bytes 20 in)])
(let ([len (read-int in)])
(let ([bstr (read-bytes len in)])
(let ([b (fasl-read (open-bytevector-input-port bstr))])
(add-hash-code (adjust-linklet-bundle-laziness
(if initial?
(strip-submodule-references b)
b))
sha-1)))))]
[(equal? tag (char->integer #\D))
(unless initial?
(raise-arguments-error 'read-compiled-linklet
"expected a linklet bundle"))
(read-bundle-directory in start-pos)]
[else
(raise-arguments-error 'read-compiled-linklet
"expected a `B` or `D`")]))))
(define (read-int in)
(integer-bytes->integer (read-bytes 4 in) #f #f))
(define (read-bundle-directory in pos)
(let ([count (read-int in)])
(let ([position-to-name
(let loop ([count count] [accum (hasheqv)])
(cond
[(zero? count) accum]
[else
(let ([bstr (read-bytes (read-int in) in)])
(let* ([offset (read-int in)]
[len (read-int in)])
(read-int in) ; left
(read-int in) ; right
(loop (fx1- count)
(hash-set accum offset bstr))))]))])
(let loop ([count count] [accum '()])
(cond
[(zero? count)
(list->bundle-directory accum)]
[else
(let ([name (hash-ref position-to-name (- (file-position in) pos) #f)])
(unless name
(raise-arguments-error 'read-compiled-linklet
"bundle not at an expected file position"))
(let ([bstr (read-bytes 2 in)])
(let ([bundle
(cond
[(equal? '#vu8(35 126) bstr)
(read-compiled-linklet-or-directory in #f)]
[(equal? '#vu8(35 102) bstr)
#f]
[else
(raise-arguments-error 'read-compiled-linklet
"expected a `#~` or `#f` for a bundle")])])
(loop (fx1- count)
(cons (cons (decode-name name 0) bundle) accum)))))])))))
(define (decode-name bstr pos)
(let ([blen (bytes-length bstr)]
[bad-bundle (lambda ()
(raise-arguments-error 'read-compiled-linklet
"malformed bundle"))])
(cond
[(= pos blen)
'()]
[(> pos blen) (bad-bundle)]
[else
(let ([len (bytes-ref bstr pos)])
(when (> (+ pos len 1) blen) (bad-bundle))
(if (= len 255)
(let ([len (integer-bytes->integer bstr #f #f (fx1+ pos) (fx+ pos 5))])
(when (> (+ pos len 1) blen) (bad-bundle))
(cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx+ pos 5) (+ pos 5 len)) #\?))
(decode-name bstr (+ pos 5 len))))
(cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx1+ pos) (+ pos 1 len)) #\?))
(decode-name bstr (+ pos 1 len)))))])))
;; Convert a post-order list into a tree
(define (list->bundle-directory l)
;; The bundles list is in post-order, so we can build directories
;; bottom-up
(let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)])
(when (null? l)
(raise-arguments-error 'read-compiled-linklet
"invalid bundle sequence"))
(let* ([p (car l)]
[path (car p)]
[v (cdr p)]
[len (length path)])
(when (< len prev-len)
(raise-arguments-error 'read-compiled-linklet
"invalid bundle sequence"))
(let sloop ([prev-len prev-len] [stack stack] [accum accum])
(cond
[(> len (fx1+ prev-len))
(sloop (fx1+ prev-len)
(cons accum stack)
(hasheq))]
[else
(let ([path (list-tail path (fxmax 0 (fx1- prev-len)))])
(cond
[(= len prev-len)
(let ([accum (if v
(hash-set accum #f v)
accum)])
(if (zero? len)
(make-linklet-directory accum)
(loop (cdr l)
(fx1- prev-len)
(cdr stack)
(hash-set (car stack) (car path) (make-linklet-directory accum)))))]
[else
(let ([path (if (positive? prev-len)
(cdr path)
path)])
(loop (cdr l)
prev-len
stack
(hash-set accum
(car path)
(make-linklet-directory (if v
(hasheq #f v)
(hasheq))))))]))])))))
;; When a bundle is loaded by itself, remove any 'pre and 'post
;; submodule descriptions:
(define (strip-submodule-references b)
(make-linklet-bundle (hash-remove (hash-remove (linklet-bundle-hash b) 'pre) 'post)))
;; If the bundle has a non-zero hash code, record it with the
;; 'hash-code key to enable module caching
(define (add-hash-code b sha-1)
(if (bytevector=? sha-1 '#vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
b
(make-linklet-bundle (hash-set (linklet-bundle-hash b) 'hash-code sha-1))))
'read-linklet
(let* ([len (integer-bytes->integer (read-bytes 4 in) #f #f)]
[bstr (read-bytes len in)])
(adjust-linklet-bundle-laziness
(fasl-read (open-bytevector-input-port bstr))))))
(define read-on-demand-source
(make-parameter #f
@ -179,19 +17,17 @@
v))
v)))
(define (adjust-linklet-bundle-laziness b)
(make-linklet-bundle
(let ([ht (linklet-bundle-hash b)])
(let loop ([i (hash-iterate-first ht)])
(cond
[(not i) (hasheq)]
[else
(let-values ([(key val) (hash-iterate-key+value ht i)])
(hash-set (loop (hash-iterate-next ht i))
key
(if (linklet? val)
(adjust-linklet-laziness val)
val)))])))))
(define (adjust-linklet-bundle-laziness ht)
(let loop ([i (hash-iterate-first ht)])
(cond
[(not i) (hasheq)]
[else
(let-values ([(key val) (hash-iterate-key+value ht i)])
(hash-set (loop (hash-iterate-next ht i))
key
(if (linklet? val)
(adjust-linklet-laziness val)
val)))])))
(define (adjust-linklet-laziness linklet)
(set-linklet-code linklet

189
racket/src/cs/linklet/write.ss
View File

@ -1,182 +1,11 @@
(define (write-linklet-bundle b port mode)
;; Various tools expect a particular header:
;; "#~"
;; length of version byte string (< 64) as one byte
;; version byte string
;; "B"
;; 20 bytes of SHA-1 hash
(write-bytes '#vu8(35 126) port)
(write-bytes (bytes (bytes-length version-bytes)) port)
(write-bytes version-bytes port)
(write-bytes (bytes (bytes-length vm-bytes)) port)
(write-bytes vm-bytes port)
(write-bytes '#vu8(66) port)
(write-bytes (make-bytes 20 0) port)
;; The rest is whatever we want. We'll simply fasl the bundle.
(define (linklet-virtual-machine-bytes)
;; #"chez-scheme"
#vu8(99 104 101 122 45 115 99 104 101 109 101))
(define (write-linklet-bundle-hash ht dest-o)
(let-values ([(o get) (open-bytevector-output-port)])
(fasl-write* b o)
(fasl-write* ht o)
(let ([bstr (get)])
(write-int (bytes-length bstr) port)
(write-bytes bstr port))))
(define (linklet-bundle->bytes b)
(let ([o (open-output-bytes)])
(write-linklet-bundle b o #t)
(get-output-bytes o)))
(define (write-linklet-directory ld port mode)
;; Various tools expect a particular header:
;; "#~"
;; length of version byte string (< 64) as one byte
;; version byte string
;; length of virtual machine byte string (< 64) as one byte
;; virtual machine byte string
;; "D"
;; bundle count as 4-byte integer
;; binary tree:
;; bundle-name length as 4-byte integer
;; bundle name [encoding decribed below]
;; bundle offset as 4-byte integer
;; bundle size as 4-byte integer
;; left-branch offset as 4-byte integer
;; right-branch offset as 4-byte integer
;; A bundle name corresponds to a list of symbols. Each symbol in the list is
;; prefixed with either: its length as a byte if less than 255; 255 followed by
;; a 4-byte integer for the length.
(write-bytes '#vu8(35 126) port)
(write-bytes (bytes (bytes-length version-bytes)) port)
(write-bytes version-bytes port)
(write-bytes (bytes (bytes-length vm-bytes)) port)
(write-bytes vm-bytes port)
(write-bytes '#vu8(68) port)
;; Flatten a directory of bundles into a vector of pairs, where
;; each pair has the encoded bundle name and the bundle bytes
(let* ([bundles (list->vector (flatten-linklet-directory ld '() '()))]
[len (vector-length bundles)]
[initial-offset (+ 2 ; "#~"
1 ; version length
(bytes-length version-bytes)
1 ; vm length
(bytes-length vm-bytes)
1 ; D
4)]) ; bundle count
(write-int len port) ; bundle count
(chez:vector-sort! (lambda (a b) (bytes<? (car a) (car b))) bundles)
;; Compute bundle offsets
(let* ([btree-size (compute-btree-size bundles len)]
[node-offsets (compute-btree-node-offsets bundles len initial-offset)]
[bundle-offsets (compute-bundle-offsets bundles len (+ initial-offset btree-size))])
(write-directory-btree bundles node-offsets bundle-offsets len port)
;; Write the bundles
(let loop ([i 0])
(unless (fx= i len)
(write-bytes (cdr (vector-ref bundles i)) port)
(loop (fx1+ i)))))))
;; Flatten a tree into a list of `(cons _name-bstr _bundle-bstr)`
(define (flatten-linklet-directory ld rev-name-prefix accum)
(let ([ht (linklet-directory-hash ld)])
(let loop ([i (hash-iterate-first ht)] [accum accum] [saw-bundle? #f])
(cond
[(not i)
(if saw-bundle?
accum
(cons (cons (encode-name rev-name-prefix)
'#vu8(35 102))
accum))]
[else
(let-values ([(key value) (hash-iterate-key+value ht i)])
(cond
[(eq? key #f)
(loop (hash-iterate-next ht i)
(cons (cons (encode-name rev-name-prefix)
(linklet-bundle->bytes value))
accum)
#t)]
[else
(loop (hash-iterate-next ht i)
(flatten-linklet-directory value (cons key rev-name-prefix) accum)
saw-bundle?)]))]))))
;; Encode a bundle name (as a reversed list of symbols) as a single
;; byte string
(define (encode-name rev-name)
(define (encode-symbol s)
(let* ([bstr (string->bytes/utf-8 (symbol->string s))]
[len (bytes-length bstr)])
(if (< len 255)
(list (bytes len) bstr)
(list (bytes 255) (integer->integer-bytes len 4 #f #f) bstr))))
(let loop ([rev-name rev-name] [accum '()])
(cond
[(null? rev-name) (apply bytes-append accum)]
[else
(loop (cdr rev-name) (append (encode-symbol (car rev-name))
accum))])))
;; Figure out how big the binary tree will be, which depends
;; on the size of bundle-name byte strings
(define (compute-btree-size bundles len)
(let loop ([i 0] [size 0])
(if (= i len)
size
(let ([nlen (bytes-length (car (vector-ref bundles i)))])
;; 5 numbers: name length, bundle offset, bundles size, lef, and right
(loop (fx1+ i) (+ size nlen (* 5 4)))))))
;; Compute the offset where each node in the binary tree will reside
;; relative to the start of the bundle directory's "#~"
(define (compute-btree-node-offsets bundles len initial-offset)
(let ([node-offsets (make-vector len)])
(let loop ([lo 0] [hi len] [offset initial-offset])
(cond
[(= lo hi) offset]
[else
(let* ([mid (quotient (+ lo hi) 2)])
(vector-set! node-offsets mid offset)
(let* ([nlen (bytes-length (car (vector-ref bundles mid)))]
[offset (+ offset 4 nlen 4 4 4 4)])
(let ([offset (loop lo mid offset)])
(loop (add1 mid) hi offset))))]))
node-offsets))
;; Compute the offset where each bundle will reside relative
;; to the start of the bundle directory's "#~"
(define (compute-bundle-offsets bundles len offset)
(let ([bundle-offsets (make-vector len)])
(let loop ([i 0] [offset offset])
(unless (= i len)
(vector-set! bundle-offsets i offset)
(loop (fx1+ i) (+ offset (bytes-length (cdr (vector-ref bundles i)))))))
bundle-offsets))
;; Write the binary tree for the directory:
(define (write-directory-btree bundles node-offsets bundle-offsets len port)
(let loop ([lo 0] [hi len])
(cond
[(= lo hi) (void)]
[else
(let* ([mid (quotient (+ lo hi) 2)]
[p (vector-ref bundles mid)]
[nlen (bytes-length (car p))])
(write-int nlen port)
(write-bytes (car p) port)
(write-int (vector-ref bundle-offsets mid) port)
(write-int (bytes-length (cdr p)) port)
(cond
[(> mid lo)
(let ([left (quotient (+ lo mid) 2)])
(write-int (vector-ref node-offsets left) port))]
[else
(write-int 0 port)])
(cond
[(< (fx1+ mid) hi)
(let ([right (quotient (+ (fx1+ mid) hi) 2)])
(write-int (vector-ref node-offsets right) port))]
[else
(write-int 0 port)])
(loop lo mid)
(loop (fx1+ mid) hi))])))
(define (write-int n port)
(write-bytes (integer->integer-bytes n 4 #f #f) port))
(write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) dest-o)
(write-bytes bstr dest-o))))

4
racket/src/cs/primitive/linklet.ss
View File

@ -23,7 +23,9 @@
[make-instance (known-procedure -2)]
[primitive->compiled-position (known-procedure 2)]
[primitive-table (known-procedure 6)]
[read-compiled-linklet (known-procedure 2)]
[linklet-virtual-machine-bytes (known-procedure 1)]
[read-linklet-bundle-hash (known-procedure 2)]
[write-linklet-bundle-hash (known-procedure 2)]
[recompile-linklet (known-procedure 30)]
[variable-reference->instance (known-procedure 6)]
[variable-reference-constant? (known-procedure 2)]

1
racket/src/cs/rumble.sls
View File

@ -764,6 +764,7 @@
(set-mpair-hash!)
(set-hash-hash!)
(set-flvector-hash!)
(set-extflonum-print!)
(set-impersonator-hash!)
(set-procedure-impersonator-hash!)
(set-vector-impersonator-hash!)

5
racket/src/cs/rumble/extfl.ss
View File

@ -3,6 +3,11 @@
(fields str)
(nongenerative #{extflonum lb32cq34kbljz9rpowkzge-0}))
(define (set-extflonum-print!)
(record-writer (record-type-descriptor extflonum)
(lambda (e p wr)
(#%display (extflonum-str e) p))))
;; used by `string->number`
(define (extflonum-string? s)
;; It's an extflonum if there's any #\t

5
racket/src/cs/rumble/number.ss
View File

@ -14,8 +14,9 @@
(check who real? x)
(exact->inexact x))
(define (real->single-flonum x)
(raise-unsupported-error 'real->single-flonum))
(define/who (real->single-flonum x)
(check who real? x)
(exact->inexact x))
(define arithmetic-shift bitwise-arithmetic-shift)

6
racket/src/expander/boot/handler.rkt
View File

@ -669,10 +669,10 @@
(c e #t))))))))
(define default-compile-handler
;; Constrained to a single argument:
;; Constrained to two arguments:
(lambda (s immediate-eval?) (compile s
(current-namespace)
(not immediate-eval?))))
(current-namespace)
(not immediate-eval?))))
(define (default-read-interaction src in)
(unless (input-port? in)

1
racket/src/expander/boot/kernel.rkt
View File

@ -20,7 +20,6 @@
declare-reexporting-module!)
(define (declare-kernel-module! ns
#:eval eval
#:main-ids main-ids
#:read-ids read-ids)
(copy-runtime-module! '#%kernel

12
racket/src/expander/boot/linklet-primitive.rkt
View File

@ -1,9 +1,19 @@
#lang racket/base
(require "../host/linklet.rkt"
"../compile/linklet.rkt"
"../common/reflect-hash.rkt"
"../run/linklet-operation.rkt")
(provide linklet-primitives)
(provide linklet-primitives
linklet-expander-primitives)
(define linklet-primitives
(linklet-operations=> reflect-hash))
(define linklet-expander-primitives
(reflect-hash linklet-directory?
linklet-directory->hash
hash->linklet-directory
linklet-bundle?
linklet-bundle->hash
hash->linklet-bundle))

76
racket/src/expander/compile/linklet.rkt Normal file
View File

@ -0,0 +1,76 @@
#lang racket/base
(require racket/fasl
"../common/contract.rkt"
"../host/linklet.rkt"
"write-linklet.rkt")
(provide linklet-directory?
linklet-bundle?
hash->linklet-directory
hash->linklet-bundle
linklet-directory->hash
linklet-bundle->hash)
(struct linklet-directory (ht)
#:property prop:custom-write (lambda (ld port mode)
(write-linklet-directory ld
linklet-directory->hash
linklet-bundle->hash
port)))
(struct linklet-bundle (ht)
#:property prop:custom-write (lambda (b port mode)
(write-linklet-bundle b
linklet-bundle->hash
port)))
(define/who (hash->linklet-directory ht)
(check who (lambda (ht)
(and (not (impersonator? ht))
(hash? ht)
(immutable? ht)
(hash-eq? ht)))
#:contract "(and/c hash? hash-eq? immutable? (not/c impersonator?))"
ht)
(for ([(k v) (in-hash ht)])
(cond
[(not k)
(unless (linklet-bundle? v)
(raise-arguments-error who
"value for #f key is not a linklet bundle"
"value" v))]
[(symbol? k)
(unless (linklet-directory? v)
(raise-arguments-error who
"value for symbol key is not a linklet directory"
"value" v))]
[else
(raise-arguments-error who
"key in given hash is not #f or a symbol"
"key" k)]))
(linklet-directory ht))
(define/who (hash->linklet-bundle ht)
(check who (lambda (ht)
(and (not (impersonator? ht))
(hash? ht)
(immutable? ht)
(hash-eq? ht)))
#:contract "(and/c hash? hash-eq? immutable? (not/c impersonator?))"
ht)
(for ([k (in-hash-keys ht)])
(unless (or (symbol? k) (fixnum? k))
(raise-arguments-error who
"key in given hash is not a symbol or fixnum"
"key" k)))
(linklet-bundle ht))
(define/who (linklet-directory->hash ld)
(check who linklet-directory? ld)
(linklet-directory-ht ld))
(define/who (linklet-bundle->hash ld)
(check who linklet-bundle? ld)
(linklet-bundle-ht ld))

1
racket/src/expander/compile/module.rkt
View File

@ -21,6 +21,7 @@
"instance.rkt"
"form.rkt"
"compiled-in-memory.rkt"
"linklet.rkt"
"../eval/reflect.rkt"
"../eval/reflect-name.rkt")

1
racket/src/expander/compile/multi-top.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "compiled-in-memory.rkt"
"multi-top-data.rkt"
"linklet.rkt"
"../host/linklet.rkt")
(provide compiled-tops->compiled-top

177
racket/src/expander/compile/read-linklet.rkt Normal file
View File

@ -0,0 +1,177 @@
#lang racket/base
(require "version-bytes.rkt"
"linklet.rkt"
"../host/linklet.rkt")
(provide read-linklet-bundle-or-directory)
(define (read-linklet-bundle-or-directory in)
(define (read-linklet-or-directory initial?)
;; `#~` has already been read
(define start-pos (- (file-position in) 2))
(define vers-len (min 63 (read-byte in)))
(define vers (read-bytes vers-len in))
(unless (equal? vers version-bytes)
(raise-arguments-error 'read-compiled-linklet
"version mismatch"
"expected" (version)
"found" (bytes->string/utf-8 vers #\?)
"in" (let ([n (object-name in)])
(if (path? n)
(unquoted-printing-string
(path->string n))
in))))
(define vm-len (min 63 (read-byte in)))
(define vm (read-bytes vm-len in))
(unless (equal? vm vm-bytes)
(raise-arguments-error 'read-compiled-linklet
"virtual-machine mismatch"
"expected" (bytes->string/utf-8 vm-bytes)
"found" (bytes->string/utf-8 vm #\?)
"in" (let ([n (object-name in)])
(if (path? n)
(unquoted-printing-string
(path->string n))
in))))
(define tag (read-byte in))
(cond
[(eqv? tag (char->integer #\B))
(define sha-1 (read-bytes 20 in))
(define b-ht (read-linklet-bundle-hash in))
(hash->linklet-bundle
(add-hash-code (if initial?
(strip-submodule-references b-ht)
b-ht)
sha-1))]
[(eqv? tag (char->integer #\D))
(unless initial?
(raise-arguments-error 'read-compiled-linklet
"expected a linklet bundle"))
(read-bundle-directory start-pos)]
[else
(raise-arguments-error 'read-compiled-linklet
"expected a `B` or `D`")]))
(define (read-bundle-directory pos)
(define count (read-int in))
(define position-to-name
(let loop ([count count] [accum (hasheqv)])
(cond
[(zero? count) accum]
[else
(define bstr (read-bytes (read-int in) in))
(define offset (read-int in))
(define len (read-int in))
(read-int in) ; left
(read-int in) ; right
(loop (sub1 count)
(hash-set accum offset bstr))])))
(let loop ([count count] [accum '()])
(cond
[(zero? count)
(list->bundle-directory accum hash->linklet-directory)]
[else
(define name (hash-ref position-to-name (- (file-position in) pos) #f))
(unless name
(raise-arguments-error 'read-compiled-linklet
"bundle not at an expected file position"))
(define bstr (read-bytes 2 in))
(define bundle
(cond
[(equal? #"#~" bstr)
(read-linklet-or-directory #f)]
[(equal? #"#f" bstr)
#f]
[else
(raise-arguments-error 'read-compiled-linklet
"expected a `#~` or `#f` for a bundle")]))
(loop (sub1 count)
(cons (cons (decode-name name 0) bundle) accum))])))
(read-linklet-or-directory #t))
(define (read-int in)
(integer-bytes->integer (read-bytes 4 in) #f #f))
(define (decode-name bstr pos)
(define blen (bytes-length bstr))
(define (bad-bundle)
(raise-arguments-error 'read-compiled-linklet
"malformed bundle"))
(cond
[(= pos blen)
'()]
[(> pos blen) (bad-bundle)]
[else
(define len (bytes-ref bstr pos))
(when (> (+ pos len 1) blen) (bad-bundle))
(cond
[(= len 255)
(define len (integer-bytes->integer bstr #f #f (add1 pos) (+ pos 5)))
(when (> (+ pos len 1) blen) (bad-bundle))
(cons (string->symbol (bytes->string/utf-8 (subbytes bstr (+ pos 5) (+ pos 5 len)) #\?))
(decode-name bstr (+ pos 5 len)))]
[else
(cons (string->symbol (bytes->string/utf-8 (subbytes bstr (add1 pos) (+ pos 1 len)) #\?))
(decode-name bstr (+ pos 1 len)))])]))
;; Convert a post-order list into a tree
(define (list->bundle-directory l hash->linklet-directory)
;; The bundles list is in post-order, so we can build directories
;; bottom-up
(let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)])
(when (null? l)
(raise-arguments-error 'read-compiled-linklet
"invalid bundle sequence"))
(let* ([p (car l)]
[path (car p)]
[v (cdr p)]
[len (length path)])
(when (< len prev-len)
(raise-arguments-error 'read-compiled-linklet
"invalid bundle sequence"))
(let sloop ([prev-len prev-len] [stack stack] [accum accum])
(cond
[(> len (add1 prev-len))
(sloop (add1 prev-len)
(cons accum stack)
(hasheq))]
[else
(let ([path (list-tail path (max 0 (sub1 prev-len)))])
(cond
[(= len prev-len)
(let ([accum (if v
(hash-set accum #f v)
accum)])
(if (zero? len)
(hash->linklet-directory accum)
(loop (cdr l)
(sub1 prev-len)
(cdr stack)
(hash-set (car stack) (car path) (hash->linklet-directory accum)))))]
[else
(let ([path (if (positive? prev-len)
(cdr path)
path)])
(loop (cdr l)
prev-len
stack
(hash-set accum
(car path)
(hash->linklet-directory (if v
(hasheq #f v)
(hasheq))))))]))])))))
;; When a bundle is loaded by itself, remove any 'pre and 'post
;; submodule descriptions:
(define (strip-submodule-references b-ht)
(hash-remove (hash-remove b-ht 'pre) 'post))
;; If the bundle has a non-zero hash code, record it with the
;; 'hash-code key to enable module caching
(define (add-hash-code b-ht sha-1)
(if (bytes=? sha-1 #"\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0")
b-ht
(hash-set b-ht 'hash-code sha-1)))

3
racket/src/expander/compile/recompile.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "../host/linklet.rkt"
"../eval/reflect.rkt")
"../eval/reflect.rkt"
"linklet.rkt")
(provide compiled-expression-recompile)

1
racket/src/expander/compile/top.rkt
View File

@ -10,6 +10,7 @@
"../common/performance.rkt"
"../eval/top-level-instance.rkt"
"compiled-in-memory.rkt"
"linklet.rkt"
"context.rkt"
"header.rkt"
"reserved-symbol.rkt"

8
racket/src/expander/compile/version-bytes.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang racket/base
(require "../host/linklet.rkt")
(provide version-bytes
vm-bytes)
(define version-bytes (string->bytes/utf-8 (version)))
(define vm-bytes (linklet-virtual-machine-bytes))

174
racket/src/expander/compile/write-linklet.rkt Normal file
View File

@ -0,0 +1,174 @@
#lang racket/base
(require "../host/linklet.rkt"
"version-bytes.rkt")
(provide write-linklet-bundle
write-linklet-directory)
(define (write-linklet-bundle b linklet-bundle->hash port)
;; Various tools expect a particular header:
;; "#~"
;; length of version byte string (< 64) as one byte
;; version byte string
;; "B"
;; 20 bytes of SHA-1 hash
(write-bytes #"#~" port)
(write-bytes (bytes (bytes-length version-bytes)) port)
(write-bytes version-bytes port)
(write-bytes (bytes (bytes-length vm-bytes)) port)
(write-bytes vm-bytes port)
(write-bytes #"B" port)
(write-bytes (make-bytes 20 0) port)
;; The rest is whatever the VM wants
(write-linklet-bundle-hash (linklet-bundle->hash b) port))
(define (linklet-bundle->bytes b linklet-bundle->hash)
(define o (open-output-bytes))
(write-linklet-bundle b linklet-bundle->hash o)
(get-output-bytes o))
(define (write-linklet-directory ld linklet-directory->hash linklet-bundle->hash port)
;; Various tools expect a particular header:
;; "#~"
;; length of version byte string (< 64) as one byte
;; version byte string
;; length of virtual machine byte string (< 64) as one byte
;; virtual machine byte string
;; "D"
;; bundle count as 4-byte integer
;; binary tree:
;; bundle-name length as 4-byte integer
;; bundle name [encoding decribed below]
;; bundle offset as 4-byte integer
;; bundle size as 4-byte integer
;; left-branch offset as 4-byte integer
;; right-branch offset as 4-byte integer
;; A bundle name corresponds to a list of symbols. Each symbol in the list is
;; prefixed with either: its length as a byte if less than 255; 255 followed by
;; a 4-byte integer for the length.
(write-bytes #"#~" port)
(write-byte (bytes-length version-bytes) port)
(write-bytes version-bytes port)
(write-byte (bytes-length vm-bytes) port)
(write-bytes vm-bytes port)
(write-bytes #"D" port)
;; Flatten a directory of bundles into a vector of pairs, where
;; each pair has the encoded bundle name and the bundle bytes
(define (flatten-linklet-directory ld rev-name-prefix accum)
(define-values (new-accum saw-bundle?)
(for/fold ([accum accum] [saw-bundle? #f]) ([(key value) (in-hash (linklet-directory->hash ld))])
(cond
[(eq? key #f)
(values (cons (cons (encode-name rev-name-prefix)
(linklet-bundle->bytes value linklet-bundle->hash))
accum)
#t)]
[else
(values (flatten-linklet-directory value (cons key rev-name-prefix) accum)
saw-bundle?)])))
(cond
[saw-bundle? new-accum]
[else (cons (cons (encode-name rev-name-prefix)
#"#f")
new-accum)]))
(define bundles (list->vector
(sort (flatten-linklet-directory ld '() '())
(lambda (a b) (bytes<? (car a) (car b))))))
(define len (vector-length bundles))
(define initial-offset (+ 2 ; "#~"
1 ; version length
(bytes-length version-bytes)
1 ; vm length
(bytes-length vm-bytes)
1 ; D
4)) ; bundle count
(write-int len port) ; bundle count
;; Compute bundle offsets
(define btree-size (compute-btree-size bundles len))
(define node-offsets (compute-btree-node-offsets bundles len initial-offset))
(define bundle-offsets (compute-bundle-offsets bundles len (+ initial-offset btree-size)))
(write-directory-btree bundles node-offsets bundle-offsets len port)
;; Write the bundles
(for ([i (in-range len)])
(write-bytes (cdr (vector-ref bundles i)) port)))
;; Encode a bundle name (as a reversed list of symbols) as a single
;; byte string
(define (encode-name rev-name)
(define (encode-symbol s)
(let* ([bstr (string->bytes/utf-8 (symbol->string s))]
[len (bytes-length bstr)])
(if (< len 255)
(list (bytes len) bstr)
(list (bytes 255) (integer->integer-bytes len 4 #f #f) bstr))))
(let loop ([rev-name rev-name] [accum '()])
(cond
[(null? rev-name) (apply bytes-append accum)]
[else
(loop (cdr rev-name) (append (encode-symbol (car rev-name))
accum))])))
;; Figure out how big the binary tree will be, which depends
;; on the size of bundle-name byte strings
(define (compute-btree-size bundles len)
(for/sum ([i (in-range len)])
(define nlen (bytes-length (car (vector-ref bundles i))))
;; 5 numbers: name length, bundle offset, bundles size, lef, and right
(+ nlen (* 5 4))))
;; Compute the offset where each node in the binary tree will reside
;; relative to the start of the bundle directory's "#~"
(define (compute-btree-node-offsets bundles len initial-offset)
(define node-offsets (make-vector len))
(let loop ([lo 0] [hi len] [offset initial-offset])
(cond
[(= lo hi) offset]
[else
(define mid (quotient (+ lo hi) 2))
(vector-set! node-offsets mid offset)
(define nlen (bytes-length (car (vector-ref bundles mid))))
(let* ([offset (+ offset 4 nlen 4 4 4 4)]
[offset (loop lo mid offset)])
(loop (add1 mid) hi offset))]))
node-offsets)
;; Compute the offset where each bundle will reside relative
;; to the start of the bundle directory's "#~"
(define (compute-bundle-offsets bundles len offset)
(define bundle-offsets (make-vector len))
(let loop ([i 0] [offset offset])
(unless (= i len)
(vector-set! bundle-offsets i offset)
(loop (add1 i) (+ offset (bytes-length (cdr (vector-ref bundles i)))))))
bundle-offsets)
;; Write the binary tree for the directory:
(define (write-directory-btree bundles node-offsets bundle-offsets len port)
(let loop ([lo 0] [hi len])
(cond
[(= lo hi) (void)]
[else
(let* ([mid (quotient (+ lo hi) 2)]
[p (vector-ref bundles mid)]
[nlen (bytes-length (car p))])
(write-int nlen port)
(write-bytes (car p) port)
(write-int (vector-ref bundle-offsets mid) port)
(write-int (bytes-length (cdr p)) port)
(cond
[(> mid lo)
(let ([left (quotient (+ lo mid) 2)])
(write-int (vector-ref node-offsets left) port))]
[else
(write-int 0 port)])
(cond
[(< (add1 mid) hi)
(let ([right (quotient (+ (add1 mid) hi) 2)])
(write-int (vector-ref node-offsets right) port))]
[else
(write-int 0 port)])
(loop lo mid)
(loop (add1 mid) hi))])))
(define (write-int n port)
(write-bytes (integer->integer-bytes n 4 #f #f) port))

1
racket/src/expander/eval/main.rkt
View File

@ -15,6 +15,7 @@
[expand expand-in-context])
"../compile/main.rkt"
"../compile/compiled-in-memory.rkt"
"../compile/linklet.rkt"
"top.rkt"
"module.rkt"
"../common/module-path.rkt"

1
racket/src/expander/eval/module.rkt
View File

@ -11,6 +11,7 @@
"../common/module-path.rkt"
"../compile/serialize.rkt"
"../host/linklet.rkt"
"../compile/linklet.rkt"
"../compile/instance.rkt"
"../compile/compiled-in-memory.rkt"
"../expand/context.rkt"

5
racket/src/expander/eval/multi-top.rkt
View File

@ -1,12 +1,13 @@
#lang racket/base
(require "../namespace/namespace.rkt"
(require "../host/linklet.rkt"
"../namespace/namespace.rkt"
"../compile/compiled-in-memory.rkt"
"../compile/serialize.rkt"
"../compile/eager-instance.rkt"
"../compile/reserved-symbol.rkt"
"../compile/namespace-scope.rkt"
"../compile/multi-top.rkt"
"../host/linklet.rkt")
"../compile/linklet.rkt")
(provide create-compiled-in-memorys-using-shared-data)

50
racket/src/expander/eval/reflect-compiled.rkt Normal file
View File

@ -0,0 +1,50 @@
#lang racket/base
(require "../compile/compiled-in-memory.rkt"
"../host/linklet.rkt"
"../compile/linklet.rkt"
"../common/contract.rkt"
"../namespace/provided.rkt"
"../namespace/provide-for-api.rkt")
(provide compiled-expression?
compiled-module-expression?
compiled->linklet-directory-or-bundle
normalize-to-linklet-directory)
(define (compiled-expression? c)
(or (compiled-in-memory? c)
(linklet-directory? c)
(linklet-bundle? c)))
(define (compiled-module-expression? c)
(define ld (compiled->linklet-directory-or-bundle c))
(or (and (linklet-directory? ld)
(let ([b (hash-ref (linklet-directory->hash ld) #f #f)])
(and b (hash-ref (linklet-bundle->hash b) 'decl #f)))
#t)
(and (linklet-bundle? ld)
(hash-ref (linklet-bundle->hash ld) 'decl #f)
#t)))
;; ----------------------------------------
(define (compiled->linklet-directory-or-bundle c)
(if (compiled-in-memory? c)
(compiled-in-memory-linklet-directory c)
c))
;; Normalize a compiled module that may have no submodules and is
;; represented directy by a linklet bundle to a representation that
;; uses a linklet directory
(define (normalize-to-linklet-directory c)
(cond
[(linklet-directory? (compiled->linklet-directory-or-bundle c))
;; already in linklet-directory form:
c]
[(linklet-bundle? c)
(hash->linklet-directory (hasheq #f c))]
[else
(struct-copy compiled-in-memory c
[linklet-directory (normalize-to-linklet-directory
(compiled-in-memory-linklet-directory c))])]))

50
racket/src/expander/eval/reflect-name.rkt
View File

@ -1,17 +1,37 @@
#lang racket/base
(require "../compile/compiled-in-memory.rkt"
"../host/linklet.rkt")
"../common/contract.rkt"
"../host/linklet.rkt"
"../compile/linklet.rkt"
"reflect-compiled.rkt")
(provide module-compiled-current-name
(provide module-compiled-name
module-compiled-current-name
change-module-name
module-compiled-immediate-name
rebuild-linklet-directory
compiled->linklet-directory-or-bundle)
(define (compiled->linklet-directory-or-bundle c)
(if (compiled-in-memory? c)
(compiled-in-memory-linklet-directory c)
c))
(define/who module-compiled-name
(case-lambda
[(c)
(check who compiled-module-expression? c)
(module-compiled-current-name c)]
[(c name)
(check who compiled-module-expression? c)
(unless (or (symbol? name)
(and (pair? name)
(list? name)
(andmap symbol? name)))
(raise-argument-error who
"(or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))"
name))
(define-values (i-name prefix)
(if (symbol? name)
(values name null)
(let ([r (reverse name)])
(values (car r) (reverse (cdr r))))))
(change-module-name c i-name prefix)]))
(define (module-compiled-current-name c)
(define ld (compiled->linklet-directory-or-bundle c))
@ -69,17 +89,19 @@
(hash->linklet-bundle (hash-set (linklet-bundle->hash lb) 'name name)))
(define (rebuild-linklet-directory main submods #:bundle-ok? [bundle-ok? #f])
(if (and (null? submods) bundle-ok?)
main
(hash->linklet-directory
(hash-set (for/fold ([ht #hasheq()]) ([submod (in-list submods)])
(define name (module-compiled-immediate-name submod))
(cond
(cond
[(and (null? submods) bundle-ok?)
main]
[else
(hash->linklet-directory
(hash-set (for/fold ([ht #hasheq()]) ([submod (in-list submods)])
(define name (module-compiled-immediate-name submod))
(cond
[(hash-ref ht name #f)
(raise-arguments-error 'module-compiled-submodules
"change would result in duplicate submodule name"
"name" name)]
[else
(hash-set ht name (compiled->linklet-directory-or-bundle submod))]))
#f
main))))
#f
main))]))

105
racket/src/expander/eval/reflect-submodule.rkt Normal file
View File

@ -0,0 +1,105 @@
#lang racket/base
(require "../compile/compiled-in-memory.rkt"
"../host/linklet.rkt"
"../common/contract.rkt"
"../compile/linklet.rkt"
"reflect-compiled.rkt"
"reflect-name.rkt")
(provide module-compiled-submodules)
;; The representation of a module with its submodules is designed to
;; make reading an individual submodule (with its submodule path
;; intact) fast and convenient --- but it makes adjusting the name
;; inconvenient, because each linklet bundle for a module encodes its
;; full submodule path. The extra layer of `compiled-in-memory`
;; support for sharing and fast compile-then-eval cycles is another
;; layer of inconvenience.
(define/who module-compiled-submodules
(case-lambda
[(c non-star?)
(check who compiled-module-expression? c)
(cond
[(compiled-in-memory? c)
;; We have a convenient `compiled-in-memory` structure
(if non-star?
(compiled-in-memory-pre-compiled-in-memorys c)
(compiled-in-memory-post-compiled-in-memorys c))]
[else
;; We have a raw linklet directory or bundle, which is designed
;; more for loading code than easy manipulation...
(cond
[(linklet-directory? c)
(define ht (linklet-directory->hash c))
(define bh (linklet-bundle->hash (hash-ref ht #f)))
(define names (hash-ref bh (if non-star? 'pre 'post) null))
(for/list ([name (in-list names)])
(hash-ref ht name))]
[else
;; a linklet bundle represents a module with no submodules
null])])]
[(c non-star? submods)
(check who compiled-module-expression? c)
(unless (and (list? submods)
(andmap compiled-module-expression? submods))
(raise-argument-error who "(listof compiled-module-expression?)" submods))
(cond
[(and (null? submods)
(or (linklet-bundle? (compiled->linklet-directory-or-bundle c))
(and (compiled-in-memory? c)
(null? (if non-star?
(compiled-in-memory-pre-compiled-in-memorys c)
(compiled-in-memory-post-compiled-in-memorys c))))))
;; No change to a module without submodules
c]
[(and (compiled-in-memory? c)
(andmap compiled-in-memory? submods))
;; All compiled-in-memory structures, so preserve them
(define pre-compiled-in-memorys (if non-star?
submods
(compiled-in-memory-pre-compiled-in-memorys c)))
(define post-compiled-in-memorys (if non-star?
(compiled-in-memory-post-compiled-in-memorys c)
submods))
(define n-c (normalize-to-linklet-directory c))
(fixup-submodule-names
(struct-copy compiled-in-memory n-c
[pre-compiled-in-memorys pre-compiled-in-memorys]
[post-compiled-in-memorys post-compiled-in-memorys]
[linklet-directory (rebuild-linklet-directory
(reset-submodule-names
(hash-ref (linklet-directory->hash (compiled->linklet-directory-or-bundle n-c)) #f)
non-star?
submods)
#:bundle-ok? (symbol? (module-compiled-current-name c))
(append pre-compiled-in-memorys
post-compiled-in-memorys))]))]
[else
;; Not all compiled-in-memory structures, so forget whatever ones we have
(define n-c (normalize-to-linklet-directory c))
(fixup-submodule-names
(rebuild-linklet-directory
(reset-submodule-names
(hash-ref (linklet-directory->hash (compiled->linklet-directory-or-bundle n-c)) #f)
non-star?
submods)
(map compiled->linklet-directory-or-bundle
(append (if non-star? submods (module-compiled-submodules c #t))
(if non-star? (module-compiled-submodules c #f) submods)))))])]))
;; ----------------------------------------
(define (fixup-submodule-names c)
;; Although this looks like a no-op, it forces a reset on submodule
;; names, except where the names already match (short-circuited in
;; `change-module-name`).
(module-compiled-name c (module-compiled-name c)))
(define (reset-submodule-names b pre? submods)
(hash->linklet-bundle
(hash-set (linklet-bundle->hash b)
(if pre? 'pre 'post)
(map module-compiled-immediate-name submods))))

143
racket/src/expander/eval/reflect.rkt
View File

@ -5,7 +5,9 @@
"module.rkt"
"../namespace/provided.rkt"
"../namespace/provide-for-api.rkt"
"reflect-name.rkt")
"reflect-compiled.rkt"
"reflect-name.rkt"
"reflect-submodule.rkt")
(provide compiled-expression?
@ -26,114 +28,6 @@
;; support for sharing and fast compile-then-eval cycles is another
;; layer of inconvenience.
(define (compiled-expression? c)
(or (compiled-in-memory? c)
(linklet-directory? c)
(linklet-bundle? c)))
(define (compiled-module-expression? c)
(define ld (compiled->linklet-directory-or-bundle c))
(or (and (linklet-directory? ld)
(let ([b (hash-ref (linklet-directory->hash ld) #f #f)])
(and b (hash-ref (linklet-bundle->hash b) 'decl #f)))
#t)
(and (linklet-bundle? ld)
(hash-ref (linklet-bundle->hash ld) 'decl #f)
#t)))
(define/who module-compiled-name
(case-lambda
[(c)
(check who compiled-module-expression? c)
(module-compiled-current-name c)]
[(c name)
(check who compiled-module-expression? c)
(unless (or (symbol? name)
(and (pair? name)
(list? name)
(andmap symbol? name)))
(raise-argument-error who
"(or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))"
name))
(define-values (i-name prefix)
(if (symbol? name)
(values name null)
(let ([r (reverse name)])
(values (car r) (reverse (cdr r))))))
(change-module-name c i-name prefix)]))
(define/who module-compiled-submodules
(case-lambda
[(c non-star?)
(check who compiled-module-expression? c)
(cond
[(compiled-in-memory? c)
;; We have a convenient `compiled-in-memory` structure
(if non-star?
(compiled-in-memory-pre-compiled-in-memorys c)
(compiled-in-memory-post-compiled-in-memorys c))]
[else
;; We have a raw linklet directory or bundle, which is designed
;; more for loading code than easy manipulation...
(cond
[(linklet-directory? c)
(define ht (linklet-directory->hash c))
(define bh (linklet-bundle->hash (hash-ref ht #f)))
(define names (hash-ref bh (if non-star? 'pre 'post) null))
(for/list ([name (in-list names)])
(hash-ref ht name))]
[else
;; a linklet bundle represents a module with no submodules
null])])]
[(c non-star? submods)
(check who compiled-module-expression? c)
(unless (and (list? submods)
(andmap compiled-module-expression? submods))
(raise-argument-error who "(listof compiled-module-expression?)" submods))
(cond
[(and (null? submods)
(or (linklet-bundle? (compiled->linklet-directory-or-bundle c))
(and (compiled-in-memory? c)
(null? (if non-star?
(compiled-in-memory-pre-compiled-in-memorys c)
(compiled-in-memory-post-compiled-in-memorys c))))))
;; No change to a module without submodules
c]
[(and (compiled-in-memory? c)
(andmap compiled-in-memory? submods))
;; All compiled-in-memory structures, so preserve them
(define pre-compiled-in-memorys (if non-star?
submods
(compiled-in-memory-pre-compiled-in-memorys c)))
(define post-compiled-in-memorys (if non-star?
(compiled-in-memory-post-compiled-in-memorys c)
submods))
(define n-c (normalize-to-linklet-directory c))
(fixup-submodule-names
(struct-copy compiled-in-memory n-c
[pre-compiled-in-memorys pre-compiled-in-memorys]
[post-compiled-in-memorys post-compiled-in-memorys]
[linklet-directory (rebuild-linklet-directory
(reset-submodule-names
(hash-ref (linklet-directory->hash (compiled->linklet-directory-or-bundle n-c)) #f)
non-star?
submods)
#:bundle-ok? (symbol? (module-compiled-current-name c))
(append pre-compiled-in-memorys
post-compiled-in-memorys))]))]
[else
;; Not all compiled-in-memory structures, so forget whatever ones we have
(define n-c (normalize-to-linklet-directory c))
(fixup-submodule-names
(rebuild-linklet-directory
(reset-submodule-names
(hash-ref (linklet-directory->hash (compiled->linklet-directory-or-bundle n-c)) #f)
non-star?
submods)
(map compiled->linklet-directory-or-bundle
(append (if non-star? submods (module-compiled-submodules c #t))
(if non-star? (module-compiled-submodules c #f) submods)))))])]))
(define/who (module-compiled-language-info c)
(check who compiled-module-expression? c)
(define h (compiled-module->h c))
@ -167,34 +61,3 @@
(check who compiled-module-expression? c)
(define h (compiled-module->h c))
(hash-ref h 'cross-phase-persistent? #f))
;; ----------------------------------------
;; Normalize a compiled module that may have no submodules and is
;; represented directy by a linklet bundle to a representation that
;; uses a linklet directory
(define (normalize-to-linklet-directory c)
(cond
[(linklet-directory? (compiled->linklet-directory-or-bundle c))
;; already in linklet-directory form:
c]
[(linklet-bundle? c)
(hash->linklet-directory (hasheq #f c))]
[else
(struct-copy compiled-in-memory c
[linklet-directory (normalize-to-linklet-directory
(compiled-in-memory-linklet-directory c))])]))
;; ----------------------------------------
(define (fixup-submodule-names c)
;; Although this looks like a no-op, it forces a reset on submodule
;; names, except where the names already match (short-circuited in
;; `change-module-name`).
(module-compiled-name c (module-compiled-name c)))
(define (reset-submodule-names b pre? submods)
(hash->linklet-bundle
(hash-set (linklet-bundle->hash b)
(if pre? 'pre 'post)
(map module-compiled-immediate-name submods))))

1
racket/src/expander/eval/top.rkt
View File

@ -14,6 +14,7 @@
"../compile/compiled-in-memory.rkt"
"../compile/multi-top.rkt"
"../compile/namespace-scope.rkt"
"../compile/linklet.rkt"
"../expand/context.rkt"
"top-level-instance.rkt"
"multi-top.rkt"

1
racket/src/expander/extract/module.rkt
View File

@ -3,6 +3,7 @@
"../run/cache.rkt"
"../compile/serialize.rkt"
"../compile/module-use.rkt"
"../compile/linklet.rkt"
(prefix-in new: "../common/module-path.rkt"))
(provide (struct-out compiled-module)

9
racket/src/expander/main.rkt
View File

@ -161,13 +161,16 @@
(hash-remove (hash-remove linklet-primitives
'variable-reference?)
'variable-reference-constant?)])
(declare-hash-based-module! '#%linklet linklet-primitives #:namespace ns
(declare-hash-based-module! '#%linklet-primitive linklet-primitives #:namespace ns
#:primitive? #t
#:register-builtin? #t))
#:register-builtin? #t)
(declare-hash-based-module! '#%linklet-expander linklet-expander-primitives #:namespace ns)
(declare-reexporting-module! '#%linklet (list '#%linklet-primitive
'#%linklet-expander)
#:namespace ns))
(declare-hash-based-module! '#%expobs expobs-primitives #:namespace ns
#:protected? #t)
(declare-kernel-module! ns
#:eval eval
#:main-ids (for/set ([name (in-hash-keys main-primitives)])
name)
#:read-ids (for/set ([name (in-hash-keys read-primitives)])

17
racket/src/expander/run/cache.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base
(require racket/file
file/sha1)
racket/port
file/sha1
"../compile/read-linklet.rkt")
(provide make-cache
get-cached-compiled
@ -51,7 +53,12 @@
(or (hash-ref new-table path #f)
(and (file-exists? path)
(file-exists? (build-path cache-dir (entry-key e)))
(equal? (call-with-input-file* path sha1)
(equal? (call-with-input-file* path (lambda (i)
(sha1
(input-port-append
#f
(open-input-string (version))
i))))
(entry-content e))
(for/and ([path (in-list (entry-dependencies e))])
(define e (hash-ref table path #f))
@ -85,7 +92,11 @@
(file-exists? cached-file))
(notify-success)
(parameterize ([read-accept-compiled #t])
(call-with-input-file* cached-file read))]
(call-with-input-file*
cached-file
(lambda (i)
(read-bytes 2 i) ; consume "#~"
(read-linklet-bundle-or-directory i))))]
[(and e
(hash-ref (cache-in-memory cache) (entry-key e) #f))
=> (lambda (c)

11
racket/src/expander/run/linklet-operation.rkt
View File

@ -18,7 +18,6 @@
compile-linklet ; result is serializable
recompile-linklet
eval-linklet ; optional; result is not serializable
read-compiled-linklet
instantiate-linklet ; fills in an instance given linket an argument instances
linklet-import-variables
@ -33,13 +32,9 @@
instance-set-variable-value!
instance-unset-variable!
linklet-directory? ; maps symbol lists to linklet bundles
hash->linklet-directory ; converts a hash table to a ld
linklet-directory->hash ; the other way
linklet-bundle? ; maps symbols and fixnums to values
hash->linklet-bundle
linklet-bundle->hash
linklet-virtual-machine-bytes
write-linklet-bundle-hash
read-linklet-bundle-hash
variable-reference?
variable-reference->instance

30
racket/src/expander/run/linklet.rkt
View File

@ -331,7 +331,13 @@
(define (eval-linklet c)
c)
(define (read-compiled-linklet in)
(define (linklet-virtual-machine-bytes)
#"source")
(define (write-linklet-bundle-hash ld in)
(write ld in))
(define (read-linklet-bundle-hash in)
(read in))
;; Convert linklet to a procedure
@ -392,28 +398,6 @@
;; ----------------------------------------
(struct linklet-directory (table)
#:prefab)
(define (hash->linklet-directory ht)
(linklet-directory ht))
(define (linklet-directory->hash ld)
(linklet-directory-table ld))
;; ----------------------------------------
(struct linklet-bundle (table)
#:prefab)
(define (hash->linklet-bundle ht)
(linklet-bundle ht))
(define (linklet-bundle->hash ld)
(linklet-bundle-table ld))
;; ----------------------------------------
(struct path-bytes (bstr) #:prefab)
(struct unreadable (str) #:prefab)
(struct void-value () #:prefab)

6
racket/src/expander/syntax/read-syntax.rkt
View File

@ -10,7 +10,7 @@
"../namespace/api-module.rkt"
"../namespace/namespace.rkt"
"srcloc.rkt"
"../host/linklet.rkt")
"../compile/read-linklet.rkt")
(provide read
read/recursive
@ -74,7 +74,7 @@
#:init-c init-c
#:readtable readtable
#:local-graph? local-graph?
#:read-compiled read-compiled-linklet
#:read-compiled read-linklet-bundle-or-directory
#:dynamic-require dynamic-require-reader
#:module-declared? read-module-declared?
#:coerce read-coerce
@ -84,7 +84,7 @@
(main:read-language in fail-thunk
#:for-syntax? #t
#:wrap read-to-syntax
#:read-compiled read-compiled-linklet
#:read-compiled read-linklet-bundle-or-directory
#:dynamic-require dynamic-require-reader
#:module-declared? read-module-declared?
#:coerce read-coerce

2
racket/src/racket/src/compile-startup.rkt
View File

@ -100,7 +100,7 @@
dest
(lambda (outfile)
(let-values ([(p) (open-output-bytes)])
(write (hash->linklet-bundle (hasheq 'startup linklet)) p)
(write-linklet-bundle-hash (hasheq 'startup linklet) p)
(let-values ([(s) (get-output-bytes p)])
(fprintf outfile "#if 0 ~a\n" version-comparisons)
(fprintf outfile "# include \"startup.inc\"\n")

187
racket/src/racket/src/linklet.c
View File

@ -58,11 +58,14 @@ static Scheme_Object *linklet_p(int argc, Scheme_Object **argv);
static Scheme_Object *compile_linklet(int argc, Scheme_Object **argv);
static Scheme_Object *recompile_linklet(int argc, Scheme_Object **argv);
static Scheme_Object *eval_linklet(int argc, Scheme_Object **argv);
static Scheme_Object *read_compiled_linklet(int argc, Scheme_Object **argv);
static Scheme_Object *instantiate_linklet(int argc, Scheme_Object **argv);
static Scheme_Object *linklet_import_variables(int argc, Scheme_Object **argv);
static Scheme_Object *linklet_export_variables(int argc, Scheme_Object **argv);
static Scheme_Object *linklet_vm_bytes(int argc, Scheme_Object **argv);
static Scheme_Object *write_linklet_bundle_hash(int argc, Scheme_Object **argv);
static Scheme_Object *read_linklet_bundle_hash(int argc, Scheme_Object **argv);
static Scheme_Object *instance_p(int argc, Scheme_Object **argv);
static Scheme_Object *make_instance(int argc, Scheme_Object **argv);
static Scheme_Object *instance_name(int argc, Scheme_Object **argv);
@ -72,14 +75,6 @@ static Scheme_Object *instance_variable_value(int argc, Scheme_Object **argv);
static Scheme_Object *instance_set_variable_value(int argc, Scheme_Object **argv);
static Scheme_Object *instance_unset_variable(int argc, Scheme_Object **argv);
static Scheme_Object *linklet_directory_p(int argc, Scheme_Object **argv);
static Scheme_Object *linklet_directory_to_hash(int argc, Scheme_Object **argv);
static Scheme_Object *hash_to_linklet_directory(int argc, Scheme_Object **argv);
static Scheme_Object *linklet_bundle_p(int argc, Scheme_Object **argv);
static Scheme_Object *linklet_bundle_to_hash(int argc, Scheme_Object **argv);
static Scheme_Object *hash_to_linklet_bundle(int argc, Scheme_Object **argv);
static Scheme_Object *variable_p(int argc, Scheme_Object **argv);
static Scheme_Object *variable_instance(int argc, Scheme_Object **argv);
static Scheme_Object *variable_const_p(int argc, Scheme_Object **argv);
@ -154,11 +149,14 @@ void scheme_init_linklet(Scheme_Startup_Env *env)
ADD_PRIM_W_ARITY2("compile-linklet", compile_linklet, 1, 5, 2, 2, env);
ADD_PRIM_W_ARITY2("recompile-linklet", recompile_linklet, 1, 4, 2, 2, env);
ADD_IMMED_PRIM("eval-linklet", eval_linklet, 1, 1, env);
ADD_PRIM_W_ARITY("read-compiled-linklet", read_compiled_linklet, 1, 1, env);
ADD_PRIM_W_ARITY2("instantiate-linklet", instantiate_linklet, 2, 4, 0, -1, env);
ADD_PRIM_W_ARITY("linklet-import-variables", linklet_import_variables, 1, 1, env);
ADD_PRIM_W_ARITY("linklet-export-variables", linklet_export_variables, 1, 1, env);
ADD_PRIM_W_ARITY("linklet-virtual-machine-bytes", linklet_vm_bytes, 0, 0, env);
ADD_PRIM_W_ARITY("write-linklet-bundle-hash", write_linklet_bundle_hash, 2, 2, env);
ADD_PRIM_W_ARITY("read-linklet-bundle-hash", read_linklet_bundle_hash, 1, 1, env);
ADD_FOLDING_PRIM("instance?", instance_p, 1, 1, 1, env);
ADD_PRIM_W_ARITY("make-instance", make_instance, 1, -1, env);
ADD_PRIM_W_ARITY("instance-name", instance_name, 1, 1, env);
@ -168,14 +166,6 @@ void scheme_init_linklet(Scheme_Startup_Env *env)
ADD_PRIM_W_ARITY("instance-set-variable-value!", instance_set_variable_value, 3, 4, env);
ADD_PRIM_W_ARITY("instance-unset-variable!", instance_unset_variable, 2, 2, env);
ADD_FOLDING_PRIM("linklet-directory?", linklet_directory_p, 1, 1, 1, env);
ADD_PRIM_W_ARITY("hash->linklet-directory", hash_to_linklet_directory, 1, 1, env);
ADD_PRIM_W_ARITY("linklet-directory->hash", linklet_directory_to_hash, 1, 1, env);
ADD_FOLDING_PRIM("linklet-bundle?", linklet_bundle_p, 1, 1, 1, env);
ADD_PRIM_W_ARITY("hash->linklet-bundle", hash_to_linklet_bundle, 1, 1, env);
ADD_PRIM_W_ARITY("linklet-bundle->hash", linklet_bundle_to_hash, 1, 1, env);
ADD_FOLDING_PRIM_UNARY_INLINED("variable-reference?", variable_p, 1, 1, 1, env);
ADD_IMMED_PRIM("variable-reference->instance", variable_instance, 1, 2, env);
@ -503,12 +493,57 @@ static Scheme_Object *eval_linklet(int argc, Scheme_Object **argv)
return (Scheme_Object *)linklet;
}
static Scheme_Object *read_compiled_linklet(int argc, Scheme_Object **argv)
static Scheme_Object *linklet_vm_bytes(int argc, Scheme_Object **argv)
{
return scheme_make_byte_string("racket");
}
static Scheme_Object *read_linklet_bundle_hash(int argc, Scheme_Object **argv)
{
if (!SCHEME_INPUT_PORTP(argv[0]))
scheme_wrong_contract("read-compiled-linklet", "input-port?", 0, argc, argv);
scheme_wrong_contract("read-linklet-bundle-hash", "input-port?", 0, argc, argv);
return scheme_read_compiled(argv[0]);
return scheme_read_linklet_bundle_hash(argv[0]);
}
static Scheme_Object *write_linklet_bundle_hash(int argc, Scheme_Object **argv)
{
mzlonglong pos;
Scheme_Object *k, *v;
Scheme_Hash_Tree *hash;
if (!SCHEME_HASHTRP(argv[0])
|| !SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[0])))
scheme_wrong_contract("write-linklet-bundle-hash",
"(and/c hash? hash-eq? immutable? (not/c impersonator?))",
0, argc, argv);
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_contract("write-linklet-bundle-hash", "output-port?", 0, argc, argv);
hash = (Scheme_Hash_Tree *)argv[0];
/* mapping: keys must be symbols and fixnums */
pos = scheme_hash_tree_next(hash, -1);
while (pos != -1) {
scheme_hash_tree_index(hash, pos, &k, &v);
if (!SCHEME_SYMBOLP(k) && !SCHEME_INTP(k)) {
scheme_contract_error("write-linklet-bundle-hash",
"key in given hash is not a symbol or fixnum",
"key", 1, k,
NULL);
}
pos = scheme_hash_tree_next(hash, pos);
}
v = scheme_alloc_small_object();
v->type = scheme_linklet_bundle_type;
SCHEME_PTR_VAL(v) = argv[0];
scheme_write(v, argv[1]);
return scheme_void;
}
static Scheme_Object *instantiate_linklet(int argc, Scheme_Object **argv)
@ -783,116 +818,6 @@ static Scheme_Object *instance_unset_variable(int argc, Scheme_Object **argv)
return scheme_void;
}
static Scheme_Object *linklet_directory_p(int argc, Scheme_Object **argv)
{
return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_directory_type)
? scheme_true
: scheme_false);
}
static Scheme_Object *linklet_directory_to_hash(int argc, Scheme_Object **argv)
{
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_directory_type))
scheme_wrong_contract("linklet-directory->hash", "linklet-directory?", 0, argc, argv);
return SCHEME_PTR_VAL(argv[0]);
}
static Scheme_Object *hash_to_linklet_directory(int argc, Scheme_Object **argv)
{
mzlonglong pos;
Scheme_Object *k, *v;
Scheme_Hash_Tree *hash;
if (!SCHEME_HASHTRP(argv[0])
|| !SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[0])))
scheme_wrong_contract("hash->linklet-directory",
"(and/c hash? hash-eq? immutable? (not/c impersonator?))",
0, argc, argv);
hash = (Scheme_Hash_Tree *)argv[0];
/* mapping: #f -> bundle, sym -> linklet directory */
pos = scheme_hash_tree_next(hash, -1);
while (pos != -1) {
scheme_hash_tree_index(hash, pos, &k, &v);
if (SCHEME_FALSEP(k)) {
if (!SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type))
scheme_contract_error("hash->linklet-directory",
"value for #f key is not a linklet bundle",
"value", 1, v,
NULL);
} else if (SCHEME_SYMBOLP(k)) {
if (!SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_directory_type))
scheme_contract_error("hash->linklet-directory",
"value for symbol key is not a linklet directory",
"key", 1, k,
"value", 1, v,
NULL);
} else {
scheme_contract_error("hash->linklet-directory",
"key in given hash is not #f or a symbol",
"key", 1, k,
NULL);
}
pos = scheme_hash_tree_next(hash, pos);
}
v = scheme_alloc_small_object();
v->type = scheme_linklet_directory_type;
SCHEME_PTR_VAL(v) = argv[0];
return v;
}
static Scheme_Object *linklet_bundle_p(int argc, Scheme_Object **argv)
{
return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_bundle_type)
? scheme_true
: scheme_false);
}
static Scheme_Object *linklet_bundle_to_hash(int argc, Scheme_Object **argv)
{
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_bundle_type))
scheme_wrong_contract("linklet-bundle->hash", "linklet-bundle?", 0, argc, argv);
return SCHEME_PTR_VAL(argv[0]);
}
static Scheme_Object *hash_to_linklet_bundle(int argc, Scheme_Object **argv)
{
mzlonglong pos;
Scheme_Object *k, *v;
Scheme_Hash_Tree *hash;
if (!SCHEME_HASHTRP(argv[0])
|| !SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[0])))
scheme_wrong_contract("hash->linklet-bundle",
"(and/c hash? hash-eq? immutable? (not/c impersonator?))",
0, argc, argv);
hash = (Scheme_Hash_Tree *)argv[0];
/* mapping: keys must be symbols and fixnums */
pos = scheme_hash_tree_next(hash, -1);
while (pos != -1) {
scheme_hash_tree_index(hash, pos, &k, &v);
if (!SCHEME_SYMBOLP(k) && !SCHEME_INTP(k)) {
scheme_contract_error("hash->linklet-bundle",
"key in given hash is not a symbol or fixnum",
"key", 1, k,
NULL);
}
pos = scheme_hash_tree_next(hash, pos);
}
v = scheme_alloc_small_object();
v->type = scheme_linklet_bundle_type;
SCHEME_PTR_VAL(v) = argv[0];
return v;
}
static Scheme_Object *variable_p(int argc, Scheme_Object **argv)
{
return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)

224
racket/src/racket/src/print.c
View File

@ -1749,161 +1749,6 @@ static int is_graph_point(Scheme_Hash_Table *ht, Scheme_Object *obj)
return 0;
}
static Scheme_Object *write_bundles_to_strings_k(void);
/* Bundles are written so that all of the link subdirectories content
of a link directory are together and terminated by a bundle or
#f (i.e., post-order traversal) */
static Scheme_Object *write_bundles_to_strings(Scheme_Object *accum_l,
Scheme_Object *ld,
Scheme_Object *name_list)
{
Scheme_Hash_Tree *ht;
mzlonglong pos;
Scheme_Object *k, *v, *bundle = scheme_false;
#ifdef DO_STACK_CHECK
#include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = accum_l;
p->ku.k.p2 = ld;
p->ku.k.p3 = name_list;
return scheme_handle_stack_overflow(write_bundles_to_strings_k);
}
#endif
ht = (Scheme_Hash_Tree *)SCHEME_PTR_VAL(ld);
pos = scheme_hash_tree_next(ht, -1);
while (pos != -1) {
scheme_hash_tree_index(ht, pos, &k, &v);
if (SCHEME_SYMBOLP(k)) {
MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_directory_type));
accum_l = write_bundles_to_strings(accum_l, v, scheme_make_pair(k, name_list));
} else {
MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type));
bundle = v;
}
pos = scheme_hash_tree_next(ht, pos);
}
/* write root bundle, if any, or #f */
{
intptr_t len, nlen;
char *s, *ns;
ns = scheme_symbol_path_to_string(scheme_reverse(name_list), &nlen);
s = scheme_write_to_string(bundle, &len);
accum_l = scheme_make_pair(scheme_make_pair(scheme_make_sized_byte_string(ns, nlen, 0),
scheme_make_sized_byte_string(s, len, 0)),
accum_l);
}
return accum_l;
}
static Scheme_Object *write_bundles_to_strings_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *accum_l = (Scheme_Object *)p->ku.k.p1;
Scheme_Object *ld = (Scheme_Object *)p->ku.k.p2;
Scheme_Object *name_list = (Scheme_Object *)p->ku.k.p3;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
return write_bundles_to_strings(accum_l, ld, name_list);
}
typedef struct Bundle_And_Offset {
Scheme_Object *bundle;
Scheme_Object *offset;
} Bundle_And_Offset;
static int compare_bundles(const void *_am, const void *_bm)
{
Scheme_Object *a = ((Bundle_And_Offset *)_am)->bundle;
Scheme_Object *b = ((Bundle_And_Offset *)_bm)->bundle;
intptr_t i, alen, blen;
unsigned char *as, *bs;
a = SCHEME_CAR(a);
b = SCHEME_CAR(b);
alen = SCHEME_BYTE_STRLEN_VAL(a);
blen = SCHEME_BYTE_STRLEN_VAL(b);
as = (unsigned char *)SCHEME_BYTE_STR_VAL(a);
bs = (unsigned char *)SCHEME_BYTE_STR_VAL(b);
for (i = 0; (i < alen) && (i < blen); i++) {
if (as[i] != bs[i])
return as[i] - bs[i];
}
return (alen - blen);
}
static intptr_t compute_bundle_subtrees(Bundle_And_Offset *a, intptr_t *subtrees,
int start, int count, intptr_t offset)
{
int midpt = start + (count / 2);
Scheme_Object *o = SCHEME_CAR(a[midpt].bundle);
intptr_t len;
len = SCHEME_BYTE_STRLEN_VAL(o);
offset += 4 + len + 16;
if (midpt > start)
offset = compute_bundle_subtrees(a, subtrees, start, midpt - start, offset);
subtrees[midpt] = offset;
count -= (midpt - start + 1);
if (count)
return compute_bundle_subtrees(a, subtrees, midpt + 1, count, offset);
else
return offset;
}
static intptr_t write_bundle_tree(PrintParams *pp, Bundle_And_Offset *a,
intptr_t *subtrees,
int start, int count, intptr_t offset)
{
int midpt = start + (count / 2);
Scheme_Object *o = SCHEME_CAR(a[midpt].bundle);
intptr_t len;
len = SCHEME_BYTE_STRLEN_VAL(o);
print_number(pp, len);
print_this_string(pp, SCHEME_BYTE_STR_VAL(o), 0, len);
print_number(pp, SCHEME_INT_VAL(a[midpt].offset));
print_number(pp, SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[midpt].bundle)));
offset += 20 + len;
if (midpt > start)
print_number(pp, offset);
else
print_number(pp, 0);
count -= (midpt - start + 1);
if (count)
print_number(pp, subtrees[midpt]);
else
print_number(pp, 0);
if (midpt > start)
offset = write_bundle_tree(pp, a, subtrees, start, midpt - start, offset);
if (count)
offset = write_bundle_tree(pp, a, subtrees, midpt + 1, count, offset);
return offset;
}
static int
print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt, PrintParams *pp)
@ -3302,60 +3147,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
set_symtab_shared(mt, obj);
}
}
else if (!compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_directory_type))
{
/* Write directory content with an index at the beginning */
Scheme_Object *p, *accum_l;
Bundle_And_Offset *a;
intptr_t *subtrees, offset, init_offset;
int count, i;
init_offset = 2 + 1 + strlen(MZSCHEME_VERSION) + 1 + strlen(MZSCHEME_VM) + 1 + 4;
accum_l = write_bundles_to_strings(scheme_null, obj, scheme_null);
for (p = accum_l, count = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) {
count++;
}
a = MALLOC_N(Bundle_And_Offset, count);
for (p = accum_l, i = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p), i++) {
a[i].bundle = SCHEME_CAR(p);
}
my_qsort(a, count, sizeof(Bundle_And_Offset), compare_bundles);
offset = init_offset;
for (i = 0; i < count; i++) {
offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CAR(a[i].bundle)) + 20;
}
for (i = 0; i < count; i++) {
a[i].offset = scheme_make_integer(offset);
offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].bundle));
}
/* a is in sorted (for btree) order */
subtrees = MALLOC_N_ATOMIC(intptr_t, count);
(void)compute_bundle_subtrees(a, subtrees, 0, count, init_offset);
print_this_string(pp, "#~", 0, 2);
print_one_byte(pp, strlen(MZSCHEME_VERSION));
print_this_string(pp, MZSCHEME_VERSION, 0, -1);
print_one_byte(pp, strlen(MZSCHEME_VM));
print_this_string(pp, MZSCHEME_VM, 0, -1);
/* "D" means "linklet directory": */
print_this_string(pp, "D", 0, 1);
print_number(pp, count);
/* Write the bundle directory as a binary search tree. */
(void)write_bundle_tree(pp, a, subtrees, 0, count, init_offset);
/* Write the bundles: */
for (i = 0; i < count; i++) {
print_this_string(pp,
SCHEME_BYTE_STR_VAL(SCHEME_CDR(a[i].bundle)),
0,
SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].bundle)));
}
}
else if ((compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_type))
|| SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_bundle_type))
{
@ -3383,8 +3174,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_bundle_type));
v = SCHEME_PTR_VAL(obj); /* extract hash table from a linklet bundle */
print_this_string(pp, "#~", 0, 2);
mt = MALLOC_ONE_RT(Scheme_Marshal_Tables);
SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info);
scheme_current_thread->current_mt = mt;
@ -3435,18 +3224,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen,
-1, &st_len);
/* Remember version: */
print_one_byte(pp, strlen(MZSCHEME_VERSION));
print_this_string(pp, MZSCHEME_VERSION, 0, -1);
print_one_byte(pp, strlen(MZSCHEME_VM));
print_this_string(pp, MZSCHEME_VM, 0, -1);
print_this_string(pp, "B", 0, 1); /* "B" means "bundle" */
/* Leave space for a module hash code */
print_this_string(pp, "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 0, 20);
if (mt->st_refs->count != mt->sorted_keys_count)
if (mt->st_refs->count != mt->sorted_keys_count)
scheme_signal_error("shared key count somehow changed");
print_number(pp, mt->st_refs->count + 1);

769
racket/src/racket/src/read.c
View File

@ -172,8 +172,6 @@ static Scheme_Object *read_box(Scheme_Object *port,
static Scheme_Object *read_hash(Scheme_Object *port,
int opener, char closer, int kind,
ReadParams *params);
static Scheme_Object *read_compiled(Scheme_Object *port,
ReadParams *params);
static void unexpected_closer(int ch,
Scheme_Object *port);
static int next_is_delim(Scheme_Object *port);
@ -684,8 +682,6 @@ static Scheme_Object *read_inner(Scheme_Object *port, ReadParams *params, int pr
return read_quote("unquoting #`@", unsyntax_splicing_symbol, 3, port, params);
} else
return read_quote("unquoting #`", unsyntax_symbol, 2, port, params);
case '~':
return read_compiled(port, params);
case '^':
{
ch = scheme_getc(port);
@ -3613,234 +3609,10 @@ static intptr_t read_simple_number_from_port(Scheme_Object *port)
+ (d << 24));
}
static void install_byecode_hash_code(CPort *rp, char *hash_code)
static Scheme_Object *read_linklet_bundle_hash(Scheme_Object *port,
int can_read_unsafe,
Scheme_Object *delay_load_info)
{
mzlonglong l = 0;
int i;
for (i = 0; i < 20; i++) {
l ^= ((umzlonglong)(hash_code[i]) << ((i % 8) * 8));
}
/* Make sure the hash code leaves lots of room for
run-time generated indices: */
# define LARGE_SPAN ((mzlonglong)1 << 40)
if (!l) l = LARGE_SPAN;
if (l > 0) l = -l;
if (l > (-LARGE_SPAN)) l -= LARGE_SPAN;
rp->bytecode_hash = l;
}
char *scheme_symbol_path_to_string(Scheme_Object *p, intptr_t *_len)
{
Scheme_Object *pr;
intptr_t len = 0, l;
unsigned char *s;
for (pr = p; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) {
l = SCHEME_SYM_LEN(SCHEME_CAR(pr));
if (l < 255)
len += l + 1;
else
len += l + 1 + 4;
}
*_len = len;
s = scheme_malloc_atomic(len + 1);
s[len] = 0;
len = 0;
for (pr = p; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) {
l = SCHEME_SYM_LEN(SCHEME_CAR(pr));
if (l < 255) {
s[len++] = l;
} else {
s[len++] = 255;
s[len++] = (l & 0xFF);
s[len++] = ((l >> 8) & 0xFF);
s[len++] = ((l >> 16) & 0xFF);
s[len++] = ((l >> 24) & 0xFF);
}
memcpy(s + len, SCHEME_SYM_VAL(SCHEME_CAR(pr)), l);
len += l;
}
return (char *)s;
}
Scheme_Object *scheme_string_to_symbol_path(char *_s, intptr_t len)
{
unsigned char *s = (unsigned char *)_s;
char *e, buffer[32];
uintptr_t pos = 0, l;
Scheme_Object *first = NULL, *last = NULL, *pr;
while (pos < len) {
l = s[pos++];
if ((l == 255) && ((len - pos) > 4)) {
l = (s[pos] | (s[pos+1] << 8) | (s[pos+2] << 16) | (s[pos+3] << 24));
pos += 4;
}
if (l > len - pos)
l = len - pos;
if (l < 32)
e = buffer;
else
e = scheme_malloc_atomic(l + 1);
memcpy(e, s + pos, l);
e[l] = 0;
pos += l;
if (!valid_utf8(e, l))
return scheme_null;
pr = scheme_make_pair(scheme_intern_exact_symbol(e, l), scheme_null);
if (last)
SCHEME_CDR(last) = pr;
else
first = pr;
last = pr;
}
return first ? first : scheme_null;
}
/* Installs into `ht` a mapping of offset -> (listof symbol) */
static void read_linklet_directory(Scheme_Object *port, Scheme_Hash_Table *ht, int depth, intptr_t bundle_pos)
{
char *s;
Scheme_Object *v, *p;
int len, left, right;
intptr_t got, offset;
if (depth > 32)
scheme_read_err(port, "read (compiled): linklet-module directory tree is imbalanced");
len = read_simple_number_from_port(port);
if (len < 0)
scheme_read_err(port, "read (compiled): linklet-bundle name read failed");
s = scheme_malloc_atomic(len + 1);
got = scheme_get_bytes(port, len, s, 0);
if (got != len)
v = NULL;
else {
s[len] = 0;
v = scheme_string_to_symbol_path(s, len);
for (p = v; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) {
if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) {
v = NULL;
break;
}
}
if (v && scheme_hash_get(ht, v))
v = NULL;
}
if (!v)
scheme_read_err(port, "read (compiled): linklet-bundle name read failed");
offset = read_simple_number_from_port(port); /* offset */
(void)read_simple_number_from_port(port); /* length */
scheme_hash_set(ht, scheme_make_integer(offset+bundle_pos), v);
left = read_simple_number_from_port(port);
right = read_simple_number_from_port(port);
if (left)
read_linklet_directory(port, ht, depth+1, bundle_pos);
if (right)
read_linklet_directory(port, ht, depth+1, bundle_pos);
}
Scheme_Object *wrap_as_linklet_directory(Scheme_Hash_Tree *ht)
{
Scheme_Object *v;
v = scheme_alloc_small_object();
v->type = scheme_linklet_directory_type;
SCHEME_PTR_VAL(v) = (Scheme_Object *)ht;
return v;
}
static Scheme_Object *bundle_list_to_hierarchical_directory(Scheme_Object *bundles)
{
Scheme_Hash_Tree *accum, *next;
Scheme_Object *p, *v, *path, *stack;
int len, prev_len, i;
/* The bundles list is in post-order, so we can build directories
bottom-up */
prev_len = 0;
stack = scheme_null;
accum = scheme_make_hash_tree(0);
while (1) {
MZ_ASSERT(SCHEME_PAIRP(bundles));
p = SCHEME_CAR(bundles);
path = SCHEME_CAR(p);
v = SCHEME_CDR(p);
MZ_ASSERT(SCHEME_FALSEP(v) || SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type));
len = scheme_list_length(path);
if (len < prev_len)
return NULL;
while (len > prev_len + 1) {
stack = scheme_make_pair((Scheme_Object *)accum, stack);
prev_len++;
accum = scheme_make_hash_tree(0);
}
for (i = 0; i < prev_len - 1; i++) {
path = SCHEME_CDR(path);
}
if (len == prev_len) {
if (!SCHEME_FALSEP(v)) {
MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type));
accum = scheme_hash_tree_set(accum, scheme_false, v);
}
if (!len)
return wrap_as_linklet_directory(accum);
next = (Scheme_Hash_Tree *)SCHEME_CAR(stack);
stack = SCHEME_CDR(stack);
next = scheme_hash_tree_set(next, SCHEME_CAR(path), wrap_as_linklet_directory(accum));
prev_len--;
accum = next;
} else {
MZ_ASSERT(len == prev_len + 1);
if (prev_len)
path = SCHEME_CDR(path);
next = scheme_make_hash_tree(0);
if (!SCHEME_FALSEP(v)) {
MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type));
next = scheme_hash_tree_set(next, scheme_false, v);
}
accum = scheme_hash_tree_set(accum, SCHEME_CAR(path), wrap_as_linklet_directory(next));
}
bundles = SCHEME_CDR(bundles);
if (SCHEME_NULLP(bundles))
return NULL;
}
}
/* "#~" has been read */
static Scheme_Object *read_compiled(Scheme_Object *port,
ReadParams *params)
{
Scheme_Hash_Table *directory = NULL; /* position -> symbol-path */
Scheme_Object *bundles = scheme_null; /* list of (cons symbol-path bundle-or-#f) */
intptr_t bundle_pos;
int bundles_to_read = 0;
Scheme_Object *result;
intptr_t size, shared_size, got, offset;
CPort *rp;
@ -3849,381 +3621,222 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
intptr_t *so;
Scheme_Load_Delay *delay_info;
Scheme_Hash_Table **local_ht;
int all_short, mode;
int all_short;
int perma_cache = use_perma_cache;
Scheme_Object *dir;
Scheme_Config *config;
char hash_code[20];
Scheme_Performance_State perf_state;
scheme_performance_record_start(&perf_state);
while (1) {
bundle_pos = SCHEME_INT_VAL(scheme_file_position(1, &port)) - 2; /* -2 for "#~" */
/* Check version: */
size = scheme_get_byte(port);
{
char buf[64];
if (size < 0) size = 0;
if (size > 63) size = 63;
got = scheme_get_bytes(port, size, buf, 0);
buf[got] = 0;
if (!params->skip_zo_vers_check)
if (strcmp(buf, MZSCHEME_VERSION))
scheme_read_err(port,
"read (compiled): wrong version for compiled code\n"
" compiled version: %s\n"
" expected version: %s",
(buf[0] ? buf : "???"), MZSCHEME_VERSION);
}
/* Check vm: */
size = scheme_get_byte(port);
{
char buf[64];
/* Allow delays? */
if (delay_load_info) {
delay_info = MALLOC_ONE_RT(Scheme_Load_Delay);
SET_REQUIRED_TAG(delay_info->type = scheme_rt_delay_load_info);
delay_info->path = delay_load_info;
} else
delay_info = NULL;
if (size < 0) size = 0;
if (size > 63) size = 63;
got = scheme_get_bytes(port, size, buf, 0);
buf[got] = 0;
if (!params->skip_zo_vers_check)
if (strcmp(buf, MZSCHEME_VM))
scheme_read_err(port,
"read (compiled): wrong virtual machine for compiled code\n"
" compiled version: %s\n"
" expected version: %s",
(buf[0] ? buf : "???"), MZSCHEME_VM);
}
mode = scheme_get_byte(port);
if (mode == 'D') {
/* a linklet directory */
if (directory)
scheme_read_err(port,
"read (compiled): found unexpected linklet directory nesting");
(void)read_simple_number_from_port(port); /* count */
directory = scheme_make_hash_table_equal();
read_linklet_directory(port, directory, 0, bundle_pos);
bundles_to_read = directory->count;
} else if (mode == 'B') {
/* single module or other top-level form */
/* Allow delays? */
if (params->delay_load_info) {
delay_info = MALLOC_ONE_RT(Scheme_Load_Delay);
SET_REQUIRED_TAG(delay_info->type = scheme_rt_delay_load_info);
delay_info->path = params->delay_load_info;
} else
delay_info = NULL;
/* Module hash code */
got = scheme_get_bytes(port, 20, hash_code, 0);
symtabsize = read_simple_number_from_port(port);
symtabsize = read_simple_number_from_port(port);
/* Load table mapping symtab indices to stream positions: */
/* Load table mapping symtab indices to stream positions: */
all_short = scheme_get_byte(port);
if (symtabsize < 0)
so = NULL;
else
so = (intptr_t *)scheme_malloc_fail_ok(scheme_malloc_atomic,
scheme_check_overflow(symtabsize, sizeof(intptr_t), 0));
if (!so)
scheme_read_err(port,
"read (compiled): could not allocate symbol table of size %" PRIdPTR,
symtabsize);
if ((got = scheme_get_bytes(port, (all_short ? 2 : 4) * (symtabsize - 1), (char *)so, 0))
!= ((all_short ? 2 : 4) * (symtabsize - 1)))
scheme_read_err(port,
"read (compiled): ill-formed code (bad table count: %" PRIdPTR " != %" PRIdPTR ")",
got, (all_short ? 2 : 4) * (symtabsize - 1));
{
/* This loop runs top to bottom, since sizeof(long) may be larger
than the decoded integers (but it's never shorter) */
intptr_t j, v;
unsigned char *so_c = (unsigned char *)so;
for (j = symtabsize - 1; j--; ) {
if (all_short) {
v = so_c[j * 2]
+ (so_c[j * 2 + 1] << 8);
} else {
v = so_c[j * 4]
+ (so_c[j * 4 + 1] << 8)
+ (so_c[j * 4 + 2] << 16)
+ (so_c[j * 4 + 3] << 24);
}
so[j] = v;
}
}
/* Continue reading content */
shared_size = read_simple_number_from_port(port);
size = read_simple_number_from_port(port);
if (shared_size >= size) {
scheme_read_err(port,
"read (compiled): ill-formed code (shared size %ld >= total size %ld)",
shared_size, size);
}
rp = MALLOC_ONE_RT(CPort);
SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
{
unsigned char *st;
st = (unsigned char *)scheme_malloc_fail_ok(scheme_malloc_atomic, size + 1);
rp->start = st;
}
rp->pos = 0;
{
intptr_t base;
scheme_tell_all(port, NULL, NULL, &base);
rp->base = base;
}
offset = SCHEME_INT_VAL(scheme_file_position(1, &port));
rp->orig_port = port;
rp->size = size;
if ((got = scheme_get_bytes(port, size, (char *)rp->start, 0)) != size)
scheme_read_err(port,
"read (compiled): ill-formed code (bad count: %ld != %ld"
", started at %ld)",
got, size, rp->base);
local_ht = MALLOC_N(Scheme_Hash_Table *, 1);
symtab = MALLOC_N(Scheme_Object *, symtabsize);
rp->symtab_size = symtabsize;
rp->ht = local_ht;
rp->symtab = symtab;
rp->unsafe_ok = params->can_read_unsafe;
{
Scheme_Hash_Table *se_ht;
se_ht = scheme_make_hash_table(SCHEME_hash_ptr);
rp->symtab_entries = se_ht;
if (delay_info)
delay_info->symtab_entries = se_ht;
}
config = scheme_current_config();
dir = scheme_get_param(config, MZCONFIG_LOAD_DIRECTORY);
if (SCHEME_TRUEP(dir))
dir = scheme_path_to_directory_path(dir);
rp->relto = dir;
install_byecode_hash_code(rp, hash_code);
rp->shared_offsets = so;
rp->delay_info = delay_info;
rp->symtab_refs = scheme_null;
if (!delay_info) {
/* Read shared parts: */
intptr_t j, len;
Scheme_Object *v;
len = symtabsize;
for (j = 1; j < len; j++) {
if (!symtab[j]) {
v = read_compact(rp, 0);
v = resolve_symtab_refs(v, rp);
symtab[j] = v;
} else {
if (j+1 < len)
rp->pos = so[j];
else
rp->pos = shared_size;
}
}
all_short = scheme_get_byte(port);
if (symtabsize < 0)
so = NULL;
else
so = (intptr_t *)scheme_malloc_fail_ok(scheme_malloc_atomic,
scheme_check_overflow(symtabsize, sizeof(intptr_t), 0));
if (!so)
scheme_read_err(port,
"read (compiled): could not allocate symbol table of size %" PRIdPTR,
symtabsize);
if ((got = scheme_get_bytes(port, (all_short ? 2 : 4) * (symtabsize - 1), (char *)so, 0))
!= ((all_short ? 2 : 4) * (symtabsize - 1)))
scheme_read_err(port,
"read (compiled): ill-formed code (bad table count: %" PRIdPTR " != %" PRIdPTR ")",
got, (all_short ? 2 : 4) * (symtabsize - 1));
{
/* This loop runs top to bottom, since sizeof(long) may be larger
than the decoded integers (but it's never shorter) */
intptr_t j, v;
unsigned char *so_c = (unsigned char *)so;
for (j = symtabsize - 1; j--; ) {
if (all_short) {
v = so_c[j * 2]
+ (so_c[j * 2 + 1] << 8);
} else {
scheme_reserve_file_descriptor();
rp->pos = shared_size; /* skip shared part */
delay_info->file_offset = offset;
delay_info->size = shared_size;
delay_info->symtab_size = rp->symtab_size;
delay_info->symtab = rp->symtab;
delay_info->shared_offsets = rp->shared_offsets;
delay_info->relto = rp->relto;
delay_info->unsafe_ok = rp->unsafe_ok;
delay_info->bytecode_hash = rp->bytecode_hash;
if (SAME_OBJ(delay_info->path, scheme_true))
perma_cache = 1;
if (perma_cache) {
unsigned char *cache;
cache = (unsigned char *)scheme_malloc_atomic(shared_size);
memcpy(cache, rp->start, shared_size);
delay_info->cached = cache;
delay_info->cached_port = port;
delay_info->perma_cache = 1;
}
}
/* Read main body: */
result = read_compact(rp, 1);
if (delay_info) {
if (delay_info->ut)
delay_info->ut->rp = NULL; /* clean up */
}
if (*local_ht)
scheme_read_err(port, "read (compiled): unexpected graph structure");
if (!SCHEME_HASHTRP(result))
scheme_read_err(port, "read (compiled): bundle content is not an immutable hash");
{
mzlonglong i;
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)result;
Scheme_Object *key, *val;
if (!scheme_starting_up) {
i = scheme_hash_tree_next(t, -1);
while (i != -1) {
scheme_hash_tree_index(t, i, &key, &val);
if (validate_loaded_linklet
&& SAME_TYPE(SCHEME_TYPE(val), scheme_linklet_type)
&& !((Scheme_Linklet *)val)->reject_eval)
scheme_validate_linklet(rp, (Scheme_Linklet *)val);
i = scheme_hash_tree_next(t, i);
}
}
/* If no exception, the resulting code is ok. */
/* Install module hash code, if any. This code is used to register
the module in scheme_module_execute(), and it's used to
find a registered module in the default load handler. */
{
int i;
for (i = 0; i < 20; i++) {
if (hash_code[i]) break;
}
if (i < 20) {
result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result,
hash_code_symbol,
scheme_make_sized_byte_string(hash_code, 20, 1));
}
}
}
if (!directory) {
/* Since we're loading an individual bundle, strip submodule references */
result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result, pre_symbol, NULL);
result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result, post_symbol, NULL);
}
{
Scheme_Object *v;
v = scheme_alloc_small_object();
v->type = scheme_linklet_bundle_type;
SCHEME_PTR_VAL(v) = result;
result = v;
}
if (directory) {
Scheme_Object *v;
/* Find bundle's symbol path by its starting position */
v = scheme_hash_get(directory, scheme_make_integer(bundle_pos));
if (!v)
scheme_read_err(port, "read (compiled): cannot match bundle position to linklet-directory path");
bundles = scheme_make_pair(scheme_make_pair(v, result), bundles);
bundles_to_read--;
if (!bundles_to_read) {
/* convert flattened directory into hierarchical form */
v = bundle_list_to_hierarchical_directory(bundles);
if (!v)
scheme_read_err(port, "read (compiled): bad shape for bundle-directory tree");
scheme_performance_record_end("read", &perf_state);
return v;
}
/* otherwise, continue reading bundles */
} else {
scheme_performance_record_end("read", &perf_state);
return result;
}
} else {
scheme_read_err(port, "read (compiled): found bad mode");
}
while (1) {
int c1, c2;
c1 = scheme_get_byte(port);
c2 = scheme_get_byte(port);
if ((c1 != '#') || ((c2 != '~') && (c2 != 'f')))
scheme_read_err(port,
"read (compiled): no `#~' for next linklet (%d to go) in a linklet directory",
bundles_to_read);
if (c2 == 'f') {
/* Got #f in place of a bundle */
Scheme_Object *v;
bundle_pos = SCHEME_INT_VAL(scheme_file_position(1, &port)) - 2; /* -2 for "#f" */
v = scheme_hash_get(directory, scheme_make_integer(bundle_pos));
if (!v)
scheme_read_err(port, "read (compiled): cannot match empty-bundle position to linklet-directory path");
bundles = scheme_make_pair(scheme_make_pair(v, scheme_false), bundles);
bundles_to_read--;
if (!bundles_to_read) {
/* convert flattened directory into hierarchical form */
v = bundle_list_to_hierarchical_directory(bundles);
if (!v)
scheme_read_err(port, "read (compiled): bad shape for bundle-directory tree");
scheme_performance_record_end("read", &perf_state);
return v;
}
} else {
/* continue outer loop to read next bundle */
break;
v = so_c[j * 4]
+ (so_c[j * 4 + 1] << 8)
+ (so_c[j * 4 + 2] << 16)
+ (so_c[j * 4 + 3] << 24);
}
so[j] = v;
}
}
}
Scheme_Object *scheme_read_compiled(Scheme_Object *port)
{
Scheme_Config *config;
Scheme_Object *v, *v2;
ReadParams params;
/* Continue reading content */
shared_size = read_simple_number_from_port(port);
size = read_simple_number_from_port(port);
if (shared_size >= size) {
scheme_read_err(port,
"read (compiled): ill-formed code (shared size %ld >= total size %ld)",
shared_size, size);
}
rp = MALLOC_ONE_RT(CPort);
SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
{
unsigned char *st;
st = (unsigned char *)scheme_malloc_fail_ok(scheme_malloc_atomic, size + 1);
rp->start = st;
}
rp->pos = 0;
{
intptr_t base;
scheme_tell_all(port, NULL, NULL, &base);
rp->base = base;
}
offset = SCHEME_INT_VAL(scheme_file_position(1, &port));
rp->orig_port = port;
rp->size = size;
if ((got = scheme_get_bytes(port, size, (char *)rp->start, 0)) != size)
scheme_read_err(port,
"read (compiled): ill-formed code (bad count: %ld != %ld"
", started at %ld)",
got, size, rp->base);
local_ht = MALLOC_N(Scheme_Hash_Table *, 1);
symtab = MALLOC_N(Scheme_Object *, symtabsize);
rp->symtab_size = symtabsize;
rp->ht = local_ht;
rp->symtab = symtab;
rp->unsafe_ok = can_read_unsafe;
{
Scheme_Hash_Table *se_ht;
se_ht = scheme_make_hash_table(SCHEME_hash_ptr);
rp->symtab_entries = se_ht;
if (delay_info)
delay_info->symtab_entries = se_ht;
}
config = scheme_current_config();
params.skip_zo_vers_check = 0;
dir = scheme_get_param(config, MZCONFIG_LOAD_DIRECTORY);
if (SCHEME_TRUEP(dir))
dir = scheme_path_to_directory_path(dir);
rp->relto = dir;
rp->shared_offsets = so;
rp->delay_info = delay_info;
rp->symtab_refs = scheme_null;
if (!delay_info) {
/* Read shared parts: */
intptr_t j, len;
Scheme_Object *v;
len = symtabsize;
for (j = 1; j < len; j++) {
if (!symtab[j]) {
v = read_compact(rp, 0);
v = resolve_symtab_refs(v, rp);
symtab[j] = v;
} else {
if (j+1 < len)
rp->pos = so[j];
else
rp->pos = shared_size;
}
}
} else {
scheme_reserve_file_descriptor();
rp->pos = shared_size; /* skip shared part */
delay_info->file_offset = offset;
delay_info->size = shared_size;
delay_info->symtab_size = rp->symtab_size;
delay_info->symtab = rp->symtab;
delay_info->shared_offsets = rp->shared_offsets;
delay_info->relto = rp->relto;
delay_info->unsafe_ok = rp->unsafe_ok;
delay_info->bytecode_hash = rp->bytecode_hash;
if (SAME_OBJ(delay_info->path, scheme_true))
perma_cache = 1;
if (perma_cache) {
unsigned char *cache;
cache = (unsigned char *)scheme_malloc_atomic(shared_size);
memcpy(cache, rp->start, shared_size);
delay_info->cached = cache;
delay_info->cached_port = port;
delay_info->perma_cache = 1;
}
}
/* Read main body: */
result = read_compact(rp, 1);
if (delay_info) {
if (delay_info->ut)
delay_info->ut->rp = NULL; /* clean up */
}
if (*local_ht)
scheme_read_err(port, "read (compiled): unexpected graph structure");
if (!SCHEME_HASHTRP(result))
scheme_read_err(port, "read (compiled): bundle content is not an immutable hash");
{
mzlonglong i;
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)result;
Scheme_Object *key, *val;
if (!scheme_starting_up) {
i = scheme_hash_tree_next(t, -1);
while (i != -1) {
scheme_hash_tree_index(t, i, &key, &val);
if (validate_loaded_linklet
&& SAME_TYPE(SCHEME_TYPE(val), scheme_linklet_type)
&& !((Scheme_Linklet *)val)->reject_eval)
scheme_validate_linklet(rp, (Scheme_Linklet *)val);
i = scheme_hash_tree_next(t, i);
}
}
/* If no exception, the resulting code is ok. */
}
scheme_performance_record_end("read", &perf_state);
return result;
}
Scheme_Object *scheme_read_linklet_bundle_hash(Scheme_Object *port)
{
Scheme_Config *config;
int can_read_unsafe;
Scheme_Object *delay_load_info, *v, *v2;
config = scheme_current_config();
v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
v2 = scheme_get_initial_inspector();
params.can_read_unsafe = SAME_OBJ(v, v2);
can_read_unsafe = SAME_OBJ(v, v2);
v = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO);
if (SCHEME_TRUEP(v))
params.delay_load_info = v;
delay_load_info = v;
else
params.delay_load_info = NULL;
delay_load_info = NULL;
return read_compiled(port, &params);
return read_linklet_bundle_hash(port, can_read_unsafe, delay_load_info);
}
THREAD_LOCAL_DECL(static Scheme_Load_Delay *clear_bytes_chain);
void scheme_clear_delayed_load_cache()

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1450
#define EXPECTED_PRIM_COUNT 1446
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

5
racket/src/racket/src/schpriv.h
View File

@ -2614,7 +2614,7 @@ void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port, Scheme_Objec
Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok);
Scheme_Object *scheme_read_compiled(Scheme_Object *port);
Scheme_Object *scheme_read_linklet_bundle_hash(Scheme_Object *port);
#define _scheme_eval_linked_expr(obj) scheme_do_eval(obj,-1,NULL,1)
#define _scheme_eval_linked_expr_multi(obj) scheme_do_eval(obj,-1,NULL,-1)
@ -3356,9 +3356,6 @@ void scheme_set_current_namespace_as_env(Scheme_Env *env);
Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home);
Scheme_Object *scheme_string_to_symbol_path(char *_s, intptr_t len);
char *scheme_symbol_path_to_string(Scheme_Object *p, intptr_t *_len);
/*========================================================================*/
/* errors and exceptions */
/*========================================================================*/

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "7.1.0.2"
#define MZSCHEME_VERSION "7.1.0.4"
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

6
racket/src/racket/src/startup.c
View File

@ -41,13 +41,13 @@ static Scheme_Linklet *eval_linklet_string(const char *str, intptr_t len, int ex
len = strlen(str);
port = scheme_make_sized_byte_string_input_port(str, -len); /* negative means it's constant */
expr = scheme_internal_read(port, 1, 1, -1, scheme_init_load_on_demand ? scheme_true : scheme_false);
if (extract) {
/* expr is a linklet bundle; 'startup is mapped to the linklet */
return (Scheme_Linklet *)scheme_hash_tree_get((Scheme_Hash_Tree *)SCHEME_PTR_VAL(expr),
expr = scheme_read_linklet_bundle_hash(port);
return (Scheme_Linklet *)scheme_hash_tree_get((Scheme_Hash_Tree *)expr,
scheme_intern_symbol("startup"));
} else {
expr = scheme_internal_read(port, 1, 1, -1, scheme_init_load_on_demand ? scheme_true : scheme_false);
return scheme_compile_and_optimize_linklet(scheme_datum_to_syntax(expr, scheme_false, 0),
scheme_intern_symbol("startup"));
}

1570
racket/src/racket/src/startup.inc
View File

File diff suppressed because it is too large Load Diff

437
racket/src/racket/src/stypes.h
View File

@ -54,247 +54,246 @@ enum {
perspective of the compiler */
scheme_linklet_bundle_type, /* 34 */
scheme_linklet_directory_type, /* 35 */
scheme_instance_type, /* 36 */
scheme_instance_type, /* 35 */
/* procedure types */
scheme_prim_type, /* 37 */
scheme_closed_prim_type, /* 38 */
scheme_closure_type, /* 39 */
scheme_case_closure_type, /* 40 */
scheme_cont_type, /* 41 */
scheme_escaping_cont_type, /* 42 */
scheme_proc_struct_type, /* 43 */
scheme_native_closure_type, /* 44 */
scheme_proc_chaperone_type, /* 45 */
scheme_prim_type, /* 36 */
scheme_closed_prim_type, /* 37 */
scheme_closure_type, /* 38 */
scheme_case_closure_type, /* 39 */
scheme_cont_type, /* 40 */
scheme_escaping_cont_type, /* 41 */
scheme_proc_struct_type, /* 42 */
scheme_native_closure_type, /* 43 */
scheme_proc_chaperone_type, /* 44 */
scheme_chaperone_type, /* 46 */
scheme_chaperone_type, /* 45 */
/* structure type (plus one above for procs) */
scheme_structure_type, /* 47 */
scheme_structure_type, /* 46 */
/* number types (must be together) */
scheme_integer_type, /* 48 */
scheme_bignum_type, /* 49 */
scheme_rational_type, /* 50 */
scheme_float_type, /* 51 */
scheme_double_type, /* 52 */
scheme_complex_type, /* 53 */
scheme_integer_type, /* 47 */
scheme_bignum_type, /* 48 */
scheme_rational_type, /* 49 */
scheme_float_type, /* 50 */
scheme_double_type, /* 51 */
scheme_complex_type, /* 52 */
/* other eqv?-able values (must be with numbers) */
scheme_char_type, /* 54 */
scheme_char_type, /* 53 */
/* other values */
scheme_long_double_type, /* 55 */
scheme_char_string_type, /* 56 */
scheme_byte_string_type, /* 57 */
scheme_unix_path_type, /* 58 */
scheme_windows_path_type, /* 59 */
scheme_symbol_type, /* 60 */
scheme_keyword_type, /* 61 */
scheme_null_type, /* 62 */
scheme_pair_type, /* 63 */
scheme_mutable_pair_type, /* 64 */
scheme_vector_type, /* 65 */
scheme_inspector_type, /* 66 */
scheme_input_port_type, /* 67 */
scheme_output_port_type, /* 68 */
scheme_eof_type, /* 69 */
scheme_true_type, /* 70 */
scheme_false_type, /* 71 */
scheme_void_type, /* 72 */
scheme_primitive_syntax_type, /* 73 */
scheme_macro_type, /* 74 */
scheme_box_type, /* 75 */
scheme_thread_type, /* 76 */
scheme_cont_mark_set_type, /* 77 */
scheme_sema_type, /* 78 */
scheme_long_double_type, /* 54 */
scheme_char_string_type, /* 55 */
scheme_byte_string_type, /* 56 */
scheme_unix_path_type, /* 57 */
scheme_windows_path_type, /* 58 */
scheme_symbol_type, /* 59 */
scheme_keyword_type, /* 60 */
scheme_null_type, /* 61 */
scheme_pair_type, /* 62 */
scheme_mutable_pair_type, /* 63 */
scheme_vector_type, /* 64 */
scheme_inspector_type, /* 65 */
scheme_input_port_type, /* 66 */
scheme_output_port_type, /* 67 */
scheme_eof_type, /* 68 */
scheme_true_type, /* 69 */
scheme_false_type, /* 70 */
scheme_void_type, /* 71 */
scheme_primitive_syntax_type, /* 72 */
scheme_macro_type, /* 73 */
scheme_box_type, /* 74 */
scheme_thread_type, /* 75 */
scheme_cont_mark_set_type, /* 76 */
scheme_sema_type, /* 77 */
/* hash table types (must be together for hash?
* implementation */
scheme_hash_table_type, /* 79 */
scheme_hash_tree_type, /* 80 */
scheme_eq_hash_tree_type, /* 81 */
scheme_eqv_hash_tree_type, /* 82 */
scheme_hash_tree_subtree_type, /* 83 */
scheme_hash_tree_collision_type, /* 84 */
scheme_hash_tree_indirection_type, /* 85 */
scheme_bucket_type, /* 86 */
scheme_bucket_table_type, /* 87 */
scheme_hash_table_type, /* 78 */
scheme_hash_tree_type, /* 79 */
scheme_eq_hash_tree_type, /* 80 */
scheme_eqv_hash_tree_type, /* 81 */
scheme_hash_tree_subtree_type, /* 82 */
scheme_hash_tree_collision_type, /* 83 */
scheme_hash_tree_indirection_type, /* 84 */
scheme_bucket_type, /* 85 */
scheme_bucket_table_type, /* 86 */
scheme_cpointer_type, /* 88 */
scheme_prefix_type, /* 89 */
scheme_weak_box_type, /* 90 */
scheme_ephemeron_type, /* 91 */
scheme_struct_type_type, /* 92 */
scheme_set_macro_type, /* 93 */
scheme_listener_type, /* 94 */
scheme_env_type, /* 95 */
scheme_startup_env_type, /* 96 */
scheme_config_type, /* 97 */
scheme_stx_type, /* 98 */
scheme_will_executor_type, /* 99 */
scheme_custodian_type, /* 100 */
scheme_random_state_type, /* 101 */
scheme_regexp_type, /* 102 */
scheme_subprocess_type, /* 103 */
scheme_eval_waiting_type, /* 104 */
scheme_tail_call_waiting_type, /* 105 */
scheme_undefined_type, /* 106 */
scheme_struct_property_type, /* 107 */
scheme_chaperone_property_type, /* 108 */
scheme_multiple_values_type, /* 109 */
scheme_placeholder_type, /* 110 */
scheme_table_placeholder_type, /* 111 */
scheme_svector_type, /* 112 */
scheme_resolve_prefix_type, /* 113 */
scheme_security_guard_type, /* 114 */
scheme_indent_type, /* 115 */
scheme_udp_type, /* 116 */
scheme_udp_evt_type, /* 117 */
scheme_tcp_accept_evt_type, /* 118 */
scheme_id_macro_type, /* 119 */
scheme_evt_set_type, /* 120 */
scheme_wrap_evt_type, /* 121 */
scheme_handle_evt_type, /* 122 */
scheme_replace_evt_type, /* 123 */
scheme_active_replace_evt_type, /* 124 */
scheme_nack_guard_evt_type, /* 125 */
scheme_semaphore_repost_type, /* 126 */
scheme_channel_type, /* 127 */
scheme_channel_put_type, /* 128 */
scheme_thread_resume_type, /* 129 */
scheme_thread_suspend_type, /* 130 */
scheme_thread_dead_type, /* 131 */
scheme_poll_evt_type, /* 132 */
scheme_nack_evt_type, /* 133 */
scheme_thread_set_type, /* 134 */
scheme_string_converter_type, /* 135 */
scheme_alarm_type, /* 136 */
scheme_thread_recv_evt_type, /* 137 */
scheme_thread_cell_type, /* 138 */
scheme_channel_syncer_type, /* 139 */
scheme_write_evt_type, /* 140 */
scheme_always_evt_type, /* 141 */
scheme_never_evt_type, /* 142 */
scheme_progress_evt_type, /* 143 */
scheme_place_dead_type, /* 144 */
scheme_already_comp_type, /* 145 */
scheme_readtable_type, /* 146 */
scheme_thread_cell_values_type, /* 147 */
scheme_global_ref_type, /* 148 */
scheme_cont_mark_chain_type, /* 149 */
scheme_raw_pair_type, /* 150 */
scheme_prompt_type, /* 151 */
scheme_prompt_tag_type, /* 152 */
scheme_continuation_mark_key_type, /* 153 */
scheme_delay_syntax_type, /* 154 */
scheme_cust_box_type, /* 155 */
scheme_logger_type, /* 156 */
scheme_log_reader_type, /* 157 */
scheme_noninline_proc_type, /* 158 */
scheme_future_type, /* 159 */
scheme_flvector_type, /* 160 */
scheme_extflvector_type, /* 161 */
scheme_fxvector_type, /* 162 */
scheme_place_type, /* 163 */
scheme_place_object_type, /* 164 */
scheme_place_async_channel_type, /* 165 */
scheme_place_bi_channel_type, /* 166 */
scheme_once_used_type, /* 167 */
scheme_serialized_symbol_type, /* 168 */
scheme_serialized_keyword_type, /* 169 */
scheme_serialized_structure_type, /* 170 */
scheme_fsemaphore_type, /* 171 */
scheme_serialized_tcp_fd_type, /* 172 */
scheme_serialized_file_fd_type, /* 173 */
scheme_port_closed_evt_type, /* 174 */
scheme_proc_shape_type, /* 175 */
scheme_struct_prop_proc_shape_type, /* 176 */
scheme_struct_proc_shape_type, /* 177 */
scheme_phantom_bytes_type, /* 178 */
scheme_environment_variables_type, /* 179 */
scheme_filesystem_change_evt_type, /* 180 */
scheme_ctype_type, /* 181 */
scheme_plumber_type, /* 182 */
scheme_plumber_handle_type, /* 183 */
scheme_deferred_expr_type, /* 184 */
scheme_unquoted_printing_string_type, /* 185 */
scheme_will_be_lambda_type, /* 186 */
scheme_cpointer_type, /* 87 */
scheme_prefix_type, /* 88 */
scheme_weak_box_type, /* 89 */
scheme_ephemeron_type, /* 90 */
scheme_struct_type_type, /* 91 */
scheme_set_macro_type, /* 92 */
scheme_listener_type, /* 93 */
scheme_env_type, /* 94 */
scheme_startup_env_type, /* 95 */
scheme_config_type, /* 96 */
scheme_stx_type, /* 97 */
scheme_will_executor_type, /* 98 */
scheme_custodian_type, /* 99 */
scheme_random_state_type, /* 100 */
scheme_regexp_type, /* 101 */
scheme_subprocess_type, /* 102 */
scheme_eval_waiting_type, /* 103 */
scheme_tail_call_waiting_type, /* 104 */
scheme_undefined_type, /* 105 */
scheme_struct_property_type, /* 106 */
scheme_chaperone_property_type, /* 107 */
scheme_multiple_values_type, /* 108 */
scheme_placeholder_type, /* 109 */
scheme_table_placeholder_type, /* 110 */
scheme_svector_type, /* 111 */
scheme_resolve_prefix_type, /* 112 */
scheme_security_guard_type, /* 113 */
scheme_indent_type, /* 114 */
scheme_udp_type, /* 115 */
scheme_udp_evt_type, /* 116 */
scheme_tcp_accept_evt_type, /* 117 */
scheme_id_macro_type, /* 118 */
scheme_evt_set_type, /* 119 */
scheme_wrap_evt_type, /* 120 */
scheme_handle_evt_type, /* 121 */
scheme_replace_evt_type, /* 122 */
scheme_active_replace_evt_type, /* 123 */
scheme_nack_guard_evt_type, /* 124 */
scheme_semaphore_repost_type, /* 125 */
scheme_channel_type, /* 126 */
scheme_channel_put_type, /* 127 */
scheme_thread_resume_type, /* 128 */
scheme_thread_suspend_type, /* 129 */
scheme_thread_dead_type, /* 130 */
scheme_poll_evt_type, /* 131 */
scheme_nack_evt_type, /* 132 */
scheme_thread_set_type, /* 133 */
scheme_string_converter_type, /* 134 */
scheme_alarm_type, /* 135 */
scheme_thread_recv_evt_type, /* 136 */
scheme_thread_cell_type, /* 137 */
scheme_channel_syncer_type, /* 138 */
scheme_write_evt_type, /* 139 */
scheme_always_evt_type, /* 140 */
scheme_never_evt_type, /* 141 */
scheme_progress_evt_type, /* 142 */
scheme_place_dead_type, /* 143 */
scheme_already_comp_type, /* 144 */
scheme_readtable_type, /* 145 */
scheme_thread_cell_values_type, /* 146 */
scheme_global_ref_type, /* 147 */
scheme_cont_mark_chain_type, /* 148 */
scheme_raw_pair_type, /* 149 */
scheme_prompt_type, /* 150 */
scheme_prompt_tag_type, /* 151 */
scheme_continuation_mark_key_type, /* 152 */
scheme_delay_syntax_type, /* 153 */
scheme_cust_box_type, /* 154 */
scheme_logger_type, /* 155 */
scheme_log_reader_type, /* 156 */
scheme_noninline_proc_type, /* 157 */
scheme_future_type, /* 158 */
scheme_flvector_type, /* 159 */
scheme_extflvector_type, /* 160 */
scheme_fxvector_type, /* 161 */
scheme_place_type, /* 162 */
scheme_place_object_type, /* 163 */
scheme_place_async_channel_type, /* 164 */
scheme_place_bi_channel_type, /* 165 */
scheme_once_used_type, /* 166 */
scheme_serialized_symbol_type, /* 167 */
scheme_serialized_keyword_type, /* 168 */
scheme_serialized_structure_type, /* 169 */
scheme_fsemaphore_type, /* 170 */
scheme_serialized_tcp_fd_type, /* 171 */
scheme_serialized_file_fd_type, /* 172 */
scheme_port_closed_evt_type, /* 173 */
scheme_proc_shape_type, /* 174 */
scheme_struct_prop_proc_shape_type, /* 175 */
scheme_struct_proc_shape_type, /* 176 */
scheme_phantom_bytes_type, /* 177 */
scheme_environment_variables_type, /* 178 */
scheme_filesystem_change_evt_type, /* 179 */
scheme_ctype_type, /* 180 */
scheme_plumber_type, /* 181 */
scheme_plumber_handle_type, /* 182 */
scheme_deferred_expr_type, /* 183 */
scheme_unquoted_printing_string_type, /* 184 */
scheme_will_be_lambda_type, /* 185 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 187 */
_scheme_last_normal_type_, /* 186 */
/* The remaining tags exist for GC tracing (in non-conservative
mode), but they are not needed for run-time tag tests */
scheme_rt_weak_array, /* 188 */
scheme_rt_weak_array, /* 187 */
scheme_rt_comp_env, /* 189 */
scheme_rt_constant_binding, /* 190 */
scheme_rt_resolve_info, /* 191 */
scheme_rt_unresolve_info, /* 192 */
scheme_rt_optimize_info, /* 193 */
scheme_rt_cont_mark, /* 194 */
scheme_rt_saved_stack, /* 195 */
scheme_rt_reply_item, /* 196 */
scheme_rt_ir_lambda_info, /* 197 */
scheme_rt_overflow, /* 198 */
scheme_rt_overflow_jmp, /* 199 */
scheme_rt_meta_cont, /* 200 */
scheme_rt_dyn_wind_cell, /* 201 */
scheme_rt_dyn_wind_info, /* 202 */
scheme_rt_dyn_wind, /* 203 */
scheme_rt_dup_check, /* 204 */
scheme_rt_thread_memory, /* 205 */
scheme_rt_input_file, /* 206 */
scheme_rt_input_fd, /* 207 */
scheme_rt_oskit_console_input, /* 208 */
scheme_rt_tested_input_file, /* 209 */
scheme_rt_tested_output_file, /* 210 */
scheme_rt_indexed_string, /* 211 */
scheme_rt_output_file, /* 212 */
scheme_rt_pipe, /* 213 */
scheme_rt_system_child, /* 214 */
scheme_rt_tcp, /* 215 */
scheme_rt_write_data, /* 216 */
scheme_rt_tcp_select_info, /* 217 */
scheme_rt_param_data, /* 218 */
scheme_rt_will, /* 219 */
scheme_rt_finalization, /* 220 */
scheme_rt_finalizations, /* 221 */
scheme_rt_cpp_object, /* 222 */
scheme_rt_cpp_array_object, /* 223 */
scheme_rt_stack_object, /* 224 */
scheme_thread_hop_type, /* 225 */
scheme_rt_srcloc, /* 226 */
scheme_rt_evt, /* 227 */
scheme_rt_syncing, /* 228 */
scheme_rt_comp_prefix, /* 229 */
scheme_rt_user_input, /* 230 */
scheme_rt_user_output, /* 231 */
scheme_rt_compact_port, /* 232 */
scheme_rt_read_special_dw, /* 233 */
scheme_rt_regwork, /* 234 */
scheme_rt_rx_lazy_string, /* 235 */
scheme_rt_buf_holder, /* 236 */
scheme_rt_parameterization, /* 237 */
scheme_rt_print_params, /* 238 */
scheme_rt_read_params, /* 239 */
scheme_rt_native_code, /* 240 */
scheme_rt_native_code_plus_case, /* 241 */
scheme_rt_jitter_data, /* 242 */
scheme_rt_module_exports, /* 243 */
scheme_rt_delay_load_info, /* 244 */
scheme_rt_marshal_info, /* 245 */
scheme_rt_unmarshal_info, /* 246 */
scheme_rt_runstack, /* 247 */
scheme_rt_sfs_info, /* 248 */
scheme_rt_validate_clearing, /* 249 */
scheme_rt_lightweight_cont, /* 250 */
scheme_rt_export_info, /* 251 */
scheme_rt_cont_jmp, /* 252 */
scheme_rt_letrec_check_frame, /* 253 */
scheme_rt_comp_env, /* 188 */
scheme_rt_constant_binding, /* 189 */
scheme_rt_resolve_info, /* 190 */
scheme_rt_unresolve_info, /* 191 */
scheme_rt_optimize_info, /* 192 */
scheme_rt_cont_mark, /* 193 */
scheme_rt_saved_stack, /* 194 */
scheme_rt_reply_item, /* 195 */
scheme_rt_ir_lambda_info, /* 196 */
scheme_rt_overflow, /* 197 */
scheme_rt_overflow_jmp, /* 198 */
scheme_rt_meta_cont, /* 199 */
scheme_rt_dyn_wind_cell, /* 200 */
scheme_rt_dyn_wind_info, /* 201 */
scheme_rt_dyn_wind, /* 202 */
scheme_rt_dup_check, /* 203 */
scheme_rt_thread_memory, /* 204 */
scheme_rt_input_file, /* 205 */
scheme_rt_input_fd, /* 206 */
scheme_rt_oskit_console_input, /* 207 */
scheme_rt_tested_input_file, /* 208 */
scheme_rt_tested_output_file, /* 209 */
scheme_rt_indexed_string, /* 210 */
scheme_rt_output_file, /* 211 */
scheme_rt_pipe, /* 212 */
scheme_rt_system_child, /* 213 */
scheme_rt_tcp, /* 214 */
scheme_rt_write_data, /* 215 */
scheme_rt_tcp_select_info, /* 216 */
scheme_rt_param_data, /* 217 */
scheme_rt_will, /* 218 */
scheme_rt_finalization, /* 219 */
scheme_rt_finalizations, /* 220 */
scheme_rt_cpp_object, /* 221 */
scheme_rt_cpp_array_object, /* 222 */
scheme_rt_stack_object, /* 223 */
scheme_thread_hop_type, /* 224 */
scheme_rt_srcloc, /* 225 */
scheme_rt_evt, /* 226 */
scheme_rt_syncing, /* 227 */
scheme_rt_comp_prefix, /* 228 */
scheme_rt_user_input, /* 229 */
scheme_rt_user_output, /* 230 */
scheme_rt_compact_port, /* 231 */
scheme_rt_read_special_dw, /* 232 */
scheme_rt_regwork, /* 233 */
scheme_rt_rx_lazy_string, /* 234 */
scheme_rt_buf_holder, /* 235 */
scheme_rt_parameterization, /* 236 */
scheme_rt_print_params, /* 237 */
scheme_rt_read_params, /* 238 */
scheme_rt_native_code, /* 239 */
scheme_rt_native_code_plus_case, /* 240 */
scheme_rt_jitter_data, /* 241 */
scheme_rt_module_exports, /* 242 */
scheme_rt_delay_load_info, /* 243 */
scheme_rt_marshal_info, /* 244 */
scheme_rt_unmarshal_info, /* 245 */
scheme_rt_runstack, /* 246 */
scheme_rt_sfs_info, /* 247 */
scheme_rt_validate_clearing, /* 248 */
scheme_rt_lightweight_cont, /* 249 */
scheme_rt_export_info, /* 250 */
scheme_rt_cont_jmp, /* 251 */
scheme_rt_letrec_check_frame, /* 252 */
#endif
_scheme_last_type_

2
racket/src/racket/src/type.c
View File

@ -133,7 +133,6 @@ scheme_init_type ()
set_name(scheme_linklet_type, "<linklet>");
set_name(scheme_instance_type, "<instance>");
set_name(scheme_linklet_directory_type, "<linklet-directory>");
set_name(scheme_linklet_bundle_type, "<linklet-bundle>");
set_name(scheme_eval_waiting_type, "<eval-waiting>");
@ -568,7 +567,6 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_linklet_type, linklet_val);
GC_REG_TRAV(scheme_instance_type, instance_val);
GC_REG_TRAV(scheme_linklet_directory_type, small_object);
GC_REG_TRAV(scheme_linklet_bundle_type, small_object);
GC_REG_TRAV(_scheme_ir_values_types_, bad_trav);