X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=55c4dba90e132d5b005eac3237d2397e0f40ea26;hb=df1314801984738011676b539cedd2c2a41d1f6e;hp=2ddcdbc3cfeb48550a0588c236a9eee6ad7ad2f4;hpb=423d7e5434081f8813e5c2399e4da052bcd36b57;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 2ddcdbc..55c4dba 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -291,6 +291,21 @@
             (or end length)
             (sb!impl::signal-bounding-indices-bad-error vector start end)))))
 
+(defun specialized-list-seek-function-name (function-name key-functions)
+  (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
+                     ;; way we are also proof against *PRINT-CASE*
+                     ;; frobbing and such.
+                     (write-char #\% s)
+                     (write-string (symbol-name function-name) s)
+                     (dolist (f key-functions)
+                       (write-char #\- s)
+                       (write-string (symbol-name f) 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)
   ;; 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
@@ -309,10 +324,6 @@
                    (values key '(%coerce-callable-to-fun key))))))
     (let* ((funs (remove nil (list (and key 'key) (cond (test 'test)
                                                         (test-not 'test-not)))))
-           (out-of-line (or (find-symbol (format nil "%~A~{-~A~}" name funs)
-                                         (load-time-value (find-package "SB!KERNEL")))
-                            (bug "Unknown list item seek transform: name=~S, funs=~S"
-                                 name funs)))
            (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)))
@@ -335,10 +346,18 @@
                  (if (eq 'key fun)
                      key-form
                      `(%coerce-callable-to-fun ,fun))))
-        (if (and (constant-lvar-p list) (policy node (>= speed space)))
-            `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
-               ,(open-code (lvar-value list)))
-            `(,out-of-line item list ,@(mapcar #'ensure-fun funs)))))))
+        (let* ((cp (constant-lvar-p list))
+               (c-list (when cp (lvar-value list))))
+          (cond ((and cp c-list (policy node (>= speed space)))
+                 `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+                    ,(open-code c-list)))
+                ((and cp (not c-list))
+                 ;; constant nil list -- nothing to find!
+                 nil)
+                (t
+                 ;; specialized out-of-line version
+                 `(,(specialized-list-seek-function-name name funs)
+                    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))