diff --git a/collects/tests/typed-scheme/optimizer/tests/define-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/define-pair.rkt index 379dcf8c..28036634 100644 --- a/collects/tests/typed-scheme/optimizer/tests/define-pair.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/define-pair.rkt @@ -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 diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt new file mode 100644 index 00000000..26dbab51 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt @@ -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))) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt index 92f40326..4af3768e 100644 --- a/collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt @@ -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 diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt index f7670a0b..d0caa847 100644 --- a/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt @@ -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 ) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt index 651a4d5f..11bc2549 100644 --- a/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt @@ -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) ) diff --git a/collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt b/collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt index 35d88957..b2a4bcc7 100644 --- a/collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt @@ -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 diff --git a/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt b/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt new file mode 100644 index 00000000..96f4c232 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt @@ -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))) diff --git a/collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt index 404b1377..c5055379 100644 --- a/collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt @@ -1,6 +1,6 @@ #; ( -simple-pair.rkt line 10 col 1 - car - unary pair +simple-pair.rkt line 10 col 1 - car - pair 1 ) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt index 6bac579c..c3c220ec 100644 --- a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt @@ -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 diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt index 59f5242d..627193c5 100644 --- a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt @@ -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 diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt index 6202645c..f9e56084 100644 --- a/collects/typed-scheme/optimizer/pair.rkt +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -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))