From 0c4f82a434daa05decb6f4c92bede7ef11d5b998 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 31 Aug 2010 14:36:22 -0600 Subject: [PATCH] added #:commit to TR optimizer stxclasses --- collects/typed-scheme/optimizer/apply.rkt | 4 +++- collects/typed-scheme/optimizer/box.rkt | 3 +++ collects/typed-scheme/optimizer/dead-code.rkt | 1 + collects/typed-scheme/optimizer/fixnum.rkt | 6 ++++++ collects/typed-scheme/optimizer/float.rkt | 7 +++++++ collects/typed-scheme/optimizer/inexact-complex.rkt | 7 +++++++ collects/typed-scheme/optimizer/number.rkt | 1 + collects/typed-scheme/optimizer/optimizer.rkt | 2 ++ collects/typed-scheme/optimizer/pair.rkt | 5 +++++ collects/typed-scheme/optimizer/sequence.rkt | 3 +++ collects/typed-scheme/optimizer/string.rkt | 3 +++ collects/typed-scheme/optimizer/struct.rkt | 1 + collects/typed-scheme/optimizer/unboxed-let.rkt | 7 +++++++ collects/typed-scheme/optimizer/vector.rkt | 3 +++ 14 files changed, 52 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/optimizer/apply.rkt b/collects/typed-scheme/optimizer/apply.rkt index 4fa67d9734..d26751757c 100644 --- a/collects/typed-scheme/optimizer/apply.rkt +++ b/collects/typed-scheme/optimizer/apply.rkt @@ -12,12 +12,14 @@ (provide apply-opt-expr) (define-syntax-class apply-op + #:commit #:literals (+ *) (pattern + #:with identity #'0) (pattern * #:with identity #'1)) (define-syntax-class apply-opt-expr - #:literals (k:apply map #%plain-app #%app) + #:commit + #:literals (k:apply map #%plain-app #%app) (pattern (#%plain-app k:apply op:apply-op (#%plain-app map f l)) #:with opt (begin (reset-unboxed-gensym) diff --git a/collects/typed-scheme/optimizer/box.rkt b/collects/typed-scheme/optimizer/box.rkt index 99efba91e4..483741fa58 100644 --- a/collects/typed-scheme/optimizer/box.rkt +++ b/collects/typed-scheme/optimizer/box.rkt @@ -11,6 +11,7 @@ (provide box-opt-expr) (define-syntax-class box-expr + #:commit (pattern e:expr #:when (match (type-of #'e) [(tc-result1: (Box: _)) #t] @@ -18,11 +19,13 @@ #:with opt ((optimize) #'e))) (define-syntax-class box-op + #:commit ;; we need the * versions of these unsafe operations to be chaperone-safe (pattern (~literal unbox) #:with unsafe #'unsafe-unbox*) (pattern (~literal set-box!) #:with unsafe #'unsafe-set-box*!)) (define-syntax-class box-opt-expr + #:commit (pattern (#%plain-app op:box-op b:box-expr new:expr ...) #:with opt (begin (log-optimization "box" #'op) diff --git a/collects/typed-scheme/optimizer/dead-code.rkt b/collects/typed-scheme/optimizer/dead-code.rkt index f20019def5..eb2c5ba78e 100644 --- a/collects/typed-scheme/optimizer/dead-code.rkt +++ b/collects/typed-scheme/optimizer/dead-code.rkt @@ -9,6 +9,7 @@ (provide dead-code-opt-expr) (define-syntax-class dead-code-opt-expr + #:commit ;; if one of the brances of an if is unreachable, we can eliminate it ;; we have to keep the test, in case it has side effects (pattern (if tst:expr thn:expr els:expr) diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt index fbe684c10c..c62f3a3c22 100644 --- a/collects/typed-scheme/optimizer/fixnum.rkt +++ b/collects/typed-scheme/optimizer/fixnum.rkt @@ -30,30 +30,36 @@ #'bitwise-xor #'unsafe-fxxor) #'fxxor #'unsafe-fxxor)) (define-syntax-class fixnum-unary-op + #:commit (pattern (~or (~literal bitwise-not) (~literal fxnot)) #:with unsafe #'unsafe-fxnot) (pattern (~or (~literal abs) (~literal fxabs)) #:with unsafe #'unsafe-fxabs)) ;; closed on fixnums, but 2nd argument must not be 0 (define-syntax-class nonzero-fixnum-binary-op + #:commit (pattern (~or (~literal quotient) (~literal fxquotient)) #:with unsafe #'unsafe-fxquotient) (pattern (~or (~literal modulo) (~literal fxmodulo)) #:with unsafe #'unsafe-fxmodulo) (pattern (~or (~literal remainder) (~literal fxremainder)) #:with unsafe #'unsafe-fxremainder)) (define-syntax-class (fixnum-op tbl) + #:commit (pattern i:id #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) (define-syntax-class fixnum-expr + #:commit (pattern e:expr #:when (subtypeof? #'e -Fixnum) #:with opt ((optimize) #'e))) (define-syntax-class nonzero-fixnum-expr + #:commit (pattern e:expr #:when (or (isoftype? #'e -PositiveFixnum) (isoftype? #'e -NegativeFixnum)) #:with opt ((optimize) #'e))) (define-syntax-class fixnum-opt-expr + #:commit (pattern (#%plain-app op:fixnum-unary-op n:fixnum-expr) #:with opt (begin (log-optimization "unary fixnum" #'op) diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt index 236c0be39b..d31beb50d3 100644 --- a/collects/typed-scheme/optimizer/float.rkt +++ b/collects/typed-scheme/optimizer/float.rkt @@ -28,19 +28,23 @@ #'sqrt #'round #'floor #'ceiling #'truncate))) (define-syntax-class (float-op tbl) + #:commit (pattern i:id #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) (define-syntax-class float-expr + #:commit (pattern e:expr #:when (subtypeof? #'e -Flonum) #:with opt ((optimize) #'e))) (define-syntax-class int-expr + #:commit (pattern e:expr #:when (subtypeof? #'e -Integer) #:with opt ((optimize) #'e))) (define-syntax-class real-expr + #:commit (pattern e:expr #:when (subtypeof? #'e -Real) #:with opt ((optimize) #'e))) @@ -48,6 +52,7 @@ ;; generates coercions to floats (define-syntax-class float-coerce-expr + #:commit (pattern e:float-arg-expr #:with opt #'e.opt) (pattern e:real-expr @@ -59,6 +64,7 @@ ;; note: none of the unary operations have types where non-float arguments ;; can result in float (as opposed to real) results (define-syntax-class float-arg-expr + #:commit ;; we can convert literals right away (pattern (quote n) #:when (exact-integer? (syntax->datum #'n)) @@ -72,6 +78,7 @@ #:with opt #'e.opt)) (define-syntax-class float-opt-expr + #:commit (pattern (#%plain-app (~var op (float-op unary-float-ops)) f:float-expr) #:when (subtypeof? this-syntax -Flonum) #:with opt diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt index 2642071110..86ebf00288 100644 --- a/collects/typed-scheme/optimizer/inexact-complex.rkt +++ b/collects/typed-scheme/optimizer/inexact-complex.rkt @@ -338,23 +338,28 @@ #:with imag-binding #f)) (define-syntax-class inexact-complex-unary-op + #:commit (pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part) (pattern (~or (~literal imag-part) (~literal flimag-part)) #:with unsafe #'unsafe-flimag-part)) (define-syntax-class inexact-complex-op + #:commit (pattern (~or (~literal +) (~literal -) (~literal *) (~literal /) (~literal conjugate)))) (define-syntax-class inexact-complex->float-op + #:commit (pattern (~or (~literal magnitude) (~literal real-part) (~literal flreal-part) (~literal unsafe-flreal-part) (~literal imag-part) (~literal flimag-part) (~literal unsafe-flimag-part)))) (define-syntax-class inexact-complex-expr + #:commit (pattern e:expr #:when (isoftype? #'e -InexactComplex) #:with opt ((optimize) #'e))) (define-syntax-class inexact-complex-opt-expr + #:commit ;; we can optimize taking the real of imag part of an unboxed complex ;; hopefully, the compiler can eliminate unused bindings for the other part if it's not used @@ -401,6 +406,7 @@ #:with opt #'e.opt)) (define-syntax-class inexact-complex-arith-opt-expr + #:commit (pattern (#%plain-app op:inexact-complex->float-op e:expr ...) #:when (subtypeof? this-syntax -Flonum) @@ -443,6 +449,7 @@ ;; and the optimized version of the operator. operators are optimized elsewhere ;; to benefit from local information (define-syntax-class (inexact-complex-call-site-opt-expr unboxed-info opt-operator) + #:commit ;; call site of a function with unboxed parameters ;; the calling convention is: real parts of unboxed, imag parts, boxed (pattern (#%plain-app op:expr args:expr ...) diff --git a/collects/typed-scheme/optimizer/number.rkt b/collects/typed-scheme/optimizer/number.rkt index 81acd094b3..40b24875e3 100644 --- a/collects/typed-scheme/optimizer/number.rkt +++ b/collects/typed-scheme/optimizer/number.rkt @@ -8,6 +8,7 @@ (provide number-opt-expr) (define-syntax-class number-opt-expr + #:commit ;; these cases are all identity (pattern (#%plain-app (~and op (~or (~literal +) (~literal *) (~literal min) (~literal max))) f:expr) diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt index 4ac752a819..90bb70f7da 100644 --- a/collects/typed-scheme/optimizer/optimizer.rkt +++ b/collects/typed-scheme/optimizer/optimizer.rkt @@ -15,10 +15,12 @@ (define-syntax-class opt-expr + #:commit (pattern e:opt-expr* #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f))) (define-syntax-class opt-expr* + #:commit #:literal-sets (kernel-literals) ;; interesting cases, where something is optimized diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt index 145d31bcc0..8245c3c9cf 100644 --- a/collects/typed-scheme/optimizer/pair.rkt +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -13,9 +13,11 @@ (define-syntax-class pair-unary-op + #:commit (pattern (~literal car) #:with unsafe #'unsafe-car) (pattern (~literal cdr) #:with unsafe #'unsafe-cdr)) (define-syntax-class mpair-op + #:commit (pattern (~literal mcar) #:with unsafe #'unsafe-mcar) (pattern (~literal mcdr) #:with unsafe #'unsafe-mcdr) (pattern (~literal set-mcar!) #:with unsafe #'unsafe-set-mcar!) @@ -23,12 +25,14 @@ (define-syntax-class pair-expr + #:commit (pattern e:expr #:when (match (type-of #'e) ; type of the operand [(tc-result1: (Pair: _ _)) #t] [_ #f]) #:with opt ((optimize) #'e))) (define-syntax-class mpair-expr + #:commit (pattern e:expr #:when (match (type-of #'e) ; type of the operand [(tc-result1: (MPair: _ _)) #t] @@ -36,6 +40,7 @@ #:with opt ((optimize) #'e))) (define-syntax-class pair-opt-expr + #:commit (pattern (#%plain-app op:pair-unary-op p:pair-expr) #:with opt (begin (log-optimization "unary pair" #'op) diff --git a/collects/typed-scheme/optimizer/sequence.rkt b/collects/typed-scheme/optimizer/sequence.rkt index 3821e88665..ac8f49aa86 100644 --- a/collects/typed-scheme/optimizer/sequence.rkt +++ b/collects/typed-scheme/optimizer/sequence.rkt @@ -13,6 +13,7 @@ (define-syntax-class list-expr + #:commit (pattern e:expr #:when (match (type-of #'e) [(tc-result1: (Listof: _)) #t] @@ -22,6 +23,7 @@ ;; unlike other vector optimizations, this works on unknown-length vectors (define-syntax-class vector-expr + #:commit (pattern e:expr #:when (match (type-of #'e) [(tc-result1: (Vector: _)) #t] @@ -30,6 +32,7 @@ #:with opt ((optimize) #'e))) (define-syntax-class sequence-opt-expr + #:commit ;; if we're iterating (with the for macros) over something we know is a list, ;; we can generate code that would be similar to if in-list had been used (pattern (#%plain-app op:id _ l) diff --git a/collects/typed-scheme/optimizer/string.rkt b/collects/typed-scheme/optimizer/string.rkt index 6d29c5ca79..0d8575ca20 100644 --- a/collects/typed-scheme/optimizer/string.rkt +++ b/collects/typed-scheme/optimizer/string.rkt @@ -9,15 +9,18 @@ (provide string-opt-expr string-expr bytes-expr) (define-syntax-class string-expr + #:commit (pattern e:expr #:when (isoftype? #'e -String) #:with opt ((optimize) #'e))) (define-syntax-class bytes-expr + #:commit (pattern e:expr #:when (isoftype? #'e -Bytes) #:with opt ((optimize) #'e))) (define-syntax-class string-opt-expr + #:commit (pattern (#%plain-app (~literal string-length) s:string-expr) #:with opt (begin (log-optimization "string-length" #'op) diff --git a/collects/typed-scheme/optimizer/struct.rkt b/collects/typed-scheme/optimizer/struct.rkt index 575b985e9f..77ee71b156 100644 --- a/collects/typed-scheme/optimizer/struct.rkt +++ b/collects/typed-scheme/optimizer/struct.rkt @@ -12,6 +12,7 @@ (provide struct-opt-expr) (define-syntax-class struct-opt-expr + #:commit ;; we can always optimize struct accessors and mutators ;; if they typecheck, they're safe (pattern (#%plain-app op:id s:expr v:expr ...) diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt index a50225c427..34d16c33b8 100644 --- a/collects/typed-scheme/optimizer/unboxed-let.rkt +++ b/collects/typed-scheme/optimizer/unboxed-let.rkt @@ -14,6 +14,7 @@ ;; possibly replace bindings of complex numbers by bindings of their 2 components ;; useful for intermediate results used more than once and for loop variables (define-syntax-class unboxed-let-opt-expr + #:commit (pattern e:app-of-unboxed-let-opt-expr #:with opt #'e.opt) (pattern (~var e (unboxed-let-opt-expr-internal #f)) @@ -24,6 +25,7 @@ ;; escapes in the operator position of a call site we control (here) ;; we can extend unboxing (define-syntax-class app-of-unboxed-let-opt-expr + #:commit #:literal-sets (kernel-literals) (pattern (#%plain-app (~and let-e ((~literal letrec-values) @@ -44,6 +46,7 @@ ;; detects which let bindings can be unboxed, same for arguments of let-bound ;; functions (define-syntax-class (unboxed-let-opt-expr-internal let-loop?) + #:commit #:literal-sets (kernel-literals) (pattern (letk:let-like-keyword ((~and clause (lhs rhs ...)) ...) body:expr ...) @@ -137,6 +140,7 @@ #,@(map (optimize) (syntax->list #'(body ...))))))) (define-splicing-syntax-class let-like-keyword + #:commit #:literal-sets (kernel-literals) (pattern (~literal let-values) #:with (key ...) #'(let*-values)) @@ -261,6 +265,7 @@ ;; let clause whose rhs is going to be unboxed (turned into multiple bindings) (define-syntax-class unboxed-let-clause + #:commit (pattern ((v:id) rhs:unboxed-inexact-complex-opt-expr) #:with id #'v #:with real-binding #'rhs.real-binding @@ -271,6 +276,7 @@ ;; these arguments may be unboxed ;; the new function will have all the unboxed arguments first, then all the boxed (define-syntax-class unboxed-fun-clause + #:commit (pattern ((v:id) (#%plain-lambda params body:expr ...)) #:with id #'v #:with unboxed-info (dict-ref unboxed-funs-table #'v #f) @@ -311,5 +317,6 @@ (cons (car params) boxed))])))))) (define-syntax-class opt-let-clause + #:commit (pattern (vs rhs:expr) #:with res #`(vs #,((optimize) #'rhs)))) diff --git a/collects/typed-scheme/optimizer/vector.rkt b/collects/typed-scheme/optimizer/vector.rkt index d162dcabc2..e3386903fa 100644 --- a/collects/typed-scheme/optimizer/vector.rkt +++ b/collects/typed-scheme/optimizer/vector.rkt @@ -12,11 +12,13 @@ (define-syntax-class vector-op + #:commit ;; we need the * versions of these unsafe operations to be chaperone-safe (pattern (~literal vector-ref) #:with unsafe #'unsafe-vector*-ref) (pattern (~literal vector-set!) #:with unsafe #'unsafe-vector*-set!)) (define-syntax-class vector-expr + #:commit (pattern e:expr #:when (match (type-of #'e) [(tc-result1: (HeterogenousVector: _)) #t] @@ -24,6 +26,7 @@ #:with opt ((optimize) #'e))) (define-syntax-class vector-opt-expr + #:commit ;; vector-length of a known-length vector (pattern (#%plain-app (~and op (~or (~literal vector-length) (~literal unsafe-vector-length)