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

Extended pair optimizations to some derived pair accessors.

Browse Source 
original commit: 024f873947bb5664b92cd68be55653b2ca4a24ee
This commit is contained in:
Vincent St-Amour 2010-09-09 17:02:46 -04:00
parent 51faa45faa
commit dee0ddc16e
11 changed files with 124 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-scheme/optimizer/tests/define-pair.rkt
View File

@ -1,6 +1,6 @@
#;
(
define-pair.rkt line 9 col 11 - car - unary pair
define-pair.rkt line 9 col 11 - car - pair
)
#lang typed/scheme

30
collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt Normal file
View File

@ -0,0 +1,30 @@
#;
(
pair.rkt line 81 col 45 - car - pair
pair.rkt line 81 col 39 - car - pair
derived-pair.rkt line 27 col 0 - (#%app caar (#%app cons (#%app cons (quote 1) (quote 2)
) (quote 3))) - derived pair
pair.rkt line 83 col 45 - cdr - pair
pair.rkt line 83 col 39 - car - pair
derived-pair.rkt line 28 col 0 - (#%app cadr (#%app cons (quote 1) (#%app cons (quote 2)
(quote 3)))) - derived pair
pair.rkt line 85 col 45 - car - pair
pair.rkt line 85 col 39 - cdr - pair
derived-pair.rkt line 29 col 0 - (#%app cdar (#%app cons (#%app cons (quote 1) (quote 2)
) (quote 3))) - derived pair
pair.rkt line 87 col 45 - cdr - pair
pair.rkt line 87 col 39 - cdr - pair
derived-pair.rkt line 30 col 0 - (#%app cddr (#%app cons (quote 1) (#%app cons (quote 2)
(quote 3)))) - derived pair
1
2
2
3
)
#lang typed/racket #:optimize
(caar (cons (cons 1 2) 3))
(cadr (cons 1 (cons 2 3)))
(cdar (cons (cons 1 2) 3))
(cddr (cons 1 (cons 2 3)))

8
collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt
View File

@ -19,16 +19,16 @@ nested-let-loop.rkt line 58 col 38 - r - leave var unboxed
nested-let-loop.rkt line 58 col 40 - s - leave var unboxed
nested-let-loop.rkt line 58 col 36 - + - unboxed binary inexact complex
nested-let-loop.rkt line 58 col 21 - loop1 - unboxed call site
nested-let-loop.rkt line 58 col 28 - cdr - unary pair
nested-let-loop.rkt line 58 col 28 - cdr - pair
nested-let-loop.rkt line 58 col 21 - loop1 - call to fun with unboxed args
nested-let-loop.rkt line 59 col 38 - s - leave var unboxed
nested-let-loop.rkt line 59 col 40 - (#%app car x) - unbox inexact-complex
nested-let-loop.rkt line 59 col 41 - car - unary pair
nested-let-loop.rkt line 59 col 41 - car - pair
nested-let-loop.rkt line 59 col 48 - (#%app car y) - unbox inexact-complex
nested-let-loop.rkt line 59 col 49 - car - unary pair
nested-let-loop.rkt line 59 col 49 - car - pair
nested-let-loop.rkt line 59 col 36 - + - unboxed binary inexact complex
nested-let-loop.rkt line 59 col 21 - loop2 - unboxed call site
nested-let-loop.rkt line 59 col 28 - cdr - unary pair
nested-let-loop.rkt line 59 col 28 - cdr - pair
nested-let-loop.rkt line 59 col 21 - loop2 - call to fun with unboxed args
#f line #f col #f - (letrec-values (((loop2) (lambda (y s) (if (#%app null? y) (#%app loop1 (#%app cdr x) (#%app + r s)) (#%app loop2 (#%app cdr y) (#%app + s (#%app car x) (#%app car y))))))) loop2) - unboxed let bindings
nested-let-loop.rkt line 56 col 38 - 0.0+0.0i - unboxed literal

4
collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt
View File

@ -1,7 +1,7 @@
#;
(
nested-pair1.rkt line 11 col 6 - cdr - unary pair
nested-pair1.rkt line 11 col 1 - car - unary pair
nested-pair1.rkt line 11 col 6 - cdr - pair
nested-pair1.rkt line 11 col 1 - car - pair
2
)

4
collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt
View File

@ -1,7 +1,7 @@
#;
(
nested-pair2.rkt line 11 col 6 - cdr - unary pair
nested-pair2.rkt line 11 col 1 - car - unary pair
nested-pair2.rkt line 11 col 6 - cdr - pair
nested-pair2.rkt line 11 col 1 - car - pair
'(2)
)

2
collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt
View File

@ -1,6 +1,6 @@
#;
(
pair-fun.rkt line 13 col 7 - car - unary pair
pair-fun.rkt line 13 col 7 - car - pair
)
#lang typed/scheme

32
collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt Normal file
View File

@ -0,0 +1,32 @@
#;
(
pair-known-length-list.rkt line 27 col 1 - car - pair
pair-known-length-list.rkt line 28 col 1 - cdr - pair
pair-known-length-list.rkt line 29 col 6 - cdr - pair
pair-known-length-list.rkt line 29 col 1 - car - pair
pair-known-length-list.rkt line 30 col 6 - cdr - pair
pair-known-length-list.rkt line 30 col 1 - cdr - pair
pair-known-length-list.rkt line 31 col 11 - cdr - pair
pair-known-length-list.rkt line 31 col 6 - cdr - pair
pair-known-length-list.rkt line 31 col 1 - car - pair
pair-known-length-list.rkt line 32 col 11 - cdr - pair
pair-known-length-list.rkt line 32 col 6 - cdr - pair
pair-known-length-list.rkt line 32 col 1 - cdr - pair
1
'(2 3)
2
'(3)
3
'()
)
#lang typed/racket #:optimize
(: x (List Integer Integer Integer))
(define x (list 1 2 3))
(car x)
(cdr x)
(car (cdr x))
(cdr (cdr x))
(car (cdr (cdr x)))
(cdr (cdr (cdr x)))

2
collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt
View File

@ -1,6 +1,6 @@
#;
(
simple-pair.rkt line 10 col 1 - car - unary pair
simple-pair.rkt line 10 col 1 - car - pair
1
)

4
collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt
View File

@ -12,11 +12,11 @@ unboxed-let-functions6.rkt line 36 col 15 - 0.0+1.0i - unboxed literal
unboxed-let-functions6.rkt line 36 col 11 - + - unboxed binary inexact complex
unboxed-let-functions6.rkt line 36 col 10 - (#%app + z (quote 0.0+1.0i)) - unboxed inexact complex
unboxed-let-functions6.rkt line 37 col 19 - z - leave var unboxed
unboxed-let-functions6.rkt line 37 col 22 - car - unary pair
unboxed-let-functions6.rkt line 37 col 22 - car - pair
unboxed-let-functions6.rkt line 37 col 21 - (#%app car l) - float-coerce-expr in complex ops
unboxed-let-functions6.rkt line 37 col 17 - + - unboxed binary inexact complex
unboxed-let-functions6.rkt line 37 col 11 - loop - unboxed call site
unboxed-let-functions6.rkt line 38 col 17 - cdr - unary pair
unboxed-let-functions6.rkt line 38 col 17 - cdr - pair
unboxed-let-functions6.rkt line 37 col 11 - loop - call to fun with unboxed args
#f line #f col #f - (letrec-values (((loop) (lambda (z l) (if (#%app null? l) (#%app + z (quote 0.0+1.0i)) (#%app loop (#%app + z (#%app car l)) (#%app cdr l)))))) loop) - unboxed let bindings
unboxed-let-functions6.rkt line 33 col 51 - 0.0+0.0i - unboxed literal

6
collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt
View File

@ -1,7 +1,7 @@
#;
(
unboxed-let-functions7.rkt line 35 col 15 - z - unbox inexact-complex
unboxed-let-functions7.rkt line 35 col 18 - car - unary pair
unboxed-let-functions7.rkt line 35 col 18 - car - pair
unboxed-let-functions7.rkt line 35 col 17 - (#%app car l) - float-coerce-expr in complex ops
unboxed-let-functions7.rkt line 35 col 13 - + - unboxed binary inexact complex
unboxed-let-functions7.rkt line 35 col 12 - (#%app + z (#%app car l)) - unboxed inexact complex
@ -10,11 +10,11 @@ unboxed-let-functions7.rkt line 31 col 6 - loop - unboxed function -> table
unboxed-let-functions7.rkt line 31 col 6 - loop - fun -> unboxed fun
unboxed-let-functions7.rkt line 34 col 6 - z - unboxed complex variable
unboxed-let-functions7.rkt line 35 col 15 - z - leave var unboxed
unboxed-let-functions7.rkt line 35 col 18 - car - unary pair
unboxed-let-functions7.rkt line 35 col 18 - car - pair
unboxed-let-functions7.rkt line 35 col 17 - (#%app car l) - float-coerce-expr in complex ops
unboxed-let-functions7.rkt line 35 col 13 - + - unboxed binary inexact complex
unboxed-let-functions7.rkt line 35 col 7 - loop - unboxed call site
unboxed-let-functions7.rkt line 36 col 13 - cdr - unary pair
unboxed-let-functions7.rkt line 36 col 13 - cdr - pair
unboxed-let-functions7.rkt line 35 col 7 - loop - call to fun with unboxed args
#f line #f col #f - (letrec-values (((loop) (lambda (z l) (if (#%app null? l) z (#%app loop (#%app + z (#%app car l)) (#%app cdr l)))))) loop) - unboxed let bindings
unboxed-let-functions7.rkt line 31 col 51 - 0.0+0.0i - unboxed literal

49
collects/typed-scheme/optimizer/pair.rkt
View File

@ -6,12 +6,13 @@
"../utils/utils.rkt"
(rep type-rep)
(types type-table utils)
(typecheck typechecker)
(optimizer utils))
(provide pair-opt-expr)
(define-syntax-class pair-unary-op
(define-syntax-class pair-op
#:commit
(pattern (~literal car) #:with unsafe #'unsafe-car)
(pattern (~literal cdr) #:with unsafe #'unsafe-cdr))
@ -40,11 +41,53 @@
(define-syntax-class pair-opt-expr
#:commit
(pattern (#%plain-app op:pair-unary-op p:pair-expr)
(pattern e:pair-derived-opt-expr
#:with opt
(begin (log-optimization "unary pair" #'op)
(begin (log-optimization "derived pair" #'e)
#'e.opt))
(pattern (#%plain-app op:pair-op p:pair-expr)
#:with opt
(begin (log-optimization "pair" #'op)
#'(op.unsafe p.opt)))
(pattern (#%plain-app op:mpair-op p:mpair-expr e:expr ...)
#:with opt
(begin (log-optimization "mutable pair" #'op)
#`(op.unsafe p.opt #,@(map (optimize) (syntax->list #'(e ...)))))))
;; if the equivalent sequence of cars and cdrs is guaranteed not to fail,
;; we can optimize
;; accessors is a list of syntax objects, all #'car or #'cdr
(define (gen-alt accessors stx)
(syntax-parse stx
[(#%plain-app op arg)
(define (gen-alt-helper accessors)
(if (null? accessors)
#'arg
#`(#%plain-app #,(car accessors)
#,(gen-alt-helper (cdr accessors)))))
(let ((ty (type-of stx))
(obj (gen-alt-helper accessors)))
;; we're calling the typechecker, but this is just a shortcut, we're
;; still conceptually single pass (we're not iterating). we could get
;; the same result by statically destructing the types.
(tc-expr/check obj ty)
obj)]))
(define-syntax-class pair-derived-expr
#:commit
(pattern (#%plain-app (~literal caar) x)
#:with alt (gen-alt (list #'car #'car) this-syntax))
(pattern (#%plain-app (~literal cadr) x)
#:with alt (gen-alt (list #'car #'cdr) this-syntax))
(pattern (#%plain-app (~literal cdar) x)
#:with alt (gen-alt (list #'cdr #'car) this-syntax))
(pattern (#%plain-app (~literal cddr) x)
#:with alt (gen-alt (list #'cdr #'cdr) this-syntax)))
(define-syntax-class pair-derived-opt-expr
#:commit
(pattern e:pair-derived-expr
#:with e*:pair-opt-expr #'e.alt
#:with opt #'e*.opt))