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
))
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
::get3
,@args nil
))
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 (flet ((general-case ()
324 `(if (>= index
#.sb
!vm
:n-word-bits
)
326 (not (zerop (logand integer
(ash 1 index
)))))))
327 (if (constant-lvar-p integer
)
328 (let ((val (lvar-value integer
)))
329 (cond ((eql val
0) nil
)
334 (define-source-transform byte
(size position
)
335 `(cons ,size
,position
))
336 (define-source-transform byte-size
(spec) `(car ,spec
))
337 (define-source-transform byte-position
(spec) `(cdr ,spec
))
338 (define-source-transform ldb-test
(bytespec integer
)
339 `(not (zerop (mask-field ,bytespec
,integer
))))
341 ;;; With the ratio and complex accessors, we pick off the "identity"
342 ;;; case, and use a primitive to handle the cell access case.
343 (define-source-transform numerator
(num)
344 (once-only ((n-num `(the rational
,num
)))
348 (define-source-transform denominator
(num)
349 (once-only ((n-num `(the rational
,num
)))
351 (%denominator
,n-num
)
354 ;;;; interval arithmetic for computing bounds
356 ;;;; This is a set of routines for operating on intervals. It
357 ;;;; implements a simple interval arithmetic package. Although SBCL
358 ;;;; has an interval type in NUMERIC-TYPE, we choose to use our own
359 ;;;; for two reasons:
361 ;;;; 1. This package is simpler than NUMERIC-TYPE.
363 ;;;; 2. It makes debugging much easier because you can just strip
364 ;;;; out these routines and test them independently of SBCL. (This is a
367 ;;;; One disadvantage is a probable increase in consing because we
368 ;;;; have to create these new interval structures even though
369 ;;;; numeric-type has everything we want to know. Reason 2 wins for
372 ;;; Support operations that mimic real arithmetic comparison
373 ;;; operators, but imposing a total order on the floating points such
374 ;;; that negative zeros are strictly less than positive zeros.
375 (macrolet ((def (name op
)
378 (if (and (floatp x
) (floatp y
) (zerop x
) (zerop y
))
379 (,op
(float-sign x
) (float-sign y
))
381 (def signed-zero-
>= >=)
382 (def signed-zero-
> >)
383 (def signed-zero-
= =)
384 (def signed-zero-
< <)
385 (def signed-zero-
<= <=))
387 ;;; The basic interval type. It can handle open and closed intervals.
388 ;;; A bound is open if it is a list containing a number, just like
389 ;;; Lisp says. NIL means unbounded.
390 (defstruct (interval (:constructor %make-interval
)
394 (defun make-interval (&key low high
)
395 (labels ((normalize-bound (val)
398 (float-infinity-p val
))
399 ;; Handle infinities.
403 ;; Handle any closed bounds.
406 ;; We have an open bound. Normalize the numeric
407 ;; bound. If the normalized bound is still a number
408 ;; (not nil), keep the bound open. Otherwise, the
409 ;; bound is really unbounded, so drop the openness.
410 (let ((new-val (normalize-bound (first val
))))
412 ;; The bound exists, so keep it open still.
415 (error "unknown bound type in MAKE-INTERVAL")))))
416 (%make-interval
:low
(normalize-bound low
)
417 :high
(normalize-bound high
))))
419 ;;; Given a number X, create a form suitable as a bound for an
420 ;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL.
421 #!-sb-fluid
(declaim (inline set-bound
))
422 (defun set-bound (x open-p
)
423 (if (and x open-p
) (list x
) x
))
425 ;;; Apply the function F to a bound X. If X is an open bound and the
426 ;;; function is declared strictly monotonic, then the result will be
427 ;;; open. IF X is NIL, the result is NIL.
428 (defun bound-func (f x strict
)
429 (declare (type function f
))
432 (with-float-traps-masked (:underflow
:overflow
:inexact
:divide-by-zero
)
433 ;; With these traps masked, we might get things like infinity
434 ;; or negative infinity returned. Check for this and return
435 ;; NIL to indicate unbounded.
436 (let ((y (funcall f
(type-bound-number x
))))
438 (float-infinity-p y
))
440 (set-bound y
(and strict
(consp x
))))))
441 ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g.
442 ;; in the course of converting a bignum to a float. Default to
444 (simple-type-error ()))))
446 (defun safe-double-coercion-p (x)
447 (or (typep x
'double-float
)
448 (<= most-negative-double-float x most-positive-double-float
)))
450 (defun safe-single-coercion-p (x)
451 (or (typep x
'single-float
)
453 ;; Fix for bug 420, and related issues: during type derivation we often
454 ;; end up deriving types for both
456 ;; (some-op <int> <single>)
458 ;; (some-op (coerce <int> 'single-float) <single>)
460 ;; or other equivalent transformed forms. The problem with this
461 ;; is that on x86 (+ <int> <single>) is on the machine level
464 ;; (coerce (+ (coerce <int> 'double-float)
465 ;; (coerce <single> 'double-float))
468 ;; so if the result of (coerce <int> 'single-float) is not exact, the
469 ;; derived types for the transformed forms will have an empty
470 ;; intersection -- which in turn means that the compiler will conclude
471 ;; that the call never returns, and all hell breaks lose when it *does*
472 ;; return at runtime. (This affects not just +, but other operators are
475 ;; See also: SAFE-CTYPE-FOR-SINGLE-COERCION-P
477 ;; FIXME: If we ever add SSE-support for x86, this conditional needs to
480 (not (typep x
`(or (integer * (,most-negative-exactly-single-float-fixnum
))
481 (integer (,most-positive-exactly-single-float-fixnum
) *))))
482 (<= most-negative-single-float x most-positive-single-float
))))
484 ;;; Apply a binary operator OP to two bounds X and Y. The result is
485 ;;; NIL if either is NIL. Otherwise bound is computed and the result
486 ;;; is open if either X or Y is open.
488 ;;; FIXME: only used in this file, not needed in target runtime
490 ;;; ANSI contaigon specifies coercion to floating point if one of the
491 ;;; arguments is floating point. Here we should check to be sure that
492 ;;; the other argument is within the bounds of that floating point
495 (defmacro safely-binop
(op x y
)
497 ((typep ,x
'double-float
)
498 (when (safe-double-coercion-p ,y
)
500 ((typep ,y
'double-float
)
501 (when (safe-double-coercion-p ,x
)
503 ((typep ,x
'single-float
)
504 (when (safe-single-coercion-p ,y
)
506 ((typep ,y
'single-float
)
507 (when (safe-single-coercion-p ,x
)
511 (defmacro bound-binop
(op x y
)
512 (with-unique-names (xb yb res
)
514 (with-float-traps-masked (:underflow
:overflow
:inexact
:divide-by-zero
)
515 (let* ((,xb
(type-bound-number ,x
))
516 (,yb
(type-bound-number ,y
))
517 (,res
(safely-binop ,op
,xb
,yb
)))
519 (and (or (consp ,x
) (consp ,y
))
520 ;; Open bounds can very easily be messed up
521 ;; by FP rounding, so take care here.
524 ;; Multiplying a greater-than-zero with
525 ;; less than one can round to zero.
526 `(or (not (fp-zero-p ,res
))
527 (cond ((and (consp ,x
) (fp-zero-p ,xb
))
529 ((and (consp ,y
) (fp-zero-p ,yb
))
532 ;; Dividing a greater-than-zero with
533 ;; greater than one can round to zero.
534 `(or (not (fp-zero-p ,res
))
535 (cond ((and (consp ,x
) (fp-zero-p ,xb
))
537 ((and (consp ,y
) (fp-zero-p ,yb
))
540 ;; Adding or subtracting greater-than-zero
541 ;; can end up with identity.
542 `(and (not (fp-zero-p ,xb
))
543 (not (fp-zero-p ,yb
))))))))))))
545 (defun coercion-loses-precision-p (val type
)
548 (double-float (subtypep type
'single-float
))
549 (rational (subtypep type
'float
))
550 (t (bug "Unexpected arguments to bounds coercion: ~S ~S" val type
))))
552 (defun coerce-for-bound (val type
)
554 (let ((xbound (coerce-for-bound (car val
) type
)))
555 (if (coercion-loses-precision-p (car val
) type
)
559 ((subtypep type
'double-float
)
560 (if (<= most-negative-double-float val most-positive-double-float
)
562 ((or (subtypep type
'single-float
) (subtypep type
'float
))
563 ;; coerce to float returns a single-float
564 (if (<= most-negative-single-float val most-positive-single-float
)
566 (t (coerce val type
)))))
568 (defun coerce-and-truncate-floats (val type
)
571 (let ((xbound (coerce-for-bound (car val
) type
)))
572 (if (coercion-loses-precision-p (car val
) type
)
576 ((subtypep type
'double-float
)
577 (if (<= most-negative-double-float val most-positive-double-float
)
579 (if (< val most-negative-double-float
)
580 most-negative-double-float most-positive-double-float
)))
581 ((or (subtypep type
'single-float
) (subtypep type
'float
))
582 ;; coerce to float returns a single-float
583 (if (<= most-negative-single-float val most-positive-single-float
)
585 (if (< val most-negative-single-float
)
586 most-negative-single-float most-positive-single-float
)))
587 (t (coerce val type
))))))
589 ;;; Convert a numeric-type object to an interval object.
590 (defun numeric-type->interval
(x)
591 (declare (type numeric-type x
))
592 (make-interval :low
(numeric-type-low x
)
593 :high
(numeric-type-high x
)))
595 (defun type-approximate-interval (type)
596 (declare (type ctype type
))
597 (let ((types (prepare-arg-for-derive-type type
))
600 (let ((type (if (member-type-p type
)
601 (convert-member-type type
)
603 (unless (numeric-type-p type
)
604 (return-from type-approximate-interval nil
))
605 (let ((interval (numeric-type->interval type
)))
608 (interval-approximate-union result interval
)
612 (defun copy-interval-limit (limit)
617 (defun copy-interval (x)
618 (declare (type interval x
))
619 (make-interval :low
(copy-interval-limit (interval-low x
))
620 :high
(copy-interval-limit (interval-high x
))))
622 ;;; Given a point P contained in the interval X, split X into two
623 ;;; intervals at the point P. If CLOSE-LOWER is T, then the left
624 ;;; interval contains P. If CLOSE-UPPER is T, the right interval
625 ;;; contains P. You can specify both to be T or NIL.
626 (defun interval-split (p x
&optional close-lower close-upper
)
627 (declare (type number p
)
629 (list (make-interval :low
(copy-interval-limit (interval-low x
))
630 :high
(if close-lower p
(list p
)))
631 (make-interval :low
(if close-upper
(list p
) p
)
632 :high
(copy-interval-limit (interval-high x
)))))
634 ;;; Return the closure of the interval. That is, convert open bounds
635 ;;; to closed bounds.
636 (defun interval-closure (x)
637 (declare (type interval x
))
638 (make-interval :low
(type-bound-number (interval-low x
))
639 :high
(type-bound-number (interval-high x
))))
641 ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
642 ;;; '-. Otherwise return NIL.
643 (defun interval-range-info (x &optional
(point 0))
644 (declare (type interval x
))
645 (let ((lo (interval-low x
))
646 (hi (interval-high x
)))
647 (cond ((and lo
(signed-zero->= (type-bound-number lo
) point
))
649 ((and hi
(signed-zero->= point
(type-bound-number hi
)))
654 ;;; Test to see whether the interval X is bounded. HOW determines the
655 ;;; test, and should be either ABOVE, BELOW, or BOTH.
656 (defun interval-bounded-p (x how
)
657 (declare (type interval x
))
664 (and (interval-low x
) (interval-high x
)))))
666 ;;; See whether the interval X contains the number P, taking into
667 ;;; account that the interval might not be closed.
668 (defun interval-contains-p (p x
)
669 (declare (type number p
)
671 ;; Does the interval X contain the number P? This would be a lot
672 ;; easier if all intervals were closed!
673 (let ((lo (interval-low x
))
674 (hi (interval-high x
)))
676 ;; The interval is bounded
677 (if (and (signed-zero-<= (type-bound-number lo
) p
)
678 (signed-zero-<= p
(type-bound-number hi
)))
679 ;; P is definitely in the closure of the interval.
680 ;; We just need to check the end points now.
681 (cond ((signed-zero-= p
(type-bound-number lo
))
683 ((signed-zero-= p
(type-bound-number hi
))
688 ;; Interval with upper bound
689 (if (signed-zero-< p
(type-bound-number hi
))
691 (and (numberp hi
) (signed-zero-= p hi
))))
693 ;; Interval with lower bound
694 (if (signed-zero-> p
(type-bound-number lo
))
696 (and (numberp lo
) (signed-zero-= p lo
))))
698 ;; Interval with no bounds
701 ;;; Determine whether two intervals X and Y intersect. Return T if so.
702 ;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they
703 ;;; were closed. Otherwise the intervals are treated as they are.
705 ;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
706 ;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
707 ;;; is T, then they do intersect because we use the closure of X = [0,
708 ;;; 1] and Y = [1, 2] to determine intersection.
709 (defun interval-intersect-p (x y
&optional closed-intervals-p
)
710 (declare (type interval x y
))
711 (and (interval-intersection/difference
(if closed-intervals-p
714 (if closed-intervals-p
719 ;;; Are the two intervals adjacent? That is, is there a number
720 ;;; between the two intervals that is not an element of either
721 ;;; interval? If so, they are not adjacent. For example [0, 1) and
722 ;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
723 ;;; between both intervals.
724 (defun interval-adjacent-p (x y
)
725 (declare (type interval x y
))
726 (flet ((adjacent (lo hi
)
727 ;; Check to see whether lo and hi are adjacent. If either is
728 ;; nil, they can't be adjacent.
729 (when (and lo hi
(= (type-bound-number lo
) (type-bound-number hi
)))
730 ;; The bounds are equal. They are adjacent if one of
731 ;; them is closed (a number). If both are open (consp),
732 ;; then there is a number that lies between them.
733 (or (numberp lo
) (numberp hi
)))))
734 (or (adjacent (interval-low y
) (interval-high x
))
735 (adjacent (interval-low x
) (interval-high y
)))))
737 ;;; Compute the intersection and difference between two intervals.
738 ;;; Two values are returned: the intersection and the difference.
740 ;;; Let the two intervals be X and Y, and let I and D be the two
741 ;;; values returned by this function. Then I = X intersect Y. If I
742 ;;; is NIL (the empty set), then D is X union Y, represented as the
743 ;;; list of X and Y. If I is not the empty set, then D is (X union Y)
744 ;;; - I, which is a list of two intervals.
746 ;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D =
747 ;;; [-1,1) union [3,5], which is returned as a list of two intervals.
748 (defun interval-intersection/difference
(x y
)
749 (declare (type interval x y
))
750 (let ((x-lo (interval-low x
))
751 (x-hi (interval-high x
))
752 (y-lo (interval-low y
))
753 (y-hi (interval-high y
)))
756 ;; If p is an open bound, make it closed. If p is a closed
757 ;; bound, make it open.
761 (test-number (p int bound
)
762 ;; Test whether P is in the interval.
763 (let ((pn (type-bound-number p
)))
764 (when (interval-contains-p pn
(interval-closure int
))
765 ;; Check for endpoints.
766 (let* ((lo (interval-low int
))
767 (hi (interval-high int
))
768 (lon (type-bound-number lo
))
769 (hin (type-bound-number hi
)))
771 ;; Interval may be a point.
772 ((and lon hin
(= lon hin pn
))
773 (and (numberp p
) (numberp lo
) (numberp hi
)))
774 ;; Point matches the low end.
775 ;; [P] [P,?} => TRUE [P] (P,?} => FALSE
776 ;; (P [P,?} => TRUE P) [P,?} => FALSE
777 ;; (P (P,?} => TRUE P) (P,?} => FALSE
778 ((and lon
(= pn lon
))
779 (or (and (numberp p
) (numberp lo
))
780 (and (consp p
) (eq :low bound
))))
781 ;; [P] {?,P] => TRUE [P] {?,P) => FALSE
782 ;; P) {?,P] => TRUE (P {?,P] => FALSE
783 ;; P) {?,P) => TRUE (P {?,P) => FALSE
784 ((and hin
(= pn hin
))
785 (or (and (numberp p
) (numberp hi
))
786 (and (consp p
) (eq :high bound
))))
787 ;; Not an endpoint, all is well.
790 (test-lower-bound (p int
)
791 ;; P is a lower bound of an interval.
793 (test-number p int
:low
)
794 (not (interval-bounded-p int
'below
))))
795 (test-upper-bound (p int
)
796 ;; P is an upper bound of an interval.
798 (test-number p int
:high
)
799 (not (interval-bounded-p int
'above
)))))
800 (let ((x-lo-in-y (test-lower-bound x-lo y
))
801 (x-hi-in-y (test-upper-bound x-hi y
))
802 (y-lo-in-x (test-lower-bound y-lo x
))
803 (y-hi-in-x (test-upper-bound y-hi x
)))
804 (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x
)
805 ;; Intervals intersect. Let's compute the intersection
806 ;; and the difference.
807 (multiple-value-bind (lo left-lo left-hi
)
808 (cond (x-lo-in-y (values x-lo y-lo
(opposite-bound x-lo
)))
809 (y-lo-in-x (values y-lo x-lo
(opposite-bound y-lo
))))
810 (multiple-value-bind (hi right-lo right-hi
)
812 (values x-hi
(opposite-bound x-hi
) y-hi
))
814 (values y-hi
(opposite-bound y-hi
) x-hi
)))
815 (values (make-interval :low lo
:high hi
)
816 (list (make-interval :low left-lo
818 (make-interval :low right-lo
821 (values nil
(list x y
))))))))
823 ;;; If intervals X and Y intersect, return a new interval that is the
824 ;;; union of the two. If they do not intersect, return NIL.
825 (defun interval-merge-pair (x y
)
826 (declare (type interval x y
))
827 ;; If x and y intersect or are adjacent, create the union.
828 ;; Otherwise return nil
829 (when (or (interval-intersect-p x y
)
830 (interval-adjacent-p x y
))
831 (flet ((select-bound (x1 x2 min-op max-op
)
832 (let ((x1-val (type-bound-number x1
))
833 (x2-val (type-bound-number x2
)))
835 ;; Both bounds are finite. Select the right one.
836 (cond ((funcall min-op x1-val x2-val
)
837 ;; x1 is definitely better.
839 ((funcall max-op x1-val x2-val
)
840 ;; x2 is definitely better.
843 ;; Bounds are equal. Select either
844 ;; value and make it open only if
846 (set-bound x1-val
(and (consp x1
) (consp x2
))))))
848 ;; At least one bound is not finite. The
849 ;; non-finite bound always wins.
851 (let* ((x-lo (copy-interval-limit (interval-low x
)))
852 (x-hi (copy-interval-limit (interval-high x
)))
853 (y-lo (copy-interval-limit (interval-low y
)))
854 (y-hi (copy-interval-limit (interval-high y
))))
855 (make-interval :low
(select-bound x-lo y-lo
#'< #'>)
856 :high
(select-bound x-hi y-hi
#'> #'<))))))
858 ;;; return the minimal interval, containing X and Y
859 (defun interval-approximate-union (x y
)
860 (cond ((interval-merge-pair x y
))
862 (make-interval :low
(copy-interval-limit (interval-low x
))
863 :high
(copy-interval-limit (interval-high y
))))
865 (make-interval :low
(copy-interval-limit (interval-low y
))
866 :high
(copy-interval-limit (interval-high x
))))))
868 ;;; basic arithmetic operations on intervals. We probably should do
869 ;;; true interval arithmetic here, but it's complicated because we
870 ;;; have float and integer types and bounds can be open or closed.
872 ;;; the negative of an interval
873 (defun interval-neg (x)
874 (declare (type interval x
))
875 (make-interval :low
(bound-func #'-
(interval-high x
) t
)
876 :high
(bound-func #'-
(interval-low x
) t
)))
878 ;;; Add two intervals.
879 (defun interval-add (x y
)
880 (declare (type interval x y
))
881 (make-interval :low
(bound-binop + (interval-low x
) (interval-low y
))
882 :high
(bound-binop + (interval-high x
) (interval-high y
))))
884 ;;; Subtract two intervals.
885 (defun interval-sub (x y
)
886 (declare (type interval x y
))
887 (make-interval :low
(bound-binop -
(interval-low x
) (interval-high y
))
888 :high
(bound-binop -
(interval-high x
) (interval-low y
))))
890 ;;; Multiply two intervals.
891 (defun interval-mul (x y
)
892 (declare (type interval x y
))
893 (flet ((bound-mul (x y
)
894 (cond ((or (null x
) (null y
))
895 ;; Multiply by infinity is infinity
897 ((or (and (numberp x
) (zerop x
))
898 (and (numberp y
) (zerop y
)))
899 ;; Multiply by closed zero is special. The result
900 ;; is always a closed bound. But don't replace this
901 ;; with zero; we want the multiplication to produce
902 ;; the correct signed zero, if needed. Use SIGNUM
903 ;; to avoid trying to multiply huge bignums with 0.0.
904 (* (signum (type-bound-number x
)) (signum (type-bound-number y
))))
905 ((or (and (floatp x
) (float-infinity-p x
))
906 (and (floatp y
) (float-infinity-p y
)))
907 ;; Infinity times anything is infinity
910 ;; General multiply. The result is open if either is open.
911 (bound-binop * x y
)))))
912 (let ((x-range (interval-range-info x
))
913 (y-range (interval-range-info y
)))
914 (cond ((null x-range
)
915 ;; Split x into two and multiply each separately
916 (destructuring-bind (x- x
+) (interval-split 0 x t t
)
917 (interval-merge-pair (interval-mul x- y
)
918 (interval-mul x
+ y
))))
920 ;; Split y into two and multiply each separately
921 (destructuring-bind (y- y
+) (interval-split 0 y t t
)
922 (interval-merge-pair (interval-mul x y-
)
923 (interval-mul x y
+))))
925 (interval-neg (interval-mul (interval-neg x
) y
)))
927 (interval-neg (interval-mul x
(interval-neg y
))))
928 ((and (eq x-range
'+) (eq y-range
'+))
929 ;; If we are here, X and Y are both positive.
931 :low
(bound-mul (interval-low x
) (interval-low y
))
932 :high
(bound-mul (interval-high x
) (interval-high y
))))
934 (bug "excluded case in INTERVAL-MUL"))))))
936 ;;; Divide two intervals.
937 (defun interval-div (top bot
)
938 (declare (type interval top bot
))
939 (flet ((bound-div (x y y-low-p
)
942 ;; Divide by infinity means result is 0. However,
943 ;; we need to watch out for the sign of the result,
944 ;; to correctly handle signed zeros. We also need
945 ;; to watch out for positive or negative infinity.
946 (if (floatp (type-bound-number x
))
948 (- (float-sign (type-bound-number x
) 0.0))
949 (float-sign (type-bound-number x
) 0.0))
951 ((zerop (type-bound-number y
))
952 ;; Divide by zero means result is infinity
955 (bound-binop / x y
)))))
956 (let ((top-range (interval-range-info top
))
957 (bot-range (interval-range-info bot
)))
958 (cond ((null bot-range
)
959 ;; The denominator contains zero, so anything goes!
962 ;; Denominator is negative so flip the sign, compute the
963 ;; result, and flip it back.
964 (interval-neg (interval-div top
(interval-neg bot
))))
966 ;; Split top into two positive and negative parts, and
967 ;; divide each separately
968 (destructuring-bind (top- top
+) (interval-split 0 top t t
)
969 (or (interval-merge-pair (interval-div top- bot
)
970 (interval-div top
+ bot
))
973 ;; Top is negative so flip the sign, divide, and flip the
974 ;; sign of the result.
975 (interval-neg (interval-div (interval-neg top
) bot
)))
976 ((and (eq top-range
'+) (eq bot-range
'+))
979 :low
(bound-div (interval-low top
) (interval-high bot
) t
)
980 :high
(bound-div (interval-high top
) (interval-low bot
) nil
)))
982 (bug "excluded case in INTERVAL-DIV"))))))
984 ;;; Apply the function F to the interval X. If X = [a, b], then the
985 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
986 ;;; result makes sense. It will if F is monotonic increasing (or, if
987 ;;; the interval is closed, non-decreasing).
989 ;;; (Actually most uses of INTERVAL-FUNC are coercions to float types,
990 ;;; which are not monotonic increasing, so default to calling
991 ;;; BOUND-FUNC with a non-strict argument).
992 (defun interval-func (f x
&optional increasing
)
993 (declare (type function f
)
995 (let ((lo (bound-func f
(interval-low x
) increasing
))
996 (hi (bound-func f
(interval-high x
) increasing
)))
997 (make-interval :low lo
:high hi
)))
999 ;;; Return T if X < Y. That is every number in the interval X is
1000 ;;; always less than any number in the interval Y.
1001 (defun interval-< (x y
)
1002 (declare (type interval x y
))
1003 ;; X < Y only if X is bounded above, Y is bounded below, and they
1005 (when (and (interval-bounded-p x
'above
)
1006 (interval-bounded-p y
'below
))
1007 ;; Intervals are bounded in the appropriate way. Make sure they
1009 (let ((left (interval-high x
))
1010 (right (interval-low y
)))
1011 (cond ((> (type-bound-number left
)
1012 (type-bound-number right
))
1013 ;; The intervals definitely overlap, so result is NIL.
1015 ((< (type-bound-number left
)
1016 (type-bound-number right
))
1017 ;; The intervals definitely don't touch, so result is T.
1020 ;; Limits are equal. Check for open or closed bounds.
1021 ;; Don't overlap if one or the other are open.
1022 (or (consp left
) (consp right
)))))))
1024 ;;; Return T if X >= Y. That is, every number in the interval X is
1025 ;;; always greater than any number in the interval Y.
1026 (defun interval->= (x y
)
1027 (declare (type interval x y
))
1028 ;; X >= Y if lower bound of X >= upper bound of Y
1029 (when (and (interval-bounded-p x
'below
)
1030 (interval-bounded-p y
'above
))
1031 (>= (type-bound-number (interval-low x
))
1032 (type-bound-number (interval-high y
)))))
1034 ;;; Return T if X = Y.
1035 (defun interval-= (x y
)
1036 (declare (type interval x y
))
1037 (and (interval-bounded-p x
'both
)
1038 (interval-bounded-p y
'both
)
1042 ;; Open intervals cannot be =
1043 (return-from interval-
= nil
))))
1044 ;; Both intervals refer to the same point
1045 (= (bound (interval-high x
)) (bound (interval-low x
))
1046 (bound (interval-high y
)) (bound (interval-low y
))))))
1048 ;;; Return T if X /= Y
1049 (defun interval-/= (x y
)
1050 (not (interval-intersect-p x y
)))
1052 ;;; Return an interval that is the absolute value of X. Thus, if
1053 ;;; X = [-1 10], the result is [0, 10].
1054 (defun interval-abs (x)
1055 (declare (type interval x
))
1056 (case (interval-range-info x
)
1062 (destructuring-bind (x- x
+) (interval-split 0 x t t
)
1063 (interval-merge-pair (interval-neg x-
) x
+)))))
1065 ;;; Compute the square of an interval.
1066 (defun interval-sqr (x)
1067 (declare (type interval x
))
1068 (interval-func (lambda (x) (* x x
)) (interval-abs x
)))
1070 ;;;; numeric DERIVE-TYPE methods
1072 ;;; a utility for defining derive-type methods of integer operations. If
1073 ;;; the types of both X and Y are integer types, then we compute a new
1074 ;;; integer type with bounds determined by FUN when applied to X and Y.
1075 ;;; Otherwise, we use NUMERIC-CONTAGION.
1076 (defun derive-integer-type-aux (x y fun
)
1077 (declare (type function fun
))
1078 (if (and (numeric-type-p x
) (numeric-type-p y
)
1079 (eq (numeric-type-class x
) 'integer
)
1080 (eq (numeric-type-class y
) 'integer
)
1081 (eq (numeric-type-complexp x
) :real
)
1082 (eq (numeric-type-complexp y
) :real
))
1083 (multiple-value-bind (low high
) (funcall fun x y
)
1084 (make-numeric-type :class
'integer
1088 (numeric-contagion x y
)))
1090 (defun derive-integer-type (x y fun
)
1091 (declare (type lvar x y
) (type function fun
))
1092 (let ((x (lvar-type x
))
1094 (derive-integer-type-aux x y fun
)))
1096 ;;; simple utility to flatten a list
1097 (defun flatten-list (x)
1098 (labels ((flatten-and-append (tree list
)
1099 (cond ((null tree
) list
)
1100 ((atom tree
) (cons tree list
))
1101 (t (flatten-and-append
1102 (car tree
) (flatten-and-append (cdr tree
) list
))))))
1103 (flatten-and-append x nil
)))
1105 ;;; Take some type of lvar and massage it so that we get a list of the
1106 ;;; constituent types. If ARG is *EMPTY-TYPE*, return NIL to indicate
1108 (defun prepare-arg-for-derive-type (arg)
1109 (flet ((listify (arg)
1114 (union-type-types arg
))
1117 (unless (eq arg
*empty-type
*)
1118 ;; Make sure all args are some type of numeric-type. For member
1119 ;; types, convert the list of members into a union of equivalent
1120 ;; single-element member-type's.
1121 (let ((new-args nil
))
1122 (dolist (arg (listify arg
))
1123 (if (member-type-p arg
)
1124 ;; Run down the list of members and convert to a list of
1126 (mapc-member-type-members
1128 (push (if (numberp member
)
1129 (make-member-type :members
(list member
))
1133 (push arg new-args
)))
1134 (unless (member *empty-type
* new-args
)
1137 ;;; Convert from the standard type convention for which -0.0 and 0.0
1138 ;;; are equal to an intermediate convention for which they are
1139 ;;; considered different which is more natural for some of the
1141 (defun convert-numeric-type (type)
1142 (declare (type numeric-type type
))
1143 ;;; Only convert real float interval delimiters types.
1144 (if (eq (numeric-type-complexp type
) :real
)
1145 (let* ((lo (numeric-type-low type
))
1146 (lo-val (type-bound-number lo
))
1147 (lo-float-zero-p (and lo
(floatp lo-val
) (= lo-val
0.0)))
1148 (hi (numeric-type-high type
))
1149 (hi-val (type-bound-number hi
))
1150 (hi-float-zero-p (and hi
(floatp hi-val
) (= hi-val
0.0))))
1151 (if (or lo-float-zero-p hi-float-zero-p
)
1153 :class
(numeric-type-class type
)
1154 :format
(numeric-type-format type
)
1156 :low
(if lo-float-zero-p
1158 (list (float 0.0 lo-val
))
1159 (float (load-time-value (make-unportable-float :single-float-negative-zero
)) lo-val
))
1161 :high
(if hi-float-zero-p
1163 (list (float (load-time-value (make-unportable-float :single-float-negative-zero
)) hi-val
))
1170 ;;; Convert back from the intermediate convention for which -0.0 and
1171 ;;; 0.0 are considered different to the standard type convention for
1172 ;;; which and equal.
1173 (defun convert-back-numeric-type (type)
1174 (declare (type numeric-type type
))
1175 ;;; Only convert real float interval delimiters types.
1176 (if (eq (numeric-type-complexp type
) :real
)
1177 (let* ((lo (numeric-type-low type
))
1178 (lo-val (type-bound-number lo
))
1180 (and lo
(floatp lo-val
) (= lo-val
0.0)
1181 (float-sign lo-val
)))
1182 (hi (numeric-type-high type
))
1183 (hi-val (type-bound-number hi
))
1185 (and hi
(floatp hi-val
) (= hi-val
0.0)
1186 (float-sign hi-val
))))
1188 ;; (float +0.0 +0.0) => (member 0.0)
1189 ;; (float -0.0 -0.0) => (member -0.0)
1190 ((and lo-float-zero-p hi-float-zero-p
)
1191 ;; shouldn't have exclusive bounds here..
1192 (aver (and (not (consp lo
)) (not (consp hi
))))
1193 (if (= lo-float-zero-p hi-float-zero-p
)
1194 ;; (float +0.0 +0.0) => (member 0.0)
1195 ;; (float -0.0 -0.0) => (member -0.0)
1196 (specifier-type `(member ,lo-val
))
1197 ;; (float -0.0 +0.0) => (float 0.0 0.0)
1198 ;; (float +0.0 -0.0) => (float 0.0 0.0)
1199 (make-numeric-type :class
(numeric-type-class type
)
1200 :format
(numeric-type-format type
)
1206 ;; (float -0.0 x) => (float 0.0 x)
1207 ((and (not (consp lo
)) (minusp lo-float-zero-p
))
1208 (make-numeric-type :class
(numeric-type-class type
)
1209 :format
(numeric-type-format type
)
1211 :low
(float 0.0 lo-val
)
1213 ;; (float (+0.0) x) => (float (0.0) x)
1214 ((and (consp lo
) (plusp lo-float-zero-p
))
1215 (make-numeric-type :class
(numeric-type-class type
)
1216 :format
(numeric-type-format type
)
1218 :low
(list (float 0.0 lo-val
))
1221 ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
1222 ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
1223 (list (make-member-type :members
(list (float 0.0 lo-val
)))
1224 (make-numeric-type :class
(numeric-type-class type
)
1225 :format
(numeric-type-format type
)
1227 :low
(list (float 0.0 lo-val
))
1231 ;; (float x +0.0) => (float x 0.0)
1232 ((and (not (consp hi
)) (plusp hi-float-zero-p
))
1233 (make-numeric-type :class
(numeric-type-class type
)
1234 :format
(numeric-type-format type
)
1237 :high
(float 0.0 hi-val
)))
1238 ;; (float x (-0.0)) => (float x (0.0))
1239 ((and (consp hi
) (minusp hi-float-zero-p
))
1240 (make-numeric-type :class
(numeric-type-class type
)
1241 :format
(numeric-type-format type
)
1244 :high
(list (float 0.0 hi-val
))))
1246 ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
1247 ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
1248 (list (make-member-type :members
(list (float (load-time-value (make-unportable-float :single-float-negative-zero
)) hi-val
)))
1249 (make-numeric-type :class
(numeric-type-class type
)
1250 :format
(numeric-type-format type
)
1253 :high
(list (float 0.0 hi-val
)))))))
1259 ;;; Convert back a possible list of numeric types.
1260 (defun convert-back-numeric-type-list (type-list)
1263 (let ((results '()))
1264 (dolist (type type-list
)
1265 (if (numeric-type-p type
)
1266 (let ((result (convert-back-numeric-type type
)))
1268 (setf results
(append results result
))
1269 (push result results
)))
1270 (push type results
)))
1273 (convert-back-numeric-type type-list
))
1275 (convert-back-numeric-type-list (union-type-types type-list
)))
1279 ;;; Take a list of types and return a canonical type specifier,
1280 ;;; combining any MEMBER types together. If both positive and negative
1281 ;;; MEMBER types are present they are converted to a float type.
1282 ;;; XXX This would be far simpler if the type-union methods could handle
1283 ;;; member/number unions.
1285 ;;; If we're about to generate an overly complex union of numeric types, start
1286 ;;; collapse the ranges together.
1288 ;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
1289 ;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
1290 ;;; invoked always, instead of in the compiler, invoked only during some type
1292 (defvar *derived-numeric-union-complexity-limit
* 6)
1294 (defun make-derived-union-type (type-list)
1295 (let ((xset (alloc-xset))
1298 (numeric-type *empty-type
*))
1299 (dolist (type type-list
)
1300 (cond ((member-type-p type
)
1301 (mapc-member-type-members
1303 (if (fp-zero-p member
)
1304 (unless (member member fp-zeroes
)
1305 (pushnew member fp-zeroes
))
1306 (add-to-xset member xset
)))
1308 ((numeric-type-p type
)
1309 (let ((*approximate-numeric-unions
*
1310 (when (and (union-type-p numeric-type
)
1311 (nthcdr *derived-numeric-union-complexity-limit
*
1312 (union-type-types numeric-type
)))
1314 (setf numeric-type
(type-union type numeric-type
))))
1316 (push type misc-types
))))
1317 (if (and (xset-empty-p xset
) (not fp-zeroes
))
1318 (apply #'type-union numeric-type misc-types
)
1319 (apply #'type-union
(make-member-type :xset xset
:fp-zeroes fp-zeroes
)
1320 numeric-type misc-types
))))
1322 ;;; Convert a member type with a single member to a numeric type.
1323 (defun convert-member-type (arg)
1324 (let* ((members (member-type-members arg
))
1325 (member (first members
))
1326 (member-type (type-of member
)))
1327 (aver (not (rest members
)))
1328 (specifier-type (cond ((typep member
'integer
)
1329 `(integer ,member
,member
))
1330 ((memq member-type
'(short-float single-float
1331 double-float long-float
))
1332 `(,member-type
,member
,member
))
1336 ;;; This is used in defoptimizers for computing the resulting type of
1339 ;;; Given the lvar ARG, derive the resulting type using the
1340 ;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
1341 ;;; "atomic" lvar type like numeric-type or member-type (containing
1342 ;;; just one element). It should return the resulting type, which can
1343 ;;; be a list of types.
1345 ;;; For the case of member types, if a MEMBER-FUN is given it is
1346 ;;; called to compute the result otherwise the member type is first
1347 ;;; converted to a numeric type and the DERIVE-FUN is called.
1348 (defun one-arg-derive-type (arg derive-fun member-fun
1349 &optional
(convert-type t
))
1350 (declare (type function derive-fun
)
1351 (type (or null function
) member-fun
))
1352 (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg
))))
1358 (with-float-traps-masked
1359 (:underflow
:overflow
:divide-by-zero
)
1361 `(eql ,(funcall member-fun
1362 (first (member-type-members x
))))))
1363 ;; Otherwise convert to a numeric type.
1364 (let ((result-type-list
1365 (funcall derive-fun
(convert-member-type x
))))
1367 (convert-back-numeric-type-list result-type-list
)
1368 result-type-list
))))
1371 (convert-back-numeric-type-list
1372 (funcall derive-fun
(convert-numeric-type x
)))
1373 (funcall derive-fun x
)))
1375 *universal-type
*))))
1376 ;; Run down the list of args and derive the type of each one,
1377 ;; saving all of the results in a list.
1378 (let ((results nil
))
1379 (dolist (arg arg-list
)
1380 (let ((result (deriver arg
)))
1382 (setf results
(append results result
))
1383 (push result results
))))
1385 (make-derived-union-type results
)
1386 (first results
)))))))
1388 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
1389 ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
1390 ;;; original args and a third which is T to indicate if the two args
1391 ;;; really represent the same lvar. This is useful for deriving the
1392 ;;; type of things like (* x x), which should always be positive. If
1393 ;;; we didn't do this, we wouldn't be able to tell.
1394 (defun two-arg-derive-type (arg1 arg2 derive-fun fun
1395 &optional
(convert-type t
))
1396 (declare (type function derive-fun fun
))
1397 (flet ((deriver (x y same-arg
)
1398 (cond ((and (member-type-p x
) (member-type-p y
))
1399 (let* ((x (first (member-type-members x
)))
1400 (y (first (member-type-members y
)))
1401 (result (ignore-errors
1402 (with-float-traps-masked
1403 (:underflow
:overflow
:divide-by-zero
1405 (funcall fun x y
)))))
1406 (cond ((null result
) *empty-type
*)
1407 ((and (floatp result
) (float-nan-p result
))
1408 (make-numeric-type :class
'float
1409 :format
(type-of result
)
1412 (specifier-type `(eql ,result
))))))
1413 ((and (member-type-p x
) (numeric-type-p y
))
1414 (let* ((x (convert-member-type x
))
1415 (y (if convert-type
(convert-numeric-type y
) y
))
1416 (result (funcall derive-fun x y same-arg
)))
1418 (convert-back-numeric-type-list result
)
1420 ((and (numeric-type-p x
) (member-type-p y
))
1421 (let* ((x (if convert-type
(convert-numeric-type x
) x
))
1422 (y (convert-member-type y
))
1423 (result (funcall derive-fun x y same-arg
)))
1425 (convert-back-numeric-type-list result
)
1427 ((and (numeric-type-p x
) (numeric-type-p y
))
1428 (let* ((x (if convert-type
(convert-numeric-type x
) x
))
1429 (y (if convert-type
(convert-numeric-type y
) y
))
1430 (result (funcall derive-fun x y same-arg
)))
1432 (convert-back-numeric-type-list result
)
1435 *universal-type
*))))
1436 (let ((same-arg (same-leaf-ref-p arg1 arg2
))
1437 (a1 (prepare-arg-for-derive-type (lvar-type arg1
)))
1438 (a2 (prepare-arg-for-derive-type (lvar-type arg2
))))
1440 (let ((results nil
))
1442 ;; Since the args are the same LVARs, just run down the
1445 (let ((result (deriver x x same-arg
)))
1447 (setf results
(append results result
))
1448 (push result results
))))
1449 ;; Try all pairwise combinations.
1452 (let ((result (or (deriver x y same-arg
)
1453 (numeric-contagion x y
))))
1455 (setf results
(append results result
))
1456 (push result results
))))))
1458 (make-derived-union-type results
)
1459 (first results
)))))))
1461 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1463 (defoptimizer (+ derive-type
) ((x y
))
1464 (derive-integer-type
1471 (values (frob (numeric-type-low x
) (numeric-type-low y
))
1472 (frob (numeric-type-high x
) (numeric-type-high y
)))))))
1474 (defoptimizer (- derive-type
) ((x y
))
1475 (derive-integer-type
1482 (values (frob (numeric-type-low x
) (numeric-type-high y
))
1483 (frob (numeric-type-high x
) (numeric-type-low y
)))))))
1485 (defoptimizer (* derive-type
) ((x y
))
1486 (derive-integer-type
1489 (let ((x-low (numeric-type-low x
))
1490 (x-high (numeric-type-high x
))
1491 (y-low (numeric-type-low y
))
1492 (y-high (numeric-type-high y
)))
1493 (cond ((not (and x-low y-low
))
1495 ((or (minusp x-low
) (minusp y-low
))
1496 (if (and x-high y-high
)
1497 (let ((max (* (max (abs x-low
) (abs x-high
))
1498 (max (abs y-low
) (abs y-high
)))))
1499 (values (- max
) max
))
1502 (values (* x-low y-low
)
1503 (if (and x-high y-high
)
1507 (defoptimizer (/ derive-type
) ((x y
))
1508 (numeric-contagion (lvar-type x
) (lvar-type y
)))
1512 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1514 (defun +-derive-type-aux
(x y same-arg
)
1515 (if (and (numeric-type-real-p x
)
1516 (numeric-type-real-p y
))
1519 (let ((x-int (numeric-type->interval x
)))
1520 (interval-add x-int x-int
))
1521 (interval-add (numeric-type->interval x
)
1522 (numeric-type->interval y
))))
1523 (result-type (numeric-contagion x y
)))
1524 ;; If the result type is a float, we need to be sure to coerce
1525 ;; the bounds into the correct type.
1526 (when (eq (numeric-type-class result-type
) 'float
)
1527 (setf result
(interval-func
1529 (coerce-for-bound x
(or (numeric-type-format result-type
)
1533 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1534 (eq (numeric-type-class y
) 'integer
))
1535 ;; The sum of integers is always an integer.
1537 (numeric-type-class result-type
))
1538 :format
(numeric-type-format result-type
)
1539 :low
(interval-low result
)
1540 :high
(interval-high result
)))
1541 ;; general contagion
1542 (numeric-contagion x y
)))
1544 (defoptimizer (+ derive-type
) ((x y
))
1545 (two-arg-derive-type x y
#'+-derive-type-aux
#'+))
1547 (defun --derive-type-aux (x y same-arg
)
1548 (if (and (numeric-type-real-p x
)
1549 (numeric-type-real-p y
))
1551 ;; (- X X) is always 0.
1553 (make-interval :low
0 :high
0)
1554 (interval-sub (numeric-type->interval x
)
1555 (numeric-type->interval y
))))
1556 (result-type (numeric-contagion x y
)))
1557 ;; If the result type is a float, we need to be sure to coerce
1558 ;; the bounds into the correct type.
1559 (when (eq (numeric-type-class result-type
) 'float
)
1560 (setf result
(interval-func
1562 (coerce-for-bound x
(or (numeric-type-format result-type
)
1566 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1567 (eq (numeric-type-class y
) 'integer
))
1568 ;; The difference of integers is always an integer.
1570 (numeric-type-class result-type
))
1571 :format
(numeric-type-format result-type
)
1572 :low
(interval-low result
)
1573 :high
(interval-high result
)))
1574 ;; general contagion
1575 (numeric-contagion x y
)))
1577 (defoptimizer (- derive-type
) ((x y
))
1578 (two-arg-derive-type x y
#'--derive-type-aux
#'-
))
1580 (defun *-derive-type-aux
(x y same-arg
)
1581 (if (and (numeric-type-real-p x
)
1582 (numeric-type-real-p y
))
1584 ;; (* X X) is always positive, so take care to do it right.
1586 (interval-sqr (numeric-type->interval x
))
1587 (interval-mul (numeric-type->interval x
)
1588 (numeric-type->interval y
))))
1589 (result-type (numeric-contagion x y
)))
1590 ;; If the result type is a float, we need to be sure to coerce
1591 ;; the bounds into the correct type.
1592 (when (eq (numeric-type-class result-type
) 'float
)
1593 (setf result
(interval-func
1595 (coerce-for-bound x
(or (numeric-type-format result-type
)
1599 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1600 (eq (numeric-type-class y
) 'integer
))
1601 ;; The product of integers is always an integer.
1603 (numeric-type-class result-type
))
1604 :format
(numeric-type-format result-type
)
1605 :low
(interval-low result
)
1606 :high
(interval-high result
)))
1607 (numeric-contagion x y
)))
1609 (defoptimizer (* derive-type
) ((x y
))
1610 (two-arg-derive-type x y
#'*-derive-type-aux
#'*))
1612 (defun /-derive-type-aux
(x y same-arg
)
1613 (if (and (numeric-type-real-p x
)
1614 (numeric-type-real-p y
))
1616 ;; (/ X X) is always 1, except if X can contain 0. In
1617 ;; that case, we shouldn't optimize the division away
1618 ;; because we want 0/0 to signal an error.
1620 (not (interval-contains-p
1621 0 (interval-closure (numeric-type->interval y
)))))
1622 (make-interval :low
1 :high
1)
1623 (interval-div (numeric-type->interval x
)
1624 (numeric-type->interval y
))))
1625 (result-type (numeric-contagion x y
)))
1626 ;; If the result type is a float, we need to be sure to coerce
1627 ;; the bounds into the correct type.
1628 (when (eq (numeric-type-class result-type
) 'float
)
1629 (setf result
(interval-func
1631 (coerce-for-bound x
(or (numeric-type-format result-type
)
1634 (make-numeric-type :class
(numeric-type-class result-type
)
1635 :format
(numeric-type-format result-type
)
1636 :low
(interval-low result
)
1637 :high
(interval-high result
)))
1638 (numeric-contagion x y
)))
1640 (defoptimizer (/ derive-type
) ((x y
))
1641 (two-arg-derive-type x y
#'/-derive-type-aux
#'/))
1645 (defun ash-derive-type-aux (n-type shift same-arg
)
1646 (declare (ignore same-arg
))
1647 ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
1648 ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
1649 ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
1650 ;; two bignums yielding zero) and it's hard to avoid that
1651 ;; calculation in here.
1652 #+(and cmu sb-xc-host
)
1653 (when (and (or (typep (numeric-type-low n-type
) 'bignum
)
1654 (typep (numeric-type-high n-type
) 'bignum
))
1655 (or (typep (numeric-type-low shift
) 'bignum
)
1656 (typep (numeric-type-high shift
) 'bignum
)))
1657 (return-from ash-derive-type-aux
*universal-type
*))
1658 (flet ((ash-outer (n s
)
1659 (when (and (fixnump s
)
1661 (> s sb
!xc
:most-negative-fixnum
))
1663 ;; KLUDGE: The bare 64's here should be related to
1664 ;; symbolic machine word size values somehow.
1667 (if (and (fixnump s
)
1668 (> s sb
!xc
:most-negative-fixnum
))
1670 (if (minusp n
) -
1 0))))
1671 (or (and (csubtypep n-type
(specifier-type 'integer
))
1672 (csubtypep shift
(specifier-type 'integer
))
1673 (let ((n-low (numeric-type-low n-type
))
1674 (n-high (numeric-type-high n-type
))
1675 (s-low (numeric-type-low shift
))
1676 (s-high (numeric-type-high shift
)))
1677 (make-numeric-type :class
'integer
:complexp
:real
1680 (ash-outer n-low s-high
)
1681 (ash-inner n-low s-low
)))
1684 (ash-inner n-high s-low
)
1685 (ash-outer n-high s-high
))))))
1688 (defoptimizer (ash derive-type
) ((n shift
))
1689 (two-arg-derive-type n shift
#'ash-derive-type-aux
#'ash
))
1691 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1692 (macrolet ((frob (fun)
1693 `#'(lambda (type type2
)
1694 (declare (ignore type2
))
1695 (let ((lo (numeric-type-low type
))
1696 (hi (numeric-type-high type
)))
1697 (values (if hi
(,fun hi
) nil
) (if lo
(,fun lo
) nil
))))))
1699 (defoptimizer (%negate derive-type
) ((num))
1700 (derive-integer-type num num
(frob -
))))
1702 (defun lognot-derive-type-aux (int)
1703 (derive-integer-type-aux int int
1704 (lambda (type type2
)
1705 (declare (ignore type2
))
1706 (let ((lo (numeric-type-low type
))
1707 (hi (numeric-type-high type
)))
1708 (values (if hi
(lognot hi
) nil
)
1709 (if lo
(lognot lo
) nil
)
1710 (numeric-type-class type
)
1711 (numeric-type-format type
))))))
1713 (defoptimizer (lognot derive-type
) ((int))
1714 (lognot-derive-type-aux (lvar-type int
)))
1716 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1717 (defoptimizer (%negate derive-type
) ((num))
1718 (flet ((negate-bound (b)
1720 (set-bound (- (type-bound-number b
))
1722 (one-arg-derive-type num
1724 (modified-numeric-type
1726 :low
(negate-bound (numeric-type-high type
))
1727 :high
(negate-bound (numeric-type-low type
))))
1730 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1731 (defoptimizer (abs derive-type
) ((num))
1732 (let ((type (lvar-type num
)))
1733 (if (and (numeric-type-p type
)
1734 (eq (numeric-type-class type
) 'integer
)
1735 (eq (numeric-type-complexp type
) :real
))
1736 (let ((lo (numeric-type-low type
))
1737 (hi (numeric-type-high type
)))
1738 (make-numeric-type :class
'integer
:complexp
:real
1739 :low
(cond ((and hi
(minusp hi
))
1745 :high
(if (and hi lo
)
1746 (max (abs hi
) (abs lo
))
1748 (numeric-contagion type type
))))
1750 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1751 (defun abs-derive-type-aux (type)
1752 (cond ((eq (numeric-type-complexp type
) :complex
)
1753 ;; The absolute value of a complex number is always a
1754 ;; non-negative float.
1755 (let* ((format (case (numeric-type-class type
)
1756 ((integer rational
) 'single-float
)
1757 (t (numeric-type-format type
))))
1758 (bound-format (or format
'float
)))
1759 (make-numeric-type :class
'float
1762 :low
(coerce 0 bound-format
)
1765 ;; The absolute value of a real number is a non-negative real
1766 ;; of the same type.
1767 (let* ((abs-bnd (interval-abs (numeric-type->interval type
)))
1768 (class (numeric-type-class type
))
1769 (format (numeric-type-format type
))
1770 (bound-type (or format class
'real
)))
1775 :low
(coerce-and-truncate-floats (interval-low abs-bnd
) bound-type
)
1776 :high
(coerce-and-truncate-floats
1777 (interval-high abs-bnd
) bound-type
))))))
1779 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1780 (defoptimizer (abs derive-type
) ((num))
1781 (one-arg-derive-type num
#'abs-derive-type-aux
#'abs
))
1783 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1784 (defoptimizer (truncate derive-type
) ((number divisor
))
1785 (let ((number-type (lvar-type number
))
1786 (divisor-type (lvar-type divisor
))
1787 (integer-type (specifier-type 'integer
)))
1788 (if (and (numeric-type-p number-type
)
1789 (csubtypep number-type integer-type
)
1790 (numeric-type-p divisor-type
)
1791 (csubtypep divisor-type integer-type
))
1792 (let ((number-low (numeric-type-low number-type
))
1793 (number-high (numeric-type-high number-type
))
1794 (divisor-low (numeric-type-low divisor-type
))
1795 (divisor-high (numeric-type-high divisor-type
)))
1796 (values-specifier-type
1797 `(values ,(integer-truncate-derive-type number-low number-high
1798 divisor-low divisor-high
)
1799 ,(integer-rem-derive-type number-low number-high
1800 divisor-low divisor-high
))))
1803 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1806 (defun rem-result-type (number-type divisor-type
)
1807 ;; Figure out what the remainder type is. The remainder is an
1808 ;; integer if both args are integers; a rational if both args are
1809 ;; rational; and a float otherwise.
1810 (cond ((and (csubtypep number-type
(specifier-type 'integer
))
1811 (csubtypep divisor-type
(specifier-type 'integer
)))
1813 ((and (csubtypep number-type
(specifier-type 'rational
))
1814 (csubtypep divisor-type
(specifier-type 'rational
)))
1816 ((and (csubtypep number-type
(specifier-type 'float
))
1817 (csubtypep divisor-type
(specifier-type 'float
)))
1818 ;; Both are floats so the result is also a float, of
1819 ;; the largest type.
1820 (or (float-format-max (numeric-type-format number-type
)
1821 (numeric-type-format divisor-type
))
1823 ((and (csubtypep number-type
(specifier-type 'float
))
1824 (csubtypep divisor-type
(specifier-type 'rational
)))
1825 ;; One of the arguments is a float and the other is a
1826 ;; rational. The remainder is a float of the same
1828 (or (numeric-type-format number-type
) 'float
))
1829 ((and (csubtypep divisor-type
(specifier-type 'float
))
1830 (csubtypep number-type
(specifier-type 'rational
)))
1831 ;; One of the arguments is a float and the other is a
1832 ;; rational. The remainder is a float of the same
1834 (or (numeric-type-format divisor-type
) 'float
))
1836 ;; Some unhandled combination. This usually means both args
1837 ;; are REAL so the result is a REAL.
1840 (defun truncate-derive-type-quot (number-type divisor-type
)
1841 (let* ((rem-type (rem-result-type number-type divisor-type
))
1842 (number-interval (numeric-type->interval number-type
))
1843 (divisor-interval (numeric-type->interval divisor-type
)))
1844 ;;(declare (type (member '(integer rational float)) rem-type))
1845 ;; We have real numbers now.
1846 (cond ((eq rem-type
'integer
)
1847 ;; Since the remainder type is INTEGER, both args are
1849 (let* ((res (integer-truncate-derive-type
1850 (interval-low number-interval
)
1851 (interval-high number-interval
)
1852 (interval-low divisor-interval
)
1853 (interval-high divisor-interval
))))
1854 (specifier-type (if (listp res
) res
'integer
))))
1856 (let ((quot (truncate-quotient-bound
1857 (interval-div number-interval
1858 divisor-interval
))))
1859 (specifier-type `(integer ,(or (interval-low quot
) '*)
1860 ,(or (interval-high quot
) '*))))))))
1862 (defun truncate-derive-type-rem (number-type divisor-type
)
1863 (let* ((rem-type (rem-result-type number-type divisor-type
))
1864 (number-interval (numeric-type->interval number-type
))
1865 (divisor-interval (numeric-type->interval divisor-type
))
1866 (rem (truncate-rem-bound number-interval divisor-interval
)))
1867 ;;(declare (type (member '(integer rational float)) rem-type))
1868 ;; We have real numbers now.
1869 (cond ((eq rem-type
'integer
)
1870 ;; Since the remainder type is INTEGER, both args are
1872 (specifier-type `(,rem-type
,(or (interval-low rem
) '*)
1873 ,(or (interval-high rem
) '*))))
1875 (multiple-value-bind (class format
)
1878 (values 'integer nil
))
1880 (values 'rational nil
))
1881 ((or single-float double-float
#!+long-float long-float
)
1882 (values 'float rem-type
))
1884 (values 'float nil
))
1887 (when (member rem-type
'(float single-float double-float
1888 #!+long-float long-float
))
1889 (setf rem
(interval-func #'(lambda (x)
1890 (coerce-for-bound x rem-type
))
1892 (make-numeric-type :class class
1894 :low
(interval-low rem
)
1895 :high
(interval-high rem
)))))))
1897 (defun truncate-derive-type-quot-aux (num div same-arg
)
1898 (declare (ignore same-arg
))
1899 (if (and (numeric-type-real-p num
)
1900 (numeric-type-real-p div
))
1901 (truncate-derive-type-quot num div
)
1904 (defun truncate-derive-type-rem-aux (num div same-arg
)
1905 (declare (ignore same-arg
))
1906 (if (and (numeric-type-real-p num
)
1907 (numeric-type-real-p div
))
1908 (truncate-derive-type-rem num div
)
1911 (defoptimizer (truncate derive-type
) ((number divisor
))
1912 (let ((quot (two-arg-derive-type number divisor
1913 #'truncate-derive-type-quot-aux
#'truncate
))
1914 (rem (two-arg-derive-type number divisor
1915 #'truncate-derive-type-rem-aux
#'rem
)))
1916 (when (and quot rem
)
1917 (make-values-type :required
(list quot rem
)))))
1919 (defun ftruncate-derive-type-quot (number-type divisor-type
)
1920 ;; The bounds are the same as for truncate. However, the first
1921 ;; result is a float of some type. We need to determine what that
1922 ;; type is. Basically it's the more contagious of the two types.
1923 (let ((q-type (truncate-derive-type-quot number-type divisor-type
))
1924 (res-type (numeric-contagion number-type divisor-type
)))
1925 (make-numeric-type :class
'float
1926 :format
(numeric-type-format res-type
)
1927 :low
(numeric-type-low q-type
)
1928 :high
(numeric-type-high q-type
))))
1930 (defun ftruncate-derive-type-quot-aux (n d same-arg
)
1931 (declare (ignore same-arg
))
1932 (if (and (numeric-type-real-p n
)
1933 (numeric-type-real-p d
))
1934 (ftruncate-derive-type-quot n d
)
1937 (defoptimizer (ftruncate derive-type
) ((number divisor
))
1939 (two-arg-derive-type number divisor
1940 #'ftruncate-derive-type-quot-aux
#'ftruncate
))
1941 (rem (two-arg-derive-type number divisor
1942 #'truncate-derive-type-rem-aux
#'rem
)))
1943 (when (and quot rem
)
1944 (make-values-type :required
(list quot rem
)))))
1946 (defun %unary-truncate-derive-type-aux
(number)
1947 (truncate-derive-type-quot number
(specifier-type '(integer 1 1))))
1949 (defoptimizer (%unary-truncate derive-type
) ((number))
1950 (one-arg-derive-type number
1951 #'%unary-truncate-derive-type-aux
1954 (defoptimizer (%unary-truncate
/single-float derive-type
) ((number))
1955 (one-arg-derive-type number
1956 #'%unary-truncate-derive-type-aux
1959 (defoptimizer (%unary-truncate
/double-float derive-type
) ((number))
1960 (one-arg-derive-type number
1961 #'%unary-truncate-derive-type-aux
1964 (defoptimizer (%unary-ftruncate derive-type
) ((number))
1965 (let ((divisor (specifier-type '(integer 1 1))))
1966 (one-arg-derive-type number
1968 (ftruncate-derive-type-quot-aux n divisor nil
))
1969 #'%unary-ftruncate
)))
1971 (defoptimizer (%unary-round derive-type
) ((number))
1972 (one-arg-derive-type number
1975 (unless (numeric-type-real-p n
)
1976 (return *empty-type
*))
1977 (let* ((interval (numeric-type->interval n
))
1978 (low (interval-low interval
))
1979 (high (interval-high interval
)))
1981 (setf low
(car low
)))
1983 (setf high
(car high
)))
1993 ;;; Define optimizers for FLOOR and CEILING.
1995 ((def (name q-name r-name
)
1996 (let ((q-aux (symbolicate q-name
"-AUX"))
1997 (r-aux (symbolicate r-name
"-AUX")))
1999 ;; Compute type of quotient (first) result.
2000 (defun ,q-aux
(number-type divisor-type
)
2001 (let* ((number-interval
2002 (numeric-type->interval number-type
))
2004 (numeric-type->interval divisor-type
))
2005 (quot (,q-name
(interval-div number-interval
2006 divisor-interval
))))
2007 (specifier-type `(integer ,(or (interval-low quot
) '*)
2008 ,(or (interval-high quot
) '*)))))
2009 ;; Compute type of remainder.
2010 (defun ,r-aux
(number-type divisor-type
)
2011 (let* ((divisor-interval
2012 (numeric-type->interval divisor-type
))
2013 (rem (,r-name divisor-interval
))
2014 (result-type (rem-result-type number-type divisor-type
)))
2015 (multiple-value-bind (class format
)
2018 (values 'integer nil
))
2020 (values 'rational nil
))
2021 ((or single-float double-float
#!+long-float long-float
)
2022 (values 'float result-type
))
2024 (values 'float nil
))
2027 (when (member result-type
'(float single-float double-float
2028 #!+long-float long-float
))
2029 ;; Make sure that the limits on the interval have
2031 (setf rem
(interval-func (lambda (x)
2032 (coerce-for-bound x result-type
))
2034 (make-numeric-type :class class
2036 :low
(interval-low rem
)
2037 :high
(interval-high rem
)))))
2038 ;; the optimizer itself
2039 (defoptimizer (,name derive-type
) ((number divisor
))
2040 (flet ((derive-q (n d same-arg
)
2041 (declare (ignore same-arg
))
2042 (if (and (numeric-type-real-p n
)
2043 (numeric-type-real-p d
))
2046 (derive-r (n d same-arg
)
2047 (declare (ignore same-arg
))
2048 (if (and (numeric-type-real-p n
)
2049 (numeric-type-real-p d
))
2052 (let ((quot (two-arg-derive-type
2053 number divisor
#'derive-q
#',name
))
2054 (rem (two-arg-derive-type
2055 number divisor
#'derive-r
#'mod
)))
2056 (when (and quot rem
)
2057 (make-values-type :required
(list quot rem
))))))))))
2059 (def floor floor-quotient-bound floor-rem-bound
)
2060 (def ceiling ceiling-quotient-bound ceiling-rem-bound
))
2062 ;;; Define optimizers for FFLOOR and FCEILING
2063 (macrolet ((def (name q-name r-name
)
2064 (let ((q-aux (symbolicate "F" q-name
"-AUX"))
2065 (r-aux (symbolicate r-name
"-AUX")))
2067 ;; Compute type of quotient (first) result.
2068 (defun ,q-aux
(number-type divisor-type
)
2069 (let* ((number-interval
2070 (numeric-type->interval number-type
))
2072 (numeric-type->interval divisor-type
))
2073 (quot (,q-name
(interval-div number-interval
2075 (res-type (numeric-contagion number-type
2078 :class
(numeric-type-class res-type
)
2079 :format
(numeric-type-format res-type
)
2080 :low
(interval-low quot
)
2081 :high
(interval-high quot
))))
2083 (defoptimizer (,name derive-type
) ((number divisor
))
2084 (flet ((derive-q (n d same-arg
)
2085 (declare (ignore same-arg
))
2086 (if (and (numeric-type-real-p n
)
2087 (numeric-type-real-p d
))
2090 (derive-r (n d same-arg
)
2091 (declare (ignore same-arg
))
2092 (if (and (numeric-type-real-p n
)
2093 (numeric-type-real-p d
))
2096 (let ((quot (two-arg-derive-type
2097 number divisor
#'derive-q
#',name
))
2098 (rem (two-arg-derive-type
2099 number divisor
#'derive-r
#'mod
)))
2100 (when (and quot rem
)
2101 (make-values-type :required
(list quot rem
))))))))))
2103 (def ffloor floor-quotient-bound floor-rem-bound
)
2104 (def fceiling ceiling-quotient-bound ceiling-rem-bound
))
2106 ;;; functions to compute the bounds on the quotient and remainder for
2107 ;;; the FLOOR function
2108 (defun floor-quotient-bound (quot)
2109 ;; Take the floor of the quotient and then massage it into what we
2111 (let ((lo (interval-low quot
))
2112 (hi (interval-high quot
)))
2113 ;; Take the floor of the lower bound. The result is always a
2114 ;; closed lower bound.
2116 (floor (type-bound-number lo
))
2118 ;; For the upper bound, we need to be careful.
2121 ;; An open bound. We need to be careful here because
2122 ;; the floor of '(10.0) is 9, but the floor of
2124 (multiple-value-bind (q r
) (floor (first hi
))
2129 ;; A closed bound, so the answer is obvious.
2133 (make-interval :low lo
:high hi
)))
2134 (defun floor-rem-bound (div)
2135 ;; The remainder depends only on the divisor. Try to get the
2136 ;; correct sign for the remainder if we can.
2137 (case (interval-range-info div
)
2139 ;; The divisor is always positive.
2140 (let ((rem (interval-abs div
)))
2141 (setf (interval-low rem
) 0)
2142 (when (and (numberp (interval-high rem
))
2143 (not (zerop (interval-high rem
))))
2144 ;; The remainder never contains the upper bound. However,
2145 ;; watch out for the case where the high limit is zero!
2146 (setf (interval-high rem
) (list (interval-high rem
))))
2149 ;; The divisor is always negative.
2150 (let ((rem (interval-neg (interval-abs div
))))
2151 (setf (interval-high rem
) 0)
2152 (when (numberp (interval-low rem
))
2153 ;; The remainder never contains the lower bound.
2154 (setf (interval-low rem
) (list (interval-low rem
))))
2157 ;; The divisor can be positive or negative. All bets off. The
2158 ;; magnitude of remainder is the maximum value of the divisor.
2159 (let ((limit (type-bound-number (interval-high (interval-abs div
)))))
2160 ;; The bound never reaches the limit, so make the interval open.
2161 (make-interval :low
(if limit
2164 :high
(list limit
))))))
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.3 :high
'(10.3
)))
2169 => #S
(INTERVAL :LOW
0 :HIGH
10)
2170 (floor-quotient-bound (make-interval :low
0.3 :high
10))
2171 => #S
(INTERVAL :LOW
0 :HIGH
10)
2172 (floor-quotient-bound (make-interval :low
0.3 :high
'(10)))
2173 => #S
(INTERVAL :LOW
0 :HIGH
9)
2174 (floor-quotient-bound (make-interval :low
'(0.3
) :high
10.3))
2175 => #S
(INTERVAL :LOW
0 :HIGH
10)
2176 (floor-quotient-bound (make-interval :low
'(0.0
) :high
10.3))
2177 => #S
(INTERVAL :LOW
0 :HIGH
10)
2178 (floor-quotient-bound (make-interval :low
'(-1.3
) :high
10.3))
2179 => #S
(INTERVAL :LOW -
2 :HIGH
10)
2180 (floor-quotient-bound (make-interval :low
'(-1.0
) :high
10.3))
2181 => #S
(INTERVAL :LOW -
1 :HIGH
10)
2182 (floor-quotient-bound (make-interval :low -
1.0 :high
10.3))
2183 => #S
(INTERVAL :LOW -
1 :HIGH
10)
2185 (floor-rem-bound (make-interval :low
0.3 :high
10.3))
2186 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2187 (floor-rem-bound (make-interval :low
0.3 :high
'(10.3
)))
2188 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2189 (floor-rem-bound (make-interval :low -
10 :high -
2.3))
2190 #S
(INTERVAL :LOW
(-10) :HIGH
0)
2191 (floor-rem-bound (make-interval :low
0.3 :high
10))
2192 => #S
(INTERVAL :LOW
0 :HIGH
'(10))
2193 (floor-rem-bound (make-interval :low
'(-1.3
) :high
10.3))
2194 => #S
(INTERVAL :LOW
'(-10.3
) :HIGH
'(10.3
))
2195 (floor-rem-bound (make-interval :low
'(-20.3
) :high
10.3))
2196 => #S
(INTERVAL :LOW
(-20.3
) :HIGH
(20.3
))
2199 ;;; same functions for CEILING
2200 (defun ceiling-quotient-bound (quot)
2201 ;; Take the ceiling of the quotient and then massage it into what we
2203 (let ((lo (interval-low quot
))
2204 (hi (interval-high quot
)))
2205 ;; Take the ceiling of the upper bound. The result is always a
2206 ;; closed upper bound.
2208 (ceiling (type-bound-number hi
))
2210 ;; For the lower bound, we need to be careful.
2213 ;; An open bound. We need to be careful here because
2214 ;; the ceiling of '(10.0) is 11, but the ceiling of
2216 (multiple-value-bind (q r
) (ceiling (first lo
))
2221 ;; A closed bound, so the answer is obvious.
2225 (make-interval :low lo
:high hi
)))
2226 (defun ceiling-rem-bound (div)
2227 ;; The remainder depends only on the divisor. Try to get the
2228 ;; correct sign for the remainder if we can.
2229 (case (interval-range-info div
)
2231 ;; Divisor is always positive. The remainder is negative.
2232 (let ((rem (interval-neg (interval-abs div
))))
2233 (setf (interval-high rem
) 0)
2234 (when (and (numberp (interval-low rem
))
2235 (not (zerop (interval-low rem
))))
2236 ;; The remainder never contains the upper bound. However,
2237 ;; watch out for the case when the upper bound is zero!
2238 (setf (interval-low rem
) (list (interval-low rem
))))
2241 ;; Divisor is always negative. The remainder is positive
2242 (let ((rem (interval-abs div
)))
2243 (setf (interval-low rem
) 0)
2244 (when (numberp (interval-high rem
))
2245 ;; The remainder never contains the lower bound.
2246 (setf (interval-high rem
) (list (interval-high rem
))))
2249 ;; The divisor can be positive or negative. All bets off. The
2250 ;; magnitude of remainder is the maximum value of the divisor.
2251 (let ((limit (type-bound-number (interval-high (interval-abs div
)))))
2252 ;; The bound never reaches the limit, so make the interval open.
2253 (make-interval :low
(if limit
2256 :high
(list limit
))))))
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.3 :high
'(10.3
)))
2262 => #S
(INTERVAL :LOW
1 :HIGH
11)
2263 (ceiling-quotient-bound (make-interval :low
0.3 :high
10))
2264 => #S
(INTERVAL :LOW
1 :HIGH
10)
2265 (ceiling-quotient-bound (make-interval :low
0.3 :high
'(10)))
2266 => #S
(INTERVAL :LOW
1 :HIGH
10)
2267 (ceiling-quotient-bound (make-interval :low
'(0.3
) :high
10.3))
2268 => #S
(INTERVAL :LOW
1 :HIGH
11)
2269 (ceiling-quotient-bound (make-interval :low
'(0.0
) :high
10.3))
2270 => #S
(INTERVAL :LOW
1 :HIGH
11)
2271 (ceiling-quotient-bound (make-interval :low
'(-1.3
) :high
10.3))
2272 => #S
(INTERVAL :LOW -
1 :HIGH
11)
2273 (ceiling-quotient-bound (make-interval :low
'(-1.0
) :high
10.3))
2274 => #S
(INTERVAL :LOW
0 :HIGH
11)
2275 (ceiling-quotient-bound (make-interval :low -
1.0 :high
10.3))
2276 => #S
(INTERVAL :LOW -
1 :HIGH
11)
2278 (ceiling-rem-bound (make-interval :low
0.3 :high
10.3))
2279 => #S
(INTERVAL :LOW
(-10.3
) :HIGH
0)
2280 (ceiling-rem-bound (make-interval :low
0.3 :high
'(10.3
)))
2281 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2282 (ceiling-rem-bound (make-interval :low -
10 :high -
2.3))
2283 => #S
(INTERVAL :LOW
0 :HIGH
(10))
2284 (ceiling-rem-bound (make-interval :low
0.3 :high
10))
2285 => #S
(INTERVAL :LOW
(-10) :HIGH
0)
2286 (ceiling-rem-bound (make-interval :low
'(-1.3
) :high
10.3))
2287 => #S
(INTERVAL :LOW
(-10.3
) :HIGH
(10.3
))
2288 (ceiling-rem-bound (make-interval :low
'(-20.3
) :high
10.3))
2289 => #S
(INTERVAL :LOW
(-20.3
) :HIGH
(20.3
))
2292 (defun truncate-quotient-bound (quot)
2293 ;; For positive quotients, truncate is exactly like floor. For
2294 ;; negative quotients, truncate is exactly like ceiling. Otherwise,
2295 ;; it's the union of the two pieces.
2296 (case (interval-range-info quot
)
2299 (floor-quotient-bound quot
))
2301 ;; just like CEILING
2302 (ceiling-quotient-bound quot
))
2304 ;; Split the interval into positive and negative pieces, compute
2305 ;; the result for each piece and put them back together.
2306 (destructuring-bind (neg pos
) (interval-split 0 quot t t
)
2307 (interval-merge-pair (ceiling-quotient-bound neg
)
2308 (floor-quotient-bound pos
))))))
2310 (defun truncate-rem-bound (num div
)
2311 ;; This is significantly more complicated than FLOOR or CEILING. We
2312 ;; need both the number and the divisor to determine the range. The
2313 ;; basic idea is to split the ranges of NUM and DEN into positive
2314 ;; and negative pieces and deal with each of the four possibilities
2316 (case (interval-range-info num
)
2318 (case (interval-range-info div
)
2320 (floor-rem-bound div
))
2322 (ceiling-rem-bound div
))
2324 (destructuring-bind (neg pos
) (interval-split 0 div t t
)
2325 (interval-merge-pair (truncate-rem-bound num neg
)
2326 (truncate-rem-bound num pos
))))))
2328 (case (interval-range-info div
)
2330 (ceiling-rem-bound div
))
2332 (floor-rem-bound div
))
2334 (destructuring-bind (neg pos
) (interval-split 0 div t t
)
2335 (interval-merge-pair (truncate-rem-bound num neg
)
2336 (truncate-rem-bound num pos
))))))
2338 (destructuring-bind (neg pos
) (interval-split 0 num t t
)
2339 (interval-merge-pair (truncate-rem-bound neg div
)
2340 (truncate-rem-bound pos div
))))))
2343 ;;; Derive useful information about the range. Returns three values:
2344 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2345 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2346 ;;; - The abs of the maximal value if there is one, or nil if it is
2348 (defun numeric-range-info (low high
)
2349 (cond ((and low
(not (minusp low
)))
2350 (values '+ low high
))
2351 ((and high
(not (plusp high
)))
2352 (values '-
(- high
) (if low
(- low
) nil
)))
2354 (values nil
0 (and low high
(max (- low
) high
))))))
2356 (defun integer-truncate-derive-type
2357 (number-low number-high divisor-low divisor-high
)
2358 ;; The result cannot be larger in magnitude than the number, but the
2359 ;; sign might change. If we can determine the sign of either the
2360 ;; number or the divisor, we can eliminate some of the cases.
2361 (multiple-value-bind (number-sign number-min number-max
)
2362 (numeric-range-info number-low number-high
)
2363 (multiple-value-bind (divisor-sign divisor-min divisor-max
)
2364 (numeric-range-info divisor-low divisor-high
)
2365 (when (and divisor-max
(zerop divisor-max
))
2366 ;; We've got a problem: guaranteed division by zero.
2367 (return-from integer-truncate-derive-type t
))
2368 (when (zerop divisor-min
)
2369 ;; We'll assume that they aren't going to divide by zero.
2371 (cond ((and number-sign divisor-sign
)
2372 ;; We know the sign of both.
2373 (if (eq number-sign divisor-sign
)
2374 ;; Same sign, so the result will be positive.
2375 `(integer ,(if divisor-max
2376 (truncate number-min divisor-max
)
2379 (truncate number-max divisor-min
)
2381 ;; Different signs, the result will be negative.
2382 `(integer ,(if number-max
2383 (- (truncate number-max divisor-min
))
2386 (- (truncate number-min divisor-max
))
2388 ((eq divisor-sign
'+)
2389 ;; The divisor is positive. Therefore, the number will just
2390 ;; become closer to zero.
2391 `(integer ,(if number-low
2392 (truncate number-low divisor-min
)
2395 (truncate number-high divisor-min
)
2397 ((eq divisor-sign
'-
)
2398 ;; The divisor is negative. Therefore, the absolute value of
2399 ;; the number will become closer to zero, but the sign will also
2401 `(integer ,(if number-high
2402 (- (truncate number-high divisor-min
))
2405 (- (truncate number-low divisor-min
))
2407 ;; The divisor could be either positive or negative.
2409 ;; The number we are dividing has a bound. Divide that by the
2410 ;; smallest posible divisor.
2411 (let ((bound (truncate number-max divisor-min
)))
2412 `(integer ,(- bound
) ,bound
)))
2414 ;; The number we are dividing is unbounded, so we can't tell
2415 ;; anything about the result.
2418 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2419 (defun integer-rem-derive-type
2420 (number-low number-high divisor-low divisor-high
)
2421 (if (and divisor-low divisor-high
)
2422 ;; We know the range of the divisor, and the remainder must be
2423 ;; smaller than the divisor. We can tell the sign of the
2424 ;; remainder if we know the sign of the number.
2425 (let ((divisor-max (1- (max (abs divisor-low
) (abs divisor-high
)))))
2426 `(integer ,(if (or (null number-low
)
2427 (minusp number-low
))
2430 ,(if (or (null number-high
)
2431 (plusp number-high
))
2434 ;; The divisor is potentially either very positive or very
2435 ;; negative. Therefore, the remainder is unbounded, but we might
2436 ;; be able to tell something about the sign from the number.
2437 `(integer ,(if (and number-low
(not (minusp number-low
)))
2438 ;; The number we are dividing is positive.
2439 ;; Therefore, the remainder must be positive.
2442 ,(if (and number-high
(not (plusp number-high
)))
2443 ;; The number we are dividing is negative.
2444 ;; Therefore, the remainder must be negative.
2448 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2449 (defoptimizer (random derive-type
) ((bound &optional state
))
2450 (declare (ignore state
))
2451 (let ((type (lvar-type bound
)))
2452 (when (numeric-type-p type
)
2453 (let ((class (numeric-type-class type
))
2454 (high (numeric-type-high type
))
2455 (format (numeric-type-format type
)))
2459 :low
(coerce 0 (or format class
'real
))
2460 :high
(cond ((not high
) nil
)
2461 ((eq class
'integer
) (max (1- high
) 0))
2462 ((or (consp high
) (zerop high
)) high
)
2465 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2466 (defun random-derive-type-aux (type)
2467 (let ((class (numeric-type-class type
))
2468 (high (numeric-type-high type
))
2469 (format (numeric-type-format type
)))
2473 :low
(coerce 0 (or format class
'real
))
2474 :high
(cond ((not high
) nil
)
2475 ((eq class
'integer
) (max (1- high
) 0))
2476 ((or (consp high
) (zerop high
)) high
)
2479 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2480 (defoptimizer (random derive-type
) ((bound &optional state
))
2481 (declare (ignore state
))
2482 (one-arg-derive-type bound
#'random-derive-type-aux nil
))
2484 ;;;; miscellaneous derive-type methods
2486 (defoptimizer (integer-length derive-type
) ((x))
2487 (let ((x-type (lvar-type x
)))
2488 (when (numeric-type-p x-type
)
2489 ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2490 ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be
2491 ;; careful about LO or HI being NIL, though. Also, if 0 is
2492 ;; contained in X, the lower bound is obviously 0.
2493 (flet ((null-or-min (a b
)
2494 (and a b
(min (integer-length a
)
2495 (integer-length b
))))
2497 (and a b
(max (integer-length a
)
2498 (integer-length b
)))))
2499 (let* ((min (numeric-type-low x-type
))
2500 (max (numeric-type-high x-type
))
2501 (min-len (null-or-min min max
))
2502 (max-len (null-or-max min max
)))
2503 (when (ctypep 0 x-type
)
2505 (specifier-type `(integer ,(or min-len
'*) ,(or max-len
'*))))))))
2507 (defoptimizer (isqrt derive-type
) ((x))
2508 (let ((x-type (lvar-type x
)))
2509 (when (numeric-type-p x-type
)
2510 (let* ((lo (numeric-type-low x-type
))
2511 (hi (numeric-type-high x-type
))
2512 (lo-res (if lo
(isqrt lo
) '*))
2513 (hi-res (if hi
(isqrt hi
) '*)))
2514 (specifier-type `(integer ,lo-res
,hi-res
))))))
2516 (defoptimizer (char-code derive-type
) ((char))
2517 (let ((type (type-intersection (lvar-type char
) (specifier-type 'character
))))
2518 (cond ((member-type-p type
)
2521 ,@(loop for member in
(member-type-members type
)
2522 when
(characterp member
)
2523 collect
(char-code member
)))))
2524 ((sb!kernel
::character-set-type-p type
)
2527 ,@(loop for
(low . high
)
2528 in
(character-set-type-pairs type
)
2529 collect
`(integer ,low
,high
)))))
2530 ((csubtypep type
(specifier-type 'base-char
))
2532 `(mod ,base-char-code-limit
)))
2535 `(mod ,sb
!xc
:char-code-limit
))))))
2537 (defoptimizer (code-char derive-type
) ((code))
2538 (let ((type (lvar-type code
)))
2539 ;; FIXME: unions of integral ranges? It ought to be easier to do
2540 ;; this, given that CHARACTER-SET is basically an integral range
2541 ;; type. -- CSR, 2004-10-04
2542 (when (numeric-type-p type
)
2543 (let* ((lo (numeric-type-low type
))
2544 (hi (numeric-type-high type
))
2545 (type (specifier-type `(character-set ((,lo .
,hi
))))))
2547 ;; KLUDGE: when running on the host, we lose a slight amount
2548 ;; of precision so that we don't have to "unparse" types
2549 ;; that formally we can't, such as (CHARACTER-SET ((0
2550 ;; . 0))). -- CSR, 2004-10-06
2552 ((csubtypep type
(specifier-type 'standard-char
)) type
)
2554 ((csubtypep type
(specifier-type 'base-char
))
2555 (specifier-type 'base-char
))
2557 ((csubtypep type
(specifier-type 'extended-char
))
2558 (specifier-type 'extended-char
))
2559 (t #+sb-xc-host
(specifier-type 'character
)
2560 #-sb-xc-host type
))))))
2562 (defoptimizer (values derive-type
) ((&rest values
))
2563 (make-values-type :required
(mapcar #'lvar-type values
)))
2565 (defun signum-derive-type-aux (type)
2566 (if (eq (numeric-type-complexp type
) :complex
)
2567 (let* ((format (case (numeric-type-class type
)
2568 ((integer rational
) 'single-float
)
2569 (t (numeric-type-format type
))))
2570 (bound-format (or format
'float
)))
2571 (make-numeric-type :class
'float
2574 :low
(coerce -
1 bound-format
)
2575 :high
(coerce 1 bound-format
)))
2576 (let* ((interval (numeric-type->interval type
))
2577 (range-info (interval-range-info interval
))
2578 (contains-0-p (interval-contains-p 0 interval
))
2579 (class (numeric-type-class type
))
2580 (format (numeric-type-format type
))
2581 (one (coerce 1 (or format class
'real
)))
2582 (zero (coerce 0 (or format class
'real
)))
2583 (minus-one (coerce -
1 (or format class
'real
)))
2584 (plus (make-numeric-type :class class
:format format
2585 :low one
:high one
))
2586 (minus (make-numeric-type :class class
:format format
2587 :low minus-one
:high minus-one
))
2588 ;; KLUDGE: here we have a fairly horrible hack to deal
2589 ;; with the schizophrenia in the type derivation engine.
2590 ;; The problem is that the type derivers reinterpret
2591 ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
2592 ;; 0d0) within the derivation mechanism doesn't include
2593 ;; -0d0. Ugh. So force it in here, instead.
2594 (zero (make-numeric-type :class class
:format format
2595 :low
(- zero
) :high zero
)))
2597 (+ (if contains-0-p
(type-union plus zero
) plus
))
2598 (- (if contains-0-p
(type-union minus zero
) minus
))
2599 (t (type-union minus zero plus
))))))
2601 (defoptimizer (signum derive-type
) ((num))
2602 (one-arg-derive-type num
#'signum-derive-type-aux nil
))
2604 ;;;; byte operations
2606 ;;;; We try to turn byte operations into simple logical operations.
2607 ;;;; First, we convert byte specifiers into separate size and position
2608 ;;;; arguments passed to internal %FOO functions. We then attempt to
2609 ;;;; transform the %FOO functions into boolean operations when the
2610 ;;;; size and position are constant and the operands are fixnums.
2612 (macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to
2613 ;; expressions that evaluate to the SIZE and POSITION of
2614 ;; the byte-specifier form SPEC. We may wrap a let around
2615 ;; the result of the body to bind some variables.
2617 ;; If the spec is a BYTE form, then bind the vars to the
2618 ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE
2619 ;; and BYTE-POSITION. The goal of this transformation is to
2620 ;; avoid consing up byte specifiers and then immediately
2621 ;; throwing them away.
2622 (with-byte-specifier ((size-var pos-var spec
) &body body
)
2623 (once-only ((spec `(macroexpand ,spec
))
2625 `(if (and (consp ,spec
)
2626 (eq (car ,spec
) 'byte
)
2627 (= (length ,spec
) 3))
2628 (let ((,size-var
(second ,spec
))
2629 (,pos-var
(third ,spec
)))
2631 (let ((,size-var
`(byte-size ,,temp
))
2632 (,pos-var
`(byte-position ,,temp
)))
2633 `(let ((,,temp
,,spec
))
2636 (define-source-transform ldb
(spec int
)
2637 (with-byte-specifier (size pos spec
)
2638 `(%ldb
,size
,pos
,int
)))
2640 (define-source-transform dpb
(newbyte spec int
)
2641 (with-byte-specifier (size pos spec
)
2642 `(%dpb
,newbyte
,size
,pos
,int
)))
2644 (define-source-transform mask-field
(spec int
)
2645 (with-byte-specifier (size pos spec
)
2646 `(%mask-field
,size
,pos
,int
)))
2648 (define-source-transform deposit-field
(newbyte spec int
)
2649 (with-byte-specifier (size pos spec
)
2650 `(%deposit-field
,newbyte
,size
,pos
,int
))))
2652 (defoptimizer (%ldb derive-type
) ((size posn num
))
2653 (declare (ignore posn num
))
2654 (let ((size (lvar-type size
)))
2655 (if (and (numeric-type-p size
)
2656 (csubtypep size
(specifier-type 'integer
)))
2657 (let ((size-high (numeric-type-high size
)))
2658 (if (and size-high
(<= size-high sb
!vm
:n-word-bits
))
2659 (specifier-type `(unsigned-byte* ,size-high
))
2660 (specifier-type 'unsigned-byte
)))
2663 (defoptimizer (%mask-field derive-type
) ((size posn num
))
2664 (declare (ignore num
))
2665 (let ((size (lvar-type size
))
2666 (posn (lvar-type posn
)))
2667 (if (and (numeric-type-p size
)
2668 (csubtypep size
(specifier-type 'integer
))
2669 (numeric-type-p posn
)
2670 (csubtypep posn
(specifier-type 'integer
)))
2671 (let ((size-high (numeric-type-high size
))
2672 (posn-high (numeric-type-high posn
)))
2673 (if (and size-high posn-high
2674 (<= (+ size-high posn-high
) sb
!vm
:n-word-bits
))
2675 (specifier-type `(unsigned-byte* ,(+ size-high posn-high
)))
2676 (specifier-type 'unsigned-byte
)))
2679 (defun %deposit-field-derive-type-aux
(size posn int
)
2680 (let ((size (lvar-type size
))
2681 (posn (lvar-type posn
))
2682 (int (lvar-type int
)))
2683 (when (and (numeric-type-p size
)
2684 (numeric-type-p posn
)
2685 (numeric-type-p int
))
2686 (let ((size-high (numeric-type-high size
))
2687 (posn-high (numeric-type-high posn
))
2688 (high (numeric-type-high int
))
2689 (low (numeric-type-low int
)))
2690 (when (and size-high posn-high high low
2691 ;; KLUDGE: we need this cutoff here, otherwise we
2692 ;; will merrily derive the type of %DPB as
2693 ;; (UNSIGNED-BYTE 1073741822), and then attempt to
2694 ;; canonicalize this type to (INTEGER 0 (1- (ASH 1
2695 ;; 1073741822))), with hilarious consequences. We
2696 ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference
2697 ;; over a reasonable amount of shifting, even on
2698 ;; the alpha/32 port, where N-WORD-BITS is 32 but
2699 ;; machine integers are 64-bits. -- CSR,
2701 (<= (+ size-high posn-high
) (* 4 sb
!vm
:n-word-bits
)))
2702 (let ((raw-bit-count (max (integer-length high
)
2703 (integer-length low
)
2704 (+ size-high posn-high
))))
2707 `(signed-byte ,(1+ raw-bit-count
))
2708 `(unsigned-byte* ,raw-bit-count
)))))))))
2710 (defoptimizer (%dpb derive-type
) ((newbyte size posn int
))
2711 (declare (ignore newbyte
))
2712 (%deposit-field-derive-type-aux size posn int
))
2714 (defoptimizer (%deposit-field derive-type
) ((newbyte size posn int
))
2715 (declare (ignore newbyte
))
2716 (%deposit-field-derive-type-aux size posn int
))
2718 (deftransform %ldb
((size posn int
)
2719 (fixnum fixnum integer
)
2720 (unsigned-byte #.sb
!vm
:n-word-bits
))
2721 "convert to inline logical operations"
2722 `(logand (ash int
(- posn
))
2723 (ash ,(1- (ash 1 sb
!vm
:n-word-bits
))
2724 (- size
,sb
!vm
:n-word-bits
))))
2726 (deftransform %mask-field
((size posn int
)
2727 (fixnum fixnum integer
)
2728 (unsigned-byte #.sb
!vm
:n-word-bits
))
2729 "convert to inline logical operations"
2731 (ash (ash ,(1- (ash 1 sb
!vm
:n-word-bits
))
2732 (- size
,sb
!vm
:n-word-bits
))
2735 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
2736 ;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
2737 ;;; as the result type, as that would allow result types that cover
2738 ;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
2739 ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
2741 (deftransform %dpb
((new size posn int
)
2743 (unsigned-byte #.sb
!vm
:n-word-bits
))
2744 "convert to inline logical operations"
2745 `(let ((mask (ldb (byte size
0) -
1)))
2746 (logior (ash (logand new mask
) posn
)
2747 (logand int
(lognot (ash mask posn
))))))
2749 (deftransform %dpb
((new size posn int
)
2751 (signed-byte #.sb
!vm
:n-word-bits
))
2752 "convert to inline logical operations"
2753 `(let ((mask (ldb (byte size
0) -
1)))
2754 (logior (ash (logand new mask
) posn
)
2755 (logand int
(lognot (ash mask posn
))))))
2757 (deftransform %deposit-field
((new size posn int
)
2759 (unsigned-byte #.sb
!vm
:n-word-bits
))
2760 "convert to inline logical operations"
2761 `(let ((mask (ash (ldb (byte size
0) -
1) posn
)))
2762 (logior (logand new mask
)
2763 (logand int
(lognot mask
)))))
2765 (deftransform %deposit-field
((new size posn int
)
2767 (signed-byte #.sb
!vm
:n-word-bits
))
2768 "convert to inline logical operations"
2769 `(let ((mask (ash (ldb (byte size
0) -
1) posn
)))
2770 (logior (logand new mask
)
2771 (logand int
(lognot mask
)))))
2773 (defoptimizer (mask-signed-field derive-type
) ((size x
))
2774 (declare (ignore x
))
2775 (let ((size (lvar-type size
)))
2776 (if (numeric-type-p size
)
2777 (let ((size-high (numeric-type-high size
)))
2778 (if (and size-high
(<= 1 size-high sb
!vm
:n-word-bits
))
2779 (specifier-type `(signed-byte ,size-high
))
2786 (defun %ash
/right
(integer amount
)
2787 (ash integer
(- amount
)))
2789 (deftransform ash
((integer amount
))
2790 "Convert ASH of signed word to %ASH/RIGHT"
2791 (unless (and (csubtypep (lvar-type integer
) ; do that ourselves to avoid
2792 (specifier-type 'sb
!vm
:signed-word
)) ; optimization
2793 (csubtypep (lvar-type amount
) ; notes.
2794 (specifier-type '(integer * 0))))
2795 (give-up-ir1-transform))
2796 (when (constant-lvar-p amount
)
2797 (give-up-ir1-transform))
2798 (let ((use (lvar-uses amount
)))
2799 (cond ((and (combination-p use
)
2800 (eql '%negate
(lvar-fun-name (combination-fun use
))))
2801 (splice-fun-args amount
'%negate
1)
2802 `(lambda (integer amount
)
2803 (declare (type unsigned-byte amount
))
2804 (%ash
/right integer
(if (>= amount
,sb
!vm
:n-word-bits
)
2805 ,(1- sb
!vm
:n-word-bits
)
2808 `(%ash
/right integer
(if (<= amount
,(- sb
!vm
:n-word-bits
))
2809 ,(1- sb
!vm
:n-word-bits
)
2812 (deftransform ash
((integer amount
))
2813 "Convert ASH of word to %ASH/RIGHT"
2814 (unless (and (csubtypep (lvar-type integer
)
2815 (specifier-type 'sb
!vm
:word
))
2816 (csubtypep (lvar-type amount
)
2817 (specifier-type '(integer * 0))))
2818 (give-up-ir1-transform))
2819 (when (constant-lvar-p amount
)
2820 (give-up-ir1-transform))
2821 (let ((use (lvar-uses amount
)))
2822 (cond ((and (combination-p use
)
2823 (eql '%negate
(lvar-fun-name (combination-fun use
))))
2824 (splice-fun-args amount
'%negate
1)
2825 `(lambda (integer amount
)
2826 (declare (type unsigned-byte amount
))
2827 (if (>= amount
,sb
!vm
:n-word-bits
)
2829 (%ash
/right integer amount
))))
2831 `(if (<= amount
,(- sb
!vm
:n-word-bits
))
2833 (%ash
/right integer
(- amount
)))))))
2835 (deftransform %ash
/right
((integer amount
) (integer (constant-arg unsigned-byte
)))
2836 "Convert %ASH/RIGHT by constant back to ASH"
2837 `(ash integer
,(- (lvar-value amount
))))
2839 (deftransform %ash
/right
((integer amount
) * * :node node
)
2840 "strength reduce large variable right shift"
2841 (let ((return-type (single-value-type (node-derived-type node
))))
2842 (cond ((type= return-type
(specifier-type '(eql 0)))
2844 ((type= return-type
(specifier-type '(eql -
1)))
2846 ((csubtypep return-type
(specifier-type '(member -
1 0)))
2847 `(ash integer
,(- sb
!vm
:n-word-bits
)))
2849 (give-up-ir1-transform)))))
2851 (defun %ash
/right-derive-type-aux
(n-type shift same-arg
)
2852 (declare (ignore same-arg
))
2853 (or (and (or (csubtypep n-type
(specifier-type 'sb
!vm
:signed-word
))
2854 (csubtypep n-type
(specifier-type 'word
)))
2855 (csubtypep shift
(specifier-type `(mod ,sb
!vm
:n-word-bits
)))
2856 (let ((n-low (numeric-type-low n-type
))
2857 (n-high (numeric-type-high n-type
))
2858 (s-low (numeric-type-low shift
))
2859 (s-high (numeric-type-high shift
)))
2860 (make-numeric-type :class
'integer
:complexp
:real
2863 (ash n-low
(- s-low
))
2864 (ash n-low
(- s-high
))))
2867 (ash n-high
(- s-high
))
2868 (ash n-high
(- s-low
)))))))
2871 (defoptimizer (%ash
/right derive-type
) ((n shift
))
2872 (two-arg-derive-type n shift
#'%ash
/right-derive-type-aux
#'%ash
/right
))
2875 ;;; Modular functions
2877 ;;; (ldb (byte s 0) (foo x y ...)) =
2878 ;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
2880 ;;; and similar for other arguments.
2882 (defun make-modular-fun-type-deriver (prototype kind width signedp
)
2883 (declare (ignore kind
))
2885 (binding* ((info (info :function
:info prototype
) :exit-if-null
)
2886 (fun (fun-info-derive-type info
) :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
))))))
2893 (let ((res (funcall fun call
)))
2895 (if (eq signedp nil
)
2896 (logand-derive-type-aux res mask-type
))))))
2899 (binding* ((info (info :function
:info prototype
) :exit-if-null
)
2900 (fun (fun-info-derive-type info
) :exit-if-null
)
2901 (res (funcall fun call
) :exit-if-null
)
2902 (mask-type (specifier-type
2904 ((nil) (let ((mask (1- (ash 1 width
))))
2905 `(integer ,mask
,mask
)))
2906 ((t) `(signed-byte ,width
))))))
2907 (if (eq signedp nil
)
2908 (logand-derive-type-aux res mask-type
)))))
2910 ;;; Try to recursively cut all uses of LVAR to WIDTH bits.
2912 ;;; For good functions, we just recursively cut arguments; their
2913 ;;; "goodness" means that the result will not increase (in the
2914 ;;; (unsigned-byte +infinity) sense). An ordinary modular function is
2915 ;;; replaced with the version, cutting its result to WIDTH or more
2916 ;;; bits. For most functions (e.g. for +) we cut all arguments; for
2917 ;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
2918 ;;; arguments (maybe to a different width) and returning the name of a
2919 ;;; modular version, if it exists, or NIL. If we have changed
2920 ;;; anything, we need to flush old derived types, because they have
2921 ;;; nothing in common with the new code.
2922 (defun cut-to-width (lvar kind width signedp
)
2923 (declare (type lvar lvar
) (type (integer 0) width
))
2924 (let ((type (specifier-type (if (zerop width
)
2927 ((nil) 'unsigned-byte
)
2930 (labels ((reoptimize-node (node name
)
2931 (setf (node-derived-type node
)
2933 (info :function
:type name
)))
2934 (setf (lvar-%derived-type
(node-lvar node
)) nil
)
2935 (setf (node-reoptimize node
) t
)
2936 (setf (block-reoptimize (node-block node
)) t
)
2937 (reoptimize-component (node-component node
) :maybe
))
2938 (insert-lvar-cut (lvar)
2939 "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
2940 to the required bit width. Returns T if any change was made.
2942 When the destination of LVAR will definitely cut LVAR's value
2943 to width (i.e. it's a logand or mask-signed-field with constant
2944 other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
2945 (binding* ((dest (lvar-dest lvar
) :exit-if-null
)
2946 (nil (combination-p dest
) :exit-if-null
)
2947 (name (lvar-fun-name (combination-fun dest
) t
))
2948 (args (combination-args dest
)))
2951 (when (= 2 (length args
))
2952 (let ((other (if (eql (first args
) lvar
)
2955 (when (and (constant-lvar-p other
)
2956 (ctypep (lvar-value other
) type
)
2958 (return-from insert-lvar-cut
)))))
2961 (eql lvar
(second args
))
2962 (constant-lvar-p (first args
))
2963 (<= (lvar-value (first args
)) width
))
2964 (return-from insert-lvar-cut
)))))
2967 `(mask-signed-field ,width
'dummy
)
2968 `(logand 'dummy
,(ldb (byte width
0) -
1))))
2969 (do-uses (node lvar
)
2970 (setf (block-reoptimize (node-block node
)) t
)
2971 (reoptimize-component (node-component node
) :maybe
))
2974 "Try to cut a node to width. The primary return value is
2975 whether we managed to cut (cleverly), and the second whether
2976 anything was changed. The third return value tells whether
2977 the cut value might be wider than expected."
2978 (when (block-delete-p (node-block node
))
2979 (return-from cut-node
(values t nil
)))
2982 (typecase (ref-leaf node
)
2984 (let* ((constant-value (constant-value (ref-leaf node
)))
2986 (cond ((not (integerp constant-value
))
2987 (return-from cut-node
(values t nil
)))
2989 (mask-signed-field width constant-value
))
2991 (ldb (byte width
0) constant-value
)))))
2992 (cond ((= constant-value new-value
)
2993 (values t nil
)) ; we knew what to do and did nothing
2995 (change-ref-leaf node
(make-constant new-value
)
2997 (let ((lvar (node-lvar node
)))
2998 (setf (lvar-%derived-type lvar
)
2999 (and (lvar-has-single-use-p lvar
)
3000 (make-values-type :required
(list (ctype-of new-value
))))))
3001 (setf (block-reoptimize (node-block node
)) t
)
3002 (reoptimize-component (node-component node
) :maybe
)
3005 (when (eq (basic-combination-kind node
) :known
)
3006 (let* ((fun-ref (lvar-use (combination-fun node
)))
3007 (fun-name (lvar-fun-name (combination-fun node
)))
3008 (modular-fun (find-modular-version fun-name kind
3010 (cond ((not modular-fun
)
3011 ;; don't know what to do here
3013 ((let ((dtype (single-value-type
3014 (node-derived-type node
))))
3019 (specifier-type 'unsigned-byte
)))
3022 (specifier-type '(integer * 0))))
3026 (csubtypep dtype type
)))
3030 (binding* ((name (etypecase modular-fun
3031 ((eql :good
) fun-name
)
3033 (modular-fun-info-name modular-fun
))
3035 (funcall modular-fun node width
)))
3039 (unless (eql modular-fun
:good
)
3040 (setq did-something t
3044 (find-free-fun name
"in a strange place"))
3045 (setf (combination-kind node
) :full
))
3046 (unless (functionp modular-fun
)
3047 (dolist (arg (basic-combination-args node
))
3048 (multiple-value-bind (change wide
)
3050 (setf did-something
(or did-something change
)
3051 over-wide
(or over-wide wide
)))))
3053 (reoptimize-node node name
))
3054 (values t did-something over-wide
)))))))))
3055 (cut-lvar (lvar &key head
3056 &aux did-something must-insert over-wide
)
3057 "Cut all the LVAR's use nodes. If any of them wasn't handled
3058 and its type is too wide for the operation we wish to perform
3059 insert an explicit bit-width narrowing operation (LOGAND or
3060 MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
3061 The narrowing operation might not be inserted if the LVAR's
3062 destination is already such an operation, to avoid endless
3065 If we're at the head, forcibly insert a cut operation if the
3066 result might be too wide.
3068 (*) We can't easily do that for each node, and doing so might
3069 result in code bloat, anyway. (I'm also not sure it would be
3070 correct for complicated C/D FG)"
3071 (do-uses (node lvar
)
3072 (multiple-value-bind (handled any-change wide
)
3074 (setf did-something
(or did-something any-change
)
3075 must-insert
(or must-insert
3077 (csubtypep (single-value-type
3078 (node-derived-type node
))
3080 over-wide
(or over-wide wide
))))
3081 (when (or must-insert
3082 (and head over-wide
))
3083 (setf did-something
(or (insert-lvar-cut lvar
) did-something
)
3084 ;; we're just the right width after an explicit cut.
3086 (values did-something over-wide
)))
3087 (cut-lvar lvar
:head t
))))
3089 (defun best-modular-version (width signedp
)
3090 ;; 1. exact width-matched :untagged
3091 ;; 2. >/>= width-matched :tagged
3092 ;; 3. >/>= width-matched :untagged
3093 (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class
*))
3094 (uswidths (modular-class-widths *untagged-signed-modular-class
*))
3095 (uwidths (if (and uuwidths uswidths
)
3096 (merge 'list
(copy-list uuwidths
) (copy-list uswidths
)
3098 (or uuwidths uswidths
)))
3099 (twidths (modular-class-widths *tagged-modular-class
*)))
3100 (let ((exact (find (cons width signedp
) uwidths
:test
#'equal
)))
3102 (return-from best-modular-version
(values width
:untagged signedp
))))
3103 (flet ((inexact-match (w)
3105 ((eq signedp
(cdr w
)) (<= width
(car w
)))
3106 ((eq signedp nil
) (< width
(car w
))))))
3107 (let ((tgt (find-if #'inexact-match twidths
)))
3109 (return-from best-modular-version
3110 (values (car tgt
) :tagged
(cdr tgt
)))))
3111 (let ((ugt (find-if #'inexact-match uwidths
)))
3113 (return-from best-modular-version
3114 (values (car ugt
) :untagged
(cdr ugt
))))))))
3116 (defun integer-type-numeric-bounds (type)
3118 (numeric-type (values (numeric-type-low type
)
3119 (numeric-type-high type
)))
3123 (dolist (type (union-type-types type
) (values low high
))
3124 (unless (and (numeric-type-p type
)
3125 (eql (numeric-type-class type
) 'integer
))
3126 (return (values nil nil
)))
3127 (let ((this-low (numeric-type-low type
))
3128 (this-high (numeric-type-high type
)))
3129 (unless (and this-low this-high
)
3130 (return (values nil nil
)))
3131 (setf low
(min this-low
(or low this-low
))
3132 high
(max this-high
(or high this-high
)))))))))
3134 (defoptimizer (logand optimizer
) ((x y
) node
)
3135 (let ((result-type (single-value-type (node-derived-type node
))))
3136 (multiple-value-bind (low high
)
3137 (integer-type-numeric-bounds result-type
)
3138 (when (and (numberp low
)
3141 (let ((width (integer-length high
)))
3142 (multiple-value-bind (w kind signedp
)
3143 (best-modular-version width nil
)
3145 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
3147 ;; FIXME: I think the FIXME (which is from APD) above
3148 ;; implies that CUT-TO-WIDTH should do /everything/
3149 ;; that's required, including reoptimizing things
3150 ;; itself that it knows are necessary. At the moment,
3151 ;; CUT-TO-WIDTH sets up some new calls with
3152 ;; combination-type :FULL, which later get noticed as
3153 ;; known functions and properly converted.
3155 ;; We cut to W not WIDTH if SIGNEDP is true, because
3156 ;; signed constant replacement needs to know which bit
3157 ;; in the field is the signed bit.
3158 (let ((xact (cut-to-width x kind
(if signedp w width
) signedp
))
3159 (yact (cut-to-width y kind
(if signedp w width
) signedp
)))
3160 (declare (ignore xact yact
))
3161 nil
) ; After fixing above, replace with T, meaning
3162 ; "don't reoptimize this (LOGAND) node any more".
3165 (defoptimizer (mask-signed-field optimizer
) ((width x
) node
)
3166 (declare (ignore width
))
3167 (let ((result-type (single-value-type (node-derived-type node
))))
3168 (multiple-value-bind (low high
)
3169 (integer-type-numeric-bounds result-type
)
3170 (when (and (numberp low
) (numberp high
))
3171 (let ((width (max (integer-length high
) (integer-length low
))))
3172 (multiple-value-bind (w kind
)
3173 (best-modular-version (1+ width
) t
)
3175 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
3176 ;; [ see comment above in LOGAND optimizer ]
3177 (cut-to-width x kind w t
)
3178 nil
; After fixing above, replace with T.
3181 (defoptimizer (logior optimizer
) ((x y
) node
)
3182 (let ((result-type (single-value-type (node-derived-type node
))))
3183 (multiple-value-bind (low high
)
3184 (integer-type-numeric-bounds result-type
)
3185 (when (and (numberp low
)
3188 (let ((width (integer-length low
)))
3189 (multiple-value-bind (w kind
)
3190 (best-modular-version (1+ width
) t
)
3192 ;; FIXME: see comment in LOGAND optimizer
3193 (let ((xact (cut-to-width x kind w t
))
3194 (yact (cut-to-width y kind w t
)))
3195 (declare (ignore xact yact
))
3196 nil
) ; After fixing above, replace with T
3199 ;;; Handle the case of a constant BOOLE-CODE.
3200 (deftransform boole
((op x y
) * *)
3201 "convert to inline logical operations"
3202 (unless (constant-lvar-p op
)
3203 (give-up-ir1-transform "BOOLE code is not a constant."))
3204 (let ((control (lvar-value op
)))
3206 (#.sb
!xc
:boole-clr
0)
3207 (#.sb
!xc
:boole-set -
1)
3208 (#.sb
!xc
:boole-1
'x
)
3209 (#.sb
!xc
:boole-2
'y
)
3210 (#.sb
!xc
:boole-c1
'(lognot x
))
3211 (#.sb
!xc
:boole-c2
'(lognot y
))
3212 (#.sb
!xc
:boole-and
'(logand x y
))
3213 (#.sb
!xc
:boole-ior
'(logior x y
))
3214 (#.sb
!xc
:boole-xor
'(logxor x y
))
3215 (#.sb
!xc
:boole-eqv
'(logeqv x y
))
3216 (#.sb
!xc
:boole-nand
'(lognand x y
))
3217 (#.sb
!xc
:boole-nor
'(lognor x y
))
3218 (#.sb
!xc
:boole-andc1
'(logandc1 x y
))
3219 (#.sb
!xc
:boole-andc2
'(logandc2 x y
))
3220 (#.sb
!xc
:boole-orc1
'(logorc1 x y
))
3221 (#.sb
!xc
:boole-orc2
'(logorc2 x y
))
3223 (abort-ir1-transform "~S is an illegal control arg to BOOLE."
3226 ;;;; converting special case multiply/divide to shifts
3228 ;;; If arg is a constant power of two, turn * into a shift.
3229 (deftransform * ((x y
) (integer integer
) *)
3230 "convert x*2^k to shift"
3231 (unless (constant-lvar-p y
)
3232 (give-up-ir1-transform))
3233 (let* ((y (lvar-value y
))
3235 (len (1- (integer-length y-abs
))))
3236 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3237 (give-up-ir1-transform))
3242 ;;; These must come before the ones below, so that they are tried
3244 (deftransform floor
((number divisor
))
3245 `(multiple-value-bind (tru rem
) (truncate number divisor
)
3246 (if (and (not (zerop rem
))
3247 (if (minusp divisor
)
3250 (values (1- tru
) (+ rem divisor
))
3253 (deftransform ceiling
((number divisor
))
3254 `(multiple-value-bind (tru rem
) (truncate number divisor
)
3255 (if (and (not (zerop rem
))
3256 (if (minusp divisor
)
3259 (values (+ tru
1) (- rem divisor
))
3262 (deftransform rem
((number divisor
))
3263 `(nth-value 1 (truncate number divisor
)))
3265 (deftransform mod
((number divisor
))
3266 `(let ((rem (rem number divisor
)))
3267 (if (and (not (zerop rem
))
3268 (if (minusp divisor
)
3274 ;;; If arg is a constant power of two, turn FLOOR into a shift and
3275 ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
3277 (flet ((frob (y ceil-p
)
3278 (unless (constant-lvar-p y
)
3279 (give-up-ir1-transform))
3280 (let* ((y (lvar-value y
))
3282 (len (1- (integer-length y-abs
))))
3283 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3284 (give-up-ir1-transform))
3285 (let ((shift (- len
))
3287 (delta (if ceil-p
(* (signum y
) (1- y-abs
)) 0)))
3288 `(let ((x (+ x
,delta
)))
3290 `(values (ash (- x
) ,shift
)
3291 (- (- (logand (- x
) ,mask
)) ,delta
))
3292 `(values (ash x
,shift
)
3293 (- (logand x
,mask
) ,delta
))))))))
3294 (deftransform floor
((x y
) (integer integer
) *)
3295 "convert division by 2^k to shift"
3297 (deftransform ceiling
((x y
) (integer integer
) *)
3298 "convert division by 2^k to shift"
3301 ;;; Do the same for MOD.
3302 (deftransform mod
((x y
) (integer integer
) *)
3303 "convert remainder mod 2^k to LOGAND"
3304 (unless (constant-lvar-p y
)
3305 (give-up-ir1-transform))
3306 (let* ((y (lvar-value y
))
3308 (len (1- (integer-length y-abs
))))
3309 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3310 (give-up-ir1-transform))
3311 (let ((mask (1- y-abs
)))
3313 `(- (logand (- x
) ,mask
))
3314 `(logand x
,mask
)))))
3316 ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
3317 (deftransform truncate
((x y
) (integer integer
))
3318 "convert division by 2^k to shift"
3319 (unless (constant-lvar-p y
)
3320 (give-up-ir1-transform))
3321 (let* ((y (lvar-value y
))
3323 (len (1- (integer-length y-abs
))))
3324 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3325 (give-up-ir1-transform))
3326 (let* ((shift (- len
))
3329 (values ,(if (minusp y
)
3331 `(- (ash (- x
) ,shift
)))
3332 (- (logand (- x
) ,mask
)))
3333 (values ,(if (minusp y
)
3334 `(ash (- ,mask x
) ,shift
)
3336 (logand x
,mask
))))))
3338 ;;; And the same for REM.
3339 (deftransform rem
((x y
) (integer integer
) *)
3340 "convert remainder mod 2^k to LOGAND"
3341 (unless (constant-lvar-p y
)
3342 (give-up-ir1-transform))
3343 (let* ((y (lvar-value y
))
3345 (len (1- (integer-length y-abs
))))
3346 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3347 (give-up-ir1-transform))
3348 (let ((mask (1- y-abs
)))
3350 (- (logand (- x
) ,mask
))
3351 (logand x
,mask
)))))
3353 ;;; Return an expression to calculate the integer quotient of X and
3354 ;;; constant Y, using multiplication, shift and add/sub instead of
3355 ;;; division. Both arguments must be unsigned, fit in a machine word and
3356 ;;; Y must neither be zero nor a power of two. The quotient is rounded
3358 ;;; The algorithm is taken from the paper "Division by Invariant
3359 ;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and
3360 ;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the
3361 ;;; case of division by powers of two.
3362 ;;; The algorithm includes an adaptive precision argument. Use it, since
3363 ;;; we often have sub-word value ranges. Careful, in this case, we need
3364 ;;; p s.t 2^p > n, not the ceiling of the binary log.
3365 ;;; Also, for some reason, the paper prefers shifting to masking. Mask
3366 ;;; instead. Masking is equivalent to shifting right, then left again;
3367 ;;; all the intermediate values are still words, so we just have to shift
3368 ;;; right a bit more to compensate, at the end.
3370 ;;; The following two examples show an average case and the worst case
3371 ;;; with respect to the complexity of the generated expression, under
3372 ;;; a word size of 64 bits:
3374 ;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) ->
3375 ;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3)
3377 ;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) ->
3379 ;;; (T1 (%MULTIPLY NUM 2635249153387078803)))
3380 ;;; (ASH (LDB (BYTE 64 0)
3381 ;;; (+ T1 (ASH (LDB (BYTE 64 0)
3386 (defun gen-unsigned-div-by-constant-expr (y max-x
)
3387 (declare (type (integer 3 #.most-positive-word
) y
)
3389 (aver (not (zerop (logand y
(1- y
)))))
3391 ;; the floor of the binary logarithm of (positive) X
3392 (integer-length (1- x
)))
3393 (choose-multiplier (y precision
)
3395 (shift l
(1- shift
))
3396 (expt-2-n+l
(expt 2 (+ sb
!vm
:n-word-bits l
)))
3397 (m-low (truncate expt-2-n
+l y
) (ash m-low -
1))
3398 (m-high (truncate (+ expt-2-n
+l
3399 (ash expt-2-n
+l
(- precision
)))
3402 ((not (and (< (ash m-low -
1) (ash m-high -
1))
3404 (values m-high shift
)))))
3405 (let ((n (expt 2 sb
!vm
:n-word-bits
))
3406 (precision (integer-length max-x
))
3408 (multiple-value-bind (m shift2
)
3409 (choose-multiplier y precision
)
3410 (when (and (>= m n
) (evenp y
))
3411 (setq shift1
(ld (logand y
(- y
))))
3412 (multiple-value-setq (m shift2
)
3413 (choose-multiplier (/ y
(ash 1 shift1
))
3414 (- precision shift1
))))
3417 `(truly-the word
,x
)))
3419 (t1 (%multiply-high num
,(- m n
))))
3420 (ash ,(word `(+ t1
(ash ,(word `(- num t1
))
3423 ((and (zerop shift1
) (zerop shift2
))
3424 (let ((max (truncate max-x y
)))
3425 ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM
3427 `(truly-the (integer 0 ,max
)
3428 (%multiply-high x
,m
))))
3430 `(ash (%multiply-high
(logandc2 x
,(1- (ash 1 shift1
))) ,m
)
3431 ,(- (+ shift1 shift2
)))))))))
3433 ;;; If the divisor is constant and both args are positive and fit in a
3434 ;;; machine word, replace the division by a multiplication and possibly
3435 ;;; some shifts and an addition. Calculate the remainder by a second
3436 ;;; multiplication and a subtraction. Dead code elimination will
3437 ;;; suppress the latter part if only the quotient is needed. If the type
3438 ;;; of the dividend allows to derive that the quotient will always have
3439 ;;; the same value, emit much simpler code to handle that. (This case
3440 ;;; may be rare but it's easy to detect and the compiler doesn't find
3441 ;;; this optimization on its own.)
3442 (deftransform truncate
((x y
) (word (constant-arg word
))
3444 :policy
(and (> speed compilation-speed
)
3446 "convert integer division to multiplication"
3447 (let* ((y (lvar-value y
))
3448 (x-type (lvar-type x
))
3449 (max-x (or (and (numeric-type-p x-type
)
3450 (numeric-type-high x-type
))
3451 most-positive-word
)))
3452 ;; Division by zero, one or powers of two is handled elsewhere.
3453 (when (zerop (logand y
(1- y
)))
3454 (give-up-ir1-transform))
3455 `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x
))
3456 (rem (ldb (byte #.sb
!vm
:n-word-bits
0)
3457 (- x
(* quot
,y
)))))
3458 (values quot rem
))))
3460 ;;;; arithmetic and logical identity operation elimination
3462 ;;; Flush calls to various arith functions that convert to the
3463 ;;; identity function or a constant.
3464 (macrolet ((def (name identity result
)
3465 `(deftransform ,name
((x y
) (* (constant-arg (member ,identity
))) *)
3466 "fold identity operations"
3473 (def logxor -
1 (lognot x
))
3476 (defun least-zero-bit (x)
3478 (1- (integer-length (logxor x
(1+ x
))))))
3480 (deftransform logand
((x y
) (* (constant-arg t
)) *)
3481 "fold identity operation"
3482 (let* ((y (lvar-value y
))
3483 (width (or (least-zero-bit y
) '*)))
3484 (unless (and (neq width
0) ; (logand x 0) handled elsewhere
3485 (csubtypep (lvar-type x
)
3486 (specifier-type `(unsigned-byte ,width
))))
3487 (give-up-ir1-transform))
3490 (deftransform mask-signed-field
((size x
) ((constant-arg t
) *) *)
3491 "fold identity operation"
3492 (let ((size (lvar-value size
)))
3493 (unless (csubtypep (lvar-type x
) (specifier-type `(signed-byte ,size
)))
3494 (give-up-ir1-transform))
3497 (deftransform logior
((x y
) (* (constant-arg t
)) *)
3498 "fold identity operation"
3499 (let* ((y (lvar-value y
))
3500 (width (or (least-zero-bit (lognot y
))
3501 (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
3502 (unless (csubtypep (lvar-type x
)
3503 (specifier-type `(integer ,(- (ash 1 width
)) -
1)))
3504 (give-up-ir1-transform))
3507 ;;; Pick off easy association opportunities for constant folding.
3508 ;;; More complicated stuff that also depends on commutativity
3509 ;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
3510 ;;; probably be handled with a more general tree-rewriting pass.
3511 (macrolet ((def (operator &key
(type 'integer
) (folded operator
))
3512 `(deftransform ,operator
((x z
) (,type
(constant-arg ,type
)))
3513 ,(format nil
"associate ~A/~A of constants"
3515 (binding* ((node (if (lvar-has-single-use-p x
)
3517 (give-up-ir1-transform)))
3518 (nil (or (and (combination-p node
)
3520 (combination-fun node
))
3522 (give-up-ir1-transform)))
3523 (y (second (combination-args node
)))
3524 (nil (or (constant-lvar-p y
)
3525 (give-up-ir1-transform)))
3527 (unless (typep y
',type
)
3528 (give-up-ir1-transform))
3529 (splice-fun-args x
',folded
2)
3531 (declare (ignore y z
))
3532 ;; (operator (folded x y) z)
3533 ;; == (operator x (folded z y))
3534 (,',operator x
',(,folded
(lvar-value z
) y
)))))))
3538 (def logtest
:folded logand
)
3539 (def + :type rational
)
3540 (def + :type rational
:folded -
)
3541 (def * :type rational
)
3542 (def * :type rational
:folded
/))
3544 (deftransform mask-signed-field
((width x
) ((constant-arg unsigned-byte
) *))
3545 "Fold mask-signed-field/mask-signed-field of constant width"
3546 (binding* ((node (if (lvar-has-single-use-p x
)
3548 (give-up-ir1-transform)))
3549 (nil (or (combination-p node
)
3550 (give-up-ir1-transform)))
3551 (nil (or (eq (lvar-fun-name (combination-fun node
))
3553 (give-up-ir1-transform)))
3554 (x-width (first (combination-args node
)))
3555 (nil (or (constant-lvar-p x-width
)
3556 (give-up-ir1-transform)))
3557 (x-width (lvar-value x-width
)))
3558 (unless (typep x-width
'unsigned-byte
)
3559 (give-up-ir1-transform))
3560 (splice-fun-args x
'mask-signed-field
2)
3561 `(lambda (width x-width x
)
3562 (declare (ignore width x-width
))
3563 (mask-signed-field ,(min (lvar-value width
) x-width
) x
))))
3565 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
3566 ;;; (* 0 -4.0) is -0.0.
3567 (deftransform -
((x y
) ((constant-arg (member 0)) rational
) *)
3568 "convert (- 0 x) to negate"
3570 (deftransform * ((x y
) (rational (constant-arg (member 0))) *)
3571 "convert (* x 0) to 0"
3574 (deftransform %negate
((x) (rational))
3575 "Eliminate %negate/%negate of rationals"
3576 (splice-fun-args x
'%negate
1)
3579 (deftransform %negate
((x) (number))
3581 (let ((use (lvar-uses x
))
3583 (unless (and (combination-p use
)
3584 (eql '* (lvar-fun-name (combination-fun use
)))
3585 (constant-lvar-p (setf arg
(second (combination-args use
))))
3586 (numberp (setf arg
(lvar-value arg
))))
3587 (give-up-ir1-transform))
3588 (splice-fun-args x
'* 2)
3590 (declare (ignore y
))
3593 ;;; Return T if in an arithmetic op including lvars X and Y, the
3594 ;;; result type is not affected by the type of X. That is, Y is at
3595 ;;; least as contagious as X.
3597 (defun not-more-contagious (x y
)
3598 (declare (type continuation x y
))
3599 (let ((x (lvar-type x
))
3601 (values (type= (numeric-contagion x y
)
3602 (numeric-contagion y y
)))))
3603 ;;; Patched version by Raymond Toy. dtc: Should be safer although it
3604 ;;; XXX needs more work as valid transforms are missed; some cases are
3605 ;;; specific to particular transform functions so the use of this
3606 ;;; function may need a re-think.
3607 (defun not-more-contagious (x y
)
3608 (declare (type lvar x y
))
3609 (flet ((simple-numeric-type (num)
3610 (and (numeric-type-p num
)
3611 ;; Return non-NIL if NUM is integer, rational, or a float
3612 ;; of some type (but not FLOAT)
3613 (case (numeric-type-class num
)
3617 (numeric-type-format num
))
3620 (let ((x (lvar-type x
))
3622 (if (and (simple-numeric-type x
)
3623 (simple-numeric-type y
))
3624 (values (type= (numeric-contagion x y
)
3625 (numeric-contagion y y
)))))))
3627 (def!type exact-number
()
3628 '(or rational
(complex rational
)))
3632 ;;; Only safely applicable for exact numbers. For floating-point
3633 ;;; x, one would have to first show that neither x or y are signed
3634 ;;; 0s, and that x isn't an SNaN.
3635 (deftransform + ((x y
) (exact-number (constant-arg (eql 0))) *)
3640 (deftransform -
((x y
) (exact-number (constant-arg (eql 0))) *)
3644 ;;; Fold (OP x +/-1)
3646 ;;; %NEGATE might not always signal correctly.
3648 ((def (name result minus-result
)
3649 `(deftransform ,name
((x y
)
3650 (exact-number (constant-arg (member 1 -
1))))
3651 "fold identity operations"
3652 (if (minusp (lvar-value y
)) ',minus-result
',result
))))
3653 (def * x
(%negate x
))
3654 (def / x
(%negate x
))
3655 (def expt x
(/ 1 x
)))
3657 ;;; Fold (expt x n) into multiplications for small integral values of
3658 ;;; N; convert (expt x 1/2) to sqrt.
3659 (deftransform expt
((x y
) (t (constant-arg real
)) *)
3660 "recode as multiplication or sqrt"
3661 (let ((val (lvar-value y
)))
3662 ;; If Y would cause the result to be promoted to the same type as
3663 ;; Y, we give up. If not, then the result will be the same type
3664 ;; as X, so we can replace the exponentiation with simple
3665 ;; multiplication and division for small integral powers.
3666 (unless (not-more-contagious y x
)
3667 (give-up-ir1-transform))
3669 (let ((x-type (lvar-type x
)))
3670 (cond ((csubtypep x-type
(specifier-type '(or rational
3671 (complex rational
))))
3673 ((csubtypep x-type
(specifier-type 'real
))
3677 ((csubtypep x-type
(specifier-type 'complex
))
3678 ;; both parts are float
3680 (t (give-up-ir1-transform)))))
3681 ((= val
2) '(* x x
))
3682 ((= val -
2) '(/ (* x x
)))
3683 ((= val
3) '(* x x x
))
3684 ((= val -
3) '(/ (* x x x
)))
3685 ((= val
1/2) '(sqrt x
))
3686 ((= val -
1/2) '(/ (sqrt x
)))
3687 (t (give-up-ir1-transform)))))
3689 (deftransform expt
((x y
) ((constant-arg (member -
1 -
1.0 -
1.0d0
)) integer
) *)
3690 "recode as an ODDP check"
3691 (let ((val (lvar-value x
)))
3693 '(- 1 (* 2 (logand 1 y
)))
3698 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
3699 ;;; transformations?
3700 ;;; Perhaps we should have to prove that the denominator is nonzero before
3701 ;;; doing them? -- WHN 19990917
3702 (macrolet ((def (name)
3703 `(deftransform ,name
((x y
) ((constant-arg (integer 0 0)) integer
)
3710 (macrolet ((def (name)
3711 `(deftransform ,name
((x y
) ((constant-arg (integer 0 0)) integer
)
3720 (macrolet ((def (name &optional float
)
3721 (let ((x (if float
'(float x
) 'x
)))
3722 `(deftransform ,name
((x y
) (integer (constant-arg (member 1 -
1)))
3724 "fold division by 1"
3725 `(values ,(if (minusp (lvar-value y
))
3738 ;;;; character operations
3740 (deftransform two-arg-char-equal
((a b
) (base-char base-char
) *
3741 :policy
(> speed space
))
3743 '(let* ((ac (char-code a
))
3745 (sum (logxor ac bc
)))
3747 (when (eql sum
#x20
)
3748 (let ((sum (+ ac bc
)))
3749 (or (and (> sum
161) (< sum
213))
3750 (and (> sum
415) (< sum
461))
3751 (and (> sum
463) (< sum
477))))))))
3753 (deftransform two-arg-char-equal
((a b
) (* (constant-arg character
)) *
3755 (let ((char (lvar-value b
)))
3756 (if (both-case-p char
)
3757 (let ((reverse (if (upper-case-p char
)
3758 (char-downcase char
)
3759 (char-upcase char
))))
3760 (if (policy node
(> speed space
))
3761 `(or (char= a
,char
)
3763 `(char-equal-constant a
,char
,reverse
)))
3766 (deftransform char-upcase
((x) (base-char))
3768 '(let ((n-code (char-code x
)))
3769 (if (or (and (> n-code
#o140
) ; Octal 141 is #\a.
3770 (< n-code
#o173
)) ; Octal 172 is #\z.
3771 (and (> n-code
#o337
)
3773 (and (> n-code
#o367
)
3775 (code-char (logxor #x20 n-code
))
3778 (deftransform char-downcase
((x) (base-char))
3780 '(let ((n-code (char-code x
)))
3781 (if (or (and (> n-code
64) ; 65 is #\A.
3782 (< n-code
91)) ; 90 is #\Z.
3787 (code-char (logxor #x20 n-code
))
3790 ;;;; equality predicate transforms
3792 ;;; Return true if X and Y are lvars whose only use is a
3793 ;;; reference to the same leaf, and the value of the leaf cannot
3795 (defun same-leaf-ref-p (x y
)
3796 (declare (type lvar x y
))
3797 (let ((x-use (principal-lvar-use x
))
3798 (y-use (principal-lvar-use y
)))
3801 (eq (ref-leaf x-use
) (ref-leaf y-use
))
3802 (constant-reference-p x-use
))))
3804 ;;; If X and Y are the same leaf, then the result is true. Otherwise,
3805 ;;; if there is no intersection between the types of the arguments,
3806 ;;; then the result is definitely false.
3807 (deftransform simple-equality-transform
((x y
) * *
3810 ((same-leaf-ref-p x y
) t
)
3811 ((not (types-equal-or-intersect (lvar-type x
) (lvar-type y
)))
3813 (t (give-up-ir1-transform))))
3816 `(%deftransform
',x
'(function * *) #'simple-equality-transform
)))
3819 (def two-arg-char-equal
))
3821 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
3822 ;;; try to convert to a type-specific predicate or EQ:
3823 ;;; -- If both args are characters, convert to CHAR=. This is better than
3824 ;;; just converting to EQ, since CHAR= may have special compilation
3825 ;;; strategies for non-standard representations, etc.
3826 ;;; -- If either arg is definitely a fixnum, we check to see if X is
3827 ;;; constant and if so, put X second. Doing this results in better
3828 ;;; code from the backend, since the backend assumes that any constant
3829 ;;; argument comes second.
3830 ;;; -- If either arg is definitely not a number or a fixnum, then we
3831 ;;; can compare with EQ.
3832 ;;; -- Otherwise, we try to put the arg we know more about second. If X
3833 ;;; is constant then we put it second. If X is a subtype of Y, we put
3834 ;;; it second. These rules make it easier for the back end to match
3835 ;;; these interesting cases.
3836 (deftransform eql
((x y
) * * :node node
)
3837 "convert to simpler equality predicate"
3838 (let ((x-type (lvar-type x
))
3839 (y-type (lvar-type y
))
3840 (char-type (specifier-type 'character
)))
3842 ((same-leaf-ref-p x y
) t
)
3843 ((not (types-equal-or-intersect x-type y-type
))
3845 ((and (csubtypep x-type char-type
)
3846 (csubtypep y-type char-type
))
3848 ((or (eq-comparable-type-p x-type
) (eq-comparable-type-p y-type
))
3851 (give-up-ir1-transform)))))
3853 ;;; similarly to the EQL transform above, we attempt to constant-fold
3854 ;;; or convert to a simpler predicate: mostly we have to be careful
3855 ;;; with strings and bit-vectors.
3856 (deftransform equal
((x y
) * *)
3857 "convert to simpler equality predicate"
3858 (let ((x-type (lvar-type x
))
3859 (y-type (lvar-type y
))
3860 (combination-type (specifier-type '(or bit-vector string
3862 (flet ((both-csubtypep (type)
3863 (let ((ctype (specifier-type type
)))
3864 (and (csubtypep x-type ctype
)
3865 (csubtypep y-type ctype
)))))
3867 ((same-leaf-ref-p x y
) t
)
3868 ((and (constant-lvar-p x
)
3869 (equal (lvar-value x
) ""))
3871 (zerop (length y
))))
3872 ((and (constant-lvar-p y
)
3873 (equal (lvar-value y
) ""))
3875 (zerop (length x
))))
3876 ((both-csubtypep 'string
)
3878 ((both-csubtypep 'bit-vector
)
3879 '(bit-vector-= x y
))
3880 ((both-csubtypep 'pathname
)
3882 ((or (not (types-equal-or-intersect x-type combination-type
))
3883 (not (types-equal-or-intersect y-type combination-type
)))
3884 (if (types-equal-or-intersect x-type y-type
)
3886 ;; Can't simply check for type intersection if both types are combination-type
3887 ;; since array specialization would mean types don't intersect, even when EQUAL
3888 ;; doesn't care for specialization.
3889 ;; Previously checking for intersection in the outer COND resulted in
3891 ;; (equal (the (cons (or simple-bit-vector
3892 ;; simple-base-string))
3894 ;; (the (cons (or (and bit-vector (not simple-array))
3895 ;; (simple-array character (*))))
3897 ;; being incorrectly folded to NIL
3899 (t (give-up-ir1-transform))))))
3901 (deftransform equalp
((x y
) * *)
3902 "convert to simpler equality predicate"
3903 (let ((x-type (lvar-type x
))
3904 (y-type (lvar-type y
))
3905 (combination-type (specifier-type '(or number array
3908 instance hash-table
))))
3909 (flet ((both-csubtypep (type)
3910 (let ((ctype (specifier-type type
)))
3911 (and (csubtypep x-type ctype
)
3912 (csubtypep y-type ctype
)))))
3914 ((same-leaf-ref-p x y
) t
)
3915 ((and (constant-lvar-p x
)
3916 (equal (lvar-value x
) ""))
3918 (zerop (length y
))))
3919 ((and (constant-lvar-p y
)
3920 (equal (lvar-value y
) ""))
3922 (zerop (length x
))))
3923 ((both-csubtypep 'string
)
3924 '(string-equal x y
))
3925 ((both-csubtypep 'bit-vector
)
3926 '(bit-vector-= x y
))
3927 ((both-csubtypep 'pathname
)
3929 ((both-csubtypep 'character
)
3931 ((both-csubtypep 'number
)
3933 ((both-csubtypep 'hash-table
)
3934 '(hash-table-equalp x y
))
3935 ((or (not (types-equal-or-intersect x-type combination-type
))
3936 (not (types-equal-or-intersect y-type combination-type
)))
3937 ;; See the comment about specialized types in the EQUAL transform above
3938 (if (types-equal-or-intersect y-type x-type
)
3941 (t (give-up-ir1-transform))))))
3943 ;;; Convert to EQL if both args are rational and complexp is specified
3944 ;;; and the same for both.
3945 (deftransform = ((x y
) (number number
) *)
3947 (let ((x-type (lvar-type x
))
3948 (y-type (lvar-type y
)))
3949 (cond ((or (and (csubtypep x-type
(specifier-type 'float
))
3950 (csubtypep y-type
(specifier-type 'float
)))
3951 (and (csubtypep x-type
(specifier-type '(complex float
)))
3952 (csubtypep y-type
(specifier-type '(complex float
))))
3953 #!+complex-float-vops
3954 (and (csubtypep x-type
(specifier-type '(or single-float
(complex single-float
))))
3955 (csubtypep y-type
(specifier-type '(or single-float
(complex single-float
)))))
3956 #!+complex-float-vops
3957 (and (csubtypep x-type
(specifier-type '(or double-float
(complex double-float
))))
3958 (csubtypep y-type
(specifier-type '(or double-float
(complex double-float
))))))
3959 ;; They are both floats. Leave as = so that -0.0 is
3960 ;; handled correctly.
3961 (give-up-ir1-transform))
3962 ((or (and (csubtypep x-type
(specifier-type 'rational
))
3963 (csubtypep y-type
(specifier-type 'rational
)))
3964 (and (csubtypep x-type
3965 (specifier-type '(complex rational
)))
3967 (specifier-type '(complex rational
)))))
3968 ;; They are both rationals and complexp is the same.
3972 (give-up-ir1-transform
3973 "The operands might not be the same type.")))))
3975 (defun maybe-float-lvar-p (lvar)
3976 (neq *empty-type
* (type-intersection (specifier-type 'float
)
3979 (flet ((maybe-invert (node op inverted x y
)
3980 ;; Don't invert if either argument can be a float (NaNs)
3982 ((or (maybe-float-lvar-p x
) (maybe-float-lvar-p y
))
3983 (delay-ir1-transform node
:constraint
)
3984 `(or (,op x y
) (= x y
)))
3986 `(if (,inverted x y
) nil t
)))))
3987 (deftransform >= ((x y
) (number number
) * :node node
)
3988 "invert or open code"
3989 (maybe-invert node
'> '< x y
))
3990 (deftransform <= ((x y
) (number number
) * :node node
)
3991 "invert or open code"
3992 (maybe-invert node
'< '> x y
)))
3994 ;;; See whether we can statically determine (< X Y) using type
3995 ;;; information. If X's high bound is < Y's low, then X < Y.
3996 ;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
3997 ;;; NIL). If not, at least make sure any constant arg is second.
3998 (macrolet ((def (name inverse reflexive-p surely-true surely-false
)
3999 `(deftransform ,name
((x y
))
4000 "optimize using intervals"
4001 (if (and (same-leaf-ref-p x y
)
4002 ;; For non-reflexive functions we don't need
4003 ;; to worry about NaNs: (non-ref-op NaN NaN) => false,
4004 ;; but with reflexive ones we don't know...
4006 '((and (not (maybe-float-lvar-p x
))
4007 (not (maybe-float-lvar-p y
))))))
4009 (let ((ix (or (type-approximate-interval (lvar-type x
))
4010 (give-up-ir1-transform)))
4011 (iy (or (type-approximate-interval (lvar-type y
))
4012 (give-up-ir1-transform))))
4017 ((and (constant-lvar-p x
)
4018 (not (constant-lvar-p y
)))
4021 (give-up-ir1-transform))))))))
4022 (def = = t
(interval-= ix iy
) (interval-/= ix iy
))
4023 (def /= /= nil
(interval-/= ix iy
) (interval-= ix iy
))
4024 (def < > nil
(interval-< ix iy
) (interval->= ix iy
))
4025 (def > < nil
(interval-< iy ix
) (interval->= iy ix
))
4026 (def <= >= t
(interval->= iy ix
) (interval-< iy ix
))
4027 (def >= <= t
(interval->= ix iy
) (interval-< ix iy
)))
4029 (defun ir1-transform-char< (x y first second inverse
)
4031 ((same-leaf-ref-p x y
) nil
)
4032 ;; If we had interval representation of character types, as we
4033 ;; might eventually have to to support 2^21 characters, then here
4034 ;; we could do some compile-time computation as in transforms for
4035 ;; < above. -- CSR, 2003-07-01
4036 ((and (constant-lvar-p first
)
4037 (not (constant-lvar-p second
)))
4039 (t (give-up-ir1-transform))))
4041 (deftransform char
< ((x y
) (character character
) *)
4042 (ir1-transform-char< x y x y
'char
>))
4044 (deftransform char
> ((x y
) (character character
) *)
4045 (ir1-transform-char< y x x y
'char
<))
4047 ;;;; converting N-arg comparisons
4049 ;;;; We convert calls to N-arg comparison functions such as < into
4050 ;;;; two-arg calls. This transformation is enabled for all such
4051 ;;;; comparisons in this file. If any of these predicates are not
4052 ;;;; open-coded, then the transformation should be removed at some
4053 ;;;; point to avoid pessimization.
4055 ;;; This function is used for source transformation of N-arg
4056 ;;; comparison functions other than inequality. We deal both with
4057 ;;; converting to two-arg calls and inverting the sense of the test,
4058 ;;; if necessary. If the call has two args, then we pass or return a
4059 ;;; negated test as appropriate. If it is a degenerate one-arg call,
4060 ;;; then we transform to code that returns true. Otherwise, we bind
4061 ;;; all the arguments and expand into a bunch of IFs.
4062 (defun multi-compare (predicate args not-p type
&optional force-two-arg-p
)
4063 (let ((nargs (length args
)))
4064 (cond ((< nargs
1) (values nil t
))
4065 ((= nargs
1) `(progn (the ,type
,@args
) t
))
4068 `(if (,predicate
,(first args
) ,(second args
)) nil t
)
4070 `(,predicate
,(first args
) ,(second args
))
4073 (do* ((i (1- nargs
) (1- i
))
4075 (current (gensym) (gensym))
4076 (vars (list current
) (cons current vars
))
4078 `(if (,predicate
,current
,last
)
4080 `(if (,predicate
,current
,last
)
4083 `((lambda ,vars
(declare (type ,type
,@vars
)) ,result
)
4086 (define-source-transform = (&rest args
) (multi-compare '= args nil
'number
))
4087 (define-source-transform < (&rest args
) (multi-compare '< args nil
'real
))
4088 (define-source-transform > (&rest args
) (multi-compare '> args nil
'real
))
4089 ;;; We cannot do the inversion for >= and <= here, since both
4090 ;;; (< NaN X) and (> NaN X)
4091 ;;; are false, and we don't have type-information available yet. The
4092 ;;; deftransforms for two-argument versions of >= and <= takes care of
4093 ;;; the inversion to > and < when possible.
4094 (define-source-transform <= (&rest args
) (multi-compare '<= args nil
'real
))
4095 (define-source-transform >= (&rest args
) (multi-compare '>= args nil
'real
))
4097 (define-source-transform char
= (&rest args
) (multi-compare 'char
= args nil
4099 (define-source-transform char
< (&rest args
) (multi-compare 'char
< args nil
4101 (define-source-transform char
> (&rest args
) (multi-compare 'char
> args nil
4103 (define-source-transform char
<= (&rest args
) (multi-compare 'char
> args t
4105 (define-source-transform char
>= (&rest args
) (multi-compare 'char
< args t
4108 (define-source-transform char-equal
(&rest args
)
4109 (multi-compare 'two-arg-char-equal args nil
'character t
))
4110 (define-source-transform char-lessp
(&rest args
)
4111 (multi-compare 'two-arg-char-lessp args nil
'character t
))
4112 (define-source-transform char-greaterp
(&rest args
)
4113 (multi-compare 'two-arg-char-greaterp args nil
'character t
))
4114 (define-source-transform char-not-greaterp
(&rest args
)
4115 (multi-compare 'two-arg-char-greaterp args t
'character t
))
4116 (define-source-transform char-not-lessp
(&rest args
)
4117 (multi-compare 'two-arg-char-lessp args t
'character t
))
4119 ;;; This function does source transformation of N-arg inequality
4120 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
4121 ;;; arg cases. If there are more than two args, then we expand into
4122 ;;; the appropriate n^2 comparisons only when speed is important.
4123 (declaim (ftype (function (symbol list t
) *) multi-not-equal
))
4124 (defun multi-not-equal (predicate args type
)
4125 (let ((nargs (length args
)))
4126 (cond ((< nargs
1) (values nil t
))
4127 ((= nargs
1) `(progn (the ,type
,@args
) t
))
4129 `(if (,predicate
,(first args
) ,(second args
)) nil t
))
4130 ((not (policy *lexenv
*
4131 (and (>= speed space
)
4132 (>= speed compilation-speed
))))
4135 (let ((vars (make-gensym-list nargs
)))
4136 (do ((var vars next
)
4137 (next (cdr vars
) (cdr next
))
4140 `((lambda ,vars
(declare (type ,type
,@vars
)) ,result
)
4142 (let ((v1 (first var
)))
4144 (setq result
`(if (,predicate
,v1
,v2
) nil
,result
))))))))))
4146 (define-source-transform /= (&rest args
)
4147 (multi-not-equal '= args
'number
))
4148 (define-source-transform char
/= (&rest args
)
4149 (multi-not-equal 'char
= args
'character
))
4150 (define-source-transform char-not-equal
(&rest args
)
4151 (multi-not-equal 'char-equal args
'character
))
4153 ;;; Expand MAX and MIN into the obvious comparisons.
4154 (define-source-transform max
(arg0 &rest rest
)
4155 (once-only ((arg0 arg0
))
4157 `(values (the real
,arg0
))
4158 `(let ((maxrest (max ,@rest
)))
4159 (if (>= ,arg0 maxrest
) ,arg0 maxrest
)))))
4160 (define-source-transform min
(arg0 &rest rest
)
4161 (once-only ((arg0 arg0
))
4163 `(values (the real
,arg0
))
4164 `(let ((minrest (min ,@rest
)))
4165 (if (<= ,arg0 minrest
) ,arg0 minrest
)))))
4167 ;;; Simplify some cross-type comparisons
4168 (macrolet ((def (comparator round
)
4170 (deftransform ,comparator
4171 ((x y
) (rational (constant-arg float
)))
4172 "open-code RATIONAL to FLOAT comparison"
4173 (let ((y (lvar-value y
)))
4175 (when (or (float-nan-p y
)
4176 (float-infinity-p y
))
4177 (give-up-ir1-transform))
4178 (setf y
(rational y
))
4180 x
,(if (csubtypep (lvar-type x
)
4181 (specifier-type 'integer
))
4184 (deftransform ,comparator
4185 ((x y
) (integer (constant-arg ratio
)))
4186 "open-code INTEGER to RATIO comparison"
4187 `(,',comparator x
,(,round
(lvar-value y
)))))))
4191 (deftransform = ((x y
) (rational (constant-arg float
)))
4192 "open-code RATIONAL to FLOAT comparison"
4193 (let ((y (lvar-value y
)))
4195 (when (or (float-nan-p y
)
4196 (float-infinity-p y
))
4197 (give-up-ir1-transform))
4198 (setf y
(rational y
))
4199 (if (and (csubtypep (lvar-type x
)
4200 (specifier-type 'integer
))
4205 (deftransform = ((x y
) (integer (constant-arg ratio
)))
4206 "constant-fold INTEGER to RATIO comparison"
4209 ;;;; converting N-arg arithmetic functions
4211 ;;;; N-arg arithmetic and logic functions are associated into two-arg
4212 ;;;; versions, and degenerate cases are flushed.
4214 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
4215 (declaim (ftype (sfunction (symbol t list t
) list
) associate-args
))
4216 (defun associate-args (fun first-arg more-args identity
)
4217 (let ((next (rest more-args
))
4218 (arg (first more-args
)))
4220 `(,fun
,first-arg
,(if arg arg identity
))
4221 (associate-args fun
`(,fun
,first-arg
,arg
) next identity
))))
4223 ;;; Reduce constants in ARGS list.
4224 (declaim (ftype (sfunction (symbol list symbol
) list
) reduce-constants
))
4225 (defun reduce-constants (fun args one-arg-result-type
)
4226 (let ((one-arg-constant-p (ecase one-arg-result-type
4228 (integer #'integerp
)))
4231 (collect ((not-constants))
4233 (let ((value (if (constantp arg
)
4234 (constant-form-value arg
)
4236 (cond ((not (funcall one-arg-constant-p value
))
4237 (not-constants arg
))
4239 (setf reduced-value
(funcall fun reduced-value value
)
4242 (setf reduced-value value
)))))
4243 ;; It is tempting to drop constants reduced to identity here,
4244 ;; but if X is SNaN in (* X 1), we cannot drop the 1.
4247 `(,reduced-value
,@(not-constants))
4249 `(,reduced-value
)))))
4251 ;;; Do source transformations for transitive functions such as +.
4252 ;;; One-arg cases are replaced with the arg and zero arg cases with
4253 ;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE)
4254 ;;; that the argument in one-argument calls is.
4255 (declaim (ftype (function (symbol list t
&optional symbol list
)
4256 (values t
&optional
(member nil t
)))
4257 source-transform-transitive
))
4258 (defun source-transform-transitive (fun args identity
4259 &optional
(one-arg-result-type 'number
)
4260 (one-arg-prefixes '(values)))
4263 (1 `(,@one-arg-prefixes
(the ,one-arg-result-type
,(first args
))))
4266 (let ((reduced-args (reduce-constants fun args one-arg-result-type
)))
4267 (associate-args fun
(first reduced-args
) (rest reduced-args
) identity
)))))
4269 (define-source-transform + (&rest args
)
4270 (source-transform-transitive '+ args
0))
4271 (define-source-transform * (&rest args
)
4272 (source-transform-transitive '* args
1))
4273 (define-source-transform logior
(&rest args
)
4274 (source-transform-transitive 'logior args
0 'integer
))
4275 (define-source-transform logxor
(&rest args
)
4276 (source-transform-transitive 'logxor args
0 'integer
))
4277 (define-source-transform logand
(&rest args
)
4278 (source-transform-transitive 'logand args -
1 'integer
))
4279 (define-source-transform logeqv
(&rest args
)
4280 (source-transform-transitive 'logeqv args -
1 'integer
))
4281 (define-source-transform gcd
(&rest args
)
4282 (source-transform-transitive 'gcd args
0 'integer
'(abs)))
4283 (define-source-transform lcm
(&rest args
)
4284 (source-transform-transitive 'lcm args
1 'integer
'(abs)))
4286 ;;; Do source transformations for intransitive n-arg functions such as
4287 ;;; /. With one arg, we form the inverse. With two args we pass.
4288 ;;; Otherwise we associate into two-arg calls.
4289 (declaim (ftype (function (symbol symbol list t list
&optional symbol
)
4290 (values list
&optional
(member nil t
)))
4291 source-transform-intransitive
))
4292 (defun source-transform-intransitive (fun fun
* args identity one-arg-prefixes
4293 &optional
(one-arg-result-type 'number
))
4295 ((0 2) (values nil t
))
4296 (1 `(,@one-arg-prefixes
(the ,one-arg-result-type
,(first args
))))
4299 (reduce-constants fun
* (rest args
) one-arg-result-type
)))
4300 (associate-args fun
(first args
) reduced-args identity
)))))
4302 (define-source-transform -
(&rest args
)
4303 (source-transform-intransitive '-
'+ args
0 '(%negate
)))
4304 (define-source-transform / (&rest args
)
4305 (source-transform-intransitive '/ '* args
1 '(/ 1)))
4307 ;;;; transforming APPLY
4309 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
4310 ;;; only needs to understand one kind of variable-argument call. It is
4311 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
4312 (define-source-transform apply
(fun arg
&rest more-args
)
4313 (let ((args (cons arg more-args
)))
4314 `(multiple-value-call ,fun
4315 ,@(mapcar (lambda (x) `(values ,x
)) (butlast args
))
4316 (values-list ,(car (last args
))))))
4318 ;;;; transforming references to &REST argument
4320 ;;; We add magical &MORE arguments to all functions with &REST. If ARG names
4321 ;;; the &REST argument, this returns the lambda-vars for the context and
4323 (defun possible-rest-arg-context (arg)
4325 (let* ((var (lexenv-find arg vars
))
4326 (info (when (lambda-var-p var
)
4327 (lambda-var-arg-info var
))))
4329 (eq :rest
(arg-info-kind info
))
4330 (consp (arg-info-default info
)))
4331 (values-list (arg-info-default info
))))))
4333 (defun mark-more-context-used (rest-var)
4334 (let ((info (lambda-var-arg-info rest-var
)))
4335 (aver (eq :rest
(arg-info-kind info
)))
4336 (destructuring-bind (context count
&optional used
) (arg-info-default info
)
4338 (setf (arg-info-default info
) (list context count t
))))))
4340 (defun mark-more-context-invalid (rest-var)
4341 (let ((info (lambda-var-arg-info rest-var
)))
4342 (aver (eq :rest
(arg-info-kind info
)))
4343 (setf (arg-info-default info
) t
)))
4345 ;;; This determines of we the REF to a &REST variable is headed towards
4346 ;;; parts unknown, or if we can really use the context.
4347 (defun rest-var-more-context-ok (lvar)
4348 (let* ((use (lvar-use lvar
))
4349 (var (when (ref-p use
) (ref-leaf use
)))
4350 (home (when (lambda-var-p var
) (lambda-var-home var
)))
4351 (info (when (lambda-var-p var
) (lambda-var-arg-info var
)))
4352 (restp (when info
(eq :rest
(arg-info-kind info
)))))
4353 (flet ((ref-good-for-more-context-p (ref)
4354 (when (not (node-lvar ref
)) ; ref that goes nowhere is ok
4355 (return-from ref-good-for-more-context-p t
))
4356 (let ((dest (principal-lvar-end (node-lvar ref
))))
4357 (and (combination-p dest
)
4358 ;; If the destination is to anything but these, we're going to
4359 ;; actually need the rest list -- and since other operations
4360 ;; might modify the list destructively, the using the context
4361 ;; isn't good anywhere else either.
4362 (lvar-fun-is (combination-fun dest
)
4363 '(%rest-values %rest-ref %rest-length
4364 %rest-null %rest-true
))
4365 ;; If the home lambda is different and isn't DX, it might
4366 ;; escape -- in which case using the more context isn't safe.
4367 (let ((clambda (node-home-lambda dest
)))
4368 (or (eq home clambda
)
4369 (leaf-dynamic-extent clambda
)))))))
4370 (let ((ok (and restp
4371 (consp (arg-info-default info
))
4372 (not (lambda-var-specvar var
))
4373 (not (lambda-var-sets var
))
4374 (every #'ref-good-for-more-context-p
(lambda-var-refs var
)))))
4376 (mark-more-context-used var
)
4378 (mark-more-context-invalid var
)))
4381 ;;; VALUES-LIST -> %REST-VALUES
4382 (define-source-transform values-list
(list)
4383 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4385 `(%rest-values
,list
,context
,count
)
4388 ;;; NTH -> %REST-REF
4389 (define-source-transform nth
(n list
)
4390 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4392 `(%rest-ref
,n
,list
,context
,count
)
4393 `(car (nthcdr ,n
,list
)))))
4394 (define-source-transform fast-
&rest-nth
(n list
)
4395 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4397 `(%rest-ref
,n
,list
,context
,count t
)
4398 (bug "no &REST context for FAST-REST-NTH"))))
4400 (define-source-transform elt
(seq n
)
4401 (if (policy *lexenv
* (= safety
3))
4403 (multiple-value-bind (context count
) (possible-rest-arg-context seq
)
4405 `(%rest-ref
,n
,seq
,context
,count
)
4408 ;;; CAxR -> %REST-REF
4409 (defun source-transform-car (list nth
)
4410 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4412 `(%rest-ref
,nth
,list
,context
,count
)
4415 (define-source-transform car
(list)
4416 (source-transform-car list
0))
4418 (define-source-transform cadr
(list)
4419 (or (source-transform-car list
1)
4420 `(car (cdr ,list
))))
4422 (define-source-transform caddr
(list)
4423 (or (source-transform-car list
2)
4424 `(car (cdr (cdr ,list
)))))
4426 (define-source-transform cadddr
(list)
4427 (or (source-transform-car list
3)
4428 `(car (cdr (cdr (cdr ,list
))))))
4430 ;;; LENGTH -> %REST-LENGTH
4431 (defun source-transform-length (list)
4432 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4434 `(%rest-length
,list
,context
,count
)
4436 (define-source-transform length
(list) (source-transform-length list
))
4437 (define-source-transform list-length
(list) (source-transform-length list
))
4439 ;;; ENDP, NULL and NOT -> %REST-NULL
4441 ;;; Outside &REST convert into an IF so that IF optimizations will eliminate
4442 ;;; redundant negations.
4443 (defun source-transform-null (x op
)
4444 (multiple-value-bind (context count
) (possible-rest-arg-context x
)
4446 `(%rest-null
',op
,x
,context
,count
))
4448 `(if (the list
,x
) nil t
))
4451 (define-source-transform not
(x) (source-transform-null x
'not
))
4452 (define-source-transform null
(x) (source-transform-null x
'null
))
4453 (define-source-transform endp
(x) (source-transform-null x
'endp
))
4455 (deftransform %rest-values
((list context count
))
4456 (if (rest-var-more-context-ok list
)
4457 `(%more-arg-values context
0 count
)
4458 `(values-list list
)))
4460 (deftransform %rest-ref
((n list context count
&optional length-checked-p
))
4461 (cond ((rest-var-more-context-ok list
)
4462 (if (and (constant-lvar-p length-checked-p
)
4463 (lvar-value length-checked-p
))
4464 `(%more-arg context n
)
4465 `(and (< (the index n
) count
) (%more-arg context n
))))
4466 ((and (constant-lvar-p n
) (zerop (lvar-value n
)))
4471 (deftransform %rest-length
((list context count
))
4472 (if (rest-var-more-context-ok list
)
4476 (deftransform %rest-null
((op list context count
))
4477 (aver (constant-lvar-p op
))
4478 (if (rest-var-more-context-ok list
)
4480 `(,(lvar-value op
) list
)))
4482 (deftransform %rest-true
((list context count
))
4483 (if (rest-var-more-context-ok list
)
4484 `(not (eql 0 count
))
4487 ;;;; transforming FORMAT
4489 ;;;; If the control string is a compile-time constant, then replace it
4490 ;;;; with a use of the FORMATTER macro so that the control string is
4491 ;;;; ``compiled.'' Furthermore, if the destination is either a stream
4492 ;;;; or T and the control string is a function (i.e. FORMATTER), then
4493 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
4495 ;;; for compile-time argument count checking.
4497 ;;; FIXME II: In some cases, type information could be correlated; for
4498 ;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
4499 ;;; of a corresponding argument is known and does not intersect the
4500 ;;; list type, a warning could be signalled.
4501 (defun check-format-args (string args fun
)
4502 (declare (type string string
))
4503 (unless (typep string
'simple-string
)
4504 (setq string
(coerce string
'simple-string
)))
4505 (multiple-value-bind (min max
)
4506 (handler-case (sb!format
:%compiler-walk-format-string string args
)
4507 (sb!format
:format-error
(c)
4508 (compiler-warn "~A" c
)))
4510 (let ((nargs (length args
)))
4513 (warn 'format-too-few-args-warning
4515 "Too few arguments (~D) to ~S ~S: requires at least ~D."
4516 :format-arguments
(list nargs fun string min
)))
4518 (warn 'format-too-many-args-warning
4520 "Too many arguments (~D) to ~S ~S: uses at most ~D."
4521 :format-arguments
(list nargs fun string max
))))))))
4523 (defoptimizer (format optimizer
) ((dest control
&rest args
))
4524 (declare (ignore dest
))
4525 (when (constant-lvar-p control
)
4526 (let ((x (lvar-value control
)))
4528 (check-format-args x args
'format
)))))
4530 ;;; We disable this transform in the cross-compiler to save memory in
4531 ;;; the target image; most of the uses of FORMAT in the compiler are for
4532 ;;; error messages, and those don't need to be particularly fast.
4534 (deftransform format
((dest control
&rest args
) (t simple-string
&rest t
) *
4535 :policy
(>= speed space
))
4536 (unless (constant-lvar-p control
)
4537 (give-up-ir1-transform "The control string is not a constant."))
4538 (let* ((argc (length args
))
4539 (arg-names (make-gensym-list argc
))
4540 (control (lvar-value control
))
4541 ;; Expanding the control string now avoids deferring to FORMATTER
4542 ;; so that we don't need an internal-only variant of it that
4543 ;; passes through extra args to %FORMATTER.
4544 (expr (handler-case ; in case %formatter wants to signal an error
4545 (sb!format
::%formatter control argc nil
)
4546 ;; otherwise, let the macro complain
4547 (sb!format
:format-error
() `(formatter ,control
)))))
4548 `(lambda (dest control
,@arg-names
)
4549 (declare (ignore control
))
4550 (format dest
,expr
,@arg-names
))))
4552 (deftransform format
((stream control
&rest args
) (stream function
&rest t
))
4553 (let ((arg-names (make-gensym-list (length args
))))
4554 `(lambda (stream control
,@arg-names
)
4555 (funcall control stream
,@arg-names
)
4558 (deftransform format
((tee control
&rest args
) ((member t
) function
&rest t
))
4559 (let ((arg-names (make-gensym-list (length args
))))
4560 `(lambda (tee control
,@arg-names
)
4561 (declare (ignore tee
))
4562 (funcall control
*standard-output
* ,@arg-names
)
4565 (deftransform format
((stream control
&rest args
) (null function
&rest t
))
4566 (let ((arg-names (make-gensym-list (length args
))))
4567 `(lambda (stream control
,@arg-names
)
4568 (declare (ignore stream
))
4569 (with-simple-output-to-string (stream)
4570 (funcall control stream
,@arg-names
)))))
4572 (deftransform pathname
((pathspec) (pathname) *)
4575 (deftransform pathname
((pathspec) (string) *)
4576 '(values (parse-namestring pathspec
)))
4580 `(defoptimizer (,name optimizer
) ((control &rest args
))
4581 (when (constant-lvar-p control
)
4582 (let ((x (lvar-value control
)))
4584 (check-format-args x args
',name
)))))))
4587 #+sb-xc-host
; Only we should be using these
4590 (def compiler-error
)
4592 (def compiler-style-warn
)
4593 (def compiler-notify
)
4594 (def maybe-compiler-notify
)
4597 (defoptimizer (cerror optimizer
) ((report control
&rest args
))
4598 (when (and (constant-lvar-p control
)
4599 (constant-lvar-p report
))
4600 (let ((x (lvar-value control
))
4601 (y (lvar-value report
)))
4602 (when (and (stringp x
) (stringp y
))
4603 (multiple-value-bind (min1 max1
)
4605 (sb!format
:%compiler-walk-format-string x args
)
4606 (sb!format
:format-error
(c)
4607 (compiler-warn "~A" c
)))
4609 (multiple-value-bind (min2 max2
)
4611 (sb!format
:%compiler-walk-format-string y args
)
4612 (sb!format
:format-error
(c)
4613 (compiler-warn "~A" c
)))
4615 (let ((nargs (length args
)))
4617 ((< nargs
(min min1 min2
))
4618 (warn 'format-too-few-args-warning
4620 "Too few arguments (~D) to ~S ~S ~S: ~
4621 requires at least ~D."
4623 (list nargs
'cerror y x
(min min1 min2
))))
4624 ((> nargs
(max max1 max2
))
4625 (warn 'format-too-many-args-warning
4627 "Too many arguments (~D) to ~S ~S ~S: ~
4630 (list nargs
'cerror y x
(max max1 max2
))))))))))))))
4632 (defoptimizer (coerce derive-type
) ((value type
) node
)
4634 ((constant-lvar-p type
)
4635 ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
4636 ;; but dealing with the niggle that complex canonicalization gets
4637 ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
4639 (let* ((specifier (lvar-value type
))
4640 (result-typeoid (careful-specifier-type specifier
)))
4642 ((null result-typeoid
) nil
)
4643 ((csubtypep result-typeoid
(specifier-type 'number
))
4644 ;; the difficult case: we have to cope with ANSI 12.1.5.3
4645 ;; Rule of Canonical Representation for Complex Rationals,
4646 ;; which is a truly nasty delivery to field.
4648 ((csubtypep result-typeoid
(specifier-type 'real
))
4649 ;; cleverness required here: it would be nice to deduce
4650 ;; that something of type (INTEGER 2 3) coerced to type
4651 ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0).
4652 ;; FLOAT gets its own clause because it's implemented as
4653 ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE
4656 ((and (numeric-type-p result-typeoid
)
4657 (eq (numeric-type-complexp result-typeoid
) :real
))
4658 ;; FIXME: is this clause (a) necessary or (b) useful?
4660 ((or (csubtypep result-typeoid
4661 (specifier-type '(complex single-float
)))
4662 (csubtypep result-typeoid
4663 (specifier-type '(complex double-float
)))
4665 (csubtypep result-typeoid
4666 (specifier-type '(complex long-float
))))
4667 ;; float complex types are never canonicalized.
4670 ;; if it's not a REAL, or a COMPLEX FLOAToid, it's
4671 ;; probably just a COMPLEX or equivalent. So, in that
4672 ;; case, we will return a complex or an object of the
4673 ;; provided type if it's rational:
4674 (type-union result-typeoid
4675 (type-intersection (lvar-type value
)
4676 (specifier-type 'rational
))))))
4677 ((and (policy node
(zerop safety
))
4678 (csubtypep result-typeoid
(specifier-type '(array * (*)))))
4679 ;; At zero safety the deftransform for COERCE can elide dimension
4680 ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
4681 ;; need to simplify the type to drop the dimension information.
4682 (let ((vtype (simplify-vector-type result-typeoid
)))
4684 (specifier-type vtype
)
4689 ;; OK, the result-type argument isn't constant. However, there
4690 ;; are common uses where we can still do better than just
4691 ;; *UNIVERSAL-TYPE*: e.g. (COERCE X (ARRAY-ELEMENT-TYPE Y)),
4692 ;; where Y is of a known type. See messages on cmucl-imp
4693 ;; 2001-02-14 and sbcl-devel 2002-12-12. We only worry here
4694 ;; about types that can be returned by (ARRAY-ELEMENT-TYPE Y), on
4695 ;; the basis that it's unlikely that other uses are both
4696 ;; time-critical and get to this branch of the COND (non-constant
4697 ;; second argument to COERCE). -- CSR, 2002-12-16
4698 (let ((value-type (lvar-type value
))
4699 (type-type (lvar-type type
)))
4701 ((good-cons-type-p (cons-type)
4702 ;; Make sure the cons-type we're looking at is something
4703 ;; we're prepared to handle which is basically something
4704 ;; that array-element-type can return.
4705 (or (and (member-type-p cons-type
)
4706 (eql 1 (member-type-size cons-type
))
4707 (null (first (member-type-members cons-type
))))
4708 (let ((car-type (cons-type-car-type cons-type
)))
4709 (and (member-type-p car-type
)
4710 (eql 1 (member-type-members car-type
))
4711 (let ((elt (first (member-type-members car-type
))))
4715 (numberp (first elt
)))))
4716 (good-cons-type-p (cons-type-cdr-type cons-type
))))))
4717 (unconsify-type (good-cons-type)
4718 ;; Convert the "printed" respresentation of a cons
4719 ;; specifier into a type specifier. That is, the
4720 ;; specifier (CONS (EQL SIGNED-BYTE) (CONS (EQL 16)
4721 ;; NULL)) is converted to (SIGNED-BYTE 16).
4722 (cond ((or (null good-cons-type
)
4723 (eq good-cons-type
'null
))
4725 ((and (eq (first good-cons-type
) 'cons
)
4726 (eq (first (second good-cons-type
)) 'member
))
4727 `(,(second (second good-cons-type
))
4728 ,@(unconsify-type (caddr good-cons-type
))))))
4729 (coerceable-p (part)
4730 ;; Can the value be coerced to the given type? Coerce is
4731 ;; complicated, so we don't handle every possible case
4732 ;; here---just the most common and easiest cases:
4734 ;; * Any REAL can be coerced to a FLOAT type.
4735 ;; * Any NUMBER can be coerced to a (COMPLEX
4736 ;; SINGLE/DOUBLE-FLOAT).
4738 ;; FIXME I: we should also be able to deal with characters
4741 ;; FIXME II: I'm not sure that anything is necessary
4742 ;; here, at least while COMPLEX is not a specialized
4743 ;; array element type in the system. Reasoning: if
4744 ;; something cannot be coerced to the requested type, an
4745 ;; error will be raised (and so any downstream compiled
4746 ;; code on the assumption of the returned type is
4747 ;; unreachable). If something can, then it will be of
4748 ;; the requested type, because (by assumption) COMPLEX
4749 ;; (and other difficult types like (COMPLEX INTEGER)
4750 ;; aren't specialized types.
4751 (let ((coerced-type (careful-specifier-type part
)))
4753 (or (and (csubtypep coerced-type
(specifier-type 'float
))
4754 (csubtypep value-type
(specifier-type 'real
)))
4755 (and (csubtypep coerced-type
4756 (specifier-type `(or (complex single-float
)
4757 (complex double-float
))))
4758 (csubtypep value-type
(specifier-type 'number
)))))))
4759 (process-types (type)
4760 ;; FIXME: This needs some work because we should be able
4761 ;; to derive the resulting type better than just the
4762 ;; type arg of coerce. That is, if X is (INTEGER 10
4763 ;; 20), then (COERCE X 'DOUBLE-FLOAT) should say
4764 ;; (DOUBLE-FLOAT 10d0 20d0) instead of just
4766 (cond ((member-type-p type
)
4769 (mapc-member-type-members
4771 (if (coerceable-p member
)
4772 (push member members
)
4773 (return-from punt
*universal-type
*)))
4775 (specifier-type `(or ,@members
)))))
4776 ((and (cons-type-p type
)
4777 (good-cons-type-p type
))
4778 (let ((c-type (unconsify-type (type-specifier type
))))
4779 (if (coerceable-p c-type
)
4780 (specifier-type c-type
)
4783 *universal-type
*))))
4784 (cond ((union-type-p type-type
)
4785 (apply #'type-union
(mapcar #'process-types
4786 (union-type-types type-type
))))
4787 ((or (member-type-p type-type
)
4788 (cons-type-p type-type
))
4789 (process-types type-type
))
4791 *universal-type
*)))))))
4793 (defoptimizer (compile derive-type
) ((nameoid function
))
4794 (declare (ignore function
))
4795 (when (csubtypep (lvar-type nameoid
)
4796 (specifier-type 'null
))
4797 (values-specifier-type '(values function boolean boolean
))))
4799 ;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
4800 ;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
4801 ;;; optimizer, above).
4802 (defoptimizer (array-element-type derive-type
) ((array))
4803 (let ((array-type (lvar-type array
)))
4804 (labels ((consify (list)
4807 `(cons (eql ,(car list
)) ,(consify (rest list
)))))
4808 (get-element-type (a)
4810 (type-specifier (array-type-specialized-element-type a
))))
4811 (cond ((eq element-type
'*)
4812 (specifier-type 'type-specifier
))
4813 ((symbolp element-type
)
4814 (make-member-type :members
(list element-type
)))
4815 ((consp element-type
)
4816 (specifier-type (consify element-type
)))
4818 (error "can't understand type ~S~%" element-type
))))))
4819 (labels ((recurse (type)
4820 (cond ((array-type-p type
)
4821 (get-element-type type
))
4822 ((union-type-p type
)
4824 (mapcar #'recurse
(union-type-types type
))))
4826 *universal-type
*))))
4827 (recurse array-type
)))))
4829 (define-source-transform sb
!impl
::sort-vector
(vector start end predicate key
)
4830 ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
4831 ;; isn't really related to the CMU CL code, since instead of trying
4832 ;; to generalize the CMU CL code to allow START and END values, this
4833 ;; code has been written from scratch following Chapter 7 of
4834 ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
4835 `(macrolet ((%index
(x) `(truly-the index
,x
))
4836 (%parent
(i) `(ash ,i -
1))
4837 (%left
(i) `(%index
(ash ,i
1)))
4838 (%right
(i) `(%index
(1+ (ash ,i
1))))
4841 (left (%left i
) (%left i
)))
4842 ((> left current-heap-size
))
4843 (declare (type index i left
))
4844 (let* ((i-elt (%elt i
))
4845 (i-key (funcall keyfun i-elt
))
4846 (left-elt (%elt left
))
4847 (left-key (funcall keyfun left-elt
)))
4848 (multiple-value-bind (large large-elt large-key
)
4849 (if (funcall ,',predicate i-key left-key
)
4850 (values left left-elt left-key
)
4851 (values i i-elt i-key
))
4852 (let ((right (%right i
)))
4853 (multiple-value-bind (largest largest-elt
)
4854 (if (> right current-heap-size
)
4855 (values large large-elt
)
4856 (let* ((right-elt (%elt right
))
4857 (right-key (funcall keyfun right-elt
)))
4858 (if (funcall ,',predicate large-key right-key
)
4859 (values right right-elt
)
4860 (values large large-elt
))))
4861 (cond ((= largest i
)
4864 (setf (%elt i
) largest-elt
4865 (%elt largest
) i-elt
4867 (%sort-vector
(keyfun &optional
(vtype 'vector
))
4868 `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had
4869 ;; trouble getting type inference to
4870 ;; propagate all the way through this
4871 ;; tangled mess of inlining. The TRULY-THE
4872 ;; here works around that. -- WHN
4874 `(aref (truly-the ,',vtype
,',',vector
)
4875 (%index
(+ (%index
,i
) start-1
)))))
4876 (let (;; Heaps prefer 1-based addressing.
4877 (start-1 (1- ,',start
))
4878 (current-heap-size (- ,',end
,',start
))
4880 (declare (type (integer -
1 #.
(1- sb
!xc
:most-positive-fixnum
))
4882 (declare (type index current-heap-size
))
4883 (declare (type function keyfun
))
4884 (loop for i of-type index
4885 from
(ash current-heap-size -
1) downto
1 do
4888 (when (< current-heap-size
2)
4890 (rotatef (%elt
1) (%elt current-heap-size
))
4891 (decf current-heap-size
)
4893 (if (typep ,vector
'simple-vector
)
4894 ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
4895 ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
4897 ;; Special-casing the KEY=NIL case lets us avoid some
4899 (%sort-vector
#'identity simple-vector
)
4900 (%sort-vector
,key simple-vector
))
4901 ;; It's hard to anticipate many speed-critical applications for
4902 ;; sorting vector types other than (VECTOR T), so we just lump
4903 ;; them all together in one slow dynamically typed mess.
4905 (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
4906 (%sort-vector
(or ,key
#'identity
))))))
4908 (deftransform sort
((list predicate
&key key
)
4910 `(sb!impl
::stable-sort-list list
4911 (%coerce-callable-to-fun predicate
)
4912 (if key
(%coerce-callable-to-fun key
) #'identity
)))
4914 (deftransform stable-sort
((sequence predicate
&key key
)
4915 ((or vector list
) *))
4916 (let ((sequence-type (lvar-type sequence
)))
4917 (cond ((csubtypep sequence-type
(specifier-type 'list
))
4918 `(sb!impl
::stable-sort-list sequence
4919 (%coerce-callable-to-fun predicate
)
4920 (if key
(%coerce-callable-to-fun key
) #'identity
)))
4921 ((csubtypep sequence-type
(specifier-type 'simple-vector
))
4922 `(sb!impl
::stable-sort-simple-vector sequence
4923 (%coerce-callable-to-fun predicate
)
4924 (and key
(%coerce-callable-to-fun key
))))
4926 `(sb!impl
::stable-sort-vector sequence
4927 (%coerce-callable-to-fun predicate
)
4928 (and key
(%coerce-callable-to-fun key
)))))))
4930 ;;;; debuggers' little helpers
4932 ;;; for debugging when transforms are behaving mysteriously,
4933 ;;; e.g. when debugging a problem with an ASH transform
4934 ;;; (defun foo (&optional s)
4935 ;;; (sb-c::/report-lvar s "S outside WHEN")
4936 ;;; (when (and (integerp s) (> s 3))
4937 ;;; (sb-c::/report-lvar s "S inside WHEN")
4938 ;;; (let ((bound (ash 1 (1- s))))
4939 ;;; (sb-c::/report-lvar bound "BOUND")
4940 ;;; (let ((x (- bound))
4942 ;;; (sb-c::/report-lvar x "X")
4943 ;;; (sb-c::/report-lvar x "Y"))
4944 ;;; `(integer ,(- bound) ,(1- bound)))))
4945 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
4946 ;;; and the function doesn't do anything at all.)
4949 (defknown /report-lvar
(t t
) null
)
4950 (deftransform /report-lvar
((x message
) (t t
))
4951 (format t
"~%/in /REPORT-LVAR~%")
4952 (format t
"/(LVAR-TYPE X)=~S~%" (lvar-type x
))
4953 (when (constant-lvar-p x
)
4954 (format t
"/(LVAR-VALUE X)=~S~%" (lvar-value x
)))
4955 (format t
"/MESSAGE=~S~%" (lvar-value message
))
4956 (give-up-ir1-transform "not a real transform"))
4957 (defun /report-lvar
(x message
)
4958 (declare (ignore x message
))))
4961 ;;;; Transforms for internal compiler utilities
4963 (defknown set-info-value
(t type-number t
) t
)
4965 ;; An optimizer to derive that SET-INFO-VALUE always returns NEWVAL's type.
4966 ;; Using `(TRULY-THE (VALUES ,(TYPE-INFO-TYPE ...))) in the compiler-macro
4967 ;; for (SETF INFO) would achieve a similar effect, but this is even better.
4968 (defoptimizer (set-info-value derive-type
) ((name type-number newval
))
4969 (declare (ignore name type-number
))
4972 ;;; If QUALITY-NAME is constant and a valid name, don't bother
4973 ;;; checking that it's still valid at run-time.
4974 (deftransform policy-quality
((policy quality-name
)
4976 (unless (and (constant-lvar-p quality-name
)
4977 (policy-quality-name-p (lvar-value quality-name
)))
4978 (give-up-ir1-transform))
4979 '(%policy-quality policy quality-name
))
4981 (deftransform encode-universal-time
4982 ((second minute hour date month year
&optional time-zone
)
4983 ((constant-arg (mod 60)) (constant-arg (mod 60))
4984 (constant-arg (mod 24))
4985 (constant-arg (integer 1 31))
4986 (constant-arg (integer 1 12))
4987 (constant-arg (integer 1899))
4988 (constant-arg (rational -
24 24))))
4989 (let ((second (lvar-value second
))
4990 (minute (lvar-value minute
))
4991 (hour (lvar-value hour
))
4992 (date (lvar-value date
))
4993 (month (lvar-value month
))
4994 (year (lvar-value year
))
4995 (time-zone (lvar-value time-zone
)))
4996 (if (zerop (rem time-zone
1/3600))
4997 (encode-universal-time second minute hour date month year time-zone
)
4998 (give-up-ir1-transform))))
5000 #!-
(and win32
(not sb-thread
))
5001 (deftransform sleep
((seconds) ((integer 0 #.
(expt 10 8))))
5002 `(sb!unix
:nanosleep seconds
0))
5004 #!-
(and win32
(not sb-thread
))
5005 (deftransform sleep
((seconds) ((constant-arg (real 0))))
5006 (let ((seconds-value (lvar-value seconds
)))
5007 (multiple-value-bind (seconds nano
)
5008 (sb!impl
::split-seconds-for-sleep seconds-value
)
5009 (if (> seconds
(expt 10 8))
5010 (give-up-ir1-transform)
5011 `(sb!unix
:nanosleep
,seconds
,nano
)))))