X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=b09518a5f2ef1b9fc1699a19ed264392dbc5bbdb;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=2fc1c400b322b74228ea85b3fad530b45fc8826e;hpb=e240610bcc02cfe6f970131a362502d33be114c5;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 2fc1c40..b09518a 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2522,7 +2522,7 @@
             `(mod ,base-char-code-limit)))
           (t
            (specifier-type
-            `(mod ,char-code-limit))))))
+            `(mod ,sb!xc:char-code-limit))))))
 
 (defoptimizer (code-char derive-type) ((code))
   (let ((type (lvar-type code)))
@@ -2955,10 +2955,11 @@
                  (setf (block-reoptimize (node-block node)) t)
                  (reoptimize-component (node-component node) :maybe))
                t)
-             (cut-node (node &aux did-something)
+             (cut-node (node &aux did-something over-wide)
                "Try to cut a node to width. The primary return value is
                 whether we managed to cut (cleverly), and the second whether
-                anything was changed."
+                anything was changed.  The third return value tells whether
+                the cut value might be wider than expected."
                (when (block-delete-p (node-block node))
                  (return-from cut-node (values t nil)))
                (typecase node
@@ -2987,32 +2988,51 @@
                            (fun-name (lvar-fun-name (combination-fun node)))
                            (modular-fun (find-modular-version fun-name kind
                                                               signedp width)))
-                      (when (and modular-fun
-                                 (not (and (eq fun-name 'logand)
-                                           (csubtypep
-                                            (single-value-type (node-derived-type node))
-                                            type))))
-                        (binding* ((name (etypecase modular-fun
-                                           ((eql :good) fun-name)
-                                           (modular-fun-info
-                                            (modular-fun-info-name modular-fun))
-                                           (function
-                                            (funcall modular-fun node width)))
-                                         :exit-if-null))
-                          (unless (eql modular-fun :good)
-                            (setq did-something t)
-                            (change-ref-leaf
-                             fun-ref
-                             (find-free-fun name "in a strange place"))
-                            (setf (combination-kind node) :full))
-                          (unless (functionp modular-fun)
-                            (dolist (arg (basic-combination-args node))
-                              (when (cut-lvar arg)
-                                (setq did-something t))))
-                          (when did-something
-                            (reoptimize-node node name))
-                          (values t did-something))))))))
-             (cut-lvar (lvar &aux did-something must-insert)
+                      (cond ((not modular-fun)
+                             ;; don't know what to do here
+                             (values nil nil))
+                            ((let ((dtype (single-value-type
+                                           (node-derived-type node))))
+                               (and
+                                (case fun-name
+                                  (logand
+                                   (csubtypep dtype
+                                              (specifier-type 'unsigned-byte)))
+                                  (logior
+                                   (csubtypep dtype
+                                              (specifier-type '(integer * 0))))
+                                  (mask-signed-field
+                                   t)
+                                  (t nil))
+                                (csubtypep dtype type)))
+                             ;; nothing to do
+                             (values t nil))
+                            (t
+                             (binding* ((name (etypecase modular-fun
+                                                ((eql :good) fun-name)
+                                                (modular-fun-info
+                                                 (modular-fun-info-name modular-fun))
+                                                (function
+                                                 (funcall modular-fun node width)))
+                                              :exit-if-null))
+                               (unless (eql modular-fun :good)
+                                 (setq did-something t
+                                       over-wide t)
+                                 (change-ref-leaf
+                                  fun-ref
+                                  (find-free-fun name "in a strange place"))
+                                 (setf (combination-kind node) :full))
+                               (unless (functionp modular-fun)
+                                 (dolist (arg (basic-combination-args node))
+                                   (multiple-value-bind (change wide)
+                                       (cut-lvar arg)
+                                     (setf did-something (or did-something change)
+                                           over-wide (or over-wide wide)))))
+                               (when did-something
+                                 (reoptimize-node node name))
+                               (values t did-something over-wide)))))))))
+             (cut-lvar (lvar &key head
+                        &aux did-something must-insert over-wide)
                "Cut all the LVAR's use nodes. If any of them wasn't handled
                 and its type is too wide for the operation we wish to perform
                 insert an explicit bit-width narrowing operation (LOGAND or
@@ -3021,22 +3041,29 @@
                 destination is already such an operation, to avoid endless
                 recursion.
 
+                If we're at the head, forcibly insert a cut operation if the
+                result might be too wide.
+
                 (*) We can't easily do that for each node, and doing so might
                 result in code bloat, anyway. (I'm also not sure it would be
                 correct for complicated C/D FG)"
                (do-uses (node lvar)
-                 (multiple-value-bind (handled any-change)
+                 (multiple-value-bind (handled any-change wide)
                      (cut-node node)
                    (setf did-something (or did-something any-change)
                          must-insert (or must-insert
                                          (not (or handled
                                                   (csubtypep (single-value-type
                                                               (node-derived-type node))
-                                                             type)))))))
-               (when must-insert
-                 (setf did-something (or (insert-lvar-cut lvar) did-something)))
-               did-something))
-      (cut-lvar lvar))))
+                                                             type))))
+                         over-wide (or over-wide wide))))
+               (when (or must-insert
+                         (and head over-wide))
+                 (setf did-something (or (insert-lvar-cut lvar) did-something)
+                       ;; we're just the right width after an explicit cut.
+                       over-wide nil))
+               (values did-something over-wide)))
+      (cut-lvar lvar :head t))))
 
 (defun best-modular-version (width signedp)
   ;; 1. exact width-matched :untagged
@@ -3158,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"))
 
@@ -3680,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))
@@ -3692,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)))
@@ -3794,25 +3835,72 @@
   "convert to simpler equality predicate"
   (let ((x-type (lvar-type x))
         (y-type (lvar-type y))
-        (string-type (specifier-type 'string))
-        (bit-vector-type (specifier-type 'bit-vector)))
-    (cond
-      ((same-leaf-ref-p x y) t)
-      ((and (csubtypep x-type string-type)
-            (csubtypep y-type string-type))
-       '(string= x y))
-      ((and (csubtypep x-type bit-vector-type)
-            (csubtypep y-type bit-vector-type))
-       '(bit-vector-= x y))
-      ;; if at least one is not a string, and at least one is not a
-      ;; bit-vector, then we can reason from types.
-      ((and (not (and (types-equal-or-intersect x-type string-type)
-                      (types-equal-or-intersect y-type string-type)))
-            (not (and (types-equal-or-intersect x-type bit-vector-type)
-                      (types-equal-or-intersect y-type bit-vector-type)))
-            (not (types-equal-or-intersect x-type y-type)))
-       nil)
-      (t (give-up-ir1-transform)))))
+        (combination-type (specifier-type '(or bit-vector string
+                                            cons pathname))))
+    (flet ((both-csubtypep (type)
+             (let ((ctype (specifier-type type)))
+               (and (csubtypep x-type ctype)
+                    (csubtypep y-type ctype)))))
+      (cond
+        ((same-leaf-ref-p x y) t)
+        ((both-csubtypep 'string)
+         '(string= x y))
+        ((both-csubtypep 'bit-vector)
+         '(bit-vector-= x y))
+        ((both-csubtypep 'pathname)
+         '(pathname= x y))
+        ((or (not (types-equal-or-intersect x-type combination-type))
+             (not (types-equal-or-intersect y-type combination-type)))
+         (if (types-equal-or-intersect x-type y-type)
+             '(eql x y)
+             ;; Can't simply check for type intersection if both types are combination-type
+             ;; since array specialization would mean types don't intersect, even when EQUAL
+             ;; doesn't care for specialization.
+             ;; Previously checking for intersection in the outer COND resulted in
+             ;;
+             ;; (equal (the (cons (or simple-bit-vector
+             ;;                       simple-base-string))
+             ;;             x)
+             ;;        (the (cons (or (and bit-vector (not simple-array))
+             ;;                       (simple-array character (*))))
+             ;;             y))
+             ;; being incorrectly folded to NIL
+             nil))
+        (t (give-up-ir1-transform))))))
+
+(deftransform equalp ((x y) * *)
+  "convert to simpler equality predicate"
+  (let ((x-type (lvar-type x))
+        (y-type (lvar-type y))
+        (combination-type (specifier-type '(or number array
+                                            character
+                                            cons pathname
+                                            instance hash-table))))
+    (flet ((both-csubtypep (type)
+             (let ((ctype (specifier-type type)))
+               (and (csubtypep x-type ctype)
+                    (csubtypep y-type ctype)))))
+      (cond
+        ((same-leaf-ref-p x y) t)
+        ((both-csubtypep 'string)
+         '(string-equal x y))
+        ((both-csubtypep 'bit-vector)
+         '(bit-vector-= x y))
+        ((both-csubtypep 'pathname)
+         '(pathname= x y))
+        ((both-csubtypep 'character)
+         '(char-equal x y))
+        ((both-csubtypep 'number)
+         '(= x y))
+        ((both-csubtypep 'hash-table)
+         '(hash-table-equalp x y))
+        ((or (not (types-equal-or-intersect x-type combination-type))
+             (not (types-equal-or-intersect y-type combination-type)))
+         ;; See the comment about specialized types in the EQUAL transform above
+         (if (types-equal-or-intersect y-type x-type)
+             '(eq x y)
+             nil))
+        (t (give-up-ir1-transform))))))
 
 ;;; Convert to EQL if both args are rational and complexp is specified
 ;;; and the same for both.
@@ -3980,15 +4068,15 @@
                                                             'character))
 
 (define-source-transform char-equal (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t))
+  (multi-compare 'two-arg-char-equal args nil 'character t))
 (define-source-transform char-lessp (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t))
+  (multi-compare 'two-arg-char-lessp args nil 'character t))
 (define-source-transform char-greaterp (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t))
+  (multi-compare 'two-arg-char-greaterp args nil 'character t))
 (define-source-transform char-not-greaterp (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t))
+  (multi-compare 'two-arg-char-greaterp args t 'character t))
 (define-source-transform char-not-lessp (&rest args)
-  (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t))
+  (multi-compare 'two-arg-char-lessp args t 'character t))
 
 ;;; This function does source transformation of N-arg inequality
 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3