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

Cleanup of syntax-parse patterns.

Browse Source 
original commit: 988466369739ac5682205e49185c3956e07f3f0d
This commit is contained in:
Vincent St-Amour 2010-08-27 13:48:25 -04:00
parent 6df18f3f24
commit 5ead0f43e2
3 changed files with 29 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/typed-scheme/optimizer/float.rkt
View File

@ -72,17 +72,17 @@
#:with opt #'e.opt))
(define-syntax-class float-opt-expr
(pattern (~and res (#%plain-app (~var op (float-op unary-float-ops)) f:float-expr))
#:when (subtypeof? #'res -Flonum)
(pattern (#%plain-app (~var op (float-op unary-float-ops)) f:float-expr)
#:when (subtypeof? this-syntax -Flonum)
#:with opt
(begin (log-optimization "unary float" #'op)
#'(op.unsafe f.opt)))
(pattern (~and res (#%plain-app (~var op (float-op binary-float-ops))
f1:float-arg-expr
f2:float-arg-expr
fs:float-arg-expr ...))
(pattern (#%plain-app (~var op (float-op binary-float-ops))
f1:float-arg-expr
f2:float-arg-expr
fs:float-arg-expr ...)
;; if the result is a float, we can coerce integers to floats and optimize
#:when (subtypeof? #'res -Flonum)
#:when (subtypeof? this-syntax -Flonum)
#:with opt
(begin (log-optimization "binary float" #'op)
(n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))

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

@ -376,9 +376,9 @@
(begin (log-optimization "unary inexact complex" #'op)
#'(op.unsafe n.opt)))
(pattern (~and exp (#%plain-app (~and op (~literal make-polar)) r theta))
#:when (isoftype? #'exp -InexactComplex)
#:with exp*:unboxed-inexact-complex-opt-expr #'exp
(pattern (#%plain-app (~and op (~literal make-polar)) r theta)
#:when (isoftype? this-syntax -InexactComplex)
#:with exp*:unboxed-inexact-complex-opt-expr this-syntax
#:with opt
(begin (log-optimization "make-polar" #'op)
(reset-unboxed-gensym)
@ -386,12 +386,12 @@
(unsafe-make-flrectangular exp*.real-binding
exp*.imag-binding))))
(pattern (~and e (#%plain-app op:id args:expr ...))
(pattern (#%plain-app op:id args:expr ...)
#:with unboxed-info (dict-ref unboxed-funs-table #'op #f)
#:when (syntax->datum #'unboxed-info)
#:with (~var e* (inexact-complex-call-site-opt-expr
#'unboxed-info #'op)) ; no need to optimize op
#'e
this-syntax
#:with opt
(begin (log-optimization "call to fun with unboxed args" #'op)
#'e*.opt))
@ -401,26 +401,26 @@
(define-syntax-class inexact-complex-arith-opt-expr
(pattern (~and exp (#%plain-app op:inexact-complex->float-op e:expr ...))
#:when (subtypeof? #'exp -Flonum)
#:with exp*:unboxed-inexact-complex-opt-expr #'exp
(pattern (#%plain-app op:inexact-complex->float-op e:expr ...)
#:when (subtypeof? this-syntax -Flonum)
#:with exp*:unboxed-inexact-complex-opt-expr this-syntax
#:with real-binding #'exp*.real-binding
#:with imag-binding #f
#:with (bindings ...) #'(exp*.bindings ...)
#:with opt
(begin (log-optimization "unboxed inexact complex->float" #'exp)
(begin (log-optimization "unboxed inexact complex->float" this-syntax)
(reset-unboxed-gensym)
#'(let*-values (exp*.bindings ...)
real-binding)))
(pattern (~and exp (#%plain-app op:inexact-complex-op e:expr ...))
#:when (isoftype? #'exp -InexactComplex)
#:with exp*:unboxed-inexact-complex-opt-expr #'exp
(pattern (#%plain-app op:inexact-complex-op e:expr ...)
#:when (isoftype? this-syntax -InexactComplex)
#:with exp*:unboxed-inexact-complex-opt-expr this-syntax
#: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)
(begin (log-optimization "unboxed inexact complex" this-syntax)
(reset-unboxed-gensym)
#'(let*-values (exp*.bindings ...)
(unsafe-make-flrectangular exp*.real-binding exp*.imag-binding))))

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

@ -25,18 +25,17 @@
;; we can extend unboxing
(define-syntax-class app-of-unboxed-let-opt-expr
#:literal-sets (kernel-literals)
(pattern (~and e ((~literal #%plain-app)
(~and let-e
((~literal letrec-values)
bindings
loop-fun:id)) ; sole element of the body
args:expr ...))
(pattern (#%plain-app
(~and let-e ((~literal letrec-values)
bindings
loop-fun:id)) ; sole element of the body
args:expr ...)
#:with (~var operator (unboxed-let-opt-expr-internal #t)) #'let-e
#:with unboxed-info (dict-ref unboxed-funs-table #'loop-fun #f)
#:when (syntax->datum #'unboxed-info)
#:with (~var e* (inexact-complex-call-site-opt-expr
#'unboxed-info #'operator.opt))
#'e
this-syntax
#:with opt
(begin (log-optimization "unboxed let loop" #'loop-fun)
#'e*.opt)))
@ -46,9 +45,8 @@
;; functions
(define-syntax-class (unboxed-let-opt-expr-internal let-loop?)
#:literal-sets (kernel-literals)
(pattern (~and exp (letk:let-like-keyword
((~and clause (lhs rhs ...)) ...)
body:expr ...))
(pattern (letk:let-like-keyword ((~and clause (lhs rhs ...)) ...)
body:expr ...)
;; we look for bindings of complexes that are not mutated and only
;; used in positions where we would unbox them
;; these are candidates for unboxing
@ -125,7 +123,7 @@
#:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...)
#:with (opt-others:opt-let-clause ...) #'(others ...)
#:with opt
(begin (log-optimization "unboxed let bindings" #'exp)
(begin (log-optimization "unboxed let bindings" this-syntax)
;; add the unboxed bindings to the table, for them to be used by
;; further optimizations
(for ((v (in-list (syntax->list #'(opt-candidates.id ...))))