Added unboxed letrec-syntaxes+values bindings.
original commit: b0d299d1b86e2bf07c7715e87ebb303f03bde853
This commit is contained in:
Vincent St-Amour
parent
277df87ff6
commit
28378f77d5
|
|
@ -0,0 +1,7 @@
|
|||
#lang typed/scheme #:optimize
|
||||
|
||||
(require racket/unsafe/ops)
|
||||
|
||||
(letrec-syntaxes+values (((s) (syntax-rules () [(_ x) x])))
|
||||
(((x) (+ 1.0+2.0i 2.0+4.0i)))
|
||||
(+ x 2.0+4.0i))
|
||||
|
|
@ -41,8 +41,8 @@
|
|||
((e (cdr l)))
|
||||
#`(unsafe-fl+ #,o #,e))))))
|
||||
(list
|
||||
#`(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 ...)))))))))
|
||||
#`((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
|
||||
|
|
@ -68,8 +68,8 @@
|
|||
((e l2))
|
||||
#`(unsafe-fl- #,o #,e))))))
|
||||
(list
|
||||
#`(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 ...)))))))))
|
||||
#`((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
|
||||
|
|
@ -104,14 +104,14 @@
|
|||
;; we eliminate operations on the imaginary parts of reals
|
||||
(let ((o-real? (equal? (syntax->datum o2) 0.0))
|
||||
(e-real? (equal? (syntax->datum (car e2)) 0.0)))
|
||||
(list* #`(#,(car is)
|
||||
(list* #`((#,(car is))
|
||||
#,(cond ((and o-real? e-real?) #'0.0)
|
||||
(o-real? #`(unsafe-fl* #,o1 #,(car e2)))
|
||||
(e-real? #`(unsafe-fl* #,o2 #,(car e1)))
|
||||
(else
|
||||
#`(unsafe-fl+ (unsafe-fl* #,o2 #,(car e1))
|
||||
(unsafe-fl* #,o1 #,(car e2))))))
|
||||
#`(#,(car rs)
|
||||
#`((#,(car rs))
|
||||
#,(cond ((or o-real? e-real?)
|
||||
#`(unsafe-fl* #,o1 #,(car e1)))
|
||||
(else
|
||||
|
|
@ -155,36 +155,36 @@
|
|||
(e-real? (equal? (syntax->datum (car e2)) 0.0)))
|
||||
(cond [(and o-real? e-real?)
|
||||
(list*
|
||||
#`(#,(car is) 0.0) ; currently not propagated
|
||||
#`(#,(car rs) (unsafe-fl/ #,o1 #,(car e1)))
|
||||
#`((#,(car is)) 0.0) ; currently not propagated
|
||||
#`((#,(car rs)) (unsafe-fl/ #,o1 #,(car e1)))
|
||||
res)]
|
||||
[o-real?
|
||||
(list*
|
||||
#`(#,(car is)
|
||||
#`((#,(car is))
|
||||
(unsafe-fl/ (unsafe-fl- 0.0
|
||||
(unsafe-fl* #,o1 #,(car e2)))
|
||||
#,(car ds)))
|
||||
#`(#,(car rs) (unsafe-fl/ (unsafe-fl* #,o1 #,(car e1))
|
||||
#,(car ds)))
|
||||
#`(#,(car ds) (unsafe-fl+ (unsafe-fl* #,(car e1) #,(car e1))
|
||||
(unsafe-fl* #,(car e2) #,(car e2))))
|
||||
#`((#,(car rs)) (unsafe-fl/ (unsafe-fl* #,o1 #,(car e1))
|
||||
#,(car ds)))
|
||||
#`((#,(car ds)) (unsafe-fl+ (unsafe-fl* #,(car e1) #,(car e1))
|
||||
(unsafe-fl* #,(car e2) #,(car e2))))
|
||||
res)]
|
||||
[e-real?
|
||||
(list*
|
||||
#`(#,(car is) (unsafe-fl/ #,o2 #,(car e1)))
|
||||
#`(#,(car rs) (unsafe-fl/ #,o1 #,(car e1)))
|
||||
#`((#,(car is)) (unsafe-fl/ #,o2 #,(car e1)))
|
||||
#`((#,(car rs)) (unsafe-fl/ #,o1 #,(car e1)))
|
||||
res)]
|
||||
[else
|
||||
(list*
|
||||
#`(#,(car is)
|
||||
#`((#,(car is))
|
||||
(unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1))
|
||||
(unsafe-fl* #,o1 #,(car e2)))
|
||||
#,(car ds)))
|
||||
#`(#,(car rs)
|
||||
#`((#,(car rs))
|
||||
(unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1))
|
||||
(unsafe-fl* #,o2 #,(car e2)))
|
||||
#,(car ds)))
|
||||
#`(#,(car ds)
|
||||
#`((#,(car ds))
|
||||
(unsafe-fl+ (unsafe-fl* #,(car e1) #,(car e1))
|
||||
(unsafe-fl* #,(car e2) #,(car e2))))
|
||||
res)]))))))))
|
||||
|
|
@ -195,7 +195,7 @@
|
|||
#:with (bindings ...)
|
||||
(begin (log-optimization "unboxed unary inexact complex" #'op)
|
||||
#`(#,@(append (syntax->list #'(c.bindings ...))
|
||||
(list #'(imag-binding (unsafe-fl- 0.0 c.imag-binding)))))))
|
||||
(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)
|
||||
|
|
@ -227,40 +227,40 @@
|
|||
#:with real-binding (unboxed-gensym)
|
||||
#:with imag-binding (unboxed-gensym)
|
||||
#:with (bindings ...)
|
||||
#`((e* #,((optimize) #'e))
|
||||
(real-binding (unsafe-flreal-part e*))
|
||||
(imag-binding (unsafe-flimag-part e*))))
|
||||
#`(((e*) #,((optimize) #'e))
|
||||
((real-binding) (unsafe-flreal-part e*))
|
||||
((imag-binding) (unsafe-flimag-part e*))))
|
||||
;; special handling of reals
|
||||
(pattern e:float-expr
|
||||
#:with real-binding (unboxed-gensym)
|
||||
#:with imag-binding #f
|
||||
#:with (bindings ...)
|
||||
#`((real-binding #,((optimize) #'e))))
|
||||
#`(((real-binding) #,((optimize) #'e))))
|
||||
(pattern e:fixnum-expr
|
||||
#:with real-binding (unboxed-gensym)
|
||||
#:with imag-binding #f
|
||||
#:with (bindings ...)
|
||||
#`((real-binding (unsafe-fx->fl #,((optimize) #'e)))))
|
||||
#`(((real-binding) (unsafe-fx->fl #,((optimize) #'e)))))
|
||||
(pattern e:int-expr
|
||||
#:with real-binding (unboxed-gensym)
|
||||
#:with imag-binding #f
|
||||
#:with (bindings ...)
|
||||
#`((real-binding (->fl #,((optimize) #'e)))))
|
||||
#`(((real-binding) (->fl #,((optimize) #'e)))))
|
||||
(pattern e:expr
|
||||
#:when (isoftype? #'e -Real)
|
||||
#:with real-binding (unboxed-gensym)
|
||||
#:with imag-binding #f
|
||||
#:with (bindings ...)
|
||||
#`((real-binding (exact->inexact #,((optimize) #'e)))))
|
||||
#`(((real-binding) (exact->inexact #,((optimize) #'e)))))
|
||||
(pattern e:expr
|
||||
#:when (isoftype? #'e -Number) ; complex, maybe exact, maybe not
|
||||
#:with e* (unboxed-gensym)
|
||||
#:with real-binding (unboxed-gensym)
|
||||
#:with imag-binding (unboxed-gensym)
|
||||
#:with (bindings ...)
|
||||
#`((e* #,((optimize) #'e))
|
||||
(real-binding (exact->inexact (real-part e*)))
|
||||
(imag-binding (exact->inexact (imag-part e*)))))
|
||||
#`(((e*) #,((optimize) #'e))
|
||||
((real-binding) (exact->inexact (real-part e*)))
|
||||
((imag-binding) (exact->inexact (imag-part e*)))))
|
||||
(pattern e:expr
|
||||
#:with (bindings ...)
|
||||
(error "non exhaustive pattern match")
|
||||
|
|
@ -290,7 +290,7 @@
|
|||
#:with opt
|
||||
(begin (log-optimization "unboxed inexact complex" #'op)
|
||||
(reset-unboxed-gensym)
|
||||
#`(let* (c*.bindings ...)
|
||||
#`(let*-values (c*.bindings ...)
|
||||
#,(if (or (free-identifier=? #'op #'real-part)
|
||||
(free-identifier=? #'op #'unsafe-flreal-part))
|
||||
#'c*.real-binding
|
||||
|
|
@ -314,5 +314,5 @@
|
|||
#:with opt
|
||||
(begin (log-optimization "unboxed inexact complex" #'exp)
|
||||
(reset-unboxed-gensym)
|
||||
#'(let* (exp*.bindings ...)
|
||||
#'(let*-values (exp*.bindings ...)
|
||||
(unsafe-make-flrectangular exp*.real-binding exp*.imag-binding)))))
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
|
||||
(define-syntax-class unboxed-let-opt-expr
|
||||
#:literal-sets (kernel-literals)
|
||||
(pattern (~and exp ((~and op (~or (~literal let-values) (~literal letrec-values)))
|
||||
(pattern (~and exp (letk:let-like-keyword
|
||||
(clause:expr ...) body:expr ...))
|
||||
;; we look for bindings of complexes that are not mutated and only
|
||||
;; used in positions where we would unbox them
|
||||
|
|
@ -32,7 +32,7 @@
|
|||
(map syntax->list (syntax->list #'(clause ...))))))
|
||||
(list candidates others))
|
||||
#:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...)
|
||||
#:with (opt-others:let-clause ...) #'(others ...)
|
||||
#:with (opt-others:opt-let-values-clause ...) #'(others ...)
|
||||
#:with opt
|
||||
(begin (log-optimization "unboxed let bindings" #'exp)
|
||||
;; add the unboxed bindings to the table, for them to be used by
|
||||
|
|
@ -41,10 +41,19 @@
|
|||
(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)))
|
||||
#`(#,(if (free-identifier=? #'op #'let-values) #'let* #'letrec)
|
||||
#`(letk.key ...
|
||||
(opt-candidates.bindings ... ... opt-others.res ...)
|
||||
#,@(map (optimize) (syntax->list #'(body ...)))))))
|
||||
|
||||
(define-splicing-syntax-class let-like-keyword
|
||||
#:literal-sets (kernel-literals)
|
||||
(pattern (~literal let-values)
|
||||
#:with (key ...) #'(let*-values))
|
||||
(pattern (~literal letrec-values)
|
||||
#:with (key ...) #'(letrec-values))
|
||||
(pattern (~seq (~literal letrec-syntaxes+values) stx-bindings)
|
||||
#:with (key ...) #'(letrec-syntaxes+values stx-bindings)))
|
||||
|
||||
;; if a variable is only used in complex arithmetic operations, it's safe
|
||||
;; to unbox it
|
||||
(define (could-be-unboxed-in? v exp)
|
||||
|
|
@ -97,6 +106,6 @@
|
|||
#: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)
|
||||
#:with res #`(v #,((optimize) #'rhs))))
|
||||
(define-syntax-class opt-let-values-clause
|
||||
(pattern (vs rhs:expr)
|
||||
#:with res #`(vs #,((optimize) #'rhs))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user