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 env
)
73 (declare (ignore env
))
74 (if (not (singleton-p (cdr form
)))
76 (let* ((name (car form
))
80 (leaf (leaf-source-name name
))))))
81 (do ((i (- (length string
) 2) (1- i
))
83 `(,(ecase (char string i
)
89 ;;; Make source transforms to turn CxR forms into combinations of CAR
90 ;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
92 ;;; Don't transform CAD*R, they are treated specially for &more args
95 (/show0
"about to set CxR source transforms")
96 (loop for i of-type index from
2 upto
4 do
97 ;; Iterate over BUF = all names CxR where x = an I-element
98 ;; string of #\A or #\D characters.
99 (let ((buf (make-string (+ 2 i
))))
100 (setf (aref buf
0) #\C
101 (aref buf
(1+ i
)) #\R
)
102 (dotimes (j (ash 2 i
))
103 (declare (type index j
))
105 (declare (type index k
))
106 (setf (aref buf
(1+ k
))
107 (if (logbitp k j
) #\A
#\D
)))
108 (unless (member buf
'("CADR" "CADDR" "CADDDR")
110 (setf (info :function
:source-transform
(intern buf
))
111 #'source-transform-cxr
)))))
112 (/show0
"done setting CxR source transforms")
114 ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
115 ;;; whatever is right for them is right for us. FIFTH..TENTH turn into
116 ;;; Nth, which can be expanded into a CAR/CDR later on if policy
118 (define-source-transform rest
(x) `(cdr ,x
))
119 (define-source-transform first
(x) `(car ,x
))
120 (define-source-transform second
(x) `(cadr ,x
))
121 (define-source-transform third
(x) `(caddr ,x
))
122 (define-source-transform fourth
(x) `(cadddr ,x
))
123 (define-source-transform fifth
(x) `(nth 4 ,x
))
124 (define-source-transform sixth
(x) `(nth 5 ,x
))
125 (define-source-transform seventh
(x) `(nth 6 ,x
))
126 (define-source-transform eighth
(x) `(nth 7 ,x
))
127 (define-source-transform ninth
(x) `(nth 8 ,x
))
128 (define-source-transform tenth
(x) `(nth 9 ,x
))
130 ;;; LIST with one arg is an extremely common operation (at least inside
131 ;;; SBCL itself); translate it to CONS to take advantage of common
132 ;;; allocation routines.
133 (define-source-transform list
(&rest args
)
135 (1 `(cons ,(first args
) nil
))
138 (defoptimizer (list derive-type
) ((&rest args
))
140 (specifier-type 'cons
)
141 (specifier-type 'null
)))
143 ;;; And similarly for LIST*.
144 (define-source-transform list
* (arg &rest others
)
145 (cond ((not others
) arg
)
146 ((not (cdr others
)) `(cons ,arg
,(car others
)))
149 (defoptimizer (list* derive-type
) ((arg &rest args
))
151 (specifier-type 'cons
)
156 (define-source-transform nconc
(&rest args
)
162 ;;; (append nil nil nil fixnum) => fixnum
163 ;;; (append x x cons x x) => cons
164 ;;; (append x x x x list) => list
165 ;;; (append x x x x sequence) => sequence
166 ;;; (append fixnum x ...) => nil
167 (defun derive-append-type (args)
169 (return-from derive-append-type
(specifier-type 'null
)))
170 (let* ((cons-type (specifier-type 'cons
))
171 (null-type (specifier-type 'null
))
172 (list-type (specifier-type 'list
))
173 (last (lvar-type (car (last args
)))))
174 ;; Derive the actual return type, assuming that all but the last
175 ;; arguments are LISTs (otherwise, APPEND/NCONC doesn't return).
176 (loop with all-nil
= t
; all but the last args are NIL?
177 with some-cons
= nil
; some args are conses?
178 for
(arg next
) on args
179 for lvar-type
= (type-approx-intersection2 (lvar-type arg
)
182 do
(multiple-value-bind (typep definitely
)
183 (ctypep nil lvar-type
)
184 (cond ((type= lvar-type
*empty-type
*)
185 ;; type mismatch! insert an inline check that'll cause
186 ;; compile-time warnings.
187 (assert-lvar-type arg list-type
188 (lexenv-policy *lexenv
*)))
189 (some-cons) ; we know result's a cons -- nothing to do
190 ((and (not typep
) definitely
) ; can't be NIL
191 (setf some-cons t
)) ; must be a CONS
193 (setf all-nil
(csubtypep lvar-type null-type
)))))
195 ;; if some of the previous arguments are CONSes so is the result;
196 ;; if all the previous values are NIL, we're a fancy identity;
197 ;; otherwise, could be either
198 (return (cond (some-cons cons-type
)
200 (t (type-union last cons-type
)))))))
202 (defoptimizer (append derive-type
) ((&rest args
))
203 (derive-append-type args
))
205 (defoptimizer (sb!impl
::append2 derive-type
) ((&rest args
))
206 (derive-append-type args
))
208 (defoptimizer (nconc derive-type
) ((&rest args
))
209 (derive-append-type args
))
211 ;;; Translate RPLACx to LET and SETF.
212 (define-source-transform rplaca
(x y
)
217 (define-source-transform rplacd
(x y
)
223 (deftransform last
((list &optional n
) (t &optional t
))
224 (let ((c (constant-lvar-p n
)))
226 (and c
(eql 1 (lvar-value n
))))
228 ((and c
(eql 0 (lvar-value n
)))
231 (let ((type (lvar-type n
)))
232 (cond ((csubtypep type
(specifier-type 'fixnum
))
233 '(%lastn
/fixnum list n
))
234 ((csubtypep type
(specifier-type 'bignum
))
235 '(%lastn
/bignum list n
))
237 (give-up-ir1-transform "second argument type too vague"))))))))
239 (define-source-transform gethash
(&rest args
)
241 (2 `(sb!impl
::gethash3
,@args nil
))
242 (3 `(sb!impl
::gethash3
,@args
))
244 (define-source-transform get
(&rest args
)
246 (2 `(sb!impl
::get3
,@args nil
))
247 (3 `(sb!impl
::get3
,@args
))
250 (defvar *default-nthcdr-open-code-limit
* 6)
251 (defvar *extreme-nthcdr-open-code-limit
* 20)
253 (deftransform nthcdr
((n l
) (unsigned-byte t
) * :node node
)
254 "convert NTHCDR to CAxxR"
255 (unless (constant-lvar-p n
)
256 (give-up-ir1-transform))
257 (let ((n (lvar-value n
)))
259 (if (policy node
(and (= speed
3) (= space
0)))
260 *extreme-nthcdr-open-code-limit
*
261 *default-nthcdr-open-code-limit
*))
262 (give-up-ir1-transform))
267 `(cdr ,(frob (1- n
))))))
270 ;;;; arithmetic and numerology
272 (define-source-transform plusp
(x) `(> ,x
0))
273 (define-source-transform minusp
(x) `(< ,x
0))
274 (define-source-transform zerop
(x) `(= ,x
0))
276 (define-source-transform 1+ (x) `(+ ,x
1))
277 (define-source-transform 1-
(x) `(- ,x
1))
279 (define-source-transform oddp
(x) `(logtest ,x
1))
280 (define-source-transform evenp
(x) `(not (logtest ,x
1)))
282 ;;; Note that all the integer division functions are available for
283 ;;; inline expansion.
285 (macrolet ((deffrob (fun)
286 `(define-source-transform ,fun
(x &optional
(y nil y-p
))
293 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
295 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
298 ;;; This used to be a source transform (hence the lack of restrictions
299 ;;; on the argument types), but we make it a regular transform so that
300 ;;; the VM has a chance to see the bare LOGTEST and potentiall choose
301 ;;; to implement it differently. --njf, 06-02-2006
303 ;;; Other transforms may be useful even with direct LOGTEST VOPs; let
304 ;;; them fire (including the type-directed constant folding below), but
305 ;;; disable the inlining rewrite in such cases. -- PK, 2013-05-20
306 (deftransform logtest
((x y
) * * :node node
)
307 (let ((type (two-arg-derive-type x y
308 #'logand-derive-type-aux
310 (multiple-value-bind (typep definitely
)
312 (cond ((and (not typep
) definitely
)
314 ((type= type
(specifier-type '(eql 0)))
316 ((neq :default
(combination-implementation-style node
))
317 (give-up-ir1-transform))
319 `(not (zerop (logand x y
))))))))
321 (deftransform logbitp
322 ((index integer
) (unsigned-byte (or (signed-byte #.sb
!vm
:n-word-bits
)
323 (unsigned-byte #.sb
!vm
:n-word-bits
))))
324 (flet ((general-case ()
325 `(if (>= index
#.sb
!vm
:n-word-bits
)
327 (not (zerop (logand integer
(ash 1 index
)))))))
328 (if (constant-lvar-p integer
)
329 (let ((val (lvar-value integer
)))
330 (cond ((eql val
0) nil
)
335 (define-source-transform byte
(size position
)
336 `(cons ,size
,position
))
337 (define-source-transform byte-size
(spec) `(car ,spec
))
338 (define-source-transform byte-position
(spec) `(cdr ,spec
))
339 (define-source-transform ldb-test
(bytespec integer
)
340 `(not (zerop (mask-field ,bytespec
,integer
))))
342 ;;; With the ratio and complex accessors, we pick off the "identity"
343 ;;; case, and use a primitive to handle the cell access case.
344 (define-source-transform numerator
(num)
345 (once-only ((n-num `(the rational
,num
)))
349 (define-source-transform denominator
(num)
350 (once-only ((n-num `(the rational
,num
)))
352 (%denominator
,n-num
)
355 ;;;; interval arithmetic for computing bounds
357 ;;;; This is a set of routines for operating on intervals. It
358 ;;;; implements a simple interval arithmetic package. Although SBCL
359 ;;;; has an interval type in NUMERIC-TYPE, we choose to use our own
360 ;;;; for two reasons:
362 ;;;; 1. This package is simpler than NUMERIC-TYPE.
364 ;;;; 2. It makes debugging much easier because you can just strip
365 ;;;; out these routines and test them independently of SBCL. (This is a
368 ;;;; One disadvantage is a probable increase in consing because we
369 ;;;; have to create these new interval structures even though
370 ;;;; numeric-type has everything we want to know. Reason 2 wins for
373 ;;; Support operations that mimic real arithmetic comparison
374 ;;; operators, but imposing a total order on the floating points such
375 ;;; that negative zeros are strictly less than positive zeros.
376 (macrolet ((def (name op
)
379 (if (and (floatp x
) (floatp y
) (zerop x
) (zerop y
))
380 (,op
(float-sign x
) (float-sign y
))
382 (def signed-zero-
>= >=)
383 (def signed-zero-
> >)
384 (def signed-zero-
= =)
385 (def signed-zero-
< <)
386 (def signed-zero-
<= <=))
388 ;;; The basic interval type. It can handle open and closed intervals.
389 ;;; A bound is open if it is a list containing a number, just like
390 ;;; Lisp says. NIL means unbounded.
391 (defstruct (interval (:constructor %make-interval
)
395 (defun make-interval (&key low high
)
396 (labels ((normalize-bound (val)
399 (float-infinity-p val
))
400 ;; Handle infinities.
404 ;; Handle any closed bounds.
407 ;; We have an open bound. Normalize the numeric
408 ;; bound. If the normalized bound is still a number
409 ;; (not nil), keep the bound open. Otherwise, the
410 ;; bound is really unbounded, so drop the openness.
411 (let ((new-val (normalize-bound (first val
))))
413 ;; The bound exists, so keep it open still.
416 (error "unknown bound type in MAKE-INTERVAL")))))
417 (%make-interval
:low
(normalize-bound low
)
418 :high
(normalize-bound high
))))
420 ;;; Given a number X, create a form suitable as a bound for an
421 ;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL.
422 #!-sb-fluid
(declaim (inline set-bound
))
423 (defun set-bound (x open-p
)
424 (if (and x open-p
) (list x
) x
))
426 ;;; Apply the function F to a bound X. If X is an open bound and the
427 ;;; function is declared strictly monotonic, then the result will be
428 ;;; open. IF X is NIL, the result is NIL.
429 (defun bound-func (f x strict
)
430 (declare (type function f
))
433 (with-float-traps-masked (:underflow
:overflow
:inexact
:divide-by-zero
)
434 ;; With these traps masked, we might get things like infinity
435 ;; or negative infinity returned. Check for this and return
436 ;; NIL to indicate unbounded.
437 (let ((y (funcall f
(type-bound-number x
))))
439 (float-infinity-p y
))
441 (set-bound y
(and strict
(consp x
))))))
442 ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g.
443 ;; in the course of converting a bignum to a float. Default to
445 (simple-type-error ()))))
447 (defun safe-double-coercion-p (x)
448 (or (typep x
'double-float
)
449 (<= most-negative-double-float x most-positive-double-float
)))
451 (defun safe-single-coercion-p (x)
452 (or (typep x
'single-float
)
454 ;; Fix for bug 420, and related issues: during type derivation we often
455 ;; end up deriving types for both
457 ;; (some-op <int> <single>)
459 ;; (some-op (coerce <int> 'single-float) <single>)
461 ;; or other equivalent transformed forms. The problem with this
462 ;; is that on x86 (+ <int> <single>) is on the machine level
465 ;; (coerce (+ (coerce <int> 'double-float)
466 ;; (coerce <single> 'double-float))
469 ;; so if the result of (coerce <int> 'single-float) is not exact, the
470 ;; derived types for the transformed forms will have an empty
471 ;; intersection -- which in turn means that the compiler will conclude
472 ;; that the call never returns, and all hell breaks lose when it *does*
473 ;; return at runtime. (This affects not just +, but other operators are
476 ;; See also: SAFE-CTYPE-FOR-SINGLE-COERCION-P
478 ;; FIXME: If we ever add SSE-support for x86, this conditional needs to
481 (not (typep x
`(or (integer * (,most-negative-exactly-single-float-fixnum
))
482 (integer (,most-positive-exactly-single-float-fixnum
) *))))
483 (<= most-negative-single-float x most-positive-single-float
))))
485 ;;; Apply a binary operator OP to two bounds X and Y. The result is
486 ;;; NIL if either is NIL. Otherwise bound is computed and the result
487 ;;; is open if either X or Y is open.
489 ;;; FIXME: only used in this file, not needed in target runtime
491 ;;; ANSI contaigon specifies coercion to floating point if one of the
492 ;;; arguments is floating point. Here we should check to be sure that
493 ;;; the other argument is within the bounds of that floating point
496 (defmacro safely-binop
(op x y
)
498 ((typep ,x
'double-float
)
499 (when (safe-double-coercion-p ,y
)
501 ((typep ,y
'double-float
)
502 (when (safe-double-coercion-p ,x
)
504 ((typep ,x
'single-float
)
505 (when (safe-single-coercion-p ,y
)
507 ((typep ,y
'single-float
)
508 (when (safe-single-coercion-p ,x
)
512 (defmacro bound-binop
(op x y
)
513 (with-unique-names (xb yb res
)
515 (with-float-traps-masked (:underflow
:overflow
:inexact
:divide-by-zero
)
516 (let* ((,xb
(type-bound-number ,x
))
517 (,yb
(type-bound-number ,y
))
518 (,res
(safely-binop ,op
,xb
,yb
)))
520 (and (or (consp ,x
) (consp ,y
))
521 ;; Open bounds can very easily be messed up
522 ;; by FP rounding, so take care here.
525 ;; Multiplying a greater-than-zero with
526 ;; less than one can round to zero.
527 `(or (not (fp-zero-p ,res
))
528 (cond ((and (consp ,x
) (fp-zero-p ,xb
))
530 ((and (consp ,y
) (fp-zero-p ,yb
))
533 ;; Dividing a greater-than-zero with
534 ;; greater than one can round to zero.
535 `(or (not (fp-zero-p ,res
))
536 (cond ((and (consp ,x
) (fp-zero-p ,xb
))
538 ((and (consp ,y
) (fp-zero-p ,yb
))
541 ;; Adding or subtracting greater-than-zero
542 ;; can end up with identity.
543 `(and (not (fp-zero-p ,xb
))
544 (not (fp-zero-p ,yb
))))))))))))
546 (defun coercion-loses-precision-p (val type
)
549 (double-float (subtypep type
'single-float
))
550 (rational (subtypep type
'float
))
551 (t (bug "Unexpected arguments to bounds coercion: ~S ~S" val type
))))
553 (defun coerce-for-bound (val type
)
555 (let ((xbound (coerce-for-bound (car val
) type
)))
556 (if (coercion-loses-precision-p (car val
) type
)
560 ((subtypep type
'double-float
)
561 (if (<= most-negative-double-float val most-positive-double-float
)
563 ((or (subtypep type
'single-float
) (subtypep type
'float
))
564 ;; coerce to float returns a single-float
565 (if (<= most-negative-single-float val most-positive-single-float
)
567 (t (coerce val type
)))))
569 (defun coerce-and-truncate-floats (val type
)
572 (let ((xbound (coerce-for-bound (car val
) type
)))
573 (if (coercion-loses-precision-p (car val
) type
)
577 ((subtypep type
'double-float
)
578 (if (<= most-negative-double-float val most-positive-double-float
)
580 (if (< val most-negative-double-float
)
581 most-negative-double-float most-positive-double-float
)))
582 ((or (subtypep type
'single-float
) (subtypep type
'float
))
583 ;; coerce to float returns a single-float
584 (if (<= most-negative-single-float val most-positive-single-float
)
586 (if (< val most-negative-single-float
)
587 most-negative-single-float most-positive-single-float
)))
588 (t (coerce val type
))))))
590 ;;; Convert a numeric-type object to an interval object.
591 (defun numeric-type->interval
(x)
592 (declare (type numeric-type x
))
593 (make-interval :low
(numeric-type-low x
)
594 :high
(numeric-type-high x
)))
596 (defun type-approximate-interval (type)
597 (declare (type ctype type
))
598 (let ((types (prepare-arg-for-derive-type type
))
601 (let ((type (if (member-type-p type
)
602 (convert-member-type type
)
604 (unless (numeric-type-p type
)
605 (return-from type-approximate-interval nil
))
606 (let ((interval (numeric-type->interval type
)))
609 (interval-approximate-union result interval
)
613 (defun copy-interval-limit (limit)
618 (defun copy-interval (x)
619 (declare (type interval x
))
620 (make-interval :low
(copy-interval-limit (interval-low x
))
621 :high
(copy-interval-limit (interval-high x
))))
623 ;;; Given a point P contained in the interval X, split X into two
624 ;;; intervals at the point P. If CLOSE-LOWER is T, then the left
625 ;;; interval contains P. If CLOSE-UPPER is T, the right interval
626 ;;; contains P. You can specify both to be T or NIL.
627 (defun interval-split (p x
&optional close-lower close-upper
)
628 (declare (type number p
)
630 (list (make-interval :low
(copy-interval-limit (interval-low x
))
631 :high
(if close-lower p
(list p
)))
632 (make-interval :low
(if close-upper
(list p
) p
)
633 :high
(copy-interval-limit (interval-high x
)))))
635 ;;; Return the closure of the interval. That is, convert open bounds
636 ;;; to closed bounds.
637 (defun interval-closure (x)
638 (declare (type interval x
))
639 (make-interval :low
(type-bound-number (interval-low x
))
640 :high
(type-bound-number (interval-high x
))))
642 ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
643 ;;; '-. Otherwise return NIL.
644 (defun interval-range-info (x &optional
(point 0))
645 (declare (type interval x
))
646 (let ((lo (interval-low x
))
647 (hi (interval-high x
)))
648 (cond ((and lo
(signed-zero->= (type-bound-number lo
) point
))
650 ((and hi
(signed-zero->= point
(type-bound-number hi
)))
655 ;;; Test to see whether the interval X is bounded. HOW determines the
656 ;;; test, and should be either ABOVE, BELOW, or BOTH.
657 (defun interval-bounded-p (x how
)
658 (declare (type interval x
))
665 (and (interval-low x
) (interval-high x
)))))
667 ;;; See whether the interval X contains the number P, taking into
668 ;;; account that the interval might not be closed.
669 (defun interval-contains-p (p x
)
670 (declare (type number p
)
672 ;; Does the interval X contain the number P? This would be a lot
673 ;; easier if all intervals were closed!
674 (let ((lo (interval-low x
))
675 (hi (interval-high x
)))
677 ;; The interval is bounded
678 (if (and (signed-zero-<= (type-bound-number lo
) p
)
679 (signed-zero-<= p
(type-bound-number hi
)))
680 ;; P is definitely in the closure of the interval.
681 ;; We just need to check the end points now.
682 (cond ((signed-zero-= p
(type-bound-number lo
))
684 ((signed-zero-= p
(type-bound-number hi
))
689 ;; Interval with upper bound
690 (if (signed-zero-< p
(type-bound-number hi
))
692 (and (numberp hi
) (signed-zero-= p hi
))))
694 ;; Interval with lower bound
695 (if (signed-zero-> p
(type-bound-number lo
))
697 (and (numberp lo
) (signed-zero-= p lo
))))
699 ;; Interval with no bounds
702 ;;; Determine whether two intervals X and Y intersect. Return T if so.
703 ;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they
704 ;;; were closed. Otherwise the intervals are treated as they are.
706 ;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
707 ;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
708 ;;; is T, then they do intersect because we use the closure of X = [0,
709 ;;; 1] and Y = [1, 2] to determine intersection.
710 (defun interval-intersect-p (x y
&optional closed-intervals-p
)
711 (declare (type interval x y
))
712 (and (interval-intersection/difference
(if closed-intervals-p
715 (if closed-intervals-p
720 ;;; Are the two intervals adjacent? That is, is there a number
721 ;;; between the two intervals that is not an element of either
722 ;;; interval? If so, they are not adjacent. For example [0, 1) and
723 ;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
724 ;;; between both intervals.
725 (defun interval-adjacent-p (x y
)
726 (declare (type interval x y
))
727 (flet ((adjacent (lo hi
)
728 ;; Check to see whether lo and hi are adjacent. If either is
729 ;; nil, they can't be adjacent.
730 (when (and lo hi
(= (type-bound-number lo
) (type-bound-number hi
)))
731 ;; The bounds are equal. They are adjacent if one of
732 ;; them is closed (a number). If both are open (consp),
733 ;; then there is a number that lies between them.
734 (or (numberp lo
) (numberp hi
)))))
735 (or (adjacent (interval-low y
) (interval-high x
))
736 (adjacent (interval-low x
) (interval-high y
)))))
738 ;;; Compute the intersection and difference between two intervals.
739 ;;; Two values are returned: the intersection and the difference.
741 ;;; Let the two intervals be X and Y, and let I and D be the two
742 ;;; values returned by this function. Then I = X intersect Y. If I
743 ;;; is NIL (the empty set), then D is X union Y, represented as the
744 ;;; list of X and Y. If I is not the empty set, then D is (X union Y)
745 ;;; - I, which is a list of two intervals.
747 ;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D =
748 ;;; [-1,1) union [3,5], which is returned as a list of two intervals.
749 (defun interval-intersection/difference
(x y
)
750 (declare (type interval x y
))
751 (let ((x-lo (interval-low x
))
752 (x-hi (interval-high x
))
753 (y-lo (interval-low y
))
754 (y-hi (interval-high y
)))
757 ;; If p is an open bound, make it closed. If p is a closed
758 ;; bound, make it open.
762 (test-number (p int bound
)
763 ;; Test whether P is in the interval.
764 (let ((pn (type-bound-number p
)))
765 (when (interval-contains-p pn
(interval-closure int
))
766 ;; Check for endpoints.
767 (let* ((lo (interval-low int
))
768 (hi (interval-high int
))
769 (lon (type-bound-number lo
))
770 (hin (type-bound-number hi
)))
772 ;; Interval may be a point.
773 ((and lon hin
(= lon hin pn
))
774 (and (numberp p
) (numberp lo
) (numberp hi
)))
775 ;; Point matches the low end.
776 ;; [P] [P,?} => TRUE [P] (P,?} => FALSE
777 ;; (P [P,?} => TRUE P) [P,?} => FALSE
778 ;; (P (P,?} => TRUE P) (P,?} => FALSE
779 ((and lon
(= pn lon
))
780 (or (and (numberp p
) (numberp lo
))
781 (and (consp p
) (eq :low bound
))))
782 ;; [P] {?,P] => TRUE [P] {?,P) => FALSE
783 ;; P) {?,P] => TRUE (P {?,P] => FALSE
784 ;; P) {?,P) => TRUE (P {?,P) => FALSE
785 ((and hin
(= pn hin
))
786 (or (and (numberp p
) (numberp hi
))
787 (and (consp p
) (eq :high bound
))))
788 ;; Not an endpoint, all is well.
791 (test-lower-bound (p int
)
792 ;; P is a lower bound of an interval.
794 (test-number p int
:low
)
795 (not (interval-bounded-p int
'below
))))
796 (test-upper-bound (p int
)
797 ;; P is an upper bound of an interval.
799 (test-number p int
:high
)
800 (not (interval-bounded-p int
'above
)))))
801 (let ((x-lo-in-y (test-lower-bound x-lo y
))
802 (x-hi-in-y (test-upper-bound x-hi y
))
803 (y-lo-in-x (test-lower-bound y-lo x
))
804 (y-hi-in-x (test-upper-bound y-hi x
)))
805 (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x
)
806 ;; Intervals intersect. Let's compute the intersection
807 ;; and the difference.
808 (multiple-value-bind (lo left-lo left-hi
)
809 (cond (x-lo-in-y (values x-lo y-lo
(opposite-bound x-lo
)))
810 (y-lo-in-x (values y-lo x-lo
(opposite-bound y-lo
))))
811 (multiple-value-bind (hi right-lo right-hi
)
813 (values x-hi
(opposite-bound x-hi
) y-hi
))
815 (values y-hi
(opposite-bound y-hi
) x-hi
)))
816 (values (make-interval :low lo
:high hi
)
817 (list (make-interval :low left-lo
819 (make-interval :low right-lo
822 (values nil
(list x y
))))))))
824 ;;; If intervals X and Y intersect, return a new interval that is the
825 ;;; union of the two. If they do not intersect, return NIL.
826 (defun interval-merge-pair (x y
)
827 (declare (type interval x y
))
828 ;; If x and y intersect or are adjacent, create the union.
829 ;; Otherwise return nil
830 (when (or (interval-intersect-p x y
)
831 (interval-adjacent-p x y
))
832 (flet ((select-bound (x1 x2 min-op max-op
)
833 (let ((x1-val (type-bound-number x1
))
834 (x2-val (type-bound-number x2
)))
836 ;; Both bounds are finite. Select the right one.
837 (cond ((funcall min-op x1-val x2-val
)
838 ;; x1 is definitely better.
840 ((funcall max-op x1-val x2-val
)
841 ;; x2 is definitely better.
844 ;; Bounds are equal. Select either
845 ;; value and make it open only if
847 (set-bound x1-val
(and (consp x1
) (consp x2
))))))
849 ;; At least one bound is not finite. The
850 ;; non-finite bound always wins.
852 (let* ((x-lo (copy-interval-limit (interval-low x
)))
853 (x-hi (copy-interval-limit (interval-high x
)))
854 (y-lo (copy-interval-limit (interval-low y
)))
855 (y-hi (copy-interval-limit (interval-high y
))))
856 (make-interval :low
(select-bound x-lo y-lo
#'< #'>)
857 :high
(select-bound x-hi y-hi
#'> #'<))))))
859 ;;; return the minimal interval, containing X and Y
860 (defun interval-approximate-union (x y
)
861 (cond ((interval-merge-pair x y
))
863 (make-interval :low
(copy-interval-limit (interval-low x
))
864 :high
(copy-interval-limit (interval-high y
))))
866 (make-interval :low
(copy-interval-limit (interval-low y
))
867 :high
(copy-interval-limit (interval-high x
))))))
869 ;;; basic arithmetic operations on intervals. We probably should do
870 ;;; true interval arithmetic here, but it's complicated because we
871 ;;; have float and integer types and bounds can be open or closed.
873 ;;; the negative of an interval
874 (defun interval-neg (x)
875 (declare (type interval x
))
876 (make-interval :low
(bound-func #'-
(interval-high x
) t
)
877 :high
(bound-func #'-
(interval-low x
) t
)))
879 ;;; Add two intervals.
880 (defun interval-add (x y
)
881 (declare (type interval x y
))
882 (make-interval :low
(bound-binop + (interval-low x
) (interval-low y
))
883 :high
(bound-binop + (interval-high x
) (interval-high y
))))
885 ;;; Subtract two intervals.
886 (defun interval-sub (x y
)
887 (declare (type interval x y
))
888 (make-interval :low
(bound-binop -
(interval-low x
) (interval-high y
))
889 :high
(bound-binop -
(interval-high x
) (interval-low y
))))
891 ;;; Multiply two intervals.
892 (defun interval-mul (x y
)
893 (declare (type interval x y
))
894 (flet ((bound-mul (x y
)
895 (cond ((or (null x
) (null y
))
896 ;; Multiply by infinity is infinity
898 ((or (and (numberp x
) (zerop x
))
899 (and (numberp y
) (zerop y
)))
900 ;; Multiply by closed zero is special. The result
901 ;; is always a closed bound. But don't replace this
902 ;; with zero; we want the multiplication to produce
903 ;; the correct signed zero, if needed. Use SIGNUM
904 ;; to avoid trying to multiply huge bignums with 0.0.
905 (* (signum (type-bound-number x
)) (signum (type-bound-number y
))))
906 ((or (and (floatp x
) (float-infinity-p x
))
907 (and (floatp y
) (float-infinity-p y
)))
908 ;; Infinity times anything is infinity
911 ;; General multiply. The result is open if either is open.
912 (bound-binop * x y
)))))
913 (let ((x-range (interval-range-info x
))
914 (y-range (interval-range-info y
)))
915 (cond ((null x-range
)
916 ;; Split x into two and multiply each separately
917 (destructuring-bind (x- x
+) (interval-split 0 x t t
)
918 (interval-merge-pair (interval-mul x- y
)
919 (interval-mul x
+ y
))))
921 ;; Split y into two and multiply each separately
922 (destructuring-bind (y- y
+) (interval-split 0 y t t
)
923 (interval-merge-pair (interval-mul x y-
)
924 (interval-mul x y
+))))
926 (interval-neg (interval-mul (interval-neg x
) y
)))
928 (interval-neg (interval-mul x
(interval-neg y
))))
929 ((and (eq x-range
'+) (eq y-range
'+))
930 ;; If we are here, X and Y are both positive.
932 :low
(bound-mul (interval-low x
) (interval-low y
))
933 :high
(bound-mul (interval-high x
) (interval-high y
))))
935 (bug "excluded case in INTERVAL-MUL"))))))
937 ;;; Divide two intervals.
938 (defun interval-div (top bot
)
939 (declare (type interval top bot
))
940 (flet ((bound-div (x y y-low-p
)
943 ;; Divide by infinity means result is 0. However,
944 ;; we need to watch out for the sign of the result,
945 ;; to correctly handle signed zeros. We also need
946 ;; to watch out for positive or negative infinity.
947 (if (floatp (type-bound-number x
))
949 (- (float-sign (type-bound-number x
) 0.0))
950 (float-sign (type-bound-number x
) 0.0))
952 ((zerop (type-bound-number y
))
953 ;; Divide by zero means result is infinity
956 (bound-binop / x y
)))))
957 (let ((top-range (interval-range-info top
))
958 (bot-range (interval-range-info bot
)))
959 (cond ((null bot-range
)
960 ;; The denominator contains zero, so anything goes!
963 ;; Denominator is negative so flip the sign, compute the
964 ;; result, and flip it back.
965 (interval-neg (interval-div top
(interval-neg bot
))))
967 ;; Split top into two positive and negative parts, and
968 ;; divide each separately
969 (destructuring-bind (top- top
+) (interval-split 0 top t t
)
970 (or (interval-merge-pair (interval-div top- bot
)
971 (interval-div top
+ bot
))
974 ;; Top is negative so flip the sign, divide, and flip the
975 ;; sign of the result.
976 (interval-neg (interval-div (interval-neg top
) bot
)))
977 ((and (eq top-range
'+) (eq bot-range
'+))
980 :low
(bound-div (interval-low top
) (interval-high bot
) t
)
981 :high
(bound-div (interval-high top
) (interval-low bot
) nil
)))
983 (bug "excluded case in INTERVAL-DIV"))))))
985 ;;; Apply the function F to the interval X. If X = [a, b], then the
986 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
987 ;;; result makes sense. It will if F is monotonic increasing (or, if
988 ;;; the interval is closed, non-decreasing).
990 ;;; (Actually most uses of INTERVAL-FUNC are coercions to float types,
991 ;;; which are not monotonic increasing, so default to calling
992 ;;; BOUND-FUNC with a non-strict argument).
993 (defun interval-func (f x
&optional increasing
)
994 (declare (type function f
)
996 (let ((lo (bound-func f
(interval-low x
) increasing
))
997 (hi (bound-func f
(interval-high x
) increasing
)))
998 (make-interval :low lo
:high hi
)))
1000 ;;; Return T if X < Y. That is every number in the interval X is
1001 ;;; always less than any number in the interval Y.
1002 (defun interval-< (x y
)
1003 (declare (type interval x y
))
1004 ;; X < Y only if X is bounded above, Y is bounded below, and they
1006 (when (and (interval-bounded-p x
'above
)
1007 (interval-bounded-p y
'below
))
1008 ;; Intervals are bounded in the appropriate way. Make sure they
1010 (let ((left (interval-high x
))
1011 (right (interval-low y
)))
1012 (cond ((> (type-bound-number left
)
1013 (type-bound-number right
))
1014 ;; The intervals definitely overlap, so result is NIL.
1016 ((< (type-bound-number left
)
1017 (type-bound-number right
))
1018 ;; The intervals definitely don't touch, so result is T.
1021 ;; Limits are equal. Check for open or closed bounds.
1022 ;; Don't overlap if one or the other are open.
1023 (or (consp left
) (consp right
)))))))
1025 ;;; Return T if X >= Y. That is, every number in the interval X is
1026 ;;; always greater than any number in the interval Y.
1027 (defun interval->= (x y
)
1028 (declare (type interval x y
))
1029 ;; X >= Y if lower bound of X >= upper bound of Y
1030 (when (and (interval-bounded-p x
'below
)
1031 (interval-bounded-p y
'above
))
1032 (>= (type-bound-number (interval-low x
))
1033 (type-bound-number (interval-high y
)))))
1035 ;;; Return T if X = Y.
1036 (defun interval-= (x y
)
1037 (declare (type interval x y
))
1038 (and (interval-bounded-p x
'both
)
1039 (interval-bounded-p y
'both
)
1043 ;; Open intervals cannot be =
1044 (return-from interval-
= nil
))))
1045 ;; Both intervals refer to the same point
1046 (= (bound (interval-high x
)) (bound (interval-low x
))
1047 (bound (interval-high y
)) (bound (interval-low y
))))))
1049 ;;; Return T if X /= Y
1050 (defun interval-/= (x y
)
1051 (not (interval-intersect-p x y
)))
1053 ;;; Return an interval that is the absolute value of X. Thus, if
1054 ;;; X = [-1 10], the result is [0, 10].
1055 (defun interval-abs (x)
1056 (declare (type interval x
))
1057 (case (interval-range-info x
)
1063 (destructuring-bind (x- x
+) (interval-split 0 x t t
)
1064 (interval-merge-pair (interval-neg x-
) x
+)))))
1066 ;;; Compute the square of an interval.
1067 (defun interval-sqr (x)
1068 (declare (type interval x
))
1069 (interval-func (lambda (x) (* x x
)) (interval-abs x
)))
1071 ;;;; numeric DERIVE-TYPE methods
1073 ;;; a utility for defining derive-type methods of integer operations. If
1074 ;;; the types of both X and Y are integer types, then we compute a new
1075 ;;; integer type with bounds determined by FUN when applied to X and Y.
1076 ;;; Otherwise, we use NUMERIC-CONTAGION.
1077 (defun derive-integer-type-aux (x y fun
)
1078 (declare (type function fun
))
1079 (if (and (numeric-type-p x
) (numeric-type-p y
)
1080 (eq (numeric-type-class x
) 'integer
)
1081 (eq (numeric-type-class y
) 'integer
)
1082 (eq (numeric-type-complexp x
) :real
)
1083 (eq (numeric-type-complexp y
) :real
))
1084 (multiple-value-bind (low high
) (funcall fun x y
)
1085 (make-numeric-type :class
'integer
1089 (numeric-contagion x y
)))
1091 (defun derive-integer-type (x y fun
)
1092 (declare (type lvar x y
) (type function fun
))
1093 (let ((x (lvar-type x
))
1095 (derive-integer-type-aux x y fun
)))
1097 ;;; simple utility to flatten a list
1098 (defun flatten-list (x)
1099 (labels ((flatten-and-append (tree list
)
1100 (cond ((null tree
) list
)
1101 ((atom tree
) (cons tree list
))
1102 (t (flatten-and-append
1103 (car tree
) (flatten-and-append (cdr tree
) list
))))))
1104 (flatten-and-append x nil
)))
1106 ;;; Take some type of lvar and massage it so that we get a list of the
1107 ;;; constituent types. If ARG is *EMPTY-TYPE*, return NIL to indicate
1109 (defun prepare-arg-for-derive-type (arg)
1110 (flet ((listify (arg)
1115 (union-type-types arg
))
1118 (unless (eq arg
*empty-type
*)
1119 ;; Make sure all args are some type of numeric-type. For member
1120 ;; types, convert the list of members into a union of equivalent
1121 ;; single-element member-type's.
1122 (let ((new-args nil
))
1123 (dolist (arg (listify arg
))
1124 (if (member-type-p arg
)
1125 ;; Run down the list of members and convert to a list of
1127 (mapc-member-type-members
1129 (push (if (numberp member
)
1130 (make-member-type :members
(list member
))
1134 (push arg new-args
)))
1135 (unless (member *empty-type
* new-args
)
1138 ;;; Convert from the standard type convention for which -0.0 and 0.0
1139 ;;; are equal to an intermediate convention for which they are
1140 ;;; considered different which is more natural for some of the
1142 (defun convert-numeric-type (type)
1143 (declare (type numeric-type type
))
1144 ;;; Only convert real float interval delimiters types.
1145 (if (eq (numeric-type-complexp type
) :real
)
1146 (let* ((lo (numeric-type-low type
))
1147 (lo-val (type-bound-number lo
))
1148 (lo-float-zero-p (and lo
(floatp lo-val
) (= lo-val
0.0)))
1149 (hi (numeric-type-high type
))
1150 (hi-val (type-bound-number hi
))
1151 (hi-float-zero-p (and hi
(floatp hi-val
) (= hi-val
0.0))))
1152 (if (or lo-float-zero-p hi-float-zero-p
)
1154 :class
(numeric-type-class type
)
1155 :format
(numeric-type-format type
)
1157 :low
(if lo-float-zero-p
1159 (list (float 0.0 lo-val
))
1160 (float (load-time-value (make-unportable-float :single-float-negative-zero
)) lo-val
))
1162 :high
(if hi-float-zero-p
1164 (list (float (load-time-value (make-unportable-float :single-float-negative-zero
)) hi-val
))
1171 ;;; Convert back from the intermediate convention for which -0.0 and
1172 ;;; 0.0 are considered different to the standard type convention for
1173 ;;; which and equal.
1174 (defun convert-back-numeric-type (type)
1175 (declare (type numeric-type type
))
1176 ;;; Only convert real float interval delimiters types.
1177 (if (eq (numeric-type-complexp type
) :real
)
1178 (let* ((lo (numeric-type-low type
))
1179 (lo-val (type-bound-number lo
))
1181 (and lo
(floatp lo-val
) (= lo-val
0.0)
1182 (float-sign lo-val
)))
1183 (hi (numeric-type-high type
))
1184 (hi-val (type-bound-number hi
))
1186 (and hi
(floatp hi-val
) (= hi-val
0.0)
1187 (float-sign hi-val
))))
1189 ;; (float +0.0 +0.0) => (member 0.0)
1190 ;; (float -0.0 -0.0) => (member -0.0)
1191 ((and lo-float-zero-p hi-float-zero-p
)
1192 ;; shouldn't have exclusive bounds here..
1193 (aver (and (not (consp lo
)) (not (consp hi
))))
1194 (if (= lo-float-zero-p hi-float-zero-p
)
1195 ;; (float +0.0 +0.0) => (member 0.0)
1196 ;; (float -0.0 -0.0) => (member -0.0)
1197 (specifier-type `(member ,lo-val
))
1198 ;; (float -0.0 +0.0) => (float 0.0 0.0)
1199 ;; (float +0.0 -0.0) => (float 0.0 0.0)
1200 (make-numeric-type :class
(numeric-type-class type
)
1201 :format
(numeric-type-format type
)
1207 ;; (float -0.0 x) => (float 0.0 x)
1208 ((and (not (consp lo
)) (minusp lo-float-zero-p
))
1209 (make-numeric-type :class
(numeric-type-class type
)
1210 :format
(numeric-type-format type
)
1212 :low
(float 0.0 lo-val
)
1214 ;; (float (+0.0) x) => (float (0.0) x)
1215 ((and (consp lo
) (plusp lo-float-zero-p
))
1216 (make-numeric-type :class
(numeric-type-class type
)
1217 :format
(numeric-type-format type
)
1219 :low
(list (float 0.0 lo-val
))
1222 ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
1223 ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
1224 (list (make-member-type :members
(list (float 0.0 lo-val
)))
1225 (make-numeric-type :class
(numeric-type-class type
)
1226 :format
(numeric-type-format type
)
1228 :low
(list (float 0.0 lo-val
))
1232 ;; (float x +0.0) => (float x 0.0)
1233 ((and (not (consp hi
)) (plusp hi-float-zero-p
))
1234 (make-numeric-type :class
(numeric-type-class type
)
1235 :format
(numeric-type-format type
)
1238 :high
(float 0.0 hi-val
)))
1239 ;; (float x (-0.0)) => (float x (0.0))
1240 ((and (consp hi
) (minusp hi-float-zero-p
))
1241 (make-numeric-type :class
(numeric-type-class type
)
1242 :format
(numeric-type-format type
)
1245 :high
(list (float 0.0 hi-val
))))
1247 ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
1248 ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
1249 (list (make-member-type :members
(list (float (load-time-value (make-unportable-float :single-float-negative-zero
)) hi-val
)))
1250 (make-numeric-type :class
(numeric-type-class type
)
1251 :format
(numeric-type-format type
)
1254 :high
(list (float 0.0 hi-val
)))))))
1260 ;;; Convert back a possible list of numeric types.
1261 (defun convert-back-numeric-type-list (type-list)
1264 (let ((results '()))
1265 (dolist (type type-list
)
1266 (if (numeric-type-p type
)
1267 (let ((result (convert-back-numeric-type type
)))
1269 (setf results
(append results result
))
1270 (push result results
)))
1271 (push type results
)))
1274 (convert-back-numeric-type type-list
))
1276 (convert-back-numeric-type-list (union-type-types type-list
)))
1280 ;;; Take a list of types and return a canonical type specifier,
1281 ;;; combining any MEMBER types together. If both positive and negative
1282 ;;; MEMBER types are present they are converted to a float type.
1283 ;;; XXX This would be far simpler if the type-union methods could handle
1284 ;;; member/number unions.
1286 ;;; If we're about to generate an overly complex union of numeric types, start
1287 ;;; collapse the ranges together.
1289 ;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
1290 ;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
1291 ;;; invoked always, instead of in the compiler, invoked only during some type
1293 (defvar *derived-numeric-union-complexity-limit
* 6)
1295 (defun make-derived-union-type (type-list)
1296 (let ((xset (alloc-xset))
1299 (numeric-type *empty-type
*))
1300 (dolist (type type-list
)
1301 (cond ((member-type-p type
)
1302 (mapc-member-type-members
1304 (if (fp-zero-p member
)
1305 (unless (member member fp-zeroes
)
1306 (pushnew member fp-zeroes
))
1307 (add-to-xset member xset
)))
1309 ((numeric-type-p type
)
1310 (let ((*approximate-numeric-unions
*
1311 (when (and (union-type-p numeric-type
)
1312 (nthcdr *derived-numeric-union-complexity-limit
*
1313 (union-type-types numeric-type
)))
1315 (setf numeric-type
(type-union type numeric-type
))))
1317 (push type misc-types
))))
1318 (if (and (xset-empty-p xset
) (not fp-zeroes
))
1319 (apply #'type-union numeric-type misc-types
)
1320 (apply #'type-union
(make-member-type :xset xset
:fp-zeroes fp-zeroes
)
1321 numeric-type misc-types
))))
1323 ;;; Convert a member type with a single member to a numeric type.
1324 (defun convert-member-type (arg)
1325 (let* ((members (member-type-members arg
))
1326 (member (first members
))
1327 (member-type (type-of member
)))
1328 (aver (not (rest members
)))
1329 (specifier-type (cond ((typep member
'integer
)
1330 `(integer ,member
,member
))
1331 ((memq member-type
'(short-float single-float
1332 double-float long-float
))
1333 `(,member-type
,member
,member
))
1337 ;;; This is used in defoptimizers for computing the resulting type of
1340 ;;; Given the lvar ARG, derive the resulting type using the
1341 ;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
1342 ;;; "atomic" lvar type like numeric-type or member-type (containing
1343 ;;; just one element). It should return the resulting type, which can
1344 ;;; be a list of types.
1346 ;;; For the case of member types, if a MEMBER-FUN is given it is
1347 ;;; called to compute the result otherwise the member type is first
1348 ;;; converted to a numeric type and the DERIVE-FUN is called.
1349 (defun one-arg-derive-type (arg derive-fun member-fun
1350 &optional
(convert-type t
))
1351 (declare (type function derive-fun
)
1352 (type (or null function
) member-fun
))
1353 (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg
))))
1359 (with-float-traps-masked
1360 (:underflow
:overflow
:divide-by-zero
)
1362 `(eql ,(funcall member-fun
1363 (first (member-type-members x
))))))
1364 ;; Otherwise convert to a numeric type.
1365 (let ((result-type-list
1366 (funcall derive-fun
(convert-member-type x
))))
1368 (convert-back-numeric-type-list result-type-list
)
1369 result-type-list
))))
1372 (convert-back-numeric-type-list
1373 (funcall derive-fun
(convert-numeric-type x
)))
1374 (funcall derive-fun x
)))
1376 *universal-type
*))))
1377 ;; Run down the list of args and derive the type of each one,
1378 ;; saving all of the results in a list.
1379 (let ((results nil
))
1380 (dolist (arg arg-list
)
1381 (let ((result (deriver arg
)))
1383 (setf results
(append results result
))
1384 (push result results
))))
1386 (make-derived-union-type results
)
1387 (first results
)))))))
1389 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
1390 ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
1391 ;;; original args and a third which is T to indicate if the two args
1392 ;;; really represent the same lvar. This is useful for deriving the
1393 ;;; type of things like (* x x), which should always be positive. If
1394 ;;; we didn't do this, we wouldn't be able to tell.
1395 (defun two-arg-derive-type (arg1 arg2 derive-fun fun
1396 &optional
(convert-type t
))
1397 (declare (type function derive-fun fun
))
1398 (flet ((deriver (x y same-arg
)
1399 (cond ((and (member-type-p x
) (member-type-p y
))
1400 (let* ((x (first (member-type-members x
)))
1401 (y (first (member-type-members y
)))
1402 (result (ignore-errors
1403 (with-float-traps-masked
1404 (:underflow
:overflow
:divide-by-zero
1406 (funcall fun x y
)))))
1407 (cond ((null result
) *empty-type
*)
1408 ((and (floatp result
) (float-nan-p result
))
1409 (make-numeric-type :class
'float
1410 :format
(type-of result
)
1413 (specifier-type `(eql ,result
))))))
1414 ((and (member-type-p x
) (numeric-type-p y
))
1415 (let* ((x (convert-member-type x
))
1416 (y (if convert-type
(convert-numeric-type y
) y
))
1417 (result (funcall derive-fun x y same-arg
)))
1419 (convert-back-numeric-type-list result
)
1421 ((and (numeric-type-p x
) (member-type-p y
))
1422 (let* ((x (if convert-type
(convert-numeric-type x
) x
))
1423 (y (convert-member-type y
))
1424 (result (funcall derive-fun x y same-arg
)))
1426 (convert-back-numeric-type-list result
)
1428 ((and (numeric-type-p x
) (numeric-type-p y
))
1429 (let* ((x (if convert-type
(convert-numeric-type x
) x
))
1430 (y (if convert-type
(convert-numeric-type y
) y
))
1431 (result (funcall derive-fun x y same-arg
)))
1433 (convert-back-numeric-type-list result
)
1436 *universal-type
*))))
1437 (let ((same-arg (same-leaf-ref-p arg1 arg2
))
1438 (a1 (prepare-arg-for-derive-type (lvar-type arg1
)))
1439 (a2 (prepare-arg-for-derive-type (lvar-type arg2
))))
1441 (let ((results nil
))
1443 ;; Since the args are the same LVARs, just run down the
1446 (let ((result (deriver x x same-arg
)))
1448 (setf results
(append results result
))
1449 (push result results
))))
1450 ;; Try all pairwise combinations.
1453 (let ((result (or (deriver x y same-arg
)
1454 (numeric-contagion x y
))))
1456 (setf results
(append results result
))
1457 (push result results
))))))
1459 (make-derived-union-type results
)
1460 (first results
)))))))
1462 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1464 (defoptimizer (+ derive-type
) ((x y
))
1465 (derive-integer-type
1472 (values (frob (numeric-type-low x
) (numeric-type-low y
))
1473 (frob (numeric-type-high x
) (numeric-type-high y
)))))))
1475 (defoptimizer (- derive-type
) ((x y
))
1476 (derive-integer-type
1483 (values (frob (numeric-type-low x
) (numeric-type-high y
))
1484 (frob (numeric-type-high x
) (numeric-type-low y
)))))))
1486 (defoptimizer (* derive-type
) ((x y
))
1487 (derive-integer-type
1490 (let ((x-low (numeric-type-low x
))
1491 (x-high (numeric-type-high x
))
1492 (y-low (numeric-type-low y
))
1493 (y-high (numeric-type-high y
)))
1494 (cond ((not (and x-low y-low
))
1496 ((or (minusp x-low
) (minusp y-low
))
1497 (if (and x-high y-high
)
1498 (let ((max (* (max (abs x-low
) (abs x-high
))
1499 (max (abs y-low
) (abs y-high
)))))
1500 (values (- max
) max
))
1503 (values (* x-low y-low
)
1504 (if (and x-high y-high
)
1508 (defoptimizer (/ derive-type
) ((x y
))
1509 (numeric-contagion (lvar-type x
) (lvar-type y
)))
1513 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1515 (defun +-derive-type-aux
(x y same-arg
)
1516 (if (and (numeric-type-real-p x
)
1517 (numeric-type-real-p y
))
1520 (let ((x-int (numeric-type->interval x
)))
1521 (interval-add x-int x-int
))
1522 (interval-add (numeric-type->interval x
)
1523 (numeric-type->interval y
))))
1524 (result-type (numeric-contagion x y
)))
1525 ;; If the result type is a float, we need to be sure to coerce
1526 ;; the bounds into the correct type.
1527 (when (eq (numeric-type-class result-type
) 'float
)
1528 (setf result
(interval-func
1530 (coerce-for-bound x
(or (numeric-type-format result-type
)
1534 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1535 (eq (numeric-type-class y
) 'integer
))
1536 ;; The sum of integers is always an integer.
1538 (numeric-type-class result-type
))
1539 :format
(numeric-type-format result-type
)
1540 :low
(interval-low result
)
1541 :high
(interval-high result
)))
1542 ;; general contagion
1543 (numeric-contagion x y
)))
1545 (defoptimizer (+ derive-type
) ((x y
))
1546 (two-arg-derive-type x y
#'+-derive-type-aux
#'+))
1548 (defun --derive-type-aux (x y same-arg
)
1549 (if (and (numeric-type-real-p x
)
1550 (numeric-type-real-p y
))
1552 ;; (- X X) is always 0.
1554 (make-interval :low
0 :high
0)
1555 (interval-sub (numeric-type->interval x
)
1556 (numeric-type->interval y
))))
1557 (result-type (numeric-contagion x y
)))
1558 ;; If the result type is a float, we need to be sure to coerce
1559 ;; the bounds into the correct type.
1560 (when (eq (numeric-type-class result-type
) 'float
)
1561 (setf result
(interval-func
1563 (coerce-for-bound x
(or (numeric-type-format result-type
)
1567 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1568 (eq (numeric-type-class y
) 'integer
))
1569 ;; The difference of integers is always an integer.
1571 (numeric-type-class result-type
))
1572 :format
(numeric-type-format result-type
)
1573 :low
(interval-low result
)
1574 :high
(interval-high result
)))
1575 ;; general contagion
1576 (numeric-contagion x y
)))
1578 (defoptimizer (- derive-type
) ((x y
))
1579 (two-arg-derive-type x y
#'--derive-type-aux
#'-
))
1581 (defun *-derive-type-aux
(x y same-arg
)
1582 (if (and (numeric-type-real-p x
)
1583 (numeric-type-real-p y
))
1585 ;; (* X X) is always positive, so take care to do it right.
1587 (interval-sqr (numeric-type->interval x
))
1588 (interval-mul (numeric-type->interval x
)
1589 (numeric-type->interval y
))))
1590 (result-type (numeric-contagion x y
)))
1591 ;; If the result type is a float, we need to be sure to coerce
1592 ;; the bounds into the correct type.
1593 (when (eq (numeric-type-class result-type
) 'float
)
1594 (setf result
(interval-func
1596 (coerce-for-bound x
(or (numeric-type-format result-type
)
1600 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1601 (eq (numeric-type-class y
) 'integer
))
1602 ;; The product of integers is always an integer.
1604 (numeric-type-class result-type
))
1605 :format
(numeric-type-format result-type
)
1606 :low
(interval-low result
)
1607 :high
(interval-high result
)))
1608 (numeric-contagion x y
)))
1610 (defoptimizer (* derive-type
) ((x y
))
1611 (two-arg-derive-type x y
#'*-derive-type-aux
#'*))
1613 (defun /-derive-type-aux
(x y same-arg
)
1614 (if (and (numeric-type-real-p x
)
1615 (numeric-type-real-p y
))
1617 ;; (/ X X) is always 1, except if X can contain 0. In
1618 ;; that case, we shouldn't optimize the division away
1619 ;; because we want 0/0 to signal an error.
1621 (not (interval-contains-p
1622 0 (interval-closure (numeric-type->interval y
)))))
1623 (make-interval :low
1 :high
1)
1624 (interval-div (numeric-type->interval x
)
1625 (numeric-type->interval y
))))
1626 (result-type (numeric-contagion x y
)))
1627 ;; If the result type is a float, we need to be sure to coerce
1628 ;; the bounds into the correct type.
1629 (when (eq (numeric-type-class result-type
) 'float
)
1630 (setf result
(interval-func
1632 (coerce-for-bound x
(or (numeric-type-format result-type
)
1635 (make-numeric-type :class
(numeric-type-class result-type
)
1636 :format
(numeric-type-format result-type
)
1637 :low
(interval-low result
)
1638 :high
(interval-high result
)))
1639 (numeric-contagion x y
)))
1641 (defoptimizer (/ derive-type
) ((x y
))
1642 (two-arg-derive-type x y
#'/-derive-type-aux
#'/))
1646 (defun ash-derive-type-aux (n-type shift same-arg
)
1647 (declare (ignore same-arg
))
1648 ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
1649 ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
1650 ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
1651 ;; two bignums yielding zero) and it's hard to avoid that
1652 ;; calculation in here.
1653 #+(and cmu sb-xc-host
)
1654 (when (and (or (typep (numeric-type-low n-type
) 'bignum
)
1655 (typep (numeric-type-high n-type
) 'bignum
))
1656 (or (typep (numeric-type-low shift
) 'bignum
)
1657 (typep (numeric-type-high shift
) 'bignum
)))
1658 (return-from ash-derive-type-aux
*universal-type
*))
1659 (flet ((ash-outer (n s
)
1660 (when (and (fixnump s
)
1662 (> s sb
!xc
:most-negative-fixnum
))
1664 ;; KLUDGE: The bare 64's here should be related to
1665 ;; symbolic machine word size values somehow.
1668 (if (and (fixnump s
)
1669 (> s sb
!xc
:most-negative-fixnum
))
1671 (if (minusp n
) -
1 0))))
1672 (or (and (csubtypep n-type
(specifier-type 'integer
))
1673 (csubtypep shift
(specifier-type 'integer
))
1674 (let ((n-low (numeric-type-low n-type
))
1675 (n-high (numeric-type-high n-type
))
1676 (s-low (numeric-type-low shift
))
1677 (s-high (numeric-type-high shift
)))
1678 (make-numeric-type :class
'integer
:complexp
:real
1681 (ash-outer n-low s-high
)
1682 (ash-inner n-low s-low
)))
1685 (ash-inner n-high s-low
)
1686 (ash-outer n-high s-high
))))))
1689 (defoptimizer (ash derive-type
) ((n shift
))
1690 (two-arg-derive-type n shift
#'ash-derive-type-aux
#'ash
))
1692 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1693 (macrolet ((frob (fun)
1694 `#'(lambda (type type2
)
1695 (declare (ignore type2
))
1696 (let ((lo (numeric-type-low type
))
1697 (hi (numeric-type-high type
)))
1698 (values (if hi
(,fun hi
) nil
) (if lo
(,fun lo
) nil
))))))
1700 (defoptimizer (%negate derive-type
) ((num))
1701 (derive-integer-type num num
(frob -
))))
1703 (defun lognot-derive-type-aux (int)
1704 (derive-integer-type-aux int int
1705 (lambda (type type2
)
1706 (declare (ignore type2
))
1707 (let ((lo (numeric-type-low type
))
1708 (hi (numeric-type-high type
)))
1709 (values (if hi
(lognot hi
) nil
)
1710 (if lo
(lognot lo
) nil
)
1711 (numeric-type-class type
)
1712 (numeric-type-format type
))))))
1714 (defoptimizer (lognot derive-type
) ((int))
1715 (lognot-derive-type-aux (lvar-type int
)))
1717 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1718 (defoptimizer (%negate derive-type
) ((num))
1719 (flet ((negate-bound (b)
1721 (set-bound (- (type-bound-number b
))
1723 (one-arg-derive-type num
1725 (modified-numeric-type
1727 :low
(negate-bound (numeric-type-high type
))
1728 :high
(negate-bound (numeric-type-low type
))))
1731 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1732 (defoptimizer (abs derive-type
) ((num))
1733 (let ((type (lvar-type num
)))
1734 (if (and (numeric-type-p type
)
1735 (eq (numeric-type-class type
) 'integer
)
1736 (eq (numeric-type-complexp type
) :real
))
1737 (let ((lo (numeric-type-low type
))
1738 (hi (numeric-type-high type
)))
1739 (make-numeric-type :class
'integer
:complexp
:real
1740 :low
(cond ((and hi
(minusp hi
))
1746 :high
(if (and hi lo
)
1747 (max (abs hi
) (abs lo
))
1749 (numeric-contagion type type
))))
1751 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1752 (defun abs-derive-type-aux (type)
1753 (cond ((eq (numeric-type-complexp type
) :complex
)
1754 ;; The absolute value of a complex number is always a
1755 ;; non-negative float.
1756 (let* ((format (case (numeric-type-class type
)
1757 ((integer rational
) 'single-float
)
1758 (t (numeric-type-format type
))))
1759 (bound-format (or format
'float
)))
1760 (make-numeric-type :class
'float
1763 :low
(coerce 0 bound-format
)
1766 ;; The absolute value of a real number is a non-negative real
1767 ;; of the same type.
1768 (let* ((abs-bnd (interval-abs (numeric-type->interval type
)))
1769 (class (numeric-type-class type
))
1770 (format (numeric-type-format type
))
1771 (bound-type (or format class
'real
)))
1776 :low
(coerce-and-truncate-floats (interval-low abs-bnd
) bound-type
)
1777 :high
(coerce-and-truncate-floats
1778 (interval-high abs-bnd
) bound-type
))))))
1780 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1781 (defoptimizer (abs derive-type
) ((num))
1782 (one-arg-derive-type num
#'abs-derive-type-aux
#'abs
))
1784 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1785 (defoptimizer (truncate derive-type
) ((number divisor
))
1786 (let ((number-type (lvar-type number
))
1787 (divisor-type (lvar-type divisor
))
1788 (integer-type (specifier-type 'integer
)))
1789 (if (and (numeric-type-p number-type
)
1790 (csubtypep number-type integer-type
)
1791 (numeric-type-p divisor-type
)
1792 (csubtypep divisor-type integer-type
))
1793 (let ((number-low (numeric-type-low number-type
))
1794 (number-high (numeric-type-high number-type
))
1795 (divisor-low (numeric-type-low divisor-type
))
1796 (divisor-high (numeric-type-high divisor-type
)))
1797 (values-specifier-type
1798 `(values ,(integer-truncate-derive-type number-low number-high
1799 divisor-low divisor-high
)
1800 ,(integer-rem-derive-type number-low number-high
1801 divisor-low divisor-high
))))
1804 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1807 (defun rem-result-type (number-type divisor-type
)
1808 ;; Figure out what the remainder type is. The remainder is an
1809 ;; integer if both args are integers; a rational if both args are
1810 ;; rational; and a float otherwise.
1811 (cond ((and (csubtypep number-type
(specifier-type 'integer
))
1812 (csubtypep divisor-type
(specifier-type 'integer
)))
1814 ((and (csubtypep number-type
(specifier-type 'rational
))
1815 (csubtypep divisor-type
(specifier-type 'rational
)))
1817 ((and (csubtypep number-type
(specifier-type 'float
))
1818 (csubtypep divisor-type
(specifier-type 'float
)))
1819 ;; Both are floats so the result is also a float, of
1820 ;; the largest type.
1821 (or (float-format-max (numeric-type-format number-type
)
1822 (numeric-type-format divisor-type
))
1824 ((and (csubtypep number-type
(specifier-type 'float
))
1825 (csubtypep divisor-type
(specifier-type 'rational
)))
1826 ;; One of the arguments is a float and the other is a
1827 ;; rational. The remainder is a float of the same
1829 (or (numeric-type-format number-type
) 'float
))
1830 ((and (csubtypep divisor-type
(specifier-type 'float
))
1831 (csubtypep number-type
(specifier-type 'rational
)))
1832 ;; One of the arguments is a float and the other is a
1833 ;; rational. The remainder is a float of the same
1835 (or (numeric-type-format divisor-type
) 'float
))
1837 ;; Some unhandled combination. This usually means both args
1838 ;; are REAL so the result is a REAL.
1841 (defun truncate-derive-type-quot (number-type divisor-type
)
1842 (let* ((rem-type (rem-result-type number-type divisor-type
))
1843 (number-interval (numeric-type->interval number-type
))
1844 (divisor-interval (numeric-type->interval divisor-type
)))
1845 ;;(declare (type (member '(integer rational float)) rem-type))
1846 ;; We have real numbers now.
1847 (cond ((eq rem-type
'integer
)
1848 ;; Since the remainder type is INTEGER, both args are
1850 (let* ((res (integer-truncate-derive-type
1851 (interval-low number-interval
)
1852 (interval-high number-interval
)
1853 (interval-low divisor-interval
)
1854 (interval-high divisor-interval
))))
1855 (specifier-type (if (listp res
) res
'integer
))))
1857 (let ((quot (truncate-quotient-bound
1858 (interval-div number-interval
1859 divisor-interval
))))
1860 (specifier-type `(integer ,(or (interval-low quot
) '*)
1861 ,(or (interval-high quot
) '*))))))))
1863 (defun truncate-derive-type-rem (number-type divisor-type
)
1864 (let* ((rem-type (rem-result-type number-type divisor-type
))
1865 (number-interval (numeric-type->interval number-type
))
1866 (divisor-interval (numeric-type->interval divisor-type
))
1867 (rem (truncate-rem-bound number-interval divisor-interval
)))
1868 ;;(declare (type (member '(integer rational float)) rem-type))
1869 ;; We have real numbers now.
1870 (cond ((eq rem-type
'integer
)
1871 ;; Since the remainder type is INTEGER, both args are
1873 (specifier-type `(,rem-type
,(or (interval-low rem
) '*)
1874 ,(or (interval-high rem
) '*))))
1876 (multiple-value-bind (class format
)
1879 (values 'integer nil
))
1881 (values 'rational nil
))
1882 ((or single-float double-float
#!+long-float long-float
)
1883 (values 'float rem-type
))
1885 (values 'float nil
))
1888 (when (member rem-type
'(float single-float double-float
1889 #!+long-float long-float
))
1890 (setf rem
(interval-func #'(lambda (x)
1891 (coerce-for-bound x rem-type
))
1893 (make-numeric-type :class class
1895 :low
(interval-low rem
)
1896 :high
(interval-high rem
)))))))
1898 (defun truncate-derive-type-quot-aux (num div same-arg
)
1899 (declare (ignore same-arg
))
1900 (if (and (numeric-type-real-p num
)
1901 (numeric-type-real-p div
))
1902 (truncate-derive-type-quot num div
)
1905 (defun truncate-derive-type-rem-aux (num div same-arg
)
1906 (declare (ignore same-arg
))
1907 (if (and (numeric-type-real-p num
)
1908 (numeric-type-real-p div
))
1909 (truncate-derive-type-rem num div
)
1912 (defoptimizer (truncate derive-type
) ((number divisor
))
1913 (let ((quot (two-arg-derive-type number divisor
1914 #'truncate-derive-type-quot-aux
#'truncate
))
1915 (rem (two-arg-derive-type number divisor
1916 #'truncate-derive-type-rem-aux
#'rem
)))
1917 (when (and quot rem
)
1918 (make-values-type :required
(list quot rem
)))))
1920 (defun ftruncate-derive-type-quot (number-type divisor-type
)
1921 ;; The bounds are the same as for truncate. However, the first
1922 ;; result is a float of some type. We need to determine what that
1923 ;; type is. Basically it's the more contagious of the two types.
1924 (let ((q-type (truncate-derive-type-quot number-type divisor-type
))
1925 (res-type (numeric-contagion number-type divisor-type
)))
1926 (make-numeric-type :class
'float
1927 :format
(numeric-type-format res-type
)
1928 :low
(numeric-type-low q-type
)
1929 :high
(numeric-type-high q-type
))))
1931 (defun ftruncate-derive-type-quot-aux (n d same-arg
)
1932 (declare (ignore same-arg
))
1933 (if (and (numeric-type-real-p n
)
1934 (numeric-type-real-p d
))
1935 (ftruncate-derive-type-quot n d
)
1938 (defoptimizer (ftruncate derive-type
) ((number divisor
))
1940 (two-arg-derive-type number divisor
1941 #'ftruncate-derive-type-quot-aux
#'ftruncate
))
1942 (rem (two-arg-derive-type number divisor
1943 #'truncate-derive-type-rem-aux
#'rem
)))
1944 (when (and quot rem
)
1945 (make-values-type :required
(list quot rem
)))))
1947 (defun %unary-truncate-derive-type-aux
(number)
1948 (truncate-derive-type-quot number
(specifier-type '(integer 1 1))))
1950 (defoptimizer (%unary-truncate derive-type
) ((number))
1951 (one-arg-derive-type number
1952 #'%unary-truncate-derive-type-aux
1955 (defoptimizer (%unary-truncate
/single-float derive-type
) ((number))
1956 (one-arg-derive-type number
1957 #'%unary-truncate-derive-type-aux
1960 (defoptimizer (%unary-truncate
/double-float derive-type
) ((number))
1961 (one-arg-derive-type number
1962 #'%unary-truncate-derive-type-aux
1965 (defoptimizer (%unary-ftruncate derive-type
) ((number))
1966 (let ((divisor (specifier-type '(integer 1 1))))
1967 (one-arg-derive-type number
1969 (ftruncate-derive-type-quot-aux n divisor nil
))
1970 #'%unary-ftruncate
)))
1972 (defoptimizer (%unary-round derive-type
) ((number))
1973 (one-arg-derive-type number
1976 (unless (numeric-type-real-p n
)
1977 (return *empty-type
*))
1978 (let* ((interval (numeric-type->interval n
))
1979 (low (interval-low interval
))
1980 (high (interval-high interval
)))
1982 (setf low
(car low
)))
1984 (setf high
(car high
)))
1994 ;;; Define optimizers for FLOOR and CEILING.
1996 ((def (name q-name r-name
)
1997 (let ((q-aux (symbolicate q-name
"-AUX"))
1998 (r-aux (symbolicate r-name
"-AUX")))
2000 ;; Compute type of quotient (first) result.
2001 (defun ,q-aux
(number-type divisor-type
)
2002 (let* ((number-interval
2003 (numeric-type->interval number-type
))
2005 (numeric-type->interval divisor-type
))
2006 (quot (,q-name
(interval-div number-interval
2007 divisor-interval
))))
2008 (specifier-type `(integer ,(or (interval-low quot
) '*)
2009 ,(or (interval-high quot
) '*)))))
2010 ;; Compute type of remainder.
2011 (defun ,r-aux
(number-type divisor-type
)
2012 (let* ((divisor-interval
2013 (numeric-type->interval divisor-type
))
2014 (rem (,r-name divisor-interval
))
2015 (result-type (rem-result-type number-type divisor-type
)))
2016 (multiple-value-bind (class format
)
2019 (values 'integer nil
))
2021 (values 'rational nil
))
2022 ((or single-float double-float
#!+long-float long-float
)
2023 (values 'float result-type
))
2025 (values 'float nil
))
2028 (when (member result-type
'(float single-float double-float
2029 #!+long-float long-float
))
2030 ;; Make sure that the limits on the interval have
2032 (setf rem
(interval-func (lambda (x)
2033 (coerce-for-bound x result-type
))
2035 (make-numeric-type :class class
2037 :low
(interval-low rem
)
2038 :high
(interval-high rem
)))))
2039 ;; the optimizer itself
2040 (defoptimizer (,name derive-type
) ((number divisor
))
2041 (flet ((derive-q (n d same-arg
)
2042 (declare (ignore same-arg
))
2043 (if (and (numeric-type-real-p n
)
2044 (numeric-type-real-p d
))
2047 (derive-r (n d same-arg
)
2048 (declare (ignore same-arg
))
2049 (if (and (numeric-type-real-p n
)
2050 (numeric-type-real-p d
))
2053 (let ((quot (two-arg-derive-type
2054 number divisor
#'derive-q
#',name
))
2055 (rem (two-arg-derive-type
2056 number divisor
#'derive-r
#'mod
)))
2057 (when (and quot rem
)
2058 (make-values-type :required
(list quot rem
))))))))))
2060 (def floor floor-quotient-bound floor-rem-bound
)
2061 (def ceiling ceiling-quotient-bound ceiling-rem-bound
))
2063 ;;; Define optimizers for FFLOOR and FCEILING
2064 (macrolet ((def (name q-name r-name
)
2065 (let ((q-aux (symbolicate "F" q-name
"-AUX"))
2066 (r-aux (symbolicate r-name
"-AUX")))
2068 ;; Compute type of quotient (first) result.
2069 (defun ,q-aux
(number-type divisor-type
)
2070 (let* ((number-interval
2071 (numeric-type->interval number-type
))
2073 (numeric-type->interval divisor-type
))
2074 (quot (,q-name
(interval-div number-interval
2076 (res-type (numeric-contagion number-type
2079 :class
(numeric-type-class res-type
)
2080 :format
(numeric-type-format res-type
)
2081 :low
(interval-low quot
)
2082 :high
(interval-high quot
))))
2084 (defoptimizer (,name derive-type
) ((number divisor
))
2085 (flet ((derive-q (n d same-arg
)
2086 (declare (ignore same-arg
))
2087 (if (and (numeric-type-real-p n
)
2088 (numeric-type-real-p d
))
2091 (derive-r (n d same-arg
)
2092 (declare (ignore same-arg
))
2093 (if (and (numeric-type-real-p n
)
2094 (numeric-type-real-p d
))
2097 (let ((quot (two-arg-derive-type
2098 number divisor
#'derive-q
#',name
))
2099 (rem (two-arg-derive-type
2100 number divisor
#'derive-r
#'mod
)))
2101 (when (and quot rem
)
2102 (make-values-type :required
(list quot rem
))))))))))
2104 (def ffloor floor-quotient-bound floor-rem-bound
)
2105 (def fceiling ceiling-quotient-bound ceiling-rem-bound
))
2107 ;;; functions to compute the bounds on the quotient and remainder for
2108 ;;; the FLOOR function
2109 (defun floor-quotient-bound (quot)
2110 ;; Take the floor of the quotient and then massage it into what we
2112 (let ((lo (interval-low quot
))
2113 (hi (interval-high quot
)))
2114 ;; Take the floor of the lower bound. The result is always a
2115 ;; closed lower bound.
2117 (floor (type-bound-number lo
))
2119 ;; For the upper bound, we need to be careful.
2122 ;; An open bound. We need to be careful here because
2123 ;; the floor of '(10.0) is 9, but the floor of
2125 (multiple-value-bind (q r
) (floor (first hi
))
2130 ;; A closed bound, so the answer is obvious.
2134 (make-interval :low lo
:high hi
)))
2135 (defun floor-rem-bound (div)
2136 ;; The remainder depends only on the divisor. Try to get the
2137 ;; correct sign for the remainder if we can.
2138 (case (interval-range-info div
)
2140 ;; The divisor is always positive.
2141 (let ((rem (interval-abs div
)))
2142 (setf (interval-low rem
) 0)
2143 (when (and (numberp (interval-high rem
))
2144 (not (zerop (interval-high rem
))))
2145 ;; The remainder never contains the upper bound. However,
2146 ;; watch out for the case where the high limit is zero!
2147 (setf (interval-high rem
) (list (interval-high rem
))))
2150 ;; The divisor is always negative.
2151 (let ((rem (interval-neg (interval-abs div
))))
2152 (setf (interval-high rem
) 0)
2153 (when (numberp (interval-low rem
))
2154 ;; The remainder never contains the lower bound.
2155 (setf (interval-low rem
) (list (interval-low rem
))))
2158 ;; The divisor can be positive or negative. All bets off. The
2159 ;; magnitude of remainder is the maximum value of the divisor.
2160 (let ((limit (type-bound-number (interval-high (interval-abs div
)))))
2161 ;; The bound never reaches the limit, so make the interval open.
2162 (make-interval :low
(if limit
2165 :high
(list limit
))))))
2167 (floor-quotient-bound (make-interval :low
0.3 :high
10.3))
2168 => #S
(INTERVAL :LOW
0 :HIGH
10)
2169 (floor-quotient-bound (make-interval :low
0.3 :high
'(10.3
)))
2170 => #S
(INTERVAL :LOW
0 :HIGH
10)
2171 (floor-quotient-bound (make-interval :low
0.3 :high
10))
2172 => #S
(INTERVAL :LOW
0 :HIGH
10)
2173 (floor-quotient-bound (make-interval :low
0.3 :high
'(10)))
2174 => #S
(INTERVAL :LOW
0 :HIGH
9)
2175 (floor-quotient-bound (make-interval :low
'(0.3
) :high
10.3))
2176 => #S
(INTERVAL :LOW
0 :HIGH
10)
2177 (floor-quotient-bound (make-interval :low
'(0.0
) :high
10.3))
2178 => #S
(INTERVAL :LOW
0 :HIGH
10)
2179 (floor-quotient-bound (make-interval :low
'(-1.3
) :high
10.3))
2180 => #S
(INTERVAL :LOW -
2 :HIGH
10)
2181 (floor-quotient-bound (make-interval :low
'(-1.0
) :high
10.3))
2182 => #S
(INTERVAL :LOW -
1 :HIGH
10)
2183 (floor-quotient-bound (make-interval :low -
1.0 :high
10.3))
2184 => #S
(INTERVAL :LOW -
1 :HIGH
10)
2186 (floor-rem-bound (make-interval :low
0.3 :high
10.3))
2187 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2188 (floor-rem-bound (make-interval :low
0.3 :high
'(10.3
)))
2189 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2190 (floor-rem-bound (make-interval :low -
10 :high -
2.3))
2191 #S
(INTERVAL :LOW
(-10) :HIGH
0)
2192 (floor-rem-bound (make-interval :low
0.3 :high
10))
2193 => #S
(INTERVAL :LOW
0 :HIGH
'(10))
2194 (floor-rem-bound (make-interval :low
'(-1.3
) :high
10.3))
2195 => #S
(INTERVAL :LOW
'(-10.3
) :HIGH
'(10.3
))
2196 (floor-rem-bound (make-interval :low
'(-20.3
) :high
10.3))
2197 => #S
(INTERVAL :LOW
(-20.3
) :HIGH
(20.3
))
2200 ;;; same functions for CEILING
2201 (defun ceiling-quotient-bound (quot)
2202 ;; Take the ceiling of the quotient and then massage it into what we
2204 (let ((lo (interval-low quot
))
2205 (hi (interval-high quot
)))
2206 ;; Take the ceiling of the upper bound. The result is always a
2207 ;; closed upper bound.
2209 (ceiling (type-bound-number hi
))
2211 ;; For the lower bound, we need to be careful.
2214 ;; An open bound. We need to be careful here because
2215 ;; the ceiling of '(10.0) is 11, but the ceiling of
2217 (multiple-value-bind (q r
) (ceiling (first lo
))
2222 ;; A closed bound, so the answer is obvious.
2226 (make-interval :low lo
:high hi
)))
2227 (defun ceiling-rem-bound (div)
2228 ;; The remainder depends only on the divisor. Try to get the
2229 ;; correct sign for the remainder if we can.
2230 (case (interval-range-info div
)
2232 ;; Divisor is always positive. The remainder is negative.
2233 (let ((rem (interval-neg (interval-abs div
))))
2234 (setf (interval-high rem
) 0)
2235 (when (and (numberp (interval-low rem
))
2236 (not (zerop (interval-low rem
))))
2237 ;; The remainder never contains the upper bound. However,
2238 ;; watch out for the case when the upper bound is zero!
2239 (setf (interval-low rem
) (list (interval-low rem
))))
2242 ;; Divisor is always negative. The remainder is positive
2243 (let ((rem (interval-abs div
)))
2244 (setf (interval-low rem
) 0)
2245 (when (numberp (interval-high rem
))
2246 ;; The remainder never contains the lower bound.
2247 (setf (interval-high rem
) (list (interval-high rem
))))
2250 ;; The divisor can be positive or negative. All bets off. The
2251 ;; magnitude of remainder is the maximum value of the divisor.
2252 (let ((limit (type-bound-number (interval-high (interval-abs div
)))))
2253 ;; The bound never reaches the limit, so make the interval open.
2254 (make-interval :low
(if limit
2257 :high
(list limit
))))))
2260 (ceiling-quotient-bound (make-interval :low
0.3 :high
10.3))
2261 => #S
(INTERVAL :LOW
1 :HIGH
11)
2262 (ceiling-quotient-bound (make-interval :low
0.3 :high
'(10.3
)))
2263 => #S
(INTERVAL :LOW
1 :HIGH
11)
2264 (ceiling-quotient-bound (make-interval :low
0.3 :high
10))
2265 => #S
(INTERVAL :LOW
1 :HIGH
10)
2266 (ceiling-quotient-bound (make-interval :low
0.3 :high
'(10)))
2267 => #S
(INTERVAL :LOW
1 :HIGH
10)
2268 (ceiling-quotient-bound (make-interval :low
'(0.3
) :high
10.3))
2269 => #S
(INTERVAL :LOW
1 :HIGH
11)
2270 (ceiling-quotient-bound (make-interval :low
'(0.0
) :high
10.3))
2271 => #S
(INTERVAL :LOW
1 :HIGH
11)
2272 (ceiling-quotient-bound (make-interval :low
'(-1.3
) :high
10.3))
2273 => #S
(INTERVAL :LOW -
1 :HIGH
11)
2274 (ceiling-quotient-bound (make-interval :low
'(-1.0
) :high
10.3))
2275 => #S
(INTERVAL :LOW
0 :HIGH
11)
2276 (ceiling-quotient-bound (make-interval :low -
1.0 :high
10.3))
2277 => #S
(INTERVAL :LOW -
1 :HIGH
11)
2279 (ceiling-rem-bound (make-interval :low
0.3 :high
10.3))
2280 => #S
(INTERVAL :LOW
(-10.3
) :HIGH
0)
2281 (ceiling-rem-bound (make-interval :low
0.3 :high
'(10.3
)))
2282 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2283 (ceiling-rem-bound (make-interval :low -
10 :high -
2.3))
2284 => #S
(INTERVAL :LOW
0 :HIGH
(10))
2285 (ceiling-rem-bound (make-interval :low
0.3 :high
10))
2286 => #S
(INTERVAL :LOW
(-10) :HIGH
0)
2287 (ceiling-rem-bound (make-interval :low
'(-1.3
) :high
10.3))
2288 => #S
(INTERVAL :LOW
(-10.3
) :HIGH
(10.3
))
2289 (ceiling-rem-bound (make-interval :low
'(-20.3
) :high
10.3))
2290 => #S
(INTERVAL :LOW
(-20.3
) :HIGH
(20.3
))
2293 (defun truncate-quotient-bound (quot)
2294 ;; For positive quotients, truncate is exactly like floor. For
2295 ;; negative quotients, truncate is exactly like ceiling. Otherwise,
2296 ;; it's the union of the two pieces.
2297 (case (interval-range-info quot
)
2300 (floor-quotient-bound quot
))
2302 ;; just like CEILING
2303 (ceiling-quotient-bound quot
))
2305 ;; Split the interval into positive and negative pieces, compute
2306 ;; the result for each piece and put them back together.
2307 (destructuring-bind (neg pos
) (interval-split 0 quot t t
)
2308 (interval-merge-pair (ceiling-quotient-bound neg
)
2309 (floor-quotient-bound pos
))))))
2311 (defun truncate-rem-bound (num div
)
2312 ;; This is significantly more complicated than FLOOR or CEILING. We
2313 ;; need both the number and the divisor to determine the range. The
2314 ;; basic idea is to split the ranges of NUM and DEN into positive
2315 ;; and negative pieces and deal with each of the four possibilities
2317 (case (interval-range-info num
)
2319 (case (interval-range-info div
)
2321 (floor-rem-bound div
))
2323 (ceiling-rem-bound div
))
2325 (destructuring-bind (neg pos
) (interval-split 0 div t t
)
2326 (interval-merge-pair (truncate-rem-bound num neg
)
2327 (truncate-rem-bound num pos
))))))
2329 (case (interval-range-info div
)
2331 (ceiling-rem-bound div
))
2333 (floor-rem-bound div
))
2335 (destructuring-bind (neg pos
) (interval-split 0 div t t
)
2336 (interval-merge-pair (truncate-rem-bound num neg
)
2337 (truncate-rem-bound num pos
))))))
2339 (destructuring-bind (neg pos
) (interval-split 0 num t t
)
2340 (interval-merge-pair (truncate-rem-bound neg div
)
2341 (truncate-rem-bound pos div
))))))
2344 ;;; Derive useful information about the range. Returns three values:
2345 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2346 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2347 ;;; - The abs of the maximal value if there is one, or nil if it is
2349 (defun numeric-range-info (low high
)
2350 (cond ((and low
(not (minusp low
)))
2351 (values '+ low high
))
2352 ((and high
(not (plusp high
)))
2353 (values '-
(- high
) (if low
(- low
) nil
)))
2355 (values nil
0 (and low high
(max (- low
) high
))))))
2357 (defun integer-truncate-derive-type
2358 (number-low number-high divisor-low divisor-high
)
2359 ;; The result cannot be larger in magnitude than the number, but the
2360 ;; sign might change. If we can determine the sign of either the
2361 ;; number or the divisor, we can eliminate some of the cases.
2362 (multiple-value-bind (number-sign number-min number-max
)
2363 (numeric-range-info number-low number-high
)
2364 (multiple-value-bind (divisor-sign divisor-min divisor-max
)
2365 (numeric-range-info divisor-low divisor-high
)
2366 (when (and divisor-max
(zerop divisor-max
))
2367 ;; We've got a problem: guaranteed division by zero.
2368 (return-from integer-truncate-derive-type t
))
2369 (when (zerop divisor-min
)
2370 ;; We'll assume that they aren't going to divide by zero.
2372 (cond ((and number-sign divisor-sign
)
2373 ;; We know the sign of both.
2374 (if (eq number-sign divisor-sign
)
2375 ;; Same sign, so the result will be positive.
2376 `(integer ,(if divisor-max
2377 (truncate number-min divisor-max
)
2380 (truncate number-max divisor-min
)
2382 ;; Different signs, the result will be negative.
2383 `(integer ,(if number-max
2384 (- (truncate number-max divisor-min
))
2387 (- (truncate number-min divisor-max
))
2389 ((eq divisor-sign
'+)
2390 ;; The divisor is positive. Therefore, the number will just
2391 ;; become closer to zero.
2392 `(integer ,(if number-low
2393 (truncate number-low divisor-min
)
2396 (truncate number-high divisor-min
)
2398 ((eq divisor-sign
'-
)
2399 ;; The divisor is negative. Therefore, the absolute value of
2400 ;; the number will become closer to zero, but the sign will also
2402 `(integer ,(if number-high
2403 (- (truncate number-high divisor-min
))
2406 (- (truncate number-low divisor-min
))
2408 ;; The divisor could be either positive or negative.
2410 ;; The number we are dividing has a bound. Divide that by the
2411 ;; smallest posible divisor.
2412 (let ((bound (truncate number-max divisor-min
)))
2413 `(integer ,(- bound
) ,bound
)))
2415 ;; The number we are dividing is unbounded, so we can't tell
2416 ;; anything about the result.
2419 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2420 (defun integer-rem-derive-type
2421 (number-low number-high divisor-low divisor-high
)
2422 (if (and divisor-low divisor-high
)
2423 ;; We know the range of the divisor, and the remainder must be
2424 ;; smaller than the divisor. We can tell the sign of the
2425 ;; remainder if we know the sign of the number.
2426 (let ((divisor-max (1- (max (abs divisor-low
) (abs divisor-high
)))))
2427 `(integer ,(if (or (null number-low
)
2428 (minusp number-low
))
2431 ,(if (or (null number-high
)
2432 (plusp number-high
))
2435 ;; The divisor is potentially either very positive or very
2436 ;; negative. Therefore, the remainder is unbounded, but we might
2437 ;; be able to tell something about the sign from the number.
2438 `(integer ,(if (and number-low
(not (minusp number-low
)))
2439 ;; The number we are dividing is positive.
2440 ;; Therefore, the remainder must be positive.
2443 ,(if (and number-high
(not (plusp number-high
)))
2444 ;; The number we are dividing is negative.
2445 ;; Therefore, the remainder must be negative.
2449 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2450 (defoptimizer (random derive-type
) ((bound &optional state
))
2451 (declare (ignore state
))
2452 (let ((type (lvar-type bound
)))
2453 (when (numeric-type-p type
)
2454 (let ((class (numeric-type-class type
))
2455 (high (numeric-type-high type
))
2456 (format (numeric-type-format type
)))
2460 :low
(coerce 0 (or format class
'real
))
2461 :high
(cond ((not high
) nil
)
2462 ((eq class
'integer
) (max (1- high
) 0))
2463 ((or (consp high
) (zerop high
)) high
)
2466 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2467 (defun random-derive-type-aux (type)
2468 (let ((class (numeric-type-class type
))
2469 (high (numeric-type-high type
))
2470 (format (numeric-type-format type
)))
2474 :low
(coerce 0 (or format class
'real
))
2475 :high
(cond ((not high
) nil
)
2476 ((eq class
'integer
) (max (1- high
) 0))
2477 ((or (consp high
) (zerop high
)) high
)
2480 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2481 (defoptimizer (random derive-type
) ((bound &optional state
))
2482 (declare (ignore state
))
2483 (one-arg-derive-type bound
#'random-derive-type-aux nil
))
2485 ;;;; miscellaneous derive-type methods
2487 (defoptimizer (integer-length derive-type
) ((x))
2488 (let ((x-type (lvar-type x
)))
2489 (when (numeric-type-p x-type
)
2490 ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2491 ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be
2492 ;; careful about LO or HI being NIL, though. Also, if 0 is
2493 ;; contained in X, the lower bound is obviously 0.
2494 (flet ((null-or-min (a b
)
2495 (and a b
(min (integer-length a
)
2496 (integer-length b
))))
2498 (and a b
(max (integer-length a
)
2499 (integer-length b
)))))
2500 (let* ((min (numeric-type-low x-type
))
2501 (max (numeric-type-high x-type
))
2502 (min-len (null-or-min min max
))
2503 (max-len (null-or-max min max
)))
2504 (when (ctypep 0 x-type
)
2506 (specifier-type `(integer ,(or min-len
'*) ,(or max-len
'*))))))))
2508 (defoptimizer (logcount derive-type
) ((x))
2509 (let ((x-type (lvar-type x
)))
2510 (when (numeric-type-p x-type
)
2511 (let ((min (numeric-type-low x-type
))
2512 (max (numeric-type-high x-type
)))
2515 `(integer ,(if (or (> min
0)
2519 ,(max (integer-length min
)
2520 (integer-length max
)))))))))
2522 (defoptimizer (isqrt derive-type
) ((x))
2523 (let ((x-type (lvar-type x
)))
2524 (when (numeric-type-p x-type
)
2525 (let* ((lo (numeric-type-low x-type
))
2526 (hi (numeric-type-high x-type
))
2527 (lo-res (if lo
(isqrt lo
) '*))
2528 (hi-res (if hi
(isqrt hi
) '*)))
2529 (specifier-type `(integer ,lo-res
,hi-res
))))))
2531 (defoptimizer (char-code derive-type
) ((char))
2532 (let ((type (type-intersection (lvar-type char
) (specifier-type 'character
))))
2533 (cond ((member-type-p type
)
2536 ,@(loop for member in
(member-type-members type
)
2537 when
(characterp member
)
2538 collect
(char-code member
)))))
2539 ((sb!kernel
::character-set-type-p type
)
2542 ,@(loop for
(low . high
)
2543 in
(character-set-type-pairs type
)
2544 collect
`(integer ,low
,high
)))))
2545 ((csubtypep type
(specifier-type 'base-char
))
2547 `(mod ,base-char-code-limit
)))
2550 `(mod ,sb
!xc
:char-code-limit
))))))
2552 (defoptimizer (code-char derive-type
) ((code))
2553 (let ((type (lvar-type code
)))
2554 ;; FIXME: unions of integral ranges? It ought to be easier to do
2555 ;; this, given that CHARACTER-SET is basically an integral range
2556 ;; type. -- CSR, 2004-10-04
2557 (when (numeric-type-p type
)
2558 (let* ((lo (numeric-type-low type
))
2559 (hi (numeric-type-high type
))
2560 (type (specifier-type `(character-set ((,lo .
,hi
))))))
2562 ;; KLUDGE: when running on the host, we lose a slight amount
2563 ;; of precision so that we don't have to "unparse" types
2564 ;; that formally we can't, such as (CHARACTER-SET ((0
2565 ;; . 0))). -- CSR, 2004-10-06
2567 ((csubtypep type
(specifier-type 'standard-char
)) type
)
2569 ((csubtypep type
(specifier-type 'base-char
))
2570 (specifier-type 'base-char
))
2572 ((csubtypep type
(specifier-type 'extended-char
))
2573 (specifier-type 'extended-char
))
2574 (t #+sb-xc-host
(specifier-type 'character
)
2575 #-sb-xc-host type
))))))
2577 (defoptimizer (values derive-type
) ((&rest values
))
2578 (make-values-type :required
(mapcar #'lvar-type values
)))
2580 (defun signum-derive-type-aux (type)
2581 (if (eq (numeric-type-complexp type
) :complex
)
2582 (let* ((format (case (numeric-type-class type
)
2583 ((integer rational
) 'single-float
)
2584 (t (numeric-type-format type
))))
2585 (bound-format (or format
'float
)))
2586 (make-numeric-type :class
'float
2589 :low
(coerce -
1 bound-format
)
2590 :high
(coerce 1 bound-format
)))
2591 (let* ((interval (numeric-type->interval type
))
2592 (range-info (interval-range-info interval
))
2593 (contains-0-p (interval-contains-p 0 interval
))
2594 (class (numeric-type-class type
))
2595 (format (numeric-type-format type
))
2596 (one (coerce 1 (or format class
'real
)))
2597 (zero (coerce 0 (or format class
'real
)))
2598 (minus-one (coerce -
1 (or format class
'real
)))
2599 (plus (make-numeric-type :class class
:format format
2600 :low one
:high one
))
2601 (minus (make-numeric-type :class class
:format format
2602 :low minus-one
:high minus-one
))
2603 ;; KLUDGE: here we have a fairly horrible hack to deal
2604 ;; with the schizophrenia in the type derivation engine.
2605 ;; The problem is that the type derivers reinterpret
2606 ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
2607 ;; 0d0) within the derivation mechanism doesn't include
2608 ;; -0d0. Ugh. So force it in here, instead.
2609 (zero (make-numeric-type :class class
:format format
2610 :low
(- zero
) :high zero
)))
2612 (+ (if contains-0-p
(type-union plus zero
) plus
))
2613 (- (if contains-0-p
(type-union minus zero
) minus
))
2614 (t (type-union minus zero plus
))))))
2616 (defoptimizer (signum derive-type
) ((num))
2617 (one-arg-derive-type num
#'signum-derive-type-aux nil
))
2619 ;;;; byte operations
2621 ;;;; We try to turn byte operations into simple logical operations.
2622 ;;;; First, we convert byte specifiers into separate size and position
2623 ;;;; arguments passed to internal %FOO functions. We then attempt to
2624 ;;;; transform the %FOO functions into boolean operations when the
2625 ;;;; size and position are constant and the operands are fixnums.
2626 ;;;; The goal of the source-transform is to avoid consing a byte specifier
2627 ;;;; to immediately throw away. A more powerful framework could recognize
2628 ;;;; in IR1 when a constructor call flows to one or more accessors for the
2629 ;;;; constructed object and nowhere else (no mutators). If so, forwarding
2630 ;;;; the constructor arguments to their reads would generally solve this.
2631 ;;;; A transform approximates that, but fails when BYTE is produced by an
2632 ;;;; inline function and not a macro.
2633 (flet ((xform (bytespec-form env int fun
&optional
(new nil setter-p
))
2634 (let ((spec (%macroexpand bytespec-form env
)))
2635 (if (and (consp spec
) (eq (car spec
) 'byte
))
2636 (if (proper-list-of-length-p (cdr spec
) 2)
2637 (values `(,fun
,@(if setter-p
(list new
))
2638 ,(second spec
) ,(third spec
) ,int
) nil
)
2639 ;; No point in compiling calls to BYTE-{SIZE,POSITION}
2640 (values nil t
)) ; T => "pass" (meaning "fail")
2641 (let ((new-temp (if setter-p
(copy-symbol 'new
)))
2642 (byte (copy-symbol 'byte
)))
2643 (values `(let (,@(if new-temp
`((,new-temp
,new
)))
2645 (,fun
,@(if setter-p
(list new-temp
))
2646 (byte-size ,byte
) (byte-position ,byte
) ,int
))
2649 ;; DEFINE-SOURCE-TRANSFORM has no compile-time effect, so it's fine that
2650 ;; these 4 things are non-toplevel. (xform does not need to be a macro)
2651 (define-source-transform ldb
(spec int
&environment env
)
2652 (xform spec env int
'%ldb
))
2654 (define-source-transform dpb
(newbyte spec int
&environment env
)
2655 (xform spec env int
'%dpb newbyte
))
2657 (define-source-transform mask-field
(spec int
&environment env
)
2658 (xform spec env int
'%mask-field
))
2660 (define-source-transform deposit-field
(newbyte spec int
&environment env
)
2661 (xform spec env int
'%deposit-field newbyte
)))
2663 (defoptimizer (%ldb derive-type
) ((size posn num
))
2664 (declare (ignore posn num
))
2665 (let ((size (lvar-type size
)))
2666 (if (and (numeric-type-p size
)
2667 (csubtypep size
(specifier-type 'integer
)))
2668 (let ((size-high (numeric-type-high size
)))
2669 (if (and size-high
(<= size-high sb
!vm
:n-word-bits
))
2670 (specifier-type `(unsigned-byte* ,size-high
))
2671 (specifier-type 'unsigned-byte
)))
2674 (defoptimizer (%mask-field derive-type
) ((size posn num
))
2675 (declare (ignore num
))
2676 (let ((size (lvar-type size
))
2677 (posn (lvar-type posn
)))
2678 (if (and (numeric-type-p size
)
2679 (csubtypep size
(specifier-type 'integer
))
2680 (numeric-type-p posn
)
2681 (csubtypep posn
(specifier-type 'integer
)))
2682 (let ((size-high (numeric-type-high size
))
2683 (posn-high (numeric-type-high posn
)))
2684 (if (and size-high posn-high
2685 (<= (+ size-high posn-high
) sb
!vm
:n-word-bits
))
2686 (specifier-type `(unsigned-byte* ,(+ size-high posn-high
)))
2687 (specifier-type 'unsigned-byte
)))
2690 (defun %deposit-field-derive-type-aux
(size posn int
)
2691 (let ((size (lvar-type size
))
2692 (posn (lvar-type posn
))
2693 (int (lvar-type int
)))
2694 (when (and (numeric-type-p size
)
2695 (numeric-type-p posn
)
2696 (numeric-type-p int
))
2697 (let ((size-high (numeric-type-high size
))
2698 (posn-high (numeric-type-high posn
))
2699 (high (numeric-type-high int
))
2700 (low (numeric-type-low int
)))
2701 (when (and size-high posn-high high low
2702 ;; KLUDGE: we need this cutoff here, otherwise we
2703 ;; will merrily derive the type of %DPB as
2704 ;; (UNSIGNED-BYTE 1073741822), and then attempt to
2705 ;; canonicalize this type to (INTEGER 0 (1- (ASH 1
2706 ;; 1073741822))), with hilarious consequences. We
2707 ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference
2708 ;; over a reasonable amount of shifting, even on
2709 ;; the alpha/32 port, where N-WORD-BITS is 32 but
2710 ;; machine integers are 64-bits. -- CSR,
2712 (<= (+ size-high posn-high
) (* 4 sb
!vm
:n-word-bits
)))
2713 (let ((raw-bit-count (max (integer-length high
)
2714 (integer-length low
)
2715 (+ size-high posn-high
))))
2718 `(signed-byte ,(1+ raw-bit-count
))
2719 `(unsigned-byte* ,raw-bit-count
)))))))))
2721 (defoptimizer (%dpb derive-type
) ((newbyte size posn int
))
2722 (declare (ignore newbyte
))
2723 (%deposit-field-derive-type-aux size posn int
))
2725 (defoptimizer (%deposit-field derive-type
) ((newbyte size posn int
))
2726 (declare (ignore newbyte
))
2727 (%deposit-field-derive-type-aux size posn int
))
2729 (deftransform %ldb
((size posn int
)
2730 (fixnum fixnum integer
)
2731 (unsigned-byte #.sb
!vm
:n-word-bits
))
2732 "convert to inline logical operations"
2733 `(logand (ash int
(- posn
))
2734 (ash ,(1- (ash 1 sb
!vm
:n-word-bits
))
2735 (- size
,sb
!vm
:n-word-bits
))))
2737 (deftransform %mask-field
((size posn int
)
2738 (fixnum fixnum integer
)
2739 (unsigned-byte #.sb
!vm
:n-word-bits
))
2740 "convert to inline logical operations"
2742 (ash (ash ,(1- (ash 1 sb
!vm
:n-word-bits
))
2743 (- size
,sb
!vm
:n-word-bits
))
2746 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
2747 ;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
2748 ;;; as the result type, as that would allow result types that cover
2749 ;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
2750 ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
2752 (deftransform %dpb
((new size posn int
)
2754 (unsigned-byte #.sb
!vm
:n-word-bits
))
2755 "convert to inline logical operations"
2756 `(let ((mask (ldb (byte size
0) -
1)))
2757 (logior (ash (logand new mask
) posn
)
2758 (logand int
(lognot (ash mask posn
))))))
2760 (deftransform %dpb
((new size posn int
)
2762 (signed-byte #.sb
!vm
:n-word-bits
))
2763 "convert to inline logical operations"
2764 `(let ((mask (ldb (byte size
0) -
1)))
2765 (logior (ash (logand new mask
) posn
)
2766 (logand int
(lognot (ash mask posn
))))))
2768 (deftransform %deposit-field
((new size posn int
)
2770 (unsigned-byte #.sb
!vm
:n-word-bits
))
2771 "convert to inline logical operations"
2772 `(let ((mask (ash (ldb (byte size
0) -
1) posn
)))
2773 (logior (logand new mask
)
2774 (logand int
(lognot mask
)))))
2776 (deftransform %deposit-field
((new size posn int
)
2778 (signed-byte #.sb
!vm
:n-word-bits
))
2779 "convert to inline logical operations"
2780 `(let ((mask (ash (ldb (byte size
0) -
1) posn
)))
2781 (logior (logand new mask
)
2782 (logand int
(lognot mask
)))))
2784 (defoptimizer (mask-signed-field derive-type
) ((size x
))
2785 (declare (ignore x
))
2786 (let ((size (lvar-type size
)))
2787 (if (numeric-type-p size
)
2788 (let ((size-high (numeric-type-high size
)))
2789 (if (and size-high
(<= 1 size-high sb
!vm
:n-word-bits
))
2790 (specifier-type `(signed-byte ,size-high
))
2797 (defun %ash
/right
(integer amount
)
2798 (ash integer
(- amount
)))
2800 (deftransform ash
((integer amount
))
2801 "Convert ASH of signed word to %ASH/RIGHT"
2802 (unless (and (csubtypep (lvar-type integer
) ; do that ourselves to avoid
2803 (specifier-type 'sb
!vm
:signed-word
)) ; optimization
2804 (csubtypep (lvar-type amount
) ; notes.
2805 (specifier-type '(integer * 0))))
2806 (give-up-ir1-transform))
2807 (when (constant-lvar-p amount
)
2808 (give-up-ir1-transform))
2809 (let ((use (lvar-uses amount
)))
2810 (cond ((and (combination-p use
)
2811 (eql '%negate
(lvar-fun-name (combination-fun use
))))
2812 (splice-fun-args amount
'%negate
1)
2813 `(lambda (integer amount
)
2814 (declare (type unsigned-byte amount
))
2815 (%ash
/right integer
(if (>= amount
,sb
!vm
:n-word-bits
)
2816 ,(1- sb
!vm
:n-word-bits
)
2819 `(%ash
/right integer
(if (<= amount
,(- sb
!vm
:n-word-bits
))
2820 ,(1- sb
!vm
:n-word-bits
)
2823 (deftransform ash
((integer amount
))
2824 "Convert ASH of word to %ASH/RIGHT"
2825 (unless (and (csubtypep (lvar-type integer
)
2826 (specifier-type 'sb
!vm
:word
))
2827 (csubtypep (lvar-type amount
)
2828 (specifier-type '(integer * 0))))
2829 (give-up-ir1-transform))
2830 (when (constant-lvar-p amount
)
2831 (give-up-ir1-transform))
2832 (let ((use (lvar-uses amount
)))
2833 (cond ((and (combination-p use
)
2834 (eql '%negate
(lvar-fun-name (combination-fun use
))))
2835 (splice-fun-args amount
'%negate
1)
2836 `(lambda (integer amount
)
2837 (declare (type unsigned-byte amount
))
2838 (if (>= amount
,sb
!vm
:n-word-bits
)
2840 (%ash
/right integer amount
))))
2842 `(if (<= amount
,(- sb
!vm
:n-word-bits
))
2844 (%ash
/right integer
(- amount
)))))))
2846 (deftransform %ash
/right
((integer amount
) (integer (constant-arg unsigned-byte
)))
2847 "Convert %ASH/RIGHT by constant back to ASH"
2848 `(ash integer
,(- (lvar-value amount
))))
2850 (deftransform %ash
/right
((integer amount
) * * :node node
)
2851 "strength reduce large variable right shift"
2852 (let ((return-type (single-value-type (node-derived-type node
))))
2853 (cond ((type= return-type
(specifier-type '(eql 0)))
2855 ((type= return-type
(specifier-type '(eql -
1)))
2857 ((csubtypep return-type
(specifier-type '(member -
1 0)))
2858 `(ash integer
,(- sb
!vm
:n-word-bits
)))
2860 (give-up-ir1-transform)))))
2862 (defun %ash
/right-derive-type-aux
(n-type shift same-arg
)
2863 (declare (ignore same-arg
))
2864 (or (and (or (csubtypep n-type
(specifier-type 'sb
!vm
:signed-word
))
2865 (csubtypep n-type
(specifier-type 'word
)))
2866 (csubtypep shift
(specifier-type `(mod ,sb
!vm
:n-word-bits
)))
2867 (let ((n-low (numeric-type-low n-type
))
2868 (n-high (numeric-type-high n-type
))
2869 (s-low (numeric-type-low shift
))
2870 (s-high (numeric-type-high shift
)))
2871 (make-numeric-type :class
'integer
:complexp
:real
2874 (ash n-low
(- s-low
))
2875 (ash n-low
(- s-high
))))
2878 (ash n-high
(- s-high
))
2879 (ash n-high
(- s-low
)))))))
2882 (defoptimizer (%ash
/right derive-type
) ((n shift
))
2883 (two-arg-derive-type n shift
#'%ash
/right-derive-type-aux
#'%ash
/right
))
2886 ;;; Not declaring it as actually being RATIO becuase it is used as one
2887 ;;; of the legs in the EXPT transform below and that may result in
2888 ;;; some unwanted type conflicts, e.g. (random (expt 2 (the integer y)))
2889 (declaim (type (sfunction (integer) rational
) reciprocate
))
2890 (defun reciprocate (x)
2891 (declare (optimize (safety 0)))
2894 (deftransform expt
((base power
) ((constant-arg unsigned-byte
) integer
))
2895 (let ((base (lvar-value base
)))
2896 (cond ((/= (logcount base
) 1)
2897 (give-up-ir1-transform))
2901 `(let ((%denominator
(ash 1 ,(if (= base
2)
2903 `(* (abs power
) ,(1- (integer-length base
)))))))
2905 (reciprocate %denominator
)
2908 (deftransform expt
((base power
) ((constant-arg unsigned-byte
) unsigned-byte
))
2909 (let ((base (lvar-value base
)))
2910 (unless (= (logcount base
) 1)
2911 (give-up-ir1-transform))
2912 `(ash 1 ,(if (= base
2)
2914 `(* power
,(1- (integer-length base
)))))))
2916 ;;; Modular functions
2918 ;;; (ldb (byte s 0) (foo x y ...)) =
2919 ;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
2921 ;;; and similar for other arguments.
2923 (defun make-modular-fun-type-deriver (prototype kind width signedp
)
2924 (declare (ignore kind
))
2926 (binding* ((info (info :function
:info prototype
) :exit-if-null
)
2927 (fun (fun-info-derive-type info
) :exit-if-null
)
2928 (mask-type (specifier-type
2930 ((nil) (let ((mask (1- (ash 1 width
))))
2931 `(integer ,mask
,mask
)))
2932 ((t) `(signed-byte ,width
))))))
2934 (let ((res (funcall fun call
)))
2936 (if (eq signedp nil
)
2937 (logand-derive-type-aux res mask-type
))))))
2940 (binding* ((info (info :function
:info prototype
) :exit-if-null
)
2941 (fun (fun-info-derive-type info
) :exit-if-null
)
2942 (res (funcall fun call
) :exit-if-null
)
2943 (mask-type (specifier-type
2945 ((nil) (let ((mask (1- (ash 1 width
))))
2946 `(integer ,mask
,mask
)))
2947 ((t) `(signed-byte ,width
))))))
2948 (if (eq signedp nil
)
2949 (logand-derive-type-aux res mask-type
)))))
2951 ;;; Try to recursively cut all uses of LVAR to WIDTH bits.
2953 ;;; For good functions, we just recursively cut arguments; their
2954 ;;; "goodness" means that the result will not increase (in the
2955 ;;; (unsigned-byte +infinity) sense). An ordinary modular function is
2956 ;;; replaced with the version, cutting its result to WIDTH or more
2957 ;;; bits. For most functions (e.g. for +) we cut all arguments; for
2958 ;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
2959 ;;; arguments (maybe to a different width) and returning the name of a
2960 ;;; modular version, if it exists, or NIL. If we have changed
2961 ;;; anything, we need to flush old derived types, because they have
2962 ;;; nothing in common with the new code.
2963 (defun cut-to-width (lvar kind width signedp
)
2964 (declare (type lvar lvar
) (type (integer 0) width
))
2965 (let ((type (specifier-type (if (zerop width
)
2968 ((nil) 'unsigned-byte
)
2971 (labels ((reoptimize-node (node name
)
2972 (setf (node-derived-type node
)
2974 (info :function
:type name
)))
2975 (setf (lvar-%derived-type
(node-lvar node
)) nil
)
2976 (setf (node-reoptimize node
) t
)
2977 (setf (block-reoptimize (node-block node
)) t
)
2978 (reoptimize-component (node-component node
) :maybe
))
2979 (insert-lvar-cut (lvar)
2980 "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
2981 to the required bit width. Returns T if any change was made.
2983 When the destination of LVAR will definitely cut LVAR's value
2984 to width (i.e. it's a logand or mask-signed-field with constant
2985 other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
2986 (binding* ((dest (lvar-dest lvar
) :exit-if-null
)
2987 (nil (combination-p dest
) :exit-if-null
)
2988 (name (lvar-fun-name (combination-fun dest
) t
))
2989 (args (combination-args dest
)))
2992 (when (= 2 (length args
))
2993 (let ((other (if (eql (first args
) lvar
)
2996 (when (and (constant-lvar-p other
)
2997 (ctypep (lvar-value other
) type
)
2999 (return-from insert-lvar-cut
)))))
3002 (eql lvar
(second args
))
3003 (constant-lvar-p (first args
))
3004 (<= (lvar-value (first args
)) width
))
3005 (return-from insert-lvar-cut
)))))
3008 `(mask-signed-field ,width
'dummy
)
3009 `(logand 'dummy
,(ldb (byte width
0) -
1))))
3010 (do-uses (node lvar
)
3011 (setf (block-reoptimize (node-block node
)) t
)
3012 (reoptimize-component (node-component node
) :maybe
))
3015 "Try to cut a node to width. The primary return value is
3016 whether we managed to cut (cleverly), and the second whether
3017 anything was changed. The third return value tells whether
3018 the cut value might be wider than expected."
3019 (when (block-delete-p (node-block node
))
3020 (return-from cut-node
(values t nil
)))
3023 (typecase (ref-leaf node
)
3025 (let* ((constant-value (constant-value (ref-leaf node
)))
3027 (cond ((not (integerp constant-value
))
3028 (return-from cut-node
(values t nil
)))
3030 (mask-signed-field width constant-value
))
3032 (ldb (byte width
0) constant-value
)))))
3033 (cond ((= constant-value new-value
)
3034 (values t nil
)) ; we knew what to do and did nothing
3036 (change-ref-leaf node
(make-constant new-value
)
3038 (let ((lvar (node-lvar node
)))
3039 (setf (lvar-%derived-type lvar
)
3040 (and (lvar-has-single-use-p lvar
)
3041 (make-values-type :required
(list (ctype-of new-value
))))))
3042 (setf (block-reoptimize (node-block node
)) t
)
3043 (reoptimize-component (node-component node
) :maybe
)
3046 (when (eq (basic-combination-kind node
) :known
)
3047 (let* ((fun-ref (lvar-use (combination-fun node
)))
3048 (fun-name (lvar-fun-name (combination-fun node
)))
3049 (modular-fun (find-modular-version fun-name kind
3051 (cond ((not modular-fun
)
3052 ;; don't know what to do here
3054 ((let ((dtype (single-value-type
3055 (node-derived-type node
))))
3060 (specifier-type 'unsigned-byte
)))
3063 (specifier-type '(integer * 0))))
3067 (csubtypep dtype type
)))
3071 (binding* ((name (etypecase modular-fun
3072 ((eql :good
) fun-name
)
3074 (modular-fun-info-name modular-fun
))
3076 (funcall modular-fun node width
)))
3080 (unless (eql modular-fun
:good
)
3081 (setq did-something t
3085 (find-free-fun name
"in a strange place"))
3086 (setf (combination-kind node
) :full
))
3087 (unless (functionp modular-fun
)
3088 (dolist (arg (basic-combination-args node
))
3089 (multiple-value-bind (change wide
)
3091 (setf did-something
(or did-something change
)
3092 over-wide
(or over-wide wide
)))))
3094 (reoptimize-node node name
))
3095 (values t did-something over-wide
)))))))))
3096 (cut-lvar (lvar &key head
3097 &aux did-something must-insert over-wide
)
3098 "Cut all the LVAR's use nodes. If any of them wasn't handled
3099 and its type is too wide for the operation we wish to perform
3100 insert an explicit bit-width narrowing operation (LOGAND or
3101 MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
3102 The narrowing operation might not be inserted if the LVAR's
3103 destination is already such an operation, to avoid endless
3106 If we're at the head, forcibly insert a cut operation if the
3107 result might be too wide.
3109 (*) We can't easily do that for each node, and doing so might
3110 result in code bloat, anyway. (I'm also not sure it would be
3111 correct for complicated C/D FG)"
3112 (do-uses (node lvar
)
3113 (multiple-value-bind (handled any-change wide
)
3115 (setf did-something
(or did-something any-change
)
3116 must-insert
(or must-insert
3118 (csubtypep (single-value-type
3119 (node-derived-type node
))
3121 over-wide
(or over-wide wide
))))
3122 (when (or must-insert
3123 (and head over-wide
))
3124 (setf did-something
(or (insert-lvar-cut lvar
) did-something
)
3125 ;; we're just the right width after an explicit cut.
3127 (values did-something over-wide
)))
3128 (cut-lvar lvar
:head t
))))
3130 (defun best-modular-version (width signedp
)
3131 ;; 1. exact width-matched :untagged
3132 ;; 2. >/>= width-matched :tagged
3133 ;; 3. >/>= width-matched :untagged
3134 (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class
*))
3135 (uswidths (modular-class-widths *untagged-signed-modular-class
*))
3136 (uwidths (if (and uuwidths uswidths
)
3137 (merge 'list
(copy-list uuwidths
) (copy-list uswidths
)
3139 (or uuwidths uswidths
)))
3140 (twidths (modular-class-widths *tagged-modular-class
*)))
3141 (let ((exact (find (cons width signedp
) uwidths
:test
#'equal
)))
3143 (return-from best-modular-version
(values width
:untagged signedp
))))
3144 (flet ((inexact-match (w)
3146 ((eq signedp
(cdr w
)) (<= width
(car w
)))
3147 ((eq signedp nil
) (< width
(car w
))))))
3148 (let ((tgt (find-if #'inexact-match twidths
)))
3150 (return-from best-modular-version
3151 (values (car tgt
) :tagged
(cdr tgt
)))))
3152 (let ((ugt (find-if #'inexact-match uwidths
)))
3154 (return-from best-modular-version
3155 (values (car ugt
) :untagged
(cdr ugt
))))))))
3157 (defun integer-type-numeric-bounds (type)
3159 ;; KLUDGE: this is not INTEGER-type-numeric-bounds
3160 (numeric-type (values (numeric-type-low type
)
3161 (numeric-type-high type
)))
3165 (dolist (type (union-type-types type
) (values low high
))
3166 (unless (and (numeric-type-p type
)
3167 (eql (numeric-type-class type
) 'integer
))
3168 (return (values nil nil
)))
3169 (let ((this-low (numeric-type-low type
))
3170 (this-high (numeric-type-high type
)))
3171 (unless (and this-low this-high
)
3172 (return (values nil nil
)))
3173 (setf low
(min this-low
(or low this-low
))
3174 high
(max this-high
(or high this-high
)))))))))
3176 (defoptimizer (logand optimizer
) ((x y
) node
)
3177 (let ((result-type (single-value-type (node-derived-type node
))))
3178 (multiple-value-bind (low high
)
3179 (integer-type-numeric-bounds result-type
)
3180 (when (and (numberp low
)
3183 (let ((width (integer-length high
)))
3184 (multiple-value-bind (w kind signedp
)
3185 (best-modular-version width nil
)
3187 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
3189 ;; FIXME: I think the FIXME (which is from APD) above
3190 ;; implies that CUT-TO-WIDTH should do /everything/
3191 ;; that's required, including reoptimizing things
3192 ;; itself that it knows are necessary. At the moment,
3193 ;; CUT-TO-WIDTH sets up some new calls with
3194 ;; combination-type :FULL, which later get noticed as
3195 ;; known functions and properly converted.
3197 ;; We cut to W not WIDTH if SIGNEDP is true, because
3198 ;; signed constant replacement needs to know which bit
3199 ;; in the field is the signed bit.
3200 (let ((xact (cut-to-width x kind
(if signedp w width
) signedp
))
3201 (yact (cut-to-width y kind
(if signedp w width
) signedp
)))
3202 (declare (ignore xact yact
))
3203 nil
) ; After fixing above, replace with T, meaning
3204 ; "don't reoptimize this (LOGAND) node any more".
3207 (defoptimizer (mask-signed-field optimizer
) ((width x
) node
)
3208 (declare (ignore width
))
3209 (let ((result-type (single-value-type (node-derived-type node
))))
3210 (multiple-value-bind (low high
)
3211 (integer-type-numeric-bounds result-type
)
3212 (when (and (numberp low
) (numberp high
))
3213 (let ((width (max (integer-length high
) (integer-length low
))))
3214 (multiple-value-bind (w kind
)
3215 (best-modular-version (1+ width
) t
)
3217 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
3218 ;; [ see comment above in LOGAND optimizer ]
3219 (cut-to-width x kind w t
)
3220 nil
; After fixing above, replace with T.
3223 (defoptimizer (logior optimizer
) ((x y
) node
)
3224 (let ((result-type (single-value-type (node-derived-type node
))))
3225 (multiple-value-bind (low high
)
3226 (integer-type-numeric-bounds result-type
)
3227 (when (and (numberp low
)
3230 (let ((width (integer-length low
)))
3231 (multiple-value-bind (w kind
)
3232 (best-modular-version (1+ width
) t
)
3234 ;; FIXME: see comment in LOGAND optimizer
3235 (let ((xact (cut-to-width x kind w t
))
3236 (yact (cut-to-width y kind w t
)))
3237 (declare (ignore xact yact
))
3238 nil
) ; After fixing above, replace with T
3241 ;;; Handle the case of a constant BOOLE-CODE.
3242 (deftransform boole
((op x y
) * *)
3243 "convert to inline logical operations"
3244 (unless (constant-lvar-p op
)
3245 (give-up-ir1-transform "BOOLE code is not a constant."))
3246 (let ((control (lvar-value op
)))
3248 (#.sb
!xc
:boole-clr
0)
3249 (#.sb
!xc
:boole-set -
1)
3250 (#.sb
!xc
:boole-1
'x
)
3251 (#.sb
!xc
:boole-2
'y
)
3252 (#.sb
!xc
:boole-c1
'(lognot x
))
3253 (#.sb
!xc
:boole-c2
'(lognot y
))
3254 (#.sb
!xc
:boole-and
'(logand x y
))
3255 (#.sb
!xc
:boole-ior
'(logior x y
))
3256 (#.sb
!xc
:boole-xor
'(logxor x y
))
3257 (#.sb
!xc
:boole-eqv
'(logeqv x y
))
3258 (#.sb
!xc
:boole-nand
'(lognand x y
))
3259 (#.sb
!xc
:boole-nor
'(lognor x y
))
3260 (#.sb
!xc
:boole-andc1
'(logandc1 x y
))
3261 (#.sb
!xc
:boole-andc2
'(logandc2 x y
))
3262 (#.sb
!xc
:boole-orc1
'(logorc1 x y
))
3263 (#.sb
!xc
:boole-orc2
'(logorc2 x y
))
3265 (abort-ir1-transform "~S is an illegal control arg to BOOLE."
3268 ;;;; converting special case multiply/divide to shifts
3270 ;;; If arg is a constant power of two, turn * into a shift.
3271 (deftransform * ((x y
) (integer integer
) *)
3272 "convert x*2^k to shift"
3273 (unless (constant-lvar-p y
)
3274 (give-up-ir1-transform))
3275 (let* ((y (lvar-value y
))
3277 (len (1- (integer-length y-abs
))))
3278 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3279 (give-up-ir1-transform))
3284 ;;; These must come before the ones below, so that they are tried
3286 (deftransform floor
((number divisor
))
3287 `(multiple-value-bind (tru rem
) (truncate number divisor
)
3288 (if (and (not (zerop rem
))
3289 (if (minusp divisor
)
3292 (values (1- tru
) (+ rem divisor
))
3295 (deftransform ceiling
((number divisor
))
3296 `(multiple-value-bind (tru rem
) (truncate number divisor
)
3297 (if (and (not (zerop rem
))
3298 (if (minusp divisor
)
3301 (values (+ tru
1) (- rem divisor
))
3304 (deftransform rem
((number divisor
))
3305 `(nth-value 1 (truncate number divisor
)))
3307 (deftransform mod
((number divisor
))
3308 `(let ((rem (rem number divisor
)))
3309 (if (and (not (zerop rem
))
3310 (if (minusp divisor
)
3316 ;;; If arg is a constant power of two, turn FLOOR into a shift and
3317 ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
3319 (flet ((frob (y ceil-p
)
3320 (unless (constant-lvar-p y
)
3321 (give-up-ir1-transform))
3322 (let* ((y (lvar-value y
))
3324 (len (1- (integer-length y-abs
))))
3325 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3326 (give-up-ir1-transform))
3327 (let ((shift (- len
))
3329 (delta (if ceil-p
(* (signum y
) (1- y-abs
)) 0)))
3330 `(let ((x (+ x
,delta
)))
3332 `(values (ash (- x
) ,shift
)
3333 (- (- (logand (- x
) ,mask
)) ,delta
))
3334 `(values (ash x
,shift
)
3335 (- (logand x
,mask
) ,delta
))))))))
3336 (deftransform floor
((x y
) (integer integer
) *)
3337 "convert division by 2^k to shift"
3339 (deftransform ceiling
((x y
) (integer integer
) *)
3340 "convert division by 2^k to shift"
3343 ;;; Do the same for MOD.
3344 (deftransform mod
((x y
) (integer integer
) *)
3345 "convert remainder mod 2^k to LOGAND"
3346 (unless (constant-lvar-p y
)
3347 (give-up-ir1-transform))
3348 (let* ((y (lvar-value y
))
3350 (len (1- (integer-length y-abs
))))
3351 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3352 (give-up-ir1-transform))
3353 (let ((mask (1- y-abs
)))
3355 `(- (logand (- x
) ,mask
))
3356 `(logand x
,mask
)))))
3358 ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
3359 (deftransform truncate
((x y
) (integer integer
))
3360 "convert division by 2^k to shift"
3361 (unless (constant-lvar-p y
)
3362 (give-up-ir1-transform))
3363 (let* ((y (lvar-value y
))
3365 (len (1- (integer-length y-abs
))))
3366 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3367 (give-up-ir1-transform))
3368 (let* ((shift (- len
))
3371 (values ,(if (minusp y
)
3373 `(- (ash (- x
) ,shift
)))
3374 (- (logand (- x
) ,mask
)))
3375 (values ,(if (minusp y
)
3376 `(ash (- ,mask x
) ,shift
)
3378 (logand x
,mask
))))))
3380 ;;; And the same for REM.
3381 (deftransform rem
((x y
) (integer integer
) *)
3382 "convert remainder mod 2^k to LOGAND"
3383 (unless (constant-lvar-p y
)
3384 (give-up-ir1-transform))
3385 (let* ((y (lvar-value y
))
3387 (len (1- (integer-length y-abs
))))
3388 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3389 (give-up-ir1-transform))
3390 (let ((mask (1- y-abs
)))
3392 (- (logand (- x
) ,mask
))
3393 (logand x
,mask
)))))
3395 ;;; Return an expression to calculate the integer quotient of X and
3396 ;;; constant Y, using multiplication, shift and add/sub instead of
3397 ;;; division. Both arguments must be unsigned, fit in a machine word and
3398 ;;; Y must neither be zero nor a power of two. The quotient is rounded
3400 ;;; The algorithm is taken from the paper "Division by Invariant
3401 ;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and
3402 ;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the
3403 ;;; case of division by powers of two.
3404 ;;; The algorithm includes an adaptive precision argument. Use it, since
3405 ;;; we often have sub-word value ranges. Careful, in this case, we need
3406 ;;; p s.t 2^p > n, not the ceiling of the binary log.
3407 ;;; Also, for some reason, the paper prefers shifting to masking. Mask
3408 ;;; instead. Masking is equivalent to shifting right, then left again;
3409 ;;; all the intermediate values are still words, so we just have to shift
3410 ;;; right a bit more to compensate, at the end.
3412 ;;; The following two examples show an average case and the worst case
3413 ;;; with respect to the complexity of the generated expression, under
3414 ;;; a word size of 64 bits:
3416 ;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) ->
3417 ;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3)
3419 ;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) ->
3421 ;;; (T1 (%MULTIPLY NUM 2635249153387078803)))
3422 ;;; (ASH (LDB (BYTE 64 0)
3423 ;;; (+ T1 (ASH (LDB (BYTE 64 0)
3428 (defun gen-unsigned-div-by-constant-expr (y max-x
)
3429 (declare (type (integer 3 #.most-positive-word
) y
)
3431 (aver (not (zerop (logand y
(1- y
)))))
3433 ;; the floor of the binary logarithm of (positive) X
3434 (integer-length (1- x
)))
3435 (choose-multiplier (y precision
)
3437 (shift l
(1- shift
))
3438 (expt-2-n+l
(expt 2 (+ sb
!vm
:n-word-bits l
)))
3439 (m-low (truncate expt-2-n
+l y
) (ash m-low -
1))
3440 (m-high (truncate (+ expt-2-n
+l
3441 (ash expt-2-n
+l
(- precision
)))
3444 ((not (and (< (ash m-low -
1) (ash m-high -
1))
3446 (values m-high shift
)))))
3447 (let ((n (expt 2 sb
!vm
:n-word-bits
))
3448 (precision (integer-length max-x
))
3450 (multiple-value-bind (m shift2
)
3451 (choose-multiplier y precision
)
3452 (when (and (>= m n
) (evenp y
))
3453 (setq shift1
(ld (logand y
(- y
))))
3454 (multiple-value-setq (m shift2
)
3455 (choose-multiplier (/ y
(ash 1 shift1
))
3456 (- precision shift1
))))
3459 `(truly-the word
,x
)))
3461 (t1 (%multiply-high num
,(- m n
))))
3462 (ash ,(word `(+ t1
(ash ,(word `(- num t1
))
3465 ((and (zerop shift1
) (zerop shift2
))
3466 (let ((max (truncate max-x y
)))
3467 ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM
3469 `(truly-the (integer 0 ,max
)
3470 (%multiply-high x
,m
))))
3472 `(ash (%multiply-high
(logandc2 x
,(1- (ash 1 shift1
))) ,m
)
3473 ,(- (+ shift1 shift2
)))))))))
3475 ;;; If the divisor is constant and both args are positive and fit in a
3476 ;;; machine word, replace the division by a multiplication and possibly
3477 ;;; some shifts and an addition. Calculate the remainder by a second
3478 ;;; multiplication and a subtraction. Dead code elimination will
3479 ;;; suppress the latter part if only the quotient is needed. If the type
3480 ;;; of the dividend allows to derive that the quotient will always have
3481 ;;; the same value, emit much simpler code to handle that. (This case
3482 ;;; may be rare but it's easy to detect and the compiler doesn't find
3483 ;;; this optimization on its own.)
3484 (deftransform truncate
((x y
) (word (constant-arg word
))
3486 :policy
(and (> speed compilation-speed
)
3488 "convert integer division to multiplication"
3489 (let* ((y (lvar-value y
))
3490 (x-type (lvar-type x
))
3491 (max-x (or (and (numeric-type-p x-type
)
3492 (numeric-type-high x-type
))
3493 most-positive-word
)))
3494 ;; Division by zero, one or powers of two is handled elsewhere.
3495 (when (zerop (logand y
(1- y
)))
3496 (give-up-ir1-transform))
3497 `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x
))
3498 (rem (ldb (byte #.sb
!vm
:n-word-bits
0)
3499 (- x
(* quot
,y
)))))
3500 (values quot rem
))))
3502 ;;;; arithmetic and logical identity operation elimination
3504 ;;; Flush calls to various arith functions that convert to the
3505 ;;; identity function or a constant.
3506 (macrolet ((def (name identity result
)
3507 `(deftransform ,name
((x y
) (* (constant-arg (member ,identity
))) *)
3508 "fold identity operations"
3515 (def logxor -
1 (lognot x
))
3518 (defun least-zero-bit (x)
3520 (1- (integer-length (logxor x
(1+ x
))))))
3522 (deftransform logand
((x y
) (* (constant-arg t
)) *)
3523 "fold identity operation"
3524 (let* ((y (lvar-value y
))
3525 (width (or (least-zero-bit y
) '*)))
3526 (unless (and (neq width
0) ; (logand x 0) handled elsewhere
3527 (csubtypep (lvar-type x
)
3528 (specifier-type `(unsigned-byte ,width
))))
3529 (give-up-ir1-transform))
3532 (deftransform mask-signed-field
((size x
) ((constant-arg t
) *) *)
3533 "fold identity operation"
3534 (let ((size (lvar-value size
)))
3535 (unless (csubtypep (lvar-type x
) (specifier-type `(signed-byte ,size
)))
3536 (give-up-ir1-transform))
3539 (deftransform logior
((x y
) (* (constant-arg integer
)) *)
3540 "fold identity operation"
3541 (let* ((y (lvar-value y
))
3542 (width (or (least-zero-bit (lognot y
))
3543 (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
3544 (unless (csubtypep (lvar-type x
)
3545 (specifier-type `(integer ,(- (ash 1 width
)) -
1)))
3546 (give-up-ir1-transform))
3549 ;;; Pick off easy association opportunities for constant folding.
3550 ;;; More complicated stuff that also depends on commutativity
3551 ;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
3552 ;;; probably be handled with a more general tree-rewriting pass.
3553 (macrolet ((def (operator &key
(type 'integer
) (folded operator
))
3554 `(deftransform ,operator
((x z
) (,type
(constant-arg ,type
)))
3555 ,(format nil
"associate ~A/~A of constants"
3557 (binding* ((node (if (lvar-has-single-use-p x
)
3559 (give-up-ir1-transform)))
3560 (nil (or (and (combination-p node
)
3562 (combination-fun node
))
3564 (give-up-ir1-transform)))
3565 (y (second (combination-args node
)))
3566 (nil (or (constant-lvar-p y
)
3567 (give-up-ir1-transform)))
3569 (unless (typep y
',type
)
3570 (give-up-ir1-transform))
3571 (splice-fun-args x
',folded
2)
3573 (declare (ignore y z
))
3574 ;; (operator (folded x y) z)
3575 ;; == (operator x (folded z y))
3576 (,',operator x
',(,folded
(lvar-value z
) y
)))))))
3580 (def logtest
:folded logand
)
3581 (def + :type rational
)
3582 (def + :type rational
:folded -
)
3583 (def * :type rational
)
3584 (def * :type rational
:folded
/))
3586 (deftransform mask-signed-field
((width x
) ((constant-arg unsigned-byte
) *))
3587 "Fold mask-signed-field/mask-signed-field of constant width"
3588 (binding* ((node (if (lvar-has-single-use-p x
)
3590 (give-up-ir1-transform)))
3591 (nil (or (combination-p node
)
3592 (give-up-ir1-transform)))
3593 (nil (or (eq (lvar-fun-name (combination-fun node
))
3595 (give-up-ir1-transform)))
3596 (x-width (first (combination-args node
)))
3597 (nil (or (constant-lvar-p x-width
)
3598 (give-up-ir1-transform)))
3599 (x-width (lvar-value x-width
)))
3600 (unless (typep x-width
'unsigned-byte
)
3601 (give-up-ir1-transform))
3602 (splice-fun-args x
'mask-signed-field
2)
3603 `(lambda (width x-width x
)
3604 (declare (ignore width x-width
))
3605 (mask-signed-field ,(min (lvar-value width
) x-width
) x
))))
3607 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
3608 ;;; (* 0 -4.0) is -0.0.
3609 (deftransform -
((x y
) ((constant-arg (member 0)) rational
) *)
3610 "convert (- 0 x) to negate"
3612 (deftransform * ((x y
) (rational (constant-arg (member 0))) *)
3613 "convert (* x 0) to 0"
3616 (deftransform %negate
((x) (rational))
3617 "Eliminate %negate/%negate of rationals"
3618 (splice-fun-args x
'%negate
1)
3621 (deftransform %negate
((x) (number))
3623 (let ((use (lvar-uses x
))
3625 (unless (and (combination-p use
)
3626 (eql '* (lvar-fun-name (combination-fun use
)))
3627 (constant-lvar-p (setf arg
(second (combination-args use
))))
3628 (numberp (setf arg
(lvar-value arg
))))
3629 (give-up-ir1-transform))
3630 (splice-fun-args x
'* 2)
3632 (declare (ignore y
))
3635 ;;; Return T if in an arithmetic op including lvars X and Y, the
3636 ;;; result type is not affected by the type of X. That is, Y is at
3637 ;;; least as contagious as X.
3639 (defun not-more-contagious (x y
)
3640 (declare (type continuation x y
))
3641 (let ((x (lvar-type x
))
3643 (values (type= (numeric-contagion x y
)
3644 (numeric-contagion y y
)))))
3645 ;;; Patched version by Raymond Toy. dtc: Should be safer although it
3646 ;;; XXX needs more work as valid transforms are missed; some cases are
3647 ;;; specific to particular transform functions so the use of this
3648 ;;; function may need a re-think.
3649 (defun not-more-contagious (x y
)
3650 (declare (type lvar x y
))
3651 (flet ((simple-numeric-type (num)
3652 (and (numeric-type-p num
)
3653 ;; Return non-NIL if NUM is integer, rational, or a float
3654 ;; of some type (but not FLOAT)
3655 (case (numeric-type-class num
)
3659 (numeric-type-format num
))
3662 (let ((x (lvar-type x
))
3664 (if (and (simple-numeric-type x
)
3665 (simple-numeric-type y
))
3666 (values (type= (numeric-contagion x y
)
3667 (numeric-contagion y y
)))))))
3669 (def!type exact-number
()
3670 '(or rational
(complex rational
)))
3674 ;;; Only safely applicable for exact numbers. For floating-point
3675 ;;; x, one would have to first show that neither x or y are signed
3676 ;;; 0s, and that x isn't an SNaN.
3677 (deftransform + ((x y
) (exact-number (constant-arg (eql 0))) *)
3682 (deftransform -
((x y
) (exact-number (constant-arg (eql 0))) *)
3686 ;;; Fold (OP x +/-1)
3688 ;;; %NEGATE might not always signal correctly.
3690 ((def (name result minus-result
)
3691 `(deftransform ,name
((x y
)
3692 (exact-number (constant-arg (member 1 -
1))))
3693 "fold identity operations"
3694 (if (minusp (lvar-value y
)) ',minus-result
',result
))))
3695 (def * x
(%negate x
))
3696 (def / x
(%negate x
))
3697 (def expt x
(/ 1 x
)))
3699 ;;; Fold (expt x n) into multiplications for small integral values of
3700 ;;; N; convert (expt x 1/2) to sqrt.
3701 (deftransform expt
((x y
) (t (constant-arg real
)) *)
3702 "recode as multiplication or sqrt"
3703 (let ((val (lvar-value y
)))
3704 ;; If Y would cause the result to be promoted to the same type as
3705 ;; Y, we give up. If not, then the result will be the same type
3706 ;; as X, so we can replace the exponentiation with simple
3707 ;; multiplication and division for small integral powers.
3708 (unless (not-more-contagious y x
)
3709 (give-up-ir1-transform))
3711 (let ((x-type (lvar-type x
)))
3712 (cond ((csubtypep x-type
(specifier-type '(or rational
3713 (complex rational
))))
3715 ((csubtypep x-type
(specifier-type 'real
))
3719 ((csubtypep x-type
(specifier-type 'complex
))
3720 ;; both parts are float
3722 (t (give-up-ir1-transform)))))
3723 ((= val
2) '(* x x
))
3724 ((= val -
2) '(/ (* x x
)))
3725 ((= val
3) '(* x x x
))
3726 ((= val -
3) '(/ (* x x x
)))
3727 ((= val
1/2) '(sqrt x
))
3728 ((= val -
1/2) '(/ (sqrt x
)))
3729 (t (give-up-ir1-transform)))))
3731 (deftransform expt
((x y
) ((constant-arg (member -
1 -
1.0 -
1.0d0
)) integer
) *)
3732 "recode as an ODDP check"
3733 (let ((val (lvar-value x
)))
3735 '(- 1 (* 2 (logand 1 y
)))
3740 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
3741 ;;; transformations?
3742 ;;; Perhaps we should have to prove that the denominator is nonzero before
3743 ;;; doing them? -- WHN 19990917
3744 (macrolet ((def (name)
3745 `(deftransform ,name
((x y
) ((constant-arg (integer 0 0)) integer
)
3752 (macrolet ((def (name)
3753 `(deftransform ,name
((x y
) ((constant-arg (integer 0 0)) integer
)
3762 (macrolet ((def (name &optional float
)
3763 (let ((x (if float
'(float x
) 'x
)))
3764 `(deftransform ,name
((x y
) (integer (constant-arg (member 1 -
1)))
3766 "fold division by 1"
3767 `(values ,(if (minusp (lvar-value y
))
3780 ;;;; character operations
3782 (deftransform two-arg-char-equal
((a b
) (base-char base-char
) *
3783 :policy
(> speed space
))
3785 '(let* ((ac (char-code a
))
3787 (sum (logxor ac bc
)))
3789 (when (eql sum
#x20
)
3790 (let ((sum (+ ac bc
)))
3791 (or (and (> sum
161) (< sum
213))
3792 (and (> sum
415) (< sum
461))
3793 (and (> sum
463) (< sum
477))))))))
3795 (deftransform two-arg-char-equal
((a b
) (* (constant-arg character
)) *
3797 (let ((char (lvar-value b
)))
3798 (if (both-case-p char
)
3799 (let ((reverse (if (upper-case-p char
)
3800 (char-downcase char
)
3801 (char-upcase char
))))
3802 (if (policy node
(> speed space
))
3803 `(or (char= a
,char
)
3805 `(char-equal-constant a
,char
,reverse
)))
3808 (deftransform char-upcase
((x) (base-char))
3810 '(let ((n-code (char-code x
)))
3811 (if (or (and (> n-code
#o140
) ; Octal 141 is #\a.
3812 (< n-code
#o173
)) ; Octal 172 is #\z.
3813 (and (> n-code
#o337
)
3815 (and (> n-code
#o367
)
3817 (code-char (logxor #x20 n-code
))
3820 (deftransform char-downcase
((x) (base-char))
3822 '(let ((n-code (char-code x
)))
3823 (if (or (and (> n-code
64) ; 65 is #\A.
3824 (< n-code
91)) ; 90 is #\Z.
3829 (code-char (logxor #x20 n-code
))
3832 ;;;; equality predicate transforms
3834 ;;; Return true if X and Y are lvars whose only use is a
3835 ;;; reference to the same leaf, and the value of the leaf cannot
3837 (defun same-leaf-ref-p (x y
)
3838 (declare (type lvar x y
))
3839 (let ((x-use (principal-lvar-use x
))
3840 (y-use (principal-lvar-use y
)))
3843 (eq (ref-leaf x-use
) (ref-leaf y-use
))
3844 (constant-reference-p x-use
))))
3846 ;;; If X and Y are the same leaf, then the result is true. Otherwise,
3847 ;;; if there is no intersection between the types of the arguments,
3848 ;;; then the result is definitely false.
3849 (deftransform simple-equality-transform
((x y
) * *
3852 ((same-leaf-ref-p x y
) t
)
3853 ((not (types-equal-or-intersect (lvar-type x
) (lvar-type y
)))
3855 (t (give-up-ir1-transform))))
3858 `(%deftransform
',x
'(function * *) #'simple-equality-transform
)))
3861 (def two-arg-char-equal
))
3863 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
3864 ;;; try to convert to a type-specific predicate or EQ:
3865 ;;; -- If both args are characters, convert to CHAR=. This is better than
3866 ;;; just converting to EQ, since CHAR= may have special compilation
3867 ;;; strategies for non-standard representations, etc.
3868 ;;; -- If either arg is definitely a fixnum, we check to see if X is
3869 ;;; constant and if so, put X second. Doing this results in better
3870 ;;; code from the backend, since the backend assumes that any constant
3871 ;;; argument comes second.
3872 ;;; -- If either arg is definitely not a number or a fixnum, then we
3873 ;;; can compare with EQ.
3874 ;;; -- Otherwise, we try to put the arg we know more about second. If X
3875 ;;; is constant then we put it second. If X is a subtype of Y, we put
3876 ;;; it second. These rules make it easier for the back end to match
3877 ;;; these interesting cases.
3878 (deftransform eql
((x y
) * * :node node
)
3879 "convert to simpler equality predicate"
3880 (let ((x-type (lvar-type x
))
3881 (y-type (lvar-type y
))
3882 #!+integer-eql-vop
(int-type (specifier-type 'integer
))
3883 (char-type (specifier-type 'character
)))
3885 ((same-leaf-ref-p x y
) t
)
3886 ((not (types-equal-or-intersect x-type y-type
))
3888 ((and (csubtypep x-type char-type
)
3889 (csubtypep y-type char-type
))
3891 ((or (eq-comparable-type-p x-type
) (eq-comparable-type-p y-type
))
3894 ((or (csubtypep x-type int-type
) (csubtypep y-type int-type
))
3895 '(%eql
/integer x y
))
3897 (give-up-ir1-transform)))))
3899 ;;; similarly to the EQL transform above, we attempt to constant-fold
3900 ;;; or convert to a simpler predicate: mostly we have to be careful
3901 ;;; with strings and bit-vectors.
3902 (deftransform equal
((x y
) * *)
3903 "convert to simpler equality predicate"
3904 (let ((x-type (lvar-type x
))
3905 (y-type (lvar-type y
))
3906 (combination-type (specifier-type '(or bit-vector string
3908 (flet ((both-csubtypep (type)
3909 (let ((ctype (specifier-type type
)))
3910 (and (csubtypep x-type ctype
)
3911 (csubtypep y-type ctype
)))))
3913 ((same-leaf-ref-p x y
) t
)
3914 ((and (constant-lvar-p x
)
3915 (equal (lvar-value x
) ""))
3917 (zerop (length y
))))
3918 ((and (constant-lvar-p y
)
3919 (equal (lvar-value y
) ""))
3921 (zerop (length x
))))
3922 ((both-csubtypep 'string
)
3924 ((both-csubtypep 'bit-vector
)
3925 '(bit-vector-= x y
))
3926 ((both-csubtypep 'pathname
)
3928 ((or (not (types-equal-or-intersect x-type combination-type
))
3929 (not (types-equal-or-intersect y-type combination-type
)))
3930 (if (types-equal-or-intersect x-type y-type
)
3932 ;; Can't simply check for type intersection if both types are combination-type
3933 ;; since array specialization would mean types don't intersect, even when EQUAL
3934 ;; doesn't care for specialization.
3935 ;; Previously checking for intersection in the outer COND resulted in
3937 ;; (equal (the (cons (or simple-bit-vector
3938 ;; simple-base-string))
3940 ;; (the (cons (or (and bit-vector (not simple-array))
3941 ;; (simple-array character (*))))
3943 ;; being incorrectly folded to NIL
3945 (t (give-up-ir1-transform))))))
3947 (deftransform equalp
((x y
) * *)
3948 "convert to simpler equality predicate"
3949 (let ((x-type (lvar-type x
))
3950 (y-type (lvar-type y
))
3951 (combination-type (specifier-type '(or number array
3954 instance hash-table
))))
3955 (flet ((both-csubtypep (type)
3956 (let ((ctype (specifier-type type
)))
3957 (and (csubtypep x-type ctype
)
3958 (csubtypep y-type ctype
)))))
3960 ((same-leaf-ref-p x y
) t
)
3961 ((and (constant-lvar-p x
)
3962 (equal (lvar-value x
) ""))
3964 (zerop (length y
))))
3965 ((and (constant-lvar-p y
)
3966 (equal (lvar-value y
) ""))
3968 (zerop (length x
))))
3969 ((both-csubtypep 'string
)
3970 '(string-equal x y
))
3971 ((both-csubtypep 'bit-vector
)
3972 '(bit-vector-= x y
))
3973 ((both-csubtypep 'pathname
)
3975 ((both-csubtypep 'character
)
3977 ((both-csubtypep 'number
)
3979 ((both-csubtypep 'hash-table
)
3980 '(hash-table-equalp x y
))
3981 ((or (not (types-equal-or-intersect x-type combination-type
))
3982 (not (types-equal-or-intersect y-type combination-type
)))
3983 ;; See the comment about specialized types in the EQUAL transform above
3984 (if (types-equal-or-intersect y-type x-type
)
3987 (t (give-up-ir1-transform))))))
3989 ;;; Convert to EQL if both args are rational and complexp is specified
3990 ;;; and the same for both.
3991 (deftransform = ((x y
) (number number
) *)
3993 (let ((x-type (lvar-type x
))
3994 (y-type (lvar-type y
)))
3995 (cond ((or (and (csubtypep x-type
(specifier-type 'float
))
3996 (csubtypep y-type
(specifier-type 'float
)))
3997 (and (csubtypep x-type
(specifier-type '(complex float
)))
3998 (csubtypep y-type
(specifier-type '(complex float
))))
3999 #!+complex-float-vops
4000 (and (csubtypep x-type
(specifier-type '(or single-float
(complex single-float
))))
4001 (csubtypep y-type
(specifier-type '(or single-float
(complex single-float
)))))
4002 #!+complex-float-vops
4003 (and (csubtypep x-type
(specifier-type '(or double-float
(complex double-float
))))
4004 (csubtypep y-type
(specifier-type '(or double-float
(complex double-float
))))))
4005 ;; They are both floats. Leave as = so that -0.0 is
4006 ;; handled correctly.
4007 (give-up-ir1-transform))
4008 ((or (and (csubtypep x-type
(specifier-type 'rational
))
4009 (csubtypep y-type
(specifier-type 'rational
)))
4010 (and (csubtypep x-type
4011 (specifier-type '(complex rational
)))
4013 (specifier-type '(complex rational
)))))
4014 ;; They are both rationals and complexp is the same.
4018 (give-up-ir1-transform
4019 "The operands might not be the same type.")))))
4021 (defun maybe-float-lvar-p (lvar)
4022 (neq *empty-type
* (type-intersection (specifier-type 'float
)
4025 (flet ((maybe-invert (node op inverted x y
)
4026 ;; Don't invert if either argument can be a float (NaNs)
4028 ((or (maybe-float-lvar-p x
) (maybe-float-lvar-p y
))
4029 (delay-ir1-transform node
:constraint
)
4030 `(or (,op x y
) (= x y
)))
4032 `(if (,inverted x y
) nil t
)))))
4033 (deftransform >= ((x y
) (number number
) * :node node
)
4034 "invert or open code"
4035 (maybe-invert node
'> '< x y
))
4036 (deftransform <= ((x y
) (number number
) * :node node
)
4037 "invert or open code"
4038 (maybe-invert node
'< '> x y
)))
4040 ;;; See whether we can statically determine (< X Y) using type
4041 ;;; information. If X's high bound is < Y's low, then X < Y.
4042 ;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
4043 ;;; NIL). If not, at least make sure any constant arg is second.
4044 (macrolet ((def (name inverse reflexive-p surely-true surely-false
)
4045 `(deftransform ,name
((x y
))
4046 "optimize using intervals"
4047 (if (and (same-leaf-ref-p x y
)
4048 ;; For non-reflexive functions we don't need
4049 ;; to worry about NaNs: (non-ref-op NaN NaN) => false,
4050 ;; but with reflexive ones we don't know...
4052 '((and (not (maybe-float-lvar-p x
))
4053 (not (maybe-float-lvar-p y
))))))
4055 (let ((ix (or (type-approximate-interval (lvar-type x
))
4056 (give-up-ir1-transform)))
4057 (iy (or (type-approximate-interval (lvar-type y
))
4058 (give-up-ir1-transform))))
4063 ((and (constant-lvar-p x
)
4064 (not (constant-lvar-p y
)))
4067 (give-up-ir1-transform))))))))
4068 (def = = t
(interval-= ix iy
) (interval-/= ix iy
))
4069 (def /= /= nil
(interval-/= ix iy
) (interval-= ix iy
))
4070 (def < > nil
(interval-< ix iy
) (interval->= ix iy
))
4071 (def > < nil
(interval-< iy ix
) (interval->= iy ix
))
4072 (def <= >= t
(interval->= iy ix
) (interval-< iy ix
))
4073 (def >= <= t
(interval->= ix iy
) (interval-< ix iy
)))
4075 (defun ir1-transform-char< (x y first second inverse
)
4077 ((same-leaf-ref-p x y
) nil
)
4078 ;; If we had interval representation of character types, as we
4079 ;; might eventually have to to support 2^21 characters, then here
4080 ;; we could do some compile-time computation as in transforms for
4081 ;; < above. -- CSR, 2003-07-01
4082 ((and (constant-lvar-p first
)
4083 (not (constant-lvar-p second
)))
4085 (t (give-up-ir1-transform))))
4087 (deftransform char
< ((x y
) (character character
) *)
4088 (ir1-transform-char< x y x y
'char
>))
4090 (deftransform char
> ((x y
) (character character
) *)
4091 (ir1-transform-char< y x x y
'char
<))
4093 ;;;; converting N-arg comparisons
4095 ;;;; We convert calls to N-arg comparison functions such as < into
4096 ;;;; two-arg calls. This transformation is enabled for all such
4097 ;;;; comparisons in this file. If any of these predicates are not
4098 ;;;; open-coded, then the transformation should be removed at some
4099 ;;;; point to avoid pessimization.
4101 ;;; This function is used for source transformation of N-arg
4102 ;;; comparison functions other than inequality. We deal both with
4103 ;;; converting to two-arg calls and inverting the sense of the test,
4104 ;;; if necessary. If the call has two args, then we pass or return a
4105 ;;; negated test as appropriate. If it is a degenerate one-arg call,
4106 ;;; then we transform to code that returns true. Otherwise, we bind
4107 ;;; all the arguments and expand into a bunch of IFs.
4108 (defun multi-compare (predicate args not-p type
&optional force-two-arg-p
)
4109 (let ((nargs (length args
)))
4110 (cond ((< nargs
1) (values nil t
))
4111 ((= nargs
1) `(progn (the ,type
,@args
) t
))
4114 `(if (,predicate
,(first args
) ,(second args
)) nil t
)
4116 `(,predicate
,(first args
) ,(second args
))
4119 (do* ((i (1- nargs
) (1- i
))
4121 (current (gensym) (gensym))
4122 (vars (list current
) (cons current vars
))
4124 `(if (,predicate
,current
,last
)
4126 `(if (,predicate
,current
,last
)
4129 `((lambda ,vars
(declare (type ,type
,@vars
)) ,result
)
4132 (define-source-transform = (&rest args
) (multi-compare '= args nil
'number
))
4133 (define-source-transform < (&rest args
) (multi-compare '< args nil
'real
))
4134 (define-source-transform > (&rest args
) (multi-compare '> args nil
'real
))
4135 ;;; We cannot do the inversion for >= and <= here, since both
4136 ;;; (< NaN X) and (> NaN X)
4137 ;;; are false, and we don't have type-information available yet. The
4138 ;;; deftransforms for two-argument versions of >= and <= takes care of
4139 ;;; the inversion to > and < when possible.
4140 (define-source-transform <= (&rest args
) (multi-compare '<= args nil
'real
))
4141 (define-source-transform >= (&rest args
) (multi-compare '>= args nil
'real
))
4143 (define-source-transform char
= (&rest args
) (multi-compare 'char
= args nil
4145 (define-source-transform char
< (&rest args
) (multi-compare 'char
< args nil
4147 (define-source-transform char
> (&rest args
) (multi-compare 'char
> args nil
4149 (define-source-transform char
<= (&rest args
) (multi-compare 'char
> args t
4151 (define-source-transform char
>= (&rest args
) (multi-compare 'char
< args t
4154 (define-source-transform char-equal
(&rest args
)
4155 (multi-compare 'two-arg-char-equal args nil
'character t
))
4156 (define-source-transform char-lessp
(&rest args
)
4157 (multi-compare 'two-arg-char-lessp args nil
'character t
))
4158 (define-source-transform char-greaterp
(&rest args
)
4159 (multi-compare 'two-arg-char-greaterp args nil
'character t
))
4160 (define-source-transform char-not-greaterp
(&rest args
)
4161 (multi-compare 'two-arg-char-greaterp args t
'character t
))
4162 (define-source-transform char-not-lessp
(&rest args
)
4163 (multi-compare 'two-arg-char-lessp args t
'character t
))
4165 ;;; This function does source transformation of N-arg inequality
4166 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
4167 ;;; arg cases. If there are more than two args, then we expand into
4168 ;;; the appropriate n^2 comparisons only when speed is important.
4169 (declaim (ftype (function (symbol list t
) *) multi-not-equal
))
4170 (defun multi-not-equal (predicate args type
)
4171 (let ((nargs (length args
)))
4172 (cond ((< nargs
1) (values nil t
))
4173 ((= nargs
1) `(progn (the ,type
,@args
) t
))
4175 `(if (,predicate
,(first args
) ,(second args
)) nil t
))
4176 ((not (policy *lexenv
*
4177 (and (>= speed space
)
4178 (>= speed compilation-speed
))))
4181 (let ((vars (make-gensym-list nargs
)))
4182 (do ((var vars next
)
4183 (next (cdr vars
) (cdr next
))
4186 `((lambda ,vars
(declare (type ,type
,@vars
)) ,result
)
4188 (let ((v1 (first var
)))
4190 (setq result
`(if (,predicate
,v1
,v2
) nil
,result
))))))))))
4192 (define-source-transform /= (&rest args
)
4193 (multi-not-equal '= args
'number
))
4194 (define-source-transform char
/= (&rest args
)
4195 (multi-not-equal 'char
= args
'character
))
4196 (define-source-transform char-not-equal
(&rest args
)
4197 (multi-not-equal 'char-equal args
'character
))
4199 ;;; Expand MAX and MIN into the obvious comparisons.
4200 (define-source-transform max
(arg0 &rest rest
)
4201 (once-only ((arg0 arg0
))
4203 `(values (the real
,arg0
))
4204 `(let ((maxrest (max ,@rest
)))
4205 (if (>= ,arg0 maxrest
) ,arg0 maxrest
)))))
4206 (define-source-transform min
(arg0 &rest rest
)
4207 (once-only ((arg0 arg0
))
4209 `(values (the real
,arg0
))
4210 `(let ((minrest (min ,@rest
)))
4211 (if (<= ,arg0 minrest
) ,arg0 minrest
)))))
4213 ;;; Simplify some cross-type comparisons
4214 (macrolet ((def (comparator round
)
4216 (deftransform ,comparator
4217 ((x y
) (rational (constant-arg float
)))
4218 "open-code RATIONAL to FLOAT comparison"
4219 (let ((y (lvar-value y
)))
4221 (when (or (float-nan-p y
)
4222 (float-infinity-p y
))
4223 (give-up-ir1-transform))
4224 (setf y
(rational y
))
4226 x
,(if (csubtypep (lvar-type x
)
4227 (specifier-type 'integer
))
4230 (deftransform ,comparator
4231 ((x y
) (integer (constant-arg ratio
)))
4232 "open-code INTEGER to RATIO comparison"
4233 `(,',comparator x
,(,round
(lvar-value y
)))))))
4237 (deftransform = ((x y
) (rational (constant-arg float
)))
4238 "open-code RATIONAL to FLOAT comparison"
4239 (let ((y (lvar-value y
)))
4241 (when (or (float-nan-p y
)
4242 (float-infinity-p y
))
4243 (give-up-ir1-transform))
4244 (setf y
(rational y
))
4245 (if (and (csubtypep (lvar-type x
)
4246 (specifier-type 'integer
))
4251 (deftransform = ((x y
) (integer (constant-arg ratio
)))
4252 "constant-fold INTEGER to RATIO comparison"
4255 ;;;; converting N-arg arithmetic functions
4257 ;;;; N-arg arithmetic and logic functions are associated into two-arg
4258 ;;;; versions, and degenerate cases are flushed.
4260 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
4261 (declaim (ftype (sfunction (symbol t list
) list
) associate-args
))
4262 (defun associate-args (fun first-arg more-args
)
4264 (let ((next (rest more-args
))
4265 (arg (first more-args
)))
4267 `(,fun
,first-arg
,arg
)
4268 (associate-args fun
`(,fun
,first-arg
,arg
) next
))))
4270 ;;; Reduce constants in ARGS list.
4271 (declaim (ftype (sfunction (symbol list symbol
) list
) reduce-constants
))
4272 (defun reduce-constants (fun args one-arg-result-type
)
4273 (let ((one-arg-constant-p (ecase one-arg-result-type
4275 (integer #'integerp
)))
4278 (collect ((not-constants))
4280 (let ((value (if (constantp arg
)
4281 (constant-form-value arg
)
4283 (cond ((not (funcall one-arg-constant-p value
))
4284 (not-constants arg
))
4286 (setf reduced-value
(funcall fun reduced-value value
)
4289 (setf reduced-value value
)))))
4290 ;; It is tempting to drop constants reduced to identity here,
4291 ;; but if X is SNaN in (* X 1), we cannot drop the 1.
4294 `(,reduced-value
,@(not-constants))
4296 `(,reduced-value
)))))
4298 ;;; Do source transformations for transitive functions such as +.
4299 ;;; One-arg cases are replaced with the arg and zero arg cases with
4300 ;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE)
4301 ;;; that the argument in one-argument calls is.
4302 (declaim (ftype (function (symbol list t
&optional symbol list
)
4303 (values t
&optional
(member nil t
)))
4304 source-transform-transitive
))
4305 (defun source-transform-transitive (fun args identity
4306 &optional
(one-arg-result-type 'number
)
4307 (one-arg-prefixes '(values)))
4310 (1 `(,@one-arg-prefixes
(the ,one-arg-result-type
,(first args
))))
4313 (let* ((reduced-args (reduce-constants fun args one-arg-result-type
))
4314 (first (first reduced-args
))
4315 (rest (rest reduced-args
)))
4317 (associate-args fun first rest
)
4320 (define-source-transform + (&rest args
)
4321 (source-transform-transitive '+ args
0))
4322 (define-source-transform * (&rest args
)
4323 (source-transform-transitive '* args
1))
4324 (define-source-transform logior
(&rest args
)
4325 (source-transform-transitive 'logior args
0 'integer
))
4326 (define-source-transform logxor
(&rest args
)
4327 (source-transform-transitive 'logxor args
0 'integer
))
4328 (define-source-transform logand
(&rest args
)
4329 (source-transform-transitive 'logand args -
1 'integer
))
4330 (define-source-transform logeqv
(&rest args
)
4331 (source-transform-transitive 'logeqv args -
1 'integer
))
4332 (define-source-transform gcd
(&rest args
)
4333 (source-transform-transitive 'gcd args
0 'integer
'(abs)))
4334 (define-source-transform lcm
(&rest args
)
4335 (source-transform-transitive 'lcm args
1 'integer
'(abs)))
4337 ;;; Do source transformations for intransitive n-arg functions such as
4338 ;;; /. With one arg, we form the inverse. With two args we pass.
4339 ;;; Otherwise we associate into two-arg calls.
4340 (declaim (ftype (function (symbol symbol list list
&optional symbol
)
4341 (values list
&optional
(member nil t
)))
4342 source-transform-intransitive
))
4343 (defun source-transform-intransitive (fun fun
* args one-arg-prefixes
4344 &optional
(one-arg-result-type 'number
))
4346 ((0 2) (values nil t
))
4347 (1 `(,@one-arg-prefixes
(the ,one-arg-result-type
,(first args
))))
4350 (reduce-constants fun
* (rest args
) one-arg-result-type
)))
4351 (associate-args fun
(first args
) reduced-args
)))))
4353 (define-source-transform -
(&rest args
)
4354 (source-transform-intransitive '-
'+ args
'(%negate
)))
4355 (define-source-transform / (&rest args
)
4356 (source-transform-intransitive '/ '* args
'(/ 1)))
4358 ;;;; transforming APPLY
4360 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
4361 ;;; only needs to understand one kind of variable-argument call. It is
4362 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
4363 (define-source-transform apply
(fun arg
&rest more-args
)
4364 (let ((args (cons arg more-args
)))
4365 `(multiple-value-call ,fun
4366 ,@(mapcar (lambda (x) `(values ,x
)) (butlast args
))
4367 (values-list ,(car (last args
))))))
4369 ;;;; transforming references to &REST argument
4371 ;;; We add magical &MORE arguments to all functions with &REST. If ARG names
4372 ;;; the &REST argument, this returns the lambda-vars for the context and
4374 (defun possible-rest-arg-context (arg)
4376 (let* ((var (lexenv-find arg vars
))
4377 (info (when (lambda-var-p var
)
4378 (lambda-var-arg-info var
))))
4380 (eq :rest
(arg-info-kind info
))
4381 (consp (arg-info-default info
)))
4382 (values-list (arg-info-default info
))))))
4384 (defun mark-more-context-used (rest-var)
4385 (let ((info (lambda-var-arg-info rest-var
)))
4386 (aver (eq :rest
(arg-info-kind info
)))
4387 (destructuring-bind (context count
&optional used
) (arg-info-default info
)
4389 (setf (arg-info-default info
) (list context count t
))))))
4391 (defun mark-more-context-invalid (rest-var)
4392 (let ((info (lambda-var-arg-info rest-var
)))
4393 (aver (eq :rest
(arg-info-kind info
)))
4394 (setf (arg-info-default info
) t
)))
4396 ;;; This determines of we the REF to a &REST variable is headed towards
4397 ;;; parts unknown, or if we can really use the context.
4398 (defun rest-var-more-context-ok (lvar)
4399 (let* ((use (lvar-use lvar
))
4400 (var (when (ref-p use
) (ref-leaf use
)))
4401 (home (when (lambda-var-p var
) (lambda-var-home var
)))
4402 (info (when (lambda-var-p var
) (lambda-var-arg-info var
)))
4403 (restp (when info
(eq :rest
(arg-info-kind info
)))))
4404 (flet ((ref-good-for-more-context-p (ref)
4405 (when (not (node-lvar ref
)) ; ref that goes nowhere is ok
4406 (return-from ref-good-for-more-context-p t
))
4407 (let ((dest (principal-lvar-end (node-lvar ref
))))
4408 (and (combination-p dest
)
4409 ;; If the destination is to anything but these, we're going to
4410 ;; actually need the rest list -- and since other operations
4411 ;; might modify the list destructively, the using the context
4412 ;; isn't good anywhere else either.
4413 (lvar-fun-is (combination-fun dest
)
4414 '(%rest-values %rest-ref %rest-length
4415 %rest-null %rest-true
))
4416 ;; If the home lambda is different and isn't DX, it might
4417 ;; escape -- in which case using the more context isn't safe.
4418 (let ((clambda (node-home-lambda dest
)))
4419 (or (eq home clambda
)
4420 (leaf-dynamic-extent clambda
)))))))
4421 (let ((ok (and restp
4422 (consp (arg-info-default info
))
4423 (not (lambda-var-specvar var
))
4424 (not (lambda-var-sets var
))
4425 (every #'ref-good-for-more-context-p
(lambda-var-refs var
)))))
4427 (mark-more-context-used var
)
4429 (mark-more-context-invalid var
)))
4432 ;;; VALUES-LIST -> %REST-VALUES
4433 (define-source-transform values-list
(list)
4434 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4436 `(%rest-values
,list
,context
,count
)
4439 ;;; NTH -> %REST-REF
4440 (define-source-transform nth
(n list
)
4441 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4443 `(%rest-ref
,n
,list
,context
,count
)
4444 `(car (nthcdr ,n
,list
)))))
4445 (define-source-transform fast-
&rest-nth
(n list
)
4446 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4448 `(%rest-ref
,n
,list
,context
,count t
)
4449 (bug "no &REST context for FAST-REST-NTH"))))
4451 (define-source-transform elt
(seq n
)
4452 (if (policy *lexenv
* (= safety
3))
4454 (multiple-value-bind (context count
) (possible-rest-arg-context seq
)
4456 `(%rest-ref
,n
,seq
,context
,count
)
4459 ;;; CAxR -> %REST-REF
4460 (defun source-transform-car (list nth
)
4461 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4463 `(%rest-ref
,nth
,list
,context
,count
)
4466 (define-source-transform car
(list)
4467 (source-transform-car list
0))
4469 (define-source-transform cadr
(list)
4470 (or (source-transform-car list
1)
4471 `(car (cdr ,list
))))
4473 (define-source-transform caddr
(list)
4474 (or (source-transform-car list
2)
4475 `(car (cdr (cdr ,list
)))))
4477 (define-source-transform cadddr
(list)
4478 (or (source-transform-car list
3)
4479 `(car (cdr (cdr (cdr ,list
))))))
4481 ;;; LENGTH -> %REST-LENGTH
4482 (defun source-transform-length (list)
4483 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4485 `(%rest-length
,list
,context
,count
)
4487 (define-source-transform length
(list) (source-transform-length list
))
4488 (define-source-transform list-length
(list) (source-transform-length list
))
4490 ;;; ENDP, NULL and NOT -> %REST-NULL
4492 ;;; Outside &REST convert into an IF so that IF optimizations will eliminate
4493 ;;; redundant negations.
4494 (defun source-transform-null (x op
)
4495 (multiple-value-bind (context count
) (possible-rest-arg-context x
)
4497 `(%rest-null
',op
,x
,context
,count
))
4499 `(if (the list
,x
) nil t
))
4502 (define-source-transform not
(x) (source-transform-null x
'not
))
4503 (define-source-transform null
(x) (source-transform-null x
'null
))
4504 (define-source-transform endp
(x) (source-transform-null x
'endp
))
4506 (deftransform %rest-values
((list context count
))
4507 (if (rest-var-more-context-ok list
)
4508 `(%more-arg-values context
0 count
)
4509 `(values-list list
)))
4511 (deftransform %rest-ref
((n list context count
&optional length-checked-p
))
4512 (cond ((rest-var-more-context-ok list
)
4513 (if (and (constant-lvar-p length-checked-p
)
4514 (lvar-value length-checked-p
))
4515 `(%more-arg context n
)
4516 `(and (< (the index n
) count
) (%more-arg context n
))))
4517 ((and (constant-lvar-p n
) (zerop (lvar-value n
)))
4522 (deftransform %rest-length
((list context count
))
4523 (if (rest-var-more-context-ok list
)
4527 (deftransform %rest-null
((op list context count
))
4528 (aver (constant-lvar-p op
))
4529 (if (rest-var-more-context-ok list
)
4531 `(,(lvar-value op
) list
)))
4533 (deftransform %rest-true
((list context count
))
4534 (if (rest-var-more-context-ok list
)
4535 `(not (eql 0 count
))
4538 ;;;; transforming FORMAT
4540 ;;;; If the control string is a compile-time constant, then replace it
4541 ;;;; with a use of the FORMATTER macro so that the control string is
4542 ;;;; ``compiled.'' Furthermore, if the destination is either a stream
4543 ;;;; or T and the control string is a function (i.e. FORMATTER), then
4544 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
4546 ;;; for compile-time argument count checking.
4548 ;;; FIXME II: In some cases, type information could be correlated; for
4549 ;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
4550 ;;; of a corresponding argument is known and does not intersect the
4551 ;;; list type, a warning could be signalled.
4552 (defun check-format-args (string args fun
)
4553 (declare (type string string
))
4554 (unless (typep string
'simple-string
)
4555 (setq string
(coerce string
'simple-string
)))
4556 (multiple-value-bind (min max
)
4557 (handler-case (sb!format
:%compiler-walk-format-string string args
)
4558 (sb!format
:format-error
(c)
4559 (compiler-warn "~A" c
)))
4561 (let ((nargs (length args
)))
4564 (warn 'format-too-few-args-warning
4566 "Too few arguments (~D) to ~S ~S: requires at least ~D."
4567 :format-arguments
(list nargs fun string min
)))
4569 (warn 'format-too-many-args-warning
4571 "Too many arguments (~D) to ~S ~S: uses at most ~D."
4572 :format-arguments
(list nargs fun string max
))))))))
4574 (defoptimizer (format optimizer
) ((dest control
&rest args
))
4575 (declare (ignore dest
))
4576 (when (constant-lvar-p control
)
4577 (let ((x (lvar-value control
)))
4579 (check-format-args x args
'format
)))))
4581 (defoptimizer (format derive-type
) ((dest control
&rest args
))
4582 (declare (ignore control args
))
4583 (when (and (constant-lvar-p dest
)
4584 (null (lvar-value dest
)))
4585 (specifier-type '(simple-array character
(*)))))
4587 ;;; We disable this transform in the cross-compiler to save memory in
4588 ;;; the target image; most of the uses of FORMAT in the compiler are for
4589 ;;; error messages, and those don't need to be particularly fast.
4591 (deftransform format
((dest control
&rest args
) (t simple-string
&rest t
) *
4592 :policy
(>= speed space
))
4593 (unless (constant-lvar-p control
)
4594 (give-up-ir1-transform "The control string is not a constant."))
4595 (let* ((argc (length args
))
4596 (arg-names (make-gensym-list argc
))
4597 (control (lvar-value control
))
4598 ;; Expanding the control string now avoids deferring to FORMATTER
4599 ;; so that we don't need an internal-only variant of it that
4600 ;; passes through extra args to %FORMATTER.
4601 (expr (handler-case ; in case %formatter wants to signal an error
4602 (sb!format
::%formatter control argc nil
)
4603 ;; otherwise, let the macro complain
4604 (sb!format
:format-error
() `(formatter ,control
)))))
4605 `(lambda (dest control
,@arg-names
)
4606 (declare (ignore control
))
4607 (format dest
,expr
,@arg-names
))))
4609 (deftransform format
((stream control
&rest args
) (stream function
&rest t
))
4610 (let ((arg-names (make-gensym-list (length args
))))
4611 `(lambda (stream control
,@arg-names
)
4612 (funcall control stream
,@arg-names
)
4615 (deftransform format
((tee control
&rest args
) ((member t
) function
&rest t
))
4616 (let ((arg-names (make-gensym-list (length args
))))
4617 `(lambda (tee control
,@arg-names
)
4618 (declare (ignore tee
))
4619 (funcall control
*standard-output
* ,@arg-names
)
4622 (deftransform format
((stream control
&rest args
) (null function
&rest t
))
4623 (let ((arg-names (make-gensym-list (length args
))))
4624 `(lambda (stream control
,@arg-names
)
4625 (declare (ignore stream
))
4626 (with-simple-output-to-string (stream)
4627 (funcall control stream
,@arg-names
)))))
4629 (defun concatenate-format-p (control args
)
4631 (loop for directive in control
4633 (or (stringp directive
)
4634 (and (sb!format
::format-directive-p directive
)
4635 (let ((char (sb!format
::format-directive-character directive
))
4636 (params (sb!format
::format-directive-params directive
)))
4639 (char-equal char
#\a)
4645 (null (sb!format
::format-directive-colonp directive
))
4646 (null (sb!format
::format-directive-atsignp directive
))
4649 '(cons (cons (eql 1) unsigned-byte
) null
)))))))))
4652 (deftransform format
((stream control
&rest args
) (null (constant-arg string
) &rest string
))
4655 (sb!format
::tokenize-control-string
(lvar-value control
))
4656 (sb!format
:format-error
()
4657 (give-up-ir1-transform)))))
4658 (unless (concatenate-format-p tokenized args
)
4659 (give-up-ir1-transform))
4660 (let ((arg-names (make-gensym-list (length args
))))
4661 `(lambda (stream control
,@arg-names
)
4662 (declare (ignore stream control
))
4665 ,@(loop for directive in tokenized
4666 for char
= (and (not (stringp directive
))
4667 (sb!format
::format-directive-character directive
))
4671 ((char-equal char
#\a)
4674 (let ((n (or (cdar (sb!format
::format-directive-params directive
))
4684 (deftransform pathname
((pathspec) (pathname) *)
4687 (deftransform pathname
((pathspec) (string) *)
4688 '(values (parse-namestring pathspec
)))
4692 `(defoptimizer (,name optimizer
) ((control &rest args
))
4693 (when (constant-lvar-p control
)
4694 (let ((x (lvar-value control
)))
4696 (check-format-args x args
',name
)))))))
4699 #+sb-xc-host
; Only we should be using these
4702 (def compiler-error
)
4704 (def compiler-style-warn
)
4705 (def compiler-notify
)
4706 (def maybe-compiler-notify
)
4709 (defoptimizer (cerror optimizer
) ((report control
&rest args
))
4710 (when (and (constant-lvar-p control
)
4711 (constant-lvar-p report
))
4712 (let ((x (lvar-value control
))
4713 (y (lvar-value report
)))
4714 (when (and (stringp x
) (stringp y
))
4715 (multiple-value-bind (min1 max1
)
4717 (sb!format
:%compiler-walk-format-string x args
)
4718 (sb!format
:format-error
(c)
4719 (compiler-warn "~A" c
)))
4721 (multiple-value-bind (min2 max2
)
4723 (sb!format
:%compiler-walk-format-string y args
)
4724 (sb!format
:format-error
(c)
4725 (compiler-warn "~A" c
)))
4727 (let ((nargs (length args
)))
4729 ((< nargs
(min min1 min2
))
4730 (warn 'format-too-few-args-warning
4732 "Too few arguments (~D) to ~S ~S ~S: ~
4733 requires at least ~D."
4735 (list nargs
'cerror y x
(min min1 min2
))))
4736 ((> nargs
(max max1 max2
))
4737 (warn 'format-too-many-args-warning
4739 "Too many arguments (~D) to ~S ~S ~S: ~
4742 (list nargs
'cerror y x
(max max1 max2
))))))))))))))
4744 (defun constant-cons-type (type)
4745 (multiple-value-bind (singleton value
)
4746 (type-singleton-p type
)
4751 (multiple-value-bind (car car-good
)
4752 (constant-cons-type (cons-type-car-type type
))
4753 (multiple-value-bind (cdr cdr-good
)
4754 (constant-cons-type (cons-type-cdr-type type
))
4755 (and car-good cdr-good
4756 (values (cons car cdr
) t
)))))))))
4758 (defoptimizer (coerce derive-type
) ((value type
) node
)
4759 (multiple-value-bind (type constant
)
4760 (if (constant-lvar-p type
)
4761 (values (lvar-value type
) t
)
4762 (constant-cons-type (lvar-type type
)))
4764 ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
4765 ;; but dealing with the niggle that complex canonicalization gets
4766 ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
4768 (let ((result-typeoid (careful-specifier-type type
)))
4770 ((null result-typeoid
) nil
)
4771 ((csubtypep result-typeoid
(specifier-type 'number
))
4772 ;; the difficult case: we have to cope with ANSI 12.1.5.3
4773 ;; Rule of Canonical Representation for Complex Rationals,
4774 ;; which is a truly nasty delivery to field.
4776 ((csubtypep result-typeoid
(specifier-type 'real
))
4777 ;; cleverness required here: it would be nice to deduce
4778 ;; that something of type (INTEGER 2 3) coerced to type
4779 ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0).
4780 ;; FLOAT gets its own clause because it's implemented as
4781 ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE
4784 ((and (numeric-type-p result-typeoid
)
4785 (eq (numeric-type-complexp result-typeoid
) :real
))
4786 ;; FIXME: is this clause (a) necessary or (b) useful?
4788 ((or (csubtypep result-typeoid
4789 (specifier-type '(complex single-float
)))
4790 (csubtypep result-typeoid
4791 (specifier-type '(complex double-float
)))
4793 (csubtypep result-typeoid
4794 (specifier-type '(complex long-float
))))
4795 ;; float complex types are never canonicalized.
4798 ;; if it's not a REAL, or a COMPLEX FLOAToid, it's
4799 ;; probably just a COMPLEX or equivalent. So, in that
4800 ;; case, we will return a complex or an object of the
4801 ;; provided type if it's rational:
4802 (type-union result-typeoid
4803 (type-intersection (lvar-type value
)
4804 (specifier-type 'rational
))))))
4805 ((and (policy node
(zerop safety
))
4806 (csubtypep result-typeoid
(specifier-type '(array * (*)))))
4807 ;; At zero safety the deftransform for COERCE can elide dimension
4808 ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
4809 ;; need to simplify the type to drop the dimension information.
4810 (let ((vtype (simplify-vector-type result-typeoid
)))
4812 (specifier-type vtype
)
4815 result-typeoid
))))))
4817 (defoptimizer (compile derive-type
) ((nameoid function
))
4818 (declare (ignore function
))
4819 (when (csubtypep (lvar-type nameoid
)
4820 (specifier-type 'null
))
4821 (values-specifier-type '(values function boolean boolean
))))
4823 ;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
4824 ;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
4825 ;;; optimizer, above).
4826 (defoptimizer (array-element-type derive-type
) ((array))
4827 (let ((array-type (lvar-type array
)))
4828 (labels ((consify (list)
4831 `(cons (eql ,(car list
)) ,(consify (rest list
)))))
4832 (get-element-type (a)
4834 (type-specifier (array-type-specialized-element-type a
))))
4835 (cond ((eq element-type
'*)
4836 (specifier-type 'type-specifier
))
4837 ((symbolp element-type
)
4838 (make-member-type :members
(list element-type
)))
4839 ((consp element-type
)
4840 (specifier-type (consify element-type
)))
4842 (error "can't understand type ~S~%" element-type
))))))
4843 (labels ((recurse (type)
4844 (cond ((array-type-p type
)
4845 (get-element-type type
))
4846 ((union-type-p type
)
4848 (mapcar #'recurse
(union-type-types type
))))
4850 *universal-type
*))))
4851 (recurse array-type
)))))
4853 (define-source-transform sb
!impl
::sort-vector
(vector start end predicate key
)
4854 ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
4855 ;; isn't really related to the CMU CL code, since instead of trying
4856 ;; to generalize the CMU CL code to allow START and END values, this
4857 ;; code has been written from scratch following Chapter 7 of
4858 ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
4859 `(macrolet ((%index
(x) `(truly-the index
,x
))
4860 (%parent
(i) `(ash ,i -
1))
4861 (%left
(i) `(%index
(ash ,i
1)))
4862 (%right
(i) `(%index
(1+ (ash ,i
1))))
4865 (left (%left i
) (%left i
)))
4866 ((> left current-heap-size
))
4867 (declare (type index i left
))
4868 (let* ((i-elt (%elt i
))
4869 (i-key (funcall keyfun i-elt
))
4870 (left-elt (%elt left
))
4871 (left-key (funcall keyfun left-elt
)))
4872 (multiple-value-bind (large large-elt large-key
)
4873 (if (funcall ,',predicate i-key left-key
)
4874 (values left left-elt left-key
)
4875 (values i i-elt i-key
))
4876 (let ((right (%right i
)))
4877 (multiple-value-bind (largest largest-elt
)
4878 (if (> right current-heap-size
)
4879 (values large large-elt
)
4880 (let* ((right-elt (%elt right
))
4881 (right-key (funcall keyfun right-elt
)))
4882 (if (funcall ,',predicate large-key right-key
)
4883 (values right right-elt
)
4884 (values large large-elt
))))
4885 (cond ((= largest i
)
4888 (setf (%elt i
) largest-elt
4889 (%elt largest
) i-elt
4891 (%sort-vector
(keyfun &optional
(vtype 'vector
))
4892 `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had
4893 ;; trouble getting type inference to
4894 ;; propagate all the way through this
4895 ;; tangled mess of inlining. The TRULY-THE
4896 ;; here works around that. -- WHN
4898 `(aref (truly-the ,',vtype
,',',vector
)
4899 (%index
(+ (%index
,i
) start-1
)))))
4900 (let (;; Heaps prefer 1-based addressing.
4901 (start-1 (1- ,',start
))
4902 (current-heap-size (- ,',end
,',start
))
4904 (declare (type (integer -
1 #.
(1- sb
!xc
:most-positive-fixnum
))
4906 (declare (type index current-heap-size
))
4907 (declare (type function keyfun
))
4908 (loop for i of-type index
4909 from
(ash current-heap-size -
1) downto
1 do
4912 (when (< current-heap-size
2)
4914 (rotatef (%elt
1) (%elt current-heap-size
))
4915 (decf current-heap-size
)
4917 (if (typep ,vector
'simple-vector
)
4918 ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
4919 ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
4921 ;; Special-casing the KEY=NIL case lets us avoid some
4923 (%sort-vector
#'identity simple-vector
)
4924 (%sort-vector
,key simple-vector
))
4925 ;; It's hard to anticipate many speed-critical applications for
4926 ;; sorting vector types other than (VECTOR T), so we just lump
4927 ;; them all together in one slow dynamically typed mess.
4929 (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
4930 (%sort-vector
(or ,key
#'identity
))))))
4932 (deftransform sort
((list predicate
&key key
)
4934 `(sb!impl
::stable-sort-list list
4935 (%coerce-callable-to-fun predicate
)
4936 (if key
(%coerce-callable-to-fun key
) #'identity
)))
4938 (deftransform stable-sort
((sequence predicate
&key key
)
4939 ((or vector list
) *))
4940 (let ((sequence-type (lvar-type sequence
)))
4941 (cond ((csubtypep sequence-type
(specifier-type 'list
))
4942 `(sb!impl
::stable-sort-list sequence
4943 (%coerce-callable-to-fun predicate
)
4944 (if key
(%coerce-callable-to-fun key
) #'identity
)))
4945 ((csubtypep sequence-type
(specifier-type 'simple-vector
))
4946 `(sb!impl
::stable-sort-simple-vector sequence
4947 (%coerce-callable-to-fun predicate
)
4948 (and key
(%coerce-callable-to-fun key
))))
4950 `(sb!impl
::stable-sort-vector sequence
4951 (%coerce-callable-to-fun predicate
)
4952 (and key
(%coerce-callable-to-fun key
)))))))
4954 ;;;; debuggers' little helpers
4956 ;;; for debugging when transforms are behaving mysteriously,
4957 ;;; e.g. when debugging a problem with an ASH transform
4958 ;;; (defun foo (&optional s)
4959 ;;; (sb-c::/report-lvar s "S outside WHEN")
4960 ;;; (when (and (integerp s) (> s 3))
4961 ;;; (sb-c::/report-lvar s "S inside WHEN")
4962 ;;; (let ((bound (ash 1 (1- s))))
4963 ;;; (sb-c::/report-lvar bound "BOUND")
4964 ;;; (let ((x (- bound))
4966 ;;; (sb-c::/report-lvar x "X")
4967 ;;; (sb-c::/report-lvar x "Y"))
4968 ;;; `(integer ,(- bound) ,(1- bound)))))
4969 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
4970 ;;; and the function doesn't do anything at all.)
4973 (defknown /report-lvar
(t t
) null
)
4974 (deftransform /report-lvar
((x message
) (t t
))
4975 (format t
"~%/in /REPORT-LVAR~%")
4976 (format t
"/(LVAR-TYPE X)=~S~%" (lvar-type x
))
4977 (when (constant-lvar-p x
)
4978 (format t
"/(LVAR-VALUE X)=~S~%" (lvar-value x
)))
4979 (format t
"/MESSAGE=~S~%" (lvar-value message
))
4980 (give-up-ir1-transform "not a real transform"))
4981 (defun /report-lvar
(x message
)
4982 (declare (ignore x message
))))
4984 (deftransform encode-universal-time
4985 ((second minute hour date month year
&optional time-zone
)
4986 ((constant-arg (mod 60)) (constant-arg (mod 60))
4987 (constant-arg (mod 24))
4988 (constant-arg (integer 1 31))
4989 (constant-arg (integer 1 12))
4990 (constant-arg (integer 1899))
4991 (constant-arg (rational -
24 24))))
4992 (let ((second (lvar-value second
))
4993 (minute (lvar-value minute
))
4994 (hour (lvar-value hour
))
4995 (date (lvar-value date
))
4996 (month (lvar-value month
))
4997 (year (lvar-value year
))
4998 (time-zone (lvar-value time-zone
)))
4999 (if (zerop (rem time-zone
1/3600))
5000 (encode-universal-time second minute hour date month year time-zone
)
5001 (give-up-ir1-transform))))
5003 #!-
(and win32
(not sb-thread
))
5004 (deftransform sleep
((seconds) ((integer 0 #.
(expt 10 8))))
5005 `(sb!unix
:nanosleep seconds
0))
5007 #!-
(and win32
(not sb-thread
))
5008 (deftransform sleep
((seconds) ((constant-arg (real 0))))
5009 (let ((seconds-value (lvar-value seconds
)))
5010 (multiple-value-bind (seconds nano
)
5011 (sb!impl
::split-seconds-for-sleep seconds-value
)
5012 (if (> seconds
(expt 10 8))
5013 (give-up-ir1-transform)
5014 `(sb!unix
:nanosleep
,seconds
,nano
)))))