From 6f6d121611b5a4f7d1f2dea75930183793d26439 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 21 Nov 2018 06:44:21 -0700 Subject: [PATCH] move linklet bundle and directory to expander layer 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`. --- pkgs/base/info.rkt | 2 +- pkgs/racket-test-core/tests/racket/fasl.rktl | 14 +- racket/collects/racket/fasl.rkt | 24 +- racket/src/cs/c/configure | 6 + racket/src/cs/c/configure.ac | 6 + racket/src/cs/io.sls | 1 + racket/src/cs/linklet.sls | 39 +- racket/src/cs/linklet/read.ss | 200 +-- racket/src/cs/linklet/write.ss | 189 +- racket/src/cs/primitive/linklet.ss | 4 +- racket/src/cs/rumble.sls | 1 + racket/src/cs/rumble/extfl.ss | 5 + racket/src/cs/rumble/number.ss | 5 +- racket/src/expander/boot/handler.rkt | 6 +- racket/src/expander/boot/kernel.rkt | 1 - .../src/expander/boot/linklet-primitive.rkt | 12 +- racket/src/expander/compile/linklet.rkt | 76 + racket/src/expander/compile/module.rkt | 1 + racket/src/expander/compile/multi-top.rkt | 1 + racket/src/expander/compile/read-linklet.rkt | 177 ++ racket/src/expander/compile/recompile.rkt | 3 +- racket/src/expander/compile/top.rkt | 1 + racket/src/expander/compile/version-bytes.rkt | 8 + racket/src/expander/compile/write-linklet.rkt | 174 ++ racket/src/expander/eval/main.rkt | 1 + racket/src/expander/eval/module.rkt | 1 + racket/src/expander/eval/multi-top.rkt | 5 +- racket/src/expander/eval/reflect-compiled.rkt | 50 + racket/src/expander/eval/reflect-name.rkt | 50 +- .../src/expander/eval/reflect-submodule.rkt | 105 ++ racket/src/expander/eval/reflect.rkt | 143 +- racket/src/expander/eval/top.rkt | 1 + racket/src/expander/extract/module.rkt | 1 + racket/src/expander/main.rkt | 9 +- racket/src/expander/run/cache.rkt | 17 +- racket/src/expander/run/linklet-operation.rkt | 11 +- racket/src/expander/run/linklet.rkt | 30 +- racket/src/expander/syntax/read-syntax.rkt | 6 +- racket/src/racket/src/compile-startup.rkt | 2 +- racket/src/racket/src/linklet.c | 187 +- racket/src/racket/src/print.c | 224 +-- racket/src/racket/src/read.c | 769 ++------ racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schpriv.h | 5 +- racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/startup.c | 6 +- racket/src/racket/src/startup.inc | 1570 ++++++++++++----- racket/src/racket/src/stypes.h | 437 +++-- racket/src/racket/src/type.c | 2 - 49 files changed, 2405 insertions(+), 2189 deletions(-) create mode 100644 racket/src/expander/compile/linklet.rkt create mode 100644 racket/src/expander/compile/read-linklet.rkt create mode 100644 racket/src/expander/compile/version-bytes.rkt create mode 100644 racket/src/expander/compile/write-linklet.rkt create mode 100644 racket/src/expander/eval/reflect-compiled.rkt create mode 100644 racket/src/expander/eval/reflect-submodule.rkt diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 426f4c9dac..f00a815163 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -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])) diff --git a/pkgs/racket-test-core/tests/racket/fasl.rktl b/pkgs/racket-test-core/tests/racket/fasl.rktl index ca74504425..6dd6bd9239 100644 --- a/pkgs/racket-test-core/tests/racket/fasl.rktl +++ b/pkgs/racket-test-core/tests/racket/fasl.rktl @@ -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"))) diff --git a/racket/collects/racket/fasl.rkt b/racket/collects/racket/fasl.rkt index 56f8788cee..29149bdce7 100644 --- a/racket/collects/racket/fasl.rkt +++ b/racket/collects/racket/fasl.rkt @@ -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)) diff --git a/racket/src/cs/c/configure b/racket/src/cs/c/configure index 98dc187a70..3bfcd7df54 100755 --- a/racket/src/cs/c/configure +++ b/racket/src/cs/c/configure @@ -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="" diff --git a/racket/src/cs/c/configure.ac b/racket/src/cs/c/configure.ac index f5645f0a15..d5359fe124 100644 --- a/racket/src/cs/c/configure.ac +++ b/racket/src/cs/c/configure.ac @@ -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="" diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index d281b85fb4..95a3e3ebc8 100644 --- a/racket/src/cs/io.sls +++ b/racket/src/cs/io.sls @@ -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) diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 008bb298d1..319a8b717b 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -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)) diff --git a/racket/src/cs/linklet/read.ss b/racket/src/cs/linklet/read.ss index 0cddcfb880..f139225fa7 100644 --- a/racket/src/cs/linklet/read.ss +++ b/racket/src/cs/linklet/read.ss @@ -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 diff --git a/racket/src/cs/linklet/write.ss b/racket/src/cs/linklet/write.ss index cf6976f005..2d24f99b2d 100644 --- a/racket/src/cs/linklet/write.ss +++ b/racket/src/cs/linklet/write.ss @@ -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) (bytesbytes 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)))) diff --git a/racket/src/cs/primitive/linklet.ss b/racket/src/cs/primitive/linklet.ss index 4a9f58ec05..ca7ea47dda 100644 --- a/racket/src/cs/primitive/linklet.ss +++ b/racket/src/cs/primitive/linklet.ss @@ -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)] diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index f3eaed06dc..4298533a0c 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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!) diff --git a/racket/src/cs/rumble/extfl.ss b/racket/src/cs/rumble/extfl.ss index 4c3de043a4..e42dbada70 100644 --- a/racket/src/cs/rumble/extfl.ss +++ b/racket/src/cs/rumble/extfl.ss @@ -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 diff --git a/racket/src/cs/rumble/number.ss b/racket/src/cs/rumble/number.ss index 4f8ffb1140..0db5912056 100644 --- a/racket/src/cs/rumble/number.ss +++ b/racket/src/cs/rumble/number.ss @@ -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) diff --git a/racket/src/expander/boot/handler.rkt b/racket/src/expander/boot/handler.rkt index 045a04ea45..a4d66beff3 100644 --- a/racket/src/expander/boot/handler.rkt +++ b/racket/src/expander/boot/handler.rkt @@ -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) diff --git a/racket/src/expander/boot/kernel.rkt b/racket/src/expander/boot/kernel.rkt index d89d6a3df4..db9b9b6d8b 100644 --- a/racket/src/expander/boot/kernel.rkt +++ b/racket/src/expander/boot/kernel.rkt @@ -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 diff --git a/racket/src/expander/boot/linklet-primitive.rkt b/racket/src/expander/boot/linklet-primitive.rkt index f83c15baaa..829ea3f6d2 100644 --- a/racket/src/expander/boot/linklet-primitive.rkt +++ b/racket/src/expander/boot/linklet-primitive.rkt @@ -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)) diff --git a/racket/src/expander/compile/linklet.rkt b/racket/src/expander/compile/linklet.rkt new file mode 100644 index 0000000000..51c5ed46ec --- /dev/null +++ b/racket/src/expander/compile/linklet.rkt @@ -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)) diff --git a/racket/src/expander/compile/module.rkt b/racket/src/expander/compile/module.rkt index 4ecf255b1b..fd4dde4022 100644 --- a/racket/src/expander/compile/module.rkt +++ b/racket/src/expander/compile/module.rkt @@ -21,6 +21,7 @@ "instance.rkt" "form.rkt" "compiled-in-memory.rkt" + "linklet.rkt" "../eval/reflect.rkt" "../eval/reflect-name.rkt") diff --git a/racket/src/expander/compile/multi-top.rkt b/racket/src/expander/compile/multi-top.rkt index 6d7ad7e8bb..4327ade6c3 100644 --- a/racket/src/expander/compile/multi-top.rkt +++ b/racket/src/expander/compile/multi-top.rkt @@ -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 diff --git a/racket/src/expander/compile/read-linklet.rkt b/racket/src/expander/compile/read-linklet.rkt new file mode 100644 index 0000000000..6c6f9e2646 --- /dev/null +++ b/racket/src/expander/compile/read-linklet.rkt @@ -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))) diff --git a/racket/src/expander/compile/recompile.rkt b/racket/src/expander/compile/recompile.rkt index e52d0df53d..d140b7eba0 100644 --- a/racket/src/expander/compile/recompile.rkt +++ b/racket/src/expander/compile/recompile.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "../host/linklet.rkt" - "../eval/reflect.rkt") + "../eval/reflect.rkt" + "linklet.rkt") (provide compiled-expression-recompile) diff --git a/racket/src/expander/compile/top.rkt b/racket/src/expander/compile/top.rkt index a48453616c..4a102207d3 100644 --- a/racket/src/expander/compile/top.rkt +++ b/racket/src/expander/compile/top.rkt @@ -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" diff --git a/racket/src/expander/compile/version-bytes.rkt b/racket/src/expander/compile/version-bytes.rkt new file mode 100644 index 0000000000..53364a63aa --- /dev/null +++ b/racket/src/expander/compile/version-bytes.rkt @@ -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)) diff --git a/racket/src/expander/compile/write-linklet.rkt b/racket/src/expander/compile/write-linklet.rkt new file mode 100644 index 0000000000..425c2e90b7 --- /dev/null +++ b/racket/src/expander/compile/write-linklet.rkt @@ -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) (bytesbytes/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)) diff --git a/racket/src/expander/eval/main.rkt b/racket/src/expander/eval/main.rkt index d4d64dae03..041fc8e479 100644 --- a/racket/src/expander/eval/main.rkt +++ b/racket/src/expander/eval/main.rkt @@ -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" diff --git a/racket/src/expander/eval/module.rkt b/racket/src/expander/eval/module.rkt index 1462ffa239..20d50f2513 100644 --- a/racket/src/expander/eval/module.rkt +++ b/racket/src/expander/eval/module.rkt @@ -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" diff --git a/racket/src/expander/eval/multi-top.rkt b/racket/src/expander/eval/multi-top.rkt index 37909dc561..943fee14f2 100644 --- a/racket/src/expander/eval/multi-top.rkt +++ b/racket/src/expander/eval/multi-top.rkt @@ -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) diff --git a/racket/src/expander/eval/reflect-compiled.rkt b/racket/src/expander/eval/reflect-compiled.rkt new file mode 100644 index 0000000000..fcf41da829 --- /dev/null +++ b/racket/src/expander/eval/reflect-compiled.rkt @@ -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))])])) diff --git a/racket/src/expander/eval/reflect-name.rkt b/racket/src/expander/eval/reflect-name.rkt index a299f8dcbb..7d8a2a6898 100644 --- a/racket/src/expander/eval/reflect-name.rkt +++ b/racket/src/expander/eval/reflect-name.rkt @@ -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))])) diff --git a/racket/src/expander/eval/reflect-submodule.rkt b/racket/src/expander/eval/reflect-submodule.rkt new file mode 100644 index 0000000000..f68bc5e71c --- /dev/null +++ b/racket/src/expander/eval/reflect-submodule.rkt @@ -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)))) + diff --git a/racket/src/expander/eval/reflect.rkt b/racket/src/expander/eval/reflect.rkt index df21ab6739..c3373942f6 100644 --- a/racket/src/expander/eval/reflect.rkt +++ b/racket/src/expander/eval/reflect.rkt @@ -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)))) diff --git a/racket/src/expander/eval/top.rkt b/racket/src/expander/eval/top.rkt index 7c48a7bb19..eb98daa2cf 100644 --- a/racket/src/expander/eval/top.rkt +++ b/racket/src/expander/eval/top.rkt @@ -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" diff --git a/racket/src/expander/extract/module.rkt b/racket/src/expander/extract/module.rkt index 09da87efe0..c66822fd7b 100644 --- a/racket/src/expander/extract/module.rkt +++ b/racket/src/expander/extract/module.rkt @@ -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) diff --git a/racket/src/expander/main.rkt b/racket/src/expander/main.rkt index cd8e1f2a11..8fa998646e 100644 --- a/racket/src/expander/main.rkt +++ b/racket/src/expander/main.rkt @@ -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)]) diff --git a/racket/src/expander/run/cache.rkt b/racket/src/expander/run/cache.rkt index 7ed721c2fa..ae168a67e3 100644 --- a/racket/src/expander/run/cache.rkt +++ b/racket/src/expander/run/cache.rkt @@ -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) diff --git a/racket/src/expander/run/linklet-operation.rkt b/racket/src/expander/run/linklet-operation.rkt index e18eaffa64..41006dafdf 100644 --- a/racket/src/expander/run/linklet-operation.rkt +++ b/racket/src/expander/run/linklet-operation.rkt @@ -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 diff --git a/racket/src/expander/run/linklet.rkt b/racket/src/expander/run/linklet.rkt index d9f1e26092..59ba8934c9 100644 --- a/racket/src/expander/run/linklet.rkt +++ b/racket/src/expander/run/linklet.rkt @@ -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) diff --git a/racket/src/expander/syntax/read-syntax.rkt b/racket/src/expander/syntax/read-syntax.rkt index 80319dacba..372ac83fd7 100644 --- a/racket/src/expander/syntax/read-syntax.rkt +++ b/racket/src/expander/syntax/read-syntax.rkt @@ -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 diff --git a/racket/src/racket/src/compile-startup.rkt b/racket/src/racket/src/compile-startup.rkt index e8f3f70332..9c13c13268 100644 --- a/racket/src/racket/src/compile-startup.rkt +++ b/racket/src/racket/src/compile-startup.rkt @@ -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") diff --git a/racket/src/racket/src/linklet.c b/racket/src/racket/src/linklet.c index 984d121940..e3ffa6ee79 100644 --- a/racket/src/racket/src/linklet.c +++ b/racket/src/racket/src/linklet.c @@ -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) diff --git a/racket/src/racket/src/print.c b/racket/src/racket/src/print.c index 36ad963b2c..8ec7cb613a 100644 --- a/racket/src/racket/src/print.c +++ b/racket/src/racket/src/print.c @@ -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); diff --git a/racket/src/racket/src/read.c b/racket/src/racket/src/read.c index 6e7e5fc752..e7749a3ae6 100644 --- a/racket/src/racket/src/read.c +++ b/racket/src/racket/src/read.c @@ -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, ¶ms); + 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() diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index 57fbfca146..067f9f2531 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -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 diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 66db32535a..aaf5c8e10f 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -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 */ /*========================================================================*/ diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 0753acb1d4..c4bc31cbed 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -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) diff --git a/racket/src/racket/src/startup.c b/racket/src/racket/src/startup.c index 7a74cabf57..3cf468147b 100644 --- a/racket/src/racket/src/startup.c +++ b/racket/src/racket/src/startup.c @@ -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")); } diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 13dbc23ea0..4cea2a023d 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -11928,7 +11928,6 @@ static const char *startup_source = "(define-values(1/compile-linklet) compile-linklet)" "(define-values(1/recompile-linklet) recompile-linklet)" "(define-values(1/eval-linklet) eval-linklet)" -"(define-values(1/read-compiled-linklet) read-compiled-linklet)" "(define-values(1/instantiate-linklet) instantiate-linklet)" "(define-values(1/linklet-import-variables) linklet-import-variables)" "(define-values(1/linklet-export-variables) linklet-export-variables)" @@ -11940,12 +11939,9 @@ static const char *startup_source = "(define-values(1/instance-variable-value) instance-variable-value)" "(define-values(1/instance-set-variable-value!) instance-set-variable-value!)" "(define-values(1/instance-unset-variable!) instance-unset-variable!)" -"(define-values(1/linklet-directory?) linklet-directory?)" -"(define-values(1/hash->linklet-directory) hash->linklet-directory)" -"(define-values(1/linklet-directory->hash) linklet-directory->hash)" -"(define-values(1/linklet-bundle?) linklet-bundle?)" -"(define-values(1/hash->linklet-bundle) hash->linklet-bundle)" -"(define-values(1/linklet-bundle->hash) linklet-bundle->hash)" +"(define-values(1/linklet-virtual-machine-bytes) linklet-virtual-machine-bytes)" +"(define-values(1/write-linklet-bundle-hash) write-linklet-bundle-hash)" +"(define-values(1/read-linklet-bundle-hash) read-linklet-bundle-hash)" "(define-values(1/variable-reference?) variable-reference?)" "(define-values(1/variable-reference->instance) variable-reference->instance)" "(define-values(1/variable-reference-constant?) variable-reference-constant?)" @@ -26648,6 +26644,485 @@ static const char *startup_source = "(make-struct-field-accessor -ref_0 10 'post-compiled-in-memorys)" "(make-struct-field-accessor -ref_0 11 'namespace-scopes)" "(make-struct-field-accessor -ref_0 12 'purely-functional?))))" +"(define-values(fasl-small-integer-start) 100)" +"(define-values(fasl-lowest-small-integer) -10)" +"(define-values(fasl-highest-small-integer)(- 255(- fasl-small-integer-start fasl-lowest-small-integer) 1))" +" (define-values (fasl-prefix) #\"racket/fasl:\")" +"(define-values(fasl-prefix-length)(bytes-length fasl-prefix))" +"(define-values(version-bytes$1)(string->bytes/utf-8(version)))" +"(define-values(vm-bytes$1)(1/linklet-virtual-machine-bytes))" +"(define-values" +"(write-linklet-bundle)" +"(lambda(b_0 linklet-bundle->hash_0 port_0)" +"(begin" +"(begin" +" (write-bytes #\"#~\" port_0)" +"(write-bytes(bytes(bytes-length version-bytes$1)) port_0)" +"(write-bytes version-bytes$1 port_0)" +"(write-bytes(bytes(bytes-length vm-bytes$1)) port_0)" +"(write-bytes vm-bytes$1 port_0)" +" (write-bytes #\"B\" port_0)" +"(write-bytes(make-bytes 20 0) port_0)" +"(1/write-linklet-bundle-hash(linklet-bundle->hash_0 b_0) port_0)))))" +"(define-values" +"(linklet-bundle->bytes)" +"(lambda(b_0 linklet-bundle->hash_0)" +"(begin" +"(let-values(((o_0)(open-output-bytes)))" +"(begin(write-linklet-bundle b_0 linklet-bundle->hash_0 o_0)(get-output-bytes o_0))))))" +"(define-values" +"(write-linklet-directory)" +"(lambda(ld_0 linklet-directory->hash_0 linklet-bundle->hash_0 port_0)" +"(begin" +" (let-values ((() (begin (write-bytes #\"#~\" port_0) (values))))" +"(let-values((()(begin(write-byte(bytes-length version-bytes$1) port_0)(values))))" +"(let-values((()(begin(write-bytes version-bytes$1 port_0)(values))))" +"(let-values((()(begin(write-byte(bytes-length vm-bytes$1) port_0)(values))))" +"(let-values((()(begin(write-bytes vm-bytes$1 port_0)(values))))" +" (let-values ((() (begin (write-bytes #\"D\" port_0) (values))))" +"(letrec-values(((flatten-linklet-directory_0)" +"(lambda(ld_1 rev-name-prefix_0 accum_0)" +"(begin" +" 'flatten-linklet-directory" +"(let-values(((new-accum_0 saw-bundle?_0)" +"(let-values(((ht_0)(linklet-directory->hash_0 ld_1)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_0)))" +"((letrec-values(((for-loop_0)" +"(lambda(accum_1 saw-bundle?_0 i_0)" +"(begin" +" 'for-loop" +"(if i_0" +"(let-values(((key_0 value_0)" +"(hash-iterate-key+value" +" ht_0" +" i_0)))" +"(let-values(((accum_2 saw-bundle?_1)" +"(let-values(((accum_2)" +" accum_1)" +"((saw-bundle?_1)" +" saw-bundle?_0))" +"(let-values(((accum_3" +" saw-bundle?_2)" +"(let-values()" +"(if(eq?" +" key_0" +" #f)" +"(let-values()" +"(values" +"(cons" +"(cons" +"(encode-name" +" rev-name-prefix_0)" +"(linklet-bundle->bytes" +" value_0" +" linklet-bundle->hash_0))" +" accum_2)" +" #t))" +"(let-values()" +"(values" +"(flatten-linklet-directory_0" +" value_0" +"(cons" +" key_0" +" rev-name-prefix_0)" +" accum_2)" +" saw-bundle?_1))))))" +"(values" +" accum_3" +" saw-bundle?_2)))))" +"(if(not #f)" +"(for-loop_0" +" accum_2" +" saw-bundle?_1" +"(hash-iterate-next ht_0 i_0))" +"(values accum_2 saw-bundle?_1))))" +"(values accum_1 saw-bundle?_0))))))" +" for-loop_0)" +" accum_0" +" #f" +"(hash-iterate-first ht_0))))))" +"(if saw-bundle?_0" +"(let-values() new-accum_0)" +"(let-values()" +" (cons (cons (encode-name rev-name-prefix_0) #\"#f\") new-accum_0))))))))" +"(let-values(((bundles_0)" +"(list->vector" +"(let-values(((temp1_0)(flatten-linklet-directory_0 ld_0 '() '()))" +"((temp2_0)" +"(lambda(a_0 b_0)(begin 'temp2(bytesbytes/utf-8(symbol->string s_0))))" +"(let-values(((len_0)(bytes-length bstr_0)))" +"(if(< len_0 255)" +"(list(bytes len_0) bstr_0)" +"(list(bytes 255)(integer->integer-bytes len_0 4 #f #f) bstr_0))))))))" +"((letrec-values(((loop_0)" +"(lambda(rev-name_1 accum_0)" +"(begin" +" 'loop" +"(if(null? rev-name_1)" +"(let-values()(apply bytes-append accum_0))" +"(let-values()" +"(loop_0(cdr rev-name_1)(append(encode-symbol_0(car rev-name_1)) accum_0))))))))" +" loop_0)" +" rev-name_0" +" '())))))" +"(define-values" +"(compute-btree-size)" +"(lambda(bundles_0 len_0)" +"(begin" +"(let-values(((start_0) 0)((end_0) len_0)((inc_0) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_0 end_0 inc_0)))" +"((letrec-values(((for-loop_0)" +"(lambda(result_0 pos_0)" +"(begin" +" 'for-loop" +"(if(< pos_0 end_0)" +"(let-values(((i_0) pos_0))" +"(let-values(((result_1)" +"(let-values(((result_1) result_0))" +"(let-values(((result_2)" +"(let-values()" +"(+" +" result_1" +"(let-values()" +"(let-values(((nlen_0)" +"(bytes-length" +"(car" +"(vector-ref bundles_0 i_0)))))" +"(+ nlen_0(* 5 4))))))))" +"(values result_2)))))" +"(if(not #f)(for-loop_0 result_1(+ pos_0 inc_0)) result_1)))" +" result_0)))))" +" for-loop_0)" +" 0" +" start_0))))))" +"(define-values" +"(compute-btree-node-offsets)" +"(lambda(bundles_0 len_0 initial-offset_0)" +"(begin" +"(let-values(((node-offsets_0)(make-vector len_0)))" +"(begin" +"((letrec-values(((loop_0)" +"(lambda(lo_0 hi_0 offset_0)" +"(begin" +" 'loop" +"(if(= lo_0 hi_0)" +"(let-values() offset_0)" +"(let-values()" +"(let-values(((mid_0)(quotient(+ lo_0 hi_0) 2)))" +"(let-values((()(begin(vector-set! node-offsets_0 mid_0 offset_0)(values))))" +"(let-values(((nlen_0)(bytes-length(car(vector-ref bundles_0 mid_0)))))" +"(let-values(((offset_1)(+ offset_0 4 nlen_0 4 4 4 4)))" +"(let-values(((offset_2)(loop_0 lo_0 mid_0 offset_1)))" +"(loop_0(add1 mid_0) hi_0 offset_2))))))))))))" +" loop_0)" +" 0" +" len_0" +" initial-offset_0)" +" node-offsets_0)))))" +"(define-values" +"(compute-bundle-offsets)" +"(lambda(bundles_0 len_0 offset_0)" +"(begin" +"(let-values(((bundle-offsets_0)(make-vector len_0)))" +"(begin" +"((letrec-values(((loop_0)" +"(lambda(i_0 offset_1)" +"(begin" +" 'loop" +"(if(= i_0 len_0)" +"(void)" +"(let-values()" +"(begin" +"(vector-set! bundle-offsets_0 i_0 offset_1)" +"(loop_0" +"(add1 i_0)" +"(+ offset_1(bytes-length(cdr(vector-ref bundles_0 i_0))))))))))))" +" loop_0)" +" 0" +" offset_0)" +" bundle-offsets_0)))))" +"(define-values" +"(write-directory-btree)" +"(lambda(bundles_0 node-offsets_0 bundle-offsets_0 len_0 port_0)" +"(begin" +"((letrec-values(((loop_0)" +"(lambda(lo_0 hi_0)" +"(begin" +" 'loop" +"(if(= lo_0 hi_0)" +"(let-values()(void))" +"(let-values()" +"(let-values(((mid_0)(quotient(+ lo_0 hi_0) 2)))" +"(let-values(((p_0)(vector-ref bundles_0 mid_0)))" +"(let-values(((nlen_0)(bytes-length(car p_0))))" +"(begin" +"(write-int nlen_0 port_0)" +"(write-bytes(car p_0) port_0)" +"(write-int(vector-ref bundle-offsets_0 mid_0) port_0)" +"(write-int(bytes-length(cdr p_0)) port_0)" +"(if(> mid_0 lo_0)" +"(let-values()" +"(let-values(((left_0)(quotient(+ lo_0 mid_0) 2)))" +"(write-int(vector-ref node-offsets_0 left_0) port_0)))" +"(let-values()(write-int 0 port_0)))" +"(if(<(add1 mid_0) hi_0)" +"(let-values()" +"(let-values(((right_0)(quotient(+(add1 mid_0) hi_0) 2)))" +"(write-int(vector-ref node-offsets_0 right_0) port_0)))" +"(let-values()(write-int 0 port_0)))" +"(loop_0 lo_0 mid_0)" +"(loop_0(add1 mid_0) hi_0)))))))))))" +" loop_0)" +" 0" +" len_0))))" +"(define-values(write-int)(lambda(n_0 port_0)(begin(write-bytes(integer->integer-bytes n_0 4 #f #f) port_0))))" +"(define-values" +"(struct:linklet-directory linklet-directory1.1 linklet-directory? linklet-directory-ht)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'linklet-directory" +" #f" +" 1" +" 0" +" #f" +"(list" +"(cons" +" prop:custom-write" +"(lambda(ld_0 port_0 mode_0)" +"(write-linklet-directory ld_0 linklet-directory->hash linklet-bundle->hash port_0))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'linklet-directory)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'ht))))" +"(define-values" +"(struct:linklet-bundle linklet-bundle2.1 linklet-bundle? linklet-bundle-ht)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'linklet-bundle" +" #f" +" 1" +" 0" +" #f" +"(list" +"(cons" +" prop:custom-write" +"(lambda(b_0 port_0 mode_0)(write-linklet-bundle b_0 linklet-bundle->hash port_0))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'linklet-bundle)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'ht))))" +"(define-values" +"(hash->linklet-directory)" +"(lambda(ht_0)" +"(begin" +"(let-values()" +"(let-values()" +"(begin" +"(if((lambda(ht_1)" +"(if(not(impersonator? ht_1))(if(hash? ht_1)(if(immutable? ht_1)(hash-eq? ht_1) #f) #f) #f))" +" ht_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'hash->linklet-directory" +" \"(and/c hash? hash-eq? immutable? (not/c impersonator?))\"" +" ht_0)))" +"(let-values(((ht_1) ht_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_1)))" +"((letrec-values(((for-loop_0)" +"(lambda(i_0)" +"(begin" +" 'for-loop" +"(if i_0" +"(let-values(((k_0 v_0)(hash-iterate-key+value ht_1 i_0)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(not k_0)" +"(let-values()" +"(if(linklet-bundle? v_0)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'hash->linklet-directory" +" \"value for #f key is not a linklet bundle\"" +" \"value\"" +" v_0))))" +"(if(symbol? k_0)" +"(let-values()" +"(if(linklet-directory? v_0)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'hash->linklet-directory" +" \"value for symbol key is not a linklet directory\"" +" \"value\"" +" v_0))))" +"(let-values()" +"(raise-arguments-error" +" 'hash->linklet-directory" +" \"key in given hash is not #f or a symbol\"" +" \"key\"" +" k_0)))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_0(hash-iterate-next ht_1 i_0))(values))))" +"(values))))))" +" for-loop_0)" +"(hash-iterate-first ht_1))))" +"(void)" +"(linklet-directory1.1 ht_0)))))))" +"(define-values" +"(hash->linklet-bundle)" +"(lambda(ht_0)" +"(begin" +"(let-values()" +"(let-values()" +"(begin" +"(if((lambda(ht_1)" +"(if(not(impersonator? ht_1))(if(hash? ht_1)(if(immutable? ht_1)(hash-eq? ht_1) #f) #f) #f))" +" ht_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'hash->linklet-bundle" +" \"(and/c hash? hash-eq? immutable? (not/c impersonator?))\"" +" ht_0)))" +"(let-values(((ht_1) ht_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_1)))" +"((letrec-values(((for-loop_0)" +"(lambda(i_0)" +"(begin" +" 'for-loop" +"(if i_0" +"(let-values(((k_0)(hash-iterate-key ht_1 i_0)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(let-values(((or-part_0)" +"(symbol? k_0)))" +"(if or-part_0" +" or-part_0" +"(fixnum? k_0)))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'hash->linklet-bundle" +" \"key in given hash is not a symbol or fixnum\"" +" \"key\"" +" k_0))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_0(hash-iterate-next ht_1 i_0))(values))))" +"(values))))))" +" for-loop_0)" +"(hash-iterate-first ht_1))))" +"(void)" +"(linklet-bundle2.1 ht_0)))))))" +"(define-values" +"(linklet-directory->hash)" +"(lambda(ld_0)" +"(begin" +"(let-values()" +"(let-values()" +"(begin" +"(if(linklet-directory? ld_0)" +"(void)" +" (let-values () (raise-argument-error 'linklet-directory->hash \"linklet-directory?\" ld_0)))" +"(linklet-directory-ht ld_0)))))))" +"(define-values" +"(linklet-bundle->hash)" +"(lambda(ld_0)" +"(begin" +"(let-values()" +"(let-values()" +"(begin" +"(if(linklet-bundle? ld_0)" +"(void)" +" (let-values () (raise-argument-error 'linklet-bundle->hash \"linklet-bundle?\" ld_0)))" +"(linklet-bundle-ht ld_0)))))))" "(define-values" "(struct:namespace-scopes namespace-scopes1.1 namespace-scopes? namespace-scopes-post namespace-scopes-other)" "(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" @@ -30568,13 +31043,13 @@ static const char *startup_source = "(hash-set" " sequence-ht_0" " 'data" -"(1/hash->linklet-directory" +"(hash->linklet-directory" "(hasheq" " #f" -"(1/hash->linklet-bundle(hasheq 0(build-shared-data-linklet cims_0 ns_0))))))" +"(hash->linklet-bundle(hasheq 0(build-shared-data-linklet cims_0 ns_0))))))" " sequence-ht_0)))" "(compiled-in-memory1.1" -"(1/hash->linklet-directory ht_0)" +"(hash->linklet-directory ht_0)" " #f" " #f" " #f" @@ -30591,7 +31066,7 @@ static const char *startup_source = "(compiled-top->compiled-tops)" "(lambda(ld_0)" "(begin" -"(let-values(((ht_0)(1/linklet-directory->hash ld_0)))" +"(let-values(((ht_0)(linklet-directory->hash ld_0)))" "(reverse$1" "(let-values(((start_0) 0)((end_0)(hash-count ht_0))((inc_0) 1))" "(begin" @@ -33502,7 +33977,7 @@ static const char *startup_source = "(let-values(((ht_2)(hash-set ht_1 'max-phase max-phase_0)))" " ht_2))))))" "(let-values(((bundle_0)" -"(1/hash->linklet-bundle" +"(hash->linklet-bundle" "(add-metadata_0" "(if serializable?_0" "(let-values()" @@ -33578,7 +34053,7 @@ static const char *startup_source = "(hash-set body-linklets_0 'link link-linklet_0))))" "(let-values() body-linklets_0))))))" "(compiled-in-memory1.1" -"(1/hash->linklet-directory(hasheq #f bundle_0))" +"(hash->linklet-directory(hasheq #f bundle_0))" " #f" " #f" " #f" @@ -35067,10 +35542,10 @@ static const char *startup_source = "(begin" "(let-values(((ld/h_0)(if(compiled-in-memory? c_0)(compiled-in-memory-linklet-directory c_0) c_0)))" "(let-values(((dh_0)" -"(if(1/linklet-directory? ld/h_0)" -"(let-values()(1/linklet-directory->hash ld/h_0))" +"(if(linklet-directory? ld/h_0)" +"(let-values()(linklet-directory->hash ld/h_0))" "(let-values() #f))))" -"(let-values(((h_0)(1/linklet-bundle->hash(if dh_0(hash-ref dh_0 #f) ld/h_0))))(values dh_0 h_0)))))))" +"(let-values(((h_0)(linklet-bundle->hash(if dh_0(hash-ref dh_0 #f) ld/h_0))))(values dh_0 h_0)))))))" "(define-values(compiled-module->h)(lambda(c_0)(begin(let-values(((dh_0 h_0)(compiled-module->dh+h c_0))) h_0))))" "(define-values" "(compiled-module->dh+h+data-instance+declaration-instance)" @@ -35498,62 +35973,48 @@ static const char *startup_source = "(let-values(((result-l7_0) result-l_0)((phaselinklet-directory-or-bundle c_0)))" +"(let-values(((or-part_0)" +"(if(linklet-directory? ld_0)" +"(if(let-values(((b_0)(hash-ref(linklet-directory->hash ld_0) #f #f)))" +"(if b_0(hash-ref(linklet-bundle->hash b_0) 'decl #f) #f))" +" #t" +" #f)" +" #f)))" +"(if or-part_0" +" or-part_0" +"(if(linklet-bundle? ld_0)(if(hash-ref(linklet-bundle->hash ld_0) 'decl #f) #t #f) #f)))))))" +"(define-values" "(compiled->linklet-directory-or-bundle)" "(lambda(c_0)(begin(if(compiled-in-memory? c_0)(compiled-in-memory-linklet-directory c_0) c_0))))" "(define-values" -"(module-compiled-current-name)" +"(normalize-to-linklet-directory)" "(lambda(c_0)" "(begin" -"(let-values(((ld_0)(compiled->linklet-directory-or-bundle c_0)))" -"(let-values(((b_0)(if(1/linklet-bundle? ld_0) ld_0(hash-ref(1/linklet-directory->hash ld_0) #f))))" -"(hash-ref(1/linklet-bundle->hash b_0) 'name))))))" -"(define-values" -"(module-compiled-immediate-name)" -"(lambda(c_0)" -"(begin(let-values(((n_0)(module-compiled-current-name c_0)))(if(pair? n_0)(car(reverse$1 n_0)) n_0)))))" -"(define-values" -"(change-module-name)" -"(lambda(c_0 name_0 prefix_0)" -"(begin" -"(let-values(((full-name_0)(if(null? prefix_0) name_0(append prefix_0(list name_0)))))" -"(let-values(((next-prefix_0)(if(null? prefix_0)(list name_0) full-name_0)))" -"(let-values(((recur_0)" -"(lambda(sub-c_0 name_1)" -"(begin" -" 'recur" -"(if(equal?(module-compiled-current-name sub-c_0)(append next-prefix_0(list name_1)))" -" sub-c_0" -"(change-module-name sub-c_0 name_1 next-prefix_0))))))" -"(if(compiled-in-memory? c_0)" +"(if(linklet-directory?(compiled->linklet-directory-or-bundle c_0))" +"(let-values() c_0)" +"(if(linklet-bundle? c_0)" +"(let-values()(hash->linklet-directory(hasheq #f c_0)))" "(let-values()" -"(let-values(((change-submodule-name_0)" -"(lambda(sub-c_0)" -"(begin" -" 'change-submodule-name" -"(recur_0 sub-c_0(module-compiled-immediate-name sub-c_0))))))" -"(let-values(((pre-compiled-in-memorys_0)" -"(map2 change-submodule-name_0(compiled-in-memory-pre-compiled-in-memorys c_0))))" -"(let-values(((post-compiled-in-memorys_0)" -"(map2 change-submodule-name_0(compiled-in-memory-post-compiled-in-memorys c_0))))" "(let-values(((the-struct_0) c_0))" "(if(compiled-in-memory? the-struct_0)" -"(let-values(((pre-compiled-in-memorys8_0) pre-compiled-in-memorys_0)" -"((post-compiled-in-memorys9_0) post-compiled-in-memorys_0)" -"((linklet-directory10_0)" -"(let-values(((temp11_0)" -"(update-one-name" -"(let-values(((ld_0)" -"(compiled->linklet-directory-or-bundle c_0)))" -"(if(1/linklet-bundle? ld_0)" -" ld_0" -"(hash-ref(1/linklet-directory->hash ld_0) #f)))" -" full-name_0))" -"((temp12_0)(symbol? full-name_0))" -"((temp13_0)" -"(append pre-compiled-in-memorys_0 post-compiled-in-memorys_0)))" -"(rebuild-linklet-directory5.1 temp12_0 temp11_0 temp13_0))))" +"(let-values(((linklet-directory1_0)" +"(normalize-to-linklet-directory(compiled-in-memory-linklet-directory c_0))))" "(compiled-in-memory1.1" -" linklet-directory10_0" +" linklet-directory1_0" "(compiled-in-memory-original-self the-struct_0)" "(compiled-in-memory-requires the-struct_0)" "(compiled-in-memory-provides the-struct_0)" @@ -35562,131 +36023,11 @@ static const char *startup_source = "(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_0)" "(compiled-in-memory-mpis the-struct_0)" "(compiled-in-memory-syntax-literals the-struct_0)" -" pre-compiled-in-memorys8_0" -" post-compiled-in-memorys9_0" +"(compiled-in-memory-pre-compiled-in-memorys the-struct_0)" +"(compiled-in-memory-post-compiled-in-memorys the-struct_0)" "(compiled-in-memory-namespace-scopes the-struct_0)" "(compiled-in-memory-purely-functional? the-struct_0)))" -" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_0)))))))" -"(if(1/linklet-directory? c_0)" -"(let-values()" -"(1/hash->linklet-directory" -"(let-values(((ht_0)(1/linklet-directory->hash c_0)))" -"(begin" -"(if(variable-reference-from-unsafe?(#%variable-reference))" -"(void)" -"(let-values()(check-in-hash ht_0)))" -"((letrec-values(((for-loop_0)" -"(lambda(table_0 i_0)" -"(begin" -" 'for-loop" -"(if i_0" -"(let-values(((key_0 val_0)(hash-iterate-key+value ht_0 i_0)))" -"(let-values(((table_1)" -"(let-values(((table_1) table_0))" -"(let-values(((table_2)" -"(let-values()" -"(let-values(((key_1 val_1)" -"(let-values()" -"(values" -" key_0" -"(if(not key_0)" -"(update-one-name" -" val_0" -" full-name_0)" -"(recur_0" -" val_0" -" key_0))))))" -"(hash-set table_1 key_1 val_1)))))" -"(values table_2)))))" -"(if(not #f)" -"(for-loop_0 table_1(hash-iterate-next ht_0 i_0))" -" table_1)))" -" table_0)))))" -" for-loop_0)" -" '#hasheq()" -"(hash-iterate-first ht_0))))))" -"(let-values()(update-one-name c_0 full-name_0))))))))))" -"(define-values" -"(update-one-name)" -"(lambda(lb_0 name_0)(begin(1/hash->linklet-bundle(hash-set(1/linklet-bundle->hash lb_0) 'name name_0)))))" -"(define-values" -"(rebuild-linklet-directory5.1)" -"(lambda(bundle-ok?1_0 main3_0 submods4_0)" -"(begin" -" 'rebuild-linklet-directory5" -"(let-values(((main_0) main3_0))" -"(let-values(((submods_0) submods4_0))" -"(let-values(((bundle-ok?_0) bundle-ok?1_0))" -"(let-values()" -"(if(if(null? submods_0) bundle-ok?_0 #f)" -" main_0" -"(1/hash->linklet-directory" -"(hash-set" -"(let-values(((lst_0) submods_0))" -"(begin" -"(if(variable-reference-from-unsafe?(#%variable-reference))" -"(void)" -"(let-values()(check-list lst_0)))" -"((letrec-values(((for-loop_0)" -"(lambda(ht_0 lst_1)" -"(begin" -" 'for-loop" -"(if(pair? lst_1)" -"(let-values(((submod_0)(unsafe-car lst_1))" -"((rest_0)(unsafe-cdr lst_1)))" -"(let-values(((ht_1)" -"(let-values(((ht_1) ht_0))" -"(let-values(((ht_2)" -"(let-values()" -"(let-values(((name_0)" -"(module-compiled-immediate-name" -" submod_0)))" -"(if(hash-ref ht_1 name_0 #f)" -"(let-values()" -"(raise-arguments-error" -" 'module-compiled-submodules" -" \"change would result in duplicate submodule name\"" -" \"name\"" -" name_0))" -"(let-values()" -"(hash-set" -" ht_1" -" name_0" -"(compiled->linklet-directory-or-bundle" -" submod_0))))))))" -"(values ht_2)))))" -"(if(not #f)(for-loop_0 ht_1 rest_0) ht_1)))" -" ht_0)))))" -" for-loop_0)" -" '#hasheq()" -" lst_0)))" -" #f" -" main_0))))))))))" -"(define-values" -"(1/compiled-expression?)" -"(lambda(c_0)" -"(begin" -" 'compiled-expression?" -"(let-values(((or-part_0)(compiled-in-memory? c_0)))" -"(if or-part_0" -" or-part_0" -"(let-values(((or-part_1)(1/linklet-directory? c_0)))(if or-part_1 or-part_1(1/linklet-bundle? c_0))))))))" -"(define-values" -"(1/compiled-module-expression?)" -"(lambda(c_0)" -"(begin" -" 'compiled-module-expression?" -"(let-values(((ld_0)(compiled->linklet-directory-or-bundle c_0)))" -"(let-values(((or-part_0)" -"(if(1/linklet-directory? ld_0)" -"(if(let-values(((b_0)(hash-ref(1/linklet-directory->hash ld_0) #f #f)))" -"(if b_0(hash-ref(1/linklet-bundle->hash b_0) 'decl #f) #f))" -" #t" -" #f)" -" #f)))" -"(if or-part_0" -" or-part_0" -"(if(1/linklet-bundle? ld_0)(if(hash-ref(1/linklet-bundle->hash ld_0) 'decl #f) #t #f) #f)))))))" +" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_0)))))))))" "(define-values" "(1/module-compiled-name)" "(let-values()" @@ -35727,6 +36068,169 @@ static const char *startup_source = "(let-values(((r_0)(reverse$1 name_0)))(values(car r_0)(reverse$1(cdr r_0)))))))" "(change-module-name c_0 i-name_0 prefix_0)))))))))" "(define-values" +"(module-compiled-current-name)" +"(lambda(c_0)" +"(begin" +"(let-values(((ld_0)(compiled->linklet-directory-or-bundle c_0)))" +"(let-values(((b_0)(if(linklet-bundle? ld_0) ld_0(hash-ref(linklet-directory->hash ld_0) #f))))" +"(hash-ref(linklet-bundle->hash b_0) 'name))))))" +"(define-values" +"(module-compiled-immediate-name)" +"(lambda(c_0)" +"(begin(let-values(((n_0)(module-compiled-current-name c_0)))(if(pair? n_0)(car(reverse$1 n_0)) n_0)))))" +"(define-values" +"(change-module-name)" +"(lambda(c_0 name_0 prefix_0)" +"(begin" +"(let-values(((full-name_0)(if(null? prefix_0) name_0(append prefix_0(list name_0)))))" +"(let-values(((next-prefix_0)(if(null? prefix_0)(list name_0) full-name_0)))" +"(let-values(((recur_0)" +"(lambda(sub-c_0 name_1)" +"(begin" +" 'recur" +"(if(equal?(module-compiled-current-name sub-c_0)(append next-prefix_0(list name_1)))" +" sub-c_0" +"(change-module-name sub-c_0 name_1 next-prefix_0))))))" +"(if(compiled-in-memory? c_0)" +"(let-values()" +"(let-values(((change-submodule-name_0)" +"(lambda(sub-c_0)" +"(begin" +" 'change-submodule-name" +"(recur_0 sub-c_0(module-compiled-immediate-name sub-c_0))))))" +"(let-values(((pre-compiled-in-memorys_0)" +"(map2 change-submodule-name_0(compiled-in-memory-pre-compiled-in-memorys c_0))))" +"(let-values(((post-compiled-in-memorys_0)" +"(map2 change-submodule-name_0(compiled-in-memory-post-compiled-in-memorys c_0))))" +"(let-values(((the-struct_0) c_0))" +"(if(compiled-in-memory? the-struct_0)" +"(let-values(((pre-compiled-in-memorys9_0) pre-compiled-in-memorys_0)" +"((post-compiled-in-memorys10_0) post-compiled-in-memorys_0)" +"((linklet-directory11_0)" +"(let-values(((temp12_0)" +"(update-one-name" +"(let-values(((ld_0)" +"(compiled->linklet-directory-or-bundle c_0)))" +"(if(linklet-bundle? ld_0)" +" ld_0" +"(hash-ref(linklet-directory->hash ld_0) #f)))" +" full-name_0))" +"((temp13_0)(symbol? full-name_0))" +"((temp14_0)" +"(append pre-compiled-in-memorys_0 post-compiled-in-memorys_0)))" +"(rebuild-linklet-directory5.1 temp13_0 temp12_0 temp14_0))))" +"(compiled-in-memory1.1" +" linklet-directory11_0" +"(compiled-in-memory-original-self the-struct_0)" +"(compiled-in-memory-requires the-struct_0)" +"(compiled-in-memory-provides the-struct_0)" +"(compiled-in-memory-phase-to-link-module-uses the-struct_0)" +"(compiled-in-memory-compile-time-inspector the-struct_0)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_0)" +"(compiled-in-memory-mpis the-struct_0)" +"(compiled-in-memory-syntax-literals the-struct_0)" +" pre-compiled-in-memorys9_0" +" post-compiled-in-memorys10_0" +"(compiled-in-memory-namespace-scopes the-struct_0)" +"(compiled-in-memory-purely-functional? the-struct_0)))" +" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_0)))))))" +"(if(linklet-directory? c_0)" +"(let-values()" +"(hash->linklet-directory" +"(let-values(((ht_0)(linklet-directory->hash c_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_0)))" +"((letrec-values(((for-loop_0)" +"(lambda(table_0 i_0)" +"(begin" +" 'for-loop" +"(if i_0" +"(let-values(((key_0 val_0)(hash-iterate-key+value ht_0 i_0)))" +"(let-values(((table_1)" +"(let-values(((table_1) table_0))" +"(let-values(((table_2)" +"(let-values()" +"(let-values(((key_1 val_1)" +"(let-values()" +"(values" +" key_0" +"(if(not key_0)" +"(update-one-name" +" val_0" +" full-name_0)" +"(recur_0" +" val_0" +" key_0))))))" +"(hash-set table_1 key_1 val_1)))))" +"(values table_2)))))" +"(if(not #f)" +"(for-loop_0 table_1(hash-iterate-next ht_0 i_0))" +" table_1)))" +" table_0)))))" +" for-loop_0)" +" '#hasheq()" +"(hash-iterate-first ht_0))))))" +"(let-values()(update-one-name c_0 full-name_0))))))))))" +"(define-values" +"(update-one-name)" +"(lambda(lb_0 name_0)(begin(hash->linklet-bundle(hash-set(linklet-bundle->hash lb_0) 'name name_0)))))" +"(define-values" +"(rebuild-linklet-directory5.1)" +"(lambda(bundle-ok?1_0 main3_0 submods4_0)" +"(begin" +" 'rebuild-linklet-directory5" +"(let-values(((main_0) main3_0))" +"(let-values(((submods_0) submods4_0))" +"(let-values(((bundle-ok?_0) bundle-ok?1_0))" +"(let-values()" +"(if(if(null? submods_0) bundle-ok?_0 #f)" +"(let-values() main_0)" +"(let-values()" +"(hash->linklet-directory" +"(hash-set" +"(let-values(((lst_0) submods_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_0)))" +"((letrec-values(((for-loop_0)" +"(lambda(ht_0 lst_1)" +"(begin" +" 'for-loop" +"(if(pair? lst_1)" +"(let-values(((submod_0)(unsafe-car lst_1))" +"((rest_0)(unsafe-cdr lst_1)))" +"(let-values(((ht_1)" +"(let-values(((ht_1) ht_0))" +"(let-values(((ht_2)" +"(let-values()" +"(let-values(((name_0)" +"(module-compiled-immediate-name" +" submod_0)))" +"(if(hash-ref ht_1 name_0 #f)" +"(let-values()" +"(raise-arguments-error" +" 'module-compiled-submodules" +" \"change would result in duplicate submodule name\"" +" \"name\"" +" name_0))" +"(let-values()" +"(hash-set" +" ht_1" +" name_0" +"(compiled->linklet-directory-or-bundle" +" submod_0))))))))" +"(values ht_2)))))" +"(if(not #f)(for-loop_0 ht_1 rest_0) ht_1)))" +" ht_0)))))" +" for-loop_0)" +" '#hasheq()" +" lst_0)))" +" #f" +" main_0)))))))))))" +"(define-values" "(1/module-compiled-submodules)" "(let-values()" "(let-values()" @@ -35744,10 +36248,10 @@ static const char *startup_source = "(compiled-in-memory-pre-compiled-in-memorys c_0)" "(compiled-in-memory-post-compiled-in-memorys c_0)))" "(let-values()" -"(if(1/linklet-directory? c_0)" +"(if(linklet-directory? c_0)" "(let-values()" -"(let-values(((ht_0)(1/linklet-directory->hash c_0)))" -"(let-values(((bh_0)(1/linklet-bundle->hash(hash-ref ht_0 #f))))" +"(let-values(((ht_0)(linklet-directory->hash c_0)))" +"(let-values(((bh_0)(linklet-bundle->hash(hash-ref ht_0 #f))))" "(let-values(((names_0)(hash-ref bh_0(if non-star?_0 'pre 'post) null)))" "(reverse$1" "(let-values(((lst_0) names_0))" @@ -35787,7 +36291,7 @@ static const char *startup_source = "(let-values()" " (raise-argument-error 'module-compiled-submodules \"(listof compiled-module-expression?)\" submods_0)))" "(if(if(null? submods_0)" -"(let-values(((or-part_0)(1/linklet-bundle?(compiled->linklet-directory-or-bundle c_0))))" +"(let-values(((or-part_0)(linklet-bundle?(compiled->linklet-directory-or-bundle c_0))))" "(if or-part_0" " or-part_0" "(if(compiled-in-memory? c_0)" @@ -35808,23 +36312,23 @@ static const char *startup_source = "(fixup-submodule-names" "(let-values(((the-struct_0) n-c_0))" "(if(compiled-in-memory? the-struct_0)" -"(let-values(((pre-compiled-in-memorys3_0) pre-compiled-in-memorys_0)" -"((post-compiled-in-memorys4_0) post-compiled-in-memorys_0)" -"((linklet-directory5_0)" -"(let-values(((temp6_0)" +"(let-values(((pre-compiled-in-memorys2_0) pre-compiled-in-memorys_0)" +"((post-compiled-in-memorys3_0) post-compiled-in-memorys_0)" +"((linklet-directory4_0)" +"(let-values(((temp5_0)" "(reset-submodule-names" "(hash-ref" -"(1/linklet-directory->hash" +"(linklet-directory->hash" "(compiled->linklet-directory-or-bundle n-c_0))" " #f)" " non-star?_0" " submods_0))" -"((temp7_0)(symbol?(module-compiled-current-name c_0)))" -"((temp8_0)" +"((temp6_0)(symbol?(module-compiled-current-name c_0)))" +"((temp7_0)" "(append pre-compiled-in-memorys_0 post-compiled-in-memorys_0)))" -"(rebuild-linklet-directory5.1 temp7_0 temp6_0 temp8_0))))" +"(rebuild-linklet-directory5.1 temp6_0 temp5_0 temp7_0))))" "(compiled-in-memory1.1" -" linklet-directory5_0" +" linklet-directory4_0" "(compiled-in-memory-original-self the-struct_0)" "(compiled-in-memory-requires the-struct_0)" "(compiled-in-memory-provides the-struct_0)" @@ -35833,28 +36337,35 @@ static const char *startup_source = "(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_0)" "(compiled-in-memory-mpis the-struct_0)" "(compiled-in-memory-syntax-literals the-struct_0)" -" pre-compiled-in-memorys3_0" -" post-compiled-in-memorys4_0" +" pre-compiled-in-memorys2_0" +" post-compiled-in-memorys3_0" "(compiled-in-memory-namespace-scopes the-struct_0)" "(compiled-in-memory-purely-functional? the-struct_0)))" " (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_0))))))))" "(let-values()" "(let-values(((n-c_0)(normalize-to-linklet-directory c_0)))" "(fixup-submodule-names" -"(let-values(((temp9_0)" +"(let-values(((temp8_0)" "(reset-submodule-names" -"(hash-ref" -"(1/linklet-directory->hash(compiled->linklet-directory-or-bundle n-c_0))" -" #f)" +"(hash-ref(linklet-directory->hash(compiled->linklet-directory-or-bundle n-c_0)) #f)" " non-star?_0" " submods_0))" -"((temp10_0)" +"((temp9_0)" "(map2" " compiled->linklet-directory-or-bundle" "(append" "(if non-star?_0 submods_0(1/module-compiled-submodules c_0 #t))" "(if non-star?_0(1/module-compiled-submodules c_0 #f) submods_0)))))" -"(rebuild-linklet-directory5.1 #f temp9_0 temp10_0)))))))))))))" +"(rebuild-linklet-directory5.1 #f temp8_0 temp9_0)))))))))))))" +"(define-values" +"(fixup-submodule-names)" +"(lambda(c_0)(begin(1/module-compiled-name c_0(1/module-compiled-name c_0)))))" +"(define-values" +"(reset-submodule-names)" +"(lambda(b_0 pre?_0 submods_0)" +"(begin" +"(hash->linklet-bundle" +"(hash-set(linklet-bundle->hash b_0)(if pre?_0 'pre 'post)(map2 module-compiled-immediate-name submods_0))))))" "(define-values" "(1/module-compiled-language-info)" "(lambda(c_0)" @@ -35980,46 +36491,6 @@ static const char *startup_source = "(values))))" "(let-values(((h_0)(compiled-module->h c_0)))(hash-ref h_0 'cross-phase-persistent? #f))))))))" "(define-values" -"(normalize-to-linklet-directory)" -"(lambda(c_0)" -"(begin" -"(if(1/linklet-directory?(compiled->linklet-directory-or-bundle c_0))" -"(let-values() c_0)" -"(if(1/linklet-bundle? c_0)" -"(let-values()(1/hash->linklet-directory(hasheq #f c_0)))" -"(let-values()" -"(let-values(((the-struct_0) c_0))" -"(if(compiled-in-memory? the-struct_0)" -"(let-values(((linklet-directory16_0)" -"(normalize-to-linklet-directory(compiled-in-memory-linklet-directory c_0))))" -"(compiled-in-memory1.1" -" linklet-directory16_0" -"(compiled-in-memory-original-self the-struct_0)" -"(compiled-in-memory-requires the-struct_0)" -"(compiled-in-memory-provides the-struct_0)" -"(compiled-in-memory-phase-to-link-module-uses the-struct_0)" -"(compiled-in-memory-compile-time-inspector the-struct_0)" -"(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_0)" -"(compiled-in-memory-mpis the-struct_0)" -"(compiled-in-memory-syntax-literals the-struct_0)" -"(compiled-in-memory-pre-compiled-in-memorys the-struct_0)" -"(compiled-in-memory-post-compiled-in-memorys the-struct_0)" -"(compiled-in-memory-namespace-scopes the-struct_0)" -"(compiled-in-memory-purely-functional? the-struct_0)))" -" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_0)))))))))" -"(define-values" -"(fixup-submodule-names)" -"(lambda(c_0)(begin(1/module-compiled-name c_0(1/module-compiled-name c_0)))))" -"(define-values" -"(reset-submodule-names)" -"(lambda(b_0 pre?_0 submods_0)" -"(begin" -"(1/hash->linklet-bundle" -"(hash-set" -"(1/linklet-bundle->hash b_0)" -"(if pre?_0 'pre 'post)" -"(map2 module-compiled-immediate-name submods_0))))))" -"(define-values" "(compile-module11.1)" "(lambda(force-linklet-directory?1_0" " modules-being-compiled3_0" @@ -36847,7 +37318,7 @@ static const char *startup_source = " 'module->namespace" " 'empty)" " bundle_11)))" -"(1/hash->linklet-bundle" +"(hash->linklet-bundle" " bundle_12))))))))))))))))" "(let-values(((ld_0)" "(if(if(null?" @@ -36860,7 +37331,7 @@ static const char *startup_source = " #f)" "(let-values() bundle_0)" "(let-values()" -"(1/hash->linklet-directory" +"(hash->linklet-directory" "(let-values(((lst_0)" "(append" " pre-submodules_0" @@ -36976,11 +37447,11 @@ static const char *startup_source = "(1/module-path-index-resolve" " sm-self_0)" "(let-values(((ht_0)" -"(1/linklet-bundle->hash" -"(if(1/linklet-directory?" +"(linklet-bundle->hash" +"(if(linklet-directory?" " ld_0)" "(hash-ref" -"(1/linklet-directory->hash" +"(linklet-directory->hash" " ld_0)" " #f)" " ld_0))))" @@ -37077,10 +37548,10 @@ static const char *startup_source = "(if(1/compiled-expression? c_0)" "(void)" " (let-values () (raise-argument-error 'compiled-expression-recompile \"compiled-expression?\" c_0)))" -"(if(1/linklet-bundle? c_0)" +"(if(linklet-bundle? c_0)" "(let-values()" -"(1/hash->linklet-bundle" -"(let-values(((ht_0)(1/linklet-bundle->hash c_0)))" +"(hash->linklet-bundle" +"(let-values(((ht_0)(linklet-bundle->hash c_0)))" "(begin" "(if(variable-reference-from-unsafe?(#%variable-reference))" "(void)" @@ -37112,10 +37583,10 @@ static const char *startup_source = " for-loop_0)" " '#hasheq()" "(hash-iterate-first ht_0))))))" -"(if(1/linklet-directory? c_0)" +"(if(linklet-directory? c_0)" "(let-values()" -"(1/hash->linklet-directory" -"(let-values(((ht_0)(1/linklet-directory->hash c_0)))" +"(hash->linklet-directory" +"(let-values(((ht_0)(linklet-directory->hash c_0)))" "(begin" "(if(variable-reference-from-unsafe?(#%variable-reference))" "(void)" @@ -37180,16 +37651,16 @@ static const char *startup_source = "(begin" " 'construct-compiled-in-memory" "(let-values(((is-module?_0)" -"(let-values(((or-part_0)(1/linklet-bundle? ld_0)))" +"(let-values(((or-part_0)(linklet-bundle? ld_0)))" "(if or-part_0" " or-part_0" "(let-values(((b_0)" "(hash-ref" -"(1/linklet-directory->hash ld_0)" +"(linklet-directory->hash ld_0)" " #f" " #f)))" "(if b_0" -"(hash-ref(1/linklet-bundle->hash b_0) 'decl #f)" +"(hash-ref(linklet-bundle->hash b_0) 'decl #f)" " #f))))))" "(let-values(((mpi-pos-vec_0)(vector-ref mpi-vector-tree_0 0)))" "(let-values(((syntax-literals-spec_0)" @@ -37480,13 +37951,13 @@ static const char *startup_source = "(extract-submodules)" "(lambda(ld_0 names-key_0)" "(begin" -"(if(1/linklet-bundle? ld_0)" +"(if(linklet-bundle? ld_0)" "(let-values() null)" "(let-values()" -"(let-values(((h_0)(1/linklet-directory->hash ld_0)))" +"(let-values(((h_0)(linklet-directory->hash ld_0)))" "(let-values(((mod_0)(hash-ref h_0 #f #f)))" " (let-values ((() (begin (if mod_0 (void) (let-values () (error \"missing main module\"))) (values))))" -"(let-values(((mh_0)(1/linklet-bundle->hash mod_0)))" +"(let-values(((mh_0)(linklet-bundle->hash mod_0)))" "(let-values(((names_0)(hash-ref mh_0 names-key_0 null)))" "(reverse$1" "(let-values(((lst_0) names_0))" @@ -37530,7 +38001,7 @@ static const char *startup_source = "(lambda(c_0)" "(begin" "(let-values(((ld_0)(if(compiled-in-memory? c_0)(compiled-in-memory-linklet-directory c_0) c_0)))" -"(if(1/linklet-directory? ld_0)(not(hash-ref(1/linklet-directory->hash ld_0) #f #f)) #f)))))" +"(if(linklet-directory? ld_0)(not(hash-ref(linklet-directory->hash ld_0) #f #f)) #f)))))" "(define-values" "(eval-top)" "(let-values(((eval-top5_0)" @@ -37575,13 +38046,13 @@ static const char *startup_source = " l_0)))))" "(if(compiled-in-memory? c_0)" "(let-values()(eval-compiled-parts_0(compiled-in-memory-pre-compiled-in-memorys c_0)))" -"(let-values(((c1_0)(hash-ref(1/linklet-directory->hash c_0) 'data #f)))" +"(let-values(((c1_0)(hash-ref(linklet-directory->hash c_0) 'data #f)))" "(if c1_0" "((lambda(data-ld_0)" "(eval-compiled-parts_0" "(create-compiled-in-memorys-using-shared-data" "(compiled-top->compiled-tops c_0)" -"(hash-ref(1/linklet-bundle->hash(hash-ref(1/linklet-directory->hash data-ld_0) #f)) 0)" +"(hash-ref(linklet-bundle->hash(hash-ref(linklet-directory->hash data-ld_0) #f)) 0)" " ns_0)))" " c1_0)" "(let-values()(eval-compiled-parts_0(compiled-top->compiled-tops c_0))))))))))" @@ -37603,7 +38074,7 @@ static const char *startup_source = "(let-values()" "(let-values(((ld_0)" "(if(compiled-in-memory? c_0)(compiled-in-memory-linklet-directory c_0) c_0)))" -"(let-values(((h_0)(1/linklet-bundle->hash(hash-ref(1/linklet-directory->hash ld_0) #f))))" +"(let-values(((h_0)(linklet-bundle->hash(hash-ref(linklet-directory->hash ld_0) #f))))" "(let-values(((link-instance_0)" "(if(compiled-in-memory? c_0)" "(link-instance-from-compiled-in-memory" @@ -45083,15 +45554,15 @@ static const char *startup_source = "(if(let-values(((or-part_0)(compiled-in-memory? s_0)))" "(if or-part_0" " or-part_0" -"(let-values(((or-part_1)(1/linklet-directory? s_0)))" -"(if or-part_1 or-part_1(1/linklet-bundle? s_0)))))" +"(let-values(((or-part_1)(linklet-directory? s_0)))" +"(if or-part_1 or-part_1(linklet-bundle? s_0)))))" "(let-values()(eval-compiled s_0 ns_0))" "(if(if(syntax?$1 s_0)" "(let-values(((or-part_0)(compiled-in-memory?(1/syntax-e s_0))))" "(if or-part_0" " or-part_0" -"(let-values(((or-part_1)(1/linklet-directory?(1/syntax-e s_0))))" -"(if or-part_1 or-part_1(1/linklet-bundle?(1/syntax-e s_0))))))" +"(let-values(((or-part_1)(linklet-directory?(1/syntax-e s_0))))" +"(if or-part_1 or-part_1(linklet-bundle?(1/syntax-e s_0))))))" " #f)" "(let-values()(eval-compiled(1/syntax->datum s_0) ns_0))" "(let-values()" @@ -57092,6 +57563,261 @@ static const char *startup_source = "(let-values(((mpi_0)(if(1/module-path-index? mod_0) mod_0(1/module-path-index-join mod_0 #f))))" "(1/module-path-index-resolve mpi_0 load?_0))))))))))" "(define-values" +"(read-linklet-bundle-or-directory)" +"(lambda(in_0)" +"(begin" +"(letrec-values(((read-linklet-or-directory_0)" +"(lambda(initial?_0)" +"(begin" +" 'read-linklet-or-directory" +"(let-values(((start-pos_0)(-(file-position in_0) 2)))" +"(let-values(((vers-len_0)(min 63(read-byte in_0))))" +"(let-values(((vers_0)(read-bytes vers-len_0 in_0)))" +"(let-values((()" +"(begin" +"(if(equal? vers_0 version-bytes$1)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'read-compiled-linklet" +" \"version mismatch\"" +" \"expected\"" +"(version)" +" \"found\"" +"(bytes->string/utf-8 vers_0 '#\\?)" +" \"in\"" +"(let-values(((n_0)(object-name in_0)))" +"(if(path? n_0)" +"(unquoted-printing-string(path->string n_0))" +" in_0)))))" +"(values))))" +"(let-values(((vm-len_0)(min 63(read-byte in_0))))" +"(let-values(((vm_0)(read-bytes vm-len_0 in_0)))" +"(let-values((()" +"(begin" +"(if(equal? vm_0 vm-bytes$1)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'read-compiled-linklet" +" \"virtual-machine mismatch\"" +" \"expected\"" +"(bytes->string/utf-8 vm-bytes$1)" +" \"found\"" +"(bytes->string/utf-8 vm_0 '#\\?)" +" \"in\"" +"(let-values(((n_0)(object-name in_0)))" +"(if(path? n_0)" +"(unquoted-printing-string(path->string n_0))" +" in_0)))))" +"(values))))" +"(let-values(((tag_0)(read-byte in_0)))" +"(if(eqv? tag_0(char->integer '#\\B))" +"(let-values()" +"(let-values(((sha-1_0)(read-bytes 20 in_0)))" +"(let-values(((b-ht_0)(1/read-linklet-bundle-hash in_0)))" +"(hash->linklet-bundle" +"(add-hash-code" +"(if initial?_0(strip-submodule-references b-ht_0) b-ht_0)" +" sha-1_0)))))" +"(if(eqv? tag_0(char->integer '#\\D))" +"(let-values()" +"(begin" +"(if initial?_0" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'read-compiled-linklet" +" \"expected a linklet bundle\")))" +"(read-bundle-directory_0 start-pos_0)))" +"(let-values()" +"(raise-arguments-error" +" 'read-compiled-linklet" +" \"expected a `B` or `D`\")))))))))))))))" +"((read-bundle-directory_0)" +"(lambda(pos_0)" +"(begin" +" 'read-bundle-directory" +"(let-values(((count_0)(read-int in_0)))" +"(let-values(((position-to-name_0)" +"((letrec-values(((loop_0)" +"(lambda(count_1 accum_0)" +"(begin" +" 'loop" +"(if(zero? count_1)" +"(let-values() accum_0)" +"(let-values()" +"(let-values(((bstr_0)" +"(read-bytes(read-int in_0) in_0)))" +"(let-values(((offset_0)(read-int in_0)))" +"(let-values(((len_0)(read-int in_0)))" +"(begin" +"(read-int in_0)" +"(read-int in_0)" +"(loop_0" +"(sub1 count_1)" +"(hash-set" +" accum_0" +" offset_0" +" bstr_0))))))))))))" +" loop_0)" +" count_0" +"(hasheqv))))" +"((letrec-values(((loop_0)" +"(lambda(count_1 accum_0)" +"(begin" +" 'loop" +"(if(zero? count_1)" +"(let-values()" +"(list->bundle-directory accum_0 hash->linklet-directory))" +"(let-values()" +"(let-values(((name_0)" +"(hash-ref" +" position-to-name_0" +"(-(file-position in_0) pos_0)" +" #f)))" +"(let-values((()" +"(begin" +"(if name_0" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'read-compiled-linklet" +" \"bundle not at an expected file position\")))" +"(values))))" +"(let-values(((bstr_0)(read-bytes 2 in_0)))" +"(let-values(((bundle_0)" +" (if (equal? #\"#~\" bstr_0)" +"(let-values()" +"(read-linklet-or-directory_0 #f))" +" (if (equal? #\"#f\" bstr_0)" +"(let-values() #f)" +"(let-values()" +"(raise-arguments-error" +" 'read-compiled-linklet" +" \"expected a `#~` or `#f` for a bundle\"))))))" +"(loop_0" +"(sub1 count_1)" +"(cons" +"(cons(decode-name name_0 0) bundle_0)" +" accum_0))))))))))))" +" loop_0)" +" count_0" +" '())))))))" +"(read-linklet-or-directory_0 #t)))))" +"(define-values(read-int)(lambda(in_0)(begin(integer-bytes->integer(read-bytes 4 in_0) #f #f))))" +"(define-values" +"(decode-name)" +"(lambda(bstr_0 pos_0)" +"(begin" +"(let-values(((blen_0)(bytes-length bstr_0)))" +"(let-values(((bad-bundle_0)" +"(lambda()" +" (begin 'bad-bundle (raise-arguments-error 'read-compiled-linklet \"malformed bundle\")))))" +"(if(= pos_0 blen_0)" +"(let-values() '())" +"(if(> pos_0 blen_0)" +"(let-values()(bad-bundle_0))" +"(let-values()" +"(let-values(((len_0)(bytes-ref bstr_0 pos_0)))" +"(begin" +"(if(>(+ pos_0 len_0 1) blen_0)(let-values()(bad-bundle_0))(void))" +"(if(= len_0 255)" +"(let-values()" +"(let-values(((len_1)(integer-bytes->integer bstr_0 #f #f(add1 pos_0)(+ pos_0 5))))" +"(begin" +"(if(>(+ pos_0 len_1 1) blen_0)(let-values()(bad-bundle_0))(void))" +"(cons" +"(string->symbol(bytes->string/utf-8(subbytes bstr_0(+ pos_0 5)(+ pos_0 5 len_1)) '#\\?))" +"(decode-name bstr_0(+ pos_0 5 len_1))))))" +"(let-values()" +"(cons" +"(string->symbol(bytes->string/utf-8(subbytes bstr_0(add1 pos_0)(+ pos_0 1 len_0)) '#\\?))" +"(decode-name bstr_0(+ pos_0 1 len_0)))))))))))))))" +"(define-values" +"(list->bundle-directory)" +"(lambda(l_0 hash->linklet-directory_0)" +"(begin" +"((letrec-values(((loop_0)" +"(lambda(l_1 prev-len_0 stack_0 accum_0)" +"(begin" +" 'loop" +"(begin" +"(if(null? l_1)" +" (let-values () (raise-arguments-error 'read-compiled-linklet \"invalid bundle sequence\"))" +"(void))" +"(let-values(((p_0)(car l_1)))" +"(let-values(((path_0)(car p_0)))" +"(let-values(((v_0)(cdr p_0)))" +"(let-values(((len_0)(length path_0)))" +"(begin" +"(if(< len_0 prev-len_0)" +"(let-values()" +" (raise-arguments-error 'read-compiled-linklet \"invalid bundle sequence\"))" +"(void))" +"((letrec-values(((sloop_0)" +"(lambda(prev-len_1 stack_1 accum_1)" +"(begin" +" 'sloop" +"(if(> len_0(add1 prev-len_1))" +"(let-values()" +"(sloop_0" +"(add1 prev-len_1)" +"(cons accum_1 stack_1)" +"(hasheq)))" +"(let-values()" +"(let-values(((path_1)" +"(list-tail" +" path_0" +"(max 0(sub1 prev-len_1)))))" +"(if(= len_0 prev-len_1)" +"(let-values()" +"(let-values(((accum_2)" +"(if v_0" +"(hash-set accum_1 #f v_0)" +" accum_1)))" +"(if(zero? len_0)" +"(hash->linklet-directory_0 accum_2)" +"(loop_0" +"(cdr l_1)" +"(sub1 prev-len_1)" +"(cdr stack_1)" +"(hash-set" +"(car stack_1)" +"(car path_1)" +"(hash->linklet-directory_0 accum_2))))))" +"(let-values()" +"(let-values(((path_2)" +"(if(positive? prev-len_1)" +"(cdr path_1)" +" path_1)))" +"(loop_0" +"(cdr l_1)" +" prev-len_1" +" stack_1" +"(hash-set" +" accum_1" +"(car path_2)" +"(hash->linklet-directory_0" +"(if v_0" +"(hasheq #f v_0)" +"(hasheq)))))))))))))))" +" sloop_0)" +" prev-len_0" +" stack_0" +" accum_0)))))))))))" +" loop_0)" +" l_0" +" 0" +" '()" +"(hasheq)))))" +"(define-values(strip-submodule-references)(lambda(b-ht_0)(begin(hash-remove(hash-remove b-ht_0 'pre) 'post))))" +"(define-values" +"(add-hash-code)" +"(lambda(b-ht_0 sha-1_0)" +"(begin" +" (if (bytes=? sha-1_0 #\"\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\") b-ht_0 (hash-set b-ht_0 'hash-code sha-1_0)))))" +"(define-values" "(read-syntax$1)" "(lambda(src_0 in_0)" "(begin" @@ -57165,7 +57891,7 @@ static const char *startup_source = "((init-c45_0) init-c_0)" "((readtable46_0) readtable_0)" "((local-graph?47_0) local-graph?_0)" -"((read-compiled-linklet48_0) 1/read-compiled-linklet)" +"((read-linklet-bundle-or-directory48_0) read-linklet-bundle-or-directory)" "((dynamic-require-reader49_0) dynamic-require-reader)" "((read-module-declared?50_0) read-module-declared?)" "((read-coerce51_0) read-coerce)" @@ -57180,7 +57906,7 @@ static const char *startup_source = " local-graph?47_0" " read-module-declared?50_0" " unsafe-undefined" -" read-compiled-linklet48_0" +" read-linklet-bundle-or-directory48_0" " readtable46_0" " recursive?42_0" " source43_0" @@ -57196,7 +57922,7 @@ static const char *startup_source = "((fail-thunk54_0) fail-thunk_0)" "((temp55_0) #t)" "((read-to-syntax56_0) read-to-syntax)" -"((read-compiled-linklet57_0) 1/read-compiled-linklet)" +"((read-linklet-bundle-or-directory57_0) read-linklet-bundle-or-directory)" "((dynamic-require-reader58_0) dynamic-require-reader)" "((read-module-declared?59_0) read-module-declared?)" "((read-coerce60_0) read-coerce)" @@ -57207,7 +57933,7 @@ static const char *startup_source = " dynamic-require-reader58_0" " temp55_0" " read-module-declared?59_0" -" read-compiled-linklet57_0" +" read-linklet-bundle-or-directory57_0" " read-to-syntax56_0" " in53_0" " fail-thunk54_0)))))" @@ -58834,20 +59560,19 @@ static const char *startup_source = "(add-core-primitive! 'read-syntax 1/read-syntax)" "(add-core-primitive! 'read-syntax/recursive 1/read-syntax/recursive)))" "(define-values" -"(declare-kernel-module!8.1)" -"(lambda(eval1_0 main-ids2_0 read-ids3_0 ns7_0)" +"(declare-kernel-module!6.1)" +"(lambda(main-ids1_0 read-ids2_0 ns5_0)" "(begin" -" 'declare-kernel-module!8" -"(let-values(((ns_0) ns7_0))" -"(let-values()" -"(let-values(((main-ids_0) main-ids2_0))" -"(let-values(((read-ids_0) read-ids3_0))" +" 'declare-kernel-module!6" +"(let-values(((ns_0) ns5_0))" +"(let-values(((main-ids_0) main-ids1_0))" +"(let-values(((read-ids_0) read-ids2_0))" "(let-values()" "(begin" -"(let-values(((temp53_0) '#%kernel)" -"((temp54_0) '#%runtime)" -"((temp55_0)(set-union primitive-ids(set-union main-ids_0 read-ids_0)))" -"((temp56_0)" +"(let-values(((temp51_0) '#%kernel)" +"((temp52_0) '#%runtime)" +"((temp53_0)(set-union primitive-ids(set-union main-ids_0 read-ids_0)))" +"((temp54_0)" "(hasheq" " 'variable-reference?" " 1/variable-reference?" @@ -58855,23 +59580,23 @@ static const char *startup_source = " 1/variable-reference-constant?" " 'variable-reference-from-unsafe?" " 1/variable-reference-from-unsafe?))" -"((ns57_0) ns_0))" -"(copy-runtime-module!26.1 unsafe-undefined temp56_0 ns57_0 #t #f temp55_0 temp54_0 temp53_0))" -"(let-values(((temp58_0) '#%kernel)((temp59_0) '(#%core #%runtime #%main #%read))((ns60_0) ns_0))" -"(declare-reexporting-module!50.1 ns60_0 #t temp58_0 temp59_0)))))))))))" +"((ns55_0) ns_0))" +"(copy-runtime-module!24.1 unsafe-undefined temp54_0 ns55_0 #t #f temp53_0 temp52_0 temp51_0))" +"(let-values(((temp56_0) '#%kernel)((temp57_0) '(#%core #%runtime #%main #%read))((ns58_0) ns_0))" +"(declare-reexporting-module!48.1 ns58_0 #t temp56_0 temp57_0))))))))))" "(define-values" -"(copy-runtime-module!26.1)" -"(lambda(alts14_0 extras15_0 namespace12_0 primitive?16_0 protected?17_0 skip13_0 to11_0 name25_0)" +"(copy-runtime-module!24.1)" +"(lambda(alts12_0 extras13_0 namespace10_0 primitive?14_0 protected?15_0 skip11_0 to9_0 name23_0)" "(begin" -" 'copy-runtime-module!26" -"(let-values(((name_0) name25_0))" -"(let-values(((to-name_0)(if(eq? to11_0 unsafe-undefined) name_0 to11_0)))" -"(let-values(((ns_0) namespace12_0))" -"(let-values(((skip-syms_0)(if(eq? skip13_0 unsafe-undefined)(seteq) skip13_0)))" -"(let-values(((alts_0)(if(eq? alts14_0 unsafe-undefined) '#hasheq() alts14_0)))" -"(let-values(((extras_0)(if(eq? extras15_0 unsafe-undefined) '#hasheq() extras15_0)))" -"(let-values(((primitive?_0) primitive?16_0))" -"(let-values(((protected?_0) protected?17_0))" +" 'copy-runtime-module!24" +"(let-values(((name_0) name23_0))" +"(let-values(((to-name_0)(if(eq? to9_0 unsafe-undefined) name_0 to9_0)))" +"(let-values(((ns_0) namespace10_0))" +"(let-values(((skip-syms_0)(if(eq? skip11_0 unsafe-undefined)(seteq) skip11_0)))" +"(let-values(((alts_0)(if(eq? alts12_0 unsafe-undefined) '#hasheq() alts12_0)))" +"(let-values(((extras_0)(if(eq? extras13_0 unsafe-undefined) '#hasheq() extras13_0)))" +"(let-values(((primitive?_0) primitive?14_0))" +"(let-values(((protected?_0) protected?15_0))" "(let-values()" "(let-values(((prims_0)(1/primitive-table name_0)))" "(let-values((()" @@ -58992,41 +59717,41 @@ static const char *startup_source = " for-loop_0)" " ht_0" "(hash-iterate-first ht_1))))))" -"(let-values(((to-name61_0) to-name_0)" -"((ht+extras62_0) ht+extras_0)" -"((ns63_0) ns_0)" -"((primitive?64_0) primitive?_0)" -"((protected?65_0) protected?_0))" -"(declare-hash-based-module!41.1" -" ns63_0" -" primitive?64_0" +"(let-values(((to-name59_0) to-name_0)" +"((ht+extras60_0) ht+extras_0)" +"((ns61_0) ns_0)" +"((primitive?62_0) primitive?_0)" +"((protected?63_0) protected?_0))" +"(declare-hash-based-module!39.1" +" ns61_0" +" primitive?62_0" " null" -" protected?65_0" +" protected?63_0" " #f" -" to-name61_0" -" ht+extras62_0)))))))))))))))))))" +" to-name59_0" +" ht+extras60_0)))))))))))))))))))" "(define-values" -"(declare-hash-based-module!41.1)" -"(lambda(namespace29_0 primitive?30_0 protected32_0 protected?31_0 register-builtin?33_0 name39_0 ht40_0)" +"(declare-hash-based-module!39.1)" +"(lambda(namespace27_0 primitive?28_0 protected30_0 protected?29_0 register-builtin?31_0 name37_0 ht38_0)" "(begin" -" 'declare-hash-based-module!41" -"(let-values(((name_0) name39_0))" -"(let-values(((ht_0) ht40_0))" -"(let-values(((ns_0) namespace29_0))" -"(let-values(((primitive?_0) primitive?30_0))" -"(let-values(((protected?_0) protected?31_0))" -"(let-values(((protected-syms_0) protected32_0))" -"(let-values(((register-builtin?_0) register-builtin?33_0))" +" 'declare-hash-based-module!39" +"(let-values(((name_0) name37_0))" +"(let-values(((ht_0) ht38_0))" +"(let-values(((ns_0) namespace27_0))" +"(let-values(((primitive?_0) primitive?28_0))" +"(let-values(((protected?_0) protected?29_0))" +"(let-values(((protected-syms_0) protected30_0))" +"(let-values(((register-builtin?_0) register-builtin?31_0))" "(let-values()" "(let-values(((mpi_0)(1/module-path-index-join(list 'quote name_0) #f)))" -"(let-values(((ns66_0) ns_0)" -"((temp67_0)" -"(let-values(((temp69_0) #t)" -"((primitive?70_0) primitive?_0)" -"((temp71_0) #t)" -"((temp72_0)(not protected?_0))" -"((mpi73_0) mpi_0)" -"((temp74_0)" +"(let-values(((ns64_0) ns_0)" +"((temp65_0)" +"(let-values(((temp67_0) #t)" +"((primitive?68_0) primitive?_0)" +"((temp69_0) #t)" +"((temp70_0)(not protected?_0))" +"((mpi71_0) mpi_0)" +"((temp72_0)" "(hasheqv" " 0" "(let-values(((ht_1) ht_0))" @@ -59060,11 +59785,11 @@ static const char *startup_source = "(void))" "(values))))" "(let-values(((binding_0)" -"(let-values(((mpi76_0)" +"(let-values(((mpi74_0)" " mpi_0)" -"((temp77_0)" +"((temp75_0)" " 0)" -"((sym78_0)" +"((sym76_0)" " sym_0))" "(make-module-binding20.1" " #f" @@ -59075,9 +59800,9 @@ static const char *startup_source = " unsafe-undefined" " 0" " unsafe-undefined" -" mpi76_0" -" temp77_0" -" sym78_0))))" +" mpi74_0" +" temp75_0" +" sym76_0))))" "(values" " sym_0" "(if(let-values(((or-part_0)" @@ -59107,7 +59832,7 @@ static const char *startup_source = " for-loop_0)" " '#hash()" "(hash-iterate-first ht_1))))))" -"((temp75_0)" +"((temp73_0)" "(lambda(data-box_0" " ns_1" " phase-shift_0" @@ -59159,35 +59884,35 @@ static const char *startup_source = "(void)))" "(void)))))" "(make-module39.1" -" temp69_0" +" temp67_0" " unsafe-undefined" " unsafe-undefined" -" temp75_0" +" temp73_0" " #f" " 0" " 0" +" temp70_0" +" unsafe-undefined" +" temp69_0" +" unsafe-undefined" +" primitive?68_0" " temp72_0" -" unsafe-undefined" -" temp71_0" -" unsafe-undefined" -" primitive?70_0" -" temp74_0" " null" -" mpi73_0" +" mpi71_0" " #f" " null" " #f)))" -"((temp68_0)(1/module-path-index-resolve mpi_0)))" -"(declare-module!58.1 #t ns66_0 temp67_0 temp68_0))))))))))))))" +"((temp66_0)(1/module-path-index-resolve mpi_0)))" +"(declare-module!58.1 #t ns64_0 temp65_0 temp66_0))))))))))))))" "(define-values" -"(declare-reexporting-module!50.1)" -"(lambda(namespace45_0 reexport?44_0 name48_0 require-names49_0)" +"(declare-reexporting-module!48.1)" +"(lambda(namespace43_0 reexport?42_0 name46_0 require-names47_0)" "(begin" -" 'declare-reexporting-module!50" -"(let-values(((name_0) name48_0))" -"(let-values(((require-names_0) require-names49_0))" -"(let-values(((reexport?_0) reexport?44_0))" -"(let-values(((ns_0) namespace45_0))" +" 'declare-reexporting-module!48" +"(let-values(((name_0) name46_0))" +"(let-values(((require-names_0) require-names47_0))" +"(let-values(((reexport?_0) reexport?42_0))" +"(let-values(((ns_0) namespace43_0))" "(let-values()" "(let-values(((mpi_0)(1/module-path-index-join(list 'quote name_0) #f)))" "(let-values(((require-mpis_0)" @@ -59224,13 +59949,13 @@ static const char *startup_source = " for-loop_0)" " null" " lst_0))))))" -"(let-values(((ns79_0) ns_0)" -"((temp80_0)" -"(let-values(((temp82_0) #t)" -"((temp83_0) #t)" -"((mpi84_0) mpi_0)" -"((temp85_0)(list(cons 0 require-mpis_0)))" -"((temp86_0)" +"(let-values(((ns77_0) ns_0)" +"((temp78_0)" +"(let-values(((temp80_0) #t)" +"((temp81_0) #t)" +"((mpi82_0) mpi_0)" +"((temp83_0)(list(cons 0 require-mpis_0)))" +"((temp84_0)" "(if reexport?_0" "(hasheqv" " 0" @@ -59330,28 +60055,28 @@ static const char *startup_source = " '#hash()" " lst_0))))" " '#hasheqv()))" -"((void87_0) void))" +"((void85_0) void))" "(make-module39.1" -" temp82_0" +" temp80_0" " unsafe-undefined" " unsafe-undefined" -" void87_0" +" void85_0" " #f" " 0" " 0" " #f" " unsafe-undefined" +" temp81_0" +" unsafe-undefined" +" #f" +" temp84_0" " temp83_0" -" unsafe-undefined" -" #f" -" temp86_0" -" temp85_0" -" mpi84_0" +" mpi82_0" " #f" " null" " #f)))" -"((temp81_0)(1/module-path-index-resolve mpi_0)))" -"(declare-module!58.1 #t ns79_0 temp80_0 temp81_0))))))))))))" +"((temp79_0)(1/module-path-index-resolve mpi_0)))" +"(declare-module!58.1 #t ns77_0 temp78_0 temp79_0))))))))))))" "(define-values" "(read-primitives)" "(hasheq" @@ -59610,8 +60335,6 @@ static const char *startup_source = " 1/recompile-linklet" " 'eval-linklet" " 1/eval-linklet" -" 'read-compiled-linklet" -" 1/read-compiled-linklet" " 'instantiate-linklet" " 1/instantiate-linklet" " 'linklet-import-variables" @@ -59634,18 +60357,12 @@ static const char *startup_source = " 1/instance-set-variable-value!" " 'instance-unset-variable!" " 1/instance-unset-variable!" -" 'linklet-directory?" -" 1/linklet-directory?" -" 'hash->linklet-directory" -" 1/hash->linklet-directory" -" 'linklet-directory->hash" -" 1/linklet-directory->hash" -" 'linklet-bundle?" -" 1/linklet-bundle?" -" 'hash->linklet-bundle" -" 1/hash->linklet-bundle" -" 'linklet-bundle->hash" -" 1/linklet-bundle->hash" +" 'linklet-virtual-machine-bytes" +" 1/linklet-virtual-machine-bytes" +" 'write-linklet-bundle-hash" +" 1/write-linklet-bundle-hash" +" 'read-linklet-bundle-hash" +" 1/read-linklet-bundle-hash" " 'variable-reference?" " 1/variable-reference?" " 'variable-reference->instance" @@ -59655,6 +60372,21 @@ static const char *startup_source = " 'variable-reference-from-unsafe?" " 1/variable-reference-from-unsafe?))" "(define-values" +"(linklet-expander-primitives)" +"(hasheq" +" 'linklet-directory?" +" linklet-directory?" +" 'linklet-directory->hash" +" linklet-directory->hash" +" 'hash->linklet-directory" +" hash->linklet-directory" +" 'linklet-bundle?" +" linklet-bundle?" +" 'linklet-bundle->hash" +" linklet-bundle->hash" +" 'hash->linklet-bundle" +" hash->linklet-bundle))" +"(define-values" "(with-module-reading-parameterization)" "(lambda(thunk_0)" "(begin" @@ -78587,36 +79319,44 @@ static const char *startup_source = "(begin" "(declare-core-module! ns_0)" "(let-values(((temp1_0) '#%read)((read-primitives2_0) read-primitives)((ns3_0) ns_0))" -"(declare-hash-based-module!41.1 ns3_0 #f null #f #f temp1_0 read-primitives2_0))" +"(declare-hash-based-module!39.1 ns3_0 #f null #f #f temp1_0 read-primitives2_0))" "(let-values(((temp4_0) '#%main)((main-primitives5_0) main-primitives)((ns6_0) ns_0))" -"(declare-hash-based-module!41.1 ns6_0 #f null #f #f temp4_0 main-primitives5_0))" +"(declare-hash-based-module!39.1 ns6_0 #f null #f #f temp4_0 main-primitives5_0))" "(let-values(((temp7_0) '#%utils)((utils-primitives8_0) utils-primitives)((ns9_0) ns_0))" -"(declare-hash-based-module!41.1 ns9_0 #f null #f #f temp7_0 utils-primitives8_0))" +"(declare-hash-based-module!39.1 ns9_0 #f null #f #f temp7_0 utils-primitives8_0))" "(let-values(((temp10_0) '#%place-struct)" "((place-struct-primitives11_0) place-struct-primitives)" "((ns12_0) ns_0)" "((temp13_0) '(dynamic-place)))" -"(declare-hash-based-module!41.1 ns12_0 #f temp13_0 #f #f temp10_0 place-struct-primitives11_0))" +"(declare-hash-based-module!39.1 ns12_0 #f temp13_0 #f #f temp10_0 place-struct-primitives11_0))" "(let-values(((temp14_0) '#%boot)((boot-primitives15_0) boot-primitives)((ns16_0) ns_0))" -"(declare-hash-based-module!41.1 ns16_0 #f null #f #f temp14_0 boot-primitives15_0))" +"(declare-hash-based-module!39.1 ns16_0 #f null #f #f temp14_0 boot-primitives15_0))" "(let-values(((linklet-primitives_0)" "(hash-remove" "(hash-remove linklet-primitives 'variable-reference?)" " 'variable-reference-constant?)))" -"(let-values(((temp17_0) '#%linklet)" +"(begin" +"(let-values(((temp17_0) '#%linklet-primitive)" "((linklet-primitives18_0) linklet-primitives_0)" "((ns19_0) ns_0)" "((temp20_0) #t)" "((temp21_0) #t))" -"(declare-hash-based-module!41.1 ns19_0 temp20_0 null #f temp21_0 temp17_0 linklet-primitives18_0)))" -"(let-values(((temp22_0) '#%expobs)" -"((expobs-primitives23_0) expobs-primitives)" -"((ns24_0) ns_0)" -"((temp25_0) #t))" -"(declare-hash-based-module!41.1 ns24_0 #f null temp25_0 #f temp22_0 expobs-primitives23_0))" -"(let-values(((ns26_0) ns_0)" -"((eval27_0) 1/eval)" -"((temp28_0)" +"(declare-hash-based-module!39.1 ns19_0 temp20_0 null #f temp21_0 temp17_0 linklet-primitives18_0))" +"(let-values(((temp22_0) '#%linklet-expander)" +"((linklet-expander-primitives23_0) linklet-expander-primitives)" +"((ns24_0) ns_0))" +"(declare-hash-based-module!39.1 ns24_0 #f null #f #f temp22_0 linklet-expander-primitives23_0))" +"(let-values(((temp25_0) '#%linklet)" +"((temp26_0)(list '#%linklet-primitive '#%linklet-expander))" +"((ns27_0) ns_0))" +"(declare-reexporting-module!48.1 ns27_0 #t temp25_0 temp26_0))))" +"(let-values(((temp28_0) '#%expobs)" +"((expobs-primitives29_0) expobs-primitives)" +"((ns30_0) ns_0)" +"((temp31_0) #t))" +"(declare-hash-based-module!39.1 ns30_0 #f null temp31_0 #f temp28_0 expobs-primitives29_0))" +"(let-values(((ns32_0) ns_0)" +"((temp33_0)" "(let-values(((ht_0) main-primitives))" "(begin" "(if(variable-reference-from-unsafe?(#%variable-reference))" @@ -78650,7 +79390,7 @@ static const char *startup_source = " for-loop_0)" " '#hash()" "(hash-iterate-first ht_0)))))" -"((temp29_0)" +"((temp34_0)" "(let-values(((ht_0) read-primitives))" "(begin" "(if(variable-reference-from-unsafe?(#%variable-reference))" @@ -78684,7 +79424,7 @@ static const char *startup_source = " for-loop_0)" " '#hash()" "(hash-iterate-first ht_0))))))" -"(declare-kernel-module!8.1 eval27_0 temp28_0 temp29_0 ns26_0))" +"(declare-kernel-module!6.1 temp33_0 temp34_0 ns32_0))" "(begin" "(let-values(((lst_0) runtime-instances))" "(begin" @@ -78704,9 +79444,9 @@ static const char *startup_source = "(let-values()" "(begin" "(let-values()" -"(let-values(((name30_0) name_0)" -"((ns31_0) ns_0)" -"((temp32_0)" +"(let-values(((name35_0) name_0)" +"((ns36_0) ns_0)" +"((temp37_0)" "(let-values(((or-part_0)" "(eq?" " name_0" @@ -78722,15 +79462,15 @@ static const char *startup_source = "(eq?" " name_0" " '#%unsafe)))))))" -"(copy-runtime-module!26.1" +"(copy-runtime-module!24.1" " unsafe-undefined" " unsafe-undefined" -" ns31_0" +" ns36_0" " #t" -" temp32_0" +" temp37_0" " unsafe-undefined" " unsafe-undefined" -" name30_0)))" +" name35_0)))" "(values)))))" "(values)))))))" "(if(not #f)(for-loop_0 rest_0)(values))))" @@ -78738,11 +79478,11 @@ static const char *startup_source = " for-loop_0)" " lst_0)))" "(void))" -"(let-values(((temp33_0) '#%builtin)" -"((temp34_0)(list* '#%place-struct '#%utils '#%boot '#%expobs '#%linklet runtime-instances))" -"((ns35_0) ns_0)" -"((temp36_0) #f))" -"(declare-reexporting-module!50.1 ns35_0 temp36_0 temp33_0 temp34_0))" +"(let-values(((temp38_0) '#%builtin)" +"((temp39_0)(list* '#%place-struct '#%utils '#%boot '#%expobs '#%linklet runtime-instances))" +"((ns40_0) ns_0)" +"((temp41_0) #f))" +"(declare-reexporting-module!48.1 ns40_0 temp41_0 temp38_0 temp39_0))" "(1/current-namespace ns_0)" "(1/dynamic-require ''#%kernel 0)))))))" "(call-with-values(lambda()(namespace-init!)) print-values)" diff --git a/racket/src/racket/src/stypes.h b/racket/src/racket/src/stypes.h index 262c4089d8..7ba3d51562 100644 --- a/racket/src/racket/src/stypes.h +++ b/racket/src/racket/src/stypes.h @@ -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_ diff --git a/racket/src/racket/src/type.c b/racket/src/racket/src/type.c index e9e72110fe..d5c78f2186 100644 --- a/racket/src/racket/src/type.c +++ b/racket/src/racket/src/type.c @@ -133,7 +133,6 @@ scheme_init_type () set_name(scheme_linklet_type, ""); set_name(scheme_instance_type, ""); - set_name(scheme_linklet_directory_type, ""); set_name(scheme_linklet_bundle_type, ""); set_name(scheme_eval_waiting_type, ""); @@ -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);