1.0.3.20: better SEARCH transform

 * Better type declarations for index variables -- fixes the
   performance regression in BENCH-STRINGS from the NaN-comparison
   changes.

 * Extend the transform to work with general vectors, arbitrary :TEST and
   :KEY, and constant but arbitrary :FROM-END.

 * Tests.

diff --git a/NEWS b/NEWS
index 8c44ad8..c29650c 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -6,7 +6,8 @@ changes in sbcl-1.0.4 relative to sbcl-1.0.3:
     and gethostbyname, on platforms where the newer functions are available.
     As a result, the ALIASES field of HOST-ENT will always be NIL on these
     platforms.
-  * optimization: code using alien values with undeclared types is much faster
+  * optimization: code using alien values with undeclared types is much faster.
+  * optimization: the compiler is now able to open code SEARCH in more cases.
   * bug fix: >= and <= gave wrong results when used with NaNs.
   * bug fix: the #= and ## reader macros now interact reasonably with
     funcallable instances.

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index de9f0ff..24fe5ce 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -779,27 +779,60 @@
              finally (return `(progn ,@forms)))))
   (define-copy-seq-transforms))
 
-;;; FIXME: this would be a valid transform for certain excluded cases:
-;;;   * :TEST 'CHAR= or :TEST #'CHAR=
-;;;   * :TEST 'EQL   or :TEST #'EQL
-;;;   * :FROM-END NIL (or :FROM-END non-NIL, with a little ingenuity)
-(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2)
-                      (simple-string simple-string &rest t)
+;;; FIXME: it really should be possible to take advantage of the
+;;; macros used in code/seq.lisp here to avoid duplication of code,
+;;; and enable even funkier transformations.
+(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2
+                               (test #'eql)
+                               (key #'identity)
+                               from-end)
+                      (vector vector &rest t)
                       *
                       :policy (> speed (max space safety)))
-  `(block search
-    (let ((end1 (or end1 (length pattern)))
-          (end2 (or end2 (length text))))
-      (do ((index2 start2 (1+ index2)))
-          ((>= index2 end2) nil)
-        (when (do ((index1 start1 (1+ index1))
-                   (index2 index2 (1+ index2)))
-                  ((>= index1 end1) t)
-                (when (= index2 end2)
-                  (return-from search nil))
-                (when (char/= (char pattern index1) (char text index2))
-                  (return nil)))
-          (return index2))))))
+  "open code"
+  (let ((from-end (when (lvar-p from-end)
+                    (unless (constant-lvar-p from-end)
+                      (give-up-ir1-transform ":FROM-END is not constant."))
+                    (lvar-value from-end)))
+        (keyp (lvar-p key))
+        (testp (lvar-p test)))
+    `(block search
+       (let ((end1 (or end1 (length pattern)))
+             (end2 (or end2 (length text)))
+             ,@(when keyp
+                     '((key (coerce key 'function))))
+             ,@(when testp
+                     '((test (coerce test 'function)))))
+         (declare (type index start1 start2 end1 end2))
+         (do (,(if from-end
+                   '(index2 (- end2 (- end1 start1)) (1- index2))
+                   '(index2 start2 (1+ index2))))
+             (,(if from-end
+                   '(< index2 start2)
+                   '(>= index2 end2))
+              nil)
+           ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
+           ;; terminates is hits -1 when :FROM-END is true and :START2
+           ;; is 0.
+           (declare (type fixnum index2))
+           (when (do ((index1 start1 (1+ index1))
+                      (index2 index2 (1+ index2)))
+                     ((>= index1 end1) t)
+                   (declare (type index index1 index2))
+                   ,@(unless from-end
+                             '((when (= index2 end2)
+                                 (return-from search nil))))
+                   (unless (,@(if testp
+                                  '(funcall test)
+                                  '(eql))
+                              ,(if keyp
+                                   '(funcall key (aref pattern index1))
+                                   '(aref pattern index1))
+                              ,(if keyp
+                                   '(funcall key (aref text index2))
+                                   '(aref text index2)))
+                     (return nil)))
+             (return index2)))))))
 
 ;;; FIXME: It seems as though it should be possible to make a DEFUN
 ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index ee254df..ae10560 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -162,7 +162,23 @@
     (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
     (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
     (null (find-if-not #'plusp seq))
-    (eql 0 (position-if-not #'evenp seq))))
+    (eql 0 (position-if-not #'evenp seq))
+    (eql 0 (search #(1) seq))
+    (eql 1 (search #(4 5) seq :key 'oddp))
+    (eql 1 (search #(-2) seq :test (lambda (a b) (= (- a) b))))
+    (eql 4 (search #(1) seq :start2 1))
+    (null (search #(3) seq :start2 3))
+    (eql 2 (search #(3) seq :start2 2))
+    (eql 0 (search #(1 2) seq))
+    (null (search #(2 1 3) seq))
+    (eql 0 (search #(0 1 2 4) seq :start1 1 :end1 3))
+    (eql 3 (search #(0 2 1 4) seq :start1 1 :end1 3))
+    (eql 4 (search #(1) seq :from-end t))
+    (eql 0 (search #(1 2) seq :from-end t))
+    (null (search #(1 2) seq :from-end t :start2 1))
+    (eql 0 (search #(0 1 2 4) seq :from-end t :start1 1 :end1 3))
+    (eql 3 (search #(0 2 1 4) seq :from-end t :start1 1 :end1 3))
+    (null (search #(2 1 3) seq :from-end t))))
 (for-every-seq "string test"
   '((null (find 0 seq))
     (null (find #\D seq :key #'char-upcase))

diff --git a/version.lisp-expr b/version.lisp-expr
index 5550796..d4d9a05 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.3.19"
+"1.0.3.20"