diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index e5674fc84d..f59671fd54 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -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])) diff --git a/pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-lib/compiler/decompile.rkt index fff96619ff..5d37be0645 100644 --- a/pkgs/compiler-lib/compiler/decompile.rkt +++ b/pkgs/compiler-lib/compiler/decompile.rkt @@ -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 '(....)])] diff --git a/pkgs/compiler-lib/compiler/private/chez.rkt b/pkgs/compiler-lib/compiler/private/chez.rkt index 8afdbe3d15..2180778cb4 100644 --- a/pkgs/compiler-lib/compiler/private/chez.rkt +++ b/pkgs/compiler-lib/compiler/private/chez.rkt @@ -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 diff --git a/pkgs/racket-doc/scribblings/reference/fasl.scrbl b/pkgs/racket-doc/scribblings/reference/fasl.scrbl index 7821e7a3b4..815be9b61b 100644 --- a/pkgs/racket-doc/scribblings/reference/fasl.scrbl +++ b/pkgs/racket-doc/scribblings/reference/fasl.scrbl @@ -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 diff --git a/racket/collects/racket/fasl.rkt b/racket/collects/racket/fasl.rkt index c91d7b6abb..458d57eb2c 100644 --- a/racket/collects/racket/fasl.rkt +++ b/racket/collects/racket/fasl.rkt @@ -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)) diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index 4b9b216068..f9c0fdecc7 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -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) diff --git a/racket/src/ChezScheme/s/fasl.ss b/racket/src/ChezScheme/s/fasl.ss index 1acc6d5c6b..be831c7c0c 100644 --- a/racket/src/ChezScheme/s/fasl.ss +++ b/racket/src/ChezScheme/s/fasl.ss @@ -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 diff --git a/racket/src/bc/src/cify-startup.rkt b/racket/src/bc/src/cify-startup.rkt index 996c7e9d6a..012e840bf3 100644 --- a/racket/src/bc/src/cify-startup.rkt +++ b/racket/src/bc/src/cify-startup.rkt @@ -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)) diff --git a/racket/src/bc/src/startup.inc b/racket/src/bc/src/startup.inc index 02fb7fe231..8bdd4959a9 100644 --- a/racket/src/bc/src/startup.inc +++ b/racket/src/bc/src/startup.inc @@ -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)" diff --git a/racket/src/cify/literal.rkt b/racket/src/cify/literal.rkt new file mode 100644 index 0000000000..a2bda516f7 --- /dev/null +++ b/racket/src/cify/literal.rkt @@ -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)))) diff --git a/racket/src/cs/c/cross-serve.ss b/racket/src/cs/c/cross-serve.ss index 0999784a43..0c54bed84f 100644 --- a/racket/src/cs/c/cross-serve.ss +++ b/racket/src/cs/c/cross-serve.ss @@ -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))))) diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index d669a84736..4f21d8bcd2 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -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)] diff --git a/racket/src/cs/convert.rkt b/racket/src/cs/convert.rkt index 3e0c43ee5d..30259ed446 100644 --- a/racket/src/cs/convert.rkt +++ b/racket/src/cs/convert.rkt @@ -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]))) ;; ---------------------------------------- diff --git a/racket/src/cs/expander.sls b/racket/src/cs/expander.sls index fb065b559a..86c51f04ee 100644 --- a/racket/src/cs/expander.sls +++ b/racket/src/cs/expander.sls @@ -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) diff --git a/racket/src/cs/expander/env.ss b/racket/src/cs/expander/env.ss index f35912e895..5c53e3d136 100644 --- a/racket/src/cs/expander/env.ss +++ b/racket/src/cs/expander/env.ss @@ -14,6 +14,4 @@ (thread) (io) (regexp) - (linklet) - (only (schemify) - force-unfasl))) + (linklet))) diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index ff50c7abf6..80acc6f925 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -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 ) 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) diff --git a/racket/src/cs/linklet/annotation.ss b/racket/src/cs/linklet/annotation.ss index f9e7d8a4f6..7f207ba68a 100644 --- a/racket/src/cs/linklet/annotation.ss +++ b/racket/src/cs/linklet/annotation.ss @@ -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))) diff --git a/racket/src/cs/linklet/cross-compile.ss b/racket/src/cs/linklet/cross-compile.ss index c80e289597..da412e91ac 100644 --- a/racket/src/cs/linklet/cross-compile.ss +++ b/racket/src/cs/linklet/cross-compile.ss @@ -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 ) (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)]) diff --git a/racket/src/cs/linklet/performance.ss b/racket/src/cs/linklet/performance.ss index 87714d7fba..9d8c5da5f2 100644 --- a/racket/src/cs/linklet/performance.ss +++ b/racket/src/cs/linklet/performance.ss @@ -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)] diff --git a/racket/src/cs/linklet/read.ss b/racket/src/cs/linklet/read.ss index 49a604c213..0a1b761875 100644 --- a/racket/src/cs/linklet/read.ss +++ b/racket/src/cs/linklet/read.ss @@ -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))]))) diff --git a/racket/src/cs/linklet/write.ss b/racket/src/cs/linklet/write.ss index 466190d5fd..075de0f7de 100644 --- a/racket/src/cs/linklet/write.ss +++ b/racket/src/cs/linklet/write.ss @@ -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) diff --git a/racket/src/cs/primitive/internal.ss b/racket/src/cs/primitive/internal.ss index 24fc449032..81d85395d3 100644 --- a/racket/src/cs/primitive/internal.ss +++ b/racket/src/cs/primitive/internal.ss @@ -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)] diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index 413e74ffaf..be4b24757e 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -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)] diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index 9e38e3fd89..8b4beec601 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -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) diff --git a/racket/src/cs/rumble/unsafe.ss b/racket/src/cs/rumble/unsafe.ss index 90b8fda929..9493bbe346 100644 --- a/racket/src/cs/rumble/unsafe.ss +++ b/racket/src/cs/rumble/unsafe.ss @@ -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 diff --git a/racket/src/cs/schemified/expander.scm b/racket/src/cs/schemified/expander.scm index 89d9ccb041..b067d02afd 100644 --- a/racket/src/cs/schemified/expander.scm +++ b/racket/src/cs/schemified/expander.scm @@ -23448,244 +23448,6 @@ (define fasl-hash-eqv-variant 2) (define s-exp->fasl.1 (letrec ((loop_0 - (|#%name| - loop - (lambda (external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - v_0) - (begin - (if (if external-lift_0 (hash-ref external-lift_0 v_0 #f) #f) - (void) - (if (if external-lift?7_0 - (|#%app| external-lift?7_0 v_0) - #f) - (begin - (hash-set! external-lift_0 v_0 #t) - (unsafe-set-box*! - shared-counter_0 - (add1 (unsafe-unbox* shared-counter_0))) - (hash-set! - shared_0 - v_0 - (- (unsafe-unbox* shared-counter_0)))) - (if (let ((or-part_0 (symbol? v_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 (keyword? v_0))) - (if or-part_1 - or-part_1 - (let ((or-part_2 (string? v_0))) - (if or-part_2 - or-part_2 - (let ((or-part_3 (bytes? v_0))) - (if or-part_3 - or-part_3 - (path? v_0))))))))) - (begin-unsafe - (do-hash-update - 'hash-update! - #t - hash-set! - shared_0 - v_0 - add1 - 0)) - (if (pair? v_0) - (begin - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - (car v_0)) - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - (cdr v_0))) - (if (vector? v_0) - (begin - (call-with-values - (lambda () - (begin - (check-vector v_0) - (values v_0 (unsafe-vector-length v_0)))) - (case-lambda - ((vec_0 len_0) - (begin - #f - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (pos_0) - (begin - (if (unsafe-fx< pos_0 len_0) - (let ((e_0 - (unsafe-vector-ref - vec_0 - pos_0))) - (begin - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - e_0) - (for-loop_0 - (unsafe-fx+ 1 pos_0)))) - (values))))))) - (for-loop_0 0)))) - (args - (raise-binding-result-arity-error 2 args)))) - (void)) - (if (hash? v_0) - (hash-for-each - v_0 - (lambda (k_0 v_1) - (begin - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - k_0) - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - v_1))) - #t) - (if (box? v_0) - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - (unbox v_0)) - (let ((c1_0 (prefab-struct-key v_0))) - (if c1_0 - (begin - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - c1_0) - (call-with-values - (lambda () - (unsafe-normalise-inputs - unsafe-vector-length - (struct->vector v_0) - 1 - #f - 1)) - (case-lambda - ((v*_0 start*_0 stop*_0 step*_0) - (begin - #t - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (idx_0) - (begin - (if (unsafe-fx< - idx_0 - stop*_0) - (let ((e_0 - (unsafe-vector-ref - v*_0 - idx_0))) - (begin - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - e_0) - (for-loop_0 - (unsafe-fx+ - idx_0 - 1)))) - (values))))))) - (for-loop_0 start*_0)))) - (args - (raise-binding-result-arity-error - 4 - args)))) - (void)) - (if (srcloc? v_0) - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - (srcloc-source v_0)) - (if (begin-unsafe (|#%app| syntax?$3 v_0)) - (begin - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - (begin-unsafe - (|#%app| syntax-e$4 v_0))) - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - (begin-unsafe - (|#%app| syntax-source$3 v_0))) - (let ((lst_0 - (begin-unsafe - (|#%app| - syntax-property-symbol-keys$3 - v_0)))) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (lst_1) - (begin - (if (pair? lst_1) - (let ((k_0 - (unsafe-car - lst_1))) - (let ((rest_0 - (unsafe-cdr - lst_1))) - (begin - (begin - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - k_0) - (loop_0 - external-lift?7_0 - external-lift_0 - shared-counter_0 - shared_0 - (begin-unsafe - (|#%app| - syntax-property$3 - v_0 - k_0)))) - (for-loop_0 - rest_0)))) - (values))))))) - (for-loop_0 lst_0)))) - (void)) - (void)))))))))))))))) - (loop_1 (|#%name| loop (lambda (handle-fail6_0 @@ -23710,7 +23472,7 @@ (begin-unsafe (write-byte 1 o_0)) (write-fasl-integer pos_0 o_0) (hash-remove! shared_0 v_0) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23768,7 +23530,7 @@ (if (rational? v_0) (begin (begin-unsafe (write-byte 11 o_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23776,7 +23538,7 @@ shared-counter_0 shared_0 (numerator v_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23787,7 +23549,7 @@ (if (complex? v_0) (begin (begin-unsafe (write-byte 12 o_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23795,7 +23557,7 @@ shared-counter_0 shared_0 (real-part v_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23880,7 +23642,7 @@ (write-byte 23 o_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23896,7 +23658,7 @@ (write-fasl-bytes (path->bytes v_0) o_0) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23950,7 +23712,7 @@ (write-fasl-integer 38 o_0) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23958,7 +23720,7 @@ shared-counter_0 shared_0 new-src_0) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23967,7 +23729,7 @@ shared_0 (srcloc-line v_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23976,7 +23738,7 @@ shared_0 (srcloc-column v_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -23985,7 +23747,7 @@ shared_0 (srcloc-position v_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24047,7 +23809,7 @@ (if (pair? v_1) (begin - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24061,7 +23823,7 @@ v_1))) (if normal-list?_0 (void) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24080,7 +23842,7 @@ (write-byte 30 o_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24088,7 +23850,7 @@ shared-counter_0 shared_0 (car v_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24139,7 +23901,7 @@ vec_0 pos_0))) (begin - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24171,7 +23933,7 @@ (write-byte byte_0 o_0))) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24189,7 +23951,7 @@ 35 o_0)) (begin - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24235,7 +23997,7 @@ v*_0 idx_0))) (begin - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24289,7 +24051,7 @@ (lambda (k_0 v_1) (begin - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24297,7 +24059,7 @@ shared-counter_0 shared_0 k_0) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24347,7 +24109,7 @@ (write-byte 40 o_0)) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24358,7 +24120,7 @@ (|#%app| syntax-e$4 v_0))) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24394,7 +24156,7 @@ (|#%app| syntax-span$3 v_0)))))))) - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24451,7 +24213,7 @@ 41 o_0)) (if handle-fail6_0 - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_0 @@ -24466,6 +24228,244 @@ "cannot write value" "value" v_0))))))))))))))))))))))))))))))))))) + (loop_1 + (|#%name| + loop + (lambda (external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + v_0) + (begin + (if (if external-lift_0 (hash-ref external-lift_0 v_0 #f) #f) + (void) + (if (if external-lift?7_0 + (|#%app| external-lift?7_0 v_0) + #f) + (begin + (hash-set! external-lift_0 v_0 #t) + (unsafe-set-box*! + shared-counter_0 + (add1 (unsafe-unbox* shared-counter_0))) + (hash-set! + shared_0 + v_0 + (- (unsafe-unbox* shared-counter_0)))) + (if (let ((or-part_0 (symbol? v_0))) + (if or-part_0 + or-part_0 + (let ((or-part_1 (keyword? v_0))) + (if or-part_1 + or-part_1 + (let ((or-part_2 (string? v_0))) + (if or-part_2 + or-part_2 + (let ((or-part_3 (bytes? v_0))) + (if or-part_3 + or-part_3 + (path? v_0))))))))) + (begin-unsafe + (do-hash-update + 'hash-update! + #t + hash-set! + shared_0 + v_0 + add1 + 0)) + (if (pair? v_0) + (begin + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + (car v_0)) + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + (cdr v_0))) + (if (vector? v_0) + (begin + (call-with-values + (lambda () + (begin + (check-vector v_0) + (values v_0 (unsafe-vector-length v_0)))) + (case-lambda + ((vec_0 len_0) + (begin + #f + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (pos_0) + (begin + (if (unsafe-fx< pos_0 len_0) + (let ((e_0 + (unsafe-vector-ref + vec_0 + pos_0))) + (begin + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + e_0) + (for-loop_0 + (unsafe-fx+ 1 pos_0)))) + (values))))))) + (for-loop_0 0)))) + (args + (raise-binding-result-arity-error 2 args)))) + (void)) + (if (hash? v_0) + (hash-for-each + v_0 + (lambda (k_0 v_1) + (begin + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + k_0) + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + v_1))) + #t) + (if (box? v_0) + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + (unbox v_0)) + (let ((c1_0 (prefab-struct-key v_0))) + (if c1_0 + (begin + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + c1_0) + (call-with-values + (lambda () + (unsafe-normalise-inputs + unsafe-vector-length + (struct->vector v_0) + 1 + #f + 1)) + (case-lambda + ((v*_0 start*_0 stop*_0 step*_0) + (begin + #t + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (idx_0) + (begin + (if (unsafe-fx< + idx_0 + stop*_0) + (let ((e_0 + (unsafe-vector-ref + v*_0 + idx_0))) + (begin + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + e_0) + (for-loop_0 + (unsafe-fx+ + idx_0 + 1)))) + (values))))))) + (for-loop_0 start*_0)))) + (args + (raise-binding-result-arity-error + 4 + args)))) + (void)) + (if (srcloc? v_0) + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + (srcloc-source v_0)) + (if (begin-unsafe (|#%app| syntax?$3 v_0)) + (begin + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + (begin-unsafe + (|#%app| syntax-e$4 v_0))) + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + (begin-unsafe + (|#%app| syntax-source$3 v_0))) + (let ((lst_0 + (begin-unsafe + (|#%app| + syntax-property-symbol-keys$3 + v_0)))) + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (lst_1) + (begin + (if (pair? lst_1) + (let ((k_0 + (unsafe-car + lst_1))) + (let ((rest_0 + (unsafe-cdr + lst_1))) + (begin + (begin + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + k_0) + (loop_1 + external-lift?7_0 + external-lift_0 + shared-counter_0 + shared_0 + (begin-unsafe + (|#%app| + syntax-property$3 + v_0 + k_0)))) + (for-loop_0 + rest_0)))) + (values))))))) + (for-loop_0 lst_0)))) + (void)) + (void)))))))))))))))) (treat-immutable?_0 (|#%name| treat-immutable? @@ -24478,17 +24478,18 @@ (lambda (external-lift?7_0 handle-fail6_0 keep-mutable?5_0 - v12_0 - orig-o11_0) + skip-prefix?8_0 + v14_0 + orig-o13_0) (begin (begin - (if orig-o11_0 - (if (output-port? orig-o11_0) + (if orig-o13_0 + (if (output-port? orig-o13_0) (void) (raise-argument-error 's-exp->fasl "(or/c output-port? #f)" - orig-o11_0)) + orig-o13_0)) (void)) (begin (if handle-fail6_0 @@ -24512,35 +24513,37 @@ "(or/c (procedure-arity-includes/c 1) #f)" external-lift?7_0)) (void)) - (let ((o_0 (if orig-o11_0 orig-o11_0 (open-output-bytes)))) + (let ((o_0 (if orig-o13_0 orig-o13_0 (open-output-bytes)))) (let ((shared_0 (make-hasheq))) (let ((external-lift_0 (if external-lift?7_0 (make-hasheq) #f))) (let ((shared-counter_0 (box 0))) (begin - (loop_0 + (loop_1 external-lift?7_0 external-lift_0 shared-counter_0 shared_0 - v12_0) + v14_0) (let ((path->relative-path-elements_0 (make-path->relative-path-elements.1 #f unsafe-undefined))) (begin - (1/write-bytes fasl-prefix o_0) + (if skip-prefix?8_0 + (void) + (1/write-bytes fasl-prefix o_0)) (let ((bstr_0 (let ((o_1 (open-output-bytes))) (begin - (loop_1 + (loop_0 handle-fail6_0 keep-mutable?5_0 o_1 path->relative-path-elements_0 shared-counter_0 shared_0 - v12_0) + v14_0) (get-output-bytes o_1 #t))))) (begin (write-fasl-integer @@ -24550,19 +24553,19 @@ (unsafe-bytes-length bstr_0) o_0) (1/write-bytes bstr_0 o_0) - (if orig-o11_0 + (if orig-o13_0 (void) (get-output-bytes o_0))))))))))))))))))) (define fasl->s-exp.1 (letrec ((intern_0 (|#%name| intern - (lambda (datum-intern?14_0 v_0) - (begin (if datum-intern?14_0 (datum-intern-literal v_0) v_0))))) + (lambda (datum-intern?16_0 v_0) + (begin (if datum-intern?16_0 (datum-intern-literal v_0) v_0))))) (loop_0 (|#%name| loop - (lambda (datum-intern?14_0 i_0 shared-count_0 shared_0) + (lambda (datum-intern?16_0 i_0 shared-count_0 shared_0) (begin (let ((type_0 (read-byte/no-eof i_0))) (let ((index_0 @@ -24628,10 +24631,10 @@ "tag" type_0)) (if (unsafe-fx< index_0 2) - (let ((pos_0 (read-fasl-integer i_0))) + (let ((pos_0 (|#%app| read-fasl-integer i_0))) (let ((v_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -24642,7 +24645,7 @@ (vector-set! shared_0 pos_0 v_0) v_0))) (if (unsafe-fx< index_0 3) - (let ((pos_0 (read-fasl-integer i_0))) + (let ((pos_0 (|#%app| read-fasl-integer i_0))) (begin (if (< pos_0 shared-count_0) (void) @@ -24656,8 +24659,8 @@ (if (unsafe-fx< index_0 8) eof (intern_0 - datum-intern?14_0 - (read-fasl-integer i_0)))))) + datum-intern?16_0 + (|#%app| read-fasl-integer i_0)))))) (if (unsafe-fx< index_0 14) (if (unsafe-fx< index_0 11) (if (unsafe-fx< index_0 10) @@ -24671,77 +24674,81 @@ (if (unsafe-fx< index_0 12) (let ((bstr_0 (read-bytes/exactly - (read-fasl-integer i_0) + (|#%app| read-fasl-integer i_0) i_0))) - (1/string->number - (bytes->string/utf-8 bstr_0) - 10 - 'read)) + (let ((app_0 1/string->number)) + (|#%app| + app_0 + (bytes->string/utf-8 bstr_0) + 10 + 'read))) (if (unsafe-fx< index_0 13) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (/ app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)))) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (make-rectangular app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))))))) (if (unsafe-fx< index_0 16) (if (unsafe-fx< index_0 15) (intern_0 - datum-intern?14_0 - (integer->char (read-fasl-integer i_0))) - (string->symbol (read-fasl-string i_0))) + datum-intern?16_0 + (integer->char + (|#%app| read-fasl-integer i_0))) + (string->symbol (|#%app| read-fasl-string i_0))) (if (unsafe-fx< index_0 17) (string->unreadable-symbol - (read-fasl-string i_0)) + (|#%app| read-fasl-string i_0)) (if (unsafe-fx< index_0 18) (string->uninterned-symbol - (read-fasl-string i_0)) + (|#%app| read-fasl-string i_0)) (if (unsafe-fx< index_0 19) - (string->keyword (read-fasl-string i_0)) - (read-fasl-string i_0))))))) + (string->keyword + (|#%app| read-fasl-string i_0)) + (|#%app| read-fasl-string i_0))))))) (if (unsafe-fx< index_0 30) (if (unsafe-fx< index_0 24) (if (unsafe-fx< index_0 21) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (string->immutable-string - (read-fasl-string i_0))) + (|#%app| read-fasl-string i_0))) (if (unsafe-fx< index_0 22) (read-fasl-bytes i_0) (if (unsafe-fx< index_0 23) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (bytes->immutable-bytes (read-fasl-bytes i_0))) (let ((app_0 (read-fasl-bytes i_0))) (bytes->path app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)))))) @@ -24753,7 +24760,7 @@ (reverse$1 (let ((lst_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -24793,21 +24800,22 @@ (build-path 'same) (apply build-path rel-elems_0))))) (intern_0 - datum-intern?14_0 - (pregexp (read-fasl-string i_0)))) + datum-intern?16_0 + (pregexp (|#%app| read-fasl-string i_0)))) (if (unsafe-fx< index_0 27) (intern_0 - datum-intern?14_0 - (regexp (read-fasl-string i_0))) + datum-intern?16_0 + (regexp (|#%app| read-fasl-string i_0))) (if (unsafe-fx< index_0 28) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (byte-pregexp (read-fasl-bytes i_0))) (if (unsafe-fx< index_0 29) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (byte-regexp (read-fasl-bytes i_0))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 + (|#%app| read-fasl-integer i_0))) (reverse$1 (begin (letrec* @@ -24821,7 +24829,7 @@ (let ((fold-var_1 (cons (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0) @@ -24838,26 +24846,26 @@ (if (unsafe-fx< index_0 31) (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (cons app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (ploop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0 len_0))) (if (unsafe-fx< index_0 33) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (let ((vec_0 (begin (if (exact-nonnegative-integer? @@ -24886,7 +24894,7 @@ v_0 i_1 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)) @@ -24917,13 +24925,13 @@ (if (unsafe-fx< index_0 34) (box (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)) (box-immutable (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))))) @@ -24931,11 +24939,11 @@ (if (unsafe-fx< index_0 36) (let ((key_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (apply make-prefab-struct key_0 @@ -24952,7 +24960,7 @@ (let ((fold-var_1 (cons (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0) @@ -24971,7 +24979,7 @@ (if (eq? tmp_0 2) (make-hasheqv) (make-hash)))))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (begin (begin (letrec* @@ -24984,7 +24992,7 @@ (begin (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -24992,7 +25000,7 @@ ht_0 app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -25009,7 +25017,7 @@ (if (eq? tmp_0 2) hash2589 hash2725))))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (begin (letrec* ((for-loop_0 @@ -25022,7 +25030,7 @@ (let ((ht_2 (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -25030,7 +25038,7 @@ ht_1 app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))))) @@ -25041,25 +25049,25 @@ (if (unsafe-fx< index_0 39) (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (let ((app_1 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (let ((app_2 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (let ((app_3 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -25069,20 +25077,20 @@ app_2 app_3 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)))))) (if (unsafe-fx< index_0 40) (let ((e_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (let ((s_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -25107,7 +25115,7 @@ s_0))))))))) (let ((lst_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -25152,48 +25160,50 @@ (ploop_0 (|#%name| ploop - (lambda (datum-intern?14_0 i_0 shared-count_0 shared_0 len_0) + (lambda (datum-intern?16_0 i_0 shared-count_0 shared_0 len_0) (begin (if (zero? len_0) - (loop_0 datum-intern?14_0 i_0 shared-count_0 shared_0) + (loop_0 datum-intern?16_0 i_0 shared-count_0 shared_0) (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (cons app_0 (ploop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0 (sub1 len_0)))))))))) (|#%name| fasl->s-exp - (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 (let ((external-lifts_0 - (if (eq? external-lifts15_0 unsafe-undefined) + (if (eq? external-lifts17_0 unsafe-undefined) '#() - external-lifts15_0))) + external-lifts17_0))) (let ((init-i_0 - (if (bytes? orig-i18_0) - (mcons orig-i18_0 0) - (if (input-port? orig-i18_0) - orig-i18_0 + (if (bytes? orig-i22_0) + (mcons orig-i22_0 0) + (if (input-port? orig-i22_0) + orig-i22_0 (raise-argument-error 'fasl->s-exp "(or/c bytes? input-port?)" - orig-i18_0))))) + orig-i22_0))))) (begin - (if (bytes=? - (read-bytes/exactly fasl-prefix-length init-i_0) - fasl-prefix) + (if skip-prefix?18_0 (void) - (read-error "unrecognized prefix")) - (let ((shared-count_0 (read-fasl-integer init-i_0))) + (if (bytes=? + (read-bytes/exactly* fasl-prefix-length init-i_0) + fasl-prefix) + (void) + (read-error "unrecognized prefix"))) + (let ((shared-count_0 (read-fasl-integer* init-i_0))) (let ((shared_0 (make-vector shared-count_0))) (begin (if (if (vector? external-lifts_0) @@ -25242,15 +25252,15 @@ (values))))))) (for-loop_0 0 start_0)))))) (args (raise-binding-result-arity-error 2 args)))) - (let ((len_0 (read-fasl-integer init-i_0))) + (let ((len_0 (read-fasl-integer* init-i_0))) (let ((i_0 (if (mpair? init-i_0) init-i_0 (let ((bstr_0 - (read-bytes/exactly len_0 init-i_0))) + (read-bytes/exactly* len_0 init-i_0))) (mcons bstr_0 0))))) (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))))))))))))))) @@ -25297,30 +25307,37 @@ (string-append "error parsing fasl stream;\n" " " s_0) args_0))) (define read-byte/no-eof + (lambda (i_0) + (let ((pos_0 (unsafe-mcdr i_0))) + (begin + (if (< pos_0 (unsafe-bytes-length (unsafe-mcar i_0))) + (void) + (read-error "truncated stream")) + (unsafe-set-mcdr! i_0 (fx+ pos_0 1)) + (unsafe-bytes-ref (unsafe-mcar i_0) pos_0))))) +(define read-byte/no-eof* (lambda (i_0) (if (mpair? i_0) - (let ((pos_0 (mcdr i_0))) - (begin - (if (< pos_0 (unsafe-bytes-length (mcar i_0))) - (void) - (read-error "truncated stream")) - (set-mcdr! i_0 (add1 pos_0)) - (unsafe-bytes-ref (mcar i_0) pos_0))) + (read-byte/no-eof i_0) (let ((b_0 (read-byte i_0))) (begin (if (eof-object? b_0) (read-error "truncated stream") (void)) b_0))))) (define read-bytes/exactly + (lambda (n_0 i_0) + (let ((pos_0 (unsafe-mcdr i_0))) + (begin + (if (let ((app_0 (+ pos_0 n_0))) + (<= app_0 (unsafe-bytes-length (unsafe-mcar i_0)))) + (void) + (read-error "truncated stream")) + (unsafe-set-mcdr! i_0 (fx+ pos_0 n_0)) + (let ((app_0 (unsafe-mcar i_0))) + (subbytes app_0 pos_0 (fx+ pos_0 n_0))))))) +(define read-bytes/exactly* (lambda (n_0 i_0) (if (mpair? i_0) - (let ((pos_0 (mcdr i_0))) - (begin - (if (let ((app_0 (+ pos_0 n_0))) - (<= app_0 (unsafe-bytes-length (mcar i_0)))) - (void) - (read-error "truncated stream")) - (set-mcdr! i_0 (+ pos_0 n_0)) - (let ((app_0 (mcar i_0))) (subbytes app_0 pos_0 (+ pos_0 n_0))))) + (read-bytes/exactly n_0 i_0) (let ((bstr_0 (read-bytes n_0 i_0))) (begin (if (if (bytes? bstr_0) (= n_0 (unsafe-bytes-length bstr_0)) #f) @@ -25330,45 +25347,133 @@ (define read-fasl-integer (lambda (i_0) (let ((b_0 (read-byte/no-eof i_0))) - (if (<= b_0 127) + (if (fx<= b_0 127) b_0 - (if (>= b_0 132) - (- b_0 256) + (if (fx>= b_0 132) + (fx- b_0 256) (if (eqv? b_0 128) - (integer-bytes->integer (read-bytes/exactly 2 i_0) #t #f) + (let ((lo_0 (read-byte/no-eof i_0))) + (let ((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) - (integer-bytes->integer (read-bytes/exactly 4 i_0) #t #f) + (let ((a_0 (read-byte/no-eof i_0))) + (let ((b_1 (read-byte/no-eof i_0))) + (let ((c_0 (read-byte/no-eof i_0))) + (let ((d_0 (read-byte/no-eof i_0))) + (bitwise-ior + a_0 + (arithmetic-shift + (if (fx> d_0 127) + (let ((app_0 (fxlshift (fx+ -256 d_0) 16))) + (fxior app_0 (fxlshift c_0 8) b_1)) + (let ((app_0 (fxlshift d_0 16))) + (fxior app_0 (fxlshift c_0 8) b_1))) + 8)))))) (if (eqv? b_0 130) (integer-bytes->integer (read-bytes/exactly 8 i_0) #t #f) (if (eqv? b_0 131) - (let ((len_0 (read-fasl-integer i_0))) - (let ((str_0 (read-fasl-string i_0 len_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) + (let ((str_0 (|#%app| read-fasl-string i_0 len_0))) (begin (if (if (string? str_0) (= len_0 (string-length str_0)) #f) (void) (read-error "truncated stream at number")) - (1/string->number str_0 16)))) + (|#%app| 1/string->number str_0 16)))) + (read-error "internal error on integer mode")))))))))) +(define read-fasl-integer* + (lambda (i_0) + (let ((b_0 (read-byte/no-eof* i_0))) + (if (fx<= b_0 127) + b_0 + (if (fx>= b_0 132) + (fx- b_0 256) + (if (eqv? b_0 128) + (let ((lo_0 (read-byte/no-eof* i_0))) + (let ((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 ((a_0 (read-byte/no-eof* i_0))) + (let ((b_1 (read-byte/no-eof* i_0))) + (let ((c_0 (read-byte/no-eof* i_0))) + (let ((d_0 (read-byte/no-eof* i_0))) + (bitwise-ior + a_0 + (arithmetic-shift + (if (fx> d_0 127) + (let ((app_0 (fxlshift (fx+ -256 d_0) 16))) + (fxior app_0 (fxlshift c_0 8) b_1)) + (let ((app_0 (fxlshift d_0 16))) + (fxior app_0 (fxlshift c_0 8) b_1))) + 8)))))) + (if (eqv? b_0 130) + (integer-bytes->integer (read-bytes/exactly* 8 i_0) #t #f) + (if (eqv? b_0 131) + (let ((len_0 (|#%app| read-fasl-integer i_0))) + (let ((str_0 (|#%app| read-fasl-string i_0 len_0))) + (begin + (if (if (string? str_0) + (= len_0 (string-length str_0)) + #f) + (void) + (read-error "truncated stream at number")) + (|#%app| 1/string->number str_0 16)))) (read-error "internal error on integer mode")))))))))) (define read-fasl-string (let ((read-fasl-string_0 (|#%name| read-fasl-string - (lambda (i21_0 len20_0) + (lambda (i25_0 len24_0) (begin (let ((len_0 - (if (eq? len20_0 unsafe-undefined) - (read-fasl-integer i21_0) - len20_0))) - (let ((bstr_0 (read-bytes/exactly len_0 i21_0))) - (bytes->string/utf-8 bstr_0)))))))) + (if (eq? len24_0 unsafe-undefined) + (|#%app| read-fasl-integer i25_0) + len24_0))) + (let ((pos_0 (unsafe-mcdr i25_0))) + (let ((bstr_0 (unsafe-mcar i25_0))) + (if (<= (+ pos_0 len_0) (unsafe-bytes-length bstr_0)) + (begin + (unsafe-set-mcdr! i25_0 (fx+ pos_0 len_0)) + (let ((s_0 (make-string len_0))) + (letrec* + ((loop_0 + (|#%name| + loop + (lambda (i_0) + (begin + (if (fx= i_0 len_0) + s_0 + (let ((c_0 + (unsafe-bytes-ref + bstr_0 + (fx+ i_0 pos_0)))) + (if (fx<= c_0 128) + (begin + (string-set! + s_0 + i_0 + (integer->char c_0)) + (loop_0 (fx+ i_0 1))) + (bytes->string/utf-8 + bstr_0 + #f + pos_0 + (fx+ pos_0 len_0)))))))))) + (loop_0 0)))) + (let ((bstr_1 (read-bytes/exactly len_0 i25_0))) + (bytes->string/utf-8 bstr_1))))))))))) (case-lambda ((i_0) (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 read-fasl-bytes (lambda (i_0) - (let ((len_0 (read-fasl-integer i_0))) (read-bytes/exactly len_0 i_0)))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) + (read-bytes/exactly len_0 i_0)))) (define struct:mpi-intern-table (make-record-type-descriptor* 'mpi-intern-table #f #f #f #f 2 3)) (define effect_2419 @@ -25520,7 +25625,7 @@ (begin (begin-unsafe (hash-set! built-in-symbols built-in-s_0 #t)) built-in-s_0)))) -(define effect_2489 +(define effect_3040 (begin (void (begin @@ -25571,7 +25676,6 @@ call-with-module-prompt make-pthread-parameter engine-block - force-unfasl make-record-type-descriptor make-record-type-descriptor* make-record-constructor-descriptor @@ -35486,7 +35590,7 @@ temp15_0))))))))) (define struct:compiled-in-memory (make-record-type-descriptor* 'compiled-in-memory #f #f #f #f 13 8191)) -(define effect_2491 +(define effect_2489 (struct-type-install-properties! struct:compiled-in-memory 'compiled-in-memory @@ -36264,7 +36368,8 @@ (void))) (define write-correlated-linklet-bundle-hash (lambda (ht_0 o_0) - (let ((temp7_0 (->faslable ht_0))) (s-exp->fasl.1 #f #f #f temp7_0 o_0)))) + (let ((temp7_0 (->faslable ht_0))) + (s-exp->fasl.1 #f #f #f #f temp7_0 o_0)))) (define ->faslable (lambda (v_0) (if (pair? v_0) @@ -36431,7 +36536,7 @@ (->faslable (correlated-linklet-name v_0)))) v_0)))))) (define read-correlated-linklet-bundle-hash - (lambda (in_0) (faslable-> (fasl->s-exp.1 #t unsafe-undefined in_0)))) + (lambda (in_0) (faslable-> (fasl->s-exp.1 #t unsafe-undefined #f in_0)))) (define faslable-> (lambda (v_0) (if (pair? v_0) @@ -62226,13 +62331,13 @@ (let ((start_0 (if (string? start2_0) (let ((or-part_0 - (1/string->number start2_0))) + (|#%app| 1/string->number start2_0))) (if or-part_0 or-part_0 0)) start2_0))) (let ((end_0 (if (string? end3_0) (let ((or-part_0 - (1/string->number end3_0))) + (|#%app| 1/string->number end3_0))) (if or-part_0 or-part_0 0)) (if end3_0 end3_0 (file-size path_0))))) (let ((temp10_0 @@ -66381,7 +66486,8 @@ 'string->number "(or/c 'single 'double)" single-mode_0)) - (unchecked-string->number + (|#%app| + unchecked-string->number s5_0 radix1_0 convert-mode2_0 @@ -66429,7 +66535,8 @@ (define unchecked-string->number (lambda (s_0 radix_0 convert-mode_0 decimal-mode_0 single-mode_0) (let ((temp46_0 (string-length s_0))) - (do-string->number.1 + (|#%app| + do-string->number.1 #f s_0 0 diff --git a/racket/src/cs/schemified/io.scm b/racket/src/cs/schemified/io.scm index 72496453ae..54f5155b99 100644 --- a/racket/src/cs/schemified/io.scm +++ b/racket/src/cs/schemified/io.scm @@ -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 diff --git a/racket/src/cs/schemified/schemify.scm b/racket/src/cs/schemified/schemify.scm index 09e699b2ed..8ac461020c 100644 --- a/racket/src/cs/schemified/schemify.scm +++ b/racket/src/cs/schemified/schemify.scm @@ -160,36 +160,6 @@ (let ((or-part_1 (relative-path? s_0))) (if or-part_1 or-part_1 (absolute-path? s_0))) #f))))) -(define-values - (prop:keyword-impersonator keyword-impersonator? keyword-impersonator-ref) - (make-struct-type-property 'keyword-impersonator)) -(define keyword-procedure-impersonator-of - (lambda (v_0) - (if (keyword-impersonator? v_0) - (|#%app| (keyword-impersonator-ref v_0) v_0) - #f))) -(define-values - (struct:keyword-procedure - mk-kw-proc - keyword-procedure? - keyword-procedure-ref - keyword-procedure-set!) - (make-struct-type - 'keyword-procedure - #f - 4 - 0 - #f - (list - (cons prop:checked-procedure #t) - (cons prop:impersonator-of keyword-procedure-impersonator-of)) - (current-inspector) - #f - '(0 1 2 3))) -(define keyword-procedure-required - (make-struct-field-accessor keyword-procedure-ref 2)) -(define keyword-procedure-allowed - (make-struct-field-accessor keyword-procedure-ref 3)) (define-values (prop:procedure-accessor procedure-accessor? procedure-accessor-ref) (make-struct-type-property @@ -205,22 +175,6 @@ #f (list (cons prop:procedure values) (cons prop:procedure-accessor values)) #t)) -(define procedure-keywords - (lambda (p_0) - (if (keyword-procedure? p_0) - (let ((app_0 (keyword-procedure-required p_0))) - (values app_0 (keyword-procedure-allowed p_0))) - (if (procedure? p_0) - (if (new-procedure? p_0) - (let ((v_0 (new-procedure-ref p_0))) - (if (procedure? v_0) - (procedure-keywords v_0) - (let ((a_0 (procedure-accessor-ref p_0))) - (if a_0 - (procedure-keywords (|#%app| a_0 p_0)) - (values null null))))) - (values null null)) - (raise-argument-error 'procedure-keywords "procedure?" p_0))))) (define check-struct-type (lambda (name_0 what_0) (begin @@ -2001,234 +1955,6 @@ v_0 2)))))))) (define empty-stream (make-do-stream (lambda () #t) void void)) -(define map_2960 - (|#%name| - map - (letrec ((loop_0 - (|#%name| - loop - (lambda (f_0 l1_0 l2_0) - (begin - (if (null? l1_0) - null - (let ((r1_0 (cdr l1_0))) - (let ((r2_0 (cdr l2_0))) - (let ((r1_1 r1_0)) - (let ((app_0 - (let ((app_0 (car l1_0))) - (|#%app| f_0 app_0 (car l2_0))))) - (cons app_0 (loop_0 f_0 r1_1 r2_0))))))))))) - (loop_1 - (|#%name| - loop - (lambda (f_0 l_0) - (begin - (if (null? l_0) - null - (let ((r_0 (cdr l_0))) - (let ((app_0 (|#%app| f_0 (car l_0)))) - (cons app_0 (loop_1 f_0 r_0)))))))))) - (case-lambda - ((f_0 l_0) (begin (loop_1 f_0 l_0))) - ((f_0 l1_0 l2_0) (loop_0 f_0 l1_0 l2_0)) - ((f_0 l_0 . args_0) (gen-map f_0 (cons l_0 args_0))))))) -(define andmap_2344 - (|#%name| - andmap - (case-lambda - ((f_0 l_0) - (begin - (if (null? l_0) - #t - (letrec* - ((loop_0 - (|#%name| - loop - (lambda (l_1) - (begin - (if (null? (cdr l_1)) - (|#%app| f_0 (car l_1)) - (let ((r_0 (cdr l_1))) - (if (|#%app| f_0 (car l_1)) (loop_0 r_0) #f)))))))) - (loop_0 l_0))))) - ((f_0 l1_0 l2_0) - (if (null? l1_0) - #t - (letrec* - ((loop_0 - (|#%name| - loop - (lambda (l1_1 l2_1) - (begin - (if (null? (cdr l1_1)) - (let ((app_0 (car l1_1))) (|#%app| f_0 app_0 (car l2_1))) - (let ((r1_0 (cdr l1_1))) - (let ((r2_0 (cdr l2_1))) - (let ((r1_1 r1_0)) - (if (let ((app_0 (car l1_1))) - (|#%app| f_0 app_0 (car l2_1))) - (loop_0 r1_1 r2_0) - #f)))))))))) - (loop_0 l1_0 l2_0)))) - ((f_0 l_0 . args_0) (gen-andmap f_0 (cons l_0 args_0)))))) -(define check-args - (letrec ((loop_0 - (|#%name| - loop - (lambda (kws_0) - (begin - (if (null? kws_0) - null - (let ((app_0 - (string-append "#:" (keyword->string (car kws_0))))) - (list* " " app_0 (loop_0 (cdr kws_0))))))))) - (loop_1 - (|#%name| - loop - (lambda (w_0 ls_0) - (begin - (if (null? ls_0) - null - (let ((app_0 - (string-append - "\n " - (let ((app_0 (error-value->string-handler))) - (|#%app| app_0 (car ls_0) w_0))))) - (cons app_0 (loop_1 w_0 (cdr ls_0)))))))))) - (lambda (who_0 f_0 ls_0) - (begin - (if (procedure? f_0) - (void) - (raise-argument-error who_0 "procedure?" f_0)) - (letrec* - ((loop_2 - (|#%name| - loop - (lambda (prev-len_0 ls_1 i_0) - (begin - (if (null? ls_1) - (void) - (let ((l_0 (car ls_1))) - (begin - (if (list? l_0) - (void) - (raise-argument-error who_0 "list?" l_0)) - (let ((len_0 (length l_0))) - (begin - (if (if prev-len_0 (not (= len_0 prev-len_0)) #f) - (raise-arguments-error - who_0 - "all lists must have same size" - "first list length" - prev-len_0 - "other list length" - len_0 - "procedure" - f_0) - (void)) - (let ((app_0 (cdr ls_1))) - (loop_2 len_0 app_0 (add1 i_0))))))))))))) - (loop_2 #f ls_0 1)) - (if (procedure-arity-includes? f_0 (length ls_0)) - (void) - (call-with-values - (lambda () (procedure-keywords f_0)) - (case-lambda - ((required-keywords_0 optional-keywords_0) - (let ((app_0 - (if (pair? required-keywords_0) - (string-append - "argument mismatch;\n" - " the given procedure expects keyword arguments") - (string-append - "argument mismatch;\n" - " the given procedure's expected number of arguments does not match" - " the given number of lists")))) - (let ((app_1 - (unquoted-printing-string - (let ((or-part_0 - (let ((n_0 (object-name f_0))) - (if (symbol? n_0) (symbol->string n_0) #f)))) - (if or-part_0 or-part_0 "#"))))) - (apply - raise-arguments-error - who_0 - app_0 - "given procedure" - app_1 - (let ((app_2 - (let ((a_0 (procedure-arity f_0))) - (if (pair? required-keywords_0) - null - (if (integer? a_0) - (list "expected" a_0) - (if (arity-at-least? a_0) - (list - "expected" - (unquoted-printing-string - (string-append - "at least " - (number->string - (arity-at-least-value a_0))))) - null)))))) - (let ((app_3 - (if (pair? required-keywords_0) - null - (list "given" (length ls_0))))) - (let ((app_4 - (if (pair? required-keywords_0) - (list - "required keywords" - (unquoted-printing-string - (apply - string-append - (cdr (loop_0 required-keywords_0))))) - null))) - (append - app_2 - app_3 - app_4 - (let ((w_0 - (let ((app_5 (error-print-width))) - (quotient app_5 (length ls_0))))) - (if (> w_0 10) - (list - "argument lists..." - (unquoted-printing-string - (apply string-append (loop_1 w_0 ls_0)))) - null)))))))))) - (args (raise-binding-result-arity-error 2 args))))))))) -(define gen-map - (letrec ((loop_0 - (|#%name| - loop - (lambda (f_0 ls_0) - (begin - (if (null? (car ls_0)) - null - (let ((next-ls_0 (map_2960 cdr ls_0))) - (let ((app_0 (apply f_0 (map_2960 car ls_0)))) - (cons app_0 (loop_0 f_0 next-ls_0)))))))))) - (lambda (f_0 ls_0) (begin #t (loop_0 f_0 ls_0))))) -(define gen-andmap - (lambda (f_0 ls_0) - (begin - #t - (letrec* - ((loop_0 - (|#%name| - loop - (lambda (ls_1) - (begin - (if (null? (car ls_1)) - #t - (if (null? (cdar ls_1)) - (apply f_0 (map_2960 car ls_1)) - (let ((next-ls_0 (map_2960 cdr ls_1))) - (if (apply f_0 (map_2960 car ls_1)) - (loop_0 next-ls_0) - #f))))))))) - (loop_0 ls_0))))) (define hash-keys (letrec ((loop_0 (|#%name| @@ -8804,6 +8530,203 @@ (if (void? x_0) (list 'quote (void)) (if (eof-object? x_0) 'eof (list 'quote x_0)))))) +(define register-literal-serialization + (letrec ((check-register_0 + (|#%name| + check-register + (lambda (datum-intern?_0 serializable?-box_0 q_0 seen_0) + (begin + (if (symbol? q_0) + (if (let ((or-part_0 (symbol-interned? q_0))) + (if or-part_0 or-part_0 (symbol-unreadable? q_0))) + (void) + (register!_0 serializable?-box_0 q_0)) + (if (let ((or-part_0 (null? q_0))) + (if or-part_0 + or-part_0 + (let ((or-part_1 (number? q_0))) + (if or-part_1 + or-part_1 + (let ((or-part_2 (char? q_0))) + (if or-part_2 + or-part_2 + (let ((or-part_3 (boolean? q_0))) + (if or-part_3 + or-part_3 + (let ((or-part_4 (eof-object? q_0))) + (if or-part_4 + or-part_4 + (let ((or-part_5 (void? q_0))) + (if or-part_5 + or-part_5 + (eq? + q_0 + unsafe-undefined))))))))))))) + (void) + (if (let ((or-part_0 (string? q_0))) + (if or-part_0 or-part_0 (bytes? q_0))) + (if datum-intern?_0 + (register!_0 serializable?-box_0 q_0) + (void)) + (if (pair? q_0) + (if (hash-ref seen_0 q_0 #f) + (raise-arguments-error + 'compile + "cannot compile cyclic value" + "value" + q_0) + (let ((seen_1 (hash-set seen_0 q_0 #t))) + (begin + (check-register_0 + datum-intern?_0 + serializable?-box_0 + (car q_0) + seen_1) + (check-register_0 + datum-intern?_0 + serializable?-box_0 + (cdr q_0) + seen_1)))) + (if (vector? q_0) + (if (hash-ref seen_0 q_0 #f) + (raise-arguments-error + 'compile + "cannot compile cyclic value" + "value" + q_0) + (let ((seen_1 (hash-set seen_0 q_0 #t))) + (begin + (call-with-values + (lambda () + (begin + (check-vector q_0) + (values q_0 (unsafe-vector-length q_0)))) + (case-lambda + ((vec_0 len_0) + (begin + #f + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (pos_0) + (begin + (if (unsafe-fx< pos_0 len_0) + (let ((e_0 + (unsafe-vector-ref + vec_0 + pos_0))) + (begin + (check-register_0 + datum-intern?_0 + serializable?-box_0 + e_0 + seen_1) + (for-loop_0 + (unsafe-fx+ 1 pos_0)))) + (values))))))) + (for-loop_0 0)))) + (args + (raise-binding-result-arity-error + 2 + args)))) + (void)))) + (if (hash? q_0) + (begin + (register!_0 serializable?-box_0 q_0) + (if (hash-ref seen_0 q_0 #f) + (raise-arguments-error + 'compile + "cannot compile cyclic value" + "value" + q_0) + (let ((seen_1 (hash-set seen_0 q_0 #t))) + (begin + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (i_0) + (begin + (if i_0 + (call-with-values + (lambda () + (hash-iterate-key+value + q_0 + i_0)) + (case-lambda + ((k_0 v_0) + (begin + (begin + (check-register_0 + datum-intern?_0 + serializable?-box_0 + k_0 + seen_1) + (check-register_0 + datum-intern?_0 + serializable?-box_0 + v_0 + seen_1)) + (for-loop_0 + (hash-iterate-next + q_0 + i_0)))) + (args + (raise-binding-result-arity-error + 2 + args)))) + (values))))))) + (for-loop_0 (hash-iterate-first q_0)))) + (void))))) + (if (box? q_0) + (if (hash-ref seen_0 q_0 #f) + (raise-arguments-error + 'compile + "cannot compile cyclic value" + "value" + q_0) + (let ((seen_1 (hash-set seen_0 q_0 #t))) + (check-register_0 + datum-intern?_0 + serializable?-box_0 + (unbox q_0) + seen_1))) + (if (srcloc? q_0) + (begin + (register!_0 serializable?-box_0 q_0) + (srcloc-source q_0)) + (if (prefab-struct-key q_0) + (begin + (register!_0 serializable?-box_0 q_0) + (if (hash-ref seen_0 q_0 #f) + (raise-arguments-error + 'compile + "cannot compile cyclic value" + "value" + q_0) + (let ((seen_1 (hash-set seen_0 q_0 #t))) + (check-register_0 + datum-intern?_0 + serializable?-box_0 + (struct->vector q_0) + seen_1)))) + (register!_0 + serializable?-box_0 + q_0)))))))))))))) + (register!_0 + (|#%name| + register! + (lambda (serializable?-box_0 q_0) + (begin + (begin + (if (unbox serializable?-box_0) + (void) + (set-box! serializable?-box_0 (make-hasheq))) + (hash-set! (unbox serializable?-box_0) q_0 #t))))))) + (lambda (q_0 serializable?-box_0 datum-intern?_0) + (check-register_0 datum-intern?_0 serializable?-box_0 q_0 hash2610)))) (define try-fold-primitive (letrec ((procz1 (lambda args_0 (error "missing")))) (lambda (orig-prim-sym_0 orig-k_0 exps_0 prim-knowns_0 primitives_0) @@ -20380,3355 +20303,6 @@ 'raise-binding-result-arity-error (length ids_0) '(args)))))))))))) -(define prefab-key-all-fields-immutable? - (lambda (k_0) - (begin - (if (prefab-key? k_0) - (void) - (raise-argument-error - 'prefab-key-all-fields-immutable? - "prefab-key?" - k_0)) - (all-fields-immutable? k_0)))) -(define all-fields-immutable? - (lambda (k_0) - (let ((or-part_0 (symbol? k_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 (null? k_0))) - (if or-part_1 - or-part_1 - (let ((rk_0 (cdr k_0))) - (let ((rk_1 - (if (if (pair? rk_0) (exact-integer? (car rk_0)) #f) - (cdr rk_0) - rk_0))) - (let ((rk_2 - (if (if (pair? rk_1) (pair? (car rk_1)) #f) - (if (zero? (caar rk_1)) - (cdr rk_1) - (cons '#(1) (cdr rk_1))) - rk_1))) - (if (if (pair? rk_2) (vector? (car rk_2)) #f) - (if (zero? (vector-length (car rk_2))) - (all-fields-immutable? (cdr rk_2)) - #f) - (all-fields-immutable? rk_2))))))))))) -(define struct:path-for-srcloc - (make-record-type-descriptor* 'path-for-srcloc #f #f #f #f 1 1)) -(define effect_2329 - (struct-type-install-properties! - struct:path-for-srcloc - 'path-for-srcloc - 1 - 0 - #f - null - (current-inspector) - #f - '(0) - #f - 'path-for-srcloc)) -(define path-for-srcloc1.1 - (|#%name| - path-for-srcloc - (record-constructor - (make-record-constructor-descriptor struct:path-for-srcloc #f #f)))) -(define path-for-srcloc?_2121 - (|#%name| path-for-srcloc? (record-predicate struct:path-for-srcloc))) -(define path-for-srcloc? - (|#%name| - path-for-srcloc? - (lambda (v) - (if (path-for-srcloc?_2121 v) - #t - ($value - (if (impersonator? v) - (path-for-srcloc?_2121 (impersonator-val v)) - #f)))))) -(define path-for-srcloc-path_2277 - (|#%name| path-for-srcloc-path (record-accessor struct:path-for-srcloc 0))) -(define path-for-srcloc-path - (|#%name| - path-for-srcloc-path - (lambda (s) - (if (path-for-srcloc?_2121 s) - (path-for-srcloc-path_2277 s) - ($value - (impersonate-ref - path-for-srcloc-path_2277 - struct:path-for-srcloc - 0 - s - 'path-for-srcloc - 'path)))))) -(define effect_2881 - (begin - (register-struct-constructor! path-for-srcloc1.1) - (register-struct-predicate! path-for-srcloc?) - (register-struct-field-accessor! - path-for-srcloc-path - struct:path-for-srcloc - 0) - (void))) -(define struct:to-fasl (make-record-type-descriptor* 'to-fasl #f #f #f #f 3 7)) -(define effect_2637 - (struct-type-install-properties! - struct:to-fasl - 'to-fasl - 3 - 0 - #f - null - (current-inspector) - #f - '() - #f - 'to-fasl)) -(define to-fasl1.1 - (|#%name| - to-fasl - (record-constructor - (make-record-constructor-descriptor struct:to-fasl #f #f)))) -(define to-fasl?_2514 (|#%name| to-fasl? (record-predicate struct:to-fasl))) -(define to-fasl? - (|#%name| - to-fasl? - (lambda (v) - (if (to-fasl?_2514 v) - #t - ($value - (if (impersonator? v) (to-fasl?_2514 (impersonator-val v)) #f)))))) -(define to-fasl-vb_2843 - (|#%name| to-fasl-vb (record-accessor struct:to-fasl 0))) -(define to-fasl-vb - (|#%name| - to-fasl-vb - (lambda (s) - (if (to-fasl?_2514 s) - (to-fasl-vb_2843 s) - ($value - (impersonate-ref to-fasl-vb_2843 struct:to-fasl 0 s 'to-fasl 'vb)))))) -(define to-fasl-lifts_2493 - (|#%name| to-fasl-lifts (record-accessor struct:to-fasl 1))) -(define to-fasl-lifts - (|#%name| - to-fasl-lifts - (lambda (s) - (if (to-fasl?_2514 s) - (to-fasl-lifts_2493 s) - ($value - (impersonate-ref - to-fasl-lifts_2493 - struct:to-fasl - 1 - s - 'to-fasl - 'lifts)))))) -(define to-fasl-wrt_2217 - (|#%name| to-fasl-wrt (record-accessor struct:to-fasl 2))) -(define to-fasl-wrt - (|#%name| - to-fasl-wrt - (lambda (s) - (if (to-fasl?_2514 s) - (to-fasl-wrt_2217 s) - ($value - (impersonate-ref - to-fasl-wrt_2217 - struct:to-fasl - 2 - s - 'to-fasl - 'wrt)))))) -(define set-to-fasl-vb!_2396 - (|#%name| set-to-fasl-vb! (record-mutator struct:to-fasl 0))) -(define set-to-fasl-vb! - (|#%name| - set-to-fasl-vb! - (lambda (s v) - (if (to-fasl?_2514 s) - (set-to-fasl-vb!_2396 s v) - ($value - (impersonate-set! - set-to-fasl-vb!_2396 - struct:to-fasl - 0 - 0 - s - v - 'to-fasl - 'vb)))))) -(define set-to-fasl-lifts!_2166 - (|#%name| set-to-fasl-lifts! (record-mutator struct:to-fasl 1))) -(define set-to-fasl-lifts! - (|#%name| - set-to-fasl-lifts! - (lambda (s v) - (if (to-fasl?_2514 s) - (set-to-fasl-lifts!_2166 s v) - ($value - (impersonate-set! - set-to-fasl-lifts!_2166 - struct:to-fasl - 1 - 1 - s - v - 'to-fasl - 'lifts)))))) -(define set-to-fasl-wrt!_2448 - (|#%name| set-to-fasl-wrt! (record-mutator struct:to-fasl 2))) -(define set-to-fasl-wrt! - (|#%name| - set-to-fasl-wrt! - (lambda (s v) - (if (to-fasl?_2514 s) - (set-to-fasl-wrt!_2448 s v) - ($value - (impersonate-set! - set-to-fasl-wrt!_2448 - struct:to-fasl - 2 - 2 - s - v - 'to-fasl - 'wrt)))))) -(define effect_1966 - (begin - (register-struct-constructor! to-fasl1.1) - (register-struct-predicate! to-fasl?) - (register-struct-field-accessor! to-fasl-vb struct:to-fasl 0) - (register-struct-field-accessor! to-fasl-lifts struct:to-fasl 1) - (register-struct-field-accessor! to-fasl-wrt struct:to-fasl 2) - (register-struct-field-mutator! set-to-fasl-vb! struct:to-fasl 0) - (register-struct-field-mutator! set-to-fasl-lifts! struct:to-fasl 1) - (register-struct-field-mutator! set-to-fasl-wrt! struct:to-fasl 2) - (void))) -(define lift-quoted? - (letrec ((lift-quoted?_0 - (|#%name| - lift-quoted? - (lambda (datum-intern?_0 for-cify?_0 q_0) - (begin - (if for-cify?_0 - (not - (let ((or-part_0 - (if (exact-integer? q_0) - (<= -536870912 q_0 536870911) - #f))) - (if or-part_0 - or-part_0 - (let ((or-part_1 (boolean? q_0))) - (if or-part_1 - or-part_1 - (let ((or-part_2 (null? q_0))) - (if or-part_2 or-part_2 (void? q_0)))))))) - (if (impersonator? q_0) - #t - (if (path? q_0) - #t - (if (regexp? q_0) - #t - (if (srcloc? q_0) - #t - (if (byte-regexp? q_0) - #t - (if (keyword? q_0) - #t - (if (hash? q_0) - #t - (if (string? q_0) - datum-intern?_0 - (if (bytes? q_0) - datum-intern?_0 - (if (pair? q_0) - (let ((or-part_0 - (lift-quoted?_0 - datum-intern?_0 - for-cify?_0 - (car q_0)))) - (if or-part_0 - or-part_0 - (lift-quoted?_0 - datum-intern?_0 - for-cify?_0 - (cdr q_0)))) - (if (vector? q_0) - (call-with-values - (lambda () - (begin - (check-vector q_0) - (values - q_0 - (unsafe-vector-length q_0)))) - (case-lambda - ((vec_0 len_0) - (begin - #f - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 pos_0) - (begin - (if (unsafe-fx< - pos_0 - len_0) - (let ((e_0 - (unsafe-vector-ref - vec_0 - pos_0))) - (let ((result_1 - (let ((result_1 - (lift-quoted?_0 - datum-intern?_0 - for-cify?_0 - e_0))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - e_0))) - result_1)) - #t - #f) - (for-loop_0 - result_1 - (unsafe-fx+ - 1 - pos_0)) - result_1))) - result_0)))))) - (for-loop_0 #f 0)))) - (args - (raise-binding-result-arity-error - 2 - args)))) - (if (box? q_0) - (lift-quoted?_0 - datum-intern?_0 - for-cify?_0 - (unbox q_0)) - (if (prefab-struct-key q_0) - #t - (if (extflonum? q_0) - #t - (if (let ((or-part_0 - (null? q_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 - (number? q_0))) - (if or-part_1 - or-part_1 - (let ((or-part_2 - (char? q_0))) - (if or-part_2 - or-part_2 - (let ((or-part_3 - (boolean? - q_0))) - (if or-part_3 - or-part_3 - (let ((or-part_4 - (if (symbol? - q_0) - (let ((or-part_4 - (symbol-interned? - q_0))) - (if or-part_4 - or-part_4 - (symbol-unreadable? - q_0))) - #f))) - (if or-part_4 - or-part_4 - (let ((or-part_5 - (eof-object? - q_0))) - (if or-part_5 - or-part_5 - (let ((or-part_6 - (void? - q_0))) - (if or-part_6 - or-part_6 - (eq? - q_0 - unsafe-undefined))))))))))))))) - #f - #t))))))))))))))))))))) - (lambda (q_0 for-cify?_0 datum-intern?_0) - (lift-quoted?_0 datum-intern?_0 for-cify?_0 q_0)))) -(define large-quoted? - (letrec ((remain_0 - (|#%name| - remain - (lambda (q_0 fuel_0) - (begin - (if (fx= fuel_0 0) - 0 - (if (pair? q_0) - (let ((app_0 (cdr q_0))) - (remain_0 - app_0 - (let ((app_1 (car q_0))) - (remain_0 app_1 (fx- fuel_0 1))))) - (if (vector? q_0) - (call-with-values - (lambda () - (begin - (check-vector q_0) - (values q_0 (unsafe-vector-length q_0)))) - (case-lambda - ((vec_0 len_0) - (begin - #f - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fuel_1 pos_0) - (begin - (if (unsafe-fx< pos_0 len_0) - (let ((e_0 - (unsafe-vector-ref vec_0 pos_0))) - (let ((fuel_2 - (let ((fuel_2 - (remain_0 e_0 fuel_1))) - (values fuel_2)))) - (for-loop_0 - fuel_2 - (unsafe-fx+ 1 pos_0)))) - fuel_1)))))) - (for-loop_0 (fx- fuel_0 1) 0)))) - (args (raise-binding-result-arity-error 2 args)))) - (if (box? q_0) - (let ((app_0 (unbox q_0))) - (remain_0 app_0 (fx- fuel_0 1))) - (if (prefab-struct-key q_0) - (remain_0 (struct->vector q_0) fuel_0) - (fx- fuel_0 1))))))))))) - (lambda (q_0) (let ((fuel_0 (remain_0 q_0 128))) (fx= fuel_0 0))))) -(define convert-for-serialize - (letrec ((convert-body_0 - (|#%name| - convert-body - (lambda (add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - body_0) - (begin - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0) - (begin - (if (pair? lst_0) - (let ((e_0 (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - e_0) - fold-var_0))) - (values fold-var_1)))) - (for-loop_0 fold-var_1 rest_0)))) - fold-var_0)))))) - (for-loop_0 null body_0)))))))) - (convert-function-body_0 - (|#%name| - convert-function-body - (lambda (add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - body_0) - (begin - (if for-cify?_0 - (if (let ((p_0 (unwrap body_0))) - (if (pair? p_0) - (if (let ((a_0 (car p_0))) - (let ((p_1 (unwrap a_0))) - (if (pair? p_1) - (if (let ((a_1 (car p_1))) - (begin-unsafe - (let ((app_0 (unwrap 'begin))) - (eq? app_0 (unwrap a_1))))) - (let ((a_1 (cdr p_1))) - (let ((p_2 (unwrap a_1))) - (if (pair? p_2) - (if (let ((a_2 (car p_2))) - (let ((p_3 (unwrap a_2))) - (if (pair? p_3) - (if (let ((a_3 - (car p_3))) - (begin-unsafe - (let ((app_0 - (unwrap - 'quote))) - (eq? - app_0 - (unwrap - a_3))))) - (let ((a_3 (cdr p_3))) - (let ((p_4 - (unwrap - a_3))) - (if (pair? p_4) - (let ((a_4 - (cdr - p_4))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_4))))) - #f))) - #f) - #f))) - (let ((a_2 (cdr p_2))) - (let ((p_3 (unwrap a_2))) - (if (pair? p_3) #t #f))) - #f) - #f))) - #f) - #f))) - (let ((a_0 (cdr p_0))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_0))))) - #f) - #f)) - (call-with-values - (lambda () - (let ((a_0 (car (unwrap body_0)))) - (let ((d_0 (cdr (unwrap a_0)))) - (let ((p_0 (unwrap d_0))) - (let ((name_0 - (let ((a_1 (car p_0))) - (let ((d_1 (cdr (unwrap a_1)))) - (let ((a_2 (car (unwrap d_1)))) - a_2))))) - (call-with-values - (lambda () - (let ((d_1 (cdr p_0))) - (let ((p_1 (unwrap d_1))) - (let ((body_1 - (let ((a_1 (car p_1))) a_1))) - (let ((bodys_0 - (let ((d_2 (cdr p_1))) d_2))) - (let ((body_2 body_1)) - (values body_2 bodys_0))))))) - (case-lambda - ((body_1 bodys_0) - (let ((name_1 name_0)) - (values name_1 body_1 bodys_0))) - (args - (raise-binding-result-arity-error - 2 - args))))))))) - (case-lambda - ((name_0 body_1 bodys_0) - (list - (list* - 'begin - (list 'quote name_0) - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - (cons body_1 bodys_0))))) - (args (raise-binding-result-arity-error 3 args)))) - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - body_0)) - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - body_0)))))) - (convert_0 - (|#%name| - convert - (lambda (add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - v_0) - (begin - (reannotate - v_0 - (let ((hd_0 - (let ((p_0 (unwrap v_0))) - (if (pair? p_0) (unwrap (car p_0)) #f)))) - (if (if (eq? 'quote hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_1))))) - #f))) - #f) - (let ((q_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((a_0 (car (unwrap d_0)))) a_0)))) - (if (lift-quoted? q_0 for-cify?_0 datum-intern?_0) - (make-construct - q_0 - add-lifted_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - for-cify?_0 - datum-intern?_0) - v_0)) - (if (if (eq? 'lambda hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) (wrap-list? a_1)) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((formals_0 (let ((a_0 (car p_0))) a_0))) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (unwrap-list d_1)))) - (let ((formals_1 formals_0)) - (values formals_1 body_0))))))) - (case-lambda - ((formals_0 body_0) - (list* - 'lambda - formals_0 - (convert-function-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - body_0))) - (args (raise-binding-result-arity-error 2 args)))) - (if (if (eq? 'case-lambda hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (if (wrap-list? a_0) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 lst_0) - (begin - (if (not - (begin-unsafe - (null? (unwrap lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap lst_0))) - (wrap-car lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap lst_0))) - (wrap-cdr lst_0) - null))) - (let ((v_2 v_1)) - (let ((result_1 - (let ((result_1 - (let ((p_0 - (unwrap - v_2))) - (if (pair? - p_0) - (let ((a_1 - (cdr - p_0))) - (wrap-list? - a_1)) - #f)))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - v_2))) - (not - result_1))) - #t - #f) - (for-loop_0 - result_1 - rest_0) - result_1))))) - result_0)))))) - (for-loop_0 #t a_0))) - #f)) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (call-with-values - (lambda () - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (formalss_0 bodys_0 lst_0) - (begin - (if (not - (begin-unsafe - (null? (unwrap lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap lst_0))) - (wrap-car lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap lst_0))) - (wrap-cdr lst_0) - null))) - (let ((v_2 v_1)) - (call-with-values - (lambda () - (call-with-values - (lambda () - (call-with-values - (lambda () - (let ((p_0 - (unwrap - v_2))) - (let ((formalss_1 - (let ((a_0 - (car - p_0))) - a_0))) - (let ((bodys_1 - (let ((d_1 - (cdr - p_0))) - (unwrap-list - d_1)))) - (let ((formalss_2 - formalss_1)) - (values - formalss_2 - bodys_1)))))) - (case-lambda - ((formalss1_0 - bodys2_0) - (values - (cons - formalss1_0 - formalss_0) - (cons - bodys2_0 - bodys_0))) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((formalss_1 bodys_1) - (values - formalss_1 - bodys_1)) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((formalss_1 bodys_1) - (for-loop_0 - formalss_1 - bodys_1 - rest_0)) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (values formalss_0 bodys_0))))))) - (for-loop_0 null null d_0)))) - (case-lambda - ((formalss_0 bodys_0) - (let ((app_0 (reverse$1 formalss_0))) - (values app_0 (reverse$1 bodys_0)))) - (args - (raise-binding-result-arity-error - 2 - args)))))) - (case-lambda - ((formalss_0 bodys_0) - (list* - 'case-lambda - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0 lst_1) - (begin - (if (if (pair? lst_0) - (pair? lst_1) - #f) - (let ((formals_0 - (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((body_0 - (unsafe-car lst_1))) - (let ((rest_1 - (unsafe-cdr lst_1))) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (list* - formals_0 - (convert-function-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - body_0)) - fold-var_0))) - (values - fold-var_1)))) - (for-loop_0 - fold-var_1 - rest_0 - rest_1)))))) - fold-var_0)))))) - (for-loop_0 null formalss_0 bodys_0)))))) - (args (raise-binding-result-arity-error 2 args)))) - (if (if (eq? 'define-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((ids_0 (let ((a_0 (car p_0))) a_0))) - (let ((rhs_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) - a_0)))) - (let ((ids_1 ids_0)) - (values ids_1 rhs_0))))))) - (case-lambda - ((ids_0 rhs_0) - (list - 'define-values - ids_0 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - rhs_0))) - (args - (raise-binding-result-arity-error 2 args)))) - (if (if (eq? 'let-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (if (wrap-list? a_1) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 lst_0) - (begin - (if (not - (begin-unsafe - (null? - (unwrap - lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-car - lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-cdr - lst_0) - null))) - (let ((v_2 - v_1)) - (let ((result_1 - (let ((result_1 - (let ((p_1 - (unwrap - v_2))) - (if (pair? - p_1) - (let ((a_2 - (cdr - p_1))) - (let ((p_2 - (unwrap - a_2))) - (if (pair? - p_2) - (let ((a_3 - (cdr - p_2))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_3))))) - #f))) - #f)))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - v_2))) - (not - result_1))) - #t - #f) - (for-loop_0 - result_1 - rest_0) - result_1))))) - result_0)))))) - (for-loop_0 #t a_1))) - #f)) - (let ((a_1 (cdr p_0))) - (wrap-list? a_1)) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (call-with-values - (lambda () - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (idss_0 - rhss_0 - lst_0) - (begin - (if (not - (begin-unsafe - (null? - (unwrap lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-car - lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-cdr - lst_0) - null))) - (let ((v_2 v_1)) - (call-with-values - (lambda () - (call-with-values - (lambda () - (call-with-values - (lambda () - (let ((p_1 - (unwrap - v_2))) - (let ((idss_1 - (let ((a_1 - (car - p_1))) - a_1))) - (let ((rhss_1 - (let ((d_1 - (cdr - p_1))) - (let ((a_1 - (car - (unwrap - d_1)))) - a_1)))) - (let ((idss_2 - idss_1)) - (values - idss_2 - rhss_1)))))) - (case-lambda - ((idss3_0 - rhss4_0) - (values - (cons - idss3_0 - idss_0) - (cons - rhss4_0 - rhss_0))) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((idss_1 - rhss_1) - (values - idss_1 - rhss_1)) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((idss_1 - rhss_1) - (for-loop_0 - idss_1 - rhss_1 - rest_0)) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (values - idss_0 - rhss_0))))))) - (for-loop_0 null null a_0)))) - (case-lambda - ((idss_0 rhss_0) - (let ((app_0 (reverse$1 idss_0))) - (values - app_0 - (reverse$1 rhss_0)))) - (args - (raise-binding-result-arity-error - 2 - args)))))) - (case-lambda - ((idss_0 rhss_0) - (let ((bodys_0 - (let ((d_1 (cdr p_0))) - (unwrap-list d_1)))) - (let ((idss_1 idss_0) - (rhss_1 rhss_0)) - (values idss_1 rhss_1 bodys_0)))) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (case-lambda - ((idss_0 rhss_0 bodys_0) - (let ((app_0 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0 lst_1) - (begin - (if (if (pair? lst_0) - (pair? lst_1) - #f) - (let ((ids_0 - (unsafe-car - lst_0))) - (let ((rest_0 - (unsafe-cdr - lst_0))) - (let ((rhs_0 - (unsafe-car - lst_1))) - (let ((rest_1 - (unsafe-cdr - lst_1))) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (list - ids_0 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - rhs_0)) - fold-var_0))) - (values - fold-var_1)))) - (for-loop_0 - fold-var_1 - rest_0 - rest_1)))))) - fold-var_0)))))) - (for-loop_0 - null - idss_0 - rhss_0)))))) - (list* - 'let-values - app_0 - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - bodys_0)))) - (args - (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'letrec-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (if (wrap-list? a_1) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 - lst_0) - (begin - (if (not - (begin-unsafe - (null? - (unwrap - lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-car - lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-cdr - lst_0) - null))) - (let ((v_2 - v_1)) - (let ((result_1 - (let ((result_1 - (let ((p_1 - (unwrap - v_2))) - (if (pair? - p_1) - (let ((a_2 - (cdr - p_1))) - (let ((p_2 - (unwrap - a_2))) - (if (pair? - p_2) - (let ((a_3 - (cdr - p_2))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_3))))) - #f))) - #f)))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - v_2))) - (not - result_1))) - #t - #f) - (for-loop_0 - result_1 - rest_0) - result_1))))) - result_0)))))) - (for-loop_0 #t a_1))) - #f)) - (let ((a_1 (cdr p_0))) - (wrap-list? a_1)) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (call-with-values - (lambda () - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (idss_0 - rhss_0 - lst_0) - (begin - (if (not - (begin-unsafe - (null? - (unwrap - lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-car - lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-cdr - lst_0) - null))) - (let ((v_2 v_1)) - (call-with-values - (lambda () - (call-with-values - (lambda () - (call-with-values - (lambda () - (let ((p_1 - (unwrap - v_2))) - (let ((idss_1 - (let ((a_1 - (car - p_1))) - a_1))) - (let ((rhss_1 - (let ((d_1 - (cdr - p_1))) - (let ((a_1 - (car - (unwrap - d_1)))) - a_1)))) - (let ((idss_2 - idss_1)) - (values - idss_2 - rhss_1)))))) - (case-lambda - ((idss5_0 - rhss6_0) - (values - (cons - idss5_0 - idss_0) - (cons - rhss6_0 - rhss_0))) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((idss_1 - rhss_1) - (values - idss_1 - rhss_1)) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((idss_1 - rhss_1) - (for-loop_0 - idss_1 - rhss_1 - rest_0)) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (values - idss_0 - rhss_0))))))) - (for-loop_0 null null a_0)))) - (case-lambda - ((idss_0 rhss_0) - (let ((app_0 - (reverse$1 idss_0))) - (values - app_0 - (reverse$1 rhss_0)))) - (args - (raise-binding-result-arity-error - 2 - args)))))) - (case-lambda - ((idss_0 rhss_0) - (let ((bodys_0 - (let ((d_1 (cdr p_0))) - (unwrap-list d_1)))) - (let ((idss_1 idss_0) - (rhss_1 rhss_0)) - (values idss_1 rhss_1 bodys_0)))) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (case-lambda - ((idss_0 rhss_0 bodys_0) - (let ((app_0 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 - lst_0 - lst_1) - (begin - (if (if (pair? lst_0) - (pair? lst_1) - #f) - (let ((ids_0 - (unsafe-car - lst_0))) - (let ((rest_0 - (unsafe-cdr - lst_0))) - (let ((rhs_0 - (unsafe-car - lst_1))) - (let ((rest_1 - (unsafe-cdr - lst_1))) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (list - ids_0 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - rhs_0)) - fold-var_0))) - (values - fold-var_1)))) - (for-loop_0 - fold-var_1 - rest_0 - rest_1)))))) - fold-var_0)))))) - (for-loop_0 - null - idss_0 - rhss_0)))))) - (list* - 'letrec-values - app_0 - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - bodys_0)))) - (args - (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'if hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (let ((a_3 (cdr p_2))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap a_3))))) - #f))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((tst_0 - (let ((a_0 (car p_0))) a_0))) - (call-with-values - (lambda () - (let ((d_1 (cdr p_0))) - (let ((p_1 (unwrap d_1))) - (let ((thn_0 - (let ((a_0 (car p_1))) - a_0))) - (let ((els_0 - (let ((d_2 - (cdr p_1))) - (let ((a_0 - (car - (unwrap - d_2)))) - a_0)))) - (let ((thn_1 thn_0)) - (values - thn_1 - els_0))))))) - (case-lambda - ((thn_0 els_0) - (let ((tst_1 tst_0)) - (values tst_1 thn_0 els_0))) - (args - (raise-binding-result-arity-error - 2 - args)))))))) - (case-lambda - ((tst_0 thn_0 els_0) - (let ((app_0 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - tst_0))) - (let ((app_1 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - thn_0))) - (list - 'if - app_0 - app_1 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - els_0))))) - (args - (raise-binding-result-arity-error - 3 - args)))) - (if (if (eq? 'with-continuation-mark* hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (let ((a_3 - (cdr p_2))) - (let ((p_3 - (unwrap - a_3))) - (if (pair? p_3) - (let ((a_4 - (cdr - p_3))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_4))))) - #f))) - #f))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((mode_0 - (let ((a_0 (car p_0))) a_0))) - (call-with-values - (lambda () - (let ((d_1 (cdr p_0))) - (let ((p_1 (unwrap d_1))) - (let ((key_0 - (let ((a_0 - (car p_1))) - a_0))) - (call-with-values - (lambda () - (let ((d_2 (cdr p_1))) - (let ((p_2 - (unwrap - d_2))) - (let ((val_0 - (let ((a_0 - (car - p_2))) - a_0))) - (let ((body_0 - (let ((d_3 - (cdr - p_2))) - (let ((a_0 - (car - (unwrap - d_3)))) - a_0)))) - (let ((val_1 - val_0)) - (values - val_1 - body_0))))))) - (case-lambda - ((val_0 body_0) - (let ((key_1 key_0)) - (values - key_1 - val_0 - body_0))) - (args - (raise-binding-result-arity-error - 2 - args)))))))) - (case-lambda - ((key_0 val_0 body_0) - (let ((mode_1 mode_0)) - (values - mode_1 - key_0 - val_0 - body_0))) - (args - (raise-binding-result-arity-error - 3 - args)))))))) - (case-lambda - ((mode_0 key_0 val_0 body_0) - (let ((app_0 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - key_0))) - (let ((app_1 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - val_0))) - (list - 'with-continuation-mark* - mode_0 - app_0 - app_1 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - body_0))))) - (args - (raise-binding-result-arity-error - 4 - args)))) - (if (if (eq? 'begin hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (wrap-list? a_0)) - #f) - (let ((exps_0 - (let ((d_0 (cdr (unwrap v_0)))) - (unwrap-list d_0)))) - (list* - 'begin - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - exps_0))) - (if (if (eq? 'begin-unsafe hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (wrap-list? a_0)) - #f) - (let ((exps_0 - (let ((d_0 (cdr (unwrap v_0)))) - (unwrap-list d_0)))) - (list* - 'begin-unsafe - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - exps_0))) - (if (if (eq? 'begin0 hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (wrap-list? a_0)) - #f) - (let ((exps_0 - (let ((d_0 - (cdr (unwrap v_0)))) - (unwrap-list d_0)))) - (list* - 'begin0 - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - exps_0))) - (if (if (eq? 'set! hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 - (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 - (cdr p_1))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_2))))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((id_0 - (let ((a_0 - (car p_0))) - a_0))) - (let ((rhs_0 - (let ((d_1 - (cdr p_0))) - (let ((a_0 - (car - (unwrap - d_1)))) - a_0)))) - (let ((id_1 id_0)) - (values - id_1 - rhs_0))))))) - (case-lambda - ((id_0 rhs_0) - (list - 'set! - id_0 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - rhs_0))) - (args - (raise-binding-result-arity-error - 2 - args)))) - (if (if (eq? - '|#%variable-reference| - hd_0) - (let ((a_0 - (cdr (unwrap v_0)))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_0))))) - #f) - v_0 - (if (if (eq? - '|#%variable-reference| - hd_0) - (let ((a_0 - (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 - (cdr p_0))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_1))))) - #f))) - #f) - v_0 - (if (let ((p_0 (unwrap v_0))) - (if (pair? p_0) - (let ((a_0 (cdr p_0))) - (wrap-list? a_0)) - #f)) - (call-with-values - (lambda () - (let ((p_0 (unwrap v_0))) - (let ((rator_0 - (let ((a_0 - (car - p_0))) - a_0))) - (let ((exps_0 - (let ((d_0 - (cdr - p_0))) - (unwrap-list - d_0)))) - (let ((rator_1 - rator_0)) - (values - rator_1 - exps_0)))))) - (case-lambda - ((rator_0 exps_0) - (let ((app_0 - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - rator_0))) - (list* - app_0 - (convert-body_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - exps_0)))) - (args - (raise-binding-result-arity-error - 2 - args)))) - (if (if (not (symbol? v_0)) - (lift-quoted? - v_0 - for-cify?_0 - datum-intern?_0) - #f) - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - (list 'quote v_0)) - v_0))))))))))))))))))))))) - (lambda (bodys_0 for-cify?_0 datum-intern?_0) - (let ((lifted-eq-constants_0 (make-hasheq))) - (let ((lifted-equal-constants_0 (make-hash))) - (let ((lift-bindings_0 null)) - (let ((lifts-count_0 0)) - (let ((add-lifted_0 - (|#%name| - add-lifted - (lambda (rhs_0) - (begin - (let ((id_0 - (string->symbol - (format "q:~a" lifts-count_0)))) - (begin - (set! lifts-count_0 (add1 lifts-count_0)) - (set! lift-bindings_0 - (cons (list id_0 rhs_0) lift-bindings_0)) - id_0))))))) - (let ((new-bodys_0 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0) - (begin - (if (pair? lst_0) - (let ((v_0 (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (if (convert-any? - v_0 - for-cify?_0 - datum-intern?_0) - (convert_0 - add-lifted_0 - datum-intern?_0 - for-cify?_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - v_0) - v_0) - fold-var_0))) - (values fold-var_1)))) - (for-loop_0 fold-var_1 rest_0)))) - fold-var_0)))))) - (for-loop_0 null bodys_0)))))) - (values new-bodys_0 (reverse$1 lift-bindings_0))))))))))) -(define convert-any? - (letrec ((convert-any?_0 - (|#%name| - convert-any? - (lambda (datum-intern?_0 for-cify?_0 v_0) - (begin - (let ((hd_0 - (let ((p_0 (unwrap v_0))) - (if (pair? p_0) (unwrap (car p_0)) #f)))) - (if (if (eq? 'quote hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_1))))) - #f))) - #f) - (let ((q_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((a_0 (car (unwrap d_0)))) a_0)))) - (lift-quoted? q_0 for-cify?_0 datum-intern?_0)) - (if (if (eq? 'lambda hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) (wrap-list? a_1)) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((formals_0 (let ((a_0 (car p_0))) a_0))) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (unwrap-list d_1)))) - (let ((formals_1 formals_0)) - (values formals_1 body_0))))))) - (case-lambda - ((formals_0 body_0) - (convert-any?_0 datum-intern?_0 for-cify?_0 body_0)) - (args (raise-binding-result-arity-error 2 args)))) - (if (if (eq? 'case-lambda hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (if (wrap-list? a_0) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 lst_0) - (begin - (if (not - (begin-unsafe - (null? (unwrap lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap lst_0))) - (wrap-car lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap lst_0))) - (wrap-cdr lst_0) - null))) - (let ((v_2 v_1)) - (let ((result_1 - (let ((result_1 - (let ((p_0 - (unwrap - v_2))) - (if (pair? - p_0) - (let ((a_1 - (cdr - p_0))) - (wrap-list? - a_1)) - #f)))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - v_2))) - (not - result_1))) - #t - #f) - (for-loop_0 - result_1 - rest_0) - result_1))))) - result_0)))))) - (for-loop_0 #t a_0))) - #f)) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (call-with-values - (lambda () - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (formalss_0 bodys_0 lst_0) - (begin - (if (not - (begin-unsafe - (null? (unwrap lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap lst_0))) - (wrap-car lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap lst_0))) - (wrap-cdr lst_0) - null))) - (let ((v_2 v_1)) - (call-with-values - (lambda () - (call-with-values - (lambda () - (call-with-values - (lambda () - (let ((p_0 - (unwrap - v_2))) - (let ((formalss_1 - (let ((a_0 - (car - p_0))) - a_0))) - (let ((bodys_1 - (let ((d_1 - (cdr - p_0))) - (unwrap-list - d_1)))) - (let ((formalss_2 - formalss_1)) - (values - formalss_2 - bodys_1)))))) - (case-lambda - ((formalss7_0 - bodys8_0) - (values - (cons - formalss7_0 - formalss_0) - (cons - bodys8_0 - bodys_0))) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((formalss_1 bodys_1) - (values - formalss_1 - bodys_1)) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((formalss_1 bodys_1) - (for-loop_0 - formalss_1 - bodys_1 - rest_0)) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (values formalss_0 bodys_0))))))) - (for-loop_0 null null d_0)))) - (case-lambda - ((formalss_0 bodys_0) - (let ((app_0 (reverse$1 formalss_0))) - (values app_0 (reverse$1 bodys_0)))) - (args - (raise-binding-result-arity-error 2 args)))))) - (case-lambda - ((formalss_0 bodys_0) - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - bodys_0)) - (args (raise-binding-result-arity-error 2 args)))) - (if (if (eq? 'define-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((ids_0 (let ((a_0 (car p_0))) a_0))) - (let ((rhs_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) - a_0)))) - (let ((ids_1 ids_0)) - (values ids_1 rhs_0))))))) - (case-lambda - ((ids_0 rhs_0) - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - rhs_0)) - (args (raise-binding-result-arity-error 2 args)))) - (if (if (eq? 'let-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (if (wrap-list? a_1) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 lst_0) - (begin - (if (not - (begin-unsafe - (null? - (unwrap - lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-car - lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-cdr - lst_0) - null))) - (let ((v_2 v_1)) - (let ((result_1 - (let ((result_1 - (let ((p_1 - (unwrap - v_2))) - (if (pair? - p_1) - (let ((a_2 - (cdr - p_1))) - (let ((p_2 - (unwrap - a_2))) - (if (pair? - p_2) - (let ((a_3 - (cdr - p_2))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_3))))) - #f))) - #f)))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - v_2))) - (not - result_1))) - #t - #f) - (for-loop_0 - result_1 - rest_0) - result_1))))) - result_0)))))) - (for-loop_0 #t a_1))) - #f)) - (let ((a_1 (cdr p_0))) - (wrap-list? a_1)) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (call-with-values - (lambda () - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (idss_0 rhss_0 lst_0) - (begin - (if (not - (begin-unsafe - (null? - (unwrap lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-car - lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-cdr - lst_0) - null))) - (let ((v_2 v_1)) - (call-with-values - (lambda () - (call-with-values - (lambda () - (call-with-values - (lambda () - (let ((p_1 - (unwrap - v_2))) - (let ((idss_1 - (let ((a_1 - (car - p_1))) - a_1))) - (let ((rhss_1 - (let ((d_1 - (cdr - p_1))) - (let ((a_1 - (car - (unwrap - d_1)))) - a_1)))) - (let ((idss_2 - idss_1)) - (values - idss_2 - rhss_1)))))) - (case-lambda - ((idss9_0 - rhss10_0) - (values - (cons - idss9_0 - idss_0) - (cons - rhss10_0 - rhss_0))) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((idss_1 - rhss_1) - (values - idss_1 - rhss_1)) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((idss_1 - rhss_1) - (for-loop_0 - idss_1 - rhss_1 - rest_0)) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (values - idss_0 - rhss_0))))))) - (for-loop_0 null null a_0)))) - (case-lambda - ((idss_0 rhss_0) - (let ((app_0 (reverse$1 idss_0))) - (values - app_0 - (reverse$1 rhss_0)))) - (args - (raise-binding-result-arity-error - 2 - args)))))) - (case-lambda - ((idss_0 rhss_0) - (let ((bodys_0 - (let ((d_1 (cdr p_0))) - (unwrap-list d_1)))) - (let ((idss_1 idss_0) (rhss_1 rhss_0)) - (values idss_1 rhss_1 bodys_0)))) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (case-lambda - ((idss_0 rhss_0 bodys_0) - (let ((or-part_0 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - rhss_0))) - (if or-part_0 - or-part_0 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - bodys_0)))) - (args - (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'letrec-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (if (wrap-list? a_1) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 lst_0) - (begin - (if (not - (begin-unsafe - (null? - (unwrap - lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-car - lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-cdr - lst_0) - null))) - (let ((v_2 - v_1)) - (let ((result_1 - (let ((result_1 - (let ((p_1 - (unwrap - v_2))) - (if (pair? - p_1) - (let ((a_2 - (cdr - p_1))) - (let ((p_2 - (unwrap - a_2))) - (if (pair? - p_2) - (let ((a_3 - (cdr - p_2))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_3))))) - #f))) - #f)))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - v_2))) - (not - result_1))) - #t - #f) - (for-loop_0 - result_1 - rest_0) - result_1))))) - result_0)))))) - (for-loop_0 #t a_1))) - #f)) - (let ((a_1 (cdr p_0))) - (wrap-list? a_1)) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (call-with-values - (lambda () - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (idss_0 - rhss_0 - lst_0) - (begin - (if (not - (begin-unsafe - (null? - (unwrap - lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-car - lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? - (unwrap - lst_0))) - (wrap-cdr - lst_0) - null))) - (let ((v_2 v_1)) - (call-with-values - (lambda () - (call-with-values - (lambda () - (call-with-values - (lambda () - (let ((p_1 - (unwrap - v_2))) - (let ((idss_1 - (let ((a_1 - (car - p_1))) - a_1))) - (let ((rhss_1 - (let ((d_1 - (cdr - p_1))) - (let ((a_1 - (car - (unwrap - d_1)))) - a_1)))) - (let ((idss_2 - idss_1)) - (values - idss_2 - rhss_1)))))) - (case-lambda - ((idss11_0 - rhss12_0) - (values - (cons - idss11_0 - idss_0) - (cons - rhss12_0 - rhss_0))) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((idss_1 - rhss_1) - (values - idss_1 - rhss_1)) - (args - (raise-binding-result-arity-error - 2 - args))))) - (case-lambda - ((idss_1 - rhss_1) - (for-loop_0 - idss_1 - rhss_1 - rest_0)) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (values - idss_0 - rhss_0))))))) - (for-loop_0 null null a_0)))) - (case-lambda - ((idss_0 rhss_0) - (let ((app_0 (reverse$1 idss_0))) - (values - app_0 - (reverse$1 rhss_0)))) - (args - (raise-binding-result-arity-error - 2 - args)))))) - (case-lambda - ((idss_0 rhss_0) - (let ((bodys_0 - (let ((d_1 (cdr p_0))) - (unwrap-list d_1)))) - (let ((idss_1 idss_0) - (rhss_1 rhss_0)) - (values idss_1 rhss_1 bodys_0)))) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (case-lambda - ((idss_0 rhss_0 bodys_0) - (let ((or-part_0 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - rhss_0))) - (if or-part_0 - or-part_0 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - bodys_0)))) - (args - (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'if hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (let ((a_3 (cdr p_2))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_3))))) - #f))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((tst_0 - (let ((a_0 (car p_0))) a_0))) - (call-with-values - (lambda () - (let ((d_1 (cdr p_0))) - (let ((p_1 (unwrap d_1))) - (let ((thn_0 - (let ((a_0 (car p_1))) - a_0))) - (let ((els_0 - (let ((d_2 - (cdr p_1))) - (let ((a_0 - (car - (unwrap - d_2)))) - a_0)))) - (let ((thn_1 thn_0)) - (values - thn_1 - els_0))))))) - (case-lambda - ((thn_0 els_0) - (let ((tst_1 tst_0)) - (values tst_1 thn_0 els_0))) - (args - (raise-binding-result-arity-error - 2 - args)))))))) - (case-lambda - ((tst_0 thn_0 els_0) - (let ((or-part_0 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - tst_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - thn_0))) - (if or-part_1 - or-part_1 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - els_0)))))) - (args - (raise-binding-result-arity-error - 3 - args)))) - (if (if (eq? 'with-continuation-mark* hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (let ((a_3 (cdr p_2))) - (let ((p_3 - (unwrap - a_3))) - (if (pair? p_3) - (let ((a_4 - (cdr - p_3))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_4))))) - #f))) - #f))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((d_1 (cdr (unwrap d_0)))) - (let ((p_0 (unwrap d_1))) - (let ((key_0 - (let ((a_0 (car p_0))) - a_0))) - (call-with-values - (lambda () - (let ((d_2 (cdr p_0))) - (let ((p_1 (unwrap d_2))) - (let ((val_0 - (let ((a_0 - (car p_1))) - a_0))) - (let ((body_0 - (let ((d_3 - (cdr - p_1))) - (let ((a_0 - (car - (unwrap - d_3)))) - a_0)))) - (let ((val_1 val_0)) - (values - val_1 - body_0))))))) - (case-lambda - ((val_0 body_0) - (let ((key_1 key_0)) - (values - key_1 - val_0 - body_0))) - (args - (raise-binding-result-arity-error - 2 - args))))))))) - (case-lambda - ((key_0 val_0 body_0) - (let ((or-part_0 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - key_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - val_0))) - (if or-part_1 - or-part_1 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - body_0)))))) - (args - (raise-binding-result-arity-error - 3 - args)))) - (if (if (eq? 'begin hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (wrap-list? a_0)) - #f) - (let ((exps_0 - (let ((d_0 (cdr (unwrap v_0)))) - (unwrap-list d_0)))) - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - exps_0)) - (if (if (eq? 'begin-unsafe hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (wrap-list? a_0)) - #f) - (let ((exps_0 - (let ((d_0 (cdr (unwrap v_0)))) - (unwrap-list d_0)))) - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - exps_0)) - (if (if (eq? 'begin0 hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (wrap-list? a_0)) - #f) - (let ((exps_0 - (let ((d_0 (cdr (unwrap v_0)))) - (unwrap-list d_0)))) - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - exps_0)) - (if (if (eq? 'set! hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 - (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 - (cdr p_1))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap - a_2))))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (let ((id_0 - (let ((a_0 (car p_0))) - a_0))) - (let ((rhs_0 - (let ((d_1 - (cdr p_0))) - (let ((a_0 - (car - (unwrap - d_1)))) - a_0)))) - (let ((id_1 id_0)) - (values - id_1 - rhs_0))))))) - (case-lambda - ((id_0 rhs_0) - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - rhs_0)) - (args - (raise-binding-result-arity-error - 2 - args)))) - (if (if (eq? - '|#%variable-reference| - hd_0) - (let ((a_0 - (cdr (unwrap v_0)))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? - app_0 - (unwrap a_0))))) - #f) - #f - (if (if (eq? - '|#%variable-reference| - hd_0) - (let ((a_0 - (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap a_1))))) - #f))) - #f) - #f - (if (wrap-list? v_0) - (let ((exps_0 - (unwrap-list v_0))) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 - lst_0) - (begin - (if (pair? lst_0) - (let ((exp_0 - (unsafe-car - lst_0))) - (let ((rest_0 - (unsafe-cdr - lst_0))) - (let ((result_1 - (let ((result_1 - (convert-any?_0 - datum-intern?_0 - for-cify?_0 - exp_0))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - exp_0))) - result_1)) - #t - #f) - (for-loop_0 - result_1 - rest_0) - result_1)))) - result_0)))))) - (for-loop_0 #f exps_0)))) - (if (not (symbol? v_0)) - (lift-quoted? - v_0 - for-cify?_0 - datum-intern?_0) - #f)))))))))))))))))))))) - (lambda (v_0 for-cify?_0 datum-intern?_0) - (convert-any?_0 datum-intern?_0 for-cify?_0 v_0)))) -(define make-construct - (letrec ((procz1 - (|#%name| - quote? - (lambda (e_0) - (begin (if (pair? e_0) (eq? 'quote (car e_0)) #f))))) - (check-cycle_0 - (|#%name| - check-cycle - (lambda (q_0 seen_0 v_0) - (begin - (begin - (if (hash-ref (unsafe-unbox* seen_0) v_0 #f) - (raise-arguments-error - 'compile - "cannot compile cyclic value" - "value" - q_0) - (void)) - (unsafe-set-box*! - seen_0 - (hash-set (unsafe-unbox* seen_0) v_0 #t))))))) - (done-cycle_0 - (|#%name| - done-cycle - (lambda (seen_0 v_0) - (begin - (unsafe-set-box*! - seen_0 - (hash-remove (unsafe-unbox* seen_0) v_0))))))) - (lambda (q_0 - add-lifted_0 - lifted-eq-constants_0 - lifted-equal-constants_0 - for-cify?_0 - datum-intern?_0) - (let ((quote?_0 procz1)) - (let ((seen_0 (box hash2610))) - (if (if (not for-cify?_0) (large-quoted? q_0) #f) - (let ((id_0 (|#%app| add-lifted_0 (to-fasl1.1 (box q_0) '#() #f)))) - (list 'force-unfasl id_0)) - (letrec* - ((make-construct_0 - (|#%name| - make-construct - (lambda (q_1) - (begin - (let ((lifted-constants_0 - (if (let ((or-part_0 (string? q_1))) - (if or-part_0 or-part_0 (bytes? q_1))) - lifted-equal-constants_0 - lifted-eq-constants_0))) - (let ((c1_0 (hash-ref lifted-constants_0 q_1 #f))) - (if c1_0 - c1_0 - (let ((rhs_0 - (if (path? q_1) - (if for-cify?_0 - (let ((app_0 (path->bytes q_1))) - (list - 'bytes->path - app_0 - (list - 'quote - (path-convention-type q_1)))) - q_1) - (if (path-for-srcloc? q_1) - q_1 - (if (regexp? q_1) - (let ((app_0 - (if (pregexp? q_1) - 'pregexp - 'regexp))) - (list app_0 (object-name q_1))) - (if (srcloc? q_1) - (let ((app_0 - (let ((src_0 - (srcloc-source q_1))) - (if (if (not for-cify?_0) - (not - (let ((or-part_0 - (string? - src_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 - (bytes? - src_0))) - (if or-part_1 - or-part_1 - (let ((or-part_2 - (symbol? - src_0))) - (if or-part_2 - or-part_2 - (not - src_0)))))))) - #f) - (make-construct_0 - (path-for-srcloc1.1 - src_0)) - (make-construct_0 - src_0))))) - (let ((app_1 - (make-construct_0 - (srcloc-line q_1)))) - (let ((app_2 - (make-construct_0 - (srcloc-column q_1)))) - (let ((app_3 - (make-construct_0 - (srcloc-position q_1)))) - (list - 'unsafe-make-srcloc - app_0 - app_1 - app_2 - app_3 - (make-construct_0 - (srcloc-span q_1))))))) - (if (byte-regexp? q_1) - (let ((app_0 - (if (byte-pregexp? q_1) - 'byte-pregexp - 'byte-regexp))) - (list app_0 (object-name q_1))) - (if (keyword? q_1) - (list - 'string->keyword - (keyword->string q_1)) - (if (hash? q_1) - (let ((mut?_0 - (not (immutable? q_1)))) - (begin - (if mut?_0 - (check-cycle_0 - q_0 - seen_0 - q_1) - (void)) - (let ((new-q_0 - (let ((app_0 - (if (hash-eq? - q_1) - 'hasheq - (if (hash-eqv? - q_1) - 'hasheqv - 'hash)))) - (list* - app_0 - (apply - append - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 - i_0) - (begin - (if i_0 - (call-with-values - (lambda () - (hash-iterate-key+value - q_1 - i_0)) - (case-lambda - ((k_0 - v_0) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (let ((app_1 - (make-construct_0 - k_0))) - (list - app_1 - (make-construct_0 - v_0))) - fold-var_0))) - (values - fold-var_1)))) - (for-loop_0 - fold-var_1 - (hash-iterate-next - q_1 - i_0)))) - (args - (raise-binding-result-arity-error - 2 - args)))) - fold-var_0)))))) - (for-loop_0 - null - (hash-iterate-first - q_1)))))))))) - (begin - (if mut?_0 - (done-cycle_0 - seen_0 - q_1) - (void)) - new-q_0)))) - (if (string? q_1) - (list - 'datum-intern-literal - q_1) - (if (bytes? q_1) - (list - 'datum-intern-literal - q_1) - (if (pair? q_1) - (if (list? q_1) - (let ((args_0 - (map_2960 - make-construct_0 - q_1))) - (if (andmap_2344 - quote?_0 - args_0) - (list 'quote q_1) - (list* - 'list - (map_2960 - make-construct_0 - q_1)))) - (let ((a_0 - (make-construct_0 - (car q_1)))) - (let ((d_0 - (make-construct_0 - (cdr q_1)))) - (let ((a_1 a_0)) - (if (if (quote?_0 - a_1) - (quote?_0 - d_0) - #f) - (list - 'quote - q_1) - (list - 'cons - a_1 - d_0)))))) - (if (vector? q_1) - (let ((args_0 - (map_2960 - make-construct_0 - (vector->list - q_1)))) - (list - 'vector->immutable-vector - (if (if (andmap_2344 - quote?_0 - args_0) - (not - (impersonator? - q_1)) - #f) - (list 'quote q_1) - (list* - 'vector - args_0)))) - (if (box? q_1) - (let ((arg_0 - (make-construct_0 - (unbox q_1)))) - (list - 'box-immutable - arg_0)) - (let ((c2_0 - (prefab-struct-key - q_1))) - (if c2_0 - (let ((mut?_0 - (not - (prefab-key-all-fields-immutable? - c2_0)))) - (begin - (if mut?_0 - (check-cycle_0 - q_0 - seen_0 - q_1) - (void)) - (let ((new-q_0 - (list* - 'make-prefab-struct - (list - 'quote - c2_0) - (map_2960 - make-construct_0 - (cdr - (vector->list - (struct->vector - q_1))))))) - (begin - (if mut?_0 - (done-cycle_0 - seen_0 - q_1) - (void)) - new-q_0)))) - (if (extflonum? - q_1) - (list* - 'string->number - (format - "~a" - q_1) - '(10 'read)) - (if (if for-cify?_0 - for-cify?_0 - (let ((or-part_0 - (null? - q_1))) - (if or-part_0 - or-part_0 - (let ((or-part_1 - (number? - q_1))) - (if or-part_1 - or-part_1 - (let ((or-part_2 - (char? - q_1))) - (if or-part_2 - or-part_2 - (let ((or-part_3 - (boolean? - q_1))) - (if or-part_3 - or-part_3 - (let ((or-part_4 - (if (symbol? - q_1) - (let ((or-part_4 - (symbol-interned? - q_1))) - (if or-part_4 - or-part_4 - (symbol-unreadable? - q_1))) - #f))) - (if or-part_4 - or-part_4 - (let ((or-part_5 - (eof-object? - q_1))) - (if or-part_5 - or-part_5 - (let ((or-part_6 - (void? - q_1))) - (if or-part_6 - or-part_6 - (eq? - q_1 - unsafe-undefined)))))))))))))))) - (list - 'quote - q_1) - (if (symbol? - q_1) - (list - 'force-unfasl - (|#%app| - add-lifted_0 - (to-fasl1.1 - (box q_1) - '#() - #f))) - (let ((id_0 - (|#%app| - add-lifted_0 - (to-fasl1.1 - (box - q_1) - '#() - #f)))) - (list - 'force-unfasl - id_0))))))))))))))))))))) - (if (if (quote?_0 rhs_0) - (let ((or-part_0 (not for-cify?_0))) - (if or-part_0 - or-part_0 - (not - (lift-quoted? - (cadr rhs_0) - #t - datum-intern?_0)))) - #f) - rhs_0 - (let ((id_0 (|#%app| add-lifted_0 rhs_0))) - (begin - (hash-set! lifted-constants_0 q_1 id_0) - id_0)))))))))))) - (make-construct_0 q_0)))))))) -(define make-let* - (lambda (bindings_0 body_0) - (if (null? bindings_0) body_0 (list 'let* bindings_0 body_0)))) (define equal-implies-eq? (lambda (e_0) (let ((hd_0 @@ -24966,7 +21540,7 @@ (lambda (id_0) (begin (unwrap (if (pair? id_0) (cadr id_0) id_0))))))) (lambda (lk_0 - serializable?_0 + serializable?-box_0 datum-intern?_0 for-interp?_0 allow-set!-undefined?_0 @@ -25167,104 +21741,37 @@ (for-loop_0 exports_1 rest_0)))) exports_0)))))) (for-loop_0 (hasheq) ex-ids_0))))) - (call-with-values - (lambda () - (if serializable?_0 - (convert-for-serialize bodys_0 #f datum-intern?_0) - (values bodys_0 null))) - (case-lambda - ((bodys/constants-lifted_0 lifted-constants_0) - (let ((src-syms_0 - (get-definition-source-syms bodys_0))) - (call-with-values - (lambda () - (schemify-body* - bodys/constants-lifted_0 - prim-knowns_0 - primitives_0 - imports_0 - exports_0 - for-interp?_0 - allow-set!-undefined?_0 - add-import!_0 - #f - unsafe-mode?_0 - enforce-constant?_0 - allow-inline?_0 - no-prompt?_0 - #t)) - (case-lambda - ((new-body_0 defn-info_0 mutated_0) - (let ((all-grps_0 - (append grps_0 (reverse$1 new-grps_0)))) - (let ((app_0 - (make-let* - lifted-constants_0 - (list* - 'lambda - (list* - 'instance-variable-reference - (let ((app_0 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 - lst_0) - (begin - (if (pair? lst_0) - (let ((grp_0 - (unsafe-car - lst_0))) - (let ((rest_0 - (unsafe-cdr - lst_0))) - (let ((fold-var_1 - (let ((lst_1 - (import-group-imports - grp_0))) - (begin - (letrec* - ((for-loop_1 - (|#%name| - for-loop - (lambda (fold-var_1 - lst_2) - (begin - (if (pair? - lst_2) - (let ((im_0 - (unsafe-car - lst_2))) - (let ((rest_1 - (unsafe-cdr - lst_2))) - (let ((fold-var_2 - (let ((fold-var_2 - (cons - (import-id - im_0) - fold-var_1))) - (values - fold-var_2)))) - (for-loop_1 - fold-var_2 - rest_1)))) - fold-var_1)))))) - (for-loop_1 - fold-var_0 - lst_1)))))) - (for-loop_0 - fold-var_1 - rest_0)))) - fold-var_0)))))) - (for-loop_0 - null - all-grps_0)))))) - (qq-append - app_0 + (let ((src-syms_0 + (get-definition-source-syms bodys_0))) + (call-with-values + (lambda () + (schemify-body* + bodys_0 + prim-knowns_0 + primitives_0 + imports_0 + exports_0 + serializable?-box_0 + datum-intern?_0 + for-interp?_0 + allow-set!-undefined?_0 + add-import!_0 + #f + unsafe-mode?_0 + enforce-constant?_0 + allow-inline?_0 + no-prompt?_0 + #t)) + (case-lambda + ((new-body_0 defn-info_0 mutated_0) + (let ((all-grps_0 + (append grps_0 (reverse$1 new-grps_0)))) + (let ((app_0 + (list* + 'lambda + (list* + 'instance-variable-reference + (let ((app_0 (reverse$1 (begin (letrec* @@ -25275,32 +21782,56 @@ lst_0) (begin (if (pair? lst_0) - (let ((ex-id_0 + (let ((grp_0 (unsafe-car lst_0))) (let ((rest_0 (unsafe-cdr lst_0))) (let ((fold-var_1 - (let ((fold-var_1 - (cons - (export-id - (hash-ref - exports_0 - (ex-int-id_0 - ex-id_0))) - fold-var_0))) - (values - fold-var_1)))) + (let ((lst_1 + (import-group-imports + grp_0))) + (begin + (letrec* + ((for-loop_1 + (|#%name| + for-loop + (lambda (fold-var_1 + lst_2) + (begin + (if (pair? + lst_2) + (let ((im_0 + (unsafe-car + lst_2))) + (let ((rest_1 + (unsafe-cdr + lst_2))) + (let ((fold-var_2 + (let ((fold-var_2 + (cons + (import-id + im_0) + fold-var_1))) + (values + fold-var_2)))) + (for-loop_1 + fold-var_2 + rest_1)))) + fold-var_1)))))) + (for-loop_1 + fold-var_0 + lst_1)))))) (for-loop_0 fold-var_1 rest_0)))) fold-var_0)))))) (for-loop_0 null - ex-ids_0))))))) - new-body_0)))) - (let ((app_1 + all-grps_0)))))) + (qq-append + app_0 (reverse$1 (begin (letrec* @@ -25310,7 +21841,7 @@ (lambda (fold-var_0 lst_0) (begin (if (pair? lst_0) - (let ((grp_0 + (let ((ex-id_0 (unsafe-car lst_0))) (let ((rest_0 @@ -25319,41 +21850,11 @@ (let ((fold-var_1 (let ((fold-var_1 (cons - (reverse$1 - (let ((lst_1 - (import-group-imports - grp_0))) - (begin - (letrec* - ((for-loop_1 - (|#%name| - for-loop - (lambda (fold-var_1 - lst_2) - (begin - (if (pair? - lst_2) - (let ((im_0 - (unsafe-car - lst_2))) - (let ((rest_1 - (unsafe-cdr - lst_2))) - (let ((fold-var_2 - (let ((fold-var_2 - (cons - (import-ext-id - im_0) - fold-var_1))) - (values - fold-var_2)))) - (for-loop_1 - fold-var_2 - rest_1)))) - fold-var_1)))))) - (for-loop_1 - null - lst_1))))) + (export-id + (hash-ref + exports_0 + (ex-int-id_0 + ex-id_0))) fold-var_0))) (values fold-var_1)))) @@ -25361,267 +21862,325 @@ fold-var_1 rest_0)))) fold-var_0)))))) - (for-loop_0 - null - all-grps_0)))))) - (let ((app_2 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0) - (begin - (if (pair? lst_0) - (let ((ex-id_0 - (unsafe-car - lst_0))) - (let ((rest_0 - (unsafe-cdr - lst_0))) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (let ((sym_0 - (ex-ext-id_0 - ex-id_0))) - (let ((int-sym_0 - (ex-int-id_0 - ex-id_0))) - (let ((src-sym_0 - (hash-ref - src-syms_0 - int-sym_0 - sym_0))) - (if (eq? - sym_0 - src-sym_0) - sym_0 - (cons - sym_0 - src-sym_0))))) - fold-var_0))) - (values - fold-var_1)))) - (for-loop_0 - fold-var_1 - rest_0)))) - fold-var_0)))))) - (for-loop_0 - null - ex-ids_0)))))) - (let ((app_3 - (if (null? new-grps_0) - import-keys_0 - (let ((len_0 - (length all-grps_0))) + (for-loop_0 null ex-ids_0))))))) + new-body_0))) + (let ((app_1 + (reverse$1 + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (fold-var_0 lst_0) + (begin + (if (pair? lst_0) + (let ((grp_0 + (unsafe-car + lst_0))) + (let ((rest_0 + (unsafe-cdr + lst_0))) + (let ((fold-var_1 + (let ((fold-var_1 + (cons + (reverse$1 + (let ((lst_1 + (import-group-imports + grp_0))) + (begin + (letrec* + ((for-loop_1 + (|#%name| + for-loop + (lambda (fold-var_1 + lst_2) + (begin + (if (pair? + lst_2) + (let ((im_0 + (unsafe-car + lst_2))) + (let ((rest_1 + (unsafe-cdr + lst_2))) + (let ((fold-var_2 + (let ((fold-var_2 + (cons + (import-ext-id + im_0) + fold-var_1))) + (values + fold-var_2)))) + (for-loop_1 + fold-var_2 + rest_1)))) + fold-var_1)))))) + (for-loop_1 + null + lst_1))))) + fold-var_0))) + (values + fold-var_1)))) + (for-loop_0 + fold-var_1 + rest_0)))) + fold-var_0)))))) + (for-loop_0 null all-grps_0)))))) + (let ((app_2 + (reverse$1 + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (fold-var_0 lst_0) (begin - (if (exact-nonnegative-integer? - len_0) - (void) - (raise-argument-error - 'for/vector - "exact-nonnegative-integer?" - len_0)) - (let ((v_0 - (make-vector - len_0 - 0))) - (begin - (if (zero? len_0) - (void) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (i_0 - lst_0) - (begin - (if (pair? - lst_0) - (let ((grp_0 - (unsafe-car - lst_0))) - (let ((rest_0 - (unsafe-cdr - lst_0))) - (let ((i_1 - (let ((i_1 - (begin - (unsafe-vector*-set! - v_0 - i_0 - (import-group-key - grp_0)) - (unsafe-fx+ - 1 - i_0)))) - (values - i_1)))) - (if (if (not - (let ((x_0 - (list - grp_0))) - (unsafe-fx= - i_1 - len_0))) - #t - #f) - (for-loop_0 - i_1 - rest_0) - i_1)))) - i_0)))))) - (for-loop_0 - 0 - all-grps_0)))) - v_0))))))) - (let ((app_4 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 - lst_0) - (begin - (if (pair? lst_0) - (let ((grp_0 - (unsafe-car - lst_0))) - (let ((rest_0 - (unsafe-cdr - lst_0))) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (let ((im-ready?_0 - (import-group-lookup-ready? - grp_0))) - (reverse$1 - (let ((lst_1 - (import-group-imports - grp_0))) - (begin - (letrec* - ((for-loop_1 - (|#%name| - for-loop - (lambda (fold-var_1 - lst_2) - (begin - (if (pair? - lst_2) - (let ((im_0 - (unsafe-car - lst_2))) - (let ((rest_1 - (unsafe-cdr - lst_2))) - (let ((fold-var_2 - (let ((fold-var_2 - (cons - (if im-ready?_0 - (let ((k_0 - (import-group-lookup - grp_0 - (import-ext-id - im_0)))) - (if (known-constant? - k_0) - (if (known-procedure? - k_0) - 'proc - #t) - #f)) - #f) - fold-var_1))) - (values - fold-var_2)))) - (for-loop_1 - fold-var_2 - rest_1)))) - fold-var_1)))))) - (for-loop_1 - null - lst_1)))))) - fold-var_0))) - (values - fold-var_1)))) - (for-loop_0 - fold-var_1 - rest_0)))) - fold-var_0)))))) - (for-loop_0 - null - all-grps_0)))))) - (values - app_0 - app_1 - app_2 - app_3 - app_4 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (knowns_0 lst_0) - (begin - (if (pair? lst_0) - (let ((ex-id_0 - (unsafe-car + (if (pair? lst_0) + (let ((ex-id_0 + (unsafe-car + lst_0))) + (let ((rest_0 + (unsafe-cdr lst_0))) - (let ((rest_0 - (unsafe-cdr + (let ((fold-var_1 + (let ((fold-var_1 + (cons + (let ((sym_0 + (ex-ext-id_0 + ex-id_0))) + (let ((int-sym_0 + (ex-int-id_0 + ex-id_0))) + (let ((src-sym_0 + (hash-ref + src-syms_0 + int-sym_0 + sym_0))) + (if (eq? + sym_0 + src-sym_0) + sym_0 + (cons + sym_0 + src-sym_0))))) + fold-var_0))) + (values + fold-var_1)))) + (for-loop_0 + fold-var_1 + rest_0)))) + fold-var_0)))))) + (for-loop_0 null ex-ids_0)))))) + (let ((app_3 + (if (null? new-grps_0) + import-keys_0 + (let ((len_0 + (length all-grps_0))) + (begin + (if (exact-nonnegative-integer? + len_0) + (void) + (raise-argument-error + 'for/vector + "exact-nonnegative-integer?" + len_0)) + (let ((v_0 + (make-vector + len_0 + 0))) + (begin + (if (zero? len_0) + (void) + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (i_0 + lst_0) + (begin + (if (pair? + lst_0) + (let ((grp_0 + (unsafe-car + lst_0))) + (let ((rest_0 + (unsafe-cdr + lst_0))) + (let ((i_1 + (let ((i_1 + (begin + (unsafe-vector*-set! + v_0 + i_0 + (import-group-key + grp_0)) + (unsafe-fx+ + 1 + i_0)))) + (values + i_1)))) + (if (if (not + (let ((x_0 + (list + grp_0))) + (unsafe-fx= + i_1 + len_0))) + #t + #f) + (for-loop_0 + i_1 + rest_0) + i_1)))) + i_0)))))) + (for-loop_0 + 0 + all-grps_0)))) + v_0))))))) + (let ((app_4 + (reverse$1 + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (fold-var_0 lst_0) + (begin + (if (pair? lst_0) + (let ((grp_0 + (unsafe-car lst_0))) - (let ((knowns_1 - (let ((knowns_1 - (let ((id_0 - (ex-int-id_0 - ex-id_0))) - (let ((v_0 - (known-inline->export-known - (hash-ref - defn-info_0 - id_0 - #f) - prim-knowns_0 - imports_0 - exports_0 - serializable?_0))) - (if (not - (set!ed-mutated-state? - (hash-ref - mutated_0 - id_0 - #f))) - (let ((ext-id_0 - (ex-ext-id_0 - ex-id_0))) - (hash-set - knowns_0 - ext-id_0 - (if v_0 - v_0 - a-known-constant))) - knowns_0))))) - (values - knowns_1)))) - (for-loop_0 - knowns_1 - rest_0)))) - knowns_0)))))) - (for-loop_0 - (hasheq) - ex-ids_0))))))))))) - (args - (raise-binding-result-arity-error 3 args)))))) - (args - (raise-binding-result-arity-error 2 args)))))))))) + (let ((rest_0 + (unsafe-cdr + lst_0))) + (let ((fold-var_1 + (let ((fold-var_1 + (cons + (let ((im-ready?_0 + (import-group-lookup-ready? + grp_0))) + (reverse$1 + (let ((lst_1 + (import-group-imports + grp_0))) + (begin + (letrec* + ((for-loop_1 + (|#%name| + for-loop + (lambda (fold-var_1 + lst_2) + (begin + (if (pair? + lst_2) + (let ((im_0 + (unsafe-car + lst_2))) + (let ((rest_1 + (unsafe-cdr + lst_2))) + (let ((fold-var_2 + (let ((fold-var_2 + (cons + (if im-ready?_0 + (let ((k_0 + (import-group-lookup + grp_0 + (import-ext-id + im_0)))) + (if (known-constant? + k_0) + (if (known-procedure? + k_0) + 'proc + #t) + #f)) + #f) + fold-var_1))) + (values + fold-var_2)))) + (for-loop_1 + fold-var_2 + rest_1)))) + fold-var_1)))))) + (for-loop_1 + null + lst_1)))))) + fold-var_0))) + (values + fold-var_1)))) + (for-loop_0 + fold-var_1 + rest_0)))) + fold-var_0)))))) + (for-loop_0 + null + all-grps_0)))))) + (values + app_0 + app_1 + app_2 + app_3 + app_4 + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (knowns_0 lst_0) + (begin + (if (pair? lst_0) + (let ((ex-id_0 + (unsafe-car + lst_0))) + (let ((rest_0 + (unsafe-cdr + lst_0))) + (let ((knowns_1 + (let ((knowns_1 + (let ((id_0 + (ex-int-id_0 + ex-id_0))) + (let ((v_0 + (known-inline->export-known + (hash-ref + defn-info_0 + id_0 + #f) + prim-knowns_0 + imports_0 + exports_0 + serializable?-box_0))) + (if (not + (set!ed-mutated-state? + (hash-ref + mutated_0 + id_0 + #f))) + (let ((ext-id_0 + (ex-ext-id_0 + ex-id_0))) + (hash-set + knowns_0 + ext-id_0 + (if v_0 + v_0 + a-known-constant))) + knowns_0))))) + (values + knowns_1)))) + (for-loop_0 + knowns_1 + rest_0)))) + knowns_0)))))) + (for-loop_0 + (hasheq) + ex-ids_0))))))))))) + (args + (raise-binding-result-arity-error + 3 + args))))))))))) (args (raise-binding-result-arity-error 3 args)))) (error 'match "failed ~e" lk_0))))))) (define schemify-body @@ -25652,6 +22211,8 @@ exports_0 #f #f + #f + #f procz1 for-cify?_0 unsafe-mode?_0 @@ -25715,6 +22276,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -25730,6 +22292,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 knowns16_0 @@ -25878,6 +22441,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -25889,6 +22453,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (cdr l_0) @@ -25943,6 +22508,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -25958,6 +22524,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 ids_0 @@ -25990,6 +22557,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26001,6 +22569,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 app_2 @@ -26119,6 +22688,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26130,6 +22700,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (cdr l_0) @@ -26143,6 +22714,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26154,6 +22726,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 l_0 @@ -26193,6 +22766,8 @@ simples_0 allow-set!-undefined?_0 add-import!_0 + serializable?-box_0 + datum-intern?_0 for-cify?_0 for-interp?_0 unsafe-mode?_0 @@ -26248,6 +22823,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26263,6 +22839,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 unsafe-undefined @@ -26277,6 +22854,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26292,6 +22870,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (list id_0) @@ -26401,6 +22980,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26416,6 +22996,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 ids_0 @@ -26429,6 +23010,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26444,6 +23026,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 unsafe-undefined @@ -26458,6 +23041,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26473,6 +23057,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 unsafe-undefined @@ -26487,6 +23072,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26502,6 +23088,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 ids_0 @@ -26528,6 +23115,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26539,6 +23127,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (cdr l_0) @@ -26590,6 +23179,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26605,6 +23195,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 unsafe-undefined @@ -26626,6 +23217,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26637,6 +23229,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (cdr l_0) @@ -26666,6 +23259,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26677,6 +23271,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 app_0 @@ -26820,6 +23415,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26835,6 +23431,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 ids_0 @@ -26848,6 +23445,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26859,6 +23457,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (cdr l_0) @@ -26879,6 +23478,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26894,6 +23494,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 app_0 @@ -26907,6 +23508,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -26922,6 +23524,7 @@ prim-knowns_0 primitives_0 schemified_0 + serializable?-box_0 simples_0 unsafe-mode?_0 knowns_1 @@ -26935,6 +23538,8 @@ primitives_0 imports_0 exports_0 + serializable?-box_0 + datum-intern?_0 for-interp?_0 allow-set!-undefined?_0 add-import!_0 @@ -27000,6 +23605,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 extra-variables_0 @@ -27011,6 +23617,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 l_0 @@ -27137,6 +23744,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27148,6 +23756,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 k_0 @@ -27186,6 +23795,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27197,6 +23807,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 type-id_0 @@ -27217,6 +23828,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27228,6 +23840,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 k_0 @@ -27276,6 +23889,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27287,6 +23901,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 type-id_0 @@ -27312,6 +23927,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 exps_0 @@ -27325,6 +23941,7 @@ prim-knowns_0 primitives_0 rator_0 + serializable?-box_0 simples_0 unsafe-mode?_0 wcm-state_0) @@ -27354,6 +23971,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 exps_0 @@ -27365,6 +23983,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 wcm-state_0 @@ -27380,6 +23999,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27391,6 +24011,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 k_0 @@ -27430,6 +24051,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27441,6 +24063,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 type-id_0 @@ -27453,6 +24076,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 exps_0 @@ -27464,6 +24088,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 wcm-state_0 @@ -27504,6 +24129,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27513,6 +24139,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 knowns_0 @@ -27594,6 +24221,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 exps_0 @@ -27605,6 +24233,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 wcm-state_0 @@ -27616,6 +24245,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 exps_0 @@ -27627,6 +24257,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 wcm-state_0 @@ -27664,6 +24295,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27675,6 +24307,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 l_0 @@ -27688,6 +24321,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27699,6 +24333,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (car l_0) @@ -27708,6 +24343,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27719,6 +24355,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (car l_0) @@ -27729,6 +24366,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27740,6 +24378,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (cdr l_0) @@ -27750,6 +24389,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27759,6 +24399,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 knowns_0 @@ -27770,6 +24411,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27781,6 +24423,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 v_0 @@ -27791,6 +24434,7 @@ (lambda (add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27802,6 +24446,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 v_0 @@ -27842,6 +24487,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -27853,6 +24499,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 body_0 @@ -28057,6 +24704,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -28068,6 +24716,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 body_0 @@ -28774,6 +25423,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -28783,6 +25433,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 knowns_1 @@ -28842,6 +25493,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -28853,6 +25505,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhs_0 @@ -28921,6 +25574,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -28932,6 +25586,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhs_0 @@ -28981,6 +25636,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -28992,6 +25648,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhs_0 @@ -29012,7 +25669,18 @@ (unwrap a_1))))) #f))) #f) - v_0 + (let ((q_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((a_0 (car (unwrap d_0)))) + a_0)))) + (begin + (if serializable?-box_0 + (register-literal-serialization + q_0 + serializable?-box_0 + datum-intern?_0) + (void)) + v_0)) (if (if (eq? 'let-values hd_0) (let ((a_0 (cdr (unwrap v_0)))) (let ((p_0 (unwrap a_0))) @@ -29053,6 +25721,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -29064,6 +25733,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 body_0 @@ -29095,6 +25765,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -29106,6 +25777,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (list* 'begin bodys_0) @@ -29400,6 +26072,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -29411,6 +26084,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (car rhss_0) @@ -29555,6 +26229,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -29566,6 +26241,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhs_0 @@ -29609,6 +26285,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -29618,6 +26295,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 new-knowns_0 @@ -29874,6 +26552,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -29885,6 +26564,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhss_0 @@ -29895,6 +26575,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -29906,6 +26587,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 bodys_0 @@ -30174,6 +26856,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -30183,6 +26866,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 knowns_1 @@ -30229,6 +26913,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -30240,6 +26925,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhs_0 @@ -30261,6 +26947,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -30272,6 +26959,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 bodys_0 @@ -30330,6 +27018,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -30341,6 +27030,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (list* 'begin bodys_0) @@ -30474,6 +27164,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -30485,6 +27176,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (list* 'begin bodys_0) @@ -30699,6 +27391,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -30710,6 +27403,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (list* @@ -31163,6 +27857,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31172,6 +27867,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhs-knowns_0 @@ -31217,6 +27913,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31226,6 +27923,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 body-knowns_0 @@ -31525,6 +28223,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31534,6 +28233,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 knowns_1 @@ -31561,6 +28261,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31572,6 +28273,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (letrec-split-values-binding @@ -31621,6 +28323,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31632,6 +28335,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhs_0 @@ -31737,6 +28441,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31748,6 +28453,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 bodys_0 @@ -31862,6 +28568,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31873,6 +28580,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 tst_0 @@ -31882,6 +28590,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31893,6 +28602,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 thn_0 @@ -31905,6 +28615,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -31916,6 +28627,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 els_0 @@ -32030,6 +28742,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32041,6 +28754,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 key_0 @@ -32050,6 +28764,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32061,6 +28776,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 val_0 @@ -32070,6 +28786,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32081,6 +28798,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 body_0 @@ -32185,6 +28903,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32196,6 +28915,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exp_0 @@ -32223,6 +28943,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32234,6 +28955,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exps_0 @@ -32261,6 +28983,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32272,6 +28995,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exps_0 @@ -32315,6 +29039,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32326,6 +29051,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exp_0 @@ -32382,6 +29108,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32393,6 +29120,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exp_0 @@ -32404,6 +29132,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32415,6 +29144,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exps_0 @@ -32501,6 +29231,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32512,6 +29243,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rhs_0 @@ -32685,6 +29417,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32696,6 +29429,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (list @@ -32929,6 +29663,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32940,6 +29675,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exp1_0 @@ -32949,6 +29685,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -32960,6 +29697,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exp2_0 @@ -33088,6 +29826,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33099,6 +29838,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 generator_0 @@ -33110,6 +29850,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33121,6 +29862,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 receiver_0 @@ -33136,6 +29878,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33147,6 +29890,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 generator_0 @@ -33157,6 +29901,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33168,6 +29913,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 receiver_0 @@ -33327,6 +30073,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33338,6 +30085,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (list @@ -33391,6 +30139,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 exps_0 @@ -33402,6 +30151,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 wcm-state_0 @@ -33416,6 +30166,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 exps_0 @@ -33429,6 +30180,7 @@ prim-knowns_0 primitives_0 rator_0 + serializable?-box_0 simples_0 unsafe-mode?_0 wcm-state_0) @@ -33440,6 +30192,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33451,6 +30204,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 rator_0 @@ -33460,6 +30214,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33471,6 +30226,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 exps_0 @@ -33533,6 +30289,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33544,6 +30301,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 k_0 @@ -33563,6 +30321,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33574,6 +30333,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 k_0 @@ -33593,6 +30353,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33604,6 +30365,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 k_0 @@ -33741,6 +30503,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33752,6 +30515,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 (known-copy-id @@ -33797,6 +30561,8 @@ simples_0 allow-set!-undefined?_0 add-import!_0 + serializable?-box_0 + datum-intern?_0 for-cify?_0 for-interp?_0 unsafe-mode?_0 @@ -33808,6 +30574,7 @@ add-import!_0 allow-inline?_0 allow-set!-undefined?_0 + datum-intern?_0 explicit-unnamed?_0 exports_0 for-cify?_0 @@ -33817,6 +30584,7 @@ no-prompt?_0 prim-knowns_0 primitives_0 + serializable?-box_0 simples_0 unsafe-mode?_0 knowns_0 @@ -49668,39 +46436,42 @@ e_0)) e_0)))))))))))))))))))) (lambda (e_0) (xify_0 e_0 hash2610)))) -(define relative-path-elements->path - (lambda (elems_0) - (let ((wrt-dir_0 - (let ((or-part_0 (current-load-relative-directory))) - (if or-part_0 or-part_0 (current-directory))))) - (let ((rel-elems_0 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0) - (begin - (if (pair? lst_0) - (let ((p_0 (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((fold-var_1 - (let ((fold-var_1 - (cons - (if (bytes? p_0) - (bytes->path-element p_0) - p_0) - fold-var_0))) - (values fold-var_1)))) - (for-loop_0 fold-var_1 rest_0)))) - fold-var_0)))))) - (for-loop_0 null elems_0)))))) - (if wrt-dir_0 - (apply build-path wrt-dir_0 rel-elems_0) - (if (null? rel-elems_0) - (build-path 'same) - (apply build-path rel-elems_0))))))) +(define kernel (primitive-table '|#%kernel|)) +(define 1/syntax? (hash-ref kernel 'syntax?)) +(define 1/syntax-e (hash-ref kernel 'syntax-e)) +(define 1/datum->syntax (hash-ref kernel 'datum->syntax)) +(define 1/syntax->datum (hash-ref kernel 'syntax->datum)) +(define 1/syntax-property (hash-ref kernel 'syntax-property)) +(define 1/syntax-property-symbol-keys + (hash-ref kernel 'syntax-property-symbol-keys)) +(define 1/syntax-source (hash-ref kernel 'syntax-source)) +(define 1/syntax-line (hash-ref kernel 'syntax-line)) +(define 1/syntax-column (hash-ref kernel 'syntax-column)) +(define 1/syntax-position (hash-ref kernel 'syntax-position)) +(define 1/syntax-span (hash-ref kernel 'syntax-span)) +(define correlated? (lambda (e_0) (|#%app| 1/syntax? e_0))) +(define datum->correlated + (let ((datum->correlated_0 + (|#%name| + datum->correlated + (lambda (d3_0 srcloc1_0 props2_0) + (begin (|#%app| 1/datum->syntax #f d3_0 srcloc1_0 props2_0)))))) + (case-lambda + ((d_0) (datum->correlated_0 d_0 #f #f)) + ((d_0 srcloc_0 props2_0) (datum->correlated_0 d_0 srcloc_0 props2_0)) + ((d_0 srcloc1_0) (datum->correlated_0 d_0 srcloc1_0 #f))))) +(define correlated-e (lambda (e_0) (|#%app| 1/syntax-e e_0))) +(define correlated-property + (case-lambda + ((e_0 k_0) (|#%app| 1/syntax-property e_0 k_0)) + ((e_0 k_0 v_0) (|#%app| 1/syntax-property e_0 k_0 v_0)))) +(define correlated-property-symbol-keys + (lambda (e_0) (|#%app| 1/syntax-property-symbol-keys e_0))) +(define correlated-source (lambda (s_0) (|#%app| 1/syntax-source s_0))) +(define correlated-line (lambda (s_0) (|#%app| 1/syntax-line s_0))) +(define correlated-column (lambda (s_0) (|#%app| 1/syntax-column s_0))) +(define correlated-position (lambda (s_0) (|#%app| 1/syntax-position s_0))) +(define correlated-span (lambda (s_0) (|#%app| 1/syntax-span s_0))) (define make-path->relative-path-elements.1 (letrec ((procz1 (lambda (v_0) #f)) (loop_0 @@ -49997,42 +46768,6 @@ #f)) #f) #f))))))))))))) -(define kernel (primitive-table '|#%kernel|)) -(define 1/syntax? (hash-ref kernel 'syntax?)) -(define 1/syntax-e (hash-ref kernel 'syntax-e)) -(define 1/datum->syntax (hash-ref kernel 'datum->syntax)) -(define 1/syntax->datum (hash-ref kernel 'syntax->datum)) -(define 1/syntax-property (hash-ref kernel 'syntax-property)) -(define 1/syntax-property-symbol-keys - (hash-ref kernel 'syntax-property-symbol-keys)) -(define 1/syntax-source (hash-ref kernel 'syntax-source)) -(define 1/syntax-line (hash-ref kernel 'syntax-line)) -(define 1/syntax-column (hash-ref kernel 'syntax-column)) -(define 1/syntax-position (hash-ref kernel 'syntax-position)) -(define 1/syntax-span (hash-ref kernel 'syntax-span)) -(define correlated? (lambda (e_0) (|#%app| 1/syntax? e_0))) -(define datum->correlated - (let ((datum->correlated_0 - (|#%name| - datum->correlated - (lambda (d3_0 srcloc1_0 props2_0) - (begin (|#%app| 1/datum->syntax #f d3_0 srcloc1_0 props2_0)))))) - (case-lambda - ((d_0) (datum->correlated_0 d_0 #f #f)) - ((d_0 srcloc_0 props2_0) (datum->correlated_0 d_0 srcloc_0 props2_0)) - ((d_0 srcloc1_0) (datum->correlated_0 d_0 srcloc1_0 #f))))) -(define correlated-e (lambda (e_0) (|#%app| 1/syntax-e e_0))) -(define correlated-property - (case-lambda - ((e_0 k_0) (|#%app| 1/syntax-property e_0 k_0)) - ((e_0 k_0 v_0) (|#%app| 1/syntax-property e_0 k_0 v_0)))) -(define correlated-property-symbol-keys - (lambda (e_0) (|#%app| 1/syntax-property-symbol-keys e_0))) -(define correlated-source (lambda (s_0) (|#%app| 1/syntax-source s_0))) -(define correlated-line (lambda (s_0) (|#%app| 1/syntax-line s_0))) -(define correlated-column (lambda (s_0) (|#%app| 1/syntax-column s_0))) -(define correlated-position (lambda (s_0) (|#%app| 1/syntax-position s_0))) -(define correlated-span (lambda (s_0) (|#%app| 1/syntax-span s_0))) (define 1/write-byte (|#%name| write-byte @@ -51137,17 +47872,18 @@ (lambda (external-lift?7_0 handle-fail6_0 keep-mutable?5_0 - v12_0 - orig-o11_0) + skip-prefix?8_0 + v14_0 + orig-o13_0) (begin (begin - (if orig-o11_0 - (if (output-port? orig-o11_0) + (if orig-o13_0 + (if (output-port? orig-o13_0) (void) (raise-argument-error 's-exp->fasl "(or/c output-port? #f)" - orig-o11_0)) + orig-o13_0)) (void)) (begin (if handle-fail6_0 @@ -51171,7 +47907,7 @@ "(or/c (procedure-arity-includes/c 1) #f)" external-lift?7_0)) (void)) - (let ((o_0 (if orig-o11_0 orig-o11_0 (open-output-bytes)))) + (let ((o_0 (if orig-o13_0 orig-o13_0 (open-output-bytes)))) (let ((shared_0 (make-hasheq))) (let ((external-lift_0 (if external-lift?7_0 (make-hasheq) #f))) @@ -51182,13 +47918,15 @@ external-lift_0 shared-counter_0 shared_0 - v12_0) + v14_0) (let ((path->relative-path-elements_0 (make-path->relative-path-elements.1 #f unsafe-undefined))) (begin - (1/write-bytes fasl-prefix o_0) + (if skip-prefix?8_0 + (void) + (1/write-bytes fasl-prefix o_0)) (let ((bstr_0 (let ((o_1 (open-output-bytes))) (begin @@ -51199,7 +47937,7 @@ path->relative-path-elements_0 shared-counter_0 shared_0 - v12_0) + v14_0) (get-output-bytes o_1 #t))))) (begin (write-fasl-integer @@ -51209,19 +47947,19 @@ (unsafe-bytes-length bstr_0) o_0) (1/write-bytes bstr_0 o_0) - (if orig-o11_0 + (if orig-o13_0 (void) (get-output-bytes o_0))))))))))))))))))) (define fasl->s-exp.1 (letrec ((intern_0 (|#%name| intern - (lambda (datum-intern?14_0 v_0) - (begin (if datum-intern?14_0 (datum-intern-literal v_0) v_0))))) + (lambda (datum-intern?16_0 v_0) + (begin (if datum-intern?16_0 (datum-intern-literal v_0) v_0))))) (loop_0 (|#%name| loop - (lambda (datum-intern?14_0 i_0 shared-count_0 shared_0) + (lambda (datum-intern?16_0 i_0 shared-count_0 shared_0) (begin (let ((type_0 (read-byte/no-eof i_0))) (let ((index_0 @@ -51287,10 +48025,10 @@ "tag" type_0)) (if (unsafe-fx< index_0 2) - (let ((pos_0 (read-fasl-integer i_0))) + (let ((pos_0 (|#%app| read-fasl-integer i_0))) (let ((v_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -51301,7 +48039,7 @@ (vector-set! shared_0 pos_0 v_0) v_0))) (if (unsafe-fx< index_0 3) - (let ((pos_0 (read-fasl-integer i_0))) + (let ((pos_0 (|#%app| read-fasl-integer i_0))) (begin (if (< pos_0 shared-count_0) (void) @@ -51315,8 +48053,8 @@ (if (unsafe-fx< index_0 8) eof (intern_0 - datum-intern?14_0 - (read-fasl-integer i_0)))))) + datum-intern?16_0 + (|#%app| read-fasl-integer i_0)))))) (if (unsafe-fx< index_0 14) (if (unsafe-fx< index_0 11) (if (unsafe-fx< index_0 10) @@ -51330,7 +48068,7 @@ (if (unsafe-fx< index_0 12) (let ((bstr_0 (read-bytes/exactly - (read-fasl-integer i_0) + (|#%app| read-fasl-integer i_0) i_0))) (string->number (bytes->string/utf-8 bstr_0) @@ -51338,69 +48076,71 @@ 'read)) (if (unsafe-fx< index_0 13) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (/ app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)))) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (make-rectangular app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))))))) (if (unsafe-fx< index_0 16) (if (unsafe-fx< index_0 15) (intern_0 - datum-intern?14_0 - (integer->char (read-fasl-integer i_0))) - (string->symbol (read-fasl-string i_0))) + datum-intern?16_0 + (integer->char + (|#%app| read-fasl-integer i_0))) + (string->symbol (|#%app| read-fasl-string i_0))) (if (unsafe-fx< index_0 17) (string->unreadable-symbol - (read-fasl-string i_0)) + (|#%app| read-fasl-string i_0)) (if (unsafe-fx< index_0 18) (string->uninterned-symbol - (read-fasl-string i_0)) + (|#%app| read-fasl-string i_0)) (if (unsafe-fx< index_0 19) - (string->keyword (read-fasl-string i_0)) - (read-fasl-string i_0))))))) + (string->keyword + (|#%app| read-fasl-string i_0)) + (|#%app| read-fasl-string i_0))))))) (if (unsafe-fx< index_0 30) (if (unsafe-fx< index_0 24) (if (unsafe-fx< index_0 21) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (string->immutable-string - (read-fasl-string i_0))) + (|#%app| read-fasl-string i_0))) (if (unsafe-fx< index_0 22) (read-fasl-bytes i_0) (if (unsafe-fx< index_0 23) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (bytes->immutable-bytes (read-fasl-bytes i_0))) (let ((app_0 (read-fasl-bytes i_0))) (bytes->path app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)))))) @@ -51412,7 +48152,7 @@ (reverse$1 (let ((lst_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -51452,21 +48192,22 @@ (build-path 'same) (apply build-path rel-elems_0))))) (intern_0 - datum-intern?14_0 - (pregexp (read-fasl-string i_0)))) + datum-intern?16_0 + (pregexp (|#%app| read-fasl-string i_0)))) (if (unsafe-fx< index_0 27) (intern_0 - datum-intern?14_0 - (regexp (read-fasl-string i_0))) + datum-intern?16_0 + (regexp (|#%app| read-fasl-string i_0))) (if (unsafe-fx< index_0 28) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (byte-pregexp (read-fasl-bytes i_0))) (if (unsafe-fx< index_0 29) (intern_0 - datum-intern?14_0 + datum-intern?16_0 (byte-regexp (read-fasl-bytes i_0))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 + (|#%app| read-fasl-integer i_0))) (reverse$1 (begin (letrec* @@ -51480,7 +48221,7 @@ (let ((fold-var_1 (cons (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0) @@ -51497,26 +48238,26 @@ (if (unsafe-fx< index_0 31) (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (cons app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (ploop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0 len_0))) (if (unsafe-fx< index_0 33) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (let ((vec_0 (begin (if (exact-nonnegative-integer? @@ -51545,7 +48286,7 @@ v_0 i_1 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)) @@ -51576,13 +48317,13 @@ (if (unsafe-fx< index_0 34) (box (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)) (box-immutable (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))))) @@ -51590,11 +48331,11 @@ (if (unsafe-fx< index_0 36) (let ((key_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (apply make-prefab-struct key_0 @@ -51611,7 +48352,7 @@ (let ((fold-var_1 (cons (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0) @@ -51630,7 +48371,7 @@ (if (eq? tmp_0 2) (make-hasheqv) (make-hash)))))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (begin (begin (letrec* @@ -51643,7 +48384,7 @@ (begin (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -51651,7 +48392,7 @@ ht_0 app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -51668,7 +48409,7 @@ (if (eq? tmp_0 2) hash2589 hash2725))))) - (let ((len_0 (read-fasl-integer i_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) (begin (letrec* ((for-loop_0 @@ -51681,7 +48422,7 @@ (let ((ht_2 (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -51689,7 +48430,7 @@ ht_1 app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))))) @@ -51700,25 +48441,25 @@ (if (unsafe-fx< index_0 39) (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (let ((app_1 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (let ((app_2 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (let ((app_3 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -51728,20 +48469,20 @@ app_2 app_3 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0)))))) (if (unsafe-fx< index_0 40) (let ((e_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (let ((s_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -51766,7 +48507,7 @@ s_0))))))))) (let ((lst_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) @@ -51811,48 +48552,50 @@ (ploop_0 (|#%name| ploop - (lambda (datum-intern?14_0 i_0 shared-count_0 shared_0 len_0) + (lambda (datum-intern?16_0 i_0 shared-count_0 shared_0 len_0) (begin (if (zero? len_0) - (loop_0 datum-intern?14_0 i_0 shared-count_0 shared_0) + (loop_0 datum-intern?16_0 i_0 shared-count_0 shared_0) (let ((app_0 (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))) (cons app_0 (ploop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0 (sub1 len_0)))))))))) (|#%name| fasl->s-exp - (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 (let ((external-lifts_0 - (if (eq? external-lifts15_0 unsafe-undefined) + (if (eq? external-lifts17_0 unsafe-undefined) '#() - external-lifts15_0))) + external-lifts17_0))) (let ((init-i_0 - (if (bytes? orig-i18_0) - (mcons orig-i18_0 0) - (if (input-port? orig-i18_0) - orig-i18_0 + (if (bytes? orig-i22_0) + (mcons orig-i22_0 0) + (if (input-port? orig-i22_0) + orig-i22_0 (raise-argument-error 'fasl->s-exp "(or/c bytes? input-port?)" - orig-i18_0))))) + orig-i22_0))))) (begin - (if (bytes=? - (read-bytes/exactly fasl-prefix-length init-i_0) - fasl-prefix) + (if skip-prefix?18_0 (void) - (read-error "unrecognized prefix")) - (let ((shared-count_0 (read-fasl-integer init-i_0))) + (if (bytes=? + (read-bytes/exactly* fasl-prefix-length init-i_0) + fasl-prefix) + (void) + (read-error "unrecognized prefix"))) + (let ((shared-count_0 (read-fasl-integer* init-i_0))) (let ((shared_0 (make-vector shared-count_0))) (begin (if (if (vector? external-lifts_0) @@ -51901,15 +48644,15 @@ (values))))))) (for-loop_0 0 start_0)))))) (args (raise-binding-result-arity-error 2 args)))) - (let ((len_0 (read-fasl-integer init-i_0))) + (let ((len_0 (read-fasl-integer* init-i_0))) (let ((i_0 (if (mpair? init-i_0) init-i_0 (let ((bstr_0 - (read-bytes/exactly len_0 init-i_0))) + (read-bytes/exactly* len_0 init-i_0))) (mcons bstr_0 0))))) (loop_0 - datum-intern?14_0 + datum-intern?16_0 i_0 shared-count_0 shared_0))))))))))))))) @@ -51956,30 +48699,37 @@ (string-append "error parsing fasl stream;\n" " " s_0) args_0))) (define read-byte/no-eof + (lambda (i_0) + (let ((pos_0 (unsafe-mcdr i_0))) + (begin + (if (< pos_0 (unsafe-bytes-length (unsafe-mcar i_0))) + (void) + (read-error "truncated stream")) + (unsafe-set-mcdr! i_0 (fx+ pos_0 1)) + (unsafe-bytes-ref (unsafe-mcar i_0) pos_0))))) +(define read-byte/no-eof* (lambda (i_0) (if (mpair? i_0) - (let ((pos_0 (mcdr i_0))) - (begin - (if (< pos_0 (unsafe-bytes-length (mcar i_0))) - (void) - (read-error "truncated stream")) - (set-mcdr! i_0 (add1 pos_0)) - (unsafe-bytes-ref (mcar i_0) pos_0))) + (read-byte/no-eof i_0) (let ((b_0 (read-byte i_0))) (begin (if (eof-object? b_0) (read-error "truncated stream") (void)) b_0))))) (define read-bytes/exactly + (lambda (n_0 i_0) + (let ((pos_0 (unsafe-mcdr i_0))) + (begin + (if (let ((app_0 (+ pos_0 n_0))) + (<= app_0 (unsafe-bytes-length (unsafe-mcar i_0)))) + (void) + (read-error "truncated stream")) + (unsafe-set-mcdr! i_0 (fx+ pos_0 n_0)) + (let ((app_0 (unsafe-mcar i_0))) + (subbytes app_0 pos_0 (fx+ pos_0 n_0))))))) +(define read-bytes/exactly* (lambda (n_0 i_0) (if (mpair? i_0) - (let ((pos_0 (mcdr i_0))) - (begin - (if (let ((app_0 (+ pos_0 n_0))) - (<= app_0 (unsafe-bytes-length (mcar i_0)))) - (void) - (read-error "truncated stream")) - (set-mcdr! i_0 (+ pos_0 n_0)) - (let ((app_0 (mcar i_0))) (subbytes app_0 pos_0 (+ pos_0 n_0))))) + (read-bytes/exactly n_0 i_0) (let ((bstr_0 (read-bytes n_0 i_0))) (begin (if (if (bytes? bstr_0) (= n_0 (unsafe-bytes-length bstr_0)) #f) @@ -51989,19 +48739,75 @@ (define read-fasl-integer (lambda (i_0) (let ((b_0 (read-byte/no-eof i_0))) - (if (<= b_0 127) + (if (fx<= b_0 127) b_0 - (if (>= b_0 132) - (- b_0 256) + (if (fx>= b_0 132) + (fx- b_0 256) (if (eqv? b_0 128) - (integer-bytes->integer (read-bytes/exactly 2 i_0) #t #f) + (let ((lo_0 (read-byte/no-eof i_0))) + (let ((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) - (integer-bytes->integer (read-bytes/exactly 4 i_0) #t #f) + (let ((a_0 (read-byte/no-eof i_0))) + (let ((b_1 (read-byte/no-eof i_0))) + (let ((c_0 (read-byte/no-eof i_0))) + (let ((d_0 (read-byte/no-eof i_0))) + (bitwise-ior + a_0 + (arithmetic-shift + (if (fx> d_0 127) + (let ((app_0 (fxlshift (fx+ -256 d_0) 16))) + (fxior app_0 (fxlshift c_0 8) b_1)) + (let ((app_0 (fxlshift d_0 16))) + (fxior app_0 (fxlshift c_0 8) b_1))) + 8)))))) (if (eqv? b_0 130) (integer-bytes->integer (read-bytes/exactly 8 i_0) #t #f) (if (eqv? b_0 131) - (let ((len_0 (read-fasl-integer i_0))) - (let ((str_0 (read-fasl-string i_0 len_0))) + (let ((len_0 (|#%app| read-fasl-integer i_0))) + (let ((str_0 (|#%app| read-fasl-string i_0 len_0))) + (begin + (if (if (string? str_0) + (= len_0 (string-length str_0)) + #f) + (void) + (read-error "truncated stream at number")) + (string->number str_0 16)))) + (read-error "internal error on integer mode")))))))))) +(define read-fasl-integer* + (lambda (i_0) + (let ((b_0 (read-byte/no-eof* i_0))) + (if (fx<= b_0 127) + b_0 + (if (fx>= b_0 132) + (fx- b_0 256) + (if (eqv? b_0 128) + (let ((lo_0 (read-byte/no-eof* i_0))) + (let ((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 ((a_0 (read-byte/no-eof* i_0))) + (let ((b_1 (read-byte/no-eof* i_0))) + (let ((c_0 (read-byte/no-eof* i_0))) + (let ((d_0 (read-byte/no-eof* i_0))) + (bitwise-ior + a_0 + (arithmetic-shift + (if (fx> d_0 127) + (let ((app_0 (fxlshift (fx+ -256 d_0) 16))) + (fxior app_0 (fxlshift c_0 8) b_1)) + (let ((app_0 (fxlshift d_0 16))) + (fxior app_0 (fxlshift c_0 8) b_1))) + 8)))))) + (if (eqv? b_0 130) + (integer-bytes->integer (read-bytes/exactly* 8 i_0) #t #f) + (if (eqv? b_0 131) + (let ((len_0 (|#%app| read-fasl-integer i_0))) + (let ((str_0 (|#%app| read-fasl-string i_0 len_0))) (begin (if (if (string? str_0) (= len_0 (string-length str_0)) @@ -52014,314 +48820,223 @@ (let ((read-fasl-string_0 (|#%name| read-fasl-string - (lambda (i21_0 len20_0) + (lambda (i25_0 len24_0) (begin (let ((len_0 - (if (eq? len20_0 unsafe-undefined) - (read-fasl-integer i21_0) - len20_0))) - (let ((bstr_0 (read-bytes/exactly len_0 i21_0))) - (bytes->string/utf-8 bstr_0)))))))) + (if (eq? len24_0 unsafe-undefined) + (|#%app| read-fasl-integer i25_0) + len24_0))) + (let ((pos_0 (unsafe-mcdr i25_0))) + (let ((bstr_0 (unsafe-mcar i25_0))) + (if (<= (+ pos_0 len_0) (unsafe-bytes-length bstr_0)) + (begin + (unsafe-set-mcdr! i25_0 (fx+ pos_0 len_0)) + (let ((s_0 (make-string len_0))) + (letrec* + ((loop_0 + (|#%name| + loop + (lambda (i_0) + (begin + (if (fx= i_0 len_0) + s_0 + (let ((c_0 + (unsafe-bytes-ref + bstr_0 + (fx+ i_0 pos_0)))) + (if (fx<= c_0 128) + (begin + (string-set! + s_0 + i_0 + (integer->char c_0)) + (loop_0 (fx+ i_0 1))) + (bytes->string/utf-8 + bstr_0 + #f + pos_0 + (fx+ pos_0 len_0)))))))))) + (loop_0 0)))) + (let ((bstr_1 (read-bytes/exactly len_0 i25_0))) + (bytes->string/utf-8 bstr_1))))))))))) (case-lambda ((i_0) (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 read-fasl-bytes (lambda (i_0) - (let ((len_0 (read-fasl-integer i_0))) (read-bytes/exactly len_0 i_0)))) -(define extract-paths-and-fasls-from-schemified-linklet - (letrec ((path-binding?_0 - (|#%name| - path-binding? - (lambda (b_0) - (begin - (let ((rhs_0 (cadr b_0))) - (let ((or-part_0 (path? rhs_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 (path-for-srcloc? rhs_0))) - (if or-part_1 or-part_1 (to-fasl? rhs_0))))))))))) - (lambda (linklet-e_0 convert?_0) - (let ((hd_0 - (let ((p_0 (unwrap linklet-e_0))) - (if (pair? p_0) (unwrap (car p_0)) #f)))) - (if (if (eq? 'lambda hd_0) #t #f) - (values '() linklet-e_0) - (if (if (eq? 'let* hd_0) - (let ((a_0 (cdr (unwrap linklet-e_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap linklet-e_0)))) - (let ((p_0 (unwrap d_0))) - (let ((bindings_0 (let ((a_0 (car p_0))) a_0))) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((bindings_1 bindings_0)) - (values bindings_1 body_0))))))) - (case-lambda - ((bindings_0 body_0) - (let ((any-path?_0 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 lst_0) - (begin - (if (pair? lst_0) - (let ((b_0 (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((result_1 - (let ((result_1 - (path-binding?_0 b_0))) - (values result_1)))) - (if (if (not - (let ((x_0 (list b_0))) - result_1)) - #t - #f) - (for-loop_0 result_1 rest_0) - result_1)))) - result_0)))))) - (for-loop_0 #f bindings_0))))) - (if any-path?_0 - (let ((paths_0 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0) - (begin - (if (pair? lst_0) - (let ((b_0 (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((fold-var_1 - (if (path-binding?_0 b_0) - (let ((fold-var_1 - (cons - (cadr b_0) - fold-var_0))) - (values fold-var_1)) - fold-var_0))) - (for-loop_0 fold-var_1 rest_0)))) - fold-var_0)))))) - (for-loop_0 null bindings_0)))))) - (if convert?_0 - (let ((path-ids_0 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0) - (begin - (if (pair? lst_0) - (let ((b_0 (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((fold-var_1 - (if (path-binding?_0 b_0) - (let ((fold-var_1 - (cons - (car b_0) - fold-var_0))) - (values fold-var_1)) - fold-var_0))) - (for-loop_0 - fold-var_1 - rest_0)))) - fold-var_0)))))) - (for-loop_0 null bindings_0)))))) - (let ((other-bindings_0 - (reverse$1 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (fold-var_0 lst_0) - (begin - (if (pair? lst_0) - (let ((b_0 (unsafe-car lst_0))) - (let ((rest_0 - (unsafe-cdr lst_0))) - (let ((fold-var_1 - (if (path-binding?_0 - b_0) - fold-var_0 - (let ((fold-var_1 - (cons - b_0 - fold-var_0))) - (values - fold-var_1))))) - (for-loop_0 - fold-var_1 - rest_0)))) - fold-var_0)))))) - (for-loop_0 null bindings_0)))))) - (values - paths_0 - (list - 'lambda - path-ids_0 - (list 'let* other-bindings_0 body_0))))) - (values paths_0 linklet-e_0))) - (values '() linklet-e_0)))) - (args (raise-binding-result-arity-error 2 args)))) - (error 'match "failed ~e" linklet-e_0))))))) -(define make-path->compiled-path - (letrec ((make-path->compiled-path_0 - (|#%name| - make-path->compiled-path - (lambda (path->relative-path-elements_0 orig-p3_0 for-srcloc?2_0) - (begin - (if (to-fasl? orig-p3_0) - (let ((v_0 (1/force-unfasl orig-p3_0))) - (if (symbol? v_0) - (box v_0) - (let ((lifts_0 '())) - (let ((cannot-fasl5_0 cannot-fasl)) - (let ((bstr_0 - (let ((temp6_0 - (lambda (v_1) - (if (symbol? v_1) - (if (not (symbol-interned? v_1)) - (if (not - (symbol-unreadable? v_1)) - (begin - (set! lifts_0 - (cons v_1 lifts_0)) - #t) - #f) - #f) - #f)))) - (s-exp->fasl.1 - temp6_0 - cannot-fasl5_0 - #f - v_0 - #f)))) - (if (null? lifts_0) - (box bstr_0) - (box - (cons - bstr_0 - (list->vector (reverse$1 lifts_0)))))))))) - (if (symbol? orig-p3_0) - orig-p3_0 - (let ((p_0 - (if (path-for-srcloc? orig-p3_0) - (path-for-srcloc-path orig-p3_0) - orig-p3_0))) - (if (path? p_0) - (let ((or-part_0 - (|#%app| path->relative-path-elements_0 p_0))) - (if or-part_0 - or-part_0 - (if (if for-srcloc?2_0 - for-srcloc?2_0 - (path-for-srcloc? orig-p3_0)) - (truncate-path p_0) - (path->bytes p_0)))) - (if (let ((or-part_0 (string? p_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 (bytes? p_0))) - (if or-part_1 - or-part_1 - (let ((or-part_2 (symbol? p_0))) - (if or-part_2 or-part_2 (not p_0))))))) - p_0 - (error - 'write - "cannot marshal value that is embedded in compiled code: ~V" - p_0))))))))))) - (lambda (who_0) - (let ((path->relative-path-elements_0 - (make-path->relative-path-elements.1 who_0 unsafe-undefined))) - (|#%name| - make-path->compiled-path - (case-lambda - ((orig-p_0) - (begin - (make-path->compiled-path_0 - path->relative-path-elements_0 - orig-p_0 - #f))) - ((orig-p_0 for-srcloc?2_0) - (make-path->compiled-path_0 - path->relative-path-elements_0 - orig-p_0 - for-srcloc?2_0)))))))) -(define compiled-path->path - (lambda (e_0) - (if (box? e_0) - (let ((c_0 (unbox e_0))) - (let ((app_0 (box (if (pair? c_0) (car c_0) c_0)))) - (let ((app_1 (if (pair? c_0) (cdr c_0) '#()))) - (to-fasl1.1 - app_0 - app_1 - (if (not (symbol? c_0)) - (let ((or-part_0 (current-load-relative-directory))) - (if or-part_0 or-part_0 (current-directory))) - #f))))) - (if (symbol? e_0) - e_0 - (if (bytes? e_0) - (bytes->path e_0) - (if (string? e_0) e_0 (relative-path-elements->path e_0))))))) -(define 1/force-unfasl + (let ((len_0 (|#%app| read-fasl-integer i_0))) + (read-bytes/exactly len_0 i_0)))) +(define fasl-literal? + (lambda (q_0 need-exposed?_0) + (if (impersonator? q_0) + #t + (if (path? q_0) + #t + (if (regexp? q_0) + #t + (if (srcloc? q_0) + #t + (if (byte-regexp? q_0) + #t + (if (keyword? q_0) + #t + (if (hash? q_0) + #t + (if (string? q_0) + #t + (if (bytes? q_0) + #t + (if (prefab-struct-key q_0) + #t + (if (|#%app| need-exposed?_0 q_0) + #t + (if (extflonum? q_0) #t #f)))))))))))))) +(define struct:to-unfasl + (make-record-type-descriptor* 'to-unfasl #f #f #f #f 3 7)) +(define effect_3053 + (struct-type-install-properties! + struct:to-unfasl + 'to-unfasl + 3 + 0 + #f + null + (current-inspector) + #f + '(0 1 2) + #f + 'to-unfasl)) +(define to-unfasl1.1 (|#%name| - force-unfasl - (lambda (tf_0) - (begin - (if (not (to-fasl? tf_0)) - tf_0 - (let ((vb_0 (to-fasl-vb tf_0))) - (let ((v_0 (unbox vb_0))) - (if (bytes? v_0) - (let ((v2_0 - (with-continuation-mark* - push-authentic - parameterization-key - (let ((app_0 - (continuation-mark-set-first - #f - parameterization-key))) - (extend-parameterization - app_0 - current-load-relative-directory - (to-fasl-wrt tf_0))) - (let ((temp9_0 (to-fasl-lifts tf_0))) - (fasl->s-exp.1 #t temp9_0 v_0))))) - (letrec* - ((loop_0 - (|#%name| - loop - (lambda () - (begin - (if (unsafe-box*-cas! vb_0 v_0 v2_0) - (begin (set-to-fasl-wrt! tf_0 #f) v2_0) - (let ((v_1 (unbox vb_0))) - (if (bytes? v_1) (loop_0) v_1)))))))) - (loop_0))) - v_0)))))))) + to-unfasl + (record-constructor + (make-record-constructor-descriptor struct:to-unfasl #f #f)))) +(define to-unfasl?_2342 + (|#%name| to-unfasl? (record-predicate struct:to-unfasl))) +(define to-unfasl? + (|#%name| + to-unfasl? + (lambda (v) + (if (to-unfasl?_2342 v) + #t + ($value + (if (impersonator? v) (to-unfasl?_2342 (impersonator-val v)) #f)))))) +(define to-unfasl-bstr_2318 + (|#%name| to-unfasl-bstr (record-accessor struct:to-unfasl 0))) +(define to-unfasl-bstr + (|#%name| + to-unfasl-bstr + (lambda (s) + (if (to-unfasl?_2342 s) + (to-unfasl-bstr_2318 s) + ($value + (impersonate-ref + to-unfasl-bstr_2318 + struct:to-unfasl + 0 + s + 'to-unfasl + 'bstr)))))) +(define to-unfasl-externals_2291 + (|#%name| to-unfasl-externals (record-accessor struct:to-unfasl 1))) +(define to-unfasl-externals + (|#%name| + to-unfasl-externals + (lambda (s) + (if (to-unfasl?_2342 s) + (to-unfasl-externals_2291 s) + ($value + (impersonate-ref + to-unfasl-externals_2291 + struct:to-unfasl + 1 + s + 'to-unfasl + 'externals)))))) +(define to-unfasl-wrt_2425 + (|#%name| to-unfasl-wrt (record-accessor struct:to-unfasl 2))) +(define to-unfasl-wrt + (|#%name| + to-unfasl-wrt + (lambda (s) + (if (to-unfasl?_2342 s) + (to-unfasl-wrt_2425 s) + ($value + (impersonate-ref + to-unfasl-wrt_2425 + struct:to-unfasl + 2 + s + 'to-unfasl + 'wrt)))))) +(define effect_1729 + (begin + (register-struct-constructor! to-unfasl1.1) + (register-struct-predicate! to-unfasl?) + (register-struct-field-accessor! to-unfasl-bstr struct:to-unfasl 0) + (register-struct-field-accessor! to-unfasl-externals struct:to-unfasl 1) + (register-struct-field-accessor! to-unfasl-wrt struct:to-unfasl 2) + (void))) +(define empty-literals? + (lambda (v_0) (if (vector? v_0) (eqv? 0 (vector-length v_0)) #f))) +(define fasl-literals + (lambda (v_0 need-exposed?_0) + (if (empty-literals? v_0) + v_0 + (let ((exposed_0 '())) + (let ((cannot-fasl5_0 cannot-fasl)) + (let ((bstr_0 + (let ((temp6_0 + (lambda (v_1) + (if (|#%app| need-exposed?_0 v_1) + (begin (set! exposed_0 (cons v_1 exposed_0)) #t) + #f)))) + (s-exp->fasl.1 temp6_0 cannot-fasl5_0 #f #t v_0 #f)))) + (if (null? exposed_0) + bstr_0 + (cons bstr_0 (list->vector (reverse$1 exposed_0)))))))))) +(define unfasl-literals/lazy + (lambda (v_0) + (if (empty-literals? v_0) + v_0 + (box + (let ((app_0 (if (pair? v_0) (car v_0) v_0))) + (let ((app_1 (if (pair? v_0) (cdr v_0) '#()))) + (to-unfasl1.1 app_0 app_1 (current-load-relative-directory)))))))) +(define force-unfasl-literals + (lambda (b_0) + (if (box? b_0) + (let ((v_0 (unbox b_0))) + (if (to-unfasl? v_0) + (let ((new-v_0 + (with-continuation-mark* + push-authentic + parameterization-key + (let ((app_0 + (continuation-mark-set-first + #f + parameterization-key))) + (extend-parameterization + app_0 + current-load-relative-directory + (to-unfasl-wrt v_0))) + (let ((temp7_0 (to-unfasl-bstr v_0))) + (let ((temp10_0 (to-unfasl-externals v_0))) + (let ((temp7_1 temp7_0)) + (fasl->s-exp.1 #t temp10_0 #t temp7_1))))))) + (letrec* + ((loop_0 + (|#%name| + loop + (lambda () + (begin + (if (unsafe-box*-cas! b_0 v_0 new-v_0) + new-v_0 + (let ((v_1 (unbox b_0))) + (if (to-unfasl? v_1) (loop_0) v_1)))))))) + (loop_0))) + v_0)) + b_0))) (define cannot-fasl (lambda (v_0) (error @@ -56999,7 +53714,7 @@ (lambda () (call-with-values (lambda () - (loop_0 + (loop_1 body-vars-index_0 e_1 env_1 @@ -57087,7 +53802,7 @@ mutated_0) (begin (let ((bs_0 - (loop_1 + (loop_0 env_0 mutated_0 serializable?_0 @@ -58732,6 +55447,83 @@ (box name_0) name_0))))))) (loop_0 + (|#%name| + loop + (lambda (env_0 + mutated_0 + serializable?_0 + stack-depth_0 + stk-i_0 + body_0) + (begin + (if (begin-unsafe + (let ((app_0 (unwrap '()))) (eq? app_0 (unwrap body_0)))) + '() + (if (let ((p_0 (unwrap body_0))) + (if (pair? p_0) + (if (let ((a_0 (car p_0))) + (let ((p_1 (unwrap a_0))) + (if (pair? p_1) + (if (let ((a_1 (car p_1))) + (begin-unsafe + (let ((app_0 (unwrap 'begin))) + (eq? app_0 (unwrap a_1))))) + (let ((a_1 (cdr p_1))) (wrap-list? a_1)) + #f) + #f))) + #t + #f) + #f)) + (call-with-values + (lambda () + (let ((p_0 (unwrap body_0))) + (let ((subs_0 + (let ((a_0 (car p_0))) + (let ((d_0 (cdr (unwrap a_0)))) + (unwrap-list d_0))))) + (let ((rest_0 (let ((d_0 (cdr p_0))) d_0))) + (let ((subs_1 subs_0)) + (values subs_1 rest_0)))))) + (case-lambda + ((subs_0 rest_0) + (loop_0 + env_0 + mutated_0 + serializable?_0 + stack-depth_0 + stk-i_0 + (append subs_0 rest_0))) + (args (raise-binding-result-arity-error 2 args)))) + (if (let ((p_0 (unwrap body_0))) (if (pair? p_0) #t #f)) + (call-with-values + (lambda () + (let ((p_0 (unwrap body_0))) + (let ((e_0 (let ((a_0 (car p_0))) a_0))) + (let ((rest_0 (let ((d_0 (cdr p_0))) d_0))) + (let ((e_1 e_0)) (values e_1 rest_0)))))) + (case-lambda + ((e_0 rest_0) + (let ((new-rest_0 + (loop_0 + env_0 + mutated_0 + serializable?_0 + stack-depth_0 + stk-i_0 + rest_0))) + (cons + (compile-expr_0 + serializable?_0 + e_0 + env_0 + stack-depth_0 + stk-i_0 + #t + mutated_0) + new-rest_0))) + (args (raise-binding-result-arity-error 2 args)))) + (error 'match "failed ~e" body_0)))))))) + (loop_1 (|#%name| loop (lambda (body-vars-index_0 e_0 env_0 num-body-vars_0) @@ -58846,7 +55638,7 @@ (lambda () (call-with-values (lambda () - (loop_0 + (loop_1 body-vars-index_0 e_2 env_1 @@ -58873,83 +55665,6 @@ (values env_1 num-body-vars_1))))))) (for-loop_0 env_0 num-body-vars_0 body_0)))) (values env_0 num-body-vars_0))))))))) - (loop_1 - (|#%name| - loop - (lambda (env_0 - mutated_0 - serializable?_0 - stack-depth_0 - stk-i_0 - body_0) - (begin - (if (begin-unsafe - (let ((app_0 (unwrap '()))) (eq? app_0 (unwrap body_0)))) - '() - (if (let ((p_0 (unwrap body_0))) - (if (pair? p_0) - (if (let ((a_0 (car p_0))) - (let ((p_1 (unwrap a_0))) - (if (pair? p_1) - (if (let ((a_1 (car p_1))) - (begin-unsafe - (let ((app_0 (unwrap 'begin))) - (eq? app_0 (unwrap a_1))))) - (let ((a_1 (cdr p_1))) (wrap-list? a_1)) - #f) - #f))) - #t - #f) - #f)) - (call-with-values - (lambda () - (let ((p_0 (unwrap body_0))) - (let ((subs_0 - (let ((a_0 (car p_0))) - (let ((d_0 (cdr (unwrap a_0)))) - (unwrap-list d_0))))) - (let ((rest_0 (let ((d_0 (cdr p_0))) d_0))) - (let ((subs_1 subs_0)) - (values subs_1 rest_0)))))) - (case-lambda - ((subs_0 rest_0) - (loop_1 - env_0 - mutated_0 - serializable?_0 - stack-depth_0 - stk-i_0 - (append subs_0 rest_0))) - (args (raise-binding-result-arity-error 2 args)))) - (if (let ((p_0 (unwrap body_0))) (if (pair? p_0) #t #f)) - (call-with-values - (lambda () - (let ((p_0 (unwrap body_0))) - (let ((e_0 (let ((a_0 (car p_0))) a_0))) - (let ((rest_0 (let ((d_0 (cdr p_0))) d_0))) - (let ((e_1 e_0)) (values e_1 rest_0)))))) - (case-lambda - ((e_0 rest_0) - (let ((new-rest_0 - (loop_1 - env_0 - mutated_0 - serializable?_0 - stack-depth_0 - stk-i_0 - rest_0))) - (cons - (compile-expr_0 - serializable?_0 - e_0 - env_0 - stack-depth_0 - stk-i_0 - #t - mutated_0) - new-rest_0))) - (args (raise-binding-result-arity-error 2 args)))) - (error 'match "failed ~e" body_0)))))))) (loop_2 (|#%name| loop @@ -59028,112 +55743,17 @@ start (lambda (serializable?_0 linklet-e_0) (begin - (let ((hd_0 - (let ((p_0 (unwrap linklet-e_0))) - (if (pair? p_0) (unwrap (car p_0)) #f)))) - (if (if (eq? 'lambda hd_0) #t #f) - (call-with-values - (lambda () - (compile-linklet-body_0 - serializable?_0 - linklet-e_0 - hash2610 - 0)) - (case-lambda - ((compiled-body_0 num-body-vars_0) - (vector #f num-body-vars_0 compiled-body_0)) - (args (raise-binding-result-arity-error 2 args)))) - (if (if (eq? 'let* hd_0) - (let ((a_0 (cdr (unwrap linklet-e_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap linklet-e_0)))) - (let ((p_0 (unwrap d_0))) - (let ((bindings_0 (let ((a_0 (car p_0))) a_0))) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) - a_0)))) - (let ((bindings_1 bindings_0)) - (values bindings_1 body_0))))))) - (case-lambda - ((bindings_0 body_0) - (let ((bindings-stk-i_0 - (make-stack-info.1 #f hash2610 #f))) - (letrec* - ((loop_4 - (|#%name| - loop - (lambda (bindings_1 elem_0 env_0 accum_0) - (begin - (if (null? bindings_1) - (call-with-values - (lambda () - (compile-linklet-body_0 - serializable?_0 - body_0 - env_0 - 1)) - (case-lambda - ((compiled-body_0 num-body-vars_0) - (vector - (list->vector (reverse$1 accum_0)) - num-body-vars_0 - compiled-body_0)) - (args - (raise-binding-result-arity-error - 2 - args)))) - (let ((binding_0 (car bindings_1))) - (let ((app_0 (cdr bindings_1))) - (let ((app_1 (fx+ elem_0 1))) - (let ((app_2 - (hash-set - env_0 - (car binding_0) - (indirect1.1 0 elem_0)))) - (loop_4 - app_0 - app_1 - app_2 - (let ((rhs_0 (cadr binding_0))) - (cons - (if (let ((or-part_0 - (path? rhs_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 - (path-for-srcloc? - rhs_0))) - (if or-part_1 - or-part_1 - (to-fasl? - rhs_0))))) - '|#%path| - (compile-expr_0 - serializable?_0 - rhs_0 - env_0 - 1 - bindings-stk-i_0 - #t - hash2610)) - accum_0))))))))))))) - (loop_4 bindings_0 0 hash2610 '())))) - (args (raise-binding-result-arity-error 2 args)))) - (error 'match "failed ~e" linklet-e_0))))))))) + (call-with-values + (lambda () + (compile-linklet-body_0 + serializable?_0 + linklet-e_0 + hash2610 + 0)) + (case-lambda + ((compiled-body_0 num-body-vars_0) + (vector num-body-vars_0 compiled-body_0)) + (args (raise-binding-result-arity-error 2 args))))))))) (lambda (linklet-e_0 serializable?_0) (with-continuation-mark* authentic @@ -59144,128 +55764,54 @@ (box 0)) (start_0 serializable?_0 linklet-e_0))))) (define interpret-linklet - (lambda (b_0 paths_0) - (let ((consts_0 (unsafe-vector*-ref b_0 0))) - (let ((num-body-vars_0 (unsafe-vector*-ref b_0 1))) - (let ((b_1 (unsafe-vector*-ref b_0 2))) - (let ((num-body-vars_1 num-body-vars_0) (consts_1 consts_0)) - (let ((consts_2 - (if consts_1 - (let ((vec_0 - (make-vector (unsafe-vector*-length consts_1)))) - (let ((stack_0 (stack-set #f 0 vec_0))) - (begin - (call-with-values - (lambda () - (begin - (check-vector consts_1) - (values - consts_1 - (unsafe-vector-length consts_1)))) - (case-lambda - ((vec_1 len_0) - (let ((start_0 0)) - (let ((vec_2 vec_1) (len_1 len_0)) - (begin - #f - (void) - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (paths_1 pos_0 pos_1) - (begin - (if (if (unsafe-fx< pos_0 len_1) - #t - #f) - (let ((b_2 - (unsafe-vector-ref - vec_2 - pos_0))) - (let ((paths_2 - (let ((paths_2 - (if (eq? - b_2 - '|#%path|) - (begin - (vector-set! - vec_0 - pos_1 - (car - paths_1)) - (cdr - paths_1)) - (begin - (vector-set! - vec_0 - pos_1 - (interpret-expr - b_2 - stack_0)) - paths_1)))) - (values paths_2)))) - (for-loop_0 - paths_2 - (unsafe-fx+ 1 pos_0) - (+ pos_1 1)))) - paths_1)))))) - (for-loop_0 paths_0 0 start_0)))))) - (args (raise-binding-result-arity-error 2 args)))) - vec_0))) - #f))) - (lambda args_0 - (let ((start-stack_0 - (if consts_2 (stack-set #f 0 consts_2) #f))) - (let ((args-stack_0 - (let ((start_0 (if consts_2 1 0))) + (lambda (b_0) + (let ((num-body-vars_0 (unsafe-vector*-ref b_0 0))) + (let ((b_1 (unsafe-vector*-ref b_0 1))) + (let ((num-body-vars_1 num-body-vars_0)) + (lambda args_0 + (let ((args-stack_0 + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (stack_0 lst_0 pos_0) (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (stack_0 lst_0 pos_0) - (begin - (if (if (pair? lst_0) #t #f) - (let ((arg_0 (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((stack_1 - (let ((stack_1 - (stack-set - stack_0 - pos_0 - arg_0))) - (values stack_1)))) - (for-loop_0 - stack_1 - rest_0 - (+ pos_0 1))))) - stack_0)))))) - (for-loop_0 start-stack_0 args_0 start_0)))))) - (let ((post-args-pos_0 - (begin-unsafe (intmap-count args-stack_0)))) - (let ((stack_0 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (stack_0 pos_0) - (begin - (if (< pos_0 num-body-vars_1) - (let ((stack_1 - (let ((stack_1 - (stack-set - stack_0 - (+ - pos_0 - post-args-pos_0) - (box - unsafe-undefined)))) - (values stack_1)))) - (for-loop_0 stack_1 (+ pos_0 1))) - stack_0)))))) - (for-loop_0 args-stack_0 0))))) - (interpret-expr b_1 stack_0))))))))))))) + (if (if (pair? lst_0) #t #f) + (let ((arg_0 (unsafe-car lst_0))) + (let ((rest_0 (unsafe-cdr lst_0))) + (let ((stack_1 + (let ((stack_1 + (stack-set + stack_0 + pos_0 + arg_0))) + (values stack_1)))) + (for-loop_0 stack_1 rest_0 (+ pos_0 1))))) + stack_0)))))) + (for-loop_0 #f args_0 0))))) + (let ((post-args-pos_0 + (begin-unsafe (intmap-count args-stack_0)))) + (let ((stack_0 + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (stack_0 pos_0) + (begin + (if (< pos_0 num-body-vars_1) + (let ((stack_1 + (let ((stack_1 + (stack-set + stack_0 + (+ pos_0 post-args-pos_0) + (box unsafe-undefined)))) + (values stack_1)))) + (for-loop_0 stack_1 (+ pos_0 1))) + stack_0)))))) + (for-loop_0 args-stack_0 0))))) + (interpret-expr b_1 stack_0)))))))))) (define interpret-expr (letrec ((apply-function_0 (|#%name| @@ -61173,8 +57719,8 @@ (letrec ((body-leftover-size_0 (|#%name| body-leftover-size - (lambda (serializable?_0 body_0 size_0) - (begin (begin (for-loop_1 serializable?_0 size_0 body_0)))))) + (lambda (body_0 size_0) + (begin (begin (for-loop_1 size_0 body_0)))))) (for-loop_0 (|#%name| for-loop @@ -61197,7 +57743,7 @@ (for-loop_1 (|#%name| for-loop - (lambda (serializable?_0 size_0 lst_0) + (lambda (size_0 lst_0) (begin (if (not (begin-unsafe (null? (unwrap lst_0)))) (let ((e_0 @@ -61211,17 +57757,9 @@ (let ((e_1 e_0)) (if (<= size_0 0) size_0 - (let ((size_1 - (leftover-size_0 - serializable?_0 - e_1 - size_0))) + (let ((size_1 (leftover-size_0 e_1 size_0))) (begin-unsafe - (begin - (for-loop_1 - serializable?_0 - size_1 - rest_0)))))))) + (begin (for-loop_1 size_1 rest_0)))))))) size_0))))) (for-loop_2 (|#%name| @@ -61238,7 +57776,7 @@ (leftover-size_0 (|#%name| leftover-size - (lambda (serializable?_0 e_0 size_0) + (lambda (e_0 size_0) (begin (if (<= size_0 0) 0 @@ -61247,10 +57785,7 @@ (if (pair? p_0) (unwrap (car p_0)) #f)))) (if (if (eq? 'begin hd_0) #t #f) (let ((body_0 (let ((d_0 (cdr (unwrap e_0)))) d_0))) - (body-leftover-size_0 - serializable?_0 - body_0 - (sub1 size_0))) + (body-leftover-size_0 body_0 (sub1 size_0))) (if (if (eq? 'define-values hd_0) (let ((a_0 (cdr (unwrap e_0)))) (let ((p_0 (unwrap a_0))) @@ -61269,10 +57804,7 @@ (let ((d_0 (cdr (unwrap e_0)))) (let ((d_1 (cdr (unwrap d_0)))) (let ((a_0 (car (unwrap d_1)))) a_0))))) - (leftover-size_0 - serializable?_0 - rhs_0 - (sub1 size_0))) + (leftover-size_0 rhs_0 (sub1 size_0))) (if (if (eq? 'lambda hd_0) (let ((a_0 (cdr (unwrap e_0)))) (let ((p_0 (unwrap a_0))) @@ -61281,10 +57813,7 @@ (let ((body_0 (let ((d_0 (cdr (unwrap e_0)))) (let ((d_1 (cdr (unwrap d_0)))) d_1)))) - (body-leftover-size_0 - serializable?_0 - body_0 - (sub1 size_0))) + (body-leftover-size_0 body_0 (sub1 size_0))) (if (if (eq? 'case-lambda hd_0) (let ((a_0 (cdr (unwrap e_0)))) (if (wrap-list? a_0) @@ -61389,10 +57918,7 @@ bodys_0)))))) (for-loop_3 null d_0))))) (reverse$1 bodys_0))))) - (body-leftover-size_0 - serializable?_0 - bodys_0 - (sub1 size_0))) + (body-leftover-size_0 bodys_0 (sub1 size_0))) (if (if (eq? 'let-values hd_0) (let ((a_0 (cdr (unwrap e_0)))) (let ((p_0 (unwrap a_0))) @@ -61548,7 +58074,6 @@ (case-lambda ((rhss_0 body_0) (body-leftover-size_0 - serializable?_0 (cons rhss_0 body_0) (sub1 size_0))) (args @@ -61709,7 +58234,6 @@ (case-lambda ((rhss_0 body_0) (body-leftover-size_0 - serializable?_0 (cons rhss_0 body_0) (sub1 size_0))) (args @@ -61775,13 +58299,10 @@ (case-lambda ((tst_0 thn_0 els_0) (leftover-size_0 - serializable?_0 els_0 (leftover-size_0 - serializable?_0 thn_0 (leftover-size_0 - serializable?_0 tst_0 (sub1 size_0))))) (args @@ -61865,13 +58386,10 @@ (case-lambda ((key_0 val_0 body_0) (leftover-size_0 - serializable?_0 body_0 (leftover-size_0 - serializable?_0 val_0 (leftover-size_0 - serializable?_0 key_0 (sub1 size_0))))) (args @@ -61883,7 +58401,6 @@ (let ((d_0 (cdr (unwrap e_0)))) d_0))) (body-leftover-size_0 - serializable?_0 body_0 (sub1 size_0))) (if (if (eq? 'begin0 hd_0) #t #f) @@ -61891,7 +58408,6 @@ (let ((d_0 (cdr (unwrap e_0)))) d_0))) (body-leftover-size_0 - serializable?_0 body_0 (sub1 size_0))) (if (if (eq? 'quote hd_0) @@ -61913,13 +58429,7 @@ (let ((a_0 (car (unwrap d_0)))) a_0)))) - (if (if serializable?_0 - (lift-quoted? v_0 #f #t) - #f) - (s-expr-leftover-size_0 - v_0 - size_0) - (sub1 size_0))) + (sub1 size_0)) (if (if (eq? 'set! hd_0) (let ((a_0 (cdr (unwrap e_0)))) @@ -61965,7 +58475,6 @@ (case-lambda ((id_0 rhs_0) (leftover-size_0 - serializable?_0 rhs_0 (sub1 size_0))) (args @@ -61981,7 +58490,6 @@ (if (let ((p_0 (unwrap e_0))) (if (pair? p_0) #t #f)) (body-leftover-size_0 - serializable?_0 e_0 size_0) (sub1 @@ -61989,8 +58497,7 @@ (next-k-proc_0 (|#%name| next-k-proc - (lambda (rest_0 serializable?_0 size_0) - (begin (for-loop_1 serializable?_0 size_0 rest_0))))) + (lambda (rest_0 size_0) (begin (for-loop_1 size_0 rest_0))))) (next-k-proc_1 (|#%name| next-k-proc @@ -62055,15 +58562,15 @@ (let ((d_0 (cdr (unwrap e_0)))) (let ((d_1 (cdr (unwrap d_0)))) (let ((d_2 (cdr (unwrap d_1)))) d_2))))) - (<= (body-leftover-size_0 serializable?_0 body_0 size_0) 0)) + (<= (body-leftover-size_0 body_0 size_0) 0)) (error 'match "failed ~e" e_0)))))) (define ->fasl (let ((->fasl_0 (|#%name| ->fasl (lambda (v2_0 handle-fail1_0) - (begin (s-exp->fasl.1 #f handle-fail1_0 #f v2_0 #f)))))) + (begin (s-exp->fasl.1 #f handle-fail1_0 #f #f v2_0 #f)))))) (case-lambda ((v_0) (->fasl_0 v_0 #f)) ((v_0 handle-fail1_0) (->fasl_0 v_0 handle-fail1_0))))) -(define fasl-> (lambda (f_0) (fasl->s-exp.1 #t unsafe-undefined f_0))) +(define fasl-> (lambda (f_0) (fasl->s-exp.1 #t unsafe-undefined #f f_0))) diff --git a/racket/src/cs/schemify.sls b/racket/src/cs/schemify.sls index 46b7650704..1b0c649747 100644 --- a/racket/src/cs/schemify.sls +++ b/racket/src/cs/schemify.sls @@ -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 diff --git a/racket/src/expander/compile/built-in-symbol.rkt b/racket/src/expander/compile/built-in-symbol.rkt index 7dd728d7d7..480aed9297 100644 --- a/racket/src/expander/compile/built-in-symbol.rkt +++ b/racket/src/expander/compile/built-in-symbol.rkt @@ -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 diff --git a/racket/src/schemify/fasl-literal.rkt b/racket/src/schemify/fasl-literal.rkt new file mode 100644 index 0000000000..f42b78b7a3 --- /dev/null +++ b/racket/src/schemify/fasl-literal.rkt @@ -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)) diff --git a/racket/src/schemify/interpret.rkt b/racket/src/schemify/interpret.rkt index 3a653f9fc2..07e30b4688 100644 --- a/racket/src/schemify/interpret.rkt +++ b/racket/src/schemify/interpret.rkt @@ -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) diff --git a/racket/src/schemify/literal.rkt b/racket/src/schemify/literal.rkt index 35f6ff26a5..de9476e40f 100644 --- a/racket/src/schemify/literal.rkt +++ b/racket/src/schemify/literal.rkt @@ -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)]))) diff --git a/racket/src/schemify/main.rkt b/racket/src/schemify/main.rkt index 9bb5921194..9c696aa3a2 100644 --- a/racket/src/schemify/main.rkt +++ b/racket/src/schemify/main.rkt @@ -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 diff --git a/racket/src/schemify/path-and-fasl.rkt b/racket/src/schemify/path-and-fasl.rkt deleted file mode 100644 index 503a04c124..0000000000 --- a/racket/src/schemify/path-and-fasl.rkt +++ /dev/null @@ -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)) diff --git a/racket/src/schemify/path-for-srcloc.rkt b/racket/src/schemify/path-for-srcloc.rkt deleted file mode 100644 index 5e199f3f79..0000000000 --- a/racket/src/schemify/path-for-srcloc.rkt +++ /dev/null @@ -1,5 +0,0 @@ -#lang racket/base - -(provide (struct-out path-for-srcloc)) - -(struct path-for-srcloc (path)) diff --git a/racket/src/schemify/quoted.rkt b/racket/src/schemify/quoted.rkt deleted file mode 100644 index 335891ae70..0000000000 --- a/racket/src/schemify/quoted.rkt +++ /dev/null @@ -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)) diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index 55910155b6..1ba4376c6f 100644 --- a/racket/src/schemify/schemify.rkt +++ b/racket/src/schemify/schemify.rkt @@ -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 diff --git a/racket/src/schemify/serialize.rkt b/racket/src/schemify/serialize.rkt deleted file mode 100644 index 40a720f47d..0000000000 --- a/racket/src/schemify/serialize.rkt +++ /dev/null @@ -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])]))])) diff --git a/racket/src/schemify/size.rkt b/racket/src/schemify/size.rkt index a3aa69b2e8..b627b1f58c 100644 --- a/racket/src/schemify/size.rkt +++ b/racket/src/schemify/size.rkt @@ -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)] diff --git a/racket/src/schemify/to-fasl.rkt b/racket/src/schemify/to-fasl.rkt deleted file mode 100644 index ace05398f9..0000000000 --- a/racket/src/schemify/to-fasl.rkt +++ /dev/null @@ -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) diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index c0dd7daa56..a8ef869ede 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -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