src/compiler/bitops-derive-type.lisp

   1 ;;;; This file contains DERIVE-TYPE methods for LOGAND, LOGIOR, and
   2 ;;;; friends.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!C")
  14
  15 ;;; Return the maximum number of bits an integer of the supplied type
  16 ;;; can take up, or NIL if it is unbounded. The second (third) value
  17 ;;; is T if the integer can be positive (negative) and NIL if not.
  18 ;;; Zero counts as positive.
  19 (defun integer-type-length (type)
  20   (if (numeric-type-p type)
  21       (let ((min (numeric-type-low type))
  22             (max (numeric-type-high type)))
  23         (values (and min max (max (integer-length min) (integer-length max)))
  24                 (or (null max) (not (minusp max)))
  25                 (or (null min) (minusp min))))
  26       (values nil t t)))
  27
  28 ;;;; Generators for simple bit masks
  29
  30 ;;; Return an integer consisting of zeroes in its N least significant
  31 ;;; bit positions and ones in all others. If N is negative, return -1.
  32 (declaim (inline zeroes))
  33 (defun zeroes (n)
  34   (ash -1 n))
  35
  36 ;;; Return an integer consisting of ones in its N least significant
  37 ;;; bit positions and zeroes in all others. If N is negative, return 0.
  38 (declaim (inline ones))
  39 (defun ones (n)
  40   (lognot (ash -1 n)))
  41
  42 ;;; The functions LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-BOUNDS below use
  43 ;;; algorithms derived from those in the chapter "Propagating Bounds
  44 ;;; through Logical Operations" from _Hacker's Delight_, Henry S.
  45 ;;; Warren, Jr., 2nd ed., pp 87-90.
  46 ;;;
  47 ;;; We used to implement the algorithms from that source (then its first
  48 ;;; edition) very faithfully here which exposed a weakness of theirs,
  49 ;;; namely worst case quadratical runtime in the number of bits of the
  50 ;;; input values, potentially leading to excessive compilation times for
  51 ;;; expressions involving bignums. To avoid that, I have devised and
  52 ;;; implemented variations of these algorithms that achieve linear
  53 ;;; runtime in all cases.
  54 ;;;
  55 ;;; Like Warren, let's start with the high bound on LOGIOR to explain
  56 ;;; how this is done. To follow, please read Warren's explanations on
  57 ;;; his "maxOR" function and compare this with how the second return
  58 ;;; value of LOGIOR-DERIVE-UNSIGNED-BOUNDS below is calculated.
  59 ;;;
  60 ;;; "maxOR" loops starting from the left until it finds a position where
  61 ;;; both B and D are 1 and where it is possible to decrease one of these
  62 ;;; bounds by setting this bit in it to 0 and all following ones to 1
  63 ;;; without the resulting value getting below the corresponding lower
  64 ;;; bound (A or C). This is done by calculating the modified values
  65 ;;; during each iteration where both B and D are 1 and comparing them
  66 ;;; against the lower bounds.
  67 ;;; The trick to avoid the loop is to exchange the order of the steps:
  68 ;;; First determine from which position rightwards it would be allowed
  69 ;;; to change B or D in this way and have the result be larger or equal
  70 ;;; than A or C respectively and then find the leftmost position equal
  71 ;;; to this or to the right of it where both B and D are 1.
  72 ;;; It is quite simple to find from where rightwards B could be modified
  73 ;;; this way: This is the leftmost position where B has a 1 and A a 0,
  74 ;;; or, cheaper to calculate, the leftmost position where A and B
  75 ;;; differ. Thus (INTEGER-LENGTH (LOGXOR A B)) gives us this position
  76 ;;; where a result of 1 corresponds to the rightmost bit position. As we
  77 ;;; don't care which of B or D we modify we can take the maximum of this
  78 ;;; value and of (INTEGER-LENGTH (LOGXOR C D)).
  79 ;;; The rest is equally simple: Build a mask of 1 bits from the thusly
  80 ;;; found position rightwards, LOGAND it with B and D and feed that into
  81 ;;; INTEGER-LENGTH. From this build another mask and LOGIOR it with B
  82 ;;; and D to set the desired bits.
  83 ;;; The special cases where A equals B and/or C equals D are covered by
  84 ;;; the same code provided the mask generator treats an argument of -1
  85 ;;; the same as 0, which both ZEROES and ONES do.
  86 ;;;
  87 ;;; To calculate the low bound on LOGIOR we need to treat X and Y
  88 ;;; independently for longer but the basic idea stays the same.
  89 ;;;
  90 ;;; LOGAND-DERIVE-UNSIGNED-BOUNDS can be derived by sufficiently many
  91 ;;; applications of DeMorgan's law from LOGIOR-DERIVE-UNSIGNED-BOUNDS.
  92 ;;; The implementation additionally avoids work (that is, calculations
  93 ;;; of one's complements) by using the identity (INTEGER-LENGTH X) =
  94 ;;; (INTEGER-LENGTH (LOGNOT X)) and observing that ZEROES is cheaper
  95 ;;; than ONES.
  96 ;;;
  97 ;;; For the low bound on LOGXOR we use Warren's formula
  98 ;;;   minXOR(a, b, c, d) = minAND(a, b, !d, !c) | minAND(!b, !a, c, d)
  99 ;;; where "!" is bitwise negation and "|" is bitwise or. Both minANDs
 100 ;;; are implemented as in LOGAND-DERIVE-UNSIGNED-BOUNDS (the part for
 101 ;;; the first result), sharing the first LOGXOR and INTEGER-LENGTH
 102 ;;; calculations as (LOGXOR A B) = (LOGXOR (LOGNOT B) (LOGNOT A)).
 103 ;;;
 104 ;;; For the high bound on LOGXOR Warren's formula seems unnecessarily
 105 ;;; complex. Instead, with (LOGNOT (LOGXOR X Y)) = (LOGXOR X (LOGNOT Y))
 106 ;;; we have
 107 ;;;   maxXOR(a, b, c, d) = !minXOR(a, b, !d, !c)
 108 ;;; and rewriting minXOR as above yields
 109 ;;;   maxXOR(a, b, c, d) = !(minAND(a, b, c, d) | minAND(!b, !a, !d, !c))
 110 ;;; This again shares the first LOGXOR and INTEGER-LENGTH calculations
 111 ;;; between both minANDs and with the ones for the low bound.
 112 ;;;
 113 ;;; LEU, 2013-04-29.
 114
 115 (defun logand-derive-unsigned-bounds (x y)
 116   (let* ((a (numeric-type-low x))
 117          (b (numeric-type-high x))
 118          (c (numeric-type-low y))
 119          (d (numeric-type-high y))
 120          (length-xor-x (integer-length (logxor a b)))
 121          (length-xor-y (integer-length (logxor c d))))
 122     (values
 123      (let* ((mask (zeroes (max length-xor-x length-xor-y)))
 124             (index (integer-length (logior mask a c))))
 125        (logand a c (zeroes (1- index))))
 126      (let* ((mask-x (ones length-xor-x))
 127             (mask-y (ones length-xor-y))
 128             (index-x (integer-length (logand mask-x b (lognot d))))
 129             (index-y (integer-length (logand mask-y d (lognot b)))))
 130        (cond ((= index-x index-y)
 131               ;; Both indexes are 0 here.
 132               (logand b d))
 133              ((> index-x index-y)
 134               (logand (logior b (ones (1- index-x))) d))
 135              (t
 136               (logand (logior d (ones (1- index-y))) b)))))))
 137
 138 (defun logand-derive-type-aux (x y &optional same-leaf)
 139   (when same-leaf
 140     (return-from logand-derive-type-aux x))
 141   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
 142     (declare (ignore x-pos))
 143     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
 144       (declare (ignore y-pos))
 145       (if (not x-neg)
 146           ;; X must be positive.
 147           (if (not y-neg)
 148               ;; They must both be positive.
 149               (cond ((and (null x-len) (null y-len))
 150                      (specifier-type 'unsigned-byte))
 151                     ((null x-len)
 152                      (specifier-type `(unsigned-byte* ,y-len)))
 153                     ((null y-len)
 154                      (specifier-type `(unsigned-byte* ,x-len)))
 155                     (t
 156                      (multiple-value-bind (low high)
 157                          (logand-derive-unsigned-bounds x y)
 158                        (specifier-type `(integer ,low ,high)))))
 159               ;; X is positive, but Y might be negative.
 160               (cond ((null x-len)
 161                      (specifier-type 'unsigned-byte))
 162                     (t
 163                      (specifier-type `(unsigned-byte* ,x-len)))))
 164           ;; X might be negative.
 165           (if (not y-neg)
 166               ;; Y must be positive.
 167               (cond ((null y-len)
 168                      (specifier-type 'unsigned-byte))
 169                     (t (specifier-type `(unsigned-byte* ,y-len))))
 170               ;; Either might be negative.
 171               (if (and x-len y-len)
 172                   ;; The result is bounded.
 173                   (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
 174                   ;; We can't tell squat about the result.
 175                   (specifier-type 'integer)))))))
 176
 177 (defun logior-derive-unsigned-bounds (x y)
 178   (let* ((a (numeric-type-low x))
 179          (b (numeric-type-high x))
 180          (c (numeric-type-low y))
 181          (d (numeric-type-high y))
 182          (length-xor-x (integer-length (logxor a b)))
 183          (length-xor-y (integer-length (logxor c d))))
 184     (values
 185      (let* ((mask-x (ones length-xor-x))
 186             (mask-y (ones length-xor-y))
 187             (index-x (integer-length (logand mask-x (lognot a) c)))
 188             (index-y (integer-length (logand mask-y (lognot c) a))))
 189        (cond ((= index-x index-y)
 190               ;; Both indexes are 0 here.
 191               (logior a c))
 192              ((> index-x index-y)
 193               (logior (logand a (zeroes (1- index-x))) c))
 194              (t
 195               (logior (logand c (zeroes (1- index-y))) a))))
 196      (let* ((mask (ones (max length-xor-x length-xor-y)))
 197             (index (integer-length (logand mask b d))))
 198        (logior b d (ones (1- index)))))))
 199
 200 (defun logior-derive-type-aux (x y &optional same-leaf)
 201   (when same-leaf
 202     (return-from logior-derive-type-aux x))
 203   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
 204     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
 205       (cond
 206        ((and (not x-neg) (not y-neg))
 207         ;; Both are positive.
 208         (if (and x-len y-len)
 209             (multiple-value-bind (low high)
 210                 (logior-derive-unsigned-bounds x y)
 211               (specifier-type `(integer ,low ,high)))
 212             (specifier-type `(unsigned-byte* *))))
 213        ((not x-pos)
 214         ;; X must be negative.
 215         (if (not y-pos)
 216             ;; Both are negative. The result is going to be negative
 217             ;; and be the same length or shorter than the smaller.
 218             (if (and x-len y-len)
 219                 ;; It's bounded.
 220                 (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
 221                 ;; It's unbounded.
 222                 (specifier-type '(integer * -1)))
 223             ;; X is negative, but we don't know about Y. The result
 224             ;; will be negative, but no more negative than X.
 225             (specifier-type
 226              `(integer ,(or (numeric-type-low x) '*)
 227                        -1))))
 228        (t
 229         ;; X might be either positive or negative.
 230         (if (not y-pos)
 231             ;; But Y is negative. The result will be negative.
 232             (specifier-type
 233              `(integer ,(or (numeric-type-low y) '*)
 234                        -1))
 235             ;; We don't know squat about either. It won't get any bigger.
 236             (if (and x-len y-len)
 237                 ;; Bounded.
 238                 (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
 239                 ;; Unbounded.
 240                 (specifier-type 'integer))))))))
 241
 242 (defun logxor-derive-unsigned-bounds (x y)
 243   (let* ((a (numeric-type-low x))
 244          (b (numeric-type-high x))
 245          (c (numeric-type-low y))
 246          (d (numeric-type-high y))
 247          (not-b (lognot b))
 248          (not-d (lognot d))
 249          (length-xor-x (integer-length (logxor a b)))
 250          (length-xor-y (integer-length (logxor c d)))
 251          (mask (zeroes (max length-xor-x length-xor-y))))
 252     (values
 253      (let ((index-ad (integer-length (logior mask a not-d)))
 254            (index-bc (integer-length (logior mask not-b c))))
 255        (logior (logand a not-d (zeroes (1- index-ad)))
 256                (logand not-b c (zeroes (1- index-bc)))))
 257      (let ((index-ac (integer-length (logior mask a c)))
 258            (index-bd (integer-length (logior mask not-b not-d))))
 259        (lognor (logand a c (zeroes (1- index-ac)))
 260                (logand not-b not-d (zeroes (1- index-bd))))))))
 261
 262 (defun logxor-derive-type-aux (x y &optional same-leaf)
 263   (when same-leaf
 264     (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
 265   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
 266     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
 267       (cond
 268         ((and (not x-neg) (not y-neg))
 269          ;; Both are positive
 270          (if (and x-len y-len)
 271              (multiple-value-bind (low high)
 272                  (logxor-derive-unsigned-bounds x y)
 273                (specifier-type `(integer ,low ,high)))
 274              (specifier-type '(unsigned-byte* *))))
 275         ((and (not x-pos) (not y-pos))
 276          ;; Both are negative.  The result will be positive, and as long
 277          ;; as the longer.
 278          (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
 279                                                (max x-len y-len)
 280                                                '*))))
 281         ((or (and (not x-pos) (not y-neg))
 282              (and (not y-pos) (not x-neg)))
 283          ;; Either X is negative and Y is positive or vice-versa. The
 284          ;; result will be negative.
 285          (specifier-type `(integer ,(if (and x-len y-len)
 286                                         (ash -1 (max x-len y-len))
 287                                         '*)
 288                            -1)))
 289         ;; We can't tell what the sign of the result is going to be.
 290         ;; All we know is that we don't create new bits.
 291         ((and x-len y-len)
 292          (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
 293         (t
 294          (specifier-type 'integer))))))
 295
 296 (macrolet ((deffrob (logfun)
 297              (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
 298              `(defoptimizer (,logfun derive-type) ((x y))
 299                 (two-arg-derive-type x y #',fun-aux #',logfun)))))
 300   (deffrob logand)
 301   (deffrob logior)
 302   (deffrob logxor))
 303
 304 (defoptimizer (logeqv derive-type) ((x y))
 305   (two-arg-derive-type x y (lambda (x y same-leaf)
 306                              (lognot-derive-type-aux
 307                               (logxor-derive-type-aux x y same-leaf)))
 308                        #'logeqv))
 309 (defoptimizer (lognand derive-type) ((x y))
 310   (two-arg-derive-type x y (lambda (x y same-leaf)
 311                              (lognot-derive-type-aux
 312                               (logand-derive-type-aux x y same-leaf)))
 313                        #'lognand))
 314 (defoptimizer (lognor derive-type) ((x y))
 315   (two-arg-derive-type x y (lambda (x y same-leaf)
 316                              (lognot-derive-type-aux
 317                               (logior-derive-type-aux x y same-leaf)))
 318                        #'lognor))
 319 (defoptimizer (logandc1 derive-type) ((x y))
 320   (two-arg-derive-type x y (lambda (x y same-leaf)
 321                              (if same-leaf
 322                                  (specifier-type '(eql 0))
 323                                  (logand-derive-type-aux
 324                                   (lognot-derive-type-aux x) y nil)))
 325                        #'logandc1))
 326 (defoptimizer (logandc2 derive-type) ((x y))
 327   (two-arg-derive-type x y (lambda (x y same-leaf)
 328                              (if same-leaf
 329                                  (specifier-type '(eql 0))
 330                                  (logand-derive-type-aux
 331                                   x (lognot-derive-type-aux y) nil)))
 332                        #'logandc2))
 333 (defoptimizer (logorc1 derive-type) ((x y))
 334   (two-arg-derive-type x y (lambda (x y same-leaf)
 335                              (if same-leaf
 336                                  (specifier-type '(eql -1))
 337                                  (logior-derive-type-aux
 338                                   (lognot-derive-type-aux x) y nil)))
 339                        #'logorc1))
 340 (defoptimizer (logorc2 derive-type) ((x y))
 341   (two-arg-derive-type x y (lambda (x y same-leaf)
 342                              (if same-leaf
 343                                  (specifier-type '(eql -1))
 344                                  (logior-derive-type-aux
 345                                   x (lognot-derive-type-aux y) nil)))
 346                        #'logorc2))