From 5e49e0adea49996ad67a405ed6fecd6d16ea7111 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 7 Jul 2011 14:47:19 -0600 Subject: [PATCH] improve decompiler handling of syntax object --- collects/compiler/decompile.rkt | 105 +++++++++++++++++++++++++------- 1 file changed, 84 insertions(+), 21 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 7e4586ef1b..f6831c0900 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -47,15 +47,16 @@ ;; Main entry: (define (decompile top) - (match top - [(struct compilation-top (max-let-depth prefix form)) - (let-values ([(globs defns) (decompile-prefix prefix)]) - `(begin - ,@defns - ,(decompile-form form globs '(#%globals) (make-hasheq))))] - [else (error 'decompile "unrecognized: ~e" top)])) + (let ([stx-ht (make-hasheq)]) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) + `(begin + ,@defns + ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht)))] + [else (error 'decompile "unrecognized: ~e" top)]))) -(define (decompile-prefix a-prefix) +(define (decompile-prefix a-prefix stx-ht) (match a-prefix [(struct prefix (num-lifts toplevels stxs)) (let ([lift-ids (for/list ([i (in-range num-lifts)]) @@ -89,37 +90,99 @@ num-lifts) (map (lambda (stx id) `(define ,id ,(if stx - `(#%decode-syntax ,(stx-encoded stx)) + `(#%decode-syntax + ,(decompile-stx (stx-encoded stx) stx-ht)) #f))) stxs stx-ids)))] [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) (cond [(symbol? modidx) modidx] [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 [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported 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)] [(closed) (make-hasheq)]) `(module ,name .... ,@defns ,@(map (lambda (form) - (decompile-form form globs stack closed)) + (decompile-form form globs stack closed stx-ht)) syntax-body) ,@(map (lambda (form) - (decompile-form form globs stack closed)) + (decompile-form form globs stack closed stx-ht)) body)))] [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 [(? mod?) - (decompile-module form stack)] + (decompile-module form stack stx-ht)] [(struct def-values (ids rhs)) `(define-values ,(map (lambda (tl) (match tl @@ -129,23 +192,23 @@ ,(decompile-expr rhs globs stack closed))] [(struct def-syntaxes (ids rhs prefix max-let-depth)) `(define-syntaxes ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix)]) + ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) `(let () ,@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)) `(define-values-for-syntax ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix)]) + ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) `(let () ,@defns - ,(decompile-form rhs globs '(#%globals) closed))))] + ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] [(struct seq (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack closed)) + (decompile-form form globs stack closed stx-ht)) forms))] [(struct splice (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack closed)) + (decompile-form form globs stack closed stx-ht)) forms))] [(struct req (reqs dummy)) `(#%require . (#%decode-syntax ,reqs))]