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

expose safe-for-space clearing in decompilation

Browse Source 
svn: r11307

original commit: e611829b76
This commit is contained in:
Matthew Flatt 2008-08-18 22:34:38 +00:00
parent da32616652
commit 19a098a7fa
2 changed files with 21 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/compiler/decompile.ss
View File

@ -75,7 +75,7 @@
(if (null? stx-ids) null '(#%stx-array))
lift-ids)
(map (lambda (stx id)
`(define ,id (decode-stx ,(stx-encoded stx))))
`(define ,id (#%decode-syntax ,(stx-encoded stx))))
stxs stx-ids)))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
@ -174,11 +174,14 @@
[(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack)
,(decompile-expr rhs globs stack))]
[(struct localref (unbox? offset flags))
[(struct localref (unbox? offset clear?))
(let ([id (list-ref/protect stack offset)])
(if unbox?
`(#%unbox ,id)
id))]
(let ([e (if unbox?
`(#%unbox ,id)
id)])
(if clear?
`(#%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)])
@ -240,8 +243,8 @@
(decompile-expr rand globs stack))
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)
,(decompile-expr args-expr globs stack))]
[(struct sequence (exprs))
`(begin ,@(for/list ([expr (in-list exprs)])
(decompile-expr expr globs stack)))]
@ -254,7 +257,7 @@
,(decompile-expr val globs stack)
,(decompile-expr body globs stack))]
[(struct closure (lam gen-id))
`(CLOSED ,gen-id ,(decompile-expr lam globs stack))]
`(#%closed ,gen-id ,(decompile-expr lam globs stack))]
[(struct indirect (val))
(if (closure? val)
(closure-gen-id val)

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

@ -35,7 +35,7 @@
(define-form-struct let-rec (procs body)) ; put `letrec'-bound closures into existing stack slots
(define-form-struct boxenv (pos body)) ; box existing stack element
(define-form-struct localref (unbox? offset flags)) ; access local via stack
(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 topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
@ -408,6 +408,10 @@
[reader (get-reader type)])
(reader l)))
(define (make-local unbox? pos flags)
(define SCHEME_LOCAL_CLEAR_ON_READ #x01)
(make-localref unbox? pos (positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ))))
(define (a . << . b)
(arithmetic-shift a b))
@ -482,7 +486,7 @@
[flags (if (< p* 0)
(read-compact-number cp)
0)])
(make-localref #t p flags))]
(make-local #t p flags))]
[(path)
(let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))])
(if (relative-path? p)
@ -527,12 +531,12 @@
(let ([c (read-compact-number cp)]
[unbox? (eq? cpt-tag 'local-unbox)])
(if (negative? c)
(make-localref unbox? (- (add1 c)) (read-compact-number cp))
(make-localref unbox? c 0)))]
(make-local unbox? (- (add1 c)) (read-compact-number cp))
(make-local unbox? c 0)))]
[(small-local)
(make-localref #f (- ch cpt-start) 0)]
(make-local #f (- ch cpt-start) 0)]
[(small-local-unbox)
(make-localref #t (- ch cpt-start) 0)]
(make-local #t (- ch cpt-start) 0)]
[(small-symbol)
(let ([l (- ch cpt-start)])
(string->symbol (read-compact-chars cp l)))]