;;;; This file contains DERIVE-TYPE methods for LOGAND, LOGIOR, and
;;;; friends.

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-C")

;;; Return the maximum number of bits an integer of the supplied type
;;; can take up, or NIL if it is unbounded. The second (third) value
;;; is T if the integer can be positive (negative) and NIL if not.
;;; Zero counts as positive.
(defun integer-type-length (type)
  (if (and (numeric-type-p type)
           (eq (numeric-type-class type) 'integer))
      (let ((min (numeric-type-low type))
            (max (numeric-type-high type)))
        (values (and min max (max (integer-length min) (integer-length max)))
                (or (null max) (not (minusp max)))
                (or (null min) (minusp min))
                min
                max))
      (values nil t t nil nil)))

;;;; Generators for simple bit masks

;;; Return an integer consisting of zeroes in its N least significant
;;; bit positions and ones in all others. If N is negative, return -1.
(declaim (inline zeroes))
(defun zeroes (n)
  (ash -1 n))

;;; Return an integer consisting of ones in its N least significant
;;; bit positions and zeroes in all others. If N is negative, return 0.
(declaim (inline ones))
(defun ones (n)
  (lognot (ash -1 n)))

;;; The functions LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-BOUNDS below use
;;; algorithms derived from those in the chapter "Propagating Bounds
;;; through Logical Operations" from _Hacker's Delight_, Henry S.
;;; Warren, Jr., 2nd ed., pp 87-90.
;;;
;;; We used to implement the algorithms from that source (then its first
;;; edition) very faithfully here which exposed a weakness of theirs,
;;; namely worst case quadratical runtime in the number of bits of the
;;; input values, potentially leading to excessive compilation times for
;;; expressions involving bignums. To avoid that, I have devised and
;;; implemented variations of these algorithms that achieve linear
;;; runtime in all cases.
;;;
;;; Like Warren, let's start with the high bound on LOGIOR to explain
;;; how this is done. To follow, please read Warren's explanations on
;;; his "maxOR" function and compare this with how the second return
;;; value of LOGIOR-DERIVE-UNSIGNED-BOUNDS below is calculated.
;;;
;;; "maxOR" loops starting from the left until it finds a position where
;;; both B and D are 1 and where it is possible to decrease one of these
;;; bounds by setting this bit in it to 0 and all following ones to 1
;;; without the resulting value getting below the corresponding lower
;;; bound (A or C). This is done by calculating the modified values
;;; during each iteration where both B and D are 1 and comparing them
;;; against the lower bounds.
;;; The trick to avoid the loop is to exchange the order of the steps:
;;; First determine from which position rightwards it would be allowed
;;; to change B or D in this way and have the result be larger or equal
;;; than A or C respectively and then find the leftmost position equal
;;; to this or to the right of it where both B and D are 1.
;;; It is quite simple to find from where rightwards B could be modified
;;; this way: This is the leftmost position where B has a 1 and A a 0,
;;; or, cheaper to calculate, the leftmost position where A and B
;;; differ. Thus (INTEGER-LENGTH (LOGXOR A B)) gives us this position
;;; where a result of 1 corresponds to the rightmost bit position. As we
;;; don't care which of B or D we modify we can take the maximum of this
;;; value and of (INTEGER-LENGTH (LOGXOR C D)).
;;; The rest is equally simple: Build a mask of 1 bits from the thusly
;;; found position rightwards, LOGAND it with B and D and feed that into
;;; INTEGER-LENGTH. From this build another mask and LOGIOR it with B
;;; and D to set the desired bits.
;;; The special cases where A equals B and/or C equals D are covered by
;;; the same code provided the mask generator treats an argument of -1
;;; the same as 0, which both ZEROES and ONES do.
;;;
;;; To calculate the low bound on LOGIOR we need to treat X and Y
;;; independently for longer but the basic idea stays the same.
;;;
;;; LOGAND-DERIVE-UNSIGNED-BOUNDS can be derived by sufficiently many
;;; applications of DeMorgan's law from LOGIOR-DERIVE-UNSIGNED-BOUNDS.
;;; The implementation additionally avoids work (that is, calculations
;;; of one's complements) by using the identity (INTEGER-LENGTH X) =
;;; (INTEGER-LENGTH (LOGNOT X)) and observing that ZEROES is cheaper
;;; than ONES.
;;;
;;; For the low bound on LOGXOR we use Warren's formula
;;;   minXOR(a, b, c, d) = minAND(a, b, !d, !c) | minAND(!b, !a, c, d)
;;; where "!" is bitwise negation and "|" is bitwise or. Both minANDs
;;; are implemented as in LOGAND-DERIVE-UNSIGNED-BOUNDS (the part for
;;; the first result), sharing the first LOGXOR and INTEGER-LENGTH
;;; calculations as (LOGXOR A B) = (LOGXOR (LOGNOT B) (LOGNOT A)).
;;;
;;; For the high bound on LOGXOR Warren's formula seems unnecessarily
;;; complex. Instead, with (LOGNOT (LOGXOR X Y)) = (LOGXOR X (LOGNOT Y))
;;; we have
;;;   maxXOR(a, b, c, d) = !minXOR(a, b, !d, !c)
;;; and rewriting minXOR as above yields
;;;   maxXOR(a, b, c, d) = !(minAND(a, b, c, d) | minAND(!b, !a, !d, !c))
;;; This again shares the first LOGXOR and INTEGER-LENGTH calculations
;;; between both minANDs and with the ones for the low bound.
;;;
;;; LEU, 2013-04-29.

(defun logand-derive-unsigned-bounds (x y)
  (let* ((a (numeric-type-low x))
         (b (numeric-type-high x))
         (c (numeric-type-low y))
         (d (numeric-type-high y))
         (length-xor-x (integer-length (logxor a b)))
         (length-xor-y (integer-length (logxor c d))))
    (values
     (let* ((mask (zeroes (max length-xor-x length-xor-y)))
            (index (integer-length (logior mask a c))))
       (logand a c (zeroes (1- index))))
     (let* ((mask-x (ones length-xor-x))
            (mask-y (ones length-xor-y))
            (index-x (integer-length (logand mask-x b (lognot d))))
            (index-y (integer-length (logand mask-y d (lognot b)))))
       (cond ((= index-x index-y)
              ;; Both indexes are 0 here.
              (logand b d))
             ((> index-x index-y)
              (logand (logior b (ones (1- index-x))) d))
             (t
              (logand (logior d (ones (1- index-y))) b)))))))

(defun logand-derive-type-aux (x y &optional same-leaf)
  (when same-leaf
    (return-from logand-derive-type-aux x))
  (flet ((minus-one (x y)
           (when (eql (nth-value 1 (type-singleton-p x))
                      -1)
             (return-from logand-derive-type-aux y))))
    (minus-one x y)
    (minus-one y x))
  (multiple-value-bind (x-len x-pos x-neg x-low x-high) (integer-type-length x)
    (multiple-value-bind (y-len y-pos y-neg y-low y-high) (integer-type-length y)
      (if (not x-neg)
          ;; X must be positive.
          (if (not y-neg)
              ;; They must both be positive.
              (cond ((and (null x-len) (null y-len))
                     (specifier-type 'unsigned-byte))
                    ((null x-len)
                     (make-numeric-type 'unsigned-byte y-len))
                    ((null y-len)
                     (make-numeric-type 'unsigned-byte x-len))
                    (t
                     (multiple-value-bind (low high)
                         (logand-derive-unsigned-bounds x y)
                       (make-numeric-type 'integer low high))))
              ;; X is positive, but Y might be negative.
              (cond ((and x-len y-low y-high (< y-high 0))
                     (multiple-value-bind (low high)
                         (let ((len (max x-len y-len)))
                           (logand-derive-unsigned-bounds x
                                                          (make-numeric-type 'integer
                                                                             (ldb (byte len 0) y-low)
                                                                             (ldb (byte len 0) y-high))))
                       (make-numeric-type 'integer low high)))
                    (x-high
                     (make-numeric-type 'integer 0 x-high))
                    (t
                     (specifier-type 'unsigned-byte))))
          ;; X might be negative.
          (if (not y-neg)
              ;; Y must be positive.
              (cond ((and y-len x-low x-high (< x-high 0))
                     (multiple-value-bind (low high)
                         (let ((len (max x-len y-len)))
                           (logand-derive-unsigned-bounds y (make-numeric-type 'integer
                                                                               (ldb (byte len 0) x-low)
                                                                               (ldb (byte len 0) x-high))))
                       (make-numeric-type 'integer low high)))
                    (y-high
                     (make-numeric-type 'integer 0 y-high))
                    (t
                     (specifier-type 'unsigned-byte)))
              ;; Either might be negative.
              (cond ((and x-low y-low)
                     (make-numeric-type 'integer
                                        (zeroes (integer-length (min x-low y-low)))
                                        (and x-high y-high
                                             (max x-high y-high -1))))
                    ((and x-high y-high)
                     (make-numeric-type 'integer nil (max x-high y-high -1)))
                    (t
                     (if (and (not y-pos)
                              (not x-pos))
                         (specifier-type '(integer * -1))
                         (specifier-type 'integer)))))))))

(defun logior-derive-unsigned-bounds (x y)
  (let* ((a (max (or (numeric-type-low x) 0) 0))
         (b (numeric-type-high x))
         (c (max (or (numeric-type-low y) 0) 0))
         (d (numeric-type-high y))
         (length-xor-x (integer-length (logxor a b)))
         (length-xor-y (integer-length (logxor c d))))
    (values
     (let* ((mask-x (ones length-xor-x))
            (mask-y (ones length-xor-y))
            (index-x (integer-length (logand mask-x (lognot a) c)))
            (index-y (integer-length (logand mask-y (lognot c) a))))
       (cond ((= index-x index-y)
              ;; Both indexes are 0 here.
              (logior a c))
             ((> index-x index-y)
              (logior (logand a (zeroes (1- index-x))) c))
             (t
              (logior (logand c (zeroes (1- index-y))) a))))
     (let* ((mask (ones (max length-xor-x length-xor-y)))
            (index (integer-length (logand mask b d))))
       (logior b d (ones (1- index)))))))

(defun logior-derive-type-aux (x y &optional same-leaf)
  (when same-leaf
    (return-from logior-derive-type-aux x))
  (multiple-value-bind (x-len x-pos x-neg x-low x-high) (integer-type-length x)
    (multiple-value-bind (y-len y-pos y-neg y-low y-high) (integer-type-length y)
      (cond
       ((and (not x-neg) (not y-neg))
        ;; Both are positive.
        (cond ((and x-len y-len)
               (multiple-value-bind (low high)
                   (logior-derive-unsigned-bounds x y)
                 (make-numeric-type 'integer low high)))
              (t
               (make-numeric-type 'integer (max y-low x-low)))))
       ((not x-pos)
        ;; X must be negative.
        (if (not y-pos)
            ;; Both are negative. The result is going to be negative
            ;; and be the same length or shorter than the smaller.
            (if (and x-len y-len)
                ;; It's bounded.
                (make-numeric-type 'integer (ash -1 (min x-len y-len)) -1)
                ;; It's unbounded.
                (specifier-type '(integer * -1)))
            ;; X is negative, but we don't know about Y. The result
            ;; will be negative, but no more negative than X.
            (make-numeric-type 'integer x-low -1)))
       (t
        ;; X might be either positive or negative.
        (flet ((add-one (a-low b-low b-high)
                 ;; Add one to a negative low power of two bound if
                 ;; there are some bits set in the second parameter.
                 (if (or (>= a-low 0)
                         (not b-high)
                         (<= b-low 0 b-high))
                     a-low
                     (let* ((length (integer-length a-low))
                            (expt (expt 2 length)))
                       (if (and (= a-low (- expt))
                                (> b-low a-low)
                                (< b-high (1- expt)))
                           (if (= b-low b-high)
                               (logior a-low b-low)
                               (1+ a-low))
                           a-low)))))
          (cond ((not y-pos)
                 ;; But Y is negative. The result will be negative.
                 (make-numeric-type 'integer y-low -1))
                ((and y-low
                      (> y-low 0))
                 (type-union (make-numeric-type 'integer (and x-low
                                                              (add-one x-low y-low y-high))
                                                -1)
                             (if (and x-high
                                      y-len)
                                 (multiple-value-bind (low high)
                                     (logior-derive-unsigned-bounds (make-numeric-type 'integer 0 x-high)
                                                                    y)
                                   (make-numeric-type 'integer low high))
                                 (make-numeric-type 'integer y-low))))
                ((and x-low
                      (> x-low 0))
                 (type-union (make-numeric-type 'integer (and y-low
                                                              (add-one y-low x-low x-high))
                                                -1)
                             (if (and y-high
                                      x-len)
                                 (multiple-value-bind (low high)
                                     (logior-derive-unsigned-bounds (make-numeric-type 'integer 0 y-high)
                                                                    x)
                                   (make-numeric-type 'integer low high))
                                 (make-numeric-type 'integer x-low))))
                (t
                 (cond ((and x-len y-len)
                        (make-numeric-type 'integer
                                           (min x-low y-low)
                                           (nth-value 1 (logior-derive-unsigned-bounds x y))))
                       ((and x-high y-high)
                        (make-numeric-type 'integer
                                           nil
                                           (nth-value 1 (logior-derive-unsigned-bounds x y))))
                       (t
                        (specifier-type 'integer)))))))))))

(defun logxor-derive-unsigned-bounds (x y)
  (let* ((a (numeric-type-low x))
         (b (numeric-type-high x))
         (c (numeric-type-low y))
         (d (numeric-type-high y))
         (not-b (lognot b))
         (not-d (lognot d))
         (length-xor-x (integer-length (logxor a b)))
         (length-xor-y (integer-length (logxor c d)))
         (mask (zeroes (max length-xor-x length-xor-y))))
    (values
     (let ((index-ad (integer-length (logior mask a not-d)))
           (index-bc (integer-length (logior mask not-b c))))
       (logior (logand a not-d (zeroes (1- index-ad)))
               (logand not-b c (zeroes (1- index-bc)))))
     (let ((index-ac (integer-length (logior mask a c)))
           (index-bd (integer-length (logior mask not-b not-d))))
       (lognor (logand a c (zeroes (1- index-ac)))
               (logand not-b not-d (zeroes (1- index-bd))))))))

(defun logxor-derive-type-aux (x y &optional same-leaf)
  (when same-leaf
    (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
  (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
    (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
      (cond
        ((and (not x-neg) (not y-neg))
         ;; Both are positive
         (if (and x-len y-len)
             (multiple-value-bind (low high)
                 (logxor-derive-unsigned-bounds x y)
               (make-numeric-type 'integer low high))
             (specifier-type 'unsigned-byte)))
        ((and (not x-pos) (not y-pos))
         ;; Both are negative.  The result will be positive, and as long
         ;; as the longer.
         (make-numeric-type 'unsigned-byte (and x-len y-len
                                                (max x-len y-len))))
        ((or (and (not x-pos) (not y-neg))
             (and (not y-pos) (not x-neg)))
         ;; Either X is negative and Y is positive or vice-versa. The
         ;; result will be negative.
         (make-numeric-type 'integer (and x-len y-len
                                          (ash -1 (max x-len y-len)))
                            -1))
        ;; We can't tell what the sign of the result is going to be.
        ;; All we know is that we don't create new bits.
        ((and x-len y-len)
         (make-numeric-type 'signed-byte (1+ (max x-len y-len))))
        (t
         (specifier-type 'integer))))))

(defoptimizer (logxor derive-type) ((x y))
  (let ((type (two-arg-derive-type x y #'logxor-derive-type-aux)))
    (flet ((try (x y)
             ;; If it's (logxor x (1- x)) then it will be a positive number,
             ;; except for 0 => -1. This is used to count unset bits.
             (or (multiple-value-bind (name combination args)
                     (combination-matches* '(-) '(* 1) (lvar-uses y) :cast-type (specifier-type 'integer))
                   (declare (ignore name))
                   (when combination
                     (when (same-leaf-ref-p x (car args))
                       (let ((r (if (types-equal-or-intersect (lvar-type x) (specifier-type '(eql 0)))
                                    (specifier-type '(integer -1))
                                    (specifier-type '(integer 1)))))
                         (if type
                             (type-intersection type r)
                             r)))))
                 ;; (logxor x (1+ x)) is positive, except -1 => -1.
                 (multiple-value-bind (name combination args)
                     (combination-matches* '(+) '(* 1) (lvar-uses y) :cast-type (specifier-type 'integer))
                   (declare (ignore name))
                   (when combination
                     (when (same-leaf-ref-p x (car args))
                       (let ((r (if (types-equal-or-intersect (lvar-type x) (specifier-type '(eql -1)))
                                    (specifier-type '(integer -1))
                                    (specifier-type '(integer 1)))))
                         (if type
                             (type-intersection type r)
                             r)))))
                 ;; (logxor x (- x)) is <= 0
                 (combination-case (x :cast (specifier-type 'integer))
                   (%negate (*)
                    (when (same-leaf-ref-p (car args) y)
                      (multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
                        (declare (ignore pos neg))
                        (let ((int (if len
                                       (make-numeric-type 'integer
                                                          (ash -1 (integer-length (max (abs low) (abs high))))
                                                          (if (<= low 0 high)
                                                              0
                                                              -2))
                                       (if (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0)))
                                           (specifier-type '(integer * 0))
                                           (specifier-type '(integer * -2))))))
                          (if type
                              (type-intersection type int)
                              int)))))))))
      (or (try x y)
          (try y x)
          type))))

(defoptimizer (logior derive-type) ((x y))
  (let ((type (two-arg-derive-type x y #'logior-derive-type-aux)))
    (flet ((try (x y)
             ;; (logior x (- x)) has the same width as X and is <= 0
             (combination-case (x :cast (specifier-type 'integer))
               (%negate (*)
                (when (same-leaf-ref-p (car args) y)
                  (multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
                    (declare (ignore pos neg))
                    (let ((int (if len
                                   (make-numeric-type 'integer
                                                      (let ((positive (if (plusp high)
                                                                          (1- (integer-length high))
                                                                          0))
                                                            (negative (if (minusp low)
                                                                          (if (= low (- (ash 1 len)))
                                                                              len
                                                                              (1- len))
                                                                          0)))
                                                        (- (ash 1 (max positive negative))))
                                                      0)
                                   (specifier-type '(integer * 0)))))
                      (if type
                          (type-intersection type int)
                          int))))))))
      (or (try x y)
          (try y x)
          type))))

(defoptimizer (logand derive-type) ((x y))
  (let ((type (two-arg-derive-type x y #'logand-derive-type-aux)))
    (flet ((try (x y)
             ;; (logand x (- x)) has the same width as (abs most-negative-X) and is >= 0
             (combination-case (x :cast (specifier-type 'integer))
               (%negate (*)
                (when (same-leaf-ref-p (car args) y)
                  (multiple-value-bind (len pos neg low high) (integer-type-length (lvar-type y))
                    (declare (ignore pos neg))
                    (let ((int (if len
                                   (make-numeric-type 'integer
                                                      (if (<= low 0 high)
                                                          0
                                                          1)
                                                      (let ((positive (if (plusp high)
                                                                          (1- (integer-length high))
                                                                          0))
                                                            (negative (if (minusp low)
                                                                          (if (= low (- (ash 1 len)))
                                                                              (1+ len)
                                                                              (1- len))
                                                                          0)))
                                                        (ash 1 (max positive negative))))
                                   (if (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0)))
                                       (specifier-type '(integer 0))
                                       (specifier-type '(integer 1))))))
                      (if type
                          (type-intersection type int)
                          int))))))))
      (or (try x y)
          (try y x)
          type))))

(defoptimizer (logeqv derive-type) ((x y))
  (two-arg-derive-type x y (lambda (x y same-leaf)
                             (lognot-derive-type-aux
                              (logxor-derive-type-aux x y same-leaf)))))
(defoptimizer (lognand derive-type) ((x y))
  (two-arg-derive-type x y (lambda (x y same-leaf)
                             (lognot-derive-type-aux
                              (logand-derive-type-aux x y same-leaf)))))
(defoptimizer (lognor derive-type) ((x y))
  (two-arg-derive-type x y (lambda (x y same-leaf)
                             (lognot-derive-type-aux
                              (logior-derive-type-aux x y same-leaf)))))
(defoptimizer (logandc1 derive-type) ((x y))
  (two-arg-derive-type x y (lambda (x y same-leaf)
                             (if same-leaf
                                 (specifier-type '(eql 0))
                                 (logand-derive-type-aux
                                  (lognot-derive-type-aux x) y)))))
(defoptimizer (logandc2 derive-type) ((x y))
  (two-arg-derive-type x y (lambda (x y same-leaf)
                             (if same-leaf
                                 (specifier-type '(eql 0))
                                 (logand-derive-type-aux
                                  x (lognot-derive-type-aux y))))))
(defoptimizer (logorc1 derive-type) ((x y))
  (two-arg-derive-type x y (lambda (x y same-leaf)
                             (if same-leaf
                                 (specifier-type '(eql -1))
                                 (logior-derive-type-aux
                                  (lognot-derive-type-aux x) y)))))
(defoptimizer (logorc2 derive-type) ((x y))
  (two-arg-derive-type x y (lambda (x y same-leaf)
                             (if same-leaf
                                 (specifier-type '(eql -1))
                                 (logior-derive-type-aux
                                  x (lognot-derive-type-aux y))))))
