From 6a35d64e95d85a9eb67c484519d4869ec2c81ad8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Mar 2019 12:13:12 -0600 Subject: [PATCH] repairs for change for machine-independent bytecode Fix problems with moving some VM-specific handlign to schemify, and fix some interning issues that the change exposed. --- pkgs/compiler-lib/compiler/decompile.rkt | 2 +- racket/collects/racket/private/c.rkt | 366 ++++++++++++++++++ racket/src/cs/expander.sls | 14 +- racket/src/cs/primitive/internal.ss | 2 +- racket/src/cs/schemify.sls | 1 + .../expander/compile/correlated-linklet.rkt | 19 +- racket/src/expander/compile/module.rkt | 2 +- racket/src/expander/main.rkt | 3 - racket/src/racket/src/startup.inc | 65 +++- racket/src/schemify/interpret.rkt | 4 +- racket/src/schemify/path.rkt | 64 ++- racket/src/schemify/serialize.rkt | 14 +- racket/src/schemify/to-fasl.rkt | 7 + 13 files changed, 507 insertions(+), 56 deletions(-) create mode 100644 racket/collects/racket/private/c.rkt create mode 100644 racket/src/schemify/to-fasl.rkt diff --git a/pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-lib/compiler/decompile.rkt index 751d50e8d7..0b084ece64 100644 --- a/pkgs/compiler-lib/compiler/decompile.rkt +++ b/pkgs/compiler-lib/compiler/decompile.rkt @@ -759,7 +759,7 @@ (struct faslable-correlated-linklet (expr name) #:prefab) -(struct faslable-correlated (e source position line column span name) +(struct faslable-correlated (e source position line column span props) #:prefab) (define (strip-correlated v) diff --git a/racket/collects/racket/private/c.rkt b/racket/collects/racket/private/c.rkt new file mode 100644 index 0000000000..cc7c8c3b79 --- /dev/null +++ b/racket/collects/racket/private/c.rkt @@ -0,0 +1,366 @@ +;;---------------------------------------------------------------------- +;; case: based on Clinger, "Rapid Case Dispatch in Scheme" +;; [http://scheme2006.cs.uchicago.edu/07-clinger.pdf] + +(module case '#%kernel + (#%require '#%paramz '#%unsafe "small-scheme.rkt" "define.rkt" + (for-syntax '#%kernel "small-scheme.rkt" "stxcase-scheme.rkt" + "qqstx.rkt" "define.rkt" "sort.rkt")) + (#%provide case) + + + (define-syntax (case stx) + (syntax-case stx (else) + ;; Empty case + [(_ v) + (syntax-protect + (syntax/loc stx (#%expression (begin v (void)))))] + + ;; Else-only case + [(_ v [else e es ...]) + (syntax-protect + (syntax/loc stx (#%expression (begin v (let-values () e es ...)))))] + + ;; If we have a syntactically correct form without an 'else' clause, + ;; add the default 'else' and try again. + [(self v [(k ...) e1 e2 ...] ...) + (syntax-protect + (syntax/loc stx (self v [(k ...) e1 e2 ...] ... [else (void)])))] + + ;; The general case + [(_ v [(k ...) e1 e2 ...] ... [else x1 x2 ...]) + (syntax-protect + (if (< (length (syntax-e #'(k ... ...))) *sequential-threshold*) + (syntax/loc stx (let ([tmp v]) + (case/sequential tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...]))) + (syntax/loc stx (let ([tmp v]) + (case/dispatch tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))))] + + ;; Error cases + [(_ v clause ...) + (let loop ([clauses (syntax->list #'(clause ...))]) + (unless (null? clauses) + (let ([clause (car clauses)]) + (syntax-case clause () + [((_ ...) _ _ ...) + (loop (cdr clauses))] + [((_ ...) . _) + (syntax-case clause () + [(_) + (raise-syntax-error + #f + "bad syntax (missing expression after datum sequence)" + stx + clause)] + [(_ . _) + (raise-syntax-error + #f + "bad syntax (illegal use of `.' in clause)" + stx + clause)] + [_ + (raise-syntax-error + #f + "bad syntax (ill-formed clause)" + stx + clause)])] + [(bad . _) + (raise-syntax-error + #f + ;; If #'bad is an identifier, report its binding in the error message. + ;; This helps resolving the syntax error when `else' is shadowed somewhere + (if (not (symbol? (syntax-e (syntax bad)))) + "bad syntax (not a datum sequence)" + (string-append + "bad syntax (not a datum sequence)\n" + " expected: a datum sequence or the binding 'else' from racket/base\n" + " given: " + (let ([binding (identifier-binding (syntax bad))]) + (cond + [(not binding) "an unbound identifier"] + [(eq? binding 'lexical) "a locally bound identifier"] + [else + (let*-values ([(src) (car binding)] + [(mpath base) (module-path-index-split src)]) + (cond + [(not mpath) + "an identifier bound by the current module"] + [else + (format "an identifier required from the module ~a" + (resolved-module-path-name + (module-path-index-resolve src)))]))])))) + stx + (syntax bad))] + [_ + (raise-syntax-error + #f + "bad syntax (ill-formed clause)" + stx + (syntax bad))]))))] + [(_ . v) + (not (null? (syntax-e (syntax v)))) + (raise-syntax-error + #f + "bad syntax (illegal use of `.')" + stx)])) + + ;; Sequential case: + ;; Turn the expression into a sequence of if-then-else. + (define-syntax (case/sequential stx) + (syntax-case stx (else) + [(_ v [(k ...) es ...] arms ... [else xs ...]) + (syntax-protect + #'(if (case/sequential-test v (k ...)) + (let-values () es ...) + (case/sequential v arms ... [else xs ...])))] + [(_ v [(k ...) es ...] [else xs ...]) + (syntax-protect + #'(if (case/sequential-test v (k ...)) + (let-values () es ...) + (let-values () xs ...)))] + [(_ v [else xs ...]) + (syntax-protect + #'(let-values () xs ...))])) + + (define-syntax (case/sequential-test stx) + (syntax-protect + (syntax-case stx () + [(_ v ()) #'#f] + [(_ v (k)) #`(equal? v 'k)] + [(_ v (k ks ...)) #`(if (equal? v 'k) + #t + (case/sequential-test v (ks ...)))]))) + + ;; Triple-dispatch case: + ;; (1) From the type of the value to a type-specific mechanism for + ;; (2) mapping the value to the index of the consequent we need. Then, + ;; (3) from the index, perform a binary search to find the consequent code. + ;; Note: the else clause is given index 0. + (define-syntax (case/dispatch stx) + (syntax-case stx (else) + [(_ v [(k ...) es ...] ... [else xs ...]) + (syntax-protect + #`(let ([index + #,(let* ([ks (partition-constants #'((k ...) ...))] + [exp #'0] + [exp (if (null? (consts-other ks)) + exp + (dispatch-other #'v (consts-other ks) exp))] + [exp (if (null? (consts-char ks)) + exp + #`(if (char? v) + #,(dispatch-char #'v (consts-char ks)) + #,exp))] + [exp (if (null? (consts-symbol ks)) + exp + #`(if #,(test-for-symbol #'v (consts-symbol ks)) + #,(dispatch-symbol #'v (consts-symbol ks) #'0) + #,exp))] + [exp (if (null? (consts-fixnum ks)) + exp + #`(if (fixnum? v) + #,(dispatch-fixnum #'v (consts-fixnum ks)) + #,exp))]) + exp)]) + #,(index-binary-search #'index #'([xs ...] [es ...] ...))))])) + + + (begin-for-syntax + (define *sequential-threshold* 12) + (define *hash-threshold* 10) + + (define nothing (gensym)) + + (define interval-lo car) + (define interval-hi cadr) + (define interval-index caddr) + + (define (partition-constants stx) + (define h (make-hash)) + + (define (duplicate? x) + (not (eq? (hash-ref h x nothing) nothing))) + + (define (add xs x idx) + (hash-set! h x idx) + (cons (cons x idx) xs)) + + (let loop ([f '()] [s '()] [c '()] [o '()] [idx 1] [xs (syntax->list stx)]) + (cond [(null? xs) + (list (cons 'fixnum f) + (cons 'symbol s) + (cons 'char c) + (cons 'other o))] + [else (let inner ([f f] [s s] [c c] [o o] [ys (syntax->list (car xs))]) + (cond [(null? ys) (loop f s c o (add1 idx) (cdr xs))] + [else + (let ([y (syntax->datum (car ys))]) + (cond [(duplicate? y) (inner f s c o (cdr ys))] + [(fixnum? y) (inner (add f y idx) s c o (cdr ys))] + [(symbol? y) (inner f (add s y idx) c o (cdr ys))] + [(keyword? y) (inner f (add s y idx) c o (cdr ys))] + [(char? y) (inner f s (add c y idx) o (cdr ys))] + [else (inner f s c (add o y idx) (cdr ys))]))]))]))) + + (define (consts-fixnum ks) (cdr (assq 'fixnum ks))) + (define (consts-symbol ks) (cdr (assq 'symbol ks))) + (define (consts-char ks) (cdr (assq 'char ks))) + (define (consts-other ks) (cdr (assq 'other ks))) + + ;; Character dispatch is fixnum dispatch. + (define (dispatch-char tmp-stx char-alist) + #`(let ([codepoint (char->integer #,tmp-stx)]) + #,(dispatch-fixnum #'codepoint + (map (λ (x) + (cons (char->integer (car x)) + (cdr x))) + char-alist)))) + + ;; Symbol and "other" dispatch is either sequential or + ;; hash-table-based, depending on how many constants we + ;; have. Assume that `alist' does not map anything to `#f'. + (define (dispatch-hashable tmp-stx alist make-hashX else-exp) + (if (< (length alist) *hash-threshold*) + #`(case/sequential #,tmp-stx + #,@(map (λ (x) + #`[(#,(car x)) #,(cdr x)]) + alist) + [else #,else-exp]) + (let ([tbl (make-hashX alist)]) + (if (literal-expression? else-exp) + #`(hash-ref #,tbl #,tmp-stx (lambda () #,else-exp)) + #`(or (hash-ref #,tbl #,tmp-stx (lambda () #f)) + #,else-exp))))) + + (define (dispatch-symbol tmp-stx symbol-alist else-exp) + (dispatch-hashable tmp-stx symbol-alist make-immutable-hasheq else-exp)) + + (define (dispatch-other tmp-stx other-alist else-exp) + (dispatch-hashable tmp-stx other-alist make-immutable-hash else-exp)) + + (define (test-for-symbol tmp-stx alist) + (define (contains? pred) + (ormap (lambda (p) (pred (car p))) alist)) + (if (contains? symbol?) + (if (contains? keyword?) + #`(or (symbol? #,tmp-stx) (keyword? #,tmp-stx)) + #`(symbol? #,tmp-stx)) + #`(keyword? #,tmp-stx))) + + (define (literal-expression? else-exp) + (define v (syntax-e else-exp)) + (or (boolean? v) (number? v))) + + ;; Fixnum dispatch is either table lookup or binary search. + (define (dispatch-fixnum tmp-stx fixnum-alist) + (define (go intervals lo hi lo-bound hi-bound) + (define len (length intervals)) + + (cond [(or (>= lo-bound hi) + (<= hi-bound lo)) + #'0] + [(and (> len 1) + (< (- hi lo) (* len 5))) + (fixnum-table-lookup intervals lo hi lo-bound hi-bound)] + [else + (fixnum-binary-search intervals lo hi lo-bound hi-bound)])) + + (define (fixnum-table-lookup intervals lo hi lo-bound hi-bound) + (define index-lists + (map (λ (int) + (vector->list + (make-vector (- (interval-hi int) + (interval-lo int)) + (interval-index int)))) + intervals)) + + #`(let ([tbl #,(list->vector (apply append index-lists))]) + #,(bounded-expr tmp-stx lo hi lo-bound hi-bound + #`(unsafe-vector*-ref tbl (unsafe-fx- #,tmp-stx #,lo))))) + + (define (fixnum-binary-search intervals lo hi lo-bound hi-bound) + (cond [(null? (cdr intervals)) + #`#,(interval-index (car intervals))] + [else + (define-values (lo-ints hi-ints) (split-intervals intervals)) + (define-values (lo-lo lo-hi) (lo+hi lo-ints)) + (define-values (hi-lo hi-hi) (lo+hi hi-ints)) + + #`(if (unsafe-fx< #,tmp-stx #,hi-lo) + #,(go lo-ints lo-lo lo-hi lo-bound hi-lo) + #,(go hi-ints hi-lo hi-hi hi-lo hi-bound))])) + + (define (split-intervals intervals) + (define n (quotient (length intervals) 2)) + (let loop ([n n] [lo '()] [hi intervals]) + (cond [(zero? n) (values (reverse lo) hi)] + [else (loop (sub1 n) (cons (car hi) lo) (cdr hi))]))) + + (define (lo+hi intervals) + (values (interval-lo (car intervals)) + (interval-hi (car (reverse intervals))))) + + (define intervals (alist->intervals fixnum-alist)) + (define-values (lo hi) (lo+hi intervals)) + + #`(if (and (unsafe-fx>= #,tmp-stx #,lo) + (unsafe-fx< #,tmp-stx #,hi)) + #,(go intervals lo hi lo hi) + 0)) + + ;; Once we have the index of the consequent we want, perform + ;; a binary search to find it. + (define (index-binary-search index-stx leg-stx) + (define legs (list->vector (syntax->list leg-stx))) + + (define (go min max) + (cond [(= min max) + #`(let-values () #,@(vector-ref legs min))] + [(= max (add1 min)) + #`(if (unsafe-fx< #,index-stx #,max) + (let-values () #,@(vector-ref legs min)) + (let-values () #,@(vector-ref legs max)))] + [else + (let ([mid (quotient (+ min max) 2)]) + #`(if (unsafe-fx< #,index-stx #,mid) + #,(go min (sub1 mid)) + #,(go mid max)))])) + + (go 0 (sub1 (vector-length legs)))) + + (define (bounded-expr tmp-stx lo hi lo-bound hi-bound exp-stx) + (cond [(and (<= hi-bound hi) + (>= lo-bound lo)) + exp-stx] + [(<= hi-bound hi) + #`(if (unsafe-fx>= #,tmp-stx #,lo) exp-stx 0)] + [(>= lo-bound lo) + #`(if (unsafe-fx< #,tmp-stx #,hi) exp-stx 0)] + [else + #`(if (and (unsafe-fx>= #,tmp-stx #,lo) + (unsafe-fx< #,tmp-stx #,hi)) + exp-stx + 0)])) + + (define (alist->intervals alist) + (let loop ([xs (sort alist < car)] [start-idx #f] [end-idx #f] [cur-val #f] [res '()]) + (cond [(null? xs) + (if start-idx + (reverse (cons (list start-idx end-idx cur-val) res)) + '())] + [else + (let* ([x (car xs)] + [k (car x)] + [v (cdr x)]) + (cond [(not start-idx) + (loop (cdr xs) k (add1 k) v res)] + [(and (= end-idx k) (= cur-val v)) + (loop (cdr xs) start-idx (add1 end-idx) cur-val res)] + [(= end-idx k) + (let ([interval (list start-idx end-idx cur-val)]) + (loop (cdr xs) k (add1 k) v (cons interval res)))] + [else + ;; insert an interval in the gap for the default + (let ([int1 (list start-idx end-idx cur-val)] + [int2 (list end-idx k 0)]) + (loop (cdr xs) k (add1 k) v (cons int2 (cons int1 res))))]))]))))) diff --git a/racket/src/cs/expander.sls b/racket/src/cs/expander.sls index 2ae40d4e01..5b5ab46375 100644 --- a/racket/src/cs/expander.sls +++ b/racket/src/cs/expander.sls @@ -28,7 +28,9 @@ (thread) (regexp) (io) - (linklet)) + (linklet) + (only (schemify) + force-unfasl)) (include "place-register.ss") (define-place-register-define define expander-register-start expander-register-count) @@ -38,9 +40,6 @@ ;; the build incompatible with previously generated ".zo" files. (define compile-as-independent? #f) - (define (fasl->s-exp/intern s) - (1/fasl->s-exp/intern s)) - ;; The expander needs various tables to set up primitive modules, and ;; the `primitive-table` function is the bridge between worlds @@ -113,7 +112,9 @@ (thread) (io) (regexp) - (linklet))) + (linklet) + (only (schemify) + force-unfasl))) ;; Ensure that the library is visited, especially for a wpo build: (eval 'variable-set!))) @@ -181,9 +182,6 @@ [(_ name val) #`(let ([name val]) name)]))) (eval `(define raise-binding-result-arity-error ',raise-binding-result-arity-error))) - ;; Special "primitive" for syntax-data deserialization: - (eval `(define fasl->s-exp/intern ',fasl->s-exp/intern)) - ;; For interpretation of the outer shell of a linklet: (install-linklet-primitive-tables! kernel-table unsafe-table diff --git a/racket/src/cs/primitive/internal.ss b/racket/src/cs/primitive/internal.ss index 17cc404a0b..7a25b5bfdc 100644 --- a/racket/src/cs/primitive/internal.ss +++ b/racket/src/cs/primitive/internal.ss @@ -36,4 +36,4 @@ [make-pthread-parameter (known-procedure 2)] [break-enabled-key (known-constant)] - [fasl->s-exp/intern (known-procedure 2)]) + [force-unfasl (known-procedure 2)]) diff --git a/racket/src/cs/schemify.sls b/racket/src/cs/schemify.sls index 01f43f4c07..86106ff02d 100644 --- a/racket/src/cs/schemify.sls +++ b/racket/src/cs/schemify.sls @@ -9,6 +9,7 @@ linklet-bigger-than? make-path->compiled-path compiled-path->path + force-unfasl prim-knowns known-procedure known-procedure/pure diff --git a/racket/src/expander/compile/correlated-linklet.rkt b/racket/src/expander/compile/correlated-linklet.rkt index 88cee26c6c..18c0b55d45 100644 --- a/racket/src/expander/compile/correlated-linklet.rkt +++ b/racket/src/expander/compile/correlated-linklet.rkt @@ -53,7 +53,7 @@ (define correlated-linklet-vm-bytes #"linklet") -(struct faslable-correlated (e source position line column span name) +(struct faslable-correlated (e source position line column span props) #:prefab) (struct faslable-correlated-linklet (expr name) @@ -81,7 +81,13 @@ (correlated-line v) (correlated-column v) (correlated-span v) - (correlated-property v 'inferred-name))] + (for/fold ([ht #f]) ([k (in-list '(inferred-name + undefined-error-name + method-arity-error))]) + (define p (correlated-property v k)) + (if p + (hash-set (or ht '#hasheq()) k p) + ht)))] [(hash? v) (cond [(hash-eq? v) @@ -101,7 +107,7 @@ ;; ---------------------------------------- (define (read-correlated-linklet-bundle-hash in) - (faslable-> (fasl->s-exp in))) + (faslable-> (fasl->s-exp in #:datum-intern? #t))) (define (faslable-> v) (cond @@ -113,7 +119,7 @@ v (cons a d))] [(faslable-correlated? v) - (define name (faslable-correlated-name v)) + (define props (faslable-correlated-props v)) (define c (datum->correlated (faslable-> (faslable-correlated-e v)) (vector (faslable-correlated-source v) @@ -121,8 +127,9 @@ (faslable-correlated-column v) (faslable-correlated-position v) (faslable-correlated-span v)))) - (if name - (correlated-property c 'inferred-name name) + (if props + (for/fold ([c c]) ([(k p) (in-hash props)]) + (correlated-property c k p)) c)] [(hash? v) (cond diff --git a/racket/src/expander/compile/module.rkt b/racket/src/expander/compile/module.rkt index c4ecd0ec80..81996527e1 100644 --- a/racket/src/expander/compile/module.rkt +++ b/racket/src/expander/compile/module.rkt @@ -265,7 +265,7 @@ (make-correlated-linklet s 'syntax-literals-data) (performance-region ['compile 'module 'linklet] - (compile-linklet s 'syntax-literals-data #f #f '(serializable uninterned-literal))))) + (compile-linklet s 'syntax-literals-data #f #f '(serializable))))) `(linklet ;; imports (,deserialize-imports diff --git a/racket/src/expander/main.rkt b/racket/src/expander/main.rkt index b7e2944c6c..2850533f92 100644 --- a/racket/src/expander/main.rkt +++ b/racket/src/expander/main.rkt @@ -1,6 +1,5 @@ #lang racket/base (require "common/set.rkt" - "common/fasl.rkt" "common/module-path.rkt" "namespace/namespace.rkt" "eval/main.rkt" @@ -119,8 +118,6 @@ expander-place-init! - fasl->s-exp/intern ; for Chez Scheme as "primitive" and in linklet layer - ;; The remaining functions are provided for basic testing ;; (such as "demo.rkt") diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 237f44e653..31c1590a44 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -28732,7 +28732,7 @@ static const char *startup_source = " faslable-correlated-line" " faslable-correlated-column" " faslable-correlated-span" -" faslable-correlated-name)" +" faslable-correlated-props)" "(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" "(let-values()" "(let-values()" @@ -28758,7 +28758,7 @@ static const char *startup_source = "(make-struct-field-accessor -ref_0 3 'line)" "(make-struct-field-accessor -ref_0 4 'column)" "(make-struct-field-accessor -ref_0 5 'span)" -"(make-struct-field-accessor -ref_0 6 'name))))" +"(make-struct-field-accessor -ref_0 6 'props))))" "(define-values" "(struct:faslable-correlated-linklet" " faslable-correlated-linklet3.1" @@ -28808,7 +28808,34 @@ static const char *startup_source = "(correlated-line v_0)" "(correlated-column v_0)" "(correlated-span v_0)" -"(correlated-property v_0 'inferred-name)))" +"(let-values(((lst_0) '(inferred-name undefined-error-name method-arity-error)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_0)))" +"((letrec-values(((for-loop_0)" +"(lambda(ht_0 lst_1)" +"(begin" +" 'for-loop" +"(if(pair? lst_1)" +"(let-values(((k_0)(unsafe-car lst_1))((rest_0)(unsafe-cdr lst_1)))" +"(let-values(((ht_1)" +"(let-values(((ht_1) ht_0))" +"(let-values(((ht_2)" +"(let-values()" +"(let-values(((p_0)" +"(correlated-property v_0 k_0)))" +"(if p_0" +"(hash-set" +"(let-values(((or-part_0) ht_1))" +"(if or-part_0 or-part_0 '#hasheq()))" +" k_0" +" p_0)" +" ht_1)))))" +"(values ht_2)))))" +"(if(not #f)(for-loop_0 ht_1 rest_0) ht_1)))" +" ht_0)))))" +" for-loop_0)" +" #f" +" lst_0)))))" "(if(hash? v_0)" "(let-values()" "(if(hash-eq? v_0)" @@ -28914,7 +28941,7 @@ static const char *startup_source = "(let-values() v_0))))))))" "(define-values" "(read-correlated-linklet-bundle-hash)" -"(lambda(in_0)(begin(faslable->(let-values(((in9_0) in_0))(fasl->s-exp17.1 #t in9_0))))))" +"(lambda(in_0)(begin(faslable->(let-values(((in9_0) in_0)((temp10_0) #t))(fasl->s-exp17.1 temp10_0 in9_0))))))" "(define-values" "(faslable->)" "(lambda(v_0)" @@ -28926,7 +28953,7 @@ static const char *startup_source = "(if(if(eq? a_0(car v_0))(eq? d_0(cdr v_0)) #f) v_0(cons a_0 d_0)))))" "(if(faslable-correlated? v_0)" "(let-values()" -"(let-values(((name_0)(faslable-correlated-name v_0)))" +"(let-values(((props_0)(faslable-correlated-props v_0)))" "(let-values(((c_0)" "(datum->correlated" "(faslable->(faslable-correlated-e v_0))" @@ -28936,7 +28963,30 @@ static const char *startup_source = "(faslable-correlated-column v_0)" "(faslable-correlated-position v_0)" "(faslable-correlated-span v_0)))))" -"(if name_0(correlated-property c_0 'inferred-name name_0) c_0))))" +"(if props_0" +"(let-values(((ht_0) props_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_0)))" +"((letrec-values(((for-loop_0)" +"(lambda(c_1 i_0)" +"(begin" +" 'for-loop" +"(if i_0" +"(let-values(((k_0 p_0)(hash-iterate-key+value ht_0 i_0)))" +"(let-values(((c_2)" +"(let-values(((c_2) c_1))" +"(let-values(((c_3)" +"(let-values()" +"(correlated-property c_2 k_0 p_0))))" +"(values c_3)))))" +"(if(not #f)(for-loop_0 c_2(hash-iterate-next ht_0 i_0)) c_2)))" +" c_1)))))" +" for-loop_0)" +" c_0" +"(hash-iterate-first ht_0))))" +" c_0))))" "(if(hash? v_0)" "(let-values()" "(if(hash-eq? v_0)" @@ -39653,8 +39703,7 @@ static const char *startup_source = " 'syntax-literals-data" " #f" " #f" -" '(serializable" -" uninterned-literal)))" +" '(serializable)))" "(if log-performance?" "(let-values()" "(end-performance-region))" diff --git a/racket/src/schemify/interpret.rkt b/racket/src/schemify/interpret.rkt index c0ba219893..9d7f76d20e 100644 --- a/racket/src/schemify/interpret.rkt +++ b/racket/src/schemify/interpret.rkt @@ -4,6 +4,7 @@ "match.rkt" "wrap.rkt" "path-for-srcloc.rkt" + "to-fasl.rkt" "interp-match.rkt" "interp-stack.rkt") @@ -84,7 +85,8 @@ (let ([rhs (cadr binding)]) (cons (cond [(or (path? rhs) - (path-for-srcloc? 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 diff --git a/racket/src/schemify/path.rkt b/racket/src/schemify/path.rkt index 6267819bc6..6ce4aca27e 100644 --- a/racket/src/schemify/path.rkt +++ b/racket/src/schemify/path.rkt @@ -1,12 +1,15 @@ #lang racket/base (require racket/private/relative-path racket/private/truncate-path + racket/fasl "match.rkt" - "path-for-srcloc.rkt") + "path-for-srcloc.rkt" + "to-fasl.rkt") (provide extract-paths-from-schemified-linklet make-path->compiled-path - compiled-path->path) + compiled-path->path + force-unfasl) ;; Recognize lifted paths in a schemified linklet, and ;; return the list of path values. If `convert?`, then @@ -20,7 +23,7 @@ [`(let* ,bindings ,body) (define (path-binding? b) (define rhs (cadr b)) - (or (path? rhs) (path-for-srcloc? rhs))) + (or (path? rhs) (path-for-srcloc? rhs) (to-fasl? rhs))) (define any-path? (for/or ([b (in-list bindings)]) (path-binding? b))) @@ -48,28 +51,49 @@ (define (make-path->compiled-path who) (define path->relative-path-elements (make-path->relative-path-elements #:who who)) (lambda (orig-p) - (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 - [(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] + [(to-fasl? orig-p) + (box (s-exp->fasl (force-unfasl orig-p)))] [else - (error 'write - "cannot marshal value that is embedded in compiled code: ~V" - p)]))) + (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 + [(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) (to-fasl (box (unbox e)) + (or (current-load-relative-directory) + (current-directory)))] [(bytes? e) (bytes->path e)] [(string? e) e] ; was `path-for-srcloc` on write [else (relative-path-elements->path e)])) + +(define (force-unfasl tf) + (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))) + (box-cas! vb v v2) + (set-to-fasl-wrt! tf #f) + (unbox vb)] + [else + ;; already forced (or never fasled) + v])) diff --git a/racket/src/schemify/serialize.rkt b/racket/src/schemify/serialize.rkt index fadbf7cdd0..0779aa9e40 100644 --- a/racket/src/schemify/serialize.rkt +++ b/racket/src/schemify/serialize.rkt @@ -1,10 +1,10 @@ #lang racket/base (require racket/extflonum racket/prefab - racket/fasl "match.rkt" "wrap.rkt" "path-for-srcloc.rkt" + "to-fasl.rkt" "quoted.rkt") (provide convert-for-serialize) @@ -78,8 +78,7 @@ `(,(convert rator) ,@(convert-body exps))] [`,_ (cond - [(and for-cify? - (not (symbol? v)) + [(and (not (symbol? v)) (lift-quoted? v for-cify? datum-intern?)) (convert `(quote ,v))] [else v])]))) @@ -136,8 +135,7 @@ [`(,exps ...) (for/or ([exp (in-list exps)]) (convert-any? exp))] - [`,_ (and for-cify? - (not (symbol? v)) + [`,_ (and (not (symbol? v)) (lift-quoted? v for-cify? datum-intern?))]))) ;; Construct an expression to be lifted @@ -155,8 +153,10 @@ (cond [(and (not for-cify?) (large-quoted? q)) - (add-lifted `(fasl->s-exp/intern - ',(s-exp->fasl 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)) diff --git a/racket/src/schemify/to-fasl.rkt b/racket/src/schemify/to-fasl.rkt new file mode 100644 index 0000000000..710b58cd20 --- /dev/null +++ b/racket/src/schemify/to-fasl.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide (struct-out to-fasl)) + +(struct to-fasl (vb ; box containing byte string as marhsaled or other as unmarshaled + wrt) ; directory for unmarshaling + #:mutable)