diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 73748b7d8b..fc5ce2ad82 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -33,7 +33,7 @@ (with-output-to-bytes (λ () (write (cdr b)))))))]) (let ([n (match v - [(struct compilation-top (_ prefix (struct primval (n)))) n] + [(struct compilation-top (_ _ prefix (struct primval (n)))) n] [else #f])]) (hash-set! table n (car b))))) table)) @@ -53,7 +53,7 @@ (define (decompile top) (let ([stx-ht (make-hasheq)]) (match top - [(struct compilation-top (max-let-depth prefix form)) + [(struct compilation-top (max-let-depth binding-namess prefix form)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) (expose-module-path-indexes `(begin diff --git a/compiler-lib/compiler/demodularizer/alpha.rkt b/compiler-lib/compiler/demodularizer/alpha.rkt index 2f3c71398d..63dc5508a8 100644 --- a/compiler-lib/compiler/demodularizer/alpha.rkt +++ b/compiler-lib/compiler/demodularizer/alpha.rkt @@ -4,8 +4,8 @@ (define (alpha-vary-ctop top) (match top - [(struct compilation-top (max-let-depth prefix form)) - (make-compilation-top max-let-depth (alpha-vary-prefix prefix) form)])) + [(struct compilation-top (max-let-depth binding-namess prefix form)) + (make-compilation-top max-let-depth binding-namess (alpha-vary-prefix prefix) form)])) (define (alpha-vary-prefix p) (struct-copy prefix p [toplevels diff --git a/compiler-lib/compiler/demodularizer/gc-toplevels.rkt b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt index ccdebc57ff..6f4987bd2d 100644 --- a/compiler-lib/compiler/demodularizer/gc-toplevels.rkt +++ b/compiler-lib/compiler/demodularizer/gc-toplevels.rkt @@ -10,7 +10,7 @@ ; XXX Use efficient set structure (define (gc-toplevels top) (match top - [(struct compilation-top (max-let-depth top-prefix form)) + [(struct compilation-top (max-let-depth binding-namess top-prefix form)) (define lift-start (prefix-lift-start top-prefix)) (define max-depgraph-index @@ -54,6 +54,7 @@ (log-debug (format "Used stxs: ~S" ordered-stxs)) (make-compilation-top max-let-depth + #hash() new-prefix new-form)])) diff --git a/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt index 3aeeadd18e..fd7ddff67f 100644 --- a/compiler-lib/compiler/demodularizer/merge.rkt +++ b/compiler-lib/compiler/demodularizer/merge.rkt @@ -15,7 +15,7 @@ (define (merge-compilation-top get-modvar-rewrite top) (parameterize ([current-get-modvar-rewrite get-modvar-rewrite]) (match top - [(struct compilation-top (max-let-depth prefix form)) + [(struct compilation-top (max-let-depth binding-namess prefix form)) (define-values (new-max-let-depth new-prefix gen-new-forms) (merge-form max-let-depth prefix form)) (define total-tls (length (prefix-toplevels new-prefix))) @@ -29,7 +29,7 @@ [p (in-list (prefix-toplevels new-prefix))]) (log-debug (format "new-prefix tls\t~v ~v" i p))) (make-compilation-top - new-max-let-depth new-prefix + new-max-let-depth #hash() new-prefix (make-splice (gen-new-forms new-prefix)))] [else (error 'merge "unrecognized: ~e" top)]))) diff --git a/compiler-lib/compiler/demodularizer/module.rkt b/compiler-lib/compiler/demodularizer/module.rkt index 6c7a3bc9c6..4f984c27af 100644 --- a/compiler-lib/compiler/demodularizer/module.rkt +++ b/compiler-lib/compiler/demodularizer/module.rkt @@ -13,13 +13,14 @@ (define (wrap-in-kernel-module name srcname lang-info self-modidx top) (match top - [(struct compilation-top (max-let-depth prefix form)) + [(struct compilation-top (max-let-depth binding-namess prefix form)) (define-values (reqs new-forms) (partition req? (splice-forms form))) (define requires (map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs)) (make-compilation-top 0 + #hash() (make-prefix 0 (list #f) empty (prefix-src-inspector-desc prefix)) (make-mod name srcname self-modidx diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index 6bbaa66bae..7d7bada6f1 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -107,9 +107,9 @@ (define (nodep top phase) (match top - [(struct compilation-top (max-let-depth prefix form)) + [(struct compilation-top (max-let-depth binding-namess prefix form)) (define-values (modvar-rewrite lang-info new-form) (nodep-form form phase)) - (values modvar-rewrite lang-info (make-compilation-top max-let-depth prefix new-form))] + (values modvar-rewrite lang-info (make-compilation-top max-let-depth #hash() prefix new-form))] [else (error 'nodep "unrecognized: ~e" top)])) (define (nodep-form form phase) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 2ed9e5ce93..0684e7261c 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -155,8 +155,11 @@ (define (out-compilation-top shared-obj-pos shared-obj-pos-any counting? outp) (define ct (match top - [(compilation-top max-let-depth prefix form) - (list* max-let-depth prefix (protect-quote form))])) + [(compilation-top max-let-depth binding-namess prefix form) + (list* max-let-depth + (binding-namess-hash->list binding-namess) + prefix + (protect-quote form))])) (out-anything ct (make-out outp shared-obj-pos shared-obj-pos-any counting? stx-objs wraps hash-consed hash-consed-results)) (file-position outp)) @@ -1247,6 +1250,13 @@ (find-relative-path r v) v))) +(define (binding-namess-hash->list binding-namess) + (for/list ([(phase t) (in-hash binding-namess)]) + (cons phase + (list->vector + (apply append (for/list ([(id sym) (in-hash t)]) + (list id sym))))))) + ;; ---------------------------------------- ;; We want to hash-cons syntax-object wraps, but a normal `equal?`-based diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 2389c36c9c..04010dbaf3 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -43,10 +43,21 @@ (define (read-compilation-top v) (match v - [`(,ld ,prefix . ,code) + [`(,ld ,binding-namess ,prefix . ,code) (unless (prefix? prefix) (error 'bad "not prefix ~a" prefix)) - (make-compilation-top ld prefix code)])) + (make-compilation-top ld + (binding-namess-list->hash binding-namess) + prefix + code)])) + +(define (binding-namess-list->hash binding-namess) + (for/hash ([e (in-list binding-namess)]) + (values (car e) + (let ([vec (cdr e)]) + (for/hash ([i (in-range 0 (vector-length vec) 2)]) + (values (vector-ref vec i) + (vector-ref vec (add1 i)))))))) (define (read-resolve-prefix v) (match v @@ -1155,8 +1166,9 @@ (define srcloc-ht (make-hasheq)) (let walk ([p v]) (match p - [(compilation-top _ pfx c) + [(compilation-top _ binding-namess pfx c) (struct-copy compilation-top p + [binding-namess (walk binding-namess)] [prefix (walk pfx)] [code (walk c)])] [(prefix _ _ s _) diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index c7db5e3a08..fecdece92b 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -66,7 +66,11 @@ (define-form-struct form ()) (define-form-struct (expr form) ()) -(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? any/c)])) ; compiled code always wrapped with this +(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] + [binding-namess (hash/c exact-nonnegative-integer? + (hash/c symbol? identifier?))] + [prefix prefix?] + [code (or/c form? any/c)])) ; compiled code always wrapped with this ;; A provided identifier (define-form-struct provided ([name symbol?]