diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index e65df730ac..8bc8967d43 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -75,12 +75,12 @@ Here's the idea: ;; Transformations (log-info "Removing dependencies") -(define-values (batch-nodep top-lang-info top-self-modidx) +(define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) (nodep-file file-to-batch (excluded-modules))) (log-info "Merging modules") (define batch-merge - (merge-compilation-top batch-nodep)) + (merge-compilation-top get-modvar-rewrite batch-nodep)) ; Not doing this for now ;(log-info "GC-ing top-levels") diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 942305bc93..f25dd63166 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -7,22 +7,24 @@ (define MODULE-TOPLEVEL-OFFSETS (make-hash)) -(define (merge-compilation-top top) - (match top - [(struct compilation-top (max-let-depth 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))) - (define total-stxs (length (prefix-stxs new-prefix))) - (define total-lifts (prefix-num-lifts new-prefix)) - (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth)) - (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-splice (gen-new-forms new-prefix)))] - [else (error 'merge "unrecognized: ~e" top)])) +(define current-get-modvar-rewrite (make-parameter #f)) +(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)) + (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))) + (define total-stxs (length (prefix-stxs new-prefix))) + (define total-lifts (prefix-num-lifts new-prefix)) + (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth)) + (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-splice (gen-new-forms new-prefix)))] + [else (error 'merge "unrecognized: ~e" top)]))) (define (merge-forms max-let-depth prefix forms) (if (empty? forms) @@ -75,7 +77,7 @@ ([tl (in-list mod-toplevels)]) (match tl [(and mv (struct module-variable (modidx sym pos phase))) - (define rw (get-modvar-rewrite modidx)) + (define rw ((current-get-modvar-rewrite) modidx)) ; 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)) @@ -166,4 +168,6 @@ (map update body)))])) (provide/contract - [merge-compilation-top (compilation-top? . -> . compilation-top?)]) \ No newline at end of file + [merge-compilation-top (-> get-modvar-rewrite/c + compilation-top? + compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 827c38026f..aaa98503e3 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -6,45 +6,53 @@ (define excluded-modules (make-parameter null)) -(define (nodep-file file-to-batch excluded) - (excluded-modules excluded) - (match (get-nodep-module-code/path file-to-batch 0) - [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) - (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite))])) +(define ZOS (make-parameter #f)) +(define MODULE-IDX-MAP (make-parameter #f)) +(define PHASE*MODULE-CACHE (make-parameter #f)) + +(define (nodep-file file-to-batch excluded) + (define idx-map (make-hash)) + (parameterize ([ZOS (make-hash)] + [MODULE-IDX-MAP idx-map] + [PHASE*MODULE-CACHE (make-hash)]) + (define (get-modvar-rewrite modidx) + (define pth (mpi->path* modidx)) + (hash-ref idx-map pth + (lambda () + (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) + (excluded-modules excluded) + (match (get-nodep-module-code/path file-to-batch 0) + [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) + (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)]))) (define (path->comp-top pth) - (call-with-input-file pth zo-parse)) + (hash-ref! (ZOS) pth + (λ () + (call-with-input-file pth zo-parse)))) (define (excluded? pth) (set-member? (excluded-modules) (path->string pth))) -(define MODULE-IDX-MAP (make-hash)) (define (get-nodep-module-code/index mpi phase) (define pth (mpi->path! mpi)) (cond [(symbol? pth) - (hash-set! MODULE-IDX-MAP pth pth) + (hash-set! (MODULE-IDX-MAP) pth pth) pth] [(excluded? pth) - (hash-set! MODULE-IDX-MAP pth mpi) + (hash-set! (MODULE-IDX-MAP) pth mpi) mpi] [else (get-nodep-module-code/path pth phase)])) -(define (get-modvar-rewrite modidx) - (define pth (mpi->path* modidx)) - (hash-ref MODULE-IDX-MAP pth - (lambda () - (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) (define-struct @phase (phase code)) (define-struct modvar-rewrite (modidx provide->toplevel)) (define-struct module-code (modvar-rewrite lang-info ctop)) (define @phase-ctop (compose module-code-ctop @phase-code)) -(define PHASE*MODULE-CACHE (make-hash)) (define (get-nodep-module-code/path pth phase) (define MODULE-CACHE - (hash-ref! PHASE*MODULE-CACHE phase make-hash)) + (hash-ref! (PHASE*MODULE-CACHE) phase make-hash)) (if (hash-ref MODULE-CACHE pth #f) #f (hash-ref! @@ -67,7 +75,7 @@ pth phase))) (when (and phase (zero? phase)) - (hash-set! MODULE-IDX-MAP pth modvar-rewrite)) + (hash-set! (MODULE-IDX-MAP) pth modvar-rewrite)) (make-@phase phase (make-module-code modvar-rewrite lang-info ctop)))))) @@ -170,9 +178,12 @@ [else (error 'extract-modules "Unknown extraction: ~S" ct)])) +(define get-modvar-rewrite/c + (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))) (provide/contract [struct modvar-rewrite ([modidx module-path-index?] [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] - [get-modvar-rewrite (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))] - [nodep-file (path-string? set? . -> . (values compilation-top? lang-info/c module-path-index?))]) \ No newline at end of file + [get-modvar-rewrite/c contract?] + [nodep-file (-> path-string? set? + (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) \ No newline at end of file