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

add machine-independent compilation mode

Browse Source 
The `compile-machine-indendent` parameter controls whether `compile`
creates a compiled expression that writes (usually in a ".zo" file) to
a machine-independent form that works for anhy Racket platform and
virtual machine. The parameter can be set through the
`-M`/`--compile-any` command-line flag or the `PLT_COMPILE_ANY`
environment variable.

Loading machine-independent code is too slow for many purposes, but
separating macro expansion from backend compilation seems likely to be
a piece of the puzzle from cross-compilation and faster distribution
builds.
This commit is contained in:
Matthew Flatt 2018-11-22 13:12:49 -07:00
parent fd52cb5dda
commit 2bbaa64cd6
26 changed files with 4064 additions and 1210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.1.0.4")
(define version "7.1.0.5")
(define deps `("racket-lib"
["racket" #:version ,version]))

19
pkgs/racket-doc/scribblings/reference/eval.scrbl
View File

@ -581,6 +581,25 @@ information to be lost from stack traces (as reported by
@racket[continuation-mark-set->context]). The default is @racket[#f],
which allows such optimizations.}
@defboolparam[compile-machine-independent on?]{
A @tech{parameter} that determines whether a newly compiled expression
writes in a machine-independent format (usually in @filepath{.zo}
files). Machine-independent compiled code works for any platform and
any Racket virtual machine. When the machine-independent compiled
expression is read back in, it is subject to further compilation for
the current platform and virtual machine, which can be considerably
slower than reading a format that is fully compiled for a platform and
virtual machine.
The default is @racket[#f], unless machine-independent mode is enabled
through the @Flag{M}/@DFlag{compile-any} command-line flag to
stand-alone Racket (or GRacket) or through the
@as-index{@envvar{PLT_COMPILE_ANY}} environment variable (set to any
value).
@history[#:added "7.1.0.5"]}
@defboolparam[eval-jit-enabled on?]{
@guidealso["JIT"]

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

@ -343,6 +343,11 @@ flags:
native-code just-in-time compiler by setting the
@racket[eval-jit-enabled] parameter to @racket[#f].}
@item{@FlagFirst{M} or @DFlagFirst{compile-any} : Enables
machine-independent bytecode by setting the
@racket[compile-machine-independent] parameter to
@racket[#t].}
@item{@FlagFirst{d} or @DFlagFirst{no-delay} : Disables on-demand
parsing of compiled code and syntax objects by setting the
@racket[read-on-demand-source] parameter to @racket[#f].}
@ -456,7 +461,8 @@ of the collapsed set.
Extra arguments following the last option are available from the
@indexed-racket[current-command-line-arguments] parameter.
@history[#:changed "6.90.0.17" @elem{Added @Flag{O}/@DFlag{stdout}.}]
@history[#:changed "6.90.0.17" @elem{Added @Flag{O}/@DFlag{stdout}.}
#:changed "7.1.0.5" @elem{Added @Flag{M}/@DFlag{compile-any}.}]
@; ----------------------------------------------------------------------

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

@ -31,6 +31,7 @@
compile-enforce-module-constants
compile-context-preservation-enabled
compile-allow-set!-undefined
compile-machine-independent
eval-jit-enabled
load-on-demand-enabled
@ -820,6 +821,9 @@
(define compile-allow-set!-undefined
(make-parameter #f (lambda (v) (and v #t))))
(define compile-machine-independent
(make-parameter #f (lambda (v) (and v #t))))
(define eval-jit-enabled
(make-parameter #t (lambda (v) (and v #t))))

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

@ -40,7 +40,8 @@
omit-debugging?
platform-independent-zo-mode?
linklet-performance-init!
linklet-performance-report!))
linklet-performance-report!
compile-machine-independent))
(linklet-performance-init!)
(unless omit-debugging?
@ -108,6 +109,7 @@
[else "compiled"]))))
(define user-specific-search-paths? #t)
(define load-on-demand? #t)
(define compile-machine-independent? (getenv "PLT_COMPILE_ANY"))
(define (see saw . args)
(let loop ([saw saw] [args args])
@ -424,6 +426,9 @@
(loop (cdr args))]
[else
(raise-bad-switch arg within-arg)])]
[("-M")
(set! compile-machine-independent? #t)
(loop (cdr args))]
[("--")
(cond
[(or (null? (cdr args)) (not (pair? (cadr args))))
@ -564,6 +569,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| compile-machine-independent #t))
(boot)
(when (and stderr-logging
(not (null? stderr-logging)))

1
racket/src/cs/primitive/kernel.ss
View File

@ -184,6 +184,7 @@
[compile-allow-set!-undefined (known-constant)]
[compile-context-preservation-enabled (known-constant)]
[compile-enforce-module-constants (known-constant)]
[compile-machine-independent (known-constant)]
[complete-path? (known-procedure 2)]
[complex? (known-procedure/succeeds 2)]
[cons (known-procedure/succeeds 4)]

125
racket/src/expander/compile/correlated-linklet.rkt Normal file
View File

@ -0,0 +1,125 @@
#lang racket/base
(require racket/fasl
"../host/linklet.rkt"
"../host/correlate.rkt")
(provide correlated-linklet?
make-correlated-linklet
correlated-linklet-expr
correlated-linklet-name
force-compile-linklet
correlated-linklet-vm-bytes
write-correlated-linklet-bundle-hash
read-correlated-linklet-bundle-hash)
(struct correlated-linklet (expr name [compiled #:mutable])
#:authentic)
(define (make-correlated-linklet expr name)
(correlated-linklet expr name #f))
;; ----------------------------------------
(define (force-compile-linklet l)
(cond
[(correlated-linklet? l)
(or (correlated-linklet-compiled l)
(let ([c (compile-linklet (correlated-linklet-expr l)
(correlated-linklet-name l))])
(set-correlated-linklet-compiled! l c)
c))]
[else l]))
;; ----------------------------------------
(define correlated-linklet-vm-bytes #"linklet")
(struct faslable-correlated (e source position line column span name)
#:prefab)
(struct faslable-correlated-linklet (expr name)
#:prefab)
;; ----------------------------------------
(define (write-correlated-linklet-bundle-hash ht o)
(s-exp->fasl (->faslable ht) o))
(define (->faslable v)
(cond
[(pair? v)
(define a (->faslable (car v)))
(define d (->faslable (cdr v)))
(if (and (eq? a (car v))
(eq? d (cdr v)))
v
(cons a d))]
[(correlated? v)
(faslable-correlated
(->faslable (correlated-e v))
(correlated-source v)
(correlated-position v)
(correlated-line v)
(correlated-column v)
(correlated-span v)
(correlated-property v 'inferred-name))]
[(hash? v)
(cond
[(hash-eq? v)
(for/hasheq ([(key value) (in-hash v)])
(values (->faslable key) (->faslable value)))]
[(hash-eqv? v)
(for/hasheqv ([(key value) (in-hash v)])
(values (->faslable key) (->faslable value)))]
[else
(for/hash ([(key value) (in-hash v)])
(values (->faslable key) (->faslable value)))])]
[(correlated-linklet? v)
(faslable-correlated-linklet (->faslable (correlated-linklet-expr v))
(->faslable (correlated-linklet-name v)))]
[else v]))
;; ----------------------------------------
(define (read-correlated-linklet-bundle-hash in)
(faslable-> (fasl->s-exp in)))
(define (faslable-> v)
(cond
[(pair? v)
(define a (faslable-> (car v)))
(define d (faslable-> (cdr v)))
(if (and (eq? a (car v))
(eq? d (cdr v)))
v
(cons a d))]
[(faslable-correlated? v)
(define name (faslable-correlated-name v))
(define c (datum->correlated (faslable-> (faslable-correlated-e v))
(vector
(faslable-correlated-source v)
(faslable-correlated-line v)
(faslable-correlated-column v)
(faslable-correlated-position v)
(faslable-correlated-span v))))
(if name
(correlated-property c 'inferred-name name)
c)]
[(hash? v)
(cond
[(hash-eq? v)
(for/hasheq ([(key value) (in-hash v)])
(values (faslable-> key) (faslable-> value)))]
[(hash-eqv? v)
(for/hasheqv ([(key value) (in-hash v)])
(values (faslable-> key) (faslable-> value)))]
[else
(for/hash ([(key value) (in-hash v)])
(values (faslable-> key) (faslable-> value)))])]
[(faslable-correlated-linklet? v)
(make-correlated-linklet (faslable-> (faslable-correlated-linklet-expr v))
(faslable-> (faslable-correlated-linklet-name v)))]
[else v]))

111
racket/src/expander/compile/form.rkt
View File

@ -23,7 +23,8 @@
"namespace-scope.rkt"
"expr.rkt"
"extra-inspector.rkt"
"correlate.rkt")
"correlate.rkt"
"correlated-linklet.rkt")
(provide compile-forms
@ -45,6 +46,7 @@
#:other-form-callback [other-form-callback void]
#:get-module-linklet-info [get-module-linklet-info (lambda (mod-name p) #f)] ; to support submodules
#:serializable? [serializable? #t]
#:to-correlated-linklet? [to-correlated-linklet? #f]
#:cross-linklet-inlining? [cross-linklet-inlining? #t])
(define phase (compile-context-phase cctx))
(define self (compile-context-self cctx))
@ -246,44 +248,38 @@
(define module-use*s
(module-uses-add-extra-inspectorsss (link-info-link-module-uses li)
(link-info-extra-inspectorsss li)))
;; Compile the linklet with support for cross-module inlining, which
;; means that the set of imports can change:
(define body-linklet
`(linklet
;; imports
(,@body-imports
,@(link-info-imports li))
;; exports
(,@(link-info-def-decls li)
,@(for/list ([binding-sym (in-list (header-binding-syms-in-order
(hash-ref phase-to-header phase)))])
(define def-sym (hash-ref binding-sym-to-define-sym binding-sym))
(if (eq? def-sym binding-sym)
def-sym
`[,def-sym ,binding-sym])))
;; body
,@(reverse bodys)
,@body-suffix-forms))
(define-values (linklet new-module-use*s)
(performance-region
['compile '_ 'linklet]
((lambda (l name keys getter)
(compile-linklet l name keys getter (if serializable? '(serializable) '())))
`(linklet
;; imports
(,@body-imports
,@(link-info-imports li))
;; exports
(,@(link-info-def-decls li)
,@(for/list ([binding-sym (in-list (header-binding-syms-in-order
(hash-ref phase-to-header phase)))])
(define def-sym (hash-ref binding-sym-to-define-sym binding-sym))
(if (eq? def-sym binding-sym)
def-sym
`[,def-sym ,binding-sym])))
;; body
,@(reverse bodys)
,@body-suffix-forms)
'module
;; Support for cross-module optimization starts with a vector
;; of keys for the linklet imports; we use `module-use` values
;; as keys, plus #f or an instance (=> cannot be pruned) for
;; each boilerplate linklet
(list->vector (append body-import-instances
module-use*s))
;; To complete cross-module support, map a key (which is a `module-use`)
;; to a linklet and an optional vector of keys for that linklet's
;; imports:
(make-module-use-to-linklet cross-linklet-inlining?
(compile-context-namespace cctx)
get-module-linklet-info
module-use*s))))
(values phase (cons linklet (list-tail (vector->list new-module-use*s)
(length body-imports))))))
(cond
[to-correlated-linklet?
(values (make-correlated-linklet body-linklet 'module) module-use*s)]
[else
;; Compile the linklet with support for cross-module inlining, which
;; means that the set of imports can change:
(compile-module-linklet body-linklet
#:body-imports body-imports
#:body-import-instances body-import-instances
#:get-module-linklet-info get-module-linklet-info
#:serializable? serializable?
#:module-use*s module-use*s
#:cross-linklet-inlining? cross-linklet-inlining?
#:namespace (compile-context-namespace cctx))]))
(values phase (cons linklet new-module-use*s))))
(define body-linklets
(for/hasheq ([(phase l+mu*s) (in-hash body-linklets+module-use*s)])
@ -301,7 +297,8 @@
[(extra-inspectorsss) (in-value (module-uses-extract-extra-inspectorsss
(cdr l+mu*s)
(car l+mu*s)
cross-linklet-inlining?
(and cross-linklet-inlining?
(not to-correlated-linklet?))
(length body-imports)))]
#:when extra-inspectorsss)
(values phase extra-inspectorsss)))
@ -385,6 +382,42 @@
;; ----------------------------------------
;; Compile the linklet with support for cross-module inlining, which
;; means that the set of imports can change: return a compiled linklet
;; and a list of `module-use*`
(define (compile-module-linklet body-linklet
#:body-imports body-imports
#:body-import-instances body-import-instances
#:get-module-linklet-info get-module-linklet-info
#:serializable? serializable?
#:module-use*s module-use*s
#:cross-linklet-inlining? cross-linklet-inlining?
#:namespace namespace)
(define-values (linklet new-module-use*s)
(performance-region
['compile '_ 'linklet]
((lambda (l name keys getter)
(compile-linklet l name keys getter (if serializable? '(serializable) '())))
body-linklet
'module
;; Support for cross-module optimization starts with a vector
;; of keys for the linklet imports; we use `module-use` values
;; as keys, plus #f or an instance (=> cannot be pruned) for
;; each boilerplate linklet
(list->vector (append body-import-instances
module-use*s))
;; To complete cross-module support, map a key (which is a `module-use`)
;; to a linklet and an optional vector of keys for that linklet's
;; imports:
(make-module-use-to-linklet cross-linklet-inlining?
namespace
get-module-linklet-info
module-use*s))))
(values linklet (list-tail (vector->list new-module-use*s)
(length body-imports))))
;; ----------------------------------------
(define (make-module-use-to-linklet cross-linklet-inlining? ns get-module-linklet-info init-mu*s)
;; Inlining might reach the same module though different indirections;
;; use a consistent `module-use` value so that the compiler knows to

21
racket/src/expander/compile/linklet.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base
(require "../common/contract.rkt"
"../host/linklet.rkt"
"write-linklet.rkt")
"write-linklet.rkt"
"correlated-linklet.rkt")
(provide linklet-directory?
linklet-bundle?
@ -15,6 +16,7 @@
(struct linklet-directory (ht)
#:property prop:custom-write (lambda (ld port mode)
(write-linklet-directory ld
(correlated-linklet-directory? ld)
linklet-directory->hash
linklet-bundle->hash
port)))
@ -22,6 +24,7 @@
(struct linklet-bundle (ht)
#:property prop:custom-write (lambda (b port mode)
(write-linklet-bundle b
(correlated-linklet-bundle? b)
linklet-bundle->hash
port)))
@ -73,3 +76,19 @@
(define/who (linklet-bundle->hash ld)
(check who linklet-bundle? ld)
(linklet-bundle-ht ld))
;; ----------------------------------------
;; If there are no values that satisfy `linklet?`, then
;; assume that we have `correlated-linklet?` values.
(define (correlated-linklet-directory? ld)
(for/and ([(k v) (in-hash (linklet-directory->hash ld))])
(cond
[(not k) (correlated-linklet-bundle? v)]
[(symbol? k) (correlated-linklet-directory? v)]
[else #t])))
(define (correlated-linklet-bundle? b)
(for/and ([(k v) (in-hash (linklet-bundle->hash b))])
(not (linklet? v))))

69
racket/src/expander/compile/module.rkt
View File

@ -22,6 +22,7 @@
"form.rkt"
"compiled-in-memory.rkt"
"linklet.rkt"
"correlated-linklet.rkt"
"../eval/reflect.rkt"
"../eval/reflect-name.rkt")
@ -32,6 +33,7 @@
(define (compile-module p cctx
#:force-linklet-directory? [force-linklet-directory? #f]
#:serializable? [serializable? #f]
#:to-correlated-linklet? [to-correlated-linklet? #f]
#:modules-being-compiled [modules-being-compiled (make-hasheq)]
#:need-compiled-submodule-rename? [need-compiled-submodule-rename? #t])
@ -74,6 +76,7 @@
#:full-module-name full-module-name
#:force-linklet-directory? force-linklet-directory?
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?
#:modules-being-compiled modules-being-compiled
#:pre-submodules pre-submodules
#:post-submodules post-submodules
@ -85,6 +88,7 @@
#:full-module-name full-module-name
#:force-linklet-directory? force-linklet-directory?
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?
#:modules-being-compiled modules-being-compiled
#:pre-submodules pre-submodules
#:post-submodules post-submodules
@ -167,7 +171,8 @@
(define ht (and modules-being-compiled
(hash-ref modules-being-compiled mod-name #f)))
(and ht (hash-ref ht phase #f)))
#:serializable? serializable?))
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?))
(when modules-being-compiled
;; Record this module's linklets for cross-module inlining among (sub)modules
@ -189,9 +194,12 @@
;; declaration, and is shared among instances
(define declaration-linklet
(and serializable?
((lambda (s) (performance-region
['compile 'module 'linklet]
(compile-linklet s 'decl)))
((lambda (s)
(if to-correlated-linklet?
(make-correlated-linklet s 'decl)
(performance-region
['compile 'module 'linklet]
(compile-linklet s 'decl))))
`(linklet
;; imports
(,deserialize-imports
@ -214,17 +222,19 @@
(define syntax-literals-linklet
(and (not (syntax-literals-empty? syntax-literals))
((lambda (s)
(performance-region
['compile 'module 'linklet]
(define-values (linklet new-keys)
(compile-linklet s 'syntax-literals
(vector deserialize-instance
empty-top-syntax-literal-instance
empty-syntax-literals-data-instance
empty-instance-instance)
(lambda (inst) (values inst #f))
(if serializable? '(serializable) '())))
linklet))
(if to-correlated-linklet?
(make-correlated-linklet s 'syntax-literals)
(performance-region
['compile 'module 'linklet]
(define-values (linklet new-keys)
(compile-linklet s 'syntax-literals
(vector deserialize-instance
empty-top-syntax-literal-instance
empty-syntax-literals-data-instance
empty-instance-instance)
(lambda (inst) (values inst #f))
(if serializable? '(serializable) '())))
linklet)))
`(linklet
;; imports
(,deserialize-imports
@ -262,9 +272,11 @@
(define syntax-literals-data-linklet
(and serializable?
(not (syntax-literals-empty? syntax-literals))
((lambda (s) (performance-region
['compile 'module 'linklet]
(compile-linklet s 'syntax-literals-data)))
((lambda (s) (if to-correlated-linklet?
(make-correlated-linklet s 'syntax-literals-data)
(performance-region
['compile 'module 'linklet]
(compile-linklet s 'syntax-literals-data))))
`(linklet
;; imports
(,deserialize-imports
@ -284,9 +296,11 @@
;; across module instances.
(define data-linklet
(and serializable?
((lambda (s) (performance-region
['compile 'module 'linklet]
(compile-linklet s 'data)))
((lambda (s) (if to-correlated-linklet?
(make-correlated-linklet s 'data)
(performance-region
['compile 'module 'linklet]
(compile-linklet s 'data))))
`(linklet
;; imports
(,deserialize-imports)
@ -348,12 +362,13 @@
;; Just use the bundle representation directly:
bundle]
[else
(hash->linklet-directory
(for/fold ([ht (hasheq #f bundle)]) ([sm (in-list (append pre-submodules post-submodules))])
(hash-set ht
(car sm)
(compiled-in-memory-linklet-directory
(cdr sm)))))]))
(define ht
(for/fold ([ht (hasheq #f bundle)]) ([sm (in-list (append pre-submodules post-submodules))])
(hash-set ht
(car sm)
(compiled-in-memory-linklet-directory
(cdr sm)))))
(hash->linklet-directory ht)]))
;; Save mpis and syntax for direct evaluation, instead of unmarshaling:
(compiled-in-memory ld

1
racket/src/expander/compile/multi-top.rkt
View File

@ -19,6 +19,7 @@
;; top of a tree, we repeat work only twice and avoid non-linear
;; behavior.)
(define (compiled-tops->compiled-top all-cims
#:to-correlated-linklet? [to-correlated-linklet? #f]
#:merge-serialization? [merge-serialization? #f]
#:namespace [ns #f]) ; need for `merge-serialization?`
(define cims (remove-nontail-purely-functional all-cims))

11
racket/src/expander/compile/read-linklet.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base
(require "version-bytes.rkt"
"linklet.rkt"
"../host/linklet.rkt")
"../host/linklet.rkt"
"correlated-linklet.rkt")
(provide read-linklet-bundle-or-directory)
@ -23,7 +24,9 @@
in))))
(define vm-len (min 63 (read-byte in)))
(define vm (read-bytes vm-len in))
(unless (equal? vm vm-bytes)
(define as-correlated-linklet? (equal? vm correlated-linklet-vm-bytes))
(unless (or as-correlated-linklet?
(equal? vm vm-bytes))
(raise-arguments-error 'read-compiled-linklet
"virtual-machine mismatch"
"expected" (bytes->string/utf-8 vm-bytes)
@ -37,7 +40,9 @@
(cond
[(eqv? tag (char->integer #\B))
(define sha-1 (read-bytes 20 in))
(define b-ht (read-linklet-bundle-hash in))
(define b-ht (if as-correlated-linklet?
(read-correlated-linklet-bundle-hash in)
(read-linklet-bundle-hash in)))
(hash->linklet-bundle
(add-hash-code (if initial?
(strip-submodule-references b-ht)

27
racket/src/expander/compile/top.rkt
View File

@ -20,7 +20,8 @@
"form.rkt"
"multi-top.rkt"
"namespace-scope.rkt"
"side-effect.rkt")
"side-effect.rkt"
"correlated-linklet.rkt")
(provide compile-single
compile-top)
@ -39,7 +40,8 @@
;; used.
(define (compile-top p cctx
#:serializable? [serializable? #t]
#:single-expression? [single-expression? #f])
#:single-expression? [single-expression? #f]
#:to-correlated-linklet? [to-correlated-linklet? #f])
(performance-region
['compile (if single-expression? 'transformer 'top)]
@ -71,6 +73,7 @@
empty-top-syntax-literal-instance
empty-instance-instance)
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?
#:definition-callback (lambda () (set! purely-functional? #f))
#:compiled-expression-callback
(lambda (e expected-results phase required-reference?)
@ -106,15 +109,17 @@
(define link-linklet
((lambda (s)
(performance-region
['compile 'top 'linklet]
(define-values (linklet new-keys)
(compile-linklet s
#f
(vector deserialize-instance
empty-eager-instance-instance)
(lambda (inst) (values inst #f))))
linklet))
(if to-correlated-linklet?
(make-correlated-linklet s #f)
(performance-region
['compile 'top 'linklet]
(define-values (linklet new-keys)
(compile-linklet s
#f
(vector deserialize-instance
empty-eager-instance-instance)
(lambda (inst) (values inst #f))))
linklet)))
`(linklet
;; imports
(,deserialize-imports

115
racket/src/expander/compile/write-linklet.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base
(require "../host/linklet.rkt"
"version-bytes.rkt")
"version-bytes.rkt"
"correlated-linklet.rkt")
(provide write-linklet-bundle
write-linklet-directory)
(define (write-linklet-bundle b linklet-bundle->hash port)
(define (write-linklet-bundle b as-correlated-linklet? linklet-bundle->hash port)
;; Various tools expect a particular header:
;; "#~"
;; length of version byte string (< 64) as one byte
@ -15,19 +16,24 @@
(write-bytes #"#~" port)
(write-bytes (bytes (bytes-length version-bytes)) port)
(write-bytes version-bytes port)
(write-bytes (bytes (bytes-length vm-bytes)) port)
(write-bytes vm-bytes port)
(let ([vm-bytes (if as-correlated-linklet?
correlated-linklet-vm-bytes
vm-bytes)])
(write-bytes (bytes (bytes-length vm-bytes)) port)
(write-bytes vm-bytes port))
(write-bytes #"B" port)
(write-bytes (make-bytes 20 0) port)
;; The rest is whatever the VM wants
(write-linklet-bundle-hash (linklet-bundle->hash b) port))
(if as-correlated-linklet?
(write-correlated-linklet-bundle-hash (linklet-bundle->hash b) port)
(write-linklet-bundle-hash (linklet-bundle->hash b) port)))
(define (linklet-bundle->bytes b linklet-bundle->hash)
(define (linklet-bundle->bytes b as-correlated-linklet? linklet-bundle->hash)
(define o (open-output-bytes))
(write-linklet-bundle b linklet-bundle->hash o)
(write-linklet-bundle b as-correlated-linklet? linklet-bundle->hash o)
(get-output-bytes o))
(define (write-linklet-directory ld linklet-directory->hash linklet-bundle->hash port)
(define (write-linklet-directory ld as-correlated-linklet? linklet-directory->hash linklet-bundle->hash port)
;; Various tools expect a particular header:
;; "#~"
;; length of version byte string (< 64) as one byte
@ -46,51 +52,54 @@
;; A bundle name corresponds to a list of symbols. Each symbol in the list is
;; prefixed with either: its length as a byte if less than 255; 255 followed by
;; a 4-byte integer for the length.
(write-bytes #"#~" port)
(write-byte (bytes-length version-bytes) port)
(write-bytes version-bytes port)
(write-byte (bytes-length vm-bytes) port)
(write-bytes vm-bytes port)
(write-bytes #"D" port)
;; Flatten a directory of bundles into a vector of pairs, where
;; each pair has the encoded bundle name and the bundle bytes
(define (flatten-linklet-directory ld rev-name-prefix accum)
(define-values (new-accum saw-bundle?)
(for/fold ([accum accum] [saw-bundle? #f]) ([(key value) (in-hash (linklet-directory->hash ld))])
(cond
[(eq? key #f)
(values (cons (cons (encode-name rev-name-prefix)
(linklet-bundle->bytes value linklet-bundle->hash))
accum)
#t)]
[else
(values (flatten-linklet-directory value (cons key rev-name-prefix) accum)
saw-bundle?)])))
(cond
[saw-bundle? new-accum]
[else (cons (cons (encode-name rev-name-prefix)
#"#f")
new-accum)]))
(define bundles (list->vector
(sort (flatten-linklet-directory ld '() '())
(lambda (a b) (bytes<? (car a) (car b))))))
(define len (vector-length bundles))
(define initial-offset (+ 2 ; "#~"
1 ; version length
(bytes-length version-bytes)
1 ; vm length
(bytes-length vm-bytes)
1 ; D
4)) ; bundle count
(write-int len port) ; bundle count
;; Compute bundle offsets
(define btree-size (compute-btree-size bundles len))
(define node-offsets (compute-btree-node-offsets bundles len initial-offset))
(define bundle-offsets (compute-bundle-offsets bundles len (+ initial-offset btree-size)))
(write-directory-btree bundles node-offsets bundle-offsets len port)
;; Write the bundles
(for ([i (in-range len)])
(write-bytes (cdr (vector-ref bundles i)) port)))
(let ([vm-bytes (if as-correlated-linklet?
correlated-linklet-vm-bytes
vm-bytes)])
(write-bytes #"#~" port)
(write-byte (bytes-length version-bytes) port)
(write-bytes version-bytes port)
(write-byte (bytes-length vm-bytes) port)
(write-bytes vm-bytes port)
(write-bytes #"D" port)
;; Flatten a directory of bundles into a vector of pairs, where
;; each pair has the encoded bundle name and the bundle bytes
(define (flatten-linklet-directory ld rev-name-prefix accum)
(define-values (new-accum saw-bundle?)
(for/fold ([accum accum] [saw-bundle? #f]) ([(key value) (in-hash (linklet-directory->hash ld))])
(cond
[(eq? key #f)
(values (cons (cons (encode-name rev-name-prefix)
(linklet-bundle->bytes value as-correlated-linklet? linklet-bundle->hash))
accum)
#t)]
[else
(values (flatten-linklet-directory value (cons key rev-name-prefix) accum)
saw-bundle?)])))
(cond
[saw-bundle? new-accum]
[else (cons (cons (encode-name rev-name-prefix)
#"#f")
new-accum)]))
(define bundles (list->vector
(sort (flatten-linklet-directory ld '() '())
(lambda (a b) (bytes<? (car a) (car b))))))
(define len (vector-length bundles))
(define initial-offset (+ 2 ; "#~"
1 ; version length
(bytes-length version-bytes)
1 ; vm length
(bytes-length vm-bytes)
1 ; D
4)) ; bundle count
(write-int len port) ; bundle count
;; Compute bundle offsets
(define btree-size (compute-btree-size bundles len))
(define node-offsets (compute-btree-node-offsets bundles len initial-offset))
(define bundle-offsets (compute-bundle-offsets bundles len (+ initial-offset btree-size)))
(write-directory-btree bundles node-offsets bundle-offsets len port)
;; Write the bundles
(for ([i (in-range len)])
(write-bytes (cdr (vector-ref bundles i)) port))))
;; Encode a bundle name (as a reversed list of symbols) as a single
;; byte string

44
racket/src/expander/eval/main.rkt
View File

@ -29,7 +29,8 @@
"reflect.rkt"
"../expand/log.rkt"
"../expand/parsed.rkt"
"../common/performance.rkt")
"../common/performance.rkt"
"../compile/correlated-linklet.rkt")
(provide eval
compile
@ -71,6 +72,8 @@
;; [Don't use keyword arguments here, because the function is
;; exported for use by an embedding runtime system.]
(define (compile s [ns (current-namespace)] [serializable? #t] [expand expand])
(define to-correlated-linklet? (and serializable?
(compile-machine-independent)))
;; The given `s` might be an already-compiled expression because it
;; went through some strange path, such as a `load` on a bytecode
;; file, which would wrap `#%top-interaction` around the compiled
@ -85,55 +88,69 @@
(per-top-level s ns
#:single (lambda (s ns as-tail?)
(list (compile-single s ns expand
serializable?)))
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?)))
#:combine append
#:observer #f)]))
(if (and (= 1 (length cs))
(not (compiled-multiple-top? (car cs))))
(car cs)
(compiled-tops->compiled-top cs
#:to-correlated-linklet? to-correlated-linklet?
#:merge-serialization? serializable?
#:namespace ns)))
;; To communicate lifts from `expand-single` to `compile-single`:
(struct lifted-parsed-begin (seq last))
(define (compile-single s ns expand serializable?)
(define exp-s (expand s ns #f #t serializable?))
(define (compile-single s ns expand
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?)
(define exp-s (expand s ns #f #t serializable? to-correlated-linklet?))
(let loop ([exp-s exp-s])
(cond
[(parsed-module? exp-s)
(compile-module exp-s (make-compile-context #:namespace ns)
#:serializable? serializable?)]
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?)]
[(lifted-parsed-begin? exp-s)
;; expansion must have captured lifts
(compiled-tops->compiled-top
#:to-correlated-linklet? to-correlated-linklet?
(for/list ([e (in-list (append (lifted-parsed-begin-seq exp-s)
(list (lifted-parsed-begin-last exp-s))))])
(loop e)))]
[else
(compile-top exp-s (make-compile-context #:namespace ns)
#:serializable? serializable?)])))
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?)])))
;; This `expand` is suitable as an expand handler (if such a thing
;; existed) to be called by `expand` and `expand-syntax`.
;; [Don't use keyword arguments here, because the function is
;; exported for use by an embedding runtime system.]
(define (expand s [ns (current-namespace)] [observable? #f] [to-parsed? #f] [serializable? #f])
(define (expand s
[ns (current-namespace)] [observable? #f] [to-parsed? #f]
[serializable? #f] [to-correlated-linklet? #f])
(define observer (and observable? (current-expand-observe)))
(when observer (...log-expand observer ['start-top]))
(parameterize ([current-expand-observe #f])
(per-top-level s ns
#:single (lambda (s ns as-tail?) (expand-single s ns observer to-parsed? serializable?))
#:single (lambda (s ns as-tail?) (expand-single s ns observer to-parsed?
#:serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?))
#:combine cons
#:wrap re-pair
#:observer observer)))
(define (expand-single s ns observer to-parsed? serializable?)
(define (expand-single s ns observer to-parsed?
#:serializable? serializable?
#:to-correlated-linklet? [to-correlated-linklet? #f])
(define rebuild-s (keep-properties-only s))
(define ctx (make-expand-context ns
#:to-parsed? to-parsed?
#:for-serializable? serializable?
#:to-correlated-linklet? to-correlated-linklet?
#:observer observer))
(define-values (require-lifts lifts exp-s) (expand-capturing-lifts s ctx))
(cond
@ -143,14 +160,16 @@
lifts
exp-s rebuild-s
#:adjust-form (lambda (form)
(expand-single form ns observer to-parsed? serializable?)))]
(expand-single form ns observer to-parsed?
#:serializable? serializable?)))]
[else
(log-top-lift-begin-before ctx require-lifts lifts exp-s ns)
(define new-s
(wrap-lifts-as-begin (append require-lifts lifts)
#:adjust-form (lambda (form)
(log-expand ctx 'next)
(expand-single form ns observer to-parsed? serializable?))
(expand-single form ns observer to-parsed?
#:serializable? serializable?))
#:adjust-body (lambda (form)
(cond
[to-parsed? form]
@ -159,7 +178,8 @@
;; This re-expansion should be unnecessary, but we do it
;; for a kind of consistentcy with `expand/capture-lifts`
;; and for expansion observers
(expand-single form ns observer to-parsed? serializable?)]))
(expand-single form ns observer to-parsed?
#:serializable? serializable?)]))
exp-s
(namespace-phase ns)))
(log-top-begin-after ctx new-s)

18
racket/src/expander/eval/module.rkt
View File

@ -14,6 +14,7 @@
"../compile/linklet.rkt"
"../compile/instance.rkt"
"../compile/compiled-in-memory.rkt"
"../compile/correlated-linklet.rkt"
"../expand/context.rkt"
"../expand/root-expand-context.rkt"
"root-context.rkt"
@ -40,7 +41,7 @@
#:supermodule-name [supermodule-name #f]) ; for submodules declared with module
(performance-region
['eval 'module]
(define-values (dh h data-instance declaration-instance)
(compiled-module->dh+h+data-instance+declaration-instance c))
@ -49,7 +50,7 @@
(make-syntax-literal-data-instance-from-compiled-in-memory c)
(let ([l (hash-ref h 'stx-data #f)])
(cond
[l (instantiate-linklet (eval-linklet l)
[l (instantiate-linklet (eval-linklet* l)
(list deserialize-instance
data-instance))]
[(eq? (hash-ref h 'module->namespace #f) 'empty)
@ -83,9 +84,9 @@
(define phases-h (for*/hash ([phase-level (in-range min-phase (add1 max-phase))]
[v (in-value (hash-ref h phase-level #f))]
#:when v)
(values phase-level (eval-linklet v))))
(values phase-level (eval-linklet* v))))
(define syntax-literals-linklet (let ([l (hash-ref h 'stx #f)])
(and l (eval-linklet l))))
(and l (eval-linklet* l))))
(define extra-inspector (and (compiled-in-memory? c)
(compiled-in-memory-compile-time-inspector c)))
@ -350,14 +351,14 @@
(define data-instance
(if (compiled-in-memory? c)
(make-data-instance-from-compiled-in-memory c)
(instantiate-linklet (eval-linklet (hash-ref h 'data))
(instantiate-linklet (eval-linklet* (hash-ref h 'data))
(list deserialize-instance))))
(define declaration-instance
(if (and (compiled-in-memory? c)
(compiled-in-memory-original-self c))
(make-declaration-instance-from-compiled-in-memory c)
(instantiate-linklet (eval-linklet (hash-ref h 'decl))
(instantiate-linklet (eval-linklet* (hash-ref h 'decl))
(list deserialize-instance
data-instance))))
@ -402,3 +403,8 @@
(for/hash ([(phase linklet) (in-hash phases-h)])
(values phase
(linklet-export-variables linklet))))
;; ----------------------------------------
(define (eval-linklet* l)
(eval-linklet (force-compile-linklet l)))

5
racket/src/expander/eval/top.rkt
View File

@ -16,6 +16,7 @@
"../compile/namespace-scope.rkt"
"../compile/linklet.rkt"
"../expand/context.rkt"
"../compile/correlated-linklet.rkt"
"top-level-instance.rkt"
"multi-top.rkt"
"protect.rkt")
@ -82,7 +83,7 @@
(define link-instance
(if (compiled-in-memory? c)
(link-instance-from-compiled-in-memory c (and (not single-expression?) ns))
(instantiate-linklet (hash-ref h 'link)
(instantiate-linklet (force-compile-linklet (hash-ref h 'link))
(list deserialize-instance
(make-eager-instance-instance
#:namespace ns
@ -137,7 +138,7 @@
name
val)))))
(define linklet (hash-ref h phase #f))
(define linklet (force-compile-linklet (hash-ref h phase #f)))
(cond
[linklet

3
racket/src/expander/expand/context.rkt
View File

@ -68,11 +68,13 @@
* name ; #f or identifier to name the expression
observer ; logging observer (for the macro debugger)
for-serializable? ; accumulate submodules as serializable?
to-correlated-linklet? ; compile to machine-independent linklets?
should-not-encounter-macros?)) ; #t when "expanding" to parse
(define (make-expand-context ns
#:to-parsed? [to-parsed? #f]
#:for-serializable? [for-serializable? #f]
#:to-correlated-linklet? [to-correlated-linklet? #f]
#:observer [observer #f])
(define root-ctx (namespace-get-root-expand-ctx ns))
(expand-context (root-expand-context-self-mpi root-ctx)
@ -114,6 +116,7 @@
#f ; name
observer
for-serializable?
to-correlated-linklet?
#f))
(define (copy-root-expand-context ctx root-ctx)

2
racket/src/expander/expand/module.rkt
View File

@ -1154,6 +1154,7 @@
#:full-module-name (and enclosing-self
(resolved-module-path-name module-name)))
#:serializable? (expand-context-for-serializable? ctx)
#:to-correlated-linklet? (expand-context-to-correlated-linklet? ctx)
#:modules-being-compiled modules-being-compiled
#:need-compiled-submodule-rename? #f))
(set-box! compiled-module-box compiled-module)
@ -1363,6 +1364,7 @@
#:full-module-name (resolved-module-path-name module-name))
#:force-linklet-directory? #t
#:serializable? (expand-context-for-serializable? ctx)
#:to-correlated-linklet? (expand-context-to-correlated-linklet? ctx)
#:modules-being-compiled modules-being-compiled
#:need-compiled-submodule-rename? #f))
(hash-set! compiled-submodules name (cons is-star? compiled-submodule))

11
racket/src/racket/cmdline.inc
View File

@ -784,6 +784,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
argv[0] = "-q";
else if (!strcmp("--no-jit", argv[0]))
argv[0] = "-j";
else if (!strcmp("--compile-mi", argv[0]))
argv[0] = "-M";
else if (!strcmp("--no-delay", argv[0]))
argv[0] = "-d";
else if (!strcmp("--repl", argv[0]))
@ -1064,6 +1066,10 @@ static int run_from_cmd_line(int argc, char *_argv[],
scheme_set_startup_use_jit(0);
was_config_flag = 1;
break;
case 'M':
scheme_set_startup_compile_machine_independent(1);
was_config_flag = 1;
break;
case 'd':
scheme_set_startup_load_on_demand(0);
was_config_flag = 1;
@ -1237,6 +1243,10 @@ static int run_from_cmd_line(int argc, char *_argv[],
}
}
if (getenv("PLT_COMPILE_ANY")) {
scheme_set_startup_compile_machine_independent(1);
}
scheme_set_logging2_spec(syslog_level, stderr_level, stdout_level);
collects_path = adjust_collects_path(collects_path, &skip_coll_dirs);
@ -1414,6 +1424,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
# else
" -j, --no-jit : No effect, since the just-in-time compiler is unavailable\n"
# endif
" -M, --compile-mi : Compile to machine-independent form\n"
" -d, --no-delay: Disable on-demand loading of syntax and code\n"
" -b, --binary : Read stdin and write stdout/stderr in binary mode\n"
" -W <levels>, --warn <levels> : Set stderr logging to <levels>\n"

3
racket/src/racket/include/scheme.h
View File

@ -1357,6 +1357,7 @@ enum {
MZCONFIG_COMPILE_MODULE_CONSTS,
MZCONFIG_USE_JIT,
MZCONFIG_DISALLOW_INLINE,
MZCONFIG_COMPILE_MACHINE_INDEPENDENT,
MZCONFIG_CUSTODIAN,
MZCONFIG_INSPECTOR,
@ -1835,6 +1836,7 @@ MZ_EXTERN int scheme_hash_percent_syntax_only; /* Defaults to 0 */
MZ_EXTERN int scheme_hash_percent_globals_only; /* Defaults to 0 */
MZ_EXTERN int scheme_binary_mode_stdio; /* Windows-specific; Defaults to 0 */
MZ_EXTERN int scheme_startup_use_jit; /* Defaults to 1 */
MZ_EXTERN int scheme_startup_compile_machine_independent; /* Defaults to 0 */
MZ_EXTERN int scheme_ignore_user_paths; /* Defaults to 0 */
MZ_EXTERN int scheme_ignore_link_paths; /* Defaults to 0 */
@ -1842,6 +1844,7 @@ MZ_EXTERN void scheme_set_case_sensitive(int);
MZ_EXTERN void scheme_set_allow_set_undefined(int);
MZ_EXTERN void scheme_set_binary_mode_stdio(int);
MZ_EXTERN void scheme_set_startup_use_jit(int);
MZ_EXTERN void scheme_set_startup_compile_machine_independent(int);
MZ_EXTERN void scheme_set_startup_load_on_demand(int);
MZ_EXTERN void scheme_set_ignore_user_paths(int);
MZ_EXTERN void scheme_set_ignore_link_paths(int);

14
racket/src/racket/src/eval.c
View File

@ -181,7 +181,11 @@
/* globals */
SHARED_OK int scheme_startup_use_jit = INIT_JIT_ON;
SHARED_OK int scheme_startup_compile_machine_independent = 0;
void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit = v; }
void scheme_set_startup_compile_machine_independent(int v) {
scheme_startup_compile_machine_independent = v;
}
/* THREAD LOCAL SHARED */
THREAD_LOCAL_DECL(volatile int scheme_fuel_counter);
@ -213,6 +217,7 @@ static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv);
static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv);
static Scheme_Object *use_jit(int argc, Scheme_Object **argv);
static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv);
static Scheme_Object *compile_machine_independent(int argc, Scheme_Object **argv);
void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full);
@ -262,6 +267,7 @@ scheme_init_eval (Scheme_Startup_Env *env)
ADD_PARAMETER("compile-enforce-module-constants", compile_module_constants, MZCONFIG_COMPILE_MODULE_CONSTS, env);
ADD_PARAMETER("eval-jit-enabled", use_jit, MZCONFIG_USE_JIT, env);
ADD_PARAMETER("compile-context-preservation-enabled", disallow_inline, MZCONFIG_DISALLOW_INLINE, env);
ADD_PARAMETER("compile-machine-independent", compile_machine_independent, MZCONFIG_COMPILE_MACHINE_INDEPENDENT, env);
}
void scheme_init_eval_places()
@ -3905,6 +3911,14 @@ static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv)
-1, NULL, NULL, 1);
}
static Scheme_Object *compile_machine_independent(int argc, Scheme_Object **argv)
{
return scheme_param_config("compile-machine-independent",
scheme_make_integer(MZCONFIG_COMPILE_MACHINE_INDEPENDENT),
argc, argv,
-1, NULL, NULL, 1);
}
static Scheme_Object *
enable_break(int argc, Scheme_Object *argv[])
{

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1446
#define EXPECTED_PRIM_COUNT 1447
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "7.1.0.4"
#define MZSCHEME_VERSION "7.1.0.5"
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

4644
racket/src/racket/src/startup.inc
View File

File diff suppressed because it is too large Load Diff

1
racket/src/racket/src/thread.c
View File

@ -7972,6 +7972,7 @@ static void make_initial_config(Scheme_Thread *p)
init_param(cells, paramz, MZCONFIG_COMPILE_MODULE_CONSTS, scheme_true);
init_param(cells, paramz, MZCONFIG_USE_JIT, scheme_startup_use_jit ? scheme_true : scheme_false);
init_param(cells, paramz, MZCONFIG_COMPILE_MACHINE_INDEPENDENT, scheme_startup_compile_machine_independent ? scheme_true : scheme_false);
{
Scheme_Object *s;