diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 75f2d7216a..15461c8866 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -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)]) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 5c0a17db8e..49669966a9 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -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)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 26b995b618..61cecff581 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -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))]