cs: fix cross-compile fasl

racket/src/cs/c/boot.c

@@ -98,6 +98,26 @@ static ptr parse_coldirs(char *s)
   }
 }
 
+static void run_cross_server(char **argv)
+{
+  ptr c, a;
+  const char *target_machine = argv[1];
+  const char *cross_server_patch_file = argv[2];
+  const char *cross_server_library_file = argv[3];
+
+  c = Stop_level_value(Sstring_to_symbol("load")); /* original `load` */
+  a = Sstring(cross_server_patch_file);
+  (void)Scall1(c, a);
+
+  c = Stop_level_value(Sstring_to_symbol("load")); /* this is the patched `load` */
+  a = Sstring(cross_server_library_file);
+  (void)Scall1(c, a);
+  c = Stop_level_value(Sstring_to_symbol("serve-cross-compile"));
+
+  a = Sstring(target_machine);
+  (void)Scall1(c, a);
+}
+
 static void racket_exit(int v)
 {
   exit(v);
@@ -134,8 +154,7 @@ void racket_boot(int argc, char **argv, char *exec_file, char *run_file,
 #ifdef RACKET_USE_FRAMEWORK
   const char *fw_path;
 #endif
-  const char *cross_server_patch_file = NULL;
+  int cross_server = 0;
-  const char *cross_server_library_file = NULL;
 
 #ifdef WIN32
   if (dlldir)
@@ -146,9 +165,8 @@ void racket_boot(int argc, char **argv, char *exec_file, char *run_file,
 
   Sscheme_init(NULL);
 
-  if ((argc == 3) && !strcmp(argv[0], "--cross-server")) {
+  if ((argc == 4) && !strcmp(argv[0], "--cross-server")) {
-    cross_server_patch_file = argv[1];
+    cross_server = 1;
-    cross_server_library_file = argv[2];
 #ifdef RACKET_AS_BOOT
     skip_racket_boot = 1;
 #endif
@@ -188,18 +206,10 @@ void racket_boot(int argc, char **argv, char *exec_file, char *run_file,
 
   Sbuild_heap(NULL, init_foreign);
 
-  if (cross_server_patch_file) {
+  if (cross_server) {
     /* Don't run Racket as usual. Instead, load the patch
        file and run `serve-cross-compile` */
-    ptr c, a;
+    run_cross_server(argv);
-    c = Stop_level_value(Sstring_to_symbol("load"));
-    a = Sstring(cross_server_patch_file);
-    (void)Scall1(c, a);
-    c = Stop_level_value(Sstring_to_symbol("load")); /* this is the patched load */
-    a = Sstring(cross_server_library_file);
-    (void)Scall1(c, a);
-    c = Stop_level_value(Sstring_to_symbol("serve-cross-compile"));
-    (void)Scall0(c);
     racket_exit(0);
   }
 

racket/src/cs/c/cross-serve.ss

@@ -10,7 +10,7 @@
   (current-output-port o))
 
 ;; Server function to run after cross-compiler is loaded:
-(define (serve-cross-compile)
+(define (serve-cross-compile target)
   ;; Don't exit due to Ctl-C:
   (keyboard-interrupt-handler void)
   ;; Restore output
@@ -47,7 +47,9 @@
              (compile-to-port (list `(lambda () ,(read-fasled))) o)]
             [(fasl)
              ;; Reads host fasl format, then writes target fasl format
-             (fasl-write (read-fasled) o)]
+             (let ([v (read-fasled)])
+               (parameterize ([#%$target-machine (string->symbol target)])
+                 (fasl-write v o)))]
             [else
              (error 'serve-cross-compile (format "unrecognized command: ~s" cmd))])
           (let ([result (get)])

racket/src/cs/linklet.sls

@@ -325,7 +325,7 @@
      [else
       ;; Combine an annotation with a hash code in a vector
       (let-values ([(o get) (open-bytevector-output-port)])
-        (fasl-write (cons (version) a) o)
+        (fasl-write* (cons (version) a) o)
         (vector (sha1-bytes (get)) a))]))
 
   (define-record-type wrapped-code
@@ -478,7 +478,7 @@
                  (let-values ([(o get) (open-bytevector-output-port)])
                    ;; convert to a hashtable so the fasled form is compact and
                    ;; doesn't have hash codes:
-                   (fasl-write (hash->eq-hashtable (hash-copy info)) o)
+                   (fasl-write* (hash->eq-hashtable (hash-copy info)) o)
                    (get))])])
           (linklet-exports-info-set! l new-info)))))
 

racket/src/cs/linklet/cross-compile.ss

@@ -104,6 +104,7 @@
                          (subprocess #f #f (get-original-error-port)
                                      exe
                                      "--cross-server"
+                                     (symbol->string machine)
                                      (patchfile "compile")
                                      (patchfile "library"))])
              (define (->string v) (#%format "~s\n" v))
@@ -123,7 +124,7 @@
 
 (define (fasl-to-bytevector v)
   (let-values ([(o get) (open-bytevector-output-port)])
-    (fasl-write v o)
+    (fasl-write* v o)
     (get)))
 
 (define (find-exe exe)

racket/src/cs/main.sps

@@ -536,13 +536,14 @@
                                        (find-system-path 'exec-file))
                   (loop rest-args)))]
              [("--cross-server")
-              (let-values ([(scheme-xpatch-file rest-args) (next-arg "compiler xpatch path" arg within-arg args)])
+              (let-values ([(scheme-xpatch-file rest-args) (next-arg "target machine" arg within-arg args)])
+                (let-values ([(scheme-xpatch-file rest-args) (next-arg "compiler xpatch path" arg within-arg (cons arg rest-args))])
                   (let-values ([(scheme-xpatch-file rest-args) (next-arg "library xpatch path" arg within-arg (cons arg rest-args))])
                     (when (or (saw-something? saw)
                               (not (null? rest-args)))
-                    (raise-user-error 'racket "--cross-server <path> cannot be combined with any other arguments")))
+                      (raise-user-error 'racket "--cross-server cannot be combined with any other arguments"))
-                (raise-user-error 'racket "--cross-server should have been handled earlier")
+                    (raise-user-error 'racket "--cross-server should have been handled earlier"))))
-                (flags-loop null (see saw 'non-config)))]
+              (flags-loop null (see saw 'non-config))]
              [("-j" "--no-jit")
               (loop (cdr args))]
              [("-h" "--help")

racket/src/cs/main/help.ss

@@ -66,7 +66,7 @@
     "  -L <levels>, --syslog <levels> : Set syslog logging to <levels>\n"
     "  --compile-machine <machine> : Compile for <machine>\n"
     "  --cross-compiler <machine> <plugin-dir> : Use compiler plugin for <machine>\n"
-    "  --cross-server <compiler> <library> : Drive cross-compiler (as only option)\n"
+    "  --cross-server <mach> <comp> <lib> : Drive cross-compiler (as only option)\n"
     " Meta options:\n"
     "  -- : No argument following this switch is used as a switch\n"
     "  -h, --help : Show this information and exits, ignoring other options\n"