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

cs: add cross-compilation hooks for Racket

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2019-03-02 18:59:44 -07:00
parent f720220c41
commit d71d68e72a
24 changed files with 496 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-doc/scribblings/reference/linklet.scrbl
View File

@ -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].}]}

4
racket/collects/compiler/private/cm-minimal.rkt
View File

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

4
racket/collects/racket/linklet.rkt
View File

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

6
racket/src/cs/Makefile
View File

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

9
racket/src/cs/c/Makefile.in
View File

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

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

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

66
racket/src/cs/linklet/annotation.ss
View File

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

119
racket/src/cs/linklet/cross-compile.ss Normal file
View File

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

34
racket/src/cs/linklet/write.ss
View File

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

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

@ -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 <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?
(|#%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))

34
racket/src/cs/main/cross-compile.ss Normal file
View File

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

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

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

49
racket/src/cs/rumble/correlated.ss
View File

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

7
racket/src/cs/schemify.sls
View File

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

4
racket/src/io/Makefile
View File

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

3
racket/src/io/main.rkt
View File

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

2
racket/src/io/path/main.rkt
View File

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

20
racket/src/io/path/system.rkt
View File

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

5
racket/src/io/port/parameter.rkt
View File

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

2
racket/src/schemify/infer-name.rkt
View File

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

16
racket/src/schemify/inline.rkt
View File

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

3
racket/src/schemify/schemify.rkt
View File

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

31
racket/src/schemify/wrap-path.rkt Normal file
View File

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

20
racket/src/schemify/wrap.rkt
View File

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