diff --git a/compiler-lib/compiler/demodularizer/merge.rkt b/compiler-lib/compiler/demodularizer/merge.rkt index 71202724f2..3aeeadd18e 100644 --- a/compiler-lib/compiler/demodularizer/merge.rkt +++ b/compiler-lib/compiler/demodularizer/merge.rkt @@ -25,6 +25,9 @@ (log-debug (format "total toplevels ~S" total-tls)) (log-debug (format "total stxs ~S" total-stxs)) (log-debug (format "num-lifts ~S" total-lifts)) + (for ([i (in-naturals)] + [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 (make-splice (gen-new-forms new-prefix)))] @@ -32,14 +35,14 @@ (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 @@ -52,15 +55,19 @@ [else (values max-let-depth prefix (lambda _ (list form)))])) +(define (index-of v l) + (for/or ([e (in-list l)] + [i (in-naturals)] + #:when (eq? e v)) + i)) + (define (merge-prefix root-prefix mod-prefix) - (match root-prefix - [(struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) - (match mod-prefix - [(struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) - (make-prefix (+ root-num-lifts mod-num-lifts) - (append root-toplevels mod-toplevels) - (append root-stxs mod-stxs) - root-src-insp-desc)])])) + (match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix) + (match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix) + (make-prefix (+ root-num-lifts mod-num-lifts) + (append root-toplevels mod-toplevels) + (append root-stxs mod-stxs) + root-src-insp-desc)) (struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent) @@ -73,22 +80,25 @@ (define tl (provide->toplevel sym pos)) (log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl)) (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)))) + (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@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta)) (define res (rewrite-fun tl)) (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S" sym pos (mpi->path* modidx) tl meta res)) res])])) -(define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) +(define (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels) (define-values (i new-toplevels remap) (for/fold ([i 0] [new-toplevels empty] [remap empty]) - ([tl (in-list mod-toplevels)]) + ([tl (in-list mod-toplevels)] + [idx (in-naturals)]) + (log-debug (format "[~S] mod-prefix tls\t~v ~v" + name idx tl)) (match tl [(and mv (struct module-variable (modidx sym pos phase constantness))) (define rw ((current-get-modvar-rewrite) modidx)) @@ -96,7 +106,7 @@ (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) @@ -113,10 +123,18 @@ [else (error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])] [tl - (values (add1 i) - (list* tl new-toplevels) - (list* (+ i toplevel-offset) remap))]))) - ; XXX This would be more efficient as a vector + (cond + [(and new-#f-idx (not tl)) + (log-debug (format "[~S] dropping a #f at ~v that would have been at ~v but is now at ~v" + name idx (+ i toplevel-offset) new-#f-idx)) + (values i + new-toplevels + (list* new-#f-idx remap))] + [else + (values (add1 i) + (list* tl new-toplevels) + (list* (+ i toplevel-offset) remap))])]))) + ; XXX This would be more efficient as a vector (values (reverse new-toplevels) (reverse remap))) @@ -127,12 +145,18 @@ unexported mod-max-let-depth dummy lang-info internal-context binding-names flags pre-submodules post-submodules)) - (define toplevel-offset (length (prefix-toplevels top-prefix))) + (define top-toplevels (prefix-toplevels top-prefix)) + (define toplevel-offset (length top-toplevels)) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) (define mod-toplevels (prefix-toplevels mod-prefix)) + (define new-#f-idx + (index-of #f top-toplevels)) + (when new-#f-idx + (log-debug (format "[~S] found a #f entry in prefix already at ~v, squashing" + name new-#f-idx))) (define-values (new-mod-toplevels toplevel-remap) - (filter-rewritable-module-variable? toplevel-offset mod-toplevels)) + (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels)) (define num-mod-toplevels (length toplevel-remap)) (define mod-stxs @@ -177,17 +201,23 @@ (define update (update-toplevels (lambda (n) - (cond - [(mod-lift-start . <= . n) - ; 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)" - name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) - lift-tl] - [else - (list-ref toplevel-remap n)])) + (define new-idx + (cond + [(mod-lift-start . <= . n) + (log-debug (format "[~S] ~v is a lift" + name n)) + (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)" + name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) + lift-tl] + [else + ;; xxx maybe change this to a vector after it is made to make this efficient + (list-ref toplevel-remap n)])) + (log-debug (format "[~S] ~v is remapped to ~v" + name n new-idx)) + new-idx) (lambda (n) (+ n topsyntax-offset)) (prefix-syntax-start top-prefix))) diff --git a/compiler-lib/compiler/demodularizer/nodep.rkt b/compiler-lib/compiler/demodularizer/nodep.rkt index d1652826ff..d3741f5977 100644 --- a/compiler-lib/compiler/demodularizer/nodep.rkt +++ b/compiler-lib/compiler/demodularizer/nodep.rkt @@ -18,7 +18,7 @@ (define idx-map (make-hash)) (parameterize ([ZOS (make-hash)] [MODULE-IDX-MAP idx-map] - [PHASE*MODULE-CACHE (make-hash)]) + [PHASE*MODULE-CACHE (make-hasheq)]) (define (get-modvar-rewrite modidx) (define pth (mpi->path* modidx)) (hash-ref idx-map pth