1 ;;;; This file contains DERIVE-TYPE methods for LOGAND, LOGIOR, and
4 ;;;; This software is part of the SBCL system. See the README file for
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.
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
))))
28 ;;;; Generators for simple bit masks
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
))
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
))
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.
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.
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.
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.
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.
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
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)).
104 ;;; For the high bound on LOGXOR Warren's formula seems unnecessarily
105 ;;; complex. Instead, with (LOGNOT (LOGXOR X Y)) = (LOGXOR X (LOGNOT Y))
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.
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
))))
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.
134 (logand (logior b
(ones (1- index-x
))) d
))
136 (logand (logior d
(ones (1- index-y
))) b
)))))))
138 (defun logand-derive-type-aux (x y
&optional 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
))
146 ;; X must be positive.
148 ;; They must both be positive.
149 (cond ((and (null x-len
) (null y-len
))
150 (specifier-type 'unsigned-byte
))
152 (specifier-type `(unsigned-byte* ,y-len
)))
154 (specifier-type `(unsigned-byte* ,x-len
)))
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.
161 (specifier-type 'unsigned-byte
))
163 (specifier-type `(unsigned-byte* ,x-len
)))))
164 ;; X might be negative.
166 ;; Y must be positive.
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
)))))))
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
))))
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.
193 (logior (logand a
(zeroes (1- index-x
))) c
))
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
)))))))
200 (defun logior-derive-type-aux (x y
&optional 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
)
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* *))))
214 ;; X must be negative.
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
)
220 (specifier-type `(integer ,(ash -
1 (min x-len y-len
)) -
1))
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.
226 `(integer ,(or (numeric-type-low x
) '*)
229 ;; X might be either positive or negative.
231 ;; But Y is negative. The result will be negative.
233 `(integer ,(or (numeric-type-low y
) '*)
235 ;; We don't know squat about either. It won't get any bigger.
236 (if (and x-len y-len
)
238 (specifier-type `(signed-byte ,(1+ (max x-len y-len
))))
240 (specifier-type 'integer
))))))))
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
))
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
))))
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
))))))))
262 (defun logxor-derive-type-aux (x y
&optional 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
)
268 ((and (not x-neg
) (not y-neg
))
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
278 (specifier-type `(unsigned-byte* ,(if (and x-len y-len
)
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
))
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.
292 (specifier-type `(signed-byte ,(1+ (max x-len y-len
)))))
294 (specifier-type 'integer
))))))
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
)))))
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
)))
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
)))
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
)))
319 (defoptimizer (logandc1 derive-type
) ((x y
))
320 (two-arg-derive-type x y
(lambda (x y same-leaf
)
322 (specifier-type '(eql 0))
323 (logand-derive-type-aux
324 (lognot-derive-type-aux x
) y nil
)))
326 (defoptimizer (logandc2 derive-type
) ((x y
))
327 (two-arg-derive-type x y
(lambda (x y same-leaf
)
329 (specifier-type '(eql 0))
330 (logand-derive-type-aux
331 x
(lognot-derive-type-aux y
) nil
)))
333 (defoptimizer (logorc1 derive-type
) ((x y
))
334 (two-arg-derive-type x y
(lambda (x y same-leaf
)
336 (specifier-type '(eql -
1))
337 (logior-derive-type-aux
338 (lognot-derive-type-aux x
) y nil
)))
340 (defoptimizer (logorc2 derive-type
) ((x y
))
341 (two-arg-derive-type x y
(lambda (x y same-leaf
)
343 (specifier-type '(eql -
1))
344 (logior-derive-type-aux
345 x
(lognot-derive-type-aux y
) nil
)))