suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add --decompile blade to mzc and refine decompiler output

Browse Source 
svn: r11310

original commit: 64c655a516
This commit is contained in:
Matthew Flatt 2008-08-19 00:04:20 +00:00
parent 19a098a7fa
commit 436c1a119a
2 changed files with 50 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/compiler/decompile.ss
View File

@ -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,18 +189,22 @@
`(#%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))
,@(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)

22
collects/compiler/zo-parse.ss
View File

@ -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?
(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))