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

cs: fix cross-compile fasl

Browse Source
This commit is contained in:
Matthew Flatt 2019-03-09 12:50:12 -07:00
parent 17e5a56569
commit de82588e08
6 changed files with 42 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
racket/src/cs/c/boot.c
View File

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

6
racket/src/cs/c/cross-serve.ss
View File

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

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

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

3
racket/src/cs/linklet/cross-compile.ss
View File

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

15
racket/src/cs/main.sps
View File

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

2
racket/src/cs/main/help.ss
View File

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