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
This commit is contained in:
Matthew Flatt 2008-08-18 22:34:38 +00:00
parent 6a0a40773b
commit e611829b76
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)) (if (null? stx-ids) null '(#%stx-array))
lift-ids) lift-ids)
(map (lambda (stx id) (map (lambda (stx id)
`(define ,id (decode-stx ,(stx-encoded stx)))) `(define ,id (#%decode-syntax ,(stx-encoded stx))))
stxs stx-ids)))] stxs stx-ids)))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)])) [else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
@ -174,11 +174,14 @@
[(struct assign (id rhs undef-ok?)) [(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack) `(set! ,(decompile-expr id globs stack)
,(decompile-expr rhs globs stack))] ,(decompile-expr rhs globs stack))]
[(struct localref (unbox? offset flags)) [(struct localref (unbox? offset clear?))
(let ([id (list-ref/protect stack offset)]) (let ([id (list-ref/protect stack offset)])
(if unbox? (let ([e (if unbox?
`(#%unbox ,id) `(#%unbox ,id)
id))] id)])
(if clear?
`(#%sfs-clear ,e)
e)))]
[(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)]) (gensym 'arg))] (let ([vars (for/list ([i (in-range num-params)]) (gensym 'arg))]
[rest-vars (if rest? (list (gensym 'rest)) null)]) [rest-vars (if rest? (list (gensym 'rest)) null)])
@ -240,8 +243,8 @@
(decompile-expr rand globs stack)) (decompile-expr rand globs stack))
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)
,(decompile-expr args-expr globs stack))] ,(decompile-expr args-expr globs stack))]
[(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)))]
@ -254,7 +257,7 @@
,(decompile-expr val globs stack) ,(decompile-expr val globs stack)
,(decompile-expr body globs stack))] ,(decompile-expr body globs stack))]
[(struct closure (lam gen-id)) [(struct closure (lam gen-id))
`(CLOSED ,gen-id ,(decompile-expr lam globs stack))] `(#%closed ,gen-id ,(decompile-expr lam globs stack))]
[(struct indirect (val)) [(struct indirect (val))
(if (closure? val) (if (closure? val)
(closure-gen-id 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 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 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 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) (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 (get-reader type)])
(reader l))) (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) (define (a . << . b)
(arithmetic-shift a b)) (arithmetic-shift a b))
@ -482,7 +486,7 @@
[flags (if (< p* 0) [flags (if (< p* 0)
(read-compact-number cp) (read-compact-number cp)
0)]) 0)])
(make-localref #t p flags))] (make-local #t p flags))]
[(path) [(path)
(let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))]) (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))])
(if (relative-path? p) (if (relative-path? p)
@ -527,12 +531,12 @@
(let ([c (read-compact-number cp)] (let ([c (read-compact-number cp)]
[unbox? (eq? cpt-tag 'local-unbox)]) [unbox? (eq? cpt-tag 'local-unbox)])
(if (negative? c) (if (negative? c)
(make-localref unbox? (- (add1 c)) (read-compact-number cp)) (make-local unbox? (- (add1 c)) (read-compact-number cp))
(make-localref unbox? c 0)))] (make-local unbox? c 0)))]
[(small-local) [(small-local)
(make-localref #f (- ch cpt-start) 0)] (make-local #f (- ch cpt-start) 0)]
[(small-local-unbox) [(small-local-unbox)
(make-localref #t (- ch cpt-start) 0)] (make-local #t (- ch cpt-start) 0)]
[(small-symbol) [(small-symbol)
(let ([l (- ch cpt-start)]) (let ([l (- ch cpt-start)])
(string->symbol (read-compact-chars cp l)))] (string->symbol (read-compact-chars cp l)))]