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

bytecode compiler: generalize local-type tracking for unboxing

Browse Source 
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: bdf1c3e165
This commit is contained in:
Matthew Flatt 2012-11-14 10:03:07 -07:00
parent 85715ca473
commit d003549257
4 changed files with 66 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/compiler/decompile.rkt
View File

@ -330,16 +330,14 @@
[(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? flonum?)) [(struct localref (unbox? offset clear? other-clears? type))
(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)
(if flonum? e)))]
`(#%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))
@ -347,13 +345,10 @@
,@(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 flonum? unused?)) [(struct let-one (rhs body type unused?))
(let ([id (or (extract-id rhs) (let ([id (or (extract-id rhs)
(gensym (if unused? 'unused 'local)))]) (gensym (or type (if unused? 'unused 'local))))])
`(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)]) `(let ([,id ,(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)])
@ -428,7 +423,10 @@
(let ([vars (for/list ([i (in-range num-params)] (let ([vars (for/list ([i (in-range num-params)]
[type (in-list arg-types)]) [type (in-list arg-types)])
(gensym (format "~a~a-" (gensym (format "~a~a-"
(case type [(ref) "argbox"] [(flonum) "argfl"] [else "arg"]) (case type
[(ref) "argbox"]
[(val) "arg"]
[else (format "arg~a" type)])
i)))] i)))]
[rest-vars (if rest? (list (gensym 'rest)) null)] [rest-vars (if rest? (list (gensym 'rest)) null)]
[captures (map (lambda (v) [captures (map (lambda (v)
@ -444,8 +442,8 @@
,@(if (null? captures) ,@(if (null? captures)
null null
`('(captures: ,@(map (lambda (c t) `('(captures: ,@(map (lambda (c t)
(if (eq? t 'flonum) (if t
`(flonum ,c) `(,t ,c)
c)) c))
captures captures
closure-types) closure-types)
@ -465,70 +463,10 @@
closed)))])) closed)))]))
(define (annotate-inline a) (define (annotate-inline a)
(if (and (symbol? (car a)) 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))
(define (annotate-unboxed args a) (define (annotate-unboxed args a)
(define (unboxable? e s) a)
(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))
;; ---------------------------------------- ;; ----------------------------------------

17
collects/compiler/zo-marshal.rkt
View File

@ -725,7 +725,7 @@
(out-marshaled set-bang-type-num (out-marshaled set-bang-type-num
(cons undef-ok? (cons id rhs)) (cons undef-ok? (cons id rhs))
out)] 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?) (if (and (not clear?) (not other-clears?) (not flonum?)
(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?
@ -735,17 +735,16 @@
out) out)
(begin (begin
(out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) (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) (out-number offset out)
(begin (begin
(out-number (- (add1 offset)) out) (out-number (- (add1 offset)) out)
(out-number (if clear? (out-number (cond
#x1 [clear? 1]
(if other-clears? [other-clears? 2]
#x2 [else (+ 2 (case type
(if flonum? [(flonum) 1]
#x3 [(fixnum) 2]))])
0)))
out)))))] out)))))]
[(? lam?) [(? lam?)
(out-lam v out)] (out-lam v out)]

55
collects/compiler/zo-parse.rkt
View File

@ -88,6 +88,7 @@
(define CLOS_IS_METHOD 16) (define CLOS_IS_METHOD 16)
(define CLOS_SINGLE_RESULT 32) (define CLOS_SINGLE_RESULT 32)
(define BITS_PER_MZSHORT 32) (define BITS_PER_MZSHORT 32)
(define BITS_PER_ARG 4)
(match v (match v
[`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest)
(let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))])
@ -95,31 +96,32 @@
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
(values (vector-length v) v rest) (values (vector-length v) v rest)
(values v (car rest) (cdr rest)))] (values v (car rest) (cdr rest)))]
[(check-bit) (lambda (i) [(get-flags) (lambda (i)
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
0 0
(let ([byte (vector-ref closed-over (let ([byte (vector-ref closed-over
(+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))])
(+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT)))
1 (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))]
0) [(num->type) (lambda (n)
(if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) (case n
2 [(2) 'flonum]
0)))))] [(3) 'fixnum]
[else (error "invaid type flag")]))]
[(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)])
(for/list ([i (in-range num-params)]) (for/list ([i (in-range num-params)])
(case (check-bit i) (define v (get-flags i))
(case v
[(0) 'val] [(0) 'val]
[(1) 'ref] [(1) 'ref]
[(2) 'flonum] [else (num->type v)])))]
[else (error "both 'ref and 'flonum argument?")])))]
[(closure-types) (for/list ([i (in-range closure-size)] [(closure-types) (for/list ([i (in-range closure-size)]
[j (in-naturals num-params)]) [j (in-naturals num-params)])
(case (check-bit j) (define v (get-flags j))
(case v
[(0) 'val/ref] [(0) 'val/ref]
[(1) (error "invalid 'ref closure variable")] [(1) (error "invalid 'ref closure variable")]
[(2) 'flonum] [else (num->type v)]))])
[else (error "both 'ref and 'flonum closure var?")]))])
(make-lam name (make-lam name
(append (append
(if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks))
@ -467,7 +469,7 @@
[16 vector] [16 vector]
[17 hash-table] [17 hash-table]
[18 stx] [18 stx]
[19 let-one-flonum] [19 let-one-typed]
[20 marshalled] [20 marshalled]
[21 quote] [21 quote]
[22 reference] [22 reference]
@ -550,14 +552,21 @@
[reader (get-reader type)]) [reader (get-reader type)])
(reader l))) (reader l)))
(define SCHEME_LOCAL_TYPE_FLONUM 1)
(define SCHEME_LOCAL_TYPE_FIXNUM 2)
(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 1)
(define SCHEME_LOCAL_OTHER_CLEARS #x02) (define SCHEME_LOCAL_OTHER_CLEARS 2)
(define SCHEME_LOCAL_FLONUM #x03) (define SCHEME_LOCAL_TYPE_OFFSET 2)
(make-localref unbox? pos (make-localref unbox? pos
(= flags SCHEME_LOCAL_CLEAR_ON_READ) (= flags SCHEME_LOCAL_CLEAR_ON_READ)
(= flags SCHEME_LOCAL_OTHER_CLEARS) (= 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) (define (a . << . b)
(arithmetic-shift a b)) (arithmetic-shift a b))
@ -841,9 +850,13 @@
(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-flonum let-one-unused) [(let-one let-one-typed let-one-unused)
(make-let-one (read-compact cp) (read-compact cp) (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))] (eq? cpt-tag 'let-one-unused))]
[(branch) [(branch)
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))] (make-branch (read-compact cp) (read-compact cp) (read-compact cp))]

15
collects/compiler/zo-structs.rkt
View File

@ -146,17 +146,20 @@
[flags (listof (or/c 'preserves-marks 'is-method 'single-result [flags (listof (or/c 'preserves-marks 'is-method 'single-result
'only-rest-arg-not-used 'sfs-clear-rest-args))] 'only-rest-arg-not-used 'sfs-clear-rest-args))]
[num-params exact-nonnegative-integer?] [num-params exact-nonnegative-integer?]
[param-types (listof (or/c 'val 'ref 'flonum))] [param-types (listof (or/c 'val 'ref 'flonum 'fixnum))]
[rest? boolean?] [rest? boolean?]
[closure-map (vectorof exact-nonnegative-integer?)] [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?))] [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))]
[max-let-depth exact-nonnegative-integer?] [max-let-depth exact-nonnegative-integer?]
[body (or/c expr? seq? any/c)])) ; `lambda' [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 (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 (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 (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?] (define-form-struct (install-value expr) ([count exact-nonnegative-integer?]
[pos 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 (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 (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) (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)