src/compiler/srctran.lisp

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