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 ;;; Bind the value and make a closure that returns it.
23 (define-source-transform constantly
(value)
24 (with-unique-names (rest n-value
)
25 `(let ((,n-value
,value
))
27 (declare (ignore ,rest
))
30 (defoptimizer (complement derive-type
) ((fun))
31 (let ((type (lvar-fun-type fun
)))
32 (when (fun-type-p type
)
34 (append (butlast (type-specifier type
))
37 ;;; If the function has a known number of arguments, then return a
38 ;;; lambda with the appropriate fixed number of args. If the
39 ;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
40 ;;; MV optimization figure things out.
41 (deftransform complement
((fun) * * :node node
)
43 (multiple-value-bind (min max
)
44 (fun-type-nargs (lvar-type fun
))
46 ((and min
(eql min max
))
47 (let ((dums (make-gensym-list min
)))
48 `#'(lambda ,dums
(not (funcall fun
,@dums
)))))
49 ((let ((lvar (node-lvar node
)))
51 (let ((dest (lvar-dest lvar
)))
52 (and (combination-p dest
)
53 (eq (combination-fun dest
) lvar
)))))
54 '#'(lambda (&rest args
)
55 (not (apply fun args
))))
57 (give-up-ir1-transform
58 "The function doesn't have a fixed argument count.")))))
62 ;;; Translate CxR into CAR/CDR combos.
63 (defun source-transform-cxr (form env
)
64 (declare (ignore env
))
65 (if (not (singleton-p (cdr form
)))
67 (let* ((name (car form
))
71 (leaf (leaf-source-name name
))))))
72 (do ((i (- (length string
) 2) (1- i
))
74 `(,(ecase (char string i
)
80 ;;; Make source transforms to turn CxR forms into combinations of CAR
81 ;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
83 ;;; Don't transform CAD*R, they are treated specially for &more args
86 (loop for i of-type index from
2 upto
4 do
87 ;; Iterate over BUF = all names CxR where x = an I-element
88 ;; string of #\A or #\D characters.
89 (let ((buf (make-string (+ 2 i
))))
90 (setf (aref buf
0) #\C
91 (aref buf
(1+ i
)) #\R
)
92 (dotimes (j (ash 2 i
))
93 (declare (type index j
))
95 (declare (type index k
))
96 (setf (aref buf
(1+ k
))
97 (if (logbitp k j
) #\A
#\D
)))
98 (unless (member buf
'("CADR" "CADDR" "CADDDR")
100 (setf (info :function
:source-transform
(intern buf
))
101 #'source-transform-cxr
)))))
103 ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
104 ;;; whatever is right for them is right for us. FIFTH..TENTH turn into
105 ;;; Nth, which can be expanded into a CAR/CDR later on if policy
107 (define-source-transform rest
(x) `(cdr ,x
))
108 (define-source-transform first
(x) `(car ,x
))
109 (define-source-transform second
(x) `(cadr ,x
))
110 (define-source-transform third
(x) `(caddr ,x
))
111 (define-source-transform fourth
(x) `(cadddr ,x
))
112 (define-source-transform fifth
(x) `(nth 4 ,x
))
113 (define-source-transform sixth
(x) `(nth 5 ,x
))
114 (define-source-transform seventh
(x) `(nth 6 ,x
))
115 (define-source-transform eighth
(x) `(nth 7 ,x
))
116 (define-source-transform ninth
(x) `(nth 8 ,x
))
117 (define-source-transform tenth
(x) `(nth 9 ,x
))
119 ;;; Pick off special cases of LIST and LIST*.
120 (define-source-transform list
(&rest args
)
121 (if args
(values nil t
) (values nil nil
)))
122 (define-source-transform list
* (arg &rest others
)
123 (if others
(values nil t
) (values arg nil
)))
124 ;;; Use LIST* in lieu of CONS so that there are only 2 low-level allocators
125 ;;; instead of 3. Strictly speaking, LIST is redundant as well.
126 (define-source-transform cons
(x y
) `(list* ,x
,y
))
128 (unless-vop-existsp (:translate acons
)
129 (define-source-transform acons
(key datum alist
&environment env
)
130 (if (sb-vm::env-system-tlab-p env
)
131 `(cons (cons ,key
,datum
) ,alist
)
133 (defoptimizer (list derive-type
) ((&rest args
))
135 (specifier-type 'cons
)
136 (specifier-type 'null
)))
138 (defoptimizer (list* derive-type
) ((arg &rest args
))
140 (specifier-type 'cons
)
143 (unless-vop-existsp (:translate unaligned-dx-cons
)
144 (define-source-transform unaligned-dx-cons
(arg)
147 (define-source-transform make-list
(length &rest rest
&environment env
)
149 ;; Use of &KEY in source xforms doesn't have all the usual semantics.
150 ;; It's better to hand-roll it - cf. transforms for WRITE[-TO-STRING].
151 (typep rest
'(cons (eql :initial-element
) (cons t null
))))
152 `(,(if (sb-vm::env-system-tlab-p env
)
153 'sb-impl
::%sys-make-list
155 ,length
,(second rest
))
156 (values nil t
))) ; give up
158 (deftransform %make-list
((length item
) ((constant-arg (integer 0 2)) t
))
159 `(list ,@(make-list (lvar-value length
) :initial-element
'item
)))
161 (define-source-transform copy-list
(list &environment env
)
162 ;; If speed is more important than space, or cons profiling is wanted,
163 ;; then inline the whole copy loop.
164 (if (policy env
(or (> speed space
) (> instrument-consing
1)))
165 (once-only ((list `(the list
,list
))) `(copy-list-macro ,list
))
166 (values nil t
))) ; give up
169 ;;; (loop append (cond (x
173 ;;; by skipping copy-list-to from the NIL path.
174 (defoptimizer (sb-impl::copy-list-to optimizer
) ((list tail
) copy-list
)
175 (flet ((ref (ref lvar
)
176 (when (and (constant-p (ref-leaf ref
))
177 (null (constant-value (ref-leaf ref
)))
178 (almost-immediately-used-p lvar ref
))
179 (let ((set (node-dest copy-list
)))
180 (when (and (set-p set
)
181 (eq (set-var set
) (lvar-lambda-var tail
))
182 (immediately-used-p (node-lvar copy-list
) copy-list
))
183 (node-ends-block set
)
184 (node-ends-block ref
)
185 (unlink-blocks (node-block ref
) (car (block-succ (node-block ref
))))
186 (delete-lvar-use ref
)
187 (link-blocks (node-block ref
) (car (block-succ (node-block set
)))))))))
190 (ref (ref node list
))
192 (and (eq (cast-asserted-type node
) (specifier-type 'list
))
193 (immediately-used-p list node
)
194 (do-uses (node (cast-value node
))
196 (ref node
(node-lvar node
))))))))))
198 (define-source-transform append
(&rest lists
)
202 (2 `(sb-impl::append2
,@lists
))
205 (define-source-transform nconc
(&rest lists
)
211 ;;; (append nil nil nil fixnum) => fixnum
212 ;;; (append x x cons x x) => cons
213 ;;; (append x x x x list) => list
214 ;;; (append x x x x sequence) => sequence
215 ;;; (append fixnum x ...) => nil
216 (defun derive-append-type (args)
218 (return-from derive-append-type
(specifier-type 'null
)))
219 (let* ((cons-type (specifier-type 'cons
))
220 (null-type (specifier-type 'null
))
221 (last (lvar-type (car (last args
)))))
222 ;; Derive the actual return type, assuming that all but the last
223 ;; arguments are LISTs (otherwise, APPEND/NCONC doesn't return).
224 (loop with all-nil
= t
; all but the last args are NIL?
225 with some-cons
= nil
; some args are conses?
226 for
(arg next
) on args
227 for lvar-type
= (lvar-type arg
)
230 (multiple-value-bind (typep definitely
)
231 (ctypep nil lvar-type
)
232 (cond (some-cons) ; we know result's a cons -- nothing to do
233 ((and (not typep
) definitely
) ; can't be NIL
234 (setf some-cons t
)) ; must be a CONS
236 (setf all-nil
(csubtypep lvar-type null-type
)))))
238 ;; if some of the previous arguments are CONSes so is the result;
239 ;; if all the previous values are NIL, we're a fancy identity;
240 ;; otherwise, could be either
241 (return (cond (some-cons cons-type
)
243 (t (type-union last cons-type
)))))))
245 (defoptimizer (append derive-type
) ((&rest args
))
246 (derive-append-type args
))
248 (defoptimizer (sb-impl::append2 derive-type
) ((&rest args
))
249 (derive-append-type args
))
251 (defoptimizer (nconc derive-type
) ((&rest args
))
252 (derive-append-type args
))
254 (deftransform sb-impl
::append2
((x y
) (null t
) * :important nil
)
257 (deftransform sb-impl
::append2
((x y
) (list t
) * :important nil
)
258 (let* ((n (splice-fun-args x
'list nil
))
259 (args (make-gensym-list (length n
))))
260 `(lambda (,@args y
) (list* ,@args y
))))
262 (deftransform append
((x &rest args
) (list &rest t
) * :important nil
)
263 (let* ((n (splice-fun-args x
'list nil
))
264 (list-args (make-gensym-list (length n
)))
265 (append-args (make-gensym-list (length args
))))
266 `(lambda (,@list-args
,@append-args
) (list* ,@list-args
(append ,@append-args
)))))
268 (flet ((remove-nil (fun args
)
270 (loop for
(arg . rest
) on args
272 (eq (lvar-type arg
) (specifier-type 'null
)))
275 (let ((vars (make-gensym-list (length args
))))
277 (declare (ignorable ,@vars
))
278 (,fun
,@(loop for var in vars
280 unless
(memq arg remove
)
282 (give-up-ir1-transform)))))
283 (deftransform append
((&rest args
))
284 (remove-nil 'append args
))
285 (deftransform nconc
((&rest args
))
286 (remove-nil 'nconc args
)))
288 (flet ((transform (fun args subseq
&rest prefix
)
292 (args (loop for arg in args
294 (lvar-matches arg
:fun-names
'(vector-subseq* subseq
))
295 ;; Nothing should be modifying the original sequence
296 (almost-immediately-used-p arg
(lvar-use arg
) :flushable t
))
297 append
(let ((call (lvar-uses arg
)))
300 (destructuring-bind (sequence start
&optional end
) (combination-args call
)
301 (declare (ignorable sequence start
))
302 (splice-fun-args arg
:any
(if end
3 2))
303 (list ''sb-impl
::%subseq
304 (car (push (gensym) vars
))
305 (car (push (gensym) vars
))
307 (car (push (gensym) vars
))))))
308 else if
(or (eq (lvar-type arg
) (specifier-type 'null
))
309 (csubtypep (lvar-type arg
) (specifier-type '(simple-array * (0)))))
313 collect
(car (push (gensym) vars
)))))
316 `(lambda ,(append prefix
(reverse vars
))
317 (declare (ignorable ,@vars
))
322 (give-up-ir1-transform)))))
323 (deftransform %concatenate-to-list
((&rest args
))
324 (transform '%concatenate-to-list args
'%concatenate-to-list-subseq
))
326 (deftransform %concatenate-to-string
((&rest args
))
327 (transform '%concatenate-to-string args
'%concatenate-to-string-subseq
))
329 (deftransform %concatenate-to-base-string
((&rest args
))
330 (transform '%concatenate-to-base-string args
'%concatenate-to-base-string-subseq
))
332 (deftransform %concatenate-to-vector
((widetag &rest args
))
333 (transform '%concatenate-to-vector args
'%concatenate-to-vector-subseq
'widetag
))
335 (deftransform %concatenate-to-simple-vector
((&rest args
))
336 (transform '%concatenate-to-simple-vector args
'%concatenate-to-simple-vector-subseq
))
337 (deftransform concatenate
((type &rest args
))
338 (transform 'concatenate args nil
'type
)))
340 (deftransform %concatenate-to-string
((string) ((array character
(*))))
344 (deftransform %concatenate-to-string
((string) ((array base-char
(*))))
345 `(coerce string
'(array character
(*))))
347 (defun concatenate-subseq-type (lvar args
)
348 (flet ((check (arg type
)
350 (return-from concatenate-subseq-type type
))))
352 do
(let ((arg (pop args
)))
353 (cond ((and (constant-lvar-p arg
)
354 (eq (lvar-value arg
) 'sb-impl
::%subseq
))
355 (check (pop args
) (specifier-type 'sequence
))
356 (check (pop args
) (specifier-type 'index
))
357 (check (pop args
) (specifier-type '(or null index
))))
359 (check arg
(specifier-type 'sequence
))))))))
361 (defoptimizer (%concatenate-to-string-subseq externally-checkable-type
) ((&rest args
) node lvar
)
362 (concatenate-subseq-type lvar args
))
363 (defoptimizer (%concatenate-to-base-string-subseq externally-checkable-type
) ((&rest args
) node lvar
)
364 (concatenate-subseq-type lvar args
))
365 (defoptimizer (%concatenate-to-list-subseq externally-checkable-type
) ((&rest args
) node lvar
)
366 (concatenate-subseq-type lvar args
))
367 (defoptimizer (%concatenate-to-simple-vector-subseq externally-checkable-type
) ((&rest args
) node lvar
)
368 (concatenate-subseq-type lvar args
))
369 (defoptimizer (%concatenate-to-vector-subseq externally-checkable-type
) ((type &rest args
) node lvar
)
370 (concatenate-subseq-type lvar args
))
372 ;;; Translate RPLACx to LET and SETF.
373 (define-source-transform rplaca
(x y
)
378 (define-source-transform rplacd
(x y
)
384 (deftransform last
((list &optional n
) (t &optional t
))
385 (let ((c (and n
(constant-lvar-p n
))))
387 (and c
(eql 1 (lvar-value n
))))
389 ((and c
(eql 0 (lvar-value n
)))
392 (let ((type (lvar-type n
)))
393 (cond ((csubtypep type
(specifier-type 'fixnum
))
394 '(%lastn
/fixnum list n
))
395 ((csubtypep type
(specifier-type 'bignum
))
396 '(%lastn
/bignum list n
))
398 (give-up-ir1-transform "second argument type too vague"))))))))
400 (define-source-transform gethash
(&rest args
)
402 (2 `(sb-impl::gethash3
,@args nil
))
403 (3 `(sb-impl::gethash3
,@args
))
405 (define-source-transform get
(&rest args
)
407 (2 `(sb-impl::get3
,@args nil
))
408 (3 `(sb-impl::get3
,@args
))
411 (defvar *default-nthcdr-open-code-limit
* 6)
412 (defvar *extreme-nthcdr-open-code-limit
* 20)
414 (deftransform nthcdr
((n l
) (unsigned-byte t
) * :node node
)
415 "convert NTHCDR to CAxxR"
416 (unless (constant-lvar-p n
)
417 (give-up-ir1-transform))
418 (let ((n (lvar-value n
)))
420 (if (policy node
(and (= speed
3) (= space
0)))
421 *extreme-nthcdr-open-code-limit
*
422 *default-nthcdr-open-code-limit
*))
423 (give-up-ir1-transform))
428 `(cdr ,(frob (1- n
))))))
431 (deftransform nth
((n l
) (unsigned-byte t
) * :node node
)
432 "convert NTH to CAxxR"
433 (unless (constant-lvar-p n
)
434 (give-up-ir1-transform))
435 (let ((n (lvar-value n
)))
437 (if (policy node
(and (= speed
3) (= space
0)))
438 *extreme-nthcdr-open-code-limit
*
439 *default-nthcdr-open-code-limit
*))
440 (give-up-ir1-transform))
444 `(cdr ,(frob (1- n
))))))
447 ;;;; arithmetic and numerology
449 (define-source-transform plusp
(x) `(sb-xc:> ,x
0))
450 (define-source-transform minusp
(x) `(sb-xc:< ,x
0))
451 (define-source-transform zerop
(x) `(sb-xc:= ,x
0))
453 (define-source-transform 1+ (x) `(+ ,x
1))
454 (define-source-transform 1-
(x) `(- ,x
1))
456 (define-source-transform oddp
(x) `(logtest ,x
1))
457 (define-source-transform evenp
(x) `(not (logtest ,x
1)))
459 (macrolet ((deffrob (fun)
460 `(define-source-transform ,fun
(x &optional
(y nil y-p
))
470 ;;; This used to be a source transform (hence the lack of restrictions
471 ;;; on the argument types), but we make it a regular transform so that
472 ;;; the VM has a chance to see the bare LOGTEST and potentiall choose
473 ;;; to implement it differently. --njf, 06-02-2006
474 (deftransform logtest
((x y
) * * :node node
)
475 (delay-ir1-transform node
:ir1-phases
)
476 `(not (zerop (logand x y
))))
478 (defoptimizer (logtest derive-type
) ((x y
))
479 (let ((type (two-arg-derive-type x y
480 #'logand-derive-type-aux
483 (multiple-value-bind (typep definitely
)
485 (cond ((and (not typep
) definitely
)
486 (specifier-type '(eql t
)))
487 ((type= type
(specifier-type '(eql 0)))
488 (specifier-type '(eql nil
))))))))
490 (defun logbitp-to-minusp-p (index integer
)
491 (let* ((int (type-approximate-interval (lvar-type integer
)))
492 (length (max (integer-length (interval-low int
))
493 (integer-length (interval-high int
))))
494 (index-int (type-approximate-interval (lvar-type index
))))
495 (>= (interval-low index-int
) length
)))
497 (deftransform logbitp
((index integer
) * * :node node
)
498 (let ((integer-type (lvar-type integer
))
499 (integer-value (and (constant-lvar-p integer
)
500 (lvar-value integer
))))
501 (cond ((eql integer-value
0)
503 ((eql integer-value -
1)
505 ((csubtypep integer-type
(specifier-type '(or word
507 (delay-ir1-transform node
:ir1-phases
)
508 (if (logbitp-to-minusp-p index integer
)
510 `(logtest 1 (ash integer
(- index
)))))
511 ((csubtypep integer-type
(specifier-type 'bignum
))
512 (if (csubtypep (lvar-type index
)
513 (specifier-type `(mod ,sb-vm
:n-word-bits
))) ; word-index
514 `(logbitp index
(%bignum-ref integer
0))
515 `(bignum-logbitp index integer
)))
517 (give-up-ir1-transform)))))
520 (defoptimizer (logbitp derive-type
) ((index integer
))
521 (let* ((one (specifier-type '(eql 1)))
522 (and (two-arg-derive-type index integer
523 (lambda (index integer same
)
524 (declare (ignore same
))
525 (logand-derive-type-aux integer
526 (ash-derive-type-aux one index nil
)))
527 (lambda (index integer
)
528 (logand integer
(ash 1 index
))))))
531 ((type= and
(specifier-type '(eql 0)))
532 (specifier-type 'null
))
533 ((not (types-equal-or-intersect and
(specifier-type '(eql 0))))
534 (specifier-type '(eql t
))))))
536 (define-source-transform byte
(size position
)
537 (if (and (constantp size
)
538 (constantp position
))
539 `'(,(constant-form-value size
) .
,(constant-form-value position
))
540 `(cons ,size
,position
)))
541 (define-source-transform byte-size
(spec) `(car ,spec
))
542 (define-source-transform byte-position
(spec) `(cdr ,spec
))
543 (define-source-transform ldb-test
(bytespec integer
)
544 `(not (zerop (mask-field ,bytespec
,integer
))))
546 ;;; With the ratio and complex accessors, we pick off the "identity"
547 ;;; case, and use a primitive to handle the cell access case.
548 (define-source-transform numerator
(num)
549 (once-only ((n-num `(the rational
,num
)))
553 (define-source-transform denominator
(num)
554 (once-only ((n-num `(the rational
,num
)))
556 (%denominator
,n-num
)
559 (defoptimizer (%numerator derive-type
) ((num))
560 (cond ((csubtypep (lvar-type num
) (specifier-type '(rational 0)))
561 (specifier-type '(integer 1)))
562 ((csubtypep (lvar-type num
) (specifier-type '(rational * 0)))
563 (specifier-type '(integer * -
1)))))
565 ;;;; interval arithmetic for computing bounds
567 ;;;; This is a set of routines for operating on intervals. It
568 ;;;; implements a simple interval arithmetic package. Although SBCL
569 ;;;; has an interval type in NUMERIC-TYPE, we choose to use our own
570 ;;;; for two reasons:
572 ;;;; 1. This package is simpler than NUMERIC-TYPE.
574 ;;;; 2. It makes debugging much easier because you can just strip
575 ;;;; out these routines and test them independently of SBCL. (This is a
578 ;;;; One disadvantage is a probable increase in consing because we
579 ;;;; have to create these new interval structures even though
580 ;;;; numeric-type has everything we want to know. Reason 2 wins for
582 (defun make-interval (&key low high
)
583 (labels ((normalize-bound (val)
584 (cond ((and (floatp val
)
585 (float-infinity-p val
))
586 ;; Handle infinities.
590 ;; Handle any closed bounds.
593 ;; We have an open bound. Normalize the numeric
594 ;; bound. If the normalized bound is still a number
595 ;; (not nil), keep the bound open. Otherwise, the
596 ;; bound is really unbounded, so drop the openness.
597 (let ((new-val (normalize-bound (first val
))))
599 ;; The bound exists, so keep it open still.
602 (error "unknown bound type in MAKE-INTERVAL")))))
603 (%make-interval
(normalize-bound low
)
604 (normalize-bound high
))))
606 ;;; Apply the function F to a bound X. If X is an open bound and the
607 ;;; function is declared strictly monotonic, then the result will be
608 ;;; open. IF X is NIL, the result is NIL.
609 (defun bound-func (f x strict
)
610 (declare (type function f
))
613 (when (and (eql f
#'log
)
615 (return-from bound-func
))
617 (set-bound (funcall f
(type-bound-number x
))
618 (and strict
(consp x
)))
619 ;; Some numerical operations will signal an ERROR, e.g. in
620 ;; the course of converting a bignum to a float. Default to
622 (arithmetic-error ()))))
624 (defun safe-double-coercion-p (x)
625 (or (typep x
'double-float
)
626 (sb-xc:<= most-negative-double-float x most-positive-double-float
)))
628 (defun safe-single-coercion-p (x)
629 (or (typep x
'single-float
)
631 ;; Fix for bug 420, and related issues: during type derivation we often
632 ;; end up deriving types for both
634 ;; (some-op <int> <single>)
636 ;; (some-op (coerce <int> 'single-float) <single>)
638 ;; or other equivalent transformed forms. The problem with this
639 ;; is that on x86 (+ <int> <single>) is on the machine level
642 ;; (coerce (+ (coerce <int> 'double-float)
643 ;; (coerce <single> 'double-float))
646 ;; so if the result of (coerce <int> 'single-float) is not exact, the
647 ;; derived types for the transformed forms will have an empty
648 ;; intersection -- which in turn means that the compiler will conclude
649 ;; that the call never returns, and all hell breaks lose when it *does*
650 ;; return at runtime. (This affects not just +, but other operators are
653 ;; FIXME: If we ever add SSE-support for x86, this conditional needs to
655 ;; This is somewhat dubious. Why isn't anything done about
656 ;; ratios? Why isn't safe-double-coercion-p doing the same,
657 ;; given that x87 floats are 80-bits internally?
659 (typep x
`(or (not integer
)
660 (integer ,most-negative-exactly-single-float-integer
661 ,most-positive-exactly-single-float-integer
)))
662 (sb-xc:<= most-negative-single-float x most-positive-single-float
))))
664 ;;; Apply a binary operator OP to two bounds X and Y. The result is
665 ;;; NIL if either is NIL. Otherwise bound is computed and the result
666 ;;; is open if either X or Y is open.
668 ;;; FIXME: only used in this file, not needed in target runtime
670 ;;; ANSI contagion specifies coercion to floating point if one of the
671 ;;; arguments is floating point. Here we should check to be sure that
672 ;;; the other argument is within the bounds of that floating point
675 (defmacro safely-binop
(op x y
)
677 ((typep ,x
'double-float
)
678 (when (safe-double-coercion-p ,y
)
680 ((typep ,y
'double-float
)
681 (when (safe-double-coercion-p ,x
)
683 ((typep ,x
'single-float
)
684 (when (safe-single-coercion-p ,y
)
686 ((typep ,y
'single-float
)
687 (when (safe-single-coercion-p ,x
)
691 (defmacro bound-binop
(op x y
)
692 (with-unique-names (xb yb res
)
695 (let* ((,xb
(type-bound-number ,x
))
696 (,yb
(type-bound-number ,y
))
697 (,res
(safely-binop ,op
,xb
,yb
)))
699 (and (or (consp ,x
) (consp ,y
))
700 ;; Open bounds can very easily be messed up
701 ;; by FP rounding, so take care here.
704 ;; Multiplying a greater-than-zero with
705 ;; less than one can round to zero.
706 `(or (not (fp-zero-p ,res
))
707 (cond ((and (consp ,x
) (fp-zero-p ,xb
))
709 ((and (consp ,y
) (fp-zero-p ,yb
))
712 ;; Dividing a greater-than-zero with
713 ;; greater than one can round to zero.
714 `(or (not (fp-zero-p ,res
))
715 (cond ((and (consp ,x
) (fp-zero-p ,xb
))
717 ((and (consp ,y
) (fp-zero-p ,yb
))
720 ;; Adding or subtracting greater-than-zero
721 ;; can end up with identity.
722 `(and (not (fp-zero-p ,xb
))
723 (not (fp-zero-p ,yb
))))))))
724 (arithmetic-error ())))))
726 (defun coercion-loses-precision-p (val type
)
729 (double-float (subtypep type
'single-float
))
730 (rational (subtypep type
'float
))
731 (t (bug "Unexpected arguments to bounds coercion: ~S ~S" val type
))))
733 (defun coerce-for-bound (val type
)
739 (let ((xbound (coerce-for-bound (car val
) type
)))
740 (if (coercion-loses-precision-p (car val
) type
)
743 ((subtypep type
'double-float
)
744 (if (sb-xc:<= most-negative-double-float val most-positive-double-float
)
746 ((or (subtypep type
'single-float
) (subtypep type
'float
))
747 ;; coerce to float returns a single-float
748 (if (sb-xc:<= most-negative-single-float val most-positive-single-float
)
750 (t (coerce val type
))))
752 (defun coerce-and-truncate-floats (val type
)
755 (let ((xbound (coerce-for-bound (car val
) type
)))
756 (if (coercion-loses-precision-p (car val
) type
)
760 ((subtypep type
'double-float
)
761 (if (sb-xc:<= most-negative-double-float val most-positive-double-float
)
763 (if (sb-xc:< val most-negative-double-float
)
764 most-negative-double-float most-positive-double-float
)))
765 ((or (subtypep type
'single-float
) (subtypep type
'float
))
766 ;; coerce to float returns a single-float
767 (if (sb-xc:<= most-negative-single-float val most-positive-single-float
)
769 (if (sb-xc:< val most-negative-single-float
)
770 most-negative-single-float most-positive-single-float
)))
771 (t (coerce val type
))))))
773 ;;; Convert a numeric-type object to an interval object.
774 (defun numeric-type->interval
(x &optional integer
)
775 (declare (type numeric-type x
))
776 (let ((low (numeric-type-low x
))
777 (high (numeric-type-high x
)))
778 (make-interval :low
(cond ((not integer
)
781 (let ((low (car low
)))
782 (unless (and (floatp low
)
783 (float-infinity-or-nan-p low
))
786 (unless (and (floatp low
)
787 (float-infinity-or-nan-p low
))
789 :high
(cond ((not integer
)
792 (let ((high (car high
)))
793 (unless (and (floatp high
)
794 (float-infinity-or-nan-p high
))
795 (1- (ceiling high
)))))
797 (unless (and (floatp high
)
798 (float-infinity-or-nan-p high
))
801 (defun type-approximate-interval (type &optional integer
)
802 (declare (type ctype type
))
803 (let ((types (prepare-arg-for-derive-type type
))
807 (let ((type (typecase type
809 (convert-member-type type
))
811 (find-if #'numeric-type-p
812 (intersection-type-types type
)))
815 (unless (numeric-type-p type
)
816 (return-from type-approximate-interval
(values nil nil
)))
817 (let ((interval (numeric-type->interval type integer
)))
818 (when (eq (numeric-type-complexp type
) :complex
)
822 (interval-approximate-union result interval
)
824 (values result complex
)))
826 (defun copy-interval-limit (limit)
831 (defun copy-interval (x)
832 (declare (type interval x
))
833 (make-interval :low
(copy-interval-limit (interval-low x
))
834 :high
(copy-interval-limit (interval-high x
))))
836 ;;; Given a point P contained in the interval X, split X into two
837 ;;; intervals at the point P. If CLOSE-LOWER is T, then the left
838 ;;; interval contains P. If CLOSE-UPPER is T, the right interval
839 ;;; contains P. You can specify both to be T or NIL.
840 (defun interval-split (p x
&optional close-lower close-upper
)
841 (declare (type number p
)
843 (list (make-interval :low
(copy-interval-limit (interval-low x
))
844 :high
(if close-lower p
(list p
)))
845 (make-interval :low
(if close-upper
(list p
) p
)
846 :high
(copy-interval-limit (interval-high x
)))))
848 ;;; Return the closure of the interval. That is, convert open bounds
849 ;;; to closed bounds.
850 (defun interval-closure (x)
851 (declare (type interval x
))
852 (make-interval :low
(type-bound-number (interval-low x
))
853 :high
(type-bound-number (interval-high x
))))
855 ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
856 ;;; '-. Otherwise return NIL.
857 (defun interval-range-info (x &optional
(point 0))
858 (declare (type interval x
))
859 (let ((lo (interval-low x
))
860 (hi (interval-high x
)))
861 (cond ((and lo
(sb-xc:>= (type-bound-number lo
) point
))
863 ((and hi
(sb-xc:>= point
(type-bound-number hi
)))
868 (defun interval-range-info> (x &optional
(point 0))
869 (declare (type interval x
))
870 (let ((lo (interval-low x
))
871 (hi (interval-high x
)))
872 (cond ((and lo
(sb-xc:>= (type-bound-number lo
) point
))
874 ((and hi
(sb-xc:> point
(type-bound-number hi
)))
877 ;;; Test to see whether the interval X is bounded. HOW determines the
878 ;;; test, and should be either ABOVE, BELOW, or BOTH.
879 (defun interval-bounded-p (x how
)
880 (declare (type interval x
))
887 (and (interval-low x
) (interval-high x
)))))
889 ;;; See whether the interval X contains the number P, taking into
890 ;;; account that the interval might not be closed.
891 (defun interval-contains-p (p interval
)
892 (declare (type number p
)
893 (type interval interval
))
894 ;; Does the interval INTERVAL contain the number P? This would be a lot
895 ;; easier if all intervals were closed!
896 (let ((lo (interval-low interval
))
897 (hi (interval-high interval
)))
899 ;; The interval is bounded
900 (if (and (sb-xc:<= (type-bound-number lo
) p
)
901 (sb-xc:<= p
(type-bound-number hi
)))
902 ;; P is definitely in the closure of the interval.
903 ;; We just need to check the end points now.
904 (cond ((sb-xc:= p
(type-bound-number lo
))
906 ((sb-xc:= p
(type-bound-number hi
))
911 ;; Interval with upper bound
912 (if (sb-xc:< p
(type-bound-number hi
))
914 (and (numberp hi
) (sb-xc:= p hi
))))
916 ;; Interval with lower bound
917 (if (sb-xc:> p
(type-bound-number lo
))
919 (and (numberp lo
) (sb-xc:= p lo
))))
921 ;; Interval with no bounds
924 ;;; Determine whether two intervals X and Y intersect. Return T if so.
925 ;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they
926 ;;; were closed. Otherwise the intervals are treated as they are.
928 ;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
929 ;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
930 ;;; is T, then they do intersect because we use the closure of X = [0,
931 ;;; 1] and Y = [1, 2] to determine intersection.
932 (defun interval-intersect-p (x y
&optional closed-intervals-p
)
933 (declare (type interval x y
))
934 (and (interval-intersection/difference
(if closed-intervals-p
937 (if closed-intervals-p
942 ;;; Are the two intervals adjacent? That is, is there a number
943 ;;; between the two intervals that is not an element of either
944 ;;; interval? If so, they are not adjacent. For example [0, 1) and
945 ;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
946 ;;; between both intervals.
947 (defun interval-adjacent-p (x y
)
948 (declare (type interval x y
))
949 (flet ((adjacent (lo hi
)
950 ;; Check to see whether lo and hi are adjacent. If either is
951 ;; nil, they can't be adjacent.
952 (when (and lo hi
(sb-xc:= (type-bound-number lo
) (type-bound-number hi
)))
953 ;; The bounds are equal. They are adjacent if one of
954 ;; them is closed (a number). If both are open (consp),
955 ;; then there is a number that lies between them.
956 (or (numberp lo
) (numberp hi
)))))
957 (or (adjacent (interval-low y
) (interval-high x
))
958 (adjacent (interval-low x
) (interval-high y
)))))
960 ;;; Compute the intersection and difference between two intervals.
961 ;;; Two values are returned: the intersection and the difference.
963 ;;; Let the two intervals be X and Y, and let I and D be the two
964 ;;; values returned by this function. Then I = X intersect Y. If I
965 ;;; is NIL (the empty set), then D is X union Y, represented as the
966 ;;; list of X and Y. If I is not the empty set, then D is (X union Y)
967 ;;; - I, which is a list of two intervals.
969 ;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D =
970 ;;; [-1,1) union [3,5], which is returned as a list of two intervals.
971 (defun interval-intersection/difference
(x y
)
972 (declare (type interval x y
))
973 (let ((x-lo (interval-low x
))
974 (x-hi (interval-high x
))
975 (y-lo (interval-low y
))
976 (y-hi (interval-high y
)))
979 ;; If p is an open bound, make it closed. If p is a closed
980 ;; bound, make it open.
984 (test-number (p int bound
)
985 ;; Test whether P is in the interval.
986 (let ((pn (type-bound-number p
)))
987 (when (interval-contains-p pn
(interval-closure int
))
988 ;; Check for endpoints.
989 (let* ((lo (interval-low int
))
990 (hi (interval-high int
))
991 (lon (type-bound-number lo
))
992 (hin (type-bound-number hi
)))
994 ;; Interval may be a point.
995 ((and lon hin
(sb-xc:= lon hin pn
))
996 (and (numberp p
) (numberp lo
) (numberp hi
)))
997 ;; Point matches the low end.
998 ;; [P] [P,?} => TRUE [P] (P,?} => FALSE
999 ;; (P [P,?} => TRUE P) [P,?} => FALSE
1000 ;; (P (P,?} => TRUE P) (P,?} => FALSE
1001 ((and lon
(sb-xc:= pn lon
))
1002 (or (and (numberp p
) (numberp lo
))
1003 (and (consp p
) (eq :low bound
))))
1004 ;; [P] {?,P] => TRUE [P] {?,P) => FALSE
1005 ;; P) {?,P] => TRUE (P {?,P] => FALSE
1006 ;; P) {?,P) => TRUE (P {?,P) => FALSE
1007 ((and hin
(sb-xc:= pn hin
))
1008 (or (and (numberp p
) (numberp hi
))
1009 (and (consp p
) (eq :high bound
))))
1010 ;; Not an endpoint, all is well.
1013 (test-lower-bound (p int
)
1014 ;; P is a lower bound of an interval.
1016 (test-number p int
:low
)
1017 (not (interval-bounded-p int
'below
))))
1018 (test-upper-bound (p int
)
1019 ;; P is an upper bound of an interval.
1021 (test-number p int
:high
)
1022 (not (interval-bounded-p int
'above
)))))
1023 (let ((x-lo-in-y (test-lower-bound x-lo y
))
1024 (x-hi-in-y (test-upper-bound x-hi y
))
1025 (y-lo-in-x (test-lower-bound y-lo x
))
1026 (y-hi-in-x (test-upper-bound y-hi x
)))
1027 (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x
)
1028 ;; Intervals intersect. Let's compute the intersection
1029 ;; and the difference.
1030 (multiple-value-bind (lo left-lo left-hi
)
1031 (cond (x-lo-in-y (values x-lo y-lo
(opposite-bound x-lo
)))
1032 (y-lo-in-x (values y-lo x-lo
(opposite-bound y-lo
))))
1033 (multiple-value-bind (hi right-lo right-hi
)
1035 (values x-hi
(opposite-bound x-hi
) y-hi
))
1037 (values y-hi
(opposite-bound y-hi
) x-hi
)))
1038 (values (make-interval :low lo
:high hi
)
1039 (list (make-interval :low left-lo
1041 (make-interval :low right-lo
1042 :high right-hi
))))))
1044 (values nil
(list x y
))))))))
1046 ;;; If intervals X and Y intersect, return a new interval that is the
1047 ;;; union of the two. If they do not intersect, return NIL.
1048 (defun interval-merge-pair (x y
)
1049 (declare (type interval x y
))
1050 ;; If x and y intersect or are adjacent, create the union.
1051 ;; Otherwise return nil
1052 (when (or (interval-intersect-p x y
)
1053 (interval-adjacent-p x y
))
1054 (flet ((select-bound (x1 x2 min-op max-op
)
1055 (let ((x1-val (type-bound-number x1
))
1056 (x2-val (type-bound-number x2
)))
1058 ;; Both bounds are finite. Select the right one.
1059 (cond ((funcall min-op x1-val x2-val
)
1060 ;; x1 is definitely better.
1062 ((funcall max-op x1-val x2-val
)
1063 ;; x2 is definitely better.
1066 ;; Bounds are equal. Select either
1067 ;; value and make it open only if
1069 (set-bound x1-val
(and (consp x1
) (consp x2
))))))
1071 ;; At least one bound is not finite. The
1072 ;; non-finite bound always wins.
1074 (let* ((x-lo (copy-interval-limit (interval-low x
)))
1075 (x-hi (copy-interval-limit (interval-high x
)))
1076 (y-lo (copy-interval-limit (interval-low y
)))
1077 (y-hi (copy-interval-limit (interval-high y
))))
1078 (make-interval :low
(select-bound x-lo y-lo
#'sb-xc
:< #'sb-xc
:>)
1079 :high
(select-bound x-hi y-hi
#'sb-xc
:> #'sb-xc
:<))))))
1081 ;;; return the minimal interval, containing X and Y
1082 (defun interval-approximate-union (x y
)
1083 (cond ((interval-merge-pair x y
))
1085 (make-interval :low
(copy-interval-limit (interval-low x
))
1086 :high
(copy-interval-limit (interval-high y
))))
1088 (make-interval :low
(copy-interval-limit (interval-low y
))
1089 :high
(copy-interval-limit (interval-high x
))))))
1091 ;;; basic arithmetic operations on intervals. We probably should do
1092 ;;; true interval arithmetic here, but it's complicated because we
1093 ;;; have float and integer types and bounds can be open or closed.
1095 ;;; the negative of an interval
1096 (defun interval-neg (x)
1097 (declare (type interval x
))
1098 (make-interval :low
(bound-func #'sb-xc
:-
(interval-high x
) t
)
1099 :high
(bound-func #'sb-xc
:-
(interval-low x
) t
)))
1101 ;;; Add two intervals.
1102 (defun interval-add (x y
)
1103 (declare (type interval x y
))
1104 (make-interval :low
(bound-binop sb-xc
:+ (interval-low x
) (interval-low y
))
1105 :high
(bound-binop sb-xc
:+ (interval-high x
) (interval-high y
))))
1107 ;;; Subtract two intervals.
1108 (defun interval-sub (x y
)
1109 (declare (type interval x y
))
1110 (make-interval :low
(bound-binop sb-xc
:-
(interval-low x
) (interval-high y
))
1111 :high
(bound-binop sb-xc
:-
(interval-high x
) (interval-low y
))))
1113 ;;; Multiply two intervals.
1114 (defun interval-mul (x y
)
1115 (declare (type interval x y
))
1116 (flet ((bound-mul (x y
)
1117 (cond ((or (null x
) (null y
))
1118 ;; Multiply by infinity is infinity
1120 ((or (and (numberp x
) (zerop x
))
1121 (and (numberp y
) (zerop y
)))
1122 ;; Multiply by closed zero is special. The result
1123 ;; is always a closed bound. But don't replace this
1124 ;; with zero; we want the multiplication to produce
1125 ;; the correct signed zero, if needed. Use SIGNUM
1126 ;; to avoid trying to multiply huge bignums with 0.0.
1127 (sb-xc:* (signum (type-bound-number x
))
1128 (signum (type-bound-number y
))))
1129 ((or (and (floatp x
) (float-infinity-p x
))
1130 (and (floatp y
) (float-infinity-p y
)))
1131 ;; Infinity times anything is infinity
1134 ;; General multiply. The result is open if either is open.
1135 (bound-binop sb-xc
:* x y
)))))
1136 (let ((x-range (interval-range-info x
))
1137 (y-range (interval-range-info y
)))
1138 (cond ((null x-range
)
1139 ;; Split x into two and multiply each separately
1140 (destructuring-bind (x- x
+) (interval-split 0 x t t
)
1141 (interval-merge-pair (interval-mul x- y
)
1142 (interval-mul x
+ y
))))
1144 ;; Split y into two and multiply each separately
1145 (destructuring-bind (y- y
+) (interval-split 0 y t t
)
1146 (interval-merge-pair (interval-mul x y-
)
1147 (interval-mul x y
+))))
1149 (interval-neg (interval-mul (interval-neg x
) y
)))
1151 (interval-neg (interval-mul x
(interval-neg y
))))
1152 ((and (eq x-range
'+) (eq y-range
'+))
1153 ;; If we are here, X and Y are both positive.
1155 :low
(bound-mul (interval-low x
) (interval-low y
))
1156 :high
(bound-mul (interval-high x
) (interval-high y
))))
1158 (bug "excluded case in INTERVAL-MUL"))))))
1160 ;;; Divide two intervals.
1161 (defun interval-div (top bot
&optional integer
)
1162 (declare (type interval top bot
))
1163 (labels ((interval-div (top bot
)
1164 (flet ((bound-div (x y y-low-p
)
1167 ;; Divide by infinity means result is 0. However,
1168 ;; we need to watch out for the sign of the result,
1169 ;; to correctly handle signed zeros. We also need
1170 ;; to watch out for positive or negative infinity.
1171 (cond ((floatp (type-bound-number x
))
1173 (sb-xc:-
(float-sign (type-bound-number x
) $
0.0))
1174 (float-sign (type-bound-number x
) $
0.0)))
1176 (not (interval-contains-p 0 top
)))
1180 ((zerop (type-bound-number y
))
1183 ;; Divide by zero means result is infinity
1185 ((and (numberp x
) (zerop x
))
1186 ;; Zero divided by anything is zero, but don't lose the sign
1187 (sb-xc:/ x
(signum (type-bound-number y
))))
1189 (bound-binop sb-xc
:/ x y
)))))
1190 (let ((top-range (interval-range-info top
))
1191 (bot-range (interval-range-info bot
)))
1192 (cond ((null bot-range
)
1194 (destructuring-bind (bot- bot
+) (interval-split 0 bot t t
)
1195 (let ((r- (interval-div top bot-
))
1196 (r+ (interval-div top bot
+)))
1197 (or (interval-merge-pair r- r
+)
1199 ;; The denominator contains zero, so anything goes!
1202 ;; Denominator is negative so flip the sign, compute the
1203 ;; result, and flip it back.
1204 (interval-neg (interval-div top
(interval-neg bot
))))
1206 ;; Split top into two positive and negative parts, and
1207 ;; divide each separately
1208 (destructuring-bind (top- top
+) (interval-split 0 top t t
)
1209 (or (interval-merge-pair (interval-div top- bot
)
1210 (interval-div top
+ bot
))
1213 ;; Top is negative so flip the sign, divide, and flip the
1214 ;; sign of the result.
1215 (interval-neg (interval-div (interval-neg top
) bot
)))
1216 ((and (eq top-range
'+) (eq bot-range
'+))
1219 :low
(bound-div (interval-low top
) (interval-high bot
) t
)
1220 :high
(bound-div (interval-high top
) (interval-low bot
) nil
)))
1222 (bug "excluded case in INTERVAL-DIV")))))))
1223 (let ((interval (interval-div top bot
)))
1224 (if (consp interval
)
1226 (let ((low (interval-low interval
))
1227 (high (interval-high interval
)))
1228 (if (and (integerp low
)
1231 ;; Don't return constants, as it will produce an error when divided by 0.
1233 (make-interval :low
'(0) :high low
)
1234 (make-interval :low low
:high
'(0)))
1237 ;;; Apply the function F to the interval X. If X = [a, b], then the
1238 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
1239 ;;; result makes sense. It will if F is monotonic increasing (or, if
1240 ;;; the interval is closed, non-decreasing).
1242 ;;; (Actually most uses of INTERVAL-FUNC are coercions to float types,
1243 ;;; which are not monotonic increasing, so default to calling
1244 ;;; BOUND-FUNC with a non-strict argument).
1245 (defun interval-func (f x
&optional increasing
)
1246 (declare (type function f
)
1248 (let ((lo (bound-func f
(interval-low x
) increasing
))
1249 (hi (bound-func f
(interval-high x
) increasing
)))
1250 (make-interval :low lo
:high hi
)))
1252 ;;; Return T if X < Y. That is every number in the interval X is
1253 ;;; always less than any number in the interval Y.
1254 (defun interval-< (x y
)
1255 (declare (type interval x y
))
1256 ;; X < Y only if X is bounded above, Y is bounded below, and they
1258 (when (and (interval-bounded-p x
'above
)
1259 (interval-bounded-p y
'below
))
1260 ;; Intervals are bounded in the appropriate way. Make sure they
1262 (let ((left (interval-high x
))
1263 (right (interval-low y
)))
1264 (cond ((sb-xc:> (type-bound-number left
)
1265 (type-bound-number right
))
1266 ;; The intervals definitely overlap, so result is NIL.
1268 ((sb-xc:< (type-bound-number left
)
1269 (type-bound-number right
))
1270 ;; The intervals definitely don't touch, so result is T.
1273 ;; Limits are equal. Check for open or closed bounds.
1274 ;; Don't overlap if one or the other are open.
1275 (or (consp left
) (consp right
)))))))
1277 ;;; Return T if X >= Y. That is, every number in the interval X is
1278 ;;; always greater than any number in the interval Y.
1279 (defun interval->= (x y
)
1280 (declare (type interval x y
))
1281 ;; X >= Y if lower bound of X >= upper bound of Y
1282 (when (and (interval-bounded-p x
'below
)
1283 (interval-bounded-p y
'above
))
1284 (sb-xc:>= (type-bound-number (interval-low x
))
1285 (type-bound-number (interval-high y
)))))
1287 ;;; Return T if X = Y.
1288 (defun interval-= (x y
)
1289 (declare (type interval x y
))
1290 (and (interval-bounded-p x
'both
)
1291 (interval-bounded-p y
'both
)
1295 ;; Open intervals cannot be =
1296 (return-from interval-
= nil
))))
1297 ;; Both intervals refer to the same point
1298 (sb-xc:= (bound (interval-high x
)) (bound (interval-low x
))
1299 (bound (interval-high y
)) (bound (interval-low y
))))))
1301 ;;; Return T if X /= Y
1302 (defun interval-/= (x y
)
1303 (not (interval-intersect-p x y
)))
1305 ;;; Return an interval that is the absolute value of X. Thus, if
1306 ;;; X = [-1 10], the result is [0, 10].
1307 (defun interval-abs (x)
1308 (declare (type interval x
))
1309 (case (interval-range-info x
)
1315 (destructuring-bind (x- x
+) (interval-split 0 x t t
)
1316 (interval-merge-pair (interval-neg x-
) x
+)))))
1318 ;;; Compute the square of an interval.
1319 (defun interval-sqr (x)
1320 (declare (type interval x
))
1321 (interval-func (lambda (x) (sb-xc:* x x
)) (interval-abs x
)))
1323 (defun interval<n
(interval n
)
1324 (let ((high (interval-high interval
)))
1330 (defun interval-high<=n
(interval n
)
1332 (let ((high (interval-high interval
)))
1334 (sb-xc:<= (if (consp high
)
1339 (defun interval-low>=n
(interval n
)
1341 (let ((low (interval-low interval
)))
1343 (sb-xc:>= (if (consp low
)
1348 ;;; Does it contain integers?
1349 (defun interval-ratio-p (interval)
1350 (let ((low (interval-low interval
))
1351 (high (interval-high interval
)))
1352 (and (or (ratiop low
)
1354 (setf low
(car low
))))
1358 (if (integerp (car high
))
1361 (= (floor low
) (floor high
)))))
1363 (defun interval-constant-p (interval)
1364 (let ((low (interval-low interval
))
1365 (high (interval-high interval
)))
1370 ;;;; numeric DERIVE-TYPE methods
1372 ;;; a utility for defining derive-type methods of integer operations. If
1373 ;;; the types of both X and Y are integer types, then we compute a new
1374 ;;; integer type with bounds determined by FUN when applied to X and Y.
1375 ;;; Otherwise, we use NUMERIC-CONTAGION.
1376 (defun derive-integer-type-aux (x y fun
)
1377 (declare (type function fun
))
1378 (if (and (numeric-type-p x
) (numeric-type-p y
)
1379 (eq (numeric-type-class x
) 'integer
)
1380 (eq (numeric-type-class y
) 'integer
)
1381 (eq (numeric-type-complexp x
) :real
)
1382 (eq (numeric-type-complexp y
) :real
))
1383 (multiple-value-bind (low high
) (funcall fun x y
)
1384 (make-numeric-type :class
'integer
1388 (numeric-contagion x y
)))
1390 (defun derive-integer-type (x y fun
)
1391 (declare (type lvar x y
) (type function fun
))
1392 (let ((x (lvar-type x
))
1394 (derive-integer-type-aux x y fun
)))
1396 ;;; simple utility to flatten a list
1397 (defun flatten-list (x)
1398 (labels ((flatten-and-append (tree list
)
1399 (cond ((null tree
) list
)
1400 ((atom tree
) (cons tree list
))
1401 (t (flatten-and-append
1402 (car tree
) (flatten-and-append (cdr tree
) list
))))))
1403 (flatten-and-append x nil
)))
1405 ;;; Take some type of lvar and massage it so that we get a list of the
1406 ;;; constituent types. If ARG is *EMPTY-TYPE*, return NIL to indicate
1408 (defun prepare-arg-for-derive-type (arg)
1409 (flet ((listify (arg)
1414 (union-type-types arg
))
1419 (ignore-hairy-type (type)
1420 (if (and (intersection-type-p type
)
1421 (find-if #'hairy-type-p
(intersection-type-types type
)))
1422 (find-if-not #'hairy-type-p
(intersection-type-types type
))
1424 (unless (eq arg
*empty-type
*)
1425 ;; Make sure all args are some type of numeric-type. For member
1426 ;; types, convert the list of members into a union of equivalent
1427 ;; single-element member-type's.
1428 (let ((new-args nil
))
1429 (dolist (arg (listify arg
))
1430 (let ((arg (ignore-hairy-type arg
)))
1431 (if (member-type-p arg
)
1432 ;; Run down the list of members and convert to a list of
1434 (mapc-member-type-members
1436 (push (if (numberp member
) (make-eql-type member
) *empty-type
*)
1439 (push arg new-args
))))
1440 (unless (member *empty-type
* new-args
)
1443 ;;; Take a list of types and return a canonical type specifier,
1444 ;;; combining any MEMBER types together. If both positive and negative
1445 ;;; MEMBER types are present they are converted to a float type.
1446 ;;; XXX This would be far simpler if the type-union methods could handle
1447 ;;; member/number unions.
1449 ;;; If we're about to generate an overly complex union of numeric types, start
1450 ;;; collapse the ranges together.
1452 ;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
1453 ;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
1454 ;;; invoked always, instead of in the compiler, invoked only during some type
1456 (defvar *derived-numeric-union-complexity-limit
* 6)
1458 (defun make-derived-union-type (type-list)
1459 (let ((xset (alloc-xset))
1462 (numeric-type *empty-type
*))
1463 (dolist (type type-list
)
1464 (cond ((member-type-p type
)
1465 (mapc-member-type-members
1467 (if (fp-zero-p member
)
1468 (unless (member member fp-zeroes
)
1469 (pushnew member fp-zeroes
))
1470 (add-to-xset member xset
)))
1472 ((numeric-type-p type
)
1473 (setf numeric-type
(type-union type numeric-type
)))
1475 (push type misc-types
))))
1476 (setf numeric-type
(sb-kernel::weaken-numeric-type-union
*derived-numeric-union-complexity-limit
* numeric-type
))
1477 (if (and (xset-empty-p xset
) (not fp-zeroes
))
1478 (apply #'type-union numeric-type misc-types
)
1479 (apply #'type-union
(make-member-type xset fp-zeroes
)
1480 numeric-type misc-types
))))
1482 ;;; Convert a member type with a single member to a numeric type.
1483 (defun convert-member-type (arg)
1484 (let* ((members (member-type-members arg
))
1485 (member (first members
))
1486 (member-type (type-of member
)))
1487 (aver (not (rest members
)))
1488 (specifier-type (cond ((typep member
'integer
)
1489 `(integer ,member
,member
))
1490 ((memq member-type
'(short-float single-float
1491 double-float long-float
))
1492 `(,member-type
,member
,member
))
1496 ;;; This is used in defoptimizers for computing the resulting type of
1499 ;;; Given the lvar ARG, derive the resulting type using the
1500 ;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
1501 ;;; "atomic" lvar type like numeric-type or member-type (containing
1502 ;;; just one element). It should return the resulting type, which can
1503 ;;; be a list of types.
1505 ;;; For the case of member types, if a MEMBER-FUN is given it is
1506 ;;; called to compute the result otherwise the member type is first
1507 ;;; converted to a numeric type and the DERIVE-FUN is called.
1508 (defun one-arg-derive-type (arg derive-fun member-fun
&optional
(ratio-to-rational t
))
1509 (declare (type function derive-fun
)
1510 (type (or null function
) member-fun
))
1511 (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg
))))
1513 (labels ((deriver (x)
1519 `(eql ,(funcall member-fun
1520 (first (member-type-members x
)))))
1521 (arithmetic-error () nil
))
1522 ;; Otherwise convert to a numeric type.
1523 (funcall derive-fun
(convert-member-type x
))))
1524 ((or (numeric-type-p x
)
1525 (and (not ratio-to-rational
)
1526 (eq x
(specifier-type 'ratio
))))
1527 (funcall derive-fun x
))
1528 ((eq x
(specifier-type 'ratio
))
1529 (deriver (specifier-type 'rational
))))))
1530 ;; Run down the list of args and derive the type of each one,
1531 ;; saving all of the results in a list.
1532 (let ((results nil
))
1533 (dolist (arg arg-list
)
1534 (let ((result (deriver arg
)))
1536 (return-from one-arg-derive-type
))
1538 (setf results
(append results result
)))
1540 (push result results
)))))
1542 (make-derived-union-type results
)
1543 (first results
)))))))
1545 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
1546 ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
1547 ;;; original args and a third which is T to indicate if the two args
1548 ;;; really represent the same lvar. This is useful for deriving the
1549 ;;; type of things like (* x x), which should always be positive. If
1550 ;;; we didn't do this, we wouldn't be able to tell.
1551 (defun two-arg-derive-type (arg1 arg2 derive-fun member-fun
&optional
(ratio-to-rational t
))
1552 (%two-arg-derive-type
(lvar-type arg1
) (lvar-type arg2
)
1553 derive-fun member-fun
1554 (same-leaf-ref-p arg1 arg2
)
1557 (defun %two-arg-derive-type
(arg1-type arg2-type derive-fun member-fun
&optional same-leaf
(ratio-to-rational t
))
1558 (declare (type function derive-fun member-fun
))
1559 (labels ((numeric-or-ratio-p (x)
1560 (or (numeric-type-p x
)
1561 (eq x
(specifier-type 'ratio
))))
1562 (deriver (x y same-arg
)
1563 (when ratio-to-rational
1564 (when (eq x
(specifier-type 'ratio
))
1565 (setf x
(specifier-type 'rational
)))
1566 (when (eq y
(specifier-type 'ratio
))
1567 (setf y
(specifier-type 'rational
))))
1568 (cond ((and (member-type-p x
) (member-type-p y
))
1569 (let* ((x (first (member-type-members x
)))
1570 (y (first (member-type-members y
)))
1571 (result (ignore-errors
1572 (funcall member-fun x y
))))
1573 (cond ((null result
) *empty-type
*)
1574 ((and (floatp result
) (float-nan-p result
))
1575 (make-numeric-type :class
'float
1576 :format
(type-of result
)
1579 (specifier-type `(eql ,result
))))))
1580 ((and (member-type-p x
) (numeric-or-ratio-p y
))
1581 (funcall derive-fun
(convert-member-type x
) y same-arg
))
1582 ((and (numeric-or-ratio-p x
) (member-type-p y
))
1583 (funcall derive-fun x
(convert-member-type y
) same-arg
))
1584 ((and (numeric-or-ratio-p x
) (numeric-or-ratio-p y
))
1585 (funcall derive-fun x y same-arg
))
1588 (derive (type1 type2 same-arg
)
1589 (let ((a1 (prepare-arg-for-derive-type type1
))
1590 (a2 (prepare-arg-for-derive-type type2
)))
1592 (let ((results nil
))
1594 ;; Since the args are the same LVARs, just run down the
1597 (let ((result (deriver x x same-arg
)))
1599 (setf results
(append results result
))
1600 (push result results
))))
1601 ;; Try all pairwise combinations.
1604 (let ((result (or (deriver x y same-arg
)
1605 (numeric-contagion x y
))))
1607 (setf results
(append results result
))
1608 (push result results
))))))
1610 (make-derived-union-type results
)
1611 (first results
)))))))
1612 (derive arg1-type arg2-type same-leaf
)))
1614 (defun +-derive-type-aux
(x y same-arg
)
1615 (cond ((and (numeric-type-real-p x
)
1616 (numeric-type-real-p y
))
1617 (let* ((x-interval (numeric-type->interval x
))
1618 (y-interval (if same-arg
1620 (numeric-type->interval y
)))
1621 (result (interval-add x-interval y-interval
))
1622 (result-type (numeric-contagion x y
)))
1623 ;; If the result type is a float, we need to be sure to coerce
1624 ;; the bounds into the correct type.
1625 (when (eq (numeric-type-class result-type
) 'float
)
1626 (setf result
(interval-func
1628 (coerce-for-bound x
(or (numeric-type-format result-type
)
1631 (let ((numeric (make-numeric-type
1632 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1633 (eq (numeric-type-class y
) 'integer
))
1634 ;; The sum of integers is always an integer.
1636 (numeric-type-class result-type
))
1637 :format
(numeric-type-format result-type
)
1638 :low
(interval-low result
)
1639 :high
(interval-high result
))))
1640 (if (or (and (eq (numeric-type-class x
) 'integer
)
1641 (interval-ratio-p y-interval
))
1642 (and (eq (numeric-type-class y
) 'integer
)
1643 (interval-ratio-p x-interval
)))
1644 (type-intersection numeric
(specifier-type 'ratio
))
1646 ((and (eq x
(specifier-type 'ratio
))
1648 (eq (numeric-type-class y
) 'integer
))
1649 (specifier-type 'ratio
))
1650 ((and (eq y
(specifier-type 'ratio
))
1652 (eq (numeric-type-class x
) 'integer
))
1653 (specifier-type 'ratio
))
1655 (numeric-contagion x y
))))
1657 (defoptimizer (+ derive-type
) ((x y
))
1658 (two-arg-derive-type x y
#'+-derive-type-aux
#'sb-xc
:+ nil
))
1660 (defun --derive-type-aux (x y same-arg
)
1661 (cond ((and (numeric-type-real-p x
)
1662 (numeric-type-real-p y
))
1663 (let* ((x-interval (numeric-type->interval x
))
1664 (y-interval (if same-arg
1666 (numeric-type->interval y
)))
1668 ;; (- X X) is always 0.
1670 (make-interval :low
0 :high
0)
1671 (interval-sub x-interval y-interval
)))
1672 (result-type (numeric-contagion x y
)))
1673 ;; If the result type is a float, we need to be sure to coerce
1674 ;; the bounds into the correct type.
1675 (when (eq (numeric-type-class result-type
) 'float
)
1676 (setf result
(interval-func
1678 (coerce-for-bound x
(or (numeric-type-format result-type
)
1683 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1684 (eq (numeric-type-class y
) 'integer
))
1685 ;; The difference of integers is always an integer.
1687 (numeric-type-class result-type
))
1688 :format
(numeric-type-format result-type
)
1689 :low
(interval-low result
)
1690 :high
(interval-high result
))))
1691 (if (or (and (eq (numeric-type-class x
) 'integer
)
1692 (interval-ratio-p y-interval
))
1693 (and (eq (numeric-type-class y
) 'integer
)
1694 (interval-ratio-p x-interval
)))
1695 (type-intersection numeric
(specifier-type 'ratio
))
1697 ((and (eq x
(specifier-type 'ratio
))
1699 (eq (numeric-type-class y
) 'integer
))
1700 (specifier-type 'ratio
))
1701 ((and (eq y
(specifier-type 'ratio
))
1703 (eq (numeric-type-class x
) 'integer
))
1704 (specifier-type 'ratio
))
1706 (eq x
(specifier-type 'ratio
)))
1707 (specifier-type '(integer 0 0)))
1709 (numeric-contagion x y
))))
1711 (defoptimizer (- derive-type
) ((x y
))
1712 (two-arg-derive-type x y
#'--derive-type-aux
#'sb-xc
:- nil
))
1714 (defun *-derive-type-aux
(x y same-arg
)
1715 (cond ((and (numeric-type-real-p x
)
1716 (numeric-type-real-p y
))
1717 (let* ((x-interval (numeric-type->interval x
))
1718 (y-interval (if same-arg
1720 (numeric-type->interval y
)))
1722 ;; (* X X) is always positive, so take care to do it right.
1724 (interval-sqr x-interval
)
1725 (interval-mul x-interval y-interval
)))
1726 (result-type (numeric-contagion x y
)))
1727 ;; If the result type is a float, we need to be sure to coerce
1728 ;; the bounds into the correct type.
1729 (when (eq (numeric-type-class result-type
) 'float
)
1730 (setf result
(interval-func
1732 (coerce-for-bound x
(or (numeric-type-format result-type
)
1737 :class
(if (and (eq (numeric-type-class x
) 'integer
)
1738 (eq (numeric-type-class y
) 'integer
))
1739 ;; The product of integers is always an integer.
1741 (numeric-type-class result-type
))
1742 :format
(numeric-type-format result-type
)
1743 :low
(interval-low result
)
1744 :high
(interval-high result
))))
1745 (flet ((ratio-result-p (a a-interval b-interval
)
1747 (and (eq (numeric-type-class a
) 'integer
)
1748 (ratiop (setf ratio
(interval-constant-p b-interval
)))
1749 (interval-bounded-p a-interval
'both
)
1750 ;; Is the integer between two adjecents
1751 ;; powers of denominator?
1752 (let* ((low (interval-low a-interval
))
1753 (high (interval-high a-interval
))
1754 (den (denominator ratio
))
1755 (rem (nth-value 1 (ceiling low den
))))
1756 (and (not (zerop rem
))
1757 (< high
(- low rem
))))))))
1758 (if (or (ratio-result-p x x-interval y-interval
)
1759 (ratio-result-p y y-interval x-interval
))
1760 (type-intersection numeric
(specifier-type 'ratio
))
1763 (eq x
(specifier-type 'ratio
)))
1764 ;; TODO: should be positive, but this result is an
1765 ;; intersection type which other optimizers do not see.
1766 (specifier-type 'ratio
))
1768 (numeric-contagion x y
))))
1770 (defoptimizer (* derive-type
) ((x y
))
1771 (let ((x-type (lvar-type x
))
1772 (y-type (lvar-type y
)))
1774 (flet ((try-zero (x y
)
1775 (when (and (csubtypep x
(specifier-type 'integer
))
1776 (csubtypep (specifier-type '(eql 0)) x
)
1777 (csubtypep y
(specifier-type '(and integer
(not (eql 0))))))
1779 (let ((result (%two-arg-derive-type
(type-intersection x
(specifier-type '(and integer
(not (eql 0)))))
1781 #'*-derive-type-aux
#'sb-xc
:* nil
)))
1783 (type-union result
(specifier-type '(eql 0)))))))))
1784 ;; If one of the integer arguments is non zero seperate the zero
1785 ;; result from the rest of the result range.
1786 (try-zero x-type y-type
)
1787 (try-zero y-type x-type
)
1788 (two-arg-derive-type x y
#'*-derive-type-aux
#'sb-xc
:* nil
)))))
1790 (defoptimizer (%signed-multiply-high derive-type
) ((x y
))
1791 (two-arg-derive-type x y
1792 (lambda (x y same-arg
)
1793 (let* ((type (*-derive-type-aux x y same-arg
))
1794 (low (numeric-type-low type
))
1795 (high (numeric-type-high type
)))
1796 (when (and low high
)
1797 (make-numeric-type :class
'integer
1799 (ash low
(- sb-vm
:n-word-bits
))
1800 :high
(ash high
(- sb-vm
:n-word-bits
))))))
1803 (defoptimizer (%multiply-high derive-type
) ((x y
) node
)
1804 (%signed-multiply-high-derive-type-optimizer node
))
1806 (defun /-derive-type-aux
(x y same-arg
)
1807 (cond ((and (numeric-type-real-p x
)
1808 (numeric-type-real-p y
))
1809 (let* ((x-interval (numeric-type->interval x
))
1810 (y-interval (if same-arg
1812 (numeric-type->interval y
)))
1813 (result-type (numeric-contagion x y
))
1814 (y-integerp (eq (numeric-type-class y
) 'integer
))
1816 ;; (/ X X) is always 1, except if X can contain 0. In
1817 ;; that case, we shouldn't optimize the division away
1818 ;; because we want 0/0 to signal an error.
1820 (not (interval-contains-p
1821 0 (interval-closure x-interval
))))
1822 (make-interval :low
1 :high
1)
1823 (interval-div x-interval y-interval
1824 (and (memq (numeric-type-class x
) '(integer rational
))
1826 (cond ((consp result
)
1827 (type-union (make-numeric-type :class
(numeric-type-class result-type
)
1828 :format
(numeric-type-format result-type
)
1829 :low
(interval-low (first result
))
1830 :high
(interval-high (first result
)))
1831 (make-numeric-type :class
(numeric-type-class result-type
)
1832 :format
(numeric-type-format result-type
)
1833 :low
(interval-low (second result
))
1834 :high
(interval-high (second result
)))))
1836 ;; If the result type is a float, we need to be sure to coerce
1837 ;; the bounds into the correct type.
1838 (when (eq (numeric-type-class result-type
) 'float
)
1839 (setf result
(interval-func
1841 (coerce-for-bound x
(or (numeric-type-format result-type
)
1844 (let ((numeric (make-numeric-type :class
(numeric-type-class result-type
)
1845 :format
(numeric-type-format result-type
)
1846 :low
(interval-low result
)
1847 :high
(interval-high result
))))
1849 (interval-ratio-p x-interval
))
1850 (type-intersection numeric
(specifier-type 'ratio
))
1852 ((and (eq x
(specifier-type 'ratio
))
1854 (specifier-type '(integer 1 1)))
1855 ((and (numeric-type-p y
)
1856 (eq (numeric-type-class y
) 'integer
))
1857 (specifier-type 'ratio
)))))
1859 (numeric-contagion x y
))))
1861 (defoptimizer (/ derive-type
) ((x y
))
1862 (two-arg-derive-type x y
#'/-derive-type-aux
#'sb-xc
:/ nil
))
1864 (defun ash-derive-type-aux (n-type shift same-arg
)
1865 (declare (ignore same-arg
))
1866 (flet ((ash-outer (n s
)
1867 (when (and (fixnump s
)
1869 (> s most-negative-fixnum
))
1871 ;; KLUDGE: The bare 64's here should be related to
1872 ;; symbolic machine word size values somehow.
1875 (if (and (fixnump s
)
1876 (> s most-negative-fixnum
))
1878 (if (minusp n
) -
1 0))))
1879 (or (and (csubtypep n-type
(specifier-type 'integer
))
1880 (csubtypep shift
(specifier-type 'integer
))
1881 (let ((n-low (numeric-type-low n-type
))
1882 (n-high (numeric-type-high n-type
))
1883 (s-low (numeric-type-low shift
))
1884 (s-high (numeric-type-high shift
)))
1885 (make-numeric-type :class
'integer
:complexp
:real
1888 (ash-outer n-low s-high
)
1889 (ash-inner n-low s-low
)))
1892 (ash-inner n-high s-low
)
1893 (ash-outer n-high s-high
))))))
1896 (defoptimizer (ash derive-type
) ((n shift
))
1897 (two-arg-derive-type n shift
#'ash-derive-type-aux
#'ash
))
1899 (defun lognot-derive-type-aux (int)
1900 (derive-integer-type-aux int int
1901 (lambda (type type2
)
1902 (declare (ignore type2
))
1903 (let ((lo (numeric-type-low type
))
1904 (hi (numeric-type-high type
)))
1905 (values (if hi
(lognot hi
) nil
)
1906 (if lo
(lognot lo
) nil
)
1907 (numeric-type-class type
)
1908 (numeric-type-format type
))))))
1910 (defoptimizer (lognot derive-type
) ((int))
1911 (one-arg-derive-type int
#'lognot-derive-type-aux
#'lognot
))
1914 (defun %negate-derive-type-aux
(type)
1915 (if (eq type
(specifier-type 'ratio
))
1917 (flet ((negate-bound (b)
1919 (set-bound (sb-xc:-
(type-bound-number b
))
1921 (modified-numeric-type
1923 :low
(negate-bound (numeric-type-high type
))
1924 :high
(negate-bound (numeric-type-low type
))))))
1926 (defoptimizer (%negate derive-type
) ((num))
1927 (one-arg-derive-type num
#'%negate-derive-type-aux
#'sb-xc
:- nil
))
1929 (defun abs-derive-type-aux (type)
1930 (cond ((eq type
(specifier-type 'ratio
))
1932 ((eq (numeric-type-complexp type
) :complex
)
1933 ;; The absolute value of a complex number is always a
1934 ;; non-negative float.
1935 (let* ((format (case (numeric-type-class type
)
1936 ((integer rational
) 'single-float
)
1937 (t (numeric-type-format type
))))
1938 (bound-format (or format
'float
)))
1939 (make-numeric-type :class
'float
1942 :low
(coerce 0 bound-format
)
1945 ;; The absolute value of a real number is a non-negative real
1946 ;; of the same type.
1947 (let* ((abs-bnd (interval-abs (numeric-type->interval type
)))
1948 (class (numeric-type-class type
))
1949 (format (numeric-type-format type
))
1950 (bound-type (or format class
'real
)))
1955 :low
(coerce-and-truncate-floats (interval-low abs-bnd
) bound-type
)
1956 :high
(coerce-and-truncate-floats
1957 (interval-high abs-bnd
) bound-type
))))))
1959 (defoptimizer (abs derive-type
) ((num))
1960 (one-arg-derive-type num
#'abs-derive-type-aux
#'abs nil
))
1962 (defun rem-result-type (number-type divisor-type
)
1963 ;; Figure out what the remainder type is. The remainder is an
1964 ;; integer if both args are integers; a rational if both args are
1965 ;; rational; and a float otherwise.
1966 (cond ((and (csubtypep number-type
(specifier-type 'integer
))
1967 (csubtypep divisor-type
(specifier-type 'integer
)))
1969 ((and (csubtypep number-type
(specifier-type 'rational
))
1970 (csubtypep divisor-type
(specifier-type 'rational
)))
1972 ((and (csubtypep number-type
(specifier-type 'float
))
1973 (csubtypep divisor-type
(specifier-type 'float
)))
1974 ;; Both are floats so the result is also a float, of
1975 ;; the largest type.
1976 (or (float-format-max (numeric-type-format number-type
)
1977 (numeric-type-format divisor-type
))
1979 ((and (csubtypep number-type
(specifier-type 'float
))
1980 (csubtypep divisor-type
(specifier-type 'rational
)))
1981 ;; One of the arguments is a float and the other is a
1982 ;; rational. The remainder is a float of the same
1984 (or (numeric-type-format number-type
) 'float
))
1985 ((and (csubtypep divisor-type
(specifier-type 'float
))
1986 (csubtypep number-type
(specifier-type 'rational
)))
1987 ;; One of the arguments is a float and the other is a
1988 ;; rational. The remainder is a float of the same
1990 (or (numeric-type-format divisor-type
) 'float
))
1992 ;; Some unhandled combination. This usually means both args
1993 ;; are REAL so the result is a REAL.
1996 (defvar *conservative-quotient-bound
* t
)
1998 (defun truncate-derive-type-quot (number-type divisor-type
)
1999 (let* ((rem-type (rem-result-type number-type divisor-type
))
2000 (number-interval (numeric-type->interval number-type
))
2001 (divisor-interval (numeric-type->interval divisor-type
)))
2002 ;;(declare (type (member '(integer rational float)) rem-type))
2003 ;; We have real numbers now.
2004 (cond ((eq rem-type
'integer
)
2005 ;; Since the remainder type is INTEGER, both args are
2007 (let* ((res (integer-truncate-derive-type
2008 (interval-low number-interval
)
2009 (interval-high number-interval
)
2010 (interval-low divisor-interval
)
2011 (interval-high divisor-interval
))))
2012 (specifier-type (if (listp res
) res
'integer
))))
2014 (multiple-value-bind (quot conservative
)
2015 (if (and (eql (interval-high divisor-interval
) 1)
2016 (eql (interval-low divisor-interval
) 1))
2017 (values number-interval nil
)
2018 (values (interval-div number-interval
2020 (let* ((*conservative-quotient-bound
* conservative
)
2021 (quot (truncate-quotient-bound quot
)))
2022 (specifier-type `(integer ,(or (interval-low quot
) '*)
2023 ,(or (interval-high quot
) '*)))))))))
2025 (defun truncate-derive-type-rem (number-type divisor-type
)
2026 (let* ((rem-type (rem-result-type number-type divisor-type
))
2027 (number-interval (numeric-type->interval number-type
))
2028 (divisor-interval (numeric-type->interval divisor-type
))
2029 (rem (truncate-rem-bound number-interval divisor-interval
)))
2030 (cond ((and (numberp (interval-low divisor-interval
))
2031 (numberp (interval-high divisor-interval
))
2032 (zerop (interval-low divisor-interval
))
2033 (zerop (interval-high divisor-interval
)))
2035 ((eq rem-type
'integer
)
2036 ;; Since the remainder type is INTEGER, both args are
2038 (specifier-type `(,rem-type
,(or (interval-low rem
) '*)
2039 ,(or (interval-high rem
) '*))))
2041 (multiple-value-bind (class format
)
2044 (values 'integer nil
))
2046 (values 'rational nil
))
2047 ((single-float double-float
#+long-float long-float
)
2048 (values 'float rem-type
))
2050 (values 'float nil
))
2053 (when (member rem-type
'(float single-float double-float
2054 #+long-float long-float
))
2055 (setf rem
(interval-func #'(lambda (x)
2056 (coerce-for-bound x rem-type
))
2058 (make-numeric-type :class class
2060 :low
(interval-low rem
)
2061 :high
(interval-high rem
)))))))
2063 (defun truncate-derive-type-quot-aux (num div same-arg
)
2064 (declare (ignore same-arg
))
2065 (when (and (numeric-type-real-p num
)
2066 (numeric-type-real-p div
))
2067 (truncate-derive-type-quot num div
)))
2069 (defun truncate-derive-type-rem-aux (num div same-arg
)
2070 (declare (ignore same-arg
))
2071 (cond ((not (and (numeric-type-real-p num
)
2072 (numeric-type-real-p div
)))
2074 ;; Floats introduce rounding errors
2075 ((and (memq (numeric-type-class num
) '(integer rational
))
2076 (memq (numeric-type-class div
) '(integer rational
)))
2077 (truncate-derive-type-rem num div
))
2079 (numeric-contagion num div
))))
2081 (defoptimizer (truncate derive-type
) ((number divisor
))
2082 (let ((quot (two-arg-derive-type number divisor
2083 #'truncate-derive-type-quot-aux
#'truncate
))
2084 (rem (two-arg-derive-type number divisor
2085 #'truncate-derive-type-rem-aux
#'rem
)))
2086 (when (and quot rem
)
2087 (make-values-type (list quot rem
)))))
2089 (defun %unary-truncate-derive-type-aux
(number)
2090 (truncate-derive-type-quot number
(specifier-type '(integer 1 1))))
2092 (defoptimizer (%unary-truncate derive-type
) ((number))
2093 (one-arg-derive-type number
2094 #'%unary-truncate-derive-type-aux
2097 (defoptimizer (%unary-truncate
/single-float derive-type
) ((number))
2098 (one-arg-derive-type number
2099 #'%unary-truncate-derive-type-aux
2102 (defoptimizer (%unary-truncate
/double-float derive-type
) ((number))
2103 (one-arg-derive-type number
2104 #'%unary-truncate-derive-type-aux
2107 (defoptimizer (unary-truncate derive-type
) ((number))
2108 (let* ((one (specifier-type '(integer 1 1)))
2109 (quot (one-arg-derive-type number
2111 (truncate-derive-type-quot-aux x one nil
))
2113 (rem (one-arg-derive-type number
2114 (lambda (x) (truncate-derive-type-rem-aux x one nil
))
2116 (when (and quot rem
)
2117 (make-values-type (list quot rem
)))))
2119 (deftransform unary-truncate
((number) (integer))
2124 (defun ftruncate-derive-type-quot (number-type divisor-type
)
2125 ;; The bounds are the same as for truncate. However, the first
2126 ;; result is a float of some type. We need to determine what that
2127 ;; type is. Basically it's the more contagious of the two types.
2128 (let ((q-type (truncate-derive-type-quot number-type divisor-type
))
2129 (format (numeric-type-format
2130 (numeric-contagion number-type divisor-type
))))
2131 (make-numeric-type :class
'float
2133 :low
(coerce-for-bound (numeric-type-low q-type
) format
)
2134 :high
(coerce-for-bound (numeric-type-high q-type
) format
))))
2136 (defun ftruncate-derive-type-quot-aux (n d same-arg
)
2137 (declare (ignore same-arg
))
2138 (when (and (numeric-type-real-p n
)
2139 (numeric-type-real-p d
))
2140 (ftruncate-derive-type-quot n d
)))
2143 (defoptimizer (ftruncate derive-type
) ((number divisor
))
2145 (two-arg-derive-type number divisor
2146 #'ftruncate-derive-type-quot-aux
#'ftruncate
))
2147 (rem (two-arg-derive-type number divisor
2148 #'truncate-derive-type-rem-aux
#'rem
)))
2149 (when (and quot rem
)
2150 (make-values-type (list quot rem
)))))
2153 (defoptimizer (%unary-ftruncate derive-type
) ((number))
2154 (let ((divisor (specifier-type '(integer 1 1))))
2155 (one-arg-derive-type number
2157 (ftruncate-derive-type-quot-aux n divisor nil
))
2158 #'%unary-ftruncate
))))
2161 (macrolet ((derive (type)
2162 `(case (lvar-value mode
)
2163 ,@(loop for mode in
'(:round
:floor
:ceiling
:truncate
)
2164 for fun in
'(fround ffloor fceiling ftruncate
)
2167 (one-arg-derive-type number
2169 (when (numeric-type-p type
)
2170 (let ((lo (numeric-type-low type
))
2171 (hi (numeric-type-high type
)))
2172 (specifier-type (list ',type
2174 (,fun
(type-bound-number lo
))
2177 (,fun
(type-bound-number hi
))
2180 (values (,fun x
)))))))))
2181 (defoptimizer (round-single derive-type
) ((number mode
))
2182 (derive single-float
))
2183 (defoptimizer (round-double derive-type
) ((number mode
))
2184 (derive double-float
)))
2186 (defoptimizer (%unary-round derive-type
) ((number))
2187 (one-arg-derive-type number
2190 (unless (numeric-type-real-p n
)
2192 (let* ((interval (numeric-type->interval n
))
2193 (low (interval-low interval
))
2194 (high (interval-high interval
)))
2196 (setf low
(car low
)))
2198 (setf high
(car high
)))
2208 ;;; Define optimizers for FLOOR and CEILING.
2210 ((def (name q-name r-name
)
2211 (let ((q-aux (symbolicate q-name
"-AUX"))
2212 (r-aux (symbolicate r-name
"-AUX")))
2214 ;; Compute type of quotient (first) result.
2215 (defun ,q-aux
(number-type divisor-type
)
2216 (let* ((number-interval
2217 (numeric-type->interval number-type
))
2219 (numeric-type->interval divisor-type
))
2220 (quot (,q-name
(interval-div number-interval
2221 divisor-interval
))))
2222 (specifier-type `(integer ,(or (interval-low quot
) '*)
2223 ,(or (interval-high quot
) '*)))))
2224 ;; Compute type of remainder.
2225 (defun ,r-aux
(number-type divisor-type
)
2226 (let* ((divisor-interval
2227 (numeric-type->interval divisor-type
))
2229 (numeric-type->interval number-type
))
2230 (rem (,r-name number-interval divisor-interval
))
2231 (result-type (rem-result-type number-type divisor-type
)))
2232 (multiple-value-bind (class format
)
2235 (values 'integer nil
))
2237 (values 'rational nil
))
2238 ((single-float double-float
#+long-float long-float
)
2239 (values 'float result-type
))
2241 (values 'float nil
))
2244 (when (member result-type
'(float single-float double-float
2245 #+long-float long-float
))
2246 ;; Make sure that the limits on the interval have
2248 (setf rem
(interval-func (lambda (x)
2249 (coerce-for-bound x result-type
))
2251 (make-numeric-type :class class
2253 :low
(interval-low rem
)
2254 :high
(interval-high rem
)))))
2255 ;; the optimizer itself
2256 (defoptimizer (,name derive-type
) ((number divisor
))
2257 (flet ((derive-q (n d same-arg
)
2258 (declare (ignore same-arg
))
2259 (when (and (numeric-type-real-p n
)
2260 (numeric-type-real-p d
))
2262 (derive-r (num div same-arg
)
2263 (declare (ignore same-arg
))
2264 (cond ((not (and (numeric-type-real-p num
)
2265 (numeric-type-real-p div
)))
2267 ;; Floats introduce rounding errors
2268 ((and (memq (numeric-type-class num
) '(integer rational
))
2269 (memq (numeric-type-class div
) '(integer rational
)))
2272 (numeric-contagion num div
)))))
2273 (let ((quot (two-arg-derive-type
2274 number divisor
#'derive-q
#',name
))
2275 (rem (two-arg-derive-type
2276 number divisor
#'derive-r
#'mod
)))
2277 (when (and quot rem
)
2278 (make-values-type (list quot rem
))))))))))
2280 (def floor floor-quotient-bound floor-rem-bound
)
2281 (def ceiling ceiling-quotient-bound ceiling-rem-bound
))
2283 ;;; The quotient for floats depends on the divisor,
2284 ;;; make the result conservative, without letting it cross 0
2285 (defmacro conservative-quotient-bound
(result direction bound
)
2286 (let ((result-sym (gensym)))
2287 `(let ((,result-sym
,result
))
2288 (,direction
,result-sym
2289 (if (and *conservative-quotient-bound
*
2295 ;;; functions to compute the bounds on the quotient and remainder for
2296 ;;; the FLOOR function
2297 (defun floor-quotient-bound (quot)
2298 ;; Take the floor of the quotient and then massage it into what we
2300 (let ((lo (interval-low quot
))
2301 (hi (interval-high quot
)))
2303 ;; Take the floor of the lower bound. The result is always a
2304 ;; closed lower bound.
2307 (conservative-quotient-bound
2308 (floor (type-bound-number lo
))
2310 (type-bound-number lo
)))
2313 (conservative-quotient-bound
2315 ;; An open bound. We need to be careful here because
2316 ;; the floor of '(10.0) is 9, but the floor of
2318 (multiple-value-bind (q r
) (floor (first hi
))
2322 ;; A closed bound, so the answer is obvious.
2325 (type-bound-number hi
))))))
2327 (defun floor-rem-bound (num div
)
2328 (case (interval-range-info div
)
2330 ;; The divisor is always positive.
2331 (let ((rem (interval-abs div
)))
2332 (setf (interval-low rem
) 0)
2333 (when (and (numberp (interval-high rem
))
2334 (not (zerop (interval-high rem
))))
2335 ;; The remainder never contains the upper bound. However,
2336 ;; watch out for the case where the high limit is zero!
2337 (setf (interval-high rem
) (list (interval-high rem
))))
2338 ;; The remainder can't be greater than the number
2339 ;; if it's getting truncated towards zero.
2340 (when (and (eq (interval-range-info num
) '+)
2341 (numberp (interval-high num
))
2342 (interval-contains-p (interval-high num
) rem
))
2343 (setf (interval-high rem
) (interval-high num
)))
2346 ;; The divisor is always negative.
2347 (let ((rem (interval-neg (interval-abs div
))))
2348 (setf (interval-high rem
) 0)
2349 (when (numberp (interval-low rem
))
2350 ;; The remainder never contains the lower bound.
2351 (setf (interval-low rem
) (list (interval-low rem
))))
2352 ;; The remainder can't be greater than the number
2353 ;; if it's getting truncated towards zero.
2354 (when (and (eq (interval-range-info num
) '-
)
2355 (numberp (interval-low num
))
2356 (interval-contains-p (interval-low num
) rem
))
2357 (setf (interval-low rem
) (interval-low num
)))
2360 ;; The divisor can be positive or negative. All bets off. The
2361 ;; magnitude of remainder is the maximum value of the divisor.
2362 (let ((limit (type-bound-number (interval-high (interval-abs div
)))))
2363 ;; The bound never reaches the limit, so make the interval open.
2364 (make-interval :low
(if limit
2367 :high
(list limit
))))))
2369 (floor-quotient-bound (make-interval :low
0.3 :high
10.3))
2370 => #S
(INTERVAL :LOW
0 :HIGH
10)
2371 (floor-quotient-bound (make-interval :low
0.3 :high
'(10.3
)))
2372 => #S
(INTERVAL :LOW
0 :HIGH
10)
2373 (floor-quotient-bound (make-interval :low
0.3 :high
10))
2374 => #S
(INTERVAL :LOW
0 :HIGH
10)
2375 (floor-quotient-bound (make-interval :low
0.3 :high
'(10)))
2376 => #S
(INTERVAL :LOW
0 :HIGH
9)
2377 (floor-quotient-bound (make-interval :low
'(0.3
) :high
10.3))
2378 => #S
(INTERVAL :LOW
0 :HIGH
10)
2379 (floor-quotient-bound (make-interval :low
'(0.0
) :high
10.3))
2380 => #S
(INTERVAL :LOW
0 :HIGH
10)
2381 (floor-quotient-bound (make-interval :low
'(-1.3
) :high
10.3))
2382 => #S
(INTERVAL :LOW -
2 :HIGH
10)
2383 (floor-quotient-bound (make-interval :low
'(-1.0
) :high
10.3))
2384 => #S
(INTERVAL :LOW -
1 :HIGH
10)
2385 (floor-quotient-bound (make-interval :low -
1.0 :high
10.3))
2386 => #S
(INTERVAL :LOW -
1 :HIGH
10)
2388 (floor-rem-bound (make-interval :low
0.3 :high
10.3))
2389 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2390 (floor-rem-bound (make-interval :low
0.3 :high
'(10.3
)))
2391 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2392 (floor-rem-bound (make-interval :low -
10 :high -
2.3))
2393 #S
(INTERVAL :LOW
(-10) :HIGH
0)
2394 (floor-rem-bound (make-interval :low
0.3 :high
10))
2395 => #S
(INTERVAL :LOW
0 :HIGH
'(10))
2396 (floor-rem-bound (make-interval :low
'(-1.3
) :high
10.3))
2397 => #S
(INTERVAL :LOW
'(-10.3
) :HIGH
'(10.3
))
2398 (floor-rem-bound (make-interval :low
'(-20.3
) :high
10.3))
2399 => #S
(INTERVAL :LOW
(-20.3
) :HIGH
(20.3
))
2402 ;;; same functions for CEILING
2403 (defun ceiling-quotient-bound (quot)
2404 ;; Take the ceiling of the quotient and then massage it into what we
2406 (let ((lo (interval-low quot
))
2407 (hi (interval-high quot
)))
2411 (conservative-quotient-bound
2413 ;; An open bound. We need to be careful here because
2414 ;; the ceiling of '(10.0) is 11, but the ceiling of
2416 (multiple-value-bind (q r
) (ceiling (first lo
))
2420 ;; A closed bound, so the answer is obvious.
2423 (type-bound-number lo
)))
2425 ;; Take the ceiling of the upper bound. The result is always a
2426 ;; closed upper bound.
2428 (conservative-quotient-bound
2429 (ceiling (type-bound-number hi
))
2431 (type-bound-number hi
))))))
2433 (defun ceiling-rem-bound (num div
)
2434 (case (interval-range-info div
)
2436 ;; Divisor is always positive. The remainder is negative.
2437 (let ((rem (interval-neg (interval-abs div
))))
2438 (setf (interval-high rem
) 0)
2439 (when (and (numberp (interval-low rem
))
2440 (not (zerop (interval-low rem
))))
2441 ;; The remainder never contains the upper bound. However,
2442 ;; watch out for the case when the upper bound is zero!
2443 (setf (interval-low rem
) (list (interval-low rem
))))
2444 ;; The remainder can't be greater than the number
2445 ;; if it's getting truncated towards zero.
2446 (when (and (eq (interval-range-info num
) '-
)
2447 (numberp (interval-low num
))
2448 (interval-contains-p (interval-low num
) rem
))
2449 (setf (interval-low rem
) (interval-low num
)))
2452 (let ((rem (interval-abs div
)))
2453 ;; Divisor is always negative. The remainder is positive
2454 (setf (interval-low rem
) 0)
2455 (when (numberp (interval-high rem
))
2456 ;; The remainder never contains the lower bound.
2457 (setf (interval-high rem
)
2458 (list (interval-high rem
))))
2459 ;; The remainder can't be greater than the number
2460 ;; if it's getting truncated towards zero.
2461 (when (and (eq (interval-range-info num
) '+)
2462 (numberp (interval-high num
))
2463 (interval-contains-p (interval-high num
) rem
))
2464 (setf (interval-high rem
) (interval-high num
)))
2467 ;; The divisor can be positive or negative. All bets off. The
2468 ;; magnitude of remainder is the maximum value of the divisor.
2469 (let ((limit (type-bound-number (interval-high (interval-abs div
)))))
2470 ;; The bound never reaches the limit, so make the interval open.
2471 (make-interval :low
(if limit
2474 :high
(list limit
))))))
2477 (ceiling-quotient-bound (make-interval :low
0.3 :high
10.3))
2478 => #S
(INTERVAL :LOW
1 :HIGH
11)
2479 (ceiling-quotient-bound (make-interval :low
0.3 :high
'(10.3
)))
2480 => #S
(INTERVAL :LOW
1 :HIGH
11)
2481 (ceiling-quotient-bound (make-interval :low
0.3 :high
10))
2482 => #S
(INTERVAL :LOW
1 :HIGH
10)
2483 (ceiling-quotient-bound (make-interval :low
0.3 :high
'(10)))
2484 => #S
(INTERVAL :LOW
1 :HIGH
10)
2485 (ceiling-quotient-bound (make-interval :low
'(0.3
) :high
10.3))
2486 => #S
(INTERVAL :LOW
1 :HIGH
11)
2487 (ceiling-quotient-bound (make-interval :low
'(0.0
) :high
10.3))
2488 => #S
(INTERVAL :LOW
1 :HIGH
11)
2489 (ceiling-quotient-bound (make-interval :low
'(-1.3
) :high
10.3))
2490 => #S
(INTERVAL :LOW -
1 :HIGH
11)
2491 (ceiling-quotient-bound (make-interval :low
'(-1.0
) :high
10.3))
2492 => #S
(INTERVAL :LOW
0 :HIGH
11)
2493 (ceiling-quotient-bound (make-interval :low -
1.0 :high
10.3))
2494 => #S
(INTERVAL :LOW -
1 :HIGH
11)
2496 (ceiling-rem-bound (make-interval :low
0.3 :high
10.3))
2497 => #S
(INTERVAL :LOW
(-10.3
) :HIGH
0)
2498 (ceiling-rem-bound (make-interval :low
0.3 :high
'(10.3
)))
2499 => #S
(INTERVAL :LOW
0 :HIGH
'(10.3
))
2500 (ceiling-rem-bound (make-interval :low -
10 :high -
2.3))
2501 => #S
(INTERVAL :LOW
0 :HIGH
(10))
2502 (ceiling-rem-bound (make-interval :low
0.3 :high
10))
2503 => #S
(INTERVAL :LOW
(-10) :HIGH
0)
2504 (ceiling-rem-bound (make-interval :low
'(-1.3
) :high
10.3))
2505 => #S
(INTERVAL :LOW
(-10.3
) :HIGH
(10.3
))
2506 (ceiling-rem-bound (make-interval :low
'(-20.3
) :high
10.3))
2507 => #S
(INTERVAL :LOW
(-20.3
) :HIGH
(20.3
))
2510 (defun truncate-quotient-bound (quot)
2511 ;; For positive quotients, truncate is exactly like floor. For
2512 ;; negative quotients, truncate is exactly like ceiling. Otherwise,
2513 ;; it's the union of the two pieces.
2514 (case (interval-range-info quot
)
2517 (floor-quotient-bound quot
))
2519 ;; just like CEILING
2520 (ceiling-quotient-bound quot
))
2522 ;; Split the interval into positive and negative pieces, compute
2523 ;; the result for each piece and put them back together.
2524 (destructuring-bind (neg pos
) (interval-split 0 quot t t
)
2525 (interval-merge-pair (ceiling-quotient-bound neg
)
2526 (floor-quotient-bound pos
))))))
2528 (defun truncate-rem-bound (num div
)
2529 ;; This is significantly more complicated than FLOOR or CEILING. We
2530 ;; need both the number and the divisor to determine the range. The
2531 ;; basic idea is to split the ranges of NUM and DEN into positive
2532 ;; and negative pieces and deal with each of the four possibilities
2534 (case (interval-range-info num
)
2536 (case (interval-range-info div
)
2538 (floor-rem-bound num div
))
2540 (ceiling-rem-bound num div
))
2542 (destructuring-bind (neg pos
) (interval-split 0 div t t
)
2543 (interval-merge-pair (truncate-rem-bound num neg
)
2544 (truncate-rem-bound num pos
))))))
2546 (case (interval-range-info div
)
2548 (ceiling-rem-bound num div
))
2550 (floor-rem-bound num div
))
2552 (destructuring-bind (neg pos
) (interval-split 0 div t t
)
2553 (interval-merge-pair (truncate-rem-bound num neg
)
2554 (truncate-rem-bound num pos
))))))
2556 (destructuring-bind (neg pos
) (interval-split 0 num t t
)
2557 (interval-merge-pair (truncate-rem-bound neg div
)
2558 (truncate-rem-bound pos div
))))))
2560 ;;; Derive useful information about the range. Returns three values:
2561 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2562 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2563 ;;; - The abs of the maximal value if there is one, or nil if it is
2565 (defun numeric-range-info (low high
)
2566 (cond ((and low
(not (minusp low
)))
2567 (values '+ low high
))
2568 ((and high
(not (plusp high
)))
2569 (values '-
(- high
) (if low
(- low
) nil
)))
2571 (values nil
0 (and low high
(max (- low
) high
))))))
2573 (defun integer-truncate-derive-type
2574 (number-low number-high divisor-low divisor-high
)
2575 ;; The result cannot be larger in magnitude than the number, but the
2576 ;; sign might change. If we can determine the sign of either the
2577 ;; number or the divisor, we can eliminate some of the cases.
2578 (multiple-value-bind (number-sign number-min number-max
)
2579 (numeric-range-info number-low number-high
)
2580 (multiple-value-bind (divisor-sign divisor-min divisor-max
)
2581 (numeric-range-info divisor-low divisor-high
)
2582 (when (and divisor-max
(zerop divisor-max
))
2583 ;; We've got a problem: guaranteed division by zero.
2584 (return-from integer-truncate-derive-type t
))
2585 (when (zerop divisor-min
)
2586 ;; We'll assume that they aren't going to divide by zero.
2588 (cond ((and number-sign divisor-sign
)
2589 ;; We know the sign of both.
2590 (if (eq number-sign divisor-sign
)
2591 ;; Same sign, so the result will be positive.
2592 `(integer ,(if divisor-max
2593 (truncate number-min divisor-max
)
2596 (truncate number-max divisor-min
)
2598 ;; Different signs, the result will be negative.
2599 `(integer ,(if number-max
2600 (- (truncate number-max divisor-min
))
2603 (- (truncate number-min divisor-max
))
2605 ((eq divisor-sign
'+)
2606 ;; The divisor is positive. Therefore, the number will just
2607 ;; become closer to zero.
2608 `(integer ,(if number-low
2609 (truncate number-low divisor-min
)
2612 (truncate number-high divisor-min
)
2614 ((eq divisor-sign
'-
)
2615 ;; The divisor is negative. Therefore, the absolute value of
2616 ;; the number will become closer to zero, but the sign will also
2618 `(integer ,(if number-high
2619 (- (truncate number-high divisor-min
))
2622 (- (truncate number-low divisor-min
))
2624 ;; The divisor could be either positive or negative.
2626 ;; The number we are dividing has a bound. Divide that by the
2627 ;; smallest posible divisor.
2628 (let ((bound (truncate number-max divisor-min
)))
2629 `(integer ,(- bound
) ,bound
)))
2631 ;; The number we are dividing is unbounded, so we can't tell
2632 ;; anything about the result.
2635 (defun random-derive-type-aux (type)
2636 (let ((class (numeric-type-class type
))
2637 (high (numeric-type-high type
))
2638 (format (numeric-type-format type
)))
2642 :low
(coerce 0 (or format class
'real
))
2643 :high
(cond ((not high
) nil
)
2644 ((eq class
'integer
) (max (1- high
) 0))
2645 ((or (consp high
) (zerop high
)) high
)
2648 (defoptimizer (random derive-type
) ((bound &optional state
))
2649 (one-arg-derive-type bound
#'random-derive-type-aux nil
))
2651 ;;;; miscellaneous derive-type methods
2653 (defoptimizer (integer-length derive-type
) ((x))
2654 (one-arg-derive-type
2657 ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2658 ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically. Be
2659 ;; careful about LO or HI being NIL, though. Also, if 0 is
2660 ;; contained in X, the lower bound is obviously 0.
2661 (flet ((min-il (a b
)
2662 (min (integer-length a
)
2663 (integer-length b
)))
2665 (max (integer-length a
)
2666 (integer-length b
))))
2667 (let ((lo (numeric-type-low x-type
))
2668 (hi (numeric-type-high x-type
)))
2670 (specifier-type `(integer ,(if (<= lo
0 hi
)
2676 (specifier-type `(integer ,(integer-length lo
)))))
2679 (specifier-type `(integer ,(integer-length hi
)))))))))
2682 (defoptimizer (logcount derive-type
) ((x))
2683 (one-arg-derive-type
2686 (let ((lo (numeric-type-low x-type
))
2687 (hi (numeric-type-high x-type
)))
2690 (make-numeric-type :class
'integer
2696 (psetf lo
(lognot hi
)
2698 (= (integer-length lo
)
2699 (integer-length hi
)))
2700 ;; Count the bits that are always the same
2701 (let ((first-diff (integer-length (logxor lo hi
))))
2703 adjust
(logcount (ash lo
(- first-diff
)))
2704 lo
(ldb (byte first-diff
0) lo
)
2705 hi
(ldb (byte first-diff
0) hi
))
2715 (let ((l (max (integer-length lo
)
2716 (integer-length hi
))))
2719 ;; Only one number can have all the bits turned on
2720 (if (or (= hi
(1- (ash 1 l
)))
2726 (specifier-type `(integer 1))))
2729 (specifier-type `(integer 1)))))))
2732 (defoptimizer (isqrt derive-type
) ((x))
2733 (one-arg-derive-type
2736 (let* ((lo (numeric-type-low x-type
))
2737 (hi (numeric-type-high x-type
))
2738 (lo-res (if (typep lo
'unsigned-byte
)
2741 (hi-res (if (typep hi
'unsigned-byte
)
2744 (specifier-type `(integer ,lo-res
,hi-res
))))
2747 (defoptimizer (char-code derive-type
) ((char))
2748 (let ((type (type-intersection (lvar-type char
) (specifier-type 'character
))))
2749 (cond ((member-type-p type
)
2752 ,@(loop for member in
(member-type-members type
)
2753 when
(characterp member
)
2754 collect
(char-code member
)))))
2755 ((sb-kernel::character-set-type-p type
)
2758 ,@(loop for
(low . high
)
2759 in
(character-set-type-pairs type
)
2760 collect
`(integer ,low
,high
)))))
2761 ((csubtypep type
(specifier-type 'base-char
))
2763 `(mod ,base-char-code-limit
)))
2766 `(mod ,char-code-limit
))))))
2768 (defoptimizer (code-char derive-type
) ((code))
2769 (one-arg-derive-type code
2771 (let* ((lo (numeric-type-low type
))
2772 (hi (numeric-type-high type
))
2773 (type (specifier-type `(character-set ((,lo .
,hi
))))))
2775 ;; KLUDGE: when running on the host, we lose a slight amount
2776 ;; of precision so that we don't have to "unparse" types
2777 ;; that formally we can't, such as (CHARACTER-SET ((0
2778 ;; . 0))). -- CSR, 2004-10-06
2780 ((csubtypep type
(specifier-type 'standard-char
)) type
)
2782 ((csubtypep type
(specifier-type 'base-char
))
2783 (specifier-type 'base-char
))
2785 ((csubtypep type
(specifier-type 'extended-char
))
2786 (specifier-type 'extended-char
))
2787 (t #+sb-xc-host
(specifier-type 'character
)
2788 #-sb-xc-host type
))))
2791 (deftransform code-char
((code))
2792 (splice-fun-args code
'char-code
1)
2795 (deftransform char-code
((char))
2796 (splice-fun-args char
'code-char
1)
2799 (deftransform digit-char
((code &optional radix
) ((integer 0 9) t
))
2801 (interval-< (type-approximate-interval (lvar-type code
))
2802 (type-approximate-interval (lvar-type radix
))))
2803 `(code-char (+ code
#.
(char-code #\
0)))
2804 (give-up-ir1-transform)))
2806 (defoptimizer (digit-char-p derive-type
) ((code &optional radix
))
2808 (let ((max (type-approximate-interval (lvar-type radix
))))
2809 (when (interval-high max
)
2810 (specifier-type `(or null
(mod ,(interval-high max
))))))
2811 (specifier-type '(or null
(mod 10)))))
2813 (defoptimizer (values derive-type
) ((&rest values
))
2814 (make-values-type (mapcar #'lvar-type values
)))
2816 (deftransform digit-char-p
((char &optional
(radix 10))
2818 #+(and (not sb-xc-host
) sb-unicode
) (character-set ((0 .
1632))))
2819 &optional
(integer 2 10))
2822 `(let ((digit (- (char-code char
) (char-code #\
0))))
2823 (if (< -
1 digit radix
)
2826 (deftransform digit-char-p
((char radix
)
2828 #+(and (not sb-xc-host
) sb-unicode
) (character-set ((0 .
1632))))
2829 (constant-arg (integer 11)))
2832 `(let* ((code (char-code char
))
2833 (digit (- code
(char-code #\
0))))
2836 (let ((weight (- (logior #x20 code
) ;; downcase
2838 (if (< -
1 weight
(- radix
10))
2841 (defun character-set-range (lvar)
2842 (if (constant-lvar-p lvar
)
2843 (let ((code (char-code (lvar-value lvar
))))
2845 (let ((type (lvar-type lvar
)))
2846 (if (typep type
'character-set-type
)
2847 (loop for
(lo . hi
) in
(character-set-type-pairs type
)
2848 minimize lo into min
2849 maximize hi into max
2850 finally
(return (values min max
)))
2851 (values 0 (1- char-code-limit
))))))
2853 (defun char<-constraints
(char1 char2
)
2854 (multiple-value-bind (min2 max2
) (character-set-range char2
)
2855 (values (list 'typep char1
(if (zerop max2
)
2857 (specifier-type `(character-set ((0 .
,(1- max2
)))))))
2858 (list 'typep char1
(specifier-type `(character-set ((,min2 .
#.
(1- char-code-limit
)))))))))
2860 (defun char>-constraints
(char1 char2
)
2861 (multiple-value-bind (min2 max2
) (character-set-range char2
)
2862 (values (list 'typep char1
(if (= min2
(1- char-code-limit
))
2864 (specifier-type `(character-set ((,(1+ min2
) .
#.
(1- char-code-limit
)))))))
2865 (list 'typep char1
(specifier-type `(character-set ((0 .
,max2
))))))))
2867 (defoptimizer (char< constraint-propagate-if
)
2869 (multiple-value-bind (if1 then1
)
2870 (char<-constraints char1 char2
)
2871 (multiple-value-bind (if2 then2
)
2872 (char>-constraints char2 char1
)
2873 (values nil nil
(list if1 if2
) (list then1 then2
)))))
2875 (defoptimizer (char> constraint-propagate-if
)
2877 (multiple-value-bind (if1 then1
)
2878 (char>-constraints char1 char2
)
2879 (multiple-value-bind (if2 then2
)
2880 (char<-constraints char2 char1
)
2881 (values nil nil
(list if1 if2
) (list then1 then2
)))))
2883 (defun signum-derive-type-aux (type)
2884 (cond ((eq type
(specifier-type 'ratio
))
2885 (specifier-type '(or (eql 1) (eql -
1))))
2886 ((eq (numeric-type-complexp type
) :complex
)
2887 (let* ((format (case (numeric-type-class type
)
2888 ((integer rational
) 'single-float
)
2889 (t (numeric-type-format type
))))
2890 (bound-format (or format
'float
)))
2891 (make-numeric-type :class
'float
2894 :low
(coerce -
1 bound-format
)
2895 :high
(coerce 1 bound-format
))))
2897 (let* ((interval (numeric-type->interval type
))
2898 (range-info (interval-range-info interval
))
2899 (contains-0-p (interval-contains-p 0 interval
))
2900 (class (numeric-type-class type
))
2901 (format (numeric-type-format type
))
2902 (one (coerce 1 (or format class
'real
)))
2903 (zero (coerce 0 (or format class
'real
)))
2904 (minus-one (coerce -
1 (or format class
'real
)))
2905 (plus (make-numeric-type :class class
:format format
2906 :low one
:high one
))
2907 (minus (make-numeric-type :class class
:format format
2908 :low minus-one
:high minus-one
))
2909 ;; KLUDGE: here we have a fairly horrible hack to deal
2910 ;; with the schizophrenia in the type derivation engine.
2911 ;; The problem is that the type derivers reinterpret
2912 ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
2913 ;; 0d0) within the derivation mechanism doesn't include
2914 ;; -0d0. Ugh. So force it in here, instead.
2915 (zero (make-numeric-type :class class
:format format
2916 :low
(sb-xc:- zero
) :high zero
)))
2919 (+ (if contains-0-p
(type-union plus zero
) plus
))
2920 (- (if contains-0-p
(type-union minus zero
) minus
))
2921 (t (type-union minus zero plus
)))))
2922 (if (eq (numeric-type-complexp type
) :real
)
2924 (type-union result
(make-numeric-type :class
'float
2929 (defoptimizer (signum derive-type
) ((num))
2930 (one-arg-derive-type num
#'signum-derive-type-aux nil
))
2932 ;;;; byte operations
2934 ;;;; We try to turn byte operations into simple logical operations.
2935 ;;;; First, we convert byte specifiers into separate size and position
2936 ;;;; arguments passed to internal %FOO functions. We then attempt to
2937 ;;;; transform the %FOO functions into boolean operations when the
2938 ;;;; size and position are constant and the operands are fixnums.
2939 ;;;; The goal of the source-transform is to avoid consing a byte specifier
2940 ;;;; to immediately throw away. A more powerful framework could recognize
2941 ;;;; in IR1 when a constructor call flows to one or more accessors for the
2942 ;;;; constructed object and nowhere else (no mutators). If so, forwarding
2943 ;;;; the constructor arguments to their reads would generally solve this.
2944 ;;;; A transform approximates that, but fails when BYTE is produced by an
2945 ;;;; inline function and not a macro.
2946 (flet ((xform (bytespec-form env int fun
&optional
(new nil setter-p
))
2947 (let ((spec (handler-case (%macroexpand bytespec-form env
)
2949 (return-from xform
(values nil t
))))))
2950 (if (and (consp spec
) (eq (car spec
) 'byte
))
2951 (if (proper-list-of-length-p (cdr spec
) 2)
2952 (values `(,fun
,@(if setter-p
(list new
))
2953 ,(second spec
) ,(third spec
) ,int
) nil
)
2954 ;; No point in compiling calls to BYTE-{SIZE,POSITION}
2955 (values nil t
)) ; T => "pass" (meaning "fail")
2956 (let ((new-temp (if setter-p
(copy-symbol 'new
)))
2957 (byte (copy-symbol 'byte
)))
2958 (values `(let (,@(if new-temp
`((,new-temp
,new
)))
2960 (,fun
,@(if setter-p
(list new-temp
))
2961 (byte-size ,byte
) (byte-position ,byte
) ,int
))
2964 ;; DEFINE-SOURCE-TRANSFORM has no compile-time effect, so it's fine that
2965 ;; these 4 things are non-toplevel. (xform does not need to be a macro)
2966 (define-source-transform ldb
(spec int
&environment env
)
2967 (xform spec env int
'%ldb
))
2969 (define-source-transform dpb
(newbyte spec int
&environment env
)
2970 (xform spec env int
'%dpb newbyte
))
2972 (define-source-transform mask-field
(spec int
&environment env
)
2973 (xform spec env int
'%mask-field
))
2975 (define-source-transform deposit-field
(newbyte spec int
&environment env
)
2976 (xform spec env int
'%deposit-field newbyte
)))
2978 (defoptimizer (%ldb derive-type
) ((size posn num
))
2979 ;; (logand (ash num (- posn)) (lognot (ash -1 size)))
2980 (let* ((shifted (two-arg-derive-type num posn
2981 (lambda (num posn same
)
2982 (declare (ignore same
))
2983 (ash-derive-type-aux num
(%negate-derive-type-aux posn
) nil
))
2985 (ash num
(- posn
)))))
2986 (minus-one (specifier-type '(eql -
1)))
2987 (mask (one-arg-derive-type size
2989 (lognot-derive-type-aux
2990 (ash-derive-type-aux minus-one x nil
)))
2992 (lognot (ash -
1 x
))))))
2993 (when (and shifted mask
)
2994 (%two-arg-derive-type shifted mask
#'logand-derive-type-aux
#'logand
))))
2996 (defoptimizer (%mask-field derive-type
) ((size posn num
))
2997 (let ((size-high (nth-value 1 (integer-type-numeric-bounds (lvar-type size
))))
2998 (posn-high (nth-value 1 (integer-type-numeric-bounds (lvar-type posn
)))))
2999 (if (and size-high posn-high
3000 (<= (+ size-high posn-high
) sb-vm
:n-word-bits
))
3001 (specifier-type `(unsigned-byte* ,(+ size-high posn-high
)))
3002 (specifier-type 'unsigned-byte
))))
3004 (defoptimizer (%dpb derive-type
) ((newbyte size posn int
))
3005 ;; (let ((mask (lognot (ash -1 size))))
3006 ;; (logior (ash (logand newbyte mask) posn)
3007 ;; (logandc2 int (ash mask posn))))
3009 (let* ((minus-one (specifier-type '(eql -
1)))
3011 (or (one-arg-derive-type size
3013 (lognot-derive-type-aux
3014 (ash-derive-type-aux minus-one x nil
)))
3016 (lognot (ash -
1 x
))))
3019 (or (%two-arg-derive-type mask
(lvar-type posn
)
3020 #'ash-derive-type-aux
#'ash
)
3023 (or (%two-arg-derive-type
(lvar-type int
) mask-shifted
3024 (lambda (int mask same
)
3025 (declare (ignore same
))
3026 (%two-arg-derive-type
3028 (lognot-derive-type-aux mask
)
3029 #'logand-derive-type-aux
3032 (logandc2 int mask
)))
3034 (new-masked (or (%two-arg-derive-type mask
(lvar-type newbyte
)
3035 #'logand-derive-type-aux
#'logand
)
3038 (or (%two-arg-derive-type new-masked
(lvar-type posn
)
3039 #'ash-derive-type-aux
#'ash
)
3041 (%two-arg-derive-type int new
#'logior-derive-type-aux
#'logior
))))
3043 (defoptimizer (%deposit-field derive-type
) ((newbyte size posn int
))
3044 ;; (let ((mask (ash (lognot (ash -1 size)) posn)))
3045 ;; (logior (logand newbyte mask)
3046 ;; (logandc2 int mask)))
3048 (let* ((minus-one (specifier-type '(eql -
1)))
3050 (or (two-arg-derive-type size posn
3051 (lambda (size posn same
)
3052 (declare (ignore same
))
3053 (ash-derive-type-aux
3054 (lognot-derive-type-aux
3055 (ash-derive-type-aux minus-one size nil
))
3058 (lognot (ash -
1 x
))))
3061 (or (%two-arg-derive-type
(lvar-type int
) mask
3062 (lambda (int mask same
)
3063 (declare (ignore same
))
3064 (%two-arg-derive-type
3066 (lognot-derive-type-aux mask
)
3067 #'logand-derive-type-aux
3070 (logandc2 int mask
)))
3072 (new (or (%two-arg-derive-type mask
(lvar-type newbyte
)
3073 #'logand-derive-type-aux
#'logand
)
3075 (%two-arg-derive-type int new
#'logior-derive-type-aux
#'logior
))))
3077 (deftransform %ldb
((size posn int
) (fixnum fixnum integer
) word
:node node
)
3078 "convert to inline logical operations"
3079 (let ((width (and (constant-lvar-p size
)
3080 (constant-lvar-p posn
)
3081 (+ (lvar-value size
) (lvar-value posn
))))
3082 (size-max (nth-value 1 (integer-type-numeric-bounds (lvar-type size
)))))
3084 (<= width sb-vm
:n-fixnum-bits
))
3085 (let ((size (lvar-value size
))
3086 (posn (lvar-value posn
)))
3087 `(logand (ash (mask-signed-field ,sb-vm
:n-fixnum-bits int
) ,(- posn
))
3088 ,(ash most-positive-word
(- size sb-vm
:n-word-bits
)))))
3090 (<= width sb-vm
:n-word-bits
))
3091 (let ((size (lvar-value size
))
3092 (posn (lvar-value posn
)))
3093 `(logand (ash (logand int
,most-positive-word
) ,(- posn
))
3094 ,(ash most-positive-word
(- size sb-vm
:n-word-bits
)))))
3095 ((let* ((posn-max (nth-value 1 (integer-type-numeric-bounds (lvar-type posn
))))
3096 (width (and size-max posn-max
3097 (+ size-max posn-max
))))
3098 (cond ((not width
) nil
)
3099 ((<= width sb-vm
:n-fixnum-bits
)
3100 `(logandc2 (ash (mask-signed-field sb-vm
:n-fixnum-bits int
) (- posn
))
3102 ((<= width sb-vm
:n-word-bits
)
3103 `(logandc2 (ash (logand int most-positive-word
) (- posn
))
3105 ((not (or (csubtypep (lvar-type int
) (specifier-type 'sb-vm
:signed-word
))
3106 (csubtypep (lvar-type int
) (specifier-type 'word
))))
3107 (delay-ir1-transform node
:ir1-phases
)
3108 (give-up-ir1-transform "not a word-sized integer"))
3110 `(logandc2 (ash int
(- posn
))
3113 (deftransform %mask-field
((size posn int
) ((integer 0 #.sb-vm
:n-word-bits
) fixnum integer
) word
)
3114 "convert to inline logical operations"
3115 `(logand int
(ash (ash ,most-positive-word
(- size
,sb-vm
:n-word-bits
)) posn
)))
3117 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
3118 ;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
3119 ;;; as the result type, as that would allow result types that cover
3120 ;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
3121 ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
3123 (deftransform %dpb
((new size posn int
) ((constant-arg integer
) (constant-arg integer
) t t
) * :important nil
)
3124 (let* ((new (lvar-value new
))
3125 (size (lvar-value size
))
3126 (cut (ldb (byte size
0) new
)))
3128 `(%dpb
,cut
,size posn int
))
3129 ((not (csubtypep (lvar-type posn
) (specifier-type `(integer 0 (,(- sb-vm
:n-fixnum-bits size
))))))
3130 (give-up-ir1-transform))
3131 ((= (logcount new
) size
)
3132 (let ((uses (lvar-uses int
)))
3133 ;; Move the cast after the ash for cast-externally-checkable-p to work.
3135 (delete-cast uses
)))
3136 `(logior (ash new posn
)
3139 (let ((uses (lvar-uses int
)))
3141 (delete-cast uses
)))
3143 (ash (ldb (byte size
0) -
1) posn
)))
3146 (give-up-ir1-transform)))))
3148 (deftransform %dpb
((new size posn int
) (:or
(* word
)
3149 (* sb-vm
:signed-word
)) * :node node
)
3150 "convert to inline logical operations"
3151 (delay-ir1-transform node
:ir1-phases
)
3152 (or (and (constant-lvar-p size
)
3153 (constant-lvar-p new
)
3154 (let* ((size (lvar-value size
))
3155 (new (ldb (byte size
0) (lvar-value new
))))
3158 (ash (ldb (byte size
0) -
1) posn
)))
3159 ((= (logcount new
) size
)
3162 `(let ((mask (ldb (byte size
0) -
1)))
3163 (logior (ash (logand new mask
) posn
)
3164 (logandc2 int
(ash mask posn
))))))
3166 (deftransform %deposit-field
((new size posn int
) (:or
(* word
)
3167 (* sb-vm
:signed-word
)))
3168 "convert to inline logical operations"
3169 `(let ((mask (ash (ldb (byte size
0) -
1) posn
)))
3170 (logior (logand new mask
)
3171 (logand int
(lognot mask
)))))
3173 (defoptimizer (mask-signed-field derive-type
) ((size x
))
3174 (let ((size (lvar-type size
)))
3175 (if (numeric-type-p size
)
3176 (let ((size-high (numeric-type-high size
)))
3177 (if (and size-high
(<= 1 size-high sb-vm
:n-word-bits
))
3178 (specifier-type `(signed-byte ,size-high
))
3184 (when-vop-existsp (:translate sb-kernel
:%ash
/right
)
3185 (defun %ash
/right
(integer amount
)
3186 (ash integer
(- amount
)))
3188 (deftransform ash
((integer amount
) (sb-vm:signed-word
(integer * 0)) *
3190 "Convert ASH of signed word to %ASH/RIGHT"
3191 (when (constant-lvar-p amount
)
3192 (give-up-ir1-transform))
3193 (let ((use (lvar-uses amount
)))
3194 (cond ((and (combination-p use
)
3195 (eql '%negate
(lvar-fun-name (combination-fun use
))))
3196 (splice-fun-args amount
'%negate
1)
3197 `(lambda (integer amount
)
3198 (declare (type unsigned-byte amount
))
3199 (%ash
/right integer
(if (>= amount
,sb-vm
:n-word-bits
)
3200 ,(1- sb-vm
:n-word-bits
)
3203 `(%ash
/right integer
(if (<= amount
,(- sb-vm
:n-word-bits
))
3204 ,(1- sb-vm
:n-word-bits
)
3207 (deftransform ash
((integer amount
) (word (integer * 0)) *
3209 "Convert ASH of word to %ASH/RIGHT"
3210 (when (constant-lvar-p amount
)
3211 (give-up-ir1-transform))
3212 (let ((use (lvar-uses amount
)))
3213 (cond ((and (combination-p use
)
3214 (eql '%negate
(lvar-fun-name (combination-fun use
))))
3215 (splice-fun-args amount
'%negate
1)
3216 `(lambda (integer amount
)
3217 (declare (type unsigned-byte amount
))
3218 (if (>= amount
,sb-vm
:n-word-bits
)
3220 (%ash
/right integer amount
))))
3222 `(if (<= amount
,(- sb-vm
:n-word-bits
))
3224 (%ash
/right integer
(- amount
)))))))
3226 (deftransform %ash
/right
((integer amount
) (integer (constant-arg unsigned-byte
)))
3227 "Convert %ASH/RIGHT by constant back to ASH"
3228 `(ash integer
,(- (lvar-value amount
))))
3230 (deftransform %ash
/right
((integer amount
) * * :node node
)
3231 "strength reduce large variable right shift"
3232 (let ((return-type (single-value-type (node-derived-type node
))))
3233 (cond ((type= return-type
(specifier-type '(eql 0)))
3235 ((type= return-type
(specifier-type '(eql -
1)))
3237 ((csubtypep return-type
(specifier-type '(member -
1 0)))
3238 `(ash integer
,(- sb-vm
:n-word-bits
)))
3240 (give-up-ir1-transform)))))
3242 (defun %ash
/right-derive-type-aux
(n-type shift same-arg
)
3243 (declare (ignore same-arg
))
3244 (or (and (or (csubtypep n-type
(specifier-type 'sb-vm
:signed-word
))
3245 (csubtypep n-type
(specifier-type 'word
)))
3246 (csubtypep shift
(specifier-type `(mod ,sb-vm
:n-word-bits
)))
3247 (let ((n-low (numeric-type-low n-type
))
3248 (n-high (numeric-type-high n-type
))
3249 (s-low (numeric-type-low shift
))
3250 (s-high (numeric-type-high shift
)))
3251 (make-numeric-type :class
'integer
:complexp
:real
3254 (ash n-low
(- s-low
))
3255 (ash n-low
(- s-high
))))
3258 (ash n-high
(- s-high
))
3259 (ash n-high
(- s-low
)))))))
3262 (defoptimizer (%ash
/right derive-type
) ((n shift
))
3263 (two-arg-derive-type n shift
#'%ash
/right-derive-type-aux
#'%ash
/right
)))
3265 (defmacro combination-typed-p
(node name
&rest types
)
3266 (labels ((gen (type)
3269 `(or ,@(loop for type in
(cdr type
)
3273 `(and ,@(loop for type in
(cdr type
)
3277 `(not ,(gen (cadr type
))))
3279 `(csubtypep (lvar-type arg
) (specifier-type ',type
))))))
3280 `(and (combination-p ,node
)
3281 (eql (lvar-fun-name (combination-fun ,node
)) ',name
)
3282 (let ((args (combination-args ,node
)))
3283 ,@(loop for type in types
3285 `(let ((arg (pop args
)))
3289 (when-vop-existsp (:translate ash-inverted
)
3290 (defun ash-inverted (integer amount
)
3291 (ash integer
(- amount
)))
3293 (deftransform ash
((integer amount
) (word t
) *
3294 :important nil
:node node
)
3295 (when (constant-lvar-p amount
)
3296 (give-up-ir1-transform))
3297 (delay-ir1-transform node
:ir1-phases
)
3298 (let ((use (lvar-uses amount
))
3299 (result-type (single-value-type (node-derived-type node
)))
3300 (dest (node-dest node
))
3302 (unless (csubtypep result-type
(specifier-type 'word
))
3303 (cond ((or (combination-typed-p dest mask-signed-field
(eql #.
(1- sb-vm
:n-word-bits
)))
3304 (combination-typed-p dest logand t word
))
3305 (setf truly-type t
))
3307 (give-up-ir1-transform))))
3308 (cond ((combination-typed-p use %negate
(:and
(:not
(integer * 0))
3310 sb-vm
:signed-word
)))
3311 (splice-fun-args amount
'%negate
1)
3313 `(truly-the word
(ash-inverted integer amount
))
3314 `(ash-inverted integer amount
)))
3316 (give-up-ir1-transform)))))
3318 (deftransform ash
((integer amount
) (sb-vm:signed-word t
) *
3319 :important nil
:node node
)
3320 (when (constant-lvar-p amount
)
3321 (give-up-ir1-transform))
3322 (delay-ir1-transform node
:ir1-phases
)
3323 (let ((use (lvar-uses amount
))
3324 (result-type (single-value-type (node-derived-type node
)))
3325 (dest (node-dest node
))
3327 (unless (csubtypep result-type
(specifier-type 'sb-vm
:signed-word
))
3328 (cond ((or (combination-typed-p dest mask-signed-field
(eql #.
(1- sb-vm
:n-word-bits
)))
3329 (combination-typed-p dest logand t word
))
3330 (setf truly-type t
))
3332 (give-up-ir1-transform))))
3333 (cond ((combination-typed-p use %negate
(:and
(:not
(integer * 0))
3335 sb-vm
:signed-word
)))
3336 (splice-fun-args amount
'%negate
1)
3338 `(truly-the sb-vm
:signed-word
(ash-inverted integer amount
))
3339 `(ash-inverted integer amount
)))
3341 (give-up-ir1-transform))))))
3343 ;;; Not declaring it as actually being RATIO because it is used as one
3344 ;;; of the legs in the EXPT transform below and that may result in
3345 ;;; some unwanted type conflicts, e.g. (random (expt 2 (the integer y)))
3346 (declaim (ftype (sfunction (integer) rational
) reciprocate
))
3347 (defun reciprocate (x)
3348 (declare (optimize (safety 0)))
3349 #+sb-xc-host
(error "Can't call reciprocate ~D" x
)
3350 #-sb-xc-host
(%make-ratio
1 x
))
3352 (deftransform expt
((base power
) ((constant-arg unsigned-byte
) integer
))
3353 (let ((base (lvar-value base
)))
3354 (cond ((/= (logcount base
) 1)
3355 (give-up-ir1-transform))
3359 `(let ((%denominator
(ash 1 ,(if (= base
2)
3361 `(* (abs power
) ,(1- (integer-length base
)))))))
3363 (reciprocate %denominator
)
3366 (deftransform expt
((base power
) ((constant-arg unsigned-byte
) unsigned-byte
))
3367 (let ((base (lvar-value base
)))
3368 (unless (= (logcount base
) 1)
3369 (give-up-ir1-transform))
3370 `(ash 1 ,(if (= base
2)
3372 `(* power
,(1- (integer-length base
)))))))
3374 (defun integer-type-numeric-bounds (type)
3376 ;; KLUDGE: this is not INTEGER-type-numeric-bounds
3377 (numeric-type (values (numeric-type-low type
)
3378 (numeric-type-high type
)))
3382 (dolist (type (union-type-types type
) (values low high
))
3383 (unless (and (numeric-type-p type
)
3384 (eql (numeric-type-class type
) 'integer
))
3385 (return (values nil nil
)))
3386 (let ((this-low (numeric-type-low type
))
3387 (this-high (numeric-type-high type
)))
3388 (unless (and this-low this-high
)
3389 (return (values nil nil
)))
3390 (setf low
(min this-low
(or low this-low
))
3391 high
(max this-high
(or high this-high
)))))))))
3393 ;;; Handle the case of a constant BOOLE-CODE.
3394 (deftransform boole
((op x y
) * *)
3395 "convert to inline logical operations"
3396 (unless (constant-lvar-p op
)
3397 (give-up-ir1-transform "BOOLE code is not a constant."))
3398 (let ((control (lvar-value op
)))
3404 (#.boole-c1
'(lognot x
))
3405 (#.boole-c2
'(lognot y
))
3406 (#.boole-and
'(logand x y
))
3407 (#.boole-ior
'(logior x y
))
3408 (#.boole-xor
'(logxor x y
))
3409 (#.boole-eqv
'(logeqv x y
))
3410 (#.boole-nand
'(lognand x y
))
3411 (#.boole-nor
'(lognor x y
))
3412 (#.boole-andc1
'(logandc1 x y
))
3413 (#.boole-andc2
'(logandc2 x y
))
3414 (#.boole-orc1
'(logorc1 x y
))
3415 (#.boole-orc2
'(logorc2 x y
))
3417 (abort-ir1-transform "~S is an illegal control arg to BOOLE."
3420 ;;;; converting special case multiply/divide to shifts
3422 ;;; If arg is a constant power of two, turn * into a shift.
3423 (deftransform * ((x y
) (integer (constant-arg unsigned-byte
)) * :node node
)
3424 "convert x*2^k to shift"
3425 ;; Delay to make sure the surrounding casts are apparent.
3426 (delay-ir1-transform node
:ir1-phases
)
3427 (let* ((type (single-value-type (node-asserted-type node
)))
3429 (len (1- (integer-length y
))))
3430 (unless (or (not (csubtypep (lvar-type x
) (specifier-type '(or word sb-vm
:signed-word
))))
3431 (csubtypep type
(specifier-type 'word
))
3432 (csubtypep type
(specifier-type 'sb-vm
:signed-word
))
3433 (>= len sb-vm
:n-word-bits
))
3434 (give-up-ir1-transform))
3435 (unless (= y
(ash 1 len
))
3436 (give-up-ir1-transform))
3439 ;;; * deals better with ASH that overflows
3440 (deftransform ash
((integer amount
) ((or word sb-vm
:signed-word
)
3441 (constant-arg (integer 1 *))) *
3444 ;; Give modular arithmetic optimizers a chance
3445 (delay-ir1-transform node
:ir1-phases
)
3446 (let ((type (single-value-type (node-asserted-type node
)))
3447 (shift (lvar-value amount
)))
3448 (when (or (csubtypep type
(specifier-type 'word
))
3449 (csubtypep type
(specifier-type 'sb-vm
:signed-word
))
3450 (>= shift sb-vm
:n-word-bits
))
3451 (give-up-ir1-transform))
3452 `(* integer
,(ash 1 shift
))))
3454 (defun cast-or-check-bound-type (node &optional fixnum
)
3455 (multiple-value-bind (dest lvar
) (immediately-used-let-dest (node-lvar node
) node t
)
3456 (cond ((cast-p dest
)
3457 (and (cast-type-check dest
)
3458 (single-value-type (cast-type-to-check dest
))))
3459 ((and (combination-p dest
)
3460 (equal (combination-fun-debug-name dest
) '(transform-for check-bound
))
3461 (eq (third (combination-args dest
)) lvar
))
3463 (specifier-type 'index
)
3464 (specifier-type 'sb-vm
:signed-word
))))))
3466 (defun overflow-transform (name x y node
&optional
(swap t
))
3467 (unless (node-lvar node
)
3468 (give-up-ir1-transform))
3469 (delay-ir1-transform node
:ir1-phases
)
3470 (let ((type (single-value-type (node-derived-type node
))))
3471 (when (or (csubtypep type
(specifier-type 'word
))
3472 (csubtypep type
(specifier-type 'sb-vm
:signed-word
)))
3473 (give-up-ir1-transform))
3474 (unless (and (or (csubtypep (lvar-type x
) (specifier-type 'word
))
3475 (csubtypep (lvar-type x
) (specifier-type 'sb-vm
:signed-word
)))
3476 (or (csubtypep (lvar-type y
) (specifier-type 'word
))
3477 (csubtypep (lvar-type y
) (specifier-type 'sb-vm
:signed-word
))))
3478 (give-up-ir1-transform))
3479 (let* ((vops (fun-info-templates (fun-info-or-lose name
)))
3480 (cast (or (cast-or-check-bound-type node
)
3481 (give-up-ir1-transform)))
3482 (result-type (type-intersection type cast
)))
3483 (when (eq result-type
*empty-type
*)
3484 (give-up-ir1-transform))
3485 (flet ((subp (lvar type
)
3487 ((not (constant-type-p type
))
3488 (csubtypep (lvar-type lvar
) type
))
3489 ((not (constant-lvar-p lvar
))
3492 (let ((value (lvar-value lvar
))
3493 (type (type-specifier (constant-type-type type
))))
3494 (if (typep type
'(cons (eql satisfies
)))
3495 (funcall (second type
) value
)
3496 (sb-xc:typep value type
)))))))
3499 for
(x-type y-type
) = (fun-type-required (vop-info-type vop
))
3500 when
(and (csubtypep result-type
(single-value-type (fun-type-returns (vop-info-type vop
))))
3501 (neq x-type
*universal-type
*)
3502 (neq y-type
*universal-type
*)
3503 (or (and (subp x x-type
)
3509 return
`(%primitive
,(vop-info-name vop
)
3513 ',(type-specifier cast
))
3514 finally
(give-up-ir1-transform))))))
3516 (deftransform * ((x y
) ((or word sb-vm
:signed-word
) (or word sb-vm
:signed-word
))
3517 * :node node
:important nil
)
3518 (overflow-transform 'overflow
* x y node
))
3520 (deftransform + ((x y
) ((or word sb-vm
:signed-word
) (or word sb-vm
:signed-word
))
3521 * :node node
:important nil
)
3522 (overflow-transform 'overflow
+ x y node
))
3524 (deftransform -
((x y
) ((or word sb-vm
:signed-word
) (or word sb-vm
:signed-word
))
3525 * :node node
:important nil
)
3526 (overflow-transform 'overflow- x y node nil
))
3528 (deftransform ash
((x y
) ((or word sb-vm
:signed-word
) (or word sb-vm
:signed-word
))
3529 * :node node
:important nil
)
3530 (overflow-transform 'overflow-ash x y node nil
))
3532 (defun overflow-transform-unknown-x (name x y node
&optional swap
)
3533 (unless (node-lvar node
)
3534 (give-up-ir1-transform))
3535 (delay-ir1-transform node
:ir1-phases
)
3536 (let ((type (single-value-type (node-derived-type node
)))
3537 (x-type (lvar-type x
))
3538 (y-type (lvar-type y
)))
3539 (when (or (csubtypep type
(specifier-type 'word
))
3540 (csubtypep type
(specifier-type 'sb-vm
:signed-word
))
3543 (csubtypep y-type
(specifier-type 'word
))
3544 (csubtypep y-type
(specifier-type 'sb-vm
:signed-word
)))
3545 (or (csubtypep x-type
(specifier-type 'word
))
3546 (csubtypep x-type
(specifier-type 'sb-vm
:signed-word
)))))
3547 (give-up-ir1-transform))
3548 (let* ((vops (fun-info-templates (fun-info-or-lose name
)))
3549 (cast (or (cast-or-check-bound-type node t
)
3550 (give-up-ir1-transform)))
3551 (result-type (type-intersection type cast
)))
3552 (when (eq result-type
*empty-type
*)
3553 (give-up-ir1-transform))
3554 (multiple-value-bind (cast-low cast-high
) (integer-type-numeric-bounds cast
)
3555 (unless (and (fixnump cast-low
)
3556 (fixnump cast-high
))
3557 (give-up-ir1-transform))
3558 (multiple-value-bind (y-low y-high
) (if swap
3559 (integer-type-numeric-bounds x-type
)
3560 (integer-type-numeric-bounds y-type
))
3561 (unless (and (fixnump y-low
)
3563 (give-up-ir1-transform))
3564 (let ((distance-low (- cast-low
(1- most-negative-fixnum
)))
3565 (distance-high (- cast-high
(1+ most-positive-fixnum
))))
3568 (and (> y-low distance-high
)
3569 (< y-high distance-low
)))
3572 (and (< y-high
(+ (1+ most-positive-fixnum
) cast-low
))
3573 (> y-low
(+ (1- most-negative-fixnum
) cast-high
)))
3574 (and (> (- y-high
) distance-high
)
3575 (< (- y-low
) distance-low
))))
3579 (give-up-ir1-transform)))
3580 (flet ((subp (lvar type
)
3582 ((not (constant-type-p type
))
3583 (csubtypep (lvar-type lvar
) type
))
3584 ((not (constant-lvar-p lvar
))
3587 (let ((value (lvar-value lvar
))
3588 (type (type-specifier (constant-type-type type
))))
3589 (if (typep type
'(cons (eql satisfies
)))
3590 (funcall (second type
) value
)
3591 (sb-xc:typep value type
)))))))
3592 (loop for vop in vops
3593 for
(x-type y-type
) = (fun-type-required (vop-info-type vop
))
3594 when
(and (csubtypep result-type
(single-value-type (fun-type-returns (vop-info-type vop
))))
3596 (eq y-type
*universal-type
*)
3597 (eq x-type
*universal-type
*))
3598 (and (subp x x-type
)
3600 return
`(%primitive
,(vop-info-name vop
)
3602 ',(type-specifier cast
))
3603 finally
(give-up-ir1-transform))))))))
3605 (deftransform + ((x y
) (t (or word sb-vm
:signed-word
))
3606 * :node node
:important nil
)
3607 (overflow-transform-unknown-x 'overflow
+ x y node
))
3609 (deftransform + ((y x
) ((or word sb-vm
:signed-word
) t
)
3610 * :node node
:important nil
)
3611 (overflow-transform-unknown-x 'overflow
+ x y node
))
3613 (deftransform * ((x y
) ((not ratio
) (or word sb-vm
:signed-word
))
3614 * :node node
:important nil
)
3615 (overflow-transform-unknown-x 'overflow
* x y node
))
3617 (deftransform * ((y x
) ((or word sb-vm
:signed-word
) (not ratio
))
3618 * :node node
:important nil
)
3619 (overflow-transform-unknown-x 'overflow
* x y node
))
3621 (deftransform -
((x y
) (t (or word sb-vm
:signed-word
))
3622 * :node node
:important nil
)
3623 (overflow-transform-unknown-x 'overflow- x y node
))
3625 (deftransform -
((x y
) ((or word sb-vm
:signed-word
) t
)
3626 * :node node
:important nil
)
3627 (overflow-transform-unknown-x 'overflow- x y node t
))
3629 (defun overflow-transform-1 (name x node
)
3630 (unless (node-lvar node
)
3631 (give-up-ir1-transform))
3632 (delay-ir1-transform node
:ir1-phases
)
3633 (let ((type (single-value-type (node-derived-type node
))))
3634 (when (or (csubtypep type
(specifier-type 'word
))
3635 (csubtypep type
(specifier-type 'sb-vm
:signed-word
)))
3636 (give-up-ir1-transform))
3637 (unless (and (or (csubtypep (lvar-type x
) (specifier-type 'word
))
3638 (csubtypep (lvar-type x
) (specifier-type 'sb-vm
:signed-word
))))
3639 (give-up-ir1-transform))
3640 (let* ((vops (fun-info-templates (fun-info-or-lose name
)))
3641 (cast (or (cast-or-check-bound-type node
)
3642 (give-up-ir1-transform)))
3643 (result-type (type-intersection type cast
)))
3644 (loop for vop in vops
3645 for
(x-type) = (fun-type-required (vop-info-type vop
))
3646 when
(and (csubtypep result-type
(single-value-type (fun-type-returns (vop-info-type vop
))))
3647 (neq x-type
*universal-type
*)
3648 (csubtypep (lvar-type x
) x-type
))
3649 return
`(%primitive
,(vop-info-name vop
) x
',(type-specifier cast
))
3650 finally
(give-up-ir1-transform)))))
3652 (deftransform %negate
((x) ((or word sb-vm
:signed-word
))
3653 * :node node
:important nil
)
3654 (overflow-transform-1 'overflow-negate x node
))
3656 (defun template-translates (fun-name args result-type
)
3657 (let ((vops (fun-info-templates (fun-info-or-lose fun-name
))))
3658 (flet ((subp (lvar type
)
3660 ((not (constant-type-p type
))
3661 (csubtypep (lvar-type lvar
) type
))
3662 ((not (constant-lvar-p lvar
))
3665 (let ((value (lvar-value lvar
))
3666 (type (type-specifier (constant-type-type type
))))
3667 (if (typep type
'(cons (eql satisfies
)))
3668 (funcall (second type
) value
)
3669 (sb-xc:typep value type
)))))))
3670 (loop for vop in vops
3671 for params
= (fun-type-required (vop-info-type vop
))
3672 thereis
(and (= (length args
)
3674 (csubtypep result-type
(single-value-type (fun-type-returns (vop-info-type vop
))))
3675 (loop for param in params
3677 always
(subp arg param
)))))))
3679 (deftransform floor
((number divisor
) (integer integer
) * :node node
)
3680 (let ((truncate-type (truncate-derive-type-optimizer node
)))
3681 (if (template-translates 'truncate
(combination-args node
) (single-value-type truncate-type
))
3682 `(multiple-value-bind (tru rem
) (truncate number divisor
)
3683 (if (if (minusp divisor
)
3686 (values (1- tru
) (+ rem divisor
))
3688 (give-up-ir1-transform))))
3690 (deftransform ceiling
((number divisor
) (integer integer
) * :node node
)
3691 (let ((truncate-type (truncate-derive-type-optimizer node
)))
3692 (if (template-translates 'truncate
(combination-args node
) (single-value-type truncate-type
))
3693 `(multiple-value-bind (tru rem
) (truncate number divisor
)
3694 (if (if (minusp divisor
)
3697 (values (+ tru
1) (- rem divisor
))
3699 (give-up-ir1-transform))))
3701 (define-source-transform rem
(number divisor
)
3702 `(nth-value 1 (truncate ,number
,divisor
)))
3704 (define-source-transform mod
(number divisor
)
3705 `(nth-value 1 (floor ,number
,divisor
)))
3707 (deftransform ceiling
((number divisor
) ((real (0) (1)) (integer * (0))) * :important nil
)
3709 (deftransform ceiling
((number divisor
) ((real (-1) (0)) (integer (0) *)) * :important nil
)
3712 (deftransform floor
((number divisor
) ((real (-1) (0)) (integer * (0))) * :important nil
)
3714 (deftransform floor
((number divisor
) ((real (0) (1)) (integer (0) *)) * :important nil
)
3717 (deftransform truncate
((number divisor
) ((and (real (-1) (1)) (not (eql $-
0d0
)) (not (eql $-
0f0
)))
3718 (and integer
(not (eql 0))))
3722 ;;; If arg is a constant power of two, turn FLOOR into a shift and
3723 ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
3725 (flet ((frob (y ceil-p
)
3726 (let* ((y (lvar-value y
))
3728 (len (1- (integer-length y-abs
))))
3729 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3730 (give-up-ir1-transform))
3731 (let ((shift (- len
))
3733 (delta (if ceil-p
(* (signum y
) (1- y-abs
)) 0)))
3734 `(let ((x (+ x
,delta
)))
3736 `(values (ash (- x
) ,shift
)
3737 (- (- (logand (- x
) ,mask
)) ,delta
))
3738 `(values (ash x
,shift
)
3739 (- (logand x
,mask
) ,delta
))))))))
3740 (deftransform floor
((x y
) (integer (constant-arg integer
)) *)
3741 "convert division by 2^k to shift"
3743 (deftransform ceiling
((x y
) (integer (constant-arg integer
)) *)
3744 "convert division by 2^k to shift"
3747 ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
3748 (deftransform truncate
((x y
) (integer (constant-arg integer
)) * :result result
:node node
)
3749 "convert division by 2^k to shift"
3750 (let* ((y (lvar-value y
))
3752 (len (1- (integer-length y-abs
))))
3753 (unless (and (> y-abs
0) (= y-abs
(ash 1 len
)))
3754 (give-up-ir1-transform))
3755 (delay-ir1-transform node
:ir1-phases
)
3756 (let* ((rem (mv-bind-dest result
1))
3757 (zerop (combination-matches 'eq
'(* 0) rem
)))
3758 (let ((shift (- len
))
3761 (setf (node-derived-type node
)
3762 (values-specifier-type '(values integer unsigned-byte
&optional
)))
3763 (erase-lvar-type result
)
3765 (values (truncate x y
))
3767 ((when-vop-existsp (:named sb-vm
::truncate
/signed-power-of-two
)
3768 (and (csubtypep (lvar-type x
) (specifier-type 'sb-vm
:signed-word
))
3769 (not (csubtypep (lvar-type x
) (specifier-type 'word
)))))
3770 (give-up-ir1-transform))
3773 (values ,(if (minusp y
)
3775 `(- (ash (- x
) ,shift
)))
3776 (- (logand (- x
) ,mask
)))
3777 (values ,(if (minusp y
)
3780 (logand x
,mask
)))))))))
3782 ;;; Floats could be transformed if we had some declaration to ignore NaNs
3783 (deftransform truncate
((x y
) (rational (or (rational (0) *)
3787 (if (same-leaf-ref-p x y
)
3789 (give-up-ir1-transform)))
3791 (defoptimizer (truncate constraint-propagate
)
3793 (when (csubtypep (lvar-type y
) (specifier-type 'rational
))
3794 (let ((var (ok-lvar-lambda-var y gen
)))
3796 (list (list 'typep var
(specifier-type '(eql 0)) t
))))))
3798 (defoptimizer (/ constraint-propagate
)
3800 (when (csubtypep (lvar-type y
) (specifier-type 'rational
))
3801 (let ((var (ok-lvar-lambda-var y gen
)))
3803 (list (list 'typep var
(specifier-type '(eql 0)) t
))))))
3805 ;;; Return an expression to calculate the integer quotient of X and
3806 ;;; constant Y, using multiplication, shift and add/sub instead of
3807 ;;; division. Both arguments must be unsigned, fit in a machine word and
3808 ;;; Y must neither be zero nor a power of two. The quotient is rounded
3810 ;;; The algorithm is taken from the paper "Division by Invariant
3811 ;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and
3812 ;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the
3813 ;;; case of division by powers of two.
3814 ;;; The algorithm includes an adaptive precision argument. Use it, since
3815 ;;; we often have sub-word value ranges. Careful, in this case, we need
3816 ;;; p s.t 2^p > n, not the ceiling of the binary log.
3817 ;;; Also, for some reason, the paper prefers shifting to masking. Mask
3818 ;;; instead. Masking is equivalent to shifting right, then left again;
3819 ;;; all the intermediate values are still words, so we just have to shift
3820 ;;; right a bit more to compensate, at the end.
3822 ;;; The following two examples show an average case and the worst case
3823 ;;; with respect to the complexity of the generated expression, under
3824 ;;; a word size of 64 bits:
3826 ;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) ->
3827 ;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3)
3829 ;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) ->
3831 ;;; (T1 (%MULTIPLY NUM 2635249153387078803)))
3832 ;;; (ASH (LDB (BYTE 64 0)
3833 ;;; (+ T1 (ASH (LDB (BYTE 64 0)
3838 (defun gen-unsigned-div-by-constant-expr (y max-x
)
3839 (declare (type (integer 3 #.most-positive-word
) y
)
3841 (aver (not (zerop (logand y
(1- y
)))))
3843 ;; the floor of the binary logarithm of (positive) X
3844 (integer-length (1- x
)))
3845 (choose-multiplier (y precision
)
3847 (shift l
(1- shift
))
3848 (expt-2-n+l
(expt 2 (+ sb-vm
:n-word-bits l
)))
3849 (m-low (truncate expt-2-n
+l y
) (ash m-low -
1))
3850 (m-high (truncate (+ expt-2-n
+l
3851 (ash expt-2-n
+l
(- precision
)))
3854 ((not (and (< (ash m-low -
1) (ash m-high -
1))
3856 (values m-high shift
)))))
3857 (let ((n (expt 2 sb-vm
:n-word-bits
))
3858 (precision (integer-length max-x
))
3860 (multiple-value-bind (m shift2
)
3861 (choose-multiplier y precision
)
3862 (when (and (>= m n
) (evenp y
))
3863 (setq shift1
(ld (logand y
(- y
))))
3864 (multiple-value-setq (m shift2
)
3865 (choose-multiplier (/ y
(ash 1 shift1
))
3866 (- precision shift1
))))
3869 `(truly-the word
,x
)))
3871 (t1 (%multiply-high num
,(- m n
))))
3872 (ash ,(word `(+ t1
(ash ,(word `(- num t1
))
3875 ((and (zerop shift1
) (zerop shift2
))
3876 (let ((max (truncate max-x y
)))
3877 ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM
3879 `(truly-the (integer 0 ,max
)
3880 (%multiply-high x
,m
))))
3882 `(ash (%multiply-high
(logandc2 x
,(1- (ash 1 shift1
))) ,m
)
3883 ,(- (+ shift1 shift2
)))))))))
3885 (when-vop-existsp (:translate %signed-multiply-high
)
3886 (defun %signed-multiply-high
(x y
)
3887 (%signed-multiply-high x y
))
3889 (defun gen-signed-truncate-by-constant-expr (y precision
)
3890 (declare (type sb-vm
:signed-word y
)
3891 (type fixnum precision
))
3892 (aver (not (zerop (logand y
(1- y
)))))
3894 ;; the floor of the binary logarithm of (positive) X
3895 (integer-length (1- x
)))
3896 (choose-multiplier (y precision
)
3898 (shift l
(1- shift
))
3899 (expt-2-n+l
(expt 2 (+ sb-vm
:n-word-bits l
)))
3900 (m-low (truncate expt-2-n
+l y
) (ash m-low -
1))
3901 (m-high (truncate (+ expt-2-n
+l
3902 (ash expt-2-n
+l
(- precision
)))
3905 ((not (and (< (ash m-low -
1) (ash m-high -
1))
3907 (values m-high shift
)))))
3908 (let ((n (expt 2 sb-vm
:n-word-bits
))
3909 (n-1 (expt 2 (1- sb-vm
:n-word-bits
))))
3910 (multiple-value-bind (m shift
) (choose-multiplier (abs y
) precision
)
3913 `(ash (%signed-multiply-high x
,m
)
3916 `(ash (truly-the sb-vm
:signed-word
3917 (+ x
(%signed-multiply-high x
,(- m n
))))
3920 `(- (ash x
(- 1 sb-vm
:n-word-bits
)) ,code
)
3921 `(- ,code
(ash x
(- 1 sb-vm
:n-word-bits
)))))))))
3923 (deftransform truncate
((x y
) (sb-vm:signed-word
3924 (constant-arg sb-vm
:signed-word
))
3926 :policy
(and (> speed compilation-speed
)
3930 "convert integer division to multiplication"
3931 (delay-ir1-transform node
:ir1-phases
)
3932 (let* ((y (lvar-value y
))
3934 (x-type (lvar-type x
)))
3935 (multiple-value-bind (precision max-x
)
3936 (if (and (numeric-type-p x-type
)
3937 (numeric-type-high x-type
)
3938 (numeric-type-low x-type
))
3939 (values (max (integer-length (numeric-type-high x-type
))
3940 (integer-length (numeric-type-low x-type
)))
3941 (max (numeric-type-high x-type
)
3942 (abs (numeric-type-low x-type
))))
3943 (values (1- sb-vm
:n-word-bits
)
3944 (expt 2 (1- sb-vm
:n-word-bits
))))
3945 ;; Division by zero, one or powers of two is handled elsewhere.
3946 (when (or (zerop (logand abs-y
(1- abs-y
)))
3947 ;; Leave it for the unsigned transform
3949 (not (types-equal-or-intersect x-type
3951 '(and sb-vm
:signed-word
3952 (not unsigned-byte
)))))))
3953 (give-up-ir1-transform))
3954 `(let* ((quot (truly-the
3955 (integer ,(- (truncate max-x abs-y
)) ,(truncate max-x abs-y
))
3956 ,(gen-signed-truncate-by-constant-expr y precision
)))
3957 (rem (truly-the (integer ,(- 1 abs-y
) ,(1- abs-y
))
3958 (- x
(truly-the sb-vm
:signed-word
(* quot
,y
))))))
3959 (values quot rem
))))))
3961 ;;; The paper also has this,
3962 ;;; but it seems to overflow when adding to X
3963 ;; (defun gen-signed-floor-by-constant-expr (y max-x)
3964 ;; (declare (type sb-vm:signed-word y)
3965 ;; (type word max-x))
3966 ;; (let ((trunc (gen-signed-truncate-by-constant-expr y
3968 ;; (let ((y-sign (xsign y)))
3969 ;; `(let* ((x-sign (xsign (logior x (+ x ,y-sign))))
3970 ;; (x (+ ,y-sign (- x-sign) x)))
3971 ;; (truly-the sb-vm:signed-word
3973 ;; (logxor x-sign ,y-sign)))))))
3975 (unless-vop-existsp (:translate %multiply-high
)
3976 (define-source-transform %multiply-high
(x y
)
3977 `(values (sb-bignum:%multiply
,x
,y
))))
3979 ;;; If the divisor is constant and both args are positive and fit in a
3980 ;;; machine word, replace the division by a multiplication and possibly
3981 ;;; some shifts and an addition. Calculate the remainder by a second
3982 ;;; multiplication and a subtraction. Dead code elimination will
3983 ;;; suppress the latter part if only the quotient is needed. If the type
3984 ;;; of the dividend allows to derive that the quotient will always have
3985 ;;; the same value, emit much simpler code to handle that. (This case
3986 ;;; may be rare but it's easy to detect and the compiler doesn't find
3987 ;;; this optimization on its own.)
3988 (deftransform truncate
((x y
) (word (constant-arg word
))
3990 :policy
(and (> speed compilation-speed
)
3994 "convert integer division to multiplication"
3995 (delay-ir1-transform node
:ir1-phases
)
3996 (let* ((y (lvar-value y
))
3997 (x-type (lvar-type x
))
3998 (max-x (or (and (numeric-type-p x-type
)
3999 (numeric-type-high x-type
))
4000 most-positive-word
)))
4001 ;; Division by zero, one or powers of two is handled elsewhere.
4002 (when (zerop (logand y
(1- y
)))
4003 (give-up-ir1-transform))
4004 `(let* ((quot (truly-the (integer 0 ,(truncate max-x y
))
4005 ,(gen-unsigned-div-by-constant-expr y max-x
)))
4006 (rem (truly-the (mod ,y
)
4007 (- x
(* quot
,y
)))))
4008 (values quot rem
))))
4010 ;;; No-op when Y is greater than X
4011 (deftransform truncate
((x y
) (rational rational
) * :important nil
)
4016 (let* ((x-interval (or (type-approximate-interval (lvar-type x
))
4017 (give-up-ir1-transform)))
4018 (x-low (strip (interval-low x-interval
)))
4019 (x-high (strip (interval-high x-interval
)))
4020 (y-interval (or (type-approximate-interval (lvar-type y
))
4021 (give-up-ir1-transform)))
4022 (y-low (strip (interval-low y-interval
)))
4023 (y-high (strip (interval-high y-interval
)))
4024 (x-max (and x-low x-high
4025 (max (abs x-low
) (abs x-high
))))
4026 (y-min (cond ((and y-low
4032 (if (and x-max y-min
4035 (give-up-ir1-transform)))))
4038 ;;;; arithmetic and logical identity operation elimination
4040 ;;; Flush calls to various arith functions that convert to the
4041 ;;; identity function or a constant.
4042 (macrolet ((def (name identity result
)
4043 `(deftransform ,name
((x y
) (t (constant-arg (member ,identity
))) *)
4044 "fold identity operations"
4051 (def logxor -
1 (lognot x
))
4055 (defun least-zero-bit (x)
4057 (1- (integer-length (logxor x
(1+ x
))))))
4059 (deftransform logand
((x y
) (t (constant-arg integer
)) *)
4060 "fold identity operation"
4061 (let* ((y (lvar-value y
))
4062 (width (or (least-zero-bit y
) '*)))
4063 (unless (and (neq width
0) ; (logand x 0) handled elsewhere
4064 (csubtypep (lvar-type x
)
4065 (specifier-type `(unsigned-byte ,width
))))
4066 (give-up-ir1-transform))
4069 (deftransform logand
((x y
) (t (constant-arg integer
)) word
4070 :node node
:important nil
)
4071 ;; Reduce constant width
4072 (let* ((high (interval-high (type-approximate-interval (single-value-type (node-asserted-type node
)))))
4073 (mask (lvar-value y
))
4074 (cut (ldb (byte (integer-length high
) 0) mask
)))
4076 (give-up-ir1-transform)
4079 (deftransform logandc2
((x y
) ((constant-arg (eql -
1)) t
) *)
4082 (deftransform logandc2
((x y
) * * :important nil
:node node
)
4083 (delay-ir1-transform node
:ir1-phases
)
4084 (if (and (not (or (csubtypep (lvar-type x
) (specifier-type 'word
))
4085 (csubtypep (lvar-type x
) (specifier-type 'sb-vm
:signed-word
))))
4086 (csubtypep (lvar-type y
) (specifier-type 'fixnum
))
4087 (csubtypep (one-arg-derive-type y
#'lognot-derive-type-aux
#'lognot
)
4088 (specifier-type 'fixnum
)))
4089 `(logand x
(lognot y
))
4090 (give-up-ir1-transform)))
4092 (deftransform mask-signed-field
((size x
) ((constant-arg t
) t
) *)
4093 "fold identity operation"
4094 (let ((size (lvar-value size
)))
4095 (cond ((= size
0) 0)
4096 ((csubtypep (lvar-type x
) (specifier-type `(signed-byte ,size
)))
4099 (give-up-ir1-transform)))))
4101 (deftransform logior
((x y
) (t (constant-arg integer
)) *)
4102 "fold identity operation"
4103 (let* ((y (lvar-value y
))
4104 (width (or (least-zero-bit (lognot y
))
4105 (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
4106 (unless (csubtypep (lvar-type x
)
4107 (specifier-type `(integer ,(- (ash 1 width
)) -
1)))
4108 (give-up-ir1-transform))
4111 ;;; Pick off easy association opportunities for constant folding.
4112 ;;; More complicated stuff that also depends on commutativity
4113 ;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
4114 ;;; probably be handled with a more general tree-rewriting pass.
4115 (macrolet ((def (operator &key
(type 'integer
) (folded (list operator
)))
4116 `(deftransform ,operator
((x z
) (,type
(constant-arg ,type
)))
4117 ,(format nil
"associate ~A/~A of constants"
4119 (binding* ((node (if (lvar-has-single-use-p x
)
4121 (give-up-ir1-transform)))
4122 (folded (or (and (combination-p node
)
4123 (car (memq (lvar-fun-name
4124 (combination-fun node
))
4126 (give-up-ir1-transform)))
4127 (y (second (combination-args node
)))
4128 (nil (or (constant-lvar-p y
)
4129 (give-up-ir1-transform)))
4131 (unless (typep y
',type
)
4132 (give-up-ir1-transform))
4133 (splice-fun-args x folded
2)
4135 (declare (ignore y z
))
4136 ;; (operator (folded x y) z)
4137 ;; == (operator x (folded z y))
4138 (,',operator x
(,folded
,(lvar-value z
) ,y
)))))))
4142 (def logtest
:folded
(logand))
4143 (def + :type rational
:folded
(+ -
))
4144 (def * :type rational
:folded
(* /)))
4146 (deftransform * ((x y
) (rational (constant-arg ratio
)))
4147 (let ((y (/ (lvar-value y
))))
4150 (give-up-ir1-transform))))
4152 (deftransform / ((x y
) (rational (constant-arg ratio
)))
4153 (let ((y (/ (lvar-value y
))))
4156 (give-up-ir1-transform))))
4158 (deftransform mask-signed-field
((width x
) ((constant-arg unsigned-byte
) t
))
4159 "Fold mask-signed-field/mask-signed-field of constant width"
4160 (binding* ((node (if (lvar-has-single-use-p x
)
4162 (give-up-ir1-transform)))
4163 (nil (or (combination-p node
)
4164 (give-up-ir1-transform)))
4165 (nil (or (eq (lvar-fun-name (combination-fun node
))
4167 (give-up-ir1-transform)))
4168 (x-width (first (combination-args node
)))
4169 (nil (or (constant-lvar-p x-width
)
4170 (give-up-ir1-transform)))
4171 (x-width (lvar-value x-width
)))
4172 (unless (typep x-width
'unsigned-byte
)
4173 (give-up-ir1-transform))
4174 (splice-fun-args x
'mask-signed-field
2)
4175 `(lambda (width x-width x
)
4176 (declare (ignore width x-width
))
4177 (mask-signed-field ,(min (lvar-value width
) x-width
) x
))))
4179 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
4180 ;;; (* 0 -4.0) is -0.0.
4181 (deftransform -
((x y
) ((constant-arg (member 0)) rational
) *)
4182 "convert (- 0 x) to negate"
4184 (deftransform * ((x y
) (rational (constant-arg (member 0))) *)
4185 "convert (* x 0) to 0"
4188 (deftransform %negate
((x) (rational))
4189 "Eliminate %negate/%negate of rationals"
4190 (splice-fun-args x
'%negate
1)
4193 (deftransform %negate
((x) (number))
4195 (let ((use (lvar-uses x
))
4197 (unless (and (combination-p use
)
4198 (eql '* (lvar-fun-name (combination-fun use
)))
4199 (constant-lvar-p (setf arg
(second (combination-args use
))))
4200 (numberp (setf arg
(lvar-value arg
))))
4201 (give-up-ir1-transform))
4202 (splice-fun-args x
'* 2)
4204 (declare (ignore y
))
4207 ;;; Return T if in an arithmetic op including lvars X and Y, the
4208 ;;; result type is not affected by the type of X. That is, Y is at
4209 ;;; least as contagious as X.
4210 (defun not-more-contagious (x y
)
4211 (let ((x (lvar-type x
))
4214 ((csubtypep x
(specifier-type 'rational
)))
4215 ((csubtypep x
(specifier-type 'single-float
))
4216 (csubtypep y
(specifier-type 'float
)))
4217 ((csubtypep x
(specifier-type 'double-float
))
4218 (csubtypep y
(specifier-type 'double-float
))))))
4220 (sb-xc:deftype exact-number
()
4221 '(or rational
(complex rational
)))
4225 ;;; Only safely applicable for exact numbers. For floating-point
4226 ;;; x, one would have to first show that neither x or y are signed
4227 ;;; 0s, and that x isn't an SNaN.
4228 (deftransform + ((x y
) (exact-number (constant-arg (eql 0))) *)
4233 (deftransform -
((x y
) (exact-number (constant-arg (eql 0))) *)
4237 ;;; Fold (OP x +/-1)
4238 ;;; If a signaling nan somehow got here without signaling anything then
4241 ((def (name result minus-result type
)
4242 `(deftransform ,name
((x y
)
4243 (,type
(constant-arg (member 1 -
1))))
4244 "fold identity operations"
4245 (if (minusp (lvar-value y
)) ',minus-result
',result
))))
4246 (def * x
(%negate x
) number
)
4247 (def / x
(%negate x
) number
)
4248 (def expt x
(/ 1 x
) (or exact-number real
))) ;; (expt #c(2d0 2d0) 1) doesn't return #c(2d0 2d0)
4250 (deftransform + ((x y
) (number number
))
4251 (cond ((splice-fun-args y
'%negate
1 nil
)
4253 ((splice-fun-args x
'%negate
1 nil
)
4256 (give-up-ir1-transform))))
4258 (deftransform -
((x y
) (number number
))
4259 (splice-fun-args y
'%negate
1)
4262 ;;; Fold (expt x n) into multiplications for small integral values of
4263 ;;; N; convert (expt x 1/2) to sqrt.
4264 (deftransform expt
((x y
) (t (constant-arg real
)) *)
4265 "recode as multiplication or sqrt"
4266 (let ((val (lvar-value y
)))
4267 ;; If Y would cause the result to be promoted to the same type as
4268 ;; Y, we give up. If not, then the result will be the same type
4269 ;; as X, so we can replace the exponentiation with simple
4270 ;; multiplication and division for small integral powers.
4271 (unless (not-more-contagious y x
)
4272 (give-up-ir1-transform))
4274 (let ((x-type (lvar-type x
)))
4275 (cond ((csubtypep x-type
(specifier-type '(or rational
4276 (complex rational
))))
4278 ((csubtypep x-type
(specifier-type 'real
))
4282 ((csubtypep x-type
(specifier-type 'complex
))
4283 ;; both parts are float
4285 (t (give-up-ir1-transform)))))
4286 ((= val
2) '(* x x
))
4287 ((= val -
2) '(/ (* x x
)))
4288 ((= val
3) '(* x x x
))
4289 ((= val -
3) '(/ (* x x x
)))
4290 ((= val
1/2) '(sqrt x
))
4291 ((= val -
1/2) '(/ (sqrt x
)))
4292 (t (give-up-ir1-transform)))))
4294 (deftransform expt
((x y
) ((constant-arg (member -
1 $-
1.0 $-
1.0d0
)) integer
) *)
4295 "recode as an ODDP check"
4296 (let ((val (lvar-value x
)))
4298 '(- 1 (* 2 (logand 1 y
)))
4303 (deftransform expt
((x y
) ((or rational
(complex rational
)) integer
) * :node node
)
4304 (delay-ir1-transform node
:ir1-phases
)
4305 `(sb-kernel::intexp x y
))
4307 (macrolet ((def (name)
4308 `(deftransform ,name
((x y
) ((constant-arg (integer 0 0)) integer
)
4315 (macrolet ((def (name)
4316 `(deftransform ,name
((x y
) ((constant-arg (integer 0 0)) integer
)
4325 (macrolet ((def (name &optional float
)
4326 (let ((x (if float
'(float x
) 'x
)))
4327 `(deftransform ,name
((x y
) (integer (constant-arg (member 1 -
1)))
4329 "fold division by 1"
4330 `(values ,(if (minusp (lvar-value y
))
4343 ;;;; character operations
4345 (deftransform char-equal
((a b
) (base-char base-char
) *
4346 :policy
(>= speed space
))
4348 '(let* ((ac (char-code a
))
4350 (sum (logxor ac bc
)))
4352 (when (eql sum
#x20
)
4353 (let ((sum (+ ac bc
)))
4354 (or (and (> sum
161) (< sum
213))
4356 (and (> sum
415) (< sum
461))
4358 (and (> sum
463) (< sum
477))))))))
4361 (deftransform char-equal
((a b
) (base-char character
) *
4362 :policy
(>= speed space
))
4364 '(let* ((ac (char-code a
))
4366 (sum (logxor ac bc
)))
4368 (when (eql sum
#x20
)
4369 (let ((sum (+ ac bc
)))
4370 (and (> sum
161) (< sum
213)))))))
4373 (deftransform char-equal
((a b
) (character base-char
) *
4374 :policy
(>= speed space
))
4376 '(let* ((ac (char-code a
))
4378 (sum (logxor ac bc
)))
4380 (when (eql sum
#x20
)
4381 (let ((sum (+ ac bc
)))
4382 (and (> sum
161) (< sum
213)))))))
4384 (defun transform-constant-char-equal (a b
&optional
(op 'char
=))
4385 (let ((char (lvar-value b
)))
4386 (if (both-case-p char
)
4387 (let ((reverse (if (upper-case-p char
)
4388 (char-downcase char
)
4389 (char-upcase char
))))
4394 (deftransform char-equal
((a b
) (t (constant-arg character
)) *
4396 (transform-constant-char-equal 'a b
))
4398 (deftransform char-upcase
((x) (base-char))
4400 '(let ((n-code (char-code x
)))
4401 (if (or (and (> n-code
#o140
) ; Octal 141 is #\a.
4402 (< n-code
#o173
)) ; Octal 172 is #\z.
4403 (and (> n-code
#o337
)
4405 (and (> n-code
#o367
)
4407 (code-char (logxor #x20 n-code
))
4410 (deftransform char-downcase
((x) (base-char))
4412 '(let ((n-code (char-code x
)))
4413 (if (or (and (> n-code
64) ; 65 is #\A.
4414 (< n-code
91)) ; 90 is #\Z.
4419 (code-char (logxor #x20 n-code
))
4422 ;;;; equality predicate transforms
4424 ;;; If X and Y are the same leaf, then the result is true. Otherwise,
4425 ;;; if there is no intersection between the types of the arguments,
4426 ;;; then the result is definitely false.
4427 (deftransform char
= ((x y
) * *)
4428 "Simple equality transform"
4429 (let ((use (lvar-uses x
))
4431 (declare (ignorable use arg
))
4433 ((same-leaf-ref-p x y
) t
)
4434 ((not (types-equal-or-intersect (lvar-type x
) (lvar-type y
)))
4436 ;; Reduce (eq (%instance-ref x i) Y) to 1 instruction
4437 ;; if possible, but do not defer the memory load unless doing
4438 ;; so can have no effect, i.e. Y is a constant or provably not
4439 ;; effectful. For now, just handle constant Y.
4440 ((and (vop-existsp :translate %instance-ref-eq
)
4443 (almost-immediately-used-p x use
)
4444 (eql '%instance-ref
(lvar-fun-name (combination-fun use
)))
4445 (constant-lvar-p (setf arg
(second (combination-args use
))))
4446 (typep (lvar-value arg
) '(unsigned-byte 16)))
4447 (splice-fun-args x
'%instance-ref
2)
4448 `(lambda (obj i val
) (%instance-ref-eq obj i val
)))
4449 (t (give-up-ir1-transform)))))
4451 (defun transform-eq-on-words (fun x y
)
4452 (flet ((try-sword (x y x-v y-v
)
4453 (when (not (or (csubtypep (lvar-type x
) (specifier-type 'fixnum
))
4454 (csubtypep (lvar-type y
) (specifier-type 'word
))))
4455 `(if (#+64-bit sb-kernel
:signed-byte-64-p
4456 #-
64-bit sb-kernel
:signed-byte-32-p
4458 (,fun
,x-v
(truly-the sb-vm
:signed-word
,y-v
))
4460 (try-word (x y x-v y-v
)
4461 (when (not (or (csubtypep (lvar-type x
) (specifier-type 'fixnum
))
4462 (csubtypep (lvar-type y
) (specifier-type 'sb-vm
:signed-word
))))
4463 `(if (#+64-bit sb-kernel
:unsigned-byte-64-p
4464 #-
64-bit sb-kernel
:unsigned-byte-32-p
4466 (,fun
,x-v
(truly-the word
,y-v
))
4468 (do-float (x-v y-v predicate type
)
4469 `(if (,predicate
,y-v
)
4470 (,fun
,x-v
(truly-the ,type
,y-v
))
4472 (let ((x-swordp (csubtypep (lvar-type x
) (specifier-type 'sb-vm
:signed-word
)))
4473 (y-swordp (csubtypep (lvar-type y
) (specifier-type 'sb-vm
:signed-word
))))
4474 (cond ((and x-swordp
(not y-swordp
))
4475 (try-sword x y
'x
'y
))
4476 ((and y-swordp
(not x-swordp
))
4477 (try-sword y y
'y
'x
))
4479 (let ((x-wordp (csubtypep (lvar-type x
) (specifier-type 'word
)))
4480 (y-wordp (csubtypep (lvar-type y
) (specifier-type 'word
))))
4481 (cond ((and x-wordp
(not y-wordp
))
4482 (try-word x y
'x
'y
))
4483 ((and y-wordp
(not x-wordp
))
4484 (try-word y y
'y
'x
))
4486 (let ((x-dfp (csubtypep (lvar-type x
) (specifier-type 'double-float
)))
4487 (y-dfp (csubtypep (lvar-type y
) (specifier-type 'double-float
))))
4488 (cond ((and x-dfp
(not y-dfp
))
4489 (do-float 'x
'y
'double-float-p
'double-float
))
4490 ((and y-dfp
(not x-dfp
))
4491 (do-float 'y
'x
'double-float-p
'double-float
))
4494 (let ((x-sfp (csubtypep (lvar-type x
) (specifier-type 'single-float
)))
4495 (y-sfp (csubtypep (lvar-type y
) (specifier-type 'single-float
))))
4496 (cond ((and x-sfp
(not y-sfp
))
4497 (do-float 'x
'y
'single-float-p
'single-float
))
4498 ((and y-sfp
(not x-sfp
))
4499 (do-float 'y
'x
'single-float-p
'single-float
)))))))))))))))
4501 (deftransform eq
((x y
) * *)
4502 "Simple equality transform"
4503 (let ((use (lvar-uses x
))
4505 (declare (ignorable use arg
))
4507 ((same-leaf-ref-p x y
) t
)
4508 ((not (types-equal-or-intersect (lvar-type x
) (lvar-type y
)))
4510 ;; Reduce (eq (%instance-ref x i) Y) to 1 instruction
4511 ;; if possible, but do not defer the memory load unless doing
4512 ;; so can have no effect, i.e. Y is a constant or provably not
4513 ;; effectful. For now, just handle constant Y.
4514 ((and (vop-existsp :translate %instance-ref-eq
)
4517 (almost-immediately-used-p x use
)
4518 (eql '%instance-ref
(lvar-fun-name (combination-fun use
)))
4519 (constant-lvar-p (setf arg
(second (combination-args use
))))
4520 (typep (lvar-value arg
) '(unsigned-byte 16)))
4521 (splice-fun-args x
'%instance-ref
2)
4522 `(lambda (obj i val
) (%instance-ref-eq obj i val
)))
4523 ((transform-eq-on-words 'eq x y
))
4524 (t (give-up-ir1-transform)))))
4526 ;;; Can't use the above thing, since TYPES-EQUAL-OR-INTERSECT is case sensitive.
4527 (deftransform char-equal
((x y
) * *)
4529 ((same-leaf-ref-p x y
) t
)
4530 (t (give-up-ir1-transform))))
4532 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
4533 ;;; try to convert to a type-specific predicate or EQ:
4534 ;;; -- If both args are characters, convert to CHAR=. This is better than
4535 ;;; just converting to EQ, since CHAR= may have special compilation
4536 ;;; strategies for non-standard representations, etc.
4537 ;;; -- If either arg is definitely a fixnum, we check to see if X is
4538 ;;; constant and if so, put X second. Doing this results in better
4539 ;;; code from the backend, since the backend assumes that any constant
4540 ;;; argument comes second.
4541 ;;; -- If either arg is definitely not a number or a fixnum, then we
4542 ;;; can compare with EQ.
4543 ;;; -- Otherwise, we try to put the arg we know more about second. If X
4544 ;;; is constant then we put it second. If X is a subtype of Y, we put
4545 ;;; it second. These rules make it easier for the back end to match
4546 ;;; these interesting cases.
4547 (deftransform eql
((x y
) * * :node node
)
4548 "convert to simpler equality predicate"
4549 (let* ((x-type (lvar-type x
))
4550 (y-type (lvar-type y
))
4551 (char-type (specifier-type 'character
)))
4553 ((same-leaf-ref-p x y
) t
)
4554 ((not (types-equal-or-intersect x-type y-type
))
4556 ((and (csubtypep x-type char-type
)
4557 (csubtypep y-type char-type
))
4559 ((or (eq-comparable-type-p x-type
) (eq-comparable-type-p y-type
))
4561 ((transform-eq-on-words 'eql x y
))
4563 (give-up-ir1-transform)))))
4565 (defun array-type-dimensions-mismatch (x-type y-type
)
4566 (and (csubtypep x-type
(specifier-type 'array
))
4567 (csubtypep y-type
(specifier-type 'array
))
4568 (let ((x-dims (sb-kernel::ctype-array-union-dimensions x-type
))
4569 (y-dims (sb-kernel::ctype-array-union-dimensions y-type
)))
4570 (unless (or (eq (car x-dims
) '*)
4571 (eq (car y-dims
) '*))
4572 (loop with simple
= (and (csubtypep x-type
(specifier-type 'simple-array
))
4573 (csubtypep y-type
(specifier-type 'simple-array
)))
4576 (loop for y-dim in y-dims
4578 (and (= (length x-dim
)
4580 ;; Can compare dimensions only for simple
4581 ;; arrays due to fill-pointer and
4584 (loop for x in x-dim
4586 always
(or (eq x
'*)
4590 ;;; Only a simple array will always remain non-empty
4591 (defun array-type-non-empty-p (type)
4592 (and (csubtypep type
(specifier-type 'simple-array
))
4593 (let ((dimensions (ctype-array-dimensions type
)))
4594 (and (consp dimensions
)
4595 (every (lambda (dim)
4596 (typep dim
'(integer 1)))
4599 (defun equal-comparable-types (x y
)
4600 (flet ((both-intersect-p (type)
4601 (let ((ctype (specifier-type type
)))
4602 (and (types-equal-or-intersect x ctype
)
4603 (types-equal-or-intersect y ctype
)))))
4604 (or (both-intersect-p 'string
)
4605 ;; Even though PATHNAME doesn't have any parameters it
4606 ;; may appear in an EQL type.
4607 (both-intersect-p 'pathname
)
4608 (both-intersect-p 'bit-vector
)
4609 (both-intersect-p 'cons
))))
4611 (defun equalp-comparable-types (x y
)
4612 (flet ((both-intersect-p (type)
4613 (let ((ctype (specifier-type type
)))
4614 (and (types-equal-or-intersect x ctype
)
4615 (types-equal-or-intersect y ctype
)))))
4616 (or (both-intersect-p 'number
)
4617 (both-intersect-p 'array
)
4618 (both-intersect-p 'character
)
4619 (both-intersect-p 'cons
)
4620 ;; Even though these don't have any parameters they may
4621 ;; appear in an EQL type.
4622 (both-intersect-p 'pathname
)
4623 (both-intersect-p 'instance
)
4624 (both-intersect-p 'hash-table
))))
4626 (defun equalp-eql-comparable-types (x y
)
4627 (flet ((both-intersect-p (type)
4628 (let ((ctype (specifier-type type
)))
4629 (and (types-equal-or-intersect x ctype
)
4630 (types-equal-or-intersect y ctype
)))))
4631 (not (or (and (let ((int-x (type-intersection x
(specifier-type 'number
)))
4632 (int-y (type-intersection y
(specifier-type 'number
))))
4633 (and (neq int-x
*empty-type
*)
4634 (neq int-y
*empty-type
*)
4636 (and (csubtypep int-x
(specifier-type 'integer
))
4637 (csubtypep int-y
(specifier-type 'integer
)))))))
4638 (both-intersect-p 'array
)
4639 (both-intersect-p 'character
)
4640 (both-intersect-p 'cons
)
4641 (both-intersect-p 'pathname
)
4642 (both-intersect-p 'instance
)
4643 (both-intersect-p 'hash-table
)))))
4645 (defun equal-remove-incompatible-types (x y
&optional equalp
)
4647 (let ((n-x (type-intersection x
(specifier-type 'number
)))
4648 (n-y (type-intersection y
(specifier-type 'number
))))
4649 (unless (or (eq n-x
*empty-type
*)
4650 (eq n-y
*empty-type
*))
4651 (let ((i-x (type-approximate-interval n-x
))
4652 (i-y (type-approximate-interval n-y
)))
4654 (interval-/= i-x i-y
))
4656 (values (type-difference x n-x
)
4657 (type-difference y n-y
)))))))
4658 (let ((a-x (type-intersection x
(specifier-type 'array
)))
4659 (a-y (type-intersection y
(specifier-type 'array
))))
4660 (when (not (or (eq a-x
*empty-type
*)
4661 (eq a-y
*empty-type
*)))
4662 (when (or (not equalp
)
4663 ;; At least one array has to be longer than 0
4664 ;; and not adjustable, because #() and "" are equalp.
4665 (array-type-non-empty-p a-x
)
4666 (array-type-non-empty-p a-y
))
4667 (let ((x-et (type-array-element-type a-x
))
4668 (y-et (type-array-element-type a-y
)))
4669 (when (and (neq x-et
*wild-type
*)
4670 (neq y-et
*wild-type
*)
4671 (not (types-equal-or-intersect x-et y-et
)))
4673 (values (type-difference x a-x
)
4674 (type-difference y a-y
))))))
4675 (when (array-type-dimensions-mismatch a-x a-y
)
4677 (values (type-difference x a-x
)
4678 (type-difference y a-y
))))))
4681 ;;; similarly to the EQL transform above, we attempt to constant-fold
4682 ;;; or convert to a simpler predicate: mostly we have to be careful
4683 ;;; with strings and bit-vectors.
4684 (deftransform equal
((x y
) * *)
4685 "convert to simpler equality predicate"
4686 (let ((x-type (lvar-type x
))
4687 (y-type (lvar-type y
)))
4688 (cond ((same-leaf-ref-p x y
) t
)
4689 ((array-type-dimensions-mismatch x-type y-type
)
4692 (flet ((try (x-type y-type
)
4693 (flet ((both-csubtypep (type)
4694 (let ((ctype (specifier-type type
)))
4695 (and (csubtypep x-type ctype
)
4696 (csubtypep y-type ctype
))))
4697 (some-csubtypep (type)
4698 (let ((ctype (specifier-type type
)))
4699 (or (csubtypep x-type ctype
)
4700 (csubtypep y-type ctype
))))
4701 (non-equal-array-p (type)
4702 (and (csubtypep type
(specifier-type 'array
))
4703 (let ((equal-types (specifier-type '(or bit character
)))
4704 (element-types (ctype-array-specialized-element-types type
)))
4705 (and (neq element-types
*wild-type
*)
4707 (csubtypep x equal-types
))
4710 ((and (constant-lvar-p x
)
4711 (equal (lvar-value x
) ""))
4713 (zerop (length y
))))
4714 ((and (constant-lvar-p y
)
4715 (equal (lvar-value y
) ""))
4717 (zerop (length x
))))
4718 ((or (some-csubtypep 'symbol
)
4719 (some-csubtypep 'character
))
4721 ((both-csubtypep 'string
)
4723 ((both-csubtypep 'bit-vector
)
4724 '(bit-vector-= x y
))
4725 ((both-csubtypep 'pathname
)
4727 ((or (non-equal-array-p x-type
)
4728 (non-equal-array-p y-type
))
4730 ((multiple-value-bind (x-type y-type
)
4731 (equal-remove-incompatible-types x-type y-type
)
4733 ((or (eq x-type
*empty-type
*)
4734 (eq y-type
*empty-type
*))
4736 ((equal-comparable-types x-type y-type
)
4738 ((types-equal-or-intersect x-type y-type
)
4740 (let ((r (try x-type y-type
)))
4742 (let* ((not-x-type (type-difference x-type
(specifier-type 'null
)))
4743 (r (try not-x-type y-type
)))
4750 (let* ((not-y-type (type-difference y-type
(specifier-type 'null
)))
4751 (r (try x-type not-y-type
)))
4758 (let ((r (try not-x-type not-y-type
)))
4759 (if (neq r
:give-up
)
4764 (give-up-ir1-transform)))))))))
4767 (deftransform equalp
((x y
) * *)
4768 "convert to simpler equality predicate"
4769 (let ((x-type (lvar-type x
))
4770 (y-type (lvar-type y
)))
4771 (cond ((same-leaf-ref-p x y
) t
)
4772 ((array-type-dimensions-mismatch x-type y-type
)
4775 (flet ((try (x-type y-type
)
4776 (flet ((both-csubtypep (type)
4777 (let ((ctype (specifier-type type
)))
4778 (and (csubtypep x-type ctype
)
4779 (csubtypep y-type ctype
))))
4780 (some-csubtypep (type)
4781 (let ((ctype (specifier-type type
)))
4782 (or (csubtypep x-type ctype
)
4783 (csubtypep y-type ctype
))))
4784 (transform-char-equal (x y
)
4785 (and (constant-lvar-p y
)
4786 (characterp (lvar-value y
))
4787 (transform-constant-char-equal x y
'eq
))))
4789 ((and (constant-lvar-p x
)
4790 (typep (lvar-value x
) '(simple-array * (0))))
4792 (zerop (length y
))))
4793 ((and (constant-lvar-p y
)
4794 (typep (lvar-value y
) '(simple-array * (0))))
4796 (zerop (length x
))))
4797 ((some-csubtypep 'symbol
)
4799 ((transform-char-equal 'x y
))
4800 ((transform-char-equal 'y x
))
4801 ((both-csubtypep 'string
)
4802 '(string-equal x y
))
4803 ((both-csubtypep 'bit-vector
)
4804 '(bit-vector-= x y
))
4805 ((both-csubtypep 'pathname
)
4807 ((both-csubtypep 'character
)
4809 ((both-csubtypep 'number
)
4811 ((both-csubtypep 'hash-table
)
4812 '(hash-table-equalp x y
))
4813 ;; TODO: two instances of the same type should dispatch
4814 ;; directly to the EQUALP-IMPL function in the layout.
4816 (multiple-value-bind (x-type y-type
)
4817 (equal-remove-incompatible-types x-type y-type t
)
4819 ((or (eq x-type
*empty-type
*)
4820 (eq y-type
*empty-type
*))
4822 ((types-equal-or-intersect x-type y-type
)
4823 (if (equalp-eql-comparable-types x-type y-type
)
4826 ((equalp-comparable-types x-type y-type
)
4828 (let ((r (try x-type y-type
)))
4830 (let* ((not-x-type (type-difference x-type
(specifier-type 'null
)))
4831 (r (try not-x-type y-type
)))
4838 (let* ((not-y-type (type-difference y-type
(specifier-type 'null
)))
4839 (r (try x-type not-y-type
)))
4846 (let ((r (try not-x-type not-y-type
)))
4847 (if (neq r
:give-up
)
4852 (give-up-ir1-transform)))))))))
4855 (defoptimizer (equal constraint-propagate-if
) ((x y
) node gen
)
4856 (let* ((x-var (ok-lvar-lambda-var x gen
))
4857 (y-var (ok-lvar-lambda-var y gen
)))
4858 (when (or x-var y-var
)
4859 (labels ((%downgrade
(type supertype
)
4860 (let ((ctype (specifier-type supertype
)))
4861 (if (types-equal-or-intersect type ctype
)
4862 (type-union type ctype
)
4865 (setf type
(%downgrade type
'cons
))
4866 (setf type
(%downgrade type
'string
))
4867 (setf type
(%downgrade type
'bit-vector
))))
4868 (let ((x-type (downgrade (lvar-type x
)))
4869 (y-type (downgrade (lvar-type y
))))
4870 (let ((intersection (type-intersection x-type y-type
)))
4871 (unless (or (eq intersection
*empty-type
*)
4872 (eq intersection
*universal-type
*))
4873 (let ((constraints))
4875 (push (list 'typep x-var intersection
) constraints
))
4877 (push (list 'typep y-var intersection
) constraints
))
4878 (values nil nil constraints
)))))))))
4880 (defoptimizer (equalp constraint-propagate-if
) ((x y
) node gen
)
4881 (let* ((x-var (ok-lvar-lambda-var x gen
))
4882 (y-var (ok-lvar-lambda-var y gen
)))
4883 (when (or x-var y-var
)
4884 (labels ((%downgrade
(type supertype
)
4885 (let ((ctype (specifier-type supertype
)))
4886 (if (types-equal-or-intersect type ctype
)
4887 (type-union type ctype
)
4890 (setf type
(%downgrade type
'array
))
4891 (setf type
(%downgrade type
'cons
))
4892 (setf type
(%downgrade type
'number
))
4893 (setf type
(%downgrade type
'character
))))
4894 (let ((x-type (downgrade (lvar-type x
)))
4895 (y-type (downgrade (lvar-type y
))))
4896 (let ((intersection (type-intersection x-type y-type
)))
4897 (unless (or (eq intersection
*empty-type
*)
4898 (eq intersection
*universal-type
*))
4899 (let ((constraints))
4901 (push (list 'typep x-var intersection
) constraints
))
4903 (push (list 'typep y-var intersection
) constraints
))
4904 (values nil nil constraints
)))))))))
4906 ;;; Convert to EQL if both args are rational and complexp is specified
4907 ;;; and the same for both.
4908 (deftransform = ((x y
) (number number
) *)
4910 (let ((x-type (lvar-type x
))
4911 (y-type (lvar-type y
)))
4912 (cond ((or (and (csubtypep x-type
(specifier-type 'float
))
4913 (csubtypep y-type
(specifier-type 'float
)))
4914 (and (csubtypep x-type
(specifier-type '(complex float
)))
4915 (csubtypep y-type
(specifier-type '(complex float
))))
4916 (and (vop-existsp :named sb-vm
::=/complex-single-float
)
4917 (csubtypep x-type
(specifier-type '(or single-float
(complex single-float
))))
4918 (csubtypep y-type
(specifier-type '(or single-float
(complex single-float
)))))
4919 (and (vop-existsp :named sb-vm
::=/complex-double-float
)
4920 (csubtypep x-type
(specifier-type '(or double-float
(complex double-float
))))
4921 (csubtypep y-type
(specifier-type '(or double-float
(complex double-float
))))))
4922 ;; They are both floats. Leave as = so that -0.0 is
4923 ;; handled correctly.
4924 (give-up-ir1-transform))
4925 ((or (and (csubtypep x-type
(specifier-type 'rational
))
4926 (csubtypep y-type
(specifier-type 'rational
)))
4927 (and (csubtypep x-type
4928 (specifier-type '(complex rational
)))
4930 (specifier-type '(complex rational
)))))
4931 ;; They are both rationals and complexp is the same.
4934 ((or (and (csubtypep x-type
(specifier-type 'real
))
4936 (specifier-type '(complex rational
))))
4937 (and (csubtypep y-type
(specifier-type 'real
))
4939 (specifier-type '(complex rational
)))))
4940 ;; Can't be EQL since imagpart can't be 0.
4943 (give-up-ir1-transform
4944 "The operands might not be the same type.")))))
4946 (defun maybe-float-lvar-p (lvar)
4947 (neq *empty-type
* (type-intersection (specifier-type 'float
)
4950 #+(or arm arm64 x86-64 x86
)
4951 (flet ((maybe-invert (op inverted x y
)
4953 ((and (not (vop-existsp :translate
>=))
4954 (csubtypep (lvar-type x
) (specifier-type 'float
))
4955 (csubtypep (lvar-type y
) (specifier-type 'float
)))
4956 `(or (,op x y
) (= x y
)))
4957 ;; Don't invert if either argument can be a float (NaNs)
4958 ((or (maybe-float-lvar-p x
) (maybe-float-lvar-p y
))
4959 (give-up-ir1-transform))
4961 `(if (,inverted x y
) nil t
)))))
4962 (deftransform >= ((x y
) (number number
) * :node node
)
4963 "invert or open code"
4964 (maybe-invert '> '< x y
))
4965 (deftransform <= ((x y
) (number number
) * :node node
)
4966 "invert or open code"
4967 (maybe-invert '< '> x y
)))
4969 ;;; FIXME: for some reason these do not survive cold-init with <=
4970 #-
(or arm arm64 x86-64 x86
)
4971 (flet ((maybe-invert (node op inverted x y
)
4973 ;; Don't invert if either argument can be a float (NaNs)
4974 ((or (maybe-float-lvar-p x
) (maybe-float-lvar-p y
))
4975 (delay-ir1-transform node
:constraint
)
4976 `(or (,op x y
) (= x y
)))
4978 `(if (,inverted x y
) nil t
)))))
4979 (deftransform >= ((x y
) (number number
) * :node node
)
4980 "invert or open code"
4981 (maybe-invert node
'> '< x y
))
4982 (deftransform <= ((x y
) (number number
) * :node node
)
4983 "invert or open code"
4984 (maybe-invert node
'< '> x y
)))
4986 ;;; See whether we can statically determine (< X Y) using type
4987 ;;; information. If X's high bound is < Y's low, then X < Y.
4988 ;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
4989 ;;; NIL). If not, at least make sure any constant arg is second.
4990 (macrolet ((def (name inverse reflexive-p surely-true surely-false
)
4991 `(deftransform ,name
((x y
))
4992 "optimize using intervals"
4993 (if (and (same-leaf-ref-p x y
)
4994 ;; For non-reflexive functions we don't need
4995 ;; to worry about NaNs: (non-ref-op NaN NaN) => false,
4996 ;; but with reflexive ones we don't know...
4998 '((and (not (maybe-float-lvar-p x
))
4999 (not (maybe-float-lvar-p y
))))))
5001 (multiple-value-bind (ix x-complex
)
5002 (type-approximate-interval (lvar-type x
))
5004 (give-up-ir1-transform))
5005 (multiple-value-bind (iy y-complex
)
5006 (type-approximate-interval (lvar-type y
))
5008 (give-up-ir1-transform))
5009 (cond ((and (or (not x-complex
)
5010 (interval-contains-p 0 ix
))
5012 (interval-contains-p 0 iy
))
5017 ((and (constant-lvar-p x
)
5018 (not (constant-lvar-p y
)))
5021 (give-up-ir1-transform)))))))))
5022 (def = = t
(interval-= ix iy
) (interval-/= ix iy
))
5023 (def < > nil
(interval-< ix iy
) (interval->= ix iy
))
5024 (def > < nil
(interval-< iy ix
) (interval->= iy ix
))
5025 (def <= >= t
(interval->= iy ix
) (interval-< iy ix
))
5026 (def >= <= t
(interval->= ix iy
) (interval-< ix iy
)))
5028 (defun ir1-transform-char< (x y first second inverse
)
5030 ((same-leaf-ref-p x y
) nil
)
5031 ;; If we had interval representation of character types, as we
5032 ;; might eventually have to to support 2^21 characters, then here
5033 ;; we could do some compile-time computation as in transforms for
5034 ;; < above. -- CSR, 2003-07-01
5035 ((and (constant-lvar-p first
)
5036 (not (constant-lvar-p second
)))
5038 (t (give-up-ir1-transform))))
5040 (deftransform char
< ((x y
) (character character
) *)
5041 (ir1-transform-char< x y x y
'char
>))
5043 (deftransform char
> ((x y
) (character character
) *)
5044 (ir1-transform-char< y x x y
'char
<))
5046 ;;;; converting N-arg comparisons
5048 ;;;; We convert calls to N-arg comparison functions such as < into
5049 ;;;; two-arg calls. This transformation is enabled for all such
5050 ;;;; comparisons in this file. If any of these predicates are not
5051 ;;;; open-coded, then the transformation should be removed at some
5052 ;;;; point to avoid pessimization.
5054 ;;; This function is used for source transformation of N-arg
5055 ;;; comparison functions other than inequality. If the call has two
5056 ;;; args, then we pass or return a negated test as appropriate. If it
5057 ;;; is a degenerate one-arg call, then we transform to code that
5058 ;;; returns true. Otherwise, we bind all the arguments and expand into
5060 (defun multi-compare (predicate args not-p type
)
5061 (let ((nargs (length args
)))
5062 (cond ((< nargs
1) (values nil t
))
5063 ((= nargs
1) `(progn (the ,type
,@args
) t
))
5066 `(if (,predicate
,(first args
) ,(second args
)) nil t
)
5069 (do* ((i (1- nargs
) (1- i
))
5071 (current (gensym) (gensym))
5072 (vars (list current
) (cons current vars
))
5074 `(if (,predicate
,current
,last
)
5076 `(if (,predicate
,current
,last
)
5080 ;; the first two arguments will be checked by the comparison function.
5081 (declare (type ,type
,@(subseq vars
2)))
5085 (define-source-transform = (&rest args
) (multi-compare '= args nil
'number
))
5086 (define-source-transform < (&rest args
) (multi-compare '< args nil
'real
))
5087 (define-source-transform > (&rest args
) (multi-compare '> args nil
'real
))
5088 ;;; We cannot do the inversion for >= and <= here, since both
5089 ;;; (< NaN X) and (> NaN X)
5090 ;;; are false, and we don't have type-information available yet. The
5091 ;;; deftransforms for two-argument versions of >= and <= takes care of
5092 ;;; the inversion to > and < when possible.
5093 (define-source-transform <= (&rest args
) (multi-compare '<= args nil
'real
))
5094 (define-source-transform >= (&rest args
) (multi-compare '>= args nil
'real
))
5096 (define-source-transform char
= (&rest args
) (multi-compare 'char
= args nil
5098 (define-source-transform char
< (&rest args
) (multi-compare 'char
< args nil
5100 (define-source-transform char
> (&rest args
) (multi-compare 'char
> args nil
5102 (define-source-transform char
<= (&rest args
) (multi-compare 'char
> args t
5104 (define-source-transform char
>= (&rest args
) (multi-compare 'char
< args t
5107 (define-source-transform char-equal
(&rest args
)
5108 (multi-compare 'char-equal args nil
'character
))
5109 (define-source-transform char-lessp
(&rest args
)
5110 (multi-compare 'char-lessp args nil
'character
))
5111 (define-source-transform char-greaterp
(&rest args
)
5112 (multi-compare 'char-greaterp args nil
'character
))
5113 (define-source-transform char-not-greaterp
(&rest args
)
5114 (multi-compare 'char-greaterp args t
'character
))
5115 (define-source-transform char-not-lessp
(&rest args
)
5116 (multi-compare 'char-lessp args t
'character
))
5118 ;;; This function does source transformation of N-arg inequality
5119 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
5120 ;;; arg cases. If there are more than two args, then we expand into
5121 ;;; the appropriate n^2 comparisons only when speed is important.
5122 (declaim (ftype (function (symbol list t
) *) multi-not-equal
))
5123 (defun multi-not-equal (predicate args type
)
5124 (let ((nargs (length args
)))
5125 (cond ((< nargs
1) (values nil t
))
5126 ((= nargs
1) `(progn (the ,type
,@args
) t
))
5128 `(if (,predicate
,(first args
) ,(second args
)) nil t
))
5129 ((or (> (length args
) 50)
5130 (not (policy *lexenv
*
5131 (and (>= speed space
)
5132 (>= speed compilation-speed
)))))
5135 (let ((vars (make-gensym-list nargs
)))
5137 (declare (type ,type
,@vars
))
5140 ,@(loop for
(var . rest
) on vars
5141 nconc
(loop for var2 in rest
5142 collect
`(if (,predicate
,var
,var2
)
5146 (return-from nil nil
))))
5149 (define-source-transform /= (&rest args
)
5150 (multi-not-equal '= args
'number
))
5151 (define-source-transform char
/= (&rest args
)
5152 (multi-not-equal 'char
= args
'character
))
5153 (define-source-transform char-not-equal
(&rest args
)
5154 (multi-not-equal 'char-equal args
'character
))
5156 ;;; Expand MAX and MIN into the obvious comparisons.
5157 (define-source-transform max
(arg0 &rest rest
)
5159 `(values (the real
,arg0
))
5160 (labels ((expand (arg0 &rest rest
)
5163 (once-only ((arg0 arg0
)
5164 (minrest (apply #'expand rest
)))
5165 `(if (> ,minrest
,arg0
)
5168 (apply #'expand arg0 rest
))))
5170 (define-source-transform min
(arg0 &rest rest
)
5172 `(values (the real
,arg0
))
5173 (labels ((expand (arg0 &rest rest
)
5176 (once-only ((arg0 arg0
)
5177 (maxrest (apply #'expand rest
)))
5178 `(if (< ,maxrest
,arg0
)
5181 (apply #'expand arg0 rest
))))
5183 ;;; Simplify some cross-type comparisons
5184 (macrolet ((def (comparator round
)
5186 (deftransform ,comparator
5187 ((x y
) (rational (constant-arg float
)))
5188 "open-code RATIONAL to FLOAT comparison"
5189 (let ((y (lvar-value y
)))
5190 (when (float-infinity-or-nan-p y
)
5191 (give-up-ir1-transform))
5192 (setf y
(rational y
))
5194 x
,(if (csubtypep (lvar-type x
)
5195 (specifier-type 'integer
))
5198 (deftransform ,comparator
5199 ((x y
) (integer (constant-arg ratio
)))
5200 "open-code INTEGER to RATIO comparison"
5201 `(,',comparator x
,(,round
(lvar-value y
)))))))
5205 (macrolet ((def (comparator not-equal round
)
5207 (deftransform ,comparator
5208 ((x y
) (rational (constant-arg float
)))
5209 "open-code RATIONAL to FLOAT comparison"
5210 (let ((y (lvar-value y
)))
5211 (when (float-infinity-or-nan-p y
)
5212 (give-up-ir1-transform))
5213 (setf y
(rational y
))
5214 (multiple-value-bind (qout rem
)
5215 (if (csubtypep (lvar-type x
)
5216 (specifier-type 'integer
))
5223 (deftransform ,comparator
5224 ((x y
) (integer (constant-arg ratio
)))
5225 "open-code INTEGER to RATIO comparison"
5226 `(,',not-equal x
,(,round
(lvar-value y
)))))))
5230 (macrolet ((def (name x y type-x type-y
&optional non-fixnum
)
5231 `(deftransform ,name
((,x
,y
) (,type-x
,type-y
) * :node node
:important nil
)
5232 (cond ((or (csubtypep (lvar-type i
) (specifier-type 'word
))
5233 (csubtypep (lvar-type i
) (specifier-type 'sb-vm
:signed-word
)))
5234 (give-up-ir1-transform))
5236 ;; Give the range-transform optimizers a chance to trigger.
5237 (delay-ir1-transform node
:ir1-phases
)
5239 (let ((i (truly-the fixnum i
)))
5240 (,',name
,',x
,',y
))
5243 (def < i f
(integer #.most-negative-fixnum
) fixnum
)
5244 (def > f i fixnum
(integer #.most-negative-fixnum
))
5246 (def > i f
(integer * #.most-positive-fixnum
) fixnum
)
5247 (def < f i fixnum
(integer * #.most-positive-fixnum
))
5249 (def > i f
(integer #.most-negative-fixnum
) fixnum t
)
5250 (def < f i fixnum
(integer #.most-negative-fixnum
) t
)
5252 (def < i f
(integer * #.most-positive-fixnum
) fixnum t
)
5253 (def > f i fixnum
(integer * #.most-positive-fixnum
) t
))
5255 (deftransform < ((x y
) (integer (eql #.
(1+ most-positive-fixnum
))) * :important nil
)
5256 `(not (> x most-positive-fixnum
)))
5258 (deftransform > ((x y
) (integer (eql #.
(1- most-negative-fixnum
))) * :important nil
)
5259 `(not (< x most-negative-fixnum
)))
5261 (deftransform = ((x y
) (rational (constant-arg float
)))
5262 "open-code RATIONAL to FLOAT comparison"
5263 (let ((y (lvar-value y
)))
5264 (when (float-infinity-or-nan-p y
)
5265 (give-up-ir1-transform))
5266 (setf y
(rational y
))
5267 (if (and (csubtypep (lvar-type x
)
5268 (specifier-type 'integer
))
5269 (sb-xc:typep y
'ratio
))
5273 (deftransform = ((x y
) (t (constant-arg integer
)))
5274 (let ((y (lvar-value y
)))
5275 (if (and (if (cast-p (lvar-uses x
))
5276 ;; Only when X is already a number.
5277 (csubtypep (lvar-type (cast-value (lvar-uses x
)))
5278 (specifier-type 'number
))
5280 (handler-case (not (sb-xc:= y
(coerce y
'double-float
)))
5281 (floating-point-overflow ()
5283 (handler-case (not (sb-xc:= y
(coerce y
'single-float
)))
5284 (floating-point-overflow ()
5287 (give-up-ir1-transform))))
5289 (deftransform = ((x y
) (integer (constant-arg ratio
)))
5290 "constant-fold INTEGER to RATIO comparison"
5293 ;;;; converting N-arg arithmetic functions
5295 ;;;; N-arg arithmetic and logic functions are associated into two-arg
5296 ;;;; versions, and degenerate cases are flushed.
5298 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
5299 (declaim (ftype (sfunction (symbol t list
) list
) associate-args
))
5300 (defun associate-args (fun first-arg more-args
)
5302 (let ((next (rest more-args
))
5303 (arg (first more-args
)))
5305 `(,fun
,first-arg
,arg
)
5306 (associate-args fun
`(,fun
,first-arg
,arg
) next
))))
5308 ;;; Reduce constants in ARGS list.
5309 (declaim (ftype (sfunction (symbol list symbol
) list
) reduce-constants
))
5310 (defun reduce-constants (fun args one-arg-result-type
)
5311 (let ((one-arg-constant-p (ecase one-arg-result-type
5313 (integer #'integerp
)))
5316 (collect ((not-constants))
5318 (let ((value (if (constantp arg
)
5319 (constant-form-value arg
)
5321 (cond ((not (funcall one-arg-constant-p value
))
5322 (not-constants arg
))
5324 (handler-case (funcall fun reduced-value value
)
5325 (arithmetic-error ()
5326 (not-constants arg
))
5328 ;; Some backends have no float traps
5329 (cond #+(and (or arm arm64 riscv
)
5331 ((or (and (floatp value
)
5332 (float-infinity-or-nan-p value
))
5333 (and (complex-float-p value
)
5334 (or (float-infinity-or-nan-p (imagpart value
))
5335 (float-infinity-or-nan-p (realpart value
)))))
5336 (not-constants arg
))
5338 (setf reduced-value value
5341 (setf reduced-value value
)))))
5342 ;; It is tempting to drop constants reduced to identity here,
5343 ;; but if X is SNaN in (* X 1), we cannot drop the 1.
5346 `(,reduced-value
,@(not-constants))
5348 `(,reduced-value
)))))
5350 ;;; Do source transformations for transitive functions such as +.
5351 ;;; One-arg cases are replaced with the arg and zero arg cases with
5352 ;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE)
5353 ;;; that the argument in one-argument calls is.
5354 (declaim (ftype (function (symbol list t
&optional symbol list
)
5355 * ; KLUDGE: avoid "assertion too complex to check"
5356 #|
(values t
&optional
(member nil t
))|
#)
5357 source-transform-transitive
))
5358 (defun source-transform-transitive (fun args identity
5359 &optional
(one-arg-result-type 'number
)
5360 (one-arg-prefixes '(values)))
5363 (1 `(,@one-arg-prefixes
(the ,one-arg-result-type
,(first args
))))
5366 (let* ((reduced-args (reduce-constants fun args one-arg-result-type
))
5367 (first (first reduced-args
))
5368 (rest (rest reduced-args
)))
5370 (associate-args fun first rest
)
5373 (define-source-transform + (&rest args
)
5374 (source-transform-transitive '+ args
0))
5375 (define-source-transform * (&rest args
)
5376 (source-transform-transitive '* args
1))
5377 (define-source-transform logior
(&rest args
)
5378 (source-transform-transitive 'logior args
0 'integer
))
5379 (define-source-transform logxor
(&rest args
)
5380 (source-transform-transitive 'logxor args
0 'integer
))
5381 (define-source-transform logand
(&rest args
)
5382 (source-transform-transitive 'logand args -
1 'integer
))
5383 #-
(or arm arm64 mips x86 x86-64 riscv
) ; defined in compiler/{arch}/arith.lisp
5384 (define-source-transform logeqv
(&rest args
)
5385 (source-transform-transitive 'logeqv args -
1 'integer
))
5386 (define-source-transform gcd
(&rest args
)
5387 (source-transform-transitive 'gcd args
0 'integer
'(abs)))
5388 (define-source-transform lcm
(&rest args
)
5389 (source-transform-transitive 'lcm args
1 'integer
'(abs)))
5390 (deftransform logandc1
((x y
))
5393 (deftransform gcd
((x y
) ((and fixnum
(not (eql 0)))
5394 (and fixnum
(not (eql 0)))))
5395 `(sb-kernel::fixnum-gcd x y
))
5397 (deftransforms (gcd sb-kernel
::fixnum-gcd
) ((x y
))
5398 (cond ((or (same-leaf-ref-p x y
)
5399 (lvar-value-is y
0))
5401 ((lvar-value-is x
0)
5404 (give-up-ir1-transform))))
5406 (deftransform lcm
((x y
))
5407 (cond ((or (same-leaf-ref-p x y
)
5408 (csubtypep (lvar-type y
) (specifier-type '(or (eql -
1) (eql 1)))))
5410 ((csubtypep (lvar-type x
) (specifier-type '(or (eql -
1) (eql 1))))
5412 ((or (lvar-value-is x
0)
5413 (lvar-value-is y
0))
5416 (give-up-ir1-transform))))
5418 (defun derive-gcd (args)
5424 (loop for arg in args
5425 for type
= (lvar-type arg
)
5426 do
(multiple-value-bind (low high
) (integer-type-numeric-bounds type
)
5427 (let ((zero (types-equal-or-intersect type
(specifier-type '(eql 0)))))
5429 (setf includes-zero nil
))
5430 (cond ((not (and low high
))
5432 ((and (= (abs low
) 1)
5435 (return-from derive-gcd
(specifier-type '(eql 1))))
5441 most-positive-fixnum
)))
5442 ;; Get some extra points
5443 (positive-primep (abs low
)))
5444 (pushnew (abs low
) primes
))))
5447 (setf min
(min min low
)
5448 max
(max max high
)))
5452 (specifier-type (cond ((not primes
)
5453 `(integer ,(if includes-zero
5463 `(or (eql 1) (eql ,(car primes
))))))))
5465 (defoptimizer (gcd derive-type
) ((&rest args
))
5467 (defoptimizer (sb-kernel::fixnum-gcd derive-type
) ((&rest args
))
5470 (defoptimizer (lcm derive-type
) ((&rest args
))
5473 (loop for arg in args
5474 for type
= (lvar-type arg
)
5475 do
(multiple-value-bind (low high
) (integer-type-numeric-bounds type
)
5476 (unless (and low high
)
5477 (return-from lcm-derive-type-optimizer
))
5478 (let* ((crosses-zero (<= low
0 high
))
5480 (abs-high (abs high
))
5481 (low (if crosses-zero
5483 (min abs-high abs-low
)))
5484 (high (max abs-low abs-high
)))
5486 (setf min
(min min low
))
5488 (push high maxes
))))
5489 (specifier-type `(integer ,min
,(reduce #'* maxes
)))))
5491 ;;; Do source transformations for intransitive n-arg functions such as
5492 ;;; /. With one arg, we form the inverse. With two args we pass.
5493 ;;; Otherwise we associate into two-arg calls.
5494 (declaim (ftype (function (symbol symbol list list
&optional symbol
)
5495 * ; KLUDGE: avoid "assertion too complex to check"
5496 #|
(values list
&optional
(member nil t
))|
#)
5497 source-transform-intransitive
))
5498 (defun source-transform-intransitive (fun fun
* args one-arg-prefixes
5499 &optional
(one-arg-result-type 'number
))
5501 ((0 2) (values nil t
))
5502 (1 `(,@one-arg-prefixes
(the ,one-arg-result-type
,(first args
))))
5505 (reduce-constants fun
* (rest args
) one-arg-result-type
)))
5506 (associate-args fun
(first args
) reduced-args
)))))
5508 (define-source-transform -
(&rest args
)
5509 (source-transform-intransitive '-
'+ args
'(%negate
)))
5510 (define-source-transform / (&rest args
)
5511 (source-transform-intransitive '/ '* args
'(/ 1)))
5513 ;;;; a hack to clean up divisions
5515 (defun count-low-order-zeros (thing)
5518 (if (constant-lvar-p thing
)
5519 (count-low-order-zeros (lvar-value thing
))
5520 (count-low-order-zeros (lvar-uses thing
))))
5522 (case (let ((name (lvar-fun-name (combination-fun thing
))))
5523 (or (modular-version-info name
:untagged nil
) name
))
5525 (let ((min most-positive-fixnum
)
5526 (itype (specifier-type 'integer
)))
5527 (dolist (arg (combination-args thing
) min
)
5528 (if (csubtypep (lvar-type arg
) itype
)
5529 (setf min
(min min
(count-low-order-zeros arg
)))
5533 (itype (specifier-type 'integer
)))
5534 (dolist (arg (combination-args thing
) result
)
5535 (if (csubtypep (lvar-type arg
) itype
)
5536 (setf result
(+ result
(count-low-order-zeros arg
)))
5539 (let ((args (combination-args thing
)))
5540 (if (= (length args
) 2)
5541 (let ((amount (second args
)))
5542 (if (constant-lvar-p amount
)
5543 (max (+ (count-low-order-zeros (first args
))
5544 (lvar-value amount
))
5552 most-positive-fixnum
5553 (do ((result 0 (1+ result
))
5554 (num thing
(ash num -
1)))
5555 ((logbitp 0 num
) result
))))
5557 (count-low-order-zeros (cast-value thing
)))
5561 (deftransform / ((numerator denominator
) (integer integer
))
5562 "convert x/2^k to shift"
5563 (unless (constant-lvar-p denominator
)
5564 (give-up-ir1-transform))
5565 (let* ((denominator (lvar-value denominator
))
5566 (bits (1- (integer-length denominator
))))
5567 (unless (and (> denominator
0) (= (ash 1 bits
) denominator
))
5568 (give-up-ir1-transform))
5569 (let ((alignment (count-low-order-zeros numerator
)))
5570 (unless (>= alignment bits
)
5571 (give-up-ir1-transform))
5572 `(ash numerator
,(- bits
)))))
5574 (deftransforms (rational rationalize
) ((x) (rational))
5577 (defoptimizer (rational derive-type
) ((x))
5578 (one-arg-derive-type x
(lambda (type)
5579 (labels ((%%rational
(x)
5580 (unless (and (floatp x
)
5581 (float-infinity-or-nan-p x
))
5585 (cons (list (%%rational
(car bound
))))
5587 (t (%%rational bound
)))))
5590 :low
(%rational
(numeric-type-low type
))
5591 :high
(%rational
(numeric-type-high type
)))))
5594 (defoptimizer (rationalize derive-type
) ((x))
5595 (one-arg-derive-type x
(lambda (type)
5596 (labels ((%%rationalize
(x)
5597 (unless (and (floatp x
)
5598 (float-infinity-or-nan-p x
))
5600 (%rationalize
(bound)
5602 (cons (list (%%rationalize
(car bound
))))
5604 (t (%%rationalize bound
)))))
5607 :low
(%rationalize
(numeric-type-low type
))
5608 :high
(%rationalize
(numeric-type-high type
)))))
5612 ;;;; transforming APPLY
5614 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
5615 ;;; only needs to understand one kind of variable-argument call. It is
5616 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
5617 (define-source-transform apply
(fun arg
&rest more-args
)
5618 (let ((args (cons arg more-args
)))
5619 `(multiple-value-call ,fun
5620 ,@(mapcar (lambda (x) `(values ,x
)) (butlast args
))
5621 (values-list ,(car (last args
))))))
5623 ;;;; transforming references to &REST argument
5625 ;;; We add magical &MORE arguments to all functions with &REST. If ARG names
5626 ;;; the &REST argument, this returns the lambda-vars for the context and
5628 (defun possible-rest-arg-context (arg)
5630 (let* ((var (lexenv-find arg vars
))
5631 (info (when (lambda-var-p var
)
5632 (lambda-var-arg-info var
))))
5634 (eq :rest
(arg-info-kind info
))
5635 (consp (arg-info-default info
)))
5636 (values-list (arg-info-default info
))))))
5638 (defun mark-more-context-used (rest-var)
5639 (let ((info (lambda-var-arg-info rest-var
)))
5640 (aver (eq :rest
(arg-info-kind info
)))
5641 (destructuring-bind (context count
&optional used
) (arg-info-default info
)
5643 (setf (arg-info-default info
) (list context count t
))))))
5645 (defun mark-more-context-invalid (rest-var)
5646 (let ((info (lambda-var-arg-info rest-var
)))
5647 (aver (eq :rest
(arg-info-kind info
)))
5648 (setf (arg-info-default info
) t
)))
5650 ;;; This determines if the REF to a &REST variable is headed towards
5651 ;;; parts unknown, or if we can really use the context.
5652 (defun rest-var-more-context-ok (lvar)
5653 (let* ((use (lvar-use lvar
))
5654 (var (when (ref-p use
) (ref-leaf use
)))
5655 (home (when (lambda-var-p var
) (lambda-var-home var
)))
5656 (info (when (lambda-var-p var
) (lambda-var-arg-info var
)))
5657 (restp (when info
(eq :rest
(arg-info-kind info
)))))
5658 (flet ((ref-good-for-more-context-p (ref)
5659 (when (not (node-lvar ref
)) ; ref that goes nowhere is ok
5660 (return-from ref-good-for-more-context-p t
))
5661 (let ((dest (principal-lvar-end (node-lvar ref
))))
5662 (and (combination-p dest
)
5663 ;; If the destination is to anything but these, we're going to
5664 ;; actually need the rest list -- and since other operations
5665 ;; might modify the list destructively, the using the context
5666 ;; isn't good anywhere else either.
5667 (lvar-fun-is (combination-fun dest
)
5668 '(%rest-values %rest-ref %rest-length
5669 %rest-null %rest-true
))
5670 ;; If the home lambda is different and isn't DX, it might
5671 ;; escape -- in which case using the more context isn't safe.
5672 (let ((clambda (node-home-lambda dest
)))
5673 (or (eq home clambda
)
5674 (leaf-dynamic-extent clambda
)))))))
5675 (let ((ok (and restp
5676 (consp (arg-info-default info
))
5677 (not (lambda-var-specvar var
))
5678 (not (lambda-var-sets var
))
5679 (every #'ref-good-for-more-context-p
(lambda-var-refs var
)))))
5681 (mark-more-context-used var
)
5683 (mark-more-context-invalid var
)))
5686 ;;; VALUES-LIST -> %REST-VALUES
5687 (define-source-transform values-list
(list)
5688 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
5690 `(%rest-values
,list
,context
,count
)
5693 ;;; NTH -> %REST-REF
5694 (define-source-transform nth
(n list
)
5695 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
5697 `(%rest-ref
,n
,list
,context
,count
)
5699 (define-source-transform fast-
&rest-nth
(n list
)
5700 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
5702 `(%rest-ref
,n
,list
,context
,count t
)
5703 (bug "no &REST context for FAST-REST-NTH"))))
5705 (define-source-transform elt
(seq n
)
5706 (if (policy *lexenv
* (= safety
3))
5708 (multiple-value-bind (context count
) (possible-rest-arg-context seq
)
5710 `(%rest-ref
,n
,seq
,context
,count
)
5713 ;;; CAxR -> %REST-REF
5714 (defun source-transform-car (list nth
)
5715 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
5717 `(%rest-ref
,nth
,list
,context
,count
)
5720 (define-source-transform car
(list)
5721 (source-transform-car list
0))
5723 (define-source-transform cadr
(list)
5724 (or (source-transform-car list
1)
5725 `(car (cdr ,list
))))
5727 (define-source-transform caddr
(list)
5728 (or (source-transform-car list
2)
5729 `(car (cdr (cdr ,list
)))))
5731 (define-source-transform cadddr
(list)
5732 (or (source-transform-car list
3)
5733 `(car (cdr (cdr (cdr ,list
))))))
5735 ;;; LENGTH -> %REST-LENGTH
5736 (defun source-transform-length (list)
5737 (multiple-value-bind (context count
) (possible-rest-arg-context list
)
5739 `(%rest-length
,list
,context
,count
)
5741 (define-source-transform length
(list) (source-transform-length list
))
5742 (define-source-transform list-length
(list) (source-transform-length list
))
5744 (defoptimizer (length derive-type
) ((sequence))
5745 (when (csubtypep (lvar-type sequence
) (specifier-type 'list
))
5746 (specifier-type '(mod #.
(truncate sb-vm
::max-dynamic-space-size
5747 (* sb-vm
:cons-size sb-vm
:n-word-bytes
))))))
5749 ;;; ENDP, NULL and NOT -> %REST-NULL
5751 ;;; Outside &REST convert into an IF so that IF optimizations will eliminate
5752 ;;; redundant negations.
5753 (defun source-transform-null (x op
)
5754 (multiple-value-bind (context count
) (possible-rest-arg-context x
)
5756 `(%rest-null
',op
,x
,context
,count
))
5758 `(if (the list
,x
) nil t
))
5761 (define-source-transform not
(x) (source-transform-null x
'not
))
5762 (define-source-transform null
(x) (source-transform-null x
'null
))
5763 (define-source-transform endp
(x) (source-transform-null x
'endp
))
5765 (deftransform %rest-values
((list context count
))
5766 (if (rest-var-more-context-ok list
)
5767 `(%more-arg-values context
0 count
)
5768 `(values-list list
)))
5770 (deftransform %rest-ref
((n list context count
&optional length-checked-p
))
5771 (cond ((not (rest-var-more-context-ok list
))
5773 ((and length-checked-p
5774 (constant-lvar-p length-checked-p
)
5775 (lvar-value length-checked-p
))
5776 `(%more-arg context n
))
5778 `(and (< (the index n
) count
) (%more-arg context n
)))))
5780 (deftransform %rest-length
((list context count
))
5781 (if (rest-var-more-context-ok list
)
5785 (deftransform %rest-null
((op list context count
))
5786 (aver (constant-lvar-p op
))
5787 (if (rest-var-more-context-ok list
)
5789 `(,(lvar-value op
) list
)))
5791 (deftransform %rest-true
((list context count
))
5792 (if (rest-var-more-context-ok list
)
5793 `(not (eql 0 count
))
5796 ;;;; transforming FORMAT
5798 ;;;; If the control string is a compile-time constant, then replace it
5799 ;;;; with a use of the FORMATTER macro so that the control string is
5800 ;;;; ``compiled.'' Furthermore, if the destination is either a stream
5801 ;;;; or T and the control string is a function (i.e. FORMATTER), then
5802 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
5804 ;;; for compile-time argument count checking.
5806 ;;; FIXME II: In some cases, type information could be correlated; for
5807 ;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
5808 ;;; of a corresponding argument is known and does not intersect the
5809 ;;; list type, a warning could be signalled.
5810 (defglobal *optimize-format-strings
* t
)
5811 (defun check-format-args (node fun arg-n verify-arg-count
5812 &aux
(combination-args (basic-combination-args node
)))
5813 ;; ARG-N is the index into COMBINATION-ARGS of a format control string,
5815 (flet ((maybe-replace (control)
5816 (binding* ((string (lvar-value control
))
5817 ((symbols new-string
)
5818 (sb-format::extract-user-fun-directives string
)))
5819 (when (or symbols
(and new-string
(string/= string new-string
)))
5823 (cond ((not symbols
) new-string
)
5824 ((producing-fasl-file)
5825 (acond ((assoc string
(constant-cache *compilation
*) :test
'equal
)
5828 (let ((proxy (sb-format::make-fmt-control-proxy
5829 new-string symbols
)))
5830 (maybe-emit-make-load-forms proxy
)
5831 (push (cons string proxy
) (constant-cache *compilation
*))
5833 #-sb-xc-host
; no such object as a FMT-CONTROL
5835 (sb-format::make-fmt-control new-string symbols
))))
5837 (when (list-of-length-at-least-p combination-args
(1+ arg-n
))
5838 (let* ((args (nthcdr arg-n combination-args
))
5839 (control (pop args
)))
5840 (when (and (constant-lvar-p control
) (stringp (lvar-value control
)))
5841 (when verify-arg-count
5842 (binding* ((string (lvar-value control
))
5843 (*compiler-error-context
* node
)
5845 (handler-case (sb-format:%compiler-walk-format-string
5847 (sb-format:format-error
(c)
5848 (compiler-warn "~A" c
)))
5850 (nargs (length args
)))
5853 (warn 'format-too-few-args-warning
5855 "Too few arguments (~D) to ~S ~S: requires at least ~D."
5856 :format-arguments
(list nargs fun string min
)))
5858 (warn 'format-too-many-args-warning
5860 "Too many arguments (~D) to ~S ~S: uses at most ~D."
5861 :format-arguments
(list nargs fun string max
))))))
5862 ;; Now possibly replace the control string
5863 (when *optimize-format-strings
*
5864 (maybe-replace control
))
5865 (return-from check-format-args
)))
5866 ;; Look for a :FORMAT-CONTROL and possibly replace that. Always do that
5867 ;; when cross-compiling, but in the target, cautiously skip this step
5868 ;; if the first argument is not known to be a symbol. Why?
5869 ;; Well if the first argument is a string (or function), then that object
5870 ;; is *arbitrary* format-control, and the arguments that follow it do not
5871 ;; necessarily comprise a keyword/value pair list as they would for
5872 ;; constructing a condition instance. Moreover, in that case you could
5873 ;; randomly have a symbol named :FORMAT-CONTROL as an argument, randomly
5874 ;; followed by a string that is not actually a format-control!
5875 ;; But when the first argument is a symbol, then the following arguments
5876 ;; must be a plist passed to MAKE-CONDITION. [See COERCE-TO-CONDITION]
5878 ;; In this cross-compiler, this processing is not only always right, but
5879 ;; in fact mandatory, to make our format strings agnostic of package names.
5880 (when (and *optimize-format-strings
*
5881 (member fun
'(error warn style-warn
5882 compiler-warn compiler-style-warn
))
5883 ;; Hmm, should we additionally require that this symbol be
5884 ;; known to designate a subtype of SIMPLE-CONDITION? Perhaps.
5886 (csubtypep (lvar-type (car combination-args
))
5887 (specifier-type 'symbol
)))
5888 (let ((keywords (cdr combination-args
)))
5890 (unless (and keywords
(constant-lvar-p (car keywords
))) (return))
5891 (when (eq (lvar-value (car keywords
)) :format-control
)
5892 (let ((control (cadr keywords
)))
5893 (when (and (constant-lvar-p control
) (stringp (lvar-value control
)))
5894 (maybe-replace control
)))
5896 (setq keywords
(cddr keywords
))))))))
5898 ;;; FORMAT control string best-effort sanity checker and compactor
5899 (dolist (fun (append '(format error warn style-warn %program-error
)
5900 #+sb-xc-host
; No need for these after self-build
5901 '(bug compiler-mumble compiler-notify
5902 compiler-style-warn compiler-warn compiler-error
5903 maybe-compiler-notify
5904 note-lossage note-unwinnage
)))
5905 (setf (fun-info-optimizer (fun-info-or-lose fun
))
5906 (let ((arg-n (if (eq fun
'format
) 1 0))
5907 ;; in some Lisps, DOLIST uses SETQ instead of LET on the iteration
5908 ;; variable, so the closures would all share one binding of FUN,
5909 ;; which is not as intended. An extra LET solves that.
5911 (lambda (node) (check-format-args node fun arg-n t
)))))
5913 ;; Can these appear in the expansion of FORMATTER?
5915 (dolist (fun '(sb-format:format-error
5916 sb-format
::format-error-at
5917 sb-format
::format-error-at
*))
5918 (setf (fun-info-optimizer (fun-info-or-lose fun
))
5919 (let ((arg-n (if (eq fun
'sb-format
:format-error
) 0 2))
5921 (lambda (node) (check-format-args node fun arg-n nil
)))))
5923 (defoptimizer (format derive-type
) ((dest control
&rest args
))
5924 (when (lvar-value-is dest nil
)
5925 (specifier-type 'simple-string
)))
5927 ;;; We disable this transform in the cross-compiler to save memory in
5928 ;;; the target image; most of the uses of FORMAT in the compiler are for
5929 ;;; error messages, and those don't need to be particularly fast.
5931 (deftransform format
((dest control
&rest args
) (t simple-string
&rest t
) *
5932 :policy
(>= speed space
))
5933 (unless (constant-lvar-p control
)
5934 (give-up-ir1-transform "The control string is not a constant."))
5935 (let* ((argc (length args
))
5936 (arg-names (make-gensym-list argc
))
5937 (control (lvar-value control
))
5938 ;; Expanding the control string now avoids deferring to FORMATTER
5939 ;; so that we don't need an internal-only variant of it that
5940 ;; passes through extra args to %FORMATTER.
5941 ;; FIXME: instead of checking the condition report, define a
5942 ;; dedicated condition class
5943 (expr (handler-case ; in case %formatter wants to signal an error
5944 (sb-format::%formatter control argc nil
)
5945 ;; otherwise, let the macro complain
5946 (sb-format:format-error
(c)
5947 (if (string= (sb-format::format-error-complaint c
)
5948 "No package named ~S")
5949 ;; "~/apackage:afun/" might become legal later.
5950 ;; To put it in perspective, "~/f" (no closing slash)
5951 ;; *will* be a runtime error, but this only *might* be
5952 ;; a runtime error, so we can't signal a full warning.
5953 ;; At absolute worst it should be a style-warning.
5954 (give-up-ir1-transform "~~// directive mentions unknown package")
5955 `(formatter ,control
))))))
5956 `(lambda (dest control
,@arg-names
)
5957 (declare (ignore control
))
5958 (format dest
,expr
,@arg-names
))))
5960 (deftransform format
((stream control
&rest args
) (stream function
&rest t
))
5961 (let ((arg-names (make-gensym-list (length args
))))
5962 `(lambda (stream control
,@arg-names
)
5963 (funcall control stream
,@arg-names
)
5966 (deftransform format
((tee control
&rest args
) ((member t
) function
&rest t
))
5967 (let ((arg-names (make-gensym-list (length args
))))
5968 `(lambda (tee control
,@arg-names
)
5969 (declare (ignore tee
))
5970 (funcall control
*standard-output
* ,@arg-names
)
5973 (deftransform format
((stream control
&rest args
) (null function
&rest t
))
5974 (let ((arg-names (make-gensym-list (length args
))))
5975 `(lambda (stream control
,@arg-names
)
5976 (declare (ignore stream
))
5977 (%with-output-to-string
(stream)
5978 (funcall control stream
,@arg-names
)))))
5980 (defun concatenate-format-p (control args
)
5982 (loop for directive in control
5984 (or (stringp directive
)
5985 (and (sb-format::format-directive-p directive
)
5986 (let ((char (sb-format::directive-character directive
))
5987 (params (sb-format::directive-params directive
)))
5988 (and (char= char
#\A
)
5993 (deftransform format
((stream control
&rest args
) (null (constant-arg string
) &rest string
))
5996 (sb-format::tokenize-control-string
(coerce (lvar-value control
) 'simple-string
))
5997 (sb-format:format-error
()
5998 (give-up-ir1-transform)))))
5999 (unless (concatenate-format-p tokenized args
)
6000 (give-up-ir1-transform))
6001 (let ((arg-names (make-gensym-list (length args
))))
6002 `(lambda (stream control
,@arg-names
)
6003 (declare (ignore stream control
)
6004 (ignorable ,@arg-names
))
6007 ,@(mapcar (lambda (directive)
6008 (if (stringp directive
)
6010 (let ((arg (pop args
))
6011 (arg-name (pop arg-names
)))
6012 (if (constant-lvar-p arg
)
6017 (deftransform pathname
((pathspec) (pathname) *)
6020 (deftransform pathname
((pathspec) (string) *)
6021 '(values (parse-namestring pathspec
)))
6023 (defoptimizer (cerror optimizer
) ((report control
&rest args
))
6024 (when (and (constant-lvar-p control
)
6025 (constant-lvar-p report
))
6026 (let ((x (lvar-value control
))
6027 (y (lvar-value report
)))
6028 (when (and (stringp x
) (stringp y
))
6029 (multiple-value-bind (min1 max1
)
6031 (sb-format:%compiler-walk-format-string x args
)
6032 (sb-format:format-error
(c)
6033 (compiler-warn "~A" c
)))
6035 (multiple-value-bind (min2 max2
)
6037 (sb-format:%compiler-walk-format-string y args
)
6038 (sb-format:format-error
(c)
6039 (compiler-warn "~A" c
)))
6041 (let ((nargs (length args
)))
6043 ((< nargs
(min min1 min2
))
6044 (warn 'format-too-few-args-warning
6046 "Too few arguments (~D) to ~S ~S ~S: ~
6047 requires at least ~D."
6049 (list nargs
'cerror y x
(min min1 min2
))))
6050 ((> nargs
(max max1 max2
))
6051 (warn 'format-too-many-args-warning
6053 "Too many arguments (~D) to ~S ~S ~S: ~
6056 (list nargs
'cerror y x
(max max1 max2
))))))))))))))
6058 (deftransform error
((x &key datum expected-type format-control format-arguments
))
6059 (if (and format-control format-arguments
6060 (let ((use (lvar-uses format-arguments
)))
6061 (and (combination-p use
)
6062 (lvar-fun-is (combination-fun use
) '(list)))))
6063 (cond ((and datum expected-type
)
6064 `(apply #'%simple-type-error x datum expected-type format-control format-arguments
))
6065 ((not (and datum expected-type
))
6066 `(apply #'%simple-error x format-control format-arguments
))
6068 (give-up-ir1-transform)))
6069 (give-up-ir1-transform)))
6071 (defun constant-cons-type (type)
6072 (multiple-value-bind (singleton value
)
6073 (type-singleton-p type
)
6078 (multiple-value-bind (car car-good
)
6079 (constant-cons-type (cons-type-car-type type
))
6080 (multiple-value-bind (cdr cdr-good
)
6081 (constant-cons-type (cons-type-cdr-type type
))
6082 (and car-good cdr-good
6083 (values (cons car cdr
) t
)))))))))
6085 (defoptimizer (coerce derive-type
) ((value type
))
6086 (multiple-value-bind (type constant
)
6087 (if (constant-lvar-p type
)
6088 (values (lvar-value type
) t
)
6089 (constant-cons-type (lvar-type type
)))
6091 ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
6092 ;; but dealing with the niggle that complex canonicalization gets
6093 ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
6095 (let ((result-typeoid (careful-specifier-type type
)))
6097 ((null result-typeoid
) nil
)
6098 ((csubtypep result-typeoid
(specifier-type 'number
))
6099 ;; the difficult case: we have to cope with ANSI 12.1.5.3
6100 ;; Rule of Canonical Representation for Complex Rationals,
6101 ;; which is a truly nasty delivery to field.
6103 ((csubtypep result-typeoid
(specifier-type 'real
))
6104 ;; cleverness required here: it would be nice to deduce
6105 ;; that something of type (INTEGER 2 3) coerced to type
6106 ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0).
6107 ;; FLOAT gets its own clause because it's implemented as
6108 ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE
6111 ((and (numeric-type-p result-typeoid
)
6112 (eq (numeric-type-complexp result-typeoid
) :real
))
6113 ;; FIXME: is this clause (a) necessary or (b) useful?
6115 ((or (csubtypep result-typeoid
6116 (specifier-type '(complex single-float
)))
6117 (csubtypep result-typeoid
6118 (specifier-type '(complex double-float
)))
6120 (csubtypep result-typeoid
6121 (specifier-type '(complex long-float
))))
6122 ;; float complex types are never canonicalized.
6125 ;; if it's not a REAL, or a COMPLEX FLOAToid, it's
6126 ;; probably just a COMPLEX or equivalent. So, in that
6127 ;; case, we will return a complex or an object of the
6128 ;; provided type if it's rational:
6129 (type-union result-typeoid
6130 (type-intersection (lvar-type value
)
6131 (specifier-type 'rational
))))))
6133 result-typeoid
))))))
6135 (defoptimizer (compile derive-type
) ((nameoid function
))
6136 (when (csubtypep (lvar-type nameoid
)
6137 (specifier-type 'null
))
6138 (values-specifier-type '(values function boolean boolean
))))
6140 ;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
6141 ;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
6142 ;;; optimizer, above).
6143 (defoptimizer (array-element-type derive-type
) ((array))
6144 (let ((array-type (lvar-type array
)))
6145 (labels ((consify (list)
6148 `(cons (eql ,(car list
)) ,(consify (rest list
)))))
6149 (get-element-type (a)
6151 (type-specifier (array-type-specialized-element-type a
))))
6152 (cond ((eq element-type
'*)
6153 (specifier-type 'type-specifier
))
6154 ((symbolp element-type
)
6155 (make-eql-type element-type
))
6156 ((consp element-type
)
6157 (specifier-type (consify element-type
)))
6159 (error "can't understand type ~S~%" element-type
))))))
6160 (labels ((recurse (type)
6161 (cond ((array-type-p type
)
6162 (get-element-type type
))
6163 ((union-type-p type
)
6165 (mapcar #'recurse
(union-type-types type
))))
6167 *universal-type
*))))
6168 (recurse array-type
)))))
6170 (deftransform array-element-type
((array))
6171 (let ((type (lvar-type array
)))
6172 (flet ((element-type (type)
6173 (and (array-type-p type
)
6174 (neq (array-type-specialized-element-type type
) *wild-type
*)
6175 (type-specifier (array-type-specialized-element-type type
)))))
6176 (cond ((let ((type (element-type type
)))
6179 ((union-type-p type
)
6181 (loop for type in
(union-type-types type
)
6182 for et
= (element-type type
)
6187 do
(give-up-ir1-transform))
6189 ((intersection-type-p type
)
6190 (loop for type in
(intersection-type-types type
)
6191 for et
= (element-type type
)
6194 finally
(give-up-ir1-transform)))
6196 (give-up-ir1-transform))))))
6198 (define-source-transform sb-impl
::sort-vector
(vector start end predicate key
)
6199 ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
6200 ;; isn't really related to the CMU CL code, since instead of trying
6201 ;; to generalize the CMU CL code to allow START and END values, this
6202 ;; code has been written from scratch following Chapter 7 of
6203 ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
6204 `(macrolet ((%index
(x) `(truly-the index
,x
))
6205 (%parent
(i) `(ash ,i -
1))
6206 (%left
(i) `(%index
(ash ,i
1)))
6207 (%right
(i) `(%index
(1+ (ash ,i
1))))
6210 (%index
(+ (%index
,i
) start-1
))))
6213 (left (%left i
) (%left i
)))
6214 ((> left current-heap-size
))
6215 (declare (type index i left
))
6216 (let* ((i-elt (%elt i
))
6217 (i-key (funcall keyfun i-elt
))
6218 (left-elt (%elt left
))
6219 (left-key (funcall keyfun left-elt
)))
6220 (multiple-value-bind (large large-elt large-key
)
6221 (if (funcall ,',predicate i-key left-key
)
6222 (values left left-elt left-key
)
6223 (values i i-elt i-key
))
6224 (let ((right (%right i
)))
6225 (multiple-value-bind (largest largest-elt
)
6226 (if (> right current-heap-size
)
6227 (values large large-elt
)
6228 (let* ((right-elt (%elt right
))
6229 (right-key (funcall keyfun right-elt
)))
6230 (if (funcall ,',predicate large-key right-key
)
6231 (values right right-elt
)
6232 (values large large-elt
))))
6233 (cond ((= largest i
)
6236 (setf (%elt i
) largest-elt
6237 (%elt largest
) i-elt
6239 (%sort-vector
(keyfun)
6240 `(let ( ;; Heaps prefer 1-based addressing.
6241 (start-1 (1- ,',start
))
6242 (current-heap-size (- ,',end
,',start
))
6244 (declare (type (integer -
1 #.
(1- most-positive-fixnum
))
6246 (declare (type index current-heap-size
))
6247 (declare (type function keyfun
))
6248 (loop for i of-type index
6249 from
(ash current-heap-size -
1) downto
1 do
6252 (when (< current-heap-size
2)
6254 (rotatef (%elt
1) (%elt current-heap-size
))
6255 (decf current-heap-size
)
6257 (declare (optimize (insert-array-bounds-checks 0) speed
))
6258 (if (typep ,vector
'simple-vector
)
6259 ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
6260 ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
6262 ;; Special-casing the KEY=NIL case lets us avoid some
6264 (%sort-vector
#'identity
)
6265 (%sort-vector
,key
))
6266 ;; It's hard to anticipate many speed-critical applications for
6267 ;; sorting vector types other than (VECTOR T), so we just lump
6268 ;; them all together in one slow dynamically typed mess.
6270 (declare (optimize (inhibit-warnings 3)))
6271 (%sort-vector
(or ,key
#'identity
))))))
6273 (deftransform sort
((list predicate
&key key
)
6275 `(sb-impl::stable-sort-list list
6276 (%coerce-callable-to-fun predicate
)
6277 (if key
(%coerce-callable-to-fun key
) #'identity
)))
6279 (deftransform stable-sort
((sequence predicate
&key key
)
6280 ((or vector list
) t
))
6281 (let ((sequence-type (lvar-type sequence
)))
6282 (cond ((csubtypep sequence-type
(specifier-type 'list
))
6283 `(sb-impl::stable-sort-list sequence
6284 (%coerce-callable-to-fun predicate
)
6285 (if key
(%coerce-callable-to-fun key
) #'identity
)))
6286 ((csubtypep sequence-type
(specifier-type 'simple-vector
))
6287 `(sb-impl::stable-sort-simple-vector sequence
6288 (%coerce-callable-to-fun predicate
)
6289 (and key
(%coerce-callable-to-fun key
))))
6291 `(sb-impl::stable-sort-vector sequence
6292 (%coerce-callable-to-fun predicate
)
6293 (and key
(%coerce-callable-to-fun key
)))))))
6295 ;;;; transforms for SB-EXT:OCTETS-TO-STRING and SB-EXT:STRING-TO-OCTETS
6297 #+sb-xc
; not needed to cross-compile
6299 (deftransform string-to-octets
((string &key external-format
(start 0) end null-terminate
)
6303 "precompute external-format lookup"
6304 (unless external-format
6305 (give-up-ir1-transform))
6306 (unless (constant-lvar-p external-format
)
6307 (give-up-ir1-transform))
6308 (let ((xf-designator (lvar-value external-format
)))
6309 (when (eql xf-designator
:default
)
6310 (give-up-ir1-transform))
6311 (let ((xf (get-external-format xf-designator
)))
6313 (give-up-ir1-transform))
6314 (let ((form `(let ((fun (load-time-value
6315 (sb-impl::ef-string-to-octets-fun
6316 (get-external-format ',xf-designator
))
6320 (sb-impl::ef-replacement
6321 (get-external-format ',xf-designator
)))))
6322 (sb-impl::%string-to-octets fun string start end
6323 (if null-terminate
1 0) replacement
))))
6324 (if (or (csubtypep (lvar-type string
) (specifier-type 'simple-string
))
6325 (policy node
(> speed space
)))
6326 `(locally (declare (inline sb-impl
::%string-to-octets
))
6329 (deftransform octets-to-string
((vector &key external-format
(start 0) end
)
6333 "precompute external-format lookup"
6334 (unless external-format
6335 (give-up-ir1-transform))
6336 (unless (constant-lvar-p external-format
)
6337 (give-up-ir1-transform))
6338 (let ((xf-designator (lvar-value external-format
)))
6339 (when (eql xf-designator
:default
)
6340 (give-up-ir1-transform))
6341 (let ((xf (get-external-format xf-designator
)))
6343 (give-up-ir1-transform))
6344 (let ((form `(let ((fun (load-time-value
6345 (sb-impl::ef-octets-to-string-fun
6346 (get-external-format ',xf-designator
))
6350 (sb-impl::ef-replacement
6351 (get-external-format ',xf-designator
)))))
6352 (sb-impl::%octets-to-string fun vector start end replacement
))))
6353 (if (or (csubtypep (lvar-type vector
) (specifier-type '(simple-array (unsigned-byte 8) (*))))
6354 (policy node
(> speed space
)))
6355 `(locally (declare (inline sb-impl
::%octets-to-string
))
6360 ;;;; debuggers' little helpers
6362 ;;; for debugging when transforms are behaving mysteriously,
6363 ;;; e.g. when debugging a problem with an ASH transform
6364 ;;; (defun foo (&optional s)
6365 ;;; (sb-c::/report-lvar s "S outside WHEN")
6366 ;;; (when (and (integerp s) (> s 3))
6367 ;;; (sb-c::/report-lvar s "S inside WHEN")
6368 ;;; (let ((bound (ash 1 (1- s))))
6369 ;;; (sb-c::/report-lvar bound "BOUND")
6370 ;;; (let ((x (- bound))
6372 ;;; (sb-c::/report-lvar x "X")
6373 ;;; (sb-c::/report-lvar x "Y"))
6374 ;;; `(integer ,(- bound) ,(1- bound)))))
6375 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
6376 ;;; and the function doesn't do anything at all.)
6379 (defknown /report-lvar
(t t
) null
)
6380 (deftransform /report-lvar
((x message
) (t t
))
6381 (format t
"~%/in /REPORT-LVAR~%")
6382 (format t
"/(LVAR-TYPE X)=~S~%" (lvar-type x
))
6383 (when (constant-lvar-p x
)
6384 (format t
"/(LVAR-VALUE X)=~S~%" (lvar-value x
)))
6385 (format t
"/MESSAGE=~S~%" (lvar-value message
))
6386 (give-up-ir1-transform "not a real transform"))
6387 (defun /report-lvar
(x message
)
6388 (declare (ignore x message
))))
6390 ;;; Can fold only when time-zone is supplied.
6391 (defoptimizer (encode-universal-time optimizer
)
6392 ((second minute hour date month year time-zone
) node
)
6393 (when (every #'constant-lvar-p
(basic-combination-args node
))
6394 (constant-fold-call node
)
6397 #-
(and win32
(not sb-thread
))
6398 (deftransform sleep
((seconds) ((integer 0 #.
(expt 10 8))))
6399 `(if sb-impl
::*deadline
*
6400 (locally (declare (notinline sleep
)) (sleep seconds
))
6401 (sb-unix:nanosleep seconds
0)))
6403 #-
(and win32
(not sb-thread
))
6404 (deftransform sleep
((seconds)
6405 ((constant-arg (or rational
(not (satisfies float-infinity-p
))))))
6406 (let ((seconds-value (lvar-value seconds
)))
6407 (multiple-value-bind (seconds nano
)
6408 (sb-impl::split-seconds-for-sleep seconds-value
)
6409 (if (> seconds
(expt 10 8))
6410 (give-up-ir1-transform)
6411 `(if sb-impl
::*deadline
*
6412 (locally (declare (notinline sleep
)) (sleep seconds
))
6413 (sb-unix:nanosleep
,seconds
,nano
))))))
6415 ;;; Define SYMBOL-TLS-INDEX to return the byte offset of this symbol's
6416 ;;; value cell in the lisp tls area.
6418 (define-source-transform symbol-tls-index
(sym)
6419 #+64-bit
`(ash (get-header-data ,sym
) -
24)
6420 #-
64-bit
`(truly-the (and fixnum unsigned-byte
)
6421 (ash (sb-vm::%symbol-tls-index
,sym
) sb-vm
:n-fixnum-tag-bits
)))
6424 (deftransform make-string-output-stream
((&key element-type
))
6425 (case (cond ((not element-type
) #+sb-unicode
'character
#-sb-unicode
'base-char
)
6426 ((not (constant-lvar-p element-type
)) nil
)
6427 (t (let ((requested-type
6428 (ir1-transform-specifier-type (lvar-value element-type
))))
6429 (cond ((eq requested-type
*empty-type
*) nil
) ; what a loser
6430 ((csubtypep requested-type
(specifier-type 'base-char
))
6432 ((csubtypep requested-type
(specifier-type 'character
))
6434 (character `(sb-impl::%make-character-string-ostream
))
6435 (base-char `(sb-impl::%make-base-string-ostream
))
6436 (t (give-up-ir1-transform))))
6438 (flet ((xform (symbol match-kind
)
6439 (when (constant-lvar-p symbol
)
6440 (let* ((symbol (lvar-value symbol
))
6441 (kind (info :variable
:kind symbol
))
6442 (state (deprecated-thing-p 'variable symbol
)))
6444 (check-deprecated-thing 'variable symbol
)
6447 (unless (gethash symbol
(free-vars *ir1-namespace
*))
6448 (setf (gethash symbol
(free-vars *ir1-namespace
*)) :deprecated
)))))
6449 ;; :global in the test below is redundant if match-kind is :global
6450 ;; but it's harmless and a convenient way to express this.
6451 ;; Note that some 3rd-party libraries use variations on DEFCONSTANT
6452 ;; expanding into expressions such as:
6453 ;; (CL:DEFCONSTANT S (IF (BOUNDP 'S) (SYMBOL-VALUE 'S) (COMPUTE)))
6454 ;; which means we have to use care if S in for-evaluation position would
6455 ;; be converted to (LOAD-TIME-VALUE (SYMBOL-VALUE 'S)).
6456 ;; When S's value is directly dumpable, it works fine, but otherwise
6457 ;; it's dangerous. If the user wishes to avoid eager evaluation entirely,
6458 ;; a local notinline declaration on SYMBOL-VALUE will do.
6459 (when (or (eq kind match-kind
)
6461 (and (eq kind
:constant
)
6463 (typep (symbol-value symbol
) '(or character symbol
6464 fixnum
#+64-bit single-float
))))
6466 (deftransform symbol-global-value
((symbol))
6467 (or (xform symbol
:global
)
6468 (give-up-ir1-transform)))
6469 (deftransform symbol-value
((symbol))
6470 (or (xform symbol
:special
)
6471 (give-up-ir1-transform))))
6473 (deftransform symbol-value
((symbol) ((constant-arg symbol
)))
6474 (let* ((symbol (lvar-value symbol
))
6475 (kind (info :variable
:kind symbol
)))
6476 (if (and (eq kind
:constant
)
6478 (typep (symbol-value symbol
) '(or character symbol
6479 fixnum
#+64-bit single-float
)))
6481 (give-up-ir1-transform))))
6483 (deftransform boundp
((symbol) ((constant-arg symbol
)) * :policy
(< safety
3))
6484 (if (always-boundp (lvar-value symbol
))
6486 (give-up-ir1-transform)))
6488 (flet ((xform (symbol match-kind
)
6489 (let* ((symbol (lvar-value symbol
))
6490 (kind (info :variable
:kind symbol
)))
6491 (if (or (eq kind match-kind
) (memq kind
'(:constant
:global
))) ; as above
6492 `(setq ,symbol value
)
6493 (give-up-ir1-transform)))))
6494 (deftransform set-symbol-global-value
((symbol value
) ((constant-arg symbol
) t
))
6495 (xform symbol
:global
))
6496 (deftransform set
((symbol value
) ((constant-arg symbol
) t
))
6497 (xform symbol
:special
)))
6499 (deftransform symbol-package
((s) (symbol) *)
6500 (if (cast-p (lvar-uses s
))
6501 ;; Avoid inlining a type check because %symbol-package is not
6502 ;; cast-externally-checkable-p
6503 (give-up-ir1-transform)
6504 `(%symbol-package s
)))
6506 (deftransforms (prin1-to-string princ-to-string
) ((object) (number) * :important nil
)
6507 `(stringify-object object
))
6509 (deftransform princ
((object &optional stream
) (string &optional t
) * :important nil
)
6510 `(write-string object stream
))
6514 (defoptimizer (sb-thread::call-with-mutex derive-type
) ((function mutex
))
6515 (let ((type (lvar-fun-type function t t
)))
6516 (when (fun-type-p type
)
6517 (fun-type-returns type
))))
6519 (defoptimizer (sb-thread::call-with-mutex-timed derive-type
) ((function mutex waitp timeout
))
6520 (let ((type (lvar-fun-type function t t
)))
6521 (when (fun-type-p type
)
6522 (let ((null-p (not (and (constant-lvar-p waitp
)
6524 (lvar-value-is timeout nil
)))))
6526 (values-type-union (fun-type-returns type
)
6527 (values-specifier-type '(values null
&optional
)))
6528 (fun-type-returns type
))))))
6530 (macrolet ((copy (to from
)
6531 `(setf (fun-info-derive-type (fun-info-or-lose ',to
))
6532 (fun-info-derive-type (fun-info-or-lose ',from
)))))
6533 (copy sb-thread
::call-with-recursive-lock-timed sb-thread
::call-with-mutex-timed
)
6534 (copy sb-thread
::call-with-recursive-lock sb-thread
::call-with-mutex
)
6535 (copy sb-thread
::fast-call-with-mutex sb-thread
::call-with-mutex
)
6536 (copy sb-thread
::fast-call-with-recursive-lock sb-thread
::call-with-recursive-lock
))
6538 (defoptimizer (sb-thread::call-with-system-mutex derive-type
) ((function mutex
))
6539 (let ((type (lvar-fun-type function t t
)))
6540 (when (fun-type-p type
)
6541 (fun-type-returns type
))))
6543 (setf (fun-info-derive-type (fun-info-or-lose 'sb-thread
::call-with-system-mutex
/allow-with-interrupts
))
6544 (setf (fun-info-derive-type (fun-info-or-lose 'sb-thread
::call-with-system-mutex
/without-gcing
))
6545 (fun-info-derive-type (fun-info-or-lose 'sb-thread
::call-with-system-mutex
)))))
6547 (defoptimizer (sb-impl::%with-standard-io-syntax derive-type
) ((function))
6548 (let ((type (lvar-fun-type function t t
)))
6549 (when (fun-type-p type
)
6550 (fun-type-returns type
))))
6552 (defoptimizer (call-with-timing derive-type
) ((timer function
&rest arguments
))
6553 (let ((type (lvar-fun-type function t t
)))
6554 (when (fun-type-p type
)
6555 (fun-type-returns type
))))
6557 (deftransform pointerp
((object))
6558 (let ((type (lvar-type object
)))
6559 (cond ((csubtypep type
(specifier-type '(or fixnum character
#+64-bit single-float
)))
6561 ((csubtypep type
(specifier-type '(or symbol list instance function
)))
6564 (give-up-ir1-transform)))))
6566 ;;; Add transforms in reverse of the order you want them tried
6567 ;;; (because of stupid semantics)
6568 (deftransform fboundp
((symbol) (symbol))
6569 `(let ((fdefn (sb-vm::%symbol-fdefn symbol
)))
6570 (and (not (eq fdefn
0))
6571 ;; On 32-bit, where %SYMBOL-FDEFN of NIL returns NIL instead of 0,
6572 ;; this is valid code! Watch closely:
6573 ;; FDEFN-FUN is "MOV EDX, [EDX+1]"
6574 ;; But [NIL+1] is the same as CDR of NIL, which is NIL.
6575 (fdefn-fun (truly-the fdefn fdefn
)))))
6576 ;;; Normally we don't create fdefns by side-effect of calling FBOUNDP,
6577 ;;; but this transform is neutral in terms of the sum of code and data size.
6578 ;;; So for the cost of an FDEFN that might never store a function, the code
6579 ;;; is smaller by about the size of an fdefn; and it's faster, so do it.
6580 (deftransform fboundp
((name) ((constant-arg symbol
)))
6581 `(fdefn-fun (load-time-value (find-or-create-fdefn ',(lvar-value name
)) t
)))
6583 ;;; Remove special bindings with empty bodies
6584 (deftransform %cleanup-point
(() * * :node node
)
6585 (let ((prev (ctran-use (node-prev (ctran-use (node-prev node
))))))
6586 (cond ((and (combination-p prev
)
6587 (eq (combination-fun-source-name prev nil
) '%special-bind
)
6588 (not (node-next node
))
6589 (let ((succ (car (block-succ (node-block node
)))))
6592 (let ((start-cleanup (block-start-cleanup succ
)))
6593 (and (neq (node-enclosing-cleanup node
) start-cleanup
)
6594 (do-nested-cleanups (cleanup (node-block node
) t
)
6595 (when (eq cleanup start-cleanup
)
6597 (when (eq (cleanup-kind cleanup
) :dynamic-extent
)
6599 (setf (lexenv-cleanup (node-lexenv node
)) nil
)
6600 (flush-combination prev
)
6603 (give-up-ir1-transform)))))
6605 (deftransform parse-integer
((string &key
(start 0) end radix junk-allowed
)
6606 (t &key
(:radix
(constant-arg (or null
(member 10 16))))
6607 (:start t
) (:end t
) (:junk-allowed t
)))
6609 (= (lvar-value radix
) 16))
6610 'sb-impl
::parse-integer16
6611 'sb-impl
::parse-integer10
)
6612 string start end junk-allowed
))
6614 (deftransform %coerce-to-policy
((thing) (policy))
6618 (defun prev-node (node &key type
(cast t
))
6622 (setf ctran
(node-prev node
))
6623 (setf node
(ctran-use ctran
))
6627 (unless (eq type
:non-ref
)
6628 (return-from prev-node node
)))
6631 (return-from prev-node node
)))
6634 (let ((pred (block-pred (ctran-block ctran
))))
6636 (return-from prev-node
))
6637 (setf node
(block-last (car pred
)))
6640 (return-from prev-node
6641 (unless (eq type
:ref
)
6645 (defun next-node (node-or-block &key type
(cast t
) single-predecessor
6647 (let ((node node-or-block
)
6650 (when (block-p node-or-block
)
6651 (when (and single-predecessor
6652 (cdr (block-pred node-or-block
)))
6653 (return-from next-node
))
6654 (setf ctran
(block-start node-or-block
))
6657 (setf ctran
(node-next node
))
6660 (setf node
(ctran-next ctran
))
6662 (ref (unless (eq type
:non-ref
)
6663 (return-from next-node node
)))
6667 (return-from next-node node
)))
6670 (return-from next-node node
)))
6671 (t (return-from next-node
6672 (unless (eq type
:ref
)
6676 (let* ((succ (first (block-succ (node-block node
))))
6677 (start (block-start succ
)))
6679 (not (and single-predecessor
6680 (cdr (block-pred succ
)))))
6682 (go :next-ctran
))))))))
6684 (defun next-block (node)
6685 (and (not (node-next node
))
6686 (car (block-succ (node-block node
)))))
6688 (defun range-transform (op a b node
)
6689 (unless (delay-ir1-optimizer node
:ir1-phases
)
6690 (let ((if (node-dest node
)))
6691 (flet ((try (consequent alternative
)
6692 (let ((then (next-node consequent
:type
:non-ref
6693 :single-predecessor t
)))
6694 (when (and (combination-p then
)
6695 (eq (combination-kind then
) :known
)) ;; no notinline
6696 (let ((op2 (combination-fun-debug-name then
)))
6697 (when (memq op2
'(< <= > >=))
6698 (flet ((try2 (&optional reverse-if
)
6704 (destructuring-bind (a2 b2
) (combination-args then
)
6705 (when (and (cond ((same-leaf-ref-p a a2
))
6706 ((same-leaf-ref-p a b2
)
6708 (setf op2
(invert-operator op2
)))
6709 ((same-leaf-ref-p b a2
)
6711 (setf op
(invert-operator op
))))
6716 (and (if-p (setf after-then
(next-node then
)))
6719 (if-consequent after-then
)
6720 (if-alternative after-then
)))))
6721 (let* ((integerp (csubtypep (lvar-type a
) (specifier-type 'integer
)))
6723 (cond ((when (and integerp
6725 (constant-lvar-p b2
))
6726 (let ((b (lvar-value b
))
6727 (b2 (lvar-value b2
)))
6728 (multiple-value-bind (l h
)
6733 (values b
(1- b2
))))
6737 (values (1+ b2
) b
)))
6741 (values (1+ b
) (1- b2
))))
6745 (values (1+ b2
) (1- b
)))))
6747 ((and (= l most-negative-fixnum
)
6748 (= h most-positive-fixnum
))
6751 (= h most-positive-word
))
6752 `(#-
64-bit unsigned-byte-32-p
#+64-bit unsigned-byte-64-p
6754 ((and (= l
(- (expt 2 (1- sb-vm
:n-word-bits
))))
6755 (= h
(1- (expt 2 (1- sb-vm
:n-word-bits
)))))
6756 `(#-
64-bit signed-byte-32-p
#+64-bit signed-byte-64-p
6758 ((not (and (csubtypep (lvar-type b
) (specifier-type 'fixnum
))
6759 (csubtypep (lvar-type b2
) (specifier-type 'fixnum
))))
6762 (and (vop-existsp :translate range
<)
6763 (or (vop-existsp :named range
<)
6764 (and (constant-lvar-p b
)
6765 (constant-lvar-p b2
)))))
6784 ((csubtypep (lvar-type a
) (specifier-type 'fixnum
))
6791 (<= '(<= l
(truly-the fixnum x
) h
))
6792 (< '(and (<= l
(truly-the fixnum x
)) (< (truly-the fixnum x
) h
)))))
6795 (<= '(and (< l
(truly-the fixnum x
)) (<= (truly-the fixnum x
) h
)))
6796 (< '(< l
(truly-the fixnum x
) h
))))
6799 (>= '(<= l
(truly-the fixnum x
) h
))
6800 (> '(and (< l
(truly-the fixnum x
)) (<= (truly-the fixnum x
) h
)))))
6803 (>= '(and (<= l
(truly-the fixnum x
)) (< (truly-the fixnum x
) h
)))
6804 (> '(< l
(truly-the fixnum x
) h
))))))))))
6806 (kill-if-branch-1 if
(if-test if
)
6809 (setf (combination-args node
) nil
)
6810 (setf (lvar-dest b
) then
6812 (flush-combination node
)
6813 (setf (combination-args then
)
6820 (transform-call then
6822 (declare (ignorable l h
))
6830 (setf op2
(not-operator op2
))
6832 (when (and (if-p if
)
6833 (immediately-used-p (node-lvar node
) node t
))
6834 (cond ((try (if-consequent if
) (if-alternative if
)))
6836 ;; Deal with (not (< .. ...)) which is transformed from >=.
6837 (setf op
(not-operator op
))
6838 (try (if-alternative if
) (if-consequent if
)))))))))
6840 (defoptimizer (> optimizer
) ((a b
) node
)
6841 (range-transform '> a b node
))
6843 (defoptimizer (< optimizer
) ((a b
) node
)
6844 (range-transform '< a b node
))
6846 (defoptimizer (>= optimizer
) ((a b
) node
)
6847 (range-transform '>= a b node
))
6849 (defoptimizer (<= optimizer
) ((a b
) node
)
6850 (range-transform '<= a b node
))
6852 (when-vop-existsp (:translate check-range
<=)
6853 (deftransform check-range
<= ((l x h
) (t sb-vm
:signed-word t
) * :important nil
)
6855 (deftransform check-range
<= ((l x h
) (t sb-vm
:word t
) * :important nil
)
6858 (deftransform check-range
<=
6859 ((l x h
) ((constant-arg fixnum
) t
(constant-arg fixnum
)) * :important nil
)
6860 (let* ((type (lvar-type x
))
6863 (range-type (specifier-type `(integer ,l
,h
)))
6864 (intersect (type-intersection type
(specifier-type 'fixnum
))))
6865 (cond ((eq intersect
*empty-type
*)
6867 ((csubtypep intersect range-type
)
6870 (csubtypep intersect
6871 (specifier-type 'unsigned-byte
)))
6872 `(check-range<= 0 x
,h
))
6873 ((let ((int (type-approximate-interval intersect
)))
6875 (let ((power-of-two (1- (ash 1 (integer-length (interval-high int
))))))
6876 (when (< 0 power-of-two h
)
6877 `(check-range<= l x
,power-of-two
))))))
6879 (give-up-ir1-transform)))))
6881 (macrolet ((def (name ld hd
)
6882 `(deftransform ,name
((l x h
) ((constant-arg fixnum
) integer
(constant-arg fixnum
)) * :important nil
)
6883 (let* ((type (lvar-type x
))
6884 (l (+ (lvar-value l
) ,ld
))
6885 (h (+ (lvar-value h
) ,hd
))
6886 (range-type (specifier-type `(integer ,l
,h
)))
6887 (unsigned-type (type-intersection type
(specifier-type 'unsigned-byte
))))
6888 (cond ((and (neq unsigned-type
*empty-type
*)
6889 (csubtypep unsigned-type
6894 (specifier-type 'unsigned-byte
)))
6897 (give-up-ir1-transform)))))))
6901 (def range
<=< 0 -
1)))
6903 (defun find-or-chains (node op
)
6904 (let ((chains (make-array 1 :adjustable t
:fill-pointer
1 :initial-element nil
)))
6905 (labels ((chain (node)
6906 (unless (combination-or-chain-computed node
)
6907 (let ((if (node-dest node
)))
6908 (when (and (if-p if
)
6909 (immediately-used-p (node-lvar node
) node t
))
6910 (destructuring-bind (a b
) (combination-args node
)
6911 (when (and (constant-lvar-p b
)
6912 (let ((value (lvar-value b
)))
6915 (characterp value
))))
6916 (push (list (lvar-value b
) node if
)
6917 (aref chains
(1- (length chains
))))
6918 (setf (combination-or-chain-computed node
) t
)
6919 (let ((else (next-node (if-alternative if
) :type
:non-ref
6920 :single-predecessor t
)))
6921 (when (and (combination-p else
)
6922 (eq (combination-kind else
) :known
)) ;; no notinline
6923 (let ((op2 (combination-fun-debug-name else
))
6926 (let ((a2 (car (combination-args else
))))
6927 (when (and (same-leaf-ref-p a a2
)
6928 (if-p (setf after-else
(next-node else
))))
6929 (unless (eq (if-consequent if
)
6930 (if-consequent after-else
))
6931 (vector-push-extend nil chains
))
6932 (chain else
))))))))))))))
6934 (map-into chains
#'nreverse chains
))))
6936 (defun contiguous-sequence (sorted-values)
6937 (when (loop for i below
(1- (length sorted-values
))
6938 for a
= (svref sorted-values i
)
6939 always
(= (1+ a
) (svref sorted-values
(1+ i
))))
6940 (values (svref sorted-values
0)
6941 (svref sorted-values
(1- (length sorted-values
))))))
6943 (defun bit-test-sequence (sorted-values)
6944 (let ((min (elt sorted-values
0))
6945 (max (elt sorted-values
(1- (length sorted-values
)))))
6946 (and (>= min
0) ;; negative numbers can be handled too
6947 (< (- max min
) sb-vm
:n-word-bits
)
6950 (defun or-eq-transform-p (values)
6951 (and (> (length values
) 1)
6954 (map nil
(lambda (value)
6963 (setf characterp t
)))
6964 (return-from or-eq-transform-p
)))
6966 (let ((values (sort (map 'vector
(if characterp
6971 (or (contiguous-sequence values
)
6972 (bit-test-sequence values
))))))
6974 (defun replace-chain (chain form
)
6975 (let* ((node (second (first chain
)))
6976 (lvar (first (combination-args node
))))
6977 (flush-dest (second (combination-args node
)))
6978 (setf (combination-args node
) nil
)
6979 (loop for
((nil node if
) next
) on chain
6980 for
(a2 b2
) = (combination-args node
)
6983 (kill-if-branch-1 if
(if-test if
)
6986 (flush-combination node
))
6988 (setf (lvar-dest lvar
) node
)
6989 (setf (combination-args node
)
6992 (transform-call node
6994 'or-eq-transform
))))))
6996 (defun single-or-chain (chain)
6997 (let* ((node (second (first chain
)))
6998 (lvar (first (combination-args node
)))
7001 (constants (sort (map 'vector
7003 (let ((value (first e
)))
7006 (and (fixnump value
)
7009 (and (characterp value
)
7017 (return-from single-or-chain
))))
7020 (type-check (if characterp
7021 (not (csubtypep (lvar-type lvar
) (specifier-type 'character
)))
7022 (not (csubtypep (lvar-type lvar
) (specifier-type 'fixnum
)))))
7023 (range-check (if (and type-check
7025 (vop-existsp :translate check-range
<=))
7028 (flet ((type-check (check-fixnum form
)
7030 (or (not (vop-existsp :translate check-range
<=))
7033 `(when (,(if characterp
7037 (let ((a (truly-the ,(if characterp
7043 ;; Transform contiguous ranges into range<=.
7044 (when (or (vop-existsp :translate range
<)
7045 (> (length constants
) 2))
7046 (multiple-value-bind (min max
)
7047 (contiguous-sequence constants
)
7049 (replace-chain chain
7051 (declare (ignore b
))
7053 `(,range-check
,min
,(if characterp
7057 (return-from single-or-chain t
))))
7058 ;; Turn into a bit mask
7059 (multiple-value-bind (min max
)
7060 (and (> (length constants
)
7064 (bit-test-sequence constants
))
7066 (replace-chain chain
7068 (declare (ignore b
))
7070 (>= max sb-vm
:n-word-bits
)
7071 `(let ((a ,(if characterp
7074 ,(cond ((< max sb-vm
:n-word-bits
)
7075 (let ((interval (type-approximate-interval (lvar-type lvar
))))
7077 (interval-high interval
)
7078 (< (interval-high interval
) sb-vm
:n-word-bits
))
7079 (setf max
(interval-high interval
))))
7080 `(and (,range-check
0 a
,max
)
7081 (logbitp (truly-the (integer 0 ,max
) a
)
7082 ,(reduce (lambda (x y
) (logior x
(ash 1 y
)))
7083 constants
:initial-value
0))))
7086 `(let ((a (- a
,min
)))
7088 (logbitp (truly-the (integer 0 ,max
) a
)
7089 ,(reduce (lambda (x y
) (logior x
(ash 1 (- y min
))))
7090 constants
:initial-value
0))))))))))
7091 (return-from single-or-chain t
)))
7093 (labels ((%one-bit-diff-p
(c1 c2
)
7094 (and (= (ash c1
(- sb-vm
:n-word-bits
)) ;; same sign
7095 (ash c2
(- sb-vm
:n-word-bits
)))
7096 (= (logcount (logxor c1 c2
)) 1)))
7097 (one-bit-diff-p (c1 c2
)
7098 (or (%one-bit-diff-p c1 c2
)
7099 ;; If the difference is a single bit
7100 ;; then it can be masked off and compared to 0.
7101 (let ((c1 (min c1 c2
))
7103 (= (logcount (- c2 c1
)) 1)))))
7104 ;; Comparing integers that differ by only one bit,
7105 ;; which is useful for case-insensitive comparison of ASCII characters.
7106 (loop for
((c1 node if
) (c2 next-node next-if
)) = chain
7110 (destructuring-bind (a b
) (combination-args node
)
7111 (destructuring-bind (a2 b2
) (combination-args next-node
)
7114 (when (and (if characterp
7115 (and (characterp c1
)
7117 (setf c1
(char-code c1
)
7121 (one-bit-diff-p c1 c2
))
7123 (kill-if-branch-1 if
(if-test if
)
7126 (setf (combination-args node
) nil
)
7127 (flush-combination node
)
7128 (setf (lvar-dest a
) next-node
)
7129 (setf (combination-args next-node
)
7133 (let* ((value (cond (type-check
7134 ;; Operate on tagged values
7136 (setf c1
(get-lisp-obj-address c1-orig
)
7137 c2
(get-lisp-obj-address c2-orig
))
7138 '(get-lisp-obj-address a
))
7140 (setf c1
(ash c1 sb-vm
:n-fixnum-tag-bits
)
7141 c2
(ash c2 sb-vm
:n-fixnum-tag-bits
))
7142 '(mask-signed-field sb-vm
:n-word-bits
(get-lisp-obj-address a
)))))
7149 (transform-call next-node
7151 (declare (ignore b
))
7152 ,(cond ((%one-bit-diff-p c1 c2
)
7154 `(not (logtest ,value
,(lognot (logxor c1 c2
))))
7155 `(eq (logandc2 ,value
7159 `(not (logtest (,@(if type-check
7160 '(logand most-positive-word
)
7161 '(mask-signed-field sb-vm
:n-fixnum-bits
)) (- ,value
,min
))
7162 ,(lognot (- max min
)))))))
7163 'or-eq-transform
)))))))))))
7165 (defun or-eq-to-aref (keys key-lists targets last-if chains otherwise
)
7166 (let (constant-targets
7169 (ref (next-node (if-consequent last-if
) :strict t
)))
7170 (when (and (ref-p ref
)
7171 (constant-p (ref-leaf ref
)))
7172 (let ((lvar (node-lvar ref
)))
7173 (setf constant-target
(next-block ref
))
7176 for keys in key-lists
7177 for target in targets
7178 for ref
= (next-node target
:strict t
)
7179 do
(unless (and (ref-p ref
)
7180 (eq lvar
(node-lvar ref
))
7181 (constant-p (setf constant
(ref-leaf ref
)))
7184 (typep (constant-value constant
)
7185 '(or symbol number character
(and array
(not (array t
))))))
7186 (setf constant-targets nil
)
7188 (when (and (eq (ctran-kind (node-prev ref
)) :block-start
)
7189 (= (length (block-pred (node-block ref
)))
7191 (push ref constant-refs
))
7192 (push (constant-value constant
) constant-targets
)))))
7193 (when constant-targets
7194 (let ((code (expand-hash-case-for-jump-table keys key-lists nil
7195 (coerce (nreverse constant-targets
) 'vector
)
7198 (replace-chain (reduce #'append chains
)
7200 (declare (ignore b
))
7201 (to-lvar ,(node-lvar ref
)
7202 ,(or constant-target
7203 (node-ends-block ref
))
7204 (the* (,(lvar-type (node-lvar ref
)) :truly t
)
7206 (loop for ref in constant-refs
7212 (defun or-eq-to-jump-table (chains node
)
7217 (loop for chain across chains
7220 (push (if-consequent (third (first chain
))) targets
)
7222 collect
(loop for
(key node if
) in chain
7224 (when (memq key keys
)
7225 (return-from or-eq-to-jump-table
))
7229 (targets (nreverse targets
))
7230 (lvar (first (combination-args node
)))
7231 (otherwise (and last-if
7232 (if-alternative last-if
))))
7233 (cond ((not (and keys
7234 (sb-impl::should-attempt-hash-based-case-dispatch keys
)
7235 (not (key-lists-for-or-eq-transform-p key-lists
))))
7237 ((suitable-jump-table-keys-p node keys
)
7238 (replace-chain (reduce #'append chains
)
7240 (declare (ignore b
))
7241 (jump-table ,(if (characterp (first keys
))
7242 `(if-to-blocks (characterp key
)
7243 (char-code (truly-the character key
))
7244 ,(if-alternative last-if
))
7245 `(if-to-blocks (fixnump key
)
7246 (truly-the fixnum key
)
7247 ,(if-alternative last-if
)))
7248 ,@(loop for group in key-lists
7249 for target in targets
7250 append
(loop for key in group
7251 collect
(cons (if (characterp key
)
7256 (otherwise .
,otherwise
))))
7258 ((let ((diff (type-difference (lvar-type lvar
)
7259 (specifier-type `(member ,@keys
)))))
7260 ;; If it's an exhaustive case add the missing case back,
7261 ;; that way the hash doesn't need to be checked for collisions.
7262 (multiple-value-bind (p value
) (type-singleton-p diff
)
7264 (typecase (car keys
)
7265 (sb-xc:fixnum
(fixnump value
))
7266 (symbol (symbolp value
))
7267 (character (characterp value
))))
7269 (setf targets
(append targets
(list otherwise
))
7270 key-lists
(append key-lists
7271 (list (list value
)))
7274 ((or-eq-to-aref keys key-lists targets last-if chains otherwise
))
7276 (multiple-value-bind (code new-targets
)
7277 (expand-hash-case-for-jump-table keys key-lists
7280 (list (cons 'otherwise
7283 (replace-chain (reduce #'append chains
)
7285 (declare (ignore b
))
7290 `((otherwise .
,otherwise
))))
7294 ;;; Do something when comparing the same value to multiple things.
7295 (defun or-eq-transform (op a b node
)
7296 (declare (ignorable b
))
7297 (unless (delay-ir1-optimizer node
:ir1-phases
)
7298 (when (types-equal-or-intersect (lvar-type a
) (specifier-type '(or character
7301 (let ((chains (find-or-chains node op
)))
7302 (or (and (policy node
(> jump-table
0))
7303 (vop-existsp :named jump-table
)
7304 (or-eq-to-jump-table chains node
))
7305 (loop for chain across chains
7306 do
(when (cdr chain
)
7307 (single-or-chain chain
))))
7308 (unless (node-prev node
)
7309 ;; Don't proceed optimizing this node
7313 (defoptimizer (eq optimizer
) ((a b
) node
)
7314 (or-eq-transform 'eq a b node
))
7316 (defoptimizer (char= optimizer
) ((a b
) node
)
7317 (or-eq-transform 'char
= a b node
))
7319 (defun change-jump-table-targets (jump-table new-targets
)
7320 (let* ((block (node-block jump-table
)))
7321 (loop for
(nil . target
) in new-targets
7322 unless
(memq target
(block-succ block
))
7323 do
(link-blocks block target
))
7324 (loop for succ in
(block-succ block
)
7325 unless
(find succ new-targets
:key
#'cdr
)
7326 do
(unlink-blocks block succ
))
7327 (setf (jump-table-targets jump-table
) new-targets
)
7328 (reoptimize-node jump-table
)))
7330 ;;; Return T if KEYS are all of a type that is _directly_ amenable to being
7331 ;;; the branch selector in the jump-table vop, and are within a sufficiently
7332 ;;; dense range that the resulting table of assembler labels would be reasonably full.
7333 ;;; Finally, ensure that any operand encoding restrictions would be adhered to.
7334 (defun suitable-jump-table-keys-p (node keys
)
7336 (return-from suitable-jump-table-keys-p nil
))
7337 (cond ((every #'fixnump keys
))
7338 ((every #'characterp keys
) (setq keys
(mapcar #'char-code keys
)))
7339 (t (return-from suitable-jump-table-keys-p nil
)))
7340 (when (policy node
(= jump-table
3)) ;; trust it
7341 (return-from suitable-jump-table-keys-p t
))
7342 ;; There could be a backend-aware aspect to the decision about whether to
7343 ;; convert to a jump table.
7344 (flet ((can-encode (min max
)
7345 (declare (ignorable min max
))
7347 (and (typep (sb-vm:fixnumize min
) '(signed-byte 16))
7348 (typep (sb-vm:fixnumize
(- max min
)) '(signed-byte 16)))
7349 #+(or x86 x86-64 arm64
) t
))
7350 (let* ((min (reduce #'min keys
))
7351 (max (reduce #'max keys
))
7352 (table-size (1+ (- max min
)))
7353 ;; TOOD: this size could be reduced now. For spread-out fixnum keys,
7354 ;; we'll use a perfect hash, making the table exactly sized.
7355 ;; So the situation where low load factor is beneficial are few.
7356 (size-limit (* (length keys
) 2)))
7357 ;; Don't waste too much space, e.g. {5,6,10,20} would require 16 words
7358 ;; for 4 entries, which is excessive.
7359 (and (<= table-size size-limit
)
7360 (can-encode min max
)))))
7362 (defun expand-hash-case-for-jump-table (keys key-lists targets
&optional constants default
)
7363 (let* ((phash-lexpr (or (perfectly-hashable keys
)
7364 (return-from expand-hash-case-for-jump-table
(values nil nil
))))
7365 (temp '#1=#:key
) ; GENSYM considered harmful
7366 (object-hash (prehash-for-perfect-hash temp keys
))
7368 (compile-perfect-hash
7369 `(lambda (,temp
) (,phash-lexpr
,object-hash
))
7370 (coerce keys
'vector
)))
7372 (make-array (length (if constants
7374 :initial-element nil
))
7375 (key-vector (make-array (length keys
)
7377 (cond #+sb-unicode
((every #'base-char-p keys
) 'base-char
)
7378 ((every #'characterp keys
) 'character
)
7381 (loop for key-list in key-lists
7382 for target
= (pop targets
)
7384 do
(dolist (key key-list
)
7385 (let ((phash (funcall hashfn key
)))
7386 (setf (aref key-vector phash
) key
)
7388 (setf (aref result-vector phash
) (aref constants index
)))
7390 (push (cons phash target
) new-targets
)
7391 (push phash
(aref result-vector index
)))))))
7392 (when (simple-vector-p keys
)
7393 (setq keys
(coerce-to-smallest-eltype keys
)))
7394 (let* ((typed-h `(truly-the (mod ,(length (if constants
7397 (first-target (and new-targets
7398 (cdar new-targets
)))
7399 (same-targets (and new-targets
7400 (loop for
(nil . block
) in
(cdr new-targets
)
7401 always
(eq block first-target
)))))
7402 (values `(let* ((#1# key
)
7403 (h (,phash-lexpr
,object-hash
)))
7404 ;; EQL reduces to EQ for all object this expanders accepts as keys
7407 `(if-to-blocks (and (< h
,(length key-vector
))
7408 (eq (aref ,key-vector
,typed-h
) #1#))
7409 ,(let ((all-equal (not (position (aref result-vector
0) result-vector
:test-not
#'eql
))))
7411 `',(aref result-vector
0)
7412 `(aref ,result-vector
,typed-h
)))
7414 `(aref ,result-vector
(truly-the (mod ,(length result-vector
)) h
)))
7415 (let ((otherwise (cdr (assoc 'otherwise targets
))))
7418 (and (< h
,(length key-vector
))
7419 (eq (aref ,key-vector
,typed-h
) #1#))
7425 (unless same-targets
7428 (defun key-lists-for-or-eq-transform-p (key-lists)
7429 (and (= (length key-lists
) 1)
7430 (or-eq-transform-p (first key-lists
))))