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

@@ -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

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-exp<?))
@@ -413,22 +414,23 @@
 
 (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:
      ;;  <name-len> <name-bytes> <bund-pos> <bund-len> <left-pos> <right-pos>
      (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]))

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

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))

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))))))

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")

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))

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))))

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) (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)

racket/src/expander/boot/load-handler.rkt

@@ -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))

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" */
 

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 */

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"