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

add virtual-machine identifier to bytecode and ".dep" files

Browse Source 
So far, bytecode for traditional Racket has been kept separate from
RacketCS bytecode by using a different "compiled" subdirectory for
RacketCS. That makes sense for development work to allow the
implementations to coexist, but it creates trouble for packaging and
distributions, and it (hopefully) won't seem necessary in the long
run. Treating the different virtual machines like different versions
seems more generally in line with our current infrastructure.
This commit is contained in:
Matthew Flatt 2018-10-21 17:33:24 -06:00
parent e3f25a6159
commit 8bed64f44f
14 changed files with 144 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
racket/collects/compiler/depend.rkt
View File

@ -14,8 +14,9 @@
(call-with-input-file* dep-path read)))
(for/fold ([all-deps all-deps]) ([dep (in-list (if (and (list? deps)
(pair? deps)
(pair? (cdr deps)))
(cddr deps)
(pair? (cdr deps))
(pair? (cddr deps)))
(cdddr deps)
'()))])
(define p (collects-relative*->path (dep->encoded-path dep) collection-cache))
(cond

35
racket/collects/compiler/private/cm-minimal.rkt
View File

@ -234,6 +234,7 @@
(cons 'ext d)))
external-deps))])
(write (list* (version)
(system-type 'vm)
(cons (or src-sha1 (get-source-sha1 path))
(get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #t #hash()))
(sort deps s-exp<?))
@ -413,13 +414,14 @@
(define (install-module-hashes! s [start 0] [len (bytes-length s)])
(define vlen (bytes-ref s (+ start 2)))
(define mode (integer->char (bytes-ref s (+ start 3 vlen))))
(define vmlen (bytes-ref s (+ start 3 vlen)))
(define mode (integer->char (bytes-ref s (+ start 4 vlen vmlen))))
(case mode
[(#\B)
;; A linklet bundle:
(define h (sha1-bytes s start (+ start len)))
;; Write sha1 for bundle hash:
(bytes-copy! s (+ start 4 vlen) h)]
(bytes-copy! s (+ start 5 vlen vmlen) h)]
[(#\D)
;; A linklet directory. The format starts with <count>,
;; and then it's <count> records of the format:
@ -427,8 +429,8 @@
(define (read-num rel-pos)
(define pos (+ start rel-pos))
(integer-bytes->integer s #t #f pos (+ pos 4)))
(define count (read-num (+ 4 vlen)))
(for/fold ([pos (+ 8 vlen)]) ([i (in-range count)])
(define count (read-num (+ 5 vlen vmlen)))
(for/fold ([pos (+ 9 vlen vmlen)]) ([i (in-range count)])
(define pos-pos (+ pos 4 (read-num pos)))
(define bund-start (read-num pos-pos))
(define bund-len (read-num (+ pos-pos 4)))
@ -463,14 +465,14 @@
#f)
(let ([src-sha1 (and zo-exists?
deps
(cadr deps)
(caddr deps)
(get-source-sha1 path))])
(if (and zo-exists?
src-sha1
(equal? src-sha1 (and (pair? (cadr deps))
(caadr deps)))
(equal? (get-dep-sha1s (cddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen)
(cdadr deps)))
(equal? src-sha1 (and (pair? (caddr deps))
(caaddr deps)))
(equal? (get-dep-sha1s (cdddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen)
(cdaddr deps)))
(begin
(trace-printf "hash-equivalent: ~a" zo-name)
(touch zo-name)
@ -519,7 +521,7 @@
(string-append
(call-with-input-file* path sha1)
(with-handlers ([exn:fail:filesystem? (lambda (exn) "")])
(call-with-input-file* dep-path (lambda (p) (cdadr (read p))))))))))
(call-with-input-file* dep-path (lambda (p) (cdaddr (read p))))))))))
(define (get-compiled-sha1 path->mode roots path)
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
@ -534,8 +536,8 @@
(define (different-source-sha1-and-dep-recorded path deps)
(define src-hash (get-source-sha1 path))
(define recorded-hash (and (pair? (cadr deps))
(caadr deps)))
(define recorded-hash (and (pair? (caddr deps))
(caaddr deps)))
(if (equal? src-hash recorded-hash)
#f
(list src-hash recorded-hash)))
@ -548,7 +550,7 @@
(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen)
(define orig-path (simple-form-path path0))
(define (read-deps path)
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))])
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) (system-type 'vm) '#f))])
(with-module-reading-parameterization
(lambda ()
(call-with-input-file*
@ -584,7 +586,10 @@
[new-seen (hash-set seen path #t)])
(define build
(cond
[(not (and (pair? deps) (equal? (version) (car deps))))
[(not (and (pair? deps)
(equal? (version) (car deps))
(pair? (cdr deps))
(equal? (system-type 'vm) (cadr deps))))
(lambda ()
(trace-printf "newer version...")
(maybe-compile-zo #f #f path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))]
@ -611,7 +616,7 @@
(begin (trace-printf "newer: ~a (~a > ~a)..."
d (car t) path-zo-time)
#t)))
(cddr deps))
(cdddr deps))
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)]
[else #f]))

2
racket/collects/setup/main.rkt
View File

@ -275,7 +275,7 @@
(eq? (car dep) 'ext))
(void)
(dynamic-require (main-collects-relative->path dep) #f))))
(cddr deps))))
(cdddr deps))))
;; Not a .zo! Don't use .zo files at all...
(escape (lambda ()
;; Try again without .zo

2
racket/collects/setup/private/pkg-deps.rkt
View File

@ -490,7 +490,7 @@
;; This is the slowest part, because we have to read the module ".zo"
(check-bytecode-deps f dir coll-path pkg))
;; Treat everything in ".dep" as 'build mode...
(define deps (cddr (call-with-input-file* (build-path dir f) read)))
(define deps (cdddr (call-with-input-file* (build-path dir f) read)))
(for ([dep (in-list deps)])
(when (and (not (external-dep? dep))
(not (indirect-dep? dep))

2
racket/collects/setup/setup-core.rkt
View File

@ -743,7 +743,7 @@
(with-handlers ([exn:fail? (lambda (x) null)])
(with-input-from-file path read)))
(when (and (pair? deps) (list? deps))
(for ([s (in-list (cddr deps))])
(for ([s (in-list (cdddr deps))])
(unless (external-dep? s)
(define new-s (dep->path s))
(when (path-string? new-s) (hash-set! dependencies new-s #t))))))

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

@ -168,6 +168,7 @@
(correlated->annotation v))))))))
v]))
(include "linklet/version.ss")
(include "linklet/write.ss")
(include "linklet/read.ss")
(include "linklet/annotation.ss")

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

@ -5,19 +5,31 @@
(define (read-compiled-linklet-or-directory in initial?)
;; `#~` has already been read
(let* ([start-pos (- (file-position in) 2)]
[vers-len (min 63 (read-byte in))]
[vers (read-bytes vers-len in)])
(unless (equal? vers (string->bytes/utf-8 (version)))
(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 ([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))

2
racket/src/cs/linklet/version.ss Normal file
View File

@ -0,0 +1,2 @@
(define version-bytes (string->bytes/utf-8 (version)))
(define vm-bytes (string->bytes/utf-8 (symbol->string (system-type 'vm))))

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

@ -6,9 +6,10 @@
;; "B"
;; 20 bytes of SHA-1 hash
(write-bytes '#vu8(35 126) port)
(let ([vers (string->bytes/utf-8 (version))])
(write-bytes (bytes (bytes-length vers)) port)
(write-bytes vers 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.
@ -28,6 +29,8 @@
;; "#~"
;; 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:
@ -41,31 +44,34 @@
;; 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)
(let ([vers (string->bytes/utf-8 (version))])
(write-bytes (bytes (bytes-length vers)) port)
(write-bytes vers 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 vers)
1 ; D
4)]) ; bundle count
(write-int len port) ; bundle count
(chez:vector-sort! (lambda (a b) (bytes<? (car a) (car b))) bundles)
;; Compute bundle offsets
(let* ([btree-size (compute-btree-size bundles len)]
[node-offsets (compute-btree-node-offsets bundles len initial-offset)]
[bundle-offsets (compute-bundle-offsets bundles len (+ initial-offset btree-size))])
(write-directory-btree bundles node-offsets bundle-offsets len port)
;; Write the bundles
(let loop ([i 0])
(unless (fx= i len)
(write-bytes (cdr (vector-ref bundles i)) port)
(loop (fx1+ i))))))))
(write-bytes (bytes (bytes-length version-bytes)) port)
(write-bytes version-bytes port)
(write-bytes (bytes (bytes-length vm-bytes)) port)
(write-bytes vm-bytes port)
(write-bytes '#vu8(68) port)
;; Flatten a directory of bundles into a vector of pairs, where
;; each pair has the encoded bundle name and the bundle bytes
(let* ([bundles (list->vector (flatten-linklet-directory ld '() '()))]
[len (vector-length bundles)]
[initial-offset (+ 2 ; "#~"
1 ; version length
(bytes-length version-bytes)
1 ; vm length
(bytes-length vm-bytes)
1 ; D
4)]) ; bundle count
(write-int len port) ; bundle count
(chez:vector-sort! (lambda (a b) (bytes<? (car a) (car b))) bundles)
;; Compute bundle offsets
(let* ([btree-size (compute-btree-size bundles len)]
[node-offsets (compute-btree-node-offsets bundles len initial-offset)]
[bundle-offsets (compute-bundle-offsets bundles len (+ initial-offset btree-size))])
(write-directory-btree bundles node-offsets bundle-offsets len port)
;; Write the bundles
(let loop ([i 0])
(unless (fx= i len)
(write-bytes (cdr (vector-ref bundles i)) port)
(loop (fx1+ i)))))))
;; Flatten a tree into a list of `(cons _name-bstr _bundle-bstr)`
(define (flatten-linklet-directory ld rev-name-prefix accum)

17
racket/src/expander/boot/load-handler.rkt
View File

@ -118,16 +118,25 @@
(lambda args
(apply abort-current-continuation (default-continuation-prompt-tag) args))))))))])))
(define version-bytes (string->bytes/utf-8 (version)))
(define version-length (bytes-length version-bytes))
(define vm-bytes (string->bytes/utf-8 (symbol->string (system-type 'vm))))
(define vm-length (bytes-length vm-bytes))
(define (linklet-bundle-or-directory-start i tag)
(define version-length (string-length (version)))
(define vm-length (string-length (symbol->string (system-type 'vm))))
(and (equal? (peek-byte i) (char->integer #\#))
(equal? (peek-byte i 1) (char->integer #\~))
(equal? (peek-byte i 2) version-length)
(equal? (peek-bytes version-length 3 i) (string->bytes/utf-8 (version)))
(equal? (peek-byte i (+ 3 version-length)) (char->integer tag))
(equal? (peek-bytes version-length 3 i) version-bytes)
(equal? (peek-byte i (+ 3 version-length)) vm-length)
(equal? (peek-bytes vm-length (+ 4 version-length) i) vm-bytes)
(equal? (peek-byte i (+ 4 version-length vm-length)) (char->integer tag))
(+ version-length
;; "#~" and tag and length byte:
4)))
vm-length
;; "#~" and tag and version length byte and vm length byte:
5)))
(define (linklet-directory-start i)
(define pos (linklet-bundle-or-directory-start i #\D))

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

@ -3310,7 +3310,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
intptr_t *subtrees, offset, init_offset;
int count, i;
init_offset = 2 + 1 + strlen(MZSCHEME_VERSION) + 1 + 4;
init_offset = 2 + 1 + strlen(MZSCHEME_VERSION) + 1 + strlen(MZSCHEME_VM) + 1 + 4;
accum_l = write_bundles_to_strings(scheme_null, obj, scheme_null);
@ -3338,6 +3338,8 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
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);
@ -3436,6 +3438,8 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
/* 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" */

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

@ -3881,6 +3881,26 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
(buf[0] ? buf : "???"), MZSCHEME_VERSION);
}
/* Check vm: */
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_VM))
scheme_read_err(port,
"read (compiled): wrong virtusal 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 */

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

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

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

@ -60004,20 +60004,31 @@ static const char *startup_source =
" loop_0)"
"(list(void))))))))"
"(call-with-input-file*61.1 'binary path1_0 temp2_0)))))))))))"
"(define-values(version-bytes)(string->bytes/utf-8(version)))"
"(define-values(version-length)(bytes-length version-bytes))"
"(define-values(vm-bytes)(string->bytes/utf-8(symbol->string(system-type 'vm))))"
"(define-values(vm-length)(bytes-length vm-bytes))"
"(define-values"
"(linklet-bundle-or-directory-start)"
"(lambda(i_0 tag_0)"
"(begin"
"(let-values(((version-length_0)(string-length(version))))"
"(let-values(((vm-length_0)(string-length(symbol->string(system-type 'vm)))))"
"(if(equal?(peek-byte i_0)(char->integer '#\\#))"
"(if(equal?(peek-byte i_0 1)(char->integer '#\\~))"
"(if(equal?(peek-byte i_0 2) version-length_0)"
"(if(equal?(peek-bytes version-length_0 3 i_0)(string->bytes/utf-8(version)))"
"(if(equal?(peek-byte i_0(+ 3 version-length_0))(char->integer tag_0))(+ version-length_0 4) #f)"
"(if(equal?(peek-bytes version-length_0 3 i_0) version-bytes)"
"(if(equal?(peek-byte i_0(+ 3 version-length_0)) vm-length_0)"
"(if(equal?(peek-bytes vm-length_0(+ 4 version-length_0) i_0) vm-bytes)"
"(if(equal?(peek-byte i_0(+ 4 version-length_0 vm-length_0))(char->integer tag_0))"
"(+ version-length_0 vm-length_0 5)"
" #f)"
" #f)"
" #f)"
" #f)))))"
" #f)"
" #f)"
" #f)"
" #f))))))"
"(define-values"
"(linklet-directory-start)"
"(lambda(i_0)"