diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 2217060f65..5ba6948567 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -330,16 +330,14 @@ [(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? flonum?)) + [(struct localref (unbox? offset clear? other-clears? type)) (let ([id (list-ref/protect stack offset 'localref)]) (let ([e (if unbox? `(#%unbox ,id) id)]) (if clear? `(#%sfs-clear ,e) - (if flonum? - `(#%from-flonum ,e) - e))))] + e)))] [(? lam?) `(lambda . ,(decompile-lam expr globs stack closed))] [(struct case-lam (name lams)) @@ -347,13 +345,10 @@ ,@(map (lambda (lam) (decompile-lam lam globs stack closed)) lams))] - [(struct let-one (rhs body flonum? unused?)) + [(struct let-one (rhs body type unused?)) (let ([id (or (extract-id rhs) - (gensym (if unused? 'unused 'local)))]) - `(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)]) - (if flonum? - (list '#%as-flonum v) - v))]) + (gensym (or type (if unused? 'unused 'local))))]) + `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)]) ,(decompile-expr body globs (cons id stack) closed)))] [(struct let-void (count boxes? body)) (let ([ids (make-vector count #f)]) @@ -428,7 +423,10 @@ (let ([vars (for/list ([i (in-range num-params)] [type (in-list arg-types)]) (gensym (format "~a~a-" - (case type [(ref) "argbox"] [(flonum) "argfl"] [else "arg"]) + (case type + [(ref) "argbox"] + [(val) "arg"] + [else (format "arg~a" type)]) i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) @@ -444,8 +442,8 @@ ,@(if (null? captures) null `('(captures: ,@(map (lambda (c t) - (if (eq? t 'flonum) - `(flonum ,c) + (if t + `(,t ,c) c)) captures closure-types) @@ -465,70 +463,10 @@ closed)))])) (define (annotate-inline a) - (if (and (symbol? (car a)) - (case (length a) - [(2) (memq (car a) '(not null? pair? mpair? symbol? - syntax? char? boolean? - number? real? exact-integer? - fixnum? inexact-real? - procedure? vector? box? string? bytes? eof-object? - zero? negative? exact-nonnegative-integer? - exact-positive-integer? - car cdr caar cadr cdar cddr - mcar mcdr unbox vector-length syntax-e - add1 sub1 - abs bitwise-not - list list* vector vector-immutable box))] - [(3) (memq (car a) '(eq? = <= < >= > - bitwise-bit-set? char=? - + - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor - arithmetic-shift vector-ref string-ref bytes-ref - set-mcar! set-mcdr! cons mcons set-box! - list list* vector vector-immutable))] - [(4) (memq (car a) '(vector-set! string-set! bytes-set! - list list* vector vector-immutable - + - * / min max bitwise-and bitwise-ior bitwise-xor))] - [else (memq (car a) '(list list* vector vector-immutable - + - * / min max bitwise-and bitwise-ior bitwise-xor))])) - (cons '#%in a) - a)) + a) (define (annotate-unboxed args a) - (define (unboxable? e s) - (cond - [(localref? e) #t] - [(toplevel? e) #t] - [(eq? '#%flonum (car s)) #t] - [(not (expr? e)) #t] - [else #f])) - (if (and (symbol? (car a)) - (case (length a) - [(2) (memq (car a) '(flabs flsqrt ->fl - unsafe-flabs - unsafe-flsqrt - unsafe-fx->fl - flsin flcos fltan - flasin flacos flatan - flexp fllog - flfloor flceiling flround fltruncate - flmin flmax - unsafe-flmin unsafe-flmax))] - [(3) (memq (car a) '(fl+ fl- fl* fl/ - fl< fl> fl<= fl>= fl= - flvector-ref - unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/ - unsafe-fl< unsafe-fl> - unsafe-fl= - unsafe-fl<= unsafe-fl>= - unsafe-flvector-ref - unsafe-f64vector-ref))] - - [(4) (memq (car a) '(flvector-set! - unsafe-flvector-set! - unsafe-f64vector-set!))] - [else #f]) - (andmap unboxable? args (cdr a))) - (cons '#%flonum a) - a)) + a) ;; ---------------------------------------- diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index b9e1333a99..d3cc61ce3f 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -725,7 +725,7 @@ (out-marshaled set-bang-type-num (cons undef-ok? (cons id rhs)) out)] - [(struct localref (unbox? offset clear? other-clears? flonum?)) + [(struct localref (unbox? offset clear? other-clears? type)) (if (and (not clear?) (not other-clears?) (not flonum?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) (out-byte (+ (if unbox? @@ -735,17 +735,16 @@ out) (begin (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) - (if (not (or clear? other-clears? flonum?)) + (if (not (or clear? other-clears? type)) (out-number offset out) (begin (out-number (- (add1 offset)) out) - (out-number (if clear? - #x1 - (if other-clears? - #x2 - (if flonum? - #x3 - 0))) + (out-number (cond + [clear? 1] + [other-clears? 2] + [else (+ 2 (case type + [(flonum) 1] + [(fixnum) 2]))]) out)))))] [(? lam?) (out-lam v out)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 18e7426b01..63b964fb19 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -88,6 +88,7 @@ (define CLOS_IS_METHOD 16) (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) + (define BITS_PER_ARG 4) (match v [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) @@ -95,31 +96,32 @@ (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (values (vector-length v) v rest) (values v (car rest) (cdr rest)))] - [(check-bit) (lambda (i) + [(get-flags) (lambda (i) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) 0 (let ([byte (vector-ref closed-over - (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) - (+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) - 1 - 0) - (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) - 2 - 0)))))] + (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))]) + (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT))) + (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))] + [(num->type) (lambda (n) + (case n + [(2) 'flonum] + [(3) 'fixnum] + [else (error "invaid type flag")]))] [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) (for/list ([i (in-range num-params)]) - (case (check-bit i) + (define v (get-flags i)) + (case v [(0) 'val] [(1) 'ref] - [(2) 'flonum] - [else (error "both 'ref and 'flonum argument?")])))] + [else (num->type v)])))] [(closure-types) (for/list ([i (in-range closure-size)] [j (in-naturals num-params)]) - (case (check-bit j) + (define v (get-flags j)) + (case v [(0) 'val/ref] [(1) (error "invalid 'ref closure variable")] - [(2) 'flonum] - [else (error "both 'ref and 'flonum closure var?")]))]) + [else (num->type v)]))]) (make-lam name (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) @@ -467,7 +469,7 @@ [16 vector] [17 hash-table] [18 stx] - [19 let-one-flonum] + [19 let-one-typed] [20 marshalled] [21 quote] [22 reference] @@ -550,14 +552,21 @@ [reader (get-reader type)]) (reader l))) +(define SCHEME_LOCAL_TYPE_FLONUM 1) +(define SCHEME_LOCAL_TYPE_FIXNUM 2) + (define (make-local unbox? pos flags) - (define SCHEME_LOCAL_CLEAR_ON_READ #x01) - (define SCHEME_LOCAL_OTHER_CLEARS #x02) - (define SCHEME_LOCAL_FLONUM #x03) + (define SCHEME_LOCAL_CLEAR_ON_READ 1) + (define SCHEME_LOCAL_OTHER_CLEARS 2) + (define SCHEME_LOCAL_TYPE_OFFSET 2) (make-localref unbox? pos (= flags SCHEME_LOCAL_CLEAR_ON_READ) (= flags SCHEME_LOCAL_OTHER_CLEARS) - (= flags SCHEME_LOCAL_FLONUM))) + (let ([t (- flags SCHEME_LOCAL_TYPE_OFFSET)]) + (cond + [(= t SCHEME_LOCAL_TYPE_FLONUM) 'flonum] + [(= t SCHEME_LOCAL_TYPE_FIXNUM) 'fixnum] + [else #f])))) (define (a . << . b) (arithmetic-shift a b)) @@ -841,9 +850,13 @@ (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) (loop l ppr)))] - [(let-one let-one-flonum let-one-unused) + [(let-one let-one-typed let-one-unused) (make-let-one (read-compact cp) (read-compact cp) - (eq? cpt-tag 'let-one-flonum) + (and (eq? cpt-tag 'let-one-typed) + (case (read-compact-number cp) + [(1) 'flonum] + [(2) 'fixnum] + [else #f])) (eq? cpt-tag 'let-one-unused))] [(branch) (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index a2aa9c284b..bdac336473 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -146,17 +146,20 @@ [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used 'sfs-clear-rest-args))] [num-params exact-nonnegative-integer?] - [param-types (listof (or/c 'val 'ref 'flonum))] + [param-types (listof (or/c 'val 'ref 'flonum 'fixnum))] [rest? boolean?] [closure-map (vectorof exact-nonnegative-integer?)] - [closure-types (listof (or/c 'val/ref 'flonum))] + [closure-types (listof (or/c 'val/ref 'flonum 'fixnum))] [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))] [max-let-depth exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; `lambda' (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over) (define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? closure?))])) -(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack +(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] ; pushes one value onto stack + [body (or/c expr? seq? any/c)] + [type (or/c #f 'flonum 'fixnum)] + [unused? boolean?])) (define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots (define-form-struct (install-value expr) ([count exact-nonnegative-integer?] [pos exact-nonnegative-integer?] @@ -166,7 +169,11 @@ (define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? any/c)])) ; put `letrec'-bound closures into existing stack slots (define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; box existing stack element -(define-form-struct (localref expr) ([unbox? boolean?] [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] [flonum? boolean?])) ; access local via stack +(define-form-struct (localref expr) ([unbox? boolean?] + [pos exact-nonnegative-integer?] + [clear? boolean?] + [other-clears? boolean?] + [type (or/c #f 'flonum 'fixnum)])) ; access local via stack (define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack)