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

improve local-variable unboxing

Browse Source 
Generalize the `np-unbox-fp-vars!` pass to avoid a shallow "known
flonum?" guard.

original commit: d938bac6b720c56a2592dabccafe4954d695d1f7
This commit is contained in:
Matthew Flatt 2020-06-16 06:39:28 -06:00
parent d9621ebedf
commit e4d5ece617
3 changed files with 117 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
mats/fl.ms
View File

@ -1113,6 +1113,9 @@
(set! i (flonum->fixnum v))
(fl+ v 1.0)))))
(check-loop-allocation (lambda (v) (let ([u (fl+ v v)])
(fl* u u))))
(check-loop-allocation (lambda (v) (if (fl= (fl+ v (fl* 2.0 v)) 7.0)
(fl+ v 1.0)
(fl- v 1.0))))
@ -1143,6 +1146,21 @@
(check-loop-allocation (lambda (v) (begin
(bytevector-ieee-double-native-set! bv 0 (fl+ v 0.1))
(fl* v 0.99)))))
(let ([bv (make-bytevector 8 0)])
(check-loop-allocation (lambda (v) (let ([v (fl+ v 1.0)])
(bytevector-ieee-double-native-set! bv 0 v)
(fl* v 0.99)))))
(or (not (enable-cp0))
(let ()
(define-record pseudo-random-generator
((mutable double x10) (mutable double x11) (mutable double x12)
(mutable double x20) (mutable double x21) (mutable double x22))
())
(let ([s (make-pseudo-random-generator 1.0 2.0 3.0 4.0 5.0 6.0)])
(check-loop-allocation (lambda (v) (let ([v (fl+ (pseudo-random-generator-x10 s) 1.0)])
(set-pseudo-random-generator-x11! s v)
(set-pseudo-random-generator-x12! s v)
(pseudo-random-generator-x20 s)))))))
(begin
(define many-compare

138
s/cpnanopass.ss
View File

@ -2939,9 +2939,15 @@
[,x (and (uvar? x) (eq? (uvar-type x) 'fp))]
[(quote ,d) (flonum? d)]
[(call ,info ,mdcl ,pr ,e* ...)
(eq? 'flonum ($sgetprop (primref-name pr) '*result-type* #f))]
(or (eq? 'flonum ($sgetprop (primref-name pr) '*result-type* #f))
(and (eq? '$object-ref (primref-name pr))
(pair? e*)
(nanopass-case (L7 Expr) (car e*)
[(quote ,d) (eq? d 'double)])))]
[(seq ,e0 ,e1) (flonum-result? e1 (fx- fuel 1))]
[(let ([,x* ,e*] ...) ,body) (flonum-result? body (fx- fuel 1))]
[(if ,e1 ,e2 ,e3) (and (flonum-result? e2 (fxsrl fuel 1))
(flonum-result? e3 (fxsrl fuel 1)))]
[else #f]))))
(define-pass np-unbox-fp-vars! : L7 (ir) -> L7 ()
@ -2987,61 +2993,114 @@
(let* ([b (last-box b)]
[l (unbox b)])
(set-box! b '())
(for-each ensure-not-unboxed! l))))))))
(Expr : Expr (ir) -> Expr ()
(for-each ensure-not-unboxed! l)))))))
(define primref-flonum-result?
(lambda (pr)
(eq? 'flonum ($sgetprop (primref-name pr) '*result-type* #f)))))
(Expr : Expr (ir [lhs #f]) -> * (#f) ; result is whether the expression produces a flonum
[(quote ,d) (flonum? d)]
[,pr #f]
[(if ,[e0 #f -> * fp?] ,e1 ,e2)
(let ([fp1? (Expr e1 lhs)]
[fp2? (Expr e2 lhs)])
(and fp1? fp2?))]
[(seq ,[e0 #f -> * fp?] ,e1)
(Expr e1 lhs)]
[,lvalue (Lvalue lvalue lhs)]
[(let ([,x* ,e*] ...) ,body)
(for-each (lambda (x e)
(nanopass-case (L7 Expr) e
[,x1
(guard (and (uvar? x1) (eq? (uvar-type x1) 'fp)))
(unify-boxed! x x1)]
[else
(Expr e)])
(when (known-flonum-result? e)
(uvar-type-set! x 'fp)))
;; Optimistically assume 'fp, so it will unify ok with
;; another variable that might be 'fp
(uvar-type-set! x 'fp)
(unless (Expr e x)
(ensure-not-unboxed! x)))
x* e*)
(Expr body)
(for-each (lambda (x) (uvar-location-set! x #f)) x*)
ir]
(let ([fp? (Expr body lhs)])
(for-each (lambda (x) (uvar-location-set! x #f)) x*)
fp?)]
[(call ,info ,mdcl ,pr ,e* ...)
(guard (and (all-set? (prim-mask unboxed-arguments) (primref-flags pr))
(let ([n (length e*)]
[i* (primref-arity pr)])
(and (ormap (lambda (i) (if (fx< i 0) (fx>= n (fx- -1 i)) (fx= n i))) i*)
(fx<= n (constant inline-args-limit))))))
(for-each (lambda (e)
(nanopass-case (L7 Expr) e
[,x (void)] ; allow x to keep 'fp type
[else (Expr e)]))
e*)
ir]
(for-each (lambda (e) (Expr e #t)) e*)
(primref-flonum-result? pr)]
[(call ,info ,mdcl ,pr ,e1 ,[e2 #f -> * fp?2] ,[e3 #f -> * fp?3] ,e4)
(guard (and (eq? '$object-set! (primref-name pr))
(nanopass-case (L7 Expr) e1
[(quote ,d) (eq? d 'double)])))
(Expr e4 #t)
#f]
[(call ,info ,mdcl ,pr ,e1 ,[e2 #f -> * fp?2] ,[e3 #f -> * fp?3])
(guard (and (eq? '$object-ref (primref-name pr))
(nanopass-case (L7 Expr) e1
[(quote ,d) (eq? d 'double)])))
#t]
[(call ,info ,mdcl ,pr ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2] ,e3)
(guard (eq? 'bytevector-ieee-double-native-set! (primref-name pr)))
(Expr e3 #t)
#f]
[(call ,info ,mdcl ,pr ,[e* #f -> * fp?] ...)
(primref-flonum-result? pr)]
[(loop ,x (,x* ...) ,body)
(safe-assert (uvar-loop? x))
(uvar-location-set! x x*)
(Expr body)
(uvar-location-set! x #f)
ir]
(let ([fp? (Expr body lhs)])
(uvar-location-set! x #f)
fp?)]
[(call ,info ,mdcl ,x ,e* ...)
(guard (uvar-loop? x))
(let ([x* (uvar-location x)])
(for-each (lambda (x e)
(cond
[(eq? (uvar-type x) 'fp)
(nanopass-case (L7 Expr) e
[,x1
(guard (and (uvar? x1) (eq? (uvar-type x1) 'fp)))
(unify-boxed! x x1)]
[else
(Expr e)
(unless (known-flonum-result? e)
(ensure-not-unboxed! x))])]
[else (Expr e)]))
(unless (Expr e x)
(ensure-not-unboxed! x)))
x* e*))
ir])
(Lvalue : Lvalue (ir) -> Lvalue ()
;; Assume fp result until proven otherwise:
#t]
[(call ,info ,mdcl ,[e #f -> * fp?] ,[e* #f -> * fp?*] ...)
#f]
[(mvcall ,info ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2]) #f]
[(mvlet ,[e #f -> * fp?] ((,x** ...) ,interface* ,[body* #f -> * body-fp?]) ...)
(andmap values body-fp?)]
[(set! ,x ,e)
(unless (Expr e x)
(ensure-not-unboxed! x))
#f]
[(set! ,[lvalue #f -> * fp?l] ,[e #f -> * fp?])
#f]
[(unboxed-fp ,[e #f -> * fp?])
#t]
[(alloc ,info ,[e #f -> * fp?]) #f]
[(goto ,l) #f]
[(label ,l ,body) (Expr body lhs)]
[(label-ref ,l ,offset) #f]
[(values ,info ,[e* #f -> * fp?] ...) #f]
[(inline ,info ,prim ,[e* #f -> * fp?] ...) #f]
[(immediate ,imm) #f]
[(literal ,info) #f]
[(attachment-set ,aop ,[e #f -> * fp?]) #f]
[(attachment-get ,reified ,[e #f -> * fp?]) #f]
[(attachment-consume ,reified ,[e #f -> * fp?]) #f]
[(continuation-get) #f]
[(continuation-set ,cop ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2]) #f]
[(foreign-call ,info ,[e #f -> * fp?] ,[e* #f -> * fp?*] ...) #f]
[(profile ,src) #f]
[(pariah) #f])
(Lvalue : Lvalue (ir [lhs #f]) -> * (#f)
[,x
(ensure-not-unboxed! x)
ir]))
(guard (uvar? x))
(cond
[(not lhs) (ensure-not-unboxed! x)]
[(eq? lhs #t) (void)]
[(not (eq? (uvar-type lhs) 'fp)) (ensure-not-unboxed! x)]
[(not (eq? (uvar-type x) 'fp)) (ensure-not-unboxed! lhs)]
[else (unify-boxed! x lhs)])
(eq? (uvar-type x) 'fp)]
[,x #f]
[(mref ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2] ,imm ,type) (eq? type 'fp)])
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
[(clause (,x* ...) ,mcp ,interface ,body) (Expr body #f) ir]))
(define target-fixnum?
(if (and (= (constant most-negative-fixnum) (most-negative-fixnum))
@ -4163,8 +4222,7 @@
[(scheme-object) (build-dirty-store base index offset value)]
[(double-float)
(bind #f (base index)
(bind #f fp (value)
`(set! ,(%mref ,base ,index ,offset fp) ,value)))]
`(set! ,(%mref ,base ,index ,offset fp) ,value))]
[(single-float)
(bind #f (base index)
`(inline ,(make-info-unboxed-args '(#t #t)) ,%store-double->single

2
s/primdata.ss
View File

@ -1331,7 +1331,7 @@
(fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments
(fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments
(fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments
(fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments
(flush-output-port [sig [() (output-port) -> (void)]] [flags true]) ; not restricted to 1 argument
(foreign-entry? [sig [(string) -> (boolean)]] [flags discard])
(foreign-entry [sig [(string) -> (uptr)]] [flags discard true])