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