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

unboxing of let-bound flonums (v4.2.3.6)

Browse Source 
svn: r17328

original commit: 45e84ca087
This commit is contained in:
Matthew Flatt 2009-12-16 13:30:40 +00:00
parent e489b59124
commit 66b8a274d7
3 changed files with 32 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/compiler/decompile.ss
View File

@ -189,14 +189,16 @@
[(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack closed)
,(decompile-expr rhs globs stack closed))]
[(struct localref (unbox? offset clear? other-clears?))
[(struct localref (unbox? offset clear? other-clears? flonum?))
(let ([id (list-ref/protect stack offset 'localref)])
(let ([e (if unbox?
`(#%unbox ,id)
id)])
(if clear?
`(#%sfs-clear ,e)
e)))]
(if flonum?
`(#%from-flonum ,e)
e))))]
[(? lam?)
`(lambda . ,(decompile-lam expr globs stack closed))]
[(struct case-lam (name lams))
@ -204,10 +206,13 @@
,@(map (lambda (lam)
(decompile-lam lam globs stack closed))
lams))]
[(struct let-one (rhs body))
[(struct let-one (rhs body flonum?))
(let ([id (or (extract-id rhs)
(gensym 'local))])
`(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
`(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)])
(if flonum?
(list '#%as-flonum v)
v))])
,(decompile-expr body globs (cons id stack) closed)))]
[(struct let-void (count boxes? body))
(let ([ids (make-vector count #f)])

21
collects/compiler/zo-marshal.ss
View File

@ -133,14 +133,14 @@
(void)]
[(struct assign (id rhs undef-ok?))
(traverse-expr rhs visit)]
[(struct localref (unbox? offset clear? other-clears?))
[(struct localref (unbox? offset clear? other-clears? flonum?))
(void)]
[(? lam?)
(traverse-lam expr visit)]
[(struct case-lam (name lams))
(traverse-data name visit)
(for-each (lambda (lam) (traverse-lam lam visit)) lams)]
[(struct let-one (rhs body))
[(struct let-one (rhs body flonum?))
(traverse-expr rhs visit)
(traverse-expr body visit)]
[(struct let-void (count boxes? body))
@ -252,7 +252,7 @@
CPT_VECTOR
CPT_HASH_TABLE
CPT_STX
CPT_GSTX
CPT_LET_ONE_FLONUM
CPT_MARSHALLED
CPT_QUOTE
CPT_REFERENCE
@ -531,7 +531,7 @@
(out-syntax SET_EXPD
(cons undef-ok? (cons id rhs))
out)]
[(struct localref (unbox? offset clear? other-clears?))
[(struct localref (unbox? offset clear? other-clears? flonum?))
(if (and (not clear?) (not other-clears?)
(offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START)))
(out-byte (+ (if unbox?
@ -545,8 +545,13 @@
(out-number offset out)
(begin
(out-number (- (add1 offset)) out)
(out-number (+ (if clear? #x1 0)
(if other-clears? #x2 0))
(out-number (if clear?
#x1
(if other-clears?
#x2
(if flonum?
#x3
0)))
out)))))]
[(? lam?)
(out-lam expr out)]
@ -567,8 +572,8 @@
(cons (or name null)
lams)
out)]
[(struct let-one (rhs body))
(out-byte CPT_LET_ONE out)
[(struct let-one (rhs body flonum?))
(out-byte (if flonum? CPT_LET_ONE_FLONUM CPT_LET_ONE) out)
(out-expr (protect-quote rhs) out)
(out-expr (protect-quote body) out)]
[(struct let-void (count boxes? body))

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

@ -41,13 +41,13 @@
(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over)
(define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam
(define-form-struct (let-one expr) (rhs body)) ; pushes one value onto stack
(define-form-struct (let-one expr) (rhs body flonum?)) ; pushes one value onto stack
(define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots
(define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s)
(define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots
(define-form-struct (boxenv expr) (pos body)) ; box existing stack element
(define-form-struct (localref expr) (unbox? pos clear? other-clears?)) ; access local via stack
(define-form-struct (localref expr) (unbox? pos clear? other-clears? flonum?)) ; access local via stack
(define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack)
(define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
@ -410,7 +410,7 @@
[16 vector]
[17 hash-table]
[18 stx]
[19 gstx] ; unused
[19 let-one-flonum]
[20 marshalled]
[21 quote]
[22 reference]
@ -491,9 +491,11 @@
(define (make-local unbox? pos flags)
(define SCHEME_LOCAL_CLEAR_ON_READ #x01)
(define SCHEME_LOCAL_OTHER_CLEARS #x02)
(define SCHEME_LOCAL_FLONUM #x03)
(make-localref unbox? pos
(positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ))
(positive? (bitwise-and flags SCHEME_LOCAL_OTHER_CLEARS))))
(= flags SCHEME_LOCAL_CLEAR_ON_READ)
(= flags SCHEME_LOCAL_OTHER_CLEARS)
(= flags SCHEME_LOCAL_FLONUM)))
(define (a . << . b)
(arithmetic-shift a b))
@ -786,8 +788,9 @@
(if ppr null (read-compact cp)))
(read-compact-list l ppr cp))
(loop l ppr)))]
[(let-one)
(make-let-one (read-compact cp) (read-compact cp))]
[(let-one let-one-flonum)
(make-let-one (read-compact cp) (read-compact cp)
(eq? cpt-tag 'let-one-flonum))]
[(branch)
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
[(module-index) (module-path-index-join (read-compact cp) (read-compact cp))]