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

cs: simplify and improve handling of literals

Browse Source 
Use data instead of code to shrink ".zo" sizes by 10-30%.

When Racket code contains a literal that cannot be serialized directly
by Chez Scheme (such as a keyword or an immutable string that should
be datum-interned), the old approach was to generate Scheme code to
construct the literal through a lifted `let` binding. To handle paths
associated with procedures, however, Chez Scheme's `fasl-write` had
been extended to allow arbitrary values to be intercepted during fasl
and passed back in to `fasl-read`. Using that strategy for all Racket
literals simplifies the implementation and reduces compiled code. It
also makes closures smaller, while increases the number of
relocations. DrRacket's foorprint shrinks by about 1%, but the main
affect is on disk space for a Racket installation.
This commit is contained in:
Matthew Flatt 2020-11-21 14:15:50 -07:00
parent b2a27ef05c
commit f07c2fea71
42 changed files with 3002 additions and 6388 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when ;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes: ;; "racket_version.h" changes:
(define version "7.9.0.6") (define version "7.9.0.7")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

26
pkgs/compiler-lib/compiler/decompile.rkt
View File

@ -248,31 +248,23 @@
[(? linklet?) [(? linklet?)
(case (system-type 'vm) (case (system-type 'vm)
[(chez-scheme) [(chez-scheme)
(define-values (fmt code sfd-paths args) ((vm-primitive 'linklet-fasled-code+arguments) l)) (define-values (fmt code literals) ((vm-primitive 'linklet-fasled-code+arguments) l))
(cond (cond
[code [code
(case fmt (case fmt
[(compile) [(compile)
(cond (cond
[(not (current-partial-fasl)) [(not (current-partial-fasl))
;; Note that applying the result of `vm-eval` no longer shows the setup of (define proc (vm-eval `(load-compiled-from-port (open-bytevector-input-port ,code) ',literals)))
;; Racket level constants (like keywords): (decompile-chez-procedure proc)]
(define make-proc (vm-eval `(load-compiled-from-port (open-bytevector-input-port ,code) ',sfd-paths)))
(define proc (make-proc))
(let ([proc (decompile-chez-procedure (if (null? args) proc (apply proc args)) make-proc)])
(if (null? args)
proc
(cons proc (map (vm-primitive 'force-unfasl) args))))]
[else [else
(define desc (disassemble-in-description (disassemble-in-description
`(#(FASL `(#(FASL
#:length ,(bytes-length code) #:length ,(bytes-length code)
,(vm-eval `(($primitive $describe-fasl-from-port) (open-bytevector-input-port ,code) ',sfd-paths)))))) #:literals ,literals
(if (null? args) ,(vm-eval `(($primitive $describe-fasl-from-port) (open-bytevector-input-port ,code) ',literals)))))])]
desc
(cons desc (map (vm-primitive 'force-unfasl) args)))])]
[(interpret) [(interpret)
(define bytecode (vm-eval `(fasl-read (open-bytevector-input-port ,code) 'load ',sfd-paths))) (define bytecode (vm-eval `(fasl-read (open-bytevector-input-port ,code) 'load ',literals)))
(list `(#%interpret ,(unwrap-chez-interpret-jitified bytecode)))] (list `(#%interpret ,(unwrap-chez-interpret-jitified bytecode)))]
[else [else
'(....)])] '(....)])]

46
pkgs/compiler-lib/compiler/private/chez.rkt
View File

@ -12,19 +12,15 @@
(define current-can-disassemble (make-parameter #t)) (define current-can-disassemble (make-parameter #t))
(define current-partial-fasl (make-parameter #f)) (define current-partial-fasl (make-parameter #f))
(define (decompile-chez-procedure p make-p) (define (decompile-chez-procedure p)
(unless (procedure? p) (unless (procedure? p)
(error 'decompile-chez-procedure "not a procedure")) (error 'decompile-chez-procedure "not a procedure"))
(define seen (make-hasheq)) (define seen (make-hasheq))
((vm-primitive 'call-with-system-wind) ((vm-primitive 'call-with-system-wind)
(lambda () (lambda ()
(define make-proc ((vm-primitive 'inspect/object) make-p))
(define make-code (make-proc 'code))
(define proc ((vm-primitive 'inspect/object) p)) (define proc ((vm-primitive 'inspect/object) p))
(define code (proc 'code)) (define code (proc 'code))
(append (decompile-code code seen #:unwrap-body? #t))))
(decompile-code make-code #f seen #:name "body-maker-that-creates-lifted-constants")
(decompile-code code proc seen #:unwrap-body? #t)))))
(define (decompile obj closure seen) (define (decompile obj closure seen)
(define type (obj 'type)) (define type (obj 'type))
@ -36,7 +32,7 @@
[else [else
(hash-set! seen (obj 'value) #t) (hash-set! seen (obj 'value) #t)
(case type (case type
[(code) (decompile-code obj closure seen)] [(code) (decompile-code obj seen)]
[(variable) [(variable)
(decompile (obj 'ref) #f seen)] (decompile (obj 'ref) #f seen)]
[(procedure) [(procedure)
@ -46,20 +42,11 @@
(define (decompile-value v seen) (define (decompile-value v seen)
(decompile ((vm-primitive 'inspect/object) v) #f seen)) (decompile ((vm-primitive 'inspect/object) v) #f seen))
(define (decompile-code code closure seen (define (decompile-code code seen
#:unwrap-body? [unwrap-body? #f] #:unwrap-body? [unwrap-body? #f])
#:name [name #f])
(define $generation (vm-eval '($primitive $generation))) (define $generation (vm-eval '($primitive $generation)))
(define $code? (vm-eval '($primitive $code?))) (define $code? (vm-eval '($primitive $code?)))
(define max-gen (vm-eval '(collect-maximum-generation))) (define max-gen (vm-eval '(collect-maximum-generation)))
(define captures (if (and closure (positive? (code 'free-count)))
`('(captures: ,@(for/list ([i (in-range (code 'free-count))])
(define v (closure 'ref i))
(let loop ([v v])
(case (v 'type)
[(variable) (loop (v 'ref))]
[else (v 'value)])))))
'()))
(append (append
(apply (apply
append append
@ -68,11 +55,9 @@
(($generation v) . > . max-gen))) (($generation v) . > . max-gen)))
(decompile-value v seen))) (decompile-value v seen)))
(if unwrap-body? (if unwrap-body?
(append (decompile-code-body code)
captures
(decompile-code-body code))
(list (list
`(define ,(let ([name (or name (code 'name))]) `(define ,(let* ([name (code 'name)])
(if name (if name
(string->symbol (string->symbol
(if (and ((string-length name) . > . 0) (if (and ((string-length name) . > . 0)
@ -81,7 +66,6 @@
name)) name))
'....)) '....))
(lambda ,(arity-mask->args (code 'arity-mask)) (lambda ,(arity-mask->args (code 'arity-mask))
,@captures
,@(decompile-code-body code))))))) ,@(decompile-code-body code)))))))
(define (decompile-code-body code-obj) (define (decompile-code-body code-obj)
@ -110,16 +94,20 @@
(if s (if s
(let-values ([(path line col pos) (let-values ([(path line col pos)
(vm-eval `(let ([s ',s]) (vm-eval `(let ([s ',s])
(values (let ([sfd (source-object-sfd s)]) (values (let* ([sfd (source-object-sfd s)])
(and sfd (source-file-descriptor-path sfd))) (and sfd (source-file-descriptor-path sfd)))
(source-object-line s) (source-object-line s)
(source-object-column s) (source-object-column s)
(source-object-bfp s))))]) (source-object-bfp s))))])
(cond (let ([path (if (srcloc? path)
[(not path) null] ;; the linklet layer wraps paths as srclocs
[(and line col) (list (format "~a:~a:~a" path line col))] (srcloc-source path)
[pos (list (format "~a:~a" path pos))] path)])
[else (list path)])) (cond
[(not path) null]
[(and line col) (list (format "~a:~a:~a" path line col))]
[pos (list (format "~a:~a" path pos))]
[else (list path)])))
null)) null))
;; Show machine/assembly code: ;; Show machine/assembly code:
(cond (cond

16
pkgs/racket-doc/scribblings/reference/fasl.scrbl
View File

@ -13,11 +13,13 @@
[out (or/c output-port? #f) #f] [out (or/c output-port? #f) #f]
[#:keep-mutable? keep-mutable? any/c #f] [#:keep-mutable? keep-mutable? any/c #f]
[#:handle-fail handle-fail (or/c #f (any/c . -> . any/c)) #f] [#:handle-fail handle-fail (or/c #f (any/c . -> . any/c)) #f]
[#:external-lift? external-lift? (or/c #f (any/c . -> . any/c)) #f]) [#:external-lift? external-lift? (or/c #f (any/c . -> . any/c)) #f]
[#:skip-prefix? skip-prefix? any/c #f])
(or/c (void) bytes?)] (or/c (void) bytes?)]
@defproc[(fasl->s-exp [in (or/c input-port? bytes?)] @defproc[(fasl->s-exp [in (or/c input-port? bytes?)]
[#:datum-intern? datum-intern? any/c #t] [#:datum-intern? datum-intern? any/c #t]
[#:external-lifts external-lifts vector? '#()]) [#:external-lifts external-lifts vector? '#()]
[#:skip-prefix? skip-prefix? any/c #f])
any/c] any/c]
)]{ )]{
@ -74,11 +76,19 @@ is filtered by @racket[datum-intern-literal]. The defaults make the
composition of @racket[s-exp->fasl] and @racket[fasl->s-exp] behave composition of @racket[s-exp->fasl] and @racket[fasl->s-exp] behave
like the composition of @racket[write] and @racket[read]. like the composition of @racket[write] and @racket[read].
If @racket[skip-prefix?] is not @racket[#f], then a prefix that
identifies the stream as a serialization is not written by
@racket[s-exp->fasl] or read by @racket[fasl->s-exp]. Omitting a
prefix can save a small amount of space, which can useful when
serializing small values, but it gives up a sanity check on the
@racket[fasl->s-exp] that is often useful.
The byte-string encoding produced by @racket[s-exp->fasl] is The byte-string encoding produced by @racket[s-exp->fasl] is
independent of the Racket version, except as future Racket versions independent of the Racket version, except as future Racket versions
introduce extensions that are not currently recognized. In particular, introduce extensions that are not currently recognized. In particular,
the result of @racket[s-exp->fasl] will be valid as input to any the result of @racket[s-exp->fasl] will be valid as input to any
future version of @racket[fasl->s-exp]. future version of @racket[fasl->s-exp] (as long as the
@racket[skip-prefix?] arguments are consistent).
@mz-examples[ @mz-examples[
#:eval fasl-eval #:eval fasl-eval

137
racket/collects/racket/fasl.rkt
View File

@ -2,6 +2,7 @@
(require '#%extfl (require '#%extfl
racket/linklet racket/linklet
racket/unsafe/undefined racket/unsafe/undefined
racket/fixnum
(for-syntax racket/base) (for-syntax racket/base)
"private/truncate-path.rkt" "private/truncate-path.rkt"
"private/relative-path.rkt" "private/relative-path.rkt"
@ -121,7 +122,8 @@
[orig-o #f] [orig-o #f]
#:keep-mutable? [keep-mutable? #f] #:keep-mutable? [keep-mutable? #f]
#:handle-fail [handle-fail #f] #:handle-fail [handle-fail #f]
#:external-lift? [external-lift? #f]) #:external-lift? [external-lift? #f]
#:skip-prefix? [skip-prefix? #f])
(when orig-o (when orig-o
(unless (output-port? orig-o) (unless (output-port? orig-o)
(raise-argument-error 's-exp->fasl "(or/c output-port? #f)" orig-o))) (raise-argument-error 's-exp->fasl "(or/c output-port? #f)" orig-o)))
@ -184,7 +186,8 @@
(define (treat-immutable? v) (or (not keep-mutable?) (immutable? v))) (define (treat-immutable? v) (or (not keep-mutable?) (immutable? v)))
(define path->relative-path-elements (make-path->relative-path-elements)) (define path->relative-path-elements (make-path->relative-path-elements))
;; The fasl formal prefix: ;; The fasl formal prefix:
(write-bytes fasl-prefix o) (unless skip-prefix?
(write-bytes fasl-prefix o))
;; Write content to a string, so we can measure it ;; Write content to a string, so we can measure it
(define bstr (define bstr
(let ([o (open-output-bytes)]) (let ([o (open-output-bytes)])
@ -394,14 +397,16 @@
(define (fasl->s-exp orig-i (define (fasl->s-exp orig-i
#:datum-intern? [intern? #t] #:datum-intern? [intern? #t]
#:external-lifts [external-lifts '#()]) #:external-lifts [external-lifts '#()]
#:skip-prefix? [skip-prefix? #f])
(define init-i (cond (define init-i (cond
[(bytes? orig-i) (mcons orig-i 0)] [(bytes? orig-i) (mcons orig-i 0)]
[(input-port? orig-i) orig-i] [(input-port? orig-i) orig-i]
[else (raise-argument-error 'fasl->s-exp "(or/c bytes? input-port?)" orig-i)])) [else (raise-argument-error 'fasl->s-exp "(or/c bytes? input-port?)" orig-i)]))
(unless (bytes=? (read-bytes/exactly fasl-prefix-length init-i) fasl-prefix) (unless skip-prefix?
(read-error "unrecognized prefix")) (unless (bytes=? (read-bytes/exactly* fasl-prefix-length init-i) fasl-prefix)
(define shared-count (read-fasl-integer init-i)) (read-error "unrecognized prefix")))
(define shared-count (read-fasl-integer* init-i))
(define shared (make-vector shared-count)) (define shared (make-vector shared-count))
(unless (and (vector? external-lifts) (unless (and (vector? external-lifts)
@ -411,11 +416,11 @@
[pos (in-naturals)]) [pos (in-naturals)])
(vector-set! shared pos (vector-ref external-lifts pos))) (vector-set! shared pos (vector-ref external-lifts pos)))
(define len (read-fasl-integer init-i)) (define len (read-fasl-integer* init-i))
(define i (if (mpair? init-i) (define i (if (mpair? init-i)
init-i init-i
;; Faster to work with a byte string: ;; Faster to work with a byte string:
(let ([bstr (read-bytes/exactly len init-i)]) (let ([bstr (read-bytes/exactly* len init-i)])
(mcons bstr 0)))) (mcons bstr 0))))
(define (intern v) (if intern? (datum-intern-literal v) v)) (define (intern v) (if intern? (datum-intern-literal v) v))
@ -588,13 +593,16 @@
args)) args))
(define (read-byte/no-eof i) (define (read-byte/no-eof i)
(define pos (mcdr i))
(unless (pos . < . (bytes-length (mcar i)))
(read-error "truncated stream"))
(set-mcdr! i (fx+ pos 1))
(bytes-ref (mcar i) pos))
(define (read-byte/no-eof* i)
(cond (cond
[(mpair? i) [(mpair? i)
(define pos (mcdr i)) (read-byte/no-eof i)]
(unless (pos . < . (bytes-length (mcar i)))
(read-error "truncated stream"))
(set-mcdr! i (add1 pos))
(bytes-ref (mcar i) pos)]
[else [else
(define b (read-byte i)) (define b (read-byte i))
(when (eof-object? b) (when (eof-object? b)
@ -602,42 +610,93 @@
b])) b]))
(define (read-bytes/exactly n i) (define (read-bytes/exactly n i)
(define pos (mcdr i))
(unless ((+ pos n) . <= . (bytes-length (mcar i)))
(read-error "truncated stream"))
(set-mcdr! i (fx+ pos n))
(subbytes (mcar i) pos (fx+ pos n)))
(define (read-bytes/exactly* n i)
(cond (cond
[(mpair? i) [(mpair? i)
(define pos (mcdr i)) (read-bytes/exactly n i)]
(unless ((+ pos n) . <= . (bytes-length (mcar i)))
(read-error "truncated stream"))
(set-mcdr! i (+ pos n))
(subbytes (mcar i) pos (+ pos n))]
[else [else
(define bstr (read-bytes n i)) (define bstr (read-bytes n i))
(unless (and (bytes? bstr) (= n (bytes-length bstr))) (unless (and (bytes? bstr) (= n (bytes-length bstr)))
(read-error "truncated stream")) (read-error "truncated stream"))
bstr])) bstr]))
(define (read-fasl-integer i) (define-values (read-fasl-integer read-fasl-integer*)
(define b (read-byte/no-eof i)) (let-syntax ([gen
(cond (syntax-rules ()
[(<= b 127) b] [(_ read-byte/no-eof read-bytes/exactly)
[(>= b 132) (- b 256)] (lambda (i)
[(eqv? b 128) (define b (read-byte/no-eof i))
(integer-bytes->integer (read-bytes/exactly 2 i) #t #f)] (cond
[(eqv? b 129) [(fx<= b 127) b]
(integer-bytes->integer (read-bytes/exactly 4 i) #t #f)] [(fx>= b 132) (fx- b 256)]
[(eqv? b 130) [(eqv? b 128)
(integer-bytes->integer (read-bytes/exactly 8 i) #t #f)] (define lo (read-byte/no-eof i))
[(eqv? b 131) (define hi (read-byte/no-eof i))
(define len (read-fasl-integer i)) (if (hi . fx> . 127)
(define str (read-fasl-string i len)) (fxior (fxlshift (fx+ -256 hi) 8) lo)
(unless (and (string? str) (= len (string-length str))) (fxior (fxlshift hi 8) lo))]
(read-error "truncated stream at number")) [(eqv? b 129)
(string->number str 16)] (define a (read-byte/no-eof i))
[else (define b (read-byte/no-eof i))
(read-error "internal error on integer mode")])) (define c (read-byte/no-eof i))
(define d (read-byte/no-eof i))
(bitwise-ior a
(arithmetic-shift
;; 24 bits always fit in a fixnum:
(if (d . fx> . 127)
(fxior (fxlshift (fx+ -256 d) 16)
(fxlshift c 8)
b)
(fxior (fxlshift d 16)
(fxlshift c 8)
b))
8))]
[(eqv? b 130)
(integer-bytes->integer (read-bytes/exactly 8 i) #t #f)]
[(eqv? b 131)
(define len (read-fasl-integer i))
(define str (read-fasl-string i len))
(unless (and (string? str) (= len (string-length str)))
(read-error "truncated stream at number"))
(string->number str 16)]
[else
(read-error "internal error on integer mode")]))])])
(values (gen read-byte/no-eof read-bytes/exactly)
(gen read-byte/no-eof* read-bytes/exactly*))))
(define (read-fasl-string i [len (read-fasl-integer i)]) (define (read-fasl-string i [len (read-fasl-integer i)])
(define bstr (read-bytes/exactly len i)) (define pos (mcdr i))
(bytes->string/utf-8 bstr)) (define bstr (mcar i))
(cond
[((+ pos len) . <= . (bytes-length bstr))
(set-mcdr! i (fx+ pos len))
;; optimistically assume ASCII:
(define s (make-string len))
(let loop ([i 0])
(cond
[(fx= i len)
;; success: all ASCII
s]
[else
(define c (bytes-ref bstr (fx+ i pos)))
(cond
[(c . fx<= . 128)
(string-set! s i (integer->char c))
(loop (fx+ i 1))]
[else
;; not ASCII, so abandon fast-path string
(bytes->string/utf-8 bstr #f pos (fx+ pos len))])]))]
[else
;; let read-bytes/exactly complain
(define bstr (read-bytes/exactly len i))
;; don't expect to get here!
(bytes->string/utf-8 bstr)]))
(define (read-fasl-bytes i) (define (read-fasl-bytes i)
(define len (read-fasl-integer i)) (define len (read-fasl-integer i))

2
racket/src/ChezScheme/s/cpnanopass.ss
View File

@ -3737,6 +3737,8 @@
[(base index offset e build-assign build-barrier-seq) [(base index offset e build-assign build-barrier-seq)
(if (nanopass-case (L7 Expr) e (if (nanopass-case (L7 Expr) e
[(quote ,d) (ptr->imm d)] [(quote ,d) (ptr->imm d)]
[(call ,info ,mdcl ,pr ,e* ...)
(eq? 'fixnum ($sgetprop (primref-name pr) '*result-type* #f))]
[else #f]) [else #f])
(build-assign base index offset e) (build-assign base index offset e)
(let ([a (if (eq? index %zero) (let ([a (if (eq? index %zero)

13
racket/src/ChezScheme/s/fasl.ss
View File

@ -207,9 +207,7 @@
[(symbol-hashtable? x) (bld-graph x t a? d #t bld-ht)] [(symbol-hashtable? x) (bld-graph x t a? d #t bld-ht)]
[($record? x) (bld-graph x t a? d #t bld-record)] [($record? x) (bld-graph x t a? d #t bld-record)]
[(box? x) (bld-graph x t a? d #t bld-box)] [(box? x) (bld-graph x t a? d #t bld-box)]
[(or (large-integer? x) (ratnum? x) ($inexactnum? x) ($exactnum? x) [else (bld-graph x t a? d #t bld-simple)])))
(fxvector? x) (flvector? x) (bytevector? x))
(bld-graph x t a? d #t bld-simple)])))
(module (small-integer? large-integer?) (module (small-integer? large-integer?)
(define least-small-integer (- (expt 2 31))) (define least-small-integer (- (expt 2 31)))
@ -626,6 +624,11 @@
(put-u8 p (constant fasl-type-graph-ref)) (put-u8 p (constant fasl-type-graph-ref))
(put-uptr p (car a))])))) (put-uptr p (car a))]))))
(define (wrf-invalid x p t a?)
(wrf-graph x p t a?
(lambda (x p t a?)
($oops 'fasl-write "invalid fasl object ~s" x))))
(define wrf (define wrf
(lambda (x p t a?) (lambda (x p t a?)
(cond (cond
@ -649,7 +652,7 @@
; this check must go before $record? check ; this check must go before $record? check
[(symbol-hashtable? x) (wrf-graph x p t a? wrf-symht)] [(symbol-hashtable? x) (wrf-graph x p t a? wrf-symht)]
; this check must go before $record? check ; this check must go before $record? check
[(hashtable? x) ($oops 'fasl-write "invalid fasl object ~s" x)] [(hashtable? x) (wrf-invalid x p t a?)]
[($record? x) (wrf-graph x p t a? wrf-record)] [($record? x) (wrf-graph x p t a? wrf-record)]
[(vector? x) (wrf-graph x p t a? wrf-vector)] [(vector? x) (wrf-graph x p t a? wrf-vector)]
[(stencil-vector? x) (wrf-graph x p t a? wrf-stencil-vector)] [(stencil-vector? x) (wrf-graph x p t a? wrf-stencil-vector)]
@ -667,7 +670,7 @@
[(eq? x '#0=#0#) (wrf-immediate (constant black-hole) p)] [(eq? x '#0=#0#) (wrf-immediate (constant black-hole) p)]
[($rtd-counts? x) (wrf-immediate (constant sfalse) p)] [($rtd-counts? x) (wrf-immediate (constant sfalse) p)]
[(phantom-bytevector? x) (wrf-phantom x p)] [(phantom-bytevector? x) (wrf-phantom x p)]
[else ($oops 'fasl-write "invalid fasl object ~s" x)]))) [else (wrf-invalid x p t a?)])))
(module (start) (module (start)
(define start (define start

10
racket/src/bc/src/cify-startup.rkt
View File

@ -4,7 +4,7 @@
primitive-in-category?) primitive-in-category?)
racket/cmdline racket/cmdline
"../../schemify/schemify.rkt" "../../schemify/schemify.rkt"
"../../schemify/serialize.rkt" "../../cify/literal.rkt"
"../../schemify/known.rkt" "../../schemify/known.rkt"
"../../schemify/lift.rkt" "../../schemify/lift.rkt"
"../../schemify/reinfer-name.rkt" "../../schemify/reinfer-name.rkt"
@ -66,13 +66,13 @@
a-known-constant])))) a-known-constant]))))
(printf "Serializable...\n") (printf "Serializable...\n")
(define-values (bodys/constants-lifted lifted-constants) (define-values (bodys/literals-extracted literals)
(time (convert-for-serialize l #t #t))) (time (extract-literals l)))
;; Startup code reuses names to keep it compact; make ;; Startup code reuses names to keep it compact; make
;; te names unique again ;; te names unique again
(define bodys/re-uniqued (define bodys/re-uniqued
(cdr (re-unique `(begin . ,bodys/constants-lifted)))) (cdr (re-unique `(begin . ,bodys/literals-extracted))))
(printf "Schemify...\n") (printf "Schemify...\n")
(define body (define body
@ -93,7 +93,7 @@
(lift-in-schemified-body body))) (lift-in-schemified-body body)))
(define converted-body (define converted-body
(append (for/list ([p (in-list lifted-constants)]) (append (for/list ([p (in-list literals)])
(cons 'define p)) (cons 'define p))
lifted-body)) lifted-body))

277
racket/src/bc/src/startup.inc
View File

@ -18756,14 +18756,15 @@ static const char *startup_source =
"(define-values(fasl-hash-eqv-variant) 2)" "(define-values(fasl-hash-eqv-variant) 2)"
"(define-values" "(define-values"
"(s-exp->fasl.1)" "(s-exp->fasl.1)"
"(lambda(external-lift?7_0 handle-fail6_0 keep-mutable?5_0 v12_0 orig-o11_0)" "(lambda(external-lift?7_0 handle-fail6_0 keep-mutable?5_0 skip-prefix?8_0 v14_0 orig-o13_0)"
"(begin" "(begin"
" 's-exp->fasl" " 's-exp->fasl"
"(let-values(((v_0) v12_0))" "(let-values(((v_0) v14_0))"
"(let-values(((orig-o_0) orig-o11_0))" "(let-values(((orig-o_0) orig-o13_0))"
"(let-values(((keep-mutable?_0) keep-mutable?5_0))" "(let-values(((keep-mutable?_0) keep-mutable?5_0))"
"(let-values(((handle-fail_0) handle-fail6_0))" "(let-values(((handle-fail_0) handle-fail6_0))"
"(let-values(((external-lift?_0) external-lift?7_0))" "(let-values(((external-lift?_0) external-lift?7_0))"
"(let-values(((skip-prefix?_0) skip-prefix?8_0))"
"(let-values()" "(let-values()"
"(let-values((()" "(let-values((()"
"(begin" "(begin"
@ -18772,7 +18773,7 @@ static const char *startup_source =
"(if(output-port? orig-o_0)" "(if(output-port? orig-o_0)"
"(void)" "(void)"
"(let-values()" "(let-values()"
" (raise-argument-error 's-exp->fasl \"(or/c output-port? #f)\" orig-o_0))))" " (raise-argument-error 's-exp->fasl \"(or/c output-port? #f)\" orig-o_0))))"
"(void))" "(void))"
"(values))))" "(values))))"
"(let-values((()" "(let-values((()"
@ -18786,7 +18787,7 @@ static const char *startup_source =
"(let-values()" "(let-values()"
"(raise-argument-error" "(raise-argument-error"
" 's-exp->fasl" " 's-exp->fasl"
" \"(or/c (procedure-arity-includes/c 1) #f)\"" " \"(or/c (procedure-arity-includes/c 1) #f)\""
" handle-fail_0))))" " handle-fail_0))))"
"(void))" "(void))"
"(values))))" "(values))))"
@ -18801,7 +18802,7 @@ static const char *startup_source =
"(let-values()" "(let-values()"
"(raise-argument-error" "(raise-argument-error"
" 's-exp->fasl" " 's-exp->fasl"
" \"(or/c (procedure-arity-includes/c 1) #f)\"" " \"(or/c (procedure-arity-includes/c 1) #f)\""
" external-lift?_0))))" " external-lift?_0))))"
"(void))" "(void))"
"(values))))" "(values))))"
@ -18833,7 +18834,8 @@ static const char *startup_source =
" shared_0" " shared_0"
" v_1" " v_1"
"(- shared-counter_0))))" "(- shared-counter_0))))"
"(if(let-values(((or-part_0)(symbol? v_1)))" "(if(let-values(((or-part_0)"
"(symbol? v_1)))"
"(if or-part_0" "(if or-part_0"
" or-part_0" " or-part_0"
"(let-values(((or-part_1)" "(let-values(((or-part_1)"
@ -18913,7 +18915,8 @@ static const char *startup_source =
"(loop_0 v_2)))" "(loop_0 v_2)))"
" #t))" " #t))"
"(if(box? v_1)" "(if(box? v_1)"
"(let-values()(loop_0(unbox v_1)))" "(let-values()"
"(loop_0(unbox v_1)))"
"(let-values(((c1_0)" "(let-values(((c1_0)"
"(prefab-struct-key" "(prefab-struct-key"
" v_1)))" " v_1)))"
@ -18936,7 +18939,7 @@ static const char *startup_source =
" 1)" " 1)"
"(normalise-inputs" "(normalise-inputs"
" 'in-vector" " 'in-vector"
" \"vector\"" " \"vector\""
"(lambda(x_0)" "(lambda(x_0)"
"(vector?" "(vector?"
" x_0))" " x_0))"
@ -19055,7 +19058,12 @@ static const char *startup_source =
"(let-values(((path->relative-path-elements_0)" "(let-values(((path->relative-path-elements_0)"
"(let-values()" "(let-values()"
"(make-path->relative-path-elements.1 #f unsafe-undefined))))" "(make-path->relative-path-elements.1 #f unsafe-undefined))))"
"(let-values((()(begin(1/write-bytes fasl-prefix o_0)(values))))" "(let-values((()"
"(begin"
"(if skip-prefix?_0"
"(void)"
"(let-values()(1/write-bytes fasl-prefix o_0)))"
"(values))))"
"(let-values(((bstr_0)" "(let-values(((bstr_0)"
"(let-values(((o_1)(open-output-bytes)))" "(let-values(((o_1)(open-output-bytes)))"
"(begin" "(begin"
@ -19064,7 +19072,9 @@ static const char *startup_source =
"(begin" "(begin"
" 'loop" " 'loop"
"(if(not" "(if(not"
"(eq?(hash-ref shared_0 v_1 1) 1))" "(eq?"
"(hash-ref shared_0 v_1 1)"
" 1))"
"(let-values()" "(let-values()"
"(let-values(((c_0)" "(let-values(((c_0)"
"(hash-ref" "(hash-ref"
@ -19084,7 +19094,8 @@ static const char *startup_source =
" shared-counter_0))" " shared-counter_0))"
"(begin" "(begin"
"(set! shared-counter_0" "(set! shared-counter_0"
"(add1 shared-counter_0))" "(add1"
" shared-counter_0))"
"(1/write-byte" "(1/write-byte"
" fasl-graph-def-type" " fasl-graph-def-type"
" o_1)" " o_1)"
@ -19156,13 +19167,14 @@ static const char *startup_source =
"(if(eqv?" "(if(eqv?"
" v_1" " v_1"
" +nan.0)" " +nan.0)"
" #\"\\0\\0\\0\\0\\0\\0\\370\\177\"" " #\"\\0\\0\\0\\0\\0\\0\\370\\177\""
"(real->floating-point-bytes" "(real->floating-point-bytes"
" v_1" " v_1"
" 8" " 8"
" #f))" " #f))"
" o_1)))" " o_1)))"
"(if(single-flonum? v_1)" "(if(single-flonum?"
" v_1)"
"(let-values()" "(let-values()"
"(begin" "(begin"
"(1/write-byte" "(1/write-byte"
@ -19173,7 +19185,7 @@ static const char *startup_source =
" v_1" " v_1"
"(real->single-flonum" "(real->single-flonum"
" +nan.0))" " +nan.0))"
" #\"\\0\\0\\300\\177\"" " #\"\\0\\0\\300\\177\""
"(real->floating-point-bytes" "(real->floating-point-bytes"
" v_1" " v_1"
" 4" " 4"
@ -19190,7 +19202,7 @@ static const char *startup_source =
"(let-values(((bstr_0)" "(let-values(((bstr_0)"
"(string->bytes/utf-8" "(string->bytes/utf-8"
"(format" "(format"
" \"~a\"" " \"~a\""
" v_1))))" " v_1))))"
"(begin" "(begin"
"(write-fasl-integer" "(write-fasl-integer"
@ -19200,7 +19212,8 @@ static const char *startup_source =
"(1/write-bytes" "(1/write-bytes"
" bstr_0" " bstr_0"
" o_1)))))" " o_1)))))"
"(if(rational? v_1)" "(if(rational?"
" v_1)"
"(let-values()" "(let-values()"
"(begin" "(begin"
"(1/write-byte" "(1/write-byte"
@ -19212,7 +19225,8 @@ static const char *startup_source =
"(loop_0" "(loop_0"
"(denominator" "(denominator"
" v_1))))" " v_1))))"
"(if(complex? v_1)" "(if(complex?"
" v_1)"
"(let-values()" "(let-values()"
"(begin" "(begin"
"(1/write-byte" "(1/write-byte"
@ -19224,7 +19238,8 @@ static const char *startup_source =
"(loop_0" "(loop_0"
"(imag-part" "(imag-part"
" v_1))))" " v_1))))"
"(if(char? v_1)" "(if(char?"
" v_1)"
"(let-values()" "(let-values()"
"(begin" "(begin"
"(1/write-byte" "(1/write-byte"
@ -19591,7 +19606,7 @@ static const char *startup_source =
" 1)" " 1)"
"(normalise-inputs" "(normalise-inputs"
" 'in-vector" " 'in-vector"
" \"vector\"" " \"vector\""
"(lambda(x_0)" "(lambda(x_0)"
"(vector?" "(vector?"
" x_0))" " x_0))"
@ -19787,8 +19802,8 @@ static const char *startup_source =
" v_1))" " v_1))"
"(raise-arguments-error" "(raise-arguments-error"
" 's-exp->fasl" " 's-exp->fasl"
" \"cannot write value\"" " \"cannot write value\""
" \"value\"" " \"value\""
" v_1))))))))))))))))))))))))))))))))))))" " v_1))))))))))))))))))))))))))))))))))))"
" loop_0)" " loop_0)"
" v_0)" " v_0)"
@ -19797,15 +19812,16 @@ static const char *startup_source =
"(write-fasl-integer shared-counter_0 o_0)" "(write-fasl-integer shared-counter_0 o_0)"
"(write-fasl-integer(bytes-length bstr_0) o_0)" "(write-fasl-integer(bytes-length bstr_0) o_0)"
"(1/write-bytes bstr_0 o_0)" "(1/write-bytes bstr_0 o_0)"
"(if orig-o_0(void)(get-output-bytes o_0))))))))))))))))))))))))" "(if orig-o_0(void)(get-output-bytes o_0)))))))))))))))))))))))))"
"(define-values" "(define-values"
"(fasl->s-exp.1)" "(fasl->s-exp.1)"
"(lambda(datum-intern?14_0 external-lifts15_0 orig-i18_0)" "(lambda(datum-intern?16_0 external-lifts17_0 skip-prefix?18_0 orig-i22_0)"
"(begin" "(begin"
" 'fasl->s-exp" " 'fasl->s-exp"
"(let-values(((orig-i_0) orig-i18_0))" "(let-values(((orig-i_0) orig-i22_0))"
"(let-values(((intern?_0) datum-intern?14_0))" "(let-values(((intern?_0) datum-intern?16_0))"
"(let-values(((external-lifts_0)(if(eq? external-lifts15_0 unsafe-undefined) '#() external-lifts15_0)))" "(let-values(((external-lifts_0)(if(eq? external-lifts17_0 unsafe-undefined) '#() external-lifts17_0)))"
"(let-values(((skip-prefix?_0) skip-prefix?18_0))"
"(let-values()" "(let-values()"
"(let-values(((init-i_0)" "(let-values(((init-i_0)"
"(if(bytes? orig-i_0)" "(if(bytes? orig-i_0)"
@ -19813,14 +19829,17 @@ static const char *startup_source =
"(if(input-port? orig-i_0)" "(if(input-port? orig-i_0)"
"(let-values() orig-i_0)" "(let-values() orig-i_0)"
"(let-values()" "(let-values()"
" (raise-argument-error 'fasl->s-exp \"(or/c bytes? input-port?)\" orig-i_0))))))" " (raise-argument-error 'fasl->s-exp \"(or/c bytes? input-port?)\" orig-i_0))))))"
"(let-values((()" "(let-values((()"
"(begin" "(begin"
"(if(bytes=?(read-bytes/exactly fasl-prefix-length init-i_0) fasl-prefix)" "(if skip-prefix?_0"
"(void)" "(void)"
" (let-values () (read-error \"unrecognized prefix\")))" "(let-values()"
"(if(bytes=?(read-bytes/exactly* fasl-prefix-length init-i_0) fasl-prefix)"
"(void)"
" (let-values () (read-error \"unrecognized prefix\")))))"
"(values))))" "(values))))"
"(let-values(((shared-count_0)(read-fasl-integer init-i_0)))" "(let-values(((shared-count_0)(read-fasl-integer* init-i_0)))"
"(let-values(((shared_0)(make-vector shared-count_0)))" "(let-values(((shared_0)(make-vector shared-count_0)))"
"(let-values((()" "(let-values((()"
"(begin" "(begin"
@ -19829,7 +19848,7 @@ static const char *startup_source =
" #f)" " #f)"
"(void)" "(void)"
"(let-values()" "(let-values()"
" (error 'fasl->s-exp \"external-lift vector does not match expected size\")))" " (error 'fasl->s-exp \"external-lift vector does not match expected size\")))"
"(values))))" "(values))))"
"(let-values((()" "(let-values((()"
"(begin" "(begin"
@ -19849,7 +19868,8 @@ static const char *startup_source =
"(begin" "(begin"
" 'for-loop" " 'for-loop"
"(if(if(unsafe-fx< pos_0 len_0) #t #f)" "(if(if(unsafe-fx< pos_0 len_0) #t #f)"
"(let-values(((v_0)(unsafe-vector-ref vec_0 pos_0))" "(let-values(((v_0)"
"(unsafe-vector-ref vec_0 pos_0))"
"((pos_2) pos_1))" "((pos_2) pos_1))"
"(let-values((()" "(let-values((()"
"(let-values()" "(let-values()"
@ -19866,7 +19886,9 @@ static const char *startup_source =
"(values)))))" "(values)))))"
"(values)))))" "(values)))))"
"(if(not #f)" "(if(not #f)"
"(for-loop_0(unsafe-fx+ 1 pos_0)(+ pos_1 1))" "(for-loop_0"
"(unsafe-fx+ 1 pos_0)"
"(+ pos_1 1))"
"(values))))" "(values))))"
"(values))))))" "(values))))))"
" for-loop_0)" " for-loop_0)"
@ -19874,11 +19896,11 @@ static const char *startup_source =
" start_0)))" " start_0)))"
"(values))))" "(values))))"
"(let-values()" "(let-values()"
"(let-values(((len_0)(read-fasl-integer init-i_0)))" "(let-values(((len_0)(read-fasl-integer* init-i_0)))"
"(let-values(((i_0)" "(let-values(((i_0)"
"(if(mpair? init-i_0)" "(if(mpair? init-i_0)"
" init-i_0" " init-i_0"
"(let-values(((bstr_0)(read-bytes/exactly len_0 init-i_0)))" "(let-values(((bstr_0)(read-bytes/exactly* len_0 init-i_0)))"
"(mcons bstr_0 0)))))" "(mcons bstr_0 0)))))"
"(let-values(((intern_0)" "(let-values(((intern_0)"
"(lambda(v_0)" "(lambda(v_0)"
@ -19953,8 +19975,8 @@ static const char *startup_source =
" fasl-lowest-small-integer))" " fasl-lowest-small-integer))"
"(let-values()" "(let-values()"
"(read-error" "(read-error"
" \"unrecognized fasl tag\"" " \"unrecognized fasl tag\""
" \"tag\"" " \"tag\""
" type_0))))" " type_0))))"
"(if(unsafe-fx< index_0 2)" "(if(unsafe-fx< index_0 2)"
"(let-values()" "(let-values()"
@ -19965,7 +19987,7 @@ static const char *startup_source =
"(if(< pos_0 shared-count_0)" "(if(< pos_0 shared-count_0)"
"(void)" "(void)"
"(let-values()" "(let-values()"
" (read-error \"bad graph index\")))" " (read-error \"bad graph index\")))"
"(vector-set! shared_0 pos_0 v_0)" "(vector-set! shared_0 pos_0 v_0)"
" v_0))))" " v_0))))"
"(if(unsafe-fx< index_0 3)" "(if(unsafe-fx< index_0 3)"
@ -19976,7 +19998,7 @@ static const char *startup_source =
"(if(< pos_0 shared-count_0)" "(if(< pos_0 shared-count_0)"
"(void)" "(void)"
"(let-values()" "(let-values()"
" (read-error \"bad graph index\")))" " (read-error \"bad graph index\")))"
"(vector-ref shared_0 pos_0))))" "(vector-ref shared_0 pos_0))))"
"(let-values() #f))))" "(let-values() #f))))"
"(if(unsafe-fx< index_0 6)" "(if(unsafe-fx< index_0 6)"
@ -20034,8 +20056,10 @@ static const char *startup_source =
"(read-fasl-string i_0)))" "(read-fasl-string i_0)))"
"(if(unsafe-fx< index_0 19)" "(if(unsafe-fx< index_0 19)"
"(let-values()" "(let-values()"
"(string->keyword(read-fasl-string i_0)))" "(string->keyword"
"(let-values()(read-fasl-string i_0))))))))" "(read-fasl-string i_0)))"
"(let-values()"
"(read-fasl-string i_0))))))))"
"(if(unsafe-fx< index_0 30)" "(if(unsafe-fx< index_0 30)"
"(if(unsafe-fx< index_0 24)" "(if(unsafe-fx< index_0 24)"
"(if(unsafe-fx< index_0 21)" "(if(unsafe-fx< index_0 21)"
@ -20068,7 +20092,8 @@ static const char *startup_source =
"(#%variable-reference))" "(#%variable-reference))"
"(void)" "(void)"
"(let-values()" "(let-values()"
"(check-list lst_0)))" "(check-list"
" lst_0)))"
"((letrec-values(((for-loop_0)" "((letrec-values(((for-loop_0)"
"(lambda(fold-var_0" "(lambda(fold-var_0"
" lst_1)" " lst_1)"
@ -20116,9 +20141,12 @@ static const char *startup_source =
"(if(null? rel-elems_0)" "(if(null? rel-elems_0)"
"(let-values()(build-path 'same))" "(let-values()(build-path 'same))"
"(let-values()" "(let-values()"
"(apply build-path rel-elems_0)))))))" "(apply"
" build-path"
" rel-elems_0)))))))"
"(let-values()" "(let-values()"
"(intern_0(pregexp(read-fasl-string i_0)))))" "(intern_0"
"(pregexp(read-fasl-string i_0)))))"
"(if(unsafe-fx< index_0 27)" "(if(unsafe-fx< index_0 27)"
"(let-values()" "(let-values()"
"(intern_0(regexp(read-fasl-string i_0))))" "(intern_0(regexp(read-fasl-string i_0))))"
@ -20203,7 +20231,8 @@ static const char *startup_source =
"(let-values(((len_1)" "(let-values(((len_1)"
"(read-fasl-integer i_0)))" "(read-fasl-integer i_0)))"
"(let-values(((vec_0)" "(let-values(((vec_0)"
"(let-values(((len_2) len_1))" "(let-values(((len_2)"
" len_1))"
"(begin" "(begin"
"(if(exact-nonnegative-integer?" "(if(exact-nonnegative-integer?"
" len_2)" " len_2)"
@ -20211,7 +20240,7 @@ static const char *startup_source =
"(let-values()" "(let-values()"
"(raise-argument-error" "(raise-argument-error"
" 'for/vector" " 'for/vector"
" \"exact-nonnegative-integer?\"" " \"exact-nonnegative-integer?\""
" len_2)))" " len_2)))"
"(let-values(((v_0)" "(let-values(((v_0)"
"(make-vector" "(make-vector"
@ -20432,7 +20461,8 @@ static const char *startup_source =
" end_0" " end_0"
" inc_0)))" " inc_0)))"
"((letrec-values(((for-loop_0)" "((letrec-values(((for-loop_0)"
"(lambda(ht_1 pos_0)" "(lambda(ht_1"
" pos_0)"
"(begin" "(begin"
" 'for-loop" " 'for-loop"
"(if(<" "(if(<"
@ -20481,8 +20511,10 @@ static const char *startup_source =
"(srcloc-source s_0)" "(srcloc-source s_0)"
"(srcloc-line s_0)" "(srcloc-line s_0)"
"(srcloc-column s_0)" "(srcloc-column s_0)"
"(srcloc-position s_0)" "(srcloc-position"
"(srcloc-span s_0)))))" " s_0)"
"(srcloc-span"
" s_0)))))"
"(let-values(((lst_0)(loop_0)))" "(let-values(((lst_0)(loop_0)))"
"(begin" "(begin"
"(if(variable-reference-from-unsafe?" "(if(variable-reference-from-unsafe?"
@ -20528,7 +20560,7 @@ static const char *startup_source =
" lst_0)))))))" " lst_0)))))))"
"(let-values()" "(let-values()"
" unsafe-undefined)))))))))))))))" " unsafe-undefined)))))))))))))))"
" loop_0)))))))))))))))))))" " loop_0))))))))))))))))))))"
"(define-values" "(define-values"
"(write-fasl-integer)" "(write-fasl-integer)"
"(lambda(i_0 o_0)" "(lambda(i_0 o_0)"
@ -20562,13 +20594,17 @@ static const char *startup_source =
"(read-byte/no-eof)" "(read-byte/no-eof)"
"(lambda(i_0)" "(lambda(i_0)"
"(begin" "(begin"
"(if(mpair? i_0)"
"(let-values()"
"(let-values(((pos_0)(mcdr i_0)))" "(let-values(((pos_0)(mcdr i_0)))"
"(begin" "(begin"
" (if (< pos_0 (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))" " (if (< pos_0 (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))"
"(set-mcdr! i_0(add1 pos_0))" "(set-mcdr! i_0(fx+ pos_0 1))"
"(bytes-ref(mcar i_0) pos_0))))" "(bytes-ref(mcar i_0) pos_0))))))"
"(define-values"
"(read-byte/no-eof*)"
"(lambda(i_0)"
"(begin"
"(if(mpair? i_0)"
"(let-values()(read-byte/no-eof i_0))"
"(let-values()" "(let-values()"
"(let-values(((b_0)(read-byte i_0)))" "(let-values(((b_0)(read-byte i_0)))"
" (begin (if (eof-object? b_0) (let-values () (read-error \"truncated stream\")) (void)) b_0)))))))" " (begin (if (eof-object? b_0) (let-values () (read-error \"truncated stream\")) (void)) b_0)))))))"
@ -20576,13 +20612,17 @@ static const char *startup_source =
"(read-bytes/exactly)" "(read-bytes/exactly)"
"(lambda(n_0 i_0)" "(lambda(n_0 i_0)"
"(begin" "(begin"
"(if(mpair? i_0)"
"(let-values()"
"(let-values(((pos_0)(mcdr i_0)))" "(let-values(((pos_0)(mcdr i_0)))"
"(begin" "(begin"
" (if (<= (+ pos_0 n_0) (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))" " (if (<= (+ pos_0 n_0) (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))"
"(set-mcdr! i_0(+ pos_0 n_0))" "(set-mcdr! i_0(fx+ pos_0 n_0))"
"(subbytes(mcar i_0) pos_0(+ pos_0 n_0)))))" "(subbytes(mcar i_0) pos_0(fx+ pos_0 n_0)))))))"
"(define-values"
"(read-bytes/exactly*)"
"(lambda(n_0 i_0)"
"(begin"
"(if(mpair? i_0)"
"(let-values()(read-bytes/exactly n_0 i_0))"
"(let-values()" "(let-values()"
"(let-values(((bstr_0)(read-bytes n_0 i_0)))" "(let-values(((bstr_0)(read-bytes n_0 i_0)))"
"(begin" "(begin"
@ -20591,18 +20631,34 @@ static const char *startup_source =
" (let-values () (read-error \"truncated stream\")))" " (let-values () (read-error \"truncated stream\")))"
" bstr_0)))))))" " bstr_0)))))))"
"(define-values" "(define-values"
"(read-fasl-integer)" "(read-fasl-integer read-fasl-integer*)"
"(let-values()"
"(let-values()"
"(values"
"(lambda(i_0)" "(lambda(i_0)"
"(begin"
"(let-values(((b_0)(read-byte/no-eof i_0)))" "(let-values(((b_0)(read-byte/no-eof i_0)))"
"(if(<= b_0 127)" "(if(fx<= b_0 127)"
"(let-values() b_0)" "(let-values() b_0)"
"(if(>= b_0 132)" "(if(fx>= b_0 132)"
"(let-values()(- b_0 256))" "(let-values()(fx- b_0 256))"
"(if(eqv? b_0 128)" "(if(eqv? b_0 128)"
"(let-values()(integer-bytes->integer(read-bytes/exactly 2 i_0) #t #f))" "(let-values()"
"(let-values(((lo_0)(read-byte/no-eof i_0)))"
"(let-values(((hi_0)(read-byte/no-eof i_0)))"
"(if(fx> hi_0 127)(fxior(fxlshift(fx+ -256 hi_0) 8) lo_0)(fxior(fxlshift hi_0 8) lo_0)))))"
"(if(eqv? b_0 129)" "(if(eqv? b_0 129)"
"(let-values()(integer-bytes->integer(read-bytes/exactly 4 i_0) #t #f))" "(let-values()"
"(let-values(((a_0)(read-byte/no-eof i_0)))"
"(let-values(((b_1)(read-byte/no-eof i_0)))"
"(let-values(((c_0)(read-byte/no-eof i_0)))"
"(let-values(((d_0)(read-byte/no-eof i_0)))"
"(bitwise-ior"
" a_0"
"(arithmetic-shift"
"(if(fx> d_0 127)"
"(fxior(fxlshift(fx+ -256 d_0) 16)(fxlshift c_0 8) b_1)"
"(fxior(fxlshift d_0 16)(fxlshift c_0 8) b_1))"
" 8)))))))"
"(if(eqv? b_0 130)" "(if(eqv? b_0 130)"
"(let-values()(integer-bytes->integer(read-bytes/exactly 8 i_0) #t #f))" "(let-values()(integer-bytes->integer(read-bytes/exactly 8 i_0) #t #f))"
"(if(eqv? b_0 131)" "(if(eqv? b_0 131)"
@ -20612,22 +20668,87 @@ static const char *startup_source =
"(begin" "(begin"
"(if(if(string? str_0)(= len_0(string-length str_0)) #f)" "(if(if(string? str_0)(= len_0(string-length str_0)) #f)"
"(void)" "(void)"
" (let-values () (read-error \"truncated stream at number\")))" " (let-values () (read-error \"truncated stream at number\")))"
"(1/string->number str_0 16)))))" "(1/string->number str_0 16)))))"
" (let-values () (read-error \"internal error on integer mode\"))))))))))))" " (let-values () (read-error \"internal error on integer mode\"))))))))))"
"(lambda(i_0)"
"(let-values(((b_0)(read-byte/no-eof* i_0)))"
"(if(fx<= b_0 127)"
"(let-values() b_0)"
"(if(fx>= b_0 132)"
"(let-values()(fx- b_0 256))"
"(if(eqv? b_0 128)"
"(let-values()"
"(let-values(((lo_0)(read-byte/no-eof* i_0)))"
"(let-values(((hi_0)(read-byte/no-eof* i_0)))"
"(if(fx> hi_0 127)(fxior(fxlshift(fx+ -256 hi_0) 8) lo_0)(fxior(fxlshift hi_0 8) lo_0)))))"
"(if(eqv? b_0 129)"
"(let-values()"
"(let-values(((a_0)(read-byte/no-eof* i_0)))"
"(let-values(((b_1)(read-byte/no-eof* i_0)))"
"(let-values(((c_0)(read-byte/no-eof* i_0)))"
"(let-values(((d_0)(read-byte/no-eof* i_0)))"
"(bitwise-ior"
" a_0"
"(arithmetic-shift"
"(if(fx> d_0 127)"
"(fxior(fxlshift(fx+ -256 d_0) 16)(fxlshift c_0 8) b_1)"
"(fxior(fxlshift d_0 16)(fxlshift c_0 8) b_1))"
" 8)))))))"
"(if(eqv? b_0 130)"
"(let-values()(integer-bytes->integer(read-bytes/exactly* 8 i_0) #t #f))"
"(if(eqv? b_0 131)"
"(let-values()"
"(let-values(((len_0)(read-fasl-integer i_0)))"
"(let-values(((str_0)(read-fasl-string i_0 len_0)))"
"(begin"
"(if(if(string? str_0)(= len_0(string-length str_0)) #f)"
"(void)"
" (let-values () (read-error \"truncated stream at number\")))"
"(1/string->number str_0 16)))))"
" (let-values () (read-error \"internal error on integer mode\"))))))))))))))"
"(define-values" "(define-values"
"(read-fasl-string)" "(read-fasl-string)"
"(let-values(((read-fasl-string_0)" "(let-values(((read-fasl-string_0)"
"(lambda(i21_0 len20_0)" "(lambda(i25_0 len24_0)"
"(begin" "(begin"
" 'read-fasl-string" " 'read-fasl-string"
"(let-values(((i_0) i21_0))" "(let-values(((i_0) i25_0))"
"(let-values(((len_0)(if(eq? len20_0 unsafe-undefined)(read-fasl-integer i_0) len20_0)))" "(let-values(((len_0)(if(eq? len24_0 unsafe-undefined)(read-fasl-integer i_0) len24_0)))"
"(let-values()" "(let-values()"
"(let-values(((bstr_0)(read-bytes/exactly len_0 i_0)))(bytes->string/utf-8 bstr_0)))))))))" "(let-values(((pos_0)(mcdr i_0)))"
"(let-values(((bstr_0)(mcar i_0)))"
"(if(<=(+ pos_0 len_0)(bytes-length bstr_0))"
"(let-values()"
"(let-values((()(begin(set-mcdr! i_0(fx+ pos_0 len_0))(values))))"
"(let-values(((s_0)(make-string len_0)))"
"((letrec-values(((loop_0)"
"(lambda(i_1)"
"(begin"
" 'loop"
"(if(fx= i_1 len_0)"
"(let-values() s_0)"
"(let-values()"
"(let-values(((c_0)(bytes-ref bstr_0(fx+ i_1 pos_0))))"
"(if(fx<= c_0 128)"
"(let-values()"
"(begin"
"(string-set! s_0 i_1(integer->char c_0))"
"(loop_0(fx+ i_1 1))))"
"(let-values()"
"(bytes->string/utf-8"
" bstr_0"
" #f"
" pos_0"
"(fx+ pos_0 len_0)))))))))))"
" loop_0)"
" 0))))"
"(let-values()"
"(let-values(((bstr_1)(read-bytes/exactly len_0 i_0)))"
"(bytes->string/utf-8 bstr_1)))))))))))))"
"(case-lambda" "(case-lambda"
"((i_0)(begin(read-fasl-string_0 i_0 unsafe-undefined)))" "((i_0)(begin(read-fasl-string_0 i_0 unsafe-undefined)))"
"((i_0 len20_0)(read-fasl-string_0 i_0 len20_0)))))" "((i_0 len24_0)(read-fasl-string_0 i_0 len24_0)))))"
"(define-values" "(define-values"
"(read-fasl-bytes)" "(read-fasl-bytes)"
"(lambda(i_0)(begin(let-values(((len_0)(read-fasl-integer i_0)))(read-bytes/exactly len_0 i_0)))))" "(lambda(i_0)(begin(let-values(((len_0)(read-fasl-integer i_0)))(read-bytes/exactly len_0 i_0)))))"
@ -20754,7 +20875,6 @@ static const char *startup_source =
" call-with-module-prompt" " call-with-module-prompt"
" make-pthread-parameter" " make-pthread-parameter"
" engine-block" " engine-block"
" force-unfasl"
" make-record-type-descriptor" " make-record-type-descriptor"
" make-record-type-descriptor*" " make-record-type-descriptor*"
" make-record-constructor-descriptor" " make-record-constructor-descriptor"
@ -29807,7 +29927,7 @@ static const char *startup_source =
"(define-values" "(define-values"
"(write-correlated-linklet-bundle-hash)" "(write-correlated-linklet-bundle-hash)"
"(lambda(ht_0 o_0)" "(lambda(ht_0 o_0)"
"(begin(let-values(((temp7_0)(->faslable ht_0))((o8_0) o_0))(s-exp->fasl.1 #f #f #f temp7_0 o8_0)))))" "(begin(let-values(((temp7_0)(->faslable ht_0))((o8_0) o_0))(s-exp->fasl.1 #f #f #f #f temp7_0 o8_0)))))"
"(define-values" "(define-values"
"(->faslable)" "(->faslable)"
"(lambda(v_0)" "(lambda(v_0)"
@ -29961,7 +30081,8 @@ static const char *startup_source =
"(define-values" "(define-values"
"(read-correlated-linklet-bundle-hash)" "(read-correlated-linklet-bundle-hash)"
"(lambda(in_0)" "(lambda(in_0)"
"(begin(faslable->(let-values(((in9_0) in_0)((temp10_0) #t))(fasl->s-exp.1 temp10_0 unsafe-undefined in9_0))))))" "(begin"
"(faslable->(let-values(((in9_0) in_0)((temp10_0) #t))(fasl->s-exp.1 temp10_0 unsafe-undefined #f in9_0))))))"
"(define-values" "(define-values"
"(faslable->)" "(faslable->)"
"(lambda(v_0)" "(lambda(v_0)"

238
racket/src/cify/literal.rkt Normal file
View File

@ -0,0 +1,238 @@
#lang racket/base
(require racket/extflonum
racket/prefab
racket/unsafe/undefined
"match.rkt"
"../schemify/wrap.rkt")
(provide extract-literals)
;; For most literal values values, lift a construction of the quoted value
;; out and replace the use of a quoted value with a variable
;; reference. This lifting can interefere with optimizations, so only
;; lift as a last resort.
(define (extract-literals bodys)
(define lifted-eq-constants (make-hasheq))
(define lifted-equal-constants (make-hash))
(define lift-bindings null)
(define lifts-count 0)
(define (add-lifted rhs)
;; FIXME: make sure these `id`s don't collide with anything
(define id (string->symbol (format "q:~a" lifts-count)))
(set! lifts-count (add1 lifts-count))
(set! lift-bindings (cons (list id rhs) lift-bindings))
id)
(define new-bodys
(for/list ([v (in-list bodys)])
(cond
[(convert-any? v)
(define (convert v)
(reannotate
v
(match v
[`(quote ,q)
(cond
[(lift-quoted? q)
(make-construct q add-lifted lifted-eq-constants lifted-equal-constants)]
[else v])]
[`(lambda ,formals ,body ...)
`(lambda ,formals ,@(convert-function-body body))]
[`(case-lambda [,formalss ,bodys ...] ...)
`(case-lambda ,@(for/list ([formals (in-list formalss)]
[body (in-list bodys)])
`[,formals ,@(convert-function-body body)]))]
[`(define-values ,ids ,rhs)
`(define-values ,ids ,(convert rhs))]
[`(let-values ([,idss ,rhss] ...) ,bodys ...)
`(let-values ,(for/list ([ids (in-list idss)]
[rhs (in-list rhss)])
`[,ids ,(convert rhs)])
,@(convert-body bodys))]
[`(letrec-values ([,idss ,rhss] ...) ,bodys ...)
`(letrec-values ,(for/list ([ids (in-list idss)]
[rhs (in-list rhss)])
`[,ids ,(convert rhs)])
,@(convert-body bodys))]
[`(if ,tst ,thn ,els)
`(if ,(convert tst) ,(convert thn) ,(convert els))]
[`(with-continuation-mark* ,mode ,key ,val ,body)
`(with-continuation-mark* ,mode ,(convert key) ,(convert val) ,(convert body))]
[`(begin ,exps ...)
`(begin . ,(convert-body exps))]
[`(begin-unsafe ,exps ...)
`(begin-unsafe . ,(convert-body exps))]
[`(begin0 ,exps ...)
`(begin0 . ,(convert-body exps))]
[`(set! ,id ,rhs)
`(set! ,id ,(convert rhs))]
[`(#%variable-reference) v]
[`(#%variable-reference ,_) v]
[`(,rator ,exps ...)
`(,(convert rator) ,@(convert-body exps))]
[`,_
(cond
[(and (not (symbol? v))
(lift-quoted? v))
(convert `(quote ,v))]
[else v])])))
(define (convert-body body)
(for/list ([e (in-list body)])
(convert e)))
(define (convert-function-body body)
;; Detect the function-name pattern and avoid
;; mangling it:
(match body
[`((begin (quote ,name) ,body . ,bodys))
`((begin (quote ,name) ,@(convert-body (cons body bodys))))]
[`,_ (convert-body body)]))
(convert v)]
[else v])))
(values new-bodys
(reverse lift-bindings)))
;; v is a form or a list of forms
(define (convert-any? v)
(let convert-any? ([v v])
(match v
[`(quote ,q) (lift-quoted? q)]
[`(lambda ,formals ,body ...)
(convert-any? body)]
[`(case-lambda [,formalss ,bodys ...] ...)
(convert-any? bodys)]
[`(define-values ,ids ,rhs)
(convert-any? rhs)]
[`(let-values ([,idss ,rhss] ...) ,bodys ...)
(or (convert-any? rhss)
(convert-any? bodys))]
[`(letrec-values ([,idss ,rhss] ...) ,bodys ...)
(or (convert-any? rhss)
(convert-any? bodys))]
[`(if ,tst ,thn ,els)
(or (convert-any? tst)
(convert-any? thn)
(convert-any? els))]
[`(with-continuation-mark* ,_ ,key ,val ,body)
(or (convert-any? key)
(convert-any? val)
(convert-any? body))]
[`(begin ,exps ...)
(convert-any? exps)]
[`(begin-unsafe ,exps ...)
(convert-any? exps)]
[`(begin0 ,exps ...)
(convert-any? exps)]
[`(set! ,id ,rhs)
(convert-any? rhs)]
[`(#%variable-reference) #f]
[`(#%variable-reference ,_) #f]
[`(,exps ...)
(for/or ([exp (in-list exps)])
(convert-any? exp))]
[`,_ (and (not (symbol? v))
(lift-quoted? v))])))
;; Construct an expression to be lifted
(define (make-construct q add-lifted lifted-eq-constants lifted-equal-constants)
(define (quote? e) (and (pair? e) (eq? 'quote (car e))))
(define seen #hasheq())
(define (check-cycle v)
(when (hash-ref seen v #f)
(raise-arguments-error 'compile "cannot compile cyclic value"
"value" q))
(set! seen (hash-set seen v #t)))
(define (done-cycle v)
(set! seen (hash-remove seen v)))
(let make-construct ([q q])
(define lifted-constants (if (or (string? q) (bytes? q))
lifted-equal-constants
lifted-eq-constants))
(cond
[(hash-ref lifted-constants q #f)
=> (lambda (id) id)]
[else
(define rhs
(cond
[(path? q)
`(bytes->path ,(path->bytes q)
',(path-convention-type q))]
[(regexp? q)
`(,(if (pregexp? q) 'pregexp 'regexp) ,(object-name q))]
[(srcloc? q)
`(unsafe-make-srcloc
,(make-construct (srcloc-source q))
,(make-construct (srcloc-line q))
,(make-construct (srcloc-column q))
,(make-construct (srcloc-position q))
,(make-construct (srcloc-span q)))]
[(byte-regexp? q)
`(,(if (byte-pregexp? q) 'byte-pregexp 'byte-regexp) ,(object-name q))]
[(keyword? q)
`(string->keyword ,(keyword->string q))]
[(hash? q)
(define mut? (not (immutable? q)))
(when mut? (check-cycle q))
(define new-q
`(,(cond
[(hash-eq? q) 'hasheq]
[(hash-eqv? q) 'hasheqv]
[else 'hash])
,@(apply append
(for/list ([(k v) (in-hash q)])
(list (make-construct k)
(make-construct v))))))
(when mut? (done-cycle q))
new-q]
[(string? q) `(datum-intern-literal ,q)]
[(bytes? q) `(datum-intern-literal ,q)]
[(pair? q)
(if (list? q)
(let ([args (map make-construct q)])
(if (andmap quote? args)
`(quote ,q)
`(list ,@(map make-construct q))))
(let ([a (make-construct (car q))]
[d (make-construct (cdr q))])
(if (and (quote? a) (quote? d))
`(quote ,q)
`(cons ,a ,d))))]
[(vector? q)
(let ([args (map make-construct (vector->list q))])
`(vector->immutable-vector
,(if (and (andmap quote? args)
(not (impersonator? q)))
`(quote ,q)
`(vector ,@args))))]
[(box? q)
(let ([arg (make-construct (unbox q))])
`(box-immutable ,arg))]
[(prefab-struct-key q)
=> (lambda (key)
(define mut? (not (prefab-key-all-fields-immutable? key)))
(when mut? (check-cycle q))
(define new-q
`(make-prefab-struct ',key ,@(map make-construct
(cdr (vector->list (struct->vector q))))))
(when mut? (done-cycle q))
new-q)]
[(extflonum? q)
`(string->number ,(format "~a" q) 10 'read)]
[else
;; Assume serializable in-place:
`(quote ,q)]))
(cond
[(and (quote? rhs)
(not (lift-quoted? (cadr rhs))))
rhs]
[else
(define id (add-lifted rhs))
(hash-set! lifted-constants q id)
id])])))
(define (lift-quoted? q)
(not (or (and (exact-integer? q)
;; always a fixnum:
(<= (- (expt 2 29)) q (sub1 (expt 2 29))))
(boolean? q)
(null? q)
(void? q))))

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

@ -32,7 +32,7 @@
(unless (eof-object? cmd) (unless (eof-object? cmd)
(get-u8 in) ; newline (get-u8 in) ; newline
(let-values ([(o get) (open-bytevector-output-port)]) (let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths (let ([literals
(case (integer->char cmd) (case (integer->char cmd)
[(#\c #\u) [(#\c #\u)
(call-with-fasled (call-with-fasled
@ -41,7 +41,7 @@
(parameterize ([optimize-level (if (fx= cmd (char->integer #\u)) (parameterize ([optimize-level (if (fx= cmd (char->integer #\u))
3 3
(optimize-level))]) (optimize-level))])
(compile-to-port (list `(lambda () ,v)) o #f #f #f (string->symbol target) #f pred))))] (compile-to-port (list v) o #f #f #f (string->symbol target) #f pred))))]
[(#\f) [(#\f)
;; Reads host fasl format, then writes target fasl format ;; Reads host fasl format, then writes target fasl format
(call-with-fasled (call-with-fasled
@ -54,11 +54,11 @@
(let ([result (get)]) (let ([result (get)])
(put-num out (bytevector-length result)) (put-num out (bytevector-length result))
(put-bytevector out result) (put-bytevector out result)
(let ([len (vector-length sfd-paths)]) (let ([len (vector-length literals)])
(put-num out len) (put-num out len)
(let loop ([i 0]) (let loop ([i 0])
(unless (fx= i len) (unless (fx= i len)
(put-num out (vector-ref sfd-paths i)) (put-num out (vector-ref literals i))
(loop (fx+ i 1))))) (loop (fx+ i 1)))))
(flush-output-port out))) (flush-output-port out)))
(loop))))))) (loop)))))))
@ -76,30 +76,41 @@
;; ---------------------------------------- ;; ----------------------------------------
(define-record-type path-placeholder (define-record-type literal-placeholder
(fields pos)) (fields pos))
(define (call-with-fasled in proc) (define (call-with-fasled in proc)
(let* ([fasled-bv (get-bytevector-n in (get-num in))] (let* ([fasled-bv (get-bytevector-n in (get-num in))]
[num-sfd-paths (get-num in)] [literals-bv (get-bytevector-n in (get-num in))]
[sfd-paths (list->vector [transparent-placeholders (make-eq-hashtable)]
(let loop ([i 0]) [literals (let ([vec (fasl-read (open-bytevector-input-port literals-bv))])
(if (fx= i num-sfd-paths) ;; Use a placeholder for opaque literals that could not be
'() ;; communicated from the Racket world. "Transparent" literals
(cons (make-path-placeholder i) ;; are things like strings and bytevectors that can affect
(loop (fx+ i 1))))))] ;; compilation, since code might be specialized to a string
;; or bytevector literal.
(let loop ([i 0])
(if (fx= i (vector-length vec))
vec
(let ([e (vector-ref vec i)]
[ph (make-literal-placeholder i)])
(cond
[(not e) (vector-set! vec i ph)]
[else (hashtable-set! transparent-placeholders e ph)])
(loop (fx+ i 1))))))]
[used-placeholders '()] [used-placeholders '()]
;; v is the Chez Scheme value communicated from the client, ;; v is the Chez Scheme value communicated from the client,
;; but with each path replace by a `path-placeholder`: ;; but with each opaque literal replaced by a `literal-placeholder`:
[v (fasl-read (open-bytevector-input-port fasled-bv) [v (fasl-read (open-bytevector-input-port fasled-bv)
'load 'load
sfd-paths)]) literals)])
(proc v (proc v
(lambda (a) (lambda (a)
(and (path-placeholder? a) (let ([a (eq-hashtable-ref transparent-placeholders a a)])
(begin (and (literal-placeholder? a)
(set! used-placeholders (cons a used-placeholders)) (begin
#t)))) (set! used-placeholders (cons a used-placeholders))
;; Return indices of paths used in new fasled output, in the #t)))))
;; order that they're used ;; Return indices of literals used in new fasled output in the order
(list->vector (map path-placeholder-pos used-placeholders)))) ;; that they're used.
(list->vector (reverse (map literal-placeholder-pos used-placeholders)))))

4
racket/src/cs/compile-file.ss
View File

@ -113,8 +113,8 @@
[whole-program? [whole-program?
(unless (= 1 (length deps)) (unless (= 1 (length deps))
(error 'compile-file "expected a single dependency for whole-program compilation")) (error 'compile-file "expected a single dependency for whole-program compilation"))
(printf "Whole-program optimizaton for Racket core...\n") (printf "Whole-program optimization for Racket core...\n")
(printf " [If this runs out of memory, try configuring with `--disable-wpo`]\n") (printf "[If this step runs out of memory, try configuring with `--disable-wpo`]\n")
(unless (equal? build-dir "") (unless (equal? build-dir "")
(library-directories (list (cons "." build-dir)))) (library-directories (list (cons "." build-dir))))
(compile-whole-program (car deps) src #t)] (compile-whole-program (car deps) src #t)]

156
racket/src/cs/convert.rkt
View File

@ -5,7 +5,6 @@
racket/file racket/file
racket/extflonum racket/extflonum
"../schemify/schemify.rkt" "../schemify/schemify.rkt"
"../schemify/serialize.rkt"
"../schemify/known.rkt" "../schemify/known.rkt"
"../schemify/lift.rkt" "../schemify/lift.rkt"
"../schemify/reinfer-name.rkt" "../schemify/reinfer-name.rkt"
@ -13,7 +12,6 @@
"known.rkt") "known.rkt")
(define skip-export? #f) (define skip-export? #f)
(define for-cify? #f)
(define unsafe-mode? #f) (define unsafe-mode? #f)
(define-values (in-file out-file) (define-values (in-file out-file)
@ -21,8 +19,6 @@
#:once-each #:once-each
[("--skip-export") "Don't generate an `export` form" [("--skip-export") "Don't generate an `export` form"
(set! skip-export? #t)] (set! skip-export? #t)]
[("--for-cify") "Keep `make-struct-type` as-is, etc."
(set! for-cify? #t)]
[("--unsafe") "Compile for unsafe mode" [("--unsafe") "Compile for unsafe mode"
(set! unsafe-mode? #t)] (set! unsafe-mode? #t)]
#:args #:args
@ -111,8 +107,7 @@
(lift (car v)) (lift (car v))
(lift (cdr v))])) (lift (cdr v))]))
(unless for-cify? (lift l)
(lift l))
(define prim-knowns (get-prim-knowns)) (define prim-knowns (get-prim-knowns))
(define primitives (get-primitives)) (define primitives (get-primitives))
@ -121,97 +116,86 @@
;; Convert: ;; Convert:
(define schemified-body (define schemified-body
(let () (let ()
(define-values (bodys/constants-lifted lifted-constants) (define bodys (recognize-inferred-names l))
(if for-cify?
(begin
(printf "Serializable...\n")
(time (convert-for-serialize l for-cify?)))
(values (recognize-inferred-names l) null)))
(printf "Schemify...\n") (printf "Schemify...\n")
(define body (define body
(time (time
(schemify-body bodys/constants-lifted prim-knowns primitives #hasheq() #hasheq() for-cify? unsafe-mode? (schemify-body bodys prim-knowns primitives #hasheq() #hasheq() #f unsafe-mode?
#t ; no-prompt? #t ; no-prompt?
#f))) ; explicit-unnamed? #f))) ; explicit-unnamed?
(printf "Lift...\n") (printf "Lift...\n")
;; Lift functions to avoid closure creation: ;; Lift functions to avoid closure creation:
(define lifted-body (time
(time (lift-in-schemified-body body #t))))
(lift-in-schemified-body body #t)))
(append (for/list ([p (in-list lifted-constants)])
(cons 'define p))
lifted-body)))
;; ---------------------------------------- ;; ----------------------------------------
(unless for-cify? ;; Set a hook to redirect literal regexps and
;; hash tables to lifted bindings
;; Set a hook to redirect literal regexps and (pretty-print-size-hook
;; hash tables to lifted bindings (lambda (v display? out)
(pretty-print-size-hook (cond
(lambda (v display? out) [(and (pair? v)
(cond (pair? (cdr v))
[(and (pair? v) (eq? 'quote (car v))
(pair? (cdr v)) (or (regexp? (cadr v))
(eq? 'quote (car v)) (byte-regexp? (cadr v))
(or (regexp? (cadr v)) (pregexp? (cadr v))
(byte-regexp? (cadr v)) (byte-pregexp? (cadr v))
(pregexp? (cadr v)) (hash? (cadr v))
(byte-pregexp? (cadr v)) (nested-hash? (cadr v))
(hash? (cadr v)) (keyword? (cadr v))
(nested-hash? (cadr v)) (list-of-keywords? (cadr v))
(keyword? (cadr v)) (extflonum? (cadr v))))
(list-of-keywords? (cadr v)) 10]
(extflonum? (cadr v)))) [(and (pair? v)
10] (pair? (cdr v))
[(and (pair? v) (eq? 'quote (car v))
(pair? (cdr v)) (void? (cadr v)))
(eq? 'quote (car v)) 6]
(void? (cadr v))) [(bytes? v) (* 3 (bytes-length v))]
6] [(and (symbol? v) (regexp-match? #rx"#" (symbol->string v)))
[(bytes? v) (* 3 (bytes-length v))] (+ 2 (string-length (symbol->string v)))]
[(and (symbol? v) (regexp-match? #rx"#" (symbol->string v))) [(char? v) 5]
(+ 2 (string-length (symbol->string v)))] [(single-flonum? v) 5]
[(char? v) 5] [(or (keyword? v)
[(single-flonum? v) 5] (regexp? v)
[(or (keyword? v) (pregexp? v)
(regexp? v) (hash? v))
(pregexp? v) (error 'lift "value that needs lifting is in an unrecognized context: ~v" v)]
(hash? v)) [else #f])))
(error 'lift "value that needs lifting is in an unrecognized context: ~v" v)]
[else #f])))
;; This hook goes with `pretty-print-size-hook` ;; This hook goes with `pretty-print-size-hook`
(pretty-print-print-hook (pretty-print-print-hook
(lambda (v display? out) (lambda (v display? out)
(cond (cond
[(and (pair? v) [(and (pair? v)
(eq? 'quote (car v)) (eq? 'quote (car v))
(or (regexp? (cadr v)) (or (regexp? (cadr v))
(byte-regexp? (cadr v)) (byte-regexp? (cadr v))
(pregexp? (cadr v)) (pregexp? (cadr v))
(byte-pregexp? (cadr v)) (byte-pregexp? (cadr v))
(hash? (cadr v)) (hash? (cadr v))
(nested-hash? (cadr v)) (nested-hash? (cadr v))
(keyword? (cadr v)) (keyword? (cadr v))
(list-of-keywords? (cadr v)) (list-of-keywords? (cadr v))
(extflonum? (cadr v)))) (extflonum? (cadr v))))
(write (hash-ref lifts (cadr v)) out)] (write (hash-ref lifts (cadr v)) out)]
[(and (pair? v) [(and (pair? v)
(pair? (cdr v)) (pair? (cdr v))
(eq? 'quote (car v)) (eq? 'quote (car v))
(void? (cadr v))) (void? (cadr v)))
(write '(void) out)] (write '(void) out)]
[(bytes? v) [(bytes? v)
(display "#vu8") (display "#vu8")
(write (bytes->list v) out)] (write (bytes->list v) out)]
[(symbol? v) [(symbol? v)
(write-string (format "|~a|" v) out)] (write-string (format "|~a|" v) out)]
[(char? v) [(char? v)
(write-string (format "#\\x~x" (char->integer v)) out)] (write-string (format "#\\x~x" (char->integer v)) out)]
[(single-flonum? v) [(single-flonum? v)
(write (real->double-flonum v) out)] (write (real->double-flonum v) out)]
[else #f])))) [else #f])))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -28,9 +28,7 @@
(thread) (thread)
(regexp) (regexp)
(io) (io)
(linklet) (linklet))
(only (schemify)
force-unfasl))
(include "place-register.ss") (include "place-register.ss")
(define-place-register-define define expander-register-start expander-register-count) (define-place-register-define define expander-register-start expander-register-count)

4
racket/src/cs/expander/env.ss
View File

@ -14,6 +14,4 @@
(thread) (thread)
(io) (io)
(regexp) (regexp)
(linklet) (linklet)))
(only (schemify)
force-unfasl)))

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

@ -180,7 +180,7 @@
(define post-lambda-on? (getenv "PLT_LINKLET_SHOW_POST_LAMBDA")) (define post-lambda-on? (getenv "PLT_LINKLET_SHOW_POST_LAMBDA"))
(define post-interp-on? (getenv "PLT_LINKLET_SHOW_POST_INTERP")) (define post-interp-on? (getenv "PLT_LINKLET_SHOW_POST_INTERP"))
(define jit-demand-on? (getenv "PLT_LINKLET_SHOW_JIT_DEMAND")) (define jit-demand-on? (getenv "PLT_LINKLET_SHOW_JIT_DEMAND"))
(define paths-on? (getenv "PLT_LINKLET_SHOW_PATHS")) (define literals-on? (getenv "PLT_LINKLET_SHOW_LITERALS"))
(define known-on? (getenv "PLT_LINKLET_SHOW_KNOWN")) (define known-on? (getenv "PLT_LINKLET_SHOW_KNOWN"))
(define cp0-on? (getenv "PLT_LINKLET_SHOW_CP0")) (define cp0-on? (getenv "PLT_LINKLET_SHOW_CP0"))
(define assembly-on? (getenv "PLT_LINKLET_SHOW_ASSEMBLY")) (define assembly-on? (getenv "PLT_LINKLET_SHOW_ASSEMBLY"))
@ -190,7 +190,7 @@
post-lambda-on? post-lambda-on?
post-interp-on? post-interp-on?
jit-demand-on? jit-demand-on?
paths-on? literals-on?
known-on? known-on?
cp0-on? cp0-on?
assembly-on? assembly-on?
@ -237,24 +237,27 @@
(call-with-system-wind (lambda () (interpret e)))) (call-with-system-wind (lambda () (interpret e))))
(define (fasl-write* s o) (define (fasl-write* s o)
(call-with-system-wind (lambda () (fasl-write s o)))) (call-with-system-wind (lambda () (fasl-write s o))))
(define (fasl-write/paths* s o) (define (fasl-write/literals* s quoteds o)
(call-with-system-wind (lambda () (call-with-system-wind (lambda ()
(call-getting-sfd-paths (call-getting-literals
quoteds
(lambda (pred) (lambda (pred)
(fasl-write s o pred)))))) (fasl-write s o pred))))))
(define (fasl-write-code* s o) (define (fasl-write-code* s quoteds o)
(call-with-system-wind (lambda () (call-with-system-wind (lambda ()
(parameterize ([fasl-compressed compress-code?]) (parameterize ([fasl-compressed compress-code?])
(call-getting-sfd-paths (call-getting-literals
quoteds
(lambda (pred) (lambda (pred)
(fasl-write s o pred 'omit-rtds))))))) (fasl-write s o pred 'omit-rtds)))))))
(define (compile-to-port* s o unsafe?) (define (compile-to-port* s quoteds o unsafe?)
(call-with-system-wind (lambda () (call-with-system-wind (lambda ()
(parameterize ([fasl-compressed compress-code?] (parameterize ([fasl-compressed compress-code?]
[optimize-level (if unsafe? [optimize-level (if unsafe?
3 3
(optimize-level))]) (optimize-level))])
(call-getting-sfd-paths (call-getting-literals
quoteds
(lambda (pred) (lambda (pred)
(compile-to-port s o #f #f #f (machine-type) #f pred 'omit-rtds))))))) (compile-to-port s o #f #f #f (machine-type) #f pred 'omit-rtds)))))))
(define (expand/optimize* e unsafe?) (define (expand/optimize* e unsafe?)
@ -264,14 +267,18 @@
(optimize-level))]) (optimize-level))])
(#%expand/optimize e))))) (#%expand/optimize e)))))
(define (call-getting-sfd-paths proc) (define (call-getting-literals quoteds proc)
(let ([sfd-paths '()]) ;; `quoteds` is a list of literal values detected by schemify,
;; but we may discover srclocs attached as procedure names
(let ([literals '()])
(proc (lambda (v) (proc (lambda (v)
(and (path? v) (and (or (srcloc? v)
(and quoteds
(hash-ref quoteds v #f)))
(begin (begin
(set! sfd-paths (cons v sfd-paths)) (set! literals (cons v literals))
#t)))) #t))))
(list->vector (reverse sfd-paths)))) (list->vector (reverse literals))))
(define (eval/foreign e mode) (define (eval/foreign e mode)
(performance-region (performance-region
@ -293,66 +300,60 @@
(install-primitives-table! primitives)) (install-primitives-table! primitives))
;; Runs the result of `interpretable-jitified-linklet` ;; Runs the result of `interpretable-jitified-linklet`
(define (run-interpret s paths) (define (run-interpret s)
(interpret-linklet s paths)) (interpret-linklet s))
(define (compile-to-proc s paths format unsafe?) (define (compile-to-proc s format unsafe?)
(if (eq? format 'interpret) (if (eq? format 'interpret)
(run-interpret s paths) (run-interpret s)
(let ([proc (compile* s unsafe?)]) (compile* s unsafe?)))
(if (null? paths)
proc
(#%apply proc paths)))))
;; returns code bytevector and sfd-paths vector ;; returns code bytevector and literals vector
(define (compile*-to-bytevector s unsafe?) (define (compile*-to-bytevector s quoteds unsafe?)
(let-values ([(o get) (open-bytevector-output-port)]) (let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths (compile-to-port* (list `(lambda () ,s)) o unsafe?)]) (let ([literals (compile-to-port* (list s) quoteds o unsafe?)])
(values (get) sfd-paths)))) (values (get) literals))))
;; returns code bytevector and sfd-paths vector ;; returns code bytevector and literals vector
(define (compile-to-bytevector s format unsafe?) (define (compile-to-bytevector s quoteds format unsafe?)
(cond (cond
[(eq? format 'interpret) [(eq? format 'interpret)
(let-values ([(o get) (open-bytevector-output-port)]) (let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths (fasl-write-code* s o)]) (let ([literals (fasl-write-code* s quoteds o)])
(values (get) sfd-paths)))] (values (get) literals)))]
[else (compile*-to-bytevector s unsafe?)])) [else (compile*-to-bytevector s quoteds unsafe?)]))
;; returns code bytevector and sfd-paths vector ;; returns code bytevector and literals vector
(define (cross-compile-to-bytevector machine s format unsafe?) (define (cross-compile-to-bytevector machine s quoteds format unsafe?)
(cond (cond
[(eq? format 'interpret) (cross-fasl-to-string machine s)] [(eq? format 'interpret) (cross-fasl-to-string machine s quoteds)]
[else (cross-compile machine s unsafe?)])) [else (cross-compile machine s quoteds unsafe?)]))
(define (eval-from-bytevector bv paths sfd-paths format) (define (eval-from-bytevector bv literals format)
(add-performance-memory! 'faslin-code (bytevector-length bv)) (add-performance-memory! 'faslin-code (bytevector-length bv))
(cond (cond
[(eq? format 'interpret) [(eq? format 'interpret)
(let ([r (performance-region (let ([r (performance-region
'faslin-code 'faslin-code
(fasl-read (open-bytevector-input-port bv) 'load sfd-paths))]) (fasl-read (open-bytevector-input-port bv) 'load literals))])
(performance-region (run-interpret r))]
'outer
(run-interpret r paths)))]
[else [else
(let ([proc (performance-region (performance-region
'faslin-code 'faslin-code
(code-from-bytevector bv sfd-paths))]) (code-from-bytevector bv literals))]))
(if (null? paths)
proc
(#%apply proc paths)))]))
(define (code-from-bytevector bv sfd-paths) (define (code-from-bytevector bv literals)
(let ([i (open-bytevector-input-port bv)]) (let ([i (open-bytevector-input-port bv)])
(let ([r (load-compiled-from-port i sfd-paths)]) (load-compiled-from-port i literals)))
(performance-region
'outer (define (extract-literals v)
(r))))) (performance-region
'faslin-literals
(force-unfasl-literals v)))
(define-record-type wrapped-code (define-record-type wrapped-code
(fields (mutable content) ; bytevector for 'lambda mode; annotation or (vector hash annotation) for 'jit mode (fields (mutable content) ; bytevector for 'lambda mode; annotation or (vector hash annotation) for 'jit mode
sfd-paths literals
arity-mask arity-mask
name) name)
(nongenerative #{wrapped-code p6o2m72rgmi36pm8vy559b-1})) (nongenerative #{wrapped-code p6o2m72rgmi36pm8vy559b-1}))
@ -365,7 +366,7 @@
'on-demand 'on-demand
(cond (cond
[(bytevector? f) [(bytevector? f)
(let* ([f (code-from-bytevector f (wrapped-code-sfd-paths wc))]) (let* ([f (code-from-bytevector f (wrapped-code-literals wc))])
(wrapped-code-content-set! wc f) (wrapped-code-content-set! wc f)
f)] f)]
[else [else
@ -427,8 +428,7 @@
(define-record-type linklet (define-record-type linklet
(fields (mutable code) ; the procedure or interpretable form (fields (mutable code) ; the procedure or interpretable form
paths ; list of paths and other fasled; if non-empty, `code` expects them as arguments literals ; vector of literals, including paths, that have to be serialized by racket/fasl
sfd-paths ; vector of additional source-location paths intercepted during fasl
format ; 'compile or 'interpret (where the latter may have compiled internal parts) format ; 'compile or 'interpret (where the latter may have compiled internal parts)
(mutable preparation) ; 'faslable, 'faslable-strict, 'faslable-unsafe, 'callable, 'lazy, or (cons 'cross <machine>) (mutable preparation) ; 'faslable, 'faslable-strict, 'faslable-unsafe, 'callable, 'lazy, or (cons 'cross <machine>)
importss-abi ; ABI for each import, in parallel to `importss` importss-abi ; ABI for each import, in parallel to `importss`
@ -440,8 +440,7 @@
(define (set-linklet-code linklet code preparation) (define (set-linklet-code linklet code preparation)
(make-linklet code (make-linklet code
(linklet-paths linklet) (linklet-literals linklet)
(linklet-sfd-paths linklet)
(linklet-format linklet) (linklet-format linklet)
preparation preparation
(linklet-importss-abi linklet) (linklet-importss-abi linklet)
@ -450,10 +449,9 @@
(linklet-importss linklet) (linklet-importss linklet)
(linklet-exports linklet))) (linklet-exports linklet)))
(define (set-linklet-paths linklet paths sfd-paths) (define (set-linklet-literals linklet literals)
(make-linklet (linklet-code linklet) (make-linklet (linklet-code linklet)
paths literals
sfd-paths
(linklet-format linklet) (linklet-format linklet)
(linklet-preparation linklet) (linklet-preparation linklet)
(linklet-importss-abi linklet) (linklet-importss-abi linklet)
@ -464,8 +462,7 @@
(define (set-linklet-preparation linklet preparation) (define (set-linklet-preparation linklet preparation)
(make-linklet (linklet-code linklet) (make-linklet (linklet-code linklet)
(linklet-paths linklet) (linklet-literals linklet)
(linklet-sfd-paths linklet)
(linklet-format linklet) (linklet-format linklet)
preparation preparation
(linklet-importss-abi linklet) (linklet-importss-abi linklet)
@ -509,6 +506,7 @@
(define quick-mode? (or default-compile-quick? (define quick-mode? (or default-compile-quick?
(and (not serializable?) (and (not serializable?)
(#%memq 'quick options)))) (#%memq 'quick options))))
(define serializable?-box (and serializable? (box #f)))
(define sfd-cache (if serializable? (define sfd-cache (if serializable?
;; For determinism: a fresh, non-weak cache per linklet ;; For determinism: a fresh, non-weak cache per linklet
(make-hash) (make-hash)
@ -530,7 +528,7 @@
;; Convert the linklet S-expression to a `lambda` S-expression: ;; Convert the linklet S-expression to a `lambda` S-expression:
(define-values (impl-lam importss exports new-import-keys importss-abi exports-info) (define-values (impl-lam importss exports new-import-keys importss-abi exports-info)
(schemify-linklet (show "linklet" c) (schemify-linklet (show "linklet" c)
serializable? serializable?-box
(not (#%memq 'uninterned-literal options)) (not (#%memq 'uninterned-literal options))
(eq? format 'interpret) (eq? format 'interpret)
(|#%app| compile-allow-set!-undefined) (|#%app| compile-allow-set!-undefined)
@ -583,44 +581,39 @@
'compile-nested 'compile-nested
(let ([expr (show lambda-on? "lambda" (correlated->annotation expr serializable? sfd-cache))]) (let ([expr (show lambda-on? "lambda" (correlated->annotation expr serializable? sfd-cache))])
(if serializable? (if serializable?
(let-values ([(code sfd-paths) (if cross-machine (let ([quoteds (unbox serializable?-box)])
(cross-compile cross-machine expr unsafe?) (let-values ([(code literals) (if cross-machine
(compile*-to-bytevector expr unsafe?))]) (cross-compile cross-machine expr quoteds unsafe?)
(make-wrapped-code code sfd-paths arity-mask (extract-inferred-name expr name))) (compile*-to-bytevector expr quoteds unsafe?))])
(make-wrapped-code code literals arity-mask (extract-inferred-name expr name))))
(compile* expr unsafe?)))))])))])) (compile* expr unsafe?)))))])))]))
(define-values (paths impl-lam/paths)
(if serializable?
(extract-paths-and-fasls-from-schemified-linklet impl-lam/jitified (eq? format 'compile))
(values '() impl-lam/jitified)))
(define impl-lam/interpable (define impl-lam/interpable
(let ([impl-lam (case (and jitify-mode? (let ([impl-lam (case (and jitify-mode?
linklet-compilation-mode) linklet-compilation-mode)
[(mach) (show post-lambda-on? "post-lambda" impl-lam/paths)] [(mach) (show post-lambda-on? "post-lambda" impl-lam/jitified)]
[else (show "schemified" impl-lam/paths)])]) [else (show "schemified" impl-lam/jitified)])])
(if (eq? format 'interpret) (if (eq? format 'interpret)
(interpretable-jitified-linklet impl-lam serializable?) (interpretable-jitified-linklet impl-lam serializable?)
(correlated->annotation impl-lam serializable? sfd-cache)))) (correlated->annotation impl-lam serializable? sfd-cache))))
(when paths-on?
(show "paths" paths))
(when known-on? (when known-on?
(show "known" (hash-map exports-info (lambda (k v) (list k v))))) (show "known" (hash-map exports-info (lambda (k v) (list k v)))))
(when (and cp0-on? (eq? format 'compile)) (when (and cp0-on? (eq? format 'compile))
(show "cp0" (expand/optimize* (correlated->annotation impl-lam/paths) unsafe?))) (show "cp0" (expand/optimize* (correlated->annotation impl-lam/jitified) unsafe?)))
(performance-region (performance-region
'compile-linklet 'compile-linklet
;; Create the linklet: ;; Create the linklet:
(let ([impl (show (and (eq? format 'interpret) post-interp-on?) "post-interp" impl-lam/interpable)]) (let ([impl (show (and (eq? format 'interpret) post-interp-on?) "post-interp" impl-lam/interpable)])
(let-values ([(code sfd-paths) (let-values ([(code literals)
(if serializable? (if serializable?
(if cross-machine (let ([quoteds (unbox serializable?-box)])
(cross-compile-to-bytevector cross-machine impl format unsafe?) (if cross-machine
(compile-to-bytevector impl format unsafe?)) (cross-compile-to-bytevector cross-machine impl quoteds format unsafe?)
(values (compile-to-proc impl paths format unsafe?) '#()))]) (compile-to-bytevector impl quoteds format unsafe?)))
(when paths-on? (values (compile-to-proc impl format unsafe?) '#()))])
(show "source paths" sfd-paths)) (when literals-on?
(show "literals" literals))
(let ([lk (make-linklet code (let ([lk (make-linklet code
paths literals
sfd-paths
format format
(if serializable? (if cross-machine (cons 'cross cross-machine) 'faslable) 'callable) (if serializable? (if cross-machine (cons 'cross cross-machine) 'faslable) 'callable)
importss-abi importss-abi
@ -680,8 +673,7 @@
[(faslable-strict) [(faslable-strict)
(set-linklet-code linklet (set-linklet-code linklet
(eval-from-bytevector (linklet-code linklet) (eval-from-bytevector (linklet-code linklet)
(linklet-paths linklet) (extract-literals (linklet-literals linklet))
(linklet-sfd-paths linklet)
(linklet-format linklet)) (linklet-format linklet))
'callable)] 'callable)]
[(faslable-unsafe) [(faslable-unsafe)
@ -719,8 +711,7 @@
(when (eq? 'lazy (linklet-preparation linklet)) (when (eq? 'lazy (linklet-preparation linklet))
;; Trigger lazy conversion of code from bytevector ;; Trigger lazy conversion of code from bytevector
(let ([code (eval-from-bytevector (linklet-code linklet) (let ([code (eval-from-bytevector (linklet-code linklet)
(linklet-paths linklet) (extract-literals (linklet-literals linklet))
(linklet-sfd-paths linklet)
(linklet-format linklet))]) (linklet-format linklet))])
(with-interrupts-disabled (with-interrupts-disabled
(when (eq? 'lazy (linklet-preparation linklet)) (when (eq? 'lazy (linklet-preparation linklet))
@ -740,8 +731,7 @@
(if (eq? 'callable (linklet-preparation linklet)) (if (eq? 'callable (linklet-preparation linklet))
(linklet-code linklet) (linklet-code linklet)
(eval-from-bytevector (linklet-code linklet) (eval-from-bytevector (linklet-code linklet)
(linklet-paths linklet) (extract-literals (linklet-literals linklet))
(linklet-sfd-paths linklet)
(linklet-format linklet))) (linklet-format linklet)))
(make-variable-reference target-instance #f) (make-variable-reference target-instance #f)
(extract-imported-variabless target-instance (extract-imported-variabless target-instance
@ -771,7 +761,7 @@
(raise-argument-error 'linklet-fasled-code+arguments "linklet?" linklet)) (raise-argument-error 'linklet-fasled-code+arguments "linklet?" linklet))
(case (linklet-preparation linklet) (case (linklet-preparation linklet)
[(faslable faslable-strict faslable-unsafe lazy) [(faslable faslable-strict faslable-unsafe lazy)
(values (linklet-format linklet) (linklet-code linklet) (linklet-sfd-paths linklet) (linklet-paths linklet))] (values (linklet-format linklet) (linklet-code linklet) (extract-literals (linklet-literals linklet)))]
[else (values #f #f #f #f)])) [else (values #f #f #f #f)]))
(define (linklet-interpret-jitified? v) (define (linklet-interpret-jitified? v)

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

@ -75,7 +75,14 @@
(hash-ref sfd-cache src #f)) (hash-ref sfd-cache src #f))
;; We'll use a file-position object in source objects, so ;; We'll use a file-position object in source objects, so
;; the sfd checksum doesn't matter ;; the sfd checksum doesn't matter
(let ([sfd (source-file-descriptor src 0)]) (let ([sfd (source-file-descriptor
;; Wrap path as a srcloc so that absolute paths are just
;; dropped when serializing the path (while paths relative
;; to the containing source can be preserved):
(if (path? src)
(srcloc src #f #f #f #f)
src)
0)])
(with-interrupts-disabled (with-interrupts-disabled
(hash-set! sfd-cache src sfd)) (hash-set! sfd-cache src sfd))
sfd))) sfd)))

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

@ -52,22 +52,23 @@
(unsafe-place-local-set! cross-machine-compiler-cache (unsafe-place-local-set! cross-machine-compiler-cache
(cons a (unsafe-place-local-ref cross-machine-compiler-cache))))) (cons a (unsafe-place-local-ref cross-machine-compiler-cache)))))
(define (do-cross cmd machine v) (define (do-cross cmd machine v quoteds)
(let* ([a (find-cross 'cross-compile machine)] (let* ([a (find-cross 'cross-compile machine)]
[ch (cadr a)] [ch (cadr a)]
[reply-ch (make-channel)]) [reply-ch (make-channel)])
(channel-put ch (list cmd (channel-put ch (list cmd
v v
quoteds
reply-ch)) reply-ch))
(let ([bv+paths (channel-get reply-ch)]) (let ([bv+literals (channel-get reply-ch)])
(cache-cross-compiler a) (cache-cross-compiler a)
(values (car bv+paths) (cdr bv+paths))))) (values (car bv+literals) (cdr bv+literals)))))
(define (cross-compile machine v unsafe?) (define (cross-compile machine v quoteds unsafe?)
(do-cross (if unsafe? 'u 'c) machine v)) (do-cross (if unsafe? 'u 'c) machine v quoteds))
(define (cross-fasl-to-string machine v) (define (cross-fasl-to-string machine v quoteds)
(do-cross 'f machine v)) (do-cross 'f machine v quoteds))
;; Start a compiler as a Racket thread under the root custodian. ;; Start a compiler as a Racket thread under the root custodian.
;; Using Racket's scheduler lets us use the event and I/O system, ;; Using Racket's scheduler lets us use the event and I/O system,
@ -114,33 +115,47 @@
(let ([msg (channel-get msg-ch)]) (let ([msg (channel-get msg-ch)])
;; msg is (list <command> <value> <reply-channel>) ;; msg is (list <command> <value> <reply-channel>)
(write-string (#%format "~a\n" (car msg)) to) (write-string (#%format "~a\n" (car msg)) to)
(let-values ([(bv sfd-paths) (fasl-to-bytevector (cadr msg))]) (let-values ([(bv literals) (fasl-to-bytevector (cadr msg) (caddr msg))])
;; We can't send paths to the cross compiler, but we can tell it ;; We can't send all literals to the cross compiler, but we can send
;; how many paths there were, and the cross compiler can report ;; strings and byte stringa, which might affect compilation. Otherwise,
;; which of those remain used in the compiled form ;; we report the existence of other literals, and the cross compiler can
(write-bytes (integer->integer-bytes (bytevector-length bv) 8 #f #f) to) ;; report which of those remain used in the compiled form.
(write-bytes bv to) (let-values ([(literals-bv ignored) (fasl-to-bytevector (strip-opaque literals) #f)])
(write-bytes (integer->integer-bytes (vector-length sfd-paths) 8 #f #f) to) (write-bytes (integer->integer-bytes (bytevector-length bv) 8 #f #f) to)
(flush-output to) (write-bytes bv to)
(write-bytes (integer->integer-bytes (bytevector-length literals-bv) 8 #f #f) to)
(write-bytes literals-bv to)
(flush-output to))
(let* ([read-num (lambda () (let* ([read-num (lambda ()
(integer-bytes->integer (read-bytes 8 from) #f #f))] (integer-bytes->integer (read-bytes 8 from) #f #f))]
[len (read-num)] [len (read-num)]
[bv (read-bytes len from)] [bv (read-bytes len from)]
[kept-sfd-paths-count (read-num)] ; number of used-path indices [kept-literals-count (read-num)] ; number of used-literal indices
[kept-sfd-paths (list->vector [kept-literals (list->vector
(let loop ([i 0]) (let loop ([i 0])
(if (fx= i kept-sfd-paths-count) (if (fx= i kept-literals-count)
'() '()
(cons (vector-ref sfd-paths (read-num)) (cons (vector-ref literals (read-num))
(loop (fx+ i 1))))))]) (loop (fx+ i 1))))))])
(channel-put (caddr msg) (cons bv kept-sfd-paths)))) (channel-put (cadddr msg) (cons bv kept-literals))))
(loop))))))) (loop)))))))
(list machine msg-ch)))) (list machine msg-ch))))
(define (fasl-to-bytevector v) (define (fasl-to-bytevector v quoteds)
(let-values ([(o get) (open-bytevector-output-port)]) (let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths (fasl-write/paths* v o)]) (let ([literals (fasl-write/literals* v quoteds o)])
(values (get) sfd-paths)))) (values (get) literals))))
(define (strip-opaque vec)
(let ([vec2 (make-vector (vector-length vec) #f)])
(let loop ([i 0])
(unless (fx= i (vector-length vec))
(let ([e (vector-ref vec i)])
(when (or (string? e)
(bytevector? e))
(vector-set! vec2 i e)))
(loop (fx+ i 1))))
vec2))
(define (find-exe exe) (define (find-exe exe)
(let-values ([(base name dir?) (split-path exe)]) (let-values ([(base name dir?) (split-path exe)])

4
racket/src/cs/linklet/performance.ss
View File

@ -106,9 +106,9 @@
[name-len (apply max (hash-table-map region-times (lambda (k v) (string-length (symbol->string k)))))] [name-len (apply max (hash-table-map region-times (lambda (k v) (string-length (symbol->string k)))))]
[len (string-length (number->string total))] [len (string-length (number->string total))]
[gc-len (string-length (number->string gc-total))] [gc-len (string-length (number->string gc-total))]
[categories '((read (read-bundle faslin-code)) [categories '((read (read-bundle faslin-code faslin-literals))
(comp-ffi (comp-ffi-call comp-ffi-back)) (comp-ffi (comp-ffi-call comp-ffi-back))
(run (instantiate outer)) (run (instantiate))
(compile (compile-linklet compile-nested)) (compile (compile-linklet compile-nested))
(compile-pass (regalloc other)))] (compile-pass (regalloc other)))]
[region-subs (make-eq-hashtable)] [region-subs (make-eq-hashtable)]

20
racket/src/cs/linklet/read.ss
View File

@ -4,7 +4,7 @@
'read-linklet 'read-linklet
(let* ([len (integer-bytes->integer (read-bytes 4 in) #f #f)] (let* ([len (integer-bytes->integer (read-bytes 4 in) #f #f)]
[bstr (read-bytes len in)]) [bstr (read-bytes len in)])
(adjust-linklet-bundle-laziness-and-paths (adjust-linklet-bundle-laziness-and-literals
(fasl-read (open-bytevector-input-port bstr)))))) (fasl-read (open-bytevector-input-port bstr))))))
(define read-on-demand-source (define read-on-demand-source
@ -18,7 +18,7 @@
v) v)
'read-on-demand-source)) 'read-on-demand-source))
(define (adjust-linklet-bundle-laziness-and-paths ls) (define (adjust-linklet-bundle-laziness-and-literals ls)
(let loop ([ls ls] [ht (hasheq)]) (let loop ([ls ls] [ht (hasheq)])
(cond (cond
[(null? ls) ht] [(null? ls) ht]
@ -30,7 +30,7 @@
key key
(if (linklet? val) (if (linklet? val)
(adjust-linklet-laziness (adjust-linklet-laziness
(decode-linklet-paths val)) (decode-linklet-literals val))
val))))]))) val))))])))
(define (adjust-linklet-laziness linklet) (define (adjust-linklet-laziness linklet)
@ -50,14 +50,10 @@
[else [else
'faslable-strict]))) 'faslable-strict])))
(define (decode-linklet-paths linklet) (define (decode-linklet-literals linklet)
(let ([paths (linklet-paths linklet)] (let ([literals (linklet-literals linklet)])
[sfd-paths (linklet-sfd-paths linklet)])
(cond (cond
[(and (null? paths) [(vector? literals) linklet]
(fxzero? (#%vector-length sfd-paths)))
linklet]
[else [else
(set-linklet-paths linklet (set-linklet-literals linklet
(#%map compiled-path->path paths) (unfasl-literals/lazy literals))])))
(#%vector-map compiled-path->path sfd-paths))])))

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

@ -4,10 +4,11 @@
#vu8(99 104 101 122 45 115 99 104 101 109 101)) #vu8(99 104 101 122 45 115 99 104 101 109 101))
(define (write-linklet-bundle-hash ht dest-o) (define (write-linklet-bundle-hash ht dest-o)
(let-values ([(ls cross-machine) (encode-linklet-paths ht)]) (let-values ([(ls cross-machine) (encode-linklet-literals ht)])
(let ([bstr (if cross-machine (let ([bstr (if cross-machine
(let-values ([(bstr sfd-paths) (cross-fasl-to-string cross-machine ls)]) (let-values ([(bstr literals) (cross-fasl-to-string cross-machine ls #f)])
;; sfd-paths should be empty (unless (equal? literals '#())
(#%error 'write-linklet "cross fasl produced additional literals"))
bstr) bstr)
(let-values ([(o get) (open-bytevector-output-port)]) (let-values ([(o get) (open-bytevector-output-port)])
(fasl-write* ls o) (fasl-write* ls o)
@ -15,37 +16,35 @@
(write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) dest-o) (write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) dest-o)
(write-bytes bstr dest-o)))) (write-bytes bstr dest-o))))
(define (encode-linklet-paths orig-ht) (define (encode-linklet-literals orig-ht)
(let ([path->compiled-path (make-path->compiled-path 'write-linklet)]) (let loop ([i (hash-iterate-first orig-ht)] [accum '()] [cross-machine #f])
(let loop ([i (hash-iterate-first orig-ht)] [accum '()] [cross-machine #f]) (cond
(cond [(not i) (values accum cross-machine)]
[(not i) (values accum cross-machine)] [else
[else (let-values ([(key v) (hash-iterate-key+value orig-ht i)])
(let-values ([(key v) (hash-iterate-key+value orig-ht i)]) (when (linklet? v) (check-fasl-preparation v))
(when (linklet? v) (check-fasl-preparation v)) (let ([new-v (cond
(let ([new-v (cond
[(linklet? v) [(linklet? v)
(cond (adjust-cross-perparation
[(or (pair? (linklet-paths v)) (let ([literals (linklet-literals v)])
(fxpositive? (#%vector-length (linklet-sfd-paths v)))) (cond
(adjust-cross-perparation [(and (#%vector? literals)
(set-linklet-paths (fx= 0 (#%vector-length literals)))
v v]
(#%map path->compiled-path [else
(linklet-paths v)) (set-linklet-literals
(#%vector-map (lambda (p) (path->compiled-path p #t)) v
(linklet-sfd-paths v))))] (fasl-literals (extract-literals literals) uninterned-symbol?))])))]
[else (adjust-cross-perparation v)])]
[else v])]) [else v])])
(when (linklet? new-v) (when (linklet? new-v)
(linklet-pack-exports-info! new-v)) (linklet-pack-exports-info! new-v))
(let ([accum (cons* key new-v accum)]) (let ([accum (cons* key new-v accum)])
(loop (hash-iterate-next orig-ht i) (loop (hash-iterate-next orig-ht i)
accum accum
(or cross-machine (or cross-machine
(and (linklet? v) (and (linklet? v)
(let ([prep (linklet-preparation v)]) (let ([prep (linklet-preparation v)])
(and (pair? prep) (cdr prep)))))))))])))) (and (pair? prep) (cdr prep)))))))))])))
;; Before fasl conversion, change 'cross or 'faslable-unsafe to 'faslable ;; Before fasl conversion, change 'cross or 'faslable-unsafe to 'faslable
(define (adjust-cross-perparation l) (define (adjust-cross-perparation l)

2
racket/src/cs/primitive/internal.ss
View File

@ -34,8 +34,6 @@
[make-pthread-parameter (known-procedure 2)] [make-pthread-parameter (known-procedure 2)]
[engine-block (known-procedure 1)] [engine-block (known-procedure 1)]
[force-unfasl (known-procedure 2)]
[ptr-ref/int8 (known-procedure 8)] [ptr-ref/int8 (known-procedure 8)]
[ptr-ref/uint8 (known-procedure 8)] [ptr-ref/uint8 (known-procedure 8)]
[ptr-ref/int16 (known-procedure 8)] [ptr-ref/int16 (known-procedure 8)]

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

@ -548,8 +548,8 @@
[make-will-executor (known-procedure/pure 1)] [make-will-executor (known-procedure/pure 1)]
[map (known-procedure -4)] [map (known-procedure -4)]
[max (known-procedure/folding -2)] [max (known-procedure/folding -2)]
[mcar (known-procedure/no-prompt 2)] [mcar (known-procedure/has-unsafe 2 'unsafe-mcar)]
[mcdr (known-procedure/no-prompt 2)] [mcdr (known-procedure/has-unsafe 2 'unsafe-mcdr)]
[mcons (known-procedure/pure 4)] [mcons (known-procedure/pure 4)]
[memory-order-acquire (known-procedure 1)] [memory-order-acquire (known-procedure 1)]
[memory-order-release (known-procedure 1)] [memory-order-release (known-procedure 1)]
@ -760,8 +760,8 @@
[semaphore? (known-procedure/pure/folding 2)] [semaphore? (known-procedure/pure/folding 2)]
[set-box! (known-procedure 4)] [set-box! (known-procedure 4)]
[set-box*! (known-procedure/has-unsafe 4 'unsafe-set-box*!)] [set-box*! (known-procedure/has-unsafe 4 'unsafe-set-box*!)]
[set-mcar! (known-procedure/no-prompt 4)] [set-mcar! (known-procedure/has-unsafe 4 'unsafe-set-mcar!)]
[set-mcdr! (known-procedure/no-prompt 4)] [set-mcdr! (known-procedure/has-unsafe 4 'unsafe-set-mcdr!)]
[set-phantom-bytes! (known-procedure/no-prompt 4)] [set-phantom-bytes! (known-procedure/no-prompt 4)]
[set-port-next-location! (known-procedure 16)] [set-port-next-location! (known-procedure 16)]
[sha1-bytes (known-procedure 14)] [sha1-bytes (known-procedure 14)]

7
racket/src/cs/rumble/error.ss
View File

@ -668,7 +668,12 @@
[loc (and (cdr p) [loc (and (cdr p)
(call-with-values (lambda () (call-with-values (lambda ()
(let* ([src (cdr p)] (let* ([src (cdr p)]
[path (source-file-descriptor-path (source-object-sfd src))]) [path (source-file-descriptor-path (source-object-sfd src))]
[path (if (srcloc? path)
;; The linklet layer wraps paths in `srcloc` to trigger specific
;; marshaling behavior
(srcloc-source path)
path)])
(if (source-object-line src) (if (source-object-line src)
(values path (values path
(source-object-line src) (source-object-line src)

7
racket/src/cs/rumble/unsafe.ss
View File

@ -206,6 +206,13 @@
(#%$string-set-immutable! s) (#%$string-set-immutable! s)
s])) s]))
(define (unsafe-vector*->immutable-vector! v) (define (unsafe-vector*->immutable-vector! v)
(vector->immutable-vector v)
;; The implementation below is not right, because the vector
;; may contain elements allocated after the vector itself, and
;; wrong-way pointers are not supposed to show up in mutable
;; vectors. Maybe the GC should treat immutable vectors like
;; mutable ones, and then morphing to immutable would be ok.
#;
(cond (cond
[(= (vector-length v) 0) (immutable-constant #())] [(= (vector-length v) 0) (immutable-constant #())]
[else [else

907
racket/src/cs/schemified/expander.scm
View File

File diff suppressed because it is too large Load Diff

25
racket/src/cs/schemified/io.scm
View File

@ -21691,13 +21691,13 @@
(if (mpair? v_0) (if (mpair? v_0)
(if (not print-graph?_0) (if (not print-graph?_0)
(if (not (eq? mode_0 0)) (if (not (eq? mode_0 0))
(let ((app_0 (mcdr v_0))) (let ((app_0 (unsafe-mcdr v_0)))
(quick-no-graph?_0 (quick-no-graph?_0
config_0 config_0
mode_0 mode_0
print-graph?_0 print-graph?_0
app_0 app_0
(let ((app_1 (mcar v_0))) (let ((app_1 (unsafe-mcar v_0)))
(quick-no-graph?_0 (quick-no-graph?_0
config_0 config_0
mode_0 mode_0
@ -22005,7 +22005,7 @@
counter_0 counter_0
cycle?_0 cycle?_0
ht_0 ht_0
(mcar v_0) (unsafe-mcar v_0)
mode_0) mode_0)
(build-graph_0 (build-graph_0
checking-port_0 checking-port_0
@ -22014,7 +22014,7 @@
counter_0 counter_0
cycle?_0 cycle?_0
ht_0 ht_0
(mcdr v_0) (unsafe-mcdr v_0)
mode_0) mode_0)
(done!_0 (done!_0
constructor?_0 constructor?_0
@ -22547,12 +22547,12 @@
(begin (begin
(if (eq? max-length_2 'full) (if (eq? max-length_2 'full)
'full 'full
(if (if (null? (mcdr v_1)) (not unquoted?_0) #f) (if (if (null? (unsafe-mcdr v_1)) (not unquoted?_0) #f)
(let ((max-length_3 (let ((max-length_3
(|#%app| (|#%app|
p_0 p_0
who_0 who_0
(mcar v_1) (unsafe-mcar v_1)
mode_0 mode_0
o_0 o_0
max-length_2 max-length_2
@ -22562,11 +22562,12 @@
(if curly?_0 "}" ")") (if curly?_0 "}" ")")
o_0 o_0
max-length_3)) max-length_3))
(if (if (mpair? (mcdr v_1)) (if (if (mpair? (unsafe-mcdr v_1))
(if (let ((or-part_0 (not graph_0))) (if (let ((or-part_0 (not graph_0)))
(if or-part_0 (if or-part_0
or-part_0 or-part_0
(not (hash-ref graph_0 (mcdr v_1) #f)))) (not
(hash-ref graph_0 (unsafe-mcdr v_1) #f))))
(not unquoted?_0) (not unquoted?_0)
#f) #f)
#f) #f)
@ -22574,13 +22575,13 @@
(|#%app| (|#%app|
p_0 p_0
who_0 who_0
(mcar v_1) (unsafe-mcar v_1)
mode_0 mode_0
o_0 o_0
max-length_2 max-length_2
graph_0 graph_0
config_0))) config_0)))
(let ((app_0 (mcdr v_1))) (let ((app_0 (unsafe-mcdr v_1)))
(loop_0 (loop_0
app_0 app_0
(write-string/max " " o_0 max-length_3)))) (write-string/max " " o_0 max-length_3))))
@ -22588,7 +22589,7 @@
(|#%app| (|#%app|
p_0 p_0
who_0 who_0
(mcar v_1) (unsafe-mcar v_1)
mode_0 mode_0
o_0 o_0
max-length_2 max-length_2
@ -22602,7 +22603,7 @@
(|#%app| (|#%app|
p_0 p_0
who_0 who_0
(mcdr v_1) (unsafe-mcdr v_1)
mode_0 mode_0
o_0 o_0
max-length_4 max-length_4

6255
racket/src/cs/schemified/schemify.scm
View File

File diff suppressed because it is too large Load Diff

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

@ -3,14 +3,14 @@
lift-in-schemified-linklet lift-in-schemified-linklet
jitify-schemified-linklet jitify-schemified-linklet
xify xify
extract-paths-and-fasls-from-schemified-linklet
interpreter-link! interpreter-link!
interpretable-jitified-linklet interpretable-jitified-linklet
interpret-linklet interpret-linklet
linklet-bigger-than? linklet-bigger-than?
make-path->compiled-path fasl-literal?
compiled-path->path fasl-literals
(rename [1/force-unfasl force-unfasl]) unfasl-literals/lazy
force-unfasl-literals
prim-knowns prim-knowns
known-procedure known-procedure
known-procedure/pure known-procedure/pure

1
racket/src/expander/compile/built-in-symbol.rkt
View File

@ -76,7 +76,6 @@
call-with-module-prompt call-with-module-prompt
make-pthread-parameter make-pthread-parameter
engine-block engine-block
force-unfasl
make-record-type-descriptor make-record-type-descriptor
make-record-type-descriptor* make-record-type-descriptor*
make-record-constructor-descriptor make-record-constructor-descriptor

95
racket/src/schemify/fasl-literal.rkt Normal file
View File

@ -0,0 +1,95 @@
#lang racket/base
(require racket/fasl
racket/unsafe/undefined
racket/extflonum)
(provide fasl-literal?
fasl-literals
unfasl-literals/lazy
force-unfasl-literals)
(define (fasl-literal? q need-exposed?)
(cond
[(impersonator? q) #t] ; i.e., strip impersonators when serializaing
[(path? q) #t]
[(regexp? q) #t]
[(srcloc? q) #t]
[(byte-regexp? q) #t]
[(keyword? q) #t]
[(hash? q) #t]
[(string? q) #t] ; to intern
[(bytes? q) #t] ; to intern
[(prefab-struct-key q) #t] ; to intern
[(need-exposed? q) #t] ; to expose to full linklet directory
;; No case for numbers, because they are historically not interned
;; on bytecode read, but extflonums are special
[(extflonum? q) #t]
;; Assume that anything else can be handled; rejecting
;; non-serializable values is someone else's problem
[else #f]))
(struct to-unfasl (bstr externals wrt))
(define (empty-literals? v)
(and (vector? v)
(eqv? 0 (vector-length v))))
(define (fasl-literals v need-exposed?)
(cond
[(empty-literals? v) v]
[else
(define exposed '())
(define bstr (s-exp->fasl v
#:skip-prefix? #t
#:handle-fail cannot-fasl
;; We have to keep uninterned symbols exposed, so they're
;; fasled with the encloding linklet directory
#:external-lift? (lambda (v)
(and (need-exposed? v)
(begin
(set! exposed (cons v exposed))
#t)))))
(if (null? exposed)
bstr
(cons bstr (list->vector (reverse exposed))))]))
(define (unfasl-literals/lazy v)
(cond
[(empty-literals? v) v]
[else
(box (to-unfasl (if (pair? v) (car v) v)
(if (pair? v) (cdr v) '#())
(current-load-relative-directory)))]))
(define (force-unfasl-literals b)
(cond
[(box? b)
(define v (unbox b))
(cond
[(to-unfasl? v)
(define new-v
(parameterize ([current-load-relative-directory (to-unfasl-wrt v)])
(fasl->s-exp (to-unfasl-bstr v)
#:datum-intern? #t
#:skip-prefix? #t
#:external-lifts (to-unfasl-externals v))))
(let loop ()
(cond
[(box-cas! b v new-v)
new-v]
[else
(let ([v (unbox b)])
(cond
[(to-unfasl? v)
;; must be a spurious CAS failure
(loop)]
[else
;; other thread beat us to it
v]))]))]
[else v])]
[else b]))
(define (cannot-fasl v)
(error 'write
"cannot marshal value that is embedded in compiled code\n value: ~v"
v))

82
racket/src/schemify/interpret.rkt
View File

@ -4,8 +4,6 @@
racket/symbol racket/symbol
"match.rkt" "match.rkt"
"wrap.rkt" "wrap.rkt"
"path-for-srcloc.rkt"
"to-fasl.rkt"
"interp-match.rkt" "interp-match.rkt"
"interp-stack.rkt" "interp-stack.rkt"
"gensym.rkt") "gensym.rkt")
@ -56,8 +54,7 @@
(set! make-interp-procedure* make-proc)) (set! make-interp-procedure* make-proc))
(define (interpretable-jitified-linklet linklet-e serializable?) (define (interpretable-jitified-linklet linklet-e serializable?)
;; Return a compiled linklet in two parts: a vector expression for ;; Return a compiled linklet as an expression for the linklet body.
;; constants to be run once, and a expression for the linklet body.
;; Conceptually, the run-time environment is implemented as a list, ;; Conceptually, the run-time environment is implemented as a list,
;; and identifiers are mapped to positions in that list, where 0 ;; and identifiers are mapped to positions in that list, where 0
@ -83,41 +80,10 @@
;; the list, for example. ;; the list, for example.
(define (start linklet-e) (define (start linklet-e)
(match linklet-e (define-values (compiled-body num-body-vars)
[`(lambda . ,_) (compile-linklet-body linklet-e '#hasheq() 0))
;; No constants: (vector num-body-vars
(define-values (compiled-body num-body-vars) compiled-body))
(compile-linklet-body linklet-e '#hasheq() 0))
(vector #f
num-body-vars
compiled-body)]
[`(let* ,bindings ,body)
(define bindings-stk-i (make-stack-info))
(let loop ([bindings bindings] [elem 0] [env '#hasheq()] [accum '()])
(cond
[(null? bindings)
(define-values (compiled-body num-body-vars)
(compile-linklet-body body env 1))
(vector (list->vector (reverse accum))
num-body-vars
compiled-body)]
[else
(let ([binding (car bindings)])
(loop (cdr bindings)
(fx+ elem 1)
(hash-set env (car binding) (indirect 0 elem))
(let ([rhs (cadr binding)])
(cons (cond
[(or (path? rhs)
(path-for-srcloc? rhs)
(to-fasl? rhs))
;; The caller must extract all the paths from the bindings
;; and pass them back in at interp time; assume '#%path is
;; not a primitive
'#%path]
[else
(compile-expr rhs env 1 bindings-stk-i #t '#hasheq())])
accum))))]))]))
(define (compile-linklet-body v env stack-depth) (define (compile-linklet-body v env stack-depth)
(match v (match v
@ -627,35 +593,19 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (interpret-linklet b ; compiled form (define (interpret-linklet b)
paths) ; unmarshaled paths
(interp-match (interp-match
b b
[#(,consts ,num-body-vars ,b) [#(,num-body-vars ,b)
(let ([consts (and consts (lambda args
(let ([vec (make-vector (vector*-length consts))]) (define start-stack empty-stack)
(define stack (stack-set empty-stack 0 vec)) (define args-stack (for/fold ([stack start-stack]) ([arg (in-list args)]
(for/fold ([paths paths]) ([b (in-vector consts)] [i (in-naturals 0)])
[i (in-naturals)]) (stack-set stack i arg)))
(cond (define post-args-pos (stack-count args-stack))
[(eq? b '#%path) (define stack (for/fold ([stack args-stack]) ([i (in-range num-body-vars)])
(vector-set! vec i (car paths)) (stack-set stack (+ i post-args-pos) (box unsafe-undefined))))
(cdr paths)] (interpret-expr b stack))]))
[else
(vector-set! vec i (interpret-expr b stack))
paths]))
vec))])
(lambda args
(define start-stack (if consts
(stack-set empty-stack 0 consts)
empty-stack))
(define args-stack (for/fold ([stack start-stack]) ([arg (in-list args)]
[i (in-naturals (if consts 1 0))])
(stack-set stack i arg)))
(define post-args-pos (stack-count args-stack))
(define stack (for/fold ([stack args-stack]) ([i (in-range num-body-vars)])
(stack-set stack (+ i post-args-pos) (box unsafe-undefined))))
(interpret-expr b stack)))]))
(define (interpret-expr b stack) (define (interpret-expr b stack)

71
racket/src/schemify/literal.rkt
View File

@ -1,9 +1,12 @@
#lang racket/base #lang racket/base
(require "wrap.rkt") (require racket/unsafe/undefined
racket/extflonum
"wrap.rkt")
(provide literal? (provide literal?
unwrap-literal unwrap-literal
wrap-literal) wrap-literal
register-literal-serialization)
(define (literal? v) (define (literal? v)
(define u (unwrap v)) (define u (unwrap v))
@ -47,3 +50,67 @@
[(eof-object? x) 'eof] [(eof-object? x) 'eof]
[else [else
`(quote ,x)])) `(quote ,x)]))
(define (register-literal-serialization q serializable?-box datum-intern?)
(let check-register ([q q] [seen #hasheq()])
(define-syntax-rule (check-cycle new-seen e0 e ...)
(cond
[(hash-ref seen q #f)
(raise-arguments-error 'compile "cannot compile cyclic value"
"value" q)]
[else
(let ([new-seen (hash-set seen q #t)])
e0 e ...)]))
(define (register! q)
(unless (unbox serializable?-box)
(set-box! serializable?-box (make-hasheq)))
(hash-set! (unbox serializable?-box) q #t))
(cond
[(symbol? q)
;; gensyms need to be exposed to the whole linklet directory:
(unless (or (symbol-interned? q)
(symbol-unreadable? q))
(register! q))]
[(or (null? q)
(number? q)
(char? q)
(boolean? q)
(eof-object? q)
(void? q)
(eq? q unsafe-undefined))
(void)]
[(or (string? q)
(bytes? q))
(when datum-intern?
(register! q))]
[(pair? q)
(check-cycle
seen
(check-register (car q) seen)
(check-register (cdr q) seen))]
[(vector? q)
(check-cycle
seen
(for ([e (in-vector q)])
(check-register e seen)))]
[(hash? q)
(register! q)
(check-cycle
seen
(for ([(k v) (in-hash q)])
(check-register k seen)
(check-register v seen)))]
[(box? q)
(check-cycle
seen
(check-register (unbox q) seen))]
[(srcloc? q)
(register! q)
(srcloc-source q)]
[(prefab-struct-key q)
(register! q)
(check-cycle
seen
(check-register (struct->vector q) seen))]
[else
(register! q)])))

9
racket/src/schemify/main.rkt
View File

@ -4,7 +4,7 @@
"lift.rkt" "lift.rkt"
"jitify.rkt" "jitify.rkt"
"xify.rkt" "xify.rkt"
"path-and-fasl.rkt" "fasl-literal.rkt"
"interpret.rkt" "interpret.rkt"
"size.rkt" "size.rkt"
"fasl.rkt") "fasl.rkt")
@ -21,9 +21,10 @@
xify xify
extract-paths-and-fasls-from-schemified-linklet fasl-literal?
make-path->compiled-path fasl-literals
compiled-path->path unfasl-literals/lazy
force-unfasl-literals
interpreter-link! interpreter-link!
interpretable-jitified-linklet interpretable-jitified-linklet

163
racket/src/schemify/path-and-fasl.rkt
View File

@ -1,163 +0,0 @@
#lang racket/base
(require racket/private/relative-path
racket/private/truncate-path
racket/fasl
"match.rkt"
"path-for-srcloc.rkt"
"to-fasl.rkt")
(provide extract-paths-and-fasls-from-schemified-linklet
make-path->compiled-path
compiled-path->path
force-unfasl)
;; Recognize lifted paths and `to-fasl`s in a schemified linklet, and
;; return the list of path and `to-fasl` values. If `convert?`, then
;; change the schemified linklet to expect the paths as arguments.
;;
;; In addition to paths, this extraction deals with values that have
;; been packages as `to-fasl`, either because they are large values
;; that are best handled in fasl form, because they are not
;; serializable (and we want to delay complaining in case no
;; serialization is needed), or because they are uninterned symbols
;; that need to be exposed to the Scheme-level `fasl` for a full
;; linklet.
(define (extract-paths-and-fasls-from-schemified-linklet linklet-e convert?)
(match linklet-e
[`(lambda . ,_)
;; No constants, so no paths:
(values '() linklet-e)]
[`(let* ,bindings ,body)
(define (path-binding? b)
(define rhs (cadr b))
(or (path? rhs)
(path-for-srcloc? rhs)
(to-fasl? rhs)))
(define any-path?
(for/or ([b (in-list bindings)])
(path-binding? b)))
(cond
[any-path?
(define paths (for/list ([b (in-list bindings)]
#:when (path-binding? b))
(cadr b)))
(cond
[convert?
(define path-ids (for/list ([b (in-list bindings)]
#:when (path-binding? b))
(car b)))
(define other-bindings (for/list ([b (in-list bindings)]
#:unless (path-binding? b))
b))
(values paths
`(lambda ,path-ids
(let* ,other-bindings ,body)))]
[else
(values paths linklet-e)])]
[else
(values '() linklet-e)])]))
(define (make-path->compiled-path who)
(define path->relative-path-elements (make-path->relative-path-elements #:who who))
(lambda (orig-p [for-srcloc? #f])
(cond
[(to-fasl? orig-p)
(define v (force-unfasl orig-p))
(cond
[(symbol? v)
;; Shortcut for just an uninterned symbol:
(box v)]
[else
(define lifts '())
(define bstr (s-exp->fasl v
#:handle-fail cannot-fasl
;; We have to keep uninterned symbols exposed, so they're
;; fasled with the encloding linklet directory
#:external-lift? (lambda (v)
(and (symbol? v)
(not (symbol-interned? v))
(not (symbol-unreadable? v))
(begin
(set! lifts (cons v lifts))
#t)))))
(if (null? lifts)
(box bstr)
(box (cons bstr (list->vector (reverse lifts)))))])]
[(symbol? orig-p)
;; Must be an uninterned symbol:
orig-p]
[else
(define p (if (path-for-srcloc? orig-p)
(path-for-srcloc-path orig-p)
orig-p))
(cond
[(path? p)
(or (path->relative-path-elements p)
(cond
[(or for-srcloc?
(path-for-srcloc? orig-p))
;; Can't make relative, so create a string that keeps up
;; to two path elements
(truncate-path p)]
[else (path->bytes p)]))]
[(or (string? p) (bytes? p) (symbol? p) (not p))
;; Allowed in compiled form
p]
[else
(error 'write
"cannot marshal value that is embedded in compiled code: ~V"
p)])])))
(define (compiled-path->path e)
(cond
[(box? e)
(define c (unbox e))
(to-fasl (box (if (pair? c) (car c) c))
(if (pair? c) (cdr c) '#())
(and (not (symbol? c))
(or (current-load-relative-directory)
(current-directory))))]
[(symbol? e)
;; Must be an uninterned symbol:
e]
[(bytes? e) (bytes->path e)]
[(string? e) e] ; was `path-for-srcloc` on write
[else (relative-path-elements->path e)]))
(define (force-unfasl tf)
(cond
[(not (to-fasl? tf))
;; act as identity on other values for the benefit of `raco decompile`
tf]
[else
(define vb (to-fasl-vb tf))
(define v (unbox vb))
(cond
[(bytes? v)
(define v2 (parameterize ([current-load-relative-directory (to-fasl-wrt tf)])
(fasl->s-exp v
#:datum-intern? #t
#:external-lifts (to-fasl-lifts tf))))
(let loop ()
(cond
[(box-cas! vb v v2)
(set-to-fasl-wrt! tf #f)
v2]
[else
(let ([v (unbox vb)])
(cond
[(bytes? v)
;; must be a spurious CAS failure
(loop)]
[else
;; other thread beat us to it
v]))]))]
[else
;; already forced (or never fasled)
v])]))
(define (cannot-fasl v)
(error 'write
"cannot marshal value that is embedded in compiled code\n value: ~v"
v))

5
racket/src/schemify/path-for-srcloc.rkt
View File

@ -1,5 +0,0 @@
#lang racket/base
(provide (struct-out path-for-srcloc))
(struct path-for-srcloc (path))

63
racket/src/schemify/quoted.rkt
View File

@ -1,63 +0,0 @@
#lang racket/base
(require racket/extflonum
racket/fixnum
racket/unsafe/undefined)
(provide lift-quoted?
large-quoted?)
;; Check whether a quoted value needs to be lifted to run-time construction
(define (lift-quoted? q for-cify? datum-intern?)
(let lift-quoted? ([q q])
(cond
[for-cify?
(not (or (and (exact-integer? q)
;; always a fixnum:
(<= (- (expt 2 29)) q (sub1 (expt 2 29))))
(boolean? q)
(null? q)
(void? q)))]
[(impersonator? q) #t] ; i.e., strip impersonators when serializaing
[(path? q) #t]
[(regexp? q) #t]
[(srcloc? q) #t]
[(byte-regexp? q) #t]
[(keyword? q) #t]
[(hash? q) #t]
[(string? q) datum-intern?]
[(bytes? q) datum-intern?]
[(pair? q) (or (lift-quoted? (car q))
(lift-quoted? (cdr q)))]
[(vector? q) (for/or ([e (in-vector q)])
(lift-quoted? e))]
[(box? q) (lift-quoted? (unbox q))]
[(prefab-struct-key q) #t]
[(extflonum? q) #t]
[(or (null? q)
(number? q)
(char? q)
(boolean? q)
(and (symbol? q)
;; lift out gensym for sharing across phases
(or (symbol-interned? q)
(symbol-unreadable? q)))
(eof-object? q)
(void? q)
(eq? q unsafe-undefined))
#f]
[else #t])))
;; Check whether a quoted value is large enough to be worth representing
;; in fasl format:
(define (large-quoted? q)
(define fuel
(let remain ([q q] [fuel 128])
(cond
[(fx= fuel 0) 0]
[(pair? q) (remain (cdr q) (remain (car q) (fx- fuel 1)))]
[(vector? q) (for/fold ([fuel (fx- fuel 1)]) ([e (in-vector q)])
(remain e fuel))]
[(box? q) (remain (unbox q) (fx- fuel 1))]
[(prefab-struct-key q) (remain (struct->vector q) fuel)]
[else (fx- fuel 1)])))
(fx= fuel 0))

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

@ -11,7 +11,6 @@
"mutated.rkt" "mutated.rkt"
"mutated-state.rkt" "mutated-state.rkt"
"left-to-right.rkt" "left-to-right.rkt"
"serialize.rkt"
"let.rkt" "let.rkt"
"equal.rkt" "equal.rkt"
"optimize.rkt" "optimize.rkt"
@ -77,7 +76,9 @@
;; An import ABI is a list of list of booleans, parallel to the ;; An import ABI is a list of list of booleans, parallel to the
;; linklet imports, where #t to means that a value is expected, and #f ;; linklet imports, where #t to means that a value is expected, and #f
;; means that a variable (which boxes a value) is expected. ;; means that a variable (which boxes a value) is expected.
(define (schemify-linklet lk serializable? datum-intern? for-interp? allow-set!-undefined? ;; If `serializable?-box` is not #f, it is filled with a
;; hash table of objects that need to be handled by `racket/fasl`.
(define (schemify-linklet lk serializable?-box datum-intern? for-interp? allow-set!-undefined?
unsafe-mode? enforce-constant? allow-inline? no-prompt? unsafe-mode? enforce-constant? allow-inline? no-prompt?
prim-knowns primitives get-import-knowns import-keys) prim-knowns primitives get-import-knowns import-keys)
(with-deterministic-gensym (with-deterministic-gensym
@ -127,31 +128,24 @@
(for/fold ([exports (hasheq)]) ([ex-id (in-list ex-ids)]) (for/fold ([exports (hasheq)]) ([ex-id (in-list ex-ids)])
(define id (ex-int-id ex-id)) (define id (ex-int-id ex-id))
(hash-set exports id (export (deterministic-gensym id) (ex-ext-id ex-id))))) (hash-set exports id (export (deterministic-gensym id) (ex-ext-id ex-id)))))
;; Lift any quoted constants that can't be serialized
(define-values (bodys/constants-lifted lifted-constants)
(if serializable?
(convert-for-serialize bodys #f datum-intern?)
(values bodys null)))
;; Collect source names for defined identifiers, to the degree that the ;; Collect source names for defined identifiers, to the degree that the
;; original source name differs from the current name ;; original source name differs from the current name
(define src-syms (get-definition-source-syms bodys)) (define src-syms (get-definition-source-syms bodys))
;; Schemify the body, collecting information about defined names: ;; Schemify the body, collecting information about defined names:
(define-values (new-body defn-info mutated) (define-values (new-body defn-info mutated)
(schemify-body* bodys/constants-lifted prim-knowns primitives imports exports (schemify-body* bodys prim-knowns primitives imports exports
for-interp? allow-set!-undefined? add-import! #f serializable?-box datum-intern? for-interp? allow-set!-undefined? add-import! #f
unsafe-mode? enforce-constant? allow-inline? no-prompt? #t)) unsafe-mode? enforce-constant? allow-inline? no-prompt? #t))
(define all-grps (append grps (reverse new-grps))) (define all-grps (append grps (reverse new-grps)))
(values (values
;; Build `lambda` with schemified body: ;; Build `lambda` with schemified body:
(make-let* `(lambda (instance-variable-reference
lifted-constants ,@(for*/list ([grp (in-list all-grps)]
`(lambda (instance-variable-reference [im (in-list (import-group-imports grp))])
,@(for*/list ([grp (in-list all-grps)] (import-id im))
[im (in-list (import-group-imports grp))]) ,@(for/list ([ex-id (in-list ex-ids)])
(import-id im)) (export-id (hash-ref exports (ex-int-id ex-id)))))
,@(for/list ([ex-id (in-list ex-ids)]) ,@new-body)
(export-id (hash-ref exports (ex-int-id ex-id)))))
,@new-body))
;; Imports (external names), possibly extended via inlining: ;; Imports (external names), possibly extended via inlining:
(for/list ([grp (in-list all-grps)]) (for/list ([grp (in-list all-grps)])
(for/list ([im (in-list (import-group-imports grp))]) (for/list ([im (in-list (import-group-imports grp))])
@ -184,7 +178,7 @@
(define id (ex-int-id ex-id)) (define id (ex-int-id ex-id))
(define v (known-inline->export-known (hash-ref defn-info id #f) (define v (known-inline->export-known (hash-ref defn-info id #f)
prim-knowns imports exports prim-knowns imports exports
serializable?)) serializable?-box))
(cond (cond
[(not (set!ed-mutated-state? (hash-ref mutated id #f))) [(not (set!ed-mutated-state? (hash-ref mutated id #f)))
(define ext-id (ex-ext-id ex-id)) (define ext-id (ex-ext-id ex-id))
@ -193,16 +187,17 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (schemify-body l prim-knowns primitives imports exports for-cify? unsafe-mode? no-prompt? explicit-unnamed?) (define (schemify-body l prim-knowns primitives imports exports
for-cify? unsafe-mode? no-prompt? explicit-unnamed?)
(with-deterministic-gensym (with-deterministic-gensym
(define-values (new-body defn-info mutated) (define-values (new-body defn-info mutated)
(schemify-body* l prim-knowns primitives imports exports (schemify-body* l prim-knowns primitives imports exports
#f #f (lambda (im ext-id index) #f) #f #f #f #f (lambda (im ext-id index) #f)
for-cify? unsafe-mode? #t #t no-prompt? explicit-unnamed?)) for-cify? unsafe-mode? #t #t no-prompt? explicit-unnamed?))
new-body)) new-body))
(define (schemify-body* l prim-knowns primitives imports exports (define (schemify-body* l prim-knowns primitives imports exports
for-interp? allow-set!-undefined? add-import! serializable?-box datum-intern? for-interp? allow-set!-undefined? add-import!
for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt? explicit-unnamed?) for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt? explicit-unnamed?)
;; Keep simple checking efficient by caching results ;; Keep simple checking efficient by caching results
(define simples (make-hasheq)) (define simples (make-hasheq))
@ -283,7 +278,7 @@
prim-knowns primitives knowns mutated imports exports simples prim-knowns primitives knowns mutated imports exports simples
allow-set!-undefined? allow-set!-undefined?
add-import! add-import!
for-cify? for-interp? serializable?-box datum-intern? for-cify? for-interp?
unsafe-mode? allow-inline? no-prompt? explicit-unnamed? unsafe-mode? allow-inline? no-prompt? explicit-unnamed?
(if (and no-prompt? (null? (cdr l))) (if (and no-prompt? (null? (cdr l)))
'tail 'tail
@ -479,7 +474,8 @@
;; a 'too-early state in `mutated` for a `letrec`-bound variable can be ;; a 'too-early state in `mutated` for a `letrec`-bound variable can be
;; effectively canceled with a mapping in `knowns`. ;; effectively canceled with a mapping in `knowns`.
(define (schemify v prim-knowns primitives knowns mutated imports exports simples allow-set!-undefined? add-import! (define (schemify v prim-knowns primitives knowns mutated imports exports simples allow-set!-undefined? add-import!
for-cify? for-interp? unsafe-mode? allow-inline? no-prompt? explicit-unnamed? wcm-state) serializable?-box datum-intern? for-cify? for-interp? unsafe-mode? allow-inline? no-prompt? explicit-unnamed?
wcm-state)
;; `wcm-state` is one of: 'tail (= unknown), 'fresh (= no marks), or 'marked (= some marks) ;; `wcm-state` is one of: 'tail (= unknown), 'fresh (= no marks), or 'marked (= some marks)
(let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [wcm-state wcm-state] [v v]) (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [wcm-state wcm-state] [v v])
(define (schemify v wcm-state) (define (schemify v wcm-state)
@ -517,7 +513,10 @@
`(define ,id ,(schemify rhs 'fresh))] `(define ,id ,(schemify rhs 'fresh))]
[`(define-values ,ids ,rhs) [`(define-values ,ids ,rhs)
`(define-values ,ids ,(schemify rhs 'fresh))] `(define-values ,ids ,(schemify rhs 'fresh))]
[`(quote ,_) v] [`(quote ,q)
(when serializable?-box
(register-literal-serialization q serializable?-box datum-intern?))
v]
[`(let-values () ,body) [`(let-values () ,body)
(schemify body wcm-state)] (schemify body wcm-state)]
[`(let-values () ,bodys ...) [`(let-values () ,bodys ...)
@ -904,8 +903,7 @@
[`,_ [`,_
(let ([u-v (unwrap v)]) (let ([u-v (unwrap v)])
(cond (cond
[(not (symbol? u-v)) [(not (symbol? u-v)) v]
v]
[(eq? u-v 'call-with-values) [(eq? u-v 'call-with-values)
'#%call-with-values] '#%call-with-values]
[else [else

286
racket/src/schemify/serialize.rkt
View File

@ -1,286 +0,0 @@
#lang racket/base
(require racket/extflonum
racket/prefab
racket/unsafe/undefined
"match.rkt"
"wrap.rkt"
"path-for-srcloc.rkt"
"to-fasl.rkt"
"quoted.rkt")
(provide convert-for-serialize)
;; Some quoted Racket values cannot be serialized and deserialized
;; automatically by Scheme: keywords (because they need to be interned
;; when reading code), strings and byte strings (ditto), regexps
;; (because they contain function pointers), etc.
;;
;; For those kinds of values, lift a construction of the quoted value
;; out and replace the use of a quoted value with a variable
;; reference. This lifting can interefere with optimizations, so only
;; lift as a last resort.
;;
;; Also lift out paths so they can be made relative, convert large
;; constants to fasl form, and lift out other non-serializable values
;; (so that `compile` will be ok, even though `write` cannot write out
;; those values).
(define (convert-for-serialize bodys for-cify? datum-intern?)
(define lifted-eq-constants (make-hasheq))
(define lifted-equal-constants (make-hash))
(define lift-bindings null)
(define lifts-count 0)
(define (add-lifted rhs)
;; FIXME: make sure these `id`s don't collide with anything
(define id (string->symbol (format "q:~a" lifts-count)))
(set! lifts-count (add1 lifts-count))
(set! lift-bindings (cons (list id rhs) lift-bindings))
id)
(define new-bodys
(for/list ([v (in-list bodys)])
(cond
[(convert-any? v for-cify? datum-intern?)
(define (convert v)
(reannotate
v
(match v
[`(quote ,q)
(cond
[(lift-quoted? q for-cify? datum-intern?)
(make-construct q add-lifted lifted-eq-constants lifted-equal-constants
for-cify? datum-intern?)]
[else v])]
[`(lambda ,formals ,body ...)
`(lambda ,formals ,@(convert-function-body body))]
[`(case-lambda [,formalss ,bodys ...] ...)
`(case-lambda ,@(for/list ([formals (in-list formalss)]
[body (in-list bodys)])
`[,formals ,@(convert-function-body body)]))]
[`(define-values ,ids ,rhs)
`(define-values ,ids ,(convert rhs))]
[`(let-values ([,idss ,rhss] ...) ,bodys ...)
`(let-values ,(for/list ([ids (in-list idss)]
[rhs (in-list rhss)])
`[,ids ,(convert rhs)])
,@(convert-body bodys))]
[`(letrec-values ([,idss ,rhss] ...) ,bodys ...)
`(letrec-values ,(for/list ([ids (in-list idss)]
[rhs (in-list rhss)])
`[,ids ,(convert rhs)])
,@(convert-body bodys))]
[`(if ,tst ,thn ,els)
`(if ,(convert tst) ,(convert thn) ,(convert els))]
[`(with-continuation-mark* ,mode ,key ,val ,body)
`(with-continuation-mark* ,mode ,(convert key) ,(convert val) ,(convert body))]
[`(begin ,exps ...)
`(begin . ,(convert-body exps))]
[`(begin-unsafe ,exps ...)
`(begin-unsafe . ,(convert-body exps))]
[`(begin0 ,exps ...)
`(begin0 . ,(convert-body exps))]
[`(set! ,id ,rhs)
`(set! ,id ,(convert rhs))]
[`(#%variable-reference) v]
[`(#%variable-reference ,_) v]
[`(,rator ,exps ...)
`(,(convert rator) ,@(convert-body exps))]
[`,_
(cond
[(and (not (symbol? v))
(lift-quoted? v for-cify? datum-intern?))
(convert `(quote ,v))]
[else v])])))
(define (convert-body body)
(for/list ([e (in-list body)])
(convert e)))
(define (convert-function-body body)
(if for-cify?
;; Detect the function-name pattern and avoid
;; mangling it:
(match body
[`((begin (quote ,name) ,body . ,bodys))
`((begin (quote ,name) ,@(convert-body (cons body bodys))))]
[`,_ (convert-body body)])
(convert-body body)))
(convert v)]
[else v])))
(values new-bodys
(reverse lift-bindings)))
;; v is a form or a list of forms
(define (convert-any? v for-cify? datum-intern?)
(let convert-any? ([v v])
(match v
[`(quote ,q) (lift-quoted? q for-cify? datum-intern?)]
[`(lambda ,formals ,body ...)
(convert-any? body)]
[`(case-lambda [,formalss ,bodys ...] ...)
(convert-any? bodys)]
[`(define-values ,ids ,rhs)
(convert-any? rhs)]
[`(let-values ([,idss ,rhss] ...) ,bodys ...)
(or (convert-any? rhss)
(convert-any? bodys))]
[`(letrec-values ([,idss ,rhss] ...) ,bodys ...)
(or (convert-any? rhss)
(convert-any? bodys))]
[`(if ,tst ,thn ,els)
(or (convert-any? tst)
(convert-any? thn)
(convert-any? els))]
[`(with-continuation-mark* ,_ ,key ,val ,body)
(or (convert-any? key)
(convert-any? val)
(convert-any? body))]
[`(begin ,exps ...)
(convert-any? exps)]
[`(begin-unsafe ,exps ...)
(convert-any? exps)]
[`(begin0 ,exps ...)
(convert-any? exps)]
[`(set! ,id ,rhs)
(convert-any? rhs)]
[`(#%variable-reference) #f]
[`(#%variable-reference ,_) #f]
[`(,exps ...)
(for/or ([exp (in-list exps)])
(convert-any? exp))]
[`,_ (and (not (symbol? v))
(lift-quoted? v for-cify? datum-intern?))])))
;; Construct an expression to be lifted
(define (make-construct q add-lifted lifted-eq-constants lifted-equal-constants
for-cify? datum-intern?)
(define (quote? e) (and (pair? e) (eq? 'quote (car e))))
(define seen #hasheq())
(define (check-cycle v)
(when (hash-ref seen v #f)
(raise-arguments-error 'compile "cannot compile cyclic value"
"value" q))
(set! seen (hash-set seen v #t)))
(define (done-cycle v)
(set! seen (hash-remove seen v)))
(cond
[(and (not for-cify?)
(large-quoted? q))
;; a `to-fasl` struct is recognized like
;; paths and `path-for-srcloc`:
(define id (add-lifted (to-fasl (box q) '#() #f)))
`(force-unfasl ,id)]
[else
(let make-construct ([q q])
(define lifted-constants (if (or (string? q) (bytes? q))
lifted-equal-constants
lifted-eq-constants))
(cond
[(hash-ref lifted-constants q #f)
=> (lambda (id) id)]
[else
(define rhs
(cond
[(path? q)
(if for-cify?
`(bytes->path ,(path->bytes q)
',(path-convention-type q))
;; We expect paths to be recognized in lifted bindings
;; and handled specially, so no conversion here:
q)]
[(path-for-srcloc? q) q]
[(regexp? q)
`(,(if (pregexp? q) 'pregexp 'regexp) ,(object-name q))]
[(srcloc? q)
`(unsafe-make-srcloc
,(let ([src (srcloc-source q)])
(if (and (not for-cify?)
;; Need to handle paths, need to reject (later) anything other
;; than a few types like strings and byte strings
(not (or (string? src) (bytes? src) (symbol? src) (not src))))
;; Like paths, `path-for-srcloc` must be recognized later
(make-construct (path-for-srcloc src))
(make-construct src)))
,(make-construct (srcloc-line q))
,(make-construct (srcloc-column q))
,(make-construct (srcloc-position q))
,(make-construct (srcloc-span q)))]
[(byte-regexp? q)
`(,(if (byte-pregexp? q) 'byte-pregexp 'byte-regexp) ,(object-name q))]
[(keyword? q)
`(string->keyword ,(keyword->string q))]
[(hash? q)
(define mut? (not (immutable? q)))
(when mut? (check-cycle q))
(define new-q
`(,(cond
[(hash-eq? q) 'hasheq]
[(hash-eqv? q) 'hasheqv]
[else 'hash])
,@(apply append
(for/list ([(k v) (in-hash q)])
(list (make-construct k)
(make-construct v))))))
(when mut? (done-cycle q))
new-q]
[(string? q) `(datum-intern-literal ,q)]
[(bytes? q) `(datum-intern-literal ,q)]
[(pair? q)
(if (list? q)
(let ([args (map make-construct q)])
(if (andmap quote? args)
`(quote ,q)
`(list ,@(map make-construct q))))
(let ([a (make-construct (car q))]
[d (make-construct (cdr q))])
(if (and (quote? a) (quote? d))
`(quote ,q)
`(cons ,a ,d))))]
[(vector? q)
(let ([args (map make-construct (vector->list q))])
`(vector->immutable-vector
,(if (and (andmap quote? args)
(not (impersonator? q)))
`(quote ,q)
`(vector ,@args))))]
[(box? q)
(let ([arg (make-construct (unbox q))])
`(box-immutable ,arg))]
[(prefab-struct-key q)
=> (lambda (key)
(define mut? (not (prefab-key-all-fields-immutable? key)))
(when mut? (check-cycle q))
(define new-q
`(make-prefab-struct ',key ,@(map make-construct
(cdr (vector->list (struct->vector q))))))
(when mut? (done-cycle q))
new-q)]
[(extflonum? q)
`(string->number ,(format "~a" q) 10 'read)]
[(or for-cify?
(null? q)
(number? q)
(char? q)
(boolean? q)
(and (symbol? q)
(or (symbol-interned? q)
(symbol-unreadable? q)))
(eof-object? q)
(void? q)
(eq? q unsafe-undefined))
;; Serializable in-place:
`(quote ,q)]
[(symbol? q)
;; Must be an uninterned symbol
`(force-unfasl ,(add-lifted (to-fasl (box q) '#() #f)))]
[else
;; Lift out anything non-serializable, so we can deal with those
;; values like we deal with paths:
(define id (add-lifted (to-fasl (box q) '#() #f)))
`(force-unfasl ,id)]))
(cond
[(and (quote? rhs)
(or (not for-cify?)
(not (lift-quoted? (cadr rhs) #t datum-intern?))))
rhs]
[else
(define id (add-lifted rhs))
(hash-set! lifted-constants q id)
id])]))]))

11
racket/src/schemify/size.rkt
View File

@ -1,7 +1,6 @@
#lang racket/base #lang racket/base
(require "wrap.rkt" (require "wrap.rkt"
"match.rkt" "match.rkt")
"quoted.rkt")
;; The `linklet-bigger-than?` function is practically an S-expression ;; The `linklet-bigger-than?` function is practically an S-expression
;; counter, but it parses expressions properly so it can stop at ;; counter, but it parses expressions properly so it can stop at
@ -38,13 +37,7 @@
(body-leftover-size body (sub1 size))] (body-leftover-size body (sub1 size))]
[`(begin0 . ,body) [`(begin0 . ,body)
(body-leftover-size body (sub1 size))] (body-leftover-size body (sub1 size))]
[`(quote ,v) (if (and serializable? [`(quote ,v) (sub1 size)]
(lift-quoted? v #f #t))
;; pessimistically assume that full
;; strcuture must be lifted for
;; serialization:
(s-expr-leftover-size v size)
(sub1 size))]
[`(set! ,id ,rhs) (leftover-size rhs (sub1 size))] [`(set! ,id ,rhs) (leftover-size rhs (sub1 size))]
[`(#%variable-reference . ,_) (sub1 size)] [`(#%variable-reference . ,_) (sub1 size)]
[`(,_ . ,_) (body-leftover-size e size)] [`(,_ . ,_) (body-leftover-size e size)]

8
racket/src/schemify/to-fasl.rkt
View File

@ -1,8 +0,0 @@
#lang racket/base
(provide (struct-out to-fasl))
(struct to-fasl (vb ; box containing byte string as marshaled or other as unmarshaled
lifts ; vector of external lifts
wrt) ; directory for unmarshaling
#:mutable)

2
racket/src/version/racket_version.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 9 #define MZSCHEME_VERSION_Y 9
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 6 #define MZSCHEME_VERSION_W 7
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x