diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss
new file mode 100644
index 0000000000..33144f5eed
--- /dev/null
+++ b/collects/compiler/decompile.ss
@@ -0,0 +1,279 @@
+#lang scheme
+(require compiler/zo-parse
+         syntax/modcollapse)
+
+(provide decompile)
+
+;; ----------------------------------------
+
+(define primitive-table
+  ;; Figure out number-to-id mapping for kernel functions in `primitive'
+  (let ([bindings
+         (let ([ns (make-base-empty-namespace)])
+           (parameterize ([current-namespace ns])
+             (namespace-require ''#%kernel)
+             (for/list ([l (namespace-mapped-symbols)])
+               (cons l (with-handlers ([exn:fail? (lambda (x) #f)])
+                         (compile l))))))]
+        [table (make-hash)])
+    (for ([b (in-list bindings)])
+      (let ([v (and (cdr b)
+                    (zo-parse (let-values ([(in out) (make-pipe)])
+                                (write (cdr b) out)
+                                (close-output-port out)
+                                in)))])
+        (let ([n (match v
+                   [(struct compilation-top (_ prefix (struct primitive (n)))) n]
+                   [else #f])])
+          (hash-set! table n (car b)))))
+    table))
+
+(define (list-ref/protect l pos)
+  (list-ref l pos)
+  #;
+  (if (pos . < . (length l))
+      (list-ref l pos)
+      'OUT-OF-BOUNDS))
+
+;; ----------------------------------------
+
+;; Main entry:
+(define (decompile top)
+  (match top
+    [(struct compilation-top (_ prefix (and (? mod?) mod)))
+     (decompile-module mod)]
+    [(struct compilation-top (_ prefix form))
+     (let-values ([(globs defns) (decompile-prefix prefix)])
+       `(begin
+          ,@defns
+          ,(decompile-form form globs '(#%prefix))))]
+    [else (error 'decompile "unrecognized: ~e" top)]))
+
+(define (decompile-prefix a-prefix)
+  (match a-prefix
+    [(struct prefix (num-lifts toplevels stxs))
+     (let ([lift-ids (for/list ([i (in-range num-lifts)])
+                    (gensym 'lift))]
+           [stx-ids (map (lambda (i) (gensym 'stx)) 
+                         stxs)])
+       (values (append 
+                (map (lambda (tl)
+                       (match tl
+                         [(struct global-bucket (name)) name]
+                         [(struct module-variable (modidx sym pos phase))
+                          (if (and (module-path-index? modidx)
+                                   (let-values ([(n b) (module-path-index-split modidx)])
+                                     (and (not n) (not b))))
+                              sym
+                              (string->symbol (format "~s@~s~a" sym (mpi->string modidx) 
+                                                      (if (zero? phase)
+                                                          ""
+                                                          (format "/~a" phase)))))]
+                         [else (error 'decompile-prefix "bad toplevel: ~e" tl)]))
+                     toplevels)
+                stx-ids
+                (if (null? stx-ids) null '(#%stx-array))
+                lift-ids)
+               (map (lambda (stx id)
+                      `(define ,id (decode-stx ,(stx-encoded stx))))
+                    stxs stx-ids)))]
+    [else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
+
+(define (mpi->string modidx)
+  (cond
+   [(symbol? modidx) modidx]
+   [else (collapse-module-path-index modidx (current-directory))]))
+
+(define (decompile-module mod-form)
+  (match mod-form
+    [(struct mod (name self-modidx prefix provides requires body syntax-body))
+     (let-values ([(globs defns) (decompile-prefix prefix)])
+       `(module ,name ....
+          ,@defns
+          ,@(map (lambda (form)
+                   (decompile-form form globs '(#%prefix)))
+                 syntax-body)
+          ,@(map (lambda (form)
+                   (decompile-form form globs '(#%prefix)))
+                 body)))]
+    [else (error 'decompile-module "huh?: ~e" mod-form)]))
+
+(define (decompile-form form globs stack)
+  (match form
+    [(struct def-values (ids rhs))
+     `(define-values ,(map (lambda (tl)
+                             (match tl
+                               [(struct toplevel (depth pos flags))
+                                (list-ref/protect globs pos)]))
+                           ids)
+        ,(decompile-expr rhs globs stack))]
+    [(struct def-syntaxes (ids rhs prefix max-let-depth))
+     `(define-syntaxes ,ids
+        ,(let-values ([(globs defns) (decompile-prefix prefix)])
+           `(let ()
+              ,@defns
+              ,(decompile-expr rhs globs '(#%prefix)))))]
+    [(struct def-for-syntax (ids rhs prefix max-let-depth))
+     `(define-values-for-syntax ,ids
+        ,(let-values ([(globs defns) (decompile-prefix prefix)])
+           `(let ()
+             ,@defns
+             ,(decompile-expr rhs globs '(#%prefix)))))]
+    [(struct sequence (forms))
+     `(begin ,@(map (lambda (form)
+                      (decompile-form form globs stack))
+                    forms))]
+    [(struct splice (forms))
+     `(begin ,@(map (lambda (form)
+                      (decompile-form form globs stack))
+                    forms))]
+    [else
+     (decompile-expr form globs stack)]))
+
+(define (extract-name name)
+  (if (symbol? name)
+      (gensym name)
+      (if (vector? name)
+          (gensym (vector-ref name 0))
+          #f)))
+
+(define (extract-id expr)
+  (match expr
+    [(struct lam (name flags num-params rest? closure-map max-let-depth body))
+     (extract-name name)]
+    [(struct case-lam (name lams))
+     (extract-name name)]
+    [(struct closure (lam gen-id))
+     (extract-id lam)]
+    [(struct indirect (v))
+     (extract-id v)]
+    [else #f]))
+
+(define (extract-ids! body ids)
+  (match body
+    [(struct let-rec (procs body))
+     (for ([proc (in-list procs)]
+           [delta (in-naturals)])
+       (when (< -1 delta (vector-length ids))
+         (vector-set! ids delta (extract-id proc))))
+     (extract-ids! body ids)]
+    [(struct install-value (val-count pos boxes? rhs body))
+     (extract-ids! body ids)]
+    [(struct boxenv (pos body))
+     (extract-ids! body ids)]
+    [else #f]))
+             
+(define (decompile-expr expr globs stack)
+  (match expr
+    [(struct toplevel (depth pos flags))
+     (list-ref/protect globs pos)]
+    [(struct topsyntax (depth pos midpt))
+     (list-ref/protect globs (+ midpt pos))]
+    [(struct primitive (id))
+     (hash-ref primitive-table id)]
+    [(struct assign (id rhs undef-ok?))
+     `(set! ,(decompile-expr id globs stack)
+            ,(decompile-expr rhs globs stack))]
+    [(struct localref (unbox? offset flags))
+     (let ([id (list-ref/protect stack offset)])
+       (if unbox?
+           `(#%unbox ,id)
+           id))]
+    [(struct lam (name flags num-params rest? closure-map max-let-depth body))
+     (let ([vars (for/list ([i (in-range num-params)]) (gensym 'arg))]
+           [rest-vars (if rest? (list (gensym 'rest)) null)])
+       `(lambda (,@vars . ,(if rest?
+                               (car rest-vars)
+                               null))
+          ,@(if name
+                `(',name)
+                null)
+          ,(decompile-expr body globs (append
+                                       (map (lambda (v)
+                                              (list-ref/protect stack v))
+                                            (vector->list closure-map))
+                                       (append vars rest-vars)))))]
+    [(struct let-one (rhs body))
+     (let ([id (or (extract-id rhs)
+                   (gensym 'local))])
+       `(let ([,id ,(decompile-expr rhs globs (cons id stack))])
+          ,(decompile-expr body globs (cons id stack))))]
+    [(struct let-void (count boxes? body))
+     (let ([ids (make-vector count #f)])
+       (extract-ids! body ids)
+       (let ([vars (for/list ([i (in-range count)]
+                              [id (in-vector ids)])
+                     (or id (gensym 'localv)))])
+         `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
+                     vars)
+            ,(decompile-expr body globs (append vars stack)))))]
+    [(struct let-rec (procs body))
+     `(begin
+        (set!-rec-values ,(for/list ([p (in-list procs)]
+                                     [i (in-naturals)])
+                            (list-ref/protect stack i))
+                         ,@(map (lambda (proc)
+                                  (decompile-expr proc globs stack))
+                                procs))
+        ,(decompile-expr body globs stack))]
+    [(struct install-value (count pos boxes? rhs body))
+     `(begin
+        (,(if boxes? '#%set-boxes! 'set!-values)
+         ,(for/list ([i (in-range count)])
+            (list-ref/protect stack (+ i pos)))
+         ,(decompile-expr rhs globs stack))
+        ,(decompile-expr body globs stack))]
+    [(struct boxenv (pos body))
+     (let ([id (list-ref/protect stack pos)])
+       `(begin
+          (set! ,id (#%box ,id))
+          ,(decompile-expr body globs stack)))]
+    [(struct branch (test then else))
+     `(if ,(decompile-expr test globs stack)
+          ,(decompile-expr then globs stack)
+          ,(decompile-expr else globs stack))]
+    [(struct application (rator rands))
+     (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
+                          stack)])
+       `(,(decompile-expr rator globs stack)
+         ,@(map (lambda (rand)
+                  (decompile-expr rand globs stack))
+                rands)))]
+    [(struct apply-values (proc args-expr))
+     `(apply-values ,(decompile-expr proc globs stack) 
+                    ,(decompile-expr args-expr globs stack))]
+    [(struct sequence (exprs))
+     `(begin ,@(for/list ([expr (in-list exprs)])
+                 (decompile-expr expr globs stack)))]
+    [(struct beg0 (exprs))
+     `(begin0 ,@(for/list ([expr (in-list exprs)])
+                  (decompile-expr expr globs stack)))]
+    [(struct closure (lam gen-id))
+     `(CLOSED ,gen-id ,(decompile-expr lam globs stack))]
+    [(struct indirect (val))
+     (if (closure? val)
+         (closure-gen-id val)
+         '???)]
+    [else `(quote ,expr)]))
+
+;; ----------------------------------------
+
+#;
+(begin
+  (require scheme/pretty)
+  (define (try e)
+    (pretty-print
+     (decompile
+      (zo-parse (let-values ([(in out) (make-pipe)])
+                  (write (parameterize ([current-namespace (make-base-namespace)])
+                           (compile e))
+                         out)
+                  (close-output-port out)
+                  in)))))
+  (pretty-print
+   (decompile
+    (zo-parse (open-input-file "/home/mflatt/proj/plt/collects/tests/mzscheme/benchmarks/common/sboyer_ss.zo"))))
+  #;
+  (try '(lambda (q . more)
+          (letrec ([f (lambda (x) f)])
+            (lambda (g) f)))))
diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss
new file mode 100644
index 0000000000..8007070022
--- /dev/null
+++ b/collects/compiler/zo-parse.ss
@@ -0,0 +1,683 @@
+#lang scheme
+(require mzlib/etc 
+         scheme/list)
+
+(provide zo-parse)
+
+;; ----------------------------------------
+;;  Structures to represent bytecode
+
+(define-syntax-rule (define-form-struct id (field-id ...))
+  (begin
+    (define-struct id (field-id ...) #:transparent)
+    (provide (struct-out id))))
+
+(define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this
+
+(define-form-struct prefix (num-lifts toplevels stxs))   ; sets up top-level and syntax-object array
+
+;; In toplevels of resove prefix:
+(define-form-struct global-bucket (name)) ; top-level binding
+(define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id
+
+;; In stxs of prefix:
+(define-form-struct stx (encoded)) ; todo: decode syntax objects
+
+(define-form-struct mod (name self-modidx prefix provides requires body syntax-body))
+
+(define-form-struct lam (name flags num-params rest? closure-map max-let-depth body)) ; `lambda'
+(define-form-struct closure (code gen-id)) ; a static closure (nothing to close over)
+(define-form-struct case-lam (name clauses)) ; each clause is an lam
+
+(define-form-struct let-one (rhs body)) ; pushes one value onto stack
+(define-form-struct let-void (count boxes? body)) ; create new stack slots
+(define-form-struct install-value (count pos boxes? rhs body)) ; set existing stack slot(s)
+(define-form-struct let-rec (procs body)) ; put `letrec'-bound closures into existing stack slots
+(define-form-struct boxenv (pos body)) ; box existing stack element
+
+(define-form-struct localref (unbox? offset flags)) ; access local via stack
+
+(define-form-struct toplevel (depth pos flags))  ; access binding via prefix array (which is on stack)
+(define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
+
+(define-form-struct application (rator rands)) ; function call
+(define-form-struct branch (test then else)) ; `if'
+(define-form-struct with-cont-mark (key val body)) ; `with-continuation-mark'
+(define-form-struct beg0 (seq)) ; `begin0'
+(define-form-struct sequence (forms)) ; `begin'
+(define-form-struct splice (forms)) ; top-level `begin'
+(define-form-struct varref (toplevel)) ; `#%variable-reference'
+(define-form-struct assign (id rhs undef-ok?)) ; top-level or module-level set!
+(define-form-struct apply-values (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc)
+(define-form-struct primitive (id)) ; direct preference to a kernel primitive
+
+;; Definitions (top level or within module):
+(define-form-struct def-values (ids rhs))
+(define-form-struct def-syntaxes (ids rhs prefix max-let-depth))
+(define-form-struct def-for-syntax (ids rhs prefix max-let-depth))
+
+;; Top-level `require'
+(define-form-struct req (reqs dummy))
+
+;; A static closure can refer directly to itself, creating a cycle
+(define-struct indirect ([v #:mutable]) #:prefab)
+(provide (struct-out indirect))
+
+;; ----------------------------------------
+;; Bytecode unmarshalers for various forms
+
+(define (read-toplevel v)
+  (define toplevel-flags-mask 3)
+  (match v
+    [(cons depth (cons pos flags))
+     (make-toplevel depth pos (bitwise-and flags toplevel-flags-mask))]
+    [(cons depth pos)
+     (make-toplevel depth pos 0)]))
+
+(define (read-topsyntax v)
+  (match v
+    [`(,depth ,pos . ,midpt)
+     (make-topsyntax depth pos midpt)]))
+
+(define (read-variable v)
+  (if (symbol? v)
+      (make-global-bucket v)
+      (let-values ([(phase modname varname)
+                    (match v
+                      [(list* phase modname varname)
+                       (values phase modname varname)]
+                      [(list* modname varname)
+                       (values 0 modname varname)])])
+        (if (and (zero? phase) (eq? modname '#%kernel))
+            (error 'bucket "var ~a" varname)
+            (make-module-variable modname varname -1 phase)))))
+
+(define (read-compilation-top v)
+  (match v
+    [`(,ld ,prefix . ,code)
+     (unless (prefix? prefix)
+       (error 'bad "not prefix ~a" prefix))
+     (make-compilation-top ld prefix code)]))
+
+(define (read-resolve-prefix v)
+  (match v
+    [`(,i ,tv . ,sv)
+     (make-prefix i (vector->list tv) (vector->list sv))]))
+
+(define (read-unclosed-procedure v)
+  (define CLOS_HAS_REST 1)
+  (define CLOS_HAS_REF_ARGS 2)
+  (match v
+    [`(,flags ,num-params ,max-let-depth ,name ,v . ,rest)
+     (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))])
+       (let-values ([(closure-size closed-over body)
+                     (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
+                         (values #f v rest)
+                         (values v (car rest) (cdr rest)))])
+         (make-lam name
+                   flags
+                   ((if rest? sub1 values) num-params)
+                   rest?
+                   closed-over
+                   max-let-depth
+                   body)))]))
+
+(define (read-let-value v)
+  (match v
+    [`(,count ,pos ,boxes? ,rhs . ,body)
+     (make-install-value count pos boxes? rhs body)]))
+
+(define (read-let-void v)
+  (match v
+    [`(,count ,boxes? . ,body)
+     (make-let-void count boxes? body)]))
+
+(define (read-letrec v)
+  (match v
+    [`(,count ,body . ,procs)
+     (make-let-rec procs body)]))
+
+(define (read-with-cont-mark v)
+  (match v
+    [`(,key ,val . ,body)
+     (make-with-cont-mark key val body)]))
+
+(define (read-sequence v) 
+  (make-sequence v))
+
+(define (read-define-values v)
+  (make-def-values
+   (cdr (vector->list v))
+   (vector-ref v 0)))
+
+(define (read-define-syntaxes mk v)
+  (mk (list-tail (vector->list v) 4)
+      (vector-ref v 0)
+      (vector-ref v 1)
+      (vector-ref v 2)
+      #;(vector-ref v 3)))
+
+(define (read-define-syntax v)
+  (read-define-syntaxes make-def-syntaxes v))
+
+(define (read-define-for-syntax v)
+  (read-define-syntaxes make-def-for-syntax v))
+
+(define (read-set! v)
+  (make-assign (cadr v) (cddr v) (car v)))
+
+(define (read-case-lambda v)
+  (make-case-lam (car v) (cdr v)))
+
+(define (read-begin0 v) 
+  (match v
+    [(struct sequence (exprs))
+     (make-beg0 exprs)]))
+
+(define (read-boxenv v)
+  (make-boxenv (car v) (cdr v)))
+(define (read-require v)
+  (make-req (cdr v) (car v)))
+(define (read-#%variable-ref v)
+  (make-varref v))
+(define (read-apply-values v)
+  (make-apply-values (car v) (cdr v)))
+(define (read-splice v)
+  (make-splice v))
+
+(define (read-module v)
+  (match v
+    [`(,name ,self-modidx ,functional? ,et-functional?
+             ,rename ,max-let-depth ,dummy
+             ,prefix ,kernel-exclusion ,reprovide-kernel?
+             ,indirect-provides ,num-indirect-provides ,protects
+             ,provide-phase-count . ,rest)
+     (let ([phase-data (take rest (* 8 provide-phase-count))])
+       (match (list-tail rest (* 8 provide-phase-count))
+         [`(,syntax-body ,body
+                         ,requires ,syntax-requires ,template-requires ,label-requires
+                         ,more-requires-count . ,more-requires)
+          (make-mod name self-modidx
+                    prefix phase-data
+                    (list*
+                     (cons 0 requires)
+                     (cons 1 syntax-requires)
+                     (cons -1 template-requires)
+                     (cons #f label-requires)
+                     more-requires)
+                    (vector->list body)
+                    (map (lambda (sb)
+                           (match sb
+                             [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
+                              ((if for-stx?
+                                   make-def-for-syntax
+                                   make-def-syntaxes)
+                               ids expr prefix max-let-depth)]))
+                         (vector->list syntax-body)))]))]))
+(define (read-module-wrap v)
+  v)
+
+;; ----------------------------------------
+;; Unmarshal dispatch for various types
+
+(define (read-more-syntax v)
+  (let ([id (car v)]
+        [v (cdr v)])
+    ;; This is the ..._EXPD mapping from "schpriv.h":
+    (case id
+      [(0) (read-define-values v)]
+      [(1) (read-define-syntax v)]
+      [(2) (read-set! v)]
+      [(3) (read-case-lambda v)]
+      [(4) (read-begin0 v)]
+      [(5) (read-boxenv v)]
+      [(6) (read-module-wrap v)]
+      [(7) (read-require v)]
+      [(8) (read-define-for-syntax v)]
+      [(9) (read-#%variable-ref v)]
+      [(10) (read-apply-values v)]
+      [(11) (read-splice v)]
+      [else (error 'read-mode-unsyntax "unknown id: ~e" id)])))
+
+;; Type mappings from "stypes.h":
+(define (int->type i)
+  (case i
+    [(0) 'toplevel-type]
+    [(3) 'syntax-type]
+    [(7) 'sequence-type]
+    [(9) 'unclosed-procedure-type]
+    [(10) 'let-value-type]
+    [(11) 'let-void-type]
+    [(12) 'letrec-type]
+    [(14) 'with-cont-mark-type]
+    [(15) 'quote-syntax-type]
+    [(24) 'variable-type]
+    [(96) 'case-lambda-sequence-type]
+    [(97) 'begin0-sequence-type]
+    [(100) 'module-type]
+    [(103) 'resolve-prefix-type]
+    [else (error 'int->type "unknown type: ~e" i)]))
+
+(define type-readers
+  (make-immutable-hash
+   (list
+    (cons 'toplevel-type read-toplevel)
+    (cons 'syntax-type read-more-syntax)
+    (cons 'sequence-type read-sequence)
+    (cons 'unclosed-procedure-type read-unclosed-procedure)
+    (cons 'let-value-type read-let-value)
+    (cons 'let-void-type read-let-void)
+    (cons 'letrec-type read-letrec)
+    (cons 'with-cont-mark-type read-with-cont-mark)
+    (cons 'quote-syntax-type read-topsyntax)
+    (cons 'variable-type read-variable)
+    (cons 'compilation-top-type read-compilation-top)
+    (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))))
+
+(define (get-reader type)
+  (or (hash-ref type-readers type #f)
+      (lambda (v)
+        (error 'read-marshalled "reader for ~a not implemented" type))))
+
+;; ----------------------------------------
+;; Lowest layer of bytecode parsing
+
+(define (split-so all-short so)
+  (define n (if (zero? all-short) 4 2))
+  (let loop ([so so])
+    (if (zero? (bytes-length so))
+        null
+        (cons (integer-bytes->integer (subbytes so 0 n) #f)
+              (loop (subbytes so n))))))
+
+(define (read-simple-number p)
+  ;; not sure if it's really unsigned
+  (integer-bytes->integer (read-bytes 4 p) #f #f))
+
+(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets))
+
+(define (cp-getc cp)
+  (begin-with-definitions
+    (when ((cport-pos cp) . >= . (cport-size cp))
+      (error "off the end"))
+    (define r
+      (bytes-ref (cport-bytes cp) (cport-pos cp)))
+    (set-cport-pos! cp (add1 (cport-pos cp)))
+    r))
+
+(define small-list-max 65)
+(define cpt-table
+  ;; The "schcpt.h" mapping
+  `([0  escape]
+    [1  symbol]
+    [2  symref]
+    [3  weird-symbol]
+    [4  keyword]
+    [5  byte-string]
+    [6  string]
+    [7  char]
+    [8  int]
+    [9  null]
+    [10 true]
+    [11 false]
+    [12 void]
+    [13 box]
+    [14 pair]
+    [15 list]
+    [16 vector]
+    [17 hash-table]
+    [18 stx]
+    [19 gstx] ; unused
+    [20 marshalled]
+    [21 quote]
+    [22 reference]
+    [23 local]
+    [24 local-unbox]
+    [25 svector]
+    [26 application]
+    [27 let-one]
+    [28 branch]
+    [29 module-index]
+    [30 module-var]
+    [31 path]
+    [32 closure]
+    [33 delayed]
+    [34 prefab]
+    [35 60 small-number]
+    [60 80 small-symbol]
+    [80 92 small-marshalled]
+    [92 ,(+ 92 small-list-max) small-proper-list]
+    [,(+ 92 small-list-max) 192 small-list]
+    [192 207 small-local]
+    [207 222 small-local-unbox]
+    [222 247 small-svector]
+    [248 small-application2]
+    [249 small-application3]
+    [247 255 small-application]))
+
+(define (cpt-table-lookup i)
+  (for/or ([ent cpt-table])
+          (match ent
+            [(list k sym) (and (= k i) (cons k sym))]
+            [(list k k* sym)
+             (and (<= k i)
+                  (< i k*)
+                  (cons k sym))])))
+
+(define (read-compact-bytes port c)
+  (begin0
+   (subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos port) c))
+   (set-cport-pos! port (+ c (cport-pos port)))))
+
+(define (read-compact-chars port c)
+  (bytes->string/utf-8 (read-compact-bytes port c)))
+
+(define (read-compact-list c proper port)
+  (cond [(= 0 c)
+         (if proper null (read-compact port))]
+        [else (cons (read-compact port) (read-compact-list (sub1 c) proper port))]))
+
+(define (read-compact-number port)
+  (define flag (cp-getc port))
+  (cond [(< flag 128)
+         flag]
+        [(zero? (bitwise-and flag #x40))
+         (let ([a (cp-getc port)])
+           (+ (a . << . 6) (bitwise-and flag 63)))]
+        [(zero? (bitwise-and flag #x20))
+         (- (bitwise-and flag #x1F))]
+        [else
+         (let ([a (cp-getc port)]
+               [b (cp-getc port)]
+               [c (cp-getc port)]
+               [d (cp-getc port)])
+           (let ([n (integer-bytes->integer (bytes a b c d) #f #f)])
+             (if (zero? (bitwise-and flag #x10))
+                 (- n)
+                 n)))]))
+
+(define (read-compact-svector port n)
+  (list->vector (reverse (for/list ([i (in-range n)]) (read-compact-number port)))))
+
+(define (read-marshalled type port)
+  (let* ([type (if (number? type) (int->type type) type)]
+         [l (read-compact port)]
+         [reader (get-reader type)])
+    (reader l)))
+
+(define (a . << . b)
+  (arithmetic-shift a b))
+
+(define-struct not-ready ())
+
+;; ----------------------------------------
+;; Main parsing loop
+
+(define (read-compact cp)
+  (let loop ([need-car 0] [proper #f] [last #f] [first #f])
+    (begin-with-definitions
+      (define ch (cp-getc cp))
+      (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))))
+      (define v 
+        (case cpt-tag
+          [(delayed)
+           (let ([pos (read-compact-number cp)])
+             (let ([v (vector-ref (cport-symtab cp) pos)])
+               (if (not-ready? v)
+                   (let ([save-pos (cport-pos cp)])
+                     (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
+                     (let ([v (read-compact cp)])
+                       (vector-set! (cport-symtab cp) pos v)
+                       (set-cport-pos! cp save-pos)
+                       v))
+                   v)))]
+          [(escape)
+           (let* ([len (read-compact-number cp)]
+                  [s (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))])
+             (set-cport-pos! cp (+ (cport-pos cp) len))
+             (parameterize ([read-accept-compiled #t]
+                            [read-accept-bar-quote #t]
+                            [read-accept-box #t]
+                            [read-accept-graph #t]
+                            [read-case-sensitive #t]
+                            [read-square-bracket-as-paren #t]
+                            [read-curly-brace-as-paren #t]
+                            [read-decimal-as-inexact #t]
+                            [read-accept-dot #t]
+                            [read-accept-infix-dot #t]
+                            [read-accept-quasiquote #t])
+               (read (open-input-bytes s))))]
+          [(reference)
+           (make-primitive (read-compact-number cp))]
+          [(small-list small-proper-list)
+           (let* ([l (- ch cpt-start)]
+                  [ppr (eq? cpt-tag 'small-proper-list)])
+             (if (positive? need-car)
+                 (if (= l 1)
+                     (cons (read-compact cp)
+                           (if ppr null (read-compact cp)))
+                     (read-compact-list l ppr cp))
+                 (loop l ppr last first)))]
+          [(let-one)
+           (make-let-one (read-compact cp) (read-compact cp))]
+          [(branch)
+           (make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
+          [(module-index) (module-path-index-join (read-compact cp) (read-compact cp))]
+          [(module-var)
+           (let ([mod (read-compact cp)]
+                 [var (read-compact cp)]
+                 [pos (read-compact-number cp)])
+             (make-module-variable mod var pos 0))]
+          [(local-unbox)
+           (let* ([p* (read-compact-number cp)]
+                  [p (if (< p* 0)
+                         (- (add1 p*))
+                         p*)]
+                  [flags (if (< p* 0)
+                             (read-compact-number cp)
+                             0)])
+             (make-localref #t p flags))]
+          [(path)
+           (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))])
+             (if (relative-path? p)
+                 (path->complete-path p (or (current-load-relative-directory)
+                                            (current-directory)))
+                 p))]
+          [(small-number)
+           (let ([l (- ch cpt-start)])
+             l)]
+          [(int)
+           (read-compact-number cp)]
+          [(false) #f]
+          [(true) #t]
+          [(null) null]
+          [(void) (void)]
+          [(vector) (let* ([n (read-compact-number cp)]
+                           [lst (for/list ([i (in-range n)])
+                                  (read-compact cp))])
+                      (vector->immutable-vector (list->vector lst)))]
+          [(list) (let* ([n (read-compact-number cp)])
+                    (for/list ([i (in-range n)])
+                      (read-compact cp)))]
+          [(prefab)
+           (let ([v (read-compact cp)])
+             (apply make-prefab-struct
+                    (vector-ref v 0)
+                    (cdr (vector->list v))))]
+          [(hash-table)
+           (let ([eq (read-compact-number cp)]
+                 [len (read-compact-number cp)])
+             ((if (zero? eq) 
+                  make-hash-placeholder
+                  make-hasheq-placeholder)
+              (for/list ([i (in-range len)])
+                (cons (read-compact cp)
+                      (read-compact cp)))))]
+          [(marshalled) (read-marshalled (read-compact-number cp) cp)]
+          [(stx)
+           (let ([v (make-reader-graph (read-compact cp))])
+             (make-stx v))]
+          [(local local-unbox)
+           (let ([c (read-compact-number cp)]
+                 [unbox? (eq? cpt-tag 'local-unbox)])
+             (if (negative? c)
+                 (make-localref unbox? (- (add1 c)) (read-compact-number cp))
+                 (make-localref unbox? c 0)))]
+          [(small-local)
+           (make-localref #f (- ch cpt-start) 0)]
+          [(small-local-unbox)
+           (make-localref #t (- ch cpt-start) 0)]
+          [(small-symbol)
+           (let ([l (- ch cpt-start)])
+             (string->symbol (read-compact-chars cp l)))]
+          [(symbol)
+           (let ([l (read-compact-number cp)])
+             (string->symbol (read-compact-chars cp l)))]
+          [(keyword)
+           (let ([l (read-compact-number cp)])
+             (string->keyword (read-compact-chars cp l)))]
+          [(byte-string)
+           (let ([l (read-compact-number cp)])
+             (read-compact-bytes cp l))]
+          [(string)
+           (let ([l (read-compact-number cp)]
+                 [cl (read-compact-number cp)])
+             (read-compact-chars cp l))]
+          [(char)
+           (integer->char (read-compact-number cp))]
+          [(box)
+           (box (read-compact cp))]
+          [(quote)
+           (make-reader-graph (read-compact cp))]
+          [(symref)
+           (let* ([l (read-compact-number cp)]
+                  [v (vector-ref (cport-symtab cp) l)])
+             (if (not-ready? v)
+                 (let ([pos (cport-pos cp)])
+                   (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l)))
+                   (let ([v (read-compact cp)])
+                     (set-cport-pos! cp pos)
+                     (vector-set! (cport-symtab cp) l v)
+                     v))
+                 v))]
+          [(weird-symbol)
+           (let ([u (read-compact-number cp)]
+                 [str (read-compact-chars cp (read-compact-number cp))])
+             ;; FIXME: no way to construct quasi-interned symbols:
+             (string->uninterned-symbol str))]
+          [(small-marshalled)
+           (read-marshalled (- ch cpt-start) cp)]
+          [(small-application2)
+           (make-application (read-compact cp)
+                             (list (read-compact cp)))]
+          [(small-application3)
+           (make-application (read-compact cp)
+                             (list (read-compact cp)
+                                   (read-compact cp)))]
+          [(small-application)
+           (let ([c (add1 (- ch cpt-start))])
+             (make-application (read-compact cp)
+                               (for/list ([i (in-range (sub1 c))])
+                                 (read-compact cp))))]          
+          [(application)
+           (let ([c (read-compact-number cp)])
+             (make-application (read-compact cp)
+                               (for/list ([i (in-range c)])
+                                 (read-compact cp))))]          
+          [(closure)
+           (let* ([l (read-compact-number cp)]
+                  [ind (make-indirect #f)])
+             (vector-set! (cport-symtab cp) l ind)
+             (let* ([v (read-compact cp)]
+                    [cl (make-closure v (gensym
+                                         (let ([s (lam-name v)])
+                                           (cond
+                                            [(symbol? s) s]
+                                            [(vector? s) (vector-ref s 0)]
+                                            [else 'closure]))))])
+               (vector-set! (cport-symtab cp) l cl)
+               (set-indirect-v! ind cl)
+               cl))]
+          [(svector)
+           (read-compact-svector cp (read-compact-number cp))]
+          [(small-svector)
+           (read-compact-svector cp (- ch cpt-start))]
+          [else (error 'read-compact "unknown tag ~a" cpt-tag)]))
+      (cond 
+        [(zero? need-car) v]
+        [(and proper (= need-car 1))
+         (cons v null)]
+        [else
+         (cons v (loop (sub1 need-car) proper last first))]))))
+
+;; path -> bytes
+;; implementes read.c:read_compiled
+(define (zo-parse port)
+  (begin-with-definitions    
+   ;; skip the "#~"
+   (read-bytes 2 port)
+   
+   (define version (read-bytes (min 63 (read-byte port)) port))
+   
+   (define symtabsize (read-simple-number port))
+   
+   (define all-short (read-byte port))
+   
+   (define cnt (* (if (not (zero? all-short)) 2 4)
+                  (sub1 symtabsize)))
+
+   (define so (read-bytes cnt port))
+   
+   (define so* (list->vector (split-so all-short so)))
+
+   (define shared-size (read-simple-number port))
+   (define size* (read-simple-number port))
+
+   (when (shared-size . >= . size*) 
+     (error 'bad-read))
+
+   (define rst (read-bytes size* port))
+
+   (unless (eof-object? (read port))
+     (error 'not-end))
+   
+   (unless (= size* (bytes-length rst))
+     (error "wrong number of bytes"))
+
+   (define symtab (make-vector symtabsize (make-not-ready)))
+
+   (define cp (make-cport 0 port size* rst symtab so*))
+   (for/list ([i (in-range 1 symtabsize)])
+     (when (not-ready? (vector-ref symtab i))
+       (set-cport-pos! cp (vector-ref so* (sub1 i)))
+       (let ([v (read-compact cp)])
+         (vector-set! symtab i v))))
+   (set-cport-pos! cp shared-size)
+   (read-marshalled 'compilation-top-type cp)))
+
+;; ----------------------------------------
+
+#;
+(begin
+  (define (compile/write sexp)
+    (define s (open-output-bytes))
+    (write (parameterize ([current-namespace (make-base-namespace)])
+             (eval '(require (for-syntax scheme/base)))
+             (compile sexp))
+           s)
+    (get-output-bytes s))
+
+  (define (compile/parse sexp)  
+    (let* ([bs (compile/write sexp)]
+           [p (open-input-bytes bs)])
+      (zo-parse p)))
+
+  #;(compile/parse #s(foo 10 13))
+  (zo-parse (open-input-file "/home/mflatt/proj/plt/collects/scheme/private/compiled/more-scheme_ss.zo"))
+)