From 1e1c06c5152cdcb129417c4460f0f3bb250e3a74 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Wed, 4 Sep 2013 21:08:41 -0700
Subject: [PATCH] Cleanup list optimizations.

original commit: 4631705b16deb9e3c0561ba97d2f73b22cf86cce
---
 .../typed-racket/optimizer/list.rkt           | 56 +++++++------------
 .../typed-racket/optimizer/utils.rkt          | 15 +++++
 .../optimizer/tests/known-length-lists.rkt    | 27 +++++----
 3 files changed, 47 insertions(+), 51 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/list.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/list.rkt
index e6965a58..ada38850 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/list.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/list.rkt
@@ -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))))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt
index f87843a6..8d037413 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt
@@ -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])))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/known-length-lists.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/known-length-lists.rkt
index ed25c465..a8fa59c2 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/known-length-lists.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/known-length-lists.rkt
@@ -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