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

Fix to tolerate complexes of unknown exactness inside inexact-complex

Browse Source 
expressions.
This commit is contained in:
Vincent St-Amour 2010-07-25 18:45:18 -04:00
parent 83cde5c8fb
commit 1b998f25e5
2 changed files with 71 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
collects/typed-scheme/optimizer/inexact-complex.rkt
View File

@ -11,7 +11,7 @@
;; contains the bindings which actually exist as separate bindings for each component
;; associates identifiers to lists (real-part imag-part)
;; associates identifiers to lists (real-binding imag-binding)
(define unboxed-vars-table (make-free-id-table))
;; it's faster to take apart a complex number and use unsafe operations on
@ -24,8 +24,8 @@
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
@ -41,15 +41,15 @@
((e (cdr l)))
#`(unsafe-fl+ #,o #,e))))))
(list
#`(real-part #,(skip-0s #'(c1.real-part c2.real-part cs.real-part ...)))
#`(imag-part #,(skip-0s #'(c1.imag-part c2.imag-part cs.imag-part ...)))))))))
#`(real-binding #,(skip-0s #'(c1.real-binding c2.real-binding cs.real-binding ...)))
#`(imag-binding #,(skip-0s #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))))))))
(pattern (#%plain-app (~and op (~literal -))
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
@ -68,34 +68,34 @@
((e l2))
#`(unsafe-fl- #,o #,e))))))
(list
#`(real-part #,(skip-0s #'(c1.real-part c2.real-part cs.real-part ...)))
#`(imag-part #,(skip-0s #'(c1.imag-part c2.imag-part cs.imag-part ...)))))))))
#`(real-binding #,(skip-0s #'(c1.real-binding c2.real-binding cs.real-binding ...)))
#`(imag-binding #,(skip-0s #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))))))))
(pattern (#%plain-app (~and op (~literal *))
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
;; we want to bind the intermediate results to reuse them
;; the final results are bound to real-part and imag-part
;; the final results are bound to real-binding and imag-binding
#,@(let ((lr (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-part c2.real-part cs.real-part ...))))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...))))
(li (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))))
(syntax->list #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))))
(let loop ([o1 (car lr)]
[o2 (car li)]
[e1 (cdr lr)]
[e2 (cdr li)]
[rs (append (map (lambda (x) (unboxed-gensym))
(syntax->list #'(cs.real-part ...)))
(list #'real-part))]
(syntax->list #'(cs.real-binding ...)))
(list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym))
(syntax->list #'(cs.imag-part ...)))
(list #'imag-part))]
(syntax->list #'(cs.imag-binding ...)))
(list #'imag-binding))]
[res '()])
(if (null? e1)
(reverse res)
@ -123,29 +123,29 @@
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with reals (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-part c2.real-part cs.real-part ...)))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...)))
#:with imags (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))
(syntax->list #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
;; we want to bind the intermediate results to reuse them
;; the final results are bound to real-part and imag-part
;; the final results are bound to real-binding and imag-binding
#,@(let loop ([o1 (car (syntax->list #'reals))]
[o2 (car (syntax->list #'imags))]
[e1 (cdr (syntax->list #'reals))]
[e2 (cdr (syntax->list #'imags))]
[rs (append (map (lambda (x) (unboxed-gensym))
(syntax->list #'(cs.real-part ...)))
(list #'real-part))]
(syntax->list #'(cs.real-binding ...)))
(list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym))
(syntax->list #'(cs.imag-part ...)))
(list #'imag-part))]
(syntax->list #'(cs.imag-binding ...)))
(list #'imag-binding))]
[ds (map (lambda (x) (unboxed-gensym))
(syntax->list #'(c2.real-part cs.real-part ...)))]
(syntax->list #'(c2.real-binding cs.real-binding ...)))]
[res '()])
(if (null? e1)
(reverse res)
@ -190,24 +190,24 @@
res)]))))))))
(pattern (#%plain-app (~and op (~literal conjugate)) c:unboxed-inexact-complex-opt-expr)
#:with real-part #'c.real-part
#:with imag-part (unboxed-gensym)
#:with real-binding #'c.real-binding
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
(begin (log-optimization "unboxed unary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c.bindings ...))
(list #'(imag-part (unsafe-fl- 0.0 c.imag-part)))))))
(list #'(imag-binding (unsafe-fl- 0.0 c.imag-binding)))))))
(pattern (#%plain-app (~and op (~or (~literal real-part) (~literal unsafe-flreal-part)))
c:unboxed-inexact-complex-opt-expr)
#:with real-part #'c.real-part
#:with imag-part #f
#:with real-binding #'c.real-binding
#:with imag-binding #f
#:with (bindings ...)
(begin (log-optimization "unboxed unary inexact complex" #'op)
#'(c.bindings ...)))
(pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part)))
c:unboxed-inexact-complex-opt-expr)
#:with real-part #'c.imag-part
#:with imag-part #f
#:with real-binding #'c.imag-binding
#:with imag-binding #f
#:with (bindings ...)
(begin (log-optimization "unboxed unary inexact complex" #'op)
#'(c.bindings ...)))
@ -216,47 +216,54 @@
(pattern v:id
#:with unboxed-info (dict-ref unboxed-vars-table #'v #f)
#:when (syntax->datum #'unboxed-info)
#:with real-part (car (syntax->list #'unboxed-info))
#:with imag-part (cadr (syntax->list #'unboxed-info))
#:with real-binding (car (syntax->list #'unboxed-info))
#:with imag-binding (cadr (syntax->list #'unboxed-info))
#:with (bindings ...) #'())
;; else, do the unboxing here
(pattern e:expr
#:when (isoftype? #'e -InexactComplex)
#:with e* (unboxed-gensym)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
#`((e* #,((optimize) #'e))
(real-part (unsafe-flreal-part e*))
(imag-part (unsafe-flimag-part e*))))
(real-binding (unsafe-flreal-part e*))
(imag-binding (unsafe-flimag-part e*))))
;; special handling of reals
(pattern e:float-expr
#:with real-part (unboxed-gensym)
#:with imag-part #f
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`((real-part #,((optimize) #'e))))
#`((real-binding #,((optimize) #'e))))
(pattern e:fixnum-expr
#:with real-part (unboxed-gensym)
#:with imag-part #f
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`((real-part (unsafe-fx->fl #,((optimize) #'e)))))
#`((real-binding (unsafe-fx->fl #,((optimize) #'e)))))
(pattern e:int-expr
#:with real-part (unboxed-gensym)
#:with imag-part #f
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`((real-part (->fl #,((optimize) #'e)))))
#`((real-binding (->fl #,((optimize) #'e)))))
(pattern e:expr
#:when (isoftype? #'e -Real)
#:with real-part (unboxed-gensym)
#:with imag-part #f
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`((real-part (exact->inexact #,((optimize) #'e)))))
#`((real-binding (exact->inexact #,((optimize) #'e)))))
(pattern e:expr
#:when (isoftype? #'e -Number) ; complex, maybe exact, maybe not
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
#`((real-binding (real-part #,((optimize) #'e)))
(imag-binding (imag-part #,((optimize) #'e)))))
(pattern e:expr
#:with (bindings ...)
(error "non exhaustive pattern match")
#:with real-part #f
#:with imag-part #f))
#:with real-binding #f
#:with imag-binding #f))
(define-syntax-class inexact-complex-unary-op
(pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part)
@ -284,8 +291,8 @@
#`(let* (c*.bindings ...)
#,(if (or (free-identifier=? #'op #'real-part)
(free-identifier=? #'op #'unsafe-flreal-part))
#'c*.real-part
#'c*.imag-part))))
#'c*.real-binding
#'c*.imag-binding))))
(pattern (#%plain-app op:inexact-complex-unary-op n:inexact-complex-expr)
#:with opt
@ -299,11 +306,11 @@
(pattern (~and exp (#%plain-app op:inexact-complex-op e:expr ...))
#:when (isoftype? #'exp -InexactComplex)
#:with exp*:unboxed-inexact-complex-opt-expr #'exp
#:with real-part #'exp*.real-part
#:with imag-part #'exp*.imag-part
#:with real-binding #'exp*.real-binding
#:with imag-binding #'exp*.imag-binding
#:with (bindings ...) #'(exp*.bindings ...)
#:with opt
(begin (log-optimization "unboxed inexact complex" #'exp)
(reset-unboxed-gensym)
#'(let* (exp*.bindings ...)
(unsafe-make-flrectangular exp*.real-part exp*.imag-part)))))
(unsafe-make-flrectangular exp*.real-binding exp*.imag-binding)))))

8
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

@ -37,8 +37,8 @@
;; add the unboxed bindings to the table, for them to be used by
;; further optimizations
(for ((v (in-list (syntax->list #'(opt-candidates.id ...))))
(r (in-list (syntax->list #'(opt-candidates.real-part ...))))
(i (in-list (syntax->list #'(opt-candidates.imag-part ...)))))
(r (in-list (syntax->list #'(opt-candidates.real-binding ...))))
(i (in-list (syntax->list #'(opt-candidates.imag-binding ...)))))
(dict-set! unboxed-vars-table v (list r i)))
#`(let* (opt-candidates.bindings ... ... opt-others.res ...)
#,@(map (optimize) (syntax->list #'(body ...)))))))
@ -92,8 +92,8 @@
(define-syntax-class unboxed-let-clause
(pattern ((v:id) rhs:unboxed-inexact-complex-opt-expr)
#:with id #'v
#:with real-part #'rhs.real-part
#:with imag-part #'rhs.imag-part
#:with real-binding #'rhs.real-binding
#:with imag-binding #'rhs.imag-binding
#:with (bindings ...) #'(rhs.bindings ...)))
(define-syntax-class let-clause ; to turn let-values clauses into let clauses
(pattern ((v:id) rhs:expr)