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?)) [(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack closed) `(set! ,(decompile-expr id globs stack closed)
,(decompile-expr rhs 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 ([id (list-ref/protect stack offset 'localref)])
(let ([e (if unbox? (let ([e (if unbox?
`(#%unbox ,id) `(#%unbox ,id)
id)]) id)])
(if clear? (if clear?
`(#%sfs-clear ,e) `(#%sfs-clear ,e)
e)))] (if flonum?
`(#%from-flonum ,e)
e))))]
[(? lam?) [(? lam?)
`(lambda . ,(decompile-lam expr globs stack closed))] `(lambda . ,(decompile-lam expr globs stack closed))]
[(struct case-lam (name lams)) [(struct case-lam (name lams))
@ -204,10 +206,13 @@
,@(map (lambda (lam) ,@(map (lambda (lam)
(decompile-lam lam globs stack closed)) (decompile-lam lam globs stack closed))
lams))] lams))]
[(struct let-one (rhs body)) [(struct let-one (rhs body flonum?))
(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) 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)))] ,(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)])

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

@ -133,14 +133,14 @@
(void)] (void)]
[(struct assign (id rhs undef-ok?)) [(struct assign (id rhs undef-ok?))
(traverse-expr rhs visit)] (traverse-expr rhs visit)]
[(struct localref (unbox? offset clear? other-clears?)) [(struct localref (unbox? offset clear? other-clears? flonum?))
(void)] (void)]
[(? lam?) [(? lam?)
(traverse-lam expr visit)] (traverse-lam expr visit)]
[(struct case-lam (name lams)) [(struct case-lam (name lams))
(traverse-data name visit) (traverse-data name visit)
(for-each (lambda (lam) (traverse-lam lam visit)) lams)] (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 rhs visit)
(traverse-expr body visit)] (traverse-expr body visit)]
[(struct let-void (count boxes? body)) [(struct let-void (count boxes? body))
@ -252,7 +252,7 @@
CPT_VECTOR CPT_VECTOR
CPT_HASH_TABLE CPT_HASH_TABLE
CPT_STX CPT_STX
CPT_GSTX CPT_LET_ONE_FLONUM
CPT_MARSHALLED CPT_MARSHALLED
CPT_QUOTE CPT_QUOTE
CPT_REFERENCE CPT_REFERENCE
@ -531,7 +531,7 @@
(out-syntax SET_EXPD (out-syntax SET_EXPD
(cons undef-ok? (cons id rhs)) (cons undef-ok? (cons id rhs))
out)] out)]
[(struct localref (unbox? offset clear? other-clears?)) [(struct localref (unbox? offset clear? other-clears? flonum?))
(if (and (not clear?) (not other-clears?) (if (and (not clear?) (not other-clears?)
(offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START)))
(out-byte (+ (if unbox? (out-byte (+ (if unbox?
@ -545,8 +545,13 @@
(out-number offset out) (out-number offset out)
(begin (begin
(out-number (- (add1 offset)) out) (out-number (- (add1 offset)) out)
(out-number (+ (if clear? #x1 0) (out-number (if clear?
(if other-clears? #x2 0)) #x1
(if other-clears?
#x2
(if flonum?
#x3
0)))
out)))))] out)))))]
[(? lam?) [(? lam?)
(out-lam expr out)] (out-lam expr out)]
@ -567,8 +572,8 @@
(cons (or name null) (cons (or name null)
lams) lams)
out)] out)]
[(struct let-one (rhs body)) [(struct let-one (rhs body flonum?))
(out-byte CPT_LET_ONE out) (out-byte (if flonum? CPT_LET_ONE_FLONUM CPT_LET_ONE) out)
(out-expr (protect-quote rhs) out) (out-expr (protect-quote rhs) out)
(out-expr (protect-quote body) out)] (out-expr (protect-quote body) out)]
[(struct let-void (count boxes? body)) [(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 (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 (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 (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 (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 (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 (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 (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) (define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
@ -410,7 +410,7 @@
[16 vector] [16 vector]
[17 hash-table] [17 hash-table]
[18 stx] [18 stx]
[19 gstx] ; unused [19 let-one-flonum]
[20 marshalled] [20 marshalled]
[21 quote] [21 quote]
[22 reference] [22 reference]
@ -491,9 +491,11 @@
(define (make-local unbox? pos flags) (define (make-local unbox? pos flags)
(define SCHEME_LOCAL_CLEAR_ON_READ #x01) (define SCHEME_LOCAL_CLEAR_ON_READ #x01)
(define SCHEME_LOCAL_OTHER_CLEARS #x02) (define SCHEME_LOCAL_OTHER_CLEARS #x02)
(define SCHEME_LOCAL_FLONUM #x03)
(make-localref unbox? pos (make-localref unbox? pos
(positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ)) (= flags SCHEME_LOCAL_CLEAR_ON_READ)
(positive? (bitwise-and flags SCHEME_LOCAL_OTHER_CLEARS)))) (= flags SCHEME_LOCAL_OTHER_CLEARS)
(= flags SCHEME_LOCAL_FLONUM)))
(define (a . << . b) (define (a . << . b)
(arithmetic-shift a b)) (arithmetic-shift a b))
@ -786,8 +788,9 @@
(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)))] (loop l ppr)))]
[(let-one) [(let-one let-one-flonum)
(make-let-one (read-compact cp) (read-compact cp))] (make-let-one (read-compact cp) (read-compact cp)
(eq? cpt-tag 'let-one-flonum))]
[(branch) [(branch)
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))] (make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
[(module-index) (module-path-index-join (read-compact cp) (read-compact cp))] [(module-index) (module-path-index-join (read-compact cp) (read-compact cp))]