add --decompile blade to mzc and refine decompiler output

svn: r11310

collects/compiler/decompile.ss

@@ -33,20 +33,18 @@
   #;
   (if (pos . < . (length l))
       (list-ref l pos)
-      'OUT-OF-BOUNDS))
+      `(OUT-OF-BOUNDS ,pos ,l)))
 
 ;; ----------------------------------------
 
 ;; 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))))]
+          ,(decompile-form form globs '(#%globals))))]
     [else (error 'decompile "unrecognized: ~e" top)]))
 
 (define (decompile-prefix a-prefix)
@@ -59,13 +57,15 @@
        (values (append 
                 (map (lambda (tl)
                        (match tl
-                         [(struct global-bucket (name)) name]
+                         [(? symbol?) '#%linkage]
+                         [(struct global-bucket (name)) 
+                          (string->symbol (format "_~a" 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 "_~a" sym))
-                              (string->symbol (format "~s@~s~a" sym (mpi->string modidx) 
+                              (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) 
                                                       (if (zero? phase)
                                                           ""
                                                           (format "/~a" phase)))))]
@@ -84,26 +84,29 @@
    [(symbol? modidx) modidx]
    [else (collapse-module-path-index modidx (current-directory))]))
 
-(define (decompile-module mod-form)
+(define (decompile-module mod-form stack)
   (match mod-form
     [(struct mod (name self-modidx prefix provides requires body syntax-body))
-     (let-values ([(globs defns) (decompile-prefix prefix)])
+     (let-values ([(globs defns) (decompile-prefix prefix)]
+                  [(stack) (append '(#%modvars) stack)])
        `(module ,name ....
           ,@defns
           ,@(map (lambda (form)
-                   (decompile-form form globs '(#%prefix)))
+                   (decompile-form form globs stack))
                  syntax-body)
           ,@(map (lambda (form)
-                   (decompile-form form globs '(#%prefix)))
+                   (decompile-form form globs stack))
                  body)))]
     [else (error 'decompile-module "huh?: ~e" mod-form)]))
 
 (define (decompile-form form globs stack)
   (match form
+    [(? mod?)
+     (decompile-module form stack)]
     [(struct def-values (ids rhs))
      `(define-values ,(map (lambda (tl)
                              (match tl
-                               [(struct toplevel (depth pos flags))
+                               [(struct toplevel (depth pos const? mutated?))
                                 (list-ref/protect globs pos)]))
                            ids)
         ,(decompile-expr rhs globs stack))]
@@ -112,13 +115,13 @@
         ,(let-values ([(globs defns) (decompile-prefix prefix)])
            `(let ()
               ,@defns
-              ,(decompile-expr rhs globs '(#%prefix)))))]
+              ,(decompile-expr rhs globs '(#%globals)))))]
     [(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)))))]
+             ,(decompile-expr rhs globs '(#%globals)))))]
     [(struct sequence (forms))
      `(begin ,@(map (lambda (form)
                       (decompile-form form globs stack))
@@ -165,8 +168,11 @@
              
 (define (decompile-expr expr globs stack)
   (match expr
-    [(struct toplevel (depth pos flags))
+    [(struct toplevel (depth pos const? mutated?))
-     (list-ref/protect globs pos)]
+     (let ([id (list-ref/protect globs pos)])
+       (if const?
+           id
+           `(#%checked ,id)))]
     [(struct topsyntax (depth pos midpt))
      (list-ref/protect globs (+ midpt pos))]
     [(struct primitive (id))
@@ -183,19 +189,23 @@
              `(#%sfs-clear ,e)
              e)))]
     [(struct lam (name flags num-params rest? closure-map max-let-depth body))
-     (let ([vars (for/list ([i (in-range num-params)]) (gensym 'arg))]
+     (let ([vars (for/list ([i (in-range num-params)]) 
-           [rest-vars (if rest? (list (gensym 'rest)) null)])
+                   (gensym (format "arg~a-" i)))]
+           [rest-vars (if rest? (list (gensym 'rest)) null)]
+           [captures (map (lambda (v)
+                            (list-ref/protect stack v))
+                          (vector->list closure-map))])
        `(lambda (,@vars . ,(if rest?
                                (car rest-vars)
                                null))
           ,@(if name
                 `(',name)
                 null)
-          ,(decompile-expr body globs (append
+          ,@(if (null? captures)
-                                       (map (lambda (v)
+                null
-                                              (list-ref/protect stack v))
+                `('(captures: ,@captures)))
-                                            (vector->list closure-map))
+          ,(decompile-expr body globs (append captures
-                                       (append vars rest-vars)))))]
+                                              (append vars rest-vars)))))]
     [(struct let-one (rhs body))
      (let ([id (or (extract-id rhs)
                    (gensym 'local))])

collects/compiler/main.ss

@@ -130,6 +130,9 @@
       [("--expand")
        ,(lambda (f) 'expand)
        ((,(format "Write macro-expanded Scheme source(s) to stdout") ""))]
+      [("--decompile")
+       ,(lambda (f) 'decompile)
+       ((,(format "Write quasi-Scheme for ~a file(s) to stdout" (extract-suffix append-zo-suffix)) ""))]
       [("-z" "--zo")
        ,(lambda (f) 'zo)
        ((,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-zo-suffix)) ""))]
@@ -444,6 +447,19 @@
                   (unless (eof-object? e)
                     (pretty-print (syntax->datum (expand e)))
                     (loop))))))))))]
+  [(decompile)
+   (let ([zo-parse (dynamic-require 'compiler/zo-parse 'zo-parse)]
+         [decompile (dynamic-require 'compiler/decompile 'decompile)])
+     (for ([zo-file source-files])
+       (let ([zo-file (path->complete-path zo-file)])
+         (let-values ([(base name dir?) (split-path zo-file)])
+           (parameterize ([current-load-relative-directory base])
+             (pretty-print
+              (decompile
+               (call-with-input-file*
+                zo-file
+                (lambda (in)
+                  (zo-parse in))))))))))]
   [(make-zo)
    (let ([n (make-base-empty-namespace)]
          [mc (dynamic-require 'mzlib/cm 'managed-compile-zo)]

collects/compiler/zo-parse.ss

@@ -37,7 +37,7 @@
 
 (define-form-struct localref (unbox? offset clear?)) ; access local via stack
 
-(define-form-struct toplevel (depth pos flags))  ; access binding via prefix array (which is on stack)
+(define-form-struct toplevel (depth pos const? mutated?))  ; 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
@@ -67,12 +67,15 @@
 ;; Bytecode unmarshalers for various forms
 
 (define (read-toplevel v)
-  (define toplevel-flags-mask 3)
+  (define SCHEME_TOPLEVEL_CONST #x01)
+  (define SCHEME_TOPLEVEL_MUTATED #x02)
   (match v
     [(cons depth (cons pos flags))
-     (make-toplevel depth pos (bitwise-and flags toplevel-flags-mask))]
+     (make-toplevel depth pos 
+                    (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST))
+                    (positive? (bitwise-and flags SCHEME_TOPLEVEL_MUTATED)))]
     [(cons depth pos)
-     (make-toplevel depth pos 0)]))
+     (make-toplevel depth pos #f #f)]))
 
 (define (read-topsyntax v)
   (match v
@@ -112,13 +115,17 @@
      (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 (vector-length v) v rest)
                          (values v (car rest) (cdr rest)))])
          (make-lam name
                    flags
                    ((if rest? sub1 values) num-params)
                    rest?
-                   closed-over
+                   (if (= closure-size (vector-length closed-over))
+                       closed-over
+                       (let ([v2 (make-vector closure-size)])
+                         (vector-copy! v2 0 closed-over 0 closure-size)
+                         v2))
                    max-let-depth
                    body)))]))
 
@@ -252,6 +259,7 @@
     [(14) 'with-cont-mark-type]
     [(15) 'quote-syntax-type]
     [(24) 'variable-type]
+    [(25) 'module-variable-type]
     [(96) 'case-lambda-sequence-type]
     [(97) 'begin0-sequence-type]
     [(100) 'module-type]
@@ -271,6 +279,7 @@
     (cons 'with-cont-mark-type read-with-cont-mark)
     (cons 'quote-syntax-type read-topsyntax)
     (cons 'variable-type read-variable)
+    (cons 'module-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)
@@ -625,7 +634,8 @@
 (define (zo-parse port)
   (begin-with-definitions    
    ;; skip the "#~"
-   (read-bytes 2 port)
+   (unless (equal? #"#~" (read-bytes 2 port))
+     (error 'zo-parse "not a bytecode stream"))
    
    (define version (read-bytes (min 63 (read-byte port)) port))