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

Cleanup list optimizations.

Browse Source 
original commit: 4631705b16deb9e3c0561ba97d2f73b22cf86cce
This commit is contained in:
Eric Dobson 2013-09-04 21:08:41 -07:00
parent c6cd43eeb9
commit 1e1c06c515
3 changed files with 47 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/list.rkt
View File

@ -11,17 +11,19 @@
(provide list-opt-expr)
(define-syntax-class known-length-list-expr
#:commit
(pattern e:expr
#:when (match (type-of #'e)
[(tc-result1: (List: es)) #t]
[_ #f])
#:with opt ((optimize) #'e)))
#:attributes (opt len)
(pattern (~and e :opt-expr)
#:attr tys (match (type-of #'e)
[(tc-result1: (List: es)) es]
[_ #f])
#:when (attribute tys)
#:attr len (length (attribute tys))))
(define-syntax-class list-op
#:commit
(pattern (~literal list-ref) #:with unsafe #'unsafe-list-ref)
(pattern (~literal list-tail) #:with unsafe #'unsafe-list-tail))
(define-unsafe-syntax-class list-ref)
(define-unsafe-syntax-class list-tail)
(define-literal-syntax-class length)
(define-merged-syntax-class list-op (list-ref^ list-tail^))
(define-syntax-class list-opt-expr
@ -29,31 +31,11 @@
;; Similar to known-length vectors opts.
;; If we use `list-ref' or `list-tail' on a known-length list with a
;; literal index, we can optimize if the index is within bounds.
(pattern (#%plain-app op:list-op l:known-length-list-expr i:expr)
#:when (let ((len (match (type-of #'l)
[(tc-result1: (List: es)) (length es)]
[_ 0])) ; can't happen
(ival (or (syntax-parse #'i
[((~literal quote) i:number)
(syntax-e #'i)]
[_ #f])
(match (type-of #'i)
[(tc-result1: (Value: (? fixnum? i))) i]
[_ -1])))) ; sure to fail the next check
(<= 0 ival (sub1 len)))
#:with opt
(begin (log-optimization "known-length list op"
"List access specialization."
this-syntax)
(add-disappeared-use #'op)
#`(op.unsafe l.opt #,((optimize) #'i))))
(pattern (#%plain-app op:list-op l:known-length-list-expr i:value-expr)
#:when (<= 0 (attribute i.val) (sub1 (attribute l.len)))
#:do [(log-opt "known-length list op" "List access specialization.")]
#:with opt #'(op.unsafe l.opt i.opt))
;; We know the length of known-length lists statically.
(pattern (#%plain-app (~and op (~literal length)) l:known-length-list-expr)
#:with opt
(begin (log-optimization "known-length list length"
"Static list length computation."
this-syntax)
(add-disappeared-use #'op)
(match (type-of #'l)
[(tc-result1: (List: es))
#`(begin l.opt #,(length es))]))))
(pattern (#%plain-app op:length^ l:known-length-list-expr)
#:do [(log-opt "known-length list length" "Static list length computation.")]
#:with opt #`(let () l.opt #,(attribute l.len))))

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

@ -16,6 +16,7 @@
mk-unsafe-tbl
n-ary->binary n-ary-comp->binary
opt-expr optimize
value-expr
define-unsafe-syntax-class
define-literal-syntax-class
define-merged-syntax-class
@ -117,3 +118,17 @@
(define-syntax-class name
#:auto-nested-attributes
(pattern (~var || syntax-classes)) ...))
(define-syntax-class value-expr
#:attributes (val opt)
#:literal-sets (kernel-literals)
(pattern (quote v)
#:attr val (syntax-e #'v)
#:with opt this-syntax)
(pattern (~and e :opt-expr)
#:when (match (type-of #'e)
[(tc-result1: (Value: _)) #t]
[_ #f])
#:attr val (match (type-of #'e)
[(tc-result1: (Value: v)) v]
[_ #f])))

27
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/known-length-lists.rkt
View File

@ -1,21 +1,20 @@
#;#;
#<<END
TR opt: known-length-lists.rkt 42:0 (length l) -- known-length list length
TR opt: known-length-lists.rkt 43:0 (list-ref l i) -- known-length list op
TR opt: known-length-lists.rkt 44:0 (list-ref l j) -- known-length list op
TR opt: known-length-lists.rkt 45:0 (list-ref l k) -- known-length list op
TR opt: known-length-lists.rkt 46:0 (list-tail l i) -- known-length list op
TR opt: known-length-lists.rkt 47:0 (list-tail l j) -- known-length list op
TR opt: known-length-lists.rkt 48:0 (list-tail l k) -- known-length list op
TR opt: known-length-lists.rkt 49:0 (list-ref l 0) -- known-length list op
TR opt: known-length-lists.rkt 50:0 (list-ref l 1) -- known-length list op
TR opt: known-length-lists.rkt 51:0 (list-ref l 2) -- known-length list op
TR opt: known-length-lists.rkt 52:0 (list-tail l 0) -- known-length list op
TR opt: known-length-lists.rkt 53:0 (list-tail l 1) -- known-length list op
TR opt: known-length-lists.rkt 54:0 (list-tail l 2) -- known-length list op
TR opt: known-length-lists.rkt 41:0 (length l) -- known-length list length
TR opt: known-length-lists.rkt 42:0 (list-ref l i) -- known-length list op
TR opt: known-length-lists.rkt 43:0 (list-ref l j) -- known-length list op
TR opt: known-length-lists.rkt 44:0 (list-ref l k) -- known-length list op
TR opt: known-length-lists.rkt 45:0 (list-tail l i) -- known-length list op
TR opt: known-length-lists.rkt 46:0 (list-tail l j) -- known-length list op
TR opt: known-length-lists.rkt 47:0 (list-tail l k) -- known-length list op
TR opt: known-length-lists.rkt 48:0 (list-ref l 0) -- known-length list op
TR opt: known-length-lists.rkt 49:0 (list-ref l 1) -- known-length list op
TR opt: known-length-lists.rkt 50:0 (list-ref l 2) -- known-length list op
TR opt: known-length-lists.rkt 51:0 (list-tail l 0) -- known-length list op
TR opt: known-length-lists.rkt 52:0 (list-tail l 1) -- known-length list op
TR opt: known-length-lists.rkt 53:0 (list-tail l 2) -- known-length list op
END
#<<END
'(1 2 3)
3
1
2