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

decompiler repairs

Browse Source 
svn: r12537
This commit is contained in:
Matthew Flatt 2008-11-20 13:47:06 +00:00
parent ed8cd4b37f
commit 1a4b3abba7
2 changed files with 75 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/compiler/decompile.ss
View File

@ -28,12 +28,12 @@
(hash-set! table n (car b))))) (hash-set! table n (car b)))))
table)) table))
(define (list-ref/protect l pos) (define (list-ref/protect l pos who)
(list-ref l pos) (list-ref l pos)
#; #;
(if (pos . < . (length l)) (if (pos . < . (length l))
(list-ref l pos) (list-ref l pos)
`(OUT-OF-BOUNDS ,pos ,l))) `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l)))
;; ---------------------------------------- ;; ----------------------------------------
@ -44,7 +44,7 @@
(let-values ([(globs defns) (decompile-prefix prefix)]) (let-values ([(globs defns) (decompile-prefix prefix)])
`(begin `(begin
,@defns ,@defns
,(decompile-form form globs '(#%globals))))] ,(decompile-form form globs '(#%globals) (make-hasheq))))]
[else (error 'decompile "unrecognized: ~e" top)])) [else (error 'decompile "unrecognized: ~e" top)]))
(define (decompile-prefix a-prefix) (define (decompile-prefix a-prefix)
@ -76,7 +76,7 @@
lift-ids) lift-ids)
(map (lambda (stx id) (map (lambda (stx id)
`(define ,id ,(if stx `(define ,id ,(if stx
`(#%decode-syntax ,(stx-encoded stx)) `(#%decode-syntax ,stx #;(stx-encoded stx))
#f))) #f)))
stxs stx-ids)))] stxs stx-ids)))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)])) [else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
@ -90,18 +90,19 @@
(match mod-form (match mod-form
[(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
(let-values ([(globs defns) (decompile-prefix prefix)] (let-values ([(globs defns) (decompile-prefix prefix)]
[(stack) (append '(#%modvars) stack)]) [(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)])
`(module ,name .... `(module ,name ....
,@defns ,@defns
,@(map (lambda (form) ,@(map (lambda (form)
(decompile-form form globs stack)) (decompile-form form globs stack closed))
syntax-body) syntax-body)
,@(map (lambda (form) ,@(map (lambda (form)
(decompile-form form globs stack)) (decompile-form form globs stack closed))
body)))] body)))]
[else (error 'decompile-module "huh?: ~e" mod-form)])) [else (error 'decompile-module "huh?: ~e" mod-form)]))
(define (decompile-form form globs stack) (define (decompile-form form globs stack closed)
(match form (match form
[(? mod?) [(? mod?)
(decompile-module form stack)] (decompile-module form stack)]
@ -109,31 +110,31 @@
`(define-values ,(map (lambda (tl) `(define-values ,(map (lambda (tl)
(match tl (match tl
[(struct toplevel (depth pos const? mutated?)) [(struct toplevel (depth pos const? mutated?))
(list-ref/protect globs pos)])) (list-ref/protect globs pos 'def-vals)]))
ids) ids)
,(decompile-expr rhs globs stack))] ,(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)])
`(let () `(let ()
,@defns ,@defns
,(decompile-form rhs globs '(#%globals)))))] ,(decompile-form rhs globs '(#%globals) closed))))]
[(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)])
`(let () `(let ()
,@defns ,@defns
,(decompile-expr rhs globs '(#%globals)))))] ,(decompile-expr rhs globs '(#%globals) closed))))]
[(struct sequence (forms)) [(struct sequence (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack)) (decompile-form form globs stack closed))
forms))] forms))]
[(struct splice (forms)) [(struct splice (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack)) (decompile-form form globs stack closed))
forms))] forms))]
[else [else
(decompile-expr form globs stack)])) (decompile-expr form globs stack closed)]))
(define (extract-name name) (define (extract-name name)
(if (symbol? name) (if (symbol? name)
@ -168,22 +169,22 @@
(extract-ids! body ids)] (extract-ids! body ids)]
[else #f])) [else #f]))
(define (decompile-expr expr globs stack) (define (decompile-expr expr globs stack closed)
(match expr (match expr
[(struct toplevel (depth pos const? mutated?)) [(struct toplevel (depth pos const? mutated?))
(let ([id (list-ref/protect globs pos)]) (let ([id (list-ref/protect globs pos 'toplevel)])
(if const? (if const?
id id
`(#%checked ,id)))] `(#%checked ,id)))]
[(struct topsyntax (depth pos midpt)) [(struct topsyntax (depth pos midpt))
(list-ref/protect globs (+ midpt pos))] (list-ref/protect globs (+ midpt pos) 'topsyntax)]
[(struct primitive (id)) [(struct primitive (id))
(hash-ref primitive-table id)] (hash-ref primitive-table id)]
[(struct assign (id rhs undef-ok?)) [(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack) `(set! ,(decompile-expr id globs stack closed)
,(decompile-expr rhs globs stack))] ,(decompile-expr rhs globs stack closed))]
[(struct localref (unbox? offset clear?)) [(struct localref (unbox? offset clear?))
(let ([id (list-ref/protect stack offset)]) (let ([id (list-ref/protect stack offset 'localref)])
(let ([e (if unbox? (let ([e (if unbox?
`(#%unbox ,id) `(#%unbox ,id)
id)]) id)])
@ -191,17 +192,17 @@
`(#%sfs-clear ,e) `(#%sfs-clear ,e)
e)))] e)))]
[(? lam?) [(? lam?)
`(lambda . ,(decompile-lam expr globs stack))] `(lambda . ,(decompile-lam expr globs stack closed))]
[(struct case-lam (name lams)) [(struct case-lam (name lams))
`(case-lambda `(case-lambda
,@(map (lambda (lam) ,@(map (lambda (lam)
(decompile-lam lam globs stack)) (decompile-lam lam globs stack closed))
lams))] lams))]
[(struct let-one (rhs body)) [(struct let-one (rhs body))
(let ([id (or (extract-id rhs) (let ([id (or (extract-id rhs)
(gensym 'local))]) (gensym 'local))])
`(let ([,id ,(decompile-expr rhs globs (cons id stack))]) `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
,(decompile-expr body globs (cons id stack))))] ,(decompile-expr body globs (cons id stack) closed)))]
[(struct let-void (count boxes? body)) [(struct let-void (count boxes? body))
(let ([ids (make-vector count #f)]) (let ([ids (make-vector count #f)])
(extract-ids! body ids) (extract-ids! body ids)
@ -210,71 +211,76 @@
(or id (gensym 'localv)))]) (or id (gensym 'localv)))])
`(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)]) `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
vars) vars)
,(decompile-expr body globs (append vars stack)))))] ,(decompile-expr body globs (append vars stack) closed))))]
[(struct let-rec (procs body)) [(struct let-rec (procs body))
`(begin `(begin
(#%set!-rec-values ,(for/list ([p (in-list procs)] (#%set!-rec-values ,(for/list ([p (in-list procs)]
[i (in-naturals)]) [i (in-naturals)])
(list-ref/protect stack i)) (list-ref/protect stack i 'let-rec))
,@(map (lambda (proc) ,@(map (lambda (proc)
(decompile-expr proc globs stack)) (decompile-expr proc globs stack closed))
procs)) procs))
,(decompile-expr body globs stack))] ,(decompile-expr body globs stack closed))]
[(struct install-value (count pos boxes? rhs body)) [(struct install-value (count pos boxes? rhs body))
`(begin `(begin
(,(if boxes? '#%set-boxes! 'set!-values) (,(if boxes? '#%set-boxes! 'set!-values)
,(for/list ([i (in-range count)]) ,(for/list ([i (in-range count)])
(list-ref/protect stack (+ i pos))) (list-ref/protect stack (+ i pos) 'install-value))
,(decompile-expr rhs globs stack)) ,(decompile-expr rhs globs stack closed))
,(decompile-expr body globs stack))] ,(decompile-expr body globs stack closed))]
[(struct boxenv (pos body)) [(struct boxenv (pos body))
(let ([id (list-ref/protect stack pos)]) (let ([id (list-ref/protect stack pos 'boxenv)])
`(begin `(begin
(set! ,id (#%box ,id)) (set! ,id (#%box ,id))
,(decompile-expr body globs stack)))] ,(decompile-expr body globs stack closed)))]
[(struct branch (test then else)) [(struct branch (test then else))
`(if ,(decompile-expr test globs stack) `(if ,(decompile-expr test globs stack closed)
,(decompile-expr then globs stack) ,(decompile-expr then globs stack closed)
,(decompile-expr else globs stack))] ,(decompile-expr else globs stack closed))]
[(struct application (rator rands)) [(struct application (rator rands))
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
stack)]) stack)])
(annotate-inline (annotate-inline
`(,(decompile-expr rator globs stack) `(,(decompile-expr rator globs stack closed)
,@(map (lambda (rand) ,@(map (lambda (rand)
(decompile-expr rand globs stack)) (decompile-expr rand globs stack closed))
rands))))] rands))))]
[(struct apply-values (proc args-expr)) [(struct apply-values (proc args-expr))
`(#%apply-values ,(decompile-expr proc globs stack) `(#%apply-values ,(decompile-expr proc globs stack closed)
,(decompile-expr args-expr globs stack))] ,(decompile-expr args-expr globs stack closed))]
[(struct sequence (exprs)) [(struct sequence (exprs))
`(begin ,@(for/list ([expr (in-list exprs)]) `(begin ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack)))] (decompile-expr expr globs stack closed)))]
[(struct beg0 (exprs)) [(struct beg0 (exprs))
`(begin0 ,@(for/list ([expr (in-list exprs)]) `(begin0 ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack)))] (decompile-expr expr globs stack closed)))]
[(struct with-cont-mark (key val body)) [(struct with-cont-mark (key val body))
`(with-continuation-mark `(with-continuation-mark
,(decompile-expr key globs stack) ,(decompile-expr key globs stack closed)
,(decompile-expr val globs stack) ,(decompile-expr val globs stack closed)
,(decompile-expr body globs stack))] ,(decompile-expr body globs stack closed))]
[(struct closure (lam gen-id)) [(struct closure (lam gen-id))
`(#%closed ,gen-id ,(decompile-expr lam globs stack))] (if (hash-ref closed gen-id #f)
gen-id
(begin
(hash-set! closed gen-id #t)
`(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
[(struct indirect (val)) [(struct indirect (val))
(if (closure? val) (if (closure? val)
(closure-gen-id val) (decompile-expr val globs stack closed)
'???)] '???)]
[else `(quote ,expr)])) [else `(quote ,expr)]))
(define (decompile-lam expr globs stack) (define (decompile-lam expr globs stack closed)
(match expr (match expr
[(struct closure (lam gen-id)) (decompile-lam lam globs stack)] [(struct indirect (val)) (decompile-lam val globs stack closed)]
[(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
[(struct lam (name flags num-params rest? closure-map max-let-depth body)) [(struct lam (name flags num-params rest? closure-map max-let-depth body))
(let ([vars (for/list ([i (in-range num-params)]) (let ([vars (for/list ([i (in-range num-params)])
(gensym (format "arg~a-" i)))] (gensym (format "arg~a-" i)))]
[rest-vars (if rest? (list (gensym 'rest)) null)] [rest-vars (if rest? (list (gensym 'rest)) null)]
[captures (map (lambda (v) [captures (map (lambda (v)
(list-ref/protect stack v)) (list-ref/protect stack v 'lam))
(vector->list closure-map))]) (vector->list closure-map))])
`((,@vars . ,(if rest? `((,@vars . ,(if rest?
(car rest-vars) (car rest-vars)
@ -285,8 +291,10 @@
,@(if (null? captures) ,@(if (null? captures)
null null
`('(captures: ,@captures))) `('(captures: ,@captures)))
,(decompile-expr body globs (append captures ,(decompile-expr body globs
(append vars rest-vars)))))])) (append captures
(append vars rest-vars))
closed)))]))
(define (annotate-inline a) (define (annotate-inline a)
(if (and (symbol? (car a)) (if (and (symbol? (car a))
@ -301,16 +309,16 @@
car cdr caar cadr cdar cddr car cdr caar cadr cdar cddr
mcar mcdr unbox vector-length syntax-e mcar mcdr unbox vector-length syntax-e
add1 sub1 - abs bitwise-not add1 sub1 - abs bitwise-not
list vector box))] list list* vector vector-immutable box))]
[(3) (memq (car a) '(eq? = <= < >= > [(3) (memq (car a) '(eq? = <= < >= >
bitwise-bit-set? char=? bitwise-bit-set? char=?
+ - * / min max bitwise-and bitwise-ior + - * / min max bitwise-and bitwise-ior
arithmetic-shift vector-ref string-ref bytes-ref arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons set-mcar! set-mcdr! cons mcons
list vector))] list list* vector vector-immutable))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set! [(4) (memq (car a) '(vector-set! string-set! bytes-set!
list vector))] list list* vector vector-immutable))]
[else (memq (car a) '(list vector))])) [else (memq (car a) '(list list* vector vector-immutable))]))
(cons '#%in a) (cons '#%in a)
a)) a))

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

@ -661,7 +661,7 @@
;; Main parsing loop ;; Main parsing loop
(define (read-compact cp) (define (read-compact cp)
(let loop ([need-car 0] [proper #f] [last #f] [first #f]) (let loop ([need-car 0] [proper #f])
(begin-with-definitions (begin-with-definitions
(define ch (cp-getc cp)) (define ch (cp-getc cp))
(define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)]) (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)])
@ -707,7 +707,7 @@
(cons (read-compact cp) (cons (read-compact cp)
(if ppr null (read-compact cp))) (if ppr null (read-compact cp)))
(read-compact-list l ppr cp)) (read-compact-list l ppr cp))
(loop l ppr last first)))] (loop l ppr)))]
[(let-one) [(let-one)
(make-let-one (read-compact cp) (read-compact cp))] (make-let-one (read-compact cp) (read-compact cp))]
[(branch) [(branch)
@ -747,7 +747,9 @@
(read-compact cp))]) (read-compact cp))])
(vector->immutable-vector (list->vector lst)))] (vector->immutable-vector (list->vector lst)))]
[(list) (let* ([n (read-compact-number cp)]) [(list) (let* ([n (read-compact-number cp)])
(append
(for/list ([i (in-range n)]) (for/list ([i (in-range n)])
(read-compact cp))
(read-compact cp)))] (read-compact cp)))]
[(prefab) [(prefab)
(let ([v (read-compact cp)]) (let ([v (read-compact cp)])
@ -845,9 +847,8 @@
[(symbol? s) s] [(symbol? s) s]
[(vector? s) (vector-ref s 0)] [(vector? s) (vector-ref s 0)]
[else 'closure]))))]) [else 'closure]))))])
(vector-set! (cport-symtab cp) l cl)
(set-indirect-v! ind cl) (set-indirect-v! ind cl)
cl))] ind))]
[(svector) [(svector)
(read-compact-svector cp (read-compact-number cp))] (read-compact-svector cp (read-compact-number cp))]
[(small-svector) [(small-svector)
@ -858,7 +859,7 @@
[(and proper (= need-car 1)) [(and proper (= need-car 1))
(cons v null)] (cons v null)]
[else [else
(cons v (loop (sub1 need-car) proper last first))])))) (cons v (loop (sub1 need-car) proper))]))))
;; path -> bytes ;; path -> bytes
;; implementes read.c:read_compiled ;; implementes read.c:read_compiled
@ -898,11 +899,13 @@
(define symtab (make-vector symtabsize (make-not-ready))) (define symtab (make-vector symtabsize (make-not-ready)))
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
(for/list ([i (in-range 1 symtabsize)]) (for/list ([i (in-range 1 symtabsize)])
(when (not-ready? (vector-ref symtab i)) (when (not-ready? (vector-ref symtab i))
(set-cport-pos! cp (vector-ref so* (sub1 i))) (set-cport-pos! cp (vector-ref so* (sub1 i)))
(let ([v (read-compact cp)]) (let ([v (read-compact cp)])
(vector-set! symtab i v)))) (vector-set! symtab i v))))
(set-cport-pos! cp shared-size) (set-cport-pos! cp shared-size)
(read-marshalled 'compilation-top-type cp))) (read-marshalled 'compilation-top-type cp)))