diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 99ad2e5e5c..2553baeaf9 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -46,6 +46,7 @@ Here's the idea: "gc-toplevels.rkt" "alpha.rkt" "module.rkt" + "replace-modidx.rkt" compiler/decompile compiler/zo-marshal racket/set) @@ -65,13 +66,13 @@ Here's the idea: ;; Compile -#;(log-debug "Removing existing zo file~n") +#;(log-debug "Removing existing zo file") #;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) #;(when (file-exists? compiled-zo-path) (delete-file compiled-zo-path)) -(log-debug "Compiling module~n") +(log-debug "Compiling module") (void (system* (find-executable-path "raco") "make" file-to-batch)) @@ -81,52 +82,49 @@ Here's the idea: (define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) ;; Transformations -(log-debug "Removing dependencies~n") +(log-debug "Removing dependencies") (define-values (batch-nodep top-lang-info top-self-modidx) (nodep-file file-to-batch (excluded-modules))) -(log-debug "Merging modules~n") +(log-debug "Merging modules") (define batch-merge (merge-compilation-top batch-nodep)) -(log-debug "GC-ing top-levels~n") +(log-debug "GC-ing top-levels") (define batch-gcd batch-merge #;(gc-toplevels batch-merge)) -(log-debug "Alpha-varying top-levels~n") +(log-debug "Alpha-varying top-levels") (define batch-alpha (alpha-vary-ctop batch-gcd)) +(log-debug "Replacing self-modidx") +(define batch-replace-modidx + (replace-modidx batch-alpha top-self-modidx)) + (define batch-modname (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) -(log-debug (format "Modularizing into ~a~n" batch-modname)) +(log-debug (format "Modularizing into ~a" batch-modname)) (define batch-mod - (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-alpha)) + (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) ;; Output (define batch-final batch-mod) -(log-debug "Writing merged source~n") +(log-debug "Writing merged source") (with-output-to-file merged-source-path (lambda () - (pretty-print (decompile batch-final))) + (write batch-final)) #:exists 'replace) -(log-debug "Writing merged struct~n") -(with-output-to-file - merged-struct-path - (lambda () - (pretty-write batch-final)) - #:exists 'replace) - -(log-debug "Writing merged zo~n") +(log-debug "Writing merged zo") (void (with-output-to-file merged-zo-path (lambda () - (write-bytes (zo-marshal batch-final))) + (zo-marshal-to batch-final (current-output-port))) #:exists 'replace)) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index a6d944d722..942305bc93 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -15,10 +15,10 @@ (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~n" max-let-depth new-max-let-depth)) - (log-debug (format "total toplevels ~S~n" total-tls)) - (log-debug (format "total stxs ~S~n" total-stxs)) - (log-debug (format "num-lifts ~S~n" total-lifts)) + (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)))] @@ -60,7 +60,7 @@ [(struct module-variable (modidx sym pos phase)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) - (log-debug (format "Rewriting ~a of ~S~n" pos (mpi->path* modidx))) + (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))) @@ -82,7 +82,7 @@ (cond ; Primitive module like #%paramz [(symbol? rw) - (log-debug (format "~S from ~S~n" sym rw)) + (log-debug (format "~S from ~S" sym rw)) (values (add1 i) (list* tl new-toplevels) (list* (+ i toplevel-offset) remap))] @@ -126,22 +126,22 @@ (list-ref toplevel-remap n))) (unless (= (length toplevel-remap) (length mod-toplevels)) - (error 'merge-module "Not remapping everything: ~S ~S~n" + (error 'merge-module "Not remapping everything: ~S ~S" mod-toplevels toplevel-remap)) - (log-debug (format "[~S] Incrementing toplevels by ~a~n" + (log-debug (format "[~S] Incrementing toplevels by ~a" name toplevel-offset)) - (log-debug (format "[~S] Incrementing lifts by ~a~n" + (log-debug (format "[~S] Incrementing lifts by ~a" name lift-offset)) - (log-debug (format "[~S] Filtered mod-vars from ~a to ~a~n" + (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" name (length mod-toplevels) (length new-mod-toplevels))) (values (max max-let-depth mod-max-let-depth) (merge-prefix top-prefix new-mod-prefix) (lambda (top-prefix) - (log-debug (format "[~S] Updating top-levels\n" name)) + (log-debug (format "[~S] Updating top-levels" name)) (define top-lift-start (prefix-lift-start top-prefix)) (define mod-lift-start (prefix-lift-start mod-prefix)) (define total-lifts (prefix-num-lifts top-prefix)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 04ff19f019..41865df308 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -950,7 +950,12 @@ (make-closure v ; XXX Why call gensym here? - (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure])) + #;(gensym (let ([s (lam-name v)]) (cond [(symbol? s) s] @@ -1046,6 +1051,7 @@ (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + #;(printf "Parsed table:\n") #;(for ([(i v) (in-dict (cport-symtab cp))]) (printf "~a = ~a\n" i (placeholder-get v)) ) (set-cport-pos! cp shared-size) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 51b4e8dd9a..858a557def 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -7,13 +7,19 @@ (parameterize ([read-accept-compiled #t]) (read (open-input-bytes bs)))) +(define (run-compiled-bytes bs [delayed? #t]) + (system "touch test.rkt") + (system "touch compiled/test_rkt.zo") + (system (format "racket ~a -t test.rkt" (if delayed? "" "-d")))) + (define (roundtrip ct) (define bs (zo-marshal ct)) - (with-output-to-file "test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) + (with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) (test #:failure-prefix (format "~S" ct) (test bs (zo-parse (open-input-bytes bs)) => ct - (read-compiled-bytes bs)))) + (run-compiled-bytes bs #t) + (run-compiled-bytes bs #f)))) (define mpi (module-path-index-join #f #f))