Convert an ASSERT into an AVER in INIT-LIVE-TNS

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index e13c30e..c808988 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -242,7 +242,7 @@
    (t (values nil t))))
 (define-source-transform get (&rest args)
   (case (length args)
    (t (values nil t))))
 (define-source-transform get (&rest args)
   (case (length args)

-   (2 `(sb!impl::get2 ,@args))
+   (2 `(sb!impl::get3 ,@args nil))

    (3 `(sb!impl::get3 ,@args))
    (t (values nil t))))
 
    (3 `(sb!impl::get3 ,@args))
    (t (values nil t))))
 

@@ -2522,7 +2522,7 @@
             `(mod ,base-char-code-limit)))
           (t
            (specifier-type
             `(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)))
 
 (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)
                  (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
                "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
                (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)))
                            (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
                "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.
 
                 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)
                 (*) 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))
                      (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
 
 (defun best-modular-version (width signedp)
   ;; 1. exact width-matched :untagged

@@ -3044,7 +3071,10 @@
   ;; 3. >/>= width-matched :untagged
   (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
          (uswidths (modular-class-widths *untagged-signed-modular-class*))
   ;; 3. >/>= width-matched :untagged
   (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
          (uswidths (modular-class-widths *untagged-signed-modular-class*))

-         (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
+         (uwidths (if (and uuwidths uswidths)
+                      (merge 'list (copy-list uuwidths) (copy-list uswidths)
+                             #'< :key #'car)
+                      (or uuwidths uswidths)))

          (twidths (modular-class-widths *tagged-modular-class*)))
     (let ((exact (find (cons width signedp) uwidths :test #'equal)))
       (when exact
          (twidths (modular-class-widths *tagged-modular-class*)))
     (let ((exact (find (cons width signedp) uwidths :test #'equal)))
       (when exact

@@ -3075,6 +3105,8 @@
            (return (values nil nil)))
          (let ((this-low (numeric-type-low type))
                (this-high (numeric-type-high type)))
            (return (values nil nil)))
          (let ((this-low (numeric-type-low type))
                (this-high (numeric-type-high type)))

+           (unless (and this-low this-high)
+             (return (values nil nil)))

            (setf low  (min this-low  (or low  this-low))
                  high (max this-high (or high this-high)))))))))
 
            (setf low  (min this-low  (or low  this-low))
                  high (max this-high (or high this-high)))))))))
 

@@ -3153,7 +3185,7 @@
         ,(lvar-value x))
       (give-up-ir1-transform)))
 
         ,(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"))
 
   (%deftransform x '(function * *) #'commutative-arg-swap
                  "place constant arg last"))
 

@@ -3675,7 +3707,8 @@
 \f
 ;;;; character operations
 
 \f
 ;;;; 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))
   "open code"
   '(let* ((ac (char-code a))
           (bc (char-code b))

@@ -3687,6 +3720,19 @@
                  (and (> sum 415) (< sum 461))
                  (and (> sum 463) (< sum 477))))))))
 
                  (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)))
 (deftransform char-upcase ((x) (base-char))
   "open code"
   '(let ((n-code (char-code x)))

@@ -3789,25 +3835,72 @@
   "convert to simpler equality predicate"
   (let ((x-type (lvar-type x))
         (y-type (lvar-type y))
   "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.
 
 ;;; Convert to EQL if both args are rational and complexp is specified
 ;;; and the same for both.

@@ -3975,15 +4068,15 @@
                                                             'character))
 
 (define-source-transform char-equal (&rest args)
                                                             '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)
 (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)
 (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)
 (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)
 (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
 
 ;;; This function does source transformation of N-arg inequality
 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3

@@ -4032,6 +4125,48 @@
         `(values (the real ,arg0))
         `(let ((minrest (min ,@rest)))
           (if (<= ,arg0 minrest) ,arg0 minrest)))))
         `(values (the real ,arg0))
         `(let ((minrest (min ,@rest)))
           (if (<= ,arg0 minrest) ,arg0 minrest)))))

+
+;;; Simplify some cross-type comparisons
+(macrolet ((def (comparator round)
+             `(progn
+                (deftransform ,comparator
+                    ((x y) (rational (constant-arg float)))
+                  "open-code RATIONAL to FLOAT comparison"
+                  (let ((y (lvar-value y)))
+                    #-sb-xc-host
+                    (when (or (float-nan-p y)
+                              (float-infinity-p y))
+                      (give-up-ir1-transform))
+                    (setf y (rational y))
+                    `(,',comparator
+                      x ,(if (csubtypep (lvar-type x)
+                                        (specifier-type 'integer))
+                             (,round y)
+                             y))))
+                (deftransform ,comparator
+                    ((x y) (integer (constant-arg ratio)))
+                  "open-code INTEGER to RATIO comparison"
+                  `(,',comparator x ,(,round (lvar-value y)))))))
+  (def < ceiling)
+  (def > floor))
+
+(deftransform = ((x y) (rational (constant-arg float)))
+  "open-code RATIONAL to FLOAT comparison"
+  (let ((y (lvar-value y)))
+    #-sb-xc-host
+    (when (or (float-nan-p y)
+              (float-infinity-p y))
+      (give-up-ir1-transform))
+    (setf y (rational y))
+    (if (and (csubtypep (lvar-type x)
+                        (specifier-type 'integer))
+             (ratiop y))
+        nil
+        `(= x ,y))))
+
+(deftransform = ((x y) (integer (constant-arg ratio)))
+  "constant-fold INTEGER to RATIO comparison"
+  nil)

 \f
 ;;;; converting N-arg arithmetic functions
 ;;;;
 \f
 ;;;; converting N-arg arithmetic functions
 ;;;;