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

Cleanup sequence optimizations.

Browse Source 
original commit: 71516d0201baf68f8a97ae7a4e46fca3ccadca45
This commit is contained in:
Eric Dobson 2013-09-04 21:36:14 -07:00
parent 1e1c06c515
commit 1ed75b095b
2 changed files with 79 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/sequence.rkt
View File

@ -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)))))

13
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt
View File

@ -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)