From 8bed64f44f26d63bfdde816fb4b3d55a60b6d67f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Oct 2018 17:33:24 -0600 Subject: [PATCH] add virtual-machine identifier to bytecode and ".dep" files 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. --- racket/collects/compiler/depend.rkt | 5 +- .../collects/compiler/private/cm-minimal.rkt | 35 ++++++----- racket/collects/setup/main.rkt | 2 +- racket/collects/setup/private/pkg-deps.rkt | 2 +- racket/collects/setup/setup-core.rkt | 2 +- racket/src/cs/linklet.sls | 1 + racket/src/cs/linklet/read.ss | 38 ++++++++---- racket/src/cs/linklet/version.ss | 2 + racket/src/cs/linklet/write.ss | 62 ++++++++++--------- racket/src/expander/boot/load-handler.rkt | 17 +++-- racket/src/racket/src/print.c | 6 +- racket/src/racket/src/read.c | 20 ++++++ racket/src/racket/src/schvers.h | 6 +- racket/src/racket/src/startup.inc | 17 ++++- 14 files changed, 144 insertions(+), 71 deletions(-) create mode 100644 racket/src/cs/linklet/version.ss diff --git a/racket/collects/compiler/depend.rkt b/racket/collects/compiler/depend.rkt index 091186ba30..25f0d3084c 100644 --- a/racket/collects/compiler/depend.rkt +++ b/racket/collects/compiler/depend.rkt @@ -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 diff --git a/racket/collects/compiler/private/cm-minimal.rkt b/racket/collects/compiler/private/cm-minimal.rkt index 2b913eda11..49698fb8c5 100644 --- a/racket/collects/compiler/private/cm-minimal.rkt +++ b/racket/collects/compiler/private/cm-minimal.rkt @@ -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-expchar (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 , ;; and then it's 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])) diff --git a/racket/collects/setup/main.rkt b/racket/collects/setup/main.rkt index ba7e189e50..45bd98e031 100644 --- a/racket/collects/setup/main.rkt +++ b/racket/collects/setup/main.rkt @@ -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 diff --git a/racket/collects/setup/private/pkg-deps.rkt b/racket/collects/setup/private/pkg-deps.rkt index 8fcf3cdf5a..7a0e17b2d7 100644 --- a/racket/collects/setup/private/pkg-deps.rkt +++ b/racket/collects/setup/private/pkg-deps.rkt @@ -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)) diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index 2ce4b41024..8d576cde1f 100644 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -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)))))) diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 8aa2e63875..62f1350b3b 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -168,6 +168,7 @@ (correlated->annotation v)))))))) v])) + (include "linklet/version.ss") (include "linklet/write.ss") (include "linklet/read.ss") (include "linklet/annotation.ss") diff --git a/racket/src/cs/linklet/read.ss b/racket/src/cs/linklet/read.ss index a654a9f79f..0cddcfb880 100644 --- a/racket/src/cs/linklet/read.ss +++ b/racket/src/cs/linklet/read.ss @@ -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)) diff --git a/racket/src/cs/linklet/version.ss b/racket/src/cs/linklet/version.ss new file mode 100644 index 0000000000..1a4db4fe26 --- /dev/null +++ b/racket/src/cs/linklet/version.ss @@ -0,0 +1,2 @@ +(define version-bytes (string->bytes/utf-8 (version))) +(define vm-bytes (string->bytes/utf-8 (symbol->string (system-type 'vm)))) diff --git a/racket/src/cs/linklet/write.ss b/racket/src/cs/linklet/write.ss index c1677a7564..cf6976f005 100644 --- a/racket/src/cs/linklet/write.ss +++ b/racket/src/cs/linklet/write.ss @@ -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) (bytesvector (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/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)) diff --git a/racket/src/racket/src/print.c b/racket/src/racket/src/print.c index 97851abf80..36ad963b2c 100644 --- a/racket/src/racket/src/print.c +++ b/racket/src/racket/src/print.c @@ -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" */ diff --git a/racket/src/racket/src/read.c b/racket/src/racket/src/read.c index 01115180db..d4e093ee1b 100644 --- a/racket/src/racket/src/read.c +++ b/racket/src/racket/src/read.c @@ -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 */ diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 85f9cb2d69..0753acb1d4 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -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" diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index e37c9a6601..35d87d30c3 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -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)"