From de82588e08817e9df425635d31d5bbcd6f000b8d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 Mar 2019 12:50:12 -0700 Subject: [PATCH] cs: fix cross-compile fasl --- racket/src/cs/c/boot.c | 40 ++++++++++++++++---------- racket/src/cs/c/cross-serve.ss | 6 ++-- racket/src/cs/linklet.sls | 4 +-- racket/src/cs/linklet/cross-compile.ss | 3 +- racket/src/cs/main.sps | 15 +++++----- racket/src/cs/main/help.ss | 2 +- 6 files changed, 42 insertions(+), 28 deletions(-) diff --git a/racket/src/cs/c/boot.c b/racket/src/cs/c/boot.c index 8e2fc12d2f..1095b0713d 100644 --- a/racket/src/cs/c/boot.c +++ b/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; - const char *cross_server_library_file = NULL; + int cross_server = 0; #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")) { - cross_server_patch_file = argv[1]; - cross_server_library_file = argv[2]; + if ((argc == 4) && !strcmp(argv[0], "--cross-server")) { + cross_server = 1; #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; - 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); + run_cross_server(argv); racket_exit(0); } diff --git a/racket/src/cs/c/cross-serve.ss b/racket/src/cs/c/cross-serve.ss index fd1e62fdff..30a1f1d524 100644 --- a/racket/src/cs/c/cross-serve.ss +++ b/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)]) diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 93ba0da2e1..20fbb70a76 100644 --- a/racket/src/cs/linklet.sls +++ b/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))))) diff --git a/racket/src/cs/linklet/cross-compile.ss b/racket/src/cs/linklet/cross-compile.ss index 5799463390..2c7aada3e7 100644 --- a/racket/src/cs/linklet/cross-compile.ss +++ b/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) diff --git a/racket/src/cs/main.sps b/racket/src/cs/main.sps index d042190e5c..10a944e23e 100644 --- a/racket/src/cs/main.sps +++ b/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 "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 cannot be combined with any other arguments"))) - (raise-user-error 'racket "--cross-server should have been handled earlier") - (flags-loop null (see saw 'non-config)))] + (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 cannot be combined with any other arguments")) + (raise-user-error 'racket "--cross-server should have been handled earlier")))) + (flags-loop null (see saw 'non-config))] [("-j" "--no-jit") (loop (cdr args))] [("-h" "--help") diff --git a/racket/src/cs/main/help.ss b/racket/src/cs/main/help.ss index 888826e695..9d735eb6f3 100644 --- a/racket/src/cs/main/help.ss +++ b/racket/src/cs/main/help.ss @@ -66,7 +66,7 @@ " -L , --syslog : Set syslog logging to \n" " --compile-machine : Compile for \n" " --cross-compiler : Use compiler plugin for \n" - " --cross-server : Drive cross-compiler (as only option)\n" + " --cross-server : 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"