diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 1c685d67ba..001fb30d53 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -90,7 +90,8 @@ Here's the idea: (log-debug "GC-ing top-levels~n") (define batch-gcd - (gc-toplevels batch-merge)) + batch-merge + #;(gc-toplevels batch-merge)) (log-debug "Alpha-varying top-levels~n") (define batch-alpha diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index d0b4ddbcba..a016720caa 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -134,8 +134,9 @@ (void)] [(and v (not (? form?))) (void)])) - (define build-graph!** (build-form-memo build-graph!* #:void? #t)) - (define (build-graph! lhs form) (build-graph!** form lhs)) + (define-values (first-build-graph!** build-graph!**) + (build-form-memo build-graph!* #:void? #t)) + (define (build-graph! lhs form) (first-build-graph!** form lhs)) build-graph!) (define (graph-dfs g start-node) @@ -267,9 +268,9 @@ [(and v (not (? form?))) v] )) - (define update + (define-values (first-update update) (build-form-memo inner-update)) - update) + first-update) (provide/contract [gc-toplevels (compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 7163de96d2..a6d944d722 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -61,10 +61,10 @@ (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) (log-debug (format "Rewriting ~a of ~S~n" pos (mpi->path* modidx))) - (+ (hash-ref MODULE-TOPLEVEL-OFFSETS self-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))])])) + (provide->toplevel sym pos))])])) (define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) (define-values @@ -76,6 +76,7 @@ (match tl [(and mv (struct module-variable (modidx sym pos phase))) (define rw (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)) (cond @@ -99,6 +100,7 @@ (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))) @@ -119,7 +121,9 @@ (define new-mod-prefix (struct-copy prefix mod-prefix [toplevels new-mod-toplevels])) - (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx toplevel-offset) + (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx + (lambda (n) + (list-ref toplevel-remap n))) (unless (= (length toplevel-remap) (length mod-toplevels)) (error 'merge-module "Not remapping everything: ~S ~S~n" diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 701b4475d8..c6d1f4d9c6 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -1,5 +1,5 @@ #lang racket -(require compiler/zo-parse +(require compiler/zo-structs "util.rkt") (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) @@ -84,9 +84,9 @@ [(and f (not (? form?))) f] )) - (define update + (define-values (first-update update) (build-form-memo inner-update)) - update) + first-update) (provide/contract [update-toplevels diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 7f8c653049..1334e2911b 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -12,23 +12,46 @@ (define (eprintf . args) (apply fprintf (current-error-port) args)) +(struct nothing ()) + +(define-syntax-rule (eprintf* . args) (void)) + (define (build-form-memo inner-update #:void? [void? #f]) (define memo (make-hasheq)) (define (update form . args) - (cond - [(hash-ref memo form #f) - => (λ (x) x)] - [else - (let () - (define ph (make-placeholder #f)) - (hash-set! memo form ph) - (define nv (apply inner-update form args)) - (placeholder-set! ph nv) - nv)])) + (eprintf* "Updating on ~a\n" form) + (define fin + (cond + [(hash-ref memo form #f) + => (λ (x) + (eprintf* "Found in memo table\n") + x)] + [else + (eprintf* "Not in memo table\n") + (let () + (define ph (make-placeholder (nothing))) + (hash-set! memo form ph) + (define nv (nothing)) + (dynamic-wind void + (λ () + (set! nv (apply inner-update form args))) + (λ () + (if (nothing? nv) + (eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form) + (begin + (placeholder-set! ph nv) + (hash-set! memo form nv))))) + nv)])) + (eprintf* "Updating on ~a ---->\n ~a\n" form fin) + fin) (define (first-update form . args) + (eprintf* "Top level update on ~a\n" form) (define final (apply update form args)) - (make-reader-graph final)) - first-update) + (eprintf* "Top level update on ~a ---->\n ~a\n" form final) + (define fin (make-reader-graph final)) + (eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin) + fin) + (values first-update update)) (define lang-info/c (or/c #f (vector/c module-path? symbol? any/c))) @@ -51,6 +74,7 @@ (((unconstrained-domain-> any/c)) (#:void? boolean?) . ->* . - (unconstrained-domain-> any/c))] + (values (unconstrained-domain-> any/c) + (unconstrained-domain-> any/c)))] [lang-info/c contract?] [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))]) \ No newline at end of file diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index afd0a0b084..666763ba8b 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -481,8 +481,8 @@ (define-syntax with-type-trace (syntax-rules () [(_ v body ...) - (begin body ...) - #;(with-continuation-mark 'zo (typeof v) + #;(begin body ...) + (with-continuation-mark 'zo (typeof v) (begin0 (begin body ...) (void)))])) (define (out-anything v out) @@ -860,7 +860,8 @@ (out-byte CPT_ESCAPE out) (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) - (out-bytes bstr out)]))))) + (out-bytes bstr out)] + [else (error 'out-anything "~s" (current-type-trace))]))))) (define-struct module-decl (content))