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

improve decompiler handling of syntax object

Browse Source
This commit is contained in:
Matthew Flatt 2011-07-07 14:47:19 -06:00
parent 4edbf125a9
commit 5e49e0adea
1 changed files with 84 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
collects/compiler/decompile.rkt
View File

@ -47,15 +47,16 @@
;; Main entry: ;; Main entry:
(define (decompile top) (define (decompile top)
(let ([stx-ht (make-hasheq)])
(match top (match top
[(struct compilation-top (max-let-depth prefix form)) [(struct compilation-top (max-let-depth prefix form))
(let-values ([(globs defns) (decompile-prefix prefix)]) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(begin `(begin
,@defns ,@defns
,(decompile-form form globs '(#%globals) (make-hasheq))))] ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht)))]
[else (error 'decompile "unrecognized: ~e" top)])) [else (error 'decompile "unrecognized: ~e" top)])))
(define (decompile-prefix a-prefix) (define (decompile-prefix a-prefix stx-ht)
(match a-prefix (match a-prefix
[(struct prefix (num-lifts toplevels stxs)) [(struct prefix (num-lifts toplevels stxs))
(let ([lift-ids (for/list ([i (in-range num-lifts)]) (let ([lift-ids (for/list ([i (in-range num-lifts)])
@ -89,37 +90,99 @@
num-lifts) num-lifts)
(map (lambda (stx id) (map (lambda (stx id)
`(define ,id ,(if stx `(define ,id ,(if stx
`(#%decode-syntax ,(stx-encoded stx)) `(#%decode-syntax
,(decompile-stx (stx-encoded stx) stx-ht))
#f))) #f)))
stxs stx-ids)))] stxs stx-ids)))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)])) [else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
(define (decompile-stx stx stx-ht)
(or (hash-ref stx-ht stx #f)
(let ([p (mcons #f #f)])
(hash-set! stx-ht stx p)
(match stx
[(wrapped datum wraps tamper-status)
(set-mcar! p (case tamper-status
[(clean) 'wrap]
[(tainted) 'wrap-tainted]
[(armed) 'wrap-armed]))
(set-mcdr! p (mcons
(cond
[(pair? datum)
(cons (decompile-stx (car datum) stx-ht)
(let loop ([l (cdr datum)])
(cond
[(null? l) null]
[(pair? l)
(cons (decompile-stx (car l) stx-ht)
(loop (cdr l)))]
[else
(decompile-stx l stx-ht)])))]
[(vector? datum)
(for/vector ([e (in-vector datum)])
(decompile-stx e stx-ht))]
[(box? datum)
(box (decompile-stx (unbox datum) stx-ht))]
[else datum])
(let loop ([wraps wraps])
(cond
[(null? wraps) null]
[else
(or (hash-ref stx-ht wraps #f)
(let ([p (mcons #f #f)])
(hash-set! stx-ht wraps p)
(set-mcar! p (decompile-wrap (car wraps) stx-ht))
(set-mcdr! p (loop (cdr wraps)))
p))]))))
p]))))
(define (decompile-wrap w stx-ht)
(or (hash-ref stx-ht w #f)
(let ([v (match w
[(lexical-rename has-free-id-renames?
ignored
alist)
`(,(if has-free-id-renames? 'lexical/free-id=? 'lexical) . ,alist)]
[(phase-shift amt src dest)
`(phase-shift ,amt ,src ,dest)]
[(wrap-mark val)
val]
[(prune sym)
`(prune ,sym)]
[(module-rename phase kind set-id unmarshals renames mark-renames plus-kern?)
`(module-rename ,phase ,kind ,set-id ,unmarshals ,renames ,mark-renames ,plus-kern?)]
[(top-level-rename flag)
`(top-level-rename ,flag)]
[else w])])
(hash-set! stx-ht w v)
v)))
(define (mpi->string modidx) (define (mpi->string modidx)
(cond (cond
[(symbol? modidx) modidx] [(symbol? modidx) modidx]
[else (collapse-module-path-index modidx (current-directory))])) [else (collapse-module-path-index modidx (current-directory))]))
(define (decompile-module mod-form stack) (define (decompile-module mod-form stack stx-ht)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported
max-let-depth dummy lang-info internal-context)) max-let-depth dummy lang-info internal-context))
(let-values ([(globs defns) (decompile-prefix prefix)] (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
[(stack) (append '(#%modvars) stack)] [(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)]) [(closed) (make-hasheq)])
`(module ,name .... `(module ,name ....
,@defns ,@defns
,@(map (lambda (form) ,@(map (lambda (form)
(decompile-form form globs stack closed)) (decompile-form form globs stack closed stx-ht))
syntax-body) syntax-body)
,@(map (lambda (form) ,@(map (lambda (form)
(decompile-form form globs stack closed)) (decompile-form form globs stack closed stx-ht))
body)))] body)))]
[else (error 'decompile-module "huh?: ~e" mod-form)])) [else (error 'decompile-module "huh?: ~e" mod-form)]))
(define (decompile-form form globs stack closed) (define (decompile-form form globs stack closed stx-ht)
(match form (match form
[(? mod?) [(? mod?)
(decompile-module form stack)] (decompile-module form stack stx-ht)]
[(struct def-values (ids rhs)) [(struct def-values (ids rhs))
`(define-values ,(map (lambda (tl) `(define-values ,(map (lambda (tl)
(match tl (match tl
@ -129,23 +192,23 @@
,(decompile-expr rhs globs stack closed))] ,(decompile-expr rhs globs stack closed))]
[(struct def-syntaxes (ids rhs prefix max-let-depth)) [(struct def-syntaxes (ids rhs prefix max-let-depth))
`(define-syntaxes ,ids `(define-syntaxes ,ids
,(let-values ([(globs defns) (decompile-prefix prefix)]) ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let () `(let ()
,@defns ,@defns
,(decompile-form rhs globs '(#%globals) closed))))] ,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
[(struct def-for-syntax (ids rhs prefix max-let-depth)) [(struct def-for-syntax (ids rhs prefix max-let-depth))
`(define-values-for-syntax ,ids `(define-values-for-syntax ,ids
,(let-values ([(globs defns) (decompile-prefix prefix)]) ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let () `(let ()
,@defns ,@defns
,(decompile-form rhs globs '(#%globals) closed))))] ,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
[(struct seq (forms)) [(struct seq (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack closed)) (decompile-form form globs stack closed stx-ht))
forms))] forms))]
[(struct splice (forms)) [(struct splice (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack closed)) (decompile-form form globs stack closed stx-ht))
forms))] forms))]
[(struct req (reqs dummy)) [(struct req (reqs dummy))
`(#%require . (#%decode-syntax ,reqs))] `(#%require . (#%decode-syntax ,reqs))]