X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fseqtran.lisp;h=3d4dc91c68093ee3f145f0d687d75e73777a7247;hb=557df1e8a17c2f4d9f97752cb8476805e79f0073;hp=b9f1e07d694f1f3a50ee2dfd62acaca0e3b83d55;hpb=94e0f68a627ce839d59e88b4c8faad486e75af91;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index b9f1e07..3d4dc91 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -291,7 +291,7 @@
              (or end length)
              (sequence-bounding-indices-bad-error vector start end)))))
 
-(defun specialized-list-seek-function-name (function-name key-functions)
+(defun specialized-list-seek-function-name (function-name key-functions variant)
   (or (find-symbol (with-output-to-string (s)
                      ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
                      ;; this ever so slightly faster then FORMAT, this
@@ -301,32 +301,48 @@
                      (write-string (symbol-name function-name) s)
                      (dolist (f key-functions)
                        (write-char #\- s)
-                       (write-string (symbol-name f) s)))
+                       (write-string (symbol-name f) s))
+                     (when variant
+                       (write-char #\- s)
+                       (write-string (symbol-name variant) s)))
                    (load-time-value (find-package "SB!KERNEL")))
-      (bug "Unknown list item seek transform: name=~S, key-functions=~S"
-           function-name key-functions)))
-
-(defun transform-list-item-seek (name list key test test-not node)
+      (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S"
+           function-name key-functions variant)))
+
+(defun transform-list-item-seek (name item list key test test-not node)
+  ;; If TEST is EQL, drop it.
+  (when (and test (lvar-for-named-function test 'eql))
+    (setf test nil))
+  ;; Ditto for KEY IDENTITY.
+  (when (and key (lvar-for-named-function key 'identity))
+    (setf key nil))
   ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
   ;; not there at all. If it might be NIL, make up a form to that
-  ;; ensure it is a function.
+  ;; ensures it is a function.
   (multiple-value-bind (key key-form)
-      (if key
-          (let ((key-type (lvar-type key))
-                (null-type (specifier-type 'null)))
-            (cond ((csubtypep key-type null-type)
-                   (values nil nil))
-                  ((csubtypep null-type key-type)
-                   (values key '(if key
-                                 (%coerce-callable-to-fun key)
-                                 #'identity)))
-                  (t
-                   (values key '(%coerce-callable-to-fun key))))))
-    (let* ((funs (remove nil (list (and key 'key) (cond (test 'test)
+      (when key
+        (let ((key-type (lvar-type key))
+              (null-type (specifier-type 'null)))
+          (cond ((csubtypep key-type null-type)
+                 (values nil nil))
+                ((csubtypep null-type key-type)
+                 (values key '(if key
+                               (%coerce-callable-to-fun key)
+                               #'identity)))
+                (t
+                 (values key '(%coerce-callable-to-fun key))))))
+    (let* ((c-test (cond ((and test (lvar-for-named-function test 'eq))
+                          (setf test nil)
+                          'eq)
+                         ((and (not test) (not test-not))
+                          (when (eq-comparable-type-p (lvar-type item))
+                            'eq))))
+           (funs (remove nil (list (and key 'key) (cond (test 'test)
                                                         (test-not 'test-not)))))
            (target-expr (if key '(%funcall key target) 'target))
            (test-expr (cond (test `(%funcall test item ,target-expr))
                             (test-not `(not (%funcall test-not item ,target-expr)))
+                            (c-test `(,c-test item ,target-expr))
                             (t `(eql item ,target-expr)))))
       (labels ((open-code (tail)
                  (when tail
@@ -356,14 +372,14 @@
                  nil)
                 (t
                  ;; specialized out-of-line version
-                 `(,(specialized-list-seek-function-name name funs)
+                 `(,(specialized-list-seek-function-name name funs c-test)
                     item list ,@(mapcar #'ensure-fun funs)))))))))
 
 (deftransform member ((item list &key key test test-not) * * :node node)
-  (transform-list-item-seek 'member list key test test-not node))
+  (transform-list-item-seek 'member item list key test test-not node))
 
 (deftransform assoc ((item list &key key test test-not) * * :node node)
-  (transform-list-item-seek 'assoc list key test test-not node))
+  (transform-list-item-seek 'assoc item list key test test-not node))
 
 (deftransform memq ((item list) (t (constant-arg list)))
   (labels ((rec (tail)
@@ -668,8 +684,10 @@
      (define-one-transform (sequence-type1 sequence-type2)
        (make-replace-transform nil sequence-type1 sequence-type2)))
   (define-replace-transforms)
-  (define-one-transform simple-base-string (simple-array character (*)))
-  (define-one-transform (simple-array character (*)) simple-base-string))
+  #!+sb-unicode
+  (progn
+   (define-one-transform (simple-array base-char (*)) (simple-array character (*)))
+   (define-one-transform (simple-array character (*)) (simple-array base-char (*)))))
 
 ;;; Expand simple cases of UB<SIZE>-BASH-COPY inline.  "simple" is
 ;;; defined as those cases where we are doing word-aligned copies from
@@ -734,7 +752,8 @@
            (do ((i end (1- i)))
                ((<= i ,src-word))
              (setf (sb!kernel:%vector-raw-bits dst (1- i))
-                   (sb!kernel:%vector-raw-bits src (1- i)))))))))
+                   (sb!kernel:%vector-raw-bits src (1- i))))
+           (values))))))
 
 #.(loop for i = 1 then (* i 2)
         collect `(deftransform ,(intern (format nil "UB~D-BASH-COPY" i)