diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index e1e9ffaf88..95aab6ec6a 100644 --- a/collects/compiler/decompile.ss +++ b/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 "~s@~s~a" sym (mpi->string modidx) + (string->symbol (format "_~a" sym)) + (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)) - (list-ref/protect globs pos)] + [(struct toplevel (depth pos const? mutated?)) + (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))] - [rest-vars (if rest? (list (gensym 'rest)) null)]) + (let ([vars (for/list ([i (in-range num-params)]) + (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 - (map (lambda (v) - (list-ref/protect stack v)) - (vector->list closure-map)) - (append vars rest-vars)))))] + ,@(if (null? captures) + null + `('(captures: ,@captures))) + ,(decompile-expr body globs (append captures + (append vars rest-vars)))))] [(struct let-one (rhs body)) (let ([id (or (extract-id rhs) (gensym 'local))]) diff --git a/collects/compiler/main.ss b/collects/compiler/main.ss index 642e758a7d..73da9777aa 100644 --- a/collects/compiler/main.ss +++ b/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)] diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index a739445462..98528bbfa4 100644 --- a/collects/compiler/zo-parse.ss +++ b/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))