From 1ed75b095b8dfc5fb00c8f09f8e91da9b506a38d Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Wed, 4 Sep 2013 21:36:14 -0700 Subject: [PATCH] Cleanup sequence optimizations. original commit: 71516d0201baf68f8a97ae7a4e46fca3ccadca45 --- .../typed-racket/optimizer/sequence.rkt | 148 ++++++++---------- .../typed-racket/optimizer/utils.rkt | 13 +- 2 files changed, 79 insertions(+), 82 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/sequence.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/sequence.rkt index e0508b39..1db0cbb4 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/sequence.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/sequence.rkt @@ -2,101 +2,87 @@ (require syntax/parse racket/match + unstable/function + syntax/parse/experimental/specialize (for-template racket/base racket/unsafe/ops) "../utils/utils.rkt" "../utils/tc-utils.rkt" (rep type-rep) (types abbrev type-table utils) - (optimizer utils logging string - float)) ; for int-expr + (optimizer utils logging float)) (provide sequence-opt-expr) -(define-syntax-class list-expr - #:commit - (pattern e:expr - #:when (match (type-of #'e) - [(tc-result1: (Listof: _)) #t] - [(tc-result1: (List: _)) #t] - [_ #f]) - #:with opt ((optimize) #'e))) +(define-syntax-class/specialize string-expr + (typed-expr (λ (t) (type-equal? t -String)))) +(define-syntax-class/specialize bytes-expr + (typed-expr (λ (t) (type-equal? t -Bytes)))) +(define-syntax-class/specialize list-expr + (typed-expr (λ (t) + (match t + [(Listof: _) #t] + [(List: _) #t] + [_ #f])))) +(define-syntax-class/specialize vector-expr + (typed-expr (disjoin Vector? HeterogeneousVector?))) -;; 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] - [(tc-result1: (HeterogeneousVector: _)) #t] - [_ #f]) - #:with opt ((optimize) #'e))) +(define-syntax-rule (log-seq-opt opt-label) + (log-opt opt-label "Sequence type specialization.")) -(define seq-opt-msg "Sequence type specialization.") +(define-syntax-class make-sequence + (pattern op:id + #:when (id-from? #'op 'make-sequence 'racket/private/for) + #:do [(add-disappeared-use (syntax-local-introduce #'op))])) (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) - #:when (id-from? #'op 'make-sequence 'racket/private/for) - #:with l*:list-expr #'l - #:with opt - (begin (log-optimization "in-list" seq-opt-msg this-syntax) - #'(let ((i l*.opt)) - (values unsafe-car unsafe-cdr i - (lambda (x) (not (null? x))) - (lambda (x) #t) - (lambda (x y) #t))))) + (pattern (#%plain-app op:make-sequence _ l:list-expr) + #:do [(log-seq-opt "in-list")] + #:with opt #'(let ((i l.opt)) + (values unsafe-car unsafe-cdr i + (lambda (x) (not (null? x))) + (lambda (x) #t) + (lambda (x y) #t)))) ;; idem for vectors - (pattern (#%plain-app op:id _ v) - #:when (id-from? #'op 'make-sequence 'racket/private/for) - #:with v*:vector-expr #'v - #:with opt - (begin (log-optimization "in-vector" seq-opt-msg this-syntax) - #'(let* ((i v*.opt) - (len (unsafe-vector-length i))) - (values (lambda (x) (unsafe-vector-ref i x)) - (lambda (x) (unsafe-fx+ 1 x)) - 0 - (lambda (x) (unsafe-fx< x len)) - (lambda (x) #t) - (lambda (x y) #t))))) + (pattern (#%plain-app op:make-sequence _ v:vector-expr) + #:do [(log-seq-opt "in-vector")] + #:with opt #'(let* ((i v.opt) + (len (unsafe-vector-length i))) + (values (lambda (x) (unsafe-vector-ref i x)) + (lambda (x) (unsafe-fx+ 1 x)) + 0 + (lambda (x) (unsafe-fx< x len)) + (lambda (x) #t) + (lambda (x y) #t)))) ;; and (byte) strings - (pattern (#%plain-app op:id _ s) - #:when (id-from? #'op 'make-sequence 'racket/private/for) - #:with s*:string-expr #'s - #:with opt - (begin (log-optimization "in-string" seq-opt-msg this-syntax) - #'(let* ((i s*.opt) - (len (string-length i))) - (values (lambda (x) (string-ref i x)) - (lambda (x) (unsafe-fx+ 1 x)) - 0 - (lambda (x) (unsafe-fx< x len)) - (lambda (x) #t) - (lambda (x y) #t))))) - (pattern (#%plain-app op:id _ s) - #:when (id-from? #'op 'make-sequence 'racket/private/for) - #:with s*:bytes-expr #'s - #:with opt - (begin (log-optimization "in-bytes" seq-opt-msg this-syntax) - #'(let* ((i s*.opt) - (len (bytes-length i))) - (values (lambda (x) (bytes-ref i x)) - (lambda (x) (unsafe-fx+ 1 x)) - 0 - (lambda (x) (unsafe-fx< x len)) - (lambda (x) #t) - (lambda (x y) #t))))) - (pattern (#%plain-app op:id _ s) ; one-arg in-range - #:when (id-from? #'op 'make-sequence 'racket/private/for) - #:with s*:int-expr #'s - #:with opt - (begin (log-optimization "in-range" seq-opt-msg this-syntax) - #'(let* ((end s*.opt)) - (values (lambda (x) x) - (lambda (x) (unsafe-fx+ 1 x)) - 0 - (lambda (x) (unsafe-fx< x end)) - (lambda (x) #t) - (lambda (x y) #t)))))) + (pattern (#%plain-app op:make-sequence _ s:string-expr) + #:do [(log-seq-opt "in-string")] + #:with opt #'(let* ((i s.opt) + (len (string-length i))) + (values (lambda (x) (string-ref i x)) + (lambda (x) (unsafe-fx+ 1 x)) + 0 + (lambda (x) (unsafe-fx< x len)) + (lambda (x) #t) + (lambda (x y) #t)))) + (pattern (#%plain-app op:make-sequence _ s:bytes-expr) + #:do [(log-seq-opt "in-bytes")] + #:with opt #'(let* ((i s.opt) + (len (bytes-length i))) + (values (lambda (x) (bytes-ref i x)) + (lambda (x) (unsafe-fx+ 1 x)) + 0 + (lambda (x) (unsafe-fx< x len)) + (lambda (x) #t) + (lambda (x y) #t)))) + (pattern (#%plain-app op:make-sequence _ s:int-expr) ; one-arg in-range + #:do [(log-seq-opt "in-range")] + #:with opt #'(let* ((end s.opt)) + (values (lambda (x) x) + (lambda (x) (unsafe-fx+ 1 x)) + 0 + (lambda (x) (unsafe-fx< x end)) + (lambda (x) #t) + (lambda (x y) #t))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt index 8d037413..cdf0455c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt @@ -3,6 +3,7 @@ (require racket/match unstable/sequence racket/dict syntax/id-table racket/syntax syntax/stx syntax/parse + syntax/parse/experimental/specialize racket/promise (for-syntax racket/base syntax/parse racket/syntax) "../utils/utils.rkt" @@ -16,7 +17,7 @@ mk-unsafe-tbl n-ary->binary n-ary-comp->binary opt-expr optimize - value-expr + value-expr typed-expr subtyped-expr define-unsafe-syntax-class define-literal-syntax-class define-merged-syntax-class @@ -119,6 +120,16 @@ #:auto-nested-attributes (pattern (~var || syntax-classes)) ...)) +(define-syntax-class (typed-expr predicate) + #:attributes (opt) + (pattern (~and e :opt-expr) + #:when (match (type-of #'e) + [(tc-result1: (? predicate)) #t] + [_ #f]))) + +(define-syntax-class/specialize (subtyped-expr type) + (typed-expr (λ (t) (subtype t type)))) + (define-syntax-class value-expr #:attributes (val opt) #:literal-sets (kernel-literals)