diff --git a/pkgs/racket-doc/scribblings/reference/linklet.scrbl b/pkgs/racket-doc/scribblings/reference/linklet.scrbl index f274cc4d3a..1832fcc067 100644 --- a/pkgs/racket-doc/scribblings/reference/linklet.scrbl +++ b/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].}]} diff --git a/racket/collects/compiler/private/cm-minimal.rkt b/racket/collects/compiler/private/cm-minimal.rkt index 26ebda46e4..edcc9ab9ba 100644 --- a/racket/collects/compiler/private/cm-minimal.rkt +++ b/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 diff --git a/racket/collects/racket/linklet.rkt b/racket/collects/racket/linklet.rkt index 8abd75a517..97eff8524e 100644 --- a/racket/collects/racket/linklet.rkt +++ b/racket/collects/racket/linklet.rkt @@ -64,8 +64,8 @@ (define (correlated? e) (syntax? e)) -(define (datum->correlated d [srcloc #f]) - (datum->syntax #f d srcloc)) +(define (datum->correlated d [srcloc #f] [props #f]) + (datum->syntax #f d srcloc props)) (define (correlated-e e) (syntax-e e)) diff --git a/racket/src/cs/Makefile b/racket/src/cs/Makefile index 4cb7af13d9..0af1458d2f 100644 --- a/racket/src/cs/Makefile +++ b/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) diff --git a/racket/src/cs/c/Makefile.in b/racket/src/cs/c/Makefile.in index e749fc8da1..5caa9d4a6a 100644 --- a/racket/src/cs/c/Makefile.in +++ b/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 diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 36964610e0..9cc2254ac4 100644 --- a/racket/src/cs/linklet.sls +++ b/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 ) 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 - (lambda () - ((if serializable? compile-to-bytevector outer-eval) - (show (and jitify-mode? post-interp-on?) "post-interp" impl-lam/interpable) - paths - format))) + (let ([lk (make-linklet ((if serializable? + (if cross-machine + (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) paths format - (if serializable? 'faslable 'callable) + (if serializable? (if cross-machine (cons 'cross cross-machine) 'faslable) 'callable) importss-abi exports-info name @@ -974,6 +1019,8 @@ (loop (cdr vars) (cdr syms))))])) ;; -------------------------------------------------- + + (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)))) diff --git a/racket/src/cs/linklet/annotation.ss b/racket/src/cs/linklet/annotation.ss index 740302bd38..2ec572b942 100644 --- a/racket/src/cs/linklet/annotation.ss +++ b/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)])))) diff --git a/racket/src/cs/linklet/cross-compile.ss b/racket/src/cs/linklet/cross-compile.ss new file mode 100644 index 0000000000..5efd0c7b86 --- /dev/null +++ b/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 ) +(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 ) +;; 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 ) + (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)))) diff --git a/racket/src/cs/linklet/write.ss b/racket/src/cs/linklet/write.ss index 0fe64ce098..f671987b79 100644 --- a/racket/src/cs/linklet/write.ss +++ b/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 ([(o get) (open-bytevector-output-port)]) - (fasl-write* (encode-linklet-paths ht) o) - (let ([bstr (get)]) + (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* ht o) + (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 - (set-linklet-paths - v - (map path->compiled-path - (linklet-paths v)))) + (adjust-cross-perparation + (set-linklet-paths + v + (map path->compiled-path + (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)) diff --git a/racket/src/cs/main.sps b/racket/src/cs/main.sps index 36648f9c64..8e255355db 100644 --- a/racket/src/cs/main.sps +++ b/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-config-dir init-config-dir) + (define host-collects-dir #f) + (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 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? - (|#%app| current-compile-target-machine #f)) + (unless (eq? compile-target-machine (machine-type)) + (|#%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)) diff --git a/racket/src/cs/main/cross-compile.ss b/racket/src/cs/main/cross-compile.ss new file mode 100644 index 0000000000..6c084b8e6d --- /dev/null +++ b/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)) diff --git a/racket/src/cs/main/help.ss b/racket/src/cs/main/help.ss index ed18fc7669..8d67c66391 100644 --- a/racket/src/cs/main/help.ss +++ b/racket/src/cs/main/help.ss @@ -64,6 +64,9 @@ " -W , --warn : Set stderr logging to \n" " -O , --stdout : Set stdout logging to \n" " -L , --syslog : Set syslog logging to \n" + " --compile-machine : Compile for \n" + " --cross-compiler : Use compiler plugin for \n" + " --cross-server : 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" diff --git a/racket/src/cs/rumble/correlated.ss b/racket/src/cs/rumble/correlated.ss index 7f8c9f2406..e8173eafff 100644 --- a/racket/src/cs/rumble/correlated.ss +++ b/racket/src/cs/rumble/correlated.ss @@ -9,28 +9,32 @@ (define-record correlated (e srcloc props)) -(define/who (datum->correlated ignored datum src) - (check who - :test (or (not src) (correlated? src) (srcloc? src) (encoded-srcloc? src)) - :contract (string-append "(or #f syntax? srcloc?\n" - " (list/c any/c\n" - " (or/c exact-positive-integer? #f)\n" - " (or/c exact-nonnegative-integer? #f)\n" - " (or/c exact-positive-integer? #f)\n" - " (or/c exact-nonnegative-integer? #f))\n" - " (vector/c any/c\n" - " (or/c exact-positive-integer? #f)\n" - " (or/c exact-nonnegative-integer? #f)\n" - " (or/c exact-positive-integer? #f)\n" - " (or/c exact-nonnegative-integer? #f)))") - src) - (if (correlated? datum) - datum - (make-correlated datum - (extract-srcloc src) - (if (correlated? src) - (correlated-props src) - empty-hasheq)))) +(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" + " (list/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f))\n" + " (vector/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (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 props + (correlated-props props) + 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 diff --git a/racket/src/cs/schemify.sls b/racket/src/cs/schemify.sls index 5e87432ca2..01f43f4c07 100644 --- a/racket/src/cs/schemify.sls +++ b/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") diff --git a/racket/src/io/Makefile b/racket/src/io/Makefile index 35f3fa09d2..a75618b0b8 100644 --- a/racket/src/io/Makefile +++ b/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 diff --git a/racket/src/io/main.rkt b/racket/src/io/main.rkt index 245e555739..7abac1dc37 100644 --- a/racket/src/io/main.rkt +++ b/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!) diff --git a/racket/src/io/path/main.rkt b/racket/src/io/path/main.rkt index 177fe195b2..cc3111dd30 100644 --- a/racket/src/io/path/main.rkt +++ b/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) diff --git a/racket/src/io/path/system.rkt b/racket/src/io/path/system.rkt index f44a8b12fe..d5a5f713da 100644 --- a/racket/src/io/path/system.rkt +++ b/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,10 +30,16 @@ (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 - (string->path "../collects")))] + [(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))] [(sys-dir) (as-dir (rktio-system-path who RKTIO_PATH_SYS_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)) diff --git a/racket/src/io/port/parameter.rkt b/racket/src/io/port/parameter.rkt index 97c8740aea..ca582875a9 100644 --- a/racket/src/io/port/parameter.rkt +++ b/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) diff --git a/racket/src/schemify/infer-name.rkt b/racket/src/schemify/infer-name.rkt index c75cc8039b..2a59040a6f 100644 --- a/racket/src/schemify/infer-name.rkt +++ b/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 diff --git a/racket/src/schemify/inline.rkt b/racket/src/schemify/inline.rkt index 315401a055..c0f5c16868 100644 --- a/racket/src/schemify/inline.rkt +++ b/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())) diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index 866bc44eda..ca7e5f0a4c 100644 --- a/racket/src/schemify/schemify.rkt +++ b/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)) diff --git a/racket/src/schemify/wrap-path.rkt b/racket/src/schemify/wrap-path.rkt new file mode 100644 index 0000000000..6d1865cc5e --- /dev/null +++ b/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])) diff --git a/racket/src/schemify/wrap.rkt b/racket/src/schemify/wrap.rkt index 2f94b5faa7..adb76bd623 100644 --- a/racket/src/schemify/wrap.rkt +++ b/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))] - [else (values #f #f #f #f)])) + (correlated-position a) + (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)