Cleanup list optimizations.

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
+  #:attributes (opt len)
-  (pattern e:expr
+  (pattern (~and e :opt-expr)
-           #:when (match (type-of #'e)
+           #:attr tys (match (type-of #'e)
-                    [(tc-result1: (List: es)) #t]
+                        [(tc-result1: (List: es)) es]
-                    [_ #f])
+                        [_ #f])
-           #:with opt ((optimize) #'e)))
+           #:when (attribute tys)
+           #:attr len (length (attribute tys))))
 
-(define-syntax-class list-op
+(define-unsafe-syntax-class list-ref)
-  #:commit
+(define-unsafe-syntax-class list-tail)
-  (pattern (~literal list-ref)  #:with unsafe #'unsafe-list-ref)
+(define-literal-syntax-class length)
-  (pattern (~literal list-tail) #:with unsafe #'unsafe-list-tail))
+
+(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)
+  (pattern (#%plain-app op:list-op l:known-length-list-expr i:value-expr)
-           #:when (let ((len (match (type-of #'l)
+    #:when (<= 0 (attribute i.val) (sub1 (attribute l.len)))
-                               [(tc-result1: (List: es)) (length es)]
+    #:do [(log-opt "known-length list op" "List access specialization.")]
-                               [_ 0])) ; can't happen
+    #:with opt #'(op.unsafe l.opt i.opt))
-                        (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))))
   ;; We know the length of known-length lists statically.
-  (pattern (#%plain-app (~and op (~literal length)) l:known-length-list-expr)
+  (pattern (#%plain-app op:length^ l:known-length-list-expr)
-           #:with opt
+    #:do [(log-opt "known-length list length" "Static list length computation.")]
-           (begin (log-optimization "known-length list length"
+    #:with opt #`(let () l.opt #,(attribute l.len))))
-                                    "Static list length computation."
-                                    this-syntax)
-                  (add-disappeared-use #'op)
-                  (match (type-of #'l)
-                    [(tc-result1: (List: es))
-                     #`(begin l.opt #,(length es))]))))

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])))

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 41: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 42: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 43: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 44: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 45: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 46: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 47: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 48: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 49: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 50: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 51: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 52: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 53:0 (list-tail l 2) -- known-length list op
 END
 #<<END
-'(1 2 3)
 3
 1
 2