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 ;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an
  29 ;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND.
  30 ;;; Credit also goes to Raymond Toy for writing (and debugging!) similar
  31 ;;; versions in CMUCL, from which these functions copy liberally.
  32
  33 (defun logand-derive-unsigned-low-bound (x y)
  34   (let ((a (numeric-type-low x))
  35         (b (numeric-type-high x))
  36         (c (numeric-type-low y))
  37         (d (numeric-type-high y)))
  38     (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1)
  39           until (zerop m) do
  40           (unless (zerop (logand m (lognot a) (lognot c)))
  41             (let ((temp (logandc2 (logior a m) (1- m))))
  42               (when (<= temp b)
  43                 (setf a temp)
  44                 (loop-finish))
  45               (setf temp (logandc2 (logior c m) (1- m)))
  46               (when (<= temp d)
  47                 (setf c temp)
  48                 (loop-finish))))
  49           finally (return (logand a c)))))
  50
  51 (defun logand-derive-unsigned-high-bound (x y)
  52   (let ((a (numeric-type-low x))
  53         (b (numeric-type-high x))
  54         (c (numeric-type-low y))
  55         (d (numeric-type-high y)))
  56     (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1)
  57           until (zerop m) do
  58           (cond
  59             ((not (zerop (logand b (lognot d) m)))
  60              (let ((temp (logior (logandc2 b m) (1- m))))
  61                (when (>= temp a)
  62                  (setf b temp)
  63                  (loop-finish))))
  64             ((not (zerop (logand (lognot b) d m)))
  65              (let ((temp (logior (logandc2 d m) (1- m))))
  66                (when (>= temp c)
  67                  (setf d temp)
  68                  (loop-finish)))))
  69           finally (return (logand b d)))))
  70
  71 (defun logand-derive-type-aux (x y &optional same-leaf)
  72   (when same-leaf
  73     (return-from logand-derive-type-aux x))
  74   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
  75     (declare (ignore x-pos))
  76     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
  77       (declare (ignore y-pos))
  78       (if (not x-neg)
  79           ;; X must be positive.
  80           (if (not y-neg)
  81               ;; They must both be positive.
  82               (cond ((and (null x-len) (null y-len))
  83                      (specifier-type 'unsigned-byte))
  84                     ((null x-len)
  85                      (specifier-type `(unsigned-byte* ,y-len)))
  86                     ((null y-len)
  87                      (specifier-type `(unsigned-byte* ,x-len)))
  88                     (t
  89                      (let ((low (logand-derive-unsigned-low-bound x y))
  90                            (high (logand-derive-unsigned-high-bound x y)))
  91                        (specifier-type `(integer ,low ,high)))))
  92               ;; X is positive, but Y might be negative.
  93               (cond ((null x-len)
  94                      (specifier-type 'unsigned-byte))
  95                     (t
  96                      (specifier-type `(unsigned-byte* ,x-len)))))
  97           ;; X might be negative.
  98           (if (not y-neg)
  99               ;; Y must be positive.
 100               (cond ((null y-len)
 101                      (specifier-type 'unsigned-byte))
 102                     (t (specifier-type `(unsigned-byte* ,y-len))))
 103               ;; Either might be negative.
 104               (if (and x-len y-len)
 105                   ;; The result is bounded.
 106                   (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
 107                   ;; We can't tell squat about the result.
 108                   (specifier-type 'integer)))))))
 109
 110 (defun logior-derive-unsigned-low-bound (x y)
 111   (let ((a (numeric-type-low x))
 112         (b (numeric-type-high x))
 113         (c (numeric-type-low y))
 114         (d (numeric-type-high y)))
 115     (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
 116           until (zerop m) do
 117           (cond
 118             ((not (zerop (logandc2 (logand c m) a)))
 119              (let ((temp (logand (logior a m) (1+ (lognot m)))))
 120                (when (<= temp b)
 121                  (setf a temp)
 122                  (loop-finish))))
 123             ((not (zerop (logandc2 (logand a m) c)))
 124              (let ((temp (logand (logior c m) (1+ (lognot m)))))
 125                (when (<= temp d)
 126                  (setf c temp)
 127                  (loop-finish)))))
 128           finally (return (logior a c)))))
 129
 130 (defun logior-derive-unsigned-high-bound (x y)
 131   (let ((a (numeric-type-low x))
 132         (b (numeric-type-high x))
 133         (c (numeric-type-low y))
 134         (d (numeric-type-high y)))
 135     (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
 136           until (zerop m) do
 137           (unless (zerop (logand b d m))
 138             (let ((temp (logior (- b m) (1- m))))
 139               (when (>= temp a)
 140                 (setf b temp)
 141                 (loop-finish))
 142               (setf temp (logior (- d m) (1- m)))
 143               (when (>= temp c)
 144                 (setf d temp)
 145                 (loop-finish))))
 146           finally (return (logior b d)))))
 147
 148 (defun logior-derive-type-aux (x y &optional same-leaf)
 149   (when same-leaf
 150     (return-from logior-derive-type-aux x))
 151   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
 152     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
 153       (cond
 154        ((and (not x-neg) (not y-neg))
 155         ;; Both are positive.
 156         (if (and x-len y-len)
 157             (let ((low (logior-derive-unsigned-low-bound x y))
 158                   (high (logior-derive-unsigned-high-bound x y)))
 159               (specifier-type `(integer ,low ,high)))
 160             (specifier-type `(unsigned-byte* *))))
 161        ((not x-pos)
 162         ;; X must be negative.
 163         (if (not y-pos)
 164             ;; Both are negative. The result is going to be negative
 165             ;; and be the same length or shorter than the smaller.
 166             (if (and x-len y-len)
 167                 ;; It's bounded.
 168                 (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
 169                 ;; It's unbounded.
 170                 (specifier-type '(integer * -1)))
 171             ;; X is negative, but we don't know about Y. The result
 172             ;; will be negative, but no more negative than X.
 173             (specifier-type
 174              `(integer ,(or (numeric-type-low x) '*)
 175                        -1))))
 176        (t
 177         ;; X might be either positive or negative.
 178         (if (not y-pos)
 179             ;; But Y is negative. The result will be negative.
 180             (specifier-type
 181              `(integer ,(or (numeric-type-low y) '*)
 182                        -1))
 183             ;; We don't know squat about either. It won't get any bigger.
 184             (if (and x-len y-len)
 185                 ;; Bounded.
 186                 (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
 187                 ;; Unbounded.
 188                 (specifier-type 'integer))))))))
 189
 190 (defun logxor-derive-unsigned-low-bound (x y)
 191   (let ((a (numeric-type-low x))
 192         (b (numeric-type-high x))
 193         (c (numeric-type-low y))
 194         (d (numeric-type-high y)))
 195     (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
 196           until (zerop m) do
 197           (cond
 198             ((not (zerop (logandc2 (logand c m) a)))
 199              (let ((temp (logand (logior a m)
 200                                  (1+ (lognot m)))))
 201                (when (<= temp b)
 202                  (setf a temp))))
 203             ((not (zerop (logandc2 (logand a m) c)))
 204              (let ((temp (logand (logior c m)
 205                                  (1+ (lognot m)))))
 206                (when (<= temp d)
 207                  (setf c temp)))))
 208           finally (return (logxor a c)))))
 209
 210 (defun logxor-derive-unsigned-high-bound (x y)
 211   (let ((a (numeric-type-low x))
 212         (b (numeric-type-high x))
 213         (c (numeric-type-low y))
 214         (d (numeric-type-high y)))
 215     (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
 216           until (zerop m) do
 217           (unless (zerop (logand b d m))
 218             (let ((temp (logior (- b m) (1- m))))
 219               (cond
 220                 ((>= temp a) (setf b temp))
 221                 (t (let ((temp (logior (- d m) (1- m))))
 222                      (when (>= temp c)
 223                        (setf d temp)))))))
 224           finally (return (logxor b d)))))
 225
 226 (defun logxor-derive-type-aux (x y &optional same-leaf)
 227   (when same-leaf
 228     (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
 229   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
 230     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
 231       (cond
 232         ((and (not x-neg) (not y-neg))
 233          ;; Both are positive
 234          (if (and x-len y-len)
 235              (let ((low (logxor-derive-unsigned-low-bound x y))
 236                    (high (logxor-derive-unsigned-high-bound x y)))
 237                (specifier-type `(integer ,low ,high)))
 238              (specifier-type '(unsigned-byte* *))))
 239         ((and (not x-pos) (not y-pos))
 240          ;; Both are negative.  The result will be positive, and as long
 241          ;; as the longer.
 242          (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
 243                                                (max x-len y-len)
 244                                                '*))))
 245         ((or (and (not x-pos) (not y-neg))
 246              (and (not y-pos) (not x-neg)))
 247          ;; Either X is negative and Y is positive or vice-versa. The
 248          ;; result will be negative.
 249          (specifier-type `(integer ,(if (and x-len y-len)
 250                                         (ash -1 (max x-len y-len))
 251                                         '*)
 252                            -1)))
 253         ;; We can't tell what the sign of the result is going to be.
 254         ;; All we know is that we don't create new bits.
 255         ((and x-len y-len)
 256          (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
 257         (t
 258          (specifier-type 'integer))))))
 259
 260 (macrolet ((deffrob (logfun)
 261              (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
 262              `(defoptimizer (,logfun derive-type) ((x y))
 263                 (two-arg-derive-type x y #',fun-aux #',logfun)))))
 264   (deffrob logand)
 265   (deffrob logior)
 266   (deffrob logxor))
 267
 268 (defoptimizer (logeqv derive-type) ((x y))
 269   (two-arg-derive-type x y (lambda (x y same-leaf)
 270                              (lognot-derive-type-aux
 271                               (logxor-derive-type-aux x y same-leaf)))
 272                        #'logeqv))
 273 (defoptimizer (lognand derive-type) ((x y))
 274   (two-arg-derive-type x y (lambda (x y same-leaf)
 275                              (lognot-derive-type-aux
 276                               (logand-derive-type-aux x y same-leaf)))
 277                        #'lognand))
 278 (defoptimizer (lognor derive-type) ((x y))
 279   (two-arg-derive-type x y (lambda (x y same-leaf)
 280                              (lognot-derive-type-aux
 281                               (logior-derive-type-aux x y same-leaf)))
 282                        #'lognor))
 283 (defoptimizer (logandc1 derive-type) ((x y))
 284   (two-arg-derive-type x y (lambda (x y same-leaf)
 285                              (if same-leaf
 286                                  (specifier-type '(eql 0))
 287                                  (logand-derive-type-aux
 288                                   (lognot-derive-type-aux x) y nil)))
 289                        #'logandc1))
 290 (defoptimizer (logandc2 derive-type) ((x y))
 291   (two-arg-derive-type x y (lambda (x y same-leaf)
 292                              (if same-leaf
 293                                  (specifier-type '(eql 0))
 294                                  (logand-derive-type-aux
 295                                   x (lognot-derive-type-aux y) nil)))
 296                        #'logandc2))
 297 (defoptimizer (logorc1 derive-type) ((x y))
 298   (two-arg-derive-type x y (lambda (x y same-leaf)
 299                              (if same-leaf
 300                                  (specifier-type '(eql -1))
 301                                  (logior-derive-type-aux
 302                                   (lognot-derive-type-aux x) y nil)))
 303                        #'logorc1))
 304 (defoptimizer (logorc2 derive-type) ((x y))
 305   (two-arg-derive-type x y (lambda (x y same-leaf)
 306                              (if same-leaf
 307                                  (specifier-type '(eql -1))
 308                                  (logior-derive-type-aux
 309                                   x (lognot-derive-type-aux y) nil)))
 310                        #'logorc2))