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
) (make-eql-type member
) *empty-type
*)
1132 (push arg new-args
)))
1133 (unless (member *empty-type
* new-args
)
1136 ;;; Convert from the standard type convention for which -0.0 and 0.0
1137 ;;; are equal to an intermediate convention for which they are
1138 ;;; considered different which is more natural for some of the
1140 (defun convert-numeric-type (type)
1141 (declare (type numeric-type type
))
1142 ;;; Only convert real float interval delimiters types.
1143 (if (eq (numeric-type-complexp type
) :real
)
1144 (let* ((lo (numeric-type-low type
))
1145 (lo-val (type-bound-number lo
))
1146 (lo-float-zero-p (and lo
(floatp lo-val
) (= lo-val
0.0)))
1147 (hi (numeric-type-high type
))
1148 (hi-val (type-bound-number hi
))
1149 (hi-float-zero-p (and hi
(floatp hi-val
) (= hi-val
0.0))))
1150 (if (or lo-float-zero-p hi-float-zero-p
)
1152 :class
(numeric-type-class type
)
1153 :format
(numeric-type-format type
)
1155 :low
(if lo-float-zero-p
1157 (list (float 0.0 lo-val
))
1158 (float (load-time-value (make-unportable-float :single-float-negative-zero
)) lo-val
))
1160 :high
(if hi-float-zero-p
1162 (list (float (load-time-value (make-unportable-float :single-float-negative-zero
)) hi-val
))
1169 ;;; Convert back from the intermediate convention for which -0.0 and
1170 ;;; 0.0 are considered different to the standard type convention for
1171 ;;; which and equal.
1172 (defun convert-back-numeric-type (type)
1173 (declare (type numeric-type type
))
1174 ;;; Only convert real float interval delimiters types.
1175 (if (eq (numeric-type-complexp type
) :real
)
1176 (let* ((lo (numeric-type-low type
))
1177 (lo-val (type-bound-number lo
))
1179 (and lo
(floatp lo-val
) (= lo-val
0.0)
1180 (float-sign lo-val
)))
1181 (hi (numeric-type-high type
))
1182 (hi-val (type-bound-number hi
))
1184 (and hi
(floatp hi-val
) (= hi-val
0.0)
1185 (float-sign hi-val
))))
1187 ;; (float +0.0 +0.0) => (member 0.0)
1188 ;; (float -0.0 -0.0) => (member -0.0)
1189 ((and lo-float-zero-p hi-float-zero-p
)
1190 ;; shouldn't have exclusive bounds here..
1191 (aver (and (not (consp lo
)) (not (consp hi
))))
1192 (if (= lo-float-zero-p hi-float-zero-p
)
1193 ;; (float +0.0 +0.0) => (member 0.0)
1194 ;; (float -0.0 -0.0) => (member -0.0)
1195 (specifier-type `(member ,lo-val
))
1196 ;; (float -0.0 +0.0) => (float 0.0 0.0)
1197 ;; (float +0.0 -0.0) => (float 0.0 0.0)
1198 (make-numeric-type :class
(numeric-type-class type
)
1199 :format
(numeric-type-format type
)
1205 ;; (float -0.0 x) => (float 0.0 x)
1206 ((and (not (consp lo
)) (minusp lo-float-zero-p
))
1207 (make-numeric-type :class
(numeric-type-class type
)
1208 :format
(numeric-type-format type
)
1210 :low
(float 0.0 lo-val
)
1212 ;; (float (+0.0) x) => (float (0.0) x)
1213 ((and (consp lo
) (plusp lo-float-zero-p
))
1214 (make-numeric-type :class
(numeric-type-class type
)
1215 :format
(numeric-type-format type
)
1217 :low
(list (float 0.0 lo-val
))
1220 ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
1221 ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
1222 (list (make-eql-type (float 0.0 lo-val
))
1223 (make-numeric-type :class
(numeric-type-class type
)
1224 :format
(numeric-type-format type
)
1226 :low
(list (float 0.0 lo-val
))
1230 ;; (float x +0.0) => (float x 0.0)
1231 ((and (not (consp hi
)) (plusp hi-float-zero-p
))
1232 (make-numeric-type :class
(numeric-type-class type
)
1233 :format
(numeric-type-format type
)
1236 :high
(float 0.0 hi-val
)))
1237 ;; (float x (-0.0)) => (float x (0.0))
1238 ((and (consp hi
) (minusp hi-float-zero-p
))
1239 (make-numeric-type :class
(numeric-type-class type
)
1240 :format
(numeric-type-format type
)
1243 :high
(list (float 0.0 hi-val
))))
1245 ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
1246 ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
1247 (list (make-eql-type
1248 (float (load-time-value
1249 (make-unportable-float :single-float-negative-zero
))
1251 (make-numeric-type :class
(numeric-type-class type
)
1252 :format
(numeric-type-format type
)
1255 :high
(list (float 0.0 hi-val
)))))))
1261 ;;; Convert back a possible list of numeric types.
1262 (defun convert-back-numeric-type-list (type-list)
1265 (let ((results '()))
1266 (dolist (type type-list
)
1267 (if (numeric-type-p type
)
1268 (let ((result (convert-back-numeric-type type
)))
1270 (setf results
(append results result
))
1271 (push result results
)))
1272 (push type results
)))
1275 (convert-back-numeric-type type-list
))
1277 (convert-back-numeric-type-list (union-type-types type-list
)))
1281 ;;; Take a list of types and return a canonical type specifier,
1282 ;;; combining any MEMBER types together. If both positive and negative
1283 ;;; MEMBER types are present they are converted to a float type.
1284 ;;; XXX This would be far simpler if the type-union methods could handle
1285 ;;; member/number unions.
1287 ;;; If we're about to generate an overly complex union of numeric types, start
1288 ;;; collapse the ranges together.
1290 ;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
1291 ;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
1292 ;;; invoked always, instead of in the compiler, invoked only during some type
1294 (defvar *derived-numeric-union-complexity-limit
* 6)
1296 (defun make-derived-union-type (type-list)
1297 (let ((xset (alloc-xset))
1300 (numeric-type *empty-type
*))
1301 (dolist (type type-list
)
1302 (cond ((member-type-p type
)
1303 (mapc-member-type-members
1305 (if (fp-zero-p member
)
1306 (unless (member member fp-zeroes
)
1307 (pushnew member fp-zeroes
))
1308 (add-to-xset member xset
)))
1310 ((numeric-type-p type
)
1311 (let ((*approximate-numeric-unions
*
1312 (when (and (union-type-p numeric-type
)
1313 (nthcdr *derived-numeric-union-complexity-limit
*
1314 (union-type-types numeric-type
)))
1316 (setf numeric-type
(type-union type numeric-type
))))
1318 (push type misc-types
))))
1319 (if (and (xset-empty-p xset
) (not fp-zeroes
))
1320 (apply #'type-union numeric-type misc-types
)
1321 (apply #'type-union
(make-member-type xset fp-zeroes
)
1322 numeric-type misc-types
))))
1324 ;;; Convert a member type with a single member to a numeric type.
1325 (defun convert-member-type (arg)
1326 (let* ((members (member-type-members arg
))
1327 (member (first members
))
1328 (member-type (type-of member
)))
1329 (aver (not (rest members
)))
1330 (specifier-type (cond ((typep member
'integer
)
1331 `(integer ,member
,member
))
1332 ((memq member-type
'(short-float single-float
1333 double-float long-float
))
1334 `(,member-type
,member
,member
))
1338 ;;; This is used in defoptimizers for computing the resulting type of
1341 ;;; Given the lvar ARG, derive the resulting type using the
1342 ;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
1343 ;;; "atomic" lvar type like numeric-type or member-type (containing
1344 ;;; just one element). It should return the resulting type, which can
1345 ;;; be a list of types.
1347 ;;; For the case of member types, if a MEMBER-FUN is given it is
1348 ;;; called to compute the result otherwise the member type is first
1349 ;;; converted to a numeric type and the DERIVE-FUN is called.
1350 (defun one-arg-derive-type (arg derive-fun member-fun
1351 &optional
(convert-type t
))
1352 (declare (type function derive-fun
)
1353 (type (or null function
) member-fun
))
1354 (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg
))))
1360 (with-float-traps-masked
1361 (:underflow
:overflow
:divide-by-zero
)
1363 `(eql ,(funcall member-fun
1364 (first (member-type-members x
))))))
1365 ;; Otherwise convert to a numeric type.
1366 (let ((result-type-list
1367 (funcall derive-fun
(convert-member-type x
))))
1369 (convert-back-numeric-type-list result-type-list
)
1370 result-type-list
))))
1373 (convert-back-numeric-type-list
1374 (funcall derive-fun
(convert-numeric-type x
)))
1375 (funcall derive-fun x
)))
1377 *universal-type
*))))
1378 ;; Run down the list of args and derive the type of each one,
1379 ;; saving all of the results in a list.
1380 (let ((results nil
))
1381 (dolist (arg arg-list
)
1382 (let ((result (deriver arg
)))
1384 (setf results
(append results result
))
1385 (push result results
))))
1387 (make-derived-union-type results
)
1388 (first results
)))))))
1390 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
1391 ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
1392 ;;; original args and a third which is T to indicate if the two args
1393 ;;; really represent the same lvar. This is useful for deriving the
1394 ;;; type of things like (* x x), which should always be positive. If
1395 ;;; we didn't do this, we wouldn't be able to tell.
1396 (defun two-arg-derive-type (arg1 arg2 derive-fun fun
1397 &optional
(convert-type t
))
1398 (declare (type function derive-fun fun
))
1399 (flet ((deriver (x y same-arg
)
1400 (cond ((and (member-type-p x
) (member-type-p y
))
1401 (let* ((x (first (member-type-members x
)))
1402 (y (first (member-type-members y
)))
1403 (result (ignore-errors
1404 (with-float-traps-masked
1405 (:underflow
:overflow
:divide-by-zero
1407 (funcall fun x y
)))))
1408 (cond ((null result
) *empty-type
*)
1409 ((and (floatp result
) (float-nan-p result
))
1410 (make-numeric-type :class
'float
1411 :format
(type-of result
)
1414 (specifier-type `(eql ,result
))))))
1415 ((and (member-type-p x
) (numeric-type-p y
))
1416 (let* ((x (convert-member-type x
))
1417 (y (if convert-type
(convert-numeric-type y
) y
))
1418 (result (funcall derive-fun x y same-arg
)))
1420 (convert-back-numeric-type-list result
)
1422 ((and (numeric-type-p x
) (member-type-p y
))
1423 (let* ((x (if convert-type
(convert-numeric-type x
) x
))
1424 (y (convert-member-type y
))
1425 (result (funcall derive-fun x y same-arg
)))
1427 (convert-back-numeric-type-list result
)
1429 ((and (numeric-type-p x
) (numeric-type-p y
))
1430 (let* ((x (if convert-type
(convert-numeric-type x
) x
))
1431 (y (if convert-type
(convert-numeric-type y
) y
))
1432 (result (funcall derive-fun x y same-arg
)))
1434 (convert-back-numeric-type-list result
)
1437 *universal-type
*))))
1438 (let ((same-arg (same-leaf-ref-p arg1 arg2
))
1439 (a1 (prepare-arg-for-derive-type (lvar-type arg1
)))
1440 (a2 (prepare-arg-for-derive-type (lvar-type arg2
))))
1442 (let ((results nil
))
1444 ;; Since the args are the same LVARs, just run down the
1447 (let ((result (deriver x x same-arg
)))
1449 (setf results
(append results result
))
1450 (push result results
))))
1451 ;; Try all pairwise combinations.
1454 (let ((result (or (deriver x y same-arg
)
1455 (numeric-contagion x y
))))
1457 (setf results
(append results result
))
1458 (push result results
))))))
1460 (make-derived-union-type results
)
1461 (first results
)))))))
1463 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1465 (defoptimizer (+ derive-type
) ((x y
))
1466 (derive-integer-type
1473 (values (frob (numeric-type-low x
) (numeric-type-low y
))
1474 (frob (numeric-type-high x
) (numeric-type-high y
)))))))
1476 (defoptimizer (- derive-type
) ((x y
))
1477 (derive-integer-type
1484 (values (frob (numeric-type-low x
) (numeric-type-high y
))
1485 (frob (numeric-type-high x
) (numeric-type-low y
)))))))
1487 (defoptimizer (* derive-type
) ((x y
))
1488 (derive-integer-type
1491 (let ((x-low (numeric-type-low x
))
1492 (x-high (numeric-type-high x
))
1493 (y-low (numeric-type-low y
))
1494 (y-high (numeric-type-high y
)))
1495 (cond ((not (and x-low y-low
))
1497 ((or (minusp x-low
) (minusp y-low
))
1498 (if (and x-high y-high
)
1499 (let ((max (* (max (abs x-low
) (abs x-high
))
1500 (max (abs y-low
) (abs y-high
)))))
1501 (values (- max
) max
))
1504 (values (* x-low y-low
)
1505 (if (and x-high y-high
)
1509 (defoptimizer (/ derive-type
) ((x y
))
1510 (numeric-contagion (lvar-type x
) (lvar-type y
)))
1514 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1516 (defun +-derive-type-aux
(x y same-arg
)
1517 (if (and (numeric-type-real-p x
)
1518 (numeric-type-real-p y
))
1521 (let ((x-int (numeric-type->interval x
)))
1522 (interval-add x-int x-int
))
1523 (interval-add (numeric-type->interval x
)
1524 (numeric-type->interval y
))))
1525 (result-type (numeric-contagion x y
)))
1526 ;; If the result type is a float, we need to be sure to coerce
1527 ;; the bounds into the correct type.
1528 (when (eq (numeric-type-class result-type
) 'float
)
1529 (setf result
(interval-func
1531 (coerce-for-bound x
(or (numeric-type-format result-type
)
1535 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1536 (eq (numeric-type-class y
) 'integer
))
1537 ;; The sum of integers is always an integer.
1539 (numeric-type-class result-type
))
1540 :format
(numeric-type-format result-type
)
1541 :low
(interval-low result
)
1542 :high
(interval-high result
)))
1543 ;; general contagion
1544 (numeric-contagion x y
)))
1546 (defoptimizer (+ derive-type
) ((x y
))
1547 (two-arg-derive-type x y
#'+-derive-type-aux
#'+))
1549 (defun --derive-type-aux (x y same-arg
)
1550 (if (and (numeric-type-real-p x
)
1551 (numeric-type-real-p y
))
1553 ;; (- X X) is always 0.
1555 (make-interval :low
0 :high
0)
1556 (interval-sub (numeric-type->interval x
)
1557 (numeric-type->interval y
))))
1558 (result-type (numeric-contagion x y
)))
1559 ;; If the result type is a float, we need to be sure to coerce
1560 ;; the bounds into the correct type.
1561 (when (eq (numeric-type-class result-type
) 'float
)
1562 (setf result
(interval-func
1564 (coerce-for-bound x
(or (numeric-type-format result-type
)
1568 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1569 (eq (numeric-type-class y
) 'integer
))
1570 ;; The difference of integers is always an integer.
1572 (numeric-type-class result-type
))
1573 :format
(numeric-type-format result-type
)
1574 :low
(interval-low result
)
1575 :high
(interval-high result
)))
1576 ;; general contagion
1577 (numeric-contagion x y
)))
1579 (defoptimizer (- derive-type
) ((x y
))
1580 (two-arg-derive-type x y
#'--derive-type-aux
#'-
))
1582 (defun *-derive-type-aux
(x y same-arg
)
1583 (if (and (numeric-type-real-p x
)
1584 (numeric-type-real-p y
))
1586 ;; (* X X) is always positive, so take care to do it right.
1588 (interval-sqr (numeric-type->interval x
))
1589 (interval-mul (numeric-type->interval x
)
1590 (numeric-type->interval y
))))
1591 (result-type (numeric-contagion x y
)))
1592 ;; If the result type is a float, we need to be sure to coerce
1593 ;; the bounds into the correct type.
1594 (when (eq (numeric-type-class result-type
) 'float
)
1595 (setf result
(interval-func
1597 (coerce-for-bound x
(or (numeric-type-format result-type
)
1601 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1602 (eq (numeric-type-class y
) 'integer
))
1603 ;; The product of integers is always an integer.
1605 (numeric-type-class result-type
))
1606 :format
(numeric-type-format result-type
)
1607 :low
(interval-low result
)
1608 :high
(interval-high result
)))
1609 (numeric-contagion x y
)))
1611 (defoptimizer (* derive-type
) ((x y
))
1612 (two-arg-derive-type x y
#'*-derive-type-aux
#'*))
1614 (defun /-derive-type-aux
(x y same-arg
)
1615 (if (and (numeric-type-real-p x
)
1616 (numeric-type-real-p y
))
1618 ;; (/ X X) is always 1, except if X can contain 0. In
1619 ;; that case, we shouldn't optimize the division away
1620 ;; because we want 0/0 to signal an error.
1622 (not (interval-contains-p
1623 0 (interval-closure (numeric-type->interval y
)))))
1624 (make-interval :low
1 :high
1)
1625 (interval-div (numeric-type->interval x
)
1626 (numeric-type->interval y
))))
1627 (result-type (numeric-contagion x y
)))
1628 ;; If the result type is a float, we need to be sure to coerce
1629 ;; the bounds into the correct type.
1630 (when (eq (numeric-type-class result-type
) 'float
)
1631 (setf result
(interval-func
1633 (coerce-for-bound x
(or (numeric-type-format result-type
)
1636 (make-numeric-type :class
(numeric-type-class result-type
)
1637 :format
(numeric-type-format result-type
)
1638 :low
(interval-low result
)
1639 :high
(interval-high result
)))
1640 (numeric-contagion x y
)))
1642 (defoptimizer (/ derive-type
) ((x y
))
1643 (two-arg-derive-type x y
#'/-derive-type-aux
#'/))
1647 (defun ash-derive-type-aux (n-type shift same-arg
)
1648 (declare (ignore same-arg
))
1649 ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
1650 ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
1651 ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
1652 ;; two bignums yielding zero) and it's hard to avoid that
1653 ;; calculation in here.
1654 #+(and cmu sb-xc-host
)
1655 (when (and (or (typep (numeric-type-low n-type
) 'bignum
)
1656 (typep (numeric-type-high n-type
) 'bignum
))
1657 (or (typep (numeric-type-low shift
) 'bignum
)
1658 (typep (numeric-type-high shift
) 'bignum
)))
1659 (return-from ash-derive-type-aux
*universal-type
*))
1660 (flet ((ash-outer (n s
)
1661 (when (and (fixnump s
)
1663 (> s sb
!xc
:most-negative-fixnum
))
1665 ;; KLUDGE: The bare 64's here should be related to
1666 ;; symbolic machine word size values somehow.
1669 (if (and (fixnump s
)
1670 (> s sb
!xc
:most-negative-fixnum
))
1672 (if (minusp n
) -
1 0))))
1673 (or (and (csubtypep n-type
(specifier-type 'integer
))
1674 (csubtypep shift
(specifier-type 'integer
))
1675 (let ((n-low (numeric-type-low n-type
))
1676 (n-high (numeric-type-high n-type
))
1677 (s-low (numeric-type-low shift
))
1678 (s-high (numeric-type-high shift
)))
1679 (make-numeric-type :class
'integer
:complexp
:real
1682 (ash-outer n-low s-high
)
1683 (ash-inner n-low s-low
)))
1686 (ash-inner n-high s-low
)
1687 (ash-outer n-high s-high
))))))
1690 (defoptimizer (ash derive-type
) ((n shift
))
1691 (two-arg-derive-type n shift
#'ash-derive-type-aux
#'ash
))
1693 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1694 (macrolet ((frob (fun)
1695 `#'(lambda (type type2
)
1696 (declare (ignore type2
))
1697 (let ((lo (numeric-type-low type
))
1698 (hi (numeric-type-high type
)))
1699 (values (if hi
(,fun hi
) nil
) (if lo
(,fun lo
) nil
))))))
1701 (defoptimizer (%negate derive-type
) ((num))
1702 (derive-integer-type num num
(frob -
))))
1704 (defun lognot-derive-type-aux (int)
1705 (derive-integer-type-aux int int
1706 (lambda (type type2
)
1707 (declare (ignore type2
))
1708 (let ((lo (numeric-type-low type
))
1709 (hi (numeric-type-high type
)))
1710 (values (if hi
(lognot hi
) nil
)
1711 (if lo
(lognot lo
) nil
)
1712 (numeric-type-class type
)
1713 (numeric-type-format type
))))))
1715 (defoptimizer (lognot derive-type
) ((int))
1716 (lognot-derive-type-aux (lvar-type int
)))
1718 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1719 (defoptimizer (%negate derive-type
) ((num))
1720 (flet ((negate-bound (b)
1722 (set-bound (- (type-bound-number b
))
1724 (one-arg-derive-type num
1726 (modified-numeric-type
1728 :low
(negate-bound (numeric-type-high type
))
1729 :high
(negate-bound (numeric-type-low type
))))
1732 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1733 (defoptimizer (abs derive-type
) ((num))
1734 (let ((type (lvar-type num
)))
1735 (if (and (numeric-type-p type
)
1736 (eq (numeric-type-class type
) 'integer
)
1737 (eq (numeric-type-complexp type
) :real
))
1738 (let ((lo (numeric-type-low type
))
1739 (hi (numeric-type-high type
)))
1740 (make-numeric-type :class
'integer
:complexp
:real
1741 :low
(cond ((and hi
(minusp hi
))
1747 :high
(if (and hi lo
)
1748 (max (abs hi
) (abs lo
))
1750 (numeric-contagion type type
))))
1752 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1753 (defun abs-derive-type-aux (type)
1754 (cond ((eq (numeric-type-complexp type
) :complex
)
1755 ;; The absolute value of a complex number is always a
1756 ;; non-negative float.
1757 (let* ((format (case (numeric-type-class type
)
1758 ((integer rational
) 'single-float
)
1759 (t (numeric-type-format type
))))
1760 (bound-format (or format
'float
)))
1761 (make-numeric-type :class
'float
1764 :low
(coerce 0 bound-format
)
1767 ;; The absolute value of a real number is a non-negative real
1768 ;; of the same type.
1769 (let* ((abs-bnd (interval-abs (numeric-type->interval type
)))
1770 (class (numeric-type-class type
))
1771 (format (numeric-type-format type
))
1772 (bound-type (or format class
'real
)))
1777 :low
(coerce-and-truncate-floats (interval-low abs-bnd
) bound-type
)
1778 :high
(coerce-and-truncate-floats
1779 (interval-high abs-bnd
) bound-type
))))))
1781 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1782 (defoptimizer (abs derive-type
) ((num))
1783 (one-arg-derive-type num
#'abs-derive-type-aux
#'abs
))
1785 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1786 (defoptimizer (truncate derive-type
) ((number divisor
))
1787 (let ((number-type (lvar-type number
))
1788 (divisor-type (lvar-type divisor
))
1789 (integer-type (specifier-type 'integer
)))
1790 (if (and (numeric-type-p number-type
)
1791 (csubtypep number-type integer-type
)
1792 (numeric-type-p divisor-type
)
1793 (csubtypep divisor-type integer-type
))
1794 (let ((number-low (numeric-type-low number-type
))
1795 (number-high (numeric-type-high number-type
))
1796 (divisor-low (numeric-type-low divisor-type
))
1797 (divisor-high (numeric-type-high divisor-type
)))
1798 (values-specifier-type
1799 `(values ,(integer-truncate-derive-type number-low number-high
1800 divisor-low divisor-high
)
1801 ,(integer-rem-derive-type number-low number-high
1802 divisor-low divisor-high
))))
1805 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1808 (defun rem-result-type (number-type divisor-type
)
1809 ;; Figure out what the remainder type is. The remainder is an
1810 ;; integer if both args are integers; a rational if both args are
1811 ;; rational; and a float otherwise.
1812 (cond ((and (csubtypep number-type
(specifier-type 'integer
))
1813 (csubtypep divisor-type
(specifier-type 'integer
)))
1815 ((and (csubtypep number-type
(specifier-type 'rational
))
1816 (csubtypep divisor-type
(specifier-type 'rational
)))
1818 ((and (csubtypep number-type
(specifier-type 'float
))
1819 (csubtypep divisor-type
(specifier-type 'float
)))
1820 ;; Both are floats so the result is also a float, of
1821 ;; the largest type.
1822 (or (float-format-max (numeric-type-format number-type
)
1823 (numeric-type-format divisor-type
))
1825 ((and (csubtypep number-type
(specifier-type 'float
))
1826 (csubtypep divisor-type
(specifier-type 'rational
)))
1827 ;; One of the arguments is a float and the other is a
1828 ;; rational. The remainder is a float of the same
1830 (or (numeric-type-format number-type
) 'float
))
1831 ((and (csubtypep divisor-type
(specifier-type 'float
))
1832 (csubtypep number-type
(specifier-type 'rational
)))
1833 ;; One of the arguments is a float and the other is a
1834 ;; rational. The remainder is a float of the same
1836 (or (numeric-type-format divisor-type
) 'float
))
1838 ;; Some unhandled combination. This usually means both args
1839 ;; are REAL so the result is a REAL.
1842 (defun truncate-derive-type-quot (number-type divisor-type
)
1843 (let* ((rem-type (rem-result-type number-type divisor-type
))
1844 (number-interval (numeric-type->interval number-type
))
1845 (divisor-interval (numeric-type->interval divisor-type
)))
1846 ;;(declare (type (member '(integer rational float)) rem-type))
1847 ;; We have real numbers now.
1848 (cond ((eq rem-type
'integer
)
1849 ;; Since the remainder type is INTEGER, both args are
1851 (let* ((res (integer-truncate-derive-type
1852 (interval-low number-interval
)
1853 (interval-high number-interval
)
1854 (interval-low divisor-interval
)
1855 (interval-high divisor-interval
))))
1856 (specifier-type (if (listp res
) res
'integer
))))
1858 (let ((quot (truncate-quotient-bound
1859 (interval-div number-interval
1860 divisor-interval
))))
1861 (specifier-type `(integer ,(or (interval-low quot
) '*)
1862 ,(or (interval-high quot
) '*))))))))
1864 (defun truncate-derive-type-rem (number-type divisor-type
)
1865 (let* ((rem-type (rem-result-type number-type divisor-type
))
1866 (number-interval (numeric-type->interval number-type
))
1867 (divisor-interval (numeric-type->interval divisor-type
))
1868 (rem (truncate-rem-bound number-interval divisor-interval
)))
1869 ;;(declare (type (member '(integer rational float)) rem-type))
1870 ;; We have real numbers now.
1871 (cond ((eq rem-type
'integer
)
1872 ;; Since the remainder type is INTEGER, both args are
1874 (specifier-type `(,rem-type
,(or (interval-low rem
) '*)
1875 ,(or (interval-high rem
) '*))))
1877 (multiple-value-bind (class format
)
1880 (values 'integer nil
))
1882 (values 'rational nil
))
1883 ((or single-float double-float
#!+long-float long-float
)
1884 (values 'float rem-type
))
1886 (values 'float nil
))
1889 (when (member rem-type
'(float single-float double-float
1890 #!+long-float long-float
))
1891 (setf rem
(interval-func #'(lambda (x)
1892 (coerce-for-bound x rem-type
))
1894 (make-numeric-type :class class
1896 :low
(interval-low rem
)
1897 :high
(interval-high rem
)))))))
1899 (defun truncate-derive-type-quot-aux (num div same-arg
)
1900 (declare (ignore same-arg
))
1901 (if (and (numeric-type-real-p num
)
1902 (numeric-type-real-p div
))
1903 (truncate-derive-type-quot num div
)
1906 (defun truncate-derive-type-rem-aux (num div same-arg
)
1907 (declare (ignore same-arg
))
1908 (if (and (numeric-type-real-p num
)
1909 (numeric-type-real-p div
))
1910 (truncate-derive-type-rem num div
)
1913 (defoptimizer (truncate derive-type
) ((number divisor
))
1914 (let ((quot (two-arg-derive-type number divisor
1915 #'truncate-derive-type-quot-aux
#'truncate
))
1916 (rem (two-arg-derive-type number divisor
1917 #'truncate-derive-type-rem-aux
#'rem
)))
1918 (when (and quot rem
)
1919 (make-values-type :required
(list quot rem
)))))
1921 (defun ftruncate-derive-type-quot (number-type divisor-type
)
1922 ;; The bounds are the same as for truncate. However, the first
1923 ;; result is a float of some type. We need to determine what that
1924 ;; type is. Basically it's the more contagious of the two types.
1925 (let ((q-type (truncate-derive-type-quot number-type divisor-type
))
1926 (res-type (numeric-contagion number-type divisor-type
)))
1927 (make-numeric-type :class
'float
1928 :format
(numeric-type-format res-type
)
1929 :low
(numeric-type-low q-type
)
1930 :high
(numeric-type-high q-type
))))
1932 (defun ftruncate-derive-type-quot-aux (n d same-arg
)
1933 (declare (ignore same-arg
))
1934 (if (and (numeric-type-real-p n
)
1935 (numeric-type-real-p d
))
1936 (ftruncate-derive-type-quot n d
)
1939 (defoptimizer (ftruncate derive-type
) ((number divisor
))
1941 (two-arg-derive-type number divisor
1942 #'ftruncate-derive-type-quot-aux
#'ftruncate
))
1943 (rem (two-arg-derive-type number divisor
1944 #'truncate-derive-type-rem-aux
#'rem
)))
1945 (when (and quot rem
)
1946 (make-values-type :required
(list quot rem
)))))
1948 (defun %unary-truncate-derive-type-aux
(number)
1949 (truncate-derive-type-quot number
(specifier-type '(integer 1 1))))
1951 (defoptimizer (%unary-truncate derive-type
) ((number))
1952 (one-arg-derive-type number
1953 #'%unary-truncate-derive-type-aux
1956 (defoptimizer (%unary-truncate
/single-float derive-type
) ((number))
1957 (one-arg-derive-type number
1958 #'%unary-truncate-derive-type-aux
1961 (defoptimizer (%unary-truncate
/double-float derive-type
) ((number))
1962 (one-arg-derive-type number
1963 #'%unary-truncate-derive-type-aux
1966 (defoptimizer (%unary-ftruncate derive-type
) ((number))
1967 (let ((divisor (specifier-type '(integer 1 1))))
1968 (one-arg-derive-type number
1970 (ftruncate-derive-type-quot-aux n divisor nil
))
1971 #'%unary-ftruncate
)))
1973 (defoptimizer (%unary-round derive-type
) ((number))
1974 (one-arg-derive-type number
1977 (unless (numeric-type-real-p n
)
1978 (return *empty-type
*))
1979 (let* ((interval (numeric-type->interval n
))
1980 (low (interval-low interval
))
1981 (high (interval-high interval
)))
1983 (setf low
(car low
)))
1985 (setf high
(car high
)))
1995 ;;; Define optimizers for FLOOR and CEILING.
1997 ((def (name q-name r-name
)
1998 (let ((q-aux (symbolicate q-name
"-AUX"))
1999 (r-aux (symbolicate r-name
"-AUX")))
2001 ;; Compute type of quotient (first) result.
2002 (defun ,q-aux
(number-type divisor-type
)
2003 (let* ((number-interval
2004 (numeric-type->interval number-type
))
2006 (numeric-type->interval divisor-type
))
2007 (quot (,q-name
(interval-div number-interval
2008 divisor-interval
))))
2009 (specifier-type `(integer ,(or (interval-low quot
) '*)
2010 ,(or (interval-high quot
) '*)))))
2011 ;; Compute type of remainder.
2012 (defun ,r-aux
(number-type divisor-type
)
2013 (let* ((divisor-interval
2014 (numeric-type->interval divisor-type
))
2015 (rem (,r-name divisor-interval
))
2016 (result-type (rem-result-type number-type divisor-type
)))
2017 (multiple-value-bind (class format
)
2020 (values 'integer nil
))
2022 (values 'rational nil
))
2023 ((or single-float double-float
#!+long-float long-float
)
2024 (values 'float result-type
))
2026 (values 'float nil
))
2029 (when (member result-type
'(float single-float double-float
2030 #!+long-float long-float
))
2031 ;; Make sure that the limits on the interval have
2033 (setf rem
(interval-func (lambda (x)
2034 (coerce-for-bound x result-type
))
2036 (make-numeric-type :class class
2038 :low
(interval-low rem
)
2039 :high
(interval-high rem
)))))
2040 ;; the optimizer itself
2041 (defoptimizer (,name derive-type
) ((number divisor
))
2042 (flet ((derive-q (n d same-arg
)
2043 (declare (ignore same-arg
))
2044 (if (and (numeric-type-real-p n
)
2045 (numeric-type-real-p d
))
2048 (derive-r (n d same-arg
)
2049 (declare (ignore same-arg
))
2050 (if (and (numeric-type-real-p n
)
2051 (numeric-type-real-p d
))
2054 (let ((quot (two-arg-derive-type
2055 number divisor
#'derive-q
#',name
))
2056 (rem (two-arg-derive-type
2057 number divisor
#'derive-r
#'mod
)))
2058 (when (and quot rem
)
2059 (make-values-type :required
(list quot rem
))))))))))
2061 (def floor floor-quotient-bound floor-rem-bound
)
2062 (def ceiling ceiling-quotient-bound ceiling-rem-bound
))
2064 ;;; Define optimizers for FFLOOR and FCEILING
2065 (macrolet ((def (name q-name r-name
)
2066 (let ((q-aux (symbolicate "F" q-name
"-AUX"))
2067 (r-aux (symbolicate r-name
"-AUX")))
2069 ;; Compute type of quotient (first) result.
2070 (defun ,q-aux
(number-type divisor-type
)
2071 (let* ((number-interval
2072 (numeric-type->interval number-type
))
2074 (numeric-type->interval divisor-type
))
2075 (quot (,q-name
(interval-div number-interval
2077 (res-type (numeric-contagion number-type
2080 :class
(numeric-type-class res-type
)
2081 :format
(numeric-type-format res-type
)
2082 :low
(interval-low quot
)
2083 :high
(interval-high quot
))))
2085 (defoptimizer (,name derive-type
) ((number divisor
))
2086 (flet ((derive-q (n d same-arg
)
2087 (declare (ignore same-arg
))
2088 (if (and (numeric-type-real-p n
)
2089 (numeric-type-real-p d
))
2092 (derive-r (n d same-arg
)
2093 (declare (ignore same-arg
))
2094 (if (and (numeric-type-real-p n
)
2095 (numeric-type-real-p d
))
2098 (let ((quot (two-arg-derive-type
2099 number divisor
#'derive-q
#',name
))
2100 (rem (two-arg-derive-type
2101 number divisor
#'derive-r
#'mod
)))
2102 (when (and quot rem
)
2103 (make-values-type :required
(list quot rem
))))))))))
2105 (def ffloor floor-quotient-bound floor-rem-bound
)
2106 (def fceiling ceiling-quotient-bound ceiling-rem-bound
))
2108 ;;; functions to compute the bounds on the quotient and remainder for
2109 ;;; the FLOOR function
2110 (defun floor-quotient-bound (quot)
2111 ;; Take the floor of the quotient and then massage it into what we
2113 (let ((lo (interval-low quot
))
2114 (hi (interval-high quot
)))
2115 ;; Take the floor of the lower bound. The result is always a
2116 ;; closed lower bound.
2118 (floor (type-bound-number lo
))
2120 ;; For the upper bound, we need to be careful.
2123 ;; An open bound. We need to be careful here because
2124 ;; the floor of '(10.0) is 9, but the floor of
2126 (multiple-value-bind (q r
) (floor (first hi
))
2131 ;; A closed bound, so the answer is obvious.
2135 (make-interval :low lo
:high hi
)))
2136 (defun floor-rem-bound (div)
2137 ;; The remainder depends only on the divisor. Try to get the
2138 ;; correct sign for the remainder if we can.
2139 (case (interval-range-info div
)
2141 ;; The divisor is always positive.
2142 (let ((rem (interval-abs div
)))
2143 (setf (interval-low rem
) 0)
2144 (when (and (numberp (interval-high rem
))
2145 (not (zerop (interval-high rem
))))
2146 ;; The remainder never contains the upper bound. However,
2147 ;; watch out for the case where the high limit is zero!
2148 (setf (interval-high rem
) (list (interval-high rem
))))
2151 ;; The divisor is always negative.
2152 (let ((rem (interval-neg (interval-abs div
))))
2153 (setf (interval-high rem
) 0)
2154 (when (numberp (interval-low rem
))
2155 ;; The remainder never contains the lower bound.
2156 (setf (interval-low rem
) (list (interval-low rem
))))
2159 ;; The divisor can be positive or negative. All bets off. The
2160 ;; magnitude of remainder is the maximum value of the divisor.
2161 (let ((limit (type-bound-number (interval-high (interval-abs div
)))))
2162 ;; The bound never reaches the limit, so make the interval open.
2163 (make-interval :low
(if limit
2166 :high
(list limit
))))))
2168 (floor-quotient-bound (make-interval :low
0.3 :high
10.3))
2169 => #S
(INTERVAL :LOW
0 :HIGH
10)
2170 (floor-quotient-bound (make-interval :low
0.3 :high
'(10.3
)))
2171 => #S
(INTERVAL :LOW
0 :HIGH
10)
2172 (floor-quotient-bound (make-interval :low
0.3 :high
10))
2173 => #S
(INTERVAL :LOW
0 :HIGH
10)
2174 (floor-quotient-bound (make-interval :low
0.3 :high
'(10)))
2175 => #S
(INTERVAL :LOW
0 :HIGH
9)
2176 (floor-quotient-bound (make-interval :low
'(0.3
) :high
10.3))
2177 => #S
(INTERVAL :LOW
0 :HIGH
10)
2178 (floor-quotient-bound (make-interval :low
'(0.0
) :high
10.3))
2179 => #S
(INTERVAL :LOW
0 :HIGH
10)
2180 (floor-quotient-bound (make-interval :low
'(-1.3
) :high
10.3))
2181 => #S
(INTERVAL :LOW -
2 :HIGH
10)
2182 (floor-quotient-bound (make-interval :low
'(-1.0
) :high
10.3))
2183 => #S
(INTERVAL :LOW -
1 :HIGH
10)
2184 (floor-quotient-bound (make-interval :low -
1.0 :high
10.3))
2185 => #S
(INTERVAL :LOW -
1 :HIGH
10)
2187 (floor-rem-bound (make-interval :low
0.3 :high
10.3))
2188 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2189 (floor-rem-bound (make-interval :low
0.3 :high
'(10.3
)))
2190 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2191 (floor-rem-bound (make-interval :low -
10 :high -
2.3))
2192 #S
(INTERVAL :LOW
(-10) :HIGH
0)
2193 (floor-rem-bound (make-interval :low
0.3 :high
10))
2194 => #S
(INTERVAL :LOW
0 :HIGH
'(10))
2195 (floor-rem-bound (make-interval :low
'(-1.3
) :high
10.3))
2196 => #S
(INTERVAL :LOW
'(-10.3
) :HIGH
'(10.3
))
2197 (floor-rem-bound (make-interval :low
'(-20.3
) :high
10.3))
2198 => #S
(INTERVAL :LOW
(-20.3
) :HIGH
(20.3
))
2201 ;;; same functions for CEILING
2202 (defun ceiling-quotient-bound (quot)
2203 ;; Take the ceiling of the quotient and then massage it into what we
2205 (let ((lo (interval-low quot
))
2206 (hi (interval-high quot
)))
2207 ;; Take the ceiling of the upper bound. The result is always a
2208 ;; closed upper bound.
2210 (ceiling (type-bound-number hi
))
2212 ;; For the lower bound, we need to be careful.
2215 ;; An open bound. We need to be careful here because
2216 ;; the ceiling of '(10.0) is 11, but the ceiling of
2218 (multiple-value-bind (q r
) (ceiling (first lo
))
2223 ;; A closed bound, so the answer is obvious.
2227 (make-interval :low lo
:high hi
)))
2228 (defun ceiling-rem-bound (div)
2229 ;; The remainder depends only on the divisor. Try to get the
2230 ;; correct sign for the remainder if we can.
2231 (case (interval-range-info div
)
2233 ;; Divisor is always positive. The remainder is negative.
2234 (let ((rem (interval-neg (interval-abs div
))))
2235 (setf (interval-high rem
) 0)
2236 (when (and (numberp (interval-low rem
))
2237 (not (zerop (interval-low rem
))))
2238 ;; The remainder never contains the upper bound. However,
2239 ;; watch out for the case when the upper bound is zero!
2240 (setf (interval-low rem
) (list (interval-low rem
))))
2243 ;; Divisor is always negative. The remainder is positive
2244 (let ((rem (interval-abs div
)))
2245 (setf (interval-low rem
) 0)
2246 (when (numberp (interval-high rem
))
2247 ;; The remainder never contains the lower bound.
2248 (setf (interval-high rem
) (list (interval-high rem
))))
2251 ;; The divisor can be positive or negative. All bets off. The
2252 ;; magnitude of remainder is the maximum value of the divisor.
2253 (let ((limit (type-bound-number (interval-high (interval-abs div
)))))
2254 ;; The bound never reaches the limit, so make the interval open.
2255 (make-interval :low
(if limit
2258 :high
(list limit
))))))
2261 (ceiling-quotient-bound (make-interval :low
0.3 :high
10.3))
2262 => #S
(INTERVAL :LOW
1 :HIGH
11)
2263 (ceiling-quotient-bound (make-interval :low
0.3 :high
'(10.3
)))
2264 => #S
(INTERVAL :LOW
1 :HIGH
11)
2265 (ceiling-quotient-bound (make-interval :low
0.3 :high
10))
2266 => #S
(INTERVAL :LOW
1 :HIGH
10)
2267 (ceiling-quotient-bound (make-interval :low
0.3 :high
'(10)))
2268 => #S
(INTERVAL :LOW
1 :HIGH
10)
2269 (ceiling-quotient-bound (make-interval :low
'(0.3
) :high
10.3))
2270 => #S
(INTERVAL :LOW
1 :HIGH
11)
2271 (ceiling-quotient-bound (make-interval :low
'(0.0
) :high
10.3))
2272 => #S
(INTERVAL :LOW
1 :HIGH
11)
2273 (ceiling-quotient-bound (make-interval :low
'(-1.3
) :high
10.3))
2274 => #S
(INTERVAL :LOW -
1 :HIGH
11)
2275 (ceiling-quotient-bound (make-interval :low
'(-1.0
) :high
10.3))
2276 => #S
(INTERVAL :LOW
0 :HIGH
11)
2277 (ceiling-quotient-bound (make-interval :low -
1.0 :high
10.3))
2278 => #S
(INTERVAL :LOW -
1 :HIGH
11)
2280 (ceiling-rem-bound (make-interval :low
0.3 :high
10.3))
2281 => #S
(INTERVAL :LOW
(-10.3
) :HIGH
0)
2282 (ceiling-rem-bound (make-interval :low
0.3 :high
'(10.3
)))
2283 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2284 (ceiling-rem-bound (make-interval :low -
10 :high -
2.3))
2285 => #S
(INTERVAL :LOW
0 :HIGH
(10))
2286 (ceiling-rem-bound (make-interval :low
0.3 :high
10))
2287 => #S
(INTERVAL :LOW
(-10) :HIGH
0)
2288 (ceiling-rem-bound (make-interval :low
'(-1.3
) :high
10.3))
2289 => #S
(INTERVAL :LOW
(-10.3
) :HIGH
(10.3
))
2290 (ceiling-rem-bound (make-interval :low
'(-20.3
) :high
10.3))
2291 => #S
(INTERVAL :LOW
(-20.3
) :HIGH
(20.3
))
2294 (defun truncate-quotient-bound (quot)
2295 ;; For positive quotients, truncate is exactly like floor. For
2296 ;; negative quotients, truncate is exactly like ceiling. Otherwise,
2297 ;; it's the union of the two pieces.
2298 (case (interval-range-info quot
)
2301 (floor-quotient-bound quot
))
2303 ;; just like CEILING
2304 (ceiling-quotient-bound quot
))
2306 ;; Split the interval into positive and negative pieces, compute
2307 ;; the result for each piece and put them back together.
2308 (destructuring-bind (neg pos
) (interval-split 0 quot t t
)
2309 (interval-merge-pair (ceiling-quotient-bound neg
)
2310 (floor-quotient-bound pos
))))))
2312 (defun truncate-rem-bound (num div
)
2313 ;; This is significantly more complicated than FLOOR or CEILING. We
2314 ;; need both the number and the divisor to determine the range. The
2315 ;; basic idea is to split the ranges of NUM and DEN into positive
2316 ;; and negative pieces and deal with each of the four possibilities
2318 (case (interval-range-info num
)
2320 (case (interval-range-info div
)
2322 (floor-rem-bound div
))
2324 (ceiling-rem-bound div
))
2326 (destructuring-bind (neg pos
) (interval-split 0 div t t
)
2327 (interval-merge-pair (truncate-rem-bound num neg
)
2328 (truncate-rem-bound num pos
))))))
2330 (case (interval-range-info div
)
2332 (ceiling-rem-bound div
))
2334 (floor-rem-bound div
))
2336 (destructuring-bind (neg pos
) (interval-split 0 div t t
)
2337 (interval-merge-pair (truncate-rem-bound num neg
)
2338 (truncate-rem-bound num pos
))))))
2340 (destructuring-bind (neg pos
) (interval-split 0 num t t
)
2341 (interval-merge-pair (truncate-rem-bound neg div
)
2342 (truncate-rem-bound pos div
))))))
2345 ;;; Derive useful information about the range. Returns three values:
2346 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2347 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2348 ;;; - The abs of the maximal value if there is one, or nil if it is
2350 (defun numeric-range-info (low high
)
2351 (cond ((and low
(not (minusp low
)))
2352 (values '+ low high
))
2353 ((and high
(not (plusp high
)))
2354 (values '-
(- high
) (if low
(- low
) nil
)))
2356 (values nil
0 (and low high
(max (- low
) high
))))))
2358 (defun integer-truncate-derive-type
2359 (number-low number-high divisor-low divisor-high
)
2360 ;; The result cannot be larger in magnitude than the number, but the
2361 ;; sign might change. If we can determine the sign of either the
2362 ;; number or the divisor, we can eliminate some of the cases.
2363 (multiple-value-bind (number-sign number-min number-max
)
2364 (numeric-range-info number-low number-high
)
2365 (multiple-value-bind (divisor-sign divisor-min divisor-max
)
2366 (numeric-range-info divisor-low divisor-high
)
2367 (when (and divisor-max
(zerop divisor-max
))
2368 ;; We've got a problem: guaranteed division by zero.
2369 (return-from integer-truncate-derive-type t
))
2370 (when (zerop divisor-min
)
2371 ;; We'll assume that they aren't going to divide by zero.
2373 (cond ((and number-sign divisor-sign
)
2374 ;; We know the sign of both.
2375 (if (eq number-sign divisor-sign
)
2376 ;; Same sign, so the result will be positive.
2377 `(integer ,(if divisor-max
2378 (truncate number-min divisor-max
)
2381 (truncate number-max divisor-min
)
2383 ;; Different signs, the result will be negative.
2384 `(integer ,(if number-max
2385 (- (truncate number-max divisor-min
))
2388 (- (truncate number-min divisor-max
))
2390 ((eq divisor-sign
'+)
2391 ;; The divisor is positive. Therefore, the number will just
2392 ;; become closer to zero.
2393 `(integer ,(if number-low
2394 (truncate number-low divisor-min
)
2397 (truncate number-high divisor-min
)
2399 ((eq divisor-sign
'-
)
2400 ;; The divisor is negative. Therefore, the absolute value of
2401 ;; the number will become closer to zero, but the sign will also
2403 `(integer ,(if number-high
2404 (- (truncate number-high divisor-min
))
2407 (- (truncate number-low divisor-min
))
2409 ;; The divisor could be either positive or negative.
2411 ;; The number we are dividing has a bound. Divide that by the
2412 ;; smallest posible divisor.
2413 (let ((bound (truncate number-max divisor-min
)))
2414 `(integer ,(- bound
) ,bound
)))
2416 ;; The number we are dividing is unbounded, so we can't tell
2417 ;; anything about the result.
2420 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2421 (defun integer-rem-derive-type
2422 (number-low number-high divisor-low divisor-high
)
2423 (if (and divisor-low divisor-high
)
2424 ;; We know the range of the divisor, and the remainder must be
2425 ;; smaller than the divisor. We can tell the sign of the
2426 ;; remainder if we know the sign of the number.
2427 (let ((divisor-max (1- (max (abs divisor-low
) (abs divisor-high
)))))
2428 `(integer ,(if (or (null number-low
)
2429 (minusp number-low
))
2432 ,(if (or (null number-high
)
2433 (plusp number-high
))
2436 ;; The divisor is potentially either very positive or very
2437 ;; negative. Therefore, the remainder is unbounded, but we might
2438 ;; be able to tell something about the sign from the number.
2439 `(integer ,(if (and number-low
(not (minusp number-low
)))
2440 ;; The number we are dividing is positive.
2441 ;; Therefore, the remainder must be positive.
2444 ,(if (and number-high
(not (plusp number-high
)))
2445 ;; The number we are dividing is negative.
2446 ;; Therefore, the remainder must be negative.
2450 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2451 (defoptimizer (random derive-type
) ((bound &optional state
))
2452 (declare (ignore state
))
2453 (let ((type (lvar-type bound
)))
2454 (when (numeric-type-p type
)
2455 (let ((class (numeric-type-class type
))
2456 (high (numeric-type-high type
))
2457 (format (numeric-type-format type
)))
2461 :low
(coerce 0 (or format class
'real
))
2462 :high
(cond ((not high
) nil
)
2463 ((eq class
'integer
) (max (1- high
) 0))
2464 ((or (consp high
) (zerop high
)) high
)
2467 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2468 (defun random-derive-type-aux (type)
2469 (let ((class (numeric-type-class type
))
2470 (high (numeric-type-high type
))
2471 (format (numeric-type-format type
)))
2475 :low
(coerce 0 (or format class
'real
))
2476 :high
(cond ((not high
) nil
)
2477 ((eq class
'integer
) (max (1- high
) 0))
2478 ((or (consp high
) (zerop high
)) high
)
2481 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2482 (defoptimizer (random derive-type
) ((bound &optional state
))
2483 (declare (ignore state
))
2484 (one-arg-derive-type bound
#'random-derive-type-aux nil
))
2486 ;;;; miscellaneous derive-type methods
2488 (defoptimizer (integer-length derive-type
) ((x))
2489 (let ((x-type (lvar-type x
)))
2490 (when (numeric-type-p x-type
)
2491 ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2492 ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be
2493 ;; careful about LO or HI being NIL, though. Also, if 0 is
2494 ;; contained in X, the lower bound is obviously 0.
2495 (flet ((null-or-min (a b
)
2496 (and a b
(min (integer-length a
)
2497 (integer-length b
))))
2499 (and a b
(max (integer-length a
)
2500 (integer-length b
)))))
2501 (let* ((min (numeric-type-low x-type
))
2502 (max (numeric-type-high x-type
))
2503 (min-len (null-or-min min max
))
2504 (max-len (null-or-max min max
)))
2505 (when (ctypep 0 x-type
)
2507 (specifier-type `(integer ,(or min-len
'*) ,(or max-len
'*))))))))
2509 (defoptimizer (logcount derive-type
) ((x))
2510 (let ((x-type (lvar-type x
)))
2511 (when (numeric-type-p x-type
)
2512 (let ((min (numeric-type-low x-type
))
2513 (max (numeric-type-high x-type
)))
2516 `(integer ,(if (or (> min
0)
2520 ,(max (integer-length min
)
2521 (integer-length max
)))))))))
2523 (defoptimizer (isqrt derive-type
) ((x))
2524 (let ((x-type (lvar-type x
)))
2525 (when (numeric-type-p x-type
)
2526 (let* ((lo (numeric-type-low x-type
))
2527 (hi (numeric-type-high x-type
))
2528 (lo-res (if lo
(isqrt lo
) '*))
2529 (hi-res (if hi
(isqrt hi
) '*)))
2530 (specifier-type `(integer ,lo-res
,hi-res
))))))
2532 (defoptimizer (char-code derive-type
) ((char))
2533 (let ((type (type-intersection (lvar-type char
) (specifier-type 'character
))))
2534 (cond ((member-type-p type
)
2537 ,@(loop for member in
(member-type-members type
)
2538 when
(characterp member
)
2539 collect
(char-code member
)))))
2540 ((sb!kernel
::character-set-type-p type
)
2543 ,@(loop for
(low . high
)
2544 in
(character-set-type-pairs type
)
2545 collect
`(integer ,low
,high
)))))
2546 ((csubtypep type
(specifier-type 'base-char
))
2548 `(mod ,base-char-code-limit
)))
2551 `(mod ,sb
!xc
:char-code-limit
))))))
2553 (defoptimizer (code-char derive-type
) ((code))
2554 (let ((type (lvar-type code
)))
2555 ;; FIXME: unions of integral ranges? It ought to be easier to do
2556 ;; this, given that CHARACTER-SET is basically an integral range
2557 ;; type. -- CSR, 2004-10-04
2558 (when (numeric-type-p type
)
2559 (let* ((lo (numeric-type-low type
))
2560 (hi (numeric-type-high type
))
2561 (type (specifier-type `(character-set ((,lo .
,hi
))))))
2563 ;; KLUDGE: when running on the host, we lose a slight amount
2564 ;; of precision so that we don't have to "unparse" types
2565 ;; that formally we can't, such as (CHARACTER-SET ((0
2566 ;; . 0))). -- CSR, 2004-10-06
2568 ((csubtypep type
(specifier-type 'standard-char
)) type
)
2570 ((csubtypep type
(specifier-type 'base-char
))
2571 (specifier-type 'base-char
))
2573 ((csubtypep type
(specifier-type 'extended-char
))
2574 (specifier-type 'extended-char
))
2575 (t #+sb-xc-host
(specifier-type 'character
)
2576 #-sb-xc-host type
))))))
2578 (defoptimizer (values derive-type
) ((&rest values
))
2579 (make-values-type :required
(mapcar #'lvar-type values
)))
2581 (defun signum-derive-type-aux (type)
2582 (if (eq (numeric-type-complexp type
) :complex
)
2583 (let* ((format (case (numeric-type-class type
)
2584 ((integer rational
) 'single-float
)
2585 (t (numeric-type-format type
))))
2586 (bound-format (or format
'float
)))
2587 (make-numeric-type :class
'float
2590 :low
(coerce -
1 bound-format
)
2591 :high
(coerce 1 bound-format
)))
2592 (let* ((interval (numeric-type->interval type
))
2593 (range-info (interval-range-info interval
))
2594 (contains-0-p (interval-contains-p 0 interval
))
2595 (class (numeric-type-class type
))
2596 (format (numeric-type-format type
))
2597 (one (coerce 1 (or format class
'real
)))
2598 (zero (coerce 0 (or format class
'real
)))
2599 (minus-one (coerce -
1 (or format class
'real
)))
2600 (plus (make-numeric-type :class class
:format format
2601 :low one
:high one
))
2602 (minus (make-numeric-type :class class
:format format
2603 :low minus-one
:high minus-one
))
2604 ;; KLUDGE: here we have a fairly horrible hack to deal
2605 ;; with the schizophrenia in the type derivation engine.
2606 ;; The problem is that the type derivers reinterpret
2607 ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
2608 ;; 0d0) within the derivation mechanism doesn't include
2609 ;; -0d0. Ugh. So force it in here, instead.
2610 (zero (make-numeric-type :class class
:format format
2611 :low
(- zero
) :high zero
)))
2613 (+ (if contains-0-p
(type-union plus zero
) plus
))
2614 (- (if contains-0-p
(type-union minus zero
) minus
))
2615 (t (type-union minus zero plus
))))))
2617 (defoptimizer (signum derive-type
) ((num))
2618 (one-arg-derive-type num
#'signum-derive-type-aux nil
))
2620 ;;;; byte operations
2622 ;;;; We try to turn byte operations into simple logical operations.
2623 ;;;; First, we convert byte specifiers into separate size and position
2624 ;;;; arguments passed to internal %FOO functions. We then attempt to
2625 ;;;; transform the %FOO functions into boolean operations when the
2626 ;;;; size and position are constant and the operands are fixnums.
2627 ;;;; The goal of the source-transform is to avoid consing a byte specifier
2628 ;;;; to immediately throw away. A more powerful framework could recognize
2629 ;;;; in IR1 when a constructor call flows to one or more accessors for the
2630 ;;;; constructed object and nowhere else (no mutators). If so, forwarding
2631 ;;;; the constructor arguments to their reads would generally solve this.
2632 ;;;; A transform approximates that, but fails when BYTE is produced by an
2633 ;;;; inline function and not a macro.
2634 (flet ((xform (bytespec-form env int fun
&optional
(new nil setter-p
))
2635 (let ((spec (%macroexpand bytespec-form env
)))
2636 (if (and (consp spec
) (eq (car spec
) 'byte
))
2637 (if (proper-list-of-length-p (cdr spec
) 2)
2638 (values `(,fun
,@(if setter-p
(list new
))
2639 ,(second spec
) ,(third spec
) ,int
) nil
)
2640 ;; No point in compiling calls to BYTE-{SIZE,POSITION}
2641 (values nil t
)) ; T => "pass" (meaning "fail")
2642 (let ((new-temp (if setter-p
(copy-symbol 'new
)))
2643 (byte (copy-symbol 'byte
)))
2644 (values `(let (,@(if new-temp
`((,new-temp
,new
)))
2646 (,fun
,@(if setter-p
(list new-temp
))
2647 (byte-size ,byte
) (byte-position ,byte
) ,int
))
2650 ;; DEFINE-SOURCE-TRANSFORM has no compile-time effect, so it's fine that
2651 ;; these 4 things are non-toplevel. (xform does not need to be a macro)
2652 (define-source-transform ldb
(spec int
&environment env
)
2653 (xform spec env int
'%ldb
))
2655 (define-source-transform dpb
(newbyte spec int
&environment env
)
2656 (xform spec env int
'%dpb newbyte
))
2658 (define-source-transform mask-field
(spec int
&environment env
)
2659 (xform spec env int
'%mask-field
))
2661 (define-source-transform deposit-field
(newbyte spec int
&environment env
)
2662 (xform spec env int
'%deposit-field newbyte
)))
2664 (defoptimizer (%ldb derive-type
) ((size posn num
))
2665 (declare (ignore posn num
))
2666 (let ((size (lvar-type size
)))
2667 (if (and (numeric-type-p size
)
2668 (csubtypep size
(specifier-type 'integer
)))
2669 (let ((size-high (numeric-type-high size
)))
2670 (if (and size-high
(<= size-high sb
!vm
:n-word-bits
))
2671 (specifier-type `(unsigned-byte* ,size-high
))
2672 (specifier-type 'unsigned-byte
)))
2675 (defoptimizer (%mask-field derive-type
) ((size posn num
))
2676 (declare (ignore num
))
2677 (let ((size (lvar-type size
))
2678 (posn (lvar-type posn
)))
2679 (if (and (numeric-type-p size
)
2680 (csubtypep size
(specifier-type 'integer
))
2681 (numeric-type-p posn
)
2682 (csubtypep posn
(specifier-type 'integer
)))
2683 (let ((size-high (numeric-type-high size
))
2684 (posn-high (numeric-type-high posn
)))
2685 (if (and size-high posn-high
2686 (<= (+ size-high posn-high
) sb
!vm
:n-word-bits
))
2687 (specifier-type `(unsigned-byte* ,(+ size-high posn-high
)))
2688 (specifier-type 'unsigned-byte
)))
2691 (defun %deposit-field-derive-type-aux
(size posn int
)
2692 (let ((size (lvar-type size
))
2693 (posn (lvar-type posn
))
2694 (int (lvar-type int
)))
2695 (when (and (numeric-type-p size
)
2696 (numeric-type-p posn
)
2697 (numeric-type-p int
))
2698 (let ((size-high (numeric-type-high size
))
2699 (posn-high (numeric-type-high posn
))
2700 (high (numeric-type-high int
))
2701 (low (numeric-type-low int
)))
2702 (when (and size-high posn-high high low
2703 ;; KLUDGE: we need this cutoff here, otherwise we
2704 ;; will merrily derive the type of %DPB as
2705 ;; (UNSIGNED-BYTE 1073741822), and then attempt to
2706 ;; canonicalize this type to (INTEGER 0 (1- (ASH 1
2707 ;; 1073741822))), with hilarious consequences. We
2708 ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference
2709 ;; over a reasonable amount of shifting, even on
2710 ;; the alpha/32 port, where N-WORD-BITS is 32 but
2711 ;; machine integers are 64-bits. -- CSR,
2713 (<= (+ size-high posn-high
) (* 4 sb
!vm
:n-word-bits
)))
2714 (let ((raw-bit-count (max (integer-length high
)
2715 (integer-length low
)
2716 (+ size-high posn-high
))))
2719 `(signed-byte ,(1+ raw-bit-count
))
2720 `(unsigned-byte* ,raw-bit-count
)))))))))
2722 (defoptimizer (%dpb derive-type
) ((newbyte size posn int
))
2723 (declare (ignore newbyte
))
2724 (%deposit-field-derive-type-aux size posn int
))
2726 (defoptimizer (%deposit-field derive-type
) ((newbyte size posn int
))
2727 (declare (ignore newbyte
))
2728 (%deposit-field-derive-type-aux size posn int
))
2730 (deftransform %ldb
((size posn int
)
2731 (fixnum fixnum integer
)
2732 (unsigned-byte #.sb
!vm
:n-word-bits
))
2733 "convert to inline logical operations"
2734 `(logand (ash int
(- posn
))
2735 (ash ,(1- (ash 1 sb
!vm
:n-word-bits
))
2736 (- size
,sb
!vm
:n-word-bits
))))
2738 (deftransform %mask-field
((size posn int
)
2739 (fixnum fixnum integer
)
2740 (unsigned-byte #.sb
!vm
:n-word-bits
))
2741 "convert to inline logical operations"
2743 (ash (ash ,(1- (ash 1 sb
!vm
:n-word-bits
))
2744 (- size
,sb
!vm
:n-word-bits
))
2747 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
2748 ;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
2749 ;;; as the result type, as that would allow result types that cover
2750 ;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
2751 ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
2753 (deftransform %dpb
((new size posn int
)
2755 (unsigned-byte #.sb
!vm
:n-word-bits
))
2756 "convert to inline logical operations"
2757 `(let ((mask (ldb (byte size
0) -
1)))
2758 (logior (ash (logand new mask
) posn
)
2759 (logand int
(lognot (ash mask posn
))))))
2761 (deftransform %dpb
((new size posn int
)
2763 (signed-byte #.sb
!vm
:n-word-bits
))
2764 "convert to inline logical operations"
2765 `(let ((mask (ldb (byte size
0) -
1)))
2766 (logior (ash (logand new mask
) posn
)
2767 (logand int
(lognot (ash mask posn
))))))
2769 (deftransform %deposit-field
((new size posn int
)
2771 (unsigned-byte #.sb
!vm
:n-word-bits
))
2772 "convert to inline logical operations"
2773 `(let ((mask (ash (ldb (byte size
0) -
1) posn
)))
2774 (logior (logand new mask
)
2775 (logand int
(lognot mask
)))))
2777 (deftransform %deposit-field
((new size posn int
)
2779 (signed-byte #.sb
!vm
:n-word-bits
))
2780 "convert to inline logical operations"
2781 `(let ((mask (ash (ldb (byte size
0) -
1) posn
)))
2782 (logior (logand new mask
)
2783 (logand int
(lognot mask
)))))
2785 (defoptimizer (mask-signed-field derive-type
) ((size x
))
2786 (declare (ignore x
))
2787 (let ((size (lvar-type size
)))
2788 (if (numeric-type-p size
)
2789 (let ((size-high (numeric-type-high size
)))
2790 (if (and size-high
(<= 1 size-high sb
!vm
:n-word-bits
))
2791 (specifier-type `(signed-byte ,size-high
))
2798 (defun %ash
/right
(integer amount
)
2799 (ash integer
(- amount
)))
2801 (deftransform ash
((integer amount
))
2802 "Convert ASH of signed word to %ASH/RIGHT"
2803 (unless (and (csubtypep (lvar-type integer
) ; do that ourselves to avoid
2804 (specifier-type 'sb
!vm
:signed-word
)) ; optimization
2805 (csubtypep (lvar-type amount
) ; notes.
2806 (specifier-type '(integer * 0))))
2807 (give-up-ir1-transform))
2808 (when (constant-lvar-p amount
)
2809 (give-up-ir1-transform))
2810 (let ((use (lvar-uses amount
)))
2811 (cond ((and (combination-p use
)
2812 (eql '%negate
(lvar-fun-name (combination-fun use
))))
2813 (splice-fun-args amount
'%negate
1)
2814 `(lambda (integer amount
)
2815 (declare (type unsigned-byte amount
))
2816 (%ash
/right integer
(if (>= amount
,sb
!vm
:n-word-bits
)
2817 ,(1- sb
!vm
:n-word-bits
)
2820 `(%ash
/right integer
(if (<= amount
,(- sb
!vm
:n-word-bits
))
2821 ,(1- sb
!vm
:n-word-bits
)
2824 (deftransform ash
((integer amount
))
2825 "Convert ASH of word to %ASH/RIGHT"
2826 (unless (and (csubtypep (lvar-type integer
)
2827 (specifier-type 'sb
!vm
:word
))
2828 (csubtypep (lvar-type amount
)
2829 (specifier-type '(integer * 0))))
2830 (give-up-ir1-transform))
2831 (when (constant-lvar-p amount
)
2832 (give-up-ir1-transform))
2833 (let ((use (lvar-uses amount
)))
2834 (cond ((and (combination-p use
)
2835 (eql '%negate
(lvar-fun-name (combination-fun use
))))
2836 (splice-fun-args amount
'%negate
1)
2837 `(lambda (integer amount
)
2838 (declare (type unsigned-byte amount
))
2839 (if (>= amount
,sb
!vm
:n-word-bits
)
2841 (%ash
/right integer amount
))))
2843 `(if (<= amount
,(- sb
!vm
:n-word-bits
))
2845 (%ash
/right integer
(- amount
)))))))
2847 (deftransform %ash
/right
((integer amount
) (integer (constant-arg unsigned-byte
)))
2848 "Convert %ASH/RIGHT by constant back to ASH"
2849 `(ash integer
,(- (lvar-value amount
))))
2851 (deftransform %ash
/right
((integer amount
) * * :node node
)
2852 "strength reduce large variable right shift"
2853 (let ((return-type (single-value-type (node-derived-type node
))))
2854 (cond ((type= return-type
(specifier-type '(eql 0)))
2856 ((type= return-type
(specifier-type '(eql -
1)))
2858 ((csubtypep return-type
(specifier-type '(member -
1 0)))
2859 `(ash integer
,(- sb
!vm
:n-word-bits
)))
2861 (give-up-ir1-transform)))))
2863 (defun %ash
/right-derive-type-aux
(n-type shift same-arg
)
2864 (declare (ignore same-arg
))
2865 (or (and (or (csubtypep n-type
(specifier-type 'sb
!vm
:signed-word
))
2866 (csubtypep n-type
(specifier-type 'word
)))
2867 (csubtypep shift
(specifier-type `(mod ,sb
!vm
:n-word-bits
)))
2868 (let ((n-low (numeric-type-low n-type
))
2869 (n-high (numeric-type-high n-type
))
2870 (s-low (numeric-type-low shift
))
2871 (s-high (numeric-type-high shift
)))
2872 (make-numeric-type :class
'integer
:complexp
:real
2875 (ash n-low
(- s-low
))
2876 (ash n-low
(- s-high
))))
2879 (ash n-high
(- s-high
))
2880 (ash n-high
(- s-low
)))))))
2883 (defoptimizer (%ash
/right derive-type
) ((n shift
))
2884 (two-arg-derive-type n shift
#'%ash
/right-derive-type-aux
#'%ash
/right
))
2887 ;;; Not declaring it as actually being RATIO becuase it is used as one
2888 ;;; of the legs in the EXPT transform below and that may result in
2889 ;;; some unwanted type conflicts, e.g. (random (expt 2 (the integer y)))
2890 (declaim (type (sfunction (integer) rational
) reciprocate
))
2891 (defun reciprocate (x)
2892 (declare (optimize (safety 0)))
2895 (deftransform expt
((base power
) ((constant-arg unsigned-byte
) integer
))
2896 (let ((base (lvar-value base
)))
2897 (cond ((/= (logcount base
) 1)
2898 (give-up-ir1-transform))
2902 `(let ((%denominator
(ash 1 ,(if (= base
2)
2904 `(* (abs power
) ,(1- (integer-length base
)))))))
2906 (reciprocate %denominator
)
2909 (deftransform expt
((base power
) ((constant-arg unsigned-byte
) unsigned-byte
))
2910 (let ((base (lvar-value base
)))
2911 (unless (= (logcount base
) 1)
2912 (give-up-ir1-transform))
2913 `(ash 1 ,(if (= base
2)
2915 `(* power
,(1- (integer-length base
)))))))
2917 ;;; Modular functions
2919 ;;; (ldb (byte s 0) (foo x y ...)) =
2920 ;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
2922 ;;; and similar for other arguments.
2924 (defun make-modular-fun-type-deriver (prototype kind width signedp
)
2925 (declare (ignore kind
))
2927 (binding* ((info (info :function
:info prototype
) :exit-if-null
)
2928 (fun (fun-info-derive-type info
) :exit-if-null
)
2929 (mask-type (specifier-type
2931 ((nil) (let ((mask (1- (ash 1 width
))))
2932 `(integer ,mask
,mask
)))
2933 ((t) `(signed-byte ,width
))))))
2935 (let ((res (funcall fun call
)))
2937 (if (eq signedp nil
)
2938 (logand-derive-type-aux res mask-type
))))))
2941 (binding* ((info (info :function
:info prototype
) :exit-if-null
)
2942 (fun (fun-info-derive-type info
) :exit-if-null
)
2943 (res (funcall fun call
) :exit-if-null
)
2944 (mask-type (specifier-type
2946 ((nil) (let ((mask (1- (ash 1 width
))))
2947 `(integer ,mask
,mask
)))
2948 ((t) `(signed-byte ,width
))))))
2949 (if (eq signedp nil
)
2950 (logand-derive-type-aux res mask-type
)))))
2952 ;;; Try to recursively cut all uses of LVAR to WIDTH bits.
2954 ;;; For good functions, we just recursively cut arguments; their
2955 ;;; "goodness" means that the result will not increase (in the
2956 ;;; (unsigned-byte +infinity) sense). An ordinary modular function is
2957 ;;; replaced with the version, cutting its result to WIDTH or more
2958 ;;; bits. For most functions (e.g. for +) we cut all arguments; for
2959 ;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
2960 ;;; arguments (maybe to a different width) and returning the name of a
2961 ;;; modular version, if it exists, or NIL. If we have changed
2962 ;;; anything, we need to flush old derived types, because they have
2963 ;;; nothing in common with the new code.
2964 (defun cut-to-width (lvar kind width signedp
)
2965 (declare (type lvar lvar
) (type (integer 0) width
))
2966 (let ((type (specifier-type (if (zerop width
)
2969 ((nil) 'unsigned-byte
)
2972 (labels ((reoptimize-node (node name
)
2973 (setf (node-derived-type node
)
2975 (info :function
:type name
)))
2976 (setf (lvar-%derived-type
(node-lvar node
)) nil
)
2977 (setf (node-reoptimize node
) t
)
2978 (setf (block-reoptimize (node-block node
)) t
)
2979 (reoptimize-component (node-component node
) :maybe
))
2980 (insert-lvar-cut (lvar)
2981 "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
2982 to the required bit width. Returns T if any change was made.
2984 When the destination of LVAR will definitely cut LVAR's value
2985 to width (i.e. it's a logand or mask-signed-field with constant
2986 other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
2987 (binding* ((dest (lvar-dest lvar
) :exit-if-null
)
2988 (nil (combination-p dest
) :exit-if-null
)
2989 (name (lvar-fun-name (combination-fun dest
) t
))
2990 (args (combination-args dest
)))
2993 (when (= 2 (length args
))
2994 (let ((other (if (eql (first args
) lvar
)
2997 (when (and (constant-lvar-p other
)
2998 (ctypep (lvar-value other
) type
)
3000 (return-from insert-lvar-cut
)))))
3003 (eql lvar
(second args
))
3004 (constant-lvar-p (first args
))
3005 (<= (lvar-value (first args
)) width
))
3006 (return-from insert-lvar-cut
)))))
3009 `(mask-signed-field ,width
'dummy
)
3010 `(logand 'dummy
,(ldb (byte width
0) -
1))))
3011 (do-uses (node lvar
)
3012 (setf (block-reoptimize (node-block node
)) t
)
3013 (reoptimize-component (node-component node
) :maybe
))
3016 "Try to cut a node to width. The primary return value is
3017 whether we managed to cut (cleverly), and the second whether
3018 anything was changed. The third return value tells whether
3019 the cut value might be wider than expected."
3020 (when (block-delete-p (node-block node
))
3021 (return-from cut-node
(values t nil
)))
3024 (typecase (ref-leaf node
)
3026 (let* ((constant-value (constant-value (ref-leaf node
)))
3028 (cond ((not (integerp constant-value
))
3029 (return-from cut-node
(values t nil
)))
3031 (mask-signed-field width constant-value
))
3033 (ldb (byte width
0) constant-value
)))))
3034 (cond ((= constant-value new-value
)
3035 (values t nil
)) ; we knew what to do and did nothing
3037 (change-ref-leaf node
(make-constant new-value
)
3039 (let ((lvar (node-lvar node
)))
3040 (setf (lvar-%derived-type lvar
)
3041 (and (lvar-has-single-use-p lvar
)
3042 (make-values-type :required
(list (ctype-of new-value
))))))
3043 (setf (block-reoptimize (node-block node
)) t
)
3044 (reoptimize-component (node-component node
) :maybe
)
3047 (when (eq (basic-combination-kind node
) :known
)
3048 (let* ((fun-ref (lvar-use (combination-fun node
)))
3049 (fun-name (lvar-fun-name (combination-fun node
)))
3050 (modular-fun (find-modular-version fun-name kind
3052 (cond ((not modular-fun
)
3053 ;; don't know what to do here
3055 ((let ((dtype (single-value-type
3056 (node-derived-type node
))))
3061 (specifier-type 'unsigned-byte
)))
3064 (specifier-type '(integer * 0))))
3068 (csubtypep dtype type
)))
3072 (binding* ((name (etypecase modular-fun
3073 ((eql :good
) fun-name
)
3075 (modular-fun-info-name modular-fun
))
3077 (funcall modular-fun node width
)))
3081 (unless (eql modular-fun
:good
)
3082 (setq did-something t
3086 (find-free-fun name
"in a strange place"))
3087 (setf (combination-kind node
) :full
))
3088 (unless (functionp modular-fun
)
3089 (dolist (arg (basic-combination-args node
))
3090 (multiple-value-bind (change wide
)
3092 (setf did-something
(or did-something change
)
3093 over-wide
(or over-wide wide
)))))
3095 (reoptimize-node node name
))
3096 (values t did-something over-wide
)))))))))
3097 (cut-lvar (lvar &key head
3098 &aux did-something must-insert over-wide
)
3099 "Cut all the LVAR's use nodes. If any of them wasn't handled
3100 and its type is too wide for the operation we wish to perform
3101 insert an explicit bit-width narrowing operation (LOGAND or
3102 MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
3103 The narrowing operation might not be inserted if the LVAR's
3104 destination is already such an operation, to avoid endless
3107 If we're at the head, forcibly insert a cut operation if the
3108 result might be too wide.
3110 (*) We can't easily do that for each node, and doing so might
3111 result in code bloat, anyway. (I'm also not sure it would be
3112 correct for complicated C/D FG)"
3113 (do-uses (node lvar
)
3114 (multiple-value-bind (handled any-change wide
)
3116 (setf did-something
(or did-something any-change
)
3117 must-insert
(or must-insert
3119 (csubtypep (single-value-type
3120 (node-derived-type node
))
3122 over-wide
(or over-wide wide
))))
3123 (when (or must-insert
3124 (and head over-wide
))
3125 (setf did-something
(or (insert-lvar-cut lvar
) did-something
)
3126 ;; we're just the right width after an explicit cut.
3128 (values did-something over-wide
)))
3129 (cut-lvar lvar
:head t
))))
3131 (defun best-modular-version (width signedp
)
3132 ;; 1. exact width-matched :untagged
3133 ;; 2. >/>= width-matched :tagged
3134 ;; 3. >/>= width-matched :untagged
3135 (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class
*))
3136 (uswidths (modular-class-widths *untagged-signed-modular-class
*))
3137 (uwidths (if (and uuwidths uswidths
)
3138 (merge 'list
(copy-list uuwidths
) (copy-list uswidths
)
3140 (or uuwidths uswidths
)))
3141 (twidths (modular-class-widths *tagged-modular-class
*)))
3142 (let ((exact (find (cons width signedp
) uwidths
:test
#'equal
)))
3144 (return-from best-modular-version
(values width
:untagged signedp
))))
3145 (flet ((inexact-match (w)
3147 ((eq signedp
(cdr w
)) (<= width
(car w
)))
3148 ((eq signedp nil
) (< width
(car w
))))))
3149 (let ((tgt (find-if #'inexact-match twidths
)))
3151 (return-from best-modular-version
3152 (values (car tgt
) :tagged
(cdr tgt
)))))
3153 (let ((ugt (find-if #'inexact-match uwidths
)))
3155 (return-from best-modular-version
3156 (values (car ugt
) :untagged
(cdr ugt
))))))))
3158 (defun integer-type-numeric-bounds (type)
3160 ;; KLUDGE: this is not INTEGER-type-numeric-bounds
3161 (numeric-type (values (numeric-type-low type
)
3162 (numeric-type-high type
)))
3166 (dolist (type (union-type-types type
) (values low high
))
3167 (unless (and (numeric-type-p type
)
3168 (eql (numeric-type-class type
) 'integer
))
3169 (return (values nil nil
)))
3170 (let ((this-low (numeric-type-low type
))
3171 (this-high (numeric-type-high type
)))
3172 (unless (and this-low this-high
)
3173 (return (values nil nil
)))
3174 (setf low
(min this-low
(or low this-low
))
3175 high
(max this-high
(or high this-high
)))))))))
3177 (defoptimizer (logand optimizer
) ((x y
) node
)
3178 (let ((result-type (single-value-type (node-derived-type node
))))
3179 (multiple-value-bind (low high
)
3180 (integer-type-numeric-bounds result-type
)
3181 (when (and (numberp low
)
3184 (let ((width (integer-length high
)))
3185 (multiple-value-bind (w kind signedp
)
3186 (best-modular-version width nil
)
3188 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
3190 ;; FIXME: I think the FIXME (which is from APD) above
3191 ;; implies that CUT-TO-WIDTH should do /everything/
3192 ;; that's required, including reoptimizing things
3193 ;; itself that it knows are necessary. At the moment,
3194 ;; CUT-TO-WIDTH sets up some new calls with
3195 ;; combination-type :FULL, which later get noticed as
3196 ;; known functions and properly converted.
3198 ;; We cut to W not WIDTH if SIGNEDP is true, because
3199 ;; signed constant replacement needs to know which bit
3200 ;; in the field is the signed bit.
3201 (let ((xact (cut-to-width x kind
(if signedp w width
) signedp
))
3202 (yact (cut-to-width y kind
(if signedp w width
) signedp
)))
3203 (declare (ignore xact yact
))
3204 nil
) ; After fixing above, replace with T, meaning
3205 ; "don't reoptimize this (LOGAND) node any more".
3208 (defoptimizer (mask-signed-field optimizer
) ((width x
) node
)
3209 (declare (ignore width
))
3210 (let ((result-type (single-value-type (node-derived-type node
))))
3211 (multiple-value-bind (low high
)
3212 (integer-type-numeric-bounds result-type
)
3213 (when (and (numberp low
) (numberp high
))
3214 (let ((width (max (integer-length high
) (integer-length low
))))
3215 (multiple-value-bind (w kind
)
3216 (best-modular-version (1+ width
) t
)
3218 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
3219 ;; [ see comment above in LOGAND optimizer ]
3220 (cut-to-width x kind w t
)
3221 nil
; After fixing above, replace with T.
3224 (defoptimizer (logior optimizer
) ((x y
) node
)
3225 (let ((result-type (single-value-type (node-derived-type node
))))
3226 (multiple-value-bind (low high
)
3227 (integer-type-numeric-bounds result-type
)
3228 (when (and (numberp low
)
3231 (let ((width (integer-length low
)))
3232 (multiple-value-bind (w kind
)
3233 (best-modular-version (1+ width
) t
)
3235 ;; FIXME: see comment in LOGAND optimizer
3236 (let ((xact (cut-to-width x kind w t
))
3237 (yact (cut-to-width y kind w t
)))
3238 (declare (ignore xact yact
))
3239 nil
) ; After fixing above, replace with T
3242 ;;; Handle the case of a constant BOOLE-CODE.
3243 (deftransform boole
((op x y
) * *)
3244 "convert to inline logical operations"
3245 (unless (constant-lvar-p op
)
3246 (give-up-ir1-transform "BOOLE code is not a constant."))
3247 (let ((control (lvar-value op
)))
3249 (#.sb
!xc
:boole-clr
0)
3250 (#.sb
!xc
:boole-set -
1)
3251 (#.sb
!xc
:boole-1
'x
)
3252 (#.sb
!xc
:boole-2
'y
)
3253 (#.sb
!xc
:boole-c1
'(lognot x
))
3254 (#.sb
!xc
:boole-c2
'(lognot y
))
3255 (#.sb
!xc
:boole-and
'(logand x y
))
3256 (#.sb
!xc
:boole-ior
'(logior x y
))
3257 (#.sb
!xc
:boole-xor
'(logxor x y
))
3258 (#.sb
!xc
:boole-eqv
'(logeqv x y
))
3259 (#.sb
!xc
:boole-nand
'(lognand x y
))
3260 (#.sb
!xc
:boole-nor
'(lognor x y
))
3261 (#.sb
!xc
:boole-andc1
'(logandc1 x y
))
3262 (#.sb
!xc
:boole-andc2
'(logandc2 x y
))
3263 (#.sb
!xc
:boole-orc1
'(logorc1 x y
))
3264 (#.sb
!xc
:boole-orc2
'(logorc2 x y
))
3266 (abort-ir1-transform "~S is an illegal control arg to BOOLE."
3269 ;;;; converting special case multiply/divide to shifts
3271 ;;; If arg is a constant power of two, turn * into a shift.
3272 (deftransform * ((x y
) (integer integer
) *)
3273 "convert x*2^k to shift"
3274 (unless (constant-lvar-p y
)
3275 (give-up-ir1-transform))
3276 (let* ((y (lvar-value y
))
3278 (len (1- (integer-length y-abs
))))
3279 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3280 (give-up-ir1-transform))
3285 ;;; These must come before the ones below, so that they are tried
3287 (deftransform floor
((number divisor
))
3288 `(multiple-value-bind (tru rem
) (truncate number divisor
)
3289 (if (and (not (zerop rem
))
3290 (if (minusp divisor
)
3293 (values (1- tru
) (+ rem divisor
))
3296 (deftransform ceiling
((number divisor
))
3297 `(multiple-value-bind (tru rem
) (truncate number divisor
)
3298 (if (and (not (zerop rem
))
3299 (if (minusp divisor
)
3302 (values (+ tru
1) (- rem divisor
))
3305 (deftransform rem
((number divisor
))
3306 `(nth-value 1 (truncate number divisor
)))
3308 (deftransform mod
((number divisor
))
3309 `(let ((rem (rem number divisor
)))
3310 (if (and (not (zerop rem
))
3311 (if (minusp divisor
)
3317 ;;; If arg is a constant power of two, turn FLOOR into a shift and
3318 ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
3320 (flet ((frob (y ceil-p
)
3321 (unless (constant-lvar-p y
)
3322 (give-up-ir1-transform))
3323 (let* ((y (lvar-value y
))
3325 (len (1- (integer-length y-abs
))))
3326 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3327 (give-up-ir1-transform))
3328 (let ((shift (- len
))
3330 (delta (if ceil-p
(* (signum y
) (1- y-abs
)) 0)))
3331 `(let ((x (+ x
,delta
)))
3333 `(values (ash (- x
) ,shift
)
3334 (- (- (logand (- x
) ,mask
)) ,delta
))
3335 `(values (ash x
,shift
)
3336 (- (logand x
,mask
) ,delta
))))))))
3337 (deftransform floor
((x y
) (integer integer
) *)
3338 "convert division by 2^k to shift"
3340 (deftransform ceiling
((x y
) (integer integer
) *)
3341 "convert division by 2^k to shift"
3344 ;;; Do the same for MOD.
3345 (deftransform mod
((x y
) (integer integer
) *)
3346 "convert remainder mod 2^k to LOGAND"
3347 (unless (constant-lvar-p y
)
3348 (give-up-ir1-transform))
3349 (let* ((y (lvar-value y
))
3351 (len (1- (integer-length y-abs
))))
3352 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3353 (give-up-ir1-transform))
3354 (let ((mask (1- y-abs
)))
3356 `(- (logand (- x
) ,mask
))
3357 `(logand x
,mask
)))))
3359 ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
3360 (deftransform truncate
((x y
) (integer integer
))
3361 "convert division by 2^k to shift"
3362 (unless (constant-lvar-p y
)
3363 (give-up-ir1-transform))
3364 (let* ((y (lvar-value y
))
3366 (len (1- (integer-length y-abs
))))
3367 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3368 (give-up-ir1-transform))
3369 (let* ((shift (- len
))
3372 (values ,(if (minusp y
)
3374 `(- (ash (- x
) ,shift
)))
3375 (- (logand (- x
) ,mask
)))
3376 (values ,(if (minusp y
)
3377 `(ash (- ,mask x
) ,shift
)
3379 (logand x
,mask
))))))
3381 ;;; And the same for REM.
3382 (deftransform rem
((x y
) (integer integer
) *)
3383 "convert remainder mod 2^k to LOGAND"
3384 (unless (constant-lvar-p y
)
3385 (give-up-ir1-transform))
3386 (let* ((y (lvar-value y
))
3388 (len (1- (integer-length y-abs
))))
3389 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3390 (give-up-ir1-transform))
3391 (let ((mask (1- y-abs
)))
3393 (- (logand (- x
) ,mask
))
3394 (logand x
,mask
)))))
3396 ;;; Return an expression to calculate the integer quotient of X and
3397 ;;; constant Y, using multiplication, shift and add/sub instead of
3398 ;;; division. Both arguments must be unsigned, fit in a machine word and
3399 ;;; Y must neither be zero nor a power of two. The quotient is rounded
3401 ;;; The algorithm is taken from the paper "Division by Invariant
3402 ;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and
3403 ;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the
3404 ;;; case of division by powers of two.
3405 ;;; The algorithm includes an adaptive precision argument. Use it, since
3406 ;;; we often have sub-word value ranges. Careful, in this case, we need
3407 ;;; p s.t 2^p > n, not the ceiling of the binary log.
3408 ;;; Also, for some reason, the paper prefers shifting to masking. Mask
3409 ;;; instead. Masking is equivalent to shifting right, then left again;
3410 ;;; all the intermediate values are still words, so we just have to shift
3411 ;;; right a bit more to compensate, at the end.
3413 ;;; The following two examples show an average case and the worst case
3414 ;;; with respect to the complexity of the generated expression, under
3415 ;;; a word size of 64 bits:
3417 ;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) ->
3418 ;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3)
3420 ;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) ->
3422 ;;; (T1 (%MULTIPLY NUM 2635249153387078803)))
3423 ;;; (ASH (LDB (BYTE 64 0)
3424 ;;; (+ T1 (ASH (LDB (BYTE 64 0)
3429 (defun gen-unsigned-div-by-constant-expr (y max-x
)
3430 (declare (type (integer 3 #.most-positive-word
) y
)
3432 (aver (not (zerop (logand y
(1- y
)))))
3434 ;; the floor of the binary logarithm of (positive) X
3435 (integer-length (1- x
)))
3436 (choose-multiplier (y precision
)
3438 (shift l
(1- shift
))
3439 (expt-2-n+l
(expt 2 (+ sb
!vm
:n-word-bits l
)))
3440 (m-low (truncate expt-2-n
+l y
) (ash m-low -
1))
3441 (m-high (truncate (+ expt-2-n
+l
3442 (ash expt-2-n
+l
(- precision
)))
3445 ((not (and (< (ash m-low -
1) (ash m-high -
1))
3447 (values m-high shift
)))))
3448 (let ((n (expt 2 sb
!vm
:n-word-bits
))
3449 (precision (integer-length max-x
))
3451 (multiple-value-bind (m shift2
)
3452 (choose-multiplier y precision
)
3453 (when (and (>= m n
) (evenp y
))
3454 (setq shift1
(ld (logand y
(- y
))))
3455 (multiple-value-setq (m shift2
)
3456 (choose-multiplier (/ y
(ash 1 shift1
))
3457 (- precision shift1
))))
3460 `(truly-the word
,x
)))
3462 (t1 (%multiply-high num
,(- m n
))))
3463 (ash ,(word `(+ t1
(ash ,(word `(- num t1
))
3466 ((and (zerop shift1
) (zerop shift2
))
3467 (let ((max (truncate max-x y
)))
3468 ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM
3470 `(truly-the (integer 0 ,max
)
3471 (%multiply-high x
,m
))))
3473 `(ash (%multiply-high
(logandc2 x
,(1- (ash 1 shift1
))) ,m
)
3474 ,(- (+ shift1 shift2
)))))))))
3476 ;;; If the divisor is constant and both args are positive and fit in a
3477 ;;; machine word, replace the division by a multiplication and possibly
3478 ;;; some shifts and an addition. Calculate the remainder by a second
3479 ;;; multiplication and a subtraction. Dead code elimination will
3480 ;;; suppress the latter part if only the quotient is needed. If the type
3481 ;;; of the dividend allows to derive that the quotient will always have
3482 ;;; the same value, emit much simpler code to handle that. (This case
3483 ;;; may be rare but it's easy to detect and the compiler doesn't find
3484 ;;; this optimization on its own.)
3485 (deftransform truncate
((x y
) (word (constant-arg word
))
3487 :policy
(and (> speed compilation-speed
)
3489 "convert integer division to multiplication"
3490 (let* ((y (lvar-value y
))
3491 (x-type (lvar-type x
))
3492 (max-x (or (and (numeric-type-p x-type
)
3493 (numeric-type-high x-type
))
3494 most-positive-word
)))
3495 ;; Division by zero, one or powers of two is handled elsewhere.
3496 (when (zerop (logand y
(1- y
)))
3497 (give-up-ir1-transform))
3498 `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x
))
3499 (rem (ldb (byte #.sb
!vm
:n-word-bits
0)
3500 (- x
(* quot
,y
)))))
3501 (values quot rem
))))
3503 ;;;; arithmetic and logical identity operation elimination
3505 ;;; Flush calls to various arith functions that convert to the
3506 ;;; identity function or a constant.
3507 (macrolet ((def (name identity result
)
3508 `(deftransform ,name
((x y
) (* (constant-arg (member ,identity
))) *)
3509 "fold identity operations"
3516 (def logxor -
1 (lognot x
))
3519 (defun least-zero-bit (x)
3521 (1- (integer-length (logxor x
(1+ x
))))))
3523 (deftransform logand
((x y
) (* (constant-arg t
)) *)
3524 "fold identity operation"
3525 (let* ((y (lvar-value y
))
3526 (width (or (least-zero-bit y
) '*)))
3527 (unless (and (neq width
0) ; (logand x 0) handled elsewhere
3528 (csubtypep (lvar-type x
)
3529 (specifier-type `(unsigned-byte ,width
))))
3530 (give-up-ir1-transform))
3533 (deftransform mask-signed-field
((size x
) ((constant-arg t
) *) *)
3534 "fold identity operation"
3535 (let ((size (lvar-value size
)))
3536 (unless (csubtypep (lvar-type x
) (specifier-type `(signed-byte ,size
)))
3537 (give-up-ir1-transform))
3540 (deftransform logior
((x y
) (* (constant-arg integer
)) *)
3541 "fold identity operation"
3542 (let* ((y (lvar-value y
))
3543 (width (or (least-zero-bit (lognot y
))
3544 (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
3545 (unless (csubtypep (lvar-type x
)
3546 (specifier-type `(integer ,(- (ash 1 width
)) -
1)))
3547 (give-up-ir1-transform))
3550 ;;; Pick off easy association opportunities for constant folding.
3551 ;;; More complicated stuff that also depends on commutativity
3552 ;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
3553 ;;; probably be handled with a more general tree-rewriting pass.
3554 (macrolet ((def (operator &key
(type 'integer
) (folded operator
))
3555 `(deftransform ,operator
((x z
) (,type
(constant-arg ,type
)))
3556 ,(format nil
"associate ~A/~A of constants"
3558 (binding* ((node (if (lvar-has-single-use-p x
)
3560 (give-up-ir1-transform)))
3561 (nil (or (and (combination-p node
)
3563 (combination-fun node
))
3565 (give-up-ir1-transform)))
3566 (y (second (combination-args node
)))
3567 (nil (or (constant-lvar-p y
)
3568 (give-up-ir1-transform)))
3570 (unless (typep y
',type
)
3571 (give-up-ir1-transform))
3572 (splice-fun-args x
',folded
2)
3574 (declare (ignore y z
))
3575 ;; (operator (folded x y) z)
3576 ;; == (operator x (folded z y))
3577 (,',operator x
',(,folded
(lvar-value z
) y
)))))))
3581 (def logtest
:folded logand
)
3582 (def + :type rational
)
3583 (def + :type rational
:folded -
)
3584 (def * :type rational
)
3585 (def * :type rational
:folded
/))
3587 (deftransform mask-signed-field
((width x
) ((constant-arg unsigned-byte
) *))
3588 "Fold mask-signed-field/mask-signed-field of constant width"
3589 (binding* ((node (if (lvar-has-single-use-p x
)
3591 (give-up-ir1-transform)))
3592 (nil (or (combination-p node
)
3593 (give-up-ir1-transform)))
3594 (nil (or (eq (lvar-fun-name (combination-fun node
))
3596 (give-up-ir1-transform)))
3597 (x-width (first (combination-args node
)))
3598 (nil (or (constant-lvar-p x-width
)
3599 (give-up-ir1-transform)))
3600 (x-width (lvar-value x-width
)))
3601 (unless (typep x-width
'unsigned-byte
)
3602 (give-up-ir1-transform))
3603 (splice-fun-args x
'mask-signed-field
2)
3604 `(lambda (width x-width x
)
3605 (declare (ignore width x-width
))
3606 (mask-signed-field ,(min (lvar-value width
) x-width
) x
))))
3608 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
3609 ;;; (* 0 -4.0) is -0.0.
3610 (deftransform -
((x y
) ((constant-arg (member 0)) rational
) *)
3611 "convert (- 0 x) to negate"
3613 (deftransform * ((x y
) (rational (constant-arg (member 0))) *)
3614 "convert (* x 0) to 0"
3617 (deftransform %negate
((x) (rational))
3618 "Eliminate %negate/%negate of rationals"
3619 (splice-fun-args x
'%negate
1)
3622 (deftransform %negate
((x) (number))
3624 (let ((use (lvar-uses x
))
3626 (unless (and (combination-p use
)
3627 (eql '* (lvar-fun-name (combination-fun use
)))
3628 (constant-lvar-p (setf arg
(second (combination-args use
))))
3629 (numberp (setf arg
(lvar-value arg
))))
3630 (give-up-ir1-transform))
3631 (splice-fun-args x
'* 2)
3633 (declare (ignore y
))
3636 ;;; Return T if in an arithmetic op including lvars X and Y, the
3637 ;;; result type is not affected by the type of X. That is, Y is at
3638 ;;; least as contagious as X.
3640 (defun not-more-contagious (x y
)
3641 (declare (type continuation x y
))
3642 (let ((x (lvar-type x
))
3644 (values (type= (numeric-contagion x y
)
3645 (numeric-contagion y y
)))))
3646 ;;; Patched version by Raymond Toy. dtc: Should be safer although it
3647 ;;; XXX needs more work as valid transforms are missed; some cases are
3648 ;;; specific to particular transform functions so the use of this
3649 ;;; function may need a re-think.
3650 (defun not-more-contagious (x y
)
3651 (declare (type lvar x y
))
3652 (flet ((simple-numeric-type (num)
3653 (and (numeric-type-p num
)
3654 ;; Return non-NIL if NUM is integer, rational, or a float
3655 ;; of some type (but not FLOAT)
3656 (case (numeric-type-class num
)
3660 (numeric-type-format num
))
3663 (let ((x (lvar-type x
))
3665 (if (and (simple-numeric-type x
)
3666 (simple-numeric-type y
))
3667 (values (type= (numeric-contagion x y
)
3668 (numeric-contagion y y
)))))))
3670 (def!type exact-number
()
3671 '(or rational
(complex rational
)))
3675 ;;; Only safely applicable for exact numbers. For floating-point
3676 ;;; x, one would have to first show that neither x or y are signed
3677 ;;; 0s, and that x isn't an SNaN.
3678 (deftransform + ((x y
) (exact-number (constant-arg (eql 0))) *)
3683 (deftransform -
((x y
) (exact-number (constant-arg (eql 0))) *)
3687 ;;; Fold (OP x +/-1)
3689 ;;; %NEGATE might not always signal correctly.
3691 ((def (name result minus-result
)
3692 `(deftransform ,name
((x y
)
3693 (exact-number (constant-arg (member 1 -
1))))
3694 "fold identity operations"
3695 (if (minusp (lvar-value y
)) ',minus-result
',result
))))
3696 (def * x
(%negate x
))
3697 (def / x
(%negate x
))
3698 (def expt x
(/ 1 x
)))
3700 ;;; Fold (expt x n) into multiplications for small integral values of
3701 ;;; N; convert (expt x 1/2) to sqrt.
3702 (deftransform expt
((x y
) (t (constant-arg real
)) *)
3703 "recode as multiplication or sqrt"
3704 (let ((val (lvar-value y
)))
3705 ;; If Y would cause the result to be promoted to the same type as
3706 ;; Y, we give up. If not, then the result will be the same type
3707 ;; as X, so we can replace the exponentiation with simple
3708 ;; multiplication and division for small integral powers.
3709 (unless (not-more-contagious y x
)
3710 (give-up-ir1-transform))
3712 (let ((x-type (lvar-type x
)))
3713 (cond ((csubtypep x-type
(specifier-type '(or rational
3714 (complex rational
))))
3716 ((csubtypep x-type
(specifier-type 'real
))
3720 ((csubtypep x-type
(specifier-type 'complex
))
3721 ;; both parts are float
3723 (t (give-up-ir1-transform)))))
3724 ((= val
2) '(* x x
))
3725 ((= val -
2) '(/ (* x x
)))
3726 ((= val
3) '(* x x x
))
3727 ((= val -
3) '(/ (* x x x
)))
3728 ((= val
1/2) '(sqrt x
))
3729 ((= val -
1/2) '(/ (sqrt x
)))
3730 (t (give-up-ir1-transform)))))
3732 (deftransform expt
((x y
) ((constant-arg (member -
1 -
1.0 -
1.0d0
)) integer
) *)
3733 "recode as an ODDP check"
3734 (let ((val (lvar-value x
)))
3736 '(- 1 (* 2 (logand 1 y
)))
3741 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
3742 ;;; transformations?
3743 ;;; Perhaps we should have to prove that the denominator is nonzero before
3744 ;;; doing them? -- WHN 19990917
3745 (macrolet ((def (name)
3746 `(deftransform ,name
((x y
) ((constant-arg (integer 0 0)) integer
)
3753 (macrolet ((def (name)
3754 `(deftransform ,name
((x y
) ((constant-arg (integer 0 0)) integer
)
3763 (macrolet ((def (name &optional float
)
3764 (let ((x (if float
'(float x
) 'x
)))
3765 `(deftransform ,name
((x y
) (integer (constant-arg (member 1 -
1)))
3767 "fold division by 1"
3768 `(values ,(if (minusp (lvar-value y
))
3781 ;;;; character operations
3783 (deftransform two-arg-char-equal
((a b
) (base-char base-char
) *
3784 :policy
(> speed space
))
3786 '(let* ((ac (char-code a
))
3788 (sum (logxor ac bc
)))
3790 (when (eql sum
#x20
)
3791 (let ((sum (+ ac bc
)))
3792 (or (and (> sum
161) (< sum
213))
3793 (and (> sum
415) (< sum
461))
3794 (and (> sum
463) (< sum
477))))))))
3796 (deftransform two-arg-char-equal
((a b
) (* (constant-arg character
)) *
3798 (let ((char (lvar-value b
)))
3799 (if (both-case-p char
)
3800 (let ((reverse (if (upper-case-p char
)
3801 (char-downcase char
)
3802 (char-upcase char
))))
3803 (if (policy node
(> speed space
))
3804 `(or (char= a
,char
)
3806 `(char-equal-constant a
,char
,reverse
)))
3809 (deftransform char-upcase
((x) (base-char))
3811 '(let ((n-code (char-code x
)))
3812 (if (or (and (> n-code
#o140
) ; Octal 141 is #\a.
3813 (< n-code
#o173
)) ; Octal 172 is #\z.
3814 (and (> n-code
#o337
)
3816 (and (> n-code
#o367
)
3818 (code-char (logxor #x20 n-code
))
3821 (deftransform char-downcase
((x) (base-char))
3823 '(let ((n-code (char-code x
)))
3824 (if (or (and (> n-code
64) ; 65 is #\A.
3825 (< n-code
91)) ; 90 is #\Z.
3830 (code-char (logxor #x20 n-code
))
3833 ;;;; equality predicate transforms
3835 ;;; Return true if X and Y are lvars whose only use is a
3836 ;;; reference to the same leaf, and the value of the leaf cannot
3838 (defun same-leaf-ref-p (x y
)
3839 (declare (type lvar x y
))
3840 (let ((x-use (principal-lvar-use x
))
3841 (y-use (principal-lvar-use y
)))
3844 (eq (ref-leaf x-use
) (ref-leaf y-use
))
3845 (constant-reference-p x-use
))))
3847 ;;; If X and Y are the same leaf, then the result is true. Otherwise,
3848 ;;; if there is no intersection between the types of the arguments,
3849 ;;; then the result is definitely false.
3850 (deftransform simple-equality-transform
((x y
) * *
3853 ((same-leaf-ref-p x y
) t
)
3854 ((not (types-equal-or-intersect (lvar-type x
) (lvar-type y
)))
3856 (t (give-up-ir1-transform))))
3859 `(%deftransform
',x
'(function * *) #'simple-equality-transform
)))
3862 (def two-arg-char-equal
))
3864 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
3865 ;;; try to convert to a type-specific predicate or EQ:
3866 ;;; -- If both args are characters, convert to CHAR=. This is better than
3867 ;;; just converting to EQ, since CHAR= may have special compilation
3868 ;;; strategies for non-standard representations, etc.
3869 ;;; -- If either arg is definitely a fixnum, we check to see if X is
3870 ;;; constant and if so, put X second. Doing this results in better
3871 ;;; code from the backend, since the backend assumes that any constant
3872 ;;; argument comes second.
3873 ;;; -- If either arg is definitely not a number or a fixnum, then we
3874 ;;; can compare with EQ.
3875 ;;; -- Otherwise, we try to put the arg we know more about second. If X
3876 ;;; is constant then we put it second. If X is a subtype of Y, we put
3877 ;;; it second. These rules make it easier for the back end to match
3878 ;;; these interesting cases.
3879 (deftransform eql
((x y
) * * :node node
)
3880 "convert to simpler equality predicate"
3881 (let ((x-type (lvar-type x
))
3882 (y-type (lvar-type y
))
3883 #!+integer-eql-vop
(int-type (specifier-type 'integer
))
3884 (char-type (specifier-type 'character
)))
3886 ((same-leaf-ref-p x y
) t
)
3887 ((not (types-equal-or-intersect x-type y-type
))
3889 ((and (csubtypep x-type char-type
)
3890 (csubtypep y-type char-type
))
3892 ((or (eq-comparable-type-p x-type
) (eq-comparable-type-p y-type
))
3895 ((or (csubtypep x-type int-type
) (csubtypep y-type int-type
))
3896 '(%eql
/integer x y
))
3898 (give-up-ir1-transform)))))
3900 ;;; similarly to the EQL transform above, we attempt to constant-fold
3901 ;;; or convert to a simpler predicate: mostly we have to be careful
3902 ;;; with strings and bit-vectors.
3903 (deftransform equal
((x y
) * *)
3904 "convert to simpler equality predicate"
3905 (let ((x-type (lvar-type x
))
3906 (y-type (lvar-type y
))
3907 (combination-type (specifier-type '(or bit-vector string
3909 (flet ((both-csubtypep (type)
3910 (let ((ctype (specifier-type type
)))
3911 (and (csubtypep x-type ctype
)
3912 (csubtypep y-type ctype
)))))
3914 ((same-leaf-ref-p x y
) t
)
3915 ((and (constant-lvar-p x
)
3916 (equal (lvar-value x
) ""))
3918 (zerop (length y
))))
3919 ((and (constant-lvar-p y
)
3920 (equal (lvar-value y
) ""))
3922 (zerop (length x
))))
3923 ((both-csubtypep 'string
)
3925 ((both-csubtypep 'bit-vector
)
3926 '(bit-vector-= x y
))
3927 ((both-csubtypep 'pathname
)
3929 ((or (not (types-equal-or-intersect x-type combination-type
))
3930 (not (types-equal-or-intersect y-type combination-type
)))
3931 (if (types-equal-or-intersect x-type y-type
)
3933 ;; Can't simply check for type intersection if both types are combination-type
3934 ;; since array specialization would mean types don't intersect, even when EQUAL
3935 ;; doesn't care for specialization.
3936 ;; Previously checking for intersection in the outer COND resulted in
3938 ;; (equal (the (cons (or simple-bit-vector
3939 ;; simple-base-string))
3941 ;; (the (cons (or (and bit-vector (not simple-array))
3942 ;; (simple-array character (*))))
3944 ;; being incorrectly folded to NIL
3946 (t (give-up-ir1-transform))))))
3948 (deftransform equalp
((x y
) * *)
3949 "convert to simpler equality predicate"
3950 (let ((x-type (lvar-type x
))
3951 (y-type (lvar-type y
))
3952 (combination-type (specifier-type '(or number array
3955 instance hash-table
))))
3956 (flet ((both-csubtypep (type)
3957 (let ((ctype (specifier-type type
)))
3958 (and (csubtypep x-type ctype
)
3959 (csubtypep y-type ctype
)))))
3961 ((same-leaf-ref-p x y
) t
)
3962 ((and (constant-lvar-p x
)
3963 (equal (lvar-value x
) ""))
3965 (zerop (length y
))))
3966 ((and (constant-lvar-p y
)
3967 (equal (lvar-value y
) ""))
3969 (zerop (length x
))))
3970 ((both-csubtypep 'string
)
3971 '(string-equal x y
))
3972 ((both-csubtypep 'bit-vector
)
3973 '(bit-vector-= x y
))
3974 ((both-csubtypep 'pathname
)
3976 ((both-csubtypep 'character
)
3978 ((both-csubtypep 'number
)
3980 ((both-csubtypep 'hash-table
)
3981 '(hash-table-equalp x y
))
3982 ((or (not (types-equal-or-intersect x-type combination-type
))
3983 (not (types-equal-or-intersect y-type combination-type
)))
3984 ;; See the comment about specialized types in the EQUAL transform above
3985 (if (types-equal-or-intersect y-type x-type
)
3988 (t (give-up-ir1-transform))))))
3990 ;;; Convert to EQL if both args are rational and complexp is specified
3991 ;;; and the same for both.
3992 (deftransform = ((x y
) (number number
) *)
3994 (let ((x-type (lvar-type x
))
3995 (y-type (lvar-type y
)))
3996 (cond ((or (and (csubtypep x-type
(specifier-type 'float
))
3997 (csubtypep y-type
(specifier-type 'float
)))
3998 (and (csubtypep x-type
(specifier-type '(complex float
)))
3999 (csubtypep y-type
(specifier-type '(complex float
))))
4000 #!+complex-float-vops
4001 (and (csubtypep x-type
(specifier-type '(or single-float
(complex single-float
))))
4002 (csubtypep y-type
(specifier-type '(or single-float
(complex single-float
)))))
4003 #!+complex-float-vops
4004 (and (csubtypep x-type
(specifier-type '(or double-float
(complex double-float
))))
4005 (csubtypep y-type
(specifier-type '(or double-float
(complex double-float
))))))
4006 ;; They are both floats. Leave as = so that -0.0 is
4007 ;; handled correctly.
4008 (give-up-ir1-transform))
4009 ((or (and (csubtypep x-type
(specifier-type 'rational
))
4010 (csubtypep y-type
(specifier-type 'rational
)))
4011 (and (csubtypep x-type
4012 (specifier-type '(complex rational
)))
4014 (specifier-type '(complex rational
)))))
4015 ;; They are both rationals and complexp is the same.
4019 (give-up-ir1-transform
4020 "The operands might not be the same type.")))))
4022 (defun maybe-float-lvar-p (lvar)
4023 (neq *empty-type
* (type-intersection (specifier-type 'float
)
4026 (flet ((maybe-invert (node op inverted x y
)
4027 ;; Don't invert if either argument can be a float (NaNs)
4029 ((or (maybe-float-lvar-p x
) (maybe-float-lvar-p y
))
4030 (delay-ir1-transform node
:constraint
)
4031 `(or (,op x y
) (= x y
)))
4033 `(if (,inverted x y
) nil t
)))))
4034 (deftransform >= ((x y
) (number number
) * :node node
)
4035 "invert or open code"
4036 (maybe-invert node
'> '< x y
))
4037 (deftransform <= ((x y
) (number number
) * :node node
)
4038 "invert or open code"
4039 (maybe-invert node
'< '> x y
)))
4041 ;;; See whether we can statically determine (< X Y) using type
4042 ;;; information. If X's high bound is < Y's low, then X < Y.
4043 ;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
4044 ;;; NIL). If not, at least make sure any constant arg is second.
4045 (macrolet ((def (name inverse reflexive-p surely-true surely-false
)
4046 `(deftransform ,name
((x y
))
4047 "optimize using intervals"
4048 (if (and (same-leaf-ref-p x y
)
4049 ;; For non-reflexive functions we don't need
4050 ;; to worry about NaNs: (non-ref-op NaN NaN) => false,
4051 ;; but with reflexive ones we don't know...
4053 '((and (not (maybe-float-lvar-p x
))
4054 (not (maybe-float-lvar-p y
))))))
4056 (let ((ix (or (type-approximate-interval (lvar-type x
))
4057 (give-up-ir1-transform)))
4058 (iy (or (type-approximate-interval (lvar-type y
))
4059 (give-up-ir1-transform))))
4064 ((and (constant-lvar-p x
)
4065 (not (constant-lvar-p y
)))
4068 (give-up-ir1-transform))))))))
4069 (def = = t
(interval-= ix iy
) (interval-/= ix iy
))
4070 (def /= /= nil
(interval-/= ix iy
) (interval-= ix iy
))
4071 (def < > nil
(interval-< ix iy
) (interval->= ix iy
))
4072 (def > < nil
(interval-< iy ix
) (interval->= iy ix
))
4073 (def <= >= t
(interval->= iy ix
) (interval-< iy ix
))
4074 (def >= <= t
(interval->= ix iy
) (interval-< ix iy
)))
4076 (defun ir1-transform-char< (x y first second inverse
)
4078 ((same-leaf-ref-p x y
) nil
)
4079 ;; If we had interval representation of character types, as we
4080 ;; might eventually have to to support 2^21 characters, then here
4081 ;; we could do some compile-time computation as in transforms for
4082 ;; < above. -- CSR, 2003-07-01
4083 ((and (constant-lvar-p first
)
4084 (not (constant-lvar-p second
)))
4086 (t (give-up-ir1-transform))))
4088 (deftransform char
< ((x y
) (character character
) *)
4089 (ir1-transform-char< x y x y
'char
>))
4091 (deftransform char
> ((x y
) (character character
) *)
4092 (ir1-transform-char< y x x y
'char
<))
4094 ;;;; converting N-arg comparisons
4096 ;;;; We convert calls to N-arg comparison functions such as < into
4097 ;;;; two-arg calls. This transformation is enabled for all such
4098 ;;;; comparisons in this file. If any of these predicates are not
4099 ;;;; open-coded, then the transformation should be removed at some
4100 ;;;; point to avoid pessimization.
4102 ;;; This function is used for source transformation of N-arg
4103 ;;; comparison functions other than inequality. We deal both with
4104 ;;; converting to two-arg calls and inverting the sense of the test,
4105 ;;; if necessary. If the call has two args, then we pass or return a
4106 ;;; negated test as appropriate. If it is a degenerate one-arg call,
4107 ;;; then we transform to code that returns true. Otherwise, we bind
4108 ;;; all the arguments and expand into a bunch of IFs.
4109 (defun multi-compare (predicate args not-p type
&optional force-two-arg-p
)
4110 (let ((nargs (length args
)))
4111 (cond ((< nargs
1) (values nil t
))
4112 ((= nargs
1) `(progn (the ,type
,@args
) t
))
4115 `(if (,predicate
,(first args
) ,(second args
)) nil t
)
4117 `(,predicate
,(first args
) ,(second args
))
4120 (do* ((i (1- nargs
) (1- i
))
4122 (current (gensym) (gensym))
4123 (vars (list current
) (cons current vars
))
4125 `(if (,predicate
,current
,last
)
4127 `(if (,predicate
,current
,last
)
4130 `((lambda ,vars
(declare (type ,type
,@vars
)) ,result
)
4133 (define-source-transform = (&rest args
) (multi-compare '= args nil
'number
))
4134 (define-source-transform < (&rest args
) (multi-compare '< args nil
'real
))
4135 (define-source-transform > (&rest args
) (multi-compare '> args nil
'real
))
4136 ;;; We cannot do the inversion for >= and <= here, since both
4137 ;;; (< NaN X) and (> NaN X)
4138 ;;; are false, and we don't have type-information available yet. The
4139 ;;; deftransforms for two-argument versions of >= and <= takes care of
4140 ;;; the inversion to > and < when possible.
4141 (define-source-transform <= (&rest args
) (multi-compare '<= args nil
'real
))
4142 (define-source-transform >= (&rest args
) (multi-compare '>= args nil
'real
))
4144 (define-source-transform char
= (&rest args
) (multi-compare 'char
= args nil
4146 (define-source-transform char
< (&rest args
) (multi-compare 'char
< args nil
4148 (define-source-transform char
> (&rest args
) (multi-compare 'char
> args nil
4150 (define-source-transform char
<= (&rest args
) (multi-compare 'char
> args t
4152 (define-source-transform char
>= (&rest args
) (multi-compare 'char
< args t
4155 (define-source-transform char-equal
(&rest args
)
4156 (multi-compare 'two-arg-char-equal args nil
'character t
))
4157 (define-source-transform char-lessp
(&rest args
)
4158 (multi-compare 'two-arg-char-lessp args nil
'character t
))
4159 (define-source-transform char-greaterp
(&rest args
)
4160 (multi-compare 'two-arg-char-greaterp args nil
'character t
))
4161 (define-source-transform char-not-greaterp
(&rest args
)
4162 (multi-compare 'two-arg-char-greaterp args t
'character t
))
4163 (define-source-transform char-not-lessp
(&rest args
)
4164 (multi-compare 'two-arg-char-lessp args t
'character t
))
4166 ;;; This function does source transformation of N-arg inequality
4167 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
4168 ;;; arg cases. If there are more than two args, then we expand into
4169 ;;; the appropriate n^2 comparisons only when speed is important.
4170 (declaim (ftype (function (symbol list t
) *) multi-not-equal
))
4171 (defun multi-not-equal (predicate args type
)
4172 (let ((nargs (length args
)))
4173 (cond ((< nargs
1) (values nil t
))
4174 ((= nargs
1) `(progn (the ,type
,@args
) t
))
4176 `(if (,predicate
,(first args
) ,(second args
)) nil t
))
4177 ((not (policy *lexenv
*
4178 (and (>= speed space
)
4179 (>= speed compilation-speed
))))
4182 (let ((vars (make-gensym-list nargs
)))
4183 (do ((var vars next
)
4184 (next (cdr vars
) (cdr next
))
4187 `((lambda ,vars
(declare (type ,type
,@vars
)) ,result
)
4189 (let ((v1 (first var
)))
4191 (setq result
`(if (,predicate
,v1
,v2
) nil
,result
))))))))))
4193 (define-source-transform /= (&rest args
)
4194 (multi-not-equal '= args
'number
))
4195 (define-source-transform char
/= (&rest args
)
4196 (multi-not-equal 'char
= args
'character
))
4197 (define-source-transform char-not-equal
(&rest args
)
4198 (multi-not-equal 'char-equal args
'character
))
4200 ;;; Expand MAX and MIN into the obvious comparisons.
4201 (define-source-transform max
(arg0 &rest rest
)
4202 (once-only ((arg0 arg0
))
4204 `(values (the real
,arg0
))
4205 `(let ((maxrest (max ,@rest
)))
4206 (if (>= ,arg0 maxrest
) ,arg0 maxrest
)))))
4207 (define-source-transform min
(arg0 &rest rest
)
4208 (once-only ((arg0 arg0
))
4210 `(values (the real
,arg0
))
4211 `(let ((minrest (min ,@rest
)))
4212 (if (<= ,arg0 minrest
) ,arg0 minrest
)))))
4214 ;;; Simplify some cross-type comparisons
4215 (macrolet ((def (comparator round
)
4217 (deftransform ,comparator
4218 ((x y
) (rational (constant-arg float
)))
4219 "open-code RATIONAL to FLOAT comparison"
4220 (let ((y (lvar-value y
)))
4222 (when (or (float-nan-p y
)
4223 (float-infinity-p y
))
4224 (give-up-ir1-transform))
4225 (setf y
(rational y
))
4227 x
,(if (csubtypep (lvar-type x
)
4228 (specifier-type 'integer
))
4231 (deftransform ,comparator
4232 ((x y
) (integer (constant-arg ratio
)))
4233 "open-code INTEGER to RATIO comparison"
4234 `(,',comparator x
,(,round
(lvar-value y
)))))))
4238 (deftransform = ((x y
) (rational (constant-arg float
)))
4239 "open-code RATIONAL to FLOAT comparison"
4240 (let ((y (lvar-value y
)))
4242 (when (or (float-nan-p y
)
4243 (float-infinity-p y
))
4244 (give-up-ir1-transform))
4245 (setf y
(rational y
))
4246 (if (and (csubtypep (lvar-type x
)
4247 (specifier-type 'integer
))
4252 (deftransform = ((x y
) (integer (constant-arg ratio
)))
4253 "constant-fold INTEGER to RATIO comparison"
4256 ;;;; converting N-arg arithmetic functions
4258 ;;;; N-arg arithmetic and logic functions are associated into two-arg
4259 ;;;; versions, and degenerate cases are flushed.
4261 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
4262 (declaim (ftype (sfunction (symbol t list
) list
) associate-args
))
4263 (defun associate-args (fun first-arg more-args
)
4265 (let ((next (rest more-args
))
4266 (arg (first more-args
)))
4268 `(,fun
,first-arg
,arg
)
4269 (associate-args fun
`(,fun
,first-arg
,arg
) next
))))
4271 ;;; Reduce constants in ARGS list.
4272 (declaim (ftype (sfunction (symbol list symbol
) list
) reduce-constants
))
4273 (defun reduce-constants (fun args one-arg-result-type
)
4274 (let ((one-arg-constant-p (ecase one-arg-result-type
4276 (integer #'integerp
)))
4279 (collect ((not-constants))
4281 (let ((value (if (constantp arg
)
4282 (constant-form-value arg
)
4284 (cond ((not (funcall one-arg-constant-p value
))
4285 (not-constants arg
))
4287 (setf reduced-value
(funcall fun reduced-value value
)
4290 (setf reduced-value value
)))))
4291 ;; It is tempting to drop constants reduced to identity here,
4292 ;; but if X is SNaN in (* X 1), we cannot drop the 1.
4295 `(,reduced-value
,@(not-constants))
4297 `(,reduced-value
)))))
4299 ;;; Do source transformations for transitive functions such as +.
4300 ;;; One-arg cases are replaced with the arg and zero arg cases with
4301 ;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE)
4302 ;;; that the argument in one-argument calls is.
4303 (declaim (ftype (function (symbol list t
&optional symbol list
)
4304 (values t
&optional
(member nil t
)))
4305 source-transform-transitive
))
4306 (defun source-transform-transitive (fun args identity
4307 &optional
(one-arg-result-type 'number
)
4308 (one-arg-prefixes '(values)))
4311 (1 `(,@one-arg-prefixes
(the ,one-arg-result-type
,(first args
))))
4314 (let* ((reduced-args (reduce-constants fun args one-arg-result-type
))
4315 (first (first reduced-args
))
4316 (rest (rest reduced-args
)))
4318 (associate-args fun first rest
)
4321 (define-source-transform + (&rest args
)
4322 (source-transform-transitive '+ args
0))
4323 (define-source-transform * (&rest args
)
4324 (source-transform-transitive '* args
1))
4325 (define-source-transform logior
(&rest args
)
4326 (source-transform-transitive 'logior args
0 'integer
))
4327 (define-source-transform logxor
(&rest args
)
4328 (source-transform-transitive 'logxor args
0 'integer
))
4329 (define-source-transform logand
(&rest args
)
4330 (source-transform-transitive 'logand args -
1 'integer
))
4331 (define-source-transform logeqv
(&rest args
)
4332 (source-transform-transitive 'logeqv args -
1 'integer
))
4333 (define-source-transform gcd
(&rest args
)
4334 (source-transform-transitive 'gcd args
0 'integer
'(abs)))
4335 (define-source-transform lcm
(&rest args
)
4336 (source-transform-transitive 'lcm args
1 'integer
'(abs)))
4338 ;;; Do source transformations for intransitive n-arg functions such as
4339 ;;; /. With one arg, we form the inverse. With two args we pass.
4340 ;;; Otherwise we associate into two-arg calls.
4341 (declaim (ftype (function (symbol symbol list list
&optional symbol
)
4342 (values list
&optional
(member nil t
)))
4343 source-transform-intransitive
))
4344 (defun source-transform-intransitive (fun fun
* args one-arg-prefixes
4345 &optional
(one-arg-result-type 'number
))
4347 ((0 2) (values nil t
))
4348 (1 `(,@one-arg-prefixes
(the ,one-arg-result-type
,(first args
))))
4351 (reduce-constants fun
* (rest args
) one-arg-result-type
)))
4352 (associate-args fun
(first args
) reduced-args
)))))
4354 (define-source-transform -
(&rest args
)
4355 (source-transform-intransitive '-
'+ args
'(%negate
)))
4356 (define-source-transform / (&rest args
)
4357 (source-transform-intransitive '/ '* args
'(/ 1)))
4359 ;;;; transforming APPLY
4361 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
4362 ;;; only needs to understand one kind of variable-argument call. It is
4363 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
4364 (define-source-transform apply
(fun arg
&rest more-args
)
4365 (let ((args (cons arg more-args
)))
4366 `(multiple-value-call ,fun
4367 ,@(mapcar (lambda (x) `(values ,x
)) (butlast args
))
4368 (values-list ,(car (last args
))))))
4370 ;;;; transforming references to &REST argument
4372 ;;; We add magical &MORE arguments to all functions with &REST. If ARG names
4373 ;;; the &REST argument, this returns the lambda-vars for the context and
4375 (defun possible-rest-arg-context (arg)
4377 (let* ((var (lexenv-find arg vars
))
4378 (info (when (lambda-var-p var
)
4379 (lambda-var-arg-info var
))))
4381 (eq :rest
(arg-info-kind info
))
4382 (consp (arg-info-default info
)))
4383 (values-list (arg-info-default info
))))))
4385 (defun mark-more-context-used (rest-var)
4386 (let ((info (lambda-var-arg-info rest-var
)))
4387 (aver (eq :rest
(arg-info-kind info
)))
4388 (destructuring-bind (context count
&optional used
) (arg-info-default info
)
4390 (setf (arg-info-default info
) (list context count t
))))))
4392 (defun mark-more-context-invalid (rest-var)
4393 (let ((info (lambda-var-arg-info rest-var
)))
4394 (aver (eq :rest
(arg-info-kind info
)))
4395 (setf (arg-info-default info
) t
)))
4397 ;;; This determines of we the REF to a &REST variable is headed towards
4398 ;;; parts unknown, or if we can really use the context.
4399 (defun rest-var-more-context-ok (lvar)
4400 (let* ((use (lvar-use lvar
))
4401 (var (when (ref-p use
) (ref-leaf use
)))
4402 (home (when (lambda-var-p var
) (lambda-var-home var
)))
4403 (info (when (lambda-var-p var
) (lambda-var-arg-info var
)))
4404 (restp (when info
(eq :rest
(arg-info-kind info
)))))
4405 (flet ((ref-good-for-more-context-p (ref)
4406 (when (not (node-lvar ref
)) ; ref that goes nowhere is ok
4407 (return-from ref-good-for-more-context-p t
))
4408 (let ((dest (principal-lvar-end (node-lvar ref
))))
4409 (and (combination-p dest
)
4410 ;; If the destination is to anything but these, we're going to
4411 ;; actually need the rest list -- and since other operations
4412 ;; might modify the list destructively, the using the context
4413 ;; isn't good anywhere else either.
4414 (lvar-fun-is (combination-fun dest
)
4415 '(%rest-values %rest-ref %rest-length
4416 %rest-null %rest-true
))
4417 ;; If the home lambda is different and isn't DX, it might
4418 ;; escape -- in which case using the more context isn't safe.
4419 (let ((clambda (node-home-lambda dest
)))
4420 (or (eq home clambda
)
4421 (leaf-dynamic-extent clambda
)))))))
4422 (let ((ok (and restp
4423 (consp (arg-info-default info
))
4424 (not (lambda-var-specvar var
))
4425 (not (lambda-var-sets var
))
4426 (every #'ref-good-for-more-context-p
(lambda-var-refs var
)))))
4428 (mark-more-context-used var
)
4430 (mark-more-context-invalid var
)))
4433 ;;; VALUES-LIST -> %REST-VALUES
4434 (define-source-transform values-list
(list)
4435 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4437 `(%rest-values
,list
,context
,count
)
4440 ;;; NTH -> %REST-REF
4441 (define-source-transform nth
(n list
)
4442 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4444 `(%rest-ref
,n
,list
,context
,count
)
4445 `(car (nthcdr ,n
,list
)))))
4446 (define-source-transform fast-
&rest-nth
(n list
)
4447 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4449 `(%rest-ref
,n
,list
,context
,count t
)
4450 (bug "no &REST context for FAST-REST-NTH"))))
4452 (define-source-transform elt
(seq n
)
4453 (if (policy *lexenv
* (= safety
3))
4455 (multiple-value-bind (context count
) (possible-rest-arg-context seq
)
4457 `(%rest-ref
,n
,seq
,context
,count
)
4460 ;;; CAxR -> %REST-REF
4461 (defun source-transform-car (list nth
)
4462 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4464 `(%rest-ref
,nth
,list
,context
,count
)
4467 (define-source-transform car
(list)
4468 (source-transform-car list
0))
4470 (define-source-transform cadr
(list)
4471 (or (source-transform-car list
1)
4472 `(car (cdr ,list
))))
4474 (define-source-transform caddr
(list)
4475 (or (source-transform-car list
2)
4476 `(car (cdr (cdr ,list
)))))
4478 (define-source-transform cadddr
(list)
4479 (or (source-transform-car list
3)
4480 `(car (cdr (cdr (cdr ,list
))))))
4482 ;;; LENGTH -> %REST-LENGTH
4483 (defun source-transform-length (list)
4484 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
4486 `(%rest-length
,list
,context
,count
)
4488 (define-source-transform length
(list) (source-transform-length list
))
4489 (define-source-transform list-length
(list) (source-transform-length list
))
4491 ;;; ENDP, NULL and NOT -> %REST-NULL
4493 ;;; Outside &REST convert into an IF so that IF optimizations will eliminate
4494 ;;; redundant negations.
4495 (defun source-transform-null (x op
)
4496 (multiple-value-bind (context count
) (possible-rest-arg-context x
)
4498 `(%rest-null
',op
,x
,context
,count
))
4500 `(if (the list
,x
) nil t
))
4503 (define-source-transform not
(x) (source-transform-null x
'not
))
4504 (define-source-transform null
(x) (source-transform-null x
'null
))
4505 (define-source-transform endp
(x) (source-transform-null x
'endp
))
4507 (deftransform %rest-values
((list context count
))
4508 (if (rest-var-more-context-ok list
)
4509 `(%more-arg-values context
0 count
)
4510 `(values-list list
)))
4512 (deftransform %rest-ref
((n list context count
&optional length-checked-p
))
4513 (cond ((rest-var-more-context-ok list
)
4514 (if (and (constant-lvar-p length-checked-p
)
4515 (lvar-value length-checked-p
))
4516 `(%more-arg context n
)
4517 `(and (< (the index n
) count
) (%more-arg context n
))))
4518 ((and (constant-lvar-p n
) (zerop (lvar-value n
)))
4523 (deftransform %rest-length
((list context count
))
4524 (if (rest-var-more-context-ok list
)
4528 (deftransform %rest-null
((op list context count
))
4529 (aver (constant-lvar-p op
))
4530 (if (rest-var-more-context-ok list
)
4532 `(,(lvar-value op
) list
)))
4534 (deftransform %rest-true
((list context count
))
4535 (if (rest-var-more-context-ok list
)
4536 `(not (eql 0 count
))
4539 ;;;; transforming FORMAT
4541 ;;;; If the control string is a compile-time constant, then replace it
4542 ;;;; with a use of the FORMATTER macro so that the control string is
4543 ;;;; ``compiled.'' Furthermore, if the destination is either a stream
4544 ;;;; or T and the control string is a function (i.e. FORMATTER), then
4545 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
4547 ;;; for compile-time argument count checking.
4549 ;;; FIXME II: In some cases, type information could be correlated; for
4550 ;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
4551 ;;; of a corresponding argument is known and does not intersect the
4552 ;;; list type, a warning could be signalled.
4553 (defun check-format-args (string args fun
)
4554 (declare (type string string
))
4555 (unless (typep string
'simple-string
)
4556 (setq string
(coerce string
'simple-string
)))
4557 (multiple-value-bind (min max
)
4558 (handler-case (sb!format
:%compiler-walk-format-string string args
)
4559 (sb!format
:format-error
(c)
4560 (compiler-warn "~A" c
)))
4562 (let ((nargs (length args
)))
4565 (warn 'format-too-few-args-warning
4567 "Too few arguments (~D) to ~S ~S: requires at least ~D."
4568 :format-arguments
(list nargs fun string min
)))
4570 (warn 'format-too-many-args-warning
4572 "Too many arguments (~D) to ~S ~S: uses at most ~D."
4573 :format-arguments
(list nargs fun string max
))))))))
4575 (defoptimizer (format optimizer
) ((dest control
&rest args
))
4576 (declare (ignore dest
))
4577 (when (constant-lvar-p control
)
4578 (let ((x (lvar-value control
)))
4580 (check-format-args x args
'format
)))))
4582 (defoptimizer (format derive-type
) ((dest control
&rest args
))
4583 (declare (ignore control args
))
4584 (when (and (constant-lvar-p dest
)
4585 (null (lvar-value dest
)))
4586 (specifier-type '(simple-array character
(*)))))
4588 ;;; We disable this transform in the cross-compiler to save memory in
4589 ;;; the target image; most of the uses of FORMAT in the compiler are for
4590 ;;; error messages, and those don't need to be particularly fast.
4592 (deftransform format
((dest control
&rest args
) (t simple-string
&rest t
) *
4593 :policy
(>= speed space
))
4594 (unless (constant-lvar-p control
)
4595 (give-up-ir1-transform "The control string is not a constant."))
4596 (let* ((argc (length args
))
4597 (arg-names (make-gensym-list argc
))
4598 (control (lvar-value control
))
4599 ;; Expanding the control string now avoids deferring to FORMATTER
4600 ;; so that we don't need an internal-only variant of it that
4601 ;; passes through extra args to %FORMATTER.
4602 (expr (handler-case ; in case %formatter wants to signal an error
4603 (sb!format
::%formatter control argc nil
)
4604 ;; otherwise, let the macro complain
4605 (sb!format
:format-error
() `(formatter ,control
)))))
4606 `(lambda (dest control
,@arg-names
)
4607 (declare (ignore control
))
4608 (format dest
,expr
,@arg-names
))))
4610 (deftransform format
((stream control
&rest args
) (stream function
&rest t
))
4611 (let ((arg-names (make-gensym-list (length args
))))
4612 `(lambda (stream control
,@arg-names
)
4613 (funcall control stream
,@arg-names
)
4616 (deftransform format
((tee control
&rest args
) ((member t
) function
&rest t
))
4617 (let ((arg-names (make-gensym-list (length args
))))
4618 `(lambda (tee control
,@arg-names
)
4619 (declare (ignore tee
))
4620 (funcall control
*standard-output
* ,@arg-names
)
4623 (deftransform format
((stream control
&rest args
) (null function
&rest t
))
4624 (let ((arg-names (make-gensym-list (length args
))))
4625 `(lambda (stream control
,@arg-names
)
4626 (declare (ignore stream
))
4627 (with-simple-output-to-string (stream)
4628 (funcall control stream
,@arg-names
)))))
4630 (defun concatenate-format-p (control args
)
4632 (loop for directive in control
4634 (or (stringp directive
)
4635 (and (sb!format
::format-directive-p directive
)
4636 (let ((char (sb!format
::format-directive-character directive
))
4637 (params (sb!format
::format-directive-params directive
)))
4640 (char-equal char
#\a)
4646 (null (sb!format
::format-directive-colonp directive
))
4647 (null (sb!format
::format-directive-atsignp directive
))
4650 '(cons (cons (eql 1) unsigned-byte
) null
)))))))))
4653 (deftransform format
((stream control
&rest args
) (null (constant-arg string
) &rest string
))
4656 (sb!format
::tokenize-control-string
(lvar-value control
))
4657 (sb!format
:format-error
()
4658 (give-up-ir1-transform)))))
4659 (unless (concatenate-format-p tokenized args
)
4660 (give-up-ir1-transform))
4661 (let ((arg-names (make-gensym-list (length args
))))
4662 `(lambda (stream control
,@arg-names
)
4663 (declare (ignore stream control
))
4666 ,@(loop for directive in tokenized
4667 for char
= (and (not (stringp directive
))
4668 (sb!format
::format-directive-character directive
))
4672 ((char-equal char
#\a)
4675 (let ((n (or (cdar (sb!format
::format-directive-params directive
))
4685 (deftransform pathname
((pathspec) (pathname) *)
4688 (deftransform pathname
((pathspec) (string) *)
4689 '(values (parse-namestring pathspec
)))
4693 `(defoptimizer (,name optimizer
) ((control &rest args
))
4694 (when (constant-lvar-p control
)
4695 (let ((x (lvar-value control
)))
4697 (check-format-args x args
',name
)))))))
4700 #+sb-xc-host
; Only we should be using these
4703 (def compiler-error
)
4705 (def compiler-style-warn
)
4706 (def compiler-notify
)
4707 (def maybe-compiler-notify
)
4710 (defoptimizer (cerror optimizer
) ((report control
&rest args
))
4711 (when (and (constant-lvar-p control
)
4712 (constant-lvar-p report
))
4713 (let ((x (lvar-value control
))
4714 (y (lvar-value report
)))
4715 (when (and (stringp x
) (stringp y
))
4716 (multiple-value-bind (min1 max1
)
4718 (sb!format
:%compiler-walk-format-string x args
)
4719 (sb!format
:format-error
(c)
4720 (compiler-warn "~A" c
)))
4722 (multiple-value-bind (min2 max2
)
4724 (sb!format
:%compiler-walk-format-string y args
)
4725 (sb!format
:format-error
(c)
4726 (compiler-warn "~A" c
)))
4728 (let ((nargs (length args
)))
4730 ((< nargs
(min min1 min2
))
4731 (warn 'format-too-few-args-warning
4733 "Too few arguments (~D) to ~S ~S ~S: ~
4734 requires at least ~D."
4736 (list nargs
'cerror y x
(min min1 min2
))))
4737 ((> nargs
(max max1 max2
))
4738 (warn 'format-too-many-args-warning
4740 "Too many arguments (~D) to ~S ~S ~S: ~
4743 (list nargs
'cerror y x
(max max1 max2
))))))))))))))
4745 (defun constant-cons-type (type)
4746 (multiple-value-bind (singleton value
)
4747 (type-singleton-p type
)
4752 (multiple-value-bind (car car-good
)
4753 (constant-cons-type (cons-type-car-type type
))
4754 (multiple-value-bind (cdr cdr-good
)
4755 (constant-cons-type (cons-type-cdr-type type
))
4756 (and car-good cdr-good
4757 (values (cons car cdr
) t
)))))))))
4759 (defoptimizer (coerce derive-type
) ((value type
) node
)
4760 (multiple-value-bind (type constant
)
4761 (if (constant-lvar-p type
)
4762 (values (lvar-value type
) t
)
4763 (constant-cons-type (lvar-type type
)))
4765 ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
4766 ;; but dealing with the niggle that complex canonicalization gets
4767 ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
4769 (let ((result-typeoid (careful-specifier-type type
)))
4771 ((null result-typeoid
) nil
)
4772 ((csubtypep result-typeoid
(specifier-type 'number
))
4773 ;; the difficult case: we have to cope with ANSI 12.1.5.3
4774 ;; Rule of Canonical Representation for Complex Rationals,
4775 ;; which is a truly nasty delivery to field.
4777 ((csubtypep result-typeoid
(specifier-type 'real
))
4778 ;; cleverness required here: it would be nice to deduce
4779 ;; that something of type (INTEGER 2 3) coerced to type
4780 ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0).
4781 ;; FLOAT gets its own clause because it's implemented as
4782 ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE
4785 ((and (numeric-type-p result-typeoid
)
4786 (eq (numeric-type-complexp result-typeoid
) :real
))
4787 ;; FIXME: is this clause (a) necessary or (b) useful?
4789 ((or (csubtypep result-typeoid
4790 (specifier-type '(complex single-float
)))
4791 (csubtypep result-typeoid
4792 (specifier-type '(complex double-float
)))
4794 (csubtypep result-typeoid
4795 (specifier-type '(complex long-float
))))
4796 ;; float complex types are never canonicalized.
4799 ;; if it's not a REAL, or a COMPLEX FLOAToid, it's
4800 ;; probably just a COMPLEX or equivalent. So, in that
4801 ;; case, we will return a complex or an object of the
4802 ;; provided type if it's rational:
4803 (type-union result-typeoid
4804 (type-intersection (lvar-type value
)
4805 (specifier-type 'rational
))))))
4806 ((and (policy node
(zerop safety
))
4807 (csubtypep result-typeoid
(specifier-type '(array * (*)))))
4808 ;; At zero safety the deftransform for COERCE can elide dimension
4809 ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
4810 ;; need to simplify the type to drop the dimension information.
4811 (let ((vtype (simplify-vector-type result-typeoid
)))
4813 (specifier-type vtype
)
4816 result-typeoid
))))))
4818 (defoptimizer (compile derive-type
) ((nameoid function
))
4819 (declare (ignore function
))
4820 (when (csubtypep (lvar-type nameoid
)
4821 (specifier-type 'null
))
4822 (values-specifier-type '(values function boolean boolean
))))
4824 ;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
4825 ;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
4826 ;;; optimizer, above).
4827 (defoptimizer (array-element-type derive-type
) ((array))
4828 (let ((array-type (lvar-type array
)))
4829 (labels ((consify (list)
4832 `(cons (eql ,(car list
)) ,(consify (rest list
)))))
4833 (get-element-type (a)
4835 (type-specifier (array-type-specialized-element-type a
))))
4836 (cond ((eq element-type
'*)
4837 (specifier-type 'type-specifier
))
4838 ((symbolp element-type
)
4839 (make-eql-type element-type
))
4840 ((consp element-type
)
4841 (specifier-type (consify element-type
)))
4843 (error "can't understand type ~S~%" element-type
))))))
4844 (labels ((recurse (type)
4845 (cond ((array-type-p type
)
4846 (get-element-type type
))
4847 ((union-type-p type
)
4849 (mapcar #'recurse
(union-type-types type
))))
4851 *universal-type
*))))
4852 (recurse array-type
)))))
4854 (define-source-transform sb
!impl
::sort-vector
(vector start end predicate key
)
4855 ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
4856 ;; isn't really related to the CMU CL code, since instead of trying
4857 ;; to generalize the CMU CL code to allow START and END values, this
4858 ;; code has been written from scratch following Chapter 7 of
4859 ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
4860 `(macrolet ((%index
(x) `(truly-the index
,x
))
4861 (%parent
(i) `(ash ,i -
1))
4862 (%left
(i) `(%index
(ash ,i
1)))
4863 (%right
(i) `(%index
(1+ (ash ,i
1))))
4866 (left (%left i
) (%left i
)))
4867 ((> left current-heap-size
))
4868 (declare (type index i left
))
4869 (let* ((i-elt (%elt i
))
4870 (i-key (funcall keyfun i-elt
))
4871 (left-elt (%elt left
))
4872 (left-key (funcall keyfun left-elt
)))
4873 (multiple-value-bind (large large-elt large-key
)
4874 (if (funcall ,',predicate i-key left-key
)
4875 (values left left-elt left-key
)
4876 (values i i-elt i-key
))
4877 (let ((right (%right i
)))
4878 (multiple-value-bind (largest largest-elt
)
4879 (if (> right current-heap-size
)
4880 (values large large-elt
)
4881 (let* ((right-elt (%elt right
))
4882 (right-key (funcall keyfun right-elt
)))
4883 (if (funcall ,',predicate large-key right-key
)
4884 (values right right-elt
)
4885 (values large large-elt
))))
4886 (cond ((= largest i
)
4889 (setf (%elt i
) largest-elt
4890 (%elt largest
) i-elt
4892 (%sort-vector
(keyfun &optional
(vtype 'vector
))
4893 `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had
4894 ;; trouble getting type inference to
4895 ;; propagate all the way through this
4896 ;; tangled mess of inlining. The TRULY-THE
4897 ;; here works around that. -- WHN
4899 `(aref (truly-the ,',vtype
,',',vector
)
4900 (%index
(+ (%index
,i
) start-1
)))))
4901 (let (;; Heaps prefer 1-based addressing.
4902 (start-1 (1- ,',start
))
4903 (current-heap-size (- ,',end
,',start
))
4905 (declare (type (integer -
1 #.
(1- sb
!xc
:most-positive-fixnum
))
4907 (declare (type index current-heap-size
))
4908 (declare (type function keyfun
))
4909 (loop for i of-type index
4910 from
(ash current-heap-size -
1) downto
1 do
4913 (when (< current-heap-size
2)
4915 (rotatef (%elt
1) (%elt current-heap-size
))
4916 (decf current-heap-size
)
4918 (if (typep ,vector
'simple-vector
)
4919 ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
4920 ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
4922 ;; Special-casing the KEY=NIL case lets us avoid some
4924 (%sort-vector
#'identity simple-vector
)
4925 (%sort-vector
,key simple-vector
))
4926 ;; It's hard to anticipate many speed-critical applications for
4927 ;; sorting vector types other than (VECTOR T), so we just lump
4928 ;; them all together in one slow dynamically typed mess.
4930 (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
4931 (%sort-vector
(or ,key
#'identity
))))))
4933 (deftransform sort
((list predicate
&key key
)
4935 `(sb!impl
::stable-sort-list list
4936 (%coerce-callable-to-fun predicate
)
4937 (if key
(%coerce-callable-to-fun key
) #'identity
)))
4939 (deftransform stable-sort
((sequence predicate
&key key
)
4940 ((or vector list
) *))
4941 (let ((sequence-type (lvar-type sequence
)))
4942 (cond ((csubtypep sequence-type
(specifier-type 'list
))
4943 `(sb!impl
::stable-sort-list sequence
4944 (%coerce-callable-to-fun predicate
)
4945 (if key
(%coerce-callable-to-fun key
) #'identity
)))
4946 ((csubtypep sequence-type
(specifier-type 'simple-vector
))
4947 `(sb!impl
::stable-sort-simple-vector sequence
4948 (%coerce-callable-to-fun predicate
)
4949 (and key
(%coerce-callable-to-fun key
))))
4951 `(sb!impl
::stable-sort-vector sequence
4952 (%coerce-callable-to-fun predicate
)
4953 (and key
(%coerce-callable-to-fun key
)))))))
4955 ;;;; debuggers' little helpers
4957 ;;; for debugging when transforms are behaving mysteriously,
4958 ;;; e.g. when debugging a problem with an ASH transform
4959 ;;; (defun foo (&optional s)
4960 ;;; (sb-c::/report-lvar s "S outside WHEN")
4961 ;;; (when (and (integerp s) (> s 3))
4962 ;;; (sb-c::/report-lvar s "S inside WHEN")
4963 ;;; (let ((bound (ash 1 (1- s))))
4964 ;;; (sb-c::/report-lvar bound "BOUND")
4965 ;;; (let ((x (- bound))
4967 ;;; (sb-c::/report-lvar x "X")
4968 ;;; (sb-c::/report-lvar x "Y"))
4969 ;;; `(integer ,(- bound) ,(1- bound)))))
4970 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
4971 ;;; and the function doesn't do anything at all.)
4974 (defknown /report-lvar
(t t
) null
)
4975 (deftransform /report-lvar
((x message
) (t t
))
4976 (format t
"~%/in /REPORT-LVAR~%")
4977 (format t
"/(LVAR-TYPE X)=~S~%" (lvar-type x
))
4978 (when (constant-lvar-p x
)
4979 (format t
"/(LVAR-VALUE X)=~S~%" (lvar-value x
)))
4980 (format t
"/MESSAGE=~S~%" (lvar-value message
))
4981 (give-up-ir1-transform "not a real transform"))
4982 (defun /report-lvar
(x message
)
4983 (declare (ignore x message
))))
4985 (deftransform encode-universal-time
4986 ((second minute hour date month year
&optional time-zone
)
4987 ((constant-arg (mod 60)) (constant-arg (mod 60))
4988 (constant-arg (mod 24))
4989 (constant-arg (integer 1 31))
4990 (constant-arg (integer 1 12))
4991 (constant-arg (integer 1899))
4992 (constant-arg (rational -
24 24))))
4993 (let ((second (lvar-value second
))
4994 (minute (lvar-value minute
))
4995 (hour (lvar-value hour
))
4996 (date (lvar-value date
))
4997 (month (lvar-value month
))
4998 (year (lvar-value year
))
4999 (time-zone (lvar-value time-zone
)))
5000 (if (zerop (rem time-zone
1/3600))
5001 (encode-universal-time second minute hour date month year time-zone
)
5002 (give-up-ir1-transform))))
5004 #!-
(and win32
(not sb-thread
))
5005 (deftransform sleep
((seconds) ((integer 0 #.
(expt 10 8))))
5006 `(sb!unix
:nanosleep seconds
0))
5008 #!-
(and win32
(not sb-thread
))
5009 (deftransform sleep
((seconds) ((constant-arg (real 0))))
5010 (let ((seconds-value (lvar-value seconds
)))
5011 (multiple-value-bind (seconds nano
)
5012 (sb!impl
::split-seconds-for-sleep seconds-value
)
5013 (if (> seconds
(expt 10 8))
5014 (give-up-ir1-transform)
5015 `(sb!unix
:nanosleep
,seconds
,nano
)))))