From c6029cacf83366e505e9c2d0742c1f311f79d73b Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 14 Feb 2013 15:54:24 -0500 Subject: [PATCH] Fix optimizations for complex unboxing. Omitted parts were not used properly. --- .../typed-racket/optimizer/float-complex.rkt | 84 ++++++++++++------- 1 file changed, 54 insertions(+), 30 deletions(-) diff --git a/collects/typed-racket/optimizer/float-complex.rkt b/collects/typed-racket/optimizer/float-complex.rkt index 3c2b9e9cd5..425ed461a9 100644 --- a/collects/typed-racket/optimizer/float-complex.rkt +++ b/collects/typed-racket/optimizer/float-complex.rkt @@ -30,6 +30,11 @@ (define complex-unboxing-opt-msg "Complex number unboxing.") (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 ;; its parts than it is to use generic operations ;; we keep the real and imaginary parts unboxed as long as we stay within @@ -81,7 +86,7 @@ (let () ;; unlike addition, we simply can't skip real parts of imaginaries (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 (l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0))) (cdr l1)))) @@ -110,9 +115,9 @@ #`(c1.bindings ... c2.bindings ... cs.bindings ... ... ;; we want to bind the intermediate results to reuse them ;; 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 ...))) - (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 ...)))) (let loop ([o1 (car lr)] [o2 (car li)] @@ -154,9 +159,9 @@ #:when (or (subtypeof? this-syntax -FloatComplex) (subtypeof? this-syntax -Number)) #:with real-binding (unboxed-gensym "unboxed-real-") #: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 ...)) - #: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 ...)) #:with (bindings ...) (begin (log-optimization "unboxed binary float complex" @@ -231,11 +236,14 @@ this-syntax) (add-disappeared-use #'op) #`(#,@(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) #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding #f + #:with imag-binding #'#f #:with (bindings ...) (begin (log-optimization "unboxed unary float complex" complex-unboxing-opt-msg @@ -243,8 +251,16 @@ (add-disappeared-use #'op) #`(c.bindings ... ((real-binding) (unsafe-flsqrt - (unsafe-fl+ (unsafe-fl* c.real-binding c.real-binding) - (unsafe-fl* c.imag-binding c.imag-binding))))))) + #,(cond [(not (syntax->datum #'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) #:with real-binding (unboxed-gensym "unboxed-real-") @@ -256,14 +272,21 @@ this-syntax) (add-disappeared-use #'op) #`(c.bindings ... - ((scaling-factor) (unsafe-flexp c.real-binding)) - ((real-binding) (unsafe-fl* (unsafe-flcos c.imag-binding) scaling-factor)) - ((imag-binding) (unsafe-fl* (unsafe-flsin c.imag-binding) scaling-factor))))) + ((scaling-factor) #,(if (syntax->datum #'c.real-binding) + #'(unsafe-flexp c.real-binding) + ;; 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))) c:unboxed-float-complex-opt-expr) #:with real-binding #'c.real-binding - #:with imag-binding #f + #:with imag-binding #'#f #:with (bindings ...) (begin (log-optimization "unboxed unary float complex" complex-unboxing-opt-msg @@ -273,7 +296,7 @@ (pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part))) c:unboxed-float-complex-opt-expr) #:with real-binding #'c.imag-binding - #:with imag-binding #f + #:with imag-binding #'#f #:with (bindings ...) (begin (log-optimization "unboxed unary float complex" complex-unboxing-opt-msg @@ -285,7 +308,7 @@ ;; must be after any cases that we are supposed to handle (pattern e:float-arg-expr #:with real-binding (unboxed-gensym 'unboxed-float-) - #:with imag-binding #f + #:with imag-binding #'#f #:with (bindings ...) (begin (log-optimization "float-arg-expr in complex ops" complex-unboxing-opt-msg @@ -362,7 +385,7 @@ (pattern (quote n) #:when (real? (syntax->datum #'n)) #:with real-binding (unboxed-gensym "unboxed-real-") - #:with imag-binding #f + #:with imag-binding #'#f #:with (bindings ...) (begin (log-optimization "unboxed literal" complex-unboxing-opt-msg @@ -398,8 +421,8 @@ (pattern e:expr #:with (bindings ...) (error (format "non exhaustive pattern match" #'e)) - #:with real-binding #f - #:with imag-binding #f)) + #:with real-binding #'#f + #:with imag-binding #'#f)) (define-syntax-class float-complex-unary-op #:commit @@ -480,8 +503,8 @@ #,(if (or (free-identifier=? #'op #'real-part) (free-identifier=? #'op #'flreal-part) (free-identifier=? #'op #'unsafe-flreal-part)) - #'c*.real-binding - #'c*.imag-binding)))) + (get-part-or-0.0 #'c*.real-binding) + (get-part-or-0.0 #'c*.imag-binding))))) (pattern (#%plain-app op:float-complex-unary-op n:float-complex-expr) #:with opt @@ -499,9 +522,9 @@ this-syntax) (add-disappeared-use #'op) (reset-unboxed-gensym) - #'(let*-values (exp*.bindings ...) - (unsafe-make-flrectangular exp*.real-binding - exp*.imag-binding)))) + #`(let*-values (exp*.bindings ...) + (unsafe-make-flrectangular #,(get-part-or-0.0 #'exp*.real-binding) + #,(get-part-or-0.0 #'exp*.imag-binding))))) (pattern (#%plain-app op:id args:expr ...) #:with unboxed-info (dict-ref unboxed-funs-table #'op #f) @@ -525,13 +548,13 @@ #:when (subtypeof? this-syntax -Flonum) #:with exp*:unboxed-float-complex-opt-expr this-syntax #:with real-binding #'exp*.real-binding - #:with imag-binding #f + #:with imag-binding #'#f #:with (bindings ...) #'(exp*.bindings ...) #:with opt (begin (reset-unboxed-gensym) (add-disappeared-use #'op) - #'(let*-values (exp*.bindings ...) - real-binding))) + #`(let*-values (exp*.bindings ...) + #,(get-part-or-0.0 #'real-binding)))) (pattern (#%plain-app op:float-complex-op e:expr ...) #:when (subtypeof? this-syntax -FloatComplex) @@ -542,8 +565,9 @@ #:with opt (begin (reset-unboxed-gensym) (add-disappeared-use #'op) - #'(let*-values (exp*.bindings ...) - (unsafe-make-flrectangular exp*.real-binding exp*.imag-binding)))) + #`(let*-values (exp*.bindings ...) + (unsafe-make-flrectangular #,(get-part-or-0.0 #'exp*.real-binding) + #,(get-part-or-0.0 #'exp*.imag-binding))))) (pattern v:id #:with unboxed-info (dict-ref unboxed-vars-table #'v #f) @@ -588,7 +612,7 @@ (reset-unboxed-gensym) #`(let*-values (e.bindings ... ...) (#%plain-app #,opt-operator - e.real-binding ... - e.imag-binding ... + #,@(syntax-map get-part-or-0.0 #'(e.real-binding ...)) + #,@(syntax-map get-part-or-0.0 #'(e.imag-binding ...)) #,@(map (lambda (i) ((optimize) (get-arg i))) boxed)))])))) ; boxed params