From d003549257e7032de552d88741f4c04c549bf9a4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 14 Nov 2012 10:03:07 -0700 Subject: [PATCH] bytecode compiler: generalize local-type tracking for unboxing Track fixnum results in the same way as flonum results to enable unboxing, if that turns out to be useful. The intent of the change, though, is to support other types in the future, such as "extnums". The output `raco decompile' no longer includes `#%in', `#%flonum', etc., annotations, which are mostly obvious and difficult to keep in sync with the implementation. A local-binding name now reflects a known type, however. The change includes a bug repair for he bytecode compiler that is independent of the generalization (i.e., the new test case triggered the old problem using flonums). original commit: bdf1c3e16548fa4c5b1b5cff37973477df271994 --- collects/compiler/decompile.rkt | 88 +++++--------------------------- collects/compiler/zo-marshal.rkt | 17 +++--- collects/compiler/zo-parse.rkt | 55 ++++++++++++-------- collects/compiler/zo-structs.rkt | 15 ++++-- 4 files changed, 66 insertions(+), 109 deletions(-) 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)