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

fix unboxing with single-argument fl+ and fl*

Browse Source 
original commit: 366468c7149dbb59cdf2dce67078e6511b137e9b
This commit is contained in:
Matthew Flatt 2020-06-12 07:58:33 -06:00
parent 23e3597778
commit 1ce6d97369
2 changed files with 32 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
mats/fl.ms
View File

@ -1125,4 +1125,7 @@
(fl+ a b c d e f g h i j k)))
(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 5.0]) (fl* x)) 5.0)
)

44
s/cpnanopass.ss
View File

@ -3111,6 +3111,7 @@
(single-valued? e2 (fx- fuel 1)))]
[(seq ,e0 ,e1)
(single-valued? e1 (fx- fuel 1))]
[(unboxed-fp ,e) #t]
[else #f]))]))
(define ensure-single-valued
(case-lambda
@ -3267,10 +3268,12 @@
[(mvlet ,e ((,x** ...) ,interface* ,body*) ...)
(values `(mvlet ,(Expr1 e) ((,x** ...) ,interface* ,(map Expr1 body*)) ...) #f)])
(Lvalue : Lvalue (ir [unboxed-fp? #f]) -> Lvalue (#f)
[(mref ,e1 ,e2 ,imm ,type) (values `(mref ,(Expr1 e1) ,(Expr1 e2) ,imm ,type) #f)]
[,x
(safe-assert (or unboxed-fp? (not (and (uvar? x) (eq? (uvar-type x) 'fp)))))
(values x (and (uvar? x) (eq? (uvar-type x) 'fp)))]))
[(mref ,e1 ,e2 ,imm ,type)
(safe-assert (or unboxed-fp? (not (eq? type 'fp))))
(values `(mref ,(Expr1 e1) ,(Expr1 e2) ,imm ,type) (eq? type 'fp))]
[,x
(safe-assert (or unboxed-fp? (not (and (uvar? x) (eq? (uvar-type x) 'fp)))))
(values x (and (uvar? x) (eq? (uvar-type x) 'fp)))]))
(define-who unhandled-arity
(lambda (name args)
(sorry! who "unhandled argument count ~s for ~s" (length args) 'name)))
@ -7485,16 +7488,25 @@
(define build-flneg
(lambda (e can-unbox-fp?)
(build-fl-adjust-sign e can-unbox-fp? %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+
[() `(quote 0.0)]
[(e) (ensure-single-valued e)]
[(e) (maybe-build-fp-boxed can-unbox-fp? (ensure-single-valued e))]
[(e1 e2) (build-fp-op-2 can-unbox-fp? %fp+ e1 e2)]
[(e1 . e*) (reduce-fp src sexpr 3 'fl+ e1 e*)])
(define-inline 3 fl*
[() `(quote 1.0)]
[(e) (ensure-single-valued e)]
[(e) (maybe-build-fp-boxed can-unbox-fp? (ensure-single-valued e))]
[(e1 e2) (build-fp-op-2 can-unbox-fp? %fp* e1 e2)]
[(e1 . e*) (reduce-fp src sexpr 3 'fl* e1 e*)])
@ -7741,13 +7753,15 @@
(let ()
(define build-checked-fp-op
(case-lambda
[(e k)
(if (known-flonum-result? e)
e
(bind #t (e)
`(if ,(build-flonums? (list e))
,e
,(k e))))]
[(e can-unbox-fp? k)
(maybe-build-fp-boxed
can-unbox-fp?
(if (known-flonum-result? e)
e
(bind #t (e)
`(if ,(build-flonums? (list e))
,e
,(k e)))))]
[(e1 op can-unbox-fp? k) ; `op` can be a procedure that produces an implicitly unboxed value
(if (known-flonum-result? e1)
(build-fp-op-1 can-unbox-fp? op e1)
@ -7789,7 +7803,7 @@
(define-inline 2 fl+
[() `(quote 0.0)]
[(e) (build-checked-fp-op e
[(e) (build-checked-fp-op e can-unbox-fp?
(lambda (e)
(build-libcall #t src sexpr fl+ e `(quote 0.0))))]
[(e1 e2) (build-checked-fp-op e1 e2 %fp+ can-unbox-fp?
@ -7799,7 +7813,7 @@
(define-inline 2 fl*
[() `(quote 1.0)]
[(e) (build-checked-fp-op e
[(e) (build-checked-fp-op e can-unbox-fp?
(lambda (e)
(build-libcall #t src sexpr fl* e `(quote 1.0))))]
[(e1 e2) (build-checked-fp-op e1 e2 %fp* can-unbox-fp?