From: Stas Boukarev <stassats@gmail.com>
Date: Thu, 5 Sep 2013 19:29:51 +0000 (+0400)
Subject: Optimize CHAR-EQUAL on constant and base-char args.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7a2ee8c1aff0bdd286cf5d43ab40bff7fed86bea;p=sbcl.git

Optimize CHAR-EQUAL on constant and base-char args.

The open-code transform for base-char arguments was never invoked, it
should have been defined on TWO-ARG-CHAR-EQUAL, not CHAR-EQUAL. And
enable it only for (> speed space).

Add a check for base-char into the TWO-ARG-CHAR-EQUAL function, and
invoke the optimized code, the same the transform uses.

Optimize (char-equal #\c x) by transforming it into a call to
(char-equal-constant x #\c #\C), which does
(or (char= #\c char) (char= #\C char)), or directly to that expression
with (> speed space).

(char-equal #\- x) is transformed to (char= #\- x).
---

diff --git a/NEWS b/NEWS
index 0ec8409..d54777d 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,7 @@ changes relative to sbcl-1.1.11:
     lp#994528)
   * optimization: EQUAL and EQUALP transforms are smarter.
     (thanks to Elias Martenson, lp#1220084)
+  * optimization: CHAR-EQUAL is faster for constant and base-char arguments.
   * bug fix: probe-file now can access symlinks to pipes and sockets in
     /proc/pid/fd on Linux. (reported by Eric Schulte)
   * bug fix: SBCL can now be built on Solaris x86-64.
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 9e850e3..631504b 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1007,6 +1007,7 @@ possibly temporariliy, because it might be used internally."
                "TWO-ARG-CHAR-EQUAL" "TWO-ARG-CHAR-NOT-EQUAL"
                "TWO-ARG-CHAR-LESSP" "TWO-ARG-CHAR-NOT-LESSP"
                "TWO-ARG-CHAR-GREATERP" "TWO-ARG-CHAR-NOT-GREATERP"
+               "CHAR-EQUAL-CONSTANT"
                ;; FIXME: potential SB!EXT exports
                "CHARACTER-CODING-ERROR"
                "CHARACTER-DECODING-ERROR" "CHARACTER-DECODING-ERROR-OCTETS"
diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp
index 0994977..265a09f 100644
--- a/src/code/target-char.lisp
+++ b/src/code/target-char.lisp
@@ -519,7 +519,24 @@ is either numeric or alphabetic."
 
 (defun two-arg-char-equal (c1 c2)
   (or (eq c1 c2)
-      (= (equal-char-code c1) (equal-char-code c2))))
+      (typecase c1
+        (base-char
+         (and (base-char-p c2)
+              (let* ((code1 (char-code c1))
+                     (code2 (char-code c2))
+                     (sum (logxor code1 code2)))
+                (when (eql sum #x20)
+                  (let ((sum (+ code1 code2)))
+                    (or (and (> sum 161) (< sum 213))
+                        (and (> sum 415) (< sum 461))
+                        (and (> sum 463) (< sum 477))))))))
+        (t
+         (= (equal-char-code c1) (equal-char-code c2))))))
+
+(defun char-equal-constant (x char reverse-case-char)
+  (declare (type character x))
+  (or (eq char x)
+      (eq reverse-case-char x)))
 
 (defun char-equal (character &rest more-characters)
   #!+sb-doc
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 3578f2f..cee3709 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -426,6 +426,10 @@
            two-arg-char-not-greaterp)
     (character character) boolean (movable foldable flushable))
 
+(defknown char-equal-constant (character character character)
+  boolean
+  (movable foldable flushable explicit-check))
+
 (defknown character (t) character (movable foldable unsafely-flushable))
 (defknown char-code (character) char-code (movable foldable flushable))
 (defknown (char-upcase char-downcase) (character) character
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index b66f0f4..5d4a693 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3185,7 +3185,7 @@
         ,(lvar-value x))
       (give-up-ir1-transform)))
 
-(dolist (x '(= char= + * logior logand logxor logtest))
+(dolist (x '(= char= two-arg-char-equal + * logior logand logxor logtest))
   (%deftransform x '(function * *) #'commutative-arg-swap
                  "place constant arg last"))
 
@@ -3707,7 +3707,8 @@
 
 ;;;; character operations
 
-(deftransform char-equal ((a b) (base-char base-char))
+(deftransform two-arg-char-equal ((a b) (base-char base-char) *
+                                  :policy (> speed space))
   "open code"
   '(let* ((ac (char-code a))
           (bc (char-code b))
@@ -3719,6 +3720,19 @@
                  (and (> sum 415) (< sum 461))
                  (and (> sum 463) (< sum 477))))))))
 
+(deftransform two-arg-char-equal ((a b) (* (constant-arg character)) *
+                                  :node node)
+  (let ((char (lvar-value b)))
+    (if (both-case-p char)
+        (let ((reverse (if (upper-case-p char)
+                           (char-downcase char)
+                           (char-upcase char))))
+          (if (policy node (> speed space))
+              `(or (char= a ,char)
+                   (char= a ,reverse))
+              `(char-equal-constant a ,char ,reverse)))
+        '(char= a b))))
+
 (deftransform char-upcase ((x) (base-char))
   "open code"
   '(let ((n-code (char-code x)))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index cb285c5..1a398d3 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2986,8 +2986,8 @@
         (compile nil `(lambda (x)
                         (declare (character x) (optimize speed))
                         (,name x))))
-      (dolist (name '(char= char/= char< char> char<= char>= char-equal
-                      char-not-equal char-lessp char-greaterp char-not-greaterp
+      (dolist (name '(char= char/= char< char> char<= char>=
+                      char-lessp char-greaterp char-not-greaterp
                       char-not-lessp))
         (setf current name)
         (compile nil `(lambda (x y)