raco make -j

original commit: 2e1dffbfcc

collects/compiler/commands/exe.rkt

@@ -23,7 +23,7 @@
    #:once-each
    [("-o") file "Write executable as <file>"
     (exe-output file)]
-   [("--gui") "Geneate GUI executable"
+   [("--gui") "Generate GUI executable"
     (gui #t)]
    [("--collects-path") path "Set <path> as main collects for executable"
     (exe-embedded-collects-path path)]

collects/compiler/commands/info.rkt

@@ -7,4 +7,5 @@
     ("decompile" compiler/commands/decompile "decompile bytecode" #f)
     ("expand" compiler/commands/expand "macro-expand source" #f)
     ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
-    ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f)))
+    ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f)
+    ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f)))

collects/compiler/commands/make.rkt

@@ -3,7 +3,9 @@
          raco/command-name
          compiler/cm
          "../compiler.ss"
-         dynext/file)
+         dynext/file
+         setup/parallel-build
+         racket/match)
 
 (define verbose (make-parameter #f))
 (define very-verbose (make-parameter #f))
@@ -12,6 +14,7 @@
 (define disable-deps (make-parameter #f))
 (define prefixes (make-parameter null))
 (define assume-primitives (make-parameter #t))
+(define worker-count (make-parameter 1))
 
 (define source-files
   (command-line
@@ -27,13 +30,15 @@
     (assume-primitives #f)]
    [("-v") "Verbose mode"
     (verbose #t)]
+   [("-j") wc "Parallel job count" (worker-count (string->number wc))]
    [("--vv") "Very verbose mode"
     (verbose #t)
     (very-verbose #t)]
    #:args (file . another-file) (cons file another-file)))
 
-(if (disable-deps)
+(cond 
   ;; Just compile one file:
+  [(disable-deps)
     (let ([prefix
            `(begin
               (require scheme)
@@ -45,8 +50,9 @@
               (void))])
       ((compile-zos prefix #:verbose? (verbose))
        source-files
-       'auto))
+       'auto))]
   ;; Normal make:
+  [(= (worker-count) 1)
     (let ([n (make-base-empty-namespace)]
           [did-one? #f])
       (parameterize ([current-namespace n]
@@ -76,4 +82,11 @@
               (when (verbose)
                 (printf " [~a \"~a\"]\n"
                         (if did-one? "output to" "already up-to-date at")
-                        dest))))))))
+                        dest)))))))]
+  ;; Parallel make:
+  [else (parallel-compile-files source-files #:worker-count (worker-count)
+    #:handler (lambda (type work msg out err)
+      (match type
+        ['done (when (verbose) (printf " Made ~a\n" work))]
+        ['output (printf " Output from: ~a\n~a~a" work out err)]
+        [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])))])

collects/compiler/commands/pack.rkt

@@ -23,7 +23,7 @@
   (command-line
    #:program (short-program+command-name)
    #:once-each
-   [("--collect") "Pack collections instead of files and directories"
+   [("--collect") "<path>s specify collections instead of files/dirs"
     (collection? #t)]
    [("--plt-name") name "Set the printed <name> describing the archive"
     (plt-name name)]
@@ -45,8 +45,8 @@
    #:once-each
    [("-v") "Verbose mode"
     (verbose #t)]
-   #:args (dest-file . file)
+   #:args (dest-file . path)
-   (values dest-file file)))
+   (values dest-file path)))
 
 (if (not (collection?))
     ;; Files and directories

collects/compiler/decompile.rkt

@@ -16,6 +16,7 @@
              (namespace-require ''#%kernel)
              (namespace-require ''#%unsafe)
              (namespace-require ''#%flfxnum)
+             (namespace-require ''#%futures)
              (for/list ([l (namespace-mapped-symbols)])
                (cons l (with-handlers ([exn:fail? (lambda (x) #f)])
                          (compile l))))))]
@@ -159,8 +160,6 @@
      (extract-name name)]
     [(struct closure (lam gen-id))
      (extract-id lam)]
-    [(struct indirect (v))
-     (extract-id v)]
     [else #f]))
 
 (define (extract-ids! body ids)
@@ -287,15 +286,10 @@
          (begin
            (hash-set! closed gen-id #t)
            `(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
-    [(struct indirect (val))
-     (if (closure? val)
-         (decompile-expr val globs stack closed)
-         '???)]
     [else `(quote ,expr)]))
 
 (define (decompile-lam expr globs stack closed)
   (match expr
-    [(struct indirect (val)) (decompile-lam val globs stack closed)]
     [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
     [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body))
      (let ([vars (for/list ([i (in-range num-params)]

collects/compiler/demodularizer/alpha.rkt

@@ -0,0 +1,19 @@
+#lang racket
+(require compiler/zo-parse)
+
+(define (alpha-vary-ctop top)
+  (match top
+    [(struct compilation-top (max-let-depth prefix form))
+     (make-compilation-top max-let-depth (alpha-vary-prefix prefix) form)]))
+(define (alpha-vary-prefix p)
+  (struct-copy prefix p
+               [toplevels
+                (map (match-lambda
+                       [(and sym (? symbol?))
+                        (gensym sym)]
+                       [other
+                        other])
+                     (prefix-toplevels p))]))
+
+(provide/contract
+ [alpha-vary-ctop (compilation-top? . -> . compilation-top?)])

collects/compiler/demodularizer/batch.rkt

@@ -0,0 +1,113 @@
+#lang racket
+#|
+Here's the idea:
+
+- Take a module's bytecode
+- Recursively get all the bytecode for modules that the target requires
+- After reading it, prune everything that isn't at phase 0 (the runtime phase)
+
+- Now that we have all the modules, the next step is to merge them into a single
+  module
+-- Although actually we collapse them into the top-level, not a module
+- To do that, we iterate through all the modules doing two things as we go:
+-- Incrementing all the global variable references by all the references in all
+   the modules
+--- So if A has 5, then B's start at index 5 and so on
+-- Replacing module variable references with the actual global variables
+   corresponding to those variables
+--- So if A's variable 'x' is in global slot 4, then if B refers to it, it 
+    directly uses slot 4, rather than a module-variable slot
+
+- At that point we have all the module code in a single top-level, but many
+  toplevels won't be used because a library function isn't really used
+- So, we do a "garbage collection" on elements of the prefix
+- First, we create a dependency graph of all toplevels and the initial scope
+- Then, we do a DFS on the initial scope and keep all those toplevels, throwing
+  away the construction of everything else
+  [XXX: This may be broken because of side-effects.]
+
+- Now we have a small amount code, but because we want to go back to source,
+  we need to fix it up a bit; because different modules may've used the same
+  names
+- So, we do alpha-renaming, but it's easy because names are only used in the
+  compilation-top prefix structure
+
+[TODO]
+
+- Next, we decompile
+- Then, it will pay to do dead code elimination and inlining, etc.
+|#
+
+(require racket/pretty
+         racket/system
+         "mpi.rkt"
+         "util.rkt"
+         "nodep.rkt"
+         "merge.rkt"
+         "gc-toplevels.rkt"
+         "alpha.rkt"
+         "module.rkt"
+         "replace-modidx.rkt"
+         compiler/decompile
+         compiler/zo-marshal
+         racket/set)
+
+(define (main file-to-batch)
+  (define-values (base name dir?) (split-path file-to-batch))
+  (when (or (eq? base #f) dir?)
+    (error 'batch "Cannot run on directory"))
+  
+  ;; Compile 
+  
+  (log-info "Compiling module")
+  (void (system* (find-executable-path "raco") "make" file-to-batch)) 
+  
+  (define merged-zo-path (path-add-suffix file-to-batch #"_merged.zo"))
+  
+  ;; Transformations
+  (define path-cache (make-hash))
+  
+  (log-info "Removing dependencies")
+  (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite)
+    (parameterize ([MODULE-PATHS path-cache])
+      (nodep-file file-to-batch)))
+  
+  (log-info "Merging modules")
+  (define batch-merge
+    (parameterize ([MODULE-PATHS path-cache])
+      (merge-compilation-top get-modvar-rewrite batch-nodep)))
+  
+  ; Not doing this for now
+  ;(log-info "GC-ing top-levels")
+  (define batch-gcd
+    batch-merge
+    #;(gc-toplevels batch-merge))
+  
+  (log-info "Alpha-varying top-levels")
+  (define batch-alpha
+    (alpha-vary-ctop batch-gcd))
+  
+  (log-info "Replacing self-modidx")
+  (define batch-replace-modidx
+    (replace-modidx batch-alpha top-self-modidx))
+  
+  (define batch-modname
+    (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) "")))
+  (log-info (format "Modularizing into ~a" batch-modname))
+  (define batch-mod
+    (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx))
+  
+  (log-info "Writing merged zo")
+  (void
+   (with-output-to-file 
+       merged-zo-path
+     (lambda ()
+       (zo-marshal-to batch-mod (current-output-port)))
+     #:exists 'replace)))
+
+(command-line #:program "batch" 
+              #:multi
+              [("-e" "--exclude-modules") mod
+                                          "Exclude a module from being batched"
+                                          (current-excluded-modules (set-add (current-excluded-modules) mod))]
+              #:args (filename) (main filename))

collects/compiler/demodularizer/gc-toplevels.rkt

@@ -0,0 +1,276 @@
+#lang racket
+(require compiler/zo-parse
+         "util.rkt")
+
+; XXX Use efficient set structure
+(define (gc-toplevels top)
+  (match top
+    [(struct compilation-top (max-let-depth top-prefix form))
+     (define lift-start
+       (prefix-lift-start top-prefix))
+     (define max-depgraph-index 
+       (+ (prefix-num-lifts top-prefix)
+          lift-start))
+     (define top-node max-depgraph-index)
+     (define DEP-GRAPH (make-vector (add1 top-node) (make-refs empty empty)))
+     (define build-graph! (make-build-graph! DEP-GRAPH))
+     (define _void (build-graph! (list top-node) form))
+     (define-values (used-tls stxs) (graph-dfs DEP-GRAPH top-node))
+     (define ordered-used-tls (sort (rest used-tls) <=)) ; This rest drops off the top-node
+     (define ordered-stxs (sort stxs <=))
+     (define (lift? i) (lift-start . <= . i))
+     (define-values (lifts normal-tls) (partition lift? ordered-used-tls))
+     (define new-prefix
+       (make-prefix 
+        (length lifts)
+        (for/list ([i normal-tls])
+          (list-ref (prefix-toplevels top-prefix) i))
+        (for/list ([i ordered-stxs])
+          (list-ref (prefix-stxs top-prefix) i))))
+     (define new-lift-start
+       (prefix-lift-start new-prefix))
+     ; XXX This probably breaks max-let-depth
+     (define new-form
+       ((gc-toplevels-form 
+         (lambda (pos) (index<=? pos ordered-used-tls))
+         (lambda (pos)
+           (if (lift? pos)
+               (+ new-lift-start (index<=? pos lifts))
+               (index<=? pos normal-tls)))
+         (lambda (stx-pos)
+           (index<=? stx-pos ordered-stxs))
+         (prefix-syntax-start new-prefix))
+        form))
+     (log-debug (format "Total TLS: ~S" (length normal-tls)))
+     (log-debug (format "Used TLS: ~S" normal-tls))
+     (log-debug (format "Total lifts: ~S" (length lifts)))
+     (log-debug (format "Used lifts: ~S" lifts))
+     (log-debug (format "Total stxs: ~S" (length stxs)))
+     (log-debug (format "Used stxs: ~S" ordered-stxs))
+     (make-compilation-top
+      max-let-depth
+      new-prefix
+      new-form)]))
+
+(define-struct refs (tl stx) #:transparent)
+
+(define (make-build-graph! DEP-GRAPH)
+  (define (build-graph!* form lhs)
+    (match form
+      [(struct def-values (ids rhs))
+       (define new-lhs (map toplevel-pos ids))
+       ; If we require one, we should require all, so make them reference each other
+       (for-each (lambda (tl) (build-graph! new-lhs tl)) ids)
+       (build-graph! new-lhs rhs)]
+      [(? def-syntaxes?)
+       (error 'build-graph "Doesn't handle syntax")]
+      [(? def-for-syntax?)
+       (error 'build-graph "Doesn't handle syntax")]
+      [(struct req (reqs dummy))
+       (build-graph! lhs dummy)]
+      [(? mod?)
+       (error 'build-graph "Doesn't handle modules")]
+      [(struct seq (forms))
+       (for-each (lambda (f) (build-graph! lhs f)) forms)]
+      [(struct splice (forms))
+       (for-each (lambda (f) (build-graph! lhs f)) forms)]
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)))
+       (build-graph! lhs body)]
+      [(and c (struct closure (code gen-id)))
+       (build-graph! lhs code)]
+      [(and cl (struct case-lam (name clauses)))
+       (for-each (lambda (l) (build-graph! lhs l))
+                 clauses)]
+      [(struct let-one (rhs body flonum? unused?))
+       (build-graph! lhs rhs)
+       (build-graph! lhs body)]
+      [(and f (struct let-void (count boxes? body)))
+       (build-graph! lhs body)]
+      [(and f (struct install-value (_ _ _ rhs body)))
+       (build-graph! lhs rhs)
+       (build-graph! lhs body)]
+      [(struct let-rec (procs body))
+       (for-each (lambda (l) (build-graph! lhs l)) procs)
+       (build-graph! lhs body)]
+      [(and f (struct boxenv (_ body)))
+       (build-graph! lhs body)]
+      [(and f (struct toplevel (_ pos _ _)))
+       (for-each (lambda (lhs)
+                   (dict-update! DEP-GRAPH lhs
+                                 (match-lambda 
+                                   [(struct refs (tls stxs))
+                                    (make-refs (list* pos tls) stxs)])))
+                 lhs)]
+      [(and f (struct topsyntax (_ pos _)))
+       (for-each (lambda (lhs)
+                   (dict-update! DEP-GRAPH lhs
+                                 (match-lambda 
+                                   [(struct refs (tls stxs))
+                                    (make-refs tls (list* pos stxs))])))
+                 lhs)]
+      [(struct application (rator rands))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 (list* rator rands))]
+      [(struct branch (test then else))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 (list test then else))]
+      [(struct with-cont-mark (key val body))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 (list key val body))]
+      [(struct beg0 (seq))
+       (for-each (lambda (f) (build-graph! lhs f))
+                 seq)]
+      [(struct varref (tl))
+       (build-graph! lhs tl)]
+      [(and f (struct assign (id rhs undef-ok?)))
+       (build-graph! lhs id)
+       (build-graph! lhs rhs)]
+      [(struct apply-values (proc args-expr))
+       (build-graph! lhs proc)
+       (build-graph! lhs args-expr)]
+      [(and f (struct primval (id)))
+       (void)]
+      [(and f (struct localref (unbox? pos clear? other-clears? flonum?)))
+       (void)]
+      [(and v (not (? form?)))
+       (void)]))
+  (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)
+  (define visited? (make-hasheq))
+  (define (visit-tl n tls stxs)
+    (if (hash-has-key? visited? n)
+        (values tls stxs)
+        (match (dict-ref g n)
+          [(struct refs (n-tls n-stxs))
+           (hash-set! visited? n #t)
+           (local
+             [(define-values (new-tls1 new-stxs1)
+                (for/fold ([new-tls tls]
+                           [new-stxs stxs])
+                  ([tl (in-list n-tls)])
+                  (visit-tl tl new-tls new-stxs)))
+              (define new-stxs2
+                (for/fold ([new-stxs new-stxs1])
+                  ([stx (in-list n-stxs)])
+                  (define this-stx (visit-stx stx))
+                  (if this-stx
+                      (list* this-stx new-stxs)
+                      new-stxs)))]          
+             (values (list* n new-tls1)
+                     new-stxs2))])))
+  (define stx-visited? (make-hasheq))
+  (define (visit-stx n)
+    (if (hash-has-key? stx-visited? n)
+        #f
+        (begin (hash-set! stx-visited? n #t)
+               n)))
+  (visit-tl start-node empty empty))
+
+; index<=? : number? (listof number?) -> (or/c number? false/c)
+; returns the index of n in l and assumes that l is sorted by <=
+(define (index<=? n l)
+  (match l
+    [(list) #f]
+    [(list-rest f l)
+     (cond
+       [(= n f)
+        0]
+       [(< n f)
+        #f]
+       [else
+        (let ([rec (index<=? n l)])
+          (if rec (add1 rec) rec))])]))
+
+(define (identity x) x)
+(define (gc-toplevels-form keep? update-tl update-ts new-ts-midpt)
+  (define (inner-update form)
+    (match form
+      [(struct def-values (ids rhs))
+       (if (ormap (compose keep? toplevel-pos) ids)
+           (make-def-values (map update ids)
+                            (update rhs))
+           #f)]
+      [(? def-syntaxes?)
+       (error 'gc-tls "Doesn't handle syntax")]
+      [(? def-for-syntax?)
+       (error 'gc-tls "Doesn't handle syntax")]
+      [(struct req (reqs dummy))
+       (make-req reqs (update dummy))]
+      [(? mod?)
+       (error 'gc-tls "Doesn't handle modules")]
+      [(struct seq (forms))
+       (make-seq (filter identity (map update forms)))]
+      [(struct splice (forms))
+       (make-splice (filter identity (map update forms)))]
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)))
+       (struct-copy lam l
+                    [body (update body)])]
+      [(and c (struct closure (code gen-id)))
+       (struct-copy closure c
+                    [code (update code)])]
+      [(and cl (struct case-lam (name clauses)))
+       (struct-copy case-lam cl
+                    [clauses (map update clauses)])]
+      [(struct let-one (rhs body flonum? unused?))
+       (make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is flonum? okay here?
+      [(and f (struct let-void (count boxes? body)))
+       (struct-copy let-void f
+                    [body (update body)])]
+      [(and f (struct install-value (_ _ _ rhs body)))
+       (struct-copy install-value f
+                    [rhs (update rhs)]
+                    [body (update body)])]
+      [(struct let-rec (procs body))
+       (make-let-rec (map update procs) (update body))]
+      [(and f (struct boxenv (_ body)))
+       (struct-copy boxenv f [body (update body)])]
+      [(and f (struct toplevel (_ pos _ _)))
+       (struct-copy toplevel f
+                    [pos (update-tl pos)])]
+      [(and f (struct topsyntax (_ pos _)))
+       (struct-copy topsyntax f
+                    [pos (update-ts pos)]
+                    [midpt new-ts-midpt])]
+      [(struct application (rator rands))
+       (make-application 
+        (update rator)
+        (map update rands))]
+      [(struct branch (test then else))
+       (make-branch 
+        (update test)
+        (update then)
+        (update else))]
+      [(struct with-cont-mark (key val body))
+       (make-with-cont-mark 
+        (update key)
+        (update val)
+        (update body))]
+      [(struct beg0 (seq))
+       (make-beg0 (map update seq))]
+      [(struct varref (tl))
+       (make-varref (update tl))]
+      [(and f (struct assign (id rhs undef-ok?)))
+       (struct-copy assign f
+                    [id (update id)]
+                    [rhs (update rhs)])]
+      [(struct apply-values (proc args-expr))
+       (make-apply-values
+        (update proc)
+        (update args-expr))]
+      [(and f (struct primval (id)))
+       f]
+      [(and f (struct localref (unbox? pos clear? other-clears? flonum?)))
+       f]
+      [(and v (not (? form?)))
+       v]
+      ))
+  (define-values (first-update update)
+    (build-form-memo inner-update))
+  first-update)
+
+(provide/contract
+ [gc-toplevels (compilation-top? . -> . compilation-top?)])

collects/compiler/demodularizer/merge.rkt

@@ -0,0 +1,173 @@
+#lang racket
+(require compiler/zo-parse
+         "util.rkt"
+         "mpi.rkt"
+         "nodep.rkt"
+         "update-toplevels.rkt")
+
+(define MODULE-TOPLEVEL-OFFSETS (make-hash))
+
+(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)
+      (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
+    [(? mod?)
+     (merge-module max-let-depth prefix form)]
+    [(struct seq (forms))
+     (merge-forms max-let-depth prefix forms)]
+    [(struct splice (forms))
+     (merge-forms max-let-depth prefix forms)]
+    [else
+     (values max-let-depth prefix (lambda _ (list form)))]))
+
+(define (merge-prefix root-prefix mod-prefix)
+  (match root-prefix
+    [(struct prefix (root-num-lifts root-toplevels root-stxs))
+     (match mod-prefix
+       [(struct prefix (mod-num-lifts mod-toplevels mod-stxs))
+        (make-prefix (+ root-num-lifts mod-num-lifts)
+                     (append root-toplevels mod-toplevels)
+                     (append root-stxs mod-stxs))])]))
+
+(define (compute-new-modvar mv rw)
+  (match mv
+    [(struct module-variable (modidx sym pos phase))
+     (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))])]))
+
+(define (filter-rewritable-module-variable? toplevel-offset mod-toplevels)
+  (define-values
+    (i new-toplevels remap)
+    (for/fold ([i 0]
+               [new-toplevels empty]
+               [remap empty])
+      ([tl (in-list mod-toplevels)])
+      (match tl
+        [(and mv (struct module-variable (modidx sym pos phase)))
+         (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))
+         (cond
+           ; Primitive module like #%paramz
+           [(symbol? rw)
+            (log-debug (format "~S from ~S" sym rw))
+            (values (add1 i)
+                    (list* tl new-toplevels)
+                    (list* (+ i toplevel-offset) remap))]
+           [(module-path-index? rw)
+            (values (add1 i)
+                    (list* tl new-toplevels)
+                    (list* (+ i toplevel-offset) remap))]
+           [(modvar-rewrite? rw)
+            (values i
+                    new-toplevels
+                    (list* (compute-new-modvar mv rw) remap))]
+           [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
+  (values (reverse new-toplevels)
+          (reverse remap)))
+
+(define (merge-module max-let-depth top-prefix mod-form)
+  (match mod-form
+    [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context))
+     (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 num-mod-toplevels
+       (length toplevel-remap))
+     (define mod-stxs
+       (length (prefix-stxs mod-prefix)))
+     (define mod-num-lifts
+       (prefix-num-lifts mod-prefix))
+     (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)))
+     (unless (= (length toplevel-remap)
+                (length mod-toplevels))
+       (error 'merge-module "Not remapping everything: ~S ~S" 
+              mod-toplevels toplevel-remap))    
+     (log-debug (format "[~S] Incrementing toplevels by ~a"
+              name
+              toplevel-offset))
+     (log-debug (format "[~S] Incrementing lifts by ~a"
+              name
+              lift-offset))
+     (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" 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))
+               (define max-toplevel (+ top-lift-start total-lifts))
+               (define update
+                 (update-toplevels 
+                  (lambda (n)
+                    (cond
+                      [(mod-lift-start . <= . n)
+                       ; This is a lift
+                       (local [(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)]))
+                  (lambda (n)
+                    (+ n topsyntax-offset))
+                  (prefix-syntax-start top-prefix)))
+               (map update body)))]))
+
+(provide/contract
+ [merge-compilation-top (-> get-modvar-rewrite/c
+                            compilation-top?
+                            compilation-top?)])

collects/compiler/demodularizer/module.rkt

@@ -0,0 +1,34 @@
+#lang racket
+(require compiler/zo-parse
+         "util.rkt")
+
+(define (->module-path-index s)
+  (if (module-path-index? s)
+      s
+      (module-path-index-join `(quote ,s) #f)))
+
+(define (wrap-in-kernel-module name srcname lang-info self-modidx top)
+  (match top
+    [(struct compilation-top (max-let-depth prefix form))
+     (define-values (reqs new-forms)
+       (partition req? (splice-forms form)))
+     (define requires
+       (map (compose ->module-path-index wrapped-datum stx-encoded req-reqs) reqs))
+     (make-compilation-top 
+      0
+      (make-prefix 0 (list #f) empty)
+      (make-mod name srcname
+                self-modidx
+                prefix
+                empty ; provides
+                (list (cons 0 requires))
+                new-forms
+                empty ; syntax-body
+                (list empty empty empty) ; unexported
+                max-let-depth
+                (make-toplevel 0 0 #f #f) ; dummy
+                lang-info
+                #t))]))
+
+(provide/contract
+ [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)])

collects/compiler/demodularizer/mpi.rkt

@@ -0,0 +1,31 @@
+#lang racket
+(require syntax/modresolve)
+
+(define current-module-path (make-parameter #f))
+
+(define (mpi->string modidx)
+  (cond
+    [(symbol? modidx) modidx]
+    [else 
+     (mpi->path! modidx)]))
+
+(define MODULE-PATHS (make-parameter #f))
+(define (mpi->path! mpi)
+  (hash-ref! 
+   (MODULE-PATHS) mpi 
+   (lambda ()
+     (define _pth
+       (resolve-module-path-index mpi (current-module-path)))
+     (if (path? _pth)
+         (simplify-path _pth #t)
+         _pth))))
+(define (mpi->path* mpi)
+  (hash-ref (MODULE-PATHS) mpi 
+            (lambda ()
+              (error 'mpi->path* "Cannot locate cache of path for ~S" mpi))))
+
+(provide/contract
+ [MODULE-PATHS (parameter/c (or/c false/c hash?))]
+ [current-module-path (parameter/c path-string?)]
+ [mpi->path! (module-path-index? . -> . (or/c symbol? path?))]
+ [mpi->path* (module-path-index? . -> . (or/c symbol? path?))])

collects/compiler/demodularizer/nodep.rkt

@@ -0,0 +1,189 @@
+#lang racket
+(require compiler/zo-parse
+         "util.rkt"
+         "mpi.rkt"
+         racket/set)
+
+(define current-excluded-modules (make-parameter (set)))
+
+(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)
+  (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))))
+    (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)
+  (hash-ref! (ZOS) pth
+             (λ ()
+               (call-with-input-file pth zo-parse))))
+
+(define (excluded? pth)
+  (set-member? (current-excluded-modules) (path->string pth)))
+
+(define (get-nodep-module-code/index mpi phase)
+  (define pth (mpi->path! mpi))
+  (cond
+    [(symbol? pth)
+     (hash-set! (MODULE-IDX-MAP) pth pth)
+     pth]
+    [(excluded? pth)
+     (hash-set! (MODULE-IDX-MAP) pth mpi)
+     mpi]
+    [else
+     (get-nodep-module-code/path pth phase)]))
+
+(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 (get-nodep-module-code/path pth phase)
+  (define MODULE-CACHE
+    (hash-ref! (PHASE*MODULE-CACHE) phase make-hash))
+  (if (hash-ref MODULE-CACHE pth #f)
+      #f
+      (hash-ref! 
+       MODULE-CACHE pth 
+       (lambda ()
+         (define-values (base file dir?) (split-path pth))
+         (define base-directory
+           (if (path? base) 
+               (path->complete-path base (current-directory))
+               (current-directory)))
+         (define-values (modvar-rewrite lang-info ctop)
+           (begin
+             (log-debug (format "Load ~S @ ~S" pth phase))
+             (nodep/dir
+              (parameterize ([current-load-relative-directory base-directory])
+                (path->comp-top
+                 (build-compiled-path 
+                             base 
+                             (path-add-suffix file #".zo"))))
+              pth
+              phase)))
+         (when (and phase (zero? phase))
+           (hash-set! (MODULE-IDX-MAP) pth modvar-rewrite))
+         (make-@phase 
+          phase
+          (make-module-code modvar-rewrite lang-info ctop))))))
+
+(define (nodep/dir top pth phase)
+  (parameterize ([current-module-path pth])
+    (nodep top phase)))
+
+(define (nodep top phase)
+  (match top
+    [(struct compilation-top (max-let-depth prefix form))
+     (define-values (modvar-rewrite lang-info new-form) (nodep-form form phase))
+     (values modvar-rewrite lang-info (make-compilation-top max-let-depth prefix new-form))]
+    [else (error 'nodep "unrecognized: ~e" top)]))
+
+(define (nodep-form form phase)
+  (if (mod? form)
+      (local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))]
+        (values modvar-rewrite lang-info (make-splice mods)))
+      (error 'nodep-form "Doesn't support non mod forms")))
+
+; XXX interning is hack to fix test/add04.ss and provide/contract renaming
+(define (intern s) (string->symbol (symbol->string s)))
+(define (construct-provide->toplevel prefix provides)
+  (define provide-ht (make-hasheq))
+  (for ([tl (prefix-toplevels prefix)]
+          [i (in-naturals)])
+      (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)
+              (lambda ()
+                (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix)))))
+
+(define (nodep-module mod-form phase)
+  (match mod-form
+    [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context))
+     (define new-prefix prefix)
+     ; Cache all the mpi paths
+     (for-each (match-lambda
+                 [(and mv (struct module-variable (modidx sym pos phase)))
+                  (mpi->path! modidx)]
+                 [tl
+                  (void)])
+               (prefix-toplevels new-prefix))
+     (log-debug (format "[~S] module-variables: ~S" name (length (filter module-variable? (prefix-toplevels new-prefix)))))
+     (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides))
+             lang-info
+             (append (requires->modlist requires phase)
+                     (if (and phase (zero? phase))
+                         (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now
+                                (list (make-mod name srcname self-modidx new-prefix provides requires body empty
+                                                unexported max-let-depth dummy lang-info internal-context)))
+                         (begin (log-debug (format "[~S] Dropping module @ ~S" name phase))
+                                empty))))]              
+    [else (error 'nodep-module "huh?: ~e" mod-form)]))
+
+(define (+* l r)
+  (if (and l r) (+ l r) #f))
+
+(define (requires->modlist requires current-phase)
+  (apply append
+         (map
+          (match-lambda
+            [(list-rest req-phase mpis)
+             (define phase (+* current-phase req-phase))
+             (apply append
+                    (map (compose extract-modules (lambda (mpi) (get-nodep-module-code/index mpi phase))) mpis))])
+          requires)))
+
+(define (all-but-last l)
+  (reverse (rest (reverse l))))
+
+(define REQUIRED (make-hasheq))
+(define (extract-modules ct)
+  (cond
+    [(compilation-top? ct)
+     (match (compilation-top-code ct)
+       [(and m (? mod?))
+        (list m)]
+       [(struct splice (mods))
+        mods])]
+    [(symbol? ct)
+     (if (hash-has-key? REQUIRED ct)
+         empty
+         (begin
+           (hash-set! REQUIRED ct #t)
+           (list (make-req (make-stx (make-wrapped ct empty #f)) (make-toplevel 0 0 #f #f)))))]
+    [(module-path-index? ct)
+     (if (hash-has-key? REQUIRED ct)
+         empty
+         (begin
+           (hash-set! REQUIRED ct #t)
+           (list (make-req (make-stx (make-wrapped ct empty #f)) (make-toplevel 0 0 #f #f)))))]
+    [(not ct)
+     empty]
+    [(@phase? ct)
+     (extract-modules (@phase-ctop ct))]
+    [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/c contract?]
+ [current-excluded-modules (parameter/c set?)]
+ [nodep-file (-> path-string?
+                 (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))])

collects/compiler/demodularizer/replace-modidx.rkt

@@ -0,0 +1,25 @@
+#lang racket
+(require unstable/struct
+         "util.rkt")
+(provide replace-modidx)
+
+(define (replace-modidx expr self-modidx)
+  (define (inner-update e)
+      (match e
+        [(app prefab-struct-key (and key (not #f))) 
+         (apply make-prefab-struct key 
+                (map update
+                     (struct->list e)))]
+        [(? module-path-index?) 
+         (define-values (path mpi) (module-path-index-split e))
+         (if (not path)
+             self-modidx
+             (module-path-index-join path (update mpi)))]
+        [(cons a b)
+         (cons (update a) (update b))]
+        [(? vector?)
+         (vector-map update e)]
+        [else e]))
+  (define-values (first-update update)
+    (build-form-memo inner-update))
+  (first-update expr))

collects/compiler/demodularizer/update-toplevels.rkt

@@ -0,0 +1,97 @@
+#lang racket
+(require compiler/zo-structs
+         "util.rkt")
+
+(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt)
+  (define (inner-update form)
+    (match form
+      [(struct def-values (ids rhs))
+       (make-def-values (map update ids)
+                        (update rhs))]
+      [(? def-syntaxes?)
+       (error 'increment "Doesn't handle syntax")]
+      [(? def-for-syntax?)
+       (error 'increment "Doesn't handle syntax")]
+      [(struct req (reqs dummy))
+       (make-req reqs (update dummy))]
+      [(? mod?)
+       (error 'increment "Doesn't handle modules")]
+      [(struct seq (forms))
+       (make-seq (map update forms))]
+      [(struct splice (forms))
+       (make-splice (map update forms))]
+      [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)))
+       (struct-copy lam l
+                    [body (update body)])]
+      [(and c (struct closure (code gen-id)))
+       (struct-copy closure c
+                    [code (update code)])]
+      [(and cl (struct case-lam (name clauses)))
+       (define new-clauses
+         (map update clauses))
+       (struct-copy case-lam cl
+                    [clauses new-clauses])]
+      [(struct let-one (rhs body flonum? unused?))
+       (make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is it okay to just pass in the old value for flonum?
+      [(and f (struct let-void (count boxes? body)))
+       (struct-copy let-void f
+                    [body (update body)])]
+      [(and f (struct install-value (_ _ _ rhs body)))
+       (struct-copy install-value f
+                    [rhs (update rhs)]
+                    [body (update body)])]
+      [(struct let-rec (procs body))
+       (make-let-rec (map update procs) (update body))]
+      [(and f (struct boxenv (_ body)))
+       (struct-copy boxenv f [body (update body)])]
+      [(and f (struct toplevel (_ pos _ _)))
+       (struct-copy toplevel f
+                    [pos (toplevel-updater pos)])]
+      [(and f (struct topsyntax (_ pos _)))
+       (struct-copy topsyntax f
+                    [pos (topsyntax-updater pos)]
+                    [midpt topsyntax-new-midpt])]
+      [(struct application (rator rands))
+       (make-application 
+        (update rator)
+        (map update rands))]
+      [(struct branch (test then else))
+       (make-branch 
+        (update test)
+        (update then)
+        (update else))]
+      [(struct with-cont-mark (key val body))
+       (make-with-cont-mark 
+        (update key)
+        (update val)
+        (update body))]
+      [(struct beg0 (seq))
+       (make-beg0 (map update seq))]
+      [(struct varref (tl))
+       (make-varref (update tl))]
+      [(and f (struct assign (id rhs undef-ok?)))
+       (struct-copy assign f
+                    [id (update id)]
+                    [rhs (update rhs)])]
+      [(struct apply-values (proc args-expr))
+       (make-apply-values
+        (update proc)
+        (update args-expr))]
+      [(and f (struct primval (id)))
+       f]
+      [(and f (struct localref (unbox? pos clear? other-clears? flonum?)))
+       f]
+      [(and f (not (? form?)))
+       f]
+      ))
+  (define-values (first-update update)
+    (build-form-memo inner-update))
+  first-update)
+
+(provide/contract
+ [update-toplevels 
+  ((exact-nonnegative-integer? . -> . exact-nonnegative-integer?)
+   (exact-nonnegative-integer? . -> . exact-nonnegative-integer?)
+   exact-nonnegative-integer?
+   . -> .
+   (form? . -> . form?))])

collects/compiler/demodularizer/util.rkt

@@ -0,0 +1,80 @@
+#lang racket
+(require compiler/zo-parse)
+
+(define (prefix-syntax-start pre)
+  (length (prefix-toplevels pre)))
+
+(define (prefix-lift-start pre)
+  (define syntax-start (prefix-syntax-start pre))
+  (define total-stxs (length (prefix-stxs pre)))
+  (+ syntax-start total-stxs (if (zero? total-stxs) 0 1)))
+
+(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)
+    (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))
+    (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)))
+
+
+(define (build-compiled-path base name)
+  (build-path 
+   (cond [(path? base) base]
+	 [(eq? base 'relative) 'same]
+	 [(eq? base #f) (error 'batch "Impossible")])
+   "compiled"
+   name))
+
+
+(provide/contract
+ [prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)]
+ [prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)]
+ [eprintf ((string?) () #:rest (listof any/c) . ->* . void)]
+ [build-form-memo 
+  (((unconstrained-domain-> any/c))
+   (#:void? boolean?)
+   . ->* .
+   (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)))])

collects/compiler/zo-parse.rkt

@@ -1,9 +1,11 @@
 #lang scheme/base
 (require mzlib/etc
+         racket/function
          scheme/match
          scheme/list
          unstable/struct
-         compiler/zo-structs)
+         compiler/zo-structs
+         racket/dict)
 
 (provide zo-parse)
 (provide (all-from-out compiler/zo-structs))
@@ -26,8 +28,6 @@
 
   I think parse-module-path-index was only used for debugging, so it is short-circuited now
 
- collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (#<module-path-index> 0 (1363072) . #f) --- that doesn't seem to match the spec
-
 |#
 ;; ----------------------------------------
 ;; Bytecode unmarshalers for various forms
@@ -72,6 +72,11 @@
        ; XXX Why not leave them as vectors and change the contract?
        (make-prefix i (vector->list tv) (vector->list sv))])))
 
+(define read-free-id-info
+  (match-lambda
+    [(vector mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0) ; I have no idea what these mean
+     (make-free-id-info mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0)]))
+
 (define (read-unclosed-procedure v)
   (define CLOS_HAS_REST 1)
   (define CLOS_HAS_REF_ARGS 2)
@@ -112,8 +117,11 @@
                    (append
                     (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks))
                     (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method))
-                    (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)))
+                    (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result))
-                   ((if rest? sub1 values) num-params)
+                    (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null))
+                   (if (and rest? (num-params . > . 0))
+                       (sub1 num-params)
+                       num-params)
                    arg-types
                    rest?
                    (if (= closure-size (vector-length closed-over))
@@ -315,6 +323,7 @@
     [(100) 'begin0-sequence-type]
     [(103) 'module-type]
     [(105) 'resolve-prefix-type]
+    [(154) 'free-id-info-type]
     [else (error 'int->type "unknown type: ~e" i)]))
 
 (define type-readers
@@ -335,11 +344,12 @@
     (cons 'case-lambda-sequence-type read-case-lambda)
     (cons 'begin0-sequence-type read-sequence)
     (cons 'module-type read-module)
-    (cons 'resolve-prefix-type read-resolve-prefix))))
+    (cons 'resolve-prefix-type read-resolve-prefix)
+    (cons 'free-id-info-type read-free-id-info))))
 
 (define (get-reader type)
-  (or (hash-ref type-readers type #f)
+  (hash-ref type-readers type
-      (lambda (v)
+            (λ ()
               (error 'read-marshalled "reader for ~a not implemented" type))))
 
 ;; ----------------------------------------
@@ -498,7 +508,33 @@
 
 ;; ----------------------------------------
 ;; Syntax unmarshaling
+(define (make-memo) (make-weak-hash))
+(define (with-memo* mt arg thnk)
+  (hash-ref! mt arg thnk))
+(define-syntax-rule (with-memo mt arg body ...)
+  (with-memo* mt arg (λ () body ...)))
+
+(define (decode-mark-map alist)
+  alist)
+
+(define marks-memo (make-memo))
+(define (decode-marks cp ms)
+  (with-memo marks-memo ms
+    (match ms
+      [#f #f]
+      [(list* #f (? number? symref) alist)
+       (make-certificate:ref
+        (symtab-lookup cp symref)
+        (decode-mark-map alist))]
+      [(list* (? list? nested) alist)
+       (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))]
+      [alist
+       (make-certificate:plain (decode-mark-map alist))])))
+
+(define stx-memo (make-memo))
+; XXX More memo use
 (define (decode-stx cp v)
+  (with-memo stx-memo v
     (if (integer? v)
         (unmarshal-stx-get/decode cp v decode-stx) 
         (let loop ([v v])
@@ -506,9 +542,11 @@
                         (match v
                           [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)]
                           [`(,datum . ,wraps) (values #f datum wraps)]
-                        [else (error 'decode-wraps "bad datum+wrap: ~e" v)])])
+                          [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])])
             (let* ([wraps (decode-wraps cp encoded-wraps)]
-                 [add-wrap (lambda (v) (make-wrapped v wraps cert-marks))])
+                   [marks (decode-marks cp cert-marks)]
+                   [wrapped-memo (make-memo)]
+                   [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))])
               (cond
                 [(pair? v)
                  (if (eq? #t (car v))
@@ -553,21 +591,19 @@
                         make-prefab-struct 
                         k
                         (map loop (struct->list v)))))]
-              [else (add-wrap v)]))))))
+                [else (add-wrap v)])))))))
 
-(define (decode-wraps cp w)
+(define wrape-memo (make-memo))
-  ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252)
+(define (decode-wrape cp a)
-  (if (integer? w)
+  (define (aloop a) (decode-wrape cp a))
-      (unmarshal-stx-get/decode cp w decode-wraps)
+  (with-memo wrape-memo a
-      (map (lambda (a)
-             (let aloop ([a a])
     ; A wrap-elem is either
     (cond
       ; A reference 
       [(integer? a) 
        (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))]
       ; A mark (not actually a number as the C says, but a (list <num>)
-                 [(and (pair? a) (null? (cdr a)) (number? (car a)))
+      [(and (pair? a) (number? (car a)))
        (make-wrap-mark (car a))]
       
       [(vector? a) 
@@ -594,31 +630,7 @@
               (make-module-rename phase 
                                   (if kind 'marked 'normal)
                                   set-id
-                                             (let ([results (map (lambda (u)
+                                  (map (curry decode-all-from-module cp) unmarshals)
-                                                                   ; u = (list path phase . src-phase)
-                                                                   ; or u = (list path phase src-phase exn ... . prefix)
-                                                                   (let ([just-phase? (let ([v (cddr u)])
-                                                                                        (or (number? v) (not v)))])
-                                                                     (let-values ([(exns prefix)
-                                                                                   (if just-phase?
-                                                                                       (values null #f)
-                                                                                       (let loop ([u (if just-phase? null (cdddr u))]
-                                                                                                  [a null])
-                                                                                         (if (pair? u)
-                                                                                             (loop (cdr u) (cons (car u) a))
-                                                                                             (values (reverse a) u))))])
-                                                                       (make-all-from-module
-                                                                        (parse-module-path-index cp (car u))
-                                                                        (cadr u)
-                                                                        (if just-phase?
-                                                                            (cddr u)
-                                                                            (caddr u))
-                                                                        exns
-                                                                        prefix))))
-                                                                 unmarshals)])
-                                               #;(printf "~nunmarshals: ~S~n" unmarshals)
-                                               #;(printf "~nunmarshal results: ~S~n" results)
-                                               results)
                                   (decode-renames renames)
                                   mark-renames
                                   (and plus-kern? 'plus-kern)))]
@@ -636,7 +648,34 @@
                             (parse-module-path-index cp dest))]
          [else (error 'parse "bad phase shift: ~e" a)])]
       [else (error 'decode-wraps "bad wrap element: ~e" a)])))
-           w)))
+
+(define all-from-module-memo (make-memo))
+(define (decode-all-from-module cp afm)
+  (define (phase? v)
+    (or (number? v) (not v)))
+  (with-memo all-from-module-memo afm
+    (match afm
+      [(list* path (? phase? phase) (? phase? src-phase) 
+              (list exn ...) prefix)
+       (make-all-from-module
+        (parse-module-path-index cp path)
+        phase src-phase exn (vector prefix))]
+      [(list* path (? phase? phase) (list exn ...) (? phase? src-phase))
+       (make-all-from-module
+        (parse-module-path-index cp path)
+        phase src-phase exn #f)]
+      [(list* path (? phase? phase) (? phase? src-phase))
+       (make-all-from-module
+        (parse-module-path-index cp path)
+        phase src-phase #f #f)])))
+
+(define wraps-memo (make-memo))
+(define (decode-wraps cp w)
+  (with-memo wraps-memo w
+    ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252)
+    (if (integer? w)
+        (unmarshal-stx-get/decode cp w decode-wraps)
+        (map (curry decode-wrape cp) w))))
 
 (define (in-vector* v n)
   (make-do-sequence
@@ -648,22 +687,24 @@
              (λ _ #t)
              (λ _ #t)))))
 
-(define (decode-renames renames)
+(define nominal-path-memo (make-memo))
-  (define decode-nominal-path
+(define (decode-nominal-path np)
-    (match-lambda
+  (with-memo nominal-path-memo np
+    (match np
       [(cons nominal-path (cons import-phase nominal-phase))
        (make-phased-nominal-path nominal-path import-phase nominal-phase)]
       [(cons nominal-path import-phase)
        (make-imported-nominal-path nominal-path import-phase)]
       [nominal-path
-       (make-simple-nominal-path nominal-path)]))
+       (make-simple-nominal-path nominal-path)])))
 
 ; XXX Weird test copied from C code. Matthew?
 (define (nom_mod_p p)
   (and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p))))) 
 
-  (for/list ([(k v) (in-vector* renames 2)])
+(define rename-v-memo (make-memo))
-    (cons k 
+(define (decode-rename-v v)
+  (with-memo rename-v-memo v
     (match v
       [(list-rest path phase export-name nominal-path nominal-export-name)
        (make-phased-module-binding path
@@ -681,10 +722,17 @@
       [(cons module-path-index export-name)
        (make-exported-module-binding module-path-index export-name)]
       [module-path-index 
-             (make-simple-module-binding module-path-index)]))))
+       (make-simple-module-binding module-path-index)])))
+
+(define renames-memo (make-memo))
+(define (decode-renames renames)
+  (with-memo renames-memo renames
+    (for/list ([(k v) (in-vector* renames 2)])
+      (cons k (decode-rename-v v)))))
 
 (define (parse-module-path-index cp s)
   s)
+
 ;; ----------------------------------------
 ;; Main parsing loop
 
@@ -692,7 +740,8 @@
   (let loop ([need-car 0] [proper #f])
     (begin-with-definitions
       (define ch (cp-getc cp))
-      (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)])
+      (define-values (cpt-start cpt-tag) 
+        (let ([x (cpt-table-lookup ch)])
           (unless x
             (error 'read-compact "unknown code : ~a" ch))
           (values (car x) (cdr x))))
@@ -715,7 +764,22 @@
                             [read-decimal-as-inexact #t]
                             [read-accept-dot #t]
                             [read-accept-infix-dot #t]
-                            [read-accept-quasiquote #t])
+                            [read-accept-quasiquote #t]
+                            [current-readtable
+                             (make-readtable 
+                              #f
+                              #\^ 
+                              'dispatch-macro
+                              (lambda (char port src line col pos)
+                                (let ([b (read port)])
+                                  (unless (bytes? b)
+                                    (error 'read-escaped-path
+                                           "expected a byte string after #^"))
+                                  (let ([p (bytes->path b)])
+                                    (if (and (relative-path? p)
+                                             (current-load-relative-directory))
+                                        (build-path (current-load-relative-directory) p)
+                                        p)))))])
                (read/recursive (open-input-bytes s))))]
           [(reference)
            (make-primval (read-compact-number cp))]
@@ -777,6 +841,10 @@
                   [lst (for/list ([i (in-range n)])
                          (read-compact cp))])
              (vector->immutable-vector (list->vector lst)))]
+          [(pair)
+           (let* ([a (read-compact cp)]
+                  [d (read-compact cp)])
+             (cons a d))]
           [(list) 
            (let ([len (read-compact-number cp)])
              (let loop ([i len])
@@ -877,18 +945,16 @@
                                (for/list ([i (in-range c)])
                                  (read-compact cp))))]          
           [(closure)
-           (let* ([l (read-compact-number cp)]
+           (read-compact-number cp) ; symbol table pos. our marshaler will generate this
-                  [ind (make-indirect #f)])
+           (let ([v (read-compact cp)])
-             (placeholder-set! (vector-ref (cport-symtab cp) l) ind)
+             (make-closure 
-             (let* ([v (read-compact cp)]
+              v
-                    [cl (make-closure v (gensym
+              (gensym
                (let ([s (lam-name v)])
                  (cond
                    [(symbol? s) s]
                    [(vector? s) (vector-ref s 0)]
-                                             [else 'closure]))))])
+                   [else 'closure])))))]
-               (set-indirect-v! ind cl)
-               ind))]
           [(svector)
            (read-compact-svector cp (read-compact-number cp))]
           [(small-svector)
@@ -907,15 +973,20 @@
   (if decoded?
       v2
       (let ([dv2 (decode-stx cp v2)])
-        (placeholder-set! (vector-ref (cport-symtab cp) pos) dv2)
+        (symtab-write! cp pos dv2)
         (vector-set! (cport-decoded cp) pos #t)
         dv2)))
 
+(define (symtab-write! cp i v)
+  (placeholder-set! (vector-ref (cport-symtab cp) i) v))
+
+(define (symtab-lookup cp i)
+  (vector-ref (cport-symtab cp) i))
+
 (require unstable/markparam)
 (define read-sym-mark (mark-parameter))
 (define (read-sym cp i)
-  (define symtab (cport-symtab cp))
+  (define ph (symtab-lookup cp i))
-  (define ph (vector-ref symtab i))
   ; We are reading this already, so return the placeholder
   (if (memq i (mark-parameter-all read-sym-mark))
       ph
@@ -933,7 +1004,7 @@
 
 ;; path -> bytes
 ;; implementes read.c:read_compiled
-(define (zo-parse port)
+(define (zo-parse [port (current-input-port)])
   (begin-with-definitions    
     ;; skip the "#~"
     (unless (equal? #"#~" (read-bytes 2 port))
@@ -971,8 +1042,12 @@
     
     (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
     
-    (for/list ([i (in-range 1 symtabsize)])
+    (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)
     (make-reader-graph
      (read-marshalled 'compilation-top-type cp))))

collects/compiler/zo-structs.rkt

@@ -27,12 +27,15 @@
     (provide/contract
      [struct id ([field-id field-contract] ...)])))
 
+(define-struct zo () #:prefab)
+(provide zo?)
+
 (define-syntax define-form-struct
   (syntax-rules ()
     [(_ (id sup) . rest)
      (define-form-struct* id (id sup) . rest)]
     [(_ id . rest)
-     (define-form-struct* id id . rest)]))
+     (define-form-struct* id (id zo) . rest)]))
 
 ;; In toplevels of resove prefix:
 (define-form-struct global-bucket ([name symbol?])) ; top-level binding
@@ -42,10 +45,32 @@
                                      [phase (or/c 0 1)])) ; direct access to exported id
 
 ;; Syntax object
+(define ((alist/c k? v?) l)
+  (let loop ([l l])
+    (match l
+      [(list) #t]
+      [(list* (? k?) (? v?) l)
+       (loop l)]
+      [_ #f])))
+
+(define mark-map? 
+  (alist/c number? module-path-index?)
+  #;(hash/c number? module-path-index?))
+(define-form-struct certificate ())
+(define-form-struct (certificate:nest certificate)
+  ([nested mark-map?]
+   [map  mark-map?]))
+(define-form-struct (certificate:ref certificate)
+  ([val any/c]
+   [map  mark-map?]))
+(define-form-struct (certificate:plain certificate)
+  ([map  mark-map?]))
+
+
 (define-form-struct wrap ())
 (define-form-struct wrapped ([datum any/c] 
                              [wraps (listof wrap?)] 
-                             [certs (or/c list? #f)]))
+                             [certs (or/c certificate? #f)]))
 
 ;; In stxs of prefix:
 (define-form-struct stx ([encoded wrapped?]))
@@ -57,10 +82,7 @@
 (define-form-struct form ())
 (define-form-struct (expr form) ())
 
-;; A static closure can refer directly to itself, creating a cycle
+(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? any/c)])) ; compiled code always wrapped with this
-(define-struct indirect ([v #:mutable]) #:prefab)
-
-(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this
 
 ;; A provided identifier
 (define-form-struct provided ([name symbol?] 
@@ -76,17 +98,17 @@
                                      [const? boolean?] 
                                      [ready? boolean?]))  ; access binding via prefix array (which is on stack)
 
-(define-form-struct (seq form) ([forms (listof (or/c form? indirect? any/c))])) ; `begin'
+(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin'
 
 ;; Definitions (top level or within module):
 (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
-                                       [rhs (or/c expr? seq? indirect? any/c)])) 
+                                       [rhs (or/c expr? seq? any/c)])) 
 (define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?                                        
-                                         [rhs (or/c expr? seq? indirect? any/c)] 
+                                         [rhs (or/c expr? seq? any/c)] 
                                          [prefix prefix?] 
                                          [max-let-depth exact-nonnegative-integer?])) 
 (define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol?
-                                           [rhs (or/c expr? seq? indirect? any/c)] 
+                                           [rhs (or/c expr? seq? any/c)] 
                                            [prefix prefix?] 
                                            [max-let-depth exact-nonnegative-integer?])) 
 
@@ -99,7 +121,7 @@
                                                           (listof provided?)))] 
                                 [requires (listof (cons/c (or/c exact-integer? #f)
                                                           (listof module-path-index?)))]
-                                [body (listof (or/c form? indirect? any/c))] 
+                                [body (listof (or/c form? any/c))] 
                                 [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] 
                                 [unexported (list/c (listof symbol?) (listof symbol?)
                                                     (listof symbol?))] 
@@ -109,50 +131,68 @@
                                 [internal-context (or/c #f #t stx?)]))
 
 (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)]
-                                [flags (listof (or/c 'preserves-marks 'is-method 'single-result))]
+                                [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used))]
-                                [num-params integer?] ; should be exact-nonnegative-integer?
+                                [num-params exact-nonnegative-integer?]
                                 [param-types (listof (or/c 'val 'ref 'flonum))]
                                 [rest? boolean?]
                                 [closure-map (vectorof exact-nonnegative-integer?)]
                                 [closure-types (listof (or/c 'val/ref 'flonum))]
                                 [max-let-depth exact-nonnegative-integer?]
-                                [body (or/c expr? seq? indirect? any/c)])) ; `lambda'
+                                [body (or/c expr? seq? any/c)])) ; `lambda'
 (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over)
-(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? indirect?))])) ; each clause is a lam (added indirect)
+(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? closure?))]))
 
-(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack
+(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack
-(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? indirect? any/c)])) ; create new stack slots
+(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots
 (define-form-struct (install-value expr) ([count exact-nonnegative-integer?] 
                                           [pos exact-nonnegative-integer?] 
                                           [boxes? boolean?] 
-                                          [rhs (or/c expr? seq? indirect? any/c)] 
+                                          [rhs (or/c expr? seq? any/c)] 
-                                          [body (or/c expr? seq? indirect? any/c)])) ; set existing stack slot(s)
+                                          [body (or/c expr? seq? any/c)])) ; set existing stack slot(s)
-(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? indirect? any/c)])) ; put `letrec'-bound closures into existing stack slots
+(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? any/c)])) ; put `letrec'-bound closures into existing stack slots
-(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? indirect? any/c)])) ; box existing stack element
+(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; box existing stack element
 
 (define-form-struct (localref expr) ([unbox? boolean?] [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] [flonum? boolean?])) ; access local via stack
 
 
 (define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack)
 
-(define-form-struct (application expr) ([rator (or/c expr? seq? indirect? any/c)] [rands (listof (or/c expr? seq? indirect? any/c))])) ; function call
+(define-form-struct (application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])) ; function call
-(define-form-struct (branch expr) ([test (or/c expr? seq? indirect? any/c)] [then (or/c expr? seq? indirect? any/c)] [else (or/c expr? seq? indirect? any/c)])) ; `if'
+(define-form-struct (branch expr) ([test (or/c expr? seq? any/c)] [then (or/c expr? seq? any/c)] [else (or/c expr? seq? any/c)])) ; `if'
-(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? indirect? any/c)] 
+(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? any/c)] 
-                                           [val (or/c expr? seq? indirect? any/c)] 
+                                           [val (or/c expr? seq? any/c)] 
-                                           [body (or/c expr? seq? indirect? any/c)])) ; `with-continuation-mark'
+                                           [body (or/c expr? seq? any/c)])) ; `with-continuation-mark'
-(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? indirect? any/c))])) ; `begin0'
+(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0'
-(define-form-struct (splice form) ([forms (listof (or/c form? indirect? any/c))])) ; top-level `begin'
+(define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin'
 (define-form-struct (varref expr) ([toplevel toplevel?])) ; `#%variable-reference'
-(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? indirect? any/c)] [undef-ok? boolean?])) ; top-level or module-level set!
+(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set!
-(define-form-struct (apply-values expr) ([proc (or/c expr? seq? indirect? any/c)] [args-expr (or/c expr? seq? indirect? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc)
+(define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc)
 (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive
 
 ;; Top-level `require'
 (define-form-struct (req form) ([reqs stx?] [dummy toplevel?]))
 
-(define-form-struct (lexical-rename wrap) ([bool1 boolean?] ; this needs a name
+
+(define-form-struct free-id-info ([path0 module-path-index?]
+                                  [symbol0 symbol?]
+                                  [path1 module-path-index?]
+                                  [symbol1 symbol?]
+                                  [phase0 (or/c exact-integer? #f)]
+                                  [phase1 (or/c exact-integer? #f)]
+                                  [phase2 (or/c exact-integer? #f)]
+                                  [use-current-inspector? boolean?]))
+
+(define-form-struct (lexical-rename wrap) ([has-free-id-renames? boolean?]
                                            [bool2 boolean?] ; this needs a name
-                                           [alist any/c])) ; should be (listof (cons/c symbol? symbol?))
+                                           [alist (listof 
+                                                   (cons/c symbol?
+                                                           (or/c
+                                                            symbol?
+                                                            (cons/c
+                                                             symbol?
+                                                             (or/c
+                                                              (cons/c symbol? (or/c symbol? #f))
+                                                              free-id-info?)))))])) 
 (define-form-struct (phase-shift wrap) ([amt exact-integer?] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)]))
 (define-form-struct (wrap-mark wrap) ([val exact-integer?]))
 (define-form-struct (prune wrap) ([sym any/c]))
@@ -160,8 +200,8 @@
 (define-form-struct all-from-module ([path module-path-index?] 
                                      [phase (or/c exact-integer? #f)] 
                                      [src-phase any/c] ; should be (or/c exact-integer? #f)
-                                     [exceptions list?] ; should be (listof symbol?)
+                                     [exceptions (or/c (listof (or/c symbol? number?)) #f)] ; should be (listof symbol?)
-                                     [prefix any/c])) ; should be (or/c symbol? #f)
+                                     [prefix (or/c (vector/c (or/c symbol? #f)) #f)])) ; should be (or/c symbol? #f)
 
 (define-form-struct nominal-path ())
 (define-form-struct (simple-nominal-path nominal-path) ([value module-path-index?]))
@@ -201,7 +241,7 @@
 ; XXX better name for 'value'
 (define-form-struct (mark-barrier wrap) ([value symbol?]))
 
-(provide/contract (struct indirect ([v (or/c closure? #f)])))
+
 
 
 

collects/meta/drdr2/analyzer/analyzer.rkt

@@ -0,0 +1 @@
+#lang racket

collects/meta/drdr2/master/master.rkt

@@ -0,0 +1 @@
+#lang racket

collects/tests/compiler/demodularizer/demod-test.rkt

@@ -0,0 +1,49 @@
+#lang racket
+(require tests/eli-tester
+         racket/runtime-path)
+
+(define (capture-output command . args)
+  (define o (open-output-string))
+  (define e (open-output-string))
+  (parameterize ([current-input-port (open-input-string "")]
+                 [current-output-port o]
+                 [current-error-port e])
+    (apply system* command args))
+  (values (get-output-string o) (get-output-string e)))
+
+(define (test-on-program filename)
+  ; run modular program, capture output
+  (define-values (modular-output modular-error)
+    (capture-output (find-executable-path "racket") filename))
+  
+  ; demodularize
+  (parameterize ([current-input-port (open-input-string "")])
+    (system* (find-executable-path "raco") "demod" filename))
+  
+  (define demod-filename 
+    (path->string
+     (path-add-suffix filename #"_merged.zo")))
+  
+  ; run whole program
+  (define-values (whole-output whole-error)
+    (capture-output (find-executable-path "racket") demod-filename))
+  
+  ; compare output 
+  (test
+   #:failure-prefix (format "~a stdout" filename)
+   whole-output => modular-output
+   #:failure-prefix (format "~a stderr" filename)
+   whole-error => modular-error))
+
+(define-runtime-path tests "tests")
+
+(define (modular-program? filename)
+  (and (not (regexp-match #rx"merged" filename))
+       (regexp-match #rx"rkt$" filename)))
+
+(test
+ (for ([i (in-list (directory-list tests))])
+   (define ip (build-path tests i))
+   (when (modular-program? ip)
+     (printf "Checking ~a\n" ip)
+     (test-on-program (path->string ip)))))

collects/tests/compiler/demodularizer/tests/kernel-5.rkt

@@ -0,0 +1,5 @@
+(module kernel-5 '#%kernel
+  (#%require racket/private/map)
+  (define-values (id) (λ (x) x))
+  (define-values (xs) (list 1 2 3 4 5))
+  (map id (map id xs)))

collects/tests/compiler/demodularizer/tests/racket-5.rkt

@@ -0,0 +1,2 @@
+#lang racket
+5

collects/tests/compiler/zo-exs.rkt

@@ -3,20 +3,105 @@
          compiler/zo-marshal
          tests/eli-tester)
 
+(define (read-compiled-bytes bs)
+  (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))
+  (test #:failure-prefix (format "~S" ct)
         (test bs
-        (zo-parse (open-input-bytes bs)) => ct))
+              (zo-parse (open-input-bytes bs)) => ct
+              (read-compiled-bytes bs)
+              #;(with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace)
+              #;(run-compiled-bytes bs #t)
+              #;(run-compiled-bytes bs #f))))
+
+(define mpi (module-path-index-join #f #f))
+
 
 (test
- (local [(define (hash-test make-hash-placeholder)
  (roundtrip
     (compilation-top 0 
                      (prefix 0 empty empty)
-                             (local [(define ht-ph (make-placeholder #f))
+                     (list 1 (list 2 3) (list 2 3) 4 5)))
-                                     (define ht (make-hash-placeholder (list (cons 'g ht-ph))))]
+ 
-                               (placeholder-set! ht-ph ht)
+ #;(roundtrip
-                               (make-reader-graph ht)))))]
+  (compilation-top 0 
-   (hash-test make-hash-placeholder)
+                   (prefix 0 empty empty)
-   (hash-test make-hasheq-placeholder)
+                   (let* ([ph (make-placeholder #f)]
-   (hash-test make-hasheqv-placeholder)))
+                          [x (closure 
+                               (lam 'name
+                                    empty
+                                    0 
+                                    empty
+                                    #f
+                                    #()
+                                    empty
+                                    0
+                                    ph)
+                               'name)])
+                     (placeholder-set! ph x)
+                     (make-reader-graph x))))
+ 
+ ; This should work, but module-path-index-join doesn't create equal? module-path-index's
+ #;(roundtrip
+    (compilation-top
+     0
+     (prefix 0 (list #f) (list))
+     (mod
+      'simple
+      'simple
+      (module-path-index-join #f #f)
+      (prefix
+       0
+       (list (module-variable 
+              (module-path-index-join
+               "modbeg.rkt"
+               (module-path-index-join
+                "pre-base.rkt"
+                (module-path-index-join
+                 "namespace.rkt"
+                 (module-path-index-join "private/base.rkt" (module-path-index-join 'racket/base #f))))) 'print-values 0 0))
+       (list))
+      (list)
+      (list (list 0 (module-path-index-join 'racket/base #f)) (list 1) (list -1) (list #f))
+      (list (apply-values
+             (toplevel 0 0 #f #t)
+             (application
+              (primval 231)
+              (list 1 'a))))
+      (list)
+      (list (list) (list) (list))
+      2
+      (toplevel 0 0 #f #f)
+      #(racket/language-info get-info #f)
+      #t)))
+
+ (roundtrip 
+    (compilation-top 0 
+                     (prefix 0 empty empty)
+                     (current-directory)))
+ 
+ (roundtrip 
+    (compilation-top 0 
+                     (prefix 0 empty empty)
+                     (list (current-directory))))
+ 
+ (roundtrip
+    (compilation-top                                            
+     0                                                          
+     (prefix 0 empty empty)
+     (cons #hash()
+           #hash())))
+ 
+ (roundtrip
+    (compilation-top                                            
+     0                                                          
+     (prefix 0 empty empty)
+     #hash())))

collects/tests/compiler/zo-test-util.rkt

@@ -0,0 +1,12 @@
+#lang racket
+
+(struct result (phase) #:prefab)
+(struct failure result (serious? msg) #:prefab)
+(struct success result () #:prefab)
+
+(provide/contract
+ [struct result ([phase symbol?])]
+ [struct failure ([phase symbol?]
+                  [serious? boolean?]
+                  [msg string?])]
+ [struct success ([phase symbol?])])

collects/tests/compiler/zo-test-worker.rkt

@@ -0,0 +1,270 @@
+#lang racket/base
+(require racket/cmdline
+         compiler/zo-parse
+         compiler/zo-marshal
+         compiler/decompile
+         racket/port
+         racket/bool
+         racket/list
+         racket/match
+         "zo-test-util.rkt")
+
+(define (bytes-gulp f)
+  (with-input-from-file f 
+    (λ () (port->bytes (current-input-port)))))
+
+(define (read-compiled-bytes bs)
+  (define ib (open-input-bytes bs))
+  (dynamic-wind void
+                (lambda ()
+                  (parameterize ([read-accept-compiled #t])
+                    (read ib)))
+                (lambda ()
+                  (close-input-port ib))))
+
+(define (zo-parse/bytes bs)
+  (define ib (open-input-bytes bs))
+  (dynamic-wind void
+                (lambda ()
+                  (zo-parse ib))
+                (lambda ()
+                  (close-input-port ib))))
+
+(define (bytes-not-equal?-error b1 b2)
+  (unless (bytes=? b1 b2)
+    (error 'bytes-not-equal?-error "Not equal")))
+
+(define (replace-file file bytes)
+  (with-output-to-file file
+    (λ () (write-bytes bytes))
+    #:exists 'truncate))
+
+(define (equal?/why-not v1 v2)
+  (define v1->v2 (make-hasheq))
+  (define (interned-symbol=? s1 s2)
+    (symbol=? (hash-ref! v1->v2 s1 s2) s2))
+  (define (yield p m v1 v2)
+    (error 'equal?/why-not "~a in ~a: ~S ~S"
+           m (reverse p) v1 v2))
+  (define (inner p v1 v2)
+    (unless (eq? v1 v2)
+      (match v1
+        [(cons car1 cdr1)
+         (match v2
+           [(cons car2 cdr2)
+            (inner (list* 'car p) car1 car2)
+            (inner (list* 'cdr p) cdr1 cdr2)]
+           [_
+            (yield p "Not a cons on right" v1 v2)])]
+        [(? vector?)
+         (match v2
+           [(? vector?)
+            (define v1l (vector-length v1))
+            (define v2l (vector-length v2))
+            (if (= v1l v2l)
+                (for ([i (in-range v1l)])
+                  (inner (list* `(vector-ref ,i) p)
+                         (vector-ref v1 i)
+                         (vector-ref v2 i)))
+                (yield p "Vector lengths not equal" v1 v2))]
+           [_
+            (yield p "Not a vector on right" v1 v2)])]
+        [(? struct?)
+         (match v2
+           [(? struct?)
+            (define vv1 (struct->vector v1))
+            (define vv2 (struct->vector v2))
+            (inner (list* `(struct->vector ,(vector-ref vv1 0)) p)
+                   vv1 vv2)]
+           [_
+            (yield p "Not a struct on right" v1 v2)])]
+        [(? hash?)
+         (match v2
+           [(? hash?)
+            (let ([p (list* 'in-hash p)])
+              (for ([(k1 hv1) (in-hash v1)])
+                (define hv2 
+                  (hash-ref v2 k1
+                            (lambda ()
+                              (yield p (format "~S not in hash on right" k1) v1 v2))))
+                (inner (list* `(hash-ref ,k1) p)
+                       hv1 hv2)))]
+           [_
+            (yield p "Not a hash on right" v1 v2)])]
+        [(? module-path-index?)
+         (match v2
+           [(? module-path-index?)
+            (define-values (mp1 bmpi1) (module-path-index-split v1))
+            (define-values (mp2 bmpi2) (module-path-index-split v2))
+            (inner (list* 'module-path-index-split_0 p) mp1 mp2)
+            (inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)]
+           [_
+            (yield p "Not a module path index on right" v1 v2)])]
+        [(? string?)
+         (match v2
+           [(? string?)
+            (unless (string=? v1 v2)
+              (yield p "Unequal strings" v1 v2))]
+           [_
+            (yield p "Not a string on right" v1 v2)])]
+        [(? bytes?)
+         (match v2
+           [(? bytes?)
+            (unless (bytes=? v1 v2)
+              (yield p "Unequal bytes" v1 v2))]
+           [_
+            (yield p "Not a bytes on right" v1 v2)])]
+        [(? path?)
+         (match v2
+           [(? path?)
+            (unless (equal? v1 v2)
+              (yield p "Unequal paths" v1 v2))]
+           [_
+            (yield p "Not a path on right" v1 v2)])]
+        [(? number?)
+         (match v2
+           [(? number?)
+            (unless (equal? v1 v2)
+              (yield p "Unequal numbers" v1 v2))]
+           [_
+            (yield p "Not a number on right" v1 v2)])]
+        [(? regexp?)
+         (match v2
+           [(? regexp?)
+            (unless (string=? (object-name v1) (object-name v2))
+              (yield p "Unequal regexp" v1 v2))]
+           [_
+            (yield p "Not a regexp on right" v1 v2)])]
+        [(? byte-regexp?)
+         (match v2
+           [(? byte-regexp?)
+            (unless (bytes=? (object-name v1) (object-name v2))
+              (yield p "Unequal byte-regexp" v1 v2))]
+           [_
+            (yield p "Not a byte-regexp on right" v1 v2)])]
+        [(? box?)
+         (match v2
+           [(? box?)
+            (inner (list* 'unbox) (unbox v1) (unbox v2))]
+           [_
+            (yield p "Not a box on right" v1 v2)])]
+        [(? symbol?)
+         (match v2
+           [(? symbol?)
+            (unless (symbol=? v1 v2)
+              (cond
+                [(and (symbol-interned? v1) (not (symbol-interned? v1)))
+                 (yield p "Not interned symbol on right" v1 v2)]
+                [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1)))
+                 (yield p "Not unreadable symbol on right" v1 v2)]
+                [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1)))
+                 (yield p "Not uninterned symbol on right" v1 v2)]
+                [(and (symbol-uninterned? v1) (symbol-uninterned? v2))
+                 (unless (interned-symbol=? v1 v2)
+                   (yield p "Uninterned symbols don't align" v1 v2))]
+                [else
+                 (yield p "Other symbol-related problem" v1 v2)]))]
+           [_
+            (yield p "Not a symbol on right" v1 v2)])]
+        [(? empty?)
+         (yield p "Not empty on right" v1 v2)]
+        [_
+         (yield p "Cannot inspect values deeper" v1 v2)])))
+  (inner empty v1 v2))  
+
+(define (symbol-uninterned? s)
+  (not (or (symbol-interned? s) (symbol-unreadable? s))))
+
+(define (run-with-limit file k thnk)
+  (define file-custodian (make-custodian))
+  (define ch (make-channel))
+  (custodian-limit-memory file-custodian k)
+  (define worker-thread
+    (parameterize ([current-custodian file-custodian])
+      (thread
+       (lambda ()
+         (define r (thnk))
+         (channel-put ch r)
+         (channel-get ch)))))
+  (begin0
+    (sync
+     (handle-evt ch
+                 (lambda (v)
+                   (when (exn? v) (raise v))
+                   v))
+     (handle-evt worker-thread
+                 (lambda _
+                   (record! (failure 'memory #f "Over memory limit")))))
+    (custodian-shutdown-all file-custodian)))
+
+(define-syntax run/stages*
+  (syntax-rules ()
+    [(_ file) 
+     (record! (success 'everything))]
+    [(_ file [step1 serious? e] . rst)
+     (let/ec esc
+       (let ([step1 (with-handlers ([exn:fail? 
+                                     (lambda (x)
+                                       (record! (failure 'step1 serious? 
+                                                         (exn-message x)))
+                                       (if serious?
+                                           (esc #f)
+                                           #f))])
+                      (begin0 e
+                              (record! (success 'step1))))])
+         (run/stages* file . rst)))]))
+
+(define-syntax-rule (define-stages (run! file)
+                      [stage serious? e] ...)
+  (define (run! file)
+    (run/stages* file [stage serious? e] ...)))
+
+(define-stages (run! file)
+  [read-orig 
+   #t
+   (bytes-gulp file)]
+  [parse-orig 
+   #t
+   (zo-parse/bytes read-orig)]
+  [marshal-parsed 
+   #t
+   (zo-marshal parse-orig)]
+  [parse-marshalled 
+   #t
+   (zo-parse/bytes marshal-parsed)]
+  #;[compare-parsed-to-parsed-marshalled 
+   #f
+   (equal?/why-not parse-orig parse-marshalled)]
+  #;[marshal-marshalled 
+   #t
+   (zo-marshal parse-marshalled)]
+  #;[compare-marshalled-to-marshalled-marshalled 
+   #f
+   (bytes-not-equal?-error marshal-parsed marshal-marshalled)]
+  #;[replace-with-marshalled 
+     #t
+     (replace-file file marshal-marshalled)]
+  #;[decompile-parsed 
+   #t
+   (decompile parse-orig)]
+  [c-parse-marshalled
+   #t
+   (read-compiled-bytes marshal-parsed)]
+  #;[compare-orig-to-marshalled 
+   #f
+   (bytes-not-equal?-error read-orig marshal-parsed)])
+
+(define RESULTS empty)
+(define (record! v)
+  (set! RESULTS (list* v RESULTS)))
+(define (run-test file)
+  (run-with-limit 
+   file
+   (* 1024 1024 512)
+   (lambda ()
+     (run! file)))
+  (write (reverse RESULTS)))
+
+(command-line #:program "zo-test-worker" 
+              #:args (file)
+              (run-test file))

collects/tests/compiler/zo-test.rkt

@@ -3,204 +3,15 @@
 exec racket -t "$0" -- -s -t 60 -v -R $*
 |#
 
-#lang scheme
+#lang racket
-(require compiler/zo-parse
+(require setup/dirs
-         compiler/zo-marshal
+         racket/runtime-path
-         compiler/decompile
+         racket/future
-         setup/dirs)
+         "zo-test-util.rkt")
-
-;; Helpers
-(define (bytes->hex-string bs)
-  (apply string-append
-         (for/list ([b bs])
-           (format "~a~x"
-                   (if (b . <= . 15) "0" "")
-                   b))))
-
-(define (show-bytes-side-by-side orig new)
-  (define max-length
-    (max (bytes-length orig) (bytes-length new)))
-  (define BYTES-PER-LINE 38)
-  (define lines
-    (ceiling (/ max-length BYTES-PER-LINE)))
-  (define (subbytes* b s e)
-    (subbytes b (min s (bytes-length b)) (min e (bytes-length b))))
-  (for ([line (in-range lines)])
-    (define start (* line BYTES-PER-LINE))
-    (define end (* (add1 line) BYTES-PER-LINE))
-    (printf "+ ~a\n" (bytes->hex-string (subbytes* orig start end)))
-    (printf "- ~a\n" (bytes->hex-string (subbytes* new start end)))))
-
-(define (bytes-gulp f)
-  (with-input-from-file f 
-    (λ () (port->bytes (current-input-port)))))
-
-(define (read-compiled-bytes bs)
-  (define ib (open-input-bytes bs))
-  (dynamic-wind void
-                (lambda ()
-                  (parameterize ([read-accept-compiled #t])
-                    (read ib)))
-                (lambda ()
-                  (close-input-port ib))))
-
-(define (zo-parse/bytes bs)
-  (define ib (open-input-bytes bs))
-  (dynamic-wind void
-                (lambda ()
-                  (zo-parse ib))
-                (lambda ()
-                  (close-input-port ib))))
-
-(define (bytes-not-equal?-error b1 b2)
-  (unless (bytes=? b1 b2)
-    (error 'bytes-not-equal?-error "Not equal")))
-
-(define (replace-file file bytes)
-  (with-output-to-file file
-    (λ () (write-bytes bytes))
-    #:exists 'truncate))
 
 (define ((make-recorder! ht) file phase)
   (hash-update! ht phase (curry list* file) empty))
 
-(define (equal?/why-not v1 v2)
-  (define v1->v2 (make-hasheq))
-  (define (interned-symbol=? s1 s2)
-    (symbol=? (hash-ref! v1->v2 s1 s2) s2))
-  (define (yield p m v1 v2)
-    (error 'equal?/why-not "~a in ~a: ~S ~S"
-           m (reverse p) v1 v2))
-  (define (inner p v1 v2)
-    (unless (eq? v1 v2)
-      (match v1
-        [(cons car1 cdr1)
-         (match v2
-           [(cons car2 cdr2)
-            (inner (list* 'car p) car1 car2)
-            (inner (list* 'cdr p) cdr1 cdr2)]
-           [_
-            (yield p "Not a cons on right" v1 v2)])]
-        [(? vector?)
-         (match v2
-           [(? vector?)
-            (define v1l (vector-length v1))
-            (define v2l (vector-length v2))
-            (if (= v1l v2l)
-                (for ([i (in-range v1l)])
-                  (inner (list* `(vector-ref ,i) p)
-                         (vector-ref v1 i)
-                         (vector-ref v2 i)))
-                (yield p "Vector lengths not equal" v1 v2))]
-           [_
-            (yield p "Not a vector on right" v1 v2)])]
-        [(? struct?)
-         (match v2
-           [(? struct?)
-            (define vv1 (struct->vector v1))
-            (define vv2 (struct->vector v2))
-            (inner (list* `(struct->vector ,(vector-ref vv1 0)) p)
-                   vv1 vv2)]
-           [_
-            (yield p "Not a struct on right" v1 v2)])]
-        [(? hash?)
-         (match v2
-           [(? hash?)
-            (let ([p (list* 'in-hash p)])
-              (for ([(k1 hv1) (in-hash v1)])
-                (define hv2 
-                  (hash-ref v2 k1
-                            (lambda ()
-                              (yield p (format "~S not in hash on right" k1) v1 v2))))
-                (inner (list* `(hash-ref ,k1) p)
-                       hv1 hv2)))]
-           [_
-            (yield p "Not a hash on right" v1 v2)])]
-        [(? module-path-index?)
-         (match v2
-           [(? module-path-index?)
-            (define-values (mp1 bmpi1) (module-path-index-split v1))
-            (define-values (mp2 bmpi2) (module-path-index-split v2))
-            (inner (list* 'module-path-index-split_0 p) mp1 mp2)
-            (inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)]
-           [_
-            (yield p "Not a module path index on right" v1 v2)])]
-        [(? string?)
-         (match v2
-           [(? string?)
-            (unless (string=? v1 v2)
-              (yield p "Unequal strings" v1 v2))]
-           [_
-            (yield p "Not a string on right" v1 v2)])]
-        [(? bytes?)
-         (match v2
-           [(? bytes?)
-            (unless (bytes=? v1 v2)
-              (yield p "Unequal bytes" v1 v2))]
-           [_
-            (yield p "Not a bytes on right" v1 v2)])]
-        [(? path?)
-         (match v2
-           [(? path?)
-            (unless (equal? v1 v2)
-              (yield p "Unequal paths" v1 v2))]
-           [_
-            (yield p "Not a path on right" v1 v2)])]
-        [(? number?)
-         (match v2
-           [(? number?)
-            (unless (equal? v1 v2)
-              (yield p "Unequal numbers" v1 v2))]
-           [_
-            (yield p "Not a number on right" v1 v2)])]
-        [(? regexp?)
-         (match v2
-           [(? regexp?)
-            (unless (string=? (object-name v1) (object-name v2))
-              (yield p "Unequal regexp" v1 v2))]
-           [_
-            (yield p "Not a regexp on right" v1 v2)])]
-        [(? byte-regexp?)
-         (match v2
-           [(? byte-regexp?)
-            (unless (bytes=? (object-name v1) (object-name v2))
-              (yield p "Unequal byte-regexp" v1 v2))]
-           [_
-            (yield p "Not a byte-regexp on right" v1 v2)])]
-        [(? box?)
-         (match v2
-           [(? box?)
-            (inner (list* 'unbox) (unbox v1) (unbox v2))]
-           [_
-            (yield p "Not a box on right" v1 v2)])]
-        [(? symbol?)
-         (match v2
-           [(? symbol?)
-            (unless (symbol=? v1 v2)
-              (cond
-                [(and (symbol-interned? v1) (not (symbol-interned? v1)))
-                 (yield p "Not interned symbol on right" v1 v2)]
-                [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1)))
-                 (yield p "Not unreadable symbol on right" v1 v2)]
-                [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1)))
-                 (yield p "Not uninterned symbol on right" v1 v2)]
-                [(and (symbol-uninterned? v1) (symbol-uninterned? v2))
-                 (unless (interned-symbol=? v1 v2)
-                   (yield p "Uninterned symbols don't align" v1 v2))]
-                [else
-                 (yield p "Other symbol-related problem" v1 v2)]))]
-           [_
-            (yield p "Not a symbol on right" v1 v2)])]
-        [(? empty?)
-         (yield p "Not empty on right" v1 v2)]
-        [_
-         (yield p "Cannot inspect values deeper" v1 v2)])))
-  (inner empty v1 v2))  
-
-(define (symbol-uninterned? s)
-  (not (or (symbol-interned? s) (symbol-unreadable? s))))
-
-;; Parameters
 (define stop-on-first-error (make-parameter #f))
 (define verbose-mode (make-parameter #f))
 (define care-about-nonserious? (make-parameter #t))
@@ -208,137 +19,23 @@ exec racket -t "$0" -- -s -t 60 -v -R $*
 (define time-limit (make-parameter +inf.0))
 (define randomize (make-parameter #f))
 
-;; Work
 (define errors (make-hash))
+(define (record-common-error! exn-msg)
+  (hash-update! errors (common-message exn-msg) add1 0))
 
-(define (common-message exn)
+(define (common-message exn-msg)
-  (define given-messages (regexp-match #rx".*given" (exn-message exn)))
+  (define given-messages (regexp-match #rx".*given" exn-msg))
   (if (and given-messages (not (empty? given-messages)))
       (first given-messages)
-      (exn-message exn)))
+      exn-msg))
-
-(define (exn-printer file phase serious? exn)
-  (hash-update! errors (common-message exn) add1 0)
-  (unless (and (not (care-about-nonserious?)) (not serious?))
-    (when (or (verbose-mode) (stop-on-first-error))
-      (fprintf (current-error-port) "~a -- ~a: ~a~n" file phase (exn-message exn)))
-    (when (stop-on-first-error)
-      exn)))
-
-(define (run-with-time-limit t thnk)
-  (define th (thread thnk))
-  (sync th
-        (handle-evt (alarm-evt (+ (current-inexact-milliseconds)
-                                  (* 1000 t)))
-                    (lambda _
-                      (kill-thread th)))))
-
-(define (run-with-limit file k thnk)
-  (define file-custodian (make-custodian))
-  (define ch (make-channel))
-  (custodian-limit-memory file-custodian k)
-  (local [(define worker-thread
-            (parameterize ([current-custodian file-custodian])
-              (thread
-               (lambda ()
-                 (define r (thnk))
-                 (channel-put ch r)
-                 (channel-get ch)))))]
-    (begin0
-      (sync
-       (handle-evt ch
-                   (lambda (v)
-                     (when (exn? v) (raise v))
-                     v))
-       (handle-evt worker-thread
-                   (lambda _
-                     (failure! file 'memory))))
-      (custodian-shutdown-all file-custodian))))
 
 (define success-ht (make-hasheq))
 (define success! (make-recorder! success-ht))
 (define failure-ht (make-hasheq))
 (define failure! (make-recorder! failure-ht))
 
-(define-syntax run/stages*
-  (syntax-rules ()
-    [(_ file) (success! file 'everything)]
-    [(_ file [step1 serious? e] . rst)
-     (let/ec esc
-       (let ([step1 (with-handlers ([exn:fail? 
-                                     (lambda (x)
-                                       (failure! file 'step1)
-                                       (esc (exn-printer file 'step1 serious? x)))])
-                      e)])
-         (success! file 'step1)
-         (run/stages* file . rst)))]))
-
-(define-syntax-rule (define-stages (stages run!)
-                      file
-                      [stage serious? e] ...)
-  (define-values (stages run!)
-    (values '(stage ...)
-            (lambda (file)
-              (run/stages* file [stage serious? e] ...)))))
-
 (define debugging? (make-parameter #f))
 
-(define (print-bytes orig new)
-  (when (debugging?)
-    (show-bytes-side-by-side orig new))
-  #t)
-
-(define-stages (stages run!)
-  file
-  [read-orig 
-   #t
-   (bytes-gulp file)]
-  [parse-orig 
-   #t
-   (zo-parse/bytes read-orig)]
-  [marshal-parsed 
-   #t
-   (zo-marshal parse-orig)]
-  #;[ignored 
-     #f
-     (printf "orig: ~a, marshalled: ~a~n"
-             (bytes-length read-orig)
-             (bytes-length marshal-parsed))]
-  [parse-marshalled 
-   #t
-   (zo-parse/bytes marshal-parsed)]
-  [compare-parsed-to-parsed-marshalled 
-   #f
-   (equal?/why-not parse-orig parse-marshalled)]
-  [marshal-marshalled 
-   #t
-   (zo-marshal parse-marshalled)]
-  [compare-marshalled-to-marshalled-marshalled 
-   #f
-   (bytes-not-equal?-error marshal-parsed marshal-marshalled)]
-  #;[replace-with-marshalled 
-     #t
-     (replace-file file marshal-marshalled)]
-  [decompile-parsed 
-   #t
-   (decompile parse-orig)]
-  [show-orig-and-marshal-parsed
-   #f
-   (print-bytes read-orig marshal-parsed)]
-  [c-parse-marshalled
-   #f
-   (read-compiled-bytes marshal-parsed)]
-  [compare-orig-to-marshalled 
-   #f
-   (bytes-not-equal?-error read-orig marshal-parsed)])
-
-(define (run-test file)
-  (run-with-limit 
-   file
-   (* 1024 1024 128)
-   (lambda ()
-     (run! file))))
-
 (define (randomize-list l)
   (define ll (length l))
   (define seen? (make-hasheq))
@@ -364,34 +61,10 @@ exec racket -t "$0" -- -s -t 60 -v -R $*
     [(regexp-match #rx"\\.zo$" p-str)
      (! p-str)]))
 
-(define (zo-test paths)
+(define-runtime-path zo-test-worker-path "zo-test-worker.rkt")
-  (run-with-time-limit 
+(define racket-path (path->string (find-executable-path "racket")))
-   (time-limit)
-   (lambda ()
-     (for-each (curry for-zos run-test) paths)))
 
-  (unless (invariant-output)
+(define p
-    (for ([kind-name (list* 'memory stages)])
-      (define fails (length (hash-ref failure-ht kind-name empty)))
-      (define succs (length (hash-ref success-ht kind-name empty)))
-      (define all (+ fails succs))
-      (unless (zero? all)
-        (printf "~S~n"
-                `(,kind-name
-                  (#f ,fails)
-                  (#t ,succs)
-                  ,all))))
-    (printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty)))
-    
-    (printf "Common Errors:~n")
-    
-    (for ([p (in-list (sort (filter (λ (p) ((car p) . > . 10))
-                                    (hash-map errors (λ (k v) (cons v k))))
-                            > #:key car))])
-      (printf "~a:~n~a~n~n" (car p) (cdr p)))))
-
-; Run
-#;(current-command-line-arguments #("-s" "/home/bjohn3x/development/plt/collects/browser/compiled/browser_scrbl.zo"))
   (command-line #:program "zo-test" 
                 #:once-each
                 [("-D") 
@@ -417,6 +90,134 @@ exec racket -t "$0" -- -s -t 60 -v -R $*
                  "Limit the run to a given amount of time"
                  (time-limit (string->number number))]
                 #:args p
-              (zo-test (if (empty? p)
+                (if (empty? p)
                     (list (find-collects-dir))
                     p)))
+
+(define to-worker-ch (make-channel))
+(define stop-ch (make-channel))
+(define from-worker-ch (make-channel))
+
+(define worker-threads
+  (for/list ([i (in-range (processor-count))])
+    (thread
+     (λ ()
+       (let loop ()
+         (sync
+          (handle-evt to-worker-ch
+                      (λ (p)
+                        (when (debugging?)
+                          (printf "~a\n" p))
+                        (define-values
+                          (sp stdout stdin stderr)
+                          (subprocess #f #f #f racket-path (path->string zo-test-worker-path) p))
+                        (define r
+                          (dynamic-wind
+                           void
+                           (λ ()
+                             (read stdout))
+                           (λ ()
+                             (close-input-port stdout)
+                             (close-input-port stderr)
+                             (close-output-port stdin)
+                             (subprocess-kill sp #t))))
+                        (channel-put from-worker-ch (cons p r))
+                        (loop)))
+          (handle-evt stop-ch
+                      (λ (die)
+                        (void)))))))))          
+
+(define (process-result p r)
+  (match r
+    [(success phase)
+     (success! p phase)]
+    [(failure phase serious? exn-msg)
+     (record-common-error! exn-msg)
+     (failure! p phase)
+     
+     (unless (and (not (care-about-nonserious?)) (not serious?))
+       (when (or (verbose-mode) (stop-on-first-error))
+         (fprintf (current-error-port) "~a -- ~a: ~a\n" p phase exn-msg))
+       (when (stop-on-first-error)
+         (stop!)))]))     
+
+(define timing-thread
+  (thread
+   (λ ()
+     (sync 
+      (alarm-evt (+ (current-inexact-milliseconds)
+                    (* 1000 (time-limit)))))
+     (stop!))))
+
+(define server-thread
+  (thread
+   (λ ()
+     (let loop ([ts worker-threads])
+       (if (empty? ts)
+           (stop!)
+           (apply
+            sync
+            (handle-evt from-worker-ch
+                        (match-lambda
+                          [(cons p rs)
+                           (for-each (curry process-result p) rs)
+                           (loop ts)]))
+            (for/list ([t (in-list ts)])
+              (handle-evt t (λ _ (loop (remq t ts)))))))))))
+
+(define (spawn-worker p)
+  (channel-put to-worker-ch p))
+
+(define (zo-test paths)
+  (for-each (curry for-zos spawn-worker) paths)
+  
+  (for ([i (in-range (processor-count))])
+    (channel-put stop-ch #t)))
+
+(define root-thread
+  (thread
+   (λ ()
+     (zo-test p))))
+
+(define final-sema (make-semaphore 0))
+(define (stop!)
+  (semaphore-post final-sema))
+
+(define (hash-keys ht)
+  (hash-map ht (λ (k v) k)))
+
+(define final-thread
+  (thread
+   (λ ()
+     (semaphore-wait final-sema)
+     (for-each kill-thread
+               (list* root-thread server-thread worker-threads))
+     (unless (invariant-output)
+       (newline)
+       (for ([kind-name 
+              (remove-duplicates 
+               (append
+                (hash-keys failure-ht)
+                (hash-keys success-ht)))])
+         (define fails (length (hash-ref failure-ht kind-name empty)))
+         (define succs (length (hash-ref success-ht kind-name empty)))
+         (define all (+ fails succs))
+         (unless (zero? all)
+           (printf "~S\n"
+                   `(,kind-name
+                     (#f ,fails)
+                     (#t ,succs)
+                     ,all))))
+       (newline)
+       (printf "~a tests passed\n" (length (hash-ref success-ht 'everything empty)))
+       
+       (let ([common-errors 
+              (sort (filter (λ (p) ((car p) . > . 10))
+                            (hash-map errors (λ (k v) (cons v k))))
+                    > #:key car)])
+         (unless (empty? common-errors)
+           (printf "Common Errors:\n")
+           (for ([p (in-list common-errors)])
+             (printf "~a:\n~a\n\n" (car p) (cdr p)))))))))
+
+(thread-wait final-thread)

collects/tests/racket/embed-me1.rkt

@@ -1,5 +1,5 @@
 (module embed-me1 mzscheme
   (with-output-to-file "stdout"
-    (lambda () (printf "This is 1~n"))
+    (lambda () (printf "This is 1\n"))
     'append))
 

collects/tests/racket/embed-me12-rd.ss

@@ -0,0 +1,15 @@
+(module embed-me11-rd mzscheme
+  (provide (rename *read-syntax read-syntax)
+           (rename *read read))
+
+  (define (*read port)
+    `(module embed-me11 mzscheme
+       (with-output-to-file "stdout"
+         (lambda () 
+           (printf ,(read port) 
+                   ;; Use `getenv' at read time!!!
+                   ,(getenv "ELEVEN")))
+         'append)))
+
+  (define (*read-syntax src port)
+    (*read port)))

collects/tests/racket/embed-me1b.rkt

@@ -4,6 +4,6 @@
          (for-syntax scheme/base))
 (define-runtime-path file '(lib "icons/file.gif"))
 (with-output-to-file "stdout"
-  (lambda () (printf "This is 1b~n"))
+  (lambda () (printf "This is 1b\n"))
   #:exists 'append)
 

collects/tests/racket/embed-me1c.rkt

@@ -4,6 +4,6 @@
          (for-syntax scheme/base))
 (define-runtime-path file '(lib "etc.ss")) ; in mzlib
 (with-output-to-file "stdout"
-  (lambda () (printf "This is 1c~n"))
+  (lambda () (printf "This is 1c\n"))
   #:exists 'append)
 

collects/tests/racket/embed-me1d.rkt

@@ -4,5 +4,5 @@
          (for-syntax scheme/base))
 (define-runtime-path file '(lib "file.gif" "icons"))
 (with-output-to-file "stdout"
-  (lambda () (printf "This is 1d~n"))
+  (lambda () (printf "This is 1d\n"))
   #:exists 'append)

collects/tests/racket/embed-me1e.rkt

@@ -4,5 +4,5 @@
          (for-syntax scheme/base))
 (define-runtime-path file '(lib "html"))
 (with-output-to-file "stdout"
-  (lambda () (printf "This is 1e~n"))
+  (lambda () (printf "This is 1e\n"))
   #:exists 'append)

collects/tests/racket/embed-me2.rkt

@@ -2,8 +2,5 @@
   (require "embed-me1.ss"
 	   mzlib/etc)
   (with-output-to-file "stdout"
-    (lambda () (printf "This is 2: ~a~n" true))
+    (lambda () (printf "This is 2: ~a\n" true))
     'append))
-
-
-

collects/tests/racket/embed.rktl

@@ -37,7 +37,7 @@
                        (mk-dest-bin #t)))
 
 (define (prepare exe src)
-  (printf "Making ~a with ~a...~n" exe src)
+  (printf "Making ~a with ~a...\n" exe src)
   (when (file-exists? exe)
     (delete-file exe)))
 
@@ -397,23 +397,36 @@
 
 ;; Try including source that needs a reader extension
 
-(define (try-reader-test mred?)
+(define (try-reader-test 12? mred? ss-file? ss-reader?)
+  ;; actual "11" files use ".rkt", actual "12" files use ".ss"
   (define dest (mk-dest mred?))
-  (define filename "embed-me11.rkt")
+  (define filename (format (if ss-file?
+                               "embed-me~a.ss"
+                               "embed-me~a.rkt")
+                           (if 12? "12" "11")))
   (define (flags s)
     (string-append "-" s))
 
+  (printf "Trying ~s ~s ~s ~s...\n" (if 12? "12" "11") mred? ss-file? ss-reader?)
+
   (create-embedding-executable 
    dest
    #:modules `((#t (lib ,filename "tests" "racket")))
    #:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename))
    #:src-filter (lambda (f)
                   (let-values ([(base name dir?) (split-path f)])
-                    (equal? name (string->path filename))))
+                    (equal? name (path-replace-suffix (string->path filename) 
+                                                      (if 12? #".ss" #".rkt")))))
    #:get-extra-imports (lambda (f code)
                          (let-values ([(base name dir?) (split-path f)])
-                           (if (equal? name (string->path filename))
+                           (if (equal? name (path-replace-suffix (string->path filename) 
-                               '((lib "embed-me11-rd.rkt" "tests" "racket"))
+                                                                 (if 12? #".ss" #".rkt")))
+                               `((lib ,(format (if ss-reader?
+                                                   "embed-me~a-rd.ss"
+                                                   "embed-me~a-rd.rkt")
+                                               (if 12? "12" "11"))
+                                      "tests" 
+                                      "racket"))
                                null)))
    #:mred? mred?)
 
@@ -422,8 +435,11 @@
   (putenv "ELEVEN" "done"))
 
 (define (try-reader)
-  (try-reader-test #f)
+  (for ([12? (in-list '(#f #t))])
-  (try-reader-test #t))
+    (try-reader-test 12? #f #f #f)
+    (try-reader-test 12? #t #f #f)
+    (try-reader-test 12? #f #t #f)
+    (try-reader-test 12? #f #f #t)))
 
 ;; ----------------------------------------