X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=67ecb5a44e898458fc366dbc02eca9a978c87705;hb=fa2c3ba871c9818e5768fd8f6092ddda83a93a1f;hp=5e4de7fb7a68d8a3ca325f7a38d883c919c7b1fa;hpb=a4ea3949e051d8c9248b231f175d54a20618743e;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 5e4de7f..67ecb5a 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -316,6 +316,8 @@
       (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S"
            function-name key-functions variant)))
 
+(defparameter *list-open-code-limit* 128)
+
 (defun transform-list-item-seek (name item list key test test-not node)
   (when (and test test-not)
     (abort-ir1-transform "Both ~S and ~S supplied to ~S." :test :test-not name))
@@ -376,7 +378,8 @@
         (let* ((cp (constant-lvar-p list))
                (c-list (when cp (lvar-value list))))
           (cond ((and cp c-list (member name '(assoc rassoc member))
-                      (policy node (>= speed space)))
+                      (policy node (>= speed space))
+                      (not (nthcdr *list-open-code-limit* c-list)))
                  `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs)
                     ,(open-code c-list)))
                 ((and cp (not c-list))
@@ -431,7 +434,8 @@
                         ,(open-code (cdr tail))))))
         (let* ((cp (constant-lvar-p list))
                (c-list (when cp (lvar-value list))))
-          (cond ((and cp c-list (policy node (>= speed space)))
+          (cond ((and cp c-list (policy node (>= speed space))
+                      (not (nthcdr *list-open-code-limit* c-list)))
                  `(let ((pred ,pred-expr)
                         ,@(when key `((key ,key-form))))
                     ,(open-code c-list)))
@@ -482,21 +486,11 @@
 ;;; almost as fast as MEMQ.
 (deftransform delete ((item list &key test) (t list &rest t) *)
   "convert to EQ test"
-  ;; FIXME: The scope of this transformation could be
-  ;; widened somewhat, letting it work whenever the test is
-  ;; 'EQL and we know from the type of ITEM that it #'EQ
-  ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER,
-  ;; and SYMBOL.)
-  ;;   If TEST is EQ, apply transform, else
-  ;;   if test is not EQL, then give up on transform, else
-  ;;   if ITEM is not a NUMBER or is a FIXNUM, apply
-  ;;   transform, else give up on transform.
-  (cond (test
-         (unless (lvar-fun-is test '(eq))
-           (give-up-ir1-transform)))
-        ((types-equal-or-intersect (lvar-type item)
-                                   (specifier-type 'number))
-         (give-up-ir1-transform "Item might be a number.")))
+  (let ((type (lvar-type item)))
+    (unless (or (and test (lvar-fun-is test '(eq)))
+                (and (eq-comparable-type-p type)
+                     (or (not test) (lvar-fun-is test '(eql)))))
+      (give-up-ir1-transform)))
   `(delq item list))
 
 (deftransform delete-if ((pred list) (t list))