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.
4
5;;;; This software is part of the SBCL system. See the README file for
6;;;; more information.
7;;;;
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.
13
14(in-package "SB!C")
15
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
18;;; arg.
19(define-source-transform identity (x) `(prog1 ,x))
20(define-source-transform values (x) `(prog1 ,x))
21
22;;; CONSTANTLY is pretty much never worth transforming, but it's good to get the type.
23(defoptimizer (constantly derive-type) ((value))
24  (specifier-type
25   `(function (&rest t) (values ,(type-specifier (lvar-type value)) &optional))))
26
27;;; If the function has a known number of arguments, then return a
28;;; lambda with the appropriate fixed number of args. If the
29;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
30;;; MV optimization figure things out.
31(deftransform complement ((fun) * * :node node)
32  "open code"
33  (multiple-value-bind (min max)
34      (fun-type-nargs (lvar-type fun))
35    (cond
36     ((and min (eql min max))
37      (let ((dums (make-gensym-list min)))
38        `#'(lambda ,dums (not (funcall fun ,@dums)))))
39     ((awhen (node-lvar node)
40        (let ((dest (lvar-dest it)))
41          (and (combination-p dest)
42               (eq (combination-fun dest) it))))
43      '#'(lambda (&rest args)
44           (not (apply fun args))))
45     (t
46      (give-up-ir1-transform
47       "The function doesn't have a fixed argument count.")))))
48
49;;;; SYMBOL-VALUE &co
50(defun derive-symbol-value-type (lvar node)
51  (if (constant-lvar-p lvar)
52      (let* ((sym (lvar-value lvar))
53             (var (maybe-find-free-var sym))
54             (local-type (when var
55                           (let ((*lexenv* (node-lexenv node)))
56                             (lexenv-find var type-restrictions))))
57             (global-type (info :variable :type sym)))
58        (if local-type
59            (type-intersection local-type global-type)
60            global-type))
61      *universal-type*))
62
63(defoptimizer (symbol-value derive-type) ((symbol) node)
64  (derive-symbol-value-type symbol node))
65
66(defoptimizer (symbol-global-value derive-type) ((symbol) node)
67  (derive-symbol-value-type symbol node))
68
69;;;; list hackery
70
71;;; Translate CxR into CAR/CDR combos.
72(defun source-transform-cxr (form env)
73  (declare (ignore env))
74  (if (not (singleton-p (cdr form)))
75      (values nil t)
76      (let* ((name (car form))
77             (string (symbol-name
78                      (etypecase name
79                        (symbol name)
80                        (leaf (leaf-source-name name))))))
81        (do ((i (- (length string) 2) (1- i))
82             (res (cadr form)
83                  `(,(ecase (char string i)
84                       (#\A 'car)
85                       (#\D 'cdr))
86                    ,res)))
87            ((zerop i) res)))))
88
89;;; Make source transforms to turn CxR forms into combinations of CAR
90;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
91;;; defined.
92;;; Don't transform CAD*R, they are treated specially for &more args
93;;; optimizations
94
95(/show0 "about to set CxR source transforms")
96(loop for i of-type index from 2 upto 4 do
97      ;; Iterate over BUF = all names CxR where x = an I-element
98      ;; string of #\A or #\D characters.
99      (let ((buf (make-string (+ 2 i))))
100        (setf (aref buf 0) #\C
101              (aref buf (1+ i)) #\R)
102        (dotimes (j (ash 2 i))
103          (declare (type index j))
104          (dotimes (k i)
105            (declare (type index k))
106            (setf (aref buf (1+ k))
107                  (if (logbitp k j) #\A #\D)))
108          (unless (member buf '("CADR" "CADDR" "CADDDR")
109                          :test #'equal)
110            (setf (info :function :source-transform (intern buf))
111                  #'source-transform-cxr)))))
112(/show0 "done setting CxR source transforms")
113
114;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
115;;; whatever is right for them is right for us. FIFTH..TENTH turn into
116;;; Nth, which can be expanded into a CAR/CDR later on if policy
117;;; favors it.
118(define-source-transform rest (x) `(cdr ,x))
119(define-source-transform first (x) `(car ,x))
120(define-source-transform second (x) `(cadr ,x))
121(define-source-transform third (x) `(caddr ,x))
122(define-source-transform fourth (x) `(cadddr ,x))
123(define-source-transform fifth (x) `(nth 4 ,x))
124(define-source-transform sixth (x) `(nth 5 ,x))
125(define-source-transform seventh (x) `(nth 6 ,x))
126(define-source-transform eighth (x) `(nth 7 ,x))
127(define-source-transform ninth (x) `(nth 8 ,x))
128(define-source-transform tenth (x) `(nth 9 ,x))
129
130;;; LIST with one arg is an extremely common operation (at least inside
131;;; SBCL itself); translate it to CONS to take advantage of common
132;;; allocation routines.
133(define-source-transform list (&rest args)
134  (case (length args)
135    (1 `(cons ,(first args) nil))
136    (t (values nil t))))
137
138(defoptimizer (list derive-type) ((&rest args))
139  (if args
140      (specifier-type 'cons)
141      (specifier-type 'null)))
142
143;;; And similarly for LIST*.
144(define-source-transform list* (arg &rest others)
145  (cond ((not others) arg)
146        ((not (cdr others)) `(cons ,arg ,(car others)))
147        (t (values nil t))))
148
149(defoptimizer (list* derive-type) ((arg &rest args))
150  (if args
151      (specifier-type 'cons)
152      (lvar-type arg)))
153
154(define-source-transform make-list (length &rest rest)
155  (if (or (null rest)
156          ;; Use of &KEY in source xforms doesn't have all the usual semantics.
157          ;; It's better to hand-roll it - cf. transforms for WRITE[-TO-STRING].
158          (typep rest '(cons (eql :initial-element) (cons t null))))
159      ;; Something fishy here- If THE is removed, OPERAND-RESTRICTION-OK
160      ;; returns NIL because type inference on MAKE-LIST never happens.
161      ;; But the fndb entry for %MAKE-LIST is right, so I'm slightly bewildered.
162      `(%make-list (the (integer 0 (,(1- sb!xc:array-dimension-limit))) ,length)
163                   ,(second rest))
164      (values nil t))) ; give up
165
166(deftransform %make-list ((length item) ((constant-arg (eql 0)) t)) nil)
167
168(define-source-transform append (&rest lists)
169  (case (length lists)
170    (0 nil)
171    (1 (car lists))
172    (2 `(sb!impl::append2 ,@lists))
173    (t (values nil t))))
174
175(define-source-transform nconc (&rest lists)
176  (case (length lists)
177    (0 ())
178    (1 (car lists))
179    (t (values nil t))))
180
181;;; (append nil nil nil fixnum) => fixnum
182;;; (append x x cons x x) => cons
183;;; (append x x x x list) => list
184;;; (append x x x x sequence) => sequence
185;;; (append fixnum x ...) => nil
186(defun derive-append-type (args)
187  (when (null args)
188    (return-from derive-append-type (specifier-type 'null)))
189  (let* ((cons-type (specifier-type 'cons))
190         (null-type (specifier-type 'null))
191         (list-type (specifier-type 'list))
192         (last (lvar-type (car (last args)))))
193    ;; Derive the actual return type, assuming that all but the last
194    ;; arguments are LISTs (otherwise, APPEND/NCONC doesn't return).
195    (loop with all-nil = t       ; all but the last args are NIL?
196          with some-cons = nil   ; some args are conses?
197          for (arg next) on args
198          for lvar-type = (type-approx-intersection2 (lvar-type arg)
199                                                     list-type)
200          while next
201          do (multiple-value-bind (typep definitely)
202                 (ctypep nil lvar-type)
203               (cond ((type= lvar-type *empty-type*)
204                      ;; type mismatch! insert an inline check that'll cause
205                      ;; compile-time warnings.
206                      (assert-lvar-type arg list-type
207                                        (lexenv-policy *lexenv*)))
208                     (some-cons) ; we know result's a cons -- nothing to do
209                     ((and (not typep) definitely) ; can't be NIL
210                      (setf some-cons t))          ; must be a CONS
211                     (all-nil
212                      (setf all-nil (csubtypep lvar-type null-type)))))
213          finally
214             ;; if some of the previous arguments are CONSes so is the result;
215             ;; if all the previous values are NIL, we're a fancy identity;
216             ;; otherwise, could be either
217             (return (cond (some-cons cons-type)
218                           (all-nil last)
219                           (t (type-union last cons-type)))))))
220
221(defoptimizer (append derive-type) ((&rest args))
222  (derive-append-type args))
223
224(defoptimizer (sb!impl::append2 derive-type) ((&rest args))
225  (derive-append-type args))
226
227(defoptimizer (nconc derive-type) ((&rest args))
228  (derive-append-type args))
229
230;;; Translate RPLACx to LET and SETF.
231(define-source-transform rplaca (x y)
232  (once-only ((n-x x))
233    `(progn
234       (setf (car ,n-x) ,y)
235       ,n-x)))
236(define-source-transform rplacd (x y)
237  (once-only ((n-x x))
238    `(progn
239       (setf (cdr ,n-x) ,y)
240       ,n-x)))
241
242(deftransform last ((list &optional n) (t &optional t))
243  (let ((c (constant-lvar-p n)))
244    (cond ((or (not n)
245               (and c (eql 1 (lvar-value n))))
246           '(%last1 list))
247          ((and c (eql 0 (lvar-value n)))
248           '(%last0 list))
249          (t
250           (let ((type (lvar-type n)))
251             (cond ((csubtypep type (specifier-type 'fixnum))
252                    '(%lastn/fixnum list n))
253                   ((csubtypep type (specifier-type 'bignum))
254                    '(%lastn/bignum list n))
255                   (t
256                    (give-up-ir1-transform "second argument type too vague"))))))))
257
258(define-source-transform gethash (&rest args)
259  (case (length args)
260   (2 `(sb!impl::gethash3 ,@args nil))
261   (3 `(sb!impl::gethash3 ,@args))
262   (t (values nil t))))
263(define-source-transform get (&rest args)
264  (case (length args)
265   (2 `(sb!impl::get3 ,@args nil))
266   (3 `(sb!impl::get3 ,@args))
267   (t (values nil t))))
268
269(defvar *default-nthcdr-open-code-limit* 6)
270(defvar *extreme-nthcdr-open-code-limit* 20)
271
272(deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
273  "convert NTHCDR to CAxxR"
274  (unless (constant-lvar-p n)
275    (give-up-ir1-transform))
276  (let ((n (lvar-value n)))
277    (when (> n
278             (if (policy node (and (= speed 3) (= space 0)))
279                 *extreme-nthcdr-open-code-limit*
280                 *default-nthcdr-open-code-limit*))
281      (give-up-ir1-transform))
282
283    (labels ((frob (n)
284               (if (zerop n)
285                   'l
286                   `(cdr ,(frob (1- n))))))
287      (frob n))))
288
289;;;; arithmetic and numerology
290
291(define-source-transform plusp (x) `(> ,x 0))
292(define-source-transform minusp (x) `(< ,x 0))
293(define-source-transform zerop (x) `(= ,x 0))
294
295(define-source-transform 1+ (x) `(+ ,x 1))
296(define-source-transform 1- (x) `(- ,x 1))
297
298(define-source-transform oddp (x) `(logtest ,x 1))
299(define-source-transform evenp (x) `(not (logtest ,x 1)))
300
301;;; Note that all the integer division functions are available for
302;;; inline expansion.
303
304(macrolet ((deffrob (fun)
305             `(define-source-transform ,fun (x &optional (y nil y-p))
306                (declare (ignore y))
307                (if y-p
308                    (values nil t)
309                    `(,',fun ,x 1)))))
310  (deffrob truncate)
311  (deffrob round)
312  #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
313  (deffrob floor)
314  #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
315  (deffrob ceiling))
316
317;;; This used to be a source transform (hence the lack of restrictions
318;;; on the argument types), but we make it a regular transform so that
319;;; the VM has a chance to see the bare LOGTEST and potentiall choose
320;;; to implement it differently.  --njf, 06-02-2006
321;;;
322;;; Other transforms may be useful even with direct LOGTEST VOPs; let
323;;; them fire (including the type-directed constant folding below), but
324;;; disable the inlining rewrite in such cases. -- PK, 2013-05-20
325(deftransform logtest ((x y) * * :node node)
326  (let ((type (two-arg-derive-type x y
327                                   #'logand-derive-type-aux
328                                   #'logand)))
329    (multiple-value-bind (typep definitely)
330        (ctypep 0 type)
331      (cond ((and (not typep) definitely)
332             t)
333            ((type= type (specifier-type '(eql 0)))
334             nil)
335            ((neq :default (combination-implementation-style node))
336             (give-up-ir1-transform))
337            (t
338             `(not (zerop (logand x y))))))))
339
340(deftransform logbitp ((index integer))
341  (let ((integer-type (lvar-type integer))
342        (integer-value (and (constant-lvar-p integer)
343                            (lvar-value integer))))
344    (cond ((eql integer-value 0)
345           nil)
346          ((eql integer-value -1)
347           t)
348          ((csubtypep integer-type (specifier-type '(or word
349                                                     sb!vm:signed-word)))
350           `(if (>= index #.sb!vm:n-word-bits)
351                (minusp integer)
352                (not (zerop (logand integer (ash 1 index))))))
353          ((csubtypep integer-type (specifier-type 'bignum))
354           (if (csubtypep (lvar-type index)
355                          (specifier-type '(mod #.sb!vm:n-word-bits))) ; word-index
356               `(logbitp index (%bignum-ref integer 0))
357               `(bignum-logbitp index integer)))
358          (t
359           (give-up-ir1-transform)))))
360
361(define-source-transform byte (size position)
362  `(cons ,size ,position))
363(define-source-transform byte-size (spec) `(car ,spec))
364(define-source-transform byte-position (spec) `(cdr ,spec))
365(define-source-transform ldb-test (bytespec integer)
366  `(not (zerop (mask-field ,bytespec ,integer))))
367
368;;; With the ratio and complex accessors, we pick off the "identity"
369;;; case, and use a primitive to handle the cell access case.
370(define-source-transform numerator (num)
371  (once-only ((n-num `(the rational ,num)))
372    `(if (ratiop ,n-num)
373         (%numerator ,n-num)
374         ,n-num)))
375(define-source-transform denominator (num)
376  (once-only ((n-num `(the rational ,num)))
377    `(if (ratiop ,n-num)
378         (%denominator ,n-num)
379         1)))
380
381;;;; interval arithmetic for computing bounds
382;;;;
383;;;; This is a set of routines for operating on intervals. It
384;;;; implements a simple interval arithmetic package. Although SBCL
385;;;; has an interval type in NUMERIC-TYPE, we choose to use our own
386;;;; for two reasons:
387;;;;
388;;;;   1. This package is simpler than NUMERIC-TYPE.
389;;;;
390;;;;   2. It makes debugging much easier because you can just strip
391;;;;   out these routines and test them independently of SBCL. (This is a
392;;;;   big win!)
393;;;;
394;;;; One disadvantage is a probable increase in consing because we
395;;;; have to create these new interval structures even though
396;;;; numeric-type has everything we want to know. Reason 2 wins for
397;;;; now.
398
399;;; Support operations that mimic real arithmetic comparison
400;;; operators, but imposing a total order on the floating points such
401;;; that negative zeros are strictly less than positive zeros.
402(macrolet ((def (name op)
403             `(defun ,name (x y)
404                (declare (real x y))
405                (if (and (floatp x) (floatp y) (zerop x) (zerop y))
406                    (,op (float-sign x) (float-sign y))
407                    (,op x y)))))
408  (def signed-zero->= >=)
409  (def signed-zero-> >)
410  (def signed-zero-= =)
411  (def signed-zero-< <)
412  (def signed-zero-<= <=))
413
414(defun make-interval (&key low high)
415  (labels ((normalize-bound (val)
416             (cond #-sb-xc-host
417                   ((and (floatp val)
418                         (float-infinity-p val))
419                    ;; Handle infinities.
420                    nil)
421                   ((or (numberp val)
422                        (eq val nil))
423                    ;; Handle any closed bounds.
424                    val)
425                   ((listp val)
426                    ;; We have an open bound. Normalize the numeric
427                    ;; bound. If the normalized bound is still a number
428                    ;; (not nil), keep the bound open. Otherwise, the
429                    ;; bound is really unbounded, so drop the openness.
430                    (let ((new-val (normalize-bound (first val))))
431                      (when new-val
432                        ;; The bound exists, so keep it open still.
433                        (list new-val))))
434                   (t
435                    (error "unknown bound type in MAKE-INTERVAL")))))
436    (%make-interval (normalize-bound low)
437                    (normalize-bound high))))
438
439;;; Apply the function F to a bound X. If X is an open bound and the
440;;; function is declared strictly monotonic, then the result will be
441;;; open. IF X is NIL, the result is NIL.
442(defun bound-func (f x strict)
443  (declare (type function f))
444  (and x
445       (handler-case
446         (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
447           ;; With these traps masked, we might get things like infinity
448           ;; or negative infinity returned. Check for this and return
449           ;; NIL to indicate unbounded.
450           (let ((y (funcall f (type-bound-number x))))
451             (if (and (floatp y)
452                      (float-infinity-p y))
453                 nil
454                 (set-bound y (and strict (consp x))))))
455         ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g.
456         ;; in the course of converting a bignum to a float.  Default to
457         ;; NIL in that case.
458         (simple-type-error ()))))
459
460(defun safe-double-coercion-p (x)
461  (or (typep x 'double-float)
462      (<= most-negative-double-float x most-positive-double-float)))
463
464(defun safe-single-coercion-p (x)
465  (or (typep x 'single-float)
466      (and
467       ;; Fix for bug 420, and related issues: during type derivation we often
468       ;; end up deriving types for both
469       ;;
470       ;;   (some-op <int> <single>)
471       ;; and
472       ;;   (some-op (coerce <int> 'single-float) <single>)
473       ;;
474       ;; or other equivalent transformed forms. The problem with this
475       ;; is that on x86 (+ <int> <single>) is on the machine level
476       ;; equivalent of
477       ;;
478       ;;   (coerce (+ (coerce <int> 'double-float)
479       ;;              (coerce <single> 'double-float))
480       ;;           'single-float)
481       ;;
482       ;; so if the result of (coerce <int> 'single-float) is not exact, the
483       ;; derived types for the transformed forms will have an empty
484       ;; intersection -- which in turn means that the compiler will conclude
485       ;; that the call never returns, and all hell breaks lose when it *does*
486       ;; return at runtime. (This affects not just +, but other operators are
487       ;; well.)
488       ;;
489       ;; See also: SAFE-CTYPE-FOR-SINGLE-COERCION-P
490       ;;
491       ;; FIXME: If we ever add SSE-support for x86, this conditional needs to
492       ;; change.
493       #!+x86
494       (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
495                          (integer (,most-positive-exactly-single-float-fixnum) *))))
496       (<= most-negative-single-float x most-positive-single-float))))
497
498;;; Apply a binary operator OP to two bounds X and Y. The result is
499;;; NIL if either is NIL. Otherwise bound is computed and the result
500;;; is open if either X or Y is open.
501;;;
502;;; FIXME: only used in this file, not needed in target runtime
503
504;;; ANSI contaigon specifies coercion to floating point if one of the
505;;; arguments is floating point. Here we should check to be sure that
506;;; the other argument is within the bounds of that floating point
507;;; type.
508
509(defmacro safely-binop (op x y)
510  `(cond
511     ((typep ,x 'double-float)
512      (when (safe-double-coercion-p ,y)
513        (,op ,x ,y)))
514     ((typep ,y 'double-float)
515      (when (safe-double-coercion-p ,x)
516        (,op ,x ,y)))
517     ((typep ,x 'single-float)
518      (when (safe-single-coercion-p ,y)
519        (,op ,x ,y)))
520     ((typep ,y 'single-float)
521      (when (safe-single-coercion-p ,x)
522        (,op ,x ,y)))
523     (t (,op ,x ,y))))
524
525(defmacro bound-binop (op x y)
526  (with-unique-names (xb yb res)
527    `(and ,x ,y
528          (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
529            (let* ((,xb (type-bound-number ,x))
530                   (,yb (type-bound-number ,y))
531                   (,res (safely-binop ,op ,xb ,yb)))
532              (set-bound ,res
533                         (and (or (consp ,x) (consp ,y))
534                              ;; Open bounds can very easily be messed up
535                              ;; by FP rounding, so take care here.
536                              ,(case op
537                                 (*
538                                  ;; Multiplying a greater-than-zero with
539                                  ;; less than one can round to zero.
540                                  `(or (not (fp-zero-p ,res))
541                                       (cond ((and (consp ,x) (fp-zero-p ,xb))
542                                              (>= (abs ,yb) 1))
543                                             ((and (consp ,y) (fp-zero-p ,yb))
544                                              (>= (abs ,xb) 1)))))
545                                 (/
546                                  ;; Dividing a greater-than-zero with
547                                  ;; greater than one can round to zero.
548                                  `(or (not (fp-zero-p ,res))
549                                       (cond ((and (consp ,x) (fp-zero-p ,xb))
550                                              (<= (abs ,yb) 1))
551                                             ((and (consp ,y) (fp-zero-p ,yb))
552                                              (<= (abs ,xb) 1)))))
553                                 ((+ -)
554                                  ;; Adding or subtracting greater-than-zero
555                                  ;; can end up with identity.
556                                  `(and (not (fp-zero-p ,xb))
557                                        (not (fp-zero-p ,yb))))))))))))
558
559(defun coercion-loses-precision-p (val type)
560  (typecase val
561    (single-float)
562    (double-float (subtypep type 'single-float))
563    (rational (subtypep type 'float))
564    (t (bug "Unexpected arguments to bounds coercion: ~S ~S" val type))))
565
566(defun coerce-for-bound (val type)
567  (if (consp val)
568      (let ((xbound (coerce-for-bound (car val) type)))
569        (if (coercion-loses-precision-p (car val) type)
570            xbound
571            (list xbound)))
572      (cond
573        ((subtypep type 'double-float)
574         (if (<= most-negative-double-float val most-positive-double-float)
575             (coerce val type)))
576        ((or (subtypep type 'single-float) (subtypep type 'float))
577         ;; coerce to float returns a single-float
578         (if (<= most-negative-single-float val most-positive-single-float)
579             (coerce val type)))
580        (t (coerce val type)))))
581
582(defun coerce-and-truncate-floats (val type)
583  (when val
584    (if (consp val)
585        (let ((xbound (coerce-for-bound (car val) type)))
586          (if (coercion-loses-precision-p (car val) type)
587              xbound
588              (list xbound)))
589        (cond
590          ((subtypep type 'double-float)
591           (if (<= most-negative-double-float val most-positive-double-float)
592               (coerce val type)
593               (if (< val most-negative-double-float)
594                   most-negative-double-float most-positive-double-float)))
595          ((or (subtypep type 'single-float) (subtypep type 'float))
596           ;; coerce to float returns a single-float
597           (if (<= most-negative-single-float val most-positive-single-float)
598               (coerce val type)
599               (if (< val most-negative-single-float)
600                   most-negative-single-float most-positive-single-float)))
601          (t (coerce val type))))))
602
603;;; Convert a numeric-type object to an interval object.
604(defun numeric-type->interval (x)
605  (declare (type numeric-type x))
606  (make-interval :low (numeric-type-low x)
607                 :high (numeric-type-high x)))
608
609(defun type-approximate-interval (type)
610  (declare (type ctype type))
611  (let ((types (prepare-arg-for-derive-type type))
612        (result nil))
613    (dolist (type types)
614      (let ((type (if (member-type-p type)
615                      (convert-member-type type)
616                      type)))
617        (unless (numeric-type-p type)
618          (return-from type-approximate-interval nil))
619        (let ((interval (numeric-type->interval type)))
620          (setq result
621                (if result
622                    (interval-approximate-union result interval)
623                    interval)))))
624    result))
625
626(defun copy-interval-limit (limit)
627  (if (numberp limit)
628      limit
629      (copy-list limit)))
630
631(defun copy-interval (x)
632  (declare (type interval x))
633  (make-interval :low (copy-interval-limit (interval-low x))
634                 :high (copy-interval-limit (interval-high x))))
635
636;;; Given a point P contained in the interval X, split X into two
637;;; intervals at the point P. If CLOSE-LOWER is T, then the left
638;;; interval contains P. If CLOSE-UPPER is T, the right interval
639;;; contains P. You can specify both to be T or NIL.
640(defun interval-split (p x &optional close-lower close-upper)
641  (declare (type number p)
642           (type interval x))
643  (list (make-interval :low (copy-interval-limit (interval-low x))
644                       :high (if close-lower p (list p)))
645        (make-interval :low (if close-upper (list p) p)
646                       :high (copy-interval-limit (interval-high x)))))
647
648;;; Return the closure of the interval. That is, convert open bounds
649;;; to closed bounds.
650(defun interval-closure (x)
651  (declare (type interval x))
652  (make-interval :low (type-bound-number (interval-low x))
653                 :high (type-bound-number (interval-high x))))
654
655;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
656;;; '-. Otherwise return NIL.
657(defun interval-range-info (x &optional (point 0))
658  (declare (type interval x))
659  (let ((lo (interval-low x))
660        (hi (interval-high x)))
661    (cond ((and lo (signed-zero->= (type-bound-number lo) point))
662           '+)
663          ((and hi (signed-zero->= point (type-bound-number hi)))
664           '-)
665          (t
666           nil))))
667
668;;; Test to see whether the interval X is bounded. HOW determines the
669;;; test, and should be either ABOVE, BELOW, or BOTH.
670(defun interval-bounded-p (x how)
671  (declare (type interval x))
672  (ecase how
673    (above
674     (interval-high x))
675    (below
676     (interval-low x))
677    (both
678     (and (interval-low x) (interval-high x)))))
679
680;;; See whether the interval X contains the number P, taking into
681;;; account that the interval might not be closed.
682(defun interval-contains-p (p x)
683  (declare (type number p)
684           (type interval x))
685  ;; Does the interval X contain the number P?  This would be a lot
686  ;; easier if all intervals were closed!
687  (let ((lo (interval-low x))
688        (hi (interval-high x)))
689    (cond ((and lo hi)
690           ;; The interval is bounded
691           (if (and (signed-zero-<= (type-bound-number lo) p)
692                    (signed-zero-<= p (type-bound-number hi)))
693               ;; P is definitely in the closure of the interval.
694               ;; We just need to check the end points now.
695               (cond ((signed-zero-= p (type-bound-number lo))
696                      (numberp lo))
697                     ((signed-zero-= p (type-bound-number hi))
698                      (numberp hi))
699                     (t t))
700               nil))
701          (hi
702           ;; Interval with upper bound
703           (if (signed-zero-< p (type-bound-number hi))
704               t
705               (and (numberp hi) (signed-zero-= p hi))))
706          (lo
707           ;; Interval with lower bound
708           (if (signed-zero-> p (type-bound-number lo))
709               t
710               (and (numberp lo) (signed-zero-= p lo))))
711          (t
712           ;; Interval with no bounds
713           t))))
714
715;;; Determine whether two intervals X and Y intersect. Return T if so.
716;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they
717;;; were closed. Otherwise the intervals are treated as they are.
718;;;
719;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
720;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
721;;; is T, then they do intersect because we use the closure of X = [0,
722;;; 1] and Y = [1, 2] to determine intersection.
723(defun interval-intersect-p (x y &optional closed-intervals-p)
724  (declare (type interval x y))
725  (and (interval-intersection/difference (if closed-intervals-p
726                                             (interval-closure x)
727                                             x)
728                                         (if closed-intervals-p
729                                             (interval-closure y)
730                                             y))
731       t))
732
733;;; Are the two intervals adjacent?  That is, is there a number
734;;; between the two intervals that is not an element of either
735;;; interval?  If so, they are not adjacent. For example [0, 1) and
736;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
737;;; between both intervals.
738(defun interval-adjacent-p (x y)
739  (declare (type interval x y))
740  (flet ((adjacent (lo hi)
741           ;; Check to see whether lo and hi are adjacent. If either is
742           ;; nil, they can't be adjacent.
743           (when (and lo hi (= (type-bound-number lo) (type-bound-number hi)))
744             ;; The bounds are equal. They are adjacent if one of
745             ;; them is closed (a number). If both are open (consp),
746             ;; then there is a number that lies between them.
747             (or (numberp lo) (numberp hi)))))
748    (or (adjacent (interval-low y) (interval-high x))
749        (adjacent (interval-low x) (interval-high y)))))
750
751;;; Compute the intersection and difference between two intervals.
752;;; Two values are returned: the intersection and the difference.
753;;;
754;;; Let the two intervals be X and Y, and let I and D be the two
755;;; values returned by this function. Then I = X intersect Y. If I
756;;; is NIL (the empty set), then D is X union Y, represented as the
757;;; list of X and Y. If I is not the empty set, then D is (X union Y)
758;;; - I, which is a list of two intervals.
759;;;
760;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D =
761;;; [-1,1) union [3,5], which is returned as a list of two intervals.
762(defun interval-intersection/difference (x y)
763  (declare (type interval x y))
764  (let ((x-lo (interval-low x))
765        (x-hi (interval-high x))
766        (y-lo (interval-low y))
767        (y-hi (interval-high y)))
768    (labels
769        ((opposite-bound (p)
770           ;; If p is an open bound, make it closed. If p is a closed
771           ;; bound, make it open.
772           (if (listp p)
773               (first p)
774               (list p)))
775         (test-number (p int bound)
776           ;; Test whether P is in the interval.
777           (let ((pn (type-bound-number p)))
778             (when (interval-contains-p pn (interval-closure int))
779               ;; Check for endpoints.
780               (let* ((lo (interval-low int))
781                      (hi (interval-high int))
782                      (lon (type-bound-number lo))
783                      (hin (type-bound-number hi)))
784                 (cond
785                   ;; Interval may be a point.
786                   ((and lon hin (= lon hin pn))
787                    (and (numberp p) (numberp lo) (numberp hi)))
788                   ;; Point matches the low end.
789                   ;; [P] [P,?} => TRUE     [P] (P,?} => FALSE
790                   ;; (P  [P,?} => TRUE      P) [P,?} => FALSE
791                   ;; (P  (P,?} => TRUE      P) (P,?} => FALSE
792                   ((and lon (= pn lon))
793                    (or (and (numberp p) (numberp lo))
794                        (and (consp p) (eq :low bound))))
795                   ;; [P] {?,P] => TRUE     [P] {?,P) => FALSE
796                   ;;  P) {?,P] => TRUE     (P  {?,P] => FALSE
797                   ;;  P) {?,P) => TRUE     (P  {?,P) => FALSE
798                   ((and hin (= pn hin))
799                    (or (and (numberp p) (numberp hi))
800                        (and (consp p) (eq :high bound))))
801                   ;; Not an endpoint, all is well.
802                   (t
803                    t))))))
804         (test-lower-bound (p int)
805           ;; P is a lower bound of an interval.
806           (if p
807               (test-number p int :low)
808               (not (interval-bounded-p int 'below))))
809         (test-upper-bound (p int)
810           ;; P is an upper bound of an interval.
811           (if p
812               (test-number p int :high)
813               (not (interval-bounded-p int 'above)))))
814      (let ((x-lo-in-y (test-lower-bound x-lo y))
815            (x-hi-in-y (test-upper-bound x-hi y))
816            (y-lo-in-x (test-lower-bound y-lo x))
817            (y-hi-in-x (test-upper-bound y-hi x)))
818        (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x)
819               ;; Intervals intersect. Let's compute the intersection
820               ;; and the difference.
821               (multiple-value-bind (lo left-lo left-hi)
822                   (cond (x-lo-in-y (values x-lo y-lo (opposite-bound x-lo)))
823                         (y-lo-in-x (values y-lo x-lo (opposite-bound y-lo))))
824                 (multiple-value-bind (hi right-lo right-hi)
825                     (cond (x-hi-in-y
826                            (values x-hi (opposite-bound x-hi) y-hi))
827                           (y-hi-in-x
828                            (values y-hi (opposite-bound y-hi) x-hi)))
829                   (values (make-interval :low lo :high hi)
830                           (list (make-interval :low left-lo
831                                                :high left-hi)
832                                 (make-interval :low right-lo
833                                                :high right-hi))))))
834              (t
835               (values nil (list x y))))))))
836
837;;; If intervals X and Y intersect, return a new interval that is the
838;;; union of the two. If they do not intersect, return NIL.
839(defun interval-merge-pair (x y)
840  (declare (type interval x y))
841  ;; If x and y intersect or are adjacent, create the union.
842  ;; Otherwise return nil
843  (when (or (interval-intersect-p x y)
844            (interval-adjacent-p x y))
845    (flet ((select-bound (x1 x2 min-op max-op)
846             (let ((x1-val (type-bound-number x1))
847                   (x2-val (type-bound-number x2)))
848               (cond ((and x1 x2)
849                      ;; Both bounds are finite. Select the right one.
850                      (cond ((funcall min-op x1-val x2-val)
851                             ;; x1 is definitely better.
852                             x1)
853                            ((funcall max-op x1-val x2-val)
854                             ;; x2 is definitely better.
855                             x2)
856                            (t
857                             ;; Bounds are equal. Select either
858                             ;; value and make it open only if
859                             ;; both were open.
860                             (set-bound x1-val (and (consp x1) (consp x2))))))
861                     (t
862                      ;; At least one bound is not finite. The
863                      ;; non-finite bound always wins.
864                      nil)))))
865      (let* ((x-lo (copy-interval-limit (interval-low x)))
866             (x-hi (copy-interval-limit (interval-high x)))
867             (y-lo (copy-interval-limit (interval-low y)))
868             (y-hi (copy-interval-limit (interval-high y))))
869        (make-interval :low (select-bound x-lo y-lo #'< #'>)
870                       :high (select-bound x-hi y-hi #'> #'<))))))
871
872;;; return the minimal interval, containing X and Y
873(defun interval-approximate-union (x y)
874  (cond ((interval-merge-pair x y))
875        ((interval-< x y)
876         (make-interval :low (copy-interval-limit (interval-low x))
877                        :high (copy-interval-limit (interval-high y))))
878        (t
879         (make-interval :low (copy-interval-limit (interval-low y))
880                        :high (copy-interval-limit (interval-high x))))))
881
882;;; basic arithmetic operations on intervals. We probably should do
883;;; true interval arithmetic here, but it's complicated because we
884;;; have float and integer types and bounds can be open or closed.
885
886;;; the negative of an interval
887(defun interval-neg (x)
888  (declare (type interval x))
889  (make-interval :low (bound-func #'- (interval-high x) t)
890                 :high (bound-func #'- (interval-low x) t)))
891
892;;; Add two intervals.
893(defun interval-add (x y)
894  (declare (type interval x y))
895  (make-interval :low (bound-binop + (interval-low x) (interval-low y))
896                 :high (bound-binop + (interval-high x) (interval-high y))))
897
898;;; Subtract two intervals.
899(defun interval-sub (x y)
900  (declare (type interval x y))
901  (make-interval :low (bound-binop - (interval-low x) (interval-high y))
902                 :high (bound-binop - (interval-high x) (interval-low y))))
903
904;;; Multiply two intervals.
905(defun interval-mul (x y)
906  (declare (type interval x y))
907  (flet ((bound-mul (x y)
908           (cond ((or (null x) (null y))
909                  ;; Multiply by infinity is infinity
910                  nil)
911                 ((or (and (numberp x) (zerop x))
912                      (and (numberp y) (zerop y)))
913                  ;; Multiply by closed zero is special. The result
914                  ;; is always a closed bound. But don't replace this
915                  ;; with zero; we want the multiplication to produce
916                  ;; the correct signed zero, if needed. Use SIGNUM
917                  ;; to avoid trying to multiply huge bignums with 0.0.
918                  (* (signum (type-bound-number x)) (signum (type-bound-number y))))
919                 ((or (and (floatp x) (float-infinity-p x))
920                      (and (floatp y) (float-infinity-p y)))
921                  ;; Infinity times anything is infinity
922                  nil)
923                 (t
924                  ;; General multiply. The result is open if either is open.
925                  (bound-binop * x y)))))
926    (let ((x-range (interval-range-info x))
927          (y-range (interval-range-info y)))
928      (cond ((null x-range)
929             ;; Split x into two and multiply each separately
930             (destructuring-bind (x- x+) (interval-split 0 x t t)
931               (interval-merge-pair (interval-mul x- y)
932                                    (interval-mul x+ y))))
933            ((null y-range)
934             ;; Split y into two and multiply each separately
935             (destructuring-bind (y- y+) (interval-split 0 y t t)
936               (interval-merge-pair (interval-mul x y-)
937                                    (interval-mul x y+))))
938            ((eq x-range '-)
939             (interval-neg (interval-mul (interval-neg x) y)))
940            ((eq y-range '-)
941             (interval-neg (interval-mul x (interval-neg y))))
942            ((and (eq x-range '+) (eq y-range '+))
943             ;; If we are here, X and Y are both positive.
944             (make-interval
945              :low (bound-mul (interval-low x) (interval-low y))
946              :high (bound-mul (interval-high x) (interval-high y))))
947            (t
948             (bug "excluded case in INTERVAL-MUL"))))))
949
950;;; Divide two intervals.
951(defun interval-div (top bot)
952  (declare (type interval top bot))
953  (flet ((bound-div (x y y-low-p)
954           ;; Compute x/y
955           (cond ((null y)
956                  ;; Divide by infinity means result is 0. However,
957                  ;; we need to watch out for the sign of the result,
958                  ;; to correctly handle signed zeros. We also need
959                  ;; to watch out for positive or negative infinity.
960                  (if (floatp (type-bound-number x))
961                      (if y-low-p
962                          (- (float-sign (type-bound-number x) 0.0))
963                          (float-sign (type-bound-number x) 0.0))
964                      0))
965                 ((zerop (type-bound-number y))
966                  ;; Divide by zero means result is infinity
967                  nil)
968                 (t
969                  (bound-binop / x y)))))
970    (let ((top-range (interval-range-info top))
971          (bot-range (interval-range-info bot)))
972      (cond ((null bot-range)
973             ;; The denominator contains zero, so anything goes!
974             (make-interval))
975            ((eq bot-range '-)
976             ;; Denominator is negative so flip the sign, compute the
977             ;; result, and flip it back.
978             (interval-neg (interval-div top (interval-neg bot))))
979            ((null top-range)
980             ;; Split top into two positive and negative parts, and
981             ;; divide each separately
982             (destructuring-bind (top- top+) (interval-split 0 top t t)
983               (or (interval-merge-pair (interval-div top- bot)
984                                        (interval-div top+ bot))
985                   (make-interval))))
986            ((eq top-range '-)
987             ;; Top is negative so flip the sign, divide, and flip the
988             ;; sign of the result.
989             (interval-neg (interval-div (interval-neg top) bot)))
990            ((and (eq top-range '+) (eq bot-range '+))
991             ;; the easy case
992             (make-interval
993              :low (bound-div (interval-low top) (interval-high bot) t)
994              :high (bound-div (interval-high top) (interval-low bot) nil)))
995            (t
996             (bug "excluded case in INTERVAL-DIV"))))))
997
998;;; Apply the function F to the interval X. If X = [a, b], then the
999;;; result is [f(a), f(b)]. It is up to the user to make sure the
1000;;; result makes sense. It will if F is monotonic increasing (or, if
1001;;; the interval is closed, non-decreasing).
1002;;;
1003;;; (Actually most uses of INTERVAL-FUNC are coercions to float types,
1004;;; which are not monotonic increasing, so default to calling
1005;;; BOUND-FUNC with a non-strict argument).
1006(defun interval-func (f x &optional increasing)
1007  (declare (type function f)
1008           (type interval x))
1009  (let ((lo (bound-func f (interval-low x) increasing))
1010        (hi (bound-func f (interval-high x) increasing)))
1011    (make-interval :low lo :high hi)))
1012
1013;;; Return T if X < Y. That is every number in the interval X is
1014;;; always less than any number in the interval Y.
1015(defun interval-< (x y)
1016  (declare (type interval x y))
1017  ;; X < Y only if X is bounded above, Y is bounded below, and they
1018  ;; don't overlap.
1019  (when (and (interval-bounded-p x 'above)
1020             (interval-bounded-p y 'below))
1021    ;; Intervals are bounded in the appropriate way. Make sure they
1022    ;; don't overlap.
1023    (let ((left (interval-high x))
1024          (right (interval-low y)))
1025      (cond ((> (type-bound-number left)
1026                (type-bound-number right))
1027             ;; The intervals definitely overlap, so result is NIL.
1028             nil)
1029            ((< (type-bound-number left)
1030                (type-bound-number right))
1031             ;; The intervals definitely don't touch, so result is T.
1032             t)
1033            (t
1034             ;; Limits are equal. Check for open or closed bounds.
1035             ;; Don't overlap if one or the other are open.
1036             (or (consp left) (consp right)))))))
1037
1038;;; Return T if X >= Y. That is, every number in the interval X is
1039;;; always greater than any number in the interval Y.
1040(defun interval->= (x y)
1041  (declare (type interval x y))
1042  ;; X >= Y if lower bound of X >= upper bound of Y
1043  (when (and (interval-bounded-p x 'below)
1044             (interval-bounded-p y 'above))
1045    (>= (type-bound-number (interval-low x))
1046        (type-bound-number (interval-high y)))))
1047
1048;;; Return T if X = Y.
1049(defun interval-= (x y)
1050  (declare (type interval x y))
1051  (and (interval-bounded-p x 'both)
1052       (interval-bounded-p y 'both)
1053       (flet ((bound (v)
1054                (if (numberp v)
1055                    v
1056                    ;; Open intervals cannot be =
1057                    (return-from interval-= nil))))
1058         ;; Both intervals refer to the same point
1059         (= (bound (interval-high x)) (bound (interval-low x))
1060            (bound (interval-high y)) (bound (interval-low y))))))
1061
1062;;; Return T if X /= Y
1063(defun interval-/= (x y)
1064  (not (interval-intersect-p x y)))
1065
1066;;; Return an interval that is the absolute value of X. Thus, if
1067;;; X = [-1 10], the result is [0, 10].
1068(defun interval-abs (x)
1069  (declare (type interval x))
1070  (case (interval-range-info x)
1071    (+
1072     (copy-interval x))
1073    (-
1074     (interval-neg x))
1075    (t
1076     (destructuring-bind (x- x+) (interval-split 0 x t t)
1077       (interval-merge-pair (interval-neg x-) x+)))))
1078
1079;;; Compute the square of an interval.
1080(defun interval-sqr (x)
1081  (declare (type interval x))
1082  (interval-func (lambda (x) (* x x)) (interval-abs x)))
1083
1084;;;; numeric DERIVE-TYPE methods
1085
1086;;; a utility for defining derive-type methods of integer operations. If
1087;;; the types of both X and Y are integer types, then we compute a new
1088;;; integer type with bounds determined by FUN when applied to X and Y.
1089;;; Otherwise, we use NUMERIC-CONTAGION.
1090(defun derive-integer-type-aux (x y fun)
1091  (declare (type function fun))
1092  (if (and (numeric-type-p x) (numeric-type-p y)
1093           (eq (numeric-type-class x) 'integer)
1094           (eq (numeric-type-class y) 'integer)
1095           (eq (numeric-type-complexp x) :real)
1096           (eq (numeric-type-complexp y) :real))
1097      (multiple-value-bind (low high) (funcall fun x y)
1098        (make-numeric-type :class 'integer
1099                           :complexp :real
1100                           :low low
1101                           :high high))
1102      (numeric-contagion x y)))
1103
1104(defun derive-integer-type (x y fun)
1105  (declare (type lvar x y) (type function fun))
1106  (let ((x (lvar-type x))
1107        (y (lvar-type y)))
1108    (derive-integer-type-aux x y fun)))
1109
1110;;; simple utility to flatten a list
1111(defun flatten-list (x)
1112  (labels ((flatten-and-append (tree list)
1113             (cond ((null tree) list)
1114                   ((atom tree) (cons tree list))
1115                   (t (flatten-and-append
1116                       (car tree) (flatten-and-append (cdr tree) list))))))
1117    (flatten-and-append x nil)))
1118
1119;;; Take some type of lvar and massage it so that we get a list of the
1120;;; constituent types. If ARG is *EMPTY-TYPE*, return NIL to indicate
1121;;; failure.
1122(defun prepare-arg-for-derive-type (arg)
1123  (flet ((listify (arg)
1124           (typecase arg
1125             (numeric-type
1126              (list arg))
1127             (union-type
1128              (union-type-types arg))
1129             (t
1130              (list arg)))))
1131    (unless (eq arg *empty-type*)
1132      ;; Make sure all args are some type of numeric-type. For member
1133      ;; types, convert the list of members into a union of equivalent
1134      ;; single-element member-type's.
1135      (let ((new-args nil))
1136        (dolist (arg (listify arg))
1137          (if (member-type-p arg)
1138              ;; Run down the list of members and convert to a list of
1139              ;; member types.
1140              (mapc-member-type-members
1141               (lambda (member)
1142                 (push (if (numberp member) (make-eql-type member) *empty-type*)
1143                       new-args))
1144               arg)
1145              (push arg new-args)))
1146        (unless (member *empty-type* new-args)
1147          new-args)))))
1148
1149;;; Take a list of types and return a canonical type specifier,
1150;;; combining any MEMBER types together. If both positive and negative
1151;;; MEMBER types are present they are converted to a float type.
1152;;; XXX This would be far simpler if the type-union methods could handle
1153;;; member/number unions.
1154;;;
1155;;; If we're about to generate an overly complex union of numeric types, start
1156;;; collapse the ranges together.
1157;;;
1158;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
1159;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
1160;;; invoked always, instead of in the compiler, invoked only during some type
1161;;; optimizations.
1162(defvar *derived-numeric-union-complexity-limit* 6)
1163
1164(defun make-derived-union-type (type-list)
1165  (let ((xset (alloc-xset))
1166        (fp-zeroes '())
1167        (misc-types '())
1168        (numeric-type *empty-type*))
1169    (dolist (type type-list)
1170      (cond ((member-type-p type)
1171             (mapc-member-type-members
1172              (lambda (member)
1173                (if (fp-zero-p member)
1174                    (unless (member member fp-zeroes)
1175                      (pushnew member fp-zeroes))
1176                    (add-to-xset member xset)))
1177              type))
1178            ((numeric-type-p type)
1179             (let ((*approximate-numeric-unions*
1180                    (when (and (union-type-p numeric-type)
1181                               (nthcdr *derived-numeric-union-complexity-limit*
1182                                       (union-type-types numeric-type)))
1183                      t)))
1184               (setf numeric-type (type-union type numeric-type))))
1185            (t
1186             (push type misc-types))))
1187    (if (and (xset-empty-p xset) (not fp-zeroes))
1188        (apply #'type-union numeric-type misc-types)
1189        (apply #'type-union (make-member-type xset fp-zeroes)
1190               numeric-type misc-types))))
1191
1192;;; Convert a member type with a single member to a numeric type.
1193(defun convert-member-type (arg)
1194  (let* ((members (member-type-members arg))
1195         (member (first members))
1196         (member-type (type-of member)))
1197    (aver (not (rest members)))
1198    (specifier-type (cond ((typep member 'integer)
1199                           `(integer ,member ,member))
1200                          ((memq member-type '(short-float single-float
1201                                               double-float long-float))
1202                           `(,member-type ,member ,member))
1203                          (t
1204                           member-type)))))
1205
1206;;; This is used in defoptimizers for computing the resulting type of
1207;;; a function.
1208;;;
1209;;; Given the lvar ARG, derive the resulting type using the
1210;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
1211;;; "atomic" lvar type like numeric-type or member-type (containing
1212;;; just one element). It should return the resulting type, which can
1213;;; be a list of types.
1214;;;
1215;;; For the case of member types, if a MEMBER-FUN is given it is
1216;;; called to compute the result otherwise the member type is first
1217;;; converted to a numeric type and the DERIVE-FUN is called.
1218(defun one-arg-derive-type (arg derive-fun member-fun)
1219  (declare (type function derive-fun)
1220           (type (or null function) member-fun))
1221  (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg))))
1222    (when arg-list
1223      (flet ((deriver (x)
1224               (typecase x
1225                 (member-type
1226                  (if member-fun
1227                      (with-float-traps-masked
1228                          (:underflow :overflow :divide-by-zero)
1229                        (specifier-type
1230                         `(eql ,(funcall member-fun
1231                                         (first (member-type-members x))))))
1232                      ;; Otherwise convert to a numeric type.
1233                      (funcall derive-fun (convert-member-type x))))
1234                 (numeric-type
1235                  (funcall derive-fun x))
1236                 (t
1237                  *universal-type*))))
1238        ;; Run down the list of args and derive the type of each one,
1239        ;; saving all of the results in a list.
1240        (let ((results nil))
1241          (dolist (arg arg-list)
1242            (let ((result (deriver arg)))
1243              (if (listp result)
1244                  (setf results (append results result))
1245                  (push result results))))
1246          (if (rest results)
1247              (make-derived-union-type results)
1248              (first results)))))))
1249
1250;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
1251;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
1252;;; original args and a third which is T to indicate if the two args
1253;;; really represent the same lvar. This is useful for deriving the
1254;;; type of things like (* x x), which should always be positive. If
1255;;; we didn't do this, we wouldn't be able to tell.
1256(defun two-arg-derive-type (arg1 arg2 derive-fun fun)
1257  (declare (type function derive-fun fun))
1258  (flet ((deriver (x y same-arg)
1259           (cond ((and (member-type-p x) (member-type-p y))
1260                  (let* ((x (first (member-type-members x)))
1261                         (y (first (member-type-members y)))
1262                         (result (ignore-errors
1263                                   (with-float-traps-masked
1264                                       (:underflow :overflow :divide-by-zero
1265                                                   :invalid)
1266                                     (funcall fun x y)))))
1267                    (cond ((null result) *empty-type*)
1268                          ((and (floatp result) (float-nan-p result))
1269                           (make-numeric-type :class 'float
1270                                              :format (type-of result)
1271                                              :complexp :real))
1272                          (t
1273                           (specifier-type `(eql ,result))))))
1274                 ((and (member-type-p x) (numeric-type-p y))
1275                  (funcall derive-fun (convert-member-type x) y same-arg))
1276                 ((and (numeric-type-p x) (member-type-p y))
1277                  (funcall derive-fun x (convert-member-type y) same-arg))
1278                 ((and (numeric-type-p x) (numeric-type-p y))
1279                  (funcall derive-fun x y same-arg))
1280                 (t
1281                  *universal-type*))))
1282    (let ((same-arg (same-leaf-ref-p arg1 arg2))
1283          (a1 (prepare-arg-for-derive-type (lvar-type arg1)))
1284          (a2 (prepare-arg-for-derive-type (lvar-type arg2))))
1285      (when (and a1 a2)
1286        (let ((results nil))
1287          (if same-arg
1288              ;; Since the args are the same LVARs, just run down the
1289              ;; lists.
1290              (dolist (x a1)
1291                (let ((result (deriver x x same-arg)))
1292                  (if (listp result)
1293                      (setf results (append results result))
1294                      (push result results))))
1295              ;; Try all pairwise combinations.
1296              (dolist (x a1)
1297                (dolist (y a2)
1298                  (let ((result (or (deriver x y same-arg)
1299                                    (numeric-contagion x y))))
1300                    (if (listp result)
1301                        (setf results (append results result))
1302                        (push result results))))))
1303          (if (rest results)
1304              (make-derived-union-type results)
1305              (first results)))))))
1306
1307#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1308(progn
1309(defoptimizer (+ derive-type) ((x y))
1310  (derive-integer-type
1311   x y
1312   #'(lambda (x y)
1313       (flet ((frob (x y)
1314                (if (and x y)
1315                    (+ x y)
1316                    nil)))
1317         (values (frob (numeric-type-low x) (numeric-type-low y))
1318                 (frob (numeric-type-high x) (numeric-type-high y)))))))
1319
1320(defoptimizer (- derive-type) ((x y))
1321  (derive-integer-type
1322   x y
1323   #'(lambda (x y)
1324       (flet ((frob (x y)
1325                (if (and x y)
1326                    (- x y)
1327                    nil)))
1328         (values (frob (numeric-type-low x) (numeric-type-high y))
1329                 (frob (numeric-type-high x) (numeric-type-low y)))))))
1330
1331(defoptimizer (* derive-type) ((x y))
1332  (derive-integer-type
1333   x y
1334   #'(lambda (x y)
1335       (let ((x-low (numeric-type-low x))
1336             (x-high (numeric-type-high x))
1337             (y-low (numeric-type-low y))
1338             (y-high (numeric-type-high y)))
1339         (cond ((not (and x-low y-low))
1340                (values nil nil))
1341               ((or (minusp x-low) (minusp y-low))
1342                (if (and x-high y-high)
1343                    (let ((max (* (max (abs x-low) (abs x-high))
1344                                  (max (abs y-low) (abs y-high)))))
1345                      (values (- max) max))
1346                    (values nil nil)))
1347               (t
1348                (values (* x-low y-low)
1349                        (if (and x-high y-high)
1350                            (* x-high y-high)
1351                            nil))))))))
1352
1353(defoptimizer (/ derive-type) ((x y))
1354  (numeric-contagion (lvar-type x) (lvar-type y)))
1355
1356) ; PROGN
1357
1358#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1359(progn
1360(defun +-derive-type-aux (x y same-arg)
1361  (if (and (numeric-type-real-p x)
1362           (numeric-type-real-p y))
1363      (let ((result
1364             (if same-arg
1365                 (let ((x-int (numeric-type->interval x)))
1366                   (interval-add x-int x-int))
1367                 (interval-add (numeric-type->interval x)
1368                               (numeric-type->interval y))))
1369            (result-type (numeric-contagion x y)))
1370        ;; If the result type is a float, we need to be sure to coerce
1371        ;; the bounds into the correct type.
1372        (when (eq (numeric-type-class result-type) 'float)
1373          (setf result (interval-func
1374                        #'(lambda (x)
1375                            (coerce-for-bound x (or (numeric-type-format result-type)
1376                                                    'float)))
1377                        result)))
1378        (make-numeric-type
1379         :class (if (and (eq (numeric-type-class x) 'integer)
1380                         (eq (numeric-type-class y) 'integer))
1381                    ;; The sum of integers is always an integer.
1382                    'integer
1383                    (numeric-type-class result-type))
1384         :format (numeric-type-format result-type)
1385         :low (interval-low result)
1386         :high (interval-high result)))
1387      ;; general contagion
1388      (numeric-contagion x y)))
1389
1390(defoptimizer (+ derive-type) ((x y))
1391  (two-arg-derive-type x y #'+-derive-type-aux #'+))
1392
1393(defun --derive-type-aux (x y same-arg)
1394  (if (and (numeric-type-real-p x)
1395           (numeric-type-real-p y))
1396      (let ((result
1397             ;; (- X X) is always 0.
1398             (if same-arg
1399                 (make-interval :low 0 :high 0)
1400                 (interval-sub (numeric-type->interval x)
1401                               (numeric-type->interval y))))
1402            (result-type (numeric-contagion x y)))
1403        ;; If the result type is a float, we need to be sure to coerce
1404        ;; the bounds into the correct type.
1405        (when (eq (numeric-type-class result-type) 'float)
1406          (setf result (interval-func
1407                        #'(lambda (x)
1408                            (coerce-for-bound x (or (numeric-type-format result-type)
1409                                                    'float)))
1410                        result)))
1411        (make-numeric-type
1412         :class (if (and (eq (numeric-type-class x) 'integer)
1413                         (eq (numeric-type-class y) 'integer))
1414                    ;; The difference of integers is always an integer.
1415                    'integer
1416                    (numeric-type-class result-type))
1417         :format (numeric-type-format result-type)
1418         :low (interval-low result)
1419         :high (interval-high result)))
1420      ;; general contagion
1421      (numeric-contagion x y)))
1422
1423(defoptimizer (- derive-type) ((x y))
1424  (two-arg-derive-type x y #'--derive-type-aux #'-))
1425
1426(defun *-derive-type-aux (x y same-arg)
1427  (if (and (numeric-type-real-p x)
1428           (numeric-type-real-p y))
1429      (let ((result
1430             ;; (* X X) is always positive, so take care to do it right.
1431             (if same-arg
1432                 (interval-sqr (numeric-type->interval x))
1433                 (interval-mul (numeric-type->interval x)
1434                               (numeric-type->interval y))))
1435            (result-type (numeric-contagion x y)))
1436        ;; If the result type is a float, we need to be sure to coerce
1437        ;; the bounds into the correct type.
1438        (when (eq (numeric-type-class result-type) 'float)
1439          (setf result (interval-func
1440                        #'(lambda (x)
1441                            (coerce-for-bound x (or (numeric-type-format result-type)
1442                                                    'float)))
1443                        result)))
1444        (make-numeric-type
1445         :class (if (and (eq (numeric-type-class x) 'integer)
1446                         (eq (numeric-type-class y) 'integer))
1447                    ;; The product of integers is always an integer.
1448                    'integer
1449                    (numeric-type-class result-type))
1450         :format (numeric-type-format result-type)
1451         :low (interval-low result)
1452         :high (interval-high result)))
1453      (numeric-contagion x y)))
1454
1455(defoptimizer (* derive-type) ((x y))
1456  (two-arg-derive-type x y #'*-derive-type-aux #'*))
1457
1458(defun /-derive-type-aux (x y same-arg)
1459  (if (and (numeric-type-real-p x)
1460           (numeric-type-real-p y))
1461      (let ((result
1462             ;; (/ X X) is always 1, except if X can contain 0. In
1463             ;; that case, we shouldn't optimize the division away
1464             ;; because we want 0/0 to signal an error.
1465             (if (and same-arg
1466                      (not (interval-contains-p
1467                            0 (interval-closure (numeric-type->interval y)))))
1468                 (make-interval :low 1 :high 1)
1469                 (interval-div (numeric-type->interval x)
1470                               (numeric-type->interval y))))
1471            (result-type (numeric-contagion x y)))
1472        ;; If the result type is a float, we need to be sure to coerce
1473        ;; the bounds into the correct type.
1474        (when (eq (numeric-type-class result-type) 'float)
1475          (setf result (interval-func
1476                        #'(lambda (x)
1477                            (coerce-for-bound x (or (numeric-type-format result-type)
1478                                                    'float)))
1479                        result)))
1480        (make-numeric-type :class (numeric-type-class result-type)
1481                           :format (numeric-type-format result-type)
1482                           :low (interval-low result)
1483                           :high (interval-high result)))
1484      (numeric-contagion x y)))
1485
1486(defoptimizer (/ derive-type) ((x y))
1487  (two-arg-derive-type x y #'/-derive-type-aux #'/))
1488
1489) ; PROGN
1490
1491(defun ash-derive-type-aux (n-type shift same-arg)
1492  (declare (ignore same-arg))
1493  ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
1494  ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
1495  ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
1496  ;; two bignums yielding zero) and it's hard to avoid that
1497  ;; calculation in here.
1498  #+(and cmu sb-xc-host)
1499  (when (and (or (typep (numeric-type-low n-type) 'bignum)
1500                 (typep (numeric-type-high n-type) 'bignum))
1501             (or (typep (numeric-type-low shift) 'bignum)
1502                 (typep (numeric-type-high shift) 'bignum)))
1503    (return-from ash-derive-type-aux *universal-type*))
1504  (flet ((ash-outer (n s)
1505           (when (and (fixnump s)
1506                      (<= s 64)
1507                      (> s sb!xc:most-negative-fixnum))
1508             (ash n s)))
1509         ;; KLUDGE: The bare 64's here should be related to
1510         ;; symbolic machine word size values somehow.
1511
1512         (ash-inner (n s)
1513           (if (and (fixnump s)
1514                    (> s sb!xc:most-negative-fixnum))
1515             (ash n (min s 64))
1516             (if (minusp n) -1 0))))
1517    (or (and (csubtypep n-type (specifier-type 'integer))
1518             (csubtypep shift (specifier-type 'integer))
1519             (let ((n-low (numeric-type-low n-type))
1520                   (n-high (numeric-type-high n-type))
1521                   (s-low (numeric-type-low shift))
1522                   (s-high (numeric-type-high shift)))
1523               (make-numeric-type :class 'integer  :complexp :real
1524                                  :low (when n-low
1525                                         (if (minusp n-low)
1526                                           (ash-outer n-low s-high)
1527                                           (ash-inner n-low s-low)))
1528                                  :high (when n-high
1529                                          (if (minusp n-high)
1530                                            (ash-inner n-high s-low)
1531                                            (ash-outer n-high s-high))))))
1532        *universal-type*)))
1533
1534(defoptimizer (ash derive-type) ((n shift))
1535  (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
1536
1537#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1538(macrolet ((frob (fun)
1539             `#'(lambda (type type2)
1540                  (declare (ignore type2))
1541                  (let ((lo (numeric-type-low type))
1542                        (hi (numeric-type-high type)))
1543                    (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
1544
1545  (defoptimizer (%negate derive-type) ((num))
1546    (derive-integer-type num num (frob -))))
1547
1548(defun lognot-derive-type-aux (int)
1549  (derive-integer-type-aux int int
1550                           (lambda (type type2)
1551                             (declare (ignore type2))
1552                             (let ((lo (numeric-type-low type))
1553                                   (hi (numeric-type-high type)))
1554                               (values (if hi (lognot hi) nil)
1555                                       (if lo (lognot lo) nil)
1556                                       (numeric-type-class type)
1557                                       (numeric-type-format type))))))
1558
1559(defoptimizer (lognot derive-type) ((int))
1560  (lognot-derive-type-aux (lvar-type int)))
1561
1562#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1563(defoptimizer (%negate derive-type) ((num))
1564  (flet ((negate-bound (b)
1565           (and b
1566                (set-bound (- (type-bound-number b))
1567                           (consp b)))))
1568    (one-arg-derive-type num
1569                         (lambda (type)
1570                           (modified-numeric-type
1571                            type
1572                            :low (negate-bound (numeric-type-high type))
1573                            :high (negate-bound (numeric-type-low type))))
1574                         #'-)))
1575
1576#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1577(defoptimizer (abs derive-type) ((num))
1578  (let ((type (lvar-type num)))
1579    (if (and (numeric-type-p type)
1580             (eq (numeric-type-class type) 'integer)
1581             (eq (numeric-type-complexp type) :real))
1582        (let ((lo (numeric-type-low type))
1583              (hi (numeric-type-high type)))
1584          (make-numeric-type :class 'integer :complexp :real
1585                             :low (cond ((and hi (minusp hi))
1586                                         (abs hi))
1587                                        (lo
1588                                         (max 0 lo))
1589                                        (t
1590                                         0))
1591                             :high (if (and hi lo)
1592                                       (max (abs hi) (abs lo))
1593                                       nil)))
1594        (numeric-contagion type type))))
1595
1596#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1597(defun abs-derive-type-aux (type)
1598  (cond ((eq (numeric-type-complexp type) :complex)
1599         ;; The absolute value of a complex number is always a
1600         ;; non-negative float.
1601         (let* ((format (case (numeric-type-class type)
1602                          ((integer rational) 'single-float)
1603                          (t (numeric-type-format type))))
1604                (bound-format (or format 'float)))
1605           (make-numeric-type :class 'float
1606                              :format format
1607                              :complexp :real
1608                              :low (coerce 0 bound-format)
1609                              :high nil)))
1610        (t
1611         ;; The absolute value of a real number is a non-negative real
1612         ;; of the same type.
1613         (let* ((abs-bnd (interval-abs (numeric-type->interval type)))
1614                (class (numeric-type-class type))
1615                (format (numeric-type-format type))
1616                (bound-type (or format class 'real)))
1617           (make-numeric-type
1618            :class class
1619            :format format
1620            :complexp :real
1621            :low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type)
1622            :high (coerce-and-truncate-floats
1623                   (interval-high abs-bnd) bound-type))))))
1624
1625#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1626(defoptimizer (abs derive-type) ((num))
1627  (one-arg-derive-type num #'abs-derive-type-aux #'abs))
1628
1629#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1630(defoptimizer (truncate derive-type) ((number divisor))
1631  (let ((number-type (lvar-type number))
1632        (divisor-type (lvar-type divisor))
1633        (integer-type (specifier-type 'integer)))
1634    (if (and (numeric-type-p number-type)
1635             (csubtypep number-type integer-type)
1636             (numeric-type-p divisor-type)
1637             (csubtypep divisor-type integer-type))
1638        (let ((number-low (numeric-type-low number-type))
1639              (number-high (numeric-type-high number-type))
1640              (divisor-low (numeric-type-low divisor-type))
1641              (divisor-high (numeric-type-high divisor-type)))
1642          (values-specifier-type
1643           `(values ,(integer-truncate-derive-type number-low number-high
1644                                                   divisor-low divisor-high)
1645                    ,(integer-rem-derive-type number-low number-high
1646                                              divisor-low divisor-high))))
1647        *universal-type*)))
1648
1649#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1650(progn
1651
1652(defun rem-result-type (number-type divisor-type)
1653  ;; Figure out what the remainder type is. The remainder is an
1654  ;; integer if both args are integers; a rational if both args are
1655  ;; rational; and a float otherwise.
1656  (cond ((and (csubtypep number-type (specifier-type 'integer))
1657              (csubtypep divisor-type (specifier-type 'integer)))
1658         'integer)
1659        ((and (csubtypep number-type (specifier-type 'rational))
1660              (csubtypep divisor-type (specifier-type 'rational)))
1661         'rational)
1662        ((and (csubtypep number-type (specifier-type 'float))
1663              (csubtypep divisor-type (specifier-type 'float)))
1664         ;; Both are floats so the result is also a float, of
1665         ;; the largest type.
1666         (or (float-format-max (numeric-type-format number-type)
1667                               (numeric-type-format divisor-type))
1668             'float))
1669        ((and (csubtypep number-type (specifier-type 'float))
1670              (csubtypep divisor-type (specifier-type 'rational)))
1671         ;; One of the arguments is a float and the other is a
1672         ;; rational. The remainder is a float of the same
1673         ;; type.
1674         (or (numeric-type-format number-type) 'float))
1675        ((and (csubtypep divisor-type (specifier-type 'float))
1676              (csubtypep number-type (specifier-type 'rational)))
1677         ;; One of the arguments is a float and the other is a
1678         ;; rational. The remainder is a float of the same
1679         ;; type.
1680         (or (numeric-type-format divisor-type) 'float))
1681        (t
1682         ;; Some unhandled combination. This usually means both args
1683         ;; are REAL so the result is a REAL.
1684         'real)))
1685
1686(defun truncate-derive-type-quot (number-type divisor-type)
1687  (let* ((rem-type (rem-result-type number-type divisor-type))
1688         (number-interval (numeric-type->interval number-type))
1689         (divisor-interval (numeric-type->interval divisor-type)))
1690    ;;(declare (type (member '(integer rational float)) rem-type))
1691    ;; We have real numbers now.
1692    (cond ((eq rem-type 'integer)
1693           ;; Since the remainder type is INTEGER, both args are
1694           ;; INTEGERs.
1695           (let* ((res (integer-truncate-derive-type
1696                        (interval-low number-interval)
1697                        (interval-high number-interval)
1698                        (interval-low divisor-interval)
1699                        (interval-high divisor-interval))))
1700             (specifier-type (if (listp res) res 'integer))))
1701          (t
1702           (let ((quot (truncate-quotient-bound
1703                        (interval-div number-interval
1704                                      divisor-interval))))
1705             (specifier-type `(integer ,(or (interval-low quot) '*)
1706                                       ,(or (interval-high quot) '*))))))))
1707
1708(defun truncate-derive-type-rem (number-type divisor-type)
1709  (let* ((rem-type (rem-result-type number-type divisor-type))
1710         (number-interval (numeric-type->interval number-type))
1711         (divisor-interval (numeric-type->interval divisor-type))
1712         (rem (truncate-rem-bound number-interval divisor-interval)))
1713    ;;(declare (type (member '(integer rational float)) rem-type))
1714    ;; We have real numbers now.
1715    (cond ((eq rem-type 'integer)
1716           ;; Since the remainder type is INTEGER, both args are
1717           ;; INTEGERs.
1718           (specifier-type `(,rem-type ,(or (interval-low rem) '*)
1719                                       ,(or (interval-high rem) '*))))
1720          (t
1721           (multiple-value-bind (class format)
1722               (ecase rem-type
1723                 (integer
1724                  (values 'integer nil))
1725                 (rational
1726                  (values 'rational nil))
1727                 ((or single-float double-float #!+long-float long-float)
1728                  (values 'float rem-type))
1729                 (float
1730                  (values 'float nil))
1731                 (real
1732                  (values nil nil)))
1733             (when (member rem-type '(float single-float double-float
1734                                            #!+long-float long-float))
1735               (setf rem (interval-func #'(lambda (x)
1736                                            (coerce-for-bound x rem-type))
1737                                        rem)))
1738             (make-numeric-type :class class
1739                                :format format
1740                                :low (interval-low rem)
1741                                :high (interval-high rem)))))))
1742
1743(defun truncate-derive-type-quot-aux (num div same-arg)
1744  (declare (ignore same-arg))
1745  (if (and (numeric-type-real-p num)
1746           (numeric-type-real-p div))
1747      (truncate-derive-type-quot num div)
1748      *empty-type*))
1749
1750(defun truncate-derive-type-rem-aux (num div same-arg)
1751  (declare (ignore same-arg))
1752  (if (and (numeric-type-real-p num)
1753           (numeric-type-real-p div))
1754      (truncate-derive-type-rem num div)
1755      *empty-type*))
1756
1757(defoptimizer (truncate derive-type) ((number divisor))
1758  (let ((quot (two-arg-derive-type number divisor
1759                                   #'truncate-derive-type-quot-aux #'truncate))
1760        (rem (two-arg-derive-type number divisor
1761                                  #'truncate-derive-type-rem-aux #'rem)))
1762    (when (and quot rem)
1763      (make-values-type :required (list quot rem)))))
1764
1765(defun ftruncate-derive-type-quot (number-type divisor-type)
1766  ;; The bounds are the same as for truncate. However, the first
1767  ;; result is a float of some type. We need to determine what that
1768  ;; type is. Basically it's the more contagious of the two types.
1769  (let ((q-type (truncate-derive-type-quot number-type divisor-type))
1770        (res-type (numeric-contagion number-type divisor-type)))
1771    (make-numeric-type :class 'float
1772                       :format (numeric-type-format res-type)
1773                       :low (numeric-type-low q-type)
1774                       :high (numeric-type-high q-type))))
1775
1776(defun ftruncate-derive-type-quot-aux (n d same-arg)
1777  (declare (ignore same-arg))
1778  (if (and (numeric-type-real-p n)
1779           (numeric-type-real-p d))
1780      (ftruncate-derive-type-quot n d)
1781      *empty-type*))
1782
1783(defoptimizer (ftruncate derive-type) ((number divisor))
1784  (let ((quot
1785         (two-arg-derive-type number divisor
1786                              #'ftruncate-derive-type-quot-aux #'ftruncate))
1787        (rem (two-arg-derive-type number divisor
1788                                  #'truncate-derive-type-rem-aux #'rem)))
1789    (when (and quot rem)
1790      (make-values-type :required (list quot rem)))))
1791
1792(defun %unary-truncate-derive-type-aux (number)
1793  (truncate-derive-type-quot number (specifier-type '(integer 1 1))))
1794
1795(defoptimizer (%unary-truncate derive-type) ((number))
1796  (one-arg-derive-type number
1797                       #'%unary-truncate-derive-type-aux
1798                       #'%unary-truncate))
1799
1800(defoptimizer (%unary-truncate/single-float derive-type) ((number))
1801  (one-arg-derive-type number
1802                       #'%unary-truncate-derive-type-aux
1803                       #'%unary-truncate))
1804
1805(defoptimizer (%unary-truncate/double-float derive-type) ((number))
1806  (one-arg-derive-type number
1807                       #'%unary-truncate-derive-type-aux
1808                       #'%unary-truncate))
1809
1810(defoptimizer (%unary-ftruncate derive-type) ((number))
1811  (let ((divisor (specifier-type '(integer 1 1))))
1812    (one-arg-derive-type number
1813                         #'(lambda (n)
1814                             (ftruncate-derive-type-quot-aux n divisor nil))
1815                         #'%unary-ftruncate)))
1816
1817(defoptimizer (%unary-round derive-type) ((number))
1818  (one-arg-derive-type number
1819                       (lambda (n)
1820                         (block nil
1821                           (unless (numeric-type-real-p n)
1822                             (return *empty-type*))
1823                           (let* ((interval (numeric-type->interval n))
1824                                  (low      (interval-low interval))
1825                                  (high     (interval-high interval)))
1826                             (when (consp low)
1827                               (setf low (car low)))
1828                             (when (consp high)
1829                               (setf high (car high)))
1830                             (specifier-type
1831                              `(integer ,(if low
1832                                             (round low)
1833                                             '*)
1834                                        ,(if high
1835                                             (round high)
1836                                             '*))))))
1837                       #'%unary-round))
1838
1839;;; Define optimizers for FLOOR and CEILING.
1840(macrolet
1841    ((def (name q-name r-name)
1842       (let ((q-aux (symbolicate q-name "-AUX"))
1843             (r-aux (symbolicate r-name "-AUX")))
1844         `(progn
1845           ;; Compute type of quotient (first) result.
1846           (defun ,q-aux (number-type divisor-type)
1847             (let* ((number-interval
1848                     (numeric-type->interval number-type))
1849                    (divisor-interval
1850                     (numeric-type->interval divisor-type))
1851                    (quot (,q-name (interval-div number-interval
1852                                                 divisor-interval))))
1853               (specifier-type `(integer ,(or (interval-low quot) '*)
1854                                         ,(or (interval-high quot) '*)))))
1855           ;; Compute type of remainder.
1856           (defun ,r-aux (number-type divisor-type)
1857             (let* ((divisor-interval
1858                     (numeric-type->interval divisor-type))
1859                    (rem (,r-name divisor-interval))
1860                    (result-type (rem-result-type number-type divisor-type)))
1861               (multiple-value-bind (class format)
1862                   (ecase result-type
1863                     (integer
1864                      (values 'integer nil))
1865                     (rational
1866                      (values 'rational nil))
1867                     ((or single-float double-float #!+long-float long-float)
1868                      (values 'float result-type))
1869                     (float
1870                      (values 'float nil))
1871                     (real
1872                      (values nil nil)))
1873                 (when (member result-type '(float single-float double-float
1874                                             #!+long-float long-float))
1875                   ;; Make sure that the limits on the interval have
1876                   ;; the right type.
1877                   (setf rem (interval-func (lambda (x)
1878                                              (coerce-for-bound x result-type))
1879                                            rem)))
1880                 (make-numeric-type :class class
1881                                    :format format
1882                                    :low (interval-low rem)
1883                                    :high (interval-high rem)))))
1884           ;; the optimizer itself
1885           (defoptimizer (,name derive-type) ((number divisor))
1886             (flet ((derive-q (n d same-arg)
1887                      (declare (ignore same-arg))
1888                      (if (and (numeric-type-real-p n)
1889                               (numeric-type-real-p d))
1890                          (,q-aux n d)
1891                          *empty-type*))
1892                    (derive-r (n d same-arg)
1893                      (declare (ignore same-arg))
1894                      (if (and (numeric-type-real-p n)
1895                               (numeric-type-real-p d))
1896                          (,r-aux n d)
1897                          *empty-type*)))
1898               (let ((quot (two-arg-derive-type
1899                            number divisor #'derive-q #',name))
1900                     (rem (two-arg-derive-type
1901                           number divisor #'derive-r #'mod)))
1902                 (when (and quot rem)
1903                   (make-values-type :required (list quot rem))))))))))
1904
1905  (def floor floor-quotient-bound floor-rem-bound)
1906  (def ceiling ceiling-quotient-bound ceiling-rem-bound))
1907
1908;;; Define optimizers for FFLOOR and FCEILING
1909(macrolet ((def (name q-name r-name)
1910             (let ((q-aux (symbolicate "F" q-name "-AUX"))
1911                   (r-aux (symbolicate r-name "-AUX")))
1912               `(progn
1913                  ;; Compute type of quotient (first) result.
1914                  (defun ,q-aux (number-type divisor-type)
1915                    (let* ((number-interval
1916                            (numeric-type->interval number-type))
1917                           (divisor-interval
1918                            (numeric-type->interval divisor-type))
1919                           (quot (,q-name (interval-div number-interval
1920                                                        divisor-interval)))
1921                           (res-type (numeric-contagion number-type
1922                                                        divisor-type)))
1923                      (make-numeric-type
1924                       :class (numeric-type-class res-type)
1925                       :format (numeric-type-format res-type)
1926                       :low  (interval-low quot)
1927                       :high (interval-high quot))))
1928
1929                  (defoptimizer (,name derive-type) ((number divisor))
1930                    (flet ((derive-q (n d same-arg)
1931                             (declare (ignore same-arg))
1932                             (if (and (numeric-type-real-p n)
1933                                      (numeric-type-real-p d))
1934                                 (,q-aux n d)
1935                                 *empty-type*))
1936                           (derive-r (n d same-arg)
1937                             (declare (ignore same-arg))
1938                             (if (and (numeric-type-real-p n)
1939                                      (numeric-type-real-p d))
1940                                 (,r-aux n d)
1941                                 *empty-type*)))
1942                      (let ((quot (two-arg-derive-type
1943                                   number divisor #'derive-q #',name))
1944                            (rem (two-arg-derive-type
1945                                  number divisor #'derive-r #'mod)))
1946                        (when (and quot rem)
1947                          (make-values-type :required (list quot rem))))))))))
1948
1949  (def ffloor floor-quotient-bound floor-rem-bound)
1950  (def fceiling ceiling-quotient-bound ceiling-rem-bound))
1951
1952;;; functions to compute the bounds on the quotient and remainder for
1953;;; the FLOOR function
1954(defun floor-quotient-bound (quot)
1955  ;; Take the floor of the quotient and then massage it into what we
1956  ;; need.
1957  (let ((lo (interval-low quot))
1958        (hi (interval-high quot)))
1959    ;; Take the floor of the lower bound. The result is always a
1960    ;; closed lower bound.
1961    (setf lo (if lo
1962                 (floor (type-bound-number lo))
1963                 nil))
1964    ;; For the upper bound, we need to be careful.
1965    (setf hi
1966          (cond ((consp hi)
1967                 ;; An open bound. We need to be careful here because
1968                 ;; the floor of '(10.0) is 9, but the floor of
1969                 ;; 10.0 is 10.
1970                 (multiple-value-bind (q r) (floor (first hi))
1971                   (if (zerop r)
1972                       (1- q)
1973                       q)))
1974                (hi
1975                 ;; A closed bound, so the answer is obvious.
1976                 (floor hi))
1977                (t
1978                 hi)))
1979    (make-interval :low lo :high hi)))
1980(defun floor-rem-bound (div)
1981  ;; The remainder depends only on the divisor. Try to get the
1982  ;; correct sign for the remainder if we can.
1983  (case (interval-range-info div)
1984    (+
1985     ;; The divisor is always positive.
1986     (let ((rem (interval-abs div)))
1987       (setf (interval-low rem) 0)
1988       (when (and (numberp (interval-high rem))
1989                  (not (zerop (interval-high rem))))
1990         ;; The remainder never contains the upper bound. However,
1991         ;; watch out for the case where the high limit is zero!
1992         (setf (interval-high rem) (list (interval-high rem))))
1993       rem))
1994    (-
1995     ;; The divisor is always negative.
1996     (let ((rem (interval-neg (interval-abs div))))
1997       (setf (interval-high rem) 0)
1998       (when (numberp (interval-low rem))
1999         ;; The remainder never contains the lower bound.
2000         (setf (interval-low rem) (list (interval-low rem))))
2001       rem))
2002    (otherwise
2003     ;; The divisor can be positive or negative. All bets off. The
2004     ;; magnitude of remainder is the maximum value of the divisor.
2005     (let ((limit (type-bound-number (interval-high (interval-abs div)))))
2006       ;; The bound never reaches the limit, so make the interval open.
2007       (make-interval :low (if limit
2008                               (list (- limit))
2009                               limit)
2010                      :high (list limit))))))
2011#| Test cases
2012(floor-quotient-bound (make-interval :low 0.3 :high 10.3))
2013=> #S(INTERVAL :LOW 0 :HIGH 10)
2014(floor-quotient-bound (make-interval :low 0.3 :high '(10.3)))
2015=> #S(INTERVAL :LOW 0 :HIGH 10)
2016(floor-quotient-bound (make-interval :low 0.3 :high 10))
2017=> #S(INTERVAL :LOW 0 :HIGH 10)
2018(floor-quotient-bound (make-interval :low 0.3 :high '(10)))
2019=> #S(INTERVAL :LOW 0 :HIGH 9)
2020(floor-quotient-bound (make-interval :low '(0.3) :high 10.3))
2021=> #S(INTERVAL :LOW 0 :HIGH 10)
2022(floor-quotient-bound (make-interval :low '(0.0) :high 10.3))
2023=> #S(INTERVAL :LOW 0 :HIGH 10)
2024(floor-quotient-bound (make-interval :low '(-1.3) :high 10.3))
2025=> #S(INTERVAL :LOW -2 :HIGH 10)
2026(floor-quotient-bound (make-interval :low '(-1.0) :high 10.3))
2027=> #S(INTERVAL :LOW -1 :HIGH 10)
2028(floor-quotient-bound (make-interval :low -1.0 :high 10.3))
2029=> #S(INTERVAL :LOW -1 :HIGH 10)
2030
2031(floor-rem-bound (make-interval :low 0.3 :high 10.3))
2032=> #S(INTERVAL :LOW 0 :HIGH '(10.3))
2033(floor-rem-bound (make-interval :low 0.3 :high '(10.3)))
2034=> #S(INTERVAL :LOW 0 :HIGH '(10.3))
2035(floor-rem-bound (make-interval :low -10 :high -2.3))
2036#S(INTERVAL :LOW (-10) :HIGH 0)
2037(floor-rem-bound (make-interval :low 0.3 :high 10))
2038=> #S(INTERVAL :LOW 0 :HIGH '(10))
2039(floor-rem-bound (make-interval :low '(-1.3) :high 10.3))
2040=> #S(INTERVAL :LOW '(-10.3) :HIGH '(10.3))
2041(floor-rem-bound (make-interval :low '(-20.3) :high 10.3))
2042=> #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
2043|#
2044
2045;;; same functions for CEILING
2046(defun ceiling-quotient-bound (quot)
2047  ;; Take the ceiling of the quotient and then massage it into what we
2048  ;; need.
2049  (let ((lo (interval-low quot))
2050        (hi (interval-high quot)))
2051    ;; Take the ceiling of the upper bound. The result is always a
2052    ;; closed upper bound.
2053    (setf hi (if hi
2054                 (ceiling (type-bound-number hi))
2055                 nil))
2056    ;; For the lower bound, we need to be careful.
2057    (setf lo
2058          (cond ((consp lo)
2059                 ;; An open bound. We need to be careful here because
2060                 ;; the ceiling of '(10.0) is 11, but the ceiling of
2061                 ;; 10.0 is 10.
2062                 (multiple-value-bind (q r) (ceiling (first lo))
2063                   (if (zerop r)
2064                       (1+ q)
2065                       q)))
2066                (lo
2067                 ;; A closed bound, so the answer is obvious.
2068                 (ceiling lo))
2069                (t
2070                 lo)))
2071    (make-interval :low lo :high hi)))
2072(defun ceiling-rem-bound (div)
2073  ;; The remainder depends only on the divisor. Try to get the
2074  ;; correct sign for the remainder if we can.
2075  (case (interval-range-info div)
2076    (+
2077     ;; Divisor is always positive. The remainder is negative.
2078     (let ((rem (interval-neg (interval-abs div))))
2079       (setf (interval-high rem) 0)
2080       (when (and (numberp (interval-low rem))
2081                  (not (zerop (interval-low rem))))
2082         ;; The remainder never contains the upper bound. However,
2083         ;; watch out for the case when the upper bound is zero!
2084         (setf (interval-low rem) (list (interval-low rem))))
2085       rem))
2086    (-
2087     ;; Divisor is always negative. The remainder is positive
2088     (let ((rem (interval-abs div)))
2089       (setf (interval-low rem) 0)
2090       (when (numberp (interval-high rem))
2091         ;; The remainder never contains the lower bound.
2092         (setf (interval-high rem) (list (interval-high rem))))
2093       rem))
2094    (otherwise
2095     ;; The divisor can be positive or negative. All bets off. The
2096     ;; magnitude of remainder is the maximum value of the divisor.
2097     (let ((limit (type-bound-number (interval-high (interval-abs div)))))
2098       ;; The bound never reaches the limit, so make the interval open.
2099       (make-interval :low (if limit
2100                               (list (- limit))
2101                               limit)
2102                      :high (list limit))))))
2103
2104#| Test cases
2105(ceiling-quotient-bound (make-interval :low 0.3 :high 10.3))
2106=> #S(INTERVAL :LOW 1 :HIGH 11)
2107(ceiling-quotient-bound (make-interval :low 0.3 :high '(10.3)))
2108=> #S(INTERVAL :LOW 1 :HIGH 11)
2109(ceiling-quotient-bound (make-interval :low 0.3 :high 10))
2110=> #S(INTERVAL :LOW 1 :HIGH 10)
2111(ceiling-quotient-bound (make-interval :low 0.3 :high '(10)))
2112=> #S(INTERVAL :LOW 1 :HIGH 10)
2113(ceiling-quotient-bound (make-interval :low '(0.3) :high 10.3))
2114=> #S(INTERVAL :LOW 1 :HIGH 11)
2115(ceiling-quotient-bound (make-interval :low '(0.0) :high 10.3))
2116=> #S(INTERVAL :LOW 1 :HIGH 11)
2117(ceiling-quotient-bound (make-interval :low '(-1.3) :high 10.3))
2118=> #S(INTERVAL :LOW -1 :HIGH 11)
2119(ceiling-quotient-bound (make-interval :low '(-1.0) :high 10.3))
2120=> #S(INTERVAL :LOW 0 :HIGH 11)
2121(ceiling-quotient-bound (make-interval :low -1.0 :high 10.3))
2122=> #S(INTERVAL :LOW -1 :HIGH 11)
2123
2124(ceiling-rem-bound (make-interval :low 0.3 :high 10.3))
2125=> #S(INTERVAL :LOW (-10.3) :HIGH 0)
2126(ceiling-rem-bound (make-interval :low 0.3 :high '(10.3)))
2127=> #S(INTERVAL :LOW 0 :HIGH '(10.3))
2128(ceiling-rem-bound (make-interval :low -10 :high -2.3))
2129=> #S(INTERVAL :LOW 0 :HIGH (10))
2130(ceiling-rem-bound (make-interval :low 0.3 :high 10))
2131=> #S(INTERVAL :LOW (-10) :HIGH 0)
2132(ceiling-rem-bound (make-interval :low '(-1.3) :high 10.3))
2133=> #S(INTERVAL :LOW (-10.3) :HIGH (10.3))
2134(ceiling-rem-bound (make-interval :low '(-20.3) :high 10.3))
2135=> #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
2136|#
2137
2138(defun truncate-quotient-bound (quot)
2139  ;; For positive quotients, truncate is exactly like floor. For
2140  ;; negative quotients, truncate is exactly like ceiling. Otherwise,
2141  ;; it's the union of the two pieces.
2142  (case (interval-range-info quot)
2143    (+
2144     ;; just like FLOOR
2145     (floor-quotient-bound quot))
2146    (-
2147     ;; just like CEILING
2148     (ceiling-quotient-bound quot))
2149    (otherwise
2150     ;; Split the interval into positive and negative pieces, compute
2151     ;; the result for each piece and put them back together.
2152     (destructuring-bind (neg pos) (interval-split 0 quot t t)
2153       (interval-merge-pair (ceiling-quotient-bound neg)
2154                            (floor-quotient-bound pos))))))
2155
2156(defun truncate-rem-bound (num div)
2157  ;; This is significantly more complicated than FLOOR or CEILING. We
2158  ;; need both the number and the divisor to determine the range. The
2159  ;; basic idea is to split the ranges of NUM and DEN into positive
2160  ;; and negative pieces and deal with each of the four possibilities
2161  ;; in turn.
2162  (case (interval-range-info num)
2163    (+
2164     (case (interval-range-info div)
2165       (+
2166        (floor-rem-bound div))
2167       (-
2168        (ceiling-rem-bound div))
2169       (otherwise
2170        (destructuring-bind (neg pos) (interval-split 0 div t t)
2171          (interval-merge-pair (truncate-rem-bound num neg)
2172                               (truncate-rem-bound num pos))))))
2173    (-
2174     (case (interval-range-info div)
2175       (+
2176        (ceiling-rem-bound div))
2177       (-
2178        (floor-rem-bound div))
2179       (otherwise
2180        (destructuring-bind (neg pos) (interval-split 0 div t t)
2181          (interval-merge-pair (truncate-rem-bound num neg)
2182                               (truncate-rem-bound num pos))))))
2183    (otherwise
2184     (destructuring-bind (neg pos) (interval-split 0 num t t)
2185       (interval-merge-pair (truncate-rem-bound neg div)
2186                            (truncate-rem-bound pos div))))))
2187) ; PROGN
2188
2189;;; Derive useful information about the range. Returns three values:
2190;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2191;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2192;;; - The abs of the maximal value if there is one, or nil if it is
2193;;;   unbounded.
2194(defun numeric-range-info (low high)
2195  (cond ((and low (not (minusp low)))
2196         (values '+ low high))
2197        ((and high (not (plusp high)))
2198         (values '- (- high) (if low (- low) nil)))
2199        (t
2200         (values nil 0 (and low high (max (- low) high))))))
2201
2202(defun integer-truncate-derive-type
2203       (number-low number-high divisor-low divisor-high)
2204  ;; The result cannot be larger in magnitude than the number, but the
2205  ;; sign might change. If we can determine the sign of either the
2206  ;; number or the divisor, we can eliminate some of the cases.
2207  (multiple-value-bind (number-sign number-min number-max)
2208      (numeric-range-info number-low number-high)
2209    (multiple-value-bind (divisor-sign divisor-min divisor-max)
2210        (numeric-range-info divisor-low divisor-high)
2211      (when (and divisor-max (zerop divisor-max))
2212        ;; We've got a problem: guaranteed division by zero.
2213        (return-from integer-truncate-derive-type t))
2214      (when (zerop divisor-min)
2215        ;; We'll assume that they aren't going to divide by zero.
2216        (incf divisor-min))
2217      (cond ((and number-sign divisor-sign)
2218             ;; We know the sign of both.
2219             (if (eq number-sign divisor-sign)
2220                 ;; Same sign, so the result will be positive.
2221                 `(integer ,(if divisor-max
2222                                (truncate number-min divisor-max)
2223                                0)
2224                           ,(if number-max
2225                                (truncate number-max divisor-min)
2226                                '*))
2227                 ;; Different signs, the result will be negative.
2228                 `(integer ,(if number-max
2229                                (- (truncate number-max divisor-min))
2230                                '*)
2231                           ,(if divisor-max
2232                                (- (truncate number-min divisor-max))
2233                                0))))
2234            ((eq divisor-sign '+)
2235             ;; The divisor is positive. Therefore, the number will just
2236             ;; become closer to zero.
2237             `(integer ,(if number-low
2238                            (truncate number-low divisor-min)
2239                            '*)
2240                       ,(if number-high
2241                            (truncate number-high divisor-min)
2242                            '*)))
2243            ((eq divisor-sign '-)
2244             ;; The divisor is negative. Therefore, the absolute value of
2245             ;; the number will become closer to zero, but the sign will also
2246             ;; change.
2247             `(integer ,(if number-high
2248                            (- (truncate number-high divisor-min))
2249                            '*)
2250                       ,(if number-low
2251                            (- (truncate number-low divisor-min))
2252                            '*)))
2253            ;; The divisor could be either positive or negative.
2254            (number-max
2255             ;; The number we are dividing has a bound. Divide that by the
2256             ;; smallest posible divisor.
2257             (let ((bound (truncate number-max divisor-min)))
2258               `(integer ,(- bound) ,bound)))
2259            (t
2260             ;; The number we are dividing is unbounded, so we can't tell
2261             ;; anything about the result.
2262             `integer)))))
2263
2264#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2265(defun integer-rem-derive-type
2266       (number-low number-high divisor-low divisor-high)
2267  (if (and divisor-low divisor-high)
2268      ;; We know the range of the divisor, and the remainder must be
2269      ;; smaller than the divisor. We can tell the sign of the
2270      ;; remainder if we know the sign of the number.
2271      (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
2272        `(integer ,(if (or (null number-low)
2273                           (minusp number-low))
2274                       (- divisor-max)
2275                       0)
2276                  ,(if (or (null number-high)
2277                           (plusp number-high))
2278                       divisor-max
2279                       0)))
2280      ;; The divisor is potentially either very positive or very
2281      ;; negative. Therefore, the remainder is unbounded, but we might
2282      ;; be able to tell something about the sign from the number.
2283      `(integer ,(if (and number-low (not (minusp number-low)))
2284                     ;; The number we are dividing is positive.
2285                     ;; Therefore, the remainder must be positive.
2286                     0
2287                     '*)
2288                ,(if (and number-high (not (plusp number-high)))
2289                     ;; The number we are dividing is negative.
2290                     ;; Therefore, the remainder must be negative.
2291                     0
2292                     '*))))
2293
2294#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2295(defoptimizer (random derive-type) ((bound &optional state))
2296  (declare (ignore state))
2297  (let ((type (lvar-type bound)))
2298    (when (numeric-type-p type)
2299      (let ((class (numeric-type-class type))
2300            (high (numeric-type-high type))
2301            (format (numeric-type-format type)))
2302        (make-numeric-type
2303         :class class
2304         :format format
2305         :low (coerce 0 (or format class 'real))
2306         :high (cond ((not high) nil)
2307                     ((eq class 'integer) (max (1- high) 0))
2308                     ((or (consp high) (zerop high)) high)
2309                     (t `(,high))))))))
2310
2311#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2312(defun random-derive-type-aux (type)
2313  (let ((class (numeric-type-class type))
2314        (high (numeric-type-high type))
2315        (format (numeric-type-format type)))
2316    (make-numeric-type
2317         :class class
2318         :format format
2319         :low (coerce 0 (or format class 'real))
2320         :high (cond ((not high) nil)
2321                     ((eq class 'integer) (max (1- high) 0))
2322                     ((or (consp high) (zerop high)) high)
2323                     (t `(,high))))))
2324
2325#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2326(defoptimizer (random derive-type) ((bound &optional state))
2327  (declare (ignore state))
2328  (one-arg-derive-type bound #'random-derive-type-aux nil))
2329
2330;;;; miscellaneous derive-type methods
2331
2332(defoptimizer (integer-length derive-type) ((x))
2333  (let ((x-type (lvar-type x)))
2334    (when (numeric-type-p x-type)
2335      ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2336      ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically.  Be
2337      ;; careful about LO or HI being NIL, though.  Also, if 0 is
2338      ;; contained in X, the lower bound is obviously 0.
2339      (flet ((null-or-min (a b)
2340               (and a b (min (integer-length a)
2341                             (integer-length b))))
2342             (null-or-max (a b)
2343               (and a b (max (integer-length a)
2344                             (integer-length b)))))
2345        (let* ((min (numeric-type-low x-type))
2346               (max (numeric-type-high x-type))
2347               (min-len (null-or-min min max))
2348               (max-len (null-or-max min max)))
2349          (when (ctypep 0 x-type)
2350            (setf min-len 0))
2351          (specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
2352
2353(defoptimizer (logcount derive-type) ((x))
2354  (let ((x-type (lvar-type x)))
2355    (when (numeric-type-p x-type)
2356      (let ((min (numeric-type-low x-type))
2357            (max (numeric-type-high x-type)))
2358        (when (and min max)
2359          (specifier-type
2360           `(integer ,(if (or (> min 0)
2361                              (< max -1))
2362                          1
2363                          0)
2364                     ,(max (integer-length min)
2365                           (integer-length max)))))))))
2366
2367(defoptimizer (isqrt derive-type) ((x))
2368  (let ((x-type (lvar-type x)))
2369    (when (numeric-type-p x-type)
2370      (let* ((lo (numeric-type-low x-type))
2371             (hi (numeric-type-high x-type))
2372             (lo-res (if (typep lo 'unsigned-byte)
2373                         (isqrt lo)
2374                         0))
2375             (hi-res (if (typep hi 'unsigned-byte)
2376                         (isqrt hi)
2377                         '*)))
2378                (specifier-type `(integer ,lo-res ,hi-res))))))
2379
2380(defoptimizer (char-code derive-type) ((char))
2381  (let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
2382    (cond ((member-type-p type)
2383           (specifier-type
2384            `(member
2385              ,@(loop for member in (member-type-members type)
2386                      when (characterp member)
2387                      collect (char-code member)))))
2388          ((sb!kernel::character-set-type-p type)
2389           (specifier-type
2390            `(or
2391              ,@(loop for (low . high)
2392                      in (character-set-type-pairs type)
2393                      collect `(integer ,low ,high)))))
2394          ((csubtypep type (specifier-type 'base-char))
2395           (specifier-type
2396            `(mod ,base-char-code-limit)))
2397          (t
2398           (specifier-type
2399            `(mod ,sb!xc:char-code-limit))))))
2400
2401(defoptimizer (code-char derive-type) ((code))
2402  (let ((type (lvar-type code)))
2403    ;; FIXME: unions of integral ranges?  It ought to be easier to do
2404    ;; this, given that CHARACTER-SET is basically an integral range
2405    ;; type.  -- CSR, 2004-10-04
2406    (when (numeric-type-p type)
2407      (let* ((lo (numeric-type-low type))
2408             (hi (numeric-type-high type))
2409             (type (specifier-type `(character-set ((,lo . ,hi))))))
2410        (cond
2411          ;; KLUDGE: when running on the host, we lose a slight amount
2412          ;; of precision so that we don't have to "unparse" types
2413          ;; that formally we can't, such as (CHARACTER-SET ((0
2414          ;; . 0))).  -- CSR, 2004-10-06
2415          #+sb-xc-host
2416          ((csubtypep type (specifier-type 'standard-char)) type)
2417          #+sb-xc-host
2418          ((csubtypep type (specifier-type 'base-char))
2419           (specifier-type 'base-char))
2420          #+sb-xc-host
2421          ((csubtypep type (specifier-type 'extended-char))
2422           (specifier-type 'extended-char))
2423          (t #+sb-xc-host (specifier-type 'character)
2424             #-sb-xc-host type))))))
2425
2426(defoptimizer (values derive-type) ((&rest values))
2427  (make-values-type :required (mapcar #'lvar-type values)))
2428
2429(defun signum-derive-type-aux (type)
2430  (if (eq (numeric-type-complexp type) :complex)
2431      (let* ((format (case (numeric-type-class type)
2432                          ((integer rational) 'single-float)
2433                          (t (numeric-type-format type))))
2434                (bound-format (or format 'float)))
2435           (make-numeric-type :class 'float
2436                              :format format
2437                              :complexp :complex
2438                              :low (coerce -1 bound-format)
2439                              :high (coerce 1 bound-format)))
2440      (let* ((interval (numeric-type->interval type))
2441             (range-info (interval-range-info interval))
2442             (contains-0-p (interval-contains-p 0 interval))
2443             (class (numeric-type-class type))
2444             (format (numeric-type-format type))
2445             (one (coerce 1 (or format class 'real)))
2446             (zero (coerce 0 (or format class 'real)))
2447             (minus-one (coerce -1 (or format class 'real)))
2448             (plus (make-numeric-type :class class :format format
2449                                      :low one :high one))
2450             (minus (make-numeric-type :class class :format format
2451                                       :low minus-one :high minus-one))
2452             ;; KLUDGE: here we have a fairly horrible hack to deal
2453             ;; with the schizophrenia in the type derivation engine.
2454             ;; The problem is that the type derivers reinterpret
2455             ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
2456             ;; 0d0) within the derivation mechanism doesn't include
2457             ;; -0d0.  Ugh.  So force it in here, instead.
2458             (zero (make-numeric-type :class class :format format
2459                                      :low (- zero) :high zero)))
2460        (case range-info
2461          (+ (if contains-0-p (type-union plus zero) plus))
2462          (- (if contains-0-p (type-union minus zero) minus))
2463          (t (type-union minus zero plus))))))
2464
2465(defoptimizer (signum derive-type) ((num))
2466  (one-arg-derive-type num #'signum-derive-type-aux nil))
2467
2468;;;; byte operations
2469;;;;
2470;;;; We try to turn byte operations into simple logical operations.
2471;;;; First, we convert byte specifiers into separate size and position
2472;;;; arguments passed to internal %FOO functions. We then attempt to
2473;;;; transform the %FOO functions into boolean operations when the
2474;;;; size and position are constant and the operands are fixnums.
2475;;;; The goal of the source-transform is to avoid consing a byte specifier
2476;;;; to immediately throw away. A more powerful framework could recognize
2477;;;; in IR1 when a constructor call flows to one or more accessors for the
2478;;;; constructed object and nowhere else (no mutators). If so, forwarding
2479;;;; the constructor arguments to their reads would generally solve this.
2480;;;; A transform approximates that, but fails when BYTE is produced by an
2481;;;; inline function and not a macro.
2482(flet ((xform (bytespec-form env int fun &optional (new nil setter-p))
2483         (let ((spec (%macroexpand bytespec-form env)))
2484           (if (and (consp spec) (eq (car spec) 'byte))
2485               (if (proper-list-of-length-p (cdr spec) 2)
2486                   (values `(,fun ,@(if setter-p (list new))
2487                                  ,(second spec) ,(third spec) ,int) nil)
2488                   ;; No point in compiling calls to BYTE-{SIZE,POSITION}
2489                   (values nil t)) ; T => "pass" (meaning "fail")
2490               (let ((new-temp (if setter-p (copy-symbol 'new)))
2491                     (byte (copy-symbol 'byte)))
2492                 (values `(let (,@(if new-temp `((,new-temp ,new)))
2493                                (,byte ,spec))
2494                            (,fun ,@(if setter-p (list new-temp))
2495                                  (byte-size ,byte) (byte-position ,byte) ,int))
2496                         nil))))))
2497
2498  ;; DEFINE-SOURCE-TRANSFORM has no compile-time effect, so it's fine that
2499  ;; these 4 things are non-toplevel. (xform does not need to be a macro)
2500  (define-source-transform ldb (spec int &environment env)
2501    (xform spec env int '%ldb))
2502
2503  (define-source-transform dpb (newbyte spec int &environment env)
2504    (xform spec env int '%dpb newbyte))
2505
2506  (define-source-transform mask-field (spec int &environment env)
2507    (xform spec env int '%mask-field))
2508
2509  (define-source-transform deposit-field (newbyte spec int &environment env)
2510    (xform spec env int '%deposit-field newbyte)))
2511
2512(defoptimizer (%ldb derive-type) ((size posn num))
2513  (declare (ignore posn num))
2514  (let ((size (lvar-type size)))
2515    (if (and (numeric-type-p size)
2516             (csubtypep size (specifier-type 'integer)))
2517        (let ((size-high (numeric-type-high size)))
2518          (if (and size-high (<= size-high sb!vm:n-word-bits))
2519              (specifier-type `(unsigned-byte* ,size-high))
2520              (specifier-type 'unsigned-byte)))
2521        *universal-type*)))
2522
2523(defoptimizer (%mask-field derive-type) ((size posn num))
2524  (declare (ignore num))
2525  (let ((size (lvar-type size))
2526        (posn (lvar-type posn)))
2527    (if (and (numeric-type-p size)
2528             (csubtypep size (specifier-type 'integer))
2529             (numeric-type-p posn)
2530             (csubtypep posn (specifier-type 'integer)))
2531        (let ((size-high (numeric-type-high size))
2532              (posn-high (numeric-type-high posn)))
2533          (if (and size-high posn-high
2534                   (<= (+ size-high posn-high) sb!vm:n-word-bits))
2535              (specifier-type `(unsigned-byte* ,(+ size-high posn-high)))
2536              (specifier-type 'unsigned-byte)))
2537        *universal-type*)))
2538
2539(defun %deposit-field-derive-type-aux (size posn int)
2540  (let ((size (lvar-type size))
2541        (posn (lvar-type posn))
2542        (int (lvar-type int)))
2543    (when (and (numeric-type-p size)
2544               (numeric-type-p posn)
2545               (numeric-type-p int))
2546      (let ((size-high (numeric-type-high size))
2547            (posn-high (numeric-type-high posn))
2548            (high (numeric-type-high int))
2549            (low (numeric-type-low int)))
2550        (when (and size-high posn-high high low
2551                   ;; KLUDGE: we need this cutoff here, otherwise we
2552                   ;; will merrily derive the type of %DPB as
2553                   ;; (UNSIGNED-BYTE 1073741822), and then attempt to
2554                   ;; canonicalize this type to (INTEGER 0 (1- (ASH 1
2555                   ;; 1073741822))), with hilarious consequences.  We
2556                   ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference
2557                   ;; over a reasonable amount of shifting, even on
2558                   ;; the alpha/32 port, where N-WORD-BITS is 32 but
2559                   ;; machine integers are 64-bits.  -- CSR,
2560                   ;; 2003-09-12
2561                   (<= (+ size-high posn-high) (* 4 sb!vm:n-word-bits)))
2562          (let ((raw-bit-count (max (integer-length high)
2563                                    (integer-length low)
2564                                    (+ size-high posn-high))))
2565            (specifier-type
2566             (if (minusp low)
2567                 `(signed-byte ,(1+ raw-bit-count))
2568                 `(unsigned-byte* ,raw-bit-count)))))))))
2569
2570(defoptimizer (%dpb derive-type) ((newbyte size posn int))
2571  (declare (ignore newbyte))
2572  (%deposit-field-derive-type-aux size posn int))
2573
2574(defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
2575  (declare (ignore newbyte))
2576  (%deposit-field-derive-type-aux size posn int))
2577
2578(deftransform %ldb ((size posn int)
2579                    (fixnum fixnum integer)
2580                    (unsigned-byte #.sb!vm:n-word-bits))
2581  "convert to inline logical operations"
2582  (if (and (constant-lvar-p size)
2583           (constant-lvar-p posn)
2584           (<= (+ (lvar-value size) (lvar-value posn)) sb!vm:n-fixnum-bits))
2585      (let ((size (lvar-value size))
2586            (posn (lvar-value posn)))
2587        `(logand (ash (mask-signed-field sb!vm:n-fixnum-bits int) ,(- posn))
2588                 ,(ash (1- (ash 1 sb!vm:n-word-bits))
2589                       (- size sb!vm:n-word-bits))))
2590      `(logand (ash int (- posn))
2591               (ash ,(1- (ash 1 sb!vm:n-word-bits))
2592                    (- size ,sb!vm:n-word-bits)))))
2593
2594(deftransform %mask-field ((size posn int)
2595                           (fixnum fixnum integer)
2596                           (unsigned-byte #.sb!vm:n-word-bits))
2597  "convert to inline logical operations"
2598  `(logand int
2599           (ash (ash ,(1- (ash 1 sb!vm:n-word-bits))
2600                     (- size ,sb!vm:n-word-bits))
2601                posn)))
2602
2603;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
2604;;;   (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
2605;;; as the result type, as that would allow result types that cover
2606;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
2607;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
2608
2609(deftransform %dpb ((new size posn int)
2610                    *
2611                    (unsigned-byte #.sb!vm:n-word-bits))
2612  "convert to inline logical operations"
2613  `(let ((mask (ldb (byte size 0) -1)))
2614     (logior (ash (logand new mask) posn)
2615             (logand int (lognot (ash mask posn))))))
2616
2617(deftransform %dpb ((new size posn int)
2618                    *
2619                    (signed-byte #.sb!vm:n-word-bits))
2620  "convert to inline logical operations"
2621  `(let ((mask (ldb (byte size 0) -1)))
2622     (logior (ash (logand new mask) posn)
2623             (logand int (lognot (ash mask posn))))))
2624
2625(deftransform %deposit-field ((new size posn int)
2626                              *
2627                              (unsigned-byte #.sb!vm:n-word-bits))
2628  "convert to inline logical operations"
2629  `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2630     (logior (logand new mask)
2631             (logand int (lognot mask)))))
2632
2633(deftransform %deposit-field ((new size posn int)
2634                              *
2635                              (signed-byte #.sb!vm:n-word-bits))
2636  "convert to inline logical operations"
2637  `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2638     (logior (logand new mask)
2639             (logand int (lognot mask)))))
2640
2641(defoptimizer (mask-signed-field derive-type) ((size x))
2642  (declare (ignore x))
2643  (let ((size (lvar-type size)))
2644    (if (numeric-type-p size)
2645        (let ((size-high (numeric-type-high size)))
2646          (if (and size-high (<= 1 size-high sb!vm:n-word-bits))
2647              (specifier-type `(signed-byte ,size-high))
2648              *universal-type*))
2649        *universal-type*)))
2650
2651;;; Rightward ASH
2652#!+ash-right-vops
2653(progn
2654  (defun %ash/right (integer amount)
2655    (ash integer (- amount)))
2656
2657  (deftransform ash ((integer amount))
2658    "Convert ASH of signed word to %ASH/RIGHT"
2659    (unless (and (csubtypep (lvar-type integer) ; do that ourselves to avoid
2660                            (specifier-type 'sb!vm:signed-word)) ; optimization
2661                 (csubtypep (lvar-type amount)  ; notes.
2662                            (specifier-type '(integer * 0))))
2663      (give-up-ir1-transform))
2664    (when (constant-lvar-p amount)
2665      (give-up-ir1-transform))
2666    (let ((use (lvar-uses amount)))
2667      (cond ((and (combination-p use)
2668                  (eql '%negate (lvar-fun-name (combination-fun use))))
2669             (splice-fun-args amount '%negate 1)
2670             `(lambda (integer amount)
2671                (declare (type unsigned-byte amount))
2672                (%ash/right integer (if (>= amount ,sb!vm:n-word-bits)
2673                                        ,(1- sb!vm:n-word-bits)
2674                                        amount))))
2675            (t
2676             `(%ash/right integer (if (<= amount ,(- sb!vm:n-word-bits))
2677                                      ,(1- sb!vm:n-word-bits)
2678                                      (- amount)))))))
2679
2680  (deftransform ash ((integer amount))
2681    "Convert ASH of word to %ASH/RIGHT"
2682    (unless (and (csubtypep (lvar-type integer)
2683                            (specifier-type 'sb!vm:word))
2684                 (csubtypep (lvar-type amount)
2685                            (specifier-type '(integer * 0))))
2686      (give-up-ir1-transform))
2687    (when (constant-lvar-p amount)
2688      (give-up-ir1-transform))
2689    (let ((use (lvar-uses amount)))
2690      (cond ((and (combination-p use)
2691                  (eql '%negate (lvar-fun-name (combination-fun use))))
2692             (splice-fun-args amount '%negate 1)
2693             `(lambda (integer amount)
2694                (declare (type unsigned-byte amount))
2695                (if (>= amount ,sb!vm:n-word-bits)
2696                    0
2697                    (%ash/right integer amount))))
2698            (t
2699             `(if (<= amount ,(- sb!vm:n-word-bits))
2700                  0
2701                  (%ash/right integer (- amount)))))))
2702
2703  (deftransform %ash/right ((integer amount) (integer (constant-arg unsigned-byte)))
2704    "Convert %ASH/RIGHT by constant back to ASH"
2705    `(ash integer ,(- (lvar-value amount))))
2706
2707  (deftransform %ash/right ((integer amount) * * :node node)
2708    "strength reduce large variable right shift"
2709    (let ((return-type (single-value-type (node-derived-type node))))
2710      (cond ((type= return-type (specifier-type '(eql 0)))
2711             0)
2712            ((type= return-type (specifier-type '(eql -1)))
2713             -1)
2714            ((csubtypep return-type (specifier-type '(member -1 0)))
2715             `(ash integer ,(- sb!vm:n-word-bits)))
2716            (t
2717             (give-up-ir1-transform)))))
2718
2719  (defun %ash/right-derive-type-aux (n-type shift same-arg)
2720    (declare (ignore same-arg))
2721    (or (and (or (csubtypep n-type (specifier-type 'sb!vm:signed-word))
2722                 (csubtypep n-type (specifier-type 'word)))
2723             (csubtypep shift (specifier-type `(mod ,sb!vm:n-word-bits)))
2724             (let ((n-low (numeric-type-low n-type))
2725                   (n-high (numeric-type-high n-type))
2726                   (s-low (numeric-type-low shift))
2727                   (s-high (numeric-type-high shift)))
2728               (make-numeric-type :class 'integer :complexp :real
2729                                  :low (when n-low
2730                                         (if (minusp n-low)
2731                                             (ash n-low (- s-low))
2732                                             (ash n-low (- s-high))))
2733                                  :high (when n-high
2734                                          (if (minusp n-high)
2735                                              (ash n-high (- s-high))
2736                                              (ash n-high (- s-low)))))))
2737        *universal-type*))
2738
2739  (defoptimizer (%ash/right derive-type) ((n shift))
2740    (two-arg-derive-type n shift #'%ash/right-derive-type-aux #'%ash/right))
2741  )
2742
2743;;; Not declaring it as actually being RATIO becuase it is used as one
2744;;; of the legs in the EXPT transform below and that may result in
2745;;; some unwanted type conflicts, e.g. (random (expt 2 (the integer y)))
2746(declaim (type (sfunction (integer) rational) reciprocate))
2747(defun reciprocate (x)
2748  (declare (optimize (safety 0)))
2749  #+sb-xc-host (error "Can't call reciprocate ~D" x)
2750  #-sb-xc-host (%make-ratio 1 x))
2751
2752(deftransform expt ((base power) ((constant-arg unsigned-byte) integer))
2753  (let ((base (lvar-value base)))
2754    (cond ((/= (logcount base) 1)
2755           (give-up-ir1-transform))
2756          ((= base 1)
2757           1)
2758          (t
2759           `(let ((%denominator (ash 1 ,(if (= base 2)
2760                                            `(abs power)
2761                                            `(* (abs power) ,(1- (integer-length base)))))))
2762              (if (minusp power)
2763                  (reciprocate %denominator)
2764                  %denominator))))))
2765
2766(deftransform expt ((base power) ((constant-arg unsigned-byte) unsigned-byte))
2767  (let ((base (lvar-value base)))
2768    (unless (= (logcount base) 1)
2769      (give-up-ir1-transform))
2770    `(ash 1 ,(if (= base 2)
2771                 `power
2772                 `(* power ,(1- (integer-length base)))))))
2773
2774;;; Modular functions
2775
2776;;; (ldb (byte s 0) (foo                 x  y ...)) =
2777;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
2778;;;
2779;;; and similar for other arguments.
2780
2781(defun make-modular-fun-type-deriver (prototype kind width signedp)
2782  (declare (ignore kind))
2783  #!-sb-fluid
2784  (binding* ((info (info :function :info prototype) :exit-if-null)
2785             (fun (fun-info-derive-type info) :exit-if-null)
2786             (mask-type (specifier-type
2787                         (ecase signedp
2788                             ((nil) (let ((mask (1- (ash 1 width))))
2789                                      `(integer ,mask ,mask)))
2790                             ((t) `(signed-byte ,width))))))
2791    (lambda (call)
2792      (let ((res (funcall fun call)))
2793        (when res
2794          (if (eq signedp nil)
2795              (logand-derive-type-aux res mask-type))))))
2796  #!+sb-fluid
2797  (lambda (call)
2798    (binding* ((info (info :function :info prototype) :exit-if-null)
2799               (fun (fun-info-derive-type info) :exit-if-null)
2800               (res (funcall fun call) :exit-if-null)
2801               (mask-type (specifier-type
2802                           (ecase signedp
2803                             ((nil) (let ((mask (1- (ash 1 width))))
2804                                      `(integer ,mask ,mask)))
2805                             ((t) `(signed-byte ,width))))))
2806      (if (eq signedp nil)
2807          (logand-derive-type-aux res mask-type)))))
2808
2809;;; Try to recursively cut all uses of LVAR to WIDTH bits.
2810;;;
2811;;; For good functions, we just recursively cut arguments; their
2812;;; "goodness" means that the result will not increase (in the
2813;;; (unsigned-byte +infinity) sense). An ordinary modular function is
2814;;; replaced with the version, cutting its result to WIDTH or more
2815;;; bits. For most functions (e.g. for +) we cut all arguments; for
2816;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
2817;;; arguments (maybe to a different width) and returning the name of a
2818;;; modular version, if it exists, or NIL. If we have changed
2819;;; anything, we need to flush old derived types, because they have
2820;;; nothing in common with the new code.
2821(defun cut-to-width (lvar kind width signedp)
2822  (declare (type lvar lvar) (type (integer 0) width))
2823  (let ((type (specifier-type (if (zerop width)
2824                                  '(eql 0)
2825                                  `(,(ecase signedp
2826                                       ((nil) 'unsigned-byte)
2827                                       ((t) 'signed-byte))
2828                                     ,width)))))
2829    (labels ((reoptimize-node (node name)
2830               (setf (node-derived-type node)
2831                     (fun-type-returns
2832                      (proclaimed-ftype name)))
2833               (setf (lvar-%derived-type (node-lvar node)) nil)
2834               (setf (node-reoptimize node) t)
2835               (setf (block-reoptimize (node-block node)) t)
2836               (reoptimize-component (node-component node) :maybe))
2837             (insert-lvar-cut (lvar)
2838               "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
2839                to the required bit width. Returns T if any change was made.
2840
2841                When the destination of LVAR will definitely cut LVAR's value
2842                to width (i.e. it's a logand or mask-signed-field with constant
2843                other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
2844               (binding* ((dest (lvar-dest lvar) :exit-if-null)
2845                          (nil  (combination-p dest) :exit-if-null)
2846                          (name (lvar-fun-name (combination-fun dest) t))
2847                          (args (combination-args dest)))
2848                 (case name
2849                   (logand
2850                    (when (= 2 (length args))
2851                      (let ((other (if (eql (first args) lvar)
2852                                       (second args)
2853                                       (first args))))
2854                        (when (and (constant-lvar-p other)
2855                                   (ctypep (lvar-value other) type)
2856                                   (not signedp))
2857                          (return-from insert-lvar-cut)))))
2858                   (mask-signed-field
2859                    (when (and signedp
2860                               (eql lvar (second args))
2861                               (constant-lvar-p (first args))
2862                               (<= (lvar-value (first args)) width))
2863                      (return-from insert-lvar-cut)))))
2864               (filter-lvar lvar
2865                            (if signedp
2866                                `(mask-signed-field ,width 'dummy)
2867                                `(logand 'dummy ,(ldb (byte width 0) -1))))
2868               (do-uses (node lvar)
2869                 (setf (block-reoptimize (node-block node)) t)
2870                 (reoptimize-component (node-component node) :maybe))
2871               t)
2872             (cut-node (node)
2873               "Try to cut a node to width. The primary return value is
2874                whether we managed to cut (cleverly), and the second whether
2875                anything was changed.  The third return value tells whether
2876                the cut value might be wider than expected."
2877               (when (block-delete-p (node-block node))
2878                 (return-from cut-node (values t nil)))
2879               (typecase node
2880                 (ref
2881                  (typecase (ref-leaf node)
2882                    (constant
2883                     (let* ((constant-value (constant-value (ref-leaf node)))
2884                            (new-value
2885                              (cond ((not (integerp constant-value))
2886                                     (return-from cut-node (values t nil)))
2887                                    (signedp
2888                                     (mask-signed-field width constant-value))
2889                                    (t
2890                                     (ldb (byte width 0) constant-value)))))
2891                       (cond ((= constant-value new-value)
2892                              (values t nil)) ; we knew what to do and did nothing
2893                             (t
2894                              (change-ref-leaf node (make-constant new-value)
2895                                               :recklessly t)
2896                              (let ((lvar (node-lvar node)))
2897                                (setf (lvar-%derived-type lvar)
2898                                      (and (lvar-has-single-use-p lvar)
2899                                           (make-values-type :required (list (ctype-of new-value))))))
2900                              (setf (block-reoptimize (node-block node)) t)
2901                              (reoptimize-component (node-component node) :maybe)
2902                              (values t t)))))))
2903                 (combination
2904                  (when (eq (basic-combination-kind node) :known)
2905                    (let* ((fun-ref (lvar-use (combination-fun node)))
2906                           (fun-name (lvar-fun-name (combination-fun node)))
2907                           (modular-fun (find-modular-version fun-name kind
2908                                                              signedp width)))
2909                      (cond ((not modular-fun)
2910                             ;; don't know what to do here
2911                             (values nil nil))
2912                            ((let ((dtype (single-value-type
2913                                           (node-derived-type node))))
2914                               (and
2915                                (case fun-name
2916                                  (logand
2917                                   (csubtypep dtype
2918                                              (specifier-type 'unsigned-byte)))
2919                                  (logior
2920                                   (csubtypep dtype
2921                                              (specifier-type '(integer * 0))))
2922                                  (mask-signed-field
2923                                   t)
2924                                  (t nil))
2925                                (csubtypep dtype type)))
2926                             ;; nothing to do
2927                             (values t nil))
2928                            (t
2929                             (binding* ((name (etypecase modular-fun
2930                                                ((eql :good) fun-name)
2931                                                (modular-fun-info
2932                                                 (modular-fun-info-name modular-fun))
2933                                                (function
2934                                                 (funcall modular-fun node width)))
2935                                              :exit-if-null)
2936                                        (did-something nil)
2937                                        (over-wide nil))
2938                               (unless (eql modular-fun :good)
2939                                 (setq did-something t
2940                                       over-wide t)
2941                                 (change-ref-leaf
2942                                  fun-ref
2943                                  (find-free-fun name "in a strange place"))
2944                                 (setf (combination-kind node) :full))
2945                               (unless (functionp modular-fun)
2946                                 (dolist (arg (basic-combination-args node))
2947                                   (multiple-value-bind (change wide)
2948                                       (cut-lvar arg)
2949                                     (setf did-something (or did-something change)
2950                                           over-wide (or over-wide wide)))))
2951                               (when did-something
2952                                 (reoptimize-node node name))
2953                               (values t did-something over-wide)))))))))
2954             (cut-lvar (lvar &key head
2955                        &aux did-something must-insert over-wide)
2956               "Cut all the LVAR's use nodes. If any of them wasn't handled
2957                and its type is too wide for the operation we wish to perform
2958                insert an explicit bit-width narrowing operation (LOGAND or
2959                MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
2960                The narrowing operation might not be inserted if the LVAR's
2961                destination is already such an operation, to avoid endless
2962                recursion.
2963
2964                If we're at the head, forcibly insert a cut operation if the
2965                result might be too wide.
2966
2967                (*) We can't easily do that for each node, and doing so might
2968                result in code bloat, anyway. (I'm also not sure it would be
2969                correct for complicated C/D FG)"
2970               (do-uses (node lvar)
2971                 (multiple-value-bind (handled any-change wide)
2972                     (cut-node node)
2973                   (setf did-something (or did-something any-change)
2974                         must-insert (or must-insert
2975                                         (not (or handled
2976                                                  (csubtypep (single-value-type
2977                                                              (node-derived-type node))
2978                                                             type))))
2979                         over-wide (or over-wide wide))))
2980               (when (or must-insert
2981                         (and head over-wide))
2982                 (setf did-something (or (insert-lvar-cut lvar) did-something)
2983                       ;; we're just the right width after an explicit cut.
2984                       over-wide nil))
2985               (values did-something over-wide)))
2986      (cut-lvar lvar :head t))))
2987
2988(defun best-modular-version (width signedp)
2989  ;; 1. exact width-matched :untagged
2990  ;; 2. >/>= width-matched :tagged
2991  ;; 3. >/>= width-matched :untagged
2992  (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
2993         (uswidths (modular-class-widths *untagged-signed-modular-class*))
2994         (uwidths (if (and uuwidths uswidths)
2995                      (merge 'list (copy-list uuwidths) (copy-list uswidths)
2996                             #'< :key #'car)
2997                      (or uuwidths uswidths)))
2998         (twidths (modular-class-widths *tagged-modular-class*)))
2999    (let ((exact (find (cons width signedp) uwidths :test #'equal)))
3000      (when exact
3001        (return-from best-modular-version (values width :untagged signedp))))
3002    (flet ((inexact-match (w)
3003             (cond
3004               ((eq signedp (cdr w)) (<= width (car w)))
3005               ((eq signedp nil) (< width (car w))))))
3006      (let ((tgt (find-if #'inexact-match twidths)))
3007        (when tgt
3008          (return-from best-modular-version
3009            (values (car tgt) :tagged (cdr tgt)))))
3010      (let ((ugt (find-if #'inexact-match uwidths)))
3011        (when ugt
3012          (return-from best-modular-version
3013            (values (car ugt) :untagged (cdr ugt))))))))
3014
3015(defun integer-type-numeric-bounds (type)
3016  (typecase type
3017    ;; KLUDGE: this is not INTEGER-type-numeric-bounds
3018    (numeric-type (values (numeric-type-low type)
3019                          (numeric-type-high type)))
3020    (union-type
3021     (let ((low  nil)
3022           (high nil))
3023       (dolist (type (union-type-types type) (values low high))
3024         (unless (and (numeric-type-p type)
3025                      (eql (numeric-type-class type) 'integer))
3026           (return (values nil nil)))
3027         (let ((this-low (numeric-type-low type))
3028               (this-high (numeric-type-high type)))
3029           (unless (and this-low this-high)
3030             (return (values nil nil)))
3031           (setf low  (min this-low  (or low  this-low))
3032                 high (max this-high (or high this-high)))))))))
3033
3034(defoptimizer (logand optimizer) ((x y) node)
3035  (let ((result-type (single-value-type (node-derived-type node))))
3036    (multiple-value-bind (low high)
3037        (integer-type-numeric-bounds result-type)
3038      (when (and (numberp low)
3039                 (numberp high)
3040                 (>= low 0))
3041        (let ((width (integer-length high)))
3042          (multiple-value-bind (w kind signedp)
3043              (best-modular-version width nil)
3044            (when w
3045              ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
3046              ;;
3047              ;; FIXME: I think the FIXME (which is from APD) above
3048              ;; implies that CUT-TO-WIDTH should do /everything/
3049              ;; that's required, including reoptimizing things
3050              ;; itself that it knows are necessary.  At the moment,
3051              ;; CUT-TO-WIDTH sets up some new calls with
3052              ;; combination-type :FULL, which later get noticed as
3053              ;; known functions and properly converted.
3054              ;;
3055              ;; We cut to W not WIDTH if SIGNEDP is true, because
3056              ;; signed constant replacement needs to know which bit
3057              ;; in the field is the signed bit.
3058              (let ((xact (cut-to-width x kind (if signedp w width) signedp))
3059                    (yact (cut-to-width y kind (if signedp w width) signedp)))
3060                (declare (ignore xact yact))
3061                nil) ; After fixing above, replace with T, meaning
3062                                        ; "don't reoptimize this (LOGAND) node any more".
3063              )))))))
3064
3065(defoptimizer (mask-signed-field optimizer) ((width x) node)
3066  (declare (ignore width))
3067  (let ((result-type (single-value-type (node-derived-type node))))
3068    (multiple-value-bind (low high)
3069        (integer-type-numeric-bounds result-type)
3070      (when (and (numberp low) (numberp high))
3071        (let ((width (max (integer-length high) (integer-length low))))
3072          (multiple-value-bind (w kind)
3073              (best-modular-version (1+ width) t)
3074            (when w
3075              ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
3076              ;; [ see comment above in LOGAND optimizer ]
3077              (cut-to-width x kind w t)
3078              nil                ; After fixing above, replace with T.
3079              )))))))
3080
3081(defoptimizer (logior optimizer) ((x y) node)
3082  (let ((result-type (single-value-type (node-derived-type node))))
3083    (multiple-value-bind (low high)
3084        (integer-type-numeric-bounds result-type)
3085      (when (and (numberp low)
3086                 (numberp high)
3087                 (<= high 0))
3088        (let ((width (integer-length low)))
3089          (multiple-value-bind (w kind)
3090              (best-modular-version (1+ width) t)
3091            (when w
3092              ;; FIXME: see comment in LOGAND optimizer
3093              (let ((xact (cut-to-width x kind w t))
3094                    (yact (cut-to-width y kind w t)))
3095                (declare (ignore xact yact))
3096                nil) ; After fixing above, replace with T
3097              )))))))
3098
3099;;; Handle the case of a constant BOOLE-CODE.
3100(deftransform boole ((op x y) * *)
3101  "convert to inline logical operations"
3102  (unless (constant-lvar-p op)
3103    (give-up-ir1-transform "BOOLE code is not a constant."))
3104  (let ((control (lvar-value op)))
3105    (case control
3106      (#.sb!xc:boole-clr 0)
3107      (#.sb!xc:boole-set -1)
3108      (#.sb!xc:boole-1 'x)
3109      (#.sb!xc:boole-2 'y)
3110      (#.sb!xc:boole-c1 '(lognot x))
3111      (#.sb!xc:boole-c2 '(lognot y))
3112      (#.sb!xc:boole-and '(logand x y))
3113      (#.sb!xc:boole-ior '(logior x y))
3114      (#.sb!xc:boole-xor '(logxor x y))
3115      (#.sb!xc:boole-eqv '(logeqv x y))
3116      (#.sb!xc:boole-nand '(lognand x y))
3117      (#.sb!xc:boole-nor '(lognor x y))
3118      (#.sb!xc:boole-andc1 '(logandc1 x y))
3119      (#.sb!xc:boole-andc2 '(logandc2 x y))
3120      (#.sb!xc:boole-orc1 '(logorc1 x y))
3121      (#.sb!xc:boole-orc2 '(logorc2 x y))
3122      (t
3123       (abort-ir1-transform "~S is an illegal control arg to BOOLE."
3124                            control)))))
3125
3126;;;; converting special case multiply/divide to shifts
3127
3128;;; If arg is a constant power of two, turn * into a shift.
3129(deftransform * ((x y) (integer integer) *)
3130  "convert x*2^k to shift"
3131  (unless (constant-lvar-p y)
3132    (give-up-ir1-transform))
3133  (let* ((y (lvar-value y))
3134         (y-abs (abs y))
3135         (len (1- (integer-length y-abs))))
3136    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3137      (give-up-ir1-transform))
3138    (if (minusp y)
3139        `(- (ash x ,len))
3140        `(ash x ,len))))
3141
3142;;; These must come before the ones below, so that they are tried
3143;;; first.
3144(deftransform floor ((number divisor))
3145  `(multiple-value-bind (tru rem) (truncate number divisor)
3146     (if (and (not (zerop rem))
3147              (if (minusp divisor)
3148                  (plusp number)
3149                  (minusp number)))
3150         (values (1- tru) (+ rem divisor))
3151         (values tru rem))))
3152
3153(deftransform ceiling ((number divisor))
3154  `(multiple-value-bind (tru rem) (truncate number divisor)
3155     (if (and (not (zerop rem))
3156              (if (minusp divisor)
3157                  (minusp number)
3158                  (plusp number)))
3159         (values (+ tru 1) (- rem divisor))
3160         (values tru rem))))
3161
3162(deftransform rem ((number divisor))
3163  `(nth-value 1 (truncate number divisor)))
3164
3165(deftransform mod ((number divisor))
3166  `(let ((rem (rem number divisor)))
3167     (if (and (not (zerop rem))
3168              (if (minusp divisor)
3169                  (plusp number)
3170                  (minusp number)))
3171         (+ rem divisor)
3172         rem)))
3173
3174;;; If arg is a constant power of two, turn FLOOR into a shift and
3175;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
3176;;; remainder.
3177(flet ((frob (y ceil-p)
3178         (unless (constant-lvar-p y)
3179           (give-up-ir1-transform))
3180         (let* ((y (lvar-value y))
3181                (y-abs (abs y))
3182                (len (1- (integer-length y-abs))))
3183           (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3184             (give-up-ir1-transform))
3185           (let ((shift (- len))
3186                 (mask (1- y-abs))
3187                 (delta (if ceil-p (* (signum y) (1- y-abs)) 0)))
3188             `(let ((x (+ x ,delta)))
3189                ,(if (minusp y)
3190                     `(values (ash (- x) ,shift)
3191                              (- (- (logand (- x) ,mask)) ,delta))
3192                     `(values (ash x ,shift)
3193                              (- (logand x ,mask) ,delta))))))))
3194  (deftransform floor ((x y) (integer integer) *)
3195    "convert division by 2^k to shift"
3196    (frob y nil))
3197  (deftransform ceiling ((x y) (integer integer) *)
3198    "convert division by 2^k to shift"
3199    (frob y t)))
3200
3201;;; Do the same for MOD.
3202(deftransform mod ((x y) (integer (constant-arg integer)) *)
3203  "convert remainder mod 2^k to LOGAND"
3204  (let* ((y (lvar-value y))
3205         (y-abs (abs y))
3206         (len (1- (integer-length y-abs))))
3207    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3208      (give-up-ir1-transform))
3209    (let ((mask (1- y-abs)))
3210      (if (minusp y)
3211          `(- (logand (- x) ,mask))
3212          `(logand x ,mask)))))
3213
3214;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
3215(deftransform truncate ((x y) (integer (constant-arg integer)))
3216  "convert division by 2^k to shift"
3217  (let* ((y (lvar-value y))
3218         (y-abs (abs y))
3219         (len (1- (integer-length y-abs))))
3220    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3221      (give-up-ir1-transform))
3222    (let ((shift (- len))
3223          (mask (1- y-abs)))
3224      `(if (minusp x)
3225           (values ,(if (minusp y)
3226                        `(ash (- x) ,shift)
3227                        `(- (ash (- x) ,shift)))
3228                   (- (logand (- x) ,mask)))
3229           (values ,(if (minusp y)
3230                        `(- (ash x ,shift))
3231                        `(ash x ,shift))
3232                   (logand x ,mask))))))
3233
3234;;; And the same for REM.
3235(deftransform rem ((x y) (integer (constant-arg integer)) *)
3236  "convert remainder mod 2^k to LOGAND"
3237  (let* ((y (lvar-value y))
3238         (y-abs (abs y))
3239         (len (1- (integer-length y-abs))))
3240    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3241      (give-up-ir1-transform))
3242    (let ((mask (1- y-abs)))
3243      `(if (minusp x)
3244           (- (logand (- x) ,mask))
3245           (logand x ,mask)))))
3246
3247;;; Return an expression to calculate the integer quotient of X and
3248;;; constant Y, using multiplication, shift and add/sub instead of
3249;;; division. Both arguments must be unsigned, fit in a machine word and
3250;;; Y must neither be zero nor a power of two. The quotient is rounded
3251;;; towards zero.
3252;;; The algorithm is taken from the paper "Division by Invariant
3253;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and
3254;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the
3255;;; case of division by powers of two.
3256;;; The algorithm includes an adaptive precision argument.  Use it, since
3257;;; we often have sub-word value ranges.  Careful, in this case, we need
3258;;; p s.t 2^p > n, not the ceiling of the binary log.
3259;;; Also, for some reason, the paper prefers shifting to masking.  Mask
3260;;; instead.  Masking is equivalent to shifting right, then left again;
3261;;; all the intermediate values are still words, so we just have to shift
3262;;; right a bit more to compensate, at the end.
3263;;;
3264;;; The following two examples show an average case and the worst case
3265;;; with respect to the complexity of the generated expression, under
3266;;; a word size of 64 bits:
3267;;;
3268;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) ->
3269;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3)
3270;;;
3271;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) ->
3272;;; (LET* ((NUM X)
3273;;;        (T1 (%MULTIPLY NUM 2635249153387078803)))
3274;;;   (ASH (LDB (BYTE 64 0)
3275;;;             (+ T1 (ASH (LDB (BYTE 64 0)
3276;;;                             (- NUM T1))
3277;;;                        -1)))
3278;;;        -2))
3279;;;
3280(defun gen-unsigned-div-by-constant-expr (y max-x)
3281  (declare (type (integer 3 #.most-positive-word) y)
3282           (type word max-x))
3283  (aver (not (zerop (logand y (1- y)))))
3284  (labels ((ld (x)
3285             ;; the floor of the binary logarithm of (positive) X
3286             (integer-length (1- x)))
3287           (choose-multiplier (y precision)
3288             (do* ((l (ld y))
3289                   (shift l (1- shift))
3290                   (expt-2-n+l (expt 2 (+ sb!vm:n-word-bits l)))
3291                   (m-low (truncate expt-2-n+l y) (ash m-low -1))
3292                   (m-high (truncate (+ expt-2-n+l
3293                                        (ash expt-2-n+l (- precision)))
3294                                     y)
3295                           (ash m-high -1)))
3296                  ((not (and (< (ash m-low -1) (ash m-high -1))
3297                             (> shift 0)))
3298                   (values m-high shift)))))
3299    (let ((n (expt 2 sb!vm:n-word-bits))
3300          (precision (integer-length max-x))
3301          (shift1 0))
3302      (multiple-value-bind (m shift2)
3303          (choose-multiplier y precision)
3304        (when (and (>= m n) (evenp y))
3305          (setq shift1 (ld (logand y (- y))))
3306          (multiple-value-setq (m shift2)
3307            (choose-multiplier (/ y (ash 1 shift1))
3308                               (- precision shift1))))
3309        (cond ((>= m n)
3310               (flet ((word (x)
3311                        `(truly-the word ,x)))
3312                 `(let* ((num x)
3313                         (t1 (%multiply-high num ,(- m n))))
3314                    (ash ,(word `(+ t1 (ash ,(word `(- num t1))
3315                                            -1)))
3316                         ,(- 1 shift2)))))
3317              ((and (zerop shift1) (zerop shift2))
3318               (let ((max (truncate max-x y)))
3319                 ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM
3320                 ;; VOP.
3321                 `(truly-the (integer 0 ,max)
3322                             (%multiply-high x ,m))))
3323              (t
3324               `(ash (%multiply-high (logandc2 x ,(1- (ash 1 shift1))) ,m)
3325                     ,(- (+ shift1 shift2)))))))))
3326
3327#!-multiply-high-vops
3328(define-source-transform %multiply-high (x y)
3329  `(values (sb!bignum:%multiply ,x ,y)))
3330
3331;;; If the divisor is constant and both args are positive and fit in a
3332;;; machine word, replace the division by a multiplication and possibly
3333;;; some shifts and an addition. Calculate the remainder by a second
3334;;; multiplication and a subtraction. Dead code elimination will
3335;;; suppress the latter part if only the quotient is needed. If the type
3336;;; of the dividend allows to derive that the quotient will always have
3337;;; the same value, emit much simpler code to handle that. (This case
3338;;; may be rare but it's easy to detect and the compiler doesn't find
3339;;; this optimization on its own.)
3340(deftransform truncate ((x y) (word (constant-arg word))
3341                        *
3342                        :policy (and (> speed compilation-speed)
3343                                     (> speed space)))
3344  "convert integer division to multiplication"
3345  (let* ((y      (lvar-value y))
3346         (x-type (lvar-type x))
3347         (max-x  (or (and (numeric-type-p x-type)
3348                          (numeric-type-high x-type))
3349                     most-positive-word)))
3350    ;; Division by zero, one or powers of two is handled elsewhere.
3351    (when (zerop (logand y (1- y)))
3352      (give-up-ir1-transform))
3353    `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x))
3354            (rem (ldb (byte #.sb!vm:n-word-bits 0)
3355                      (- x (* quot ,y)))))
3356       (values quot rem))))
3357
3358;;;; arithmetic and logical identity operation elimination
3359
3360;;; Flush calls to various arith functions that convert to the
3361;;; identity function or a constant.
3362(macrolet ((def (name identity result)
3363             `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) *)
3364                "fold identity operations"
3365                ',result)))
3366  (def ash 0 x)
3367  (def logand -1 x)
3368  (def logand 0 0)
3369  (def logior 0 x)
3370  (def logior -1 -1)
3371  (def logxor -1 (lognot x))
3372  (def logxor 0 x))
3373
3374(defun least-zero-bit (x)
3375  (and (/= x -1)
3376       (1- (integer-length (logxor x (1+ x))))))
3377
3378(deftransform logand ((x y) (* (constant-arg t)) *)
3379  "fold identity operation"
3380  (let* ((y (lvar-value y))
3381         (width (or (least-zero-bit y) '*)))
3382    (unless (and (neq width 0) ; (logand x 0) handled elsewhere
3383                 (csubtypep (lvar-type x)
3384                            (specifier-type `(unsigned-byte ,width))))
3385      (give-up-ir1-transform))
3386    'x))
3387
3388(deftransform mask-signed-field ((size x) ((constant-arg t) *) *)
3389  "fold identity operation"
3390  (let ((size (lvar-value size)))
3391    (when (= size 0) (give-up-ir1-transform))
3392    (unless (csubtypep (lvar-type x) (specifier-type `(signed-byte ,size)))
3393      (give-up-ir1-transform))
3394    'x))
3395
3396(deftransform logior ((x y) (* (constant-arg integer)) *)
3397  "fold identity operation"
3398  (let* ((y (lvar-value y))
3399         (width (or (least-zero-bit (lognot y))
3400                    (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
3401    (unless (csubtypep (lvar-type x)
3402                       (specifier-type `(integer ,(- (ash 1 width)) -1)))
3403      (give-up-ir1-transform))
3404    'x))
3405
3406;;; Pick off easy association opportunities for constant folding.
3407;;; More complicated stuff that also depends on commutativity
3408;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
3409;;; probably be handled with a more general tree-rewriting pass.
3410(macrolet ((def (operator &key (type 'integer) (folded operator))
3411             `(deftransform ,operator ((x z) (,type (constant-arg ,type)))
3412                ,(format nil "associate ~A/~A of constants"
3413                         operator folded)
3414                (binding* ((node  (if (lvar-has-single-use-p x)
3415                                      (lvar-use x)
3416                                      (give-up-ir1-transform)))
3417                           (nil (or (and (combination-p node)
3418                                         (eq (lvar-fun-name
3419                                              (combination-fun node))
3420                                             ',folded))
3421                                    (give-up-ir1-transform)))
3422                           (y   (second (combination-args node)))
3423                           (nil (or (constant-lvar-p y)
3424                                    (give-up-ir1-transform)))
3425                           (y   (lvar-value y)))
3426                  (unless (typep y ',type)
3427                    (give-up-ir1-transform))
3428                  (splice-fun-args x ',folded 2)
3429                  `(lambda (x y z)
3430                     (declare (ignore y z))
3431                     ;; (operator (folded x y) z)
3432                     ;; == (operator x (folded z y))
3433                     (,',operator x ',(,folded (lvar-value z) y)))))))
3434  (def logand)
3435  (def logior)
3436  (def logxor)
3437  (def logtest :folded logand)
3438  (def + :type rational)
3439  (def + :type rational :folded -)
3440  (def * :type rational)
3441  (def * :type rational :folded /))
3442
3443(deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
3444  "Fold mask-signed-field/mask-signed-field of constant width"
3445  (binding* ((node  (if (lvar-has-single-use-p x)
3446                        (lvar-use x)
3447                        (give-up-ir1-transform)))
3448             (nil (or (combination-p node)
3449                      (give-up-ir1-transform)))
3450             (nil (or (eq (lvar-fun-name (combination-fun node))
3451                          'mask-signed-field)
3452                      (give-up-ir1-transform)))
3453             (x-width (first (combination-args node)))
3454             (nil (or (constant-lvar-p x-width)
3455                      (give-up-ir1-transform)))
3456             (x-width (lvar-value x-width)))
3457    (unless (typep x-width 'unsigned-byte)
3458      (give-up-ir1-transform))
3459    (splice-fun-args x 'mask-signed-field 2)
3460    `(lambda (width x-width x)
3461       (declare (ignore width x-width))
3462       (mask-signed-field ,(min (lvar-value width) x-width) x))))
3463
3464;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
3465;;; (* 0 -4.0) is -0.0.
3466(deftransform - ((x y) ((constant-arg (member 0)) rational) *)
3467  "convert (- 0 x) to negate"
3468  '(%negate y))
3469(deftransform * ((x y) (rational (constant-arg (member 0))) *)
3470  "convert (* x 0) to 0"
3471  0)
3472
3473(deftransform %negate ((x) (rational))
3474  "Eliminate %negate/%negate of rationals"
3475  (splice-fun-args x '%negate 1)
3476  '(the rational x))
3477
3478(deftransform %negate ((x) (number))
3479  "Combine %negate/*"
3480  (let ((use (lvar-uses x))
3481        arg)
3482    (unless (and (combination-p use)
3483                 (eql '* (lvar-fun-name (combination-fun use)))
3484                 (constant-lvar-p (setf arg (second (combination-args use))))
3485                 (numberp (setf arg (lvar-value arg))))
3486      (give-up-ir1-transform))
3487    (splice-fun-args x '* 2)
3488    `(lambda (x y)
3489       (declare (ignore y))
3490       (* x ,(- arg)))))
3491
3492;;; Return T if in an arithmetic op including lvars X and Y, the
3493;;; result type is not affected by the type of X. That is, Y is at
3494;;; least as contagious as X.
3495#+nil
3496(defun not-more-contagious (x y)
3497  (declare (type continuation x y))
3498  (let ((x (lvar-type x))
3499        (y (lvar-type y)))
3500    (values (type= (numeric-contagion x y)
3501                   (numeric-contagion y y)))))
3502;;; Patched version by Raymond Toy. dtc: Should be safer although it
3503;;; XXX needs more work as valid transforms are missed; some cases are
3504;;; specific to particular transform functions so the use of this
3505;;; function may need a re-think.
3506(defun not-more-contagious (x y)
3507  (declare (type lvar x y))
3508  (flet ((simple-numeric-type (num)
3509           (and (numeric-type-p num)
3510                ;; Return non-NIL if NUM is integer, rational, or a float
3511                ;; of some type (but not FLOAT)
3512                (case (numeric-type-class num)
3513                  ((integer rational)
3514                   t)
3515                  (float
3516                   (numeric-type-format num))
3517                  (t
3518                   nil)))))
3519    (let ((x (lvar-type x))
3520          (y (lvar-type y)))
3521      (if (and (simple-numeric-type x)
3522               (simple-numeric-type y))
3523          (values (type= (numeric-contagion x y)
3524                         (numeric-contagion y y)))))))
3525
3526(def!type exact-number ()
3527  '(or rational (complex rational)))
3528
3529;;; Fold (+ x 0).
3530;;;
3531;;; Only safely applicable for exact numbers. For floating-point
3532;;; x, one would have to first show that neither x or y are signed
3533;;; 0s, and that x isn't an SNaN.
3534(deftransform + ((x y) (exact-number (constant-arg (eql 0))) *)
3535  "fold zero arg"
3536  'x)
3537
3538;;; Fold (- x 0).
3539(deftransform - ((x y) (exact-number (constant-arg (eql 0))) *)
3540  "fold zero arg"
3541  'x)
3542
3543;;; Fold (OP x +/-1)
3544;;;
3545;;; %NEGATE might not always signal correctly.
3546(macrolet
3547    ((def (name result minus-result)
3548         `(deftransform ,name ((x y)
3549                               (exact-number (constant-arg (member 1 -1))))
3550            "fold identity operations"
3551            (if (minusp (lvar-value y)) ',minus-result ',result))))
3552  (def * x (%negate x))
3553  (def / x (%negate x))
3554  (def expt x (/ 1 x)))
3555
3556;;; Fold (expt x n) into multiplications for small integral values of
3557;;; N; convert (expt x 1/2) to sqrt.
3558(deftransform expt ((x y) (t (constant-arg real)) *)
3559  "recode as multiplication or sqrt"
3560  (let ((val (lvar-value y)))
3561    ;; If Y would cause the result to be promoted to the same type as
3562    ;; Y, we give up. If not, then the result will be the same type
3563    ;; as X, so we can replace the exponentiation with simple
3564    ;; multiplication and division for small integral powers.
3565    (unless (not-more-contagious y x)
3566      (give-up-ir1-transform))
3567    (cond ((zerop val)
3568           (let ((x-type (lvar-type x)))
3569             (cond ((csubtypep x-type (specifier-type '(or rational
3570                                                        (complex rational))))
3571                    '1)
3572                   ((csubtypep x-type (specifier-type 'real))
3573                    `(if (rationalp x)
3574                         1
3575                         (float 1 x)))
3576                   ((csubtypep x-type (specifier-type 'complex))
3577                    ;; both parts are float
3578                    `(1+ (* x ,val)))
3579                   (t (give-up-ir1-transform)))))
3580          ((= val 2) '(* x x))
3581          ((= val -2) '(/ (* x x)))
3582          ((= val 3) '(* x x x))
3583          ((= val -3) '(/ (* x x x)))
3584          ((= val 1/2) '(sqrt x))
3585          ((= val -1/2) '(/ (sqrt x)))
3586          (t (give-up-ir1-transform)))))
3587
3588(deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *)
3589  "recode as an ODDP check"
3590  (let ((val (lvar-value x)))
3591    (if (eql -1 val)
3592        '(- 1 (* 2 (logand 1 y)))
3593        `(if (oddp y)
3594             ,val
3595             ,(abs val)))))
3596
3597;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
3598;;; transformations?
3599;;; Perhaps we should have to prove that the denominator is nonzero before
3600;;; doing them?  -- WHN 19990917
3601(macrolet ((def (name)
3602             `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
3603                                   *)
3604                "fold zero arg"
3605                0)))
3606  (def ash)
3607  (def /))
3608
3609(macrolet ((def (name)
3610             `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
3611                                   *)
3612                "fold zero arg"
3613                '(values 0 0))))
3614  (def truncate)
3615  (def round)
3616  (def floor)
3617  (def ceiling))
3618
3619(macrolet ((def (name &optional float)
3620             (let ((x (if float '(float x) 'x)))
3621               `(deftransform ,name ((x y) (integer (constant-arg (member 1 -1)))
3622                                     *)
3623                  "fold division by 1"
3624                  `(values ,(if (minusp (lvar-value y))
3625                                '(%negate ,x)
3626                                ',x)  0)))))
3627  (def truncate)
3628  (def round)
3629  (def floor)
3630  (def ceiling)
3631  (def ftruncate t)
3632  (def fround t)
3633  (def ffloor t)
3634  (def fceiling t))
3635
3636
3637;;;; character operations
3638
3639(deftransform two-arg-char-equal ((a b) (base-char base-char) *
3640                                  :policy (> speed space))
3641  "open code"
3642  '(let* ((ac (char-code a))
3643          (bc (char-code b))
3644          (sum (logxor ac bc)))
3645     (or (zerop sum)
3646         (when (eql sum #x20)
3647           (let ((sum (+ ac bc)))
3648             (or (and (> sum 161) (< sum 213))
3649                 (and (> sum 415) (< sum 461))
3650                 (and (> sum 463) (< sum 477))))))))
3651
3652(deftransform two-arg-char-equal ((a b) (* (constant-arg character)) *
3653                                  :node node)
3654  (let ((char (lvar-value b)))
3655    (if (both-case-p char)
3656        (let ((reverse (if (upper-case-p char)
3657                           (char-downcase char)
3658                           (char-upcase char))))
3659          (if (policy node (> speed space))
3660              `(or (char= a ,char)
3661                   (char= a ,reverse))
3662              `(char-equal-constant a ,char ,reverse)))
3663        '(char= a b))))
3664
3665(deftransform char-upcase ((x) (base-char))
3666  "open code"
3667  '(let ((n-code (char-code x)))
3668     (if (or (and (> n-code #o140)      ; Octal 141 is #\a.
3669                  (< n-code #o173))     ; Octal 172 is #\z.
3670             (and (> n-code #o337)
3671                  (< n-code #o367))
3672             (and (> n-code #o367)
3673                  (< n-code #o377)))
3674         (code-char (logxor #x20 n-code))
3675         x)))
3676
3677(deftransform char-downcase ((x) (base-char))
3678  "open code"
3679  '(let ((n-code (char-code x)))
3680     (if (or (and (> n-code 64)         ; 65 is #\A.
3681                  (< n-code 91))        ; 90 is #\Z.
3682             (and (> n-code 191)
3683                  (< n-code 215))
3684             (and (> n-code 215)
3685                  (< n-code 223)))
3686         (code-char (logxor #x20 n-code))
3687         x)))
3688
3689;;;; equality predicate transforms
3690
3691;;; Return true if X and Y are lvars whose only use is a
3692;;; reference to the same leaf, and the value of the leaf cannot
3693;;; change.
3694(defun same-leaf-ref-p (x y)
3695  (declare (type lvar x y))
3696  (let ((x-use (principal-lvar-use x))
3697        (y-use (principal-lvar-use y)))
3698    (and (ref-p x-use)
3699         (ref-p y-use)
3700         (eq (ref-leaf x-use) (ref-leaf y-use))
3701         (constant-reference-p x-use))))
3702
3703;;; If X and Y are the same leaf, then the result is true. Otherwise,
3704;;; if there is no intersection between the types of the arguments,
3705;;; then the result is definitely false.
3706(deftransforms (eq char=) ((x y) * *)
3707  "Simple equality transform"
3708  (cond
3709    ((same-leaf-ref-p x y) t)
3710    ((not (types-equal-or-intersect (lvar-type x) (lvar-type y)))
3711     nil)
3712    (t (give-up-ir1-transform))))
3713
3714;;; Can't use the above thing, since TYPES-EQUAL-OR-INTERSECT is case sensitive.
3715(deftransform two-arg-char-equal ((x y) * *)
3716  (cond
3717    ((same-leaf-ref-p x y) t)
3718    (t (give-up-ir1-transform))))
3719
3720;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
3721;;; try to convert to a type-specific predicate or EQ:
3722;;; -- If both args are characters, convert to CHAR=. This is better than
3723;;;    just converting to EQ, since CHAR= may have special compilation
3724;;;    strategies for non-standard representations, etc.
3725;;; -- If either arg is definitely a fixnum, we check to see if X is
3726;;;    constant and if so, put X second. Doing this results in better
3727;;;    code from the backend, since the backend assumes that any constant
3728;;;    argument comes second.
3729;;; -- If either arg is definitely not a number or a fixnum, then we
3730;;;    can compare with EQ.
3731;;; -- Otherwise, we try to put the arg we know more about second. If X
3732;;;    is constant then we put it second. If X is a subtype of Y, we put
3733;;;    it second. These rules make it easier for the back end to match
3734;;;    these interesting cases.
3735(deftransform eql ((x y) * * :node node)
3736  "convert to simpler equality predicate"
3737  (let ((x-type (lvar-type x))
3738        (y-type (lvar-type y))
3739        #!+integer-eql-vop (int-type (specifier-type 'integer))
3740        (char-type (specifier-type 'character)))
3741    (cond
3742      ((same-leaf-ref-p x y) t)
3743      ((not (types-equal-or-intersect x-type y-type))
3744       nil)
3745      ((and (csubtypep x-type char-type)
3746            (csubtypep y-type char-type))
3747       '(char= x y))
3748      ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
3749       '(eq y x))
3750      #!+integer-eql-vop
3751      ((or (csubtypep x-type int-type) (csubtypep y-type int-type))
3752       '(%eql/integer x y))
3753      (t
3754       (give-up-ir1-transform)))))
3755
3756(defun array-type-dimensions-mismatch (x-type y-type)
3757  (let ((array-type (specifier-type 'array))
3758        (simple-array-type (specifier-type 'simple-array)))
3759    (and (csubtypep x-type array-type)
3760         (csubtypep y-type array-type)
3761         (let ((x-dims (ctype-array-dimensions x-type))
3762               (y-dims (ctype-array-dimensions y-type)))
3763           (and (consp x-dims)
3764                (consp y-dims)
3765                (or (/= (length x-dims)
3766                        (length y-dims))
3767                    ;; Can compare dimensions only for simple
3768                    ;; arrays due to fill-pointer and
3769                    ;; adjust-array.
3770                    (and (csubtypep x-type simple-array-type)
3771                         (csubtypep y-type simple-array-type)
3772                         (loop for x-dim in x-dims
3773                               for y-dim in y-dims
3774                               thereis (and (integerp x-dim)
3775                                            (integerp y-dim)
3776                                            (not (= x-dim y-dim)))))))))))
3777
3778;;; similarly to the EQL transform above, we attempt to constant-fold
3779;;; or convert to a simpler predicate: mostly we have to be careful
3780;;; with strings and bit-vectors.
3781(deftransform equal ((x y) * *)
3782  "convert to simpler equality predicate"
3783  (let ((x-type (lvar-type x))
3784        (y-type (lvar-type y))
3785        (combination-type (specifier-type '(or bit-vector string
3786                                            cons pathname))))
3787    (flet ((both-csubtypep (type)
3788             (let ((ctype (specifier-type type)))
3789               (and (csubtypep x-type ctype)
3790                    (csubtypep y-type ctype))))
3791           (some-csubtypep (type)
3792             (let ((ctype (specifier-type type)))
3793               (or (csubtypep x-type ctype)
3794                   (csubtypep y-type ctype))))
3795           (some-csubtypep2 (type1 type2)
3796             (let ((ctype1 (specifier-type type1))
3797                   (ctype2 (specifier-type type2)))
3798               (or (and (csubtypep x-type ctype1)
3799                        (csubtypep y-type ctype2))
3800                   (and (csubtypep y-type ctype1)
3801                        (csubtypep x-type ctype2)))))
3802           (mismatching-types-p (type)
3803             (let* ((ctype (specifier-type type))
3804                    (x-equal (types-equal-or-intersect x-type ctype))
3805                    (y-equal (types-equal-or-intersect y-type ctype)))
3806               (or (and x-equal (not y-equal))
3807                   (and (not x-equal) y-equal))))
3808           (non-equal-array-p (type)
3809             (and (csubtypep type (specifier-type 'array))
3810                  (let ((equal-types (specifier-type '(or bit character)))
3811                        (element-types (ctype-array-specialized-element-types type)))
3812                    (and (neq element-types *wild-type*)
3813                         (notany (lambda (x)
3814                                   (csubtypep x equal-types))
3815                                 element-types))))))
3816      (cond
3817        ((same-leaf-ref-p x y) t)
3818        ((array-type-dimensions-mismatch x-type y-type)
3819         nil)
3820        ((and (constant-lvar-p x)
3821              (equal (lvar-value x) ""))
3822         `(and (stringp y)
3823               (zerop (length y))))
3824        ((and (constant-lvar-p y)
3825              (equal (lvar-value y) ""))
3826         `(and (stringp x)
3827               (zerop (length x))))
3828        ((both-csubtypep 'string)
3829         '(string= x y))
3830        ((both-csubtypep 'bit-vector)
3831         '(bit-vector-= x y))
3832        ((both-csubtypep 'pathname)
3833         '(pathname= x y))
3834        ((or (non-equal-array-p x-type)
3835             (non-equal-array-p y-type))
3836         '(eq x y))
3837        ((types-equal-or-intersect x-type y-type)
3838         (cond ((some-csubtypep 'number)
3839                '(eql x y))
3840               ((some-csubtypep '(and array (not vector)))
3841                '(eq x y))
3842               ((both-csubtypep 'simple-array)
3843                ;; Can only work on simple arrays due to fill-pointer
3844                (let ((x-dim (ctype-array-dimensions x-type))
3845                      (y-dim (ctype-array-dimensions x-type)))
3846                  (if (and (consp x-dim)
3847                           (consp y-dim)
3848                           (integerp (car x-dim))
3849                           (integerp (car y-dim))
3850                           (not (equal x-dim y-dim)))
3851                      nil
3852                      (give-up-ir1-transform))))
3853               ((or (types-equal-or-intersect x-type combination-type)
3854                    (types-equal-or-intersect y-type combination-type))
3855                (give-up-ir1-transform))
3856               (t
3857                '(eql x y))))
3858        ((or (mismatching-types-p 'cons)
3859             (mismatching-types-p 'bit-vector)
3860             (mismatching-types-p 'string))
3861         nil)
3862        ((some-csubtypep2 '(and array (not vector))
3863                          'vector)
3864         nil)
3865        (t (give-up-ir1-transform))))))
3866
3867(deftransform equalp ((x y) * *)
3868  "convert to simpler equality predicate"
3869  (let ((x-type (lvar-type x))
3870        (y-type (lvar-type y))
3871        (combination-type (specifier-type '(or number array
3872                                            character
3873                                            cons pathname
3874                                            instance hash-table))))
3875    (flet ((both-csubtypep (type)
3876             (let ((ctype (specifier-type type)))
3877               (and (csubtypep x-type ctype)
3878                    (csubtypep y-type ctype))))
3879           (mismatching-types-p (type)
3880             (let* ((ctype (specifier-type type))
3881                    (x-equal (types-equal-or-intersect x-type ctype))
3882                    (y-equal (types-equal-or-intersect y-type ctype)))
3883               (or (and x-equal (not y-equal))
3884                   (and (not x-equal) y-equal)))))
3885      (cond
3886        ((same-leaf-ref-p x y) t)
3887        ((array-type-dimensions-mismatch x-type y-type)
3888         nil)
3889        ((and (constant-lvar-p x)
3890              (equal (lvar-value x) ""))
3891         `(and (stringp y)
3892               (zerop (length y))))
3893        ((and (constant-lvar-p y)
3894              (equal (lvar-value y) ""))
3895         `(and (stringp x)
3896               (zerop (length x))))
3897        ((both-csubtypep 'string)
3898         '(string-equal x y))
3899        ((both-csubtypep 'bit-vector)
3900         '(bit-vector-= x y))
3901        ((both-csubtypep 'pathname)
3902         '(pathname= x y))
3903        ((both-csubtypep 'character)
3904         '(char-equal x y))
3905        ((both-csubtypep 'number)
3906         '(= x y))
3907        ((both-csubtypep 'hash-table)
3908         '(hash-table-equalp x y))
3909        ((and (both-csubtypep 'array)
3910              (flet ((upgraded-et (type)
3911                       (multiple-value-bind (specialized supetype)
3912                           (array-type-upgraded-element-type type)
3913                         (or supetype specialized))))
3914                (let ((number-ctype (specifier-type 'number))
3915                      (x-et (upgraded-et x-type))
3916                      (y-et (upgraded-et y-type)))
3917                  (and (neq x-et *wild-type*)
3918                       (neq y-et *wild-type*)
3919                       (cond ((types-equal-or-intersect x-et y-et)
3920                              nil)
3921                             ((csubtypep x-et number-ctype)
3922                              (not (types-equal-or-intersect y-et number-ctype)))
3923                             ((types-equal-or-intersect y-et number-ctype)
3924                              (not (types-equal-or-intersect x-et number-ctype))))))))
3925         nil)
3926        ((types-equal-or-intersect x-type y-type)
3927         (if (or (types-equal-or-intersect x-type combination-type)
3928                 (types-equal-or-intersect y-type combination-type))
3929             (give-up-ir1-transform)
3930             '(eq x y)))
3931        ((or (mismatching-types-p 'cons)
3932             (mismatching-types-p 'array)
3933             (mismatching-types-p 'number))
3934         nil)
3935        (t (give-up-ir1-transform))))))
3936
3937;;; Convert to EQL if both args are rational and complexp is specified
3938;;; and the same for both.
3939(deftransform = ((x y) (number number) *)
3940  "open code"
3941  (let ((x-type (lvar-type x))
3942        (y-type (lvar-type y)))
3943    (cond ((or (and (csubtypep x-type (specifier-type 'float))
3944                    (csubtypep y-type (specifier-type 'float)))
3945               (and (csubtypep x-type (specifier-type '(complex float)))
3946                    (csubtypep y-type (specifier-type '(complex float))))
3947               #!+complex-float-vops
3948               (and (csubtypep x-type (specifier-type '(or single-float (complex single-float))))
3949                    (csubtypep y-type (specifier-type '(or single-float (complex single-float)))))
3950               #!+complex-float-vops
3951               (and (csubtypep x-type (specifier-type '(or double-float (complex double-float))))
3952                    (csubtypep y-type (specifier-type '(or double-float (complex double-float))))))
3953           ;; They are both floats. Leave as = so that -0.0 is
3954           ;; handled correctly.
3955           (give-up-ir1-transform))
3956          ((or (and (csubtypep x-type (specifier-type 'rational))
3957                    (csubtypep y-type (specifier-type 'rational)))
3958               (and (csubtypep x-type
3959                               (specifier-type '(complex rational)))
3960                    (csubtypep y-type
3961                               (specifier-type '(complex rational)))))
3962           ;; They are both rationals and complexp is the same.
3963           ;; Convert to EQL.
3964           '(eql x y))
3965          (t
3966           (give-up-ir1-transform
3967            "The operands might not be the same type.")))))
3968
3969(defun maybe-float-lvar-p (lvar)
3970  (neq *empty-type* (type-intersection (specifier-type 'float)
3971                                       (lvar-type lvar))))
3972
3973(flet ((maybe-invert (node op inverted x y)
3974         ;; Don't invert if either argument can be a float (NaNs)
3975         (cond
3976           ((or (maybe-float-lvar-p x) (maybe-float-lvar-p y))
3977            (delay-ir1-transform node :constraint)
3978            `(or (,op x y) (= x y)))
3979           (t
3980            `(if (,inverted x y) nil t)))))
3981  (deftransform >= ((x y) (number number) * :node node)
3982    "invert or open code"
3983    (maybe-invert node '> '< x y))
3984  (deftransform <= ((x y) (number number) * :node node)
3985    "invert or open code"
3986    (maybe-invert node '< '> x y)))
3987
3988;;; See whether we can statically determine (< X Y) using type
3989;;; information. If X's high bound is < Y's low, then X < Y.
3990;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
3991;;; NIL). If not, at least make sure any constant arg is second.
3992(macrolet ((def (name inverse reflexive-p surely-true surely-false)
3993             `(deftransform ,name ((x y))
3994                "optimize using intervals"
3995                (if (and (same-leaf-ref-p x y)
3996                         ;; For non-reflexive functions we don't need
3997                         ;; to worry about NaNs: (non-ref-op NaN NaN) => false,
3998                         ;; but with reflexive ones we don't know...
3999                         ,@(when reflexive-p
4000                                 '((and (not (maybe-float-lvar-p x))
4001                                        (not (maybe-float-lvar-p y))))))
4002                    ,reflexive-p
4003                    (let ((ix (or (type-approximate-interval (lvar-type x))
4004                                  (give-up-ir1-transform)))
4005                          (iy (or (type-approximate-interval (lvar-type y))
4006                                  (give-up-ir1-transform))))
4007                      (cond (,surely-true
4008                             t)
4009                            (,surely-false
4010                             nil)
4011                            ((and (constant-lvar-p x)
4012                                  (not (constant-lvar-p y)))
4013                             `(,',inverse y x))
4014                            (t
4015                             (give-up-ir1-transform))))))))
4016  (def = = t (interval-= ix iy) (interval-/= ix iy))
4017  (def /= /= nil (interval-/= ix iy) (interval-= ix iy))
4018  (def < > nil (interval-< ix iy) (interval->= ix iy))
4019  (def > < nil (interval-< iy ix) (interval->= iy ix))
4020  (def <= >= t (interval->= iy ix) (interval-< iy ix))
4021  (def >= <= t (interval->= ix iy) (interval-< ix iy)))
4022
4023(defun ir1-transform-char< (x y first second inverse)
4024  (cond
4025    ((same-leaf-ref-p x y) nil)
4026    ;; If we had interval representation of character types, as we
4027    ;; might eventually have to to support 2^21 characters, then here
4028    ;; we could do some compile-time computation as in transforms for
4029    ;; < above. -- CSR, 2003-07-01
4030    ((and (constant-lvar-p first)
4031          (not (constant-lvar-p second)))
4032     `(,inverse y x))
4033    (t (give-up-ir1-transform))))
4034
4035(deftransform char< ((x y) (character character) *)
4036  (ir1-transform-char< x y x y 'char>))
4037
4038(deftransform char> ((x y) (character character) *)
4039  (ir1-transform-char< y x x y 'char<))
4040
4041;;;; converting N-arg comparisons
4042;;;;
4043;;;; We convert calls to N-arg comparison functions such as < into
4044;;;; two-arg calls. This transformation is enabled for all such
4045;;;; comparisons in this file. If any of these predicates are not
4046;;;; open-coded, then the transformation should be removed at some
4047;;;; point to avoid pessimization.
4048
4049;;; This function is used for source transformation of N-arg
4050;;; comparison functions other than inequality. We deal both with
4051;;; converting to two-arg calls and inverting the sense of the test,
4052;;; if necessary. If the call has two args, then we pass or return a
4053;;; negated test as appropriate. If it is a degenerate one-arg call,
4054;;; then we transform to code that returns true. Otherwise, we bind
4055;;; all the arguments and expand into a bunch of IFs.
4056(defun multi-compare (predicate args not-p type &optional force-two-arg-p)
4057  (let ((nargs (length args)))
4058    (cond ((< nargs 1) (values nil t))
4059          ((= nargs 1) `(progn (the ,type ,@args) t))
4060          ((= nargs 2)
4061           (if not-p
4062               `(if (,predicate ,(first args) ,(second args)) nil t)
4063               (if force-two-arg-p
4064                   `(,predicate ,(first args) ,(second args))
4065                   (values nil t))))
4066          (t
4067           (do* ((i (1- nargs) (1- i))
4068                 (last nil current)
4069                 (current (gensym) (gensym))
4070                 (vars (list current) (cons current vars))
4071                 (result t (if not-p
4072                               `(if (,predicate ,current ,last)
4073                                    nil ,result)
4074                               `(if (,predicate ,current ,last)
4075                                    ,result nil))))
4076               ((zerop i)
4077                `((lambda ,vars (declare (type ,type ,@vars)) ,result)
4078                  ,@args)))))))
4079
4080(define-source-transform = (&rest args) (multi-compare '= args nil 'number))
4081(define-source-transform < (&rest args) (multi-compare '< args nil 'real))
4082(define-source-transform > (&rest args) (multi-compare '> args nil 'real))
4083;;; We cannot do the inversion for >= and <= here, since both
4084;;;   (< NaN X) and (> NaN X)
4085;;; are false, and we don't have type-information available yet. The
4086;;; deftransforms for two-argument versions of >= and <= takes care of
4087;;; the inversion to > and < when possible.
4088(define-source-transform <= (&rest args) (multi-compare '<= args nil 'real))
4089(define-source-transform >= (&rest args) (multi-compare '>= args nil 'real))
4090
4091(define-source-transform char= (&rest args) (multi-compare 'char= args nil
4092                                                           'character))
4093(define-source-transform char< (&rest args) (multi-compare 'char< args nil
4094                                                           'character))
4095(define-source-transform char> (&rest args) (multi-compare 'char> args nil
4096                                                           'character))
4097(define-source-transform char<= (&rest args) (multi-compare 'char> args t
4098                                                            'character))
4099(define-source-transform char>= (&rest args) (multi-compare 'char< args t
4100                                                            'character))
4101
4102(define-source-transform char-equal (&rest args)
4103  (multi-compare 'two-arg-char-equal args nil 'character t))
4104(define-source-transform char-lessp (&rest args)
4105  (multi-compare 'two-arg-char-lessp args nil 'character t))
4106(define-source-transform char-greaterp (&rest args)
4107  (multi-compare 'two-arg-char-greaterp args nil 'character t))
4108(define-source-transform char-not-greaterp (&rest args)
4109  (multi-compare 'two-arg-char-greaterp args t 'character t))
4110(define-source-transform char-not-lessp (&rest args)
4111  (multi-compare 'two-arg-char-lessp args t 'character t))
4112
4113;;; This function does source transformation of N-arg inequality
4114;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
4115;;; arg cases. If there are more than two args, then we expand into
4116;;; the appropriate n^2 comparisons only when speed is important.
4117(declaim (ftype (function (symbol list t) *) multi-not-equal))
4118(defun multi-not-equal (predicate args type)
4119  (let ((nargs (length args)))
4120    (cond ((< nargs 1) (values nil t))
4121          ((= nargs 1) `(progn (the ,type ,@args) t))
4122          ((= nargs 2)
4123           `(if (,predicate ,(first args) ,(second args)) nil t))
4124          ((not (policy *lexenv*
4125                        (and (>= speed space)
4126                             (>= speed compilation-speed))))
4127           (values nil t))
4128          (t
4129           (let ((vars (make-gensym-list nargs)))
4130             (do ((var vars next)
4131                  (next (cdr vars) (cdr next))
4132                  (result t))
4133                 ((null next)
4134                  `((lambda ,vars (declare (type ,type ,@vars)) ,result)
4135                    ,@args))
4136               (let ((v1 (first var)))
4137                 (dolist (v2 next)
4138                   (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
4139
4140(define-source-transform /= (&rest args)
4141  (multi-not-equal '= args 'number))
4142(define-source-transform char/= (&rest args)
4143  (multi-not-equal 'char= args 'character))
4144(define-source-transform char-not-equal (&rest args)
4145  (multi-not-equal 'char-equal args 'character))
4146
4147;;; Expand MAX and MIN into the obvious comparisons.
4148(define-source-transform max (arg0 &rest rest)
4149  (once-only ((arg0 arg0))
4150    (if (null rest)
4151        `(values (the real ,arg0))
4152        `(let ((maxrest (max ,@rest)))
4153          (if (>= ,arg0 maxrest) ,arg0 maxrest)))))
4154(define-source-transform min (arg0 &rest rest)
4155  (once-only ((arg0 arg0))
4156    (if (null rest)
4157        `(values (the real ,arg0))
4158        `(let ((minrest (min ,@rest)))
4159          (if (<= ,arg0 minrest) ,arg0 minrest)))))
4160
4161;;; Simplify some cross-type comparisons
4162(macrolet ((def (comparator round)
4163             `(progn
4164                (deftransform ,comparator
4165                    ((x y) (rational (constant-arg float)))
4166                  "open-code RATIONAL to FLOAT comparison"
4167                  (let ((y (lvar-value y)))
4168                    #-sb-xc-host
4169                    (when (or (float-nan-p y)
4170                              (float-infinity-p y))
4171                      (give-up-ir1-transform))
4172                    (setf y (rational y))
4173                    `(,',comparator
4174                      x ,(if (csubtypep (lvar-type x)
4175                                        (specifier-type 'integer))
4176                             (,round y)
4177                             y))))
4178                (deftransform ,comparator
4179                    ((x y) (integer (constant-arg ratio)))
4180                  "open-code INTEGER to RATIO comparison"
4181                  `(,',comparator x ,(,round (lvar-value y)))))))
4182  (def < ceiling)
4183  (def > floor))
4184
4185(deftransform = ((x y) (rational (constant-arg float)))
4186  "open-code RATIONAL to FLOAT comparison"
4187  (let ((y (lvar-value y)))
4188    #-sb-xc-host
4189    (when (or (float-nan-p y)
4190              (float-infinity-p y))
4191      (give-up-ir1-transform))
4192    (setf y (rational y))
4193    (if (and (csubtypep (lvar-type x)
4194                        (specifier-type 'integer))
4195             (ratiop y))
4196        nil
4197        `(= x ,y))))
4198
4199(deftransform = ((x y) (integer (constant-arg ratio)))
4200  "constant-fold INTEGER to RATIO comparison"
4201  nil)
4202
4203;;;; converting N-arg arithmetic functions
4204;;;;
4205;;;; N-arg arithmetic and logic functions are associated into two-arg
4206;;;; versions, and degenerate cases are flushed.
4207
4208;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
4209(declaim (ftype (sfunction (symbol t list) list) associate-args))
4210(defun associate-args (fun first-arg more-args)
4211  (aver more-args)
4212  (let ((next (rest more-args))
4213        (arg (first more-args)))
4214    (if (null next)
4215        `(,fun ,first-arg ,arg)
4216        (associate-args fun `(,fun ,first-arg ,arg) next))))
4217
4218;;; Reduce constants in ARGS list.
4219(declaim (ftype (sfunction (symbol list symbol) list) reduce-constants))
4220(defun reduce-constants (fun args one-arg-result-type)
4221  (let ((one-arg-constant-p (ecase one-arg-result-type
4222                              (number #'numberp)
4223                              (integer #'integerp)))
4224        (reduced-value)
4225        (reduced-p nil))
4226    (collect ((not-constants))
4227      (dolist (arg args)
4228        (let ((value (if (constantp arg)
4229                         (constant-form-value arg)
4230                         arg)))
4231          (cond ((not (funcall one-arg-constant-p value))
4232                 (not-constants arg))
4233                (reduced-value
4234                 (setf reduced-value (funcall fun reduced-value value)
4235                       reduced-p t))
4236                (t
4237                 (setf reduced-value value)))))
4238      ;; It is tempting to drop constants reduced to identity here,
4239      ;; but if X is SNaN in (* X 1), we cannot drop the 1.
4240      (if (not-constants)
4241          (if reduced-p
4242              `(,reduced-value ,@(not-constants))
4243              args)
4244          `(,reduced-value)))))
4245
4246;;; Do source transformations for transitive functions such as +.
4247;;; One-arg cases are replaced with the arg and zero arg cases with
4248;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE)
4249;;; that the argument in one-argument calls is.
4250(declaim (ftype (function (symbol list t &optional symbol list)
4251                          * ; KLUDGE: avoid "assertion too complex to check"
4252                          #|(values t &optional (member nil t))|#)
4253                source-transform-transitive))
4254(defun source-transform-transitive (fun args identity
4255                                    &optional (one-arg-result-type 'number)
4256                                              (one-arg-prefixes '(values)))
4257  (case (length args)
4258    (0 identity)
4259    (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
4260    (2 (values nil t))
4261    (t
4262     (let* ((reduced-args (reduce-constants fun args one-arg-result-type))
4263            (first (first reduced-args))
4264            (rest (rest reduced-args)))
4265       (if rest
4266           (associate-args fun first rest)
4267           first)))))
4268
4269(define-source-transform + (&rest args)
4270  (source-transform-transitive '+ args 0))
4271(define-source-transform * (&rest args)
4272  (source-transform-transitive '* args 1))
4273(define-source-transform logior (&rest args)
4274  (source-transform-transitive 'logior args 0 'integer))
4275(define-source-transform logxor (&rest args)
4276  (source-transform-transitive 'logxor args 0 'integer))
4277(define-source-transform logand (&rest args)
4278  (source-transform-transitive 'logand args -1 'integer))
4279(define-source-transform logeqv (&rest args)
4280  (source-transform-transitive 'logeqv args -1 'integer))
4281(define-source-transform gcd (&rest args)
4282  (source-transform-transitive 'gcd args 0 'integer '(abs)))
4283(define-source-transform lcm (&rest args)
4284  (source-transform-transitive 'lcm args 1 'integer '(abs)))
4285
4286;;; Do source transformations for intransitive n-arg functions such as
4287;;; /. With one arg, we form the inverse. With two args we pass.
4288;;; Otherwise we associate into two-arg calls.
4289(declaim (ftype (function (symbol symbol list list &optional symbol)
4290                          * ; KLUDGE: avoid "assertion too complex to check"
4291                          #|(values list &optional (member nil t))|#)
4292                source-transform-intransitive))
4293(defun source-transform-intransitive (fun fun* args one-arg-prefixes
4294                                      &optional (one-arg-result-type 'number))
4295  (case (length args)
4296    ((0 2) (values nil t))
4297    (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
4298    (t
4299     (let ((reduced-args
4300             (reduce-constants fun* (rest args) one-arg-result-type)))
4301       (associate-args fun (first args) reduced-args)))))
4302
4303(define-source-transform - (&rest args)
4304  (source-transform-intransitive '- '+ args '(%negate)))
4305(define-source-transform / (&rest args)
4306  (source-transform-intransitive '/ '* args '(/ 1)))
4307
4308;;;; transforming APPLY
4309
4310;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
4311;;; only needs to understand one kind of variable-argument call. It is
4312;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
4313(define-source-transform apply (fun arg &rest more-args)
4314  (let ((args (cons arg more-args)))
4315    `(multiple-value-call ,fun
4316       ,@(mapcar (lambda (x) `(values ,x)) (butlast args))
4317       (values-list ,(car (last args))))))
4318
4319;;;; transforming references to &REST argument
4320
4321;;; We add magical &MORE arguments to all functions with &REST. If ARG names
4322;;; the &REST argument, this returns the lambda-vars for the context and
4323;;; count.
4324(defun possible-rest-arg-context (arg)
4325  (when (symbolp arg)
4326    (let* ((var (lexenv-find arg vars))
4327           (info (when (lambda-var-p var)
4328                   (lambda-var-arg-info var))))
4329      (when (and info
4330                 (eq :rest (arg-info-kind info))
4331                 (consp (arg-info-default info)))
4332        (values-list (arg-info-default info))))))
4333
4334(defun mark-more-context-used (rest-var)
4335  (let ((info (lambda-var-arg-info rest-var)))
4336    (aver (eq :rest (arg-info-kind info)))
4337    (destructuring-bind (context count &optional used) (arg-info-default info)
4338      (unless used
4339        (setf (arg-info-default info) (list context count t))))))
4340
4341(defun mark-more-context-invalid (rest-var)
4342  (let ((info (lambda-var-arg-info rest-var)))
4343    (aver (eq :rest (arg-info-kind info)))
4344    (setf (arg-info-default info) t)))
4345
4346;;; This determines if the REF to a &REST variable is headed towards
4347;;; parts unknown, or if we can really use the context.
4348(defun rest-var-more-context-ok (lvar)
4349  (let* ((use (lvar-use lvar))
4350         (var (when (ref-p use) (ref-leaf use)))
4351         (home (when (lambda-var-p var) (lambda-var-home var)))
4352         (info (when (lambda-var-p var) (lambda-var-arg-info var)))
4353         (restp (when info (eq :rest (arg-info-kind info)))))
4354    (flet ((ref-good-for-more-context-p (ref)
4355             (when (not (node-lvar ref)) ; ref that goes nowhere is ok
4356               (return-from ref-good-for-more-context-p t))
4357             (let ((dest (principal-lvar-end (node-lvar ref))))
4358               (and (combination-p dest)
4359                    ;; If the destination is to anything but these, we're going to
4360                    ;; actually need the rest list -- and since other operations
4361                    ;; might modify the list destructively, the using the context
4362                    ;; isn't good anywhere else either.
4363                    (lvar-fun-is (combination-fun dest)
4364                                 '(%rest-values %rest-ref %rest-length
4365                                   %rest-null %rest-true))
4366                    ;; If the home lambda is different and isn't DX, it might
4367                    ;; escape -- in which case using the more context isn't safe.
4368                    (let ((clambda (node-home-lambda dest)))
4369                      (or (eq home clambda)
4370                          (leaf-dynamic-extent clambda)))))))
4371      (let ((ok (and restp
4372                     (consp (arg-info-default info))
4373                     (not (lambda-var-specvar var))
4374                     (not (lambda-var-sets var))
4375                     (every #'ref-good-for-more-context-p (lambda-var-refs var)))))
4376        (if ok
4377            (mark-more-context-used var)
4378            (when restp
4379              (mark-more-context-invalid var)))
4380        ok))))
4381
4382;;; VALUES-LIST -> %REST-VALUES
4383(define-source-transform values-list (list)
4384  (multiple-value-bind (context count) (possible-rest-arg-context list)
4385    (if context
4386        `(%rest-values ,list ,context ,count)
4387        (values nil t))))
4388
4389;;; NTH -> %REST-REF
4390(define-source-transform nth (n list)
4391  (multiple-value-bind (context count) (possible-rest-arg-context list)
4392    (if context
4393        `(%rest-ref ,n ,list ,context ,count)
4394        `(car (nthcdr ,n ,list)))))
4395(define-source-transform fast-&rest-nth (n list)
4396  (multiple-value-bind (context count) (possible-rest-arg-context list)
4397    (if context
4398        `(%rest-ref ,n ,list ,context ,count t)
4399        (bug "no &REST context for FAST-REST-NTH"))))
4400
4401(define-source-transform elt (seq n)
4402  (if (policy *lexenv* (= safety 3))
4403      (values nil t)
4404      (multiple-value-bind (context count) (possible-rest-arg-context seq)
4405        (if context
4406            `(%rest-ref ,n ,seq ,context ,count)
4407            (values nil t)))))
4408
4409;;; CAxR -> %REST-REF
4410(defun source-transform-car (list nth)
4411  (multiple-value-bind (context count) (possible-rest-arg-context list)
4412    (if context
4413        `(%rest-ref ,nth ,list ,context ,count)
4414        (values nil t))))
4415
4416(define-source-transform car (list)
4417  (source-transform-car list 0))
4418
4419(define-source-transform cadr (list)
4420  (or (source-transform-car list 1)
4421      `(car (cdr ,list))))
4422
4423(define-source-transform caddr (list)
4424  (or (source-transform-car list 2)
4425      `(car (cdr (cdr ,list)))))
4426
4427(define-source-transform cadddr (list)
4428  (or (source-transform-car list 3)
4429      `(car (cdr (cdr (cdr ,list))))))
4430
4431;;; LENGTH -> %REST-LENGTH
4432(defun source-transform-length (list)
4433  (multiple-value-bind (context count) (possible-rest-arg-context list)
4434    (if context
4435        `(%rest-length ,list ,context ,count)
4436        (values nil t))))
4437(define-source-transform length (list) (source-transform-length list))
4438(define-source-transform list-length (list) (source-transform-length list))
4439
4440;;; ENDP, NULL and NOT -> %REST-NULL
4441;;;
4442;;; Outside &REST convert into an IF so that IF optimizations will eliminate
4443;;; redundant negations.
4444(defun source-transform-null (x op)
4445  (multiple-value-bind (context count) (possible-rest-arg-context x)
4446    (cond (context
4447           `(%rest-null ',op ,x ,context ,count))
4448          ((eq 'endp op)
4449           `(if (the list ,x) nil t))
4450          (t
4451           `(if ,x nil t)))))
4452(define-source-transform not (x) (source-transform-null x 'not))
4453(define-source-transform null (x) (source-transform-null x 'null))
4454(define-source-transform endp (x) (source-transform-null x 'endp))
4455
4456(deftransform %rest-values ((list context count))
4457  (if (rest-var-more-context-ok list)
4458      `(%more-arg-values context 0 count)
4459      `(values-list list)))
4460
4461(deftransform %rest-ref ((n list context count &optional length-checked-p))
4462  (cond ((rest-var-more-context-ok list)
4463         (if (and (constant-lvar-p length-checked-p)
4464                  (lvar-value length-checked-p))
4465             `(%more-arg context n)
4466             `(and (< (the index n) count) (%more-arg context n))))
4467        ((and (constant-lvar-p n) (zerop (lvar-value n)))
4468         `(car list))
4469        (t
4470         `(nth n list))))
4471
4472(deftransform %rest-length ((list context count))
4473  (if (rest-var-more-context-ok list)
4474      'count
4475      `(length list)))
4476
4477(deftransform %rest-null ((op list context count))
4478  (aver (constant-lvar-p op))
4479  (if (rest-var-more-context-ok list)
4480      `(eql 0 count)
4481      `(,(lvar-value op) list)))
4482
4483(deftransform %rest-true ((list context count))
4484  (if (rest-var-more-context-ok list)
4485      `(not (eql 0 count))
4486      `list))
4487
4488;;;; transforming FORMAT
4489;;;;
4490;;;; If the control string is a compile-time constant, then replace it
4491;;;; with a use of the FORMATTER macro so that the control string is
4492;;;; ``compiled.'' Furthermore, if the destination is either a stream
4493;;;; or T and the control string is a function (i.e. FORMATTER), then
4494;;;; convert the call to FORMAT to just a FUNCALL of that function.
4495
4496;;; for compile-time argument count checking.
4497;;;
4498;;; FIXME II: In some cases, type information could be correlated; for
4499;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
4500;;; of a corresponding argument is known and does not intersect the
4501;;; list type, a warning could be signalled.
4502(defun check-format-args (string args fun)
4503  (declare (type string string))
4504  (unless (typep string 'simple-string)
4505    (setq string (coerce string 'simple-string)))
4506  (multiple-value-bind (min max)
4507      (handler-case (sb!format:%compiler-walk-format-string string args)
4508        (sb!format:format-error (c)
4509          (compiler-warn "~A" c)))
4510    (when min
4511      (let ((nargs (length args)))
4512        (cond
4513          ((< nargs min)
4514           (warn 'format-too-few-args-warning
4515                 :format-control
4516                 "Too few arguments (~D) to ~S ~S: requires at least ~D."
4517                 :format-arguments (list nargs fun string min)))
4518          ((> nargs max)
4519           (warn 'format-too-many-args-warning
4520                 :format-control
4521                 "Too many arguments (~D) to ~S ~S: uses at most ~D."
4522                 :format-arguments (list nargs fun string max))))))))
4523
4524(defoptimizer (format optimizer) ((dest control &rest args) node)
4525  (declare (ignore dest))
4526  (when (constant-lvar-p control)
4527    (let ((x (lvar-value control)))
4528      (when (stringp x)
4529        (let ((*compiler-error-context* node))
4530         (check-format-args x args 'format))))))
4531
4532(defoptimizer (format derive-type) ((dest control &rest args))
4533  (declare (ignore control args))
4534  (when (and (constant-lvar-p dest)
4535             (null (lvar-value dest)))
4536    (specifier-type '(simple-array character (*)))))
4537
4538;;; We disable this transform in the cross-compiler to save memory in
4539;;; the target image; most of the uses of FORMAT in the compiler are for
4540;;; error messages, and those don't need to be particularly fast.
4541#+sb-xc
4542(deftransform format ((dest control &rest args) (t simple-string &rest t) *
4543                      :policy (>= speed space))
4544  (unless (constant-lvar-p control)
4545    (give-up-ir1-transform "The control string is not a constant."))
4546  (let* ((argc (length args))
4547         (arg-names (make-gensym-list argc))
4548         (control (lvar-value control))
4549         ;; Expanding the control string now avoids deferring to FORMATTER
4550         ;; so that we don't need an internal-only variant of it that
4551         ;; passes through extra args to %FORMATTER.
4552         ;; FIXME: instead of checking the condition report, define a
4553         ;; dedicated condition class
4554         (expr (handler-case ; in case %formatter wants to signal an error
4555                   (sb!format::%formatter control argc nil)
4556                 ;; otherwise, let the macro complain
4557                 (sb!format:format-error (c)
4558                   (if (string= (sb!format::format-error-complaint c)
4559                                "No package named ~S")
4560                       ;; "~/apackage:afun/" might become legal later.
4561                       ;; To put it in perspective, "~/f" (no closing slash)
4562                       ;; *will* be a runtime error, but this only *might* be
4563                       ;; a runtime error, so we can't signal a full warning.
4564                       ;; At absolute worst it should be a style-warning.
4565                       (give-up-ir1-transform "~~// directive mentions unknown package")
4566                      `(formatter ,control))))))
4567    `(lambda (dest control ,@arg-names)
4568       (declare (ignore control))
4569       (format dest ,expr ,@arg-names))))
4570
4571(deftransform format ((stream control &rest args) (stream function &rest t))
4572  (let ((arg-names (make-gensym-list (length args))))
4573    `(lambda (stream control ,@arg-names)
4574       (funcall control stream ,@arg-names)
4575       nil)))
4576
4577(deftransform format ((tee control &rest args) ((member t) function &rest t))
4578  (let ((arg-names (make-gensym-list (length args))))
4579    `(lambda (tee control ,@arg-names)
4580       (declare (ignore tee))
4581       (funcall control *standard-output* ,@arg-names)
4582       nil)))
4583
4584(deftransform format ((stream control &rest args) (null function &rest t))
4585  (let ((arg-names (make-gensym-list (length args))))
4586    `(lambda (stream control ,@arg-names)
4587       (declare (ignore stream))
4588       (with-simple-output-to-string (stream)
4589         (funcall control stream ,@arg-names)))))
4590
4591(defun concatenate-format-p (control args)
4592  (and
4593   (loop for directive in control
4594         always
4595         (or (stringp directive)
4596             (and (sb!format::format-directive-p directive)
4597                  (let ((char (sb!format::format-directive-character directive))
4598                        (params (sb!format::format-directive-params directive)))
4599                    (or
4600                     (and
4601                      (char-equal char #\a)
4602                      (null params)
4603                      (pop args))
4604                     (and
4605                      (or (eql char #\~)
4606                          (eql char #\%))
4607                      (null (sb!format::format-directive-colonp directive))
4608                      (null (sb!format::format-directive-atsignp directive))
4609                      (or (null params)
4610                          (typep params
4611                                 '(cons (cons (eql 1) unsigned-byte) null)))))))))
4612   (null args)))
4613
4614(deftransform format ((stream control &rest args) (null (constant-arg string) &rest string))
4615  (let ((tokenized
4616          (handler-case
4617              (sb!format::tokenize-control-string (lvar-value control))
4618            (sb!format:format-error ()
4619              (give-up-ir1-transform)))))
4620    (unless (concatenate-format-p tokenized args)
4621      (give-up-ir1-transform))
4622    (let ((arg-names (make-gensym-list (length args))))
4623      `(lambda (stream control ,@arg-names)
4624         (declare (ignore stream control)
4625                  (ignorable ,@arg-names))
4626         (concatenate
4627          'string
4628          ,@(let ((strings
4629                    (loop for directive in tokenized
4630                          for char = (and (not (stringp directive))
4631                                          (sb!format::format-directive-character directive))
4632                          when
4633                          (cond ((not char)
4634                                 directive)
4635                                ((char-equal char #\a)
4636                                 (let ((arg (pop args))
4637                                       (arg-name (pop arg-names)))
4638                                   (if
4639                                    (constant-lvar-p arg)
4640                                    (lvar-value arg)
4641                                    arg-name)))
4642                                (t
4643                                 (let ((n (or (cdar (sb!format::format-directive-params directive))
4644                                              1)))
4645                                   (and (plusp n)
4646                                        (make-string n
4647                                                     :initial-element
4648                                                     (if (eql char #\%)
4649                                                         #\Newline
4650                                                         char))))))
4651                          collect it)))
4652              ;; Join adjacent constant strings
4653              (loop with concat
4654                    for (string . rest) on strings
4655                    when (stringp string)
4656                    do (setf concat
4657                             (if concat
4658                                 (concatenate 'string concat string)
4659                                 string))
4660                    else
4661                    when concat collect (shiftf concat nil) end
4662                    and collect string
4663                    when (and concat (not rest))
4664                    collect concat)))))))
4665
4666(deftransform pathname ((pathspec) (pathname) *)
4667  'pathspec)
4668
4669(deftransform pathname ((pathspec) (string) *)
4670  '(values (parse-namestring pathspec)))
4671
4672(macrolet
4673    ((def (name)
4674         `(defoptimizer (,name optimizer) ((control &rest args) node)
4675            (when (constant-lvar-p control)
4676              (let ((x (lvar-value control)))
4677                (when (stringp x)
4678                  (let ((*compiler-error-context* node))
4679                    (check-format-args x args ',name))))))))
4680  (def error)
4681  (def warn)
4682  #+sb-xc-host ; Only we should be using these
4683  (progn
4684    (def style-warn)
4685    (def compiler-error)
4686    (def compiler-warn)
4687    (def compiler-style-warn)
4688    (def compiler-notify)
4689    (def maybe-compiler-notify)
4690    (def bug)))
4691
4692(defoptimizer (cerror optimizer) ((report control &rest args))
4693  (when (and (constant-lvar-p control)
4694             (constant-lvar-p report))
4695    (let ((x (lvar-value control))
4696          (y (lvar-value report)))
4697      (when (and (stringp x) (stringp y))
4698        (multiple-value-bind (min1 max1)
4699            (handler-case
4700                (sb!format:%compiler-walk-format-string x args)
4701              (sb!format:format-error (c)
4702                (compiler-warn "~A" c)))
4703          (when min1
4704            (multiple-value-bind (min2 max2)
4705                (handler-case
4706                    (sb!format:%compiler-walk-format-string y args)
4707                  (sb!format:format-error (c)
4708                    (compiler-warn "~A" c)))
4709              (when min2
4710                (let ((nargs (length args)))
4711                  (cond
4712                    ((< nargs (min min1 min2))
4713                     (warn 'format-too-few-args-warning
4714                           :format-control
4715                           "Too few arguments (~D) to ~S ~S ~S: ~
4716                            requires at least ~D."
4717                           :format-arguments
4718                           (list nargs 'cerror y x (min min1 min2))))
4719                    ((> nargs (max max1 max2))
4720                     (warn 'format-too-many-args-warning
4721                           :format-control
4722                           "Too many arguments (~D) to ~S ~S ~S: ~
4723                            uses at most ~D."
4724                           :format-arguments
4725                           (list nargs 'cerror y x (max max1 max2))))))))))))))
4726
4727(defun constant-cons-type (type)
4728  (multiple-value-bind (singleton value)
4729      (type-singleton-p type)
4730    (if singleton
4731        (values value t)
4732        (typecase type
4733          (cons-type
4734           (multiple-value-bind (car car-good)
4735               (constant-cons-type (cons-type-car-type type))
4736             (multiple-value-bind (cdr cdr-good)
4737                 (constant-cons-type (cons-type-cdr-type type))
4738               (and car-good cdr-good
4739                    (values (cons car cdr) t)))))))))
4740
4741(defoptimizer (coerce derive-type) ((value type) node)
4742  (multiple-value-bind (type constant)
4743      (if (constant-lvar-p type)
4744          (values (lvar-value type) t)
4745          (constant-cons-type (lvar-type type)))
4746    (when constant
4747      ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
4748      ;; but dealing with the niggle that complex canonicalization gets
4749      ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
4750      ;; type COMPLEX.
4751      (let ((result-typeoid (careful-specifier-type type)))
4752        (cond
4753          ((null result-typeoid) nil)
4754          ((csubtypep result-typeoid (specifier-type 'number))
4755           ;; the difficult case: we have to cope with ANSI 12.1.5.3
4756           ;; Rule of Canonical Representation for Complex Rationals,
4757           ;; which is a truly nasty delivery to field.
4758           (cond
4759             ((csubtypep result-typeoid (specifier-type 'real))
4760              ;; cleverness required here: it would be nice to deduce
4761              ;; that something of type (INTEGER 2 3) coerced to type
4762              ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0).
4763              ;; FLOAT gets its own clause because it's implemented as
4764              ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE
4765              ;; logic below.
4766              result-typeoid)
4767             ((and (numeric-type-p result-typeoid)
4768                   (eq (numeric-type-complexp result-typeoid) :real))
4769              ;; FIXME: is this clause (a) necessary or (b) useful?
4770              result-typeoid)
4771             ((or (csubtypep result-typeoid
4772                             (specifier-type '(complex single-float)))
4773                  (csubtypep result-typeoid
4774                             (specifier-type '(complex double-float)))
4775                  #!+long-float
4776                  (csubtypep result-typeoid
4777                             (specifier-type '(complex long-float))))
4778              ;; float complex types are never canonicalized.
4779              result-typeoid)
4780             (t
4781              ;; if it's not a REAL, or a COMPLEX FLOAToid, it's
4782              ;; probably just a COMPLEX or equivalent.  So, in that
4783              ;; case, we will return a complex or an object of the
4784              ;; provided type if it's rational:
4785              (type-union result-typeoid
4786                          (type-intersection (lvar-type value)
4787                                             (specifier-type 'rational))))))
4788          ;; At zero safety the deftransform for COERCE can elide dimension
4789          ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
4790          ;; need to simplify the type to drop the dimension information.
4791          ((and (policy node (zerop safety))
4792                (csubtypep result-typeoid (specifier-type '(array * (*))))
4793                (simplify-vector-type result-typeoid)))
4794          (t
4795           result-typeoid))))))
4796
4797(defoptimizer (compile derive-type) ((nameoid function))
4798  (declare (ignore function))
4799  (when (csubtypep (lvar-type nameoid)
4800                   (specifier-type 'null))
4801    (values-specifier-type '(values function boolean boolean))))
4802
4803;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
4804;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
4805;;; optimizer, above).
4806(defoptimizer (array-element-type derive-type) ((array))
4807  (let ((array-type (lvar-type array)))
4808    (labels ((consify (list)
4809              (if (endp list)
4810                  '(eql nil)
4811                  `(cons (eql ,(car list)) ,(consify (rest list)))))
4812            (get-element-type (a)
4813              (let ((element-type
4814                     (type-specifier (array-type-specialized-element-type a))))
4815                (cond ((eq element-type '*)
4816                       (specifier-type 'type-specifier))
4817                      ((symbolp element-type)
4818                       (make-eql-type element-type))
4819                      ((consp element-type)
4820                       (specifier-type (consify element-type)))
4821                      (t
4822                       (error "can't understand type ~S~%" element-type))))))
4823      (labels ((recurse (type)
4824                  (cond ((array-type-p type)
4825                         (get-element-type type))
4826                        ((union-type-p type)
4827                         (apply #'type-union
4828                                (mapcar #'recurse (union-type-types type))))
4829                        (t
4830                         *universal-type*))))
4831        (recurse array-type)))))
4832
4833(define-source-transform sb!impl::sort-vector (vector start end predicate key)
4834  ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
4835  ;; isn't really related to the CMU CL code, since instead of trying
4836  ;; to generalize the CMU CL code to allow START and END values, this
4837  ;; code has been written from scratch following Chapter 7 of
4838  ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
4839  `(macrolet ((%index (x) `(truly-the index ,x))
4840              (%parent (i) `(ash ,i -1))
4841              (%left (i) `(%index (ash ,i 1)))
4842              (%right (i) `(%index (1+ (ash ,i 1))))
4843              (%heapify (i)
4844               `(do* ((i ,i)
4845                      (left (%left i) (%left i)))
4846                 ((> left current-heap-size))
4847                 (declare (type index i left))
4848                 (let* ((i-elt (%elt i))
4849                        (i-key (funcall keyfun i-elt))
4850                        (left-elt (%elt left))
4851                        (left-key (funcall keyfun left-elt)))
4852                   (multiple-value-bind (large large-elt large-key)
4853                       (if (funcall ,',predicate i-key left-key)
4854                           (values left left-elt left-key)
4855                           (values i i-elt i-key))
4856                     (let ((right (%right i)))
4857                       (multiple-value-bind (largest largest-elt)
4858                           (if (> right current-heap-size)
4859                               (values large large-elt)
4860                               (let* ((right-elt (%elt right))
4861                                      (right-key (funcall keyfun right-elt)))
4862                                 (if (funcall ,',predicate large-key right-key)
4863                                     (values right right-elt)
4864                                     (values large large-elt))))
4865                         (cond ((= largest i)
4866                                (return))
4867                               (t
4868                                (setf (%elt i) largest-elt
4869                                      (%elt largest) i-elt
4870                                      i largest)))))))))
4871              (%sort-vector (keyfun &optional (vtype 'vector))
4872               `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had
4873                           ;; trouble getting type inference to
4874                           ;; propagate all the way through this
4875                           ;; tangled mess of inlining. The TRULY-THE
4876                           ;; here works around that. -- WHN
4877                           (%elt (i)
4878                            `(aref (truly-the ,',vtype ,',',vector)
4879                              (%index (+ (%index ,i) start-1)))))
4880                 (let (;; Heaps prefer 1-based addressing.
4881                       (start-1 (1- ,',start))
4882                       (current-heap-size (- ,',end ,',start))
4883                       (keyfun ,keyfun))
4884                   (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum))
4885                                  start-1))
4886                   (declare (type index current-heap-size))
4887                   (declare (type function keyfun))
4888                   (loop for i of-type index
4889                         from (ash current-heap-size -1) downto 1 do
4890                         (%heapify i))
4891                   (loop
4892                    (when (< current-heap-size 2)
4893                      (return))
4894                    (rotatef (%elt 1) (%elt current-heap-size))
4895                    (decf current-heap-size)
4896                    (%heapify 1))))))
4897    (if (typep ,vector 'simple-vector)
4898        ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
4899        ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
4900        (if (null ,key)
4901            ;; Special-casing the KEY=NIL case lets us avoid some
4902            ;; function calls.
4903            (%sort-vector #'identity simple-vector)
4904            (%sort-vector ,key simple-vector))
4905        ;; It's hard to anticipate many speed-critical applications for
4906        ;; sorting vector types other than (VECTOR T), so we just lump
4907        ;; them all together in one slow dynamically typed mess.
4908        (locally
4909          (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
4910          (%sort-vector (or ,key #'identity))))))
4911
4912(deftransform sort ((list predicate &key key)
4913                    (list * &rest t) *)
4914  `(sb!impl::stable-sort-list list
4915                              (%coerce-callable-to-fun predicate)
4916                              (if key (%coerce-callable-to-fun key) #'identity)))
4917
4918(deftransform stable-sort ((sequence predicate &key key)
4919                           ((or vector list) *))
4920  (let ((sequence-type (lvar-type sequence)))
4921    (cond ((csubtypep sequence-type (specifier-type 'list))
4922           `(sb!impl::stable-sort-list sequence
4923                                       (%coerce-callable-to-fun predicate)
4924                                       (if key (%coerce-callable-to-fun key) #'identity)))
4925          ((csubtypep sequence-type (specifier-type 'simple-vector))
4926           `(sb!impl::stable-sort-simple-vector sequence
4927                                                (%coerce-callable-to-fun predicate)
4928                                                (and key (%coerce-callable-to-fun key))))
4929          (t
4930           `(sb!impl::stable-sort-vector sequence
4931                                         (%coerce-callable-to-fun predicate)
4932                                         (and key (%coerce-callable-to-fun key)))))))
4933
4934;;;; debuggers' little helpers
4935
4936;;; for debugging when transforms are behaving mysteriously,
4937;;; e.g. when debugging a problem with an ASH transform
4938;;;   (defun foo (&optional s)
4939;;;     (sb-c::/report-lvar s "S outside WHEN")
4940;;;     (when (and (integerp s) (> s 3))
4941;;;       (sb-c::/report-lvar s "S inside WHEN")
4942;;;       (let ((bound (ash 1 (1- s))))
4943;;;         (sb-c::/report-lvar bound "BOUND")
4944;;;         (let ((x (- bound))
4945;;;               (y (1- bound)))
4946;;;           (sb-c::/report-lvar x "X")
4947;;;           (sb-c::/report-lvar x "Y"))
4948;;;         `(integer ,(- bound) ,(1- bound)))))
4949;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
4950;;; and the function doesn't do anything at all.)
4951#!+sb-show
4952(progn
4953  (defknown /report-lvar (t t) null)
4954  (deftransform /report-lvar ((x message) (t t))
4955    (format t "~%/in /REPORT-LVAR~%")
4956    (format t "/(LVAR-TYPE X)=~S~%" (lvar-type x))
4957    (when (constant-lvar-p x)
4958      (format t "/(LVAR-VALUE X)=~S~%" (lvar-value x)))
4959    (format t "/MESSAGE=~S~%" (lvar-value message))
4960    (give-up-ir1-transform "not a real transform"))
4961  (defun /report-lvar (x message)
4962    (declare (ignore x message))))
4963
4964(deftransform encode-universal-time
4965    ((second minute hour date month year &optional time-zone)
4966     ((constant-arg (mod 60)) (constant-arg (mod 60))
4967      (constant-arg (mod 24))
4968      (constant-arg (integer 1 31))
4969      (constant-arg (integer 1 12))
4970      (constant-arg (integer 1899))
4971      (constant-arg (rational -24 24))))
4972  (let ((second (lvar-value second))
4973        (minute (lvar-value minute))
4974        (hour (lvar-value hour))
4975        (date (lvar-value date))
4976        (month (lvar-value month))
4977        (year (lvar-value year))
4978        (time-zone (lvar-value time-zone)))
4979    (if (zerop (rem time-zone 1/3600))
4980        (encode-universal-time second minute hour date month year time-zone)
4981        (give-up-ir1-transform))))
4982
4983#!-(and win32 (not sb-thread))
4984(deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
4985  `(sb!unix:nanosleep seconds 0))
4986
4987#!-(and win32 (not sb-thread))
4988(deftransform sleep ((seconds) ((constant-arg (real 0))))
4989  (let ((seconds-value (lvar-value seconds)))
4990    (multiple-value-bind (seconds nano)
4991        (sb!impl::split-seconds-for-sleep seconds-value)
4992      (if (> seconds (expt 10 8))
4993          (give-up-ir1-transform)
4994          `(sb!unix:nanosleep ,seconds ,nano)))))
4995
4996;; On 64-bit architectures the TLS index is in the symbol header,
4997;; !DEFINE-PRIMITIVE-OBJECT doesn't define an accessor for it.
4998;; In the architectures where tls-index is an ordinary slot holding a tagged
4999;; object, it represents the byte offset to an aligned object and looks
5000;; in Lisp like a fixnum that is off by a factor of (EXPT 2 N-FIXNUM-TAG-BITS).
5001;; We're reading with a raw SAP accessor, so must make it look equally "off".
5002;; Also we don't get the defknown automatically.
5003#!+(and 64-bit sb-thread)
5004(defknown symbol-tls-index (t) fixnum (flushable))
5005#!+(and 64-bit sb-thread)
5006(define-source-transform symbol-tls-index (sym)
5007  `(ash (sap-ref-32 (int-sap (get-lisp-obj-address (the symbol ,sym)))
5008                    (- 4 sb!vm:other-pointer-lowtag))
5009        (- sb!vm:n-fixnum-tag-bits)))
5010
5011(deftransform make-string-output-stream ((&key element-type))
5012  (let ((element-type (cond ((not element-type)
5013                             'character)
5014                            ((constant-lvar-p element-type)
5015                             (let ((specifier (careful-specifier-type (lvar-value element-type))))
5016                               (and (csubtypep specifier (specifier-type 'character))
5017                                    (type-specifier specifier)))))))
5018   (if element-type
5019       `(sb!impl::%make-string-output-stream ',element-type)
5020       (give-up-ir1-transform))))
5021
5022(deftransform set ((symbol value) ((constant-arg symbol) *))
5023  (let* ((symbol (lvar-value symbol)))
5024    (case (info :variable :kind symbol)
5025      ((:constant :global :special)
5026       `(setq ,symbol value))
5027      (t
5028       (give-up-ir1-transform)))))
5029