diff --git a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt index 6edd751cb7..c90cdc1c1f 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt @@ -9,7 +9,7 @@ "nodep.rkt" "update-toplevels.rkt") -(define MODULE-TOPLEVEL-OFFSETS (make-hash)) +(define MODULE-TOPLEVEL-OFFSETS (make-hasheq)) (define current-get-modvar-rewrite (make-parameter #f)) (define (merge-compilation-top get-modvar-rewrite top) @@ -25,21 +25,21 @@ (log-debug (format "total toplevels ~S" total-tls)) (log-debug (format "total stxs ~S" total-stxs)) (log-debug (format "num-lifts ~S" total-lifts)) - (make-compilation-top - new-max-let-depth new-prefix + (make-compilation-top + new-max-let-depth new-prefix (make-splice (gen-new-forms new-prefix)))] [else (error 'merge "unrecognized: ~e" top)]))) (define (merge-forms max-let-depth prefix forms) (if (empty? forms) - (values max-let-depth prefix (lambda _ empty)) - (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] - [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) - (values rmax-let-depth - rprefix - (lambda args - (append (apply gen-fform args) - (apply gen-rforms args))))))) + (values max-let-depth prefix (lambda _ empty)) + (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] + [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) + (values rmax-let-depth + rprefix + (lambda args + (append (apply gen-fform args) + (apply gen-rforms args))))))) (define (merge-form max-let-depth prefix form) (match form @@ -61,16 +61,20 @@ (append root-toplevels mod-toplevels) (append root-stxs mod-stxs))])])) +(struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent) + (define (compute-new-modvar mv rw) (match mv [(struct module-variable (modidx sym pos phase constantness)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) (log-debug (format "Rewriting ~a of ~S" pos (mpi->path* modidx))) - ((hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx - (lambda () - (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))) - (provide->toplevel sym pos))])])) + (match-define (toplevel-offset-rewriter rewrite-fun meta) + (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx + (lambda () + (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))) + (log-debug (format "Rewriting ~a of ~S from ~S" pos (mpi->path* modidx) meta)) + (rewrite-fun (provide->toplevel sym pos))])])) (define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) (define-values @@ -78,15 +82,15 @@ (for/fold ([i 0] [new-toplevels empty] [remap empty]) - ([tl (in-list mod-toplevels)]) + ([tl (in-list mod-toplevels)]) (match tl [(and mv (struct module-variable (modidx sym pos phase constantness))) (define rw ((current-get-modvar-rewrite) modidx)) - ; XXX We probably don't need to deal with #f phase + ; XXX We probably don't need to deal with #f phase (unless (or (not phase) (zero? phase)) (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) (cond - ; Primitive module like #%paramz + ; Primitive module like #%paramz [(symbol? rw) (log-debug (format "~S from ~S" sym rw)) (values (add1 i) @@ -106,7 +110,7 @@ (values (add1 i) (list* tl new-toplevels) (list* (+ i toplevel-offset) remap))]))) - ; XXX This would be more efficient as a vector + ; XXX This would be more efficient as a vector (values (reverse new-toplevels) (reverse remap))) @@ -118,8 +122,9 @@ (define toplevel-offset (length (prefix-toplevels top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) - (define mod-toplevels (prefix-toplevels mod-prefix)) - (define-values (new-mod-toplevels toplevel-remap) (filter-rewritable-module-variable? toplevel-offset mod-toplevels)) + (define mod-toplevels (prefix-toplevels mod-prefix)) + (define-values (new-mod-toplevels toplevel-remap) + (filter-rewritable-module-variable? toplevel-offset mod-toplevels)) (define num-mod-toplevels (length toplevel-remap)) (define mod-stxs @@ -129,9 +134,16 @@ (define new-mod-prefix (struct-copy prefix mod-prefix [toplevels new-mod-toplevels])) - (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx - (lambda (n) - (list-ref toplevel-remap n))) + (define offset-meta (vector name srcname self-modidx)) + (log-debug "Setting toplevel offsets rewriter for ~S and it is currently ~S" + offset-meta + (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx #f)) + (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx + (toplevel-offset-rewriter + (lambda (n) + (log-debug "Finding offset ~a in ~S of ~S" n toplevel-remap offset-meta) + (list-ref toplevel-remap n)) + offset-meta)) (unless (= (length toplevel-remap) (length mod-toplevels)) (error 'merge-module "Not remapping everything: ~S ~S" @@ -142,7 +154,7 @@ (log-debug (format "[~S] Incrementing lifts by ~a" name lift-offset)) - (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" + (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" name (length mod-toplevels) (length new-mod-toplevels))) @@ -155,15 +167,15 @@ (define total-lifts (prefix-num-lifts top-prefix)) (define max-toplevel (+ top-lift-start total-lifts)) (define update - (update-toplevels + (update-toplevels (lambda (n) (cond [(mod-lift-start . <= . n) - ; This is a lift + ; This is a lift (define which-lift (- n mod-lift-start)) (define lift-tl (+ top-lift-start lift-offset which-lift)) (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" + (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) lift-tl] [else diff --git a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt index 50ca687268..75e1a4eecb 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt @@ -128,10 +128,13 @@ (when (symbol? tl) (hash-set! provide-ht (intern tl) i))) (lambda (sym pos) - (log-debug (format "Looking up ~S@~a" sym pos)) - (hash-ref provide-ht (intern sym) + (log-debug (format "Looking up ~S@~a in ~S" sym pos prefix)) + (define res + (hash-ref provide-ht (intern sym) (lambda () - (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))) + (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix)))) + (log-debug (format "Looked up ~S@~a and got ~v" sym pos res)) + res)) (define (nodep-module mod-form phase) (match mod-form diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt index a10efce85e..0fd5b24fa8 100644 --- a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt @@ -13,7 +13,7 @@ (values (get-output-string o) (get-output-string e))) (define (test-on-program filename) - ; run modular program, capture output + ;; run modular program, capture output (define-values (modular-output modular-error) (capture-output (find-exe) filename)) @@ -24,15 +24,15 @@ (find-system-path 'temp-dir) (path-add-suffix filename #"_merged.zo"))))) - ; demodularize + ;; demodularize (parameterize ([current-input-port (open-input-string "")]) (system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename filename)) - ; run whole program + ;; run whole program (define-values (whole-output whole-error) (capture-output (find-exe) demod-filename)) - ; compare output + ;; compare output (test #:failure-prefix (format "~a stdout" filename) whole-output => modular-output diff --git a/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt new file mode 100644 index 0000000000..ea2c5d0f5e --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt @@ -0,0 +1,2 @@ +#lang racket/base +5