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
;; "racket_version.h" changes:
(define version "7.9.0.6")
(define version "7.9.0.7")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

@ -248,31 +248,23 @@
[(? linklet?)
(case (system-type 'vm)
[(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
[code
(case fmt
[(compile)
(cond
[(not (current-partial-fasl))
;; Note that applying the result of `vm-eval` no longer shows the setup of
;; Racket level constants (like keywords):
(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))))]
(define proc (vm-eval `(load-compiled-from-port (open-bytevector-input-port ,code) ',literals)))
(decompile-chez-procedure proc)]
[else
(define desc (disassemble-in-description
`(#(FASL
#:length ,(bytes-length code)
,(vm-eval `(($primitive $describe-fasl-from-port) (open-bytevector-input-port ,code) ',sfd-paths))))))
(if (null? args)
desc
(cons desc (map (vm-primitive 'force-unfasl) args)))])]
(disassemble-in-description
`(#(FASL
#:length ,(bytes-length code)
#:literals ,literals
,(vm-eval `(($primitive $describe-fasl-from-port) (open-bytevector-input-port ,code) ',literals)))))])]
[(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)))]
[else
'(....)])]

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

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

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

@ -13,11 +13,13 @@
[out (or/c output-port? #f) #f]
[#:keep-mutable? keep-mutable? 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?)]
@defproc[(fasl->s-exp [in (or/c input-port? bytes?)]
[#: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]
)]{
@ -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
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
independent of the Racket version, except as future Racket versions
introduce extensions that are not currently recognized. In particular,
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[
#:eval fasl-eval

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

@ -2,6 +2,7 @@
(require '#%extfl
racket/linklet
racket/unsafe/undefined
racket/fixnum
(for-syntax racket/base)
"private/truncate-path.rkt"
"private/relative-path.rkt"
@ -121,7 +122,8 @@
[orig-o #f]
#:keep-mutable? [keep-mutable? #f]
#:handle-fail [handle-fail #f]
#:external-lift? [external-lift? #f])
#:external-lift? [external-lift? #f]
#:skip-prefix? [skip-prefix? #f])
(when orig-o
(unless (output-port? 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 path->relative-path-elements (make-path->relative-path-elements))
;; 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
(define bstr
(let ([o (open-output-bytes)])
@ -394,14 +397,16 @@
(define (fasl->s-exp orig-i
#:datum-intern? [intern? #t]
#:external-lifts [external-lifts '#()])
#:external-lifts [external-lifts '#()]
#:skip-prefix? [skip-prefix? #f])
(define init-i (cond
[(bytes? orig-i) (mcons orig-i 0)]
[(input-port? orig-i) 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)
(read-error "unrecognized prefix"))
(define shared-count (read-fasl-integer init-i))
(unless skip-prefix?
(unless (bytes=? (read-bytes/exactly* fasl-prefix-length init-i) fasl-prefix)
(read-error "unrecognized prefix")))
(define shared-count (read-fasl-integer* init-i))
(define shared (make-vector shared-count))
(unless (and (vector? external-lifts)
@ -411,11 +416,11 @@
[pos (in-naturals)])
(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)
init-i
;; 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))))
(define (intern v) (if intern? (datum-intern-literal v) v))
@ -588,13 +593,16 @@
args))
(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
[(mpair? i)
(define pos (mcdr i))
(unless (pos . < . (bytes-length (mcar i)))
(read-error "truncated stream"))
(set-mcdr! i (add1 pos))
(bytes-ref (mcar i) pos)]
(read-byte/no-eof i)]
[else
(define b (read-byte i))
(when (eof-object? b)
@ -602,42 +610,93 @@
b]))
(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
[(mpair? i)
(define pos (mcdr i))
(unless ((+ pos n) . <= . (bytes-length (mcar i)))
(read-error "truncated stream"))
(set-mcdr! i (+ pos n))
(subbytes (mcar i) pos (+ pos n))]
(read-bytes/exactly n i)]
[else
(define bstr (read-bytes n i))
(unless (and (bytes? bstr) (= n (bytes-length bstr)))
(read-error "truncated stream"))
bstr]))
(define (read-fasl-integer i)
(define b (read-byte/no-eof i))
(cond
[(<= b 127) b]
[(>= b 132) (- b 256)]
[(eqv? b 128)
(integer-bytes->integer (read-bytes/exactly 2 i) #t #f)]
[(eqv? b 129)
(integer-bytes->integer (read-bytes/exactly 4 i) #t #f)]
[(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")]))
(define-values (read-fasl-integer read-fasl-integer*)
(let-syntax ([gen
(syntax-rules ()
[(_ read-byte/no-eof read-bytes/exactly)
(lambda (i)
(define b (read-byte/no-eof i))
(cond
[(fx<= b 127) b]
[(fx>= b 132) (fx- b 256)]
[(eqv? b 128)
(define lo (read-byte/no-eof i))
(define hi (read-byte/no-eof i))
(if (hi . fx> . 127)
(fxior (fxlshift (fx+ -256 hi) 8) lo)
(fxior (fxlshift hi 8) lo))]
[(eqv? b 129)
(define a (read-byte/no-eof i))
(define b (read-byte/no-eof i))
(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 bstr (read-bytes/exactly len i))
(bytes->string/utf-8 bstr))
(define pos (mcdr i))
(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 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)
(if (nanopass-case (L7 Expr) e
[(quote ,d) (ptr->imm d)]
[(call ,info ,mdcl ,pr ,e* ...)
(eq? 'fixnum ($sgetprop (primref-name pr) '*result-type* #f))]
[else #f])
(build-assign base index offset e)
(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)]
[($record? x) (bld-graph x t a? d #t bld-record)]
[(box? x) (bld-graph x t a? d #t bld-box)]
[(or (large-integer? x) (ratnum? x) ($inexactnum? x) ($exactnum? x)
(fxvector? x) (flvector? x) (bytevector? x))
(bld-graph x t a? d #t bld-simple)])))
[else (bld-graph x t a? d #t bld-simple)])))
(module (small-integer? large-integer?)
(define least-small-integer (- (expt 2 31)))
@ -626,6 +624,11 @@
(put-u8 p (constant fasl-type-graph-ref))
(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
(lambda (x p t a?)
(cond
@ -649,7 +652,7 @@
; this check must go before $record? check
[(symbol-hashtable? x) (wrf-graph x p t a? wrf-symht)]
; 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)]
[(vector? x) (wrf-graph x p t a? wrf-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)]
[($rtd-counts? x) (wrf-immediate (constant sfalse) 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)
(define start

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

@ -4,7 +4,7 @@
primitive-in-category?)
racket/cmdline
"../../schemify/schemify.rkt"
"../../schemify/serialize.rkt"
"../../cify/literal.rkt"
"../../schemify/known.rkt"
"../../schemify/lift.rkt"
"../../schemify/reinfer-name.rkt"
@ -66,13 +66,13 @@
a-known-constant]))))
(printf "Serializable...\n")
(define-values (bodys/constants-lifted lifted-constants)
(time (convert-for-serialize l #t #t)))
(define-values (bodys/literals-extracted literals)
(time (extract-literals l)))
;; Startup code reuses names to keep it compact; make
;; te names unique again
(define bodys/re-uniqued
(cdr (re-unique `(begin . ,bodys/constants-lifted))))
(cdr (re-unique `(begin . ,bodys/literals-extracted))))
(printf "Schemify...\n")
(define body
@ -93,7 +93,7 @@
(lift-in-schemified-body body)))
(define converted-body
(append (for/list ([p (in-list lifted-constants)])
(append (for/list ([p (in-list literals)])
(cons 'define p))
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"
"(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"
" 's-exp->fasl"
"(let-values(((v_0) v12_0))"
"(let-values(((orig-o_0) orig-o11_0))"
"(let-values(((v_0) v14_0))"
"(let-values(((orig-o_0) orig-o13_0))"
"(let-values(((keep-mutable?_0) keep-mutable?5_0))"
"(let-values(((handle-fail_0) handle-fail6_0))"
"(let-values(((external-lift?_0) external-lift?7_0))"
"(let-values(((skip-prefix?_0) skip-prefix?8_0))"
"(let-values()"
"(let-values((()"
"(begin"
@ -18772,7 +18773,7 @@ static const char *startup_source =
"(if(output-port? orig-o_0)"
"(void)"
"(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))"
"(values))))"
"(let-values((()"
@ -18786,7 +18787,7 @@ static const char *startup_source =
"(let-values()"
"(raise-argument-error"
" 's-exp->fasl"
" \"(or/c (procedure-arity-includes/c 1) #f)\""
" \"(or/c (procedure-arity-includes/c 1) #f)\""
" handle-fail_0))))"
"(void))"
"(values))))"
@ -18801,7 +18802,7 @@ static const char *startup_source =
"(let-values()"
"(raise-argument-error"
" 's-exp->fasl"
" \"(or/c (procedure-arity-includes/c 1) #f)\""
" \"(or/c (procedure-arity-includes/c 1) #f)\""
" external-lift?_0))))"
"(void))"
"(values))))"
@ -18833,7 +18834,8 @@ static const char *startup_source =
" shared_0"
" v_1"
"(- 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"
" or-part_0"
"(let-values(((or-part_1)"
@ -18913,7 +18915,8 @@ static const char *startup_source =
"(loop_0 v_2)))"
" #t))"
"(if(box? v_1)"
"(let-values()(loop_0(unbox v_1)))"
"(let-values()"
"(loop_0(unbox v_1)))"
"(let-values(((c1_0)"
"(prefab-struct-key"
" v_1)))"
@ -18936,7 +18939,7 @@ static const char *startup_source =
" 1)"
"(normalise-inputs"
" 'in-vector"
" \"vector\""
" \"vector\""
"(lambda(x_0)"
"(vector?"
" x_0))"
@ -19055,7 +19058,12 @@ static const char *startup_source =
"(let-values(((path->relative-path-elements_0)"
"(let-values()"
"(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(((o_1)(open-output-bytes)))"
"(begin"
@ -19064,7 +19072,9 @@ static const char *startup_source =
"(begin"
" 'loop"
"(if(not"
"(eq?(hash-ref shared_0 v_1 1) 1))"
"(eq?"
"(hash-ref shared_0 v_1 1)"
" 1))"
"(let-values()"
"(let-values(((c_0)"
"(hash-ref"
@ -19084,7 +19094,8 @@ static const char *startup_source =
" shared-counter_0))"
"(begin"
"(set! shared-counter_0"
"(add1 shared-counter_0))"
"(add1"
" shared-counter_0))"
"(1/write-byte"
" fasl-graph-def-type"
" o_1)"
@ -19156,13 +19167,14 @@ static const char *startup_source =
"(if(eqv?"
" v_1"
" +nan.0)"
" #\"\\0\\0\\0\\0\\0\\0\\370\\177\""
" #\"\\0\\0\\0\\0\\0\\0\\370\\177\""
"(real->floating-point-bytes"
" v_1"
" 8"
" #f))"
" o_1)))"
"(if(single-flonum? v_1)"
"(if(single-flonum?"
" v_1)"
"(let-values()"
"(begin"
"(1/write-byte"
@ -19173,7 +19185,7 @@ static const char *startup_source =
" v_1"
"(real->single-flonum"
" +nan.0))"
" #\"\\0\\0\\300\\177\""
" #\"\\0\\0\\300\\177\""
"(real->floating-point-bytes"
" v_1"
" 4"
@ -19190,7 +19202,7 @@ static const char *startup_source =
"(let-values(((bstr_0)"
"(string->bytes/utf-8"
"(format"
" \"~a\""
" \"~a\""
" v_1))))"
"(begin"
"(write-fasl-integer"
@ -19200,7 +19212,8 @@ static const char *startup_source =
"(1/write-bytes"
" bstr_0"
" o_1)))))"
"(if(rational? v_1)"
"(if(rational?"
" v_1)"
"(let-values()"
"(begin"
"(1/write-byte"
@ -19212,7 +19225,8 @@ static const char *startup_source =
"(loop_0"
"(denominator"
" v_1))))"
"(if(complex? v_1)"
"(if(complex?"
" v_1)"
"(let-values()"
"(begin"
"(1/write-byte"
@ -19224,7 +19238,8 @@ static const char *startup_source =
"(loop_0"
"(imag-part"
" v_1))))"
"(if(char? v_1)"
"(if(char?"
" v_1)"
"(let-values()"
"(begin"
"(1/write-byte"
@ -19591,7 +19606,7 @@ static const char *startup_source =
" 1)"
"(normalise-inputs"
" 'in-vector"
" \"vector\""
" \"vector\""
"(lambda(x_0)"
"(vector?"
" x_0))"
@ -19787,8 +19802,8 @@ static const char *startup_source =
" v_1))"
"(raise-arguments-error"
" 's-exp->fasl"
" \"cannot write value\""
" \"value\""
" \"cannot write value\""
" \"value\""
" v_1))))))))))))))))))))))))))))))))))))"
" loop_0)"
" v_0)"
@ -19797,15 +19812,16 @@ static const char *startup_source =
"(write-fasl-integer shared-counter_0 o_0)"
"(write-fasl-integer(bytes-length 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"
"(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"
" 'fasl->s-exp"
"(let-values(((orig-i_0) orig-i18_0))"
"(let-values(((intern?_0) datum-intern?14_0))"
"(let-values(((external-lifts_0)(if(eq? external-lifts15_0 unsafe-undefined) '#() external-lifts15_0)))"
"(let-values(((orig-i_0) orig-i22_0))"
"(let-values(((intern?_0) datum-intern?16_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(((init-i_0)"
"(if(bytes? orig-i_0)"
@ -19813,14 +19829,17 @@ static const char *startup_source =
"(if(input-port? orig-i_0)"
"(let-values() orig-i_0)"
"(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((()"
"(begin"
"(if(bytes=?(read-bytes/exactly fasl-prefix-length init-i_0) fasl-prefix)"
"(if skip-prefix?_0"
"(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))))"
"(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((()"
"(begin"
@ -19829,7 +19848,7 @@ static const char *startup_source =
" #f)"
"(void)"
"(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))))"
"(let-values((()"
"(begin"
@ -19849,7 +19868,8 @@ static const char *startup_source =
"(begin"
" 'for-loop"
"(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))"
"(let-values((()"
"(let-values()"
@ -19866,7 +19886,9 @@ static const char *startup_source =
"(values)))))"
"(values)))))"
"(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))))))"
" for-loop_0)"
@ -19874,11 +19896,11 @@ static const char *startup_source =
" start_0)))"
"(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)"
"(if(mpair? 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)))))"
"(let-values(((intern_0)"
"(lambda(v_0)"
@ -19953,8 +19975,8 @@ static const char *startup_source =
" fasl-lowest-small-integer))"
"(let-values()"
"(read-error"
" \"unrecognized fasl tag\""
" \"tag\""
" \"unrecognized fasl tag\""
" \"tag\""
" type_0))))"
"(if(unsafe-fx< index_0 2)"
"(let-values()"
@ -19965,7 +19987,7 @@ static const char *startup_source =
"(if(< pos_0 shared-count_0)"
"(void)"
"(let-values()"
" (read-error \"bad graph index\")))"
" (read-error \"bad graph index\")))"
"(vector-set! shared_0 pos_0 v_0)"
" v_0))))"
"(if(unsafe-fx< index_0 3)"
@ -19976,7 +19998,7 @@ static const char *startup_source =
"(if(< pos_0 shared-count_0)"
"(void)"
"(let-values()"
" (read-error \"bad graph index\")))"
" (read-error \"bad graph index\")))"
"(vector-ref shared_0 pos_0))))"
"(let-values() #f))))"
"(if(unsafe-fx< index_0 6)"
@ -20034,8 +20056,10 @@ static const char *startup_source =
"(read-fasl-string i_0)))"
"(if(unsafe-fx< index_0 19)"
"(let-values()"
"(string->keyword(read-fasl-string i_0)))"
"(let-values()(read-fasl-string i_0))))))))"
"(string->keyword"
"(read-fasl-string i_0)))"
"(let-values()"
"(read-fasl-string i_0))))))))"
"(if(unsafe-fx< index_0 30)"
"(if(unsafe-fx< index_0 24)"
"(if(unsafe-fx< index_0 21)"
@ -20068,7 +20092,8 @@ static const char *startup_source =
"(#%variable-reference))"
"(void)"
"(let-values()"
"(check-list lst_0)))"
"(check-list"
" lst_0)))"
"((letrec-values(((for-loop_0)"
"(lambda(fold-var_0"
" lst_1)"
@ -20116,9 +20141,12 @@ static const char *startup_source =
"(if(null? rel-elems_0)"
"(let-values()(build-path 'same))"
"(let-values()"
"(apply build-path rel-elems_0)))))))"
"(apply"
" build-path"
" rel-elems_0)))))))"
"(let-values()"
"(intern_0(pregexp(read-fasl-string i_0)))))"
"(intern_0"
"(pregexp(read-fasl-string i_0)))))"
"(if(unsafe-fx< index_0 27)"
"(let-values()"
"(intern_0(regexp(read-fasl-string i_0))))"
@ -20203,7 +20231,8 @@ static const char *startup_source =
"(let-values(((len_1)"
"(read-fasl-integer i_0)))"
"(let-values(((vec_0)"
"(let-values(((len_2) len_1))"
"(let-values(((len_2)"
" len_1))"
"(begin"
"(if(exact-nonnegative-integer?"
" len_2)"
@ -20211,7 +20240,7 @@ static const char *startup_source =
"(let-values()"
"(raise-argument-error"
" 'for/vector"
" \"exact-nonnegative-integer?\""
" \"exact-nonnegative-integer?\""
" len_2)))"
"(let-values(((v_0)"
"(make-vector"
@ -20432,7 +20461,8 @@ static const char *startup_source =
" end_0"
" inc_0)))"
"((letrec-values(((for-loop_0)"
"(lambda(ht_1 pos_0)"
"(lambda(ht_1"
" pos_0)"
"(begin"
" 'for-loop"
"(if(<"
@ -20481,8 +20511,10 @@ static const char *startup_source =
"(srcloc-source s_0)"
"(srcloc-line s_0)"
"(srcloc-column s_0)"
"(srcloc-position s_0)"
"(srcloc-span s_0)))))"
"(srcloc-position"
" s_0)"
"(srcloc-span"
" s_0)))))"
"(let-values(((lst_0)(loop_0)))"
"(begin"
"(if(variable-reference-from-unsafe?"
@ -20528,7 +20560,7 @@ static const char *startup_source =
" lst_0)))))))"
"(let-values()"
" unsafe-undefined)))))))))))))))"
" loop_0)))))))))))))))))))"
" loop_0))))))))))))))))))))"
"(define-values"
"(write-fasl-integer)"
"(lambda(i_0 o_0)"
@ -20562,13 +20594,17 @@ static const char *startup_source =
"(read-byte/no-eof)"
"(lambda(i_0)"
"(begin"
"(if(mpair? i_0)"
"(let-values()"
"(let-values(((pos_0)(mcdr i_0)))"
"(begin"
" (if (< pos_0 (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))"
"(set-mcdr! i_0(add1 pos_0))"
"(bytes-ref(mcar i_0) pos_0))))"
" (if (< pos_0 (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))"
"(set-mcdr! i_0(fx+ pos_0 1))"
"(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(((b_0)(read-byte i_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)"
"(lambda(n_0 i_0)"
"(begin"
"(if(mpair? i_0)"
"(let-values()"
"(let-values(((pos_0)(mcdr i_0)))"
"(begin"
" (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))"
"(subbytes(mcar i_0) pos_0(+ pos_0 n_0)))))"
" (if (<= (+ pos_0 n_0) (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))"
"(set-mcdr! i_0(fx+ 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(((bstr_0)(read-bytes n_0 i_0)))"
"(begin"
@ -20591,18 +20631,34 @@ static const char *startup_source =
" (let-values () (read-error \"truncated stream\")))"
" bstr_0)))))))"
"(define-values"
"(read-fasl-integer)"
"(read-fasl-integer read-fasl-integer*)"
"(let-values()"
"(let-values()"
"(values"
"(lambda(i_0)"
"(begin"
"(let-values(((b_0)(read-byte/no-eof i_0)))"
"(if(<= b_0 127)"
"(if(fx<= b_0 127)"
"(let-values() b_0)"
"(if(>= b_0 132)"
"(let-values()(- b_0 256))"
"(if(fx>= b_0 132)"
"(let-values()(fx- b_0 256))"
"(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)"
"(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)"
"(let-values()(integer-bytes->integer(read-bytes/exactly 8 i_0) #t #f))"
"(if(eqv? b_0 131)"
@ -20612,22 +20668,87 @@ static const char *startup_source =
"(begin"
"(if(if(string? str_0)(= len_0(string-length str_0)) #f)"
"(void)"
" (let-values () (read-error \"truncated stream at number\")))"
" (let-values () (read-error \"truncated stream at number\")))"
"(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"
"(read-fasl-string)"
"(let-values(((read-fasl-string_0)"
"(lambda(i21_0 len20_0)"
"(lambda(i25_0 len24_0)"
"(begin"
" 'read-fasl-string"
"(let-values(((i_0) i21_0))"
"(let-values(((len_0)(if(eq? len20_0 unsafe-undefined)(read-fasl-integer i_0) len20_0)))"
"(let-values(((i_0) i25_0))"
"(let-values(((len_0)(if(eq? len24_0 unsafe-undefined)(read-fasl-integer i_0) len24_0)))"
"(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"
"((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"
"(read-fasl-bytes)"
"(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"
" make-pthread-parameter"
" engine-block"
" force-unfasl"
" make-record-type-descriptor"
" make-record-type-descriptor*"
" make-record-constructor-descriptor"
@ -29807,7 +29927,7 @@ static const char *startup_source =
"(define-values"
"(write-correlated-linklet-bundle-hash)"
"(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"
"(->faslable)"
"(lambda(v_0)"
@ -29961,7 +30081,8 @@ static const char *startup_source =
"(define-values"
"(read-correlated-linklet-bundle-hash)"
"(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"
"(faslable->)"
"(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)
(get-u8 in) ; newline
(let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths
(let ([literals
(case (integer->char cmd)
[(#\c #\u)
(call-with-fasled
@ -41,7 +41,7 @@
(parameterize ([optimize-level (if (fx= cmd (char->integer #\u))
3
(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)
;; Reads host fasl format, then writes target fasl format
(call-with-fasled
@ -54,11 +54,11 @@
(let ([result (get)])
(put-num out (bytevector-length result))
(put-bytevector out result)
(let ([len (vector-length sfd-paths)])
(let ([len (vector-length literals)])
(put-num out len)
(let loop ([i 0])
(unless (fx= i len)
(put-num out (vector-ref sfd-paths i))
(put-num out (vector-ref literals i))
(loop (fx+ i 1)))))
(flush-output-port out)))
(loop)))))))
@ -76,30 +76,41 @@
;; ----------------------------------------
(define-record-type path-placeholder
(define-record-type literal-placeholder
(fields pos))
(define (call-with-fasled in proc)
(let* ([fasled-bv (get-bytevector-n in (get-num in))]
[num-sfd-paths (get-num in)]
[sfd-paths (list->vector
(let loop ([i 0])
(if (fx= i num-sfd-paths)
'()
(cons (make-path-placeholder i)
(loop (fx+ i 1))))))]
[literals-bv (get-bytevector-n in (get-num in))]
[transparent-placeholders (make-eq-hashtable)]
[literals (let ([vec (fasl-read (open-bytevector-input-port literals-bv))])
;; Use a placeholder for opaque literals that could not be
;; communicated from the Racket world. "Transparent" literals
;; are things like strings and bytevectors that can affect
;; 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 '()]
;; 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)
'load
sfd-paths)])
literals)])
(proc v
(lambda (a)
(and (path-placeholder? a)
(begin
(set! used-placeholders (cons a used-placeholders))
#t))))
;; Return indices of paths used in new fasled output, in the
;; order that they're used
(list->vector (map path-placeholder-pos used-placeholders))))
(let ([a (eq-hashtable-ref transparent-placeholders a a)])
(and (literal-placeholder? a)
(begin
(set! used-placeholders (cons a used-placeholders))
#t)))))
;; Return indices of literals used in new fasled output in the order
;; 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?
(unless (= 1 (length deps))
(error 'compile-file "expected a single dependency for whole-program compilation"))
(printf "Whole-program optimizaton for Racket core...\n")
(printf " [If this runs out of memory, try configuring with `--disable-wpo`]\n")
(printf "Whole-program optimization for Racket core...\n")
(printf "[If this step runs out of memory, try configuring with `--disable-wpo`]\n")
(unless (equal? build-dir "")
(library-directories (list (cons "." build-dir))))
(compile-whole-program (car deps) src #t)]

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

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

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

@ -28,9 +28,7 @@
(thread)
(regexp)
(io)
(linklet)
(only (schemify)
force-unfasl))
(linklet))
(include "place-register.ss")
(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)
(io)
(regexp)
(linklet)
(only (schemify)
force-unfasl)))
(linklet)))

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

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

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

@ -75,7 +75,14 @@
(hash-ref sfd-cache src #f))
;; We'll use a file-position object in source objects, so
;; 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
(hash-set! sfd-cache src sfd))
sfd)))

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

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

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

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

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

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

@ -34,8 +34,6 @@
[make-pthread-parameter (known-procedure 2)]
[engine-block (known-procedure 1)]
[force-unfasl (known-procedure 2)]
[ptr-ref/int8 (known-procedure 8)]
[ptr-ref/uint8 (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)]
[map (known-procedure -4)]
[max (known-procedure/folding -2)]
[mcar (known-procedure/no-prompt 2)]
[mcdr (known-procedure/no-prompt 2)]
[mcar (known-procedure/has-unsafe 2 'unsafe-mcar)]
[mcdr (known-procedure/has-unsafe 2 'unsafe-mcdr)]
[mcons (known-procedure/pure 4)]
[memory-order-acquire (known-procedure 1)]
[memory-order-release (known-procedure 1)]
@ -760,8 +760,8 @@
[semaphore? (known-procedure/pure/folding 2)]
[set-box! (known-procedure 4)]
[set-box*! (known-procedure/has-unsafe 4 'unsafe-set-box*!)]
[set-mcar! (known-procedure/no-prompt 4)]
[set-mcdr! (known-procedure/no-prompt 4)]
[set-mcar! (known-procedure/has-unsafe 4 'unsafe-set-mcar!)]
[set-mcdr! (known-procedure/has-unsafe 4 'unsafe-set-mcdr!)]
[set-phantom-bytes! (known-procedure/no-prompt 4)]
[set-port-next-location! (known-procedure 16)]
[sha1-bytes (known-procedure 14)]

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

@ -668,7 +668,12 @@
[loc (and (cdr p)
(call-with-values (lambda ()
(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)
(values path
(source-object-line src)

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

@ -206,6 +206,13 @@
(#%$string-set-immutable! s)
s]))
(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
[(= (vector-length v) 0) (immutable-constant #())]
[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 (not print-graph?_0)
(if (not (eq? mode_0 0))
(let ((app_0 (mcdr v_0)))
(let ((app_0 (unsafe-mcdr v_0)))
(quick-no-graph?_0
config_0
mode_0
print-graph?_0
app_0
(let ((app_1 (mcar v_0)))
(let ((app_1 (unsafe-mcar v_0)))
(quick-no-graph?_0
config_0
mode_0
@ -22005,7 +22005,7 @@
counter_0
cycle?_0
ht_0
(mcar v_0)
(unsafe-mcar v_0)
mode_0)
(build-graph_0
checking-port_0
@ -22014,7 +22014,7 @@
counter_0
cycle?_0
ht_0
(mcdr v_0)
(unsafe-mcdr v_0)
mode_0)
(done!_0
constructor?_0
@ -22547,12 +22547,12 @@
(begin
(if (eq? max-length_2 '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
(|#%app|
p_0
who_0
(mcar v_1)
(unsafe-mcar v_1)
mode_0
o_0
max-length_2
@ -22562,11 +22562,12 @@
(if curly?_0 "}" ")")
o_0
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 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)
#f)
#f)
@ -22574,13 +22575,13 @@
(|#%app|
p_0
who_0
(mcar v_1)
(unsafe-mcar v_1)
mode_0
o_0
max-length_2
graph_0
config_0)))
(let ((app_0 (mcdr v_1)))
(let ((app_0 (unsafe-mcdr v_1)))
(loop_0
app_0
(write-string/max " " o_0 max-length_3))))
@ -22588,7 +22589,7 @@
(|#%app|
p_0
who_0
(mcar v_1)
(unsafe-mcar v_1)
mode_0
o_0
max-length_2
@ -22602,7 +22603,7 @@
(|#%app|
p_0
who_0
(mcdr v_1)
(unsafe-mcdr v_1)
mode_0
o_0
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
jitify-schemified-linklet
xify
extract-paths-and-fasls-from-schemified-linklet
interpreter-link!
interpretable-jitified-linklet
interpret-linklet
linklet-bigger-than?
make-path->compiled-path
compiled-path->path
(rename [1/force-unfasl force-unfasl])
fasl-literal?
fasl-literals
unfasl-literals/lazy
force-unfasl-literals
prim-knowns
known-procedure
known-procedure/pure

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

@ -76,7 +76,6 @@
call-with-module-prompt
make-pthread-parameter
engine-block
force-unfasl
make-record-type-descriptor
make-record-type-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
"match.rkt"
"wrap.rkt"
"path-for-srcloc.rkt"
"to-fasl.rkt"
"interp-match.rkt"
"interp-stack.rkt"
"gensym.rkt")
@ -56,8 +54,7 @@
(set! make-interp-procedure* make-proc))
(define (interpretable-jitified-linklet linklet-e serializable?)
;; Return a compiled linklet in two parts: a vector expression for
;; constants to be run once, and a expression for the linklet body.
;; Return a compiled linklet as an expression for the linklet body.
;; Conceptually, the run-time environment is implemented as a list,
;; and identifiers are mapped to positions in that list, where 0
@ -83,41 +80,10 @@
;; the list, for example.
(define (start linklet-e)
(match linklet-e
[`(lambda . ,_)
;; No constants:
(define-values (compiled-body num-body-vars)
(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-values (compiled-body num-body-vars)
(compile-linklet-body linklet-e '#hasheq() 0))
(vector num-body-vars
compiled-body))
(define (compile-linklet-body v env stack-depth)
(match v
@ -627,35 +593,19 @@
;; ----------------------------------------
(define (interpret-linklet b ; compiled form
paths) ; unmarshaled paths
(define (interpret-linklet b)
(interp-match
b
[#(,consts ,num-body-vars ,b)
(let ([consts (and consts
(let ([vec (make-vector (vector*-length consts))])
(define stack (stack-set empty-stack 0 vec))
(for/fold ([paths paths]) ([b (in-vector consts)]
[i (in-naturals)])
(cond
[(eq? b '#%path)
(vector-set! vec i (car paths))
(cdr paths)]
[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)))]))
[#(,num-body-vars ,b)
(lambda args
(define start-stack empty-stack)
(define args-stack (for/fold ([stack start-stack]) ([arg (in-list args)]
[i (in-naturals 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)

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

@ -1,9 +1,12 @@
#lang racket/base
(require "wrap.rkt")
(require racket/unsafe/undefined
racket/extflonum
"wrap.rkt")
(provide literal?
unwrap-literal
wrap-literal)
wrap-literal
register-literal-serialization)
(define (literal? v)
(define u (unwrap v))
@ -47,3 +50,67 @@
[(eof-object? x) 'eof]
[else
`(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"
"jitify.rkt"
"xify.rkt"
"path-and-fasl.rkt"
"fasl-literal.rkt"
"interpret.rkt"
"size.rkt"
"fasl.rkt")
@ -21,9 +21,10 @@
xify
extract-paths-and-fasls-from-schemified-linklet
make-path->compiled-path
compiled-path->path
fasl-literal?
fasl-literals
unfasl-literals/lazy
force-unfasl-literals
interpreter-link!
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-state.rkt"
"left-to-right.rkt"
"serialize.rkt"
"let.rkt"
"equal.rkt"
"optimize.rkt"
@ -77,7 +76,9 @@
;; 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
;; 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?
prim-knowns primitives get-import-knowns import-keys)
(with-deterministic-gensym
@ -127,31 +128,24 @@
(for/fold ([exports (hasheq)]) ([ex-id (in-list ex-ids)])
(define id (ex-int-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
;; original source name differs from the current name
(define src-syms (get-definition-source-syms bodys))
;; Schemify the body, collecting information about defined names:
(define-values (new-body defn-info mutated)
(schemify-body* bodys/constants-lifted prim-knowns primitives imports exports
for-interp? allow-set!-undefined? add-import! #f
(schemify-body* bodys prim-knowns primitives imports exports
serializable?-box datum-intern? for-interp? allow-set!-undefined? add-import! #f
unsafe-mode? enforce-constant? allow-inline? no-prompt? #t))
(define all-grps (append grps (reverse new-grps)))
(values
;; Build `lambda` with schemified body:
(make-let*
lifted-constants
`(lambda (instance-variable-reference
,@(for*/list ([grp (in-list all-grps)]
[im (in-list (import-group-imports grp))])
(import-id im))
,@(for/list ([ex-id (in-list ex-ids)])
(export-id (hash-ref exports (ex-int-id ex-id)))))
,@new-body))
`(lambda (instance-variable-reference
,@(for*/list ([grp (in-list all-grps)]
[im (in-list (import-group-imports grp))])
(import-id im))
,@(for/list ([ex-id (in-list ex-ids)])
(export-id (hash-ref exports (ex-int-id ex-id)))))
,@new-body)
;; Imports (external names), possibly extended via inlining:
(for/list ([grp (in-list all-grps)])
(for/list ([im (in-list (import-group-imports grp))])
@ -184,7 +178,7 @@
(define id (ex-int-id ex-id))
(define v (known-inline->export-known (hash-ref defn-info id #f)
prim-knowns imports exports
serializable?))
serializable?-box))
(cond
[(not (set!ed-mutated-state? (hash-ref mutated id #f)))
(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
(define-values (new-body defn-info mutated)
(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?))
new-body))
(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?)
;; Keep simple checking efficient by caching results
(define simples (make-hasheq))
@ -283,7 +278,7 @@
prim-knowns primitives knowns mutated imports exports simples
allow-set!-undefined?
add-import!
for-cify? for-interp?
serializable?-box datum-intern? for-cify? for-interp?
unsafe-mode? allow-inline? no-prompt? explicit-unnamed?
(if (and no-prompt? (null? (cdr l)))
'tail
@ -479,7 +474,8 @@
;; a 'too-early state in `mutated` for a `letrec`-bound variable can be
;; effectively canceled with a mapping in `knowns`.
(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)
(let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [wcm-state wcm-state] [v v])
(define (schemify v wcm-state)
@ -517,7 +513,10 @@
`(define ,id ,(schemify rhs 'fresh))]
[`(define-values ,ids ,rhs)
`(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)
(schemify body wcm-state)]
[`(let-values () ,bodys ...)
@ -904,8 +903,7 @@
[`,_
(let ([u-v (unwrap v)])
(cond
[(not (symbol? u-v))
v]
[(not (symbol? u-v)) v]
[(eq? u-v 'call-with-values)
'#%call-with-values]
[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
(require "wrap.rkt"
"match.rkt"
"quoted.rkt")
"match.rkt")
;; The `linklet-bigger-than?` function is practically an S-expression
;; counter, but it parses expressions properly so it can stop at
@ -38,13 +37,7 @@
(body-leftover-size body (sub1 size))]
[`(begin0 . ,body)
(body-leftover-size body (sub1 size))]
[`(quote ,v) (if (and serializable?
(lift-quoted? v #f #t))
;; pessimistically assume that full
;; strcuture must be lifted for
;; serialization:
(s-expr-leftover-size v size)
(sub1 size))]
[`(quote ,v) (sub1 size)]
[`(set! ,id ,rhs) (leftover-size rhs (sub1 size))]
[`(#%variable-reference . ,_) (sub1 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_Y 9
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_W 7
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x