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

Fix optimizations for complex unboxing.

Browse Source 
Omitted parts were not used properly.
This commit is contained in:
Vincent St-Amour 2013-02-14 15:54:24 -05:00
parent 29a181175f
commit c6029cacf8
1 changed files with 54 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
collects/typed-racket/optimizer/float-complex.rkt
View File

@ -30,6 +30,11 @@
(define complex-unboxing-opt-msg "Complex number unboxing.") (define complex-unboxing-opt-msg "Complex number unboxing.")
(define arity-raising-opt-msg "Complex number arity raising.") (define arity-raising-opt-msg "Complex number arity raising.")
(define (get-part-or-0.0 stx) ; if a component is unavailable, pretend it's 0.0
(if (syntax->datum stx)
stx
#'0.0))
;; it's faster to take apart a complex number and use unsafe operations on ;; it's faster to take apart a complex number and use unsafe operations on
;; its parts than it is to use generic operations ;; its parts than it is to use generic operations
;; we keep the real and imaginary parts unboxed as long as we stay within ;; we keep the real and imaginary parts unboxed as long as we stay within
@ -81,7 +86,7 @@
(let () (let ()
;; unlike addition, we simply can't skip real parts of imaginaries ;; unlike addition, we simply can't skip real parts of imaginaries
(define (skip-0s l) (define (skip-0s l)
(let* ((l1 (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) l)) (let* ((l1 (syntax-map get-part-or-0.0 l))
;; but we can skip all but the first 0 ;; but we can skip all but the first 0
(l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0))) (l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0)))
(cdr l1)))) (cdr l1))))
@ -110,9 +115,9 @@
#`(c1.bindings ... c2.bindings ... cs.bindings ... ... #`(c1.bindings ... c2.bindings ... cs.bindings ... ...
;; we want to bind the intermediate results to reuse them ;; we want to bind the intermediate results to reuse them
;; the final results are bound to real-binding and imag-binding ;; the final results are bound to real-binding and imag-binding
#,@(let ((lr (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) #,@(let ((lr (syntax-map get-part-or-0.0
#'(c1.real-binding c2.real-binding cs.real-binding ...))) #'(c1.real-binding c2.real-binding cs.real-binding ...)))
(li (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) (li (syntax-map get-part-or-0.0
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))) #'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))
(let loop ([o1 (car lr)] (let loop ([o1 (car lr)]
[o2 (car li)] [o2 (car li)]
@ -154,9 +159,9 @@
#:when (or (subtypeof? this-syntax -FloatComplex) (subtypeof? this-syntax -Number)) #:when (or (subtypeof? this-syntax -FloatComplex) (subtypeof? this-syntax -Number))
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with reals (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) #:with reals (syntax-map get-part-or-0.0
#'(c1.real-binding c2.real-binding cs.real-binding ...)) #'(c1.real-binding c2.real-binding cs.real-binding ...))
#:with imags (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) #:with imags (syntax-map get-part-or-0.0
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...)) #'(c1.imag-binding c2.imag-binding cs.imag-binding ...))
#:with (bindings ...) #:with (bindings ...)
(begin (log-optimization "unboxed binary float complex" (begin (log-optimization "unboxed binary float complex"
@ -231,11 +236,14 @@
this-syntax) this-syntax)
(add-disappeared-use #'op) (add-disappeared-use #'op)
#`(#,@(append (syntax->list #'(c.bindings ...)) #`(#,@(append (syntax->list #'(c.bindings ...))
(list #'((imag-binding) (unsafe-fl- 0.0 c.imag-binding))))))) (list #`((imag-binding) #,(if (syntax->datum #'c.imag-binding)
#'(unsafe-fl- 0.0 c.imag-binding)
;; our input has no imaginary part
#'0.0)))))))
(pattern (#%plain-app (~and op (~literal magnitude)) c:unboxed-float-complex-opt-expr) (pattern (#%plain-app (~and op (~literal magnitude)) c:unboxed-float-complex-opt-expr)
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding #f #:with imag-binding #'#f
#:with (bindings ...) #:with (bindings ...)
(begin (log-optimization "unboxed unary float complex" (begin (log-optimization "unboxed unary float complex"
complex-unboxing-opt-msg complex-unboxing-opt-msg
@ -243,8 +251,16 @@
(add-disappeared-use #'op) (add-disappeared-use #'op)
#`(c.bindings ... #`(c.bindings ...
((real-binding) (unsafe-flsqrt ((real-binding) (unsafe-flsqrt
(unsafe-fl+ (unsafe-fl* c.real-binding c.real-binding) #,(cond [(not (syntax->datum #'c.imag-binding))
(unsafe-fl* c.imag-binding c.imag-binding))))))) ;; just the real part (has to have at least 1 part)
#'(unsafe-fl* c.real-binding c.real-binding)]
[(not (syntax->datum #'c.real-binding))
;; just the imaginary part
#'(unsafe-fl* c.imag-binding c.imag-binding)]
[else
;; both parts
#'(unsafe-fl+ (unsafe-fl* c.real-binding c.real-binding)
(unsafe-fl* c.imag-binding c.imag-binding))]))))))
(pattern (#%plain-app (~and op (~literal exp)) c:unboxed-float-complex-opt-expr) (pattern (#%plain-app (~and op (~literal exp)) c:unboxed-float-complex-opt-expr)
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
@ -256,14 +272,21 @@
this-syntax) this-syntax)
(add-disappeared-use #'op) (add-disappeared-use #'op)
#`(c.bindings ... #`(c.bindings ...
((scaling-factor) (unsafe-flexp c.real-binding)) ((scaling-factor) #,(if (syntax->datum #'c.real-binding)
((real-binding) (unsafe-fl* (unsafe-flcos c.imag-binding) scaling-factor)) #'(unsafe-flexp c.real-binding)
((imag-binding) (unsafe-fl* (unsafe-flsin c.imag-binding) scaling-factor))))) ;; our input has no real part, pretend it's 0.0
#'1.0))
((real-binding) #,(if (syntax->datum #'c.imag-binding)
#'(unsafe-fl* (unsafe-flcos c.imag-binding) scaling-factor)
#'0.0))
((imag-binding) #,(if (syntax->datum #'c.imag-binding)
#'(unsafe-fl* (unsafe-flsin c.imag-binding) scaling-factor)
#'0.0)))))
(pattern (#%plain-app (~and op (~or (~literal real-part) (~literal unsafe-flreal-part))) (pattern (#%plain-app (~and op (~or (~literal real-part) (~literal unsafe-flreal-part)))
c:unboxed-float-complex-opt-expr) c:unboxed-float-complex-opt-expr)
#:with real-binding #'c.real-binding #:with real-binding #'c.real-binding
#:with imag-binding #f #:with imag-binding #'#f
#:with (bindings ...) #:with (bindings ...)
(begin (log-optimization "unboxed unary float complex" (begin (log-optimization "unboxed unary float complex"
complex-unboxing-opt-msg complex-unboxing-opt-msg
@ -273,7 +296,7 @@
(pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part))) (pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part)))
c:unboxed-float-complex-opt-expr) c:unboxed-float-complex-opt-expr)
#:with real-binding #'c.imag-binding #:with real-binding #'c.imag-binding
#:with imag-binding #f #:with imag-binding #'#f
#:with (bindings ...) #:with (bindings ...)
(begin (log-optimization "unboxed unary float complex" (begin (log-optimization "unboxed unary float complex"
complex-unboxing-opt-msg complex-unboxing-opt-msg
@ -285,7 +308,7 @@
;; must be after any cases that we are supposed to handle ;; must be after any cases that we are supposed to handle
(pattern e:float-arg-expr (pattern e:float-arg-expr
#:with real-binding (unboxed-gensym 'unboxed-float-) #:with real-binding (unboxed-gensym 'unboxed-float-)
#:with imag-binding #f #:with imag-binding #'#f
#:with (bindings ...) #:with (bindings ...)
(begin (log-optimization "float-arg-expr in complex ops" (begin (log-optimization "float-arg-expr in complex ops"
complex-unboxing-opt-msg complex-unboxing-opt-msg
@ -362,7 +385,7 @@
(pattern (quote n) (pattern (quote n)
#:when (real? (syntax->datum #'n)) #:when (real? (syntax->datum #'n))
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding #f #:with imag-binding #'#f
#:with (bindings ...) #:with (bindings ...)
(begin (log-optimization "unboxed literal" (begin (log-optimization "unboxed literal"
complex-unboxing-opt-msg complex-unboxing-opt-msg
@ -398,8 +421,8 @@
(pattern e:expr (pattern e:expr
#:with (bindings ...) #:with (bindings ...)
(error (format "non exhaustive pattern match" #'e)) (error (format "non exhaustive pattern match" #'e))
#:with real-binding #f #:with real-binding #'#f
#:with imag-binding #f)) #:with imag-binding #'#f))
(define-syntax-class float-complex-unary-op (define-syntax-class float-complex-unary-op
#:commit #:commit
@ -480,8 +503,8 @@
#,(if (or (free-identifier=? #'op #'real-part) #,(if (or (free-identifier=? #'op #'real-part)
(free-identifier=? #'op #'flreal-part) (free-identifier=? #'op #'flreal-part)
(free-identifier=? #'op #'unsafe-flreal-part)) (free-identifier=? #'op #'unsafe-flreal-part))
#'c*.real-binding (get-part-or-0.0 #'c*.real-binding)
#'c*.imag-binding)))) (get-part-or-0.0 #'c*.imag-binding)))))
(pattern (#%plain-app op:float-complex-unary-op n:float-complex-expr) (pattern (#%plain-app op:float-complex-unary-op n:float-complex-expr)
#:with opt #:with opt
@ -499,9 +522,9 @@
this-syntax) this-syntax)
(add-disappeared-use #'op) (add-disappeared-use #'op)
(reset-unboxed-gensym) (reset-unboxed-gensym)
#'(let*-values (exp*.bindings ...) #`(let*-values (exp*.bindings ...)
(unsafe-make-flrectangular exp*.real-binding (unsafe-make-flrectangular #,(get-part-or-0.0 #'exp*.real-binding)
exp*.imag-binding)))) #,(get-part-or-0.0 #'exp*.imag-binding)))))
(pattern (#%plain-app op:id args:expr ...) (pattern (#%plain-app op:id args:expr ...)
#:with unboxed-info (dict-ref unboxed-funs-table #'op #f) #:with unboxed-info (dict-ref unboxed-funs-table #'op #f)
@ -525,13 +548,13 @@
#:when (subtypeof? this-syntax -Flonum) #:when (subtypeof? this-syntax -Flonum)
#:with exp*:unboxed-float-complex-opt-expr this-syntax #:with exp*:unboxed-float-complex-opt-expr this-syntax
#:with real-binding #'exp*.real-binding #:with real-binding #'exp*.real-binding
#:with imag-binding #f #:with imag-binding #'#f
#:with (bindings ...) #'(exp*.bindings ...) #:with (bindings ...) #'(exp*.bindings ...)
#:with opt #:with opt
(begin (reset-unboxed-gensym) (begin (reset-unboxed-gensym)
(add-disappeared-use #'op) (add-disappeared-use #'op)
#'(let*-values (exp*.bindings ...) #`(let*-values (exp*.bindings ...)
real-binding))) #,(get-part-or-0.0 #'real-binding))))
(pattern (#%plain-app op:float-complex-op e:expr ...) (pattern (#%plain-app op:float-complex-op e:expr ...)
#:when (subtypeof? this-syntax -FloatComplex) #:when (subtypeof? this-syntax -FloatComplex)
@ -542,8 +565,9 @@
#:with opt #:with opt
(begin (reset-unboxed-gensym) (begin (reset-unboxed-gensym)
(add-disappeared-use #'op) (add-disappeared-use #'op)
#'(let*-values (exp*.bindings ...) #`(let*-values (exp*.bindings ...)
(unsafe-make-flrectangular exp*.real-binding exp*.imag-binding)))) (unsafe-make-flrectangular #,(get-part-or-0.0 #'exp*.real-binding)
#,(get-part-or-0.0 #'exp*.imag-binding)))))
(pattern v:id (pattern v:id
#:with unboxed-info (dict-ref unboxed-vars-table #'v #f) #:with unboxed-info (dict-ref unboxed-vars-table #'v #f)
@ -588,7 +612,7 @@
(reset-unboxed-gensym) (reset-unboxed-gensym)
#`(let*-values (e.bindings ... ...) #`(let*-values (e.bindings ... ...)
(#%plain-app #,opt-operator (#%plain-app #,opt-operator
e.real-binding ... #,@(syntax-map get-part-or-0.0 #'(e.real-binding ...))
e.imag-binding ... #,@(syntax-map get-part-or-0.0 #'(e.imag-binding ...))
#,@(map (lambda (i) ((optimize) (get-arg i))) #,@(map (lambda (i) ((optimize) (get-arg i)))
boxed)))])))) ; boxed params boxed)))])))) ; boxed params