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: bdf1c3e165
This commit is contained in:
Matthew Flatt
parent
85715ca473
commit
d003549257
|
|
@ -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)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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))]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user