/[cmucl]/src/compiler/srctran.lisp
ViewVC logotype

Contents of /src/compiler/srctran.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.174 - (show annotations)
Wed Jan 12 00:41:34 2011 UTC (3 years, 3 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, HEAD
Changes since 1.173: +24 -1 lines
Transform (EQ foo NIL) to the equivalent (IF foo NIL T).  Optimization
suggested by Helmut Eller on cmucl-imp, 2011-01-08.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/srctran.lisp,v 1.174 2011/01/12 00:41:34 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains macro-like source transformations which convert
13 ;;; uses of certain functions into the canonical form desired within the
14 ;;; compiler. ### and other IR1 transforms and stuff. Some code adapted from
15 ;;; CLC, written by Wholey and Fahlman.
16 ;;;
17 ;;; Written by Rob MacLachlan
18 ;;;
19 ;;; Propagate-float-type extension by Raymond Toy.
20 ;;;
21 (in-package "C")
22 (intl:textdomain "cmucl")
23
24 #+conservative-float-type
25 (sys:register-lisp-feature :conservative-float-type)
26
27 ;;; Source transform for Not, Null -- Internal
28 ;;;
29 ;;; Convert into an IF so that IF optimizations will eliminate redundant
30 ;;; negations.
31 ;;;
32 (def-source-transform not (x) `(if ,x nil t))
33 (def-source-transform null (x) `(if ,x nil t))
34
35 ;;; Source transform for Endp -- Internal
36 ;;;
37 ;;; Endp is just NULL with a List assertion.
38 ;;;
39 (def-source-transform endp (x)
40 `(null (the (values &optional list &rest t) ,x)))
41
42 ;;; We turn Identity into Prog1 so that it is obvious that it just returns the
43 ;;; first value of its argument. Ditto for Values with one arg.
44 (def-source-transform identity (x) `(prog1 ,x))
45 (def-source-transform values (x) `(prog1 ,x))
46
47 ;;; CONSTANTLY source transform -- Internal
48 ;;;
49 ;;; Bind the values and make a closure that returns them.
50 ;;;
51 (def-source-transform constantly (value &rest values)
52 (let ((temps (loop repeat (1+ (length values))
53 collect (gensym)))
54 (dum (gensym)))
55 `(let ,(loop for temp in temps and
56 value in (list* value values)
57 collect `(,temp ,value))
58 #'(lambda (&rest ,dum)
59 (declare (ignore ,dum))
60 (values ,@temps)))))
61
62
63 ;;; COMPLEMENT IR1 transform -- Internal
64 ;;;
65 ;;; If the function has a known number of arguments, then return a lambda
66 ;;; with the appropriate fixed number of args. If the destination is a
67 ;;; FUNCALL, then do the &REST APPLY thing, and let MV optimization figure
68 ;;; things out.
69 ;;;
70 (deftransform complement ((fun) * * :node node :when :both)
71 "open code"
72 (multiple-value-bind (min max)
73 (function-type-nargs (continuation-type fun))
74 (cond
75 ((and min (eql min max))
76 (let ((dums (loop repeat min collect (gensym))))
77 `#'(lambda ,dums (not (funcall fun ,@dums)))))
78 ((let* ((cont (node-cont node))
79 (dest (continuation-dest cont)))
80 (and (combination-p dest)
81 (eq (combination-fun dest) cont)))
82 '#'(lambda (&rest args)
83 (not (apply fun args))))
84 (t
85 (give-up (intl:gettext "Function doesn't have fixed argument count."))))))
86
87
88 ;;;; List hackery:
89
90 ;;;
91 ;;; Translate CxxR into car/cdr combos.
92
93 (defun source-transform-cxr (form)
94 (if (or (byte-compiling) (/= (length form) 2))
95 (values nil t)
96 (let ((name (symbol-name (car form))))
97 (do ((i (- (length name) 2) (1- i))
98 (res (cadr form)
99 `(,(ecase (char name i)
100 (#\A 'car)
101 (#\D 'cdr))
102 ,res)))
103 ((zerop i) res)))))
104
105 (do ((i 2 (1+ i))
106 (b '(1 0) (cons i b)))
107 ((= i 5))
108 (dotimes (j (ash 1 i))
109 (setf (info function source-transform
110 (intern (format nil "C~{~:[A~;D~]~}R"
111 (mapcar #'(lambda (x) (logbitp x j)) b))))
112 #'source-transform-cxr)))
113
114 ;;;
115 ;;; Turn First..Fourth and Rest into the obvious synonym, assuming whatever is
116 ;;; right for them is right for us. Fifth..Tenth turn into Nth, which can be
117 ;;; expanded into a car/cdr later on if policy favors it.
118 (def-source-transform first (x) `(car ,x))
119 (def-source-transform rest (x) `(cdr ,x))
120 (def-source-transform second (x) `(cadr ,x))
121 (def-source-transform third (x) `(caddr ,x))
122 (def-source-transform fourth (x) `(cadddr ,x))
123 (def-source-transform fifth (x) `(nth 4 ,x))
124 (def-source-transform sixth (x) `(nth 5 ,x))
125 (def-source-transform seventh (x) `(nth 6 ,x))
126 (def-source-transform eighth (x) `(nth 7 ,x))
127 (def-source-transform ninth (x) `(nth 8 ,x))
128 (def-source-transform tenth (x) `(nth 9 ,x))
129
130
131 ;;;
132 ;;; Translate RPLACx to LET and SETF.
133 (def-source-transform rplaca (x y)
134 (once-only ((n-x x))
135 `(progn
136 (setf (car ,n-x) ,y)
137 ,n-x)))
138 ;;;
139 (def-source-transform rplacd (x y)
140 (once-only ((n-x x))
141 `(progn
142 (setf (cdr ,n-x) ,y)
143 ,n-x)))
144
145
146 (def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
147
148 (defvar *default-nthcdr-open-code-limit* 6)
149 (defvar *extreme-nthcdr-open-code-limit* 20)
150
151 (deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
152 "convert NTHCDR to CAxxR"
153 (unless (constant-continuation-p n) (give-up))
154 (let ((n (continuation-value n)))
155 (when (> n
156 (if (policy node (= speed 3) (= space 0))
157 *extreme-nthcdr-open-code-limit*
158 *default-nthcdr-open-code-limit*))
159 (give-up))
160
161 (labels ((frob (n)
162 (if (zerop n)
163 'l
164 `(cdr ,(frob (1- n))))))
165 (frob n))))
166
167
168 ;;;; ARITHMETIC and NUMEROLOGY.
169
170 (def-source-transform plusp (x) `(> ,x 0))
171 (def-source-transform minusp (x) `(< ,x 0))
172 (def-source-transform zerop (x) `(= ,x 0))
173
174 (def-source-transform 1+ (x) `(+ ,x 1))
175 (def-source-transform 1- (x) `(- ,x 1))
176
177 (def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
178 (def-source-transform evenp (x) `(zerop (logand ,x 1)))
179
180 ;;; Note that all the integer division functions are available for inline
181 ;;; expansion.
182
183 (macrolet ((frob (fun)
184 `(def-source-transform ,fun (x &optional (y nil y-p))
185 (declare (ignore y))
186 (if y-p
187 (values nil t)
188 `(,',fun ,x 1)))))
189 (frob truncate)
190 (frob round)
191 (frob floor)
192 (frob ceiling))
193
194 ;; Some of these source transforms are not needed when modular
195 ;; arithmetic is available. When modular arithmetic is available, the
196 ;; various backends need to define them there.
197 #-modular-arith
198 (progn
199 (def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
200 (def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
201 (def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
202 (def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
203 (def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
204 (def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
205 )
206
207 (def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
208 (def-source-transform byte (size position) `(cons ,size ,position))
209 (def-source-transform byte-size (spec) `(car ,spec))
210 (def-source-transform byte-position (spec) `(cdr ,spec))
211 (def-source-transform ldb-test (bytespec integer)
212 `(not (zerop (mask-field ,bytespec ,integer))))
213
214
215 ;;; With the ratio and complex accessors, we pick off the "identity" case, and
216 ;;; use a primitive to handle the cell access case.
217 ;;;
218 (def-source-transform numerator (num)
219 (once-only ((n-num `(the (values rational &rest t) ,num)))
220 `(if (ratiop ,n-num)
221 (%numerator ,n-num)
222 ,n-num)))
223 ;;;
224 (def-source-transform denominator (num)
225 (once-only ((n-num `(the (values rational &rest t) ,num)))
226 `(if (ratiop ,n-num)
227 (%denominator ,n-num)
228 1)))
229
230 (deftransform logbitp ((index integer)
231 (integer (or (signed-byte #.vm:word-bits)
232 (unsigned-byte #.vm:word-bits)))
233 (member nil t))
234 `(if (>= index #.vm:word-bits)
235 (minusp integer)
236 (not (zerop (logand integer (ash 1 index))))))
237
238 ;;;; Interval arithmetic for computing bounds
239 ;;;; (toy@rtp.ericsson.se)
240 ;;;;
241 ;;;; This is a set of routines for operating on intervals. It implements a
242 ;;;; simple interval arithmetic package. Although CMUCL has an interval type
243 ;;;; in numeric-type, we choose to use our own for two reasons:
244 ;;;;
245 ;;;; 1. This package is simpler than numeric-type
246 ;;;;
247 ;;;; 2. It makes debugging much easier because you can just strip out these
248 ;;;; routines and test them independently of CMUCL. (A big win!)
249 ;;;;
250 ;;;; One disadvantage is a probable increase in consing because we have to
251 ;;;; create these new interval structures even though numeric-type has
252 ;;;; everything we want to know. Reason 2 wins for now.
253
254
255 ;;; The basic interval type. It can handle open and closed intervals. A
256 ;;; bound is open if it is a list containing a number, just like Lisp says.
257 ;;; NIL means unbounded.
258 ;;;
259 (defstruct (interval
260 (:constructor %make-interval))
261 low high)
262
263 (defun make-interval (&key low high)
264 (labels ((normalize-bound (val)
265 (cond ((and (floatp val)
266 (float-infinity-p val))
267 ;; Handle infinities
268 nil)
269 ((or (numberp val)
270 (eq val nil))
271 ;; Handle any closed bounds
272 val)
273 ((listp val)
274 ;; We have an open bound. Normalize the numeric bound.
275 ;; If the normalized bound is still a number (not nil),
276 ;; keep the bound open. Otherwise, the bound is really
277 ;; unbounded, so drop the openness.
278 (let ((new-val (normalize-bound (first val))))
279 (when new-val
280 ;; Bound exists, so keep it open still
281 (list new-val))))
282 (t
283 (error (intl:gettext "Unknown bound type in make-interval!"))))))
284 (%make-interval :low (normalize-bound low)
285 :high (normalize-bound high))))
286
287 (declaim (inline bound-value set-bound))
288
289 ;;; Extract the numeric value of a bound. Return NIL, if X is NIL.
290 ;;;
291 (defun bound-value (x)
292 (if (consp x) (car x) x))
293
294 ;;; Given a number X, create a form suitable as a bound for an interval.
295 ;;; Make the bound open if OPEN-P is T. NIL remains NIL.
296 ;;;
297 (defun set-bound (x open-p)
298 (if (and x open-p) (list x) x))
299
300 ;;; Apply the function F to a bound X. If X is an open bound, then the result
301 ;;; will be open. IF X is NIL, the result is NIL.
302 ;;;
303 (defun bound-func (f x)
304 (and x
305 (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
306 ;; With these traps masked, we might get things like infinity or
307 ;; negative infinity returned. Check for this and return NIL to
308 ;; indicate unbounded.
309 ;;
310 ;; We also ignore any errors that funcall might cause and
311 ;; return NIL instead to indicate infinity.
312 (let ((y (ignore-errors (funcall f (bound-value x)))))
313 (if (and (floatp y)
314 (float-infinity-p y))
315 nil
316 (set-bound y (consp x)))))))
317
318 ;;; Apply a binary operator OP to two bounds X and Y. The result is NIL if
319 ;;; either is NIL. Otherwise bound is computed and the result is open if
320 ;;; either X or Y is open.
321 ;;;
322 (defmacro bound-binop (op x y)
323 `(and ,x ,y
324 (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
325 (set-bound (,op (bound-value ,x)
326 (bound-value ,y))
327 (or (consp ,x) (consp ,y))))))
328
329 ;;; NUMERIC-TYPE->INTERVAL
330 ;;;
331 ;;; Convert a numeric-type object to an interval object.
332 ;;;
333 (defun numeric-type->interval (x)
334 (declare (type numeric-type x))
335 (make-interval :low (numeric-type-low x)
336 :high (numeric-type-high x)))
337
338 (defun copy-interval-limit (limit)
339 (if (numberp limit)
340 limit
341 (copy-list limit)))
342
343 (defun copy-interval (x)
344 (declare (type interval x))
345 (make-interval :low (copy-interval-limit (interval-low x))
346 :high (copy-interval-limit (interval-high x))))
347
348 ;;; INTERVAL-SPLIT
349 ;;;
350 ;;; Given a point P contained in the interval X, split X into two interval at
351 ;;; the point P. If CLOSE-LOWER is T, then the left interval contains P. If
352 ;;; CLOSE-UPPER is T, the right interval contains P. You can specify both to
353 ;;; be T or NIL.
354 ;;;
355 (defun interval-split (p x &optional close-lower close-upper)
356 (declare (type number p)
357 (type interval x))
358 ;; Need to be careful if the lower limit is -0.0 and the split point is 0.
359 (let ((low (interval-low x)))
360 (cond ((and (zerop p)
361 (floatp (bound-value low))
362 (member (bound-value low) '(-0f0 -0d0)))
363 (list (make-interval :low (copy-interval-limit low)
364 :high (float -0d0 (bound-value low)))
365 (make-interval :low (if close-upper (list p) p)
366 :high (copy-interval-limit (interval-high x)))))
367 (t
368 (list (make-interval :low (copy-interval-limit (interval-low x))
369 :high (if close-lower p (list p)))
370 (make-interval :low (if close-upper (list p) p)
371 :high (copy-interval-limit (interval-high x))))))))
372
373 ;;; INTERVAL-CLOSURE
374 ;;;
375 ;;; Return the closure of the interval. That is, convert open bounds to
376 ;;; closed bounds.
377 ;;;
378 (defun interval-closure (x)
379 (declare (type interval x))
380 (make-interval :low (bound-value (interval-low x))
381 :high (bound-value (interval-high x))))
382
383 ;;; INTERVAL-RANGE-INFO
384 ;;;
385 ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
386 ;;; '-. Otherwise return NIL.
387 ;;;
388 (defun interval-range-info (x &optional (point 0))
389 (declare (type interval x))
390 (labels ((signed->= (x y)
391 ;; If one of the args is a float, we need to do a float
392 ;; comparison to get the correct value when testing for a
393 ;; signed-zero. That is, we want (>= -0.0 0) to be false.
394 (if (and (zerop x) (zerop y)
395 (or (floatp x) (floatp y)))
396 (>= (float-sign (float x)) (float-sign (float y)))
397 (>= x y))))
398 (let ((lo (interval-low x))
399 (hi (interval-high x)))
400 ;; FIXME! We get confused if X is the interval -0d0 to 0d0.
401 ;; Special case that. What else could we be missing?
402 (cond ((and (zerop point)
403 (numberp (bound-value lo))
404 (numberp (bound-value hi))
405 (floatp (bound-value lo))
406 (zerop (bound-value lo))
407 (= (bound-value lo) (bound-value hi)))
408 ;; At this point lo = hi = +/- 0.0.
409 (cond ((or (eql (bound-value lo) (bound-value hi))
410 (integerp (bound-value hi)))
411 ;; Both bounds are the same kind of signed 0. Or
412 ;; the high bound is an exact 0. The sign of the
413 ;; zero tells us the sign of the interval.
414 (if (= (float-sign (bound-value lo)) -1)
415 '-
416 '+))
417 (t
418 ;; They have different signs
419 nil)))
420 ((and lo (signed->= (bound-value lo) point))
421 '+)
422 ((and hi (signed->= point (bound-value hi)))
423 '-)
424 (t
425 nil)))))
426
427 ;;; INTERVAL-BOUNDED-P
428 ;;;
429 ;;; Test to see if the interval X is bounded. HOW determines the test, and
430 ;;; should be either ABOVE, BELOW, or BOTH.
431 ;;;
432 (defun interval-bounded-p (x how)
433 (declare (type interval x))
434 (ecase how
435 ('above
436 (interval-high x))
437 ('below
438 (interval-low x))
439 ('both
440 (and (interval-low x) (interval-high x)))))
441
442 ;;; Return the sign of the number, taking into account the sign of
443 ;;; signed-zeros. An integer 0 has a positive sign here.
444 (declaim (inline number-sign))
445 (defun number-sign (x)
446 (declare (real x))
447 (if (floatp x)
448 (float-sign x)
449 (if (minusp x) -1.0 1.0)))
450
451 ;;; Signed zero comparison functions. Use these functions if we need
452 ;;; to distinguish between signed zeroes. Thus -0.0 < 0.0, which not
453 ;;; true with normal Lisp comparison functions.
454
455 (defun signed-zero-= (x y)
456 (declare (real x y))
457 (and (= x y)
458 (= (number-sign x)
459 (number-sign y))))
460
461
462 (macrolet ((frob (name op1 op2)
463 `(defun ,name (x y)
464 (declare (real x y))
465 ;; Comparison (op1) is true, or the numbers are EQUAL
466 ;; so we need to compare the signs of the numbers
467 ;; appropriately.
468 (or (,op1 x y)
469 (and (= x y)
470 ;; Convert the numbers to long-floats so we
471 ;; don't get problems converting to
472 ;; shorter floats from longer.
473 (,op2 (number-sign x)
474 (number-sign y)))))))
475 (frob signed-zero-< < <)
476 (frob signed-zero-> > >)
477 (frob signed-zero-<= < <=)
478 (frob signed-zero->= > >=))
479
480 ;;; INTERVAL-CONTAINS-P
481 ;;;
482 ;;; See if the interval X contains the number P, taking into account that the
483 ;;; interval might not be closed.
484 ;;;
485 (defun interval-contains-p (p x)
486 (declare (type number p)
487 (type interval x))
488 ;; Does the interval X contain the number P? This would be a lot easier if
489 ;; all intervals were closed!
490 (let ((lo (interval-low x))
491 (hi (interval-high x)))
492 (cond ((and lo hi)
493 ;; The interval is bounded
494 (if (and (signed-zero-<= (bound-value lo) p)
495 (signed-zero-<= p (bound-value hi)))
496 ;; P is definitely in the closure of the interval.
497 ;; We just need to check the end points now.
498 (cond ((signed-zero-= p (bound-value lo))
499 (numberp lo))
500 ((signed-zero-= p (bound-value hi))
501 (numberp hi))
502 (t t))
503 nil))
504 (hi
505 ;; Interval with upper bound
506 (if (signed-zero-< p (bound-value hi))
507 t
508 (and (numberp hi) (signed-zero-= p hi))))
509 (lo
510 ;; Interval with lower bound
511 (if (signed-zero-> p (bound-value lo))
512 t
513 (and (numberp lo) (signed-zero-= p lo))))
514 (t
515 ;; Interval with no bounds
516 t))))
517
518 ;;; INTERVAL-INTERSECT-P
519 ;;;
520 ;;; Determine if two intervals X and Y intersect. Return T if so. If
521 ;;; CLOSED-INTERVALS-P is T, the treat the intervals as if they were closed.
522 ;;; Otherwise the intervals are treated as they are.
523 ;;;
524 ;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect because no
525 ;;; element in X is in Y. However, if CLOSED-INTERVALS-P is T, then they do
526 ;;; intersect because we use the closure of X = [0, 1] and Y = [1, 2] to
527 ;;; determine intersection.
528 ;;;
529 (defun interval-intersect-p (x y &optional closed-intervals-p)
530 (declare (type interval x y))
531 (multiple-value-bind (intersect diff)
532 (interval-intersection/difference (if closed-intervals-p
533 (interval-closure x)
534 x)
535 (if closed-intervals-p
536 (interval-closure y)
537 y))
538 (declare (ignore diff))
539 intersect))
540
541 ;;; Are the two intervals adjacent? That is, is there a number between the
542 ;;; two intervals that is not an element of either interval? If so, they are
543 ;;; not adjacent. For example [0, 1) and [1, 2] are adjacent but [0, 1) and
544 ;;; (1, 2] are not because 1 lies between both intervals.
545 ;;;
546 (defun interval-adjacent-p (x y)
547 (declare (type interval x y))
548 (flet ((adjacent (lo hi)
549 ;; Check to see if lo and hi are adjacent. If either is
550 ;; nil, they can't be adjacent.
551 (when (and lo hi (= (bound-value lo) (bound-value hi)))
552 ;; The bounds are equal. They are adjacent if one of them is
553 ;; closed (a number). If both are open (consp), then there is a
554 ;; number that lies between them.
555 (or (numberp lo) (numberp hi)))))
556 (or (adjacent (interval-low y) (interval-high x))
557 (adjacent (interval-low x) (interval-high y)))))
558
559 ;;; INTERVAL-INTERSECTION/DIFFERENCE
560 ;;;
561 ;;; Compute the intersection and difference between two intervals.
562 ;;; Two values are returned: the intersection and the difference.
563 ;;;
564 ;;; Let the two intervals be X and Y, and let I and D be the two values
565 ;;; returned by this function. Then I = X intersect Y. If I is NIL (the
566 ;;; empty set), then D is X union Y, represented as the list of X and Y. If I
567 ;;; is not the empty set, then D is (X union Y) - I, which is a list of two
568 ;;; intervals.
569 ;;;
570 ;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D = [-1,1)
571 ;;; union [3,5], which is returned as a list of two intervals.
572 ;;;
573 (defun interval-intersection/difference (x y)
574 (declare (type interval x y))
575 (let ((x-lo (interval-low x))
576 (x-hi (interval-high x))
577 (y-lo (interval-low y))
578 (y-hi (interval-high y)))
579 (labels
580 ((test-lower-bound (p int)
581 ;; Test if the low bound P is in the interval INT.
582 (if p
583 (if (interval-contains-p (bound-value p)
584 (interval-closure int))
585 (let ((lo (interval-low int))
586 (hi (interval-high int)))
587 ;; Check for endpoints
588 (cond ((and lo (= (bound-value p) (bound-value lo)))
589 (not (and (numberp p) (consp lo))))
590 ((and hi (= (bound-value p) (bound-value hi)))
591 (and (numberp p) (numberp hi)))
592 (t t))))
593 (not (interval-bounded-p int 'below))))
594 (test-upper-bound (p int)
595 ;; Test if the upper bound P is in the interval INT.
596 (if p
597 (if (interval-contains-p (bound-value p)
598 (interval-closure int))
599 (let ((lo (interval-low int))
600 (hi (interval-high int)))
601 ;; Check for endpoints
602 (cond ((and lo (= (bound-value p) (bound-value lo)))
603 (and (numberp p) (numberp lo)))
604 ((and hi (= (bound-value p) (bound-value hi)))
605 (not (and (numberp p) (consp hi))))
606 (t t))))
607 (not (interval-bounded-p int 'above))))
608 (opposite-bound (p)
609 ;; If P is an open bound, make it closed. If P is a closed bound,
610 ;; make it open.
611 (if (listp p)
612 (first p)
613 (list p))))
614 (let ((x-lo-in-y (test-lower-bound x-lo y))
615 (x-hi-in-y (test-upper-bound x-hi y))
616 (y-lo-in-x (test-lower-bound y-lo x))
617 (y-hi-in-x (test-upper-bound y-hi x)))
618 (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x)
619 ;; Intervals intersect. Let's compute the intersection and the
620 ;; difference.
621 (multiple-value-bind (lo left-lo left-hi)
622 (cond (x-lo-in-y
623 (values x-lo y-lo (opposite-bound x-lo)))
624 (y-lo-in-x
625 (values y-lo x-lo (opposite-bound y-lo))))
626 (multiple-value-bind (hi right-lo right-hi)
627 (cond (x-hi-in-y
628 (values x-hi (opposite-bound x-hi) y-hi))
629 (y-hi-in-x
630 (values y-hi (opposite-bound y-hi) x-hi)))
631 (values (make-interval :low lo :high hi)
632 (list (make-interval :low left-lo :high left-hi)
633 (make-interval :low right-lo :high right-hi))))))
634 (t
635 (values nil (list x y))))))))
636
637 ;;; INTERVAL-MERGE-PAIR
638 ;;;
639 ;;; If intervals X and Y intersect, return a new interval that is the union of
640 ;;; the two. If they do not intersect, return NIL.
641 ;;;
642 (defun interval-merge-pair (x y)
643 (declare (type interval x y))
644 ;; If x and y intersect or are adjacent, create the union.
645 ;; Otherwise return nil
646 (when (or (interval-intersect-p x y)
647 (interval-adjacent-p x y))
648 (flet ((select-bound (x1 x2 min-op max-op)
649 (let ((x1-val (bound-value x1))
650 (x2-val (bound-value x2)))
651 (cond ((and x1 x2)
652 ;; Both bounds are finite. Select the right one.
653 (cond ((funcall min-op x1-val x2-val)
654 ;; x1 definitely better
655 x1)
656 ((funcall max-op x1-val x2-val)
657 ;; x2 definitely better
658 x2)
659 (t
660 ;; Bounds are equal. Select either value and
661 ;; make it open only if both were open.
662 (set-bound x1-val (and (consp x1) (consp x2))))))
663 (t
664 ;; At least one bound is not finite. The non-finite
665 ;; bound always wins.
666 nil)))))
667 (let* ((x-lo (copy-interval-limit (interval-low x)))
668 (x-hi (copy-interval-limit (interval-high x)))
669 (y-lo (copy-interval-limit (interval-low y)))
670 (y-hi (copy-interval-limit (interval-high y))))
671 (make-interval :low (select-bound x-lo y-lo
672 #'signed-zero-< #'signed-zero->)
673 :high (select-bound x-hi y-hi
674 #'signed-zero-> #'signed-zero-<))))))
675
676 ;; Wrap a handler-case around BODY so that any errors in the body
677 ;; will return a doubly-infinite interval.
678 ;;
679 ;; This is intended to catch things like (* 0f0 n) where n is an
680 ;; integer that won't fit in a single-float.
681 ;;
682 ;; This is a bit heavy-handed since ANY error gets converted to an
683 ;; unbounded interval. Perhaps some more fine-grained control would
684 ;; be appropriate?
685
686 (defmacro with-unbounded-interval-on-error (() &body body)
687 `(handler-case
688 (progn ,@body)
689 (error ()
690 (make-interval :low nil :high nil))))
691
692 ;;; Basic arithmetic operations on intervals. We probably should do true
693 ;;; interval arithmetic here, but it's complicated because we have float and
694 ;;; integer types and bounds can be open or closed.
695
696 ;;; INTERVAL-NEG
697 ;;;
698 ;;; The negative of an interval
699 ;;;
700 (defun interval-neg (x)
701 (declare (type interval x))
702 (make-interval :low (bound-func #'- (interval-high x))
703 :high (bound-func #'- (interval-low x))))
704
705 ;;; INTERVAL-ADD
706 ;;;
707 ;;; Add two intervals
708 ;;;
709 (defun interval-add (x y)
710 (declare (type interval x y))
711 (with-unbounded-interval-on-error ()
712 (make-interval :low (bound-binop + (interval-low x) (interval-low y))
713 :high (bound-binop + (interval-high x) (interval-high y)))))
714
715 ;;; INTERVAL-SUB
716 ;;;
717 ;;; Subtract two intervals
718 ;;;
719 (defun interval-sub (x y)
720 (declare (type interval x y))
721 (with-unbounded-interval-on-error ()
722 (make-interval :low (bound-binop - (interval-low x) (interval-high y))
723 :high (bound-binop - (interval-high x) (interval-low y)))))
724
725 ;;; INTERVAL-MUL
726 ;;;
727 ;;; Multiply two intervals
728 ;;;
729 (defun interval-mul (x y)
730 (declare (type interval x y))
731 (flet ((bound-mul (x y)
732 (cond ((or (null x) (null y))
733 ;; Multiply by infinity is infinity
734 nil)
735 ((or (and (numberp x) (zerop x))
736 (and (numberp y) (zerop y)))
737 ;; Multiply by closed zero is special. The result is always
738 ;; a closed bound. But don't replace this with zero; we
739 ;; want the multiplication to produce the correct signed
740 ;; zero, if needed.
741 (* (bound-value x) (bound-value y)))
742 ((or (and (floatp x) (float-infinity-p x))
743 (and (floatp y) (float-infinity-p y)))
744 ;; Infinity times anything is infinity
745 nil)
746 (t
747 ;; General multiply. The result is open if either is open.
748 (bound-binop * x y)))))
749 (let ((x-range (interval-range-info x))
750 (y-range (interval-range-info y)))
751 (cond ((null x-range)
752 ;; Split x into two and multiply each separately
753 (destructuring-bind (x- x+)
754 (interval-split 0 x t t)
755 (interval-merge-pair (interval-mul x- y)
756 (interval-mul x+ y))))
757 ((null y-range)
758 ;; Split y into two and multiply each separately
759 (destructuring-bind (y- y+)
760 (interval-split 0 y t t)
761 (interval-merge-pair (interval-mul x y-)
762 (interval-mul x y+))))
763 ((eq x-range '-)
764 (interval-neg (interval-mul (interval-neg x) y)))
765 ((eq y-range '-)
766 (interval-neg (interval-mul x (interval-neg y))))
767 ((and (eq x-range '+) (eq y-range '+))
768 ;; If we are here, X and Y are both positive
769 (with-unbounded-interval-on-error ()
770 (make-interval :low (bound-mul (interval-low x) (interval-low y))
771 :high (bound-mul (interval-high x)
772 (interval-high y)))))
773 (t
774 (error (intl:gettext "This shouldn't happen!")))))))
775
776 ;;; INTERVAL-DIV
777 ;;;
778 ;;; Divide two intervals.
779 ;;;
780 (defun interval-div (top bot)
781 (declare (type interval top bot))
782 (flet ((bound-div (x y y-low-p)
783 ;; Compute x/y
784 (cond ((null y)
785 ;; Divide by infinity means result is 0. However, we need
786 ;; to watch out for the sign of the result, to correctly
787 ;; handle signed zeros. We also need to watch out for
788 ;; positive or negative infinity.
789 (if (floatp (bound-value x))
790 (if y-low-p
791 (- (float-sign (bound-value x) 0.0))
792 (float-sign (bound-value x) 0.0))
793 0))
794 ((zerop (bound-value y))
795 ;; Divide by zero means result is infinity
796 nil)
797 ((and (numberp x) (zerop x))
798 ;; Zero divided by anything is zero.
799 x)
800 (t
801 (bound-binop / x y)))))
802 (let ((top-range (interval-range-info top))
803 (bot-range (interval-range-info bot)))
804 (cond ((null bot-range)
805 ;; The denominator contains zero, so anything goes!
806 (make-interval :low nil :high nil))
807 ((eq bot-range '-)
808 ;; Denominator is negative so flip the sign, compute the result,
809 ;; and flip it back.
810 (interval-neg (interval-div top (interval-neg bot))))
811 ((null top-range)
812 ;; Split top into two positive and negative parts, and divide
813 ;; each separately
814 (destructuring-bind (top- top+)
815 (interval-split 0 top t t)
816 (interval-merge-pair (interval-div top- bot)
817 (interval-div top+ bot))))
818 ((eq top-range '-)
819 ;; Top is negative so flip the sign, divide, and flip the sign of
820 ;; the result.
821 (interval-neg (interval-div (interval-neg top) bot)))
822 ((and (eq top-range '+) (eq bot-range '+))
823 ;; The easy case, sort of. Both are positive, so we know that
824 ;; the lower bound must be >= +0. If bound-div returns NIL, we
825 ;; were dividing by zero, so replace that result with 0 or '(0),
826 ;; depending on whether the numerator contains 0. This isn't
827 ;; quite right, but until we make the interval and numeric-type
828 ;; routines understand the concept of infinity better, this will
829 ;; have to do for now. (RLT)
830 (with-unbounded-interval-on-error ()
831 (make-interval :low (or (bound-div (interval-low top)
832 (interval-high bot) nil)
833 (if (interval-contains-p 0 top)
834 0
835 '(0)))
836 :high (bound-div (interval-high top)
837 (interval-low bot) t))))
838 (t
839 (error (intl:gettext "This shouldn't happen!")))))))
840
841
842 ;;; INTERVAL-FUNC
843 ;;;
844 ;;; Apply the function F to the interval X. If X = [a, b], then the result is
845 ;;; [f(a), f(b)]. It is up to the user to make sure the result makes sense.
846 ;;; It will if F is monotonic increasing (or non-decreasing).
847 ;;;
848 (defun interval-func (f x)
849 (declare (type interval x))
850 (let ((lo (bound-func f (interval-low x)))
851 (hi (bound-func f (interval-high x))))
852 (make-interval :low lo :high hi)))
853
854 ;;; INTERVAL-<
855 ;;;
856 ;;; Return T if X < Y. That is every number in the interval X is always less
857 ;;; than any number in the interval Y.
858 ;;;
859 (defun interval-< (x y)
860 (declare (type interval x y))
861 ;; X < Y only if X is bounded above, Y is bounded below, and they don't
862 ;; overlap.
863 (when (and (interval-bounded-p x 'above)
864 (interval-bounded-p y 'below))
865 ;; Intervals are bounded in the appropriate way. Make sure they don't
866 ;; overlap.
867 (let ((left (interval-high x))
868 (right (interval-low y)))
869 (cond ((> (bound-value left)
870 (bound-value right))
871 ;; Definitely overlap so result is NIL
872 nil)
873 ((< (bound-value left)
874 (bound-value right))
875 ;; Definitely don't touch, so result is T
876 t)
877 (t
878 ;; Limits are equal. Check for open or closed bounds.
879 ;; Don't overlap if one or the other are open.
880 (or (consp left) (consp right)))))))
881
882 ;;; INVTERVAL->=
883 ;;;
884 ;;; Return T if X >= Y. That is, every number in the interval X is always
885 ;;; greater than any number in the interval Y.
886 ;;;
887 (defun interval->= (x y)
888 (declare (type interval x y))
889 ;; X >= Y if lower bound of X >= upper bound of Y
890 (when (and (interval-bounded-p x 'below)
891 (interval-bounded-p y 'above))
892 (>= (bound-value (interval-low x)) (bound-value (interval-high y)))))
893
894 ;;; INTERVAL-ABS
895 ;;;
896 ;;; Return an interval that is the absolute value of X. Thus, if X = [-1 10],
897 ;;; the result is [0, 10].
898 ;;;
899 (defun interval-abs (x)
900 (declare (type interval x))
901 (case (interval-range-info x)
902 ('+
903 (copy-interval x))
904 ('-
905 (interval-neg x))
906 (t
907 (destructuring-bind (x- x+)
908 (interval-split 0 x t t)
909 (interval-merge-pair (interval-neg x-) x+)))))
910
911 ;;; INTERVAL-SQR
912 ;;;
913 ;;; Compute the square of an interval.
914 ;;;
915 (defun interval-sqr (x)
916 (declare (type interval x))
917 (interval-func #'(lambda (x) (* x x))
918 (interval-abs x)))
919
920
921
922
923 ;;;; Numeric Derive-Type methods:
924
925 ;;; Derive-Integer-Type -- Internal
926 ;;;
927 ;;; Utility for defining derive-type methods of integer operations. If the
928 ;;; types of both X and Y are integer types, then we compute a new integer type
929 ;;; with bounds determined Fun when applied to X and Y. Otherwise, we use
930 ;;; Numeric-Contagion.
931 ;;;
932 (defun derive-integer-type (x y fun)
933 (declare (type continuation x y) (type function fun))
934 (let ((x (continuation-type x))
935 (y (continuation-type y)))
936 (if (and (numeric-type-p x) (numeric-type-p y)
937 (eq (numeric-type-class x) 'integer)
938 (eq (numeric-type-class y) 'integer)
939 (eq (numeric-type-complexp x) :real)
940 (eq (numeric-type-complexp y) :real))
941 (multiple-value-bind (low high)
942 (funcall fun x y)
943 (make-numeric-type :class 'integer :complexp :real
944 :low low :high high))
945 (numeric-contagion x y))))
946
947 ;; Simple utility to flatten a list
948 (defun flatten-list (x)
949 (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
950 (cond ((null x) r)
951 ((atom x)
952 (cons x r))
953 (t (flatten-helper (car x)
954 (flatten-helper (cdr x) r))))))
955 (flatten-helper x nil)))
956
957 ;;; Take some type of continuation and massage it so that we get a list of the
958 ;;; constituent types. If ARG is *EMPTY-TYPE*, return NIL to indicate
959 ;;; failure.
960 ;;;
961 (defun prepare-arg-for-derive-type (arg)
962 (flet ((listify (arg)
963 (typecase arg
964 (numeric-type
965 (list arg))
966 (union-type
967 (union-type-types arg))
968 (t
969 (list arg)))))
970 (unless (eq arg *empty-type*)
971 ;; Make sure all args are some type of numeric-type. For member types,
972 ;; convert the list of members into a union of equivalent single-element
973 ;; member-type's.
974 (let ((new-args nil))
975 (dolist (arg (listify arg))
976 (if (member-type-p arg)
977 ;; Run down the list of members and convert to a list of
978 ;; member types.
979 (dolist (member (member-type-members arg))
980 (push (if (numberp member)
981 (specifier-type `(eql ,member))
982 *empty-type*)
983 new-args))
984 (push arg new-args)))
985 (unless (member *empty-type* new-args)
986 new-args)))))
987
988 ;;; Convert from the standard type convention for which -0.0 and 0.0 and equal
989 ;;; to an intermediate convention for which they are considered different
990 ;;; which is more natural for some of the optimisers.
991 ;;;
992 (defun convert-numeric-type (type)
993 (declare (type numeric-type type))
994 ;; Only convert real float interval delimiters types.
995 (if (eq (numeric-type-complexp type) :real)
996 (let* ((lo (numeric-type-low type))
997 (lo-val (bound-value lo))
998 (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0)))
999 (hi (numeric-type-high type))
1000 (hi-val (bound-value hi))
1001 (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0))))
1002 (if (or lo-float-zero-p hi-float-zero-p)
1003 (make-numeric-type
1004 :class (numeric-type-class type)
1005 :format (numeric-type-format type)
1006 :complexp :real
1007 :low (if lo-float-zero-p
1008 (if (consp lo)
1009 (list (float 0.0 lo-val))
1010 (float -0.0 lo-val))
1011 lo)
1012 :high (if hi-float-zero-p
1013 (if (consp hi)
1014 (list (float -0.0 hi-val))
1015 (float 0.0 hi-val))
1016 hi))
1017 type))
1018 ;; Not real float.
1019 type))
1020
1021 ;;; Convert back from the intermediate convention for which -0.0 and 0.0 are
1022 ;;; considered different to the standard type convention for which and equal.
1023 ;;;
1024 (defun convert-back-numeric-type (type)
1025 (declare (type numeric-type type))
1026 ;;; Only convert real float interval delimiters types.
1027 (if (eq (numeric-type-complexp type) :real)
1028 (let* ((lo (numeric-type-low type))
1029 (lo-val (bound-value lo))
1030 (lo-float-zero-p
1031 (and lo (floatp lo-val) (= lo-val 0.0)
1032 (float-sign lo-val)))
1033 (hi (numeric-type-high type))
1034 (hi-val (bound-value hi))
1035 (hi-float-zero-p
1036 (and hi (floatp hi-val) (= hi-val 0.0)
1037 (float-sign hi-val))))
1038 (cond
1039 ;; (float +0.0 +0.0) => (member 0.0)
1040 ;; (float -0.0 -0.0) => (member -0.0)
1041 ((and lo-float-zero-p hi-float-zero-p)
1042 ;; Shouldn't have exclusive bounds here.
1043 (assert (and (not (consp lo)) (not (consp hi))))
1044 (if (= lo-float-zero-p hi-float-zero-p)
1045 ;; (float +0.0 +0.0) => (member 0.0)
1046 ;; (float -0.0 -0.0) => (member -0.0)
1047 (specifier-type `(member ,lo-val))
1048 ;; (float -0.0 +0.0) => (float 0.0 0.0)
1049 ;; (float +0.0 -0.0) => (float 0.0 0.0)
1050 (make-numeric-type :class (numeric-type-class type)
1051 :format (numeric-type-format type)
1052 :complexp :real
1053 :low hi-val
1054 :high hi-val)))
1055 (lo-float-zero-p
1056 (cond
1057 ;; (float -0.0 x) => (float 0.0 x)
1058 ((and (not (consp lo)) (minusp lo-float-zero-p))
1059 (make-numeric-type :class (numeric-type-class type)
1060 :format (numeric-type-format type)
1061 :complexp :real
1062 :low (float 0.0 lo-val)
1063 :high hi))
1064 ;; (float (+0.0) x) => (float (0.0) x)
1065 ((and (consp lo) (plusp lo-float-zero-p))
1066 (make-numeric-type :class (numeric-type-class type)
1067 :format (numeric-type-format type)
1068 :complexp :real
1069 :low (list (float 0.0 lo-val))
1070 :high hi))
1071 (t
1072 ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
1073 ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
1074 (list (make-member-type :members (list (float 0.0 lo-val)))
1075 (make-numeric-type :class (numeric-type-class type)
1076 :format (numeric-type-format type)
1077 :complexp :real
1078 :low (list (float 0.0 lo-val))
1079 :high hi)))))
1080 (hi-float-zero-p
1081 (cond
1082 ;; (float x +0.0) => (float x 0.0)
1083 ((and (not (consp hi)) (plusp hi-float-zero-p))
1084 (make-numeric-type :class (numeric-type-class type)
1085 :format (numeric-type-format type)
1086 :complexp :real
1087 :low lo
1088 :high (float 0.0 hi-val)))
1089 ;; (float x (-0.0)) => (float x (0.0))
1090 ((and (consp hi) (minusp hi-float-zero-p))
1091 (make-numeric-type :class (numeric-type-class type)
1092 :format (numeric-type-format type)
1093 :complexp :real
1094 :low lo
1095 :high (list (float 0.0 hi-val))))
1096 (t
1097 ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
1098 ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
1099 (list (make-member-type :members (list (float -0.0 hi-val)))
1100 (make-numeric-type :class (numeric-type-class type)
1101 :format (numeric-type-format type)
1102 :complexp :real
1103 :low lo
1104 :high (list (float 0.0 hi-val)))))))
1105 (t
1106 type)))
1107 ;; Not real float.
1108 type))
1109
1110 ;;; Convert back a possible list of numeric types.
1111 ;;;
1112 (defun convert-back-numeric-type-list (type-list)
1113 (typecase type-list
1114 (list
1115 (let ((results '()))
1116 (dolist (type type-list)
1117 (if (numeric-type-p type)
1118 (let ((result (convert-back-numeric-type type)))
1119 (if (listp result)
1120 (setf results (append results result))
1121 (push result results)))
1122 (push type results)))
1123 results))
1124 (numeric-type
1125 (convert-back-numeric-type type-list))
1126 (union-type
1127 (convert-back-numeric-type-list (union-type-types type-list)))
1128 (t
1129 type-list)))
1130
1131 ;;; Make-Canonical-Union-Type
1132 ;;;
1133 ;;; Take a list of types and return a canonical type specifier, combining any
1134 ;;; members types together. If both positive and negative members types are
1135 ;;; present they are converted to a float type.
1136 ;;;
1137 (defun make-canonical-union-type (type-list)
1138 (let ((members '())
1139 (misc-types '()))
1140 (dolist (type type-list)
1141 (if (member-type-p type)
1142 (setf members (union members (member-type-members type)))
1143 (push type misc-types)))
1144 #+long-float
1145 (when (null (set-difference '(-0l0 0l0) members))
1146 (push (specifier-type '(long-float 0l0 0l0)) misc-types)
1147 (setf members (set-difference members '(-0l0 0l0))))
1148 #+double-double-2
1149 (let ((pzero (kernel:make-double-double-float 0d0 0d0))
1150 (nzero (kernel:make-double-double-float -0d0 0d0)))
1151 (when (null (set-difference (list pzero nzero) members))
1152 (push (specifier-type (list 'kernel:double-double-float pzero pzero)) misc-types)
1153 (setf members (set-difference members (list nzero pzero)))))
1154 (when (null (set-difference '(-0d0 0d0) members))
1155 (push (specifier-type '(double-float 0d0 0d0)) misc-types)
1156 (setf members (set-difference members '(-0d0 0d0))))
1157 (when (null (set-difference '(-0f0 0f0) members))
1158 (push (specifier-type '(single-float 0f0 0f0)) misc-types)
1159 (setf members (set-difference members '(-0f0 0f0))))
1160 (if members
1161 (apply #'type-union (make-member-type :members members) misc-types)
1162 (apply #'type-union misc-types))))
1163
1164 ;;; Convert-Member-Type
1165 ;;;
1166 ;;; Convert a member type with a single member to a numeric type.
1167 ;;;
1168 (defun convert-member-type (arg)
1169 (let* ((members (member-type-members arg))
1170 (member (first members))
1171 (member-type (type-of member)))
1172 (assert (not (rest members)))
1173 (cond ((subtypep member-type 'integer)
1174 (specifier-type `(integer ,member ,member)))
1175 ((subtypep member-type 'complex)
1176 (specifier-type member-type))
1177 (t
1178 (specifier-type `(,member-type ,member ,member))))))
1179
1180 ;;; ONE-ARG-DERIVE-TYPE
1181 ;;;
1182 ;;; This is used in defoptimizers for computing the resulting type of a
1183 ;;; function.
1184 ;;;
1185 ;;; Given the continuation ARG, derive the resulting type using the
1186 ;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some "atomic"
1187 ;;; continuation type like numeric-type or member-type (containing just one
1188 ;;; element). It should return the resulting type, which can be a list of
1189 ;;; types.
1190 ;;;
1191 ;;; For the case of member types, if a member-fcn is given it is called to
1192 ;;; compute the result otherwise the member type is first converted to a
1193 ;;; numeric type and the derive-fcn is call.
1194 ;;;
1195 (defun one-arg-derive-type (arg derive-fcn member-fcn
1196 &optional (convert-type t))
1197 (declare (type function derive-fcn)
1198 (type (or null function) member-fcn)
1199 )
1200 (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
1201 (when arg-list
1202 (flet ((deriver (x)
1203 (typecase x
1204 (member-type
1205 (if member-fcn
1206 (with-float-traps-masked
1207 (:underflow :overflow :divide-by-zero)
1208 (specifier-type `(eql ,(funcall member-fcn
1209 (first (member-type-members x))))))
1210 ;; Otherwise convert to a numeric type.
1211 (let ((result-type-list
1212 (funcall derive-fcn (convert-member-type x))))
1213 (if convert-type
1214 (convert-back-numeric-type-list result-type-list)
1215 result-type-list))))
1216 (numeric-type
1217 (if convert-type
1218 (convert-back-numeric-type-list
1219 (funcall derive-fcn (convert-numeric-type x)))
1220 (funcall derive-fcn x)))
1221 (t
1222 *universal-type*))))
1223 ;; Run down the list of args and derive the type of each one, saving
1224 ;; all of the results in a list.
1225 (let ((results nil))
1226 (dolist (arg arg-list)
1227 (let ((result (deriver arg)))
1228 (if (listp result)
1229 (setf results (append results result))
1230 (push result results))))
1231 (if (rest results)
1232 (make-canonical-union-type results)
1233 (first results)))))))
1234
1235 ;;; TWO-ARG-DERIVE-TYPE
1236 ;;;
1237 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes two
1238 ;;; arguments. DERIVE-FCN takes 3 args in this case: the two original args
1239 ;;; and a third which is T to indicate if the two args really represent the
1240 ;;; same continuation. This is useful for deriving the type of things like
1241 ;;; (* x x), which should always be positive. If we didn't do this, we
1242 ;;; wouldn't be able to tell.
1243 ;;;
1244 ;;; Without the negative-zero-is-not-zero feature, numeric types are first
1245 ;;; converted to the negative-zero-is-not-zero conventions as expected by the
1246 ;;; deriver function.
1247 ;;;
1248 ;;; For the case of two member types, the result may be derived by calling the
1249 ;;; given function FCN but if a NaN is generated then an unbounded type is
1250 ;;; returned. Alternatively a tighter, less conservative, type can often be
1251 ;;; returned by converting to numeric types and calling the deriver function,
1252 ;;; which is the default behavior without the conservative-float-type feature.
1253 ;;;
1254 (defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
1255 &optional (convert-type t))
1256 #-conservative-float-type
1257 (declare (ignore fcn))
1258 (labels ((maybe-convert-numeric-type (type)
1259 (if convert-type (convert-numeric-type type) type))
1260 (maybe-convert-back-type-list (type)
1261 (if convert-type (convert-back-numeric-type-list type) type))
1262 (deriver (x y same-arg)
1263 (cond #+conservative-float-type
1264 ((and (member-type-p x) (member-type-p y))
1265 (let* ((x (first (member-type-members x)))
1266 (y (first (member-type-members y)))
1267 (result (with-float-traps-masked
1268 (:underflow :overflow :divide-by-zero
1269 :invalid)
1270 (funcall fcn x y))))
1271 (cond ((null result))
1272 ((and (floatp result) (float-nan-p result))
1273 (make-numeric-type :class 'float
1274 :format (type-of result)
1275 :complexp :real))
1276 (t
1277 (specifier-type `(eql ,result))))))
1278 #-conservative-float-type
1279 ((and (member-type-p x) (member-type-p y))
1280 (let* ((x (convert-member-type x))
1281 (y (convert-member-type y))
1282 (result (funcall derive-fcn x y same-arg)))
1283 (maybe-convert-back-type-list result)))
1284 ((and (member-type-p x) (numeric-type-p y))
1285 (let* ((x (convert-member-type x))
1286 (y (maybe-convert-numeric-type y))
1287 (result (funcall derive-fcn x y same-arg)))
1288 (maybe-convert-back-type-list result)))
1289 ((and (numeric-type-p x) (member-type-p y))
1290 (let* ((x (maybe-convert-numeric-type x))
1291 (y (convert-member-type y))
1292 (result (funcall derive-fcn x y same-arg)))
1293 (maybe-convert-back-type-list result)))
1294 ((and (numeric-type-p x) (numeric-type-p y))
1295 (let* ((x (maybe-convert-numeric-type x))
1296 (y (maybe-convert-numeric-type y))
1297 (result (funcall derive-fcn x y same-arg)))
1298 (maybe-convert-back-type-list result)))
1299 (t
1300 *universal-type*)))
1301 (non-const-same-leaf-ref-p (x y)
1302 ;; Just like same-leaf-ref-p, but we don't care if the
1303 ;; value of the leaf is constant or not.
1304 (declare (type continuation x y))
1305 (let ((x-use (continuation-use x))
1306 (y-use (continuation-use y)))
1307 (and (ref-p x-use)
1308 (ref-p y-use)
1309 (eq (ref-leaf x-use) (ref-leaf y-use))))))
1310
1311 (let ((same-arg (non-const-same-leaf-ref-p arg1 arg2))
1312 (a1 (prepare-arg-for-derive-type (continuation-type arg1)))
1313 (a2 (prepare-arg-for-derive-type (continuation-type arg2))))
1314 (when (and a1 a2)
1315 (let ((results nil))
1316 (if same-arg
1317 ;; Since the args are the same continuation, just run
1318 ;; down the lists.
1319 (dolist (x a1)
1320 (let ((result (deriver x x same-arg)))
1321 (if (listp result)
1322 (setf results (append results result))
1323 (push result results))))
1324 ;; Try all pairwise combinations.
1325 (dolist (x a1)
1326 (dolist (y a2)
1327 (let ((result (or (deriver x y same-arg)
1328 (numeric-contagion x y))))
1329 (if (listp result)
1330 (setf results (append results result))
1331 (push result results))))))
1332 (if (rest results)
1333 (make-canonical-union-type results)
1334 (first results)))))))
1335
1336
1337
1338 (defun +-derive-type-aux (x y same-arg)
1339 (if (and (numeric-type-real-p x)
1340 (numeric-type-real-p y))
1341 (let ((result
1342 (if same-arg
1343 (let ((x-int (numeric-type->interval x)))
1344 (interval-add x-int x-int))
1345 (interval-add (numeric-type->interval x)
1346 (numeric-type->interval y))))
1347 (result-type (numeric-contagion x y)))
1348 ;; If the result type is a float, we need to be sure to coerce
1349 ;; the bounds into the correct type.
1350 (when (eq (numeric-type-class result-type) 'float)
1351 (setf result (interval-func
1352 #'(lambda (x)
1353 (coerce x (or (numeric-type-format result-type)
1354 'float)))
1355 result)))
1356 (make-numeric-type
1357 :class (if (and (eq (numeric-type-class x) 'integer)
1358 (eq (numeric-type-class y) 'integer))
1359 ;; The sum of integers is always an integer
1360 'integer
1361 (numeric-type-class result-type))
1362 :format (numeric-type-format result-type)
1363 :low (interval-low result)
1364 :high (interval-high result)))
1365 ;; General contagion
1366 (numeric-contagion x y)))
1367
1368
1369 (defoptimizer (+ derive-type) ((x y))
1370 (two-arg-derive-type x y #'+-derive-type-aux #'+))
1371
1372 (defun --derive-type-aux (x y same-arg)
1373 (if (and (numeric-type-real-p x)
1374 (numeric-type-real-p y))
1375 (let ((result
1376 ;; (- x x) is always 0.
1377 (if same-arg
1378 (make-interval :low 0 :high 0)
1379 (interval-sub (numeric-type->interval x)
1380 (numeric-type->interval y))))
1381 (result-type (numeric-contagion x y)))
1382 ;; If the result type is a float, we need to be sure to coerce
1383 ;; the bounds into the correct type.
1384 (when (eq (numeric-type-class result-type) 'float)
1385 (setf result (interval-func
1386 #'(lambda (x)
1387 (coerce x (or (numeric-type-format result-type)
1388 'float)))
1389 result)))
1390 (make-numeric-type
1391 :class (if (and (eq (numeric-type-class x) 'integer)
1392 (eq (numeric-type-class y) 'integer))
1393 ;; The difference of integers is always an integer
1394 'integer
1395 (numeric-type-class result-type))
1396 :format (numeric-type-format result-type)
1397 :low (interval-low result)
1398 :high (interval-high result)))
1399 ;; General contagion
1400 (numeric-contagion x y)))
1401
1402 (defoptimizer (- derive-type) ((x y))
1403 (two-arg-derive-type x y #'--derive-type-aux #'-))
1404
1405 (defun *-derive-type-aux (x y same-arg)
1406 (if (and (numeric-type-real-p x)
1407 (numeric-type-real-p y))
1408 (let ((result
1409 ;; (* x x) is always positive, so take care to do it
1410 ;; right.
1411 (if same-arg
1412 (interval-sqr (numeric-type->interval x))
1413 (interval-mul (numeric-type->interval x)
1414 (numeric-type->interval y))))
1415 (result-type (numeric-contagion x y)))
1416 ;; If the result type is a float, we need to be sure to coerce
1417 ;; the bounds into the correct type.
1418 (when (eq (numeric-type-class result-type) 'float)
1419 (setf result (interval-func
1420 #'(lambda (x)
1421 (coerce x (or (numeric-type-format result-type)
1422 'float)))
1423 result)))
1424 (make-numeric-type
1425 :class (if (and (eq (numeric-type-class x) 'integer)
1426 (eq (numeric-type-class y) 'integer))
1427 ;; The product of integers is always an integer
1428 'integer
1429 (numeric-type-class result-type))
1430 :format (numeric-type-format result-type)
1431 :low (interval-low result)
1432 :high (interval-high result)))
1433 (numeric-contagion x y)))
1434
1435 (defoptimizer (* derive-type) ((x y))
1436 (two-arg-derive-type x y #'*-derive-type-aux #'*))
1437
1438 (defun /-derive-type-aux (x y same-arg)
1439 (if (and (numeric-type-real-p x)
1440 (numeric-type-real-p y))
1441 (let ((result
1442 ;; (/ x x) is always 1, except if x can contain 0. In
1443 ;; that case, we shouldn't optimize the division away
1444 ;; because we want 0/0 to signal an error.
1445 (if (and same-arg
1446 (not (interval-contains-p
1447 0 (interval-closure (numeric-type->interval y)))))
1448 (make-interval :low 1 :high 1)
1449 (interval-div (numeric-type->interval x)
1450 (numeric-type->interval y))))
1451 (result-type (numeric-contagion x y)))
1452 ;; If the result type is a float, we need to be sure to coerce
1453 ;; the bounds into the correct type.
1454 (when (eq (numeric-type-class result-type) 'float)
1455 (setf result (interval-func
1456 #'(lambda (x)
1457 (coerce x (or (numeric-type-format result-type)
1458 'float)))
1459 result)))
1460 (make-numeric-type :class (numeric-type-class result-type)
1461 :format (numeric-type-format result-type)
1462 :low (interval-low result)
1463 :high (interval-high result)))
1464 (numeric-contagion x y)))
1465
1466
1467 (defoptimizer (/ derive-type) ((x y))
1468 (two-arg-derive-type x y #'/-derive-type-aux #'/))
1469
1470
1471
1472
1473 ;;; 'ash derive type optimizer.
1474 ;;;
1475 ;;; Large resulting bounds are easy to generate but are not particularly
1476 ;;; useful, so an open outer bound is returned for a shift greater than 64 -
1477 ;;; the largest word size of any of the ports. Large negative shifts are also
1478 ;;; problematic as the 'ash implementation only accepts shifts greater than
1479 ;;; the most-negative-fixnum. These issues are handled by two local functions:
1480 ;;;
1481 ;;; ash-outer: performs the shift when within an acceptable range, otherwise
1482 ;;; returns an open bound.
1483 ;;;
1484 ;;; ash-inner: performs the shift when within range, limited to a maximum of
1485 ;;; 64, otherwise returns the inner limit.
1486 ;;;
1487
1488 (defun ash-derive-type-aux (n-type shift same-arg)
1489 (declare (ignore same-arg))
1490 (flet ((ash-outer (n s)
1491 (when (and (fixnump s)
1492 (<= s 64)
1493 (> s most-negative-fixnum))
1494 (ash n s)))
1495 (ash-inner (n s)
1496 (if (and (fixnump s)
1497 (> s most-negative-fixnum))
1498 (ash n (min s 64))
1499 (if (minusp n) -1 0))))
1500 (or (and (csubtypep n-type (specifier-type 'integer))
1501 (csubtypep shift (specifier-type 'integer))
1502 (let ((n-low (numeric-type-low n-type))
1503 (n-high (numeric-type-high n-type))
1504 (s-low (numeric-type-low shift))
1505 (s-high (numeric-type-high shift)))
1506 (make-numeric-type :class 'integer :complexp :real
1507 :low (when n-low
1508 (if (minusp n-low)
1509 (ash-outer n-low s-high)
1510 (ash-inner n-low s-low)))
1511 :high (when n-high
1512 (if (minusp n-high)
1513 (ash-inner n-high s-low)
1514 (ash-outer n-high s-high))))))
1515 *universal-type*)))
1516 ;;;
1517 (defoptimizer (ash derive-type) ((n shift))
1518 (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
1519
1520
1521 (defoptimizer (lognot derive-type) ((int))
1522 (derive-integer-type int int
1523 #'(lambda (type type2)
1524 (declare (ignore type2))
1525 (let ((lo (numeric-type-low type))
1526 (hi (numeric-type-high type)))
1527 (values (if hi (lognot hi) nil)
1528 (if lo (lognot lo) nil)
1529 (numeric-type-class type)
1530 (numeric-type-format type))))))
1531
1532 (defoptimizer (%negate derive-type) ((num))
1533 (flet ((negate-bound (b)
1534 (set-bound (- (bound-value b)) (consp b))))
1535 (one-arg-derive-type num
1536 #'(lambda (type)
1537 (let ((lo (numeric-type-low type))
1538 (hi (numeric-type-high type))
1539 (result (copy-numeric-type type)))
1540 (setf (numeric-type-low result)
1541 (if hi (negate-bound hi) nil))
1542 (setf (numeric-type-high result)
1543 (if lo (negate-bound lo) nil))
1544 result))
1545 #'-)))
1546
1547 (defun abs-derive-type-aux (type)
1548 (cond ((eq (numeric-type-complexp type) :complex)
1549 ;; The absolute value of a complex number is always a
1550 ;; non-negative float.
1551 (let* ((format (case (numeric-type-class type)
1552 ((integer rational) 'single-float)
1553 (t (numeric-type-format type))))
1554 (bound-format (or format 'float)))
1555 (make-numeric-type :class 'float
1556 :format format
1557 :complexp :real
1558 :low (coerce 0 bound-format)
1559 :high nil)))
1560 (t
1561 ;; The absolute value of a real number is a non-negative real
1562 ;; of the same type.
1563 (let* ((abs-bnd (interval-abs (numeric-type->interval type)))
1564 (class (numeric-type-class type))
1565 (format (numeric-type-format type))
1566 (bound-type (or format class 'real)))
1567 (make-numeric-type
1568 :class class
1569 :format format
1570 :complexp :real
1571 :low (coerce-numeric-bound (interval-low abs-bnd) bound-type)
1572 :high (coerce-numeric-bound
1573 (interval-high abs-bnd) bound-type))))))
1574
1575 (defoptimizer (abs derive-type) ((num))
1576 (one-arg-derive-type num #'abs-derive-type-aux #'abs))
1577
1578 (defun rem-result-type (number-type divisor-type)
1579 ;; Figure out what the remainder type is. The remainder is an
1580 ;; integer if both args are integers; a rational if both args are
1581 ;; rational; and a float otherwise.
1582 (cond ((and (csubtypep number-type (specifier-type 'integer))
1583 (csubtypep divisor-type (specifier-type 'integer)))
1584 'integer)
1585 ((and (csubtypep number-type (specifier-type 'rational))
1586 (csubtypep divisor-type (specifier-type 'rational)))
1587 'rational)
1588 ((and (csubtypep number-type (specifier-type 'float))
1589 (csubtypep divisor-type (specifier-type 'float)))
1590 ;; Both are floats so the result is also a float, of
1591 ;; the largest type.
1592 (or (float-format-max (numeric-type-format number-type)
1593 (numeric-type-format divisor-type))
1594 'float))
1595 ((and (csubtypep number-type (specifier-type 'float))
1596 (csubtypep divisor-type (specifier-type 'rational)))
1597 ;; One of the arguments is a float and the other is a
1598 ;; rational. The remainder is a float of the same
1599 ;; type.
1600 (or (numeric-type-format number-type) 'float))
1601 ((and (csubtypep divisor-type (specifier-type 'float))
1602 (csubtypep number-type (specifier-type 'rational)))
1603 ;; One of the arguments is a float and the other is a
1604 ;; rational. The remainder is a float of the same
1605 ;; type.
1606 (or (numeric-type-format divisor-type) 'float))
1607 (t
1608 ;; Some unhandled combination. This usually means both args
1609 ;; are REAL so the result is a REAL.
1610 'real)))
1611
1612
1613 (defun truncate-derive-type-quot (number-type divisor-type)
1614 (let* ((rem-type (rem-result-type number-type divisor-type))
1615 (number-interval (numeric-type->interval number-type))
1616 (divisor-interval (numeric-type->interval divisor-type)))
1617 ;;(declare (type (member '(integer rational float)) rem-type))
1618 ;; We have real numbers now.
1619 (cond ((eq rem-type 'integer)
1620 ;; Since the remainder type is INTEGER, both args are
1621 ;; INTEGERs.
1622 (let* ((res (integer-truncate-derive-type
1623 (interval-low number-interval)
1624 (interval-high number-interval)
1625 (interval-low divisor-interval)
1626 (interval-high divisor-interval))))
1627 (specifier-type (if (listp res) res 'integer))))
1628 (t
1629 (let ((quot (truncate-quotient-bound
1630 (interval-div number-interval
1631 divisor-interval))))
1632 (specifier-type `(integer ,(or (interval-low quot) '*)
1633 ,(or (interval-high quot) '*))))))))
1634
1635 (defun truncate-derive-type-rem (number-type divisor-type)
1636 (let* ((rem-type (rem-result-type number-type divisor-type))
1637 (number-interval (numeric-type->interval number-type))
1638 (divisor-interval (numeric-type->interval divisor-type))
1639 (rem (truncate-rem-bound number-interval divisor-interval)))
1640 ;;(declare (type (member '(integer rational float)) rem-type))
1641 ;; We have real numbers now.
1642 (cond ((eq rem-type 'integer)
1643 ;; Since the remainder type is INTEGER, both args are
1644 ;; INTEGERs.
1645 (specifier-type `(,rem-type ,(or (interval-low rem) '*)
1646 ,(or (interval-high rem) '*))))
1647 (t
1648 (multiple-value-bind (class format)
1649 (ecase rem-type
1650 (integer
1651 (values 'integer nil))
1652 (rational
1653 (values 'rational nil))
1654 ((or single-float double-float #+long-float long-float
1655 #+double-double double-double-float)
1656 (values 'float rem-type))
1657 (float
1658 (values 'float nil))
1659 (real
1660 (values nil nil)))
1661 (when (member rem-type '(float single-float double-float
1662 #+long-float long-float
1663 #+double-double double-double-float))
1664 (setf rem (interval-func #'(lambda (x)
1665 (coerce x rem-type))
1666 rem)))
1667 (make-numeric-type :class class
1668 :format format
1669 :low (interval-low rem)
1670 :high (interval-high rem)))))))
1671
1672 (defun truncate-derive-type-quot-aux (num div same-arg)
1673 (declare (ignore same-arg))
1674 (if (and (numeric-type-real-p num)
1675 (numeric-type-real-p div))
1676 (truncate-derive-type-quot num div)
1677 *empty-type*))
1678
1679 (defun truncate-derive-type-rem-aux (num div same-arg)
1680 (declare (ignore same-arg))
1681 (if (and (numeric-type-real-p num)
1682 (numeric-type-real-p div))
1683 (truncate-derive-type-rem num div)
1684 *empty-type*))
1685
1686 (defoptimizer (truncate derive-type) ((number divisor))
1687 (let ((quot (two-arg-derive-type number divisor
1688 #'truncate-derive-type-quot-aux #'truncate))
1689 (rem (two-arg-derive-type number divisor
1690 #'truncate-derive-type-rem-aux #'rem)))
1691 (when (and quot rem)
1692 (make-values-type :required (list quot rem)))))
1693
1694
1695 (defun ftruncate-derive-type-quot (number-type divisor-type)
1696 ;; The bounds are the same as for truncate. However, the first
1697 ;; result is a float of some type. We need to determine what that
1698 ;; type is. Basically it's the more contagious of the two types.
1699 ;;
1700 ;; FIXME: Now that ftruncate returns signed zeroes, we should do
1701 ;; something better than calling truncate-derive-type-quot to figure
1702 ;; out the result and massaging that to get the correct float
1703 ;; result.
1704 (let* ((q-type (truncate-derive-type-quot number-type divisor-type))
1705 (res-type (numeric-contagion number-type divisor-type))
1706 (res-format (numeric-type-format res-type)))
1707 (flet ((floatify-bound (x)
1708 ;; Don't have to deal with list-type bounds because the
1709 ;; truncate defoptimizer doesn't return list-type bounds.
1710 ;;
1711 ;; Also, if RES-FORMAT is NIL, that means we want a FLOAT
1712 ;; type.
1713 (if (numberp x)
1714 (coerce x (or res-format 'float))
1715 x)))
1716 (let ((q-lo (floatify-bound (numeric-type-low q-type)))
1717 (q-hi (floatify-bound (numeric-type-high q-type))))
1718 ;; We need to be careful if q-type contains zero. Why?
1719 ;; Because ftruncate returns signed zeroes. See GCL
1720 ;; ansi-tests misc.558 for an example:
1721 ;;
1722 ;; (defun misc-558 (p1)
1723 ;; (declare (optimize (speed 1) (safety 2) (debug 2)
1724 ;; (space 3))
1725 ;; (type (eql -39466.56) p1))
1726 ;; (ffloor p1 305598613))
1727 ;;
1728 (when (csubtypep (specifier-type '(integer 0 0)) q-type)
1729 ;; The quotient contains 0. We really only have a problem
1730 ;; if one of the end points is zero.
1731 (cond ((and q-lo (zerop q-lo))
1732 ;; We should only include -0.0 if the result really
1733 ;; could be -0.0, but we're lazy right now and just
1734 ;; force it. The interval is very slightly larger
1735 ;; than the true interval.
1736 (setq q-lo (float -0d0 q-lo)))
1737 ((and q-hi (zerop q-hi))
1738 ;; This probably isn't needed because 0 is converted
1739 ;; to +0.0, which is the upper bound we want.
1740 (setq q-hi (float 0d0 q-hi)))))
1741 (make-numeric-type :class 'float
1742 :format res-format
1743 :low q-lo
1744 :high q-hi)))))
1745
1746 (defun ftruncate-derive-type-quot-aux (n d same-arg)
1747 (declare (ignore same-arg))
1748 (if (and (numeric-type-real-p n)
1749 (numeric-type-real-p d))
1750 (ftruncate-derive-type-quot n d)
1751 *empty-type*))
1752
1753 ;; I (RLT) don't understand why I need to make divisor optional. This
1754 ;; should look just like the optimizer for TRUNCATE. Until I figure
1755 ;; out why, this seems to work.
1756 (defoptimizer (ftruncate derive-type) ((number &optional divisor))
1757 (if divisor
1758 (let ((quot
1759 (two-arg-derive-type number divisor
1760 #'ftruncate-derive-type-quot-aux #'ftruncate))
1761 (rem (two-arg-derive-type number divisor
1762 #'truncate-derive-type-rem-aux #'rem)))
1763 (when (and quot rem)
1764 (make-values-type :required (list quot rem))))
1765 (let* ((div (specifier-type '(integer 1 1)))
1766 (quot
1767 (one-arg-derive-type number
1768 #'(lambda (n)
1769 (ftruncate-derive-type-quot-aux n div nil))
1770 #'ftruncate))
1771 (rem (one-arg-derive-type number
1772 #'(lambda (n)
1773 (truncate-derive-type-rem-aux n div nil))
1774 #'(lambda (x)
1775 (rem x 1)))))
1776 (when (and quot rem)
1777 (make-values-type :required (list quot rem))))))
1778
1779
1780 (defun %unary-truncate-derive-type-aux (number)
1781 (truncate-derive-type-quot number (specifier-type '(integer 1 1))))
1782
1783 (defoptimizer (%unary-truncate derive-type) ((number))
1784 (one-arg-derive-type number
1785 #'%unary-truncate-derive-type-aux
1786 #'%unary-truncate))
1787
1788 (defoptimizer (%unary-ftruncate derive-type) ((number))
1789 (let ((divisor (specifier-type '(integer 1 1))))
1790 (one-arg-derive-type number
1791 #'(lambda (n)
1792 (ftruncate-derive-type-quot-aux n divisor nil))
1793 #'%unary-ftruncate)))
1794
1795 ;;; Define optimizers for floor and ceiling
1796 (macrolet
1797 ((frob-opt (name q-name r-name)
1798 (let ((q-aux (symbolicate q-name "-AUX"))
1799 (r-aux (symbolicate r-name "-AUX")))
1800 `(progn
1801 ;; Compute type of quotient (first) result
1802 (defun ,q-aux (number-type divisor-type)
1803 (let* ((number-interval
1804 (numeric-type->interval number-type))
1805 (divisor-interval
1806 (numeric-type->interval divisor-type))
1807 (quot (,q-name (interval-div number-interval
1808 divisor-interval))))
1809 (specifier-type `(integer ,(or (interval-low quot) '*)
1810 ,(or (interval-high quot) '*)))))
1811
1812 ;; Compute type of remainder
1813 (defun ,r-aux (number-type divisor-type)
1814 (let* ((divisor-interval
1815 (numeric-type->interval divisor-type))
1816 (rem (,r-name divisor-interval))
1817 (result-type (rem-result-type number-type divisor-type)))
1818 (when (member result-type '(float single-float double-float
1819 #+long-float long-float
1820 #+double-double double-double-float))
1821 ;; Make sure the limits on the interval have the right type.
1822 (setf rem (interval-func #'(lambda (x)
1823 (coerce x result-type))
1824 rem)))
1825 (specifier-type `(,result-type ,(or (interval-low rem) '*)
1826 ,(or (interval-high rem) '*)))))
1827
1828 ;; The optimizer itself
1829 (defoptimizer (,name derive-type) ((number divisor))
1830 (flet ((derive-q (n d same-arg)
1831 (declare (ignore same-arg))
1832 (if (and (numeric-type-real-p n)
1833 (numeric-type-real-p d))
1834 (,q-aux n d)
1835 *empty-type*))
1836 (derive-r (n d same-arg)
1837 (declare (ignore same-arg))
1838 (if (and (numeric-type-real-p n)
1839 (numeric-type-real-p d))
1840 (,r-aux n d)
1841 *empty-type*)))
1842 (let ((quot (two-arg-derive-type
1843 number divisor #'derive-q #',name))
1844 (rem (two-arg-derive-type
1845 number divisor #'derive-r #'mod)))
1846 (when (and quot rem)
1847 (make-values-type :required (list quot rem))))))
1848 ))))
1849
1850 (frob-opt floor floor-quotient-bound floor-rem-bound)
1851 (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound))
1852
1853 ;;; Define optimizers for ffloor and fceiling
1854 (macrolet
1855 ((frob-opt (name q-name r-name)
1856 (let ((q-aux (symbolicate "F" q-name "-AUX"))
1857 (r-aux (symbolicate r-name "-AUX")))
1858 `(progn
1859 ;; Compute type of quotient (first) result
1860 (defun ,q-aux (number-type divisor-type)
1861 (let* ((number-interval
1862 (numeric-type->interval number-type))
1863 (divisor-interval
1864 (numeric-type->interval divisor-type))
1865 (quot (,q-name (interval-div number-interval
1866 divisor-interval)))
1867 (res-type (numeric-contagion number-type divisor-type))
1868 (res-format (numeric-type-format res-type)))
1869 (flet ((floatify (x)
1870 (if (numberp x)
1871 (coerce x (or res-format 'float))
1872 x)))
1873 (make-numeric-type
1874 :class 'float
1875 :format res-format
1876 :low (floatify (interval-low quot))
1877 :high (floatify (interval-high quot))))))
1878
1879 (defoptimizer (,name derive-type) ((number divisor))
1880 (flet ((derive-q (n d same-arg)
1881 (declare (ignore same-arg))
1882 (if (and (numeric-type-real-p n)
1883 (numeric-type-real-p d))
1884 (,q-aux n d)
1885 *empty-type*))
1886 (derive-r (n d same-arg)
1887 (declare (ignore same-arg))
1888 (if (and (numeric-type-real-p n)
1889 (numeric-type-real-p d))
1890 (,r-aux n d)
1891 *empty-type*)))
1892 (let ((quot (two-arg-derive-type
1893 number divisor #'derive-q #',name))
1894 (rem (two-arg-derive-type
1895 number divisor #'derive-r #'mod)))
1896 (when (and quot rem)
1897 (make-values-type :required (list quot rem))))))))))
1898
1899 (frob-opt ffloor floor-quotient-bound floor-rem-bound)
1900 (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
1901
1902 ;;; Functions to compute the bounds on the quotient and remainder for
1903 ;;; the FLOOR function.
1904
1905 (defun floor-quotient-bound (quot)
1906 ;; Take the floor of the quotient and then massage it into what we
1907 ;; need.
1908 (let ((lo (interval-low quot))
1909 (hi (interval-high quot)))
1910 ;; Take the floor of the lower bound. The result is always a
1911 ;; closed lower bound.
1912 (setf lo (if lo
1913 (floor (bound-value lo))
1914 nil))
1915 ;; For the upper bound, we need to be careful
1916 (setf hi
1917 (cond ((consp hi)
1918 ;; An open bound. We need to be careful here because
1919 ;; the floor of '(10.0) is 9, but the floor of
1920 ;; 10.0 is 10.
1921 (multiple-value-bind (q r)
1922 (floor (first hi))
1923 (if (zerop r)
1924 (1- q)
1925 q)))
1926 (hi
1927 ;; A closed bound, so the answer is obvious.
1928 (floor hi))
1929 (t
1930 hi)))
1931 (make-interval :low lo :high hi)))
1932
1933 (defun floor-rem-bound (div)
1934 ;; The remainder depends only on the divisor. Try to get the
1935 ;; correct sign for the remainder if we can.
1936
1937 (case (interval-range-info div)
1938 (+
1939 ;; Divisor is always positive.
1940 (let ((rem (interval-abs div)))
1941 (setf (interval-low rem) 0)
1942 (when (and (numberp (interval-high rem))
1943 (not (zerop (interval-high rem))))
1944 ;; The remainder never contains the upper bound. However,
1945 ;; watch out for the case where the high limit is zero!
1946 (setf (interval-high rem) (list (interval-high rem))))
1947 rem))
1948 (-
1949 ;; Divisor is always negative
1950 (let ((rem (interval-neg (interval-abs div))))
1951 (setf (interval-high rem) 0)
1952 (when (numberp (interval-low rem))
1953 ;; The remainder never contains the lower bound.
1954 (setf (interval-low rem) (list (interval-low rem))))
1955 rem))
1956 (otherwise
1957 ;; The divisor can be positive or negative. All bets off.
1958 ;; The magnitude of remainder is the maximum value of the
1959 ;; divisor.
1960 (let ((limit (bound-value (interval-high (interval-abs div)))))
1961 ;; The bound never reaches the limit, so make the interval open
1962 (make-interval :low (if limit
1963 (list (- limit))
1964 limit)
1965 :high (list limit))))))
1966 #| Test cases
1967 (floor-quotient-bound (make-interval :low 0.3 :high 10.3))
1968 => #S(INTERVAL :LOW 0 :HIGH 10)
1969 (floor-quotient-bound (make-interval :low 0.3 :high '(10.3)))
1970 => #S(INTERVAL :LOW 0 :HIGH 10)
1971 (floor-quotient-bound (make-interval :low 0.3 :high 10))
1972 => #S(INTERVAL :LOW 0 :HIGH 10)
1973 (floor-quotient-bound (make-interval :low 0.3 :high '(10)))
1974 => #S(INTERVAL :LOW 0 :HIGH 9)
1975 (floor-quotient-bound (make-interval :low '(0.3) :high 10.3))
1976 => #S(INTERVAL :LOW 0 :HIGH 10)
1977 (floor-quotient-bound (make-interval :low '(0.0) :high 10.3))
1978 => #S(INTERVAL :LOW 0 :HIGH 10)
1979 (floor-quotient-bound (make-interval :low '(-1.3) :high 10.3))
1980 => #S(INTERVAL :LOW -2 :HIGH 10)
1981 (floor-quotient-bound (make-interval :low '(-1.0) :high 10.3))
1982 => #S(INTERVAL :LOW -1 :HIGH 10)
1983 (floor-quotient-bound (make-interval :low -1.0 :high 10.3))
1984 => #S(INTERVAL :LOW -1 :HIGH 10)
1985
1986
1987 (floor-rem-bound (make-interval :low 0.3 :high 10.3))
1988 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
1989 (floor-rem-bound (make-interval :low 0.3 :high '(10.3)))
1990 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
1991 (floor-rem-bound (make-interval :low -10 :high -2.3))
1992 #S(INTERVAL :LOW (-10) :HIGH 0)
1993 (floor-rem-bound (make-interval :low 0.3 :high 10))
1994 => #S(INTERVAL :LOW 0 :HIGH '(10))
1995 (floor-rem-bound (make-interval :low '(-1.3) :high 10.3))
1996 => #S(INTERVAL :LOW '(-10.3) :HIGH '(10.3))
1997 (floor-rem-bound (make-interval :low '(-20.3) :high 10.3))
1998 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
1999 |#
2000
2001
2002 ;;; Same functions for CEILING
2003 (defun ceiling-quotient-bound (quot)
2004 ;; Take the ceiling of the quotient and then massage it into what we
2005 ;; need.
2006 (let ((lo (interval-low quot))
2007 (hi (interval-high quot)))
2008 ;; Take the ceiling of the upper bound. The result is always a
2009 ;; closed upper bound.
2010 (setf hi (if hi
2011 (ceiling (bound-value hi))
2012 nil))
2013 ;; For the lower bound, we need to be careful
2014 (setf lo
2015 (cond ((consp lo)
2016 ;; An open bound. We need to be careful here because
2017 ;; the ceiling of '(10.0) is 11, but the ceiling of
2018 ;; 10.0 is 10.
2019 (multiple-value-bind (q r)
2020 (ceiling (first lo))
2021 (if (zerop r)
2022 (1+ q)
2023 q)))
2024 (lo
2025 ;; A closed bound, so the answer is obvious.
2026 (ceiling lo))
2027 (t
2028 lo)))
2029 (make-interval :low lo :high hi)))
2030
2031
2032 (defun ceiling-rem-bound (div)
2033 ;; The remainder depends only on the divisor. Try to get the
2034 ;; correct sign for the remainder if we can.
2035
2036 (case (interval-range-info div)
2037 (+
2038 ;; Divisor is always positive. The remainder is negative.
2039 (let ((rem (interval-neg (interval-abs div))))
2040 (setf (interval-high rem) 0)
2041 (when (and (numberp (interval-low rem))
2042 (not (zerop (interval-low rem))))
2043 ;; The remainder never contains the upper bound. However,
2044 ;; watch out for the case when the upper bound is zero!
2045 (setf (interval-low rem) (list (interval-low rem))))
2046 rem))
2047 (-
2048 ;; Divisor is always negative. The remainder is positive
2049 (let ((rem (interval-abs div)))
2050 (setf (interval-low rem) 0)
2051 (when (numberp (interval-high rem))
2052 ;; The remainder never contains the lower bound.
2053 (setf (interval-high rem) (list (interval-high rem))))
2054 rem))
2055 (otherwise
2056 ;; The divisor can be positive or negative. All bets off.
2057 ;; The magnitude of remainder is the maximum value of the
2058 ;; divisor.
2059 (let ((limit (bound-value (interval-high (interval-abs div)))))
2060 ;; The bound never reaches the limit, so make the interval open
2061 (make-interval :low (if limit
2062 (list (- limit))
2063 limit)
2064 :high (list limit))))))
2065
2066 #| Test cases
2067 (ceiling-quotient-bound (make-interval :low 0.3 :high 10.3))
2068 => #S(INTERVAL :LOW 1 :HIGH 11)
2069 (ceiling-quotient-bound (make-interval :low 0.3 :high '(10.3)))
2070 => #S(INTERVAL :LOW 1 :HIGH 11)
2071 (ceiling-quotient-bound (make-interval :low 0.3 :high 10))
2072 => #S(INTERVAL :LOW 1 :HIGH 10)
2073 (ceiling-quotient-bound (make-interval :low 0.3 :high '(10)))
2074 => #S(INTERVAL :LOW 1 :HIGH 10)
2075 (ceiling-quotient-bound (make-interval :low '(0.3) :high 10.3))
2076 => #S(INTERVAL :LOW 1 :HIGH 11)
2077 (ceiling-quotient-bound (make-interval :low '(0.0) :high 10.3))
2078 => #S(INTERVAL :LOW 1 :HIGH 11)
2079 (ceiling-quotient-bound (make-interval :low '(-1.3) :high 10.3))
2080 => #S(INTERVAL :LOW -1 :HIGH 11)
2081 (ceiling-quotient-bound (make-interval :low '(-1.0) :high 10.3))
2082 => #S(INTERVAL :LOW 0 :HIGH 11)
2083 (ceiling-quotient-bound (make-interval :low -1.0 :high 10.3))
2084 => #S(INTERVAL :LOW -1 :HIGH 11)
2085
2086
2087 (ceiling-rem-bound (make-interval :low 0.3 :high 10.3))
2088 => #S(INTERVAL :LOW (-10.3) :HIGH 0)
2089 (ceiling-rem-bound (make-interval :low 0.3 :high '(10.3)))
2090 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
2091 (ceiling-rem-bound (make-interval :low -10 :high -2.3))
2092 => #S(INTERVAL :LOW 0 :HIGH (10))
2093 (ceiling-rem-bound (make-interval :low 0.3 :high 10))
2094 => #S(INTERVAL :LOW (-10) :HIGH 0)
2095 (ceiling-rem-bound (make-interval :low '(-1.3) :high 10.3))
2096 => #S(INTERVAL :LOW (-10.3) :HIGH (10.3))
2097 (ceiling-rem-bound (make-interval :low '(-20.3) :high 10.3))
2098 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
2099 |#
2100
2101
2102
2103
2104
2105 (defun truncate-quotient-bound (quot)
2106 ;; For positive quotients, truncate is exactly like floor. For
2107 ;; negative quotients, truncate is exactly like ceiling. Otherwise,
2108 ;; it's the union of the two pieces.
2109 (case (interval-range-info quot)
2110 (+
2111 ;; Just like floor
2112 (floor-quotient-bound quot))
2113 (-
2114 ;; Just like ceiling
2115 (ceiling-quotient-bound quot))
2116 (otherwise
2117 ;; Split the interval into positive and negative pieces, compute
2118 ;; the result for each piece and put them back together.
2119 (destructuring-bind (neg pos)
2120 (interval-split 0 quot t t)
2121 (interval-merge-pair (ceiling-quotient-bound neg)
2122 (floor-quotient-bound pos))))))
2123
2124
2125 (defun truncate-rem-bound (num div)
2126 ;; This is significantly more complicated than floor or ceiling. We
2127 ;; need both the number and the divisor to determine the range. The
2128 ;; basic idea is to split the ranges of num and den into positive
2129 ;; and negative pieces and deal with each of the four possibilities
2130 ;; in turn.
2131 (case (interval-range-info num)
2132 (+
2133 (case (interval-range-info div)
2134 (+
2135 (floor-rem-bound div))
2136 (-
2137 (ceiling-rem-bound div))
2138 (otherwise
2139 (destructuring-bind (neg pos)
2140 (interval-split 0 div t t)
2141 (interval-merge-pair (truncate-rem-bound num neg)
2142 (truncate-rem-bound num pos))))))
2143 (-
2144 (case (interval-range-info div)
2145 (+
2146 (ceiling-rem-bound div))
2147 (-
2148 (floor-rem-bound div))
2149 (otherwise
2150 (destructuring-bind (neg pos)
2151 (interval-split 0 div t t)
2152 (interval-merge-pair (truncate-rem-bound num neg)
2153 (truncate-rem-bound num pos))))))
2154 (otherwise
2155 (destructuring-bind (neg pos)
2156 (interval-split 0 num t t)
2157 (interval-merge-pair (truncate-rem-bound neg div)
2158 (truncate-rem-bound pos div))))))
2159
2160
2161
2162
2163 ;;; NUMERIC-RANGE-INFO -- internal.
2164 ;;;
2165 ;;; Derive useful information about the range. Returns three values:
2166 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2167 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2168 ;;; - The abs of the maximal value if there is one, or nil if it is
2169 ;;; unbounded.
2170 ;;;
2171 (defun numeric-range-info (low high)
2172 (cond ((and low (not (minusp low)))
2173 (values '+ low high))
2174 ((and high (not (plusp high)))
2175 (values '- (- high) (if low (- low) nil)))
2176 (t
2177 (values nil 0 (and low high (max (- low) high))))))
2178
2179 ;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal
2180 ;;;
2181 (defun integer-truncate-derive-type
2182 (number-low number-high divisor-low divisor-high)
2183 ;; The result cannot be larger in magnitude than the number, but the sign
2184 ;; might change. If we can determine the sign of either the number or
2185 ;; the divisor, we can eliminate some of the cases.
2186 (multiple-value-bind
2187 (number-sign number-min number-max)
2188 (numeric-range-info number-low number-high)
2189 (multiple-value-bind
2190 (divisor-sign divisor-min divisor-max)
2191 (numeric-range-info divisor-low divisor-high)
2192 (when (and divisor-max (zerop divisor-max))
2193 ;; We've got a problem: guarenteed division by zero.
2194 (return-from integer-truncate-derive-type t))
2195 (when (zerop divisor-min)
2196 ;; We'll assume that they aren't going to divide by zero.
2197 (incf divisor-min))
2198 (cond ((and number-sign divisor-sign)
2199 ;; We know the sign of both.
2200 (if (eq number-sign divisor-sign)
2201 ;; Same sign, so the result will be positive.
2202 `(integer ,(if divisor-max
2203 (truncate number-min divisor-max)
2204 0)
2205 ,(if number-max
2206 (truncate number-max divisor-min)
2207 '*))
2208 ;; Different signs, the result will be negative.
2209 `(integer ,(if number-max
2210 (- (truncate number-max divisor-min))
2211 '*)
2212 ,(if divisor-max
2213 (- (truncate number-min divisor-max))
2214 0))))
2215 ((eq divisor-sign '+)
2216 ;; The divisor is positive. Therefore, the number will just
2217 ;; become closer to zero.
2218 `(integer ,(if number-low
2219 (truncate number-low divisor-min)
2220 '*)
2221 ,(if number-high
2222 (truncate number-high divisor-min)
2223 '*)))
2224 ((eq divisor-sign '-)
2225 ;; The divisor is negative. Therefore, the absolute value of
2226 ;; the number will become closer to zero, but the sign will also
2227 ;; change.
2228 `(integer ,(if number-high
2229 (- (truncate number-high divisor-min))
2230 '*)
2231 ,(if number-low
2232 (- (truncate number-low divisor-min))
2233 '*)))
2234 ;; The divisor could be either positive or negative.
2235 (number-max
2236 ;; The number we are dividing has a bound. Divide that by the
2237 ;; smallest posible divisor.
2238 (let ((bound (truncate number-max divisor-min)))
2239 `(integer ,(- bound) ,bound)))
2240 (t
2241 ;; The number we are dividing is unbounded, so we can't tell
2242 ;; anything about the result.
2243 `integer)))))
2244
2245
2246 (defun random-derive-type-aux (type)
2247 (let ((class (numeric-type-class type))
2248 (high (numeric-type-high type))
2249 (format (numeric-type-format type)))
2250 (make-numeric-type
2251 :class class
2252 :format format
2253 :low (coerce 0 (or format class 'real))
2254 :high (cond ((not high) nil)
2255 ((eq class 'integer) (max (1- high) 0))
2256 ((or (consp high) (zerop high)) high)
2257 (t `(,high))))))
2258
2259 (defoptimizer (random derive-type) ((bound &optional state))
2260 (one-arg-derive-type bound #'random-derive-type-aux nil))
2261
2262
2263 ;;;; Logical derive-type methods:
2264
2265
2266 ;;; Integer-Type-Length -- Internal
2267 ;;;
2268 ;;; Return the maximum number of bits an integer of the supplied type can take
2269 ;;; up, or NIL if it is unbounded. The second (third) value is T if the
2270 ;;; integer can be positive (negative) and NIL if not. Zero counts as
2271 ;;; positive.
2272 ;;;
2273 (defun integer-type-length (type)
2274 (if (numeric-type-p type)
2275 (let ((min (numeric-type-low type))
2276 (max (numeric-type-high type)))
2277 (values (and min max (max (integer-length min) (integer-length max)))
2278 (or (null max) (not (minusp max)))
2279 (or (null min) (minusp min))))
2280 (values nil t t)))
2281
2282 ;;; From Hacker's Delight, by Henry S. Warren, Jr.
2283
2284 ;;; Let a <= x <= b and c <= y <= d, with X and Y both unsigned 32-bit
2285 ;;; numbers. (Mostly because that's what the routines support, but
2286 ;;; they could be extended to any positive integer.) MIN-AND and
2287 ;;; MAX-AND compute reasonably tight bounds on x&y. MIN-OR and MAX-OR
2288 ;;; compute the bounds on x|y.
2289
2290 (defun min-and (a b c d)
2291 ;; Note that the body of the loop doesn't really do anything unless
2292 ;; ~a&~c&m is non-zero. So, rather than start m at #x80000000, we
2293 ;; can start at the most significant bit where ~a&~c is non-zero.
2294 (let ((m (ash 1 (integer-length (logandc2 (lognot a) c)))))
2295 (loop while (not (zerop m))
2296 do
2297 (when (/= (logand m (lognot a) (lognot c)) 0)
2298 (let ((temp (logandc2 (logior a m) (- m 1))))
2299 (when (<= temp b)
2300 (setf a temp)
2301 (return)))
2302 (let ((temp (logandc2 (logior c m) (- m 1))))
2303 (when (<= temp d)
2304 (setf c temp)
2305 (return))))
2306 (setf m (ash m -1)))
2307 (logand a c)))
2308
2309 (defun max-and (a b c d)
2310 ;; Note that the body of the loop doesn't really do anything unless
2311 ;; b&~d&m is non-zero or ~b&d&m is non-zero. So, rather than start
2312 ;; m at #x80000000, we can start at the most significant bit where
2313 ;; b&~d or ~b&d is non-zero. That is, b^d is non-zero
2314 (let ((m (ash 1 (integer-length (logxor b d)))))
2315 (loop while (not (zerop m))
2316 do
2317 (cond ((/= (logand b (lognot d) m) 0)
2318 (let ((temp (logior (logandc2 b m) (- m 1))))
2319 (when (>= temp a)
2320 (setf b temp)
2321 (return))))
2322 ((/= (logand (lognot b) d m) 0)
2323 (let ((temp (logior (logandc2 d m) (- m 1))))
2324 (when (>= temp c)
2325 (setf d temp)
2326 (return)))))
2327 (setf m (ash m -1))))
2328 (logand b d))
2329
2330 (defun min-or (a b c d)
2331 ;; Note that the body of the loop doesn't do anything unless ~a&c&m
2332 ;; is non-zero or if ~c&a&m is non-zero. So rather than start m at
2333 ;; #x80000000, we can start at the most significant bit where ~a&c
2334 ;; or ~c&a is non-zero, i.e., where MSB of a^c.
2335 (let ((m (ash 1 (integer-length (logxor a c)))))
2336 (loop while (not (zerop m))
2337 do
2338 (cond ((/= (logandc2 (logand c m) a) 0)
2339 (let ((temp (logand (logior a m)
2340 (1+ (lognot m)))))
2341 (when (<= temp b)
2342 (setf a temp)
2343 (return))))
2344 ((/= (logandc1 c (logand a m)) 0)
2345 (let ((temp (logand (logior c m)
2346 (1+ (lognot m)))))
2347 (when (<= temp d)
2348 (setf c temp)
2349 (return)))))
2350 (setf m (ash m -1))))
2351 (logior a c))
2352
2353 (defun max-or (a b c d)
2354 ;; Note that the body of the loop doesn't do anything unless b&d&m
2355 ;; is non-zero. That is, when the MSB of b&d is non-zero.
2356 (let ((m (ash 1 (integer-length (logand b d)))))
2357 (loop while (not (zerop m))
2358 do
2359 (when (/= (logand m b d) 0)
2360 (let ((temp (logior (- b m)
2361 (- m 1))))
2362 (when (>= temp a)
2363 (setf b temp)
2364 (return)))
2365 (let ((temp (logior (- d m)
2366 (- m 1))))
2367 (when (>= temp c)
2368 (setf d temp)
2369 (return))))
2370 (setf m (ash m -1)))
2371 (logior b d)))
2372
2373 (defun min-xor (a b c d)
2374 ;; Note that the body of the loop doesn't do anything unless ~a&c&m
2375 ;; is non-zero or if ~c&a&m is non-zero. So rather than start m at
2376 ;; #x80000000, we can start at the most significant bit where ~a&c
2377 ;; or ~c&a is non-zero, i.e., where MSB of a^c is 1.
2378 (let ((m (ash 1 (1- (integer-length (logxor a c))))))
2379 (loop while (not (zerop m))
2380 do
2381 (cond ((/= (logandc2 (logand c m) a) 0)
2382 (let ((temp (logand (logior a m)
2383 (1+ (lognot m)))))
2384 (when (<= temp b)
2385 (setf a temp))))
2386 ((/= (logandc1 c (logand a m)) 0)
2387 (let ((temp (logand (logior c m)
2388 (1+ (lognot m)))))
2389 (when (<= temp d)
2390 (setf c temp)))))
2391 (setf m (ash m -1))))
2392 (logxor a c))
2393
2394 (defun max-xor (a b c d)
2395 ;; Note that the body of the loop doesn't do anything unless b&d&m
2396 ;; is non-zero. So rather than start m at #x80000000, we can start
2397 ;; at the most significant bit where b&d is non-zero.
2398 (let ((m (ash 1 (1- (integer-length (logand b d))))))
2399 (loop while (not (zerop m))
2400 do
2401 (when (/= (logand m b d) 0)
2402 (let ((temp (logior (- b m)
2403 (- m 1))))
2404 (if (>= temp a)
2405 (setf b temp)
2406 (let ((temp (logior (- d m)
2407 (- m 1))))
2408 (when (>= temp c)
2409 (setf d temp))))))
2410 (setf m (ash m -1)))
2411 (logxor b d)))
2412
2413
2414 (defun logand-derive-type-aux (x y &optional same-leaf)
2415 (declare (ignore same-leaf))
2416 (multiple-value-bind
2417 (x-len x-pos x-neg)
2418 (integer-type-length x)
2419 (declare (ignore x-pos))
2420 (multiple-value-bind
2421 (y-len y-pos y-neg)
2422 (integer-type-length y)
2423 (declare (ignore y-pos))
2424 (if (not x-neg)
2425 ;; X must be positive.
2426 (if (not y-neg)
2427 ;; The must both be positive.
2428 (cond ((and (null x-len) (null y-len))
2429 ;; Both are unbounded, so result is unbounded.
2430 (specifier-type 'unsigned-byte))
2431 ((or (eql x-len 0)
2432 (eql y-len 0))
2433 ;; One has zero length, so the result has zero length.
2434 (specifier-type '(integer 0 0)))
2435 ((or (and x-len (null y-len))
2436 (and y-len (null x-len)))
2437 ;; One is bounded, so the result is bounded.
2438 ;; The computed length here is a bit loose.
2439 (specifier-type `(unsigned-byte ,(max (or x-len 0)
2440 (or y-len 0)))))
2441 ((and (<= x-len 32) (<= y-len 32))
2442 ;; If both args are unsigned 32-bit numbers, we
2443 ;; can compute better bounds, so we do. But if
2444 ;; one arg is a constant and is a single bit, we
2445 ;; can do even better.
2446 ;;
2447 ;; What about the case where one arg is constant
2448 ;; and has several bits set? We could compute
2449 ;; exact values by turning off each individual
2450 ;; bit and all combinations thereof. Should we?
2451 (let ((xlo (numeric-type-low x))
2452 (xhi (numeric-type-high x))
2453 (ylo (numeric-type-low y))
2454 (yhi (numeric-type-high y)))
2455 (cond ((and (= xlo xhi) (= 1 (logcount xlo)))
2456 (specifier-type `(member 0 ,xlo)))
2457 ((and (= ylo yhi) (= 1 (logcount ylo)))
2458 (specifier-type `(member 0 ,ylo)))
2459 (t
2460 (specifier-type `(integer ,(min-and xlo xhi ylo yhi)
2461 ,(max-and xlo xhi ylo yhi)))))))
2462 (t
2463 (specifier-type `(unsigned-byte ,(min x-len y-len)))))
2464 ;; X is positive, but Y might be negative.
2465 (cond ((null x-len)
2466 (specifier-type 'unsigned-byte))
2467 ((zerop x-len)
2468 (specifier-type '(integer 0 0)))
2469 (t
2470 (specifier-type `(unsigned-byte ,x-len)))))
2471 ;; X might be negative.
2472 (if (not y-neg)
2473 ;; Y must be positive.
2474 (cond ((null y-len)
2475 (specifier-type 'unsigned-byte))
2476 ((zerop y-len)
2477 (specifier-type '(integer 0 0)))
2478 (t
2479 (specifier-type
2480 `(unsigned-byte ,y-len))))
2481 ;; Either might be negative.
2482 (if (and x-len y-len)
2483 ;; The result is bounded.
2484 (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
2485 ;; We can't tell squat about the result.
2486 (specifier-type 'integer)))))))
2487
2488 (defun logior-derive-type-aux (x y &optional same-leaf)
2489 (declare (ignore same-leaf))
2490 (multiple-value-bind
2491 (x-len x-pos x-neg)
2492 (integer-type-length x)
2493 (multiple-value-bind
2494 (y-len y-pos y-neg)
2495 (integer-type-length y)
2496 (cond ((and (not x-neg) (not y-neg))
2497 ;; Both are positive.
2498 (cond ((or (null x-len) (null y-len))
2499 (specifier-type 'unsigned-byte))
2500 ((and (zerop x-len) (zerop y-len))
2501 (specifier-type '(integer 0 0)))
2502 ((and (<= x-len 32) (<= y-len 32))
2503 (let ((xlo (numeric-type-low x))
2504 (xhi (numeric-type-high x))
2505 (ylo (numeric-type-low y))
2506 (yhi (numeric-type-high y)))
2507 (specifier-type `(integer ,(min-or xlo xhi ylo yhi)
2508 ,(max-or xlo xhi ylo yhi)))))
2509 (t
2510 (specifier-type `(unsigned-byte ,(max x-len y-len))))))
2511 ((not x-pos)
2512 ;; X must be negative.
2513 (if (not y-pos)
2514 ;; Both are negative. The result is going to be negative and be
2515 ;; the same length or shorter than the smaller.
2516 (if (and x-len y-len)
2517 ;; It's bounded.
2518 (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
2519 ;; It's unbounded.
2520 (specifier-type '(integer * -1)))
2521 ;; X is negative, but we don't know about Y. The result will be
2522 ;; negative, but no more negative than X.
2523 (specifier-type
2524 `(integer ,(or (numeric-type-low x) '*)
2525 -1))))
2526 (t
2527 ;; X might be either positive or negative.
2528 (if (not y-pos)
2529 ;; But Y is negative. The result will be negative.
2530 (specifier-type
2531 `(integer ,(or (numeric-type-low y) '*)
2532 -1))
2533 ;; We don't know squat about either. It won't get any bigger.
2534 (if (and x-len y-len)
2535 ;; Bounded.
2536 (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
2537 ;; Unbounded.
2538 (specifier-type 'integer))))))))
2539
2540 (defun logxor-derive-type-aux (x y &optional same-leaf)
2541 (declare (ignore same-leaf))
2542 (multiple-value-bind
2543 (x-len x-pos x-neg)
2544 (integer-type-length x)
2545 (multiple-value-bind
2546 (y-len y-pos y-neg)
2547 (integer-type-length y)
2548 (cond
2549 ((and (not x-neg) (not y-neg))
2550 ;; Both are positive
2551 (cond ((or (null x-len) (null y-len))
2552 (specifier-type 'unsigned-byte))
2553