From 6e958b627fb16ffffe0674d1b629c3b32fd2fb4b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Mar 2019 06:00:36 -0600 Subject: [PATCH] expander: avoid VM-specific expansion Move different handling of serialized syntax data to the schemify layer instead of te expander, so that the result of compiling in machine-independent form is the same for traditional Racket and Racket CS. --- pkgs/compiler-lib/compiler/decompile.rkt | 15 +- racket/src/expander/compile/correlate.rkt | 3 +- racket/src/expander/compile/serialize.rkt | 32 ++-- racket/src/expander/expand/expr.rkt | 5 +- racket/src/racket/src/startup.inc | 72 ++++---- racket/src/racket/src/syntax.c | 1 + racket/src/schemify/quoted.rkt | 21 ++- racket/src/schemify/serialize.rkt | 195 +++++++++++----------- 8 files changed, 176 insertions(+), 168 deletions(-) diff --git a/pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-lib/compiler/decompile.rkt index cb0cdc0ceb..751d50e8d7 100644 --- a/pkgs/compiler-lib/compiler/decompile.rkt +++ b/pkgs/compiler-lib/compiler/decompile.rkt @@ -269,12 +269,14 @@ (define-values ,_ (lambda ,_ (begin - (vector-copy! ,_ ,_ (let-values (((.inspector) #f)) - (deserialize .mpi-vector .inspector .bulk-binding-registry - ',num-mutables ',mutable-vec - ',num-shares ',share-vec - ',mutable-fill-vec - ',result-vec))) + (vector-copy! ,_ ,_ (let-values ([(.inspector) #f]) + (let-values ([(data) + '#(,mutable-vec ,share-vec ,mutable-fill-vec ,result-vec)]) + (deserialize .mpi-vector .inspector .bulk-binding-registry + ',num-mutables (,_ data 0) + ',num-shares (,_ data 1) + (,_ data 2) + (,_ data 3))))) ,_)))) (decompile-deserialize '.mpi-vector '.inspector '.bulk-binding-registry num-mutables mutable-vec @@ -282,7 +284,6 @@ mutable-fill-vec result-vec)] [else - (log-error ">> HERE ~.s" (strip-correlated expr)) (decompile-linklet l)])] [else (decompile-linklet l)])) diff --git a/racket/src/expander/compile/correlate.rkt b/racket/src/expander/compile/correlate.rkt index 0a57ddcd66..c8f167a387 100644 --- a/racket/src/expander/compile/correlate.rkt +++ b/racket/src/expander/compile/correlate.rkt @@ -15,7 +15,8 @@ ->correlated correlate-source-name - compile-keep-source-locations!) + compile-keep-source-locations! + keep-source-locations?) (define keep-source-locations? #f) diff --git a/racket/src/expander/compile/serialize.rkt b/racket/src/expander/compile/serialize.rkt index b704ff93c7..eb9a1e6da7 100644 --- a/racket/src/expander/compile/serialize.rkt +++ b/racket/src/expander/compile/serialize.rkt @@ -624,27 +624,17 @@ ,mutable-fills-expr ,result-expr)) - (cond - [(eq? 'chez-scheme (system-type 'vm)) - ;; It's better to interpret the quoted-data construction in Chez Scheme, - ;; instead of compiling the construction, because it's more compact - ;; and easier to delay. Rely on `fasl->s-exp/intern` as a primitive - ;; (from the linklet perspective) that is installed on startup. - `(let-values ([(data) (fasl->s-exp/intern - ,(s-exp->fasl - (vector mutable-shell-bindings - shared-bindings - mutable-fills - result)))]) - ,(finish '(unsafe-vector-ref data 0) - '(unsafe-vector-ref data 1) - '(unsafe-vector-ref data 2) - '(unsafe-vector-ref data 3)))] - [else - (finish `',mutable-shell-bindings - `',shared-bindings - `',mutable-fills - `',result)])) + ;; Putting the quoted-data construction into one vector makes + ;; it easy to specialize in some back ends to a more compact + ;; format. + `(let-values ([(data) ',(vector mutable-shell-bindings + shared-bindings + mutable-fills + result)]) + ,(finish '(unsafe-vector*-ref data 0) + '(unsafe-vector*-ref data 1) + '(unsafe-vector*-ref data 2) + '(unsafe-vector*-ref data 3)))) (define (sorted-hash-keys ht) (define ks (hash-keys ht)) diff --git a/racket/src/expander/expand/expr.rkt b/racket/src/expander/expand/expr.rkt index 6cbf40bf8f..3c513fb861 100644 --- a/racket/src/expander/expand/expr.rkt +++ b/racket/src/expander/expand/expr.rkt @@ -25,7 +25,8 @@ "reference-record.rkt" "prepare.rkt" "log.rkt" - "parsed.rkt") + "parsed.rkt" + "../compile/correlate.rkt") ;; ---------------------------------------- @@ -414,7 +415,7 @@ (list (core-id 'quote phase) null)))] [else - (define keep-for-parsed? (eq? (system-type 'vm) 'chez-scheme)) + (define keep-for-parsed? keep-source-locations?) (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? keep-for-parsed?)) (define prefixless (cdr (syntax-e disarmed-s))) (define rebuild-prefixless (and (syntax? prefixless) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 8d6aa50adc..237f44e653 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -22073,35 +22073,25 @@ static const char *startup_source = " shared-bindings-expr_0" " mutable-fills-expr_0" " result-expr_0)))))" -"(if(eq? 'chez-scheme(system-type 'vm))" -"(let-values()" "(list" " 'let-values" "(list" "(list" " '(data)" "(list" -" 'fasl->s-exp/intern" -"(let-values(((temp20_0)" +" 'quote" "(vector" " mutable-shell-bindings_0" " shared-bindings_0" " mutable-fills_0" -" result_0)))" -"(s-exp->fasl11.1 #f temp20_0 #f)))))" +" result_0))))" "(finish_0" -" '(unsafe-vector-ref data 0)" -" '(unsafe-vector-ref data 1)" -" '(unsafe-vector-ref data 2)" -" '(unsafe-vector-ref data 3))))" -"(let-values()" -"(finish_0" -"(list 'quote mutable-shell-bindings_0)" -"(list 'quote shared-bindings_0)" -"(list 'quote mutable-fills_0)" -"(list" -" 'quote" -" result_0))))))))))))))))))))))))))))))))))))))" +" '(unsafe-vector*-ref data 0)" +" '(unsafe-vector*-ref data 1)" +" '(unsafe-vector*-ref data 2)" +" '(unsafe-vector*-ref" +" data" +" 3)))))))))))))))))))))))))))))))))))))" "(define-values" "(sorted-hash-keys)" "(lambda(ht_0)" @@ -22113,16 +22103,16 @@ static const char *startup_source = "(let-values() ks_0)" "(if(andmap2 symbol? ks_0)" "(let-values()" -"(let-values(((ks21_0) ks_0)((symbolline = -1; empty_srcloc->col = -1; empty_srcloc->pos = -1; + empty_srcloc->span = -1; REGISTER_SO(scheme_paren_shape_symbol); scheme_paren_shape_symbol = scheme_intern_symbol("paren-shape"); diff --git a/racket/src/schemify/quoted.rkt b/racket/src/schemify/quoted.rkt index a8a1644547..be8c03bf31 100644 --- a/racket/src/schemify/quoted.rkt +++ b/racket/src/schemify/quoted.rkt @@ -1,7 +1,9 @@ #lang racket/base -(require racket/extflonum) +(require racket/extflonum + racket/fixnum) -(provide lift-quoted?) +(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?) @@ -31,3 +33,18 @@ [(prefab-struct-key q) #t] [(extflonum? q) #t] [else #f]))) + +;; 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/serialize.rkt b/racket/src/schemify/serialize.rkt index d866e5e7c3..fadbf7cdd0 100644 --- a/racket/src/schemify/serialize.rkt +++ b/racket/src/schemify/serialize.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/extflonum racket/prefab + racket/fasl "match.rkt" "wrap.rkt" "path-for-srcloc.rkt" @@ -151,99 +152,105 @@ (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) - (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 type slike 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)] - [else `(quote ,q)])) + (cond + [(and (not for-cify?) + (large-quoted? q)) + (add-lifted `(fasl->s-exp/intern + ',(s-exp->fasl q)))] + [else + (let make-construct ([q q]) + (define lifted-constants (if (or (string? q) (bytes? q)) + lifted-equal-constants + lifted-eq-constants)) (cond - [(and (quote? rhs) - (or (not for-cify?) - (not (lift-quoted? (cadr rhs) #t datum-intern?)))) - rhs] + [(hash-ref lifted-constants q #f) + => (lambda (id) id)] [else - (define id (add-lifted rhs)) - (hash-set! lifted-constants q id) - id])]))) + (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 type slike 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)] + [else `(quote ,q)])) + (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])]))]))