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

refactor np-expand-primitives unboxing

Browse Source 
Shift addition of boxing as needed into the main loop, infer unboxed
variables and `mref`s, and centralize lifting of the `unboxed-fp`
declaration.

original commit: ed8ca4b6c77bdd436b0dee467a8350a450a44fb3
This commit is contained in:
Matthew Flatt 2020-06-12 09:21:46 -06:00
parent 1ce6d97369
commit d26b54dd52
2 changed files with 143 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
mats/fl.ms
View File

@ -1126,6 +1126,7 @@
(fl= 66.0 (many-add 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0))) (fl= 66.0 (many-add 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0)))
(eqv? (let ([x 4.0]) (fl+ x)) 4.0) (eqv? (let ([x 4.0]) (fl+ x)) 4.0)
(eqv? (let ([x 4.0]) (fl+ (fl- x 1.0))) 3.0)
(eqv? (let ([x 5.0]) (fl* x)) 5.0) (eqv? (let ([x 5.0]) (fl* x)) 5.0)
) )

253
s/cpnanopass.ss
View File

@ -3074,10 +3074,10 @@
(define ht2 (make-hashtable symbol-hash eq?)) (define ht2 (make-hashtable symbol-hash eq?))
(define ht3 (make-hashtable symbol-hash eq?)) (define ht3 (make-hashtable symbol-hash eq?))
(define handle-prim (define handle-prim
(lambda (src sexpr can-unbox-fp? level name e*) (lambda (src sexpr level name e*)
(let ([handler (or (and (fx= level 3) (symbol-hashtable-ref ht3 name #f)) (let ([handler (or (and (fx= level 3) (symbol-hashtable-ref ht3 name #f))
(symbol-hashtable-ref ht2 name #f))]) (symbol-hashtable-ref ht2 name #f))])
(and handler (handler src sexpr can-unbox-fp? e*))))) (and handler (handler src sexpr e*)))))
(define-syntax Symref (define-syntax Symref
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
@ -3132,6 +3132,14 @@
(define Expr* (define Expr*
(lambda (e*) (lambda (e*)
(map Expr1 e*))) (map Expr1 e*)))
(define unboxed-fp->boxed
(lambda (e)
(let ([t (make-tmp 't)])
(with-output-language (L9 Expr)
`(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))])
(seq
(set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e)
,t))))))
(define (fp-lvalue? lvalue) (define (fp-lvalue? lvalue)
(nanopass-case (L9 Lvalue) lvalue (nanopass-case (L9 Lvalue) lvalue
[,x (and (uvar? x) (eq? (uvar-type x) 'fp))] [,x (and (uvar? x) (eq? (uvar-type x) 'fp))]
@ -3145,6 +3153,9 @@
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
[(clause (,x* ...) ,mcp ,interface ,[body #f -> body unboxed-fp?]) [(clause (,x* ...) ,mcp ,interface ,[body #f -> body unboxed-fp?])
`(clause (,x* ...) ,mcp ,interface ,body)]) `(clause (,x* ...) ,mcp ,interface ,body)])
;; The result of `Expr` can be unboxed (second result is #t) only
;; if the `can-unbox-fp?` argument is #t, but the result can always
;; be a boxed expression (even if `can-unbox-fp?` is #t)
(Expr : Expr (ir [can-unbox-fp? #f]) -> Expr (#f) (Expr : Expr (ir [can-unbox-fp? #f]) -> Expr (#f)
[(quote ,d) [(quote ,d)
(values (cond (values (cond
@ -3152,9 +3163,10 @@
[else `(literal ,(make-info-literal #f 'object d 0))]) [else `(literal ,(make-info-literal #f 'object d 0))])
#f)] #f)]
[,pr (values (Symref (primref-name pr)) #f)] [,pr (values (Symref (primref-name pr)) #f)]
[(unboxed-fp ,[e can-unbox-fp? -> e unboxed-fp?]) [(unboxed-fp ,[e #t -> e unboxed-fp?])
(safe-assert can-unbox-fp?) (if can-unbox-fp?
(values e #t)] (values e #t)
(values (unboxed-fp->boxed e) #f))]
[(call ,info0 ,mdcl0 [(call ,info0 ,mdcl0
(call ,info1 ,mdcl1 ,pr (quote ,d)) (call ,info1 ,mdcl1 ,pr (quote ,d))
,[e* #f -> e* unboxed-fp?*] ...) ,[e* #f -> e* unboxed-fp?*] ...)
@ -3167,7 +3179,7 @@
;; Note: single-valued also implies that the primitive doesn't ;; Note: single-valued also implies that the primitive doesn't
;; tail-call an arbitary function (which might inspect attachments): ;; tail-call an arbitary function (which might inspect attachments):
(all-set? (prim-mask single-valued) (primref-flags pr))) (all-set? (prim-mask single-valued) (primref-flags pr)))
(handle-prim (info-call-src info) (info-call-sexpr info) can-unbox-fp? (primref-level pr) (primref-name pr) e*)) (handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*))
=> (lambda (e) => (lambda (e)
(let-values ([(e unboxed-fp?) (Expr e can-unbox-fp?)]) (let-values ([(e unboxed-fp?) (Expr e can-unbox-fp?)])
(values (values
@ -3190,7 +3202,8 @@
(info-call-shift-consumer-attachment?* info)) (info-call-shift-consumer-attachment?* info))
info)]) info)])
(values `(call ,info ,mdcl ,(Symref (primref-name pr)) ,e* ...) (values `(call ,info ,mdcl ,(Symref (primref-name pr)) ,e* ...)
#f)))])] ;; an error can be treated as unboxed if the context wants that:
(and can-unbox-fp? (info-call-error? info)))))])]
[(call ,info ,mdcl ,x ,e* ...) [(call ,info ,mdcl ,x ,e* ...)
(guard (uvar-loop? x)) (guard (uvar-loop? x))
(let ([e* (map (lambda (x1 e) (let ([e* (map (lambda (x1 e)
@ -3269,11 +3282,15 @@
(values `(mvlet ,(Expr1 e) ((,x** ...) ,interface* ,(map Expr1 body*)) ...) #f)]) (values `(mvlet ,(Expr1 e) ((,x** ...) ,interface* ,(map Expr1 body*)) ...) #f)])
(Lvalue : Lvalue (ir [unboxed-fp? #f]) -> Lvalue (#f) (Lvalue : Lvalue (ir [unboxed-fp? #f]) -> Lvalue (#f)
[(mref ,e1 ,e2 ,imm ,type) [(mref ,e1 ,e2 ,imm ,type)
(safe-assert (or unboxed-fp? (not (eq? type 'fp)))) (let ([e `(mref ,(Expr1 e1) ,(Expr1 e2) ,imm ,type)])
(values `(mref ,(Expr1 e1) ,(Expr1 e2) ,imm ,type) (eq? type 'fp))] (if (and (eq? type 'fp) (not unboxed-fp?))
(values (unboxed-fp->boxed e) #f)
(values e (eq? type 'fp))))]
[,x [,x
(safe-assert (or unboxed-fp? (not (and (uvar? x) (eq? (uvar-type x) 'fp))))) (let ([fp? (and (uvar? x) (eq? (uvar-type x) 'fp))])
(values x (and (uvar? x) (eq? (uvar-type x) 'fp)))])) (if (and fp? (not unboxed-fp?))
(values (unboxed-fp->boxed x) #f)
(values x fp?)))]))
(define-who unhandled-arity (define-who unhandled-arity
(lambda (name args) (lambda (name args)
(sorry! who "unhandled argument count ~s for ~s" (length args) 'name))) (sorry! who "unhandled argument count ~s for ~s" (length args) 'name)))
@ -3315,10 +3332,10 @@
(unless (= (bitmaskify arity) (bitmaskify (map compute-interface #'(clause ...)))) (unless (= (bitmaskify arity) (bitmaskify (map compute-interface #'(clause ...))))
(syntax-error x (format "arity mismatch for ~s" name)))))) (syntax-error x (format "arity mismatch for ~s" name))))))
(check-and-record level #'id) (check-and-record level #'id)
(with-implicit (k src sexpr moi can-unbox-fp?) (with-implicit (k src sexpr moi)
#`(symbol-hashtable-set! #,(if (eqv? level 2) #'ht2 #'ht3) 'id #`(symbol-hashtable-set! #,(if (eqv? level 2) #'ht2 #'ht3) 'id
(rec moi (rec moi
(lambda (src sexpr can-unbox-fp? args) (lambda (src sexpr args)
(apply (case-lambda clause ... [rest #f]) args))))))])))) (apply (case-lambda clause ... [rest #f]) args))))))]))))
(define no-need-to-bind? (define no-need-to-bind?
(lambda (multiple-ref? e) (lambda (multiple-ref? e)
@ -3336,11 +3353,9 @@
(if (no-need-to-bind? multiple-ref? e) (if (no-need-to-bind? multiple-ref? e)
(values e values) (values e values)
(let ([t (make-tmp 't type)]) (let ([t (make-tmp 't type)])
(values t (values t (lift-fp-unboxed
(lambda (body) (lambda (body)
(nanopass-case (L7 Expr) body `(let ([,t ,e]) ,body))))))))
[(unboxed-fp ,body) `(unboxed-fp (let ([,t ,e]) ,body))]
[else `(let ([,t ,e]) ,body)])))))))
(define list-binder (define list-binder
(lambda (multiple-ref? type e*) (lambda (multiple-ref? type e*)
(if (null? e*) (if (null? e*)
@ -3380,6 +3395,23 @@
($bind list-binder multiple-ref? type (b ...) e)] ($bind list-binder multiple-ref? type (b ...) e)]
[(_ multiple-ref? (b ...) e) [(_ multiple-ref? (b ...) e)
($bind list-binder multiple-ref? ptr (b ...) e)])) ($bind list-binder multiple-ref? ptr (b ...) e)]))
(define lift-fp-unboxed
(lambda (k)
(lambda (e)
;; Propagate unboxing information:
(nanopass-case (L7 Expr) e
[(unboxed-fp ,e) `(unboxed-fp ,(k e))]
[else
(let ([new-e (k e)])
(nanopass-case (L7 Expr) e
[(mref ,e0 ,e1 ,imm ,type)
(if (eq? type 'fp)
`(unboxed-fp ,new-e)
new-e)]
[,x (if (and (uvar? x) (eq? (uvar-type x) 'fp))
`(unboxed-fp ,new-e)
new-e)]
[else new-e]))]))))
(define-syntax build-libcall (define-syntax build-libcall
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
@ -3961,10 +3993,8 @@
(case-lambda (case-lambda
[(swapped? type base offset-expr) [(swapped? type base offset-expr)
(let-values ([(index offset) (offset-expr->index+offset offset-expr)]) (let-values ([(index offset) (offset-expr->index+offset offset-expr)])
(build-object-ref swapped? type base index offset #f))] (build-object-ref swapped? type base index offset))]
[(swapped? type base index offset) [(swapped? type base index offset)
(build-object-ref swapped? type base index offset #f)]
[(swapped? type base index offset can-unbox-fp?)
(case type (case type
[(scheme-object) `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset))] [(scheme-object) `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset))]
[(double-float) [(double-float)
@ -3990,15 +4020,7 @@
(immediate ,offset))) (immediate ,offset)))
,t)))]) ,t)))])
(bind #f (base index) (bind #f (base index)
(cond (%mref ,base ,index ,offset fp)))]
[can-unbox-fp?
`(unboxed-fp ,(%mref ,base ,index ,offset fp))]
[else
(bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
(%seq
(set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)
(unboxed-fp ,(%mref ,base ,index ,offset fp)))
,t))])))]
[(single-float) [(single-float)
(if swapped? (if swapped?
(bind #f (base index) (bind #f (base index)
@ -4012,7 +4034,7 @@
,%load-single->double ,%load-single->double
;; slight abuse to call this "unboxed", but `load-single->double` ;; slight abuse to call this "unboxed", but `load-single->double`
;; wants an FP-flavored address ;; wants an FP-flavored address
(unboxed-fp ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp))))) ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp))))
,t))) ,t)))
(bind #f (base index) (bind #f (base index)
(bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
@ -4022,7 +4044,7 @@
,%load-single->double ,%load-single->double
;; slight abuse to call this "unboxed", but `load-single->double` ;; slight abuse to call this "unboxed", but `load-single->double`
;; wants an FP-flavored address ;; wants an FP-flavored address
(unboxed-fp ,(%mref ,base ,index ,offset fp))))) ,(%mref ,base ,index ,offset fp))))
,t))))] ,t))))]
[(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64) [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64)
(build-int-load swapped? type base index offset (build-int-load swapped? type base index offset
@ -4107,8 +4129,8 @@
`(inline ,(make-info-unboxed-args '(#t #t)) ,%store-double->single `(inline ,(make-info-unboxed-args '(#t #t)) ,%store-double->single
;; slight abuse to call this "unboxed", but `store-double->single` ;; slight abuse to call this "unboxed", but `store-double->single`
;; wants an FP-flavored address ;; wants an FP-flavored address
(unboxed-fp ,(%mref ,base ,index ,offset fp)) ,(%mref ,base ,index ,offset fp)
(unboxed-fp ,(%mref ,value ,%zero ,(constant flonum-data-disp) fp))))] ,(%mref ,value ,%zero ,(constant flonum-data-disp) fp)))]
; 40-bit+ only on 64-bit machines ; 40-bit+ only on 64-bit machines
[(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64
unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64)
@ -4283,8 +4305,8 @@
(list-bind #f (e*) (list-bind #f (e*)
(let compare ([src src] [e2 e2] [e* e*]) (let compare ([src src] [e2 e2] [e* e*])
(if (null? e*) (if (null? e*)
(moi src sexpr #f (list e1 e2)) (moi src sexpr (list e1 e2))
`(if ,(moi src sexpr #f (list e1 e2)) `(if ,(moi src sexpr (list e1 e2))
,(compare #f (car e*) (cdr e*)) ,(compare #f (car e*) (cdr e*))
(quote #f)))))))))) (quote #f))))))))))
(define reduce-inequality (define reduce-inequality
@ -4296,8 +4318,8 @@
(let compare ([src src] [e* (cons e1 (reverse (cons e2 re*)))]) (let compare ([src src] [e* (cons e1 (reverse (cons e2 re*)))])
(let ([more-args (cddr e*)]) (let ([more-args (cddr e*)])
(if (null? more-args) (if (null? more-args)
(moi src sexpr #f e*) (moi src sexpr e*)
`(if ,(moi src sexpr #f (list (car e*) (cadr e*))) `(if ,(moi src sexpr (list (car e*) (cadr e*)))
,(compare #f (cdr e*)) ,(compare #f (cdr e*))
(quote #f)))))) (quote #f))))))
(bind #t ([e2 e2]) (f (car e*) (cdr e*) (cons e2 re*)))))))) (bind #t ([e2 e2]) (f (car e*) (cdr e*) (cons e2 re*))))))))
@ -4309,7 +4331,7 @@
(let reduce ([src src] [e e] [e* e*]) (let reduce ([src src] [e e] [e* e*])
(if (null? e*) (if (null? e*)
e e
(reduce #f (moi src sexpr #f (list e (car e*))) (cdr e*))))))))) (reduce #f (moi src sexpr (list e (car e*))) (cdr e*)))))))))
(define reduce-fp-compare ; suitable for arguments known or assumed to produce flonums (define reduce-fp-compare ; suitable for arguments known or assumed to produce flonums
(lambda (reduce) (lambda (reduce)
(lambda (src sexpr moi e1 e2 e*) (lambda (src sexpr moi e1 e2 e*)
@ -7233,13 +7255,13 @@
(define-relop-inline >= r6rs:>= RELOP>= >=) (define-relop-inline >= r6rs:>= RELOP>= >=)
(define-relop-inline > r6rs:> RELOP> >)) (define-relop-inline > r6rs:> RELOP> >))
(define-inline 3 positive? ; 3 so opt-level 2 errors come from positive? (define-inline 3 positive? ; 3 so opt-level 2 errors come from positive?
[(e) (handle-prim src sexpr #f 3 '> (list e `(quote 0)))]) [(e) (handle-prim src sexpr 3 '> (list e `(quote 0)))])
(define-inline 3 nonnegative? ; 3 so opt-level 2 errors come from nonnegative? (define-inline 3 nonnegative? ; 3 so opt-level 2 errors come from nonnegative?
[(e) (handle-prim src sexpr #f 3 '>= (list e `(quote 0)))]) [(e) (handle-prim src sexpr 3 '>= (list e `(quote 0)))])
(define-inline 3 negative? ; 3 so opt-level 2 errors come from negative? (define-inline 3 negative? ; 3 so opt-level 2 errors come from negative?
[(e) (handle-prim src sexpr #f 3 '< (list e `(quote 0)))]) [(e) (handle-prim src sexpr 3 '< (list e `(quote 0)))])
(define-inline 3 nonpositive? ; 3 so opt-level 2 errors come from nonpositive? (define-inline 3 nonpositive? ; 3 so opt-level 2 errors come from nonpositive?
[(e) (handle-prim src sexpr #f 3 '<= (list e `(quote 0)))]) [(e) (handle-prim src sexpr 3 '<= (list e `(quote 0)))])
(define-inline 2 zero? (define-inline 2 zero?
[(e) [(e)
(or (relop-length RELOP= e) (or (relop-length RELOP= e)
@ -7446,31 +7468,18 @@
,(build-not (build-fl= e2 e2))))]) ,(build-not (build-fl= e2 e2))))])
(let () (let ()
(define build-fp-boxed
(lambda (can-unbox-fp? e)
(if can-unbox-fp?
`(unboxed-fp ,e)
(bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
`(seq
(set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) (unboxed-fp ,e))
,t)))))
(define (unboxed-explicit->implicit e)
(nanopass-case (L7 Expr) e
[(unboxed-fp ,e) e]
[else (%mref ,e ,%zero ,(constant flonum-data-disp) fp)]))
(define build-fp-op-1 (define build-fp-op-1
(lambda (can-unbox-fp? op e) (lambda (op e)
(bind #f fp (e) (bind #f fp (e)
(build-fp-boxed can-unbox-fp? (if (procedure? op) (op e) `(inline ,(make-info-unboxed-args '(#t)) ,op ,e)))))) (if (procedure? op) (op e) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t)) ,op ,e))))))
(define build-fp-op-2 (define build-fp-op-2
(lambda (can-unbox-fp? op e1 e2) (lambda (op e1 e2)
(bind #f fp (e1 e2) (bind #f fp (e1 e2)
(build-fp-boxed can-unbox-fp? `(inline ,(make-info-unboxed-args '(#t #t)) ,op ,e1 ,e2))))) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t #t)) ,op ,e1 ,e2)))))
(define build-fl-adjust-sign (define build-fl-adjust-sign
(lambda (e can-unbox-fp? combine base) (lambda (e combine base)
(build-fp-boxed `(unboxed-fp
can-unbox-fp? ,(constant-case ptr-bits
(constant-case ptr-bits
[(64) [(64)
(let ([t (make-tmp 'flsgn)]) (let ([t (make-tmp 'flsgn)])
`(let ([,t (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto ,e)]) `(let ([,t (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto ,e)])
@ -7483,47 +7492,38 @@
[,tlo (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/lo ,e)]) [,tlo (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/lo ,e)])
(inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,thi ,base) ,tlo))))])))) (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,thi ,base) ,tlo))))]))))
(define build-flabs (define build-flabs
(lambda (e can-unbox-fp?) (lambda (e)
(build-fl-adjust-sign e can-unbox-fp? %logand (%inline srl (immediate -1) (immediate 1))))) (build-fl-adjust-sign e %logand (%inline srl (immediate -1) (immediate 1)))))
(define build-flneg (define build-flneg
(lambda (e can-unbox-fp?) (lambda (e)
(build-fl-adjust-sign e can-unbox-fp? %logxor (%inline sll (immediate -1) (immediate ,(fx- (constant ptr-bits) 1)))))) (build-fl-adjust-sign e %logxor (%inline sll (immediate -1) (immediate ,(fx- (constant ptr-bits) 1))))))
(define maybe-build-fp-boxed
;; Used for an `e` that may be implicitly unboxed because it appears
;; as an argument to a primitive that accepts unboxed arguments
(lambda (can-unbox-fp? e)
(nanopass-case (L7 Expr) e
[,x (if (and (uvar? x) (eq? (uvar-type x) 'fp))
(build-fp-boxed can-unbox-fp? e)
e)]
[else e])))
(define-inline 3 fl+ (define-inline 3 fl+
[() `(quote 0.0)] [() `(quote 0.0)]
[(e) (maybe-build-fp-boxed can-unbox-fp? (ensure-single-valued e))] [(e) (ensure-single-valued e)]
[(e1 e2) (build-fp-op-2 can-unbox-fp? %fp+ e1 e2)] [(e1 e2) (build-fp-op-2 %fp+ e1 e2)]
[(e1 . e*) (reduce-fp src sexpr 3 'fl+ e1 e*)]) [(e1 . e*) (reduce-fp src sexpr 3 'fl+ e1 e*)])
(define-inline 3 fl* (define-inline 3 fl*
[() `(quote 1.0)] [() `(quote 1.0)]
[(e) (maybe-build-fp-boxed can-unbox-fp? (ensure-single-valued e))] [(e) (ensure-single-valued e)]
[(e1 e2) (build-fp-op-2 can-unbox-fp? %fp* e1 e2)] [(e1 e2) (build-fp-op-2 %fp* e1 e2)]
[(e1 . e*) (reduce-fp src sexpr 3 'fl* e1 e*)]) [(e1 . e*) (reduce-fp src sexpr 3 'fl* e1 e*)])
(define-inline 3 fl- (define-inline 3 fl-
[(e) (build-flneg e can-unbox-fp?)] [(e) (build-flneg e)]
[(e1 e2) (build-fp-op-2 can-unbox-fp? %fp- e1 e2)] [(e1 e2) (build-fp-op-2 %fp- e1 e2)]
[(e1 . e*) (reduce-fp src sexpr 3 'fl- e1 e*)]) [(e1 . e*) (reduce-fp src sexpr 3 'fl- e1 e*)])
(define-inline 3 fl/ (define-inline 3 fl/
[(e) (build-fp-op-2 can-unbox-fp? %fp/ `(quote 1.0) e)] [(e) (build-fp-op-2 %fp/ `(quote 1.0) e)]
[(e1 e2) (build-fp-op-2 can-unbox-fp? %fp/ e1 e2)] [(e1 e2) (build-fp-op-2 %fp/ e1 e2)]
[(e1 . e*) (reduce-fp src sexpr 3 'fl/ e1 e*)]) [(e1 . e*) (reduce-fp src sexpr 3 'fl/ e1 e*)])
(define-inline 3 flsqrt (define-inline 3 flsqrt
[(e) [(e)
(constant-case architecture (constant-case architecture
[(x86 x86_64 arm32) (build-fp-op-1 can-unbox-fp? %fpsqrt e)] [(x86 x86_64 arm32) (build-fp-op-1 %fpsqrt e)]
[(ppc32) #f])]) [(ppc32) #f])])
(define-inline 3 flround (define-inline 3 flround
@ -7531,7 +7531,7 @@
[(e) (build-libcall #f src sexpr flround e)]) [(e) (build-libcall #f src sexpr flround e)])
(define-inline 3 flabs (define-inline 3 flabs
[(e) (build-flabs e can-unbox-fp?)]) [(e) (build-flabs e)])
(let () (let ()
(define build-fl-make-rectangular (define build-fl-make-rectangular
@ -7542,9 +7542,9 @@
(set! ,(%mref ,t ,(constant inexactnum-type-disp)) (set! ,(%mref ,t ,(constant inexactnum-type-disp))
,(%constant type-inexactnum)) ,(%constant type-inexactnum))
(set! ,(%mref ,t ,%zero ,(constant inexactnum-real-disp) fp) (set! ,(%mref ,t ,%zero ,(constant inexactnum-real-disp) fp)
(unboxed-fp ,(%mref ,e1 ,%zero ,(constant flonum-data-disp) fp))) ,(%mref ,e1 ,%zero ,(constant flonum-data-disp) fp))
(set! ,(%mref ,t ,%zero ,(constant inexactnum-imag-disp) fp) (set! ,(%mref ,t ,%zero ,(constant inexactnum-imag-disp) fp)
(unboxed-fp ,(%mref ,e2 ,%zero ,(constant flonum-data-disp) fp))) ,(%mref ,e2 ,%zero ,(constant flonum-data-disp) fp))
,t))))) ,t)))))
(define-inline 3 fl-make-rectangular (define-inline 3 fl-make-rectangular
@ -7553,10 +7553,10 @@
(define-inline 3 cfl- (define-inline 3 cfl-
[(e) (bind #t (e) [(e) (bind #t (e)
`(if ,(%type-check mask-flonum type-flonum ,e) `(if ,(%type-check mask-flonum type-flonum ,e)
,(build-flneg e #f) ,(build-flneg e)
,(build-fl-make-rectangular ,(build-fl-make-rectangular
(build-flneg (build-$inexactnum-real-part e) #f) (build-flneg (build-$inexactnum-real-part e))
(build-flneg (build-$inexactnum-imag-part e) #f))))] (build-flneg (build-$inexactnum-imag-part e)))))]
[(e1 e2) (build-libcall #f src sexpr cfl- e1 e2)] [(e1 e2) (build-libcall #f src sexpr cfl- e1 e2)]
; TODO: add 3 argument version of cfl- library function ; TODO: add 3 argument version of cfl- library function
#;[(e1 e2 e3) (build-libcall #f src sexpr cfl- e1 e2 e3)] #;[(e1 e2 e3) (build-libcall #f src sexpr cfl- e1 e2 e3)]
@ -7591,7 +7591,7 @@
,e ,e
,(build-fl-make-rectangular ,(build-fl-make-rectangular
(build-$inexactnum-real-part e) (build-$inexactnum-real-part e)
(build-flneg (build-$inexactnum-imag-part e) #f))))])) (build-flneg (build-$inexactnum-imag-part e)))))]))
(define-inline 3 $make-exactnum (define-inline 3 $make-exactnum
[(e1 e2) (bind #f (e1 e2) [(e1 e2) (bind #f (e1 e2)
@ -7753,31 +7753,27 @@
(let () (let ()
(define build-checked-fp-op (define build-checked-fp-op
(case-lambda (case-lambda
[(e can-unbox-fp? k) [(e k)
(maybe-build-fp-boxed
can-unbox-fp?
(if (known-flonum-result? e) (if (known-flonum-result? e)
e e
(bind #t (e) (bind #t (e)
`(if ,(build-flonums? (list e)) `(if ,(build-flonums? (list e))
,e ,e
,(k e)))))] ,(k e))))]
[(e1 op can-unbox-fp? k) ; `op` can be a procedure that produces an implicitly unboxed value [(e1 op k) ; `op` can be a procedure that produces an implicitly unboxed value
(if (known-flonum-result? e1) (if (known-flonum-result? e1)
(build-fp-op-1 can-unbox-fp? op e1) (build-fp-op-1 op e1)
(bind #t (e1) (bind #t (e1)
(let ([e (build-fp-op-1 can-unbox-fp? op e1)] (let ([e (build-fp-op-1 op e1)]
[k (lambda (e) [k (lambda (e)
`(if ,(build-flonums? (list e1)) `(if ,(build-flonums? (list e1))
,e ,e
,(k e1)))]) ,(k e1)))])
(nanopass-case (L7 Expr) e ((lift-fp-unboxed k) e))))]
[(unboxed-fp ,e) `(unboxed-fp ,(k e))] [(e1 e2 op k)
[else (k e)]))))]
[(e1 e2 op can-unbox-fp? k)
;; uses result of `e1` or `e2` twice for error if other is always a flonum ;; uses result of `e1` or `e2` twice for error if other is always a flonum
(let ([build (lambda (e1 e2) (let ([build (lambda (e1 e2)
(build-fp-op-2 can-unbox-fp? op e1 e2))]) (build-fp-op-2 op e1 e2))])
(if (known-flonum-result? e1) (if (known-flonum-result? e1)
(if (known-flonum-result? e2) (if (known-flonum-result? e2)
(build e1 e2) (build e1 e2)
@ -7797,50 +7793,48 @@
`(if ,(build-flonums? (list e1 e2)) `(if ,(build-flonums? (list e1 e2))
,e ,e
,(k e1 e2)))]) ,(k e1 e2)))])
(nanopass-case (L7 Expr) e ((lift-fp-unboxed k) e))))))]))
[(unboxed-fp ,e) `(unboxed-fp ,(k e))]
[else (k e)]))))))]))
(define-inline 2 fl+ (define-inline 2 fl+
[() `(quote 0.0)] [() `(quote 0.0)]
[(e) (build-checked-fp-op e can-unbox-fp? [(e) (build-checked-fp-op e
(lambda (e) (lambda (e)
(build-libcall #t src sexpr fl+ e `(quote 0.0))))] (build-libcall #t src sexpr fl+ e `(quote 0.0))))]
[(e1 e2) (build-checked-fp-op e1 e2 %fp+ can-unbox-fp? [(e1 e2) (build-checked-fp-op e1 e2 %fp+
(lambda (e1 e2) (lambda (e1 e2)
(build-libcall #t src sexpr fl+ e1 e2)))] (build-libcall #t src sexpr fl+ e1 e2)))]
[(e1 . e*) (reduce-fp src sexpr 2 'fl+ e1 e*)]) [(e1 . e*) (reduce-fp src sexpr 2 'fl+ e1 e*)])
(define-inline 2 fl* (define-inline 2 fl*
[() `(quote 1.0)] [() `(quote 1.0)]
[(e) (build-checked-fp-op e can-unbox-fp? [(e) (build-checked-fp-op e
(lambda (e) (lambda (e)
(build-libcall #t src sexpr fl* e `(quote 1.0))))] (build-libcall #t src sexpr fl* e `(quote 1.0))))]
[(e1 e2) (build-checked-fp-op e1 e2 %fp* can-unbox-fp? [(e1 e2) (build-checked-fp-op e1 e2 %fp*
(lambda (e1 e2) (lambda (e1 e2)
(build-libcall #t src sexpr fl* e1 e2)))] (build-libcall #t src sexpr fl* e1 e2)))]
[(e1 . e*) (reduce-fp src sexpr 2 'fl* e1 e*)]) [(e1 . e*) (reduce-fp src sexpr 2 'fl* e1 e*)])
(define-inline 2 fl- (define-inline 2 fl-
[(e) (build-checked-fp-op e (lambda (e) (unboxed-explicit->implicit (build-flneg e #t))) can-unbox-fp? [(e) (build-checked-fp-op e build-flneg
(lambda (e) (lambda (e)
(build-libcall #t src sexpr flnegate e)))] (build-libcall #t src sexpr flnegate e)))]
[(e1 e2) (build-checked-fp-op e1 e2 %fp- can-unbox-fp? [(e1 e2) (build-checked-fp-op e1 e2 %fp-
(lambda (e1 e2) (lambda (e1 e2)
(build-libcall #t src sexpr fl- e1 e2)))] (build-libcall #t src sexpr fl- e1 e2)))]
[(e1 . e*) (reduce-fp src sexpr 2 'fl- e1 e*)]) [(e1 . e*) (reduce-fp src sexpr 2 'fl- e1 e*)])
(define-inline 2 fl/ (define-inline 2 fl/
[(e) (build-checked-fp-op `(quote 1.0) e %fp/ can-unbox-fp? [(e) (build-checked-fp-op `(quote 1.0) e %fp/
(lambda (e1 e2) (lambda (e1 e2)
(build-libcall #t src sexpr fl/ e1 e2)))] (build-libcall #t src sexpr fl/ e1 e2)))]
[(e1 e2) (build-checked-fp-op e1 e2 %fp/ can-unbox-fp? [(e1 e2) (build-checked-fp-op e1 e2 %fp/
(lambda (e1 e2) (lambda (e1 e2)
(build-libcall #t src sexpr fl/ e1 e2)))] (build-libcall #t src sexpr fl/ e1 e2)))]
[(e1 . e*) (reduce-fp src sexpr 2 'fl/ e1 e*)]) [(e1 . e*) (reduce-fp src sexpr 2 'fl/ e1 e*)])
(define-inline 2 flabs (define-inline 2 flabs
[(e) (build-checked-fp-op e (lambda (e) (unboxed-explicit->implicit (build-flabs e #t))) can-unbox-fp? [(e) (build-checked-fp-op e build-flabs
(lambda (e) (lambda (e)
(build-libcall #t src sexpr flabs e)))]))) (build-libcall #t src sexpr flabs e)))])))
@ -7852,30 +7846,25 @@
(let () (let ()
(define build-fixnum->flonum (define build-fixnum->flonum
; NB: x must already be bound in order to ensure it is done before the flonum is allocated ; NB: x must already be bound in order to ensure it is done before the flonum is allocated
(lambda (e-x can-unbox-fp? k) (lambda (e-x k)
(let ([e (%inline fpt ,(build-unfix e-x))]) (k `(unboxed-fp ,(%inline fpt ,(build-unfix e-x))))))
(if can-unbox-fp?
`(unboxed-fp ,(k e))
(k (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
(%seq
(set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) (unboxed-fp ,e))
,t)))))))
(define-inline 3 fixnum->flonum (define-inline 3 fixnum->flonum
[(e-x) (bind #f (e-x) (build-fixnum->flonum e-x can-unbox-fp? values))]) [(e-x) (bind #f (e-x) (build-fixnum->flonum e-x values))])
(define-inline 2 fixnum->flonum (define-inline 2 fixnum->flonum
[(e-x) (bind #t (e-x) [(e-x) (bind #t (e-x)
(build-fixnum->flonum e-x can-unbox-fp? (build-fixnum->flonum e-x
(lift-fp-unboxed
(lambda (e) (lambda (e)
`(if ,(%type-check mask-fixnum type-fixnum ,e-x) `(if ,(%type-check mask-fixnum type-fixnum ,e-x)
,e ,e
,(build-libcall #t src sexpr fixnum->flonum e-x)))))]) ,(build-libcall #t src sexpr fixnum->flonum e-x))))))])
(define-inline 2 real->flonum (define-inline 2 real->flonum
[(e-x) [(e-x)
(if (known-flonum-result? e-x) (if (known-flonum-result? e-x)
e-x e-x
(bind #t (e-x) (bind #t (e-x)
`(if ,(%type-check mask-fixnum type-fixnum ,e-x) `(if ,(%type-check mask-fixnum type-fixnum ,e-x)
,(build-fixnum->flonum e-x #f values) ,(build-fixnum->flonum e-x values)
(if ,(%type-check mask-flonum type-flonum ,e-x) (if ,(%type-check mask-flonum type-flonum ,e-x)
,e-x ,e-x
,(build-libcall #t src sexpr real->flonum e-x `(quote real->flonum))))))])) ,(build-libcall #t src sexpr real->flonum e-x `(quote real->flonum))))))]))
@ -9314,7 +9303,7 @@
(define-inline 2 name (define-inline 2 name
[(e-bv e-offset) [(e-bv e-offset)
(bind #t (e-bv e-offset) (bind #t (e-bv e-offset)
`(if ,(handle-prim #f #f #f 3 '$bytevector-ref-check? (list `(quote 8) e-bv e-offset)) `(if ,(handle-prim #f #f 3 '$bytevector-ref-check? (list `(quote 8) e-bv e-offset))
,(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) ,(let-values ([(e-index imm-offset) (bv-index-offset e-offset)])
(build-object-ref #f 'type e-bv e-index imm-offset)) (build-object-ref #f 'type e-bv e-index imm-offset))
,(build-libcall #t src sexpr name e-bv e-offset)))])])) ,(build-libcall #t src sexpr name e-bv e-offset)))])]))
@ -9330,7 +9319,7 @@
#'(define-inline 3 name #'(define-inline 3 name
[(e-bv e-offset) [(e-bv e-offset)
(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)])
(build-object-ref #f 'type e-bv e-index imm-offset can-unbox-fp?))])]))) (build-object-ref #f 'type e-bv e-index imm-offset))])])))
(define-bv-native-ref-inline bytevector-s8-ref integer-8) (define-bv-native-ref-inline bytevector-s8-ref integer-8)
(define-bv-native-ref-inline bytevector-u8-ref unsigned-8) (define-bv-native-ref-inline bytevector-u8-ref unsigned-8)
@ -9458,7 +9447,7 @@
(bv-offset-okay? e-offset mask)) (bv-offset-okay? e-offset mask))
(constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness)
(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)])
(build-object-ref #f 'type e-bv e-index imm-offset can-unbox-fp?)))])]))) (build-object-ref #f 'type e-bv e-index imm-offset)))])])))
(define-bv-ieee-ref-inline bytevector-ieee-single-ref single-float 3) (define-bv-ieee-ref-inline bytevector-ieee-single-ref single-float 3)
(define-bv-ieee-ref-inline bytevector-ieee-double-ref double-float 7)) (define-bv-ieee-ref-inline bytevector-ieee-double-ref double-float 7))
@ -10383,12 +10372,12 @@
[(e-bop e-x) [(e-bop e-x)
(bind #t (e-x) (bind #t (e-x)
(build-libcall #f src sexpr name e-bop e-x `(immediate 0) (build-libcall #f src sexpr name e-bop e-x `(immediate 0)
(handle-prim #f #f #f 3 'x-length (list e-x))))] (handle-prim #f #f 3 'x-length (list e-x))))]
[(e-bop e-x e-start) [(e-bop e-x e-start)
(bind #t (e-x e-start) (bind #t (e-x e-start)
(build-libcall #f src sexpr name e-bop e-x e-start (build-libcall #f src sexpr name e-bop e-x e-start
(%inline - (%inline -
,(handle-prim #f #f #f 3 'x-length (list e-x)) ,(handle-prim #f #f 3 'x-length (list e-x))
,e-start)))] ,e-start)))]
[(e-bop e-x e-start e-count) [(e-bop e-x e-start e-count)
(build-libcall #f src sexpr name e-bop e-x e-start e-count)])])) (build-libcall #f src sexpr name e-bop e-x e-start e-count)])]))