From f88c8f479e6dfb07f87e2c65ab8c5b85d865b058 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 9 Sep 2010 18:32:39 -0400
Subject: [PATCH] Extended pair optimization to the rest of the standard
 derived pair accessors.

original commit: 0166ece180194605a52841a2a91fb2618e0372a1
---
 .../optimizer/tests/derived-pair2.rkt         |  54 ++++++++
 .../optimizer/tests/derived-pair3.rkt         | 118 ++++++++++++++++++
 collects/typed-scheme/optimizer/pair.rkt      |  26 +++-
 3 files changed, 197 insertions(+), 1 deletion(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt
 create mode 100644 collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt

diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt
new file mode 100644
index 00000000..2f540a2a
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt
@@ -0,0 +1,54 @@
+#;
+(
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+derived-pair2.rkt line 47 col 0 - (#%app caaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+derived-pair2.rkt line 48 col 0 - (#%app caadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+derived-pair2.rkt line 49 col 0 - (#%app cadar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+derived-pair2.rkt line 50 col 0 - (#%app caddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+derived-pair2.rkt line 51 col 0 - (#%app cdaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+derived-pair2.rkt line 52 col 0 - (#%app cdadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+derived-pair2.rkt line 53 col 0 - (#%app cddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+derived-pair2.rkt line 54 col 0 - (#%app cdddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) - derived pair
+1
+2
+2
+3
+2
+3
+3
+4
+)
+
+#lang typed/racket #:optimize
+
+(caaar (cons (cons (cons 1 2) 3) 4))
+(caadr (cons 1 (cons (cons 2 3) 4)))
+(cadar (cons (cons 1 (cons 2 3)) 4))
+(caddr (cons 1 (cons 2 (cons 3 4))))
+(cdaar (cons (cons (cons 1 2) 3) 4))
+(cdadr (cons 1 (cons (cons 2 3) 4)))
+(cddar (cons (cons 1 (cons 2 3)) 4))
+(cdddr (cons 1 (cons 2 (cons 3 4))))
diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt
new file mode 100644
index 00000000..4fa58e4d
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt
@@ -0,0 +1,118 @@
+#;
+(
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+derived-pair3.rkt line 103 col 0 - (#%app caaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+derived-pair3.rkt line 104 col 0 - (#%app caaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+derived-pair3.rkt line 105 col 0 - (#%app caadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+derived-pair3.rkt line 106 col 0 - (#%app caaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+derived-pair3.rkt line 107 col 0 - (#%app cadaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+derived-pair3.rkt line 108 col 0 - (#%app cadadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+derived-pair3.rkt line 109 col 0 - (#%app caddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+derived-pair3.rkt line 110 col 0 - (#%app cadddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+derived-pair3.rkt line 111 col 0 - (#%app cdaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+derived-pair3.rkt line 112 col 0 - (#%app cdaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+derived-pair3.rkt line 113 col 0 - (#%app cdadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+derived-pair3.rkt line 114 col 0 - (#%app cdaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+derived-pair3.rkt line 115 col 0 - (#%app cddaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+derived-pair3.rkt line 116 col 0 - (#%app cddadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) - derived pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+derived-pair3.rkt line 117 col 0 - (#%app cdddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) - derived pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
+derived-pair3.rkt line 118 col 0 - (#%app cddddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) - derived pair
+1
+2
+2
+3
+2
+3
+3
+4
+2
+3
+3
+4
+3
+4
+4
+5
+)
+
+#lang typed/racket #:optimize
+
+(caaaar (cons (cons (cons (cons 1 2) 3) 4) 5))
+(caaadr (cons 1 (cons (cons (cons 2 3) 4) 5)))
+(caadar (cons (cons 1 (cons (cons 2 3) 4)) 5))
+(caaddr (cons 1 (cons 2 (cons (cons 3 4) 5))))
+(cadaar (cons (cons (cons 1 (cons 2 3)) 4) 5))
+(cadadr (cons 1 (cons (cons 2 (cons 3 4)) 5)))
+(caddar (cons (cons 1 (cons 2 (cons 3 4))) 5))
+(cadddr (cons 1 (cons 2 (cons 3 (cons 4 5)))))
+(cdaaar (cons (cons (cons (cons 1 2) 3) 4) 5))
+(cdaadr (cons 1 (cons (cons (cons 2 3) 4) 5)))
+(cdadar (cons (cons 1 (cons (cons 2 3) 4)) 5))
+(cdaddr (cons 1 (cons 2 (cons (cons 3 4) 5))))
+(cddaar (cons (cons (cons 1 (cons 2 3)) 4) 5))
+(cddadr (cons 1 (cons (cons 2 (cons 3 4)) 5)))
+(cdddar (cons (cons 1 (cons 2 (cons 3 4))) 5))
+(cddddr (cons 1 (cons 2 (cons 3 (cons 4 5)))))
diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt
index 38120a3d..948eb5f1 100644
--- a/collects/typed-scheme/optimizer/pair.rkt
+++ b/collects/typed-scheme/optimizer/pair.rkt
@@ -86,7 +86,31 @@
  (caar #'car #'car)
  (cadr #'car #'cdr)
  (cdar #'cdr #'car)
- (cddr #'cdr #'cdr))
+ (cddr #'cdr #'cdr)
+ (caaar #'car #'car #'car)
+ (caadr #'car #'car #'cdr)
+ (cadar #'car #'cdr #'car)
+ (caddr #'car #'cdr #'cdr)
+ (cdaar #'cdr #'car #'car)
+ (cdadr #'cdr #'car #'cdr)
+ (cddar #'cdr #'cdr #'car)
+ (cdddr #'cdr #'cdr #'cdr)
+ (caaaar #'car #'car #'car #'car)
+ (caaadr #'car #'car #'car #'cdr)
+ (caadar #'car #'car #'cdr #'car)
+ (caaddr #'car #'car #'cdr #'cdr)
+ (cadaar #'car #'cdr #'car #'car)
+ (cadadr #'car #'cdr #'car #'cdr)
+ (caddar #'car #'cdr #'cdr #'car)
+ (cadddr #'car #'cdr #'cdr #'cdr)
+ (cdaaar #'cdr #'car #'car #'car)
+ (cdaadr #'cdr #'car #'car #'cdr)
+ (cdadar #'cdr #'car #'cdr #'car)
+ (cdaddr #'cdr #'car #'cdr #'cdr)
+ (cddaar #'cdr #'cdr #'car #'car)
+ (cddadr #'cdr #'cdr #'car #'cdr)
+ (cdddar #'cdr #'cdr #'cdr #'car)
+ (cddddr #'cdr #'cdr #'cdr #'cdr))
 
 (define-syntax-class pair-derived-opt-expr
   #:commit