cs: add cross-compilation hooks for Racket

Add options to load a "plug-in" cross compiler, which should be a Chez
Scheme patch file plus declarations for the built-in libraries. Since
loading a patch file replaces the initial compiler, a separate
cross-compiler process is used to load the plug-in.

pkgs/racket-doc/scribblings/reference/linklet.scrbl

@@ -507,7 +507,8 @@ primitive.}
                                                (or/c exact-nonnegative-integer? #f)
                                                (or/c exact-positive-integer? #f)
                                                (or/c exact-nonnegative-integer? #f)))
-                                #f])
+                                #f]
+                         [prop (or/c correlated? #f)])
           correlated?]
 @defproc*[([(correlated-property [stx correlated?]
                                  [key any/c]
@@ -530,4 +531,7 @@ recur through the given S-expression and convert pieces to
 simply wrapped around the immediate value. In contrast,
 @racket[correlated->datum] recurs through its argument (which is not
 necessarily a @tech{correlated object}) to discover any
-@tech{correlated objects} and convert them to plain S-expressions.}
+@tech{correlated objects} and convert them to plain S-expressions.
+
+@history[#:changed "7.6.0.6" @elem{Added the @racket[prop] argument
+                                   to @racket[datum->correlated].}]}

racket/collects/compiler/private/cm-minimal.rkt

@@ -355,14 +355,14 @@
                                         ""))])))
 
 (define (cross-multi-compile? roots)
-  ;; Combination of cross-installation mode, compiling to machine-independent form,
+  ;; Combination of cross-installation mode, compiling to non-default target machine,
   ;; and multiple compiled-file roots triggers a special multi-target compilation mode.
   ;; Write code compiled for the running Racket to the first root, and write code for
   ;; the cross-compile target to the second root --- but count the cross-compile target
   ;; as machine-independent if it would be the same as the current target.
   (and ((length roots) . > . 1)
        (cross-installation?)
-       (not (current-compile-target-machine))))
+       (not (eq? (system-type 'target-machine) (current-compile-target-machine)))))
 
 ;; Handle cross-multi-compile mode, or just continue on to `compile-zo*`
 (define (compile-zo*/cross-compile path->mode roots path src-sha1 read-src-syntax orig-zo-name

racket/collects/racket/linklet.rkt

@@ -64,8 +64,8 @@
 (define (correlated? e)
   (syntax? e))
 
-(define (datum->correlated d [srcloc #f])
+(define (datum->correlated d [srcloc #f] [props #f])
-  (datum->syntax #f d srcloc))
+  (datum->syntax #f d srcloc props))
 
 (define (correlated-e e)
   (syntax-e e))

racket/src/cs/Makefile

@@ -84,7 +84,10 @@ run-wpo: $(BUILDDIR)racket.so ../../bin/racket
 $(BUILDDIR)racket.so: $(BUILDDIR)main.$(CSO) $(COMPILE_FILE_DEPS)
 	$(COMPILE_FILE) --whole-program $(BUILDDIR)racket.so $(BUILDDIR)main.wpo
 
-$(BUILDDIR)main.$(CSO): $(MAIN_DEPS) main.sps main/help.ss $(COMPILE_FILE_DEPS)
+MAIN_SRCS = main/help.ss \
+            main/cross-compile.ss
+
+$(BUILDDIR)main.$(CSO): $(MAIN_DEPS) main.sps $(MAIN_SRCS) $(COMPILE_FILE_DEPS)
 	$(COMPILE_FILE) main.sps $(MAIN_DEPS)
 
 strip:
@@ -123,6 +126,7 @@ LINKLET_SRCS = linklet/read.ss \
                linklet/performance.ss \
                linklet/annotation.ss \
                linklet/compress.ss \
+               linklet/cross-compile.ss \
                linklet/db.ss
 
 $(BUILDDIR)linklet.$(CSO): linklet.sls $(LINKLET_SRCS) $(LINKLET_DEPS) $(COMPILE_FILE_DEPS)

racket/src/cs/c/Makefile.in

@@ -303,6 +303,15 @@ plain-install@MINGW@:
 	$(ICP) MzStart.exe $(libpltdir)/MzStart.exe
 	$(ICP) MrStart.exe $(libpltdir)/MrStart.exe
 	$(MAKE) system-install
+	$(MAKE) racket-xpatch.$(TARGET_MACH)
+
+SCHEME_XPATCH = $(SCHEME_SRC)/@TARGET_MACH@/s/xpatch
+RACKET_XPATCH = chezpart.$(MACH) rumble.$(MACH)	thread.$(MACH) \
+                io.$(MACH) regexp.$(MACH) schemify.$(MACH) linklet.$(MACH) expander.$(MACH)
+ALL_XPATCH = $(SCHEME_XPATCH) $(RACKET_XPATCH)
+
+racket-xpatch.$(TARGET_MACH): $(ALL_XPATCH)
+	cat $(ALL_XPATCH) > racket-xpatch.$(TARGET_MACH)
 
 # ----------------------------------------
 # Common

racket/src/cs/linklet.sls

@@ -29,6 +29,9 @@
           variable-reference-constant?
           variable-reference-from-unsafe?
 
+          add-cross-compiler!        ; not exported to racket
+          unmarshal-annotation       ; not exported to racket
+
           compile-enforce-module-constants
           compile-context-preservation-enabled
           compile-allow-set!-undefined
@@ -84,9 +87,25 @@
                 current-environment-variables
                 find-system-path
                 build-path
-                format)
+                format
+                get-original-error-port
+                subprocess
+                write-string
+                flush-output
+                read-line)
           (only (thread)
-                current-process-milliseconds)
+                current-process-milliseconds
+                ;; Used by cross-compiler:
+                unsafe-make-custodian-at-root
+                current-custodian
+                custodian-shutdown-all
+                thread
+                make-channel
+                channel-put
+                channel-get
+                make-will-executor
+                will-register
+                will-try-execute)
           (regexp)
           (schemify))
 
@@ -182,7 +201,7 @@
   ;; that need to be managed correctly when swapping Racket
   ;; engines/threads.
   (define (compile* e)
-    (call-with-system-wind (lambda () (eval e)))) ; eval => compile, except in cross mode
+    (call-with-system-wind (lambda () (compile e))))
   (define (interpret* e)
     (call-with-system-wind (lambda () (interpret e))))
   (define (fasl-write* s o)
@@ -227,6 +246,15 @@
           (bytevector-compress bv)
           bv)))
 
+  (define (make-cross-compile-to-bytevector machine)
+    (lambda (s paths format)
+      (let ([bv (cond
+                 [(eq? format 'interpret) (cross-fasl-to-string machine s)]
+                 [else (cross-compile machine s)])])
+        (if compress-code?
+            (bytevector-compress bv)
+            bv))))
+
   (define (eval-from-bytevector c-bv paths format)
     (let ([bv (if (bytevector-uncompressed-fasl? c-bv)
                   c-bv
@@ -393,7 +421,7 @@
     (fields (mutable code) ; the procedure or interpretable form
             paths          ; list of paths; if non-empty, `code` expects them as arguments
             format         ; 'compile or 'interpret (where the latter may have compiled internal parts)
-            (mutable preparation) ; 'faslable, 'faslable-strict, 'callable, or 'lazy
+            (mutable preparation) ; 'faslable, 'faslable-strict, 'callable, 'lazy, or (cons 'cross <machine>)
             importss-abi   ; ABI for each import, in parallel to `importss`
             exports-info   ; hash(sym -> known) for info about each export; see "known.rkt"
             name           ; name of the linklet (for debugging purposes)
@@ -423,6 +451,17 @@
                   (linklet-importss linklet)
                   (linklet-exports linklet)))
 
+  (define (set-linklet-preparation linklet preparation)
+    (make-linklet (linklet-code linklet)
+                  (linklet-paths linklet)
+                  (linklet-format linklet)
+                  preparation
+                  (linklet-importss-abi linklet)
+                  (linklet-exports-info linklet)
+                  (linklet-name linklet)
+                  (linklet-importss linklet)
+                  (linklet-exports linklet)))
+
   (define compile-linklet
     (case-lambda
      [(c) (compile-linklet c #f #f (lambda (key) (values #f #f)) '(serializable))]
@@ -432,6 +471,10 @@
      [(c name import-keys get-import options)
       (define serializable? (#%memq 'serializable options))
       (define use-prompt? (#%memq 'use-prompt options))
+      (define cross-machine (and serializable?
+                                 (let ([m  (|#%app| current-compile-target-machine)])
+                                   (and (not (eq? m (machine-type)))
+                                        m))))
       (performance-region
        'schemify
        (define jitify-mode?
@@ -513,15 +556,17 @@
        (performance-region
         'compile-linklet
         ;; Create the linklet:
-        (let ([lk (make-linklet (call-with-system-wind
+        (let ([lk (make-linklet ((if serializable?
-                                 (lambda ()
+                                     (if cross-machine
-                                   ((if serializable? compile-to-bytevector outer-eval)
+                                         (make-cross-compile-to-bytevector cross-machine)
+                                         compile-to-bytevector)
+                                     outer-eval)
                                  (show (and jitify-mode? post-interp-on?) "post-interp" impl-lam/interpable)
                                  paths
-                                    format)))
+                                 format)
                                 paths
                                 format
-                                (if serializable? 'faslable 'callable)
+                                (if serializable? (if cross-machine (cons 'cross cross-machine) 'faslable) 'callable)
                                 importss-abi
                                 exports-info
                                 name
@@ -975,6 +1020,8 @@
 
   ;; --------------------------------------------------
 
+  (include "linklet/cross-compile.ss")
+  
   (define compile-enforce-module-constants
     (make-parameter #t (lambda (v) (and v #t))))
 
@@ -997,7 +1044,9 @@
   (define (compile-target-machine? v)
     (unless (symbol? v)
       (raise-argument-error 'compile-target-machine? "symbol?" v))
-    (eq? v (machine-type)))
+    (or (eq? v (machine-type))
+        (and (#%assq v cross-machine-types)
+             #t)))
 
   (define eval-jit-enabled
     (make-parameter #t (lambda (v) (and v #t))))

racket/src/cs/linklet/annotation.ss

@@ -94,3 +94,69 @@
           s
           (cons a d)))]
    [else s]))
+
+;; --------------------------------------------------
+
+;; Used for cross-compiler communication
+
+(define-record-type marshaled-annotation
+  (fields expression source-object)
+  (nongenerative #{marshaled-annotation gd3r4cl07w9emgzjvdmpf3qpq-0}))
+
+(define (marshal-annotation v)
+  (cond
+   [(annotation? v)
+    (make-marshaled-annotation (marshal-annotation (annotation-expression v))
+                               (mashal-source-object (annotation-source v)))]
+   [(pair? v)
+    (let ([a (marshal-annotation (car v))]
+          [d (marshal-annotation (cdr v))])
+      (if (and (eq? a (car v))
+               (eq? d (cdr v)))
+          v
+          (cons a d)))]
+   [else v]))
+
+(define (mashal-source-object s)
+  (vector (source-file-descriptor-path (source-object-sfd s))
+          (source-object-bfp s)
+          (source-object-efp s)
+          (source-object-line s)
+          (source-object-column s)))
+
+(define (unmarshal-annotation v)
+  (let ([ht (make-hashtable equal-hash equal?)])
+    (let-values ([(a stripped)
+                  (let loop ([v v])
+                    (cond
+                     [(marshaled-annotation? v)
+                      (let-values ([(e s-e) (loop (marshaled-annotation-expression v))])
+                        (values (make-annotation e
+                                                 (unmarshal-source-object
+                                                  (marshaled-annotation-source-object v)
+                                                  ht)
+                                                 s-e)
+                                s-e))]
+                     [(pair? v)
+                      (let-values ([(a s-a) (loop (car v))]
+                                   [(d s-d) (loop (cdr v))])
+                        (if (and (eq? a (car v))
+                                 (eq? d (cdr v)))
+                            (values v v)
+                            (values (cons a d) (cons s-a s-d))))]
+                     [else (values v v)]))])
+      a)))
+
+(define (unmarshal-source-object s ht)
+  (let ([p (#%vector-ref s 0)]
+        [bfp (#%vector-ref s 1)]
+        [efp (#%vector-ref s 2)]
+        [line (#%vector-ref s 3)]
+        [column (#%vector-ref s 4)])
+    (let ([sfd (or (hashtable-ref ht p #f)
+                   (let ([sfd (source-file-descriptor p 0)])
+                     (hashtable-set! ht p sfd)
+                     sfd))])
+      (cond
+       [line (make-source-object sfd bfp efp line column)]
+       [else (make-source-object sfd bfp efp)]))))

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

@@ -0,0 +1,119 @@
+;; The server half of this interaction is in "../main/cross-compile.ss".
+
+;; Currently, cross-compilation support in Chez Scheme replaces the
+;; compiler for the build machine. Until that changes, we can't load
+;; cross-compilation support into the Chez Scheme instance that runs
+;; Racket. Instead, launch a separate process and commuincate with
+;; it via stdin/stdout.
+
+;; To manage the possibility of multipe Racket threads and places that
+;; cross-compile at the same time, we create a separate cross-compiler
+;; process for each request --- but cache processes so that requests
+;; can complete quickly in common cases. These separate processes can
+;; just be forgotten if the compilation request is abandoned, so we
+;; put each compiler in a thread (managed by the root custodian) that
+;; can be cleaned up.
+
+;; List of (list <machine-sym> <path-path>)
+(define cross-machine-types '())
+
+(define (add-cross-compiler! x-machine-type x-path exe-path)
+  (set! cross-machine-types
+        (cons (list x-machine-type (cons exe-path x-path))
+              cross-machine-types)))
+
+;; List of (list <machine-sym> <msg-channel>)
+;; representing started compiler processes.
+(define cross-machine-compiler-cache (unsafe-make-place-local '()))
+
+;; To clean up abandonded compilers:
+(define compiler-will-executor (unsafe-make-place-local #f))
+
+;; Find compiler, starting one if necessary
+(define (find-cross who machine)
+  (disable-interrupts)
+  (let* ([cache (unsafe-place-local-ref cross-machine-compiler-cache)]
+         [a (#%assq machine cache)])
+    (cond
+     [a
+      (unsafe-place-local-set! cross-machine-compiler-cache (#%remq a cache))
+      (enable-interrupts)
+      a]
+     [else
+      (enable-interrupts)
+      (let ([a (#%assq machine cross-machine-types)])
+        (cond
+         [a (start-cross-compiler machine (cadr a))]
+         [else
+          (#%error who "no compiler loaded for ~a" machine)]))])))
+
+(define (cache-cross-compiler a)
+  (with-interrupts-disabled
+   (unsafe-place-local-set! cross-machine-compiler-cache
+                            (cons a (unsafe-place-local-ref cross-machine-compiler-cache)))))
+
+(define (do-cross machine msg v)
+  (let* ([a (find-cross 'cross-compile machine)]
+         [ch (cadr a)]
+         [reply-ch (make-channel)])
+    (channel-put ch (list msg
+                          (marshal-annotation v)
+                          reply-ch))
+    (begin0
+     (channel-get reply-ch)
+     (cache-cross-compiler a))))
+
+(define (cross-compile machine v)
+  (do-cross machine 'compile v))
+
+(define (cross-fasl-to-string machine v)
+  (do-cross machine 'fasl v))
+
+;; Start a compiler as a Racket thread under the root custodian.
+;; Using Racket's scheduler lets us use the event and I/O system,
+;; including support for running a process and managing resources
+;; through a custodian. Putting each cross-compiler instance in
+;; its own thread more gracefully handles the case that a compilation
+;; request is abandoned by the caller.
+(define (start-cross-compiler machine exe+x)
+  (let ([we (with-interrupts-disabled
+             (or (unsafe-place-local-ref compiler-will-executor)
+                 (let ([we (make-will-executor)])
+                   (unsafe-place-local-set! compiler-will-executor we)
+                   we)))])
+    (let clean-up ()
+      (when (will-try-execute we)
+        (clean-up)))
+    (let ([exe (car exe+x)]
+          [xpatch (cdr exe+x)]
+          [msg-ch (make-channel)]
+          [c (unsafe-make-custodian-at-root)])
+      (with-continuation-mark
+          parameterization-key
+          (extend-parameterization (continuation-mark-set-first
+                                    #f
+                                    parameterization-key)
+                                   current-custodian
+                                   c)
+        ;; At this point, we're under the root custodian
+        (thread
+         (lambda ()
+           (let-values ([(subproc from to err)
+                         (subprocess #f #f (get-original-error-port)
+                                     exe
+                                     "--cross-server"
+                                     xpatch)])
+             (define (->string v) (#%format "~s\n" v))
+             (define (string-> str) (#%read (open-string-input-port str)))
+             ;; If this compiler instance becomes unreachable because the
+             ;; called is interrupted, then shut this compiler down:
+             (will-register we msg-ch (lambda (msg-ch) (custodian-shutdown-all c)))
+             (let loop ()
+               (let ([msg (channel-get msg-ch)])
+                 ;; msg is (list <command> <value> <reply-channel>)
+                 (write-string (->string (car msg)) to)
+                 (write-string (->string (cadr msg)) to)
+                 (flush-output to)
+                 (channel-put (caddr msg) (string-> (read-line from)))
+                 (loop)))))))
+      (list machine msg-ch))))

racket/src/cs/linklet/write.ss

@@ -4,26 +4,40 @@
   #vu8(99 104 101 122 45 115 99 104 101 109 101))
 
 (define (write-linklet-bundle-hash ht dest-o)
+  (let-values ([(ht cross-machine) (encode-linklet-paths ht)])
+    (let ([bstr (if cross-machine
+                    (cross-fasl-to-string cross-machine ht)
                     (let-values ([(o get) (open-bytevector-output-port)])
-    (fasl-write* (encode-linklet-paths ht) o)
+                      (fasl-write* ht o)
-    (let ([bstr (get)])
+                      (get)))])
       (write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) dest-o)
       (write-bytes bstr dest-o))))
 
 (define (encode-linklet-paths orig-ht)
   (let ([path->compiled-path (make-path->compiled-path 'write-linklet)])
-    (let loop ([i (hash-iterate-first orig-ht)] [ht orig-ht])
+    (let loop ([i (hash-iterate-first orig-ht)] [ht orig-ht] [cross-machine #f])
       (cond
-       [(not i) ht]
+       [(not i) (values ht cross-machine)]
        [else
         (let-values ([(key v) (hash-iterate-key+value orig-ht i)])
           (let ([new-ht (if (and (linklet? v)
                                  (pair? (linklet-paths v)))
                             (hash-set ht key
+                                      (adjust-cross-perparation
                                        (set-linklet-paths
                                         v
                                         (map path->compiled-path
-                                            (linklet-paths v))))
+                                             (linklet-paths v)))))
                             ht)])
             (loop (hash-iterate-next orig-ht i)
-                  new-ht)))]))))
+                  new-ht
+                  (or cross-machine
+                      (and (linklet? v)
+                           (let ([prep (linklet-preparation v)])
+                             (and (pair? prep) (cdr prep))))))))]))))
+
+;; Before fasl conversion, change 'cross to 'faslable
+(define (adjust-cross-perparation l)
+  (if (pair? (linklet-preparation l))
+      (set-linklet-preparation l 'faslable)
+      l))

racket/src/cs/main.sps

@@ -44,7 +44,10 @@
                platform-independent-zo-mode?
                linklet-performance-init!
                linklet-performance-report!
-               current-compile-target-machine))
+               current-compile-target-machine
+               compile-target-machine?
+               add-cross-compiler!
+               unmarshal-annotation))
 
  (linklet-performance-init!)
  (unless omit-debugging?
@@ -140,9 +143,12 @@
                     [else "compiled"]))))
    (define user-specific-search-paths? #t)
    (define load-on-demand? #t)
-   (define compile-machine-independent? (getenv "PLT_COMPILE_ANY"))
+   (define compile-target-machine (if (getenv "PLT_COMPILE_ANY")
+                                      #f
+                                      (machine-type)))
    (define compiled-roots-path-list-string (getenv "PLTCOMPILEDROOTS"))
    (define embedded-load-in-places #f)
+   (define cross-compile-server-patch-file #f)
 
    (define (see saw . args)
      (let loop ([saw saw] [args args])
@@ -151,6 +157,8 @@
            (loop (hash-set saw (car args) #t) (cdr args)))))
    (define (saw? saw tag)
      (hash-ref saw tag #f))
+   (define (saw-something? saw)
+     (positive? (hash-count saw)))
 
    (define rx:logging-spec (pregexp "^[\\s]*(none|fatal|error|warning|info|debug)(?:@([^\\s @]+))?(.*)$"))
    (define rx:all-whitespace (pregexp "^[\\s]*$"))
@@ -244,8 +252,8 @@
    (define syslog-logging-arg #f)
    (define runtime-for-init? #t)
    (define exit-value 0)
-   (define host-collects-dir init-collects-dir)
+   (define host-collects-dir #f)
-   (define host-config-dir init-config-dir)
+   (define host-config-dir #f)
    (define addon-dir #f)
    (define rev-collects-post-extra '())
 
@@ -288,6 +296,7 @@
                  loads)))
 
    (include "main/help.ss")
+   (include "main/cross-compile.ss")
 
    (define-syntax string-case
      ;; Assumes that `arg` is a variable
@@ -306,7 +315,7 @@
                      [saw (hasheq)])
       ;; An element of `args` can become `(cons _arg _within-arg)`
       ;; due to splitting multiple flags with a single "-"
-      (define (loop args) (flags-loop args saw))
+      (define (loop args) (flags-loop args (see saw 'something)))
       ;; Called to handle remaining non-switch arguments:
       (define (finish args saw)
         (cond
@@ -513,8 +522,29 @@
                [else
                 (raise-bad-switch arg within-arg)])]
              [("-M" "--compile-any")
-              (set! compile-machine-independent? #t)
+              (set! compile-target-machine #f)
               (loop (cdr args))]
+             [("--compile-machine")
+              (let-values ([(mach-str rest-args) (next-arg "target machine" arg within-arg args)])
+                (let ([mach (string->symbol mach-str)])
+                  (unless (compile-target-machine? mach)
+                    (raise-user-error 'racket "machine not supported as a compile target: ~a" mach))
+                  (set! compile-target-machine mach))
+                (loop rest-args))]
+             [("--cross-compiler")
+              (let-values ([(mach rest-args) (next-arg "target machine" arg within-arg args)])
+                (let-values ([(xpatch-file rest-args) (next-arg "cross-compiler path" arg within-arg (cons arg rest-args))])
+                  (add-cross-compiler! (string->symbol mach)
+                                       (path->complete-path (->path (find-original-bytes xpatch-file)))
+                                       (find-system-path 'exec-file))
+                  (loop rest-args)))]
+             [("--cross-server")
+              (let-values ([(xpatch-file rest-args) (next-arg "xpatch path" arg within-arg args)])
+                (set! cross-compile-server-patch-file xpatch-file)
+                (when (or (saw-something? saw)
+                          (not (null? rest-args)))
+                  (raise-user-error 'racket "--cross-server <path> cannot be combined with any other arguments"))
+                (flags-loop null (see saw 'non-config)))]
              [("-j" "--no-jit")
               (loop (cdr args))]
              [("-h" "--help")
@@ -668,8 +698,8 @@
      (|#%app| use-compiled-file-paths compiled-file-paths)
      (|#%app| use-user-specific-search-paths user-specific-search-paths?)
      (|#%app| load-on-demand-enabled load-on-demand?)
-     (when compile-machine-independent?
+     (unless (eq? compile-target-machine (machine-type))
-       (|#%app| current-compile-target-machine #f))
+       (|#%app| current-compile-target-machine compile-target-machine))
      (boot)
      (when (and stderr-logging
                 (not (null? stderr-logging)))
@@ -680,6 +710,10 @@
      (when (and syslog-logging
                 (not (null? syslog-logging)))
        (apply add-syslog-log-receiver! (|#%app| current-logger) syslog-logging))
+     (when host-collects-dir
+       (set-host-collects-dir! host-collects-dir))
+     (when host-config-dir
+       (set-host-config-dir! host-config-dir))
      (cond
       [(eq? init-collects-dir 'disable)
        (|#%app| use-collection-link-paths #f)
@@ -731,6 +765,9 @@
    (call-in-main-thread
     (lambda ()
       (initialize-place!)
+      (when cross-compile-server-patch-file
+        ;; does not return:
+        (serve-cross-compile cross-compile-server-patch-file))
 
       (when init-library
         (namespace-require+ init-library))

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

@@ -0,0 +1,34 @@
+;; The client half of this interaction is in "../linklet/cross-compile.ss".
+;; Communication uses the Chez Scheme printer and reader so make the
+;; server as independent from Racket as possible. We don't even need
+;; this code to run as part of Racket CS, but it's convenient to
+;; organize things that way.
+
+(define (serve-cross-compile cross-compile-server-patch-file)
+  (break-enabled #f) ; exit on EOF, but not on a break signal
+  (unsafe-start-atomic)
+  (call-with-system-wind
+   (lambda ()
+     (let-values ([(o get) (open-bytevector-output-port (current-transcoder))])
+       (parameterize ([#%current-output-port o])
+         ;; Loading the patch file disables normal `compile` and makes
+         ;; `compile-to-port` compile to some other machine type:
+         (#%load cross-compile-server-patch-file)))
+     ;; Serve requests to compile or to fasl data:
+     (let loop ()
+       (let ([cmd (#%read)])
+         (unless (eof-object? cmd)
+           (let-values ([(o get) (open-bytevector-output-port)])
+             (case cmd
+               [(fasl)
+                (fasl-write (unmarshal-annotation (#%read)) o)]
+               [(compile)
+                (compile-to-port (list `(lambda () ,(unmarshal-annotation (#%read)))) o)]
+               [else
+                (#%error 'serve-cross-compile (#%format "unrecognized command: ~s" cmd))])
+             (let ([result (get)])
+               (#%write result)
+               (#%newline)
+               (#%flush-output-port)))
+           (loop))))))
+  (exit))

racket/src/cs/main/help.ss

@@ -64,6 +64,9 @@
     "  -W <levels>, --warn <levels> : Set stderr logging to <levels>\n"
     "  -O <levels>, --stdout <levels> : Set stdout logging to <levels>\n"
     "  -L <levels>, --syslog <levels> : Set syslog logging to <levels>\n"
+    "  --compile-machine <machine> : Compile for <machine>\n"
+    "  --cross-compiler <machine> <plugin-file> : Use compiler plugin for <machine>\n"
+    "  --cross-server <plugin-file> : Drive cross-compiler plugin (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"

racket/src/cs/rumble/correlated.ss

@@ -9,7 +9,9 @@
 
 (define-record correlated (e srcloc props))
 
-(define/who (datum->correlated ignored datum src)
+(define/who datum->correlated
+  (case-lambda
+   [(ignored datum src props)
     (check who
            :test (or (not src) (correlated? src) (srcloc? src) (encoded-srcloc? src))
            :contract (string-append "(or #f syntax? srcloc?\n"
@@ -24,13 +26,15 @@
                                     "              (or/c exact-positive-integer? #f)\n"
                                     "              (or/c exact-nonnegative-integer? #f)))")
            src)
+    (check who correlated? :or-false props)
     (if (correlated? datum)
         datum
         (make-correlated datum
                          (extract-srcloc src)
-                       (if (correlated? src)
+                         (if props
-                           (correlated-props src)
+                             (correlated-props props)
-                           empty-hasheq))))
+                             empty-hasheq)))]
+   [(ignored datum src) (datum->correlated ignored datum src #f)]))
 
 (define (correlated->datum e)
   (cond
@@ -95,6 +99,7 @@
 (define (extract-srcloc src)
   (cond
    [(not src) #f]
+   [(srcloc? src) src]
    [(correlated? src) (correlated-srcloc src)]
    [(vector? src) (|#%app|
                    srcloc

racket/src/cs/schemify.sls

@@ -24,7 +24,8 @@
                   [correlated-source rumble:correlated-source]
                   [correlated-line rumble:correlated-line]
                   [correlated-column rumble:correlated-column]
-                  [correlated-position rumble:correlated-position])
+                  [correlated-position rumble:correlated-position]
+                  [correlated-span rumble:correlated-span])
           (regexp)
           (io))
 
@@ -42,7 +43,8 @@
              'syntax-source rumble:correlated-source
              'syntax-line rumble:correlated-line
              'syntax-column rumble:correlated-column
-             'syntax-position rumble:correlated-position)]
+             'syntax-position rumble:correlated-position
+             'syntax-span rumble:correlated-span)]
       [else #f]))
 
   ;; For direct access by schemified schemify:
@@ -54,6 +56,7 @@
   (define syntax-line rumble:correlated-line)
   (define syntax-column rumble:correlated-column)
   (define syntax-position rumble:correlated-position)
+  (define syntax-span rumble:correlated-span)
 
   (include "include.ss")
   (include-generated "schemify.scm")

racket/src/io/Makefile

@@ -28,7 +28,9 @@ GLOBALS = --no-global \
           ++global-ok run-file \
           ++global-ok collects-dir \
           ++global-ok config-dir \
-          ++global-ok addon-dir
+          ++global-ok addon-dir \
+          ++global-ok host-collects-dir \
+          ++global-ok host-config-dir
 
 io-src: $(RKTIO_DEP)
 	$(RACO) make ../expander/bootstrap-run.rkt

racket/src/io/main.rkt

@@ -53,7 +53,8 @@
          (all-from-out "machine/main.rkt")
          (all-from-out "run/main.rkt")
          make-place-ports+fds
-         io-place-init!)
+         io-place-init!
+         get-original-error-port)
 
 (define (io-place-init! in-fd out-fd err-fd cust plumber)
   (sandman-place-init!)

racket/src/io/path/main.rkt

@@ -61,6 +61,8 @@
          set-collects-dir!
          set-config-dir!
          set-addon-dir!
+         set-host-collects-dir!
+         set-host-config-dir!
 
          _path)
 

racket/src/io/path/system.rkt

@@ -17,6 +17,8 @@
          set-collects-dir!
          set-config-dir!
          set-addon-dir!
+         set-host-collects-dir!
+         set-host-config-dir!
 
          init-current-directory!)
 
@@ -28,9 +30,15 @@
                        (string->path "/usr/local/bin/racket"))]
       [(run-file) (or run-file
                       (find-system-path 'exec-file))]
-      [(config-dir host-config-dir) (as-dir (or config-dir
+      [(config-dir) (as-dir (or config-dir
                                                 (string->path "../etc")))]
-      [(collects-dir host-collects-dir) (as-dir (or collects-dir
+      [(collects-dir) (as-dir (or collects-dir
+                                  (string->path "../collects")))]
+      [(host-config-dir) (as-dir (or host-config-dir
+                                     config-dir
+                                     (string->path "../etc")))]
+      [(host-collects-dir) (as-dir (or host-collects-dir
+                                       collects-dir
                                        (string->path "../collects")))]
       [(orig-dir) (as-dir orig-dir)]
       [(temp-dir) (as-dir (rktio-system-path who RKTIO_PATH_TEMP_DIR))]
@@ -96,6 +104,12 @@
 (define addon-dir #f)
 (define (set-addon-dir! p) (set! addon-dir p))
 
+(define host-collects-dir #f)
+(define (set-host-collects-dir! p) (set! host-collects-dir p))
+
+(define host-config-dir #f)
+(define (set-host-config-dir! p) (set! host-config-dir p))
+
 (define (rktio-system-path who key)
   (start-atomic)
   (define s (rktio_system_path rktio key))

racket/src/io/port/parameter.rkt

@@ -14,7 +14,8 @@
          orig-output-port
          orig-error-port
 
-         init-current-ports!)
+         init-current-ports!
+         get-original-error-port)
 
 (define (make-stdin)
   (open-input-fd (check-rktio-error
@@ -80,3 +81,5 @@
                                         #:plumber plumber))
   (current-error-port orig-error-port))
 
+(define (get-original-error-port)
+  orig-error-port)

racket/src/schemify/infer-name.rkt

@@ -11,7 +11,7 @@
      ;; `infer-procedure-name`) take care of it
      new-s]
     [else
-     (define-values (src line col pos) (wrap-source orig-s))
+     (define-values (src line col pos span) (wrap-source orig-s))
      (define (add-property str)
        (wrap-property-set (reannotate orig-s new-s)
                           'inferred-name

racket/src/schemify/inline.rkt

@@ -3,7 +3,8 @@
          "match.rkt"
          "known.rkt"
          "import.rkt"
-         "export.rkt")
+         "export.rkt"
+         "wrap-path.rkt")
 
 (provide init-inline-fuel
          can-inline?
@@ -203,18 +204,23 @@
 
 ;; ----------------------------------------
 
-(define (known-inline->export-known k prim-knowns imports exports)
+(define (known-inline->export-known k prim-knowns imports exports serializable?)
   (cond
     [(known-procedure/can-inline? k)
+     (define expr (known-procedure/can-inline-expr k))
      (define needed
-       (needed-imports (known-procedure/can-inline-expr k) prim-knowns imports exports '() '#hasheq()))
+       (needed-imports expr prim-knowns imports exports '() '#hasheq()))
      (cond
        [(not needed) (known-procedure (known-procedure-arity-mask k))]
-       [(hash-empty? needed) k]
+       [(hash-empty? needed) (cond
+                               [serializable? (known-procedure/can-inline
+                                               (known-procedure-arity-mask k)
+                                               (wrap-truncate-paths expr))]
+                               [else k])]
        [else
         (known-procedure/can-inline/need-imports
          (known-procedure-arity-mask k)
-         (known-procedure/can-inline-expr k)
+         (if serializable? (wrap-truncate-paths expr) expr)
          (hash->list needed))])]
     [(known-field-accessor? k)
      (define needed (needed-imports (known-field-accessor-type-id k) prim-knowns imports exports '() '#hasheq()))

racket/src/schemify/schemify.rkt

@@ -169,7 +169,8 @@
       (for/fold ([knowns (hasheq)]) ([ex-id (in-list ex-ids)])
         (define id (ex-int-id ex-id))
         (define v (known-inline->export-known (hash-ref defn-info id #f)
-                                              prim-knowns imports exports))
+                                              prim-knowns imports exports
+                                              serializable?))
         (cond
          [(not (set!ed-mutated-state? (hash-ref mutated id #f)))
           (define ext-id (ex-ext-id ex-id))

racket/src/schemify/wrap-path.rkt

@@ -0,0 +1,31 @@
+#lang racket/base
+(require racket/private/truncate-path
+         "wrap.rkt"
+         "match.rkt")
+
+;; We can't store paths in known-value information, so check through
+;; wraps to convert to strings any that we find in source locations.
+
+(provide wrap-truncate-paths)
+
+(define (wrap-truncate-paths e)
+  (cond
+    [(wrap? e)
+     (define orig (unwrap e))
+     (define u-e (wrap-truncate-paths orig))
+     (define-values (src line col pos span) (wrap-source e))
+     (cond
+       [(and (not (path? src))
+             (eq? orig u-e))
+        e]
+       [else
+        (reannotate/new-srcloc e u-e (srcloc (truncate-path src) line col pos span))])]
+    [(pair? e)
+     (define a (wrap-truncate-paths (car e)))
+     (define d (wrap-truncate-paths (cdr e)))
+     (cond
+       [(and (eq? a (car e))
+             (eq? d (cdr e)))
+        e]
+       [else (cons a d)])]
+    [else e]))

racket/src/schemify/wrap.rkt

@@ -3,13 +3,15 @@
          (for-syntax racket/base))
 
 (provide unwrap unwrap-list
+         wrap?
          wrap-pair? wrap-null? wrap-car wrap-cdr wrap-list?
          wrap-eq? wrap-equal?
          in-wrap-list
          wrap-property
          wrap-property-set
          wrap-source
-         reannotate)
+         reannotate
+         reannotate/new-srcloc)
 
 (import-from-primitive-table
  #%kernel
@@ -20,13 +22,17 @@
  [syntax-source correlated-source]
  [syntax-line correlated-line]
  [syntax-column correlated-column]
- [syntax-position correlated-position])
+ [syntax-position correlated-position]
+ [syntax-span correlated-span])
 
 (define (unwrap v)
   (if (correlated? v)
       (correlated-e v)
       v))
 
+(define (wrap? v)
+  (correlated? v))
+
 (define (unwrap-list v)
   (cond
     [(null? v) null]
@@ -86,14 +92,18 @@
      (values (correlated-source a)
              (correlated-line a)
              (correlated-column a)
-             (correlated-position a))]
+             (correlated-position a)
-    [else (values #f #f #f #f)]))
+             (correlated-span a))]
+    [else (values #f #f #f #f #f)]))
 
 (define (reannotate old-term new-term)
   (if (correlated? old-term)
-      (datum->correlated #f new-term old-term)
+      (datum->correlated #f new-term old-term old-term)
       new-term))
 
+(define (reannotate/new-srcloc old-term new-term new-srcloc)
+  (datum->correlated #f new-term new-srcloc old-term))
+
 (define-sequence-syntax in-wrap-list
   (lambda (stx) (raise-argument-error "allowed only in `for` forms" stx))
   (lambda (stx)