1 ;;;; This file contains macro-like source transformations which
2 ;;;; convert uses of certain functions into the canonical form desired
3 ;;;; within the compiler. FIXME: and other IR1 transforms and stuff.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
16 ;;; We turn IDENTITY into PROG1 so that it is obvious that it just
17 ;;; returns the first value of its argument. Ditto for VALUES with one
19 (define-source-transform identity (x) `(prog1 ,x))
20 (define-source-transform values (x) `(prog1 ,x))
22 ;;; CONSTANTLY is pretty much never worth transforming, but it's good to get the type.
23 (defoptimizer (constantly derive-type) ((value))
25 `(function (&rest t) (values ,(type-specifier (lvar-type value)) &optional))))
27 ;;; If the function has a known number of arguments, then return a
28 ;;; lambda with the appropriate fixed number of args. If the
29 ;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
30 ;;; MV optimization figure things out.
31 (deftransform complement ((fun) * * :node node)
33 (multiple-value-bind (min max)
34 (fun-type-nargs (lvar-type fun))
36 ((and min (eql min max))
37 (let ((dums (make-gensym-list min)))
38 `#'(lambda ,dums (not (funcall fun ,@dums)))))
39 ((awhen (node-lvar node)
40 (let ((dest (lvar-dest it)))
41 (and (combination-p dest)
42 (eq (combination-fun dest) it))))
43 '#'(lambda (&rest args)
44 (not (apply fun args))))
46 (give-up-ir1-transform
47 "The function doesn't have a fixed argument count.")))))
50 (defun derive-symbol-value-type (lvar node)
51 (if (constant-lvar-p lvar)
52 (let* ((sym (lvar-value lvar))
53 (var (maybe-find-free-var sym))
55 (let ((*lexenv* (node-lexenv node)))
56 (lexenv-find var type-restrictions))))
57 (global-type (info :variable :type sym)))
59 (type-intersection local-type global-type)
63 (defoptimizer (symbol-value derive-type) ((symbol) node)
64 (derive-symbol-value-type symbol node))
66 (defoptimizer (symbol-global-value derive-type) ((symbol) node)
67 (derive-symbol-value-type symbol node))
71 ;;; Translate CxR into CAR/CDR combos.
72 (defun source-transform-cxr (form)
73 (if (/= (length form) 2)
75 (let* ((name (car form))
79 (leaf (leaf-source-name name))))))
80 (do ((i (- (length string) 2) (1- i))
82 `(,(ecase (char string i)
88 ;;; Make source transforms to turn CxR forms into combinations of CAR
89 ;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
91 ;;; Don't transform CAD*R, they are treated specially for &more args
94 (/show0 "about to set CxR source transforms")
95 (loop for i of-type index from 2 upto 4 do
96 ;; Iterate over BUF = all names CxR where x = an I-element
97 ;; string of #\A or #\D characters.
98 (let ((buf (make-string (+ 2 i))))
99 (setf (aref buf 0) #\C
100 (aref buf (1+ i)) #\R)
101 (dotimes (j (ash 2 i))
102 (declare (type index j))
104 (declare (type index k))
105 (setf (aref buf (1+ k))
106 (if (logbitp k j) #\A #\D)))
107 (unless (member buf '("CADR" "CADDR" "CADDDR")
109 (setf (info :function :source-transform (intern buf))
110 #'source-transform-cxr)))))
111 (/show0 "done setting CxR source transforms")
113 ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
114 ;;; whatever is right for them is right for us. FIFTH..TENTH turn into
115 ;;; Nth, which can be expanded into a CAR/CDR later on if policy
117 (define-source-transform rest (x) `(cdr ,x))
118 (define-source-transform first (x) `(car ,x))
119 (define-source-transform second (x) `(cadr ,x))
120 (define-source-transform third (x) `(caddr ,x))
121 (define-source-transform fourth (x) `(cadddr ,x))
122 (define-source-transform fifth (x) `(nth 4 ,x))
123 (define-source-transform sixth (x) `(nth 5 ,x))
124 (define-source-transform seventh (x) `(nth 6 ,x))
125 (define-source-transform eighth (x) `(nth 7 ,x))
126 (define-source-transform ninth (x) `(nth 8 ,x))
127 (define-source-transform tenth (x) `(nth 9 ,x))
129 ;;; LIST with one arg is an extremely common operation (at least inside
130 ;;; SBCL itself); translate it to CONS to take advantage of common
131 ;;; allocation routines.
132 (define-source-transform list (&rest args)
134 (1 `(cons ,(first args) nil))
137 (defoptimizer (list derive-type) ((&rest args) node)
139 (specifier-type 'cons)
140 (specifier-type 'null)))
142 ;;; And similarly for LIST*.
143 (define-source-transform list* (arg &rest others)
144 (cond ((not others) arg)
145 ((not (cdr others)) `(cons ,arg ,(car others)))
148 (defoptimizer (list* derive-type) ((arg &rest args))
150 (specifier-type 'cons)
155 (define-source-transform nconc (&rest args)
161 ;;; (append nil nil nil fixnum) => fixnum
162 ;;; (append x x cons x x) => cons
163 ;;; (append x x x x list) => list
164 ;;; (append x x x x sequence) => sequence
165 ;;; (append fixnum x ...) => nil
166 (defun derive-append-type (args)
168 (return-from derive-append-type (specifier-type 'null)))
169 (let* ((cons-type (specifier-type 'cons))
170 (null-type (specifier-type 'null))
171 (list-type (specifier-type 'list))
172 (last (lvar-type (car (last args)))))
173 ;; Derive the actual return type, assuming that all but the last
174 ;; arguments are LISTs (otherwise, APPEND/NCONC doesn't return).
175 (loop with all-nil = t ; all but the last args are NIL?
176 with some-cons = nil ; some args are conses?
177 for (arg next) on args
178 for lvar-type = (type-approx-intersection2 (lvar-type arg)
181 do (multiple-value-bind (typep definitely)
182 (ctypep nil lvar-type)
183 (cond ((type= lvar-type *empty-type*)
184 ;; type mismatch! insert an inline check that'll cause
185 ;; compile-time warnings.
186 (assert-lvar-type arg list-type
187 (lexenv-policy *lexenv*)))
188 (some-cons) ; we know result's a cons -- nothing to do
189 ((and (not typep) definitely) ; can't be NIL
190 (setf some-cons t)) ; must be a CONS
192 (setf all-nil (csubtypep lvar-type null-type)))))
194 ;; if some of the previous arguments are CONSes so is the result;
195 ;; if all the previous values are NIL, we're a fancy identity;
196 ;; otherwise, could be either
197 (return (cond (some-cons cons-type)
199 (t (type-union last cons-type)))))))
201 (defoptimizer (append derive-type) ((&rest args))
202 (derive-append-type args))
204 (defoptimizer (sb!impl::append2 derive-type) ((&rest args))
205 (derive-append-type args))
207 (defoptimizer (nconc derive-type) ((&rest args))
208 (derive-append-type args))
210 ;;; Translate RPLACx to LET and SETF.
211 (define-source-transform rplaca (x y)
216 (define-source-transform rplacd (x y)
222 (deftransform last ((list &optional n) (t &optional t))
223 (let ((c (constant-lvar-p n)))
225 (and c (eql 1 (lvar-value n))))
227 ((and c (eql 0 (lvar-value n)))
230 (let ((type (lvar-type n)))
231 (cond ((csubtypep type (specifier-type 'fixnum))
232 '(%lastn/fixnum list n))
233 ((csubtypep type (specifier-type 'bignum))
234 '(%lastn/bignum list n))
236 (give-up-ir1-transform "second argument type too vague"))))))))
238 (define-source-transform gethash (&rest args)
240 (2 `(sb!impl::gethash3 ,@args nil))
241 (3 `(sb!impl::gethash3 ,@args))
243 (define-source-transform get (&rest args)
245 (2 `(sb!impl::get2 ,@args))
246 (3 `(sb!impl::get3 ,@args))
249 (defvar *default-nthcdr-open-code-limit* 6)
250 (defvar *extreme-nthcdr-open-code-limit* 20)
252 (deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
253 "convert NTHCDR to CAxxR"
254 (unless (constant-lvar-p n)
255 (give-up-ir1-transform))
256 (let ((n (lvar-value n)))
258 (if (policy node (and (= speed 3) (= space 0)))
259 *extreme-nthcdr-open-code-limit*
260 *default-nthcdr-open-code-limit*))
261 (give-up-ir1-transform))
266 `(cdr ,(frob (1- n))))))
269 ;;;; arithmetic and numerology
271 (define-source-transform plusp (x) `(> ,x 0))
272 (define-source-transform minusp (x) `(< ,x 0))
273 (define-source-transform zerop (x) `(= ,x 0))
275 (define-source-transform 1+ (x) `(+ ,x 1))
276 (define-source-transform 1- (x) `(- ,x 1))
278 (define-source-transform oddp (x) `(logtest ,x 1))
279 (define-source-transform evenp (x) `(not (logtest ,x 1)))
281 ;;; Note that all the integer division functions are available for
282 ;;; inline expansion.
284 (macrolet ((deffrob (fun)
285 `(define-source-transform ,fun (x &optional (y nil y-p))
292 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
294 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
297 ;;; This used to be a source transform (hence the lack of restrictions
298 ;;; on the argument types), but we make it a regular transform so that
299 ;;; the VM has a chance to see the bare LOGTEST and potentiall choose
300 ;;; to implement it differently. --njf, 06-02-2006
302 ;;; Other transforms may be useful even with direct LOGTEST VOPs; let
303 ;;; them fire (including the type-directed constant folding below), but
304 ;;; disable the inlining rewrite in such cases. -- PK, 2013-05-20
305 (deftransform logtest ((x y) * * :node node)
306 (let ((type (two-arg-derive-type x y
307 #'logand-derive-type-aux
309 (multiple-value-bind (typep definitely)
311 (cond ((and (not typep) definitely)
313 ((type= type (specifier-type '(eql 0)))
315 ((neq :default (combination-implementation-style node))
316 (give-up-ir1-transform))
318 `(not (zerop (logand x y))))))))
320 (deftransform logbitp
321 ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
322 (unsigned-byte #.sb!vm:n-word-bits))))
323 `(if (>= index #.sb!vm:n-word-bits)
325 (not (zerop (logand integer (ash 1 index))))))
327 (define-source-transform byte (size position)
328 `(cons ,size ,position))
329 (define-source-transform byte-size (spec) `(car ,spec))
330 (define-source-transform byte-position (spec) `(cdr ,spec))
331 (define-source-transform ldb-test (bytespec integer)
332 `(not (zerop (mask-field ,bytespec ,integer))))
334 ;;; With the ratio and complex accessors, we pick off the "identity"
335 ;;; case, and use a primitive to handle the cell access case.
336 (define-source-transform numerator (num)
337 (once-only ((n-num `(the rational ,num)))
341 (define-source-transform denominator (num)
342 (once-only ((n-num `(the rational ,num)))
344 (%denominator ,n-num)
347 ;;;; interval arithmetic for computing bounds
349 ;;;; This is a set of routines for operating on intervals. It
350 ;;;; implements a simple interval arithmetic package. Although SBCL
351 ;;;; has an interval type in NUMERIC-TYPE, we choose to use our own
352 ;;;; for two reasons:
354 ;;;; 1. This package is simpler than NUMERIC-TYPE.
356 ;;;; 2. It makes debugging much easier because you can just strip
357 ;;;; out these routines and test them independently of SBCL. (This is a
360 ;;;; One disadvantage is a probable increase in consing because we
361 ;;;; have to create these new interval structures even though
362 ;;;; numeric-type has everything we want to know. Reason 2 wins for
365 ;;; Support operations that mimic real arithmetic comparison
366 ;;; operators, but imposing a total order on the floating points such
367 ;;; that negative zeros are strictly less than positive zeros.
368 (macrolet ((def (name op)
371 (if (and (floatp x) (floatp y) (zerop x) (zerop y))
372 (,op (float-sign x) (float-sign y))
374 (def signed-zero->= >=)
375 (def signed-zero-> >)
376 (def signed-zero-= =)
377 (def signed-zero-< <)
378 (def signed-zero-<= <=))
380 ;;; The basic interval type. It can handle open and closed intervals.
381 ;;; A bound is open if it is a list containing a number, just like
382 ;;; Lisp says. NIL means unbounded.
383 (defstruct (interval (:constructor %make-interval)
387 (defun make-interval (&key low high)
388 (labels ((normalize-bound (val)
391 (float-infinity-p val))
392 ;; Handle infinities.
396 ;; Handle any closed bounds.
399 ;; We have an open bound. Normalize the numeric
400 ;; bound. If the normalized bound is still a number
401 ;; (not nil), keep the bound open. Otherwise, the
402 ;; bound is really unbounded, so drop the openness.
403 (let ((new-val (normalize-bound (first val))))
405 ;; The bound exists, so keep it open still.
408 (error "unknown bound type in MAKE-INTERVAL")))))
409 (%make-interval :low (normalize-bound low)
410 :high (normalize-bound high))))
412 ;;; Given a number X, create a form suitable as a bound for an
413 ;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL.
414 #!-sb-fluid (declaim (inline set-bound))
415 (defun set-bound (x open-p)
416 (if (and x open-p) (list x) x))
418 ;;; Apply the function F to a bound X. If X is an open bound and the
419 ;;; function is declared strictly monotonic, then the result will be
420 ;;; open. IF X is NIL, the result is NIL.
421 (defun bound-func (f x strict)
422 (declare (type function f))
425 (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
426 ;; With these traps masked, we might get things like infinity
427 ;; or negative infinity returned. Check for this and return
428 ;; NIL to indicate unbounded.
429 (let ((y (funcall f (type-bound-number x))))
431 (float-infinity-p y))
433 (set-bound y (and strict (consp x))))))
434 ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g.
435 ;; in the course of converting a bignum to a float. Default to
437 (simple-type-error ()))))
439 (defun safe-double-coercion-p (x)
440 (or (typep x 'double-float)
441 (<= most-negative-double-float x most-positive-double-float)))
443 (defun safe-single-coercion-p (x)
444 (or (typep x 'single-float)
446 ;; Fix for bug 420, and related issues: during type derivation we often
447 ;; end up deriving types for both
449 ;; (some-op <int> <single>)
451 ;; (some-op (coerce <int> 'single-float) <single>)
453 ;; or other equivalent transformed forms. The problem with this
454 ;; is that on x86 (+ <int> <single>) is on the machine level
457 ;; (coerce (+ (coerce <int> 'double-float)
458 ;; (coerce <single> 'double-float))
461 ;; so if the result of (coerce <int> 'single-float) is not exact, the
462 ;; derived types for the transformed forms will have an empty
463 ;; intersection -- which in turn means that the compiler will conclude
464 ;; that the call never returns, and all hell breaks lose when it *does*
465 ;; return at runtime. (This affects not just +, but other operators are
468 ;; See also: SAFE-CTYPE-FOR-SINGLE-COERCION-P
470 ;; FIXME: If we ever add SSE-support for x86, this conditional needs to
473 (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
474 (integer (,most-positive-exactly-single-float-fixnum) *))))
475 (<= most-negative-single-float x most-positive-single-float))))
477 ;;; Apply a binary operator OP to two bounds X and Y. The result is
478 ;;; NIL if either is NIL. Otherwise bound is computed and the result
479 ;;; is open if either X or Y is open.
481 ;;; FIXME: only used in this file, not needed in target runtime
483 ;;; ANSI contaigon specifies coercion to floating point if one of the
484 ;;; arguments is floating point. Here we should check to be sure that
485 ;;; the other argument is within the bounds of that floating point
488 (defmacro safely-binop (op x y)
490 ((typep ,x 'double-float)
491 (when (safe-double-coercion-p ,y)
493 ((typep ,y 'double-float)
494 (when (safe-double-coercion-p ,x)
496 ((typep ,x 'single-float)
497 (when (safe-single-coercion-p ,y)
499 ((typep ,y 'single-float)
500 (when (safe-single-coercion-p ,x)
504 (defmacro bound-binop (op x y)
505 (with-unique-names (xb yb res)
507 (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
508 (let* ((,xb (type-bound-number ,x))
509 (,yb (type-bound-number ,y))
510 (,res (safely-binop ,op ,xb ,yb)))
512 (and (or (consp ,x) (consp ,y))
513 ;; Open bounds can very easily be messed up
514 ;; by FP rounding, so take care here.
517 ;; Multiplying a greater-than-zero with
518 ;; less than one can round to zero.
519 `(or (not (fp-zero-p ,res))
520 (cond ((and (consp ,x) (fp-zero-p ,xb))
522 ((and (consp ,y) (fp-zero-p ,yb))
525 ;; Dividing a greater-than-zero with
526 ;; greater than one can round to zero.
527 `(or (not (fp-zero-p ,res))
528 (cond ((and (consp ,x) (fp-zero-p ,xb))
530 ((and (consp ,y) (fp-zero-p ,yb))
533 ;; Adding or subtracting greater-than-zero
534 ;; can end up with identity.
535 `(and (not (fp-zero-p ,xb))
536 (not (fp-zero-p ,yb))))))))))))
538 (defun coercion-loses-precision-p (val type)
541 (double-float (subtypep type 'single-float))
542 (rational (subtypep type 'float))
543 (t (bug "Unexpected arguments to bounds coercion: ~S ~S" val type))))
545 (defun coerce-for-bound (val type)
547 (let ((xbound (coerce-for-bound (car val) type)))
548 (if (coercion-loses-precision-p (car val) type)
552 ((subtypep type 'double-float)
553 (if (<= most-negative-double-float val most-positive-double-float)
555 ((or (subtypep type 'single-float) (subtypep type 'float))
556 ;; coerce to float returns a single-float
557 (if (<= most-negative-single-float val most-positive-single-float)
559 (t (coerce val type)))))
561 (defun coerce-and-truncate-floats (val type)
564 (let ((xbound (coerce-for-bound (car val) type)))
565 (if (coercion-loses-precision-p (car val) type)
569 ((subtypep type 'double-float)
570 (if (<= most-negative-double-float val most-positive-double-float)
572 (if (< val most-negative-double-float)
573 most-negative-double-float most-positive-double-float)))
574 ((or (subtypep type 'single-float) (subtypep type 'float))
575 ;; coerce to float returns a single-float
576 (if (<= most-negative-single-float val most-positive-single-float)
578 (if (< val most-negative-single-float)
579 most-negative-single-float most-positive-single-float)))
580 (t (coerce val type))))))
582 ;;; Convert a numeric-type object to an interval object.
583 (defun numeric-type->interval (x)
584 (declare (type numeric-type x))
585 (make-interval :low (numeric-type-low x)
586 :high (numeric-type-high x)))
588 (defun type-approximate-interval (type)
589 (declare (type ctype type))
590 (let ((types (prepare-arg-for-derive-type type))
593 (let ((type (if (member-type-p type)
594 (convert-member-type type)
596 (unless (numeric-type-p type)
597 (return-from type-approximate-interval nil))
598 (let ((interval (numeric-type->interval type)))
601 (interval-approximate-union result interval)
605 (defun copy-interval-limit (limit)
610 (defun copy-interval (x)
611 (declare (type interval x))
612 (make-interval :low (copy-interval-limit (interval-low x))
613 :high (copy-interval-limit (interval-high x))))
615 ;;; Given a point P contained in the interval X, split X into two
616 ;;; intervals at the point P. If CLOSE-LOWER is T, then the left
617 ;;; interval contains P. If CLOSE-UPPER is T, the right interval
618 ;;; contains P. You can specify both to be T or NIL.
619 (defun interval-split (p x &optional close-lower close-upper)
620 (declare (type number p)
622 (list (make-interval :low (copy-interval-limit (interval-low x))
623 :high (if close-lower p (list p)))
624 (make-interval :low (if close-upper (list p) p)
625 :high (copy-interval-limit (interval-high x)))))
627 ;;; Return the closure of the interval. That is, convert open bounds
628 ;;; to closed bounds.
629 (defun interval-closure (x)
630 (declare (type interval x))
631 (make-interval :low (type-bound-number (interval-low x))
632 :high (type-bound-number (interval-high x))))
634 ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
635 ;;; '-. Otherwise return NIL.
636 (defun interval-range-info (x &optional (point 0))
637 (declare (type interval x))
638 (let ((lo (interval-low x))
639 (hi (interval-high x)))
640 (cond ((and lo (signed-zero->= (type-bound-number lo) point))
642 ((and hi (signed-zero->= point (type-bound-number hi)))
647 ;;; Test to see whether the interval X is bounded. HOW determines the
648 ;;; test, and should be either ABOVE, BELOW, or BOTH.
649 (defun interval-bounded-p (x how)
650 (declare (type interval x))
657 (and (interval-low x) (interval-high x)))))
659 ;;; See whether the interval X contains the number P, taking into
660 ;;; account that the interval might not be closed.
661 (defun interval-contains-p (p x)
662 (declare (type number p)
664 ;; Does the interval X contain the number P? This would be a lot
665 ;; easier if all intervals were closed!
666 (let ((lo (interval-low x))
667 (hi (interval-high x)))
669 ;; The interval is bounded
670 (if (and (signed-zero-<= (type-bound-number lo) p)
671 (signed-zero-<= p (type-bound-number hi)))
672 ;; P is definitely in the closure of the interval.
673 ;; We just need to check the end points now.
674 (cond ((signed-zero-= p (type-bound-number lo))
676 ((signed-zero-= p (type-bound-number hi))
681 ;; Interval with upper bound
682 (if (signed-zero-< p (type-bound-number hi))
684 (and (numberp hi) (signed-zero-= p hi))))
686 ;; Interval with lower bound
687 (if (signed-zero-> p (type-bound-number lo))
689 (and (numberp lo) (signed-zero-= p lo))))
691 ;; Interval with no bounds
694 ;;; Determine whether two intervals X and Y intersect. Return T if so.
695 ;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they
696 ;;; were closed. Otherwise the intervals are treated as they are.
698 ;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
699 ;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
700 ;;; is T, then they do intersect because we use the closure of X = [0,
701 ;;; 1] and Y = [1, 2] to determine intersection.
702 (defun interval-intersect-p (x y &optional closed-intervals-p)
703 (declare (type interval x y))
704 (and (interval-intersection/difference (if closed-intervals-p
707 (if closed-intervals-p
712 ;;; Are the two intervals adjacent? That is, is there a number
713 ;;; between the two intervals that is not an element of either
714 ;;; interval? If so, they are not adjacent. For example [0, 1) and
715 ;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
716 ;;; between both intervals.
717 (defun interval-adjacent-p (x y)
718 (declare (type interval x y))
719 (flet ((adjacent (lo hi)
720 ;; Check to see whether lo and hi are adjacent. If either is
721 ;; nil, they can't be adjacent.
722 (when (and lo hi (= (type-bound-number lo) (type-bound-number hi)))
723 ;; The bounds are equal. They are adjacent if one of
724 ;; them is closed (a number). If both are open (consp),
725 ;; then there is a number that lies between them.
726 (or (numberp lo) (numberp hi)))))
727 (or (adjacent (interval-low y) (interval-high x))
728 (adjacent (interval-low x) (interval-high y)))))
730 ;;; Compute the intersection and difference between two intervals.
731 ;;; Two values are returned: the intersection and the difference.
733 ;;; Let the two intervals be X and Y, and let I and D be the two
734 ;;; values returned by this function. Then I = X intersect Y. If I
735 ;;; is NIL (the empty set), then D is X union Y, represented as the
736 ;;; list of X and Y. If I is not the empty set, then D is (X union Y)
737 ;;; - I, which is a list of two intervals.
739 ;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D =
740 ;;; [-1,1) union [3,5], which is returned as a list of two intervals.
741 (defun interval-intersection/difference (x y)
742 (declare (type interval x y))
743 (let ((x-lo (interval-low x))
744 (x-hi (interval-high x))
745 (y-lo (interval-low y))
746 (y-hi (interval-high y)))
749 ;; If p is an open bound, make it closed. If p is a closed
750 ;; bound, make it open.
754 (test-number (p int bound)
755 ;; Test whether P is in the interval.
756 (let ((pn (type-bound-number p)))
757 (when (interval-contains-p pn (interval-closure int))
758 ;; Check for endpoints.
759 (let* ((lo (interval-low int))
760 (hi (interval-high int))
761 (lon (type-bound-number lo))
762 (hin (type-bound-number hi)))
764 ;; Interval may be a point.
765 ((and lon hin (= lon hin pn))
766 (and (numberp p) (numberp lo) (numberp hi)))
767 ;; Point matches the low end.
768 ;; [P] [P,?} => TRUE [P] (P,?} => FALSE
769 ;; (P [P,?} => TRUE P) [P,?} => FALSE
770 ;; (P (P,?} => TRUE P) (P,?} => FALSE
771 ((and lon (= pn lon))
772 (or (and (numberp p) (numberp lo))
773 (and (consp p) (eq :low bound))))
774 ;; [P] {?,P] => TRUE [P] {?,P) => FALSE
775 ;; P) {?,P] => TRUE (P {?,P] => FALSE
776 ;; P) {?,P) => TRUE (P {?,P) => FALSE
777 ((and hin (= pn hin))
778 (or (and (numberp p) (numberp hi))
779 (and (consp p) (eq :high bound))))
780 ;; Not an endpoint, all is well.
783 (test-lower-bound (p int)
784 ;; P is a lower bound of an interval.
786 (test-number p int :low)
787 (not (interval-bounded-p int 'below))))
788 (test-upper-bound (p int)
789 ;; P is an upper bound of an interval.
791 (test-number p int :high)
792 (not (interval-bounded-p int 'above)))))
793 (let ((x-lo-in-y (test-lower-bound x-lo y))
794 (x-hi-in-y (test-upper-bound x-hi y))
795 (y-lo-in-x (test-lower-bound y-lo x))
796 (y-hi-in-x (test-upper-bound y-hi x)))
797 (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x)
798 ;; Intervals intersect. Let's compute the intersection
799 ;; and the difference.
800 (multiple-value-bind (lo left-lo left-hi)
801 (cond (x-lo-in-y (values x-lo y-lo (opposite-bound x-lo)))
802 (y-lo-in-x (values y-lo x-lo (opposite-bound y-lo))))
803 (multiple-value-bind (hi right-lo right-hi)
805 (values x-hi (opposite-bound x-hi) y-hi))
807 (values y-hi (opposite-bound y-hi) x-hi)))
808 (values (make-interval :low lo :high hi)
809 (list (make-interval :low left-lo
811 (make-interval :low right-lo
814 (values nil (list x y))))))))
816 ;;; If intervals X and Y intersect, return a new interval that is the
817 ;;; union of the two. If they do not intersect, return NIL.
818 (defun interval-merge-pair (x y)
819 (declare (type interval x y))
820 ;; If x and y intersect or are adjacent, create the union.
821 ;; Otherwise return nil
822 (when (or (interval-intersect-p x y)
823 (interval-adjacent-p x y))
824 (flet ((select-bound (x1 x2 min-op max-op)
825 (let ((x1-val (type-bound-number x1))
826 (x2-val (type-bound-number x2)))
828 ;; Both bounds are finite. Select the right one.
829 (cond ((funcall min-op x1-val x2-val)
830 ;; x1 is definitely better.
832 ((funcall max-op x1-val x2-val)
833 ;; x2 is definitely better.
836 ;; Bounds are equal. Select either
837 ;; value and make it open only if
839 (set-bound x1-val (and (consp x1) (consp x2))))))
841 ;; At least one bound is not finite. The
842 ;; non-finite bound always wins.
844 (let* ((x-lo (copy-interval-limit (interval-low x)))
845 (x-hi (copy-interval-limit (interval-high x)))
846 (y-lo (copy-interval-limit (interval-low y)))
847 (y-hi (copy-interval-limit (interval-high y))))
848 (make-interval :low (select-bound x-lo y-lo #'< #'>)
849 :high (select-bound x-hi y-hi #'> #'<))))))
851 ;;; return the minimal interval, containing X and Y
852 (defun interval-approximate-union (x y)
853 (cond ((interval-merge-pair x y))
855 (make-interval :low (copy-interval-limit (interval-low x))
856 :high (copy-interval-limit (interval-high y))))
858 (make-interval :low (copy-interval-limit (interval-low y))
859 :high (copy-interval-limit (interval-high x))))))
861 ;;; basic arithmetic operations on intervals. We probably should do
862 ;;; true interval arithmetic here, but it's complicated because we
863 ;;; have float and integer types and bounds can be open or closed.
865 ;;; the negative of an interval
866 (defun interval-neg (x)
867 (declare (type interval x))
868 (make-interval :low (bound-func #'- (interval-high x) t)
869 :high (bound-func #'- (interval-low x) t)))
871 ;;; Add two intervals.
872 (defun interval-add (x y)
873 (declare (type interval x y))
874 (make-interval :low (bound-binop + (interval-low x) (interval-low y))
875 :high (bound-binop + (interval-high x) (interval-high y))))
877 ;;; Subtract two intervals.
878 (defun interval-sub (x y)
879 (declare (type interval x y))
880 (make-interval :low (bound-binop - (interval-low x) (interval-high y))
881 :high (bound-binop - (interval-high x) (interval-low y))))
883 ;;; Multiply two intervals.
884 (defun interval-mul (x y)
885 (declare (type interval x y))
886 (flet ((bound-mul (x y)
887 (cond ((or (null x) (null y))
888 ;; Multiply by infinity is infinity
890 ((or (and (numberp x) (zerop x))
891 (and (numberp y) (zerop y)))
892 ;; Multiply by closed zero is special. The result
893 ;; is always a closed bound. But don't replace this
894 ;; with zero; we want the multiplication to produce
895 ;; the correct signed zero, if needed. Use SIGNUM
896 ;; to avoid trying to multiply huge bignums with 0.0.
897 (* (signum (type-bound-number x)) (signum (type-bound-number y))))
898 ((or (and (floatp x) (float-infinity-p x))
899 (and (floatp y) (float-infinity-p y)))
900 ;; Infinity times anything is infinity
903 ;; General multiply. The result is open if either is open.
904 (bound-binop * x y)))))
905 (let ((x-range (interval-range-info x))
906 (y-range (interval-range-info y)))
907 (cond ((null x-range)
908 ;; Split x into two and multiply each separately
909 (destructuring-bind (x- x+) (interval-split 0 x t t)
910 (interval-merge-pair (interval-mul x- y)
911 (interval-mul x+ y))))
913 ;; Split y into two and multiply each separately
914 (destructuring-bind (y- y+) (interval-split 0 y t t)
915 (interval-merge-pair (interval-mul x y-)
916 (interval-mul x y+))))
918 (interval-neg (interval-mul (interval-neg x) y)))
920 (interval-neg (interval-mul x (interval-neg y))))
921 ((and (eq x-range '+) (eq y-range '+))
922 ;; If we are here, X and Y are both positive.
924 :low (bound-mul (interval-low x) (interval-low y))
925 :high (bound-mul (interval-high x) (interval-high y))))
927 (bug "excluded case in INTERVAL-MUL"))))))
929 ;;; Divide two intervals.
930 (defun interval-div (top bot)
931 (declare (type interval top bot))
932 (flet ((bound-div (x y y-low-p)
935 ;; Divide by infinity means result is 0. However,
936 ;; we need to watch out for the sign of the result,
937 ;; to correctly handle signed zeros. We also need
938 ;; to watch out for positive or negative infinity.
939 (if (floatp (type-bound-number x))
941 (- (float-sign (type-bound-number x) 0.0))
942 (float-sign (type-bound-number x) 0.0))
944 ((zerop (type-bound-number y))
945 ;; Divide by zero means result is infinity
948 (bound-binop / x y)))))
949 (let ((top-range (interval-range-info top))
950 (bot-range (interval-range-info bot)))
951 (cond ((null bot-range)
952 ;; The denominator contains zero, so anything goes!
953 (make-interval :low nil :high nil))
955 ;; Denominator is negative so flip the sign, compute the
956 ;; result, and flip it back.
957 (interval-neg (interval-div top (interval-neg bot))))
959 ;; Split top into two positive and negative parts, and
960 ;; divide each separately
961 (destructuring-bind (top- top+) (interval-split 0 top t t)
962 (interval-merge-pair (interval-div top- bot)
963 (interval-div top+ bot))))
965 ;; Top is negative so flip the sign, divide, and flip the
966 ;; sign of the result.
967 (interval-neg (interval-div (interval-neg top) bot)))
968 ((and (eq top-range '+) (eq bot-range '+))
971 :low (bound-div (interval-low top) (interval-high bot) t)
972 :high (bound-div (interval-high top) (interval-low bot) nil)))
974 (bug "excluded case in INTERVAL-DIV"))))))
976 ;;; Apply the function F to the interval X. If X = [a, b], then the
977 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
978 ;;; result makes sense. It will if F is monotonic increasing (or, if
979 ;;; the interval is closed, non-decreasing).
981 ;;; (Actually most uses of INTERVAL-FUNC are coercions to float types,
982 ;;; which are not monotonic increasing, so default to calling
983 ;;; BOUND-FUNC with a non-strict argument).
984 (defun interval-func (f x &optional increasing)
985 (declare (type function f)
987 (let ((lo (bound-func f (interval-low x) increasing))
988 (hi (bound-func f (interval-high x) increasing)))
989 (make-interval :low lo :high hi)))
991 ;;; Return T if X < Y. That is every number in the interval X is
992 ;;; always less than any number in the interval Y.
993 (defun interval-< (x y)
994 (declare (type interval x y))
995 ;; X < Y only if X is bounded above, Y is bounded below, and they
997 (when (and (interval-bounded-p x 'above)
998 (interval-bounded-p y 'below))
999 ;; Intervals are bounded in the appropriate way. Make sure they
1001 (let ((left (interval-high x))
1002 (right (interval-low y)))
1003 (cond ((> (type-bound-number left)
1004 (type-bound-number right))
1005 ;; The intervals definitely overlap, so result is NIL.
1007 ((< (type-bound-number left)
1008 (type-bound-number right))
1009 ;; The intervals definitely don't touch, so result is T.
1012 ;; Limits are equal. Check for open or closed bounds.
1013 ;; Don't overlap if one or the other are open.
1014 (or (consp left) (consp right)))))))
1016 ;;; Return T if X >= Y. That is, every number in the interval X is
1017 ;;; always greater than any number in the interval Y.
1018 (defun interval->= (x y)
1019 (declare (type interval x y))
1020 ;; X >= Y if lower bound of X >= upper bound of Y
1021 (when (and (interval-bounded-p x 'below)
1022 (interval-bounded-p y 'above))
1023 (>= (type-bound-number (interval-low x))
1024 (type-bound-number (interval-high y)))))
1026 ;;; Return T if X = Y.
1027 (defun interval-= (x y)
1028 (declare (type interval x y))
1029 (and (interval-bounded-p x 'both)
1030 (interval-bounded-p y 'both)
1034 ;; Open intervals cannot be =
1035 (return-from interval-= nil))))
1036 ;; Both intervals refer to the same point
1037 (= (bound (interval-high x)) (bound (interval-low x))
1038 (bound (interval-high y)) (bound (interval-low y))))))
1040 ;;; Return T if X /= Y
1041 (defun interval-/= (x y)
1042 (not (interval-intersect-p x y)))
1044 ;;; Return an interval that is the absolute value of X. Thus, if
1045 ;;; X = [-1 10], the result is [0, 10].
1046 (defun interval-abs (x)
1047 (declare (type interval x))
1048 (case (interval-range-info x)
1054 (destructuring-bind (x- x+) (interval-split 0 x t t)
1055 (interval-merge-pair (interval-neg x-) x+)))))
1057 ;;; Compute the square of an interval.
1058 (defun interval-sqr (x)
1059 (declare (type interval x))
1060 (interval-func (lambda (x) (* x x)) (interval-abs x)))
1062 ;;;; numeric DERIVE-TYPE methods
1064 ;;; a utility for defining derive-type methods of integer operations. If
1065 ;;; the types of both X and Y are integer types, then we compute a new
1066 ;;; integer type with bounds determined by FUN when applied to X and Y.
1067 ;;; Otherwise, we use NUMERIC-CONTAGION.
1068 (defun derive-integer-type-aux (x y fun)
1069 (declare (type function fun))
1070 (if (and (numeric-type-p x) (numeric-type-p y)
1071 (eq (numeric-type-class x) 'integer)
1072 (eq (numeric-type-class y) 'integer)
1073 (eq (numeric-type-complexp x) :real)
1074 (eq (numeric-type-complexp y) :real))
1075 (multiple-value-bind (low high) (funcall fun x y)
1076 (make-numeric-type :class 'integer
1080 (numeric-contagion x y)))
1082 (defun derive-integer-type (x y fun)
1083 (declare (type lvar x y) (type function fun))
1084 (let ((x (lvar-type x))
1086 (derive-integer-type-aux x y fun)))
1088 ;;; simple utility to flatten a list
1089 (defun flatten-list (x)
1090 (labels ((flatten-and-append (tree list)
1091 (cond ((null tree) list)
1092 ((atom tree) (cons tree list))
1093 (t (flatten-and-append
1094 (car tree) (flatten-and-append (cdr tree) list))))))
1095 (flatten-and-append x nil)))
1097 ;;; Take some type of lvar and massage it so that we get a list of the
1098 ;;; constituent types. If ARG is *EMPTY-TYPE*, return NIL to indicate
1100 (defun prepare-arg-for-derive-type (arg)
1101 (flet ((listify (arg)
1106 (union-type-types arg))
1109 (unless (eq arg *empty-type*)
1110 ;; Make sure all args are some type of numeric-type. For member
1111 ;; types, convert the list of members into a union of equivalent
1112 ;; single-element member-type's.
1113 (let ((new-args nil))
1114 (dolist (arg (listify arg))
1115 (if (member-type-p arg)
1116 ;; Run down the list of members and convert to a list of
1118 (mapc-member-type-members
1120 (push (if (numberp member)
1121 (make-member-type :members (list member))
1125 (push arg new-args)))
1126 (unless (member *empty-type* new-args)
1129 ;;; Convert from the standard type convention for which -0.0 and 0.0
1130 ;;; are equal to an intermediate convention for which they are
1131 ;;; considered different which is more natural for some of the
1133 (defun convert-numeric-type (type)
1134 (declare (type numeric-type type))
1135 ;;; Only convert real float interval delimiters types.
1136 (if (eq (numeric-type-complexp type) :real)
1137 (let* ((lo (numeric-type-low type))
1138 (lo-val (type-bound-number lo))
1139 (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0)))
1140 (hi (numeric-type-high type))
1141 (hi-val (type-bound-number hi))
1142 (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0))))
1143 (if (or lo-float-zero-p hi-float-zero-p)
1145 :class (numeric-type-class type)
1146 :format (numeric-type-format type)
1148 :low (if lo-float-zero-p
1150 (list (float 0.0 lo-val))
1151 (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val))
1153 :high (if hi-float-zero-p
1155 (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val))
1162 ;;; Convert back from the intermediate convention for which -0.0 and
1163 ;;; 0.0 are considered different to the standard type convention for
1164 ;;; which and equal.
1165 (defun convert-back-numeric-type (type)
1166 (declare (type numeric-type type))
1167 ;;; Only convert real float interval delimiters types.
1168 (if (eq (numeric-type-complexp type) :real)
1169 (let* ((lo (numeric-type-low type))
1170 (lo-val (type-bound-number lo))
1172 (and lo (floatp lo-val) (= lo-val 0.0)
1173 (float-sign lo-val)))
1174 (hi (numeric-type-high type))
1175 (hi-val (type-bound-number hi))
1177 (and hi (floatp hi-val) (= hi-val 0.0)
1178 (float-sign hi-val))))
1180 ;; (float +0.0 +0.0) => (member 0.0)
1181 ;; (float -0.0 -0.0) => (member -0.0)
1182 ((and lo-float-zero-p hi-float-zero-p)
1183 ;; shouldn't have exclusive bounds here..
1184 (aver (and (not (consp lo)) (not (consp hi))))
1185 (if (= lo-float-zero-p hi-float-zero-p)
1186 ;; (float +0.0 +0.0) => (member 0.0)
1187 ;; (float -0.0 -0.0) => (member -0.0)
1188 (specifier-type `(member ,lo-val))
1189 ;; (float -0.0 +0.0) => (float 0.0 0.0)
1190 ;; (float +0.0 -0.0) => (float 0.0 0.0)
1191 (make-numeric-type :class (numeric-type-class type)
1192 :format (numeric-type-format type)
1198 ;; (float -0.0 x) => (float 0.0 x)
1199 ((and (not (consp lo)) (minusp lo-float-zero-p))
1200 (make-numeric-type :class (numeric-type-class type)
1201 :format (numeric-type-format type)
1203 :low (float 0.0 lo-val)
1205 ;; (float (+0.0) x) => (float (0.0) x)
1206 ((and (consp lo) (plusp lo-float-zero-p))
1207 (make-numeric-type :class (numeric-type-class type)
1208 :format (numeric-type-format type)
1210 :low (list (float 0.0 lo-val))
1213 ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
1214 ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
1215 (list (make-member-type :members (list (float 0.0 lo-val)))
1216 (make-numeric-type :class (numeric-type-class type)
1217 :format (numeric-type-format type)
1219 :low (list (float 0.0 lo-val))
1223 ;; (float x +0.0) => (float x 0.0)
1224 ((and (not (consp hi)) (plusp hi-float-zero-p))
1225 (make-numeric-type :class (numeric-type-class type)
1226 :format (numeric-type-format type)
1229 :high (float 0.0 hi-val)))
1230 ;; (float x (-0.0)) => (float x (0.0))
1231 ((and (consp hi) (minusp hi-float-zero-p))
1232 (make-numeric-type :class (numeric-type-class type)
1233 :format (numeric-type-format type)
1236 :high (list (float 0.0 hi-val))))
1238 ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
1239 ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
1240 (list (make-member-type :members (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)))
1241 (make-numeric-type :class (numeric-type-class type)
1242 :format (numeric-type-format type)
1245 :high (list (float 0.0 hi-val)))))))
1251 ;;; Convert back a possible list of numeric types.
1252 (defun convert-back-numeric-type-list (type-list)
1255 (let ((results '()))
1256 (dolist (type type-list)
1257 (if (numeric-type-p type)
1258 (let ((result (convert-back-numeric-type type)))
1260 (setf results (append results result))
1261 (push result results)))
1262 (push type results)))
1265 (convert-back-numeric-type type-list))
1267 (convert-back-numeric-type-list (union-type-types type-list)))
1271 ;;; Take a list of types and return a canonical type specifier,
1272 ;;; combining any MEMBER types together. If both positive and negative
1273 ;;; MEMBER types are present they are converted to a float type.
1274 ;;; XXX This would be far simpler if the type-union methods could handle
1275 ;;; member/number unions.
1277 ;;; If we're about to generate an overly complex union of numeric types, start
1278 ;;; collapse the ranges together.
1280 ;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
1281 ;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
1282 ;;; invoked always, instead of in the compiler, invoked only during some type
1284 (defvar *derived-numeric-union-complexity-limit* 6)
1286 (defun make-derived-union-type (type-list)
1287 (let ((xset (alloc-xset))
1290 (numeric-type *empty-type*))
1291 (dolist (type type-list)
1292 (cond ((member-type-p type)
1293 (mapc-member-type-members
1295 (if (fp-zero-p member)
1296 (unless (member member fp-zeroes)
1297 (pushnew member fp-zeroes))
1298 (add-to-xset member xset)))
1300 ((numeric-type-p type)
1301 (let ((*approximate-numeric-unions*
1302 (when (and (union-type-p numeric-type)
1303 (nthcdr *derived-numeric-union-complexity-limit*
1304 (union-type-types numeric-type)))
1306 (setf numeric-type (type-union type numeric-type))))
1308 (push type misc-types))))
1309 (if (and (xset-empty-p xset) (not fp-zeroes))
1310 (apply #'type-union numeric-type misc-types)
1311 (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes)
1312 numeric-type misc-types))))
1314 ;;; Convert a member type with a single member to a numeric type.
1315 (defun convert-member-type (arg)
1316 (let* ((members (member-type-members arg))
1317 (member (first members))
1318 (member-type (type-of member)))
1319 (aver (not (rest members)))
1320 (specifier-type (cond ((typep member 'integer)
1321 `(integer ,member ,member))
1322 ((memq member-type '(short-float single-float
1323 double-float long-float))
1324 `(,member-type ,member ,member))
1328 ;;; This is used in defoptimizers for computing the resulting type of
1331 ;;; Given the lvar ARG, derive the resulting type using the
1332 ;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
1333 ;;; "atomic" lvar type like numeric-type or member-type (containing
1334 ;;; just one element). It should return the resulting type, which can
1335 ;;; be a list of types.
1337 ;;; For the case of member types, if a MEMBER-FUN is given it is
1338 ;;; called to compute the result otherwise the member type is first
1339 ;;; converted to a numeric type and the DERIVE-FUN is called.
1340 (defun one-arg-derive-type (arg derive-fun member-fun
1341 &optional (convert-type t))
1342 (declare (type function derive-fun)
1343 (type (or null function) member-fun))
1344 (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg))))
1350 (with-float-traps-masked
1351 (:underflow :overflow :divide-by-zero)
1353 `(eql ,(funcall member-fun
1354 (first (member-type-members x))))))
1355 ;; Otherwise convert to a numeric type.
1356 (let ((result-type-list
1357 (funcall derive-fun (convert-member-type x))))
1359 (convert-back-numeric-type-list result-type-list)
1360 result-type-list))))
1363 (convert-back-numeric-type-list
1364 (funcall derive-fun (convert-numeric-type x)))
1365 (funcall derive-fun x)))
1367 *universal-type*))))
1368 ;; Run down the list of args and derive the type of each one,
1369 ;; saving all of the results in a list.
1370 (let ((results nil))
1371 (dolist (arg arg-list)
1372 (let ((result (deriver arg)))
1374 (setf results (append results result))
1375 (push result results))))
1377 (make-derived-union-type results)
1378 (first results)))))))
1380 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
1381 ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
1382 ;;; original args and a third which is T to indicate if the two args
1383 ;;; really represent the same lvar. This is useful for deriving the
1384 ;;; type of things like (* x x), which should always be positive. If
1385 ;;; we didn't do this, we wouldn't be able to tell.
1386 (defun two-arg-derive-type (arg1 arg2 derive-fun fun
1387 &optional (convert-type t))
1388 (declare (type function derive-fun fun))
1389 (flet ((deriver (x y same-arg)
1390 (cond ((and (member-type-p x) (member-type-p y))
1391 (let* ((x (first (member-type-members x)))
1392 (y (first (member-type-members y)))
1393 (result (ignore-errors
1394 (with-float-traps-masked
1395 (:underflow :overflow :divide-by-zero
1397 (funcall fun x y)))))
1398 (cond ((null result) *empty-type*)
1399 ((and (floatp result) (float-nan-p result))
1400 (make-numeric-type :class 'float
1401 :format (type-of result)
1404 (specifier-type `(eql ,result))))))
1405 ((and (member-type-p x) (numeric-type-p y))
1406 (let* ((x (convert-member-type x))
1407 (y (if convert-type (convert-numeric-type y) y))
1408 (result (funcall derive-fun x y same-arg)))
1410 (convert-back-numeric-type-list result)
1412 ((and (numeric-type-p x) (member-type-p y))
1413 (let* ((x (if convert-type (convert-numeric-type x) x))
1414 (y (convert-member-type y))
1415 (result (funcall derive-fun x y same-arg)))
1417 (convert-back-numeric-type-list result)
1419 ((and (numeric-type-p x) (numeric-type-p y))
1420 (let* ((x (if convert-type (convert-numeric-type x) x))
1421 (y (if convert-type (convert-numeric-type y) y))
1422 (result (funcall derive-fun x y same-arg)))
1424 (convert-back-numeric-type-list result)
1427 *universal-type*))))
1428 (let ((same-arg (same-leaf-ref-p arg1 arg2))
1429 (a1 (prepare-arg-for-derive-type (lvar-type arg1)))
1430 (a2 (prepare-arg-for-derive-type (lvar-type arg2))))
1432 (let ((results nil))
1434 ;; Since the args are the same LVARs, just run down the
1437 (let ((result (deriver x x same-arg)))
1439 (setf results (append results result))
1440 (push result results))))
1441 ;; Try all pairwise combinations.
1444 (let ((result (or (deriver x y same-arg)
1445 (numeric-contagion x y))))
1447 (setf results (append results result))
1448 (push result results))))))
1450 (make-derived-union-type results)
1451 (first results)))))))
1453 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1455 (defoptimizer (+ derive-type) ((x y))
1456 (derive-integer-type
1463 (values (frob (numeric-type-low x) (numeric-type-low y))
1464 (frob (numeric-type-high x) (numeric-type-high y)))))))
1466 (defoptimizer (- derive-type) ((x y))
1467 (derive-integer-type
1474 (values (frob (numeric-type-low x) (numeric-type-high y))
1475 (frob (numeric-type-high x) (numeric-type-low y)))))))
1477 (defoptimizer (* derive-type) ((x y))
1478 (derive-integer-type
1481 (let ((x-low (numeric-type-low x))
1482 (x-high (numeric-type-high x))
1483 (y-low (numeric-type-low y))
1484 (y-high (numeric-type-high y)))
1485 (cond ((not (and x-low y-low))
1487 ((or (minusp x-low) (minusp y-low))
1488 (if (and x-high y-high)
1489 (let ((max (* (max (abs x-low) (abs x-high))
1490 (max (abs y-low) (abs y-high)))))
1491 (values (- max) max))
1494 (values (* x-low y-low)
1495 (if (and x-high y-high)
1499 (defoptimizer (/ derive-type) ((x y))
1500 (numeric-contagion (lvar-type x) (lvar-type y)))
1504 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1506 (defun +-derive-type-aux (x y same-arg)
1507 (if (and (numeric-type-real-p x)
1508 (numeric-type-real-p y))
1511 (let ((x-int (numeric-type->interval x)))
1512 (interval-add x-int x-int))
1513 (interval-add (numeric-type->interval x)
1514 (numeric-type->interval y))))
1515 (result-type (numeric-contagion x y)))
1516 ;; If the result type is a float, we need to be sure to coerce
1517 ;; the bounds into the correct type.
1518 (when (eq (numeric-type-class result-type) 'float)
1519 (setf result (interval-func
1521 (coerce-for-bound x (or (numeric-type-format result-type)
1525 :class (if (and (eq (numeric-type-class x) 'integer)
1526 (eq (numeric-type-class y) 'integer))
1527 ;; The sum of integers is always an integer.
1529 (numeric-type-class result-type))
1530 :format (numeric-type-format result-type)
1531 :low (interval-low result)
1532 :high (interval-high result)))
1533 ;; general contagion
1534 (numeric-contagion x y)))
1536 (defoptimizer (+ derive-type) ((x y))
1537 (two-arg-derive-type x y #'+-derive-type-aux #'+))
1539 (defun --derive-type-aux (x y same-arg)
1540 (if (and (numeric-type-real-p x)
1541 (numeric-type-real-p y))
1543 ;; (- X X) is always 0.
1545 (make-interval :low 0 :high 0)
1546 (interval-sub (numeric-type->interval x)
1547 (numeric-type->interval y))))
1548 (result-type (numeric-contagion x y)))
1549 ;; If the result type is a float, we need to be sure to coerce
1550 ;; the bounds into the correct type.
1551 (when (eq (numeric-type-class result-type) 'float)
1552 (setf result (interval-func
1554 (coerce-for-bound x (or (numeric-type-format result-type)
1558 :class (if (and (eq (numeric-type-class x) 'integer)
1559 (eq (numeric-type-class y) 'integer))
1560 ;; The difference of integers is always an integer.
1562 (numeric-type-class result-type))
1563 :format (numeric-type-format result-type)
1564 :low (interval-low result)
1565 :high (interval-high result)))
1566 ;; general contagion
1567 (numeric-contagion x y)))
1569 (defoptimizer (- derive-type) ((x y))
1570 (two-arg-derive-type x y #'--derive-type-aux #'-))
1572 (defun *-derive-type-aux (x y same-arg)
1573 (if (and (numeric-type-real-p x)
1574 (numeric-type-real-p y))
1576 ;; (* X X) is always positive, so take care to do it right.
1578 (interval-sqr (numeric-type->interval x))
1579 (interval-mul (numeric-type->interval x)
1580 (numeric-type->interval y))))
1581 (result-type (numeric-contagion x y)))
1582 ;; If the result type is a float, we need to be sure to coerce
1583 ;; the bounds into the correct type.
1584 (when (eq (numeric-type-class result-type) 'float)
1585 (setf result (interval-func
1587 (coerce-for-bound x (or (numeric-type-format result-type)
1591 :class (if (and (eq (numeric-type-class x) 'integer)
1592 (eq (numeric-type-class y) 'integer))
1593 ;; The product of integers is always an integer.
1595 (numeric-type-class result-type))
1596 :format (numeric-type-format result-type)
1597 :low (interval-low result)
1598 :high (interval-high result)))
1599 (numeric-contagion x y)))
1601 (defoptimizer (* derive-type) ((x y))
1602 (two-arg-derive-type x y #'*-derive-type-aux #'*))
1604 (defun /-derive-type-aux (x y same-arg)
1605 (if (and (numeric-type-real-p x)
1606 (numeric-type-real-p y))
1608 ;; (/ X X) is always 1, except if X can contain 0. In
1609 ;; that case, we shouldn't optimize the division away
1610 ;; because we want 0/0 to signal an error.
1612 (not (interval-contains-p
1613 0 (interval-closure (numeric-type->interval y)))))
1614 (make-interval :low 1 :high 1)
1615 (interval-div (numeric-type->interval x)
1616 (numeric-type->interval y))))
1617 (result-type (numeric-contagion x y)))
1618 ;; If the result type is a float, we need to be sure to coerce
1619 ;; the bounds into the correct type.
1620 (when (eq (numeric-type-class result-type) 'float)
1621 (setf result (interval-func
1623 (coerce-for-bound x (or (numeric-type-format result-type)
1626 (make-numeric-type :class (numeric-type-class result-type)
1627 :format (numeric-type-format result-type)
1628 :low (interval-low result)
1629 :high (interval-high result)))
1630 (numeric-contagion x y)))
1632 (defoptimizer (/ derive-type) ((x y))
1633 (two-arg-derive-type x y #'/-derive-type-aux #'/))
1637 (defun ash-derive-type-aux (n-type shift same-arg)
1638 (declare (ignore same-arg))
1639 ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
1640 ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
1641 ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
1642 ;; two bignums yielding zero) and it's hard to avoid that
1643 ;; calculation in here.
1644 #+(and cmu sb-xc-host)
1645 (when (and (or (typep (numeric-type-low n-type) 'bignum)
1646 (typep (numeric-type-high n-type) 'bignum))
1647 (or (typep (numeric-type-low shift) 'bignum)
1648 (typep (numeric-type-high shift) 'bignum)))
1649 (return-from ash-derive-type-aux *universal-type*))
1650 (flet ((ash-outer (n s)
1651 (when (and (fixnump s)
1653 (> s sb!xc:most-negative-fixnum))
1655 ;; KLUDGE: The bare 64's here should be related to
1656 ;; symbolic machine word size values somehow.
1659 (if (and (fixnump s)
1660 (> s sb!xc:most-negative-fixnum))
1662 (if (minusp n) -1 0))))
1663 (or (and (csubtypep n-type (specifier-type 'integer))
1664 (csubtypep shift (specifier-type 'integer))
1665 (let ((n-low (numeric-type-low n-type))
1666 (n-high (numeric-type-high n-type))
1667 (s-low (numeric-type-low shift))
1668 (s-high (numeric-type-high shift)))
1669 (make-numeric-type :class 'integer :complexp :real
1672 (ash-outer n-low s-high)
1673 (ash-inner n-low s-low)))
1676 (ash-inner n-high s-low)
1677 (ash-outer n-high s-high))))))
1680 (defoptimizer (ash derive-type) ((n shift))
1681 (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
1683 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1684 (macrolet ((frob (fun)
1685 `#'(lambda (type type2)
1686 (declare (ignore type2))
1687 (let ((lo (numeric-type-low type))
1688 (hi (numeric-type-high type)))
1689 (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
1691 (defoptimizer (%negate derive-type) ((num))
1692 (derive-integer-type num num (frob -))))
1694 (defun lognot-derive-type-aux (int)
1695 (derive-integer-type-aux int int
1696 (lambda (type type2)
1697 (declare (ignore type2))
1698 (let ((lo (numeric-type-low type))
1699 (hi (numeric-type-high type)))
1700 (values (if hi (lognot hi) nil)
1701 (if lo (lognot lo) nil)
1702 (numeric-type-class type)
1703 (numeric-type-format type))))))
1705 (defoptimizer (lognot derive-type) ((int))
1706 (lognot-derive-type-aux (lvar-type int)))
1708 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1709 (defoptimizer (%negate derive-type) ((num))
1710 (flet ((negate-bound (b)
1712 (set-bound (- (type-bound-number b))
1714 (one-arg-derive-type num
1716 (modified-numeric-type
1718 :low (negate-bound (numeric-type-high type))
1719 :high (negate-bound (numeric-type-low type))))
1722 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1723 (defoptimizer (abs derive-type) ((num))
1724 (let ((type (lvar-type num)))
1725 (if (and (numeric-type-p type)
1726 (eq (numeric-type-class type) 'integer)
1727 (eq (numeric-type-complexp type) :real))
1728 (let ((lo (numeric-type-low type))
1729 (hi (numeric-type-high type)))
1730 (make-numeric-type :class 'integer :complexp :real
1731 :low (cond ((and hi (minusp hi))
1737 :high (if (and hi lo)
1738 (max (abs hi) (abs lo))
1740 (numeric-contagion type type))))
1742 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1743 (defun abs-derive-type-aux (type)
1744 (cond ((eq (numeric-type-complexp type) :complex)
1745 ;; The absolute value of a complex number is always a
1746 ;; non-negative float.
1747 (let* ((format (case (numeric-type-class type)
1748 ((integer rational) 'single-float)
1749 (t (numeric-type-format type))))
1750 (bound-format (or format 'float)))
1751 (make-numeric-type :class 'float
1754 :low (coerce 0 bound-format)
1757 ;; The absolute value of a real number is a non-negative real
1758 ;; of the same type.
1759 (let* ((abs-bnd (interval-abs (numeric-type->interval type)))
1760 (class (numeric-type-class type))
1761 (format (numeric-type-format type))
1762 (bound-type (or format class 'real)))
1767 :low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type)
1768 :high (coerce-and-truncate-floats
1769 (interval-high abs-bnd) bound-type))))))
1771 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1772 (defoptimizer (abs derive-type) ((num))
1773 (one-arg-derive-type num #'abs-derive-type-aux #'abs))
1775 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1776 (defoptimizer (truncate derive-type) ((number divisor))
1777 (let ((number-type (lvar-type number))
1778 (divisor-type (lvar-type divisor))
1779 (integer-type (specifier-type 'integer)))
1780 (if (and (numeric-type-p number-type)
1781 (csubtypep number-type integer-type)
1782 (numeric-type-p divisor-type)
1783 (csubtypep divisor-type integer-type))
1784 (let ((number-low (numeric-type-low number-type))
1785 (number-high (numeric-type-high number-type))
1786 (divisor-low (numeric-type-low divisor-type))
1787 (divisor-high (numeric-type-high divisor-type)))
1788 (values-specifier-type
1789 `(values ,(integer-truncate-derive-type number-low number-high
1790 divisor-low divisor-high)
1791 ,(integer-rem-derive-type number-low number-high
1792 divisor-low divisor-high))))
1795 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1798 (defun rem-result-type (number-type divisor-type)
1799 ;; Figure out what the remainder type is. The remainder is an
1800 ;; integer if both args are integers; a rational if both args are
1801 ;; rational; and a float otherwise.
1802 (cond ((and (csubtypep number-type (specifier-type 'integer))
1803 (csubtypep divisor-type (specifier-type 'integer)))
1805 ((and (csubtypep number-type (specifier-type 'rational))
1806 (csubtypep divisor-type (specifier-type 'rational)))
1808 ((and (csubtypep number-type (specifier-type 'float))
1809 (csubtypep divisor-type (specifier-type 'float)))
1810 ;; Both are floats so the result is also a float, of
1811 ;; the largest type.
1812 (or (float-format-max (numeric-type-format number-type)
1813 (numeric-type-format divisor-type))
1815 ((and (csubtypep number-type (specifier-type 'float))
1816 (csubtypep divisor-type (specifier-type 'rational)))
1817 ;; One of the arguments is a float and the other is a
1818 ;; rational. The remainder is a float of the same
1820 (or (numeric-type-format number-type) 'float))
1821 ((and (csubtypep divisor-type (specifier-type 'float))
1822 (csubtypep number-type (specifier-type 'rational)))
1823 ;; One of the arguments is a float and the other is a
1824 ;; rational. The remainder is a float of the same
1826 (or (numeric-type-format divisor-type) 'float))
1828 ;; Some unhandled combination. This usually means both args
1829 ;; are REAL so the result is a REAL.
1832 (defun truncate-derive-type-quot (number-type divisor-type)
1833 (let* ((rem-type (rem-result-type number-type divisor-type))
1834 (number-interval (numeric-type->interval number-type))
1835 (divisor-interval (numeric-type->interval divisor-type)))
1836 ;;(declare (type (member '(integer rational float)) rem-type))
1837 ;; We have real numbers now.
1838 (cond ((eq rem-type 'integer)
1839 ;; Since the remainder type is INTEGER, both args are
1841 (let* ((res (integer-truncate-derive-type
1842 (interval-low number-interval)
1843 (interval-high number-interval)
1844 (interval-low divisor-interval)
1845 (interval-high divisor-interval))))
1846 (specifier-type (if (listp res) res 'integer))))
1848 (let ((quot (truncate-quotient-bound
1849 (interval-div number-interval
1850 divisor-interval))))
1851 (specifier-type `(integer ,(or (interval-low quot) '*)
1852 ,(or (interval-high quot) '*))))))))
1854 (defun truncate-derive-type-rem (number-type divisor-type)
1855 (let* ((rem-type (rem-result-type number-type divisor-type))
1856 (number-interval (numeric-type->interval number-type))
1857 (divisor-interval (numeric-type->interval divisor-type))
1858 (rem (truncate-rem-bound number-interval divisor-interval)))
1859 ;;(declare (type (member '(integer rational float)) rem-type))
1860 ;; We have real numbers now.
1861 (cond ((eq rem-type 'integer)
1862 ;; Since the remainder type is INTEGER, both args are
1864 (specifier-type `(,rem-type ,(or (interval-low rem) '*)
1865 ,(or (interval-high rem) '*))))
1867 (multiple-value-bind (class format)
1870 (values 'integer nil))
1872 (values 'rational nil))
1873 ((or single-float double-float #!+long-float long-float)
1874 (values 'float rem-type))
1876 (values 'float nil))
1879 (when (member rem-type '(float single-float double-float
1880 #!+long-float long-float))
1881 (setf rem (interval-func #'(lambda (x)
1882 (coerce-for-bound x rem-type))
1884 (make-numeric-type :class class
1886 :low (interval-low rem)
1887 :high (interval-high rem)))))))
1889 (defun truncate-derive-type-quot-aux (num div same-arg)
1890 (declare (ignore same-arg))
1891 (if (and (numeric-type-real-p num)
1892 (numeric-type-real-p div))
1893 (truncate-derive-type-quot num div)
1896 (defun truncate-derive-type-rem-aux (num div same-arg)
1897 (declare (ignore same-arg))
1898 (if (and (numeric-type-real-p num)
1899 (numeric-type-real-p div))
1900 (truncate-derive-type-rem num div)
1903 (defoptimizer (truncate derive-type) ((number divisor))
1904 (let ((quot (two-arg-derive-type number divisor
1905 #'truncate-derive-type-quot-aux #'truncate))
1906 (rem (two-arg-derive-type number divisor
1907 #'truncate-derive-type-rem-aux #'rem)))
1908 (when (and quot rem)
1909 (make-values-type :required (list quot rem)))))
1911 (defun ftruncate-derive-type-quot (number-type divisor-type)
1912 ;; The bounds are the same as for truncate. However, the first
1913 ;; result is a float of some type. We need to determine what that
1914 ;; type is. Basically it's the more contagious of the two types.
1915 (let ((q-type (truncate-derive-type-quot number-type divisor-type))
1916 (res-type (numeric-contagion number-type divisor-type)))
1917 (make-numeric-type :class 'float
1918 :format (numeric-type-format res-type)
1919 :low (numeric-type-low q-type)
1920 :high (numeric-type-high q-type))))
1922 (defun ftruncate-derive-type-quot-aux (n d same-arg)
1923 (declare (ignore same-arg))
1924 (if (and (numeric-type-real-p n)
1925 (numeric-type-real-p d))
1926 (ftruncate-derive-type-quot n d)
1929 (defoptimizer (ftruncate derive-type) ((number divisor))
1931 (two-arg-derive-type number divisor
1932 #'ftruncate-derive-type-quot-aux #'ftruncate))
1933 (rem (two-arg-derive-type number divisor
1934 #'truncate-derive-type-rem-aux #'rem)))
1935 (when (and quot rem)
1936 (make-values-type :required (list quot rem)))))
1938 (defun %unary-truncate-derive-type-aux (number)
1939 (truncate-derive-type-quot number (specifier-type '(integer 1 1))))
1941 (defoptimizer (%unary-truncate derive-type) ((number))
1942 (one-arg-derive-type number
1943 #'%unary-truncate-derive-type-aux
1946 (defoptimizer (%unary-truncate/single-float derive-type) ((number))
1947 (one-arg-derive-type number
1948 #'%unary-truncate-derive-type-aux
1951 (defoptimizer (%unary-truncate/double-float derive-type) ((number))
1952 (one-arg-derive-type number
1953 #'%unary-truncate-derive-type-aux
1956 (defoptimizer (%unary-ftruncate derive-type) ((number))
1957 (let ((divisor (specifier-type '(integer 1 1))))
1958 (one-arg-derive-type number
1960 (ftruncate-derive-type-quot-aux n divisor nil))
1961 #'%unary-ftruncate)))
1963 (defoptimizer (%unary-round derive-type) ((number))
1964 (one-arg-derive-type number
1967 (unless (numeric-type-real-p n)
1968 (return *empty-type*))
1969 (let* ((interval (numeric-type->interval n))
1970 (low (interval-low interval))
1971 (high (interval-high interval)))
1973 (setf low (car low)))
1975 (setf high (car high)))
1985 ;;; Define optimizers for FLOOR and CEILING.
1987 ((def (name q-name r-name)
1988 (let ((q-aux (symbolicate q-name "-AUX"))
1989 (r-aux (symbolicate r-name "-AUX")))
1991 ;; Compute type of quotient (first) result.
1992 (defun ,q-aux (number-type divisor-type)
1993 (let* ((number-interval
1994 (numeric-type->interval number-type))
1996 (numeric-type->interval divisor-type))
1997 (quot (,q-name (interval-div number-interval
1998 divisor-interval))))
1999 (specifier-type `(integer ,(or (interval-low quot) '*)
2000 ,(or (interval-high quot) '*)))))
2001 ;; Compute type of remainder.
2002 (defun ,r-aux (number-type divisor-type)
2003 (let* ((divisor-interval
2004 (numeric-type->interval divisor-type))
2005 (rem (,r-name divisor-interval))
2006 (result-type (rem-result-type number-type divisor-type)))
2007 (multiple-value-bind (class format)
2010 (values 'integer nil))
2012 (values 'rational nil))
2013 ((or single-float double-float #!+long-float long-float)
2014 (values 'float result-type))
2016 (values 'float nil))
2019 (when (member result-type '(float single-float double-float
2020 #!+long-float long-float))
2021 ;; Make sure that the limits on the interval have
2023 (setf rem (interval-func (lambda (x)
2024 (coerce-for-bound x result-type))
2026 (make-numeric-type :class class
2028 :low (interval-low rem)
2029 :high (interval-high rem)))))
2030 ;; the optimizer itself
2031 (defoptimizer (,name derive-type) ((number divisor))
2032 (flet ((derive-q (n d same-arg)
2033 (declare (ignore same-arg))
2034 (if (and (numeric-type-real-p n)
2035 (numeric-type-real-p d))
2038 (derive-r (n d same-arg)
2039 (declare (ignore same-arg))
2040 (if (and (numeric-type-real-p n)
2041 (numeric-type-real-p d))
2044 (let ((quot (two-arg-derive-type
2045 number divisor #'derive-q #',name))
2046 (rem (two-arg-derive-type
2047 number divisor #'derive-r #'mod)))
2048 (when (and quot rem)
2049 (make-values-type :required (list quot rem))))))))))
2051 (def floor floor-quotient-bound floor-rem-bound)
2052 (def ceiling ceiling-quotient-bound ceiling-rem-bound))
2054 ;;; Define optimizers for FFLOOR and FCEILING
2055 (macrolet ((def (name q-name r-name)
2056 (let ((q-aux (symbolicate "F" q-name "-AUX"))
2057 (r-aux (symbolicate r-name "-AUX")))
2059 ;; Compute type of quotient (first) result.
2060 (defun ,q-aux (number-type divisor-type)
2061 (let* ((number-interval
2062 (numeric-type->interval number-type))
2064 (numeric-type->interval divisor-type))
2065 (quot (,q-name (interval-div number-interval
2067 (res-type (numeric-contagion number-type
2070 :class (numeric-type-class res-type)
2071 :format (numeric-type-format res-type)
2072 :low (interval-low quot)
2073 :high (interval-high quot))))
2075 (defoptimizer (,name derive-type) ((number divisor))
2076 (flet ((derive-q (n d same-arg)
2077 (declare (ignore same-arg))
2078 (if (and (numeric-type-real-p n)
2079 (numeric-type-real-p d))
2082 (derive-r (n d same-arg)
2083 (declare (ignore same-arg))
2084 (if (and (numeric-type-real-p n)
2085 (numeric-type-real-p d))
2088 (let ((quot (two-arg-derive-type
2089 number divisor #'derive-q #',name))
2090 (rem (two-arg-derive-type
2091 number divisor #'derive-r #'mod)))
2092 (when (and quot rem)
2093 (make-values-type :required (list quot rem))))))))))
2095 (def ffloor floor-quotient-bound floor-rem-bound)
2096 (def fceiling ceiling-quotient-bound ceiling-rem-bound))
2098 ;;; functions to compute the bounds on the quotient and remainder for
2099 ;;; the FLOOR function
2100 (defun floor-quotient-bound (quot)
2101 ;; Take the floor of the quotient and then massage it into what we
2103 (let ((lo (interval-low quot))
2104 (hi (interval-high quot)))
2105 ;; Take the floor of the lower bound. The result is always a
2106 ;; closed lower bound.
2108 (floor (type-bound-number lo))
2110 ;; For the upper bound, we need to be careful.
2113 ;; An open bound. We need to be careful here because
2114 ;; the floor of '(10.0) is 9, but the floor of
2116 (multiple-value-bind (q r) (floor (first hi))
2121 ;; A closed bound, so the answer is obvious.
2125 (make-interval :low lo :high hi)))
2126 (defun floor-rem-bound (div)
2127 ;; The remainder depends only on the divisor. Try to get the
2128 ;; correct sign for the remainder if we can.
2129 (case (interval-range-info div)
2131 ;; The divisor is always positive.
2132 (let ((rem (interval-abs div)))
2133 (setf (interval-low rem) 0)
2134 (when (and (numberp (interval-high rem))
2135 (not (zerop (interval-high rem))))
2136 ;; The remainder never contains the upper bound. However,
2137 ;; watch out for the case where the high limit is zero!
2138 (setf (interval-high rem) (list (interval-high rem))))
2141 ;; The divisor is always negative.
2142 (let ((rem (interval-neg (interval-abs div))))
2143 (setf (interval-high rem) 0)
2144 (when (numberp (interval-low rem))
2145 ;; The remainder never contains the lower bound.
2146 (setf (interval-low rem) (list (interval-low rem))))
2149 ;; The divisor can be positive or negative. All bets off. The
2150 ;; magnitude of remainder is the maximum value of the divisor.
2151 (let ((limit (type-bound-number (interval-high (interval-abs div)))))
2152 ;; The bound never reaches the limit, so make the interval open.
2153 (make-interval :low (if limit
2156 :high (list limit))))))
2158 (floor-quotient-bound (make-interval :low 0.3 :high 10.3))
2159 => #S(INTERVAL :LOW 0 :HIGH 10)
2160 (floor-quotient-bound (make-interval :low 0.3 :high '(10.3)))
2161 => #S(INTERVAL :LOW 0 :HIGH 10)
2162 (floor-quotient-bound (make-interval :low 0.3 :high 10))
2163 => #S(INTERVAL :LOW 0 :HIGH 10)
2164 (floor-quotient-bound (make-interval :low 0.3 :high '(10)))
2165 => #S(INTERVAL :LOW 0 :HIGH 9)
2166 (floor-quotient-bound (make-interval :low '(0.3) :high 10.3))
2167 => #S(INTERVAL :LOW 0 :HIGH 10)
2168 (floor-quotient-bound (make-interval :low '(0.0) :high 10.3))
2169 => #S(INTERVAL :LOW 0 :HIGH 10)
2170 (floor-quotient-bound (make-interval :low '(-1.3) :high 10.3))
2171 => #S(INTERVAL :LOW -2 :HIGH 10)
2172 (floor-quotient-bound (make-interval :low '(-1.0) :high 10.3))
2173 => #S(INTERVAL :LOW -1 :HIGH 10)
2174 (floor-quotient-bound (make-interval :low -1.0 :high 10.3))
2175 => #S(INTERVAL :LOW -1 :HIGH 10)
2177 (floor-rem-bound (make-interval :low 0.3 :high 10.3))
2178 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
2179 (floor-rem-bound (make-interval :low 0.3 :high '(10.3)))
2180 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
2181 (floor-rem-bound (make-interval :low -10 :high -2.3))
2182 #S(INTERVAL :LOW (-10) :HIGH 0)
2183 (floor-rem-bound (make-interval :low 0.3 :high 10))
2184 => #S(INTERVAL :LOW 0 :HIGH '(10))
2185 (floor-rem-bound (make-interval :low '(-1.3) :high 10.3))
2186 => #S(INTERVAL :LOW '(-10.3) :HIGH '(10.3))
2187 (floor-rem-bound (make-interval :low '(-20.3) :high 10.3))
2188 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
2191 ;;; same functions for CEILING
2192 (defun ceiling-quotient-bound (quot)
2193 ;; Take the ceiling of the quotient and then massage it into what we
2195 (let ((lo (interval-low quot))
2196 (hi (interval-high quot)))
2197 ;; Take the ceiling of the upper bound. The result is always a
2198 ;; closed upper bound.
2200 (ceiling (type-bound-number hi))
2202 ;; For the lower bound, we need to be careful.
2205 ;; An open bound. We need to be careful here because
2206 ;; the ceiling of '(10.0) is 11, but the ceiling of
2208 (multiple-value-bind (q r) (ceiling (first lo))
2213 ;; A closed bound, so the answer is obvious.
2217 (make-interval :low lo :high hi)))
2218 (defun ceiling-rem-bound (div)
2219 ;; The remainder depends only on the divisor. Try to get the
2220 ;; correct sign for the remainder if we can.
2221 (case (interval-range-info div)
2223 ;; Divisor is always positive. The remainder is negative.
2224 (let ((rem (interval-neg (interval-abs div))))
2225 (setf (interval-high rem) 0)
2226 (when (and (numberp (interval-low rem))
2227 (not (zerop (interval-low rem))))
2228 ;; The remainder never contains the upper bound. However,
2229 ;; watch out for the case when the upper bound is zero!
2230 (setf (interval-low rem) (list (interval-low rem))))
2233 ;; Divisor is always negative. The remainder is positive
2234 (let ((rem (interval-abs div)))
2235 (setf (interval-low rem) 0)
2236 (when (numberp (interval-high rem))
2237 ;; The remainder never contains the lower bound.
2238 (setf (interval-high rem) (list (interval-high rem))))
2241 ;; The divisor can be positive or negative. All bets off. The
2242 ;; magnitude of remainder is the maximum value of the divisor.
2243 (let ((limit (type-bound-number (interval-high (interval-abs div)))))
2244 ;; The bound never reaches the limit, so make the interval open.
2245 (make-interval :low (if limit
2248 :high (list limit))))))
2251 (ceiling-quotient-bound (make-interval :low 0.3 :high 10.3))
2252 => #S(INTERVAL :LOW 1 :HIGH 11)
2253 (ceiling-quotient-bound (make-interval :low 0.3 :high '(10.3)))
2254 => #S(INTERVAL :LOW 1 :HIGH 11)
2255 (ceiling-quotient-bound (make-interval :low 0.3 :high 10))
2256 => #S(INTERVAL :LOW 1 :HIGH 10)
2257 (ceiling-quotient-bound (make-interval :low 0.3 :high '(10)))
2258 => #S(INTERVAL :LOW 1 :HIGH 10)
2259 (ceiling-quotient-bound (make-interval :low '(0.3) :high 10.3))
2260 => #S(INTERVAL :LOW 1 :HIGH 11)
2261 (ceiling-quotient-bound (make-interval :low '(0.0) :high 10.3))
2262 => #S(INTERVAL :LOW 1 :HIGH 11)
2263 (ceiling-quotient-bound (make-interval :low '(-1.3) :high 10.3))
2264 => #S(INTERVAL :LOW -1 :HIGH 11)
2265 (ceiling-quotient-bound (make-interval :low '(-1.0) :high 10.3))
2266 => #S(INTERVAL :LOW 0 :HIGH 11)
2267 (ceiling-quotient-bound (make-interval :low -1.0 :high 10.3))
2268 => #S(INTERVAL :LOW -1 :HIGH 11)
2270 (ceiling-rem-bound (make-interval :low 0.3 :high 10.3))
2271 => #S(INTERVAL :LOW (-10.3) :HIGH 0)
2272 (ceiling-rem-bound (make-interval :low 0.3 :high '(10.3)))
2273 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
2274 (ceiling-rem-bound (make-interval :low -10 :high -2.3))
2275 => #S(INTERVAL :LOW 0 :HIGH (10))
2276 (ceiling-rem-bound (make-interval :low 0.3 :high 10))
2277 => #S(INTERVAL :LOW (-10) :HIGH 0)
2278 (ceiling-rem-bound (make-interval :low '(-1.3) :high 10.3))
2279 => #S(INTERVAL :LOW (-10.3) :HIGH (10.3))
2280 (ceiling-rem-bound (make-interval :low '(-20.3) :high 10.3))
2281 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
2284 (defun truncate-quotient-bound (quot)
2285 ;; For positive quotients, truncate is exactly like floor. For
2286 ;; negative quotients, truncate is exactly like ceiling. Otherwise,
2287 ;; it's the union of the two pieces.
2288 (case (interval-range-info quot)
2291 (floor-quotient-bound quot))
2293 ;; just like CEILING
2294 (ceiling-quotient-bound quot))
2296 ;; Split the interval into positive and negative pieces, compute
2297 ;; the result for each piece and put them back together.
2298 (destructuring-bind (neg pos) (interval-split 0 quot t t)
2299 (interval-merge-pair (ceiling-quotient-bound neg)
2300 (floor-quotient-bound pos))))))
2302 (defun truncate-rem-bound (num div)
2303 ;; This is significantly more complicated than FLOOR or CEILING. We
2304 ;; need both the number and the divisor to determine the range. The
2305 ;; basic idea is to split the ranges of NUM and DEN into positive
2306 ;; and negative pieces and deal with each of the four possibilities
2308 (case (interval-range-info num)
2310 (case (interval-range-info div)
2312 (floor-rem-bound div))
2314 (ceiling-rem-bound div))
2316 (destructuring-bind (neg pos) (interval-split 0 div t t)
2317 (interval-merge-pair (truncate-rem-bound num neg)
2318 (truncate-rem-bound num pos))))))
2320 (case (interval-range-info div)
2322 (ceiling-rem-bound div))
2324 (floor-rem-bound div))
2326 (destructuring-bind (neg pos) (interval-split 0 div t t)
2327 (interval-merge-pair (truncate-rem-bound num neg)
2328 (truncate-rem-bound num pos))))))
2330 (destructuring-bind (neg pos) (interval-split 0 num t t)
2331 (interval-merge-pair (truncate-rem-bound neg div)
2332 (truncate-rem-bound pos div))))))
2335 ;;; Derive useful information about the range. Returns three values:
2336 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2337 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2338 ;;; - The abs of the maximal value if there is one, or nil if it is
2340 (defun numeric-range-info (low high)
2341 (cond ((and low (not (minusp low)))
2342 (values '+ low high))
2343 ((and high (not (plusp high)))
2344 (values '- (- high) (if low (- low) nil)))
2346 (values nil 0 (and low high (max (- low) high))))))
2348 (defun integer-truncate-derive-type
2349 (number-low number-high divisor-low divisor-high)
2350 ;; The result cannot be larger in magnitude than the number, but the
2351 ;; sign might change. If we can determine the sign of either the
2352 ;; number or the divisor, we can eliminate some of the cases.
2353 (multiple-value-bind (number-sign number-min number-max)
2354 (numeric-range-info number-low number-high)
2355 (multiple-value-bind (divisor-sign divisor-min divisor-max)
2356 (numeric-range-info divisor-low divisor-high)
2357 (when (and divisor-max (zerop divisor-max))
2358 ;; We've got a problem: guaranteed division by zero.
2359 (return-from integer-truncate-derive-type t))
2360 (when (zerop divisor-min)
2361 ;; We'll assume that they aren't going to divide by zero.
2363 (cond ((and number-sign divisor-sign)
2364 ;; We know the sign of both.
2365 (if (eq number-sign divisor-sign)
2366 ;; Same sign, so the result will be positive.
2367 `(integer ,(if divisor-max
2368 (truncate number-min divisor-max)
2371 (truncate number-max divisor-min)
2373 ;; Different signs, the result will be negative.
2374 `(integer ,(if number-max
2375 (- (truncate number-max divisor-min))
2378 (- (truncate number-min divisor-max))
2380 ((eq divisor-sign '+)
2381 ;; The divisor is positive. Therefore, the number will just
2382 ;; become closer to zero.
2383 `(integer ,(if number-low
2384 (truncate number-low divisor-min)
2387 (truncate number-high divisor-min)
2389 ((eq divisor-sign '-)
2390 ;; The divisor is negative. Therefore, the absolute value of
2391 ;; the number will become closer to zero, but the sign will also
2393 `(integer ,(if number-high
2394 (- (truncate number-high divisor-min))
2397 (- (truncate number-low divisor-min))
2399 ;; The divisor could be either positive or negative.
2401 ;; The number we are dividing has a bound. Divide that by the
2402 ;; smallest posible divisor.
2403 (let ((bound (truncate number-max divisor-min)))
2404 `(integer ,(- bound) ,bound)))
2406 ;; The number we are dividing is unbounded, so we can't tell
2407 ;; anything about the result.
2410 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2411 (defun integer-rem-derive-type
2412 (number-low number-high divisor-low divisor-high)
2413 (if (and divisor-low divisor-high)
2414 ;; We know the range of the divisor, and the remainder must be
2415 ;; smaller than the divisor. We can tell the sign of the
2416 ;; remainder if we know the sign of the number.
2417 (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
2418 `(integer ,(if (or (null number-low)
2419 (minusp number-low))
2422 ,(if (or (null number-high)
2423 (plusp number-high))
2426 ;; The divisor is potentially either very positive or very
2427 ;; negative. Therefore, the remainder is unbounded, but we might
2428 ;; be able to tell something about the sign from the number.
2429 `(integer ,(if (and number-low (not (minusp number-low)))
2430 ;; The number we are dividing is positive.
2431 ;; Therefore, the remainder must be positive.
2434 ,(if (and number-high (not (plusp number-high)))
2435 ;; The number we are dividing is negative.
2436 ;; Therefore, the remainder must be negative.
2440 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2441 (defoptimizer (random derive-type) ((bound &optional state))
2442 (let ((type (lvar-type bound)))
2443 (when (numeric-type-p type)
2444 (let ((class (numeric-type-class type))
2445 (high (numeric-type-high type))
2446 (format (numeric-type-format type)))
2450 :low (coerce 0 (or format class 'real))
2451 :high (cond ((not high) nil)
2452 ((eq class 'integer) (max (1- high) 0))
2453 ((or (consp high) (zerop high)) high)
2456 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2457 (defun random-derive-type-aux (type)
2458 (let ((class (numeric-type-class type))
2459 (high (numeric-type-high type))
2460 (format (numeric-type-format type)))
2464 :low (coerce 0 (or format class 'real))
2465 :high (cond ((not high) nil)
2466 ((eq class 'integer) (max (1- high) 0))
2467 ((or (consp high) (zerop high)) high)
2470 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2471 (defoptimizer (random derive-type) ((bound &optional state))
2472 (one-arg-derive-type bound #'random-derive-type-aux nil))
2474 ;;;; miscellaneous derive-type methods
2476 (defoptimizer (integer-length derive-type) ((x))
2477 (let ((x-type (lvar-type x)))
2478 (when (numeric-type-p x-type)
2479 ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2480 ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be
2481 ;; careful about LO or HI being NIL, though. Also, if 0 is
2482 ;; contained in X, the lower bound is obviously 0.
2483 (flet ((null-or-min (a b)
2484 (and a b (min (integer-length a)
2485 (integer-length b))))
2487 (and a b (max (integer-length a)
2488 (integer-length b)))))
2489 (let* ((min (numeric-type-low x-type))
2490 (max (numeric-type-high x-type))
2491 (min-len (null-or-min min max))
2492 (max-len (null-or-max min max)))
2493 (when (ctypep 0 x-type)
2495 (specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
2497 (defoptimizer (isqrt derive-type) ((x))
2498 (let ((x-type (lvar-type x)))
2499 (when (numeric-type-p x-type)
2500 (let* ((lo (numeric-type-low x-type))
2501 (hi (numeric-type-high x-type))
2502 (lo-res (if lo (isqrt lo) '*))
2503 (hi-res (if hi (isqrt hi) '*)))
2504 (specifier-type `(integer ,lo-res ,hi-res))))))
2506 (defoptimizer (char-code derive-type) ((char))
2507 (let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
2508 (cond ((member-type-p type)
2511 ,@(loop for member in (member-type-members type)
2512 when (characterp member)
2513 collect (char-code member)))))
2514 ((sb!kernel::character-set-type-p type)
2517 ,@(loop for (low . high)
2518 in (character-set-type-pairs type)
2519 collect `(integer ,low ,high)))))
2520 ((csubtypep type (specifier-type 'base-char))
2522 `(mod ,base-char-code-limit)))
2525 `(mod ,char-code-limit))))))
2527 (defoptimizer (code-char derive-type) ((code))
2528 (let ((type (lvar-type code)))
2529 ;; FIXME: unions of integral ranges? It ought to be easier to do
2530 ;; this, given that CHARACTER-SET is basically an integral range
2531 ;; type. -- CSR, 2004-10-04
2532 (when (numeric-type-p type)
2533 (let* ((lo (numeric-type-low type))
2534 (hi (numeric-type-high type))
2535 (type (specifier-type `(character-set ((,lo . ,hi))))))
2537 ;; KLUDGE: when running on the host, we lose a slight amount
2538 ;; of precision so that we don't have to "unparse" types
2539 ;; that formally we can't, such as (CHARACTER-SET ((0
2540 ;; . 0))). -- CSR, 2004-10-06
2542 ((csubtypep type (specifier-type 'standard-char)) type)
2544 ((csubtypep type (specifier-type 'base-char))
2545 (specifier-type 'base-char))
2547 ((csubtypep type (specifier-type 'extended-char))
2548 (specifier-type 'extended-char))
2549 (t #+sb-xc-host (specifier-type 'character)
2550 #-sb-xc-host type))))))
2552 (defoptimizer (values derive-type) ((&rest values))
2553 (make-values-type :required (mapcar #'lvar-type values)))
2555 (defun signum-derive-type-aux (type)
2556 (if (eq (numeric-type-complexp type) :complex)
2557 (let* ((format (case (numeric-type-class type)
2558 ((integer rational) 'single-float)
2559 (t (numeric-type-format type))))
2560 (bound-format (or format 'float)))
2561 (make-numeric-type :class 'float
2564 :low (coerce -1 bound-format)
2565 :high (coerce 1 bound-format)))
2566 (let* ((interval (numeric-type->interval type))
2567 (range-info (interval-range-info interval))
2568 (contains-0-p (interval-contains-p 0 interval))
2569 (class (numeric-type-class type))
2570 (format (numeric-type-format type))
2571 (one (coerce 1 (or format class 'real)))
2572 (zero (coerce 0 (or format class 'real)))
2573 (minus-one (coerce -1 (or format class 'real)))
2574 (plus (make-numeric-type :class class :format format
2575 :low one :high one))
2576 (minus (make-numeric-type :class class :format format
2577 :low minus-one :high minus-one))
2578 ;; KLUDGE: here we have a fairly horrible hack to deal
2579 ;; with the schizophrenia in the type derivation engine.
2580 ;; The problem is that the type derivers reinterpret
2581 ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
2582 ;; 0d0) within the derivation mechanism doesn't include
2583 ;; -0d0. Ugh. So force it in here, instead.
2584 (zero (make-numeric-type :class class :format format
2585 :low (- zero) :high zero)))
2587 (+ (if contains-0-p (type-union plus zero) plus))
2588 (- (if contains-0-p (type-union minus zero) minus))
2589 (t (type-union minus zero plus))))))
2591 (defoptimizer (signum derive-type) ((num))
2592 (one-arg-derive-type num #'signum-derive-type-aux nil))
2594 ;;;; byte operations
2596 ;;;; We try to turn byte operations into simple logical operations.
2597 ;;;; First, we convert byte specifiers into separate size and position
2598 ;;;; arguments passed to internal %FOO functions. We then attempt to
2599 ;;;; transform the %FOO functions into boolean operations when the
2600 ;;;; size and position are constant and the operands are fixnums.
2602 (macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to
2603 ;; expressions that evaluate to the SIZE and POSITION of
2604 ;; the byte-specifier form SPEC. We may wrap a let around
2605 ;; the result of the body to bind some variables.
2607 ;; If the spec is a BYTE form, then bind the vars to the
2608 ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE
2609 ;; and BYTE-POSITION. The goal of this transformation is to
2610 ;; avoid consing up byte specifiers and then immediately
2611 ;; throwing them away.
2612 (with-byte-specifier ((size-var pos-var spec) &body body)
2613 (once-only ((spec `(macroexpand ,spec))
2615 `(if (and (consp ,spec)
2616 (eq (car ,spec) 'byte)
2617 (= (length ,spec) 3))
2618 (let ((,size-var (second ,spec))
2619 (,pos-var (third ,spec)))
2621 (let ((,size-var `(byte-size ,,temp))
2622 (,pos-var `(byte-position ,,temp)))
2623 `(let ((,,temp ,,spec))
2626 (define-source-transform ldb (spec int)
2627 (with-byte-specifier (size pos spec)
2628 `(%ldb ,size ,pos ,int)))
2630 (define-source-transform dpb (newbyte spec int)
2631 (with-byte-specifier (size pos spec)
2632 `(%dpb ,newbyte ,size ,pos ,int)))
2634 (define-source-transform mask-field (spec int)
2635 (with-byte-specifier (size pos spec)
2636 `(%mask-field ,size ,pos ,int)))
2638 (define-source-transform deposit-field (newbyte spec int)
2639 (with-byte-specifier (size pos spec)
2640 `(%deposit-field ,newbyte ,size ,pos ,int))))
2642 (defoptimizer (%ldb derive-type) ((size posn num))
2643 (let ((size (lvar-type size)))
2644 (if (and (numeric-type-p size)
2645 (csubtypep size (specifier-type 'integer)))
2646 (let ((size-high (numeric-type-high size)))
2647 (if (and size-high (<= size-high sb!vm:n-word-bits))
2648 (specifier-type `(unsigned-byte* ,size-high))
2649 (specifier-type 'unsigned-byte)))
2652 (defoptimizer (%mask-field derive-type) ((size posn num))
2653 (let ((size (lvar-type size))
2654 (posn (lvar-type posn)))
2655 (if (and (numeric-type-p size)
2656 (csubtypep size (specifier-type 'integer))
2657 (numeric-type-p posn)
2658 (csubtypep posn (specifier-type 'integer)))
2659 (let ((size-high (numeric-type-high size))
2660 (posn-high (numeric-type-high posn)))
2661 (if (and size-high posn-high
2662 (<= (+ size-high posn-high) sb!vm:n-word-bits))
2663 (specifier-type `(unsigned-byte* ,(+ size-high posn-high)))
2664 (specifier-type 'unsigned-byte)))
2667 (defun %deposit-field-derive-type-aux (size posn int)
2668 (let ((size (lvar-type size))
2669 (posn (lvar-type posn))
2670 (int (lvar-type int)))
2671 (when (and (numeric-type-p size)
2672 (numeric-type-p posn)
2673 (numeric-type-p int))
2674 (let ((size-high (numeric-type-high size))
2675 (posn-high (numeric-type-high posn))
2676 (high (numeric-type-high int))
2677 (low (numeric-type-low int)))
2678 (when (and size-high posn-high high low
2679 ;; KLUDGE: we need this cutoff here, otherwise we
2680 ;; will merrily derive the type of %DPB as
2681 ;; (UNSIGNED-BYTE 1073741822), and then attempt to
2682 ;; canonicalize this type to (INTEGER 0 (1- (ASH 1
2683 ;; 1073741822))), with hilarious consequences. We
2684 ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference
2685 ;; over a reasonable amount of shifting, even on
2686 ;; the alpha/32 port, where N-WORD-BITS is 32 but
2687 ;; machine integers are 64-bits. -- CSR,
2689 (<= (+ size-high posn-high) (* 4 sb!vm:n-word-bits)))
2690 (let ((raw-bit-count (max (integer-length high)
2691 (integer-length low)
2692 (+ size-high posn-high))))
2695 `(signed-byte ,(1+ raw-bit-count))
2696 `(unsigned-byte* ,raw-bit-count)))))))))
2698 (defoptimizer (%dpb derive-type) ((newbyte size posn int))
2699 (%deposit-field-derive-type-aux size posn int))
2701 (defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
2702 (%deposit-field-derive-type-aux size posn int))
2704 (deftransform %ldb ((size posn int)
2705 (fixnum fixnum integer)
2706 (unsigned-byte #.sb!vm:n-word-bits))
2707 "convert to inline logical operations"
2708 `(logand (ash int (- posn))
2709 (ash ,(1- (ash 1 sb!vm:n-word-bits))
2710 (- size ,sb!vm:n-word-bits))))
2712 (deftransform %mask-field ((size posn int)
2713 (fixnum fixnum integer)
2714 (unsigned-byte #.sb!vm:n-word-bits))
2715 "convert to inline logical operations"
2717 (ash (ash ,(1- (ash 1 sb!vm:n-word-bits))
2718 (- size ,sb!vm:n-word-bits))
2721 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
2722 ;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
2723 ;;; as the result type, as that would allow result types that cover
2724 ;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
2725 ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
2727 (deftransform %dpb ((new size posn int)
2729 (unsigned-byte #.sb!vm:n-word-bits))
2730 "convert to inline logical operations"
2731 `(let ((mask (ldb (byte size 0) -1)))
2732 (logior (ash (logand new mask) posn)
2733 (logand int (lognot (ash mask posn))))))
2735 (deftransform %dpb ((new size posn int)
2737 (signed-byte #.sb!vm:n-word-bits))
2738 "convert to inline logical operations"
2739 `(let ((mask (ldb (byte size 0) -1)))
2740 (logior (ash (logand new mask) posn)
2741 (logand int (lognot (ash mask posn))))))
2743 (deftransform %deposit-field ((new size posn int)
2745 (unsigned-byte #.sb!vm:n-word-bits))
2746 "convert to inline logical operations"
2747 `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2748 (logior (logand new mask)
2749 (logand int (lognot mask)))))
2751 (deftransform %deposit-field ((new size posn int)
2753 (signed-byte #.sb!vm:n-word-bits))
2754 "convert to inline logical operations"
2755 `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2756 (logior (logand new mask)
2757 (logand int (lognot mask)))))
2759 (defoptimizer (mask-signed-field derive-type) ((size x))
2760 (let ((size (lvar-type size)))
2761 (if (numeric-type-p size)
2762 (let ((size-high (numeric-type-high size)))
2763 (if (and size-high (<= 1 size-high sb!vm:n-word-bits))
2764 (specifier-type `(signed-byte ,size-high))
2771 (defun %ash/right (integer amount)
2772 (ash integer (- amount)))
2774 (deftransform ash ((integer amount))
2775 "Convert ASH of signed word to %ASH/RIGHT"
2776 (unless (and (csubtypep (lvar-type integer) ; do that ourselves to avoid
2777 (specifier-type 'sb!vm:signed-word)) ; optimization
2778 (csubtypep (lvar-type amount) ; notes.
2779 (specifier-type '(integer * 0))))
2780 (give-up-ir1-transform))
2781 (when (constant-lvar-p amount)
2782 (give-up-ir1-transform))
2783 (let ((use (lvar-uses amount)))
2784 (cond ((and (combination-p use)
2785 (eql '%negate (lvar-fun-name (combination-fun use))))
2786 (splice-fun-args amount '%negate 1)
2787 `(lambda (integer amount)
2788 (declare (type unsigned-byte amount))
2789 (%ash/right integer (if (>= amount ,sb!vm:n-word-bits)
2790 ,(1- sb!vm:n-word-bits)
2793 `(%ash/right integer (if (<= amount ,(- sb!vm:n-word-bits))
2794 ,(1- sb!vm:n-word-bits)
2797 (deftransform ash ((integer amount))
2798 "Convert ASH of word to %ASH/RIGHT"
2799 (unless (and (csubtypep (lvar-type integer)
2800 (specifier-type 'sb!vm:word))
2801 (csubtypep (lvar-type amount)
2802 (specifier-type '(integer * 0))))
2803 (give-up-ir1-transform))
2804 (when (constant-lvar-p amount)
2805 (give-up-ir1-transform))
2806 (let ((use (lvar-uses amount)))
2807 (cond ((and (combination-p use)
2808 (eql '%negate (lvar-fun-name (combination-fun use))))
2809 (splice-fun-args amount '%negate 1)
2810 `(lambda (integer amount)
2811 (declare (type unsigned-byte amount))
2812 (if (>= amount ,sb!vm:n-word-bits)
2814 (%ash/right integer amount))))
2816 `(if (<= amount ,(- sb!vm:n-word-bits))
2818 (%ash/right integer (- amount)))))))
2820 (deftransform %ash/right ((integer amount) (integer (constant-arg unsigned-byte)))
2821 "Convert %ASH/RIGHT by constant back to ASH"
2822 `(ash integer ,(- (lvar-value amount))))
2824 (deftransform %ash/right ((integer amount) * * :node node)
2825 "strength reduce large variable right shift"
2826 (let ((return-type (single-value-type (node-derived-type node))))
2827 (cond ((type= return-type (specifier-type '(eql 0)))
2829 ((type= return-type (specifier-type '(eql -1)))
2831 ((csubtypep return-type (specifier-type '(member -1 0)))
2832 `(ash integer ,(- sb!vm:n-word-bits)))
2834 (give-up-ir1-transform)))))
2836 (defun %ash/right-derive-type-aux (n-type shift same-arg)
2837 (declare (ignore same-arg))
2838 (or (and (or (csubtypep n-type (specifier-type 'sb!vm:signed-word))
2839 (csubtypep n-type (specifier-type 'word)))
2840 (csubtypep shift (specifier-type `(mod ,sb!vm:n-word-bits)))
2841 (let ((n-low (numeric-type-low n-type))
2842 (n-high (numeric-type-high n-type))
2843 (s-low (numeric-type-low shift))
2844 (s-high (numeric-type-high shift)))
2845 (make-numeric-type :class 'integer :complexp :real
2848 (ash n-low (- s-low))
2849 (ash n-low (- s-high))))
2852 (ash n-high (- s-high))
2853 (ash n-high (- s-low)))))))
2856 (defoptimizer (%ash/right derive-type) ((n shift))
2857 (two-arg-derive-type n shift #'%ash/right-derive-type-aux #'%ash/right))
2860 ;;; Modular functions
2862 ;;; (ldb (byte s 0) (foo x y ...)) =
2863 ;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
2865 ;;; and similar for other arguments.
2867 (defun make-modular-fun-type-deriver (prototype kind width signedp)
2868 (declare (ignore kind))
2870 (binding* ((info (info :function :info prototype) :exit-if-null)
2871 (fun (fun-info-derive-type info) :exit-if-null)
2872 (mask-type (specifier-type
2874 ((nil) (let ((mask (1- (ash 1 width))))
2875 `(integer ,mask ,mask)))
2876 ((t) `(signed-byte ,width))))))
2878 (let ((res (funcall fun call)))
2880 (if (eq signedp nil)
2881 (logand-derive-type-aux res mask-type))))))
2884 (binding* ((info (info :function :info prototype) :exit-if-null)
2885 (fun (fun-info-derive-type info) :exit-if-null)
2886 (res (funcall fun call) :exit-if-null)
2887 (mask-type (specifier-type
2889 ((nil) (let ((mask (1- (ash 1 width))))
2890 `(integer ,mask ,mask)))
2891 ((t) `(signed-byte ,width))))))
2892 (if (eq signedp nil)
2893 (logand-derive-type-aux res mask-type)))))
2895 ;;; Try to recursively cut all uses of LVAR to WIDTH bits.
2897 ;;; For good functions, we just recursively cut arguments; their
2898 ;;; "goodness" means that the result will not increase (in the
2899 ;;; (unsigned-byte +infinity) sense). An ordinary modular function is
2900 ;;; replaced with the version, cutting its result to WIDTH or more
2901 ;;; bits. For most functions (e.g. for +) we cut all arguments; for
2902 ;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
2903 ;;; arguments (maybe to a different width) and returning the name of a
2904 ;;; modular version, if it exists, or NIL. If we have changed
2905 ;;; anything, we need to flush old derived types, because they have
2906 ;;; nothing in common with the new code.
2907 (defun cut-to-width (lvar kind width signedp)
2908 (declare (type lvar lvar) (type (integer 0) width))
2909 (let ((type (specifier-type (if (zerop width)
2912 ((nil) 'unsigned-byte)
2915 (labels ((reoptimize-node (node name)
2916 (setf (node-derived-type node)
2918 (info :function :type name)))
2919 (setf (lvar-%derived-type (node-lvar node)) nil)
2920 (setf (node-reoptimize node) t)
2921 (setf (block-reoptimize (node-block node)) t)
2922 (reoptimize-component (node-component node) :maybe))
2923 (insert-lvar-cut (lvar)
2924 "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
2925 to the required bit width. Returns T if any change was made.
2927 When the destination of LVAR will definitely cut LVAR's value
2928 to width (i.e. it's a logand or mask-signed-field with constant
2929 other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
2930 (binding* ((dest (lvar-dest lvar) :exit-if-null)
2931 (nil (combination-p dest) :exit-if-null)
2932 (name (lvar-fun-name (combination-fun dest) t))
2933 (args (combination-args dest)))
2936 (when (= 2 (length args))
2937 (let ((other (if (eql (first args) lvar)
2940 (when (and (constant-lvar-p other)
2941 (ctypep (lvar-value other) type)
2943 (return-from insert-lvar-cut)))))
2946 (eql lvar (second args))
2947 (constant-lvar-p (first args))
2948 (<= (lvar-value (first args)) width))
2949 (return-from insert-lvar-cut)))))
2952 `(mask-signed-field ,width 'dummy)
2953 `(logand 'dummy ,(ldb (byte width 0) -1))))
2954 (do-uses (node lvar)
2955 (setf (block-reoptimize (node-block node)) t)
2956 (reoptimize-component (node-component node) :maybe))
2958 (cut-node (node &aux did-something)
2959 "Try to cut a node to width. The primary return value is
2960 whether we managed to cut (cleverly), and the second whether
2961 anything was changed."
2962 (when (block-delete-p (node-block node))
2963 (return-from cut-node (values t nil)))
2966 (typecase (ref-leaf node)
2968 (let* ((constant-value (constant-value (ref-leaf node)))
2969 (new-value (if signedp
2970 (mask-signed-field width constant-value)
2971 (ldb (byte width 0) constant-value))))
2972 (cond ((= constant-value new-value)
2973 (values t nil)) ; we knew what to do and did nothing
2975 (change-ref-leaf node (make-constant new-value)
2977 (let ((lvar (node-lvar node)))
2978 (setf (lvar-%derived-type lvar)
2979 (and (lvar-has-single-use-p lvar)
2980 (make-values-type :required (list (ctype-of new-value))))))
2981 (setf (block-reoptimize (node-block node)) t)
2982 (reoptimize-component (node-component node) :maybe)
2985 (when (eq (basic-combination-kind node) :known)
2986 (let* ((fun-ref (lvar-use (combination-fun node)))
2987 (fun-name (lvar-fun-name (combination-fun node)))
2988 (modular-fun (find-modular-version fun-name kind
2990 (when (and modular-fun
2991 (not (and (eq fun-name 'logand)
2993 (single-value-type (node-derived-type node))
2995 (binding* ((name (etypecase modular-fun
2996 ((eql :good) fun-name)
2998 (modular-fun-info-name modular-fun))
3000 (funcall modular-fun node width)))
3002 (unless (eql modular-fun :good)
3003 (setq did-something t)
3006 (find-free-fun name "in a strange place"))
3007 (setf (combination-kind node) :full))
3008 (unless (functionp modular-fun)
3009 (dolist (arg (basic-combination-args node))
3010 (when (cut-lvar arg)
3011 (setq did-something t))))
3013 (reoptimize-node node name))
3014 (values t did-something))))))))
3015 (cut-lvar (lvar &aux did-something must-insert)
3016 "Cut all the LVAR's use nodes. If any of them wasn't handled
3017 and its type is too wide for the operation we wish to perform
3018 insert an explicit bit-width narrowing operation (LOGAND or
3019 MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
3020 The narrowing operation might not be inserted if the LVAR's
3021 destination is already such an operation, to avoid endless
3024 (*) We can't easily do that for each node, and doing so might
3025 result in code bloat, anyway. (I'm also not sure it would be
3026 correct for complicated C/D FG)"
3027 (do-uses (node lvar)
3028 (multiple-value-bind (handled any-change)
3030 (setf did-something (or did-something any-change)
3031 must-insert (or must-insert
3033 (csubtypep (single-value-type
3034 (node-derived-type node))
3037 (setf did-something (or (insert-lvar-cut lvar) did-something)))
3041 (defun best-modular-version (width signedp)
3042 ;; 1. exact width-matched :untagged
3043 ;; 2. >/>= width-matched :tagged
3044 ;; 3. >/>= width-matched :untagged
3045 (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
3046 (uswidths (modular-class-widths *untagged-signed-modular-class*))
3047 (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
3048 (twidths (modular-class-widths *tagged-modular-class*)))
3049 (let ((exact (find (cons width signedp) uwidths :test #'equal)))
3051 (return-from best-modular-version (values width :untagged signedp))))
3052 (flet ((inexact-match (w)
3054 ((eq signedp (cdr w)) (<= width (car w)))
3055 ((eq signedp nil) (< width (car w))))))
3056 (let ((tgt (find-if #'inexact-match twidths)))
3058 (return-from best-modular-version
3059 (values (car tgt) :tagged (cdr tgt)))))
3060 (let ((ugt (find-if #'inexact-match uwidths)))
3062 (return-from best-modular-version
3063 (values (car ugt) :untagged (cdr ugt))))))))
3065 (defun integer-type-numeric-bounds (type)
3067 (numeric-type (values (numeric-type-low type)
3068 (numeric-type-high type)))
3072 (dolist (type (union-type-types type) (values low high))
3073 (unless (and (numeric-type-p type)
3074 (eql (numeric-type-class type) 'integer))
3075 (return (values nil nil)))
3076 (let ((this-low (numeric-type-low type))
3077 (this-high (numeric-type-high type)))
3078 (setf low (min this-low (or low this-low))
3079 high (max this-high (or high this-high)))))))))
3081 (defoptimizer (logand optimizer) ((x y) node)
3082 (let ((result-type (single-value-type (node-derived-type node))))
3083 (multiple-value-bind (low high)
3084 (integer-type-numeric-bounds result-type)
3085 (when (and (numberp low)
3088 (let ((width (integer-length high)))
3089 (multiple-value-bind (w kind signedp)
3090 (best-modular-version width nil)
3092 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
3094 ;; FIXME: I think the FIXME (which is from APD) above
3095 ;; implies that CUT-TO-WIDTH should do /everything/
3096 ;; that's required, including reoptimizing things
3097 ;; itself that it knows are necessary. At the moment,
3098 ;; CUT-TO-WIDTH sets up some new calls with
3099 ;; combination-type :FULL, which later get noticed as
3100 ;; known functions and properly converted.
3102 ;; We cut to W not WIDTH if SIGNEDP is true, because
3103 ;; signed constant replacement needs to know which bit
3104 ;; in the field is the signed bit.
3105 (let ((xact (cut-to-width x kind (if signedp w width) signedp))
3106 (yact (cut-to-width y kind (if signedp w width) signedp)))
3107 (declare (ignore xact yact))
3108 nil) ; After fixing above, replace with T, meaning
3109 ; "don't reoptimize this (LOGAND) node any more".
3112 (defoptimizer (mask-signed-field optimizer) ((width x) node)
3113 (let ((result-type (single-value-type (node-derived-type node))))
3114 (multiple-value-bind (low high)
3115 (integer-type-numeric-bounds result-type)
3116 (when (and (numberp low) (numberp high))
3117 (let ((width (max (integer-length high) (integer-length low))))
3118 (multiple-value-bind (w kind)
3119 (best-modular-version (1+ width) t)
3121 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
3122 ;; [ see comment above in LOGAND optimizer ]
3123 (cut-to-width x kind w t)
3124 nil ; After fixing above, replace with T.
3127 (defoptimizer (logior optimizer) ((x y) node)
3128 (let ((result-type (single-value-type (node-derived-type node))))
3129 (multiple-value-bind (low high)
3130 (integer-type-numeric-bounds result-type)
3131 (when (and (numberp low)
3134 (let ((width (integer-length low)))
3135 (multiple-value-bind (w kind)
3136 (best-modular-version (1+ width) t)
3138 ;; FIXME: see comment in LOGAND optimizer
3139 (let ((xact (cut-to-width x kind w t))
3140 (yact (cut-to-width y kind w t)))
3141 (declare (ignore xact yact))
3142 nil) ; After fixing above, replace with T
3145 ;;; miscellanous numeric transforms
3147 ;;; If a constant appears as the first arg, swap the args.
3148 (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
3149 (if (and (constant-lvar-p x)
3150 (not (constant-lvar-p y)))
3151 `(,(lvar-fun-name (basic-combination-fun node))
3152 (truly-the ,(lvar-type y) y)
3154 (give-up-ir1-transform)))
3156 (dolist (x '(= char= + * logior logand logxor logtest))
3157 (%deftransform x '(function * *) #'commutative-arg-swap
3158 "place constant arg last"))
3160 ;;; Handle the case of a constant BOOLE-CODE.
3161 (deftransform boole ((op x y) * *)
3162 "convert to inline logical operations"
3163 (unless (constant-lvar-p op)
3164 (give-up-ir1-transform "BOOLE code is not a constant."))
3165 (let ((control (lvar-value op)))
3167 (#.sb!xc:boole-clr 0)
3168 (#.sb!xc:boole-set -1)
3169 (#.sb!xc:boole-1 'x)
3170 (#.sb!xc:boole-2 'y)
3171 (#.sb!xc:boole-c1 '(lognot x))
3172 (#.sb!xc:boole-c2 '(lognot y))
3173 (#.sb!xc:boole-and '(logand x y))
3174 (#.sb!xc:boole-ior '(logior x y))
3175 (#.sb!xc:boole-xor '(logxor x y))
3176 (#.sb!xc:boole-eqv '(logeqv x y))
3177 (#.sb!xc:boole-nand '(lognand x y))
3178 (#.sb!xc:boole-nor '(lognor x y))
3179 (#.sb!xc:boole-andc1 '(logandc1 x y))
3180 (#.sb!xc:boole-andc2 '(logandc2 x y))
3181 (#.sb!xc:boole-orc1 '(logorc1 x y))
3182 (#.sb!xc:boole-orc2 '(logorc2 x y))
3184 (abort-ir1-transform "~S is an illegal control arg to BOOLE."
3187 ;;;; converting special case multiply/divide to shifts
3189 ;;; If arg is a constant power of two, turn * into a shift.
3190 (deftransform * ((x y) (integer integer) *)
3191 "convert x*2^k to shift"
3192 (unless (constant-lvar-p y)
3193 (give-up-ir1-transform))
3194 (let* ((y (lvar-value y))
3196 (len (1- (integer-length y-abs))))
3197 (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3198 (give-up-ir1-transform))
3203 ;;; These must come before the ones below, so that they are tried
3204 ;;; first. Since %FLOOR and %CEILING are inlined, this allows
3205 ;;; the general case to be handled by TRUNCATE transforms.
3206 (deftransform floor ((x y))
3209 (deftransform ceiling ((x y))
3212 ;;; If arg is a constant power of two, turn FLOOR into a shift and
3213 ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
3215 (flet ((frob (y ceil-p)
3216 (unless (constant-lvar-p y)
3217 (give-up-ir1-transform))
3218 (let* ((y (lvar-value y))
3220 (len (1- (integer-length y-abs))))
3221 (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3222 (give-up-ir1-transform))
3223 (let ((shift (- len))
3225 (delta (if ceil-p (* (signum y) (1- y-abs)) 0)))
3226 `(let ((x (+ x ,delta)))
3228 `(values (ash (- x) ,shift)
3229 (- (- (logand (- x) ,mask)) ,delta))
3230 `(values (ash x ,shift)
3231 (- (logand x ,mask) ,delta))))))))
3232 (deftransform floor ((x y) (integer integer) *)
3233 "convert division by 2^k to shift"
3235 (deftransform ceiling ((x y) (integer integer) *)
3236 "convert division by 2^k to shift"
3239 ;;; Do the same for MOD.
3240 (deftransform mod ((x y) (integer integer) *)
3241 "convert remainder mod 2^k to LOGAND"
3242 (unless (constant-lvar-p y)
3243 (give-up-ir1-transform))
3244 (let* ((y (lvar-value y))
3246 (len (1- (integer-length y-abs))))
3247 (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3248 (give-up-ir1-transform))
3249 (let ((mask (1- y-abs)))
3251 `(- (logand (- x) ,mask))
3252 `(logand x ,mask)))))
3254 ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
3255 (deftransform truncate ((x y) (integer integer))
3256 "convert division by 2^k to shift"
3257 (unless (constant-lvar-p y)
3258 (give-up-ir1-transform))
3259 (let* ((y (lvar-value y))
3261 (len (1- (integer-length y-abs))))
3262 (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3263 (give-up-ir1-transform))
3264 (let* ((shift (- len))
3267 (values ,(if (minusp y)
3269 `(- (ash (- x) ,shift)))
3270 (- (logand (- x) ,mask)))
3271 (values ,(if (minusp y)
3272 `(ash (- ,mask x) ,shift)
3274 (logand x ,mask))))))
3276 ;;; And the same for REM.
3277 (deftransform rem ((x y) (integer integer) *)
3278 "convert remainder mod 2^k to LOGAND"
3279 (unless (constant-lvar-p y)
3280 (give-up-ir1-transform))
3281 (let* ((y (lvar-value y))
3283 (len (1- (integer-length y-abs))))
3284 (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3285 (give-up-ir1-transform))
3286 (let ((mask (1- y-abs)))
3288 (- (logand (- x) ,mask))
3289 (logand x ,mask)))))
3291 ;;; Return an expression to calculate the integer quotient of X and
3292 ;;; constant Y, using multiplication, shift and add/sub instead of
3293 ;;; division. Both arguments must be unsigned, fit in a machine word and
3294 ;;; Y must neither be zero nor a power of two. The quotient is rounded
3296 ;;; The algorithm is taken from the paper "Division by Invariant
3297 ;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and
3298 ;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the
3299 ;;; case of division by powers of two.
3300 ;;; The algorithm includes an adaptive precision argument. Use it, since
3301 ;;; we often have sub-word value ranges. Careful, in this case, we need
3302 ;;; p s.t 2^p > n, not the ceiling of the binary log.
3303 ;;; Also, for some reason, the paper prefers shifting to masking. Mask
3304 ;;; instead. Masking is equivalent to shifting right, then left again;
3305 ;;; all the intermediate values are still words, so we just have to shift
3306 ;;; right a bit more to compensate, at the end.
3308 ;;; The following two examples show an average case and the worst case
3309 ;;; with respect to the complexity of the generated expression, under
3310 ;;; a word size of 64 bits:
3312 ;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) ->
3313 ;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3)
3315 ;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) ->
3317 ;;; (T1 (%MULTIPLY NUM 2635249153387078803)))
3318 ;;; (ASH (LDB (BYTE 64 0)
3319 ;;; (+ T1 (ASH (LDB (BYTE 64 0)
3324 (defun gen-unsigned-div-by-constant-expr (y max-x)
3325 (declare (type (integer 3 #.most-positive-word) y)
3327 (aver (not (zerop (logand y (1- y)))))
3329 ;; the floor of the binary logarithm of (positive) X
3330 (integer-length (1- x)))
3331 (choose-multiplier (y precision)
3333 (shift l (1- shift))
3334 (expt-2-n+l (expt 2 (+ sb!vm:n-word-bits l)))
3335 (m-low (truncate expt-2-n+l y) (ash m-low -1))
3336 (m-high (truncate (+ expt-2-n+l
3337 (ash expt-2-n+l (- precision)))
3340 ((not (and (< (ash m-low -1) (ash m-high -1))
3342 (values m-high shift)))))
3343 (let ((n (expt 2 sb!vm:n-word-bits))
3344 (precision (integer-length max-x))
3346 (multiple-value-bind (m shift2)
3347 (choose-multiplier y precision)
3348 (when (and (>= m n) (evenp y))
3349 (setq shift1 (ld (logand y (- y))))
3350 (multiple-value-setq (m shift2)
3351 (choose-multiplier (/ y (ash 1 shift1))
3352 (- precision shift1))))
3355 `(truly-the word ,x)))
3357 (t1 (%multiply-high num ,(- m n))))
3358 (ash ,(word `(+ t1 (ash ,(word `(- num t1))
3361 ((and (zerop shift1) (zerop shift2))
3362 (let ((max (truncate max-x y)))
3363 ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM
3365 `(truly-the (integer 0 ,max)
3366 (%multiply-high x ,m))))
3368 `(ash (%multiply-high (logandc2 x ,(1- (ash 1 shift1))) ,m)
3369 ,(- (+ shift1 shift2)))))))))
3371 ;;; If the divisor is constant and both args are positive and fit in a
3372 ;;; machine word, replace the division by a multiplication and possibly
3373 ;;; some shifts and an addition. Calculate the remainder by a second
3374 ;;; multiplication and a subtraction. Dead code elimination will
3375 ;;; suppress the latter part if only the quotient is needed. If the type
3376 ;;; of the dividend allows to derive that the quotient will always have
3377 ;;; the same value, emit much simpler code to handle that. (This case
3378 ;;; may be rare but it's easy to detect and the compiler doesn't find
3379 ;;; this optimization on its own.)
3380 (deftransform truncate ((x y) (word (constant-arg word))
3382 :policy (and (> speed compilation-speed)
3384 "convert integer division to multiplication"
3385 (let* ((y (lvar-value y))
3386 (x-type (lvar-type x))
3387 (max-x (or (and (numeric-type-p x-type)
3388 (numeric-type-high x-type))
3389 most-positive-word)))
3390 ;; Division by zero, one or powers of two is handled elsewhere.
3391 (when (zerop (logand y (1- y)))
3392 (give-up-ir1-transform))
3393 `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x))
3394 (rem (ldb (byte #.sb!vm:n-word-bits 0)
3395 (- x (* quot ,y)))))
3396 (values quot rem))))
3398 ;;;; arithmetic and logical identity operation elimination
3400 ;;; Flush calls to various arith functions that convert to the
3401 ;;; identity function or a constant.
3402 (macrolet ((def (name identity result)
3403 `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) *)
3404 "fold identity operations"
3411 (def logxor -1 (lognot x))
3414 (defun least-zero-bit (x)
3416 (1- (integer-length (logxor x (1+ x))))))
3418 (deftransform logand ((x y) (* (constant-arg t)) *)
3419 "fold identity operation"
3420 (let* ((y (lvar-value y))
3421 (width (or (least-zero-bit y) '*)))
3422 (unless (and (neq width 0) ; (logand x 0) handled elsewhere
3423 (csubtypep (lvar-type x)
3424 (specifier-type `(unsigned-byte ,width))))
3425 (give-up-ir1-transform))
3428 (deftransform mask-signed-field ((size x) ((constant-arg t) *) *)
3429 "fold identity operation"
3430 (let ((size (lvar-value size)))
3431 (unless (csubtypep (lvar-type x) (specifier-type `(signed-byte ,size)))
3432 (give-up-ir1-transform))
3435 (deftransform logior ((x y) (* (constant-arg t)) *)
3436 "fold identity operation"
3437 (let* ((y (lvar-value y))
3438 (width (or (least-zero-bit (lognot y))
3439 (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
3440 (unless (csubtypep (lvar-type x)
3441 (specifier-type `(integer ,(- (ash 1 width)) -1)))
3442 (give-up-ir1-transform))
3445 ;;; Pick off easy association opportunities for constant folding.
3446 ;;; More complicated stuff that also depends on commutativity
3447 ;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
3448 ;;; probably be handled with a more general tree-rewriting pass.
3449 (macrolet ((def (operator &key (type 'integer) (folded operator))
3450 `(deftransform ,operator ((x z) (,type (constant-arg ,type)))
3451 ,(format nil "associate ~A/~A of constants"
3453 (binding* ((node (if (lvar-has-single-use-p x)
3455 (give-up-ir1-transform)))
3456 (nil (or (and (combination-p node)
3458 (combination-fun node))
3460 (give-up-ir1-transform)))
3461 (y (second (combination-args node)))
3462 (nil (or (constant-lvar-p y)
3463 (give-up-ir1-transform)))
3465 (unless (typep y ',type)
3466 (give-up-ir1-transform))
3467 (splice-fun-args x ',folded 2)
3469 (declare (ignore y z))
3470 ;; (operator (folded x y) z)
3471 ;; == (operator x (folded z y))
3472 (,',operator x ',(,folded (lvar-value z) y)))))))
3476 (def logtest :folded logand)
3477 (def + :type rational)
3478 (def + :type rational :folded -)
3479 (def * :type rational)
3480 (def * :type rational :folded /))
3482 (deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
3483 "Fold mask-signed-field/mask-signed-field of constant width"
3484 (binding* ((node (if (lvar-has-single-use-p x)
3486 (give-up-ir1-transform)))
3487 (nil (or (combination-p node)
3488 (give-up-ir1-transform)))
3489 (nil (or (eq (lvar-fun-name (combination-fun node))
3491 (give-up-ir1-transform)))
3492 (x-width (first (combination-args node)))
3493 (nil (or (constant-lvar-p x-width)
3494 (give-up-ir1-transform)))
3495 (x-width (lvar-value x-width)))
3496 (unless (typep x-width 'unsigned-byte)
3497 (give-up-ir1-transform))
3498 (splice-fun-args x 'mask-signed-field 2)
3499 `(lambda (width x-width x)
3500 (declare (ignore width x-width))
3501 (mask-signed-field ,(min (lvar-value width) x-width) x))))
3503 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
3504 ;;; (* 0 -4.0) is -0.0.
3505 (deftransform - ((x y) ((constant-arg (member 0)) rational) *)
3506 "convert (- 0 x) to negate"
3508 (deftransform * ((x y) (rational (constant-arg (member 0))) *)
3509 "convert (* x 0) to 0"
3512 (deftransform %negate ((x) (rational))
3513 "Eliminate %negate/%negate of rationals"
3514 (splice-fun-args x '%negate 1)
3517 (deftransform %negate ((x) (number))
3519 (let ((use (lvar-uses x))
3521 (unless (and (combination-p use)
3522 (eql '* (lvar-fun-name (combination-fun use)))
3523 (constant-lvar-p (setf arg (second (combination-args use))))
3524 (numberp (setf arg (lvar-value arg))))
3525 (give-up-ir1-transform))
3526 (splice-fun-args x '* 2)
3528 (declare (ignore y))
3531 ;;; Return T if in an arithmetic op including lvars X and Y, the
3532 ;;; result type is not affected by the type of X. That is, Y is at
3533 ;;; least as contagious as X.
3535 (defun not-more-contagious (x y)
3536 (declare (type continuation x y))
3537 (let ((x (lvar-type x))
3539 (values (type= (numeric-contagion x y)
3540 (numeric-contagion y y)))))
3541 ;;; Patched version by Raymond Toy. dtc: Should be safer although it
3542 ;;; XXX needs more work as valid transforms are missed; some cases are
3543 ;;; specific to particular transform functions so the use of this
3544 ;;; function may need a re-think.
3545 (defun not-more-contagious (x y)
3546 (declare (type lvar x y))
3547 (flet ((simple-numeric-type (num)
3548 (and (numeric-type-p num)
3549 ;; Return non-NIL if NUM is integer, rational, or a float
3550 ;; of some type (but not FLOAT)
3551 (case (numeric-type-class num)
3555 (numeric-type-format num))
3558 (let ((x (lvar-type x))
3560 (if (and (simple-numeric-type x)
3561 (simple-numeric-type y))
3562 (values (type= (numeric-contagion x y)
3563 (numeric-contagion y y)))))))
3565 (def!type exact-number ()
3566 '(or rational (complex rational)))
3570 ;;; Only safely applicable for exact numbers. For floating-point
3571 ;;; x, one would have to first show that neither x or y are signed
3572 ;;; 0s, and that x isn't an SNaN.
3573 (deftransform + ((x y) (exact-number (constant-arg (eql 0))) *)
3578 (deftransform - ((x y) (exact-number (constant-arg (eql 0))) *)
3582 ;;; Fold (OP x +/-1)
3584 ;;; %NEGATE might not always signal correctly.
3586 ((def (name result minus-result)
3587 `(deftransform ,name ((x y)
3588 (exact-number (constant-arg (member 1 -1))))
3589 "fold identity operations"
3590 (if (minusp (lvar-value y)) ',minus-result ',result))))
3591 (def * x (%negate x))
3592 (def / x (%negate x))
3593 (def expt x (/ 1 x)))
3595 ;;; Fold (expt x n) into multiplications for small integral values of
3596 ;;; N; convert (expt x 1/2) to sqrt.
3597 (deftransform expt ((x y) (t (constant-arg real)) *)
3598 "recode as multiplication or sqrt"
3599 (let ((val (lvar-value y)))
3600 ;; If Y would cause the result to be promoted to the same type as
3601 ;; Y, we give up. If not, then the result will be the same type
3602 ;; as X, so we can replace the exponentiation with simple
3603 ;; multiplication and division for small integral powers.
3604 (unless (not-more-contagious y x)
3605 (give-up-ir1-transform))
3607 (let ((x-type (lvar-type x)))
3608 (cond ((csubtypep x-type (specifier-type '(or rational
3609 (complex rational))))
3611 ((csubtypep x-type (specifier-type 'real))
3615 ((csubtypep x-type (specifier-type 'complex))
3616 ;; both parts are float
3618 (t (give-up-ir1-transform)))))
3619 ((= val 2) '(* x x))
3620 ((= val -2) '(/ (* x x)))
3621 ((= val 3) '(* x x x))
3622 ((= val -3) '(/ (* x x x)))
3623 ((= val 1/2) '(sqrt x))
3624 ((= val -1/2) '(/ (sqrt x)))
3625 (t (give-up-ir1-transform)))))
3627 (deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *)
3628 "recode as an ODDP check"
3629 (let ((val (lvar-value x)))
3631 '(- 1 (* 2 (logand 1 y)))
3636 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
3637 ;;; transformations?
3638 ;;; Perhaps we should have to prove that the denominator is nonzero before
3639 ;;; doing them? -- WHN 19990917
3640 (macrolet ((def (name)
3641 `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
3648 (macrolet ((def (name)
3649 `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
3658 (macrolet ((def (name &optional float)
3659 (let ((x (if float '(float x) 'x)))
3660 `(deftransform ,name ((x y) (integer (constant-arg (member 1 -1)))
3662 "fold division by 1"
3663 `(values ,(if (minusp (lvar-value y))
3676 ;;;; character operations
3678 (deftransform char-equal ((a b) (base-char base-char))
3680 '(let* ((ac (char-code a))
3682 (sum (logxor ac bc)))
3684 (when (eql sum #x20)
3685 (let ((sum (+ ac bc)))
3686 (or (and (> sum 161) (< sum 213))
3687 (and (> sum 415) (< sum 461))
3688 (and (> sum 463) (< sum 477))))))))
3690 (deftransform char-upcase ((x) (base-char))
3692 '(let ((n-code (char-code x)))
3693 (if (or (and (> n-code #o140) ; Octal 141 is #\a.
3694 (< n-code #o173)) ; Octal 172 is #\z.
3695 (and (> n-code #o337)
3697 (and (> n-code #o367)
3699 (code-char (logxor #x20 n-code))
3702 (deftransform char-downcase ((x) (base-char))
3704 '(let ((n-code (char-code x)))
3705 (if (or (and (> n-code 64) ; 65 is #\A.
3706 (< n-code 91)) ; 90 is #\Z.
3711 (code-char (logxor #x20 n-code))
3714 ;;;; equality predicate transforms
3716 ;;; Return true if X and Y are lvars whose only use is a
3717 ;;; reference to the same leaf, and the value of the leaf cannot
3719 (defun same-leaf-ref-p (x y)
3720 (declare (type lvar x y))
3721 (let ((x-use (principal-lvar-use x))
3722 (y-use (principal-lvar-use y)))
3725 (eq (ref-leaf x-use) (ref-leaf y-use))
3726 (constant-reference-p x-use))))
3728 ;;; If X and Y are the same leaf, then the result is true. Otherwise,
3729 ;;; if there is no intersection between the types of the arguments,
3730 ;;; then the result is definitely false.
3731 (deftransform simple-equality-transform ((x y) * *
3734 ((same-leaf-ref-p x y) t)
3735 ((not (types-equal-or-intersect (lvar-type x) (lvar-type y)))
3737 (t (give-up-ir1-transform))))
3740 `(%deftransform ',x '(function * *) #'simple-equality-transform)))
3744 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
3745 ;;; try to convert to a type-specific predicate or EQ:
3746 ;;; -- If both args are characters, convert to CHAR=. This is better than
3747 ;;; just converting to EQ, since CHAR= may have special compilation
3748 ;;; strategies for non-standard representations, etc.
3749 ;;; -- If either arg is definitely a fixnum, we check to see if X is
3750 ;;; constant and if so, put X second. Doing this results in better
3751 ;;; code from the backend, since the backend assumes that any constant
3752 ;;; argument comes second.
3753 ;;; -- If either arg is definitely not a number or a fixnum, then we
3754 ;;; can compare with EQ.
3755 ;;; -- Otherwise, we try to put the arg we know more about second. If X
3756 ;;; is constant then we put it second. If X is a subtype of Y, we put
3757 ;;; it second. These rules make it easier for the back end to match
3758 ;;; these interesting cases.
3759 (deftransform eql ((x y) * * :node node)
3760 "convert to simpler equality predicate"
3761 (let ((x-type (lvar-type x))
3762 (y-type (lvar-type y))
3763 (char-type (specifier-type 'character)))
3764 (flet ((fixnum-type-p (type)
3765 (csubtypep type (specifier-type 'fixnum))))
3767 ((same-leaf-ref-p x y) t)
3768 ((not (types-equal-or-intersect x-type y-type))
3770 ((and (csubtypep x-type char-type)
3771 (csubtypep y-type char-type))
3773 ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
3774 (if (and (constant-lvar-p x) (not (constant-lvar-p y)))
3777 ((and (not (constant-lvar-p y))
3778 (or (constant-lvar-p x)
3779 (and (csubtypep x-type y-type)
3780 (not (csubtypep y-type x-type)))))
3783 (give-up-ir1-transform))))))
3785 ;;; similarly to the EQL transform above, we attempt to constant-fold
3786 ;;; or convert to a simpler predicate: mostly we have to be careful
3787 ;;; with strings and bit-vectors.
3788 (deftransform equal ((x y) * *)
3789 "convert to simpler equality predicate"
3790 (let ((x-type (lvar-type x))
3791 (y-type (lvar-type y))
3792 (string-type (specifier-type 'string))
3793 (bit-vector-type (specifier-type 'bit-vector)))
3795 ((same-leaf-ref-p x y) t)
3796 ((and (csubtypep x-type string-type)
3797 (csubtypep y-type string-type))
3799 ((and (csubtypep x-type bit-vector-type)
3800 (csubtypep y-type bit-vector-type))
3801 '(bit-vector-= x y))
3802 ;; if at least one is not a string, and at least one is not a
3803 ;; bit-vector, then we can reason from types.
3804 ((and (not (and (types-equal-or-intersect x-type string-type)
3805 (types-equal-or-intersect y-type string-type)))
3806 (not (and (types-equal-or-intersect x-type bit-vector-type)
3807 (types-equal-or-intersect y-type bit-vector-type)))
3808 (not (types-equal-or-intersect x-type y-type)))
3810 (t (give-up-ir1-transform)))))
3812 ;;; Convert to EQL if both args are rational and complexp is specified
3813 ;;; and the same for both.
3814 (deftransform = ((x y) (number number) *)
3816 (let ((x-type (lvar-type x))
3817 (y-type (lvar-type y)))
3818 (cond ((or (and (csubtypep x-type (specifier-type 'float))
3819 (csubtypep y-type (specifier-type 'float)))
3820 (and (csubtypep x-type (specifier-type '(complex float)))
3821 (csubtypep y-type (specifier-type '(complex float))))
3822 #!+complex-float-vops
3823 (and (csubtypep x-type (specifier-type '(or single-float (complex single-float))))
3824 (csubtypep y-type (specifier-type '(or single-float (complex single-float)))))
3825 #!+complex-float-vops
3826 (and (csubtypep x-type (specifier-type '(or double-float (complex double-float))))
3827 (csubtypep y-type (specifier-type '(or double-float (complex double-float))))))
3828 ;; They are both floats. Leave as = so that -0.0 is
3829 ;; handled correctly.
3830 (give-up-ir1-transform))
3831 ((or (and (csubtypep x-type (specifier-type 'rational))
3832 (csubtypep y-type (specifier-type 'rational)))
3833 (and (csubtypep x-type
3834 (specifier-type '(complex rational)))
3836 (specifier-type '(complex rational)))))
3837 ;; They are both rationals and complexp is the same.
3841 (give-up-ir1-transform
3842 "The operands might not be the same type.")))))
3844 (defun maybe-float-lvar-p (lvar)
3845 (neq *empty-type* (type-intersection (specifier-type 'float)
3848 (flet ((maybe-invert (node op inverted x y)
3849 ;; Don't invert if either argument can be a float (NaNs)
3851 ((or (maybe-float-lvar-p x) (maybe-float-lvar-p y))
3852 (delay-ir1-transform node :constraint)
3853 `(or (,op x y) (= x y)))
3855 `(if (,inverted x y) nil t)))))
3856 (deftransform >= ((x y) (number number) * :node node)
3857 "invert or open code"
3858 (maybe-invert node '> '< x y))
3859 (deftransform <= ((x y) (number number) * :node node)
3860 "invert or open code"
3861 (maybe-invert node '< '> x y)))
3863 ;;; See whether we can statically determine (< X Y) using type
3864 ;;; information. If X's high bound is < Y's low, then X < Y.
3865 ;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
3866 ;;; NIL). If not, at least make sure any constant arg is second.
3867 (macrolet ((def (name inverse reflexive-p surely-true surely-false)
3868 `(deftransform ,name ((x y))
3869 "optimize using intervals"
3870 (if (and (same-leaf-ref-p x y)
3871 ;; For non-reflexive functions we don't need
3872 ;; to worry about NaNs: (non-ref-op NaN NaN) => false,
3873 ;; but with reflexive ones we don't know...
3875 '((and (not (maybe-float-lvar-p x))
3876 (not (maybe-float-lvar-p y))))))
3878 (let ((ix (or (type-approximate-interval (lvar-type x))
3879 (give-up-ir1-transform)))
3880 (iy (or (type-approximate-interval (lvar-type y))
3881 (give-up-ir1-transform))))
3886 ((and (constant-lvar-p x)
3887 (not (constant-lvar-p y)))
3890 (give-up-ir1-transform))))))))
3891 (def = = t (interval-= ix iy) (interval-/= ix iy))
3892 (def /= /= nil (interval-/= ix iy) (interval-= ix iy))
3893 (def < > nil (interval-< ix iy) (interval->= ix iy))
3894 (def > < nil (interval-< iy ix) (interval->= iy ix))
3895 (def <= >= t (interval->= iy ix) (interval-< iy ix))
3896 (def >= <= t (interval->= ix iy) (interval-< ix iy)))
3898 (defun ir1-transform-char< (x y first second inverse)
3900 ((same-leaf-ref-p x y) nil)
3901 ;; If we had interval representation of character types, as we
3902 ;; might eventually have to to support 2^21 characters, then here
3903 ;; we could do some compile-time computation as in transforms for
3904 ;; < above. -- CSR, 2003-07-01
3905 ((and (constant-lvar-p first)
3906 (not (constant-lvar-p second)))
3908 (t (give-up-ir1-transform))))
3910 (deftransform char< ((x y) (character character) *)
3911 (ir1-transform-char< x y x y 'char>))
3913 (deftransform char> ((x y) (character character) *)
3914 (ir1-transform-char< y x x y 'char<))
3916 ;;;; converting N-arg comparisons
3918 ;;;; We convert calls to N-arg comparison functions such as < into
3919 ;;;; two-arg calls. This transformation is enabled for all such
3920 ;;;; comparisons in this file. If any of these predicates are not
3921 ;;;; open-coded, then the transformation should be removed at some
3922 ;;;; point to avoid pessimization.
3924 ;;; This function is used for source transformation of N-arg
3925 ;;; comparison functions other than inequality. We deal both with
3926 ;;; converting to two-arg calls and inverting the sense of the test,
3927 ;;; if necessary. If the call has two args, then we pass or return a
3928 ;;; negated test as appropriate. If it is a degenerate one-arg call,
3929 ;;; then we transform to code that returns true. Otherwise, we bind
3930 ;;; all the arguments and expand into a bunch of IFs.
3931 (defun multi-compare (predicate args not-p type &optional force-two-arg-p)
3932 (let ((nargs (length args)))
3933 (cond ((< nargs 1) (values nil t))
3934 ((= nargs 1) `(progn (the ,type ,@args) t))
3937 `(if (,predicate ,(first args) ,(second args)) nil t)
3939 `(,predicate ,(first args) ,(second args))
3942 (do* ((i (1- nargs) (1- i))
3944 (current (gensym) (gensym))
3945 (vars (list current) (cons current vars))
3947 `(if (,predicate ,current ,last)
3949 `(if (,predicate ,current ,last)
3952 `((lambda ,vars (declare (type ,type ,@vars)) ,result)
3955 (define-source-transform = (&rest args) (multi-compare '= args nil 'number))
3956 (define-source-transform < (&rest args) (multi-compare '< args nil 'real))
3957 (define-source-transform > (&rest args) (multi-compare '> args nil 'real))
3958 ;;; We cannot do the inversion for >= and <= here, since both
3959 ;;; (< NaN X) and (> NaN X)
3960 ;;; are false, and we don't have type-information available yet. The
3961 ;;; deftransforms for two-argument versions of >= and <= takes care of
3962 ;;; the inversion to > and < when possible.
3963 (define-source-transform <= (&rest args) (multi-compare '<= args nil 'real))
3964 (define-source-transform >= (&rest args) (multi-compare '>= args nil 'real))
3966 (define-source-transform char= (&rest args) (multi-compare 'char= args nil
3968 (define-source-transform char< (&rest args) (multi-compare 'char< args nil
3970 (define-source-transform char> (&rest args) (multi-compare 'char> args nil
3972 (define-source-transform char<= (&rest args) (multi-compare 'char> args t
3974 (define-source-transform char>= (&rest args) (multi-compare 'char< args t
3977 (define-source-transform char-equal (&rest args)
3978 (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t))
3979 (define-source-transform char-lessp (&rest args)
3980 (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t))
3981 (define-source-transform char-greaterp (&rest args)
3982 (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t))
3983 (define-source-transform char-not-greaterp (&rest args)
3984 (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t))
3985 (define-source-transform char-not-lessp (&rest args)
3986 (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t))
3988 ;;; This function does source transformation of N-arg inequality
3989 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
3990 ;;; arg cases. If there are more than two args, then we expand into
3991 ;;; the appropriate n^2 comparisons only when speed is important.
3992 (declaim (ftype (function (symbol list t) *) multi-not-equal))
3993 (defun multi-not-equal (predicate args type)
3994 (let ((nargs (length args)))
3995 (cond ((< nargs 1) (values nil t))
3996 ((= nargs 1) `(progn (the ,type ,@args) t))
3998 `(if (,predicate ,(first args) ,(second args)) nil t))
3999 ((not (policy *lexenv*
4000 (and (>= speed space)
4001 (>= speed compilation-speed))))
4004 (let ((vars (make-gensym-list nargs)))
4005 (do ((var vars next)
4006 (next (cdr vars) (cdr next))
4009 `((lambda ,vars (declare (type ,type ,@vars)) ,result)
4011 (let ((v1 (first var)))
4013 (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
4015 (define-source-transform /= (&rest args)
4016 (multi-not-equal '= args 'number))
4017 (define-source-transform char/= (&rest args)
4018 (multi-not-equal 'char= args 'character))
4019 (define-source-transform char-not-equal (&rest args)
4020 (multi-not-equal 'char-equal args 'character))
4022 ;;; Expand MAX and MIN into the obvious comparisons.
4023 (define-source-transform max (arg0 &rest rest)
4024 (once-only ((arg0 arg0))
4026 `(values (the real ,arg0))
4027 `(let ((maxrest (max ,@rest)))
4028 (if (>= ,arg0 maxrest) ,arg0 maxrest)))))
4029 (define-source-transform min (arg0 &rest rest)
4030 (once-only ((arg0 arg0))
4032 `(values (the real ,arg0))
4033 `(let ((minrest (min ,@rest)))
4034 (if (<= ,arg0 minrest) ,arg0 minrest)))))
4036 ;;; Simplify some cross-type comparisons
4037 (macrolet ((def (comparator round)
4039 (deftransform ,comparator
4040 ((x y) (rational (constant-arg float)))
4041 "open-code RATIONAL to FLOAT comparison"
4042 (let ((y (lvar-value y)))
4044 (when (or (float-nan-p y)
4045 (float-infinity-p y))
4046 (give-up-ir1-transform))
4047 (setf y (rational y))
4049 x ,(if (csubtypep (lvar-type x)
4050 (specifier-type 'integer))
4053 (deftransform ,comparator
4054 ((x y) (integer (constant-arg ratio)))
4055 "open-code INTEGER to RATIO comparison"
4056 `(,',comparator x ,(,round (lvar-value y)))))))
4060 (deftransform = ((x y) (rational (constant-arg float)))
4061 "open-code RATIONAL to FLOAT comparison"
4062 (let ((y (lvar-value y)))
4064 (when (or (float-nan-p y)
4065 (float-infinity-p y))
4066 (give-up-ir1-transform))
4067 (setf y (rational y))
4068 (if (and (csubtypep (lvar-type x)
4069 (specifier-type 'integer))
4074 (deftransform = ((x y) (integer (constant-arg ratio)))
4075 "constant-fold INTEGER to RATIO comparison"
4078 ;;;; converting N-arg arithmetic functions
4080 ;;;; N-arg arithmetic and logic functions are associated into two-arg
4081 ;;;; versions, and degenerate cases are flushed.
4083 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
4084 (declaim (ftype (sfunction (symbol t list t) list) associate-args))
4085 (defun associate-args (fun first-arg more-args identity)
4086 (let ((next (rest more-args))
4087 (arg (first more-args)))
4089 `(,fun ,first-arg ,(if arg arg identity))
4090 (associate-args fun `(,fun ,first-arg ,arg) next identity))))
4092 ;;; Reduce constants in ARGS list.
4093 (declaim (ftype (sfunction (symbol list t symbol) list) reduce-constants))
4094 (defun reduce-constants (fun args identity one-arg-result-type)
4095 (let ((one-arg-constant-p (ecase one-arg-result-type
4097 (integer #'integerp)))
4098 (reduced-value identity)
4100 (collect ((not-constants))
4102 (if (funcall one-arg-constant-p arg)
4103 (setf reduced-value (funcall fun reduced-value arg)
4105 (not-constants arg)))
4106 ;; It is tempting to drop constants reduced to identity here,
4107 ;; but if X is SNaN in (* X 1), we cannot drop the 1.
4110 `(,reduced-value ,@(not-constants))
4112 `(,reduced-value)))))
4114 ;;; Do source transformations for transitive functions such as +.
4115 ;;; One-arg cases are replaced with the arg and zero arg cases with
4116 ;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE)
4117 ;;; that the argument in one-argument calls is.
4118 (declaim (ftype (function (symbol list t &optional symbol list)
4119 (values t &optional (member nil t)))
4120 source-transform-transitive))
4121 (defun source-transform-transitive (fun args identity
4122 &optional (one-arg-result-type 'number)
4123 (one-arg-prefixes '(values)))
4126 (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
4128 (t (let ((reduced-args (reduce-constants fun args identity one-arg-result-type)))
4129 (associate-args fun (first reduced-args) (rest reduced-args) identity)))))
4131 (define-source-transform + (&rest args)
4132 (source-transform-transitive '+ args 0))
4133 (define-source-transform * (&rest args)
4134 (source-transform-transitive '* args 1))
4135 (define-source-transform logior (&rest args)
4136 (source-transform-transitive 'logior args 0 'integer))
4137 (define-source-transform logxor (&rest args)
4138 (source-transform-transitive 'logxor args 0 'integer))
4139 (define-source-transform logand (&rest args)
4140 (source-transform-transitive 'logand args -1 'integer))
4141 (define-source-transform logeqv (&rest args)
4142 (source-transform-transitive 'logeqv args -1 'integer))
4143 (define-source-transform gcd (&rest args)
4144 (source-transform-transitive 'gcd args 0 'integer '(abs)))
4145 (define-source-transform lcm (&rest args)
4146 (source-transform-transitive 'lcm args 1 'integer '(abs)))
4148 ;;; Do source transformations for intransitive n-arg functions such as
4149 ;;; /. With one arg, we form the inverse. With two args we pass.
4150 ;;; Otherwise we associate into two-arg calls.
4151 (declaim (ftype (function (symbol symbol list t list &optional symbol)
4152 (values list &optional (member nil t)))
4153 source-transform-intransitive))
4154 (defun source-transform-intransitive (fun fun* args identity one-arg-prefixes
4155 &optional (one-arg-result-type 'number))
4157 ((0 2) (values nil t))
4158 (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
4159 (t (let ((reduced-args
4160 (reduce-constants fun* (rest args) identity one-arg-result-type)))
4161 (associate-args fun (first args) reduced-args identity)))))
4163 (define-source-transform - (&rest args)
4164 (source-transform-intransitive '- '+ args 0 '(%negate)))
4165 (define-source-transform / (&rest args)
4166 (source-transform-intransitive '/ '* args 1 '(/ 1)))
4168 ;;;; transforming APPLY
4170 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
4171 ;;; only needs to understand one kind of variable-argument call. It is
4172 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
4173 (define-source-transform apply (fun arg &rest more-args)
4174 (let ((args (cons arg more-args)))
4175 `(multiple-value-call ,fun
4176 ,@(mapcar (lambda (x) `(values ,x)) (butlast args))
4177 (values-list ,(car (last args))))))
4179 ;;;; transforming references to &REST argument
4181 ;;; We add magical &MORE arguments to all functions with &REST. If ARG names
4182 ;;; the &REST argument, this returns the lambda-vars for the context and
4184 (defun possible-rest-arg-context (arg)
4186 (let* ((var (lexenv-find arg vars))
4187 (info (when (lambda-var-p var)
4188 (lambda-var-arg-info var))))
4190 (eq :rest (arg-info-kind info))
4191 (consp (arg-info-default info)))
4192 (values-list (arg-info-default info))))))
4194 (defun mark-more-context-used (rest-var)
4195 (let ((info (lambda-var-arg-info rest-var)))
4196 (aver (eq :rest (arg-info-kind info)))
4197 (destructuring-bind (context count &optional used) (arg-info-default info)
4199 (setf (arg-info-default info) (list context count t))))))
4201 (defun mark-more-context-invalid (rest-var)
4202 (let ((info (lambda-var-arg-info rest-var)))
4203 (aver (eq :rest (arg-info-kind info)))
4204 (setf (arg-info-default info) t)))
4206 ;;; This determines of we the REF to a &REST variable is headed towards
4207 ;;; parts unknown, or if we can really use the context.
4208 (defun rest-var-more-context-ok (lvar)
4209 (let* ((use (lvar-use lvar))
4210 (var (when (ref-p use) (ref-leaf use)))
4211 (home (when (lambda-var-p var) (lambda-var-home var)))
4212 (info (when (lambda-var-p var) (lambda-var-arg-info var)))
4213 (restp (when info (eq :rest (arg-info-kind info)))))
4214 (flet ((ref-good-for-more-context-p (ref)
4215 (let ((dest (principal-lvar-end (node-lvar ref))))
4216 (and (combination-p dest)
4217 ;; If the destination is to anything but these, we're going to
4218 ;; actually need the rest list -- and since other operations
4219 ;; might modify the list destructively, the using the context
4220 ;; isn't good anywhere else either.
4221 (lvar-fun-is (combination-fun dest)
4222 '(%rest-values %rest-ref %rest-length
4223 %rest-null %rest-true))
4224 ;; If the home lambda is different and isn't DX, it might
4225 ;; escape -- in which case using the more context isn't safe.
4226 (let ((clambda (node-home-lambda dest)))
4227 (or (eq home clambda)
4228 (leaf-dynamic-extent clambda)))))))
4229 (let ((ok (and restp
4230 (consp (arg-info-default info))
4231 (not (lambda-var-specvar var))
4232 (not (lambda-var-sets var))
4233 (every #'ref-good-for-more-context-p (lambda-var-refs var)))))
4235 (mark-more-context-used var)
4237 (mark-more-context-invalid var)))
4240 ;;; VALUES-LIST -> %REST-VALUES
4241 (define-source-transform values-list (list)
4242 (multiple-value-bind (context count) (possible-rest-arg-context list)
4244 `(%rest-values ,list ,context ,count)
4247 ;;; NTH -> %REST-REF
4248 (define-source-transform nth (n list)
4249 (multiple-value-bind (context count) (possible-rest-arg-context list)
4251 `(%rest-ref ,n ,list ,context ,count)
4252 `(car (nthcdr ,n ,list)))))
4254 (define-source-transform elt (seq n)
4255 (if (policy *lexenv* (= safety 3))
4257 (multiple-value-bind (context count) (possible-rest-arg-context seq)
4259 `(%rest-ref ,n ,seq ,context ,count)
4262 ;;; CAxR -> %REST-REF
4263 (defun source-transform-car (list nth)
4264 (multiple-value-bind (context count) (possible-rest-arg-context list)
4266 `(%rest-ref ,nth ,list ,context ,count)
4269 (define-source-transform car (list)
4270 (source-transform-car list 0))
4272 (define-source-transform cadr (list)
4273 (or (source-transform-car list 1)
4274 `(car (cdr ,list))))
4276 (define-source-transform caddr (list)
4277 (or (source-transform-car list 2)
4278 `(car (cdr (cdr ,list)))))
4280 (define-source-transform cadddr (list)
4281 (or (source-transform-car list 3)
4282 `(car (cdr (cdr (cdr ,list))))))
4284 ;;; LENGTH -> %REST-LENGTH
4285 (defun source-transform-length (list)
4286 (multiple-value-bind (context count) (possible-rest-arg-context list)
4288 `(%rest-length ,list ,context ,count)
4290 (define-source-transform length (list) (source-transform-length list))
4291 (define-source-transform list-length (list) (source-transform-length list))
4293 ;;; ENDP, NULL and NOT -> %REST-NULL
4295 ;;; Outside &REST convert into an IF so that IF optimizations will eliminate
4296 ;;; redundant negations.
4297 (defun source-transform-null (x op)
4298 (multiple-value-bind (context count) (possible-rest-arg-context x)
4300 `(%rest-null ',op ,x ,context ,count))
4302 `(if (the list ,x) nil t))
4305 (define-source-transform not (x) (source-transform-null x 'not))
4306 (define-source-transform null (x) (source-transform-null x 'null))
4307 (define-source-transform endp (x) (source-transform-null x 'endp))
4309 (deftransform %rest-values ((list context count))
4310 (if (rest-var-more-context-ok list)
4311 `(%more-arg-values context 0 count)
4312 `(values-list list)))
4314 (deftransform %rest-ref ((n list context count))
4315 (cond ((rest-var-more-context-ok list)
4316 `(and (< (the index n) count)
4317 (%more-arg context n)))
4318 ((and (constant-lvar-p n) (zerop (lvar-value n)))
4323 (deftransform %rest-length ((list context count))
4324 (if (rest-var-more-context-ok list)
4328 (deftransform %rest-null ((op list context count))
4329 (aver (constant-lvar-p op))
4330 (if (rest-var-more-context-ok list)
4332 `(,(lvar-value op) list)))
4334 (deftransform %rest-true ((list context count))
4335 (if (rest-var-more-context-ok list)
4336 `(not (eql 0 count))
4339 ;;;; transforming FORMAT
4341 ;;;; If the control string is a compile-time constant, then replace it
4342 ;;;; with a use of the FORMATTER macro so that the control string is
4343 ;;;; ``compiled.'' Furthermore, if the destination is either a stream
4344 ;;;; or T and the control string is a function (i.e. FORMATTER), then
4345 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
4347 ;;; for compile-time argument count checking.
4349 ;;; FIXME II: In some cases, type information could be correlated; for
4350 ;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
4351 ;;; of a corresponding argument is known and does not intersect the
4352 ;;; list type, a warning could be signalled.
4353 (defun check-format-args (string args fun)
4354 (declare (type string string))
4355 (unless (typep string 'simple-string)
4356 (setq string (coerce string 'simple-string)))
4357 (multiple-value-bind (min max)
4358 (handler-case (sb!format:%compiler-walk-format-string string args)
4359 (sb!format:format-error (c)
4360 (compiler-warn "~A" c)))
4362 (let ((nargs (length args)))
4365 (warn 'format-too-few-args-warning
4367 "Too few arguments (~D) to ~S ~S: requires at least ~D."
4368 :format-arguments (list nargs fun string min)))
4370 (warn 'format-too-many-args-warning
4372 "Too many arguments (~D) to ~S ~S: uses at most ~D."
4373 :format-arguments (list nargs fun string max))))))))
4375 (defoptimizer (format optimizer) ((dest control &rest args))
4376 (when (constant-lvar-p control)
4377 (let ((x (lvar-value control)))
4379 (check-format-args x args 'format)))))
4381 ;;; We disable this transform in the cross-compiler to save memory in
4382 ;;; the target image; most of the uses of FORMAT in the compiler are for
4383 ;;; error messages, and those don't need to be particularly fast.
4385 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
4386 :policy (>= speed space))
4387 (unless (constant-lvar-p control)
4388 (give-up-ir1-transform "The control string is not a constant."))
4389 (let ((arg-names (make-gensym-list (length args))))
4390 `(lambda (dest control ,@arg-names)
4391 (declare (ignore control))
4392 (format dest (formatter ,(lvar-value control)) ,@arg-names))))
4394 (deftransform format ((stream control &rest args) (stream function &rest t))
4395 (let ((arg-names (make-gensym-list (length args))))
4396 `(lambda (stream control ,@arg-names)
4397 (funcall control stream ,@arg-names)
4400 (deftransform format ((tee control &rest args) ((member t) function &rest t))
4401 (let ((arg-names (make-gensym-list (length args))))
4402 `(lambda (tee control ,@arg-names)
4403 (declare (ignore tee))
4404 (funcall control *standard-output* ,@arg-names)
4407 (deftransform pathname ((pathspec) (pathname) *)
4410 (deftransform pathname ((pathspec) (string) *)
4411 '(values (parse-namestring pathspec)))
4415 `(defoptimizer (,name optimizer) ((control &rest args))
4416 (when (constant-lvar-p control)
4417 (let ((x (lvar-value control)))
4419 (check-format-args x args ',name)))))))
4422 #+sb-xc-host ; Only we should be using these
4425 (def compiler-error)
4427 (def compiler-style-warn)
4428 (def compiler-notify)
4429 (def maybe-compiler-notify)
4432 (defoptimizer (cerror optimizer) ((report control &rest args))
4433 (when (and (constant-lvar-p control)
4434 (constant-lvar-p report))
4435 (let ((x (lvar-value control))
4436 (y (lvar-value report)))
4437 (when (and (stringp x) (stringp y))
4438 (multiple-value-bind (min1 max1)
4440 (sb!format:%compiler-walk-format-string x args)
4441 (sb!format:format-error (c)
4442 (compiler-warn "~A" c)))
4444 (multiple-value-bind (min2 max2)
4446 (sb!format:%compiler-walk-format-string y args)
4447 (sb!format:format-error (c)
4448 (compiler-warn "~A" c)))
4450 (let ((nargs (length args)))
4452 ((< nargs (min min1 min2))
4453 (warn 'format-too-few-args-warning
4455 "Too few arguments (~D) to ~S ~S ~S: ~
4456 requires at least ~D."
4458 (list nargs 'cerror y x (min min1 min2))))
4459 ((> nargs (max max1 max2))
4460 (warn 'format-too-many-args-warning
4462 "Too many arguments (~D) to ~S ~S ~S: ~
4465 (list nargs 'cerror y x (max max1 max2))))))))))))))
4467 (defoptimizer (coerce derive-type) ((value type) node)
4469 ((constant-lvar-p type)
4470 ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
4471 ;; but dealing with the niggle that complex canonicalization gets
4472 ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
4474 (let* ((specifier (lvar-value type))
4475 (result-typeoid (careful-specifier-type specifier)))
4477 ((null result-typeoid) nil)
4478 ((csubtypep result-typeoid (specifier-type 'number))
4479 ;; the difficult case: we have to cope with ANSI 12.1.5.3
4480 ;; Rule of Canonical Representation for Complex Rationals,
4481 ;; which is a truly nasty delivery to field.
4483 ((csubtypep result-typeoid (specifier-type 'real))
4484 ;; cleverness required here: it would be nice to deduce
4485 ;; that something of type (INTEGER 2 3) coerced to type
4486 ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0).
4487 ;; FLOAT gets its own clause because it's implemented as
4488 ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE
4491 ((and (numeric-type-p result-typeoid)
4492 (eq (numeric-type-complexp result-typeoid) :real))
4493 ;; FIXME: is this clause (a) necessary or (b) useful?
4495 ((or (csubtypep result-typeoid
4496 (specifier-type '(complex single-float)))
4497 (csubtypep result-typeoid
4498 (specifier-type '(complex double-float)))
4500 (csubtypep result-typeoid
4501 (specifier-type '(complex long-float))))
4502 ;; float complex types are never canonicalized.
4505 ;; if it's not a REAL, or a COMPLEX FLOAToid, it's
4506 ;; probably just a COMPLEX or equivalent. So, in that
4507 ;; case, we will return a complex or an object of the
4508 ;; provided type if it's rational:
4509 (type-union result-typeoid
4510 (type-intersection (lvar-type value)
4511 (specifier-type 'rational))))))
4512 ((and (policy node (zerop safety))
4513 (csubtypep result-typeoid (specifier-type '(array * (*)))))
4514 ;; At zero safety the deftransform for COERCE can elide dimension
4515 ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
4516 ;; need to simplify the type to drop the dimension information.
4517 (let ((vtype (simplify-vector-type result-typeoid)))
4519 (specifier-type vtype)
4524 ;; OK, the result-type argument isn't constant. However, there
4525 ;; are common uses where we can still do better than just
4526 ;; *UNIVERSAL-TYPE*: e.g. (COERCE X (ARRAY-ELEMENT-TYPE Y)),
4527 ;; where Y is of a known type. See messages on cmucl-imp
4528 ;; 2001-02-14 and sbcl-devel 2002-12-12. We only worry here
4529 ;; about types that can be returned by (ARRAY-ELEMENT-TYPE Y), on
4530 ;; the basis that it's unlikely that other uses are both
4531 ;; time-critical and get to this branch of the COND (non-constant
4532 ;; second argument to COERCE). -- CSR, 2002-12-16
4533 (let ((value-type (lvar-type value))
4534 (type-type (lvar-type type)))
4536 ((good-cons-type-p (cons-type)
4537 ;; Make sure the cons-type we're looking at is something
4538 ;; we're prepared to handle which is basically something
4539 ;; that array-element-type can return.
4540 (or (and (member-type-p cons-type)
4541 (eql 1 (member-type-size cons-type))
4542 (null (first (member-type-members cons-type))))
4543 (let ((car-type (cons-type-car-type cons-type)))
4544 (and (member-type-p car-type)
4545 (eql 1 (member-type-members car-type))
4546 (let ((elt (first (member-type-members car-type))))
4550 (numberp (first elt)))))
4551 (good-cons-type-p (cons-type-cdr-type cons-type))))))
4552 (unconsify-type (good-cons-type)
4553 ;; Convert the "printed" respresentation of a cons
4554 ;; specifier into a type specifier. That is, the
4555 ;; specifier (CONS (EQL SIGNED-BYTE) (CONS (EQL 16)
4556 ;; NULL)) is converted to (SIGNED-BYTE 16).
4557 (cond ((or (null good-cons-type)
4558 (eq good-cons-type 'null))
4560 ((and (eq (first good-cons-type) 'cons)
4561 (eq (first (second good-cons-type)) 'member))
4562 `(,(second (second good-cons-type))
4563 ,@(unconsify-type (caddr good-cons-type))))))
4564 (coerceable-p (part)
4565 ;; Can the value be coerced to the given type? Coerce is
4566 ;; complicated, so we don't handle every possible case
4567 ;; here---just the most common and easiest cases:
4569 ;; * Any REAL can be coerced to a FLOAT type.
4570 ;; * Any NUMBER can be coerced to a (COMPLEX
4571 ;; SINGLE/DOUBLE-FLOAT).
4573 ;; FIXME I: we should also be able to deal with characters
4576 ;; FIXME II: I'm not sure that anything is necessary
4577 ;; here, at least while COMPLEX is not a specialized
4578 ;; array element type in the system. Reasoning: if
4579 ;; something cannot be coerced to the requested type, an
4580 ;; error will be raised (and so any downstream compiled
4581 ;; code on the assumption of the returned type is
4582 ;; unreachable). If something can, then it will be of
4583 ;; the requested type, because (by assumption) COMPLEX
4584 ;; (and other difficult types like (COMPLEX INTEGER)
4585 ;; aren't specialized types.
4586 (let ((coerced-type (careful-specifier-type part)))
4588 (or (and (csubtypep coerced-type (specifier-type 'float))
4589 (csubtypep value-type (specifier-type 'real)))
4590 (and (csubtypep coerced-type
4591 (specifier-type `(or (complex single-float)
4592 (complex double-float))))
4593 (csubtypep value-type (specifier-type 'number)))))))
4594 (process-types (type)
4595 ;; FIXME: This needs some work because we should be able
4596 ;; to derive the resulting type better than just the
4597 ;; type arg of coerce. That is, if X is (INTEGER 10
4598 ;; 20), then (COERCE X 'DOUBLE-FLOAT) should say
4599 ;; (DOUBLE-FLOAT 10d0 20d0) instead of just
4601 (cond ((member-type-p type)
4604 (mapc-member-type-members
4606 (if (coerceable-p member)
4607 (push member members)
4608 (return-from punt *universal-type*)))
4610 (specifier-type `(or ,@members)))))
4611 ((and (cons-type-p type)
4612 (good-cons-type-p type))
4613 (let ((c-type (unconsify-type (type-specifier type))))
4614 (if (coerceable-p c-type)
4615 (specifier-type c-type)
4618 *universal-type*))))
4619 (cond ((union-type-p type-type)
4620 (apply #'type-union (mapcar #'process-types
4621 (union-type-types type-type))))
4622 ((or (member-type-p type-type)
4623 (cons-type-p type-type))
4624 (process-types type-type))
4626 *universal-type*)))))))
4628 (defoptimizer (compile derive-type) ((nameoid function))
4629 (when (csubtypep (lvar-type nameoid)
4630 (specifier-type 'null))
4631 (values-specifier-type '(values function boolean boolean))))
4633 ;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
4634 ;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
4635 ;;; optimizer, above).
4636 (defoptimizer (array-element-type derive-type) ((array))
4637 (let ((array-type (lvar-type array)))
4638 (labels ((consify (list)
4641 `(cons (eql ,(car list)) ,(consify (rest list)))))
4642 (get-element-type (a)
4644 (type-specifier (array-type-specialized-element-type a))))
4645 (cond ((eq element-type '*)
4646 (specifier-type 'type-specifier))
4647 ((symbolp element-type)
4648 (make-member-type :members (list element-type)))
4649 ((consp element-type)
4650 (specifier-type (consify element-type)))
4652 (error "can't understand type ~S~%" element-type))))))
4653 (labels ((recurse (type)
4654 (cond ((array-type-p type)
4655 (get-element-type type))
4656 ((union-type-p type)
4658 (mapcar #'recurse (union-type-types type))))
4660 *universal-type*))))
4661 (recurse array-type)))))
4663 (define-source-transform sb!impl::sort-vector (vector start end predicate key)
4664 ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
4665 ;; isn't really related to the CMU CL code, since instead of trying
4666 ;; to generalize the CMU CL code to allow START and END values, this
4667 ;; code has been written from scratch following Chapter 7 of
4668 ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
4669 `(macrolet ((%index (x) `(truly-the index ,x))
4670 (%parent (i) `(ash ,i -1))
4671 (%left (i) `(%index (ash ,i 1)))
4672 (%right (i) `(%index (1+ (ash ,i 1))))
4675 (left (%left i) (%left i)))
4676 ((> left current-heap-size))
4677 (declare (type index i left))
4678 (let* ((i-elt (%elt i))
4679 (i-key (funcall keyfun i-elt))
4680 (left-elt (%elt left))
4681 (left-key (funcall keyfun left-elt)))
4682 (multiple-value-bind (large large-elt large-key)
4683 (if (funcall ,',predicate i-key left-key)
4684 (values left left-elt left-key)
4685 (values i i-elt i-key))
4686 (let ((right (%right i)))
4687 (multiple-value-bind (largest largest-elt)
4688 (if (> right current-heap-size)
4689 (values large large-elt)
4690 (let* ((right-elt (%elt right))
4691 (right-key (funcall keyfun right-elt)))
4692 (if (funcall ,',predicate large-key right-key)
4693 (values right right-elt)
4694 (values large large-elt))))
4695 (cond ((= largest i)
4698 (setf (%elt i) largest-elt
4699 (%elt largest) i-elt
4701 (%sort-vector (keyfun &optional (vtype 'vector))
4702 `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had
4703 ;; trouble getting type inference to
4704 ;; propagate all the way through this
4705 ;; tangled mess of inlining. The TRULY-THE
4706 ;; here works around that. -- WHN
4708 `(aref (truly-the ,',vtype ,',',vector)
4709 (%index (+ (%index ,i) start-1)))))
4710 (let (;; Heaps prefer 1-based addressing.
4711 (start-1 (1- ,',start))
4712 (current-heap-size (- ,',end ,',start))
4714 (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum))
4716 (declare (type index current-heap-size))
4717 (declare (type function keyfun))
4718 (loop for i of-type index
4719 from (ash current-heap-size -1) downto 1 do
4722 (when (< current-heap-size 2)
4724 (rotatef (%elt 1) (%elt current-heap-size))
4725 (decf current-heap-size)
4727 (if (typep ,vector 'simple-vector)
4728 ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
4729 ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
4731 ;; Special-casing the KEY=NIL case lets us avoid some
4733 (%sort-vector #'identity simple-vector)
4734 (%sort-vector ,key simple-vector))
4735 ;; It's hard to anticipate many speed-critical applications for
4736 ;; sorting vector types other than (VECTOR T), so we just lump
4737 ;; them all together in one slow dynamically typed mess.
4739 (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
4740 (%sort-vector (or ,key #'identity))))))
4742 ;;;; debuggers' little helpers
4744 ;;; for debugging when transforms are behaving mysteriously,
4745 ;;; e.g. when debugging a problem with an ASH transform
4746 ;;; (defun foo (&optional s)
4747 ;;; (sb-c::/report-lvar s "S outside WHEN")
4748 ;;; (when (and (integerp s) (> s 3))
4749 ;;; (sb-c::/report-lvar s "S inside WHEN")
4750 ;;; (let ((bound (ash 1 (1- s))))
4751 ;;; (sb-c::/report-lvar bound "BOUND")
4752 ;;; (let ((x (- bound))
4754 ;;; (sb-c::/report-lvar x "X")
4755 ;;; (sb-c::/report-lvar x "Y"))
4756 ;;; `(integer ,(- bound) ,(1- bound)))))
4757 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
4758 ;;; and the function doesn't do anything at all.)
4761 (defknown /report-lvar (t t) null)
4762 (deftransform /report-lvar ((x message) (t t))
4763 (format t "~%/in /REPORT-LVAR~%")
4764 (format t "/(LVAR-TYPE X)=~S~%" (lvar-type x))
4765 (when (constant-lvar-p x)
4766 (format t "/(LVAR-VALUE X)=~S~%" (lvar-value x)))
4767 (format t "/MESSAGE=~S~%" (lvar-value message))
4768 (give-up-ir1-transform "not a real transform"))
4769 (defun /report-lvar (x message)
4770 (declare (ignore x message))))
4773 ;;;; Transforms for internal compiler utilities
4775 ;;; If QUALITY-NAME is constant and a valid name, don't bother
4776 ;;; checking that it's still valid at run-time.
4777 (deftransform policy-quality ((policy quality-name)
4779 (unless (and (constant-lvar-p quality-name)
4780 (policy-quality-name-p (lvar-value quality-name)))
4781 (give-up-ir1-transform))
4782 '(%policy-quality policy quality-name))
4784 (deftransform encode-universal-time
4785 ((second minute hour date month year &optional time-zone)
4786 ((constant-arg (mod 60)) (constant-arg (mod 60))
4787 (constant-arg (mod 24))
4788 (constant-arg (integer 1 31))
4789 (constant-arg (integer 1 12))
4790 (constant-arg (integer 1899))
4791 (constant-arg (rational -24 24))))
4792 (let ((second (lvar-value second))
4793 (minute (lvar-value minute))
4794 (hour (lvar-value hour))
4795 (date (lvar-value date))
4796 (month (lvar-value month))
4797 (year (lvar-value year))
4798 (time-zone (lvar-value time-zone)))
4799 (if (zerop (rem time-zone 1/3600))
4800 (encode-universal-time second minute hour date month year time-zone)
4801 (give-up-ir1-transform))))
4803 #!-(and win32 (not sb-thread))
4804 (deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
4805 `(sb!unix:nanosleep seconds 0))
4807 #!-(and win32 (not sb-thread))
4808 (deftransform sleep ((seconds) ((constant-arg (real 0))))
4809 (let ((seconds-value (lvar-value seconds)))
4810 (multiple-value-bind (seconds nano)
4811 (sb!impl::split-seconds-for-sleep seconds-value)
4812 (if (> seconds (expt 10 8))
4813 (give-up-ir1-transform)
4814 `(sb!unix:nanosleep ,seconds ,nano)))))