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

decompiler repairs

Browse Source 
svn: r12537

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

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

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