X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=e13c30e019e7799ab08cf50a3f42b4620e683ba5;hb=1daa58cfa315fe86634069c941cf54ec8f95623c;hp=ca2c4d982c0ef2a0d6ce66ed9d3fa7d9b1271fe7;hpb=750b2f3d09ba0f8c20bbf735cdd5aaeea868c052;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index ca2c4d9..e13c30e 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -13,29 +13,16 @@ (in-package "SB!C") -;;; Convert into an IF so that IF optimizations will eliminate redundant -;;; negations. -(define-source-transform not (x) `(if ,x nil t)) -(define-source-transform null (x) `(if ,x nil t)) - -;;; ENDP is just NULL with a LIST assertion. The assertion will be -;;; optimized away when SAFETY optimization is low; hopefully that -;;; is consistent with ANSI's "should return an error". -(define-source-transform endp (x) `(null (the list ,x))) - ;;; We turn IDENTITY into PROG1 so that it is obvious that it just ;;; returns the first value of its argument. Ditto for VALUES with one ;;; arg. (define-source-transform identity (x) `(prog1 ,x)) (define-source-transform values (x) `(prog1 ,x)) -;;; Bind the value and make a closure that returns it. -(define-source-transform constantly (value) - (with-unique-names (rest n-value) - `(let ((,n-value ,value)) - (lambda (&rest ,rest) - (declare (ignore ,rest)) - ,n-value)))) +;;; CONSTANTLY is pretty much never worth transforming, but it's good to get the type. +(defoptimizer (constantly derive-type) ((value)) + (specifier-type + `(function (&rest t) (values ,(type-specifier (lvar-type value)) &optional)))) ;;; If the function has a known number of arguments, then return a ;;; lambda with the appropriate fixed number of args. If the @@ -59,6 +46,26 @@ (give-up-ir1-transform "The function doesn't have a fixed argument count."))))) +;;;; SYMBOL-VALUE &co +(defun derive-symbol-value-type (lvar node) + (if (constant-lvar-p lvar) + (let* ((sym (lvar-value lvar)) + (var (maybe-find-free-var sym)) + (local-type (when var + (let ((*lexenv* (node-lexenv node))) + (lexenv-find var type-restrictions)))) + (global-type (info :variable :type sym))) + (if local-type + (type-intersection local-type global-type) + global-type)) + *universal-type*)) + +(defoptimizer (symbol-value derive-type) ((symbol) node) + (derive-symbol-value-type symbol node)) + +(defoptimizer (symbol-global-value derive-type) ((symbol) node) + (derive-symbol-value-type symbol node)) + ;;;; list hackery ;;; Translate CxR into CAR/CDR combos. @@ -81,6 +88,9 @@ ;;; Make source transforms to turn CxR forms into combinations of CAR ;;; and CDR. ANSI specifies that everything up to 4 A/D operations is ;;; defined. +;;; Don't transform CAD*R, they are treated specially for &more args +;;; optimizations + (/show0 "about to set CxR source transforms") (loop for i of-type index from 2 upto 4 do ;; Iterate over BUF = all names CxR where x = an I-element @@ -94,16 +104,18 @@ (declare (type index k)) (setf (aref buf (1+ k)) (if (logbitp k j) #\A #\D))) - (setf (info :function :source-transform (intern buf)) - #'source-transform-cxr)))) + (unless (member buf '("CADR" "CADDR" "CADDDR") + :test #'equal) + (setf (info :function :source-transform (intern buf)) + #'source-transform-cxr))))) (/show0 "done setting CxR source transforms") ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming ;;; whatever is right for them is right for us. FIFTH..TENTH turn into ;;; Nth, which can be expanded into a CAR/CDR later on if policy ;;; favors it. -(define-source-transform first (x) `(car ,x)) (define-source-transform rest (x) `(cdr ,x)) +(define-source-transform first (x) `(car ,x)) (define-source-transform second (x) `(cadr ,x)) (define-source-transform third (x) `(caddr ,x)) (define-source-transform fourth (x) `(cadddr ,x)) @@ -114,6 +126,87 @@ (define-source-transform ninth (x) `(nth 8 ,x)) (define-source-transform tenth (x) `(nth 9 ,x)) +;;; LIST with one arg is an extremely common operation (at least inside +;;; SBCL itself); translate it to CONS to take advantage of common +;;; allocation routines. +(define-source-transform list (&rest args) + (case (length args) + (1 `(cons ,(first args) nil)) + (t (values nil t)))) + +(defoptimizer (list derive-type) ((&rest args) node) + (if args + (specifier-type 'cons) + (specifier-type 'null))) + +;;; And similarly for LIST*. +(define-source-transform list* (arg &rest others) + (cond ((not others) arg) + ((not (cdr others)) `(cons ,arg ,(car others))) + (t (values nil t)))) + +(defoptimizer (list* derive-type) ((arg &rest args)) + (if args + (specifier-type 'cons) + (lvar-type arg))) + +;;; + +(define-source-transform nconc (&rest args) + (case (length args) + (0 ()) + (1 (car args)) + (t (values nil t)))) + +;;; (append nil nil nil fixnum) => fixnum +;;; (append x x cons x x) => cons +;;; (append x x x x list) => list +;;; (append x x x x sequence) => sequence +;;; (append fixnum x ...) => nil +(defun derive-append-type (args) + (when (null args) + (return-from derive-append-type (specifier-type 'null))) + (let* ((cons-type (specifier-type 'cons)) + (null-type (specifier-type 'null)) + (list-type (specifier-type 'list)) + (last (lvar-type (car (last args))))) + ;; Derive the actual return type, assuming that all but the last + ;; arguments are LISTs (otherwise, APPEND/NCONC doesn't return). + (loop with all-nil = t ; all but the last args are NIL? + with some-cons = nil ; some args are conses? + for (arg next) on args + for lvar-type = (type-approx-intersection2 (lvar-type arg) + list-type) + while next + do (multiple-value-bind (typep definitely) + (ctypep nil lvar-type) + (cond ((type= lvar-type *empty-type*) + ;; type mismatch! insert an inline check that'll cause + ;; compile-time warnings. + (assert-lvar-type arg list-type + (lexenv-policy *lexenv*))) + (some-cons) ; we know result's a cons -- nothing to do + ((and (not typep) definitely) ; can't be NIL + (setf some-cons t)) ; must be a CONS + (all-nil + (setf all-nil (csubtypep lvar-type null-type))))) + finally + ;; if some of the previous arguments are CONSes so is the result; + ;; if all the previous values are NIL, we're a fancy identity; + ;; otherwise, could be either + (return (cond (some-cons cons-type) + (all-nil last) + (t (type-union last cons-type))))))) + +(defoptimizer (append derive-type) ((&rest args)) + (derive-append-type args)) + +(defoptimizer (sb!impl::append2 derive-type) ((&rest args)) + (derive-append-type args)) + +(defoptimizer (nconc derive-type) ((&rest args)) + (derive-append-type args)) + ;;; Translate RPLACx to LET and SETF. (define-source-transform rplaca (x y) (once-only ((n-x x)) @@ -126,12 +219,25 @@ (setf (cdr ,n-x) ,y) ,n-x))) -(define-source-transform nth (n l) `(car (nthcdr ,n ,l))) +(deftransform last ((list &optional n) (t &optional t)) + (let ((c (constant-lvar-p n))) + (cond ((or (not n) + (and c (eql 1 (lvar-value n)))) + '(%last1 list)) + ((and c (eql 0 (lvar-value n))) + '(%last0 list)) + (t + (let ((type (lvar-type n))) + (cond ((csubtypep type (specifier-type 'fixnum)) + '(%lastn/fixnum list n)) + ((csubtypep type (specifier-type 'bignum)) + '(%lastn/bignum list n)) + (t + (give-up-ir1-transform "second argument type too vague")))))))) -(define-source-transform last (x) `(sb!impl::last1 ,x)) (define-source-transform gethash (&rest args) (case (length args) - (2 `(sb!impl::gethash2 ,@args)) + (2 `(sb!impl::gethash3 ,@args nil)) (3 `(sb!impl::gethash3 ,@args)) (t (values nil t)))) (define-source-transform get (&rest args) @@ -169,8 +275,8 @@ (define-source-transform 1+ (x) `(+ ,x 1)) (define-source-transform 1- (x) `(- ,x 1)) -(define-source-transform oddp (x) `(not (zerop (logand ,x 1)))) -(define-source-transform evenp (x) `(zerop (logand ,x 1))) +(define-source-transform oddp (x) `(logtest ,x 1)) +(define-source-transform evenp (x) `(not (logtest ,x 1))) ;;; Note that all the integer division functions are available for ;;; inline expansion. @@ -192,8 +298,24 @@ ;;; on the argument types), but we make it a regular transform so that ;;; the VM has a chance to see the bare LOGTEST and potentiall choose ;;; to implement it differently. --njf, 06-02-2006 -(deftransform logtest ((x y) * *) - `(not (zerop (logand x y)))) +;;; +;;; Other transforms may be useful even with direct LOGTEST VOPs; let +;;; them fire (including the type-directed constant folding below), but +;;; disable the inlining rewrite in such cases. -- PK, 2013-05-20 +(deftransform logtest ((x y) * * :node node) + (let ((type (two-arg-derive-type x y + #'logand-derive-type-aux + #'logand))) + (multiple-value-bind (typep definitely) + (ctypep 0 type) + (cond ((and (not typep) definitely) + t) + ((type= type (specifier-type '(eql 0))) + nil) + ((neq :default (combination-implementation-style node)) + (give-up-ir1-transform)) + (t + `(not (zerop (logand x y)))))))) (deftransform logbitp ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits) @@ -293,20 +415,64 @@ (defun set-bound (x open-p) (if (and x open-p) (list x) x)) -;;; Apply the function F to a bound X. If X is an open bound, then -;;; the result will be open. IF X is NIL, the result is NIL. -(defun bound-func (f x) +;;; Apply the function F to a bound X. If X is an open bound and the +;;; function is declared strictly monotonic, then the result will be +;;; open. IF X is NIL, the result is NIL. +(defun bound-func (f x strict) (declare (type function f)) (and x - (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - ;; With these traps masked, we might get things like infinity - ;; or negative infinity returned. Check for this and return - ;; NIL to indicate unbounded. - (let ((y (funcall f (type-bound-number x)))) - (if (and (floatp y) - (float-infinity-p y)) - nil - (set-bound y (consp x))))))) + (handler-case + (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) + ;; With these traps masked, we might get things like infinity + ;; or negative infinity returned. Check for this and return + ;; NIL to indicate unbounded. + (let ((y (funcall f (type-bound-number x)))) + (if (and (floatp y) + (float-infinity-p y)) + nil + (set-bound y (and strict (consp x)))))) + ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g. + ;; in the course of converting a bignum to a float. Default to + ;; NIL in that case. + (simple-type-error ())))) + +(defun safe-double-coercion-p (x) + (or (typep x 'double-float) + (<= most-negative-double-float x most-positive-double-float))) + +(defun safe-single-coercion-p (x) + (or (typep x 'single-float) + (and + ;; Fix for bug 420, and related issues: during type derivation we often + ;; end up deriving types for both + ;; + ;; (some-op ) + ;; and + ;; (some-op (coerce 'single-float) ) + ;; + ;; or other equivalent transformed forms. The problem with this + ;; is that on x86 (+ ) is on the machine level + ;; equivalent of + ;; + ;; (coerce (+ (coerce 'double-float) + ;; (coerce 'double-float)) + ;; 'single-float) + ;; + ;; so if the result of (coerce 'single-float) is not exact, the + ;; derived types for the transformed forms will have an empty + ;; intersection -- which in turn means that the compiler will conclude + ;; that the call never returns, and all hell breaks lose when it *does* + ;; return at runtime. (This affects not just +, but other operators are + ;; well.) + ;; + ;; See also: SAFE-CTYPE-FOR-SINGLE-COERCION-P + ;; + ;; FIXME: If we ever add SSE-support for x86, this conditional needs to + ;; change. + #!+x86 + (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum)) + (integer (,most-positive-exactly-single-float-fixnum) *)))) + (<= most-negative-single-float x most-positive-single-float)))) ;;; Apply a binary operator OP to two bounds X and Y. The result is ;;; NIL if either is NIL. Otherwise bound is computed and the result @@ -321,32 +487,67 @@ (defmacro safely-binop (op x y) `(cond - ((typep ,x 'single-float) - (if (or (typep ,y 'single-float) - (<= most-negative-single-float ,y most-positive-single-float)) - (,op ,x ,y))) - ((typep ,x 'double-float) - (if (or (typep ,y 'double-float) - (<= most-negative-double-float ,y most-positive-double-float)) - (,op ,x ,y))) - ((typep ,y 'single-float) - (if (<= most-negative-single-float ,x most-positive-single-float) - (,op ,x ,y))) - ((typep ,y 'double-float) - (if (<= most-negative-double-float ,x most-positive-double-float) - (,op ,x ,y))) - (t (,op ,x ,y)))) + ((typep ,x 'double-float) + (when (safe-double-coercion-p ,y) + (,op ,x ,y))) + ((typep ,y 'double-float) + (when (safe-double-coercion-p ,x) + (,op ,x ,y))) + ((typep ,x 'single-float) + (when (safe-single-coercion-p ,y) + (,op ,x ,y))) + ((typep ,y 'single-float) + (when (safe-single-coercion-p ,x) + (,op ,x ,y))) + (t (,op ,x ,y)))) (defmacro bound-binop (op x y) - `(and ,x ,y - (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - (set-bound (safely-binop ,op (type-bound-number ,x) - (type-bound-number ,y)) - (or (consp ,x) (consp ,y)))))) + (with-unique-names (xb yb res) + `(and ,x ,y + (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) + (let* ((,xb (type-bound-number ,x)) + (,yb (type-bound-number ,y)) + (,res (safely-binop ,op ,xb ,yb))) + (set-bound ,res + (and (or (consp ,x) (consp ,y)) + ;; Open bounds can very easily be messed up + ;; by FP rounding, so take care here. + ,(case op + (* + ;; Multiplying a greater-than-zero with + ;; less than one can round to zero. + `(or (not (fp-zero-p ,res)) + (cond ((and (consp ,x) (fp-zero-p ,xb)) + (>= (abs ,yb) 1)) + ((and (consp ,y) (fp-zero-p ,yb)) + (>= (abs ,xb) 1))))) + (/ + ;; Dividing a greater-than-zero with + ;; greater than one can round to zero. + `(or (not (fp-zero-p ,res)) + (cond ((and (consp ,x) (fp-zero-p ,xb)) + (<= (abs ,yb) 1)) + ((and (consp ,y) (fp-zero-p ,yb)) + (<= (abs ,xb) 1))))) + ((+ -) + ;; Adding or subtracting greater-than-zero + ;; can end up with identity. + `(and (not (fp-zero-p ,xb)) + (not (fp-zero-p ,yb)))))))))))) + +(defun coercion-loses-precision-p (val type) + (typecase val + (single-float) + (double-float (subtypep type 'single-float)) + (rational (subtypep type 'float)) + (t (bug "Unexpected arguments to bounds coercion: ~S ~S" val type)))) (defun coerce-for-bound (val type) (if (consp val) - (list (coerce-for-bound (car val) type)) + (let ((xbound (coerce-for-bound (car val) type))) + (if (coercion-loses-precision-p (car val) type) + xbound + (list xbound))) (cond ((subtypep type 'double-float) (if (<= most-negative-double-float val most-positive-double-float) @@ -360,7 +561,10 @@ (defun coerce-and-truncate-floats (val type) (when val (if (consp val) - (list (coerce-and-truncate-floats (car val) type)) + (let ((xbound (coerce-for-bound (car val) type))) + (if (coercion-loses-precision-p (car val) type) + xbound + (list xbound))) (cond ((subtypep type 'double-float) (if (<= most-negative-double-float val most-positive-double-float) @@ -409,7 +613,7 @@ :high (copy-interval-limit (interval-high x)))) ;;; Given a point P contained in the interval X, split X into two -;;; interval at the point P. If CLOSE-LOWER is T, then the left +;;; intervals at the point P. If CLOSE-LOWER is T, then the left ;;; interval contains P. If CLOSE-UPPER is T, the right interval ;;; contains P. You can specify both to be T or NIL. (defun interval-split (p x &optional close-lower close-upper) @@ -497,15 +701,13 @@ ;;; 1] and Y = [1, 2] to determine intersection. (defun interval-intersect-p (x y &optional closed-intervals-p) (declare (type interval x y)) - (multiple-value-bind (intersect diff) - (interval-intersection/difference (if closed-intervals-p - (interval-closure x) - x) - (if closed-intervals-p - (interval-closure y) - y)) - (declare (ignore diff)) - intersect)) + (and (interval-intersection/difference (if closed-intervals-p + (interval-closure x) + x) + (if closed-intervals-p + (interval-closure y) + y)) + t)) ;;; Are the two intervals adjacent? That is, is there a number ;;; between the two intervals that is not an element of either @@ -549,27 +751,44 @@ (if (listp p) (first p) (list p))) - (test-number (p int) + (test-number (p int bound) ;; Test whether P is in the interval. - (when (interval-contains-p (type-bound-number p) - (interval-closure int)) - (let ((lo (interval-low int)) - (hi (interval-high int))) + (let ((pn (type-bound-number p))) + (when (interval-contains-p pn (interval-closure int)) ;; Check for endpoints. - (cond ((and lo (= (type-bound-number p) (type-bound-number lo))) - (not (and (consp p) (numberp lo)))) - ((and hi (= (type-bound-number p) (type-bound-number hi))) - (not (and (numberp p) (consp hi)))) - (t t))))) + (let* ((lo (interval-low int)) + (hi (interval-high int)) + (lon (type-bound-number lo)) + (hin (type-bound-number hi))) + (cond + ;; Interval may be a point. + ((and lon hin (= lon hin pn)) + (and (numberp p) (numberp lo) (numberp hi))) + ;; Point matches the low end. + ;; [P] [P,?} => TRUE [P] (P,?} => FALSE + ;; (P [P,?} => TRUE P) [P,?} => FALSE + ;; (P (P,?} => TRUE P) (P,?} => FALSE + ((and lon (= pn lon)) + (or (and (numberp p) (numberp lo)) + (and (consp p) (eq :low bound)))) + ;; [P] {?,P] => TRUE [P] {?,P) => FALSE + ;; P) {?,P] => TRUE (P {?,P] => FALSE + ;; P) {?,P) => TRUE (P {?,P) => FALSE + ((and hin (= pn hin)) + (or (and (numberp p) (numberp hi)) + (and (consp p) (eq :high bound)))) + ;; Not an endpoint, all is well. + (t + t)))))) (test-lower-bound (p int) ;; P is a lower bound of an interval. (if p - (test-number p int) + (test-number p int :low) (not (interval-bounded-p int 'below)))) (test-upper-bound (p int) ;; P is an upper bound of an interval. (if p - (test-number p int) + (test-number p int :high) (not (interval-bounded-p int 'above))))) (let ((x-lo-in-y (test-lower-bound x-lo y)) (x-hi-in-y (test-upper-bound x-hi y)) @@ -646,8 +865,8 @@ ;;; the negative of an interval (defun interval-neg (x) (declare (type interval x)) - (make-interval :low (bound-func #'- (interval-high x)) - :high (bound-func #'- (interval-low x)))) + (make-interval :low (bound-func #'- (interval-high x) t) + :high (bound-func #'- (interval-low x) t))) ;;; Add two intervals. (defun interval-add (x y) @@ -673,8 +892,9 @@ ;; Multiply by closed zero is special. The result ;; is always a closed bound. But don't replace this ;; with zero; we want the multiplication to produce - ;; the correct signed zero, if needed. - (* (type-bound-number x) (type-bound-number y))) + ;; the correct signed zero, if needed. Use SIGNUM + ;; to avoid trying to multiply huge bignums with 0.0. + (* (signum (type-bound-number x)) (signum (type-bound-number y)))) ((or (and (floatp x) (float-infinity-p x)) (and (floatp y) (float-infinity-p y))) ;; Infinity times anything is infinity @@ -724,9 +944,6 @@ ((zerop (type-bound-number y)) ;; Divide by zero means result is infinity nil) - ((and (numberp x) (zerop x)) - ;; Zero divided by anything is zero. - x) (t (bound-binop / x y))))) (let ((top-range (interval-range-info top)) @@ -758,13 +975,17 @@ ;;; Apply the function F to the interval X. If X = [a, b], then the ;;; result is [f(a), f(b)]. It is up to the user to make sure the -;;; result makes sense. It will if F is monotonic increasing (or -;;; non-decreasing). -(defun interval-func (f x) +;;; result makes sense. It will if F is monotonic increasing (or, if +;;; the interval is closed, non-decreasing). +;;; +;;; (Actually most uses of INTERVAL-FUNC are coercions to float types, +;;; which are not monotonic increasing, so default to calling +;;; BOUND-FUNC with a non-strict argument). +(defun interval-func (f x &optional increasing) (declare (type function f) (type interval x)) - (let ((lo (bound-func f (interval-low x))) - (hi (bound-func f (interval-high x)))) + (let ((lo (bound-func f (interval-low x) increasing)) + (hi (bound-func f (interval-high x) increasing))) (make-interval :low lo :high hi))) ;;; Return T if X < Y. That is every number in the interval X is @@ -802,6 +1023,24 @@ (>= (type-bound-number (interval-low x)) (type-bound-number (interval-high y))))) +;;; Return T if X = Y. +(defun interval-= (x y) + (declare (type interval x y)) + (and (interval-bounded-p x 'both) + (interval-bounded-p y 'both) + (flet ((bound (v) + (if (numberp v) + v + ;; Open intervals cannot be = + (return-from interval-= nil)))) + ;; Both intervals refer to the same point + (= (bound (interval-high x)) (bound (interval-low x)) + (bound (interval-high y)) (bound (interval-low y)))))) + +;;; Return T if X /= Y +(defun interval-/= (x y) + (not (interval-intersect-p x y))) + ;;; Return an interval that is the absolute value of X. Thus, if ;;; X = [-1 10], the result is [0, 10]. (defun interval-abs (x) @@ -818,14 +1057,13 @@ ;;; Compute the square of an interval. (defun interval-sqr (x) (declare (type interval x)) - (interval-func (lambda (x) (* x x)) - (interval-abs x))) + (interval-func (lambda (x) (* x x)) (interval-abs x))) ;;;; numeric DERIVE-TYPE methods ;;; a utility for defining derive-type methods of integer operations. If ;;; the types of both X and Y are integer types, then we compute a new -;;; integer type with bounds determined Fun when applied to X and Y. +;;; integer type with bounds determined by FUN when applied to X and Y. ;;; Otherwise, we use NUMERIC-CONTAGION. (defun derive-integer-type-aux (x y fun) (declare (type function fun)) @@ -877,11 +1115,13 @@ (if (member-type-p arg) ;; Run down the list of members and convert to a list of ;; member types. - (dolist (member (member-type-members arg)) - (push (if (numberp member) - (make-member-type :members (list member)) - *empty-type*) - new-args)) + (mapc-member-type-members + (lambda (member) + (push (if (numberp member) + (make-member-type :members (list member)) + *empty-type*) + new-args)) + arg) (push arg new-args))) (unless (member *empty-type* new-args) new-args))))) @@ -997,7 +1237,7 @@ (t ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0))) ;; (float x -0.0) => (or (member -0.0) (float x (0.0))) - (list (make-member-type :members (list (float -0.0 hi-val))) + (list (make-member-type :members (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val))) (make-numeric-type :class (numeric-type-class type) :format (numeric-type-format type) :complexp :real @@ -1028,37 +1268,48 @@ (t type-list))) -;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably -;;; belong in the kernel's type logic, invoked always, instead of in -;;; the compiler, invoked only during some type optimizations. (In -;;; fact, as of 0.pre8.100 or so they probably are, under -;;; MAKE-MEMBER-TYPE, so probably this code can be deleted) - ;;; Take a list of types and return a canonical type specifier, ;;; combining any MEMBER types together. If both positive and negative ;;; MEMBER types are present they are converted to a float type. ;;; XXX This would be far simpler if the type-union methods could handle ;;; member/number unions. -(defun make-canonical-union-type (type-list) - (let ((members '()) - (misc-types '())) +;;; +;;; If we're about to generate an overly complex union of numeric types, start +;;; collapse the ranges together. +;;; +;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and +;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic, +;;; invoked always, instead of in the compiler, invoked only during some type +;;; optimizations. +(defvar *derived-numeric-union-complexity-limit* 6) + +(defun make-derived-union-type (type-list) + (let ((xset (alloc-xset)) + (fp-zeroes '()) + (misc-types '()) + (numeric-type *empty-type*)) (dolist (type type-list) - (if (member-type-p type) - (setf members (union members (member-type-members type))) - (push type misc-types))) - #!+long-float - (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)) - (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) - (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (if members - (apply #'type-union (make-member-type :members members) misc-types) - (apply #'type-union misc-types)))) + (cond ((member-type-p type) + (mapc-member-type-members + (lambda (member) + (if (fp-zero-p member) + (unless (member member fp-zeroes) + (pushnew member fp-zeroes)) + (add-to-xset member xset))) + type)) + ((numeric-type-p type) + (let ((*approximate-numeric-unions* + (when (and (union-type-p numeric-type) + (nthcdr *derived-numeric-union-complexity-limit* + (union-type-types numeric-type))) + t))) + (setf numeric-type (type-union type numeric-type)))) + (t + (push type misc-types)))) + (if (and (xset-empty-p xset) (not fp-zeroes)) + (apply #'type-union numeric-type misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) + numeric-type misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -1123,7 +1374,7 @@ (setf results (append results result)) (push result results)))) (if (rest results) - (make-canonical-union-type results) + (make-derived-union-type results) (first results))))))) ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes @@ -1196,7 +1447,7 @@ (setf results (append results result)) (push result results)))))) (if (rest results) - (make-canonical-union-type results) + (make-derived-union-type results) (first results))))))) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) @@ -1692,6 +1943,16 @@ #'%unary-truncate-derive-type-aux #'%unary-truncate)) +(defoptimizer (%unary-truncate/single-float derive-type) ((number)) + (one-arg-derive-type number + #'%unary-truncate-derive-type-aux + #'%unary-truncate)) + +(defoptimizer (%unary-truncate/double-float derive-type) ((number)) + (one-arg-derive-type number + #'%unary-truncate-derive-type-aux + #'%unary-truncate)) + (defoptimizer (%unary-ftruncate derive-type) ((number)) (let ((divisor (specifier-type '(integer 1 1)))) (one-arg-derive-type number @@ -1699,6 +1960,28 @@ (ftruncate-derive-type-quot-aux n divisor nil)) #'%unary-ftruncate))) +(defoptimizer (%unary-round derive-type) ((number)) + (one-arg-derive-type number + (lambda (n) + (block nil + (unless (numeric-type-real-p n) + (return *empty-type*)) + (let* ((interval (numeric-type->interval n)) + (low (interval-low interval)) + (high (interval-high interval))) + (when (consp low) + (setf low (car low))) + (when (consp high) + (setf high (car high))) + (specifier-type + `(integer ,(if low + (round low) + '*) + ,(if high + (round high) + '*)))))) + #'%unary-round)) + ;;; Define optimizers for FLOOR and CEILING. (macrolet ((def (name q-name r-name) @@ -2130,7 +2413,7 @@ (if (and divisor-low divisor-high) ;; We know the range of the divisor, and the remainder must be ;; smaller than the divisor. We can tell the sign of the - ;; remainer if we know the sign of the number. + ;; remainder if we know the sign of the number. (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high))))) `(integer ,(if (or (null number-low) (minusp number-low)) @@ -2141,7 +2424,7 @@ divisor-max 0))) ;; The divisor is potentially either very positive or very - ;; negative. Therefore, the remainer is unbounded, but we might + ;; negative. Therefore, the remainder is unbounded, but we might ;; be able to tell something about the sign from the number. `(integer ,(if (and number-low (not (minusp number-low))) ;; The number we are dividing is positive. @@ -2188,305 +2471,6 @@ (defoptimizer (random derive-type) ((bound &optional state)) (one-arg-derive-type bound #'random-derive-type-aux nil)) -;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends - -;;; Return the maximum number of bits an integer of the supplied type -;;; can take up, or NIL if it is unbounded. The second (third) value -;;; is T if the integer can be positive (negative) and NIL if not. -;;; Zero counts as positive. -(defun integer-type-length (type) - (if (numeric-type-p type) - (let ((min (numeric-type-low type)) - (max (numeric-type-high type))) - (values (and min max (max (integer-length min) (integer-length max))) - (or (null max) (not (minusp max))) - (or (null min) (minusp min)))) - (values nil t t))) - -;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an -;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND. -;;; Credit also goes to Raymond Toy for writing (and debugging!) similar -;;; versions in CMUCL, from which these functions copy liberally. - -(defun logand-derive-unsigned-low-bound (x y) - (let ((a (numeric-type-low x)) - (b (numeric-type-high x)) - (c (numeric-type-low y)) - (d (numeric-type-high y))) - (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1) - until (zerop m) do - (unless (zerop (logand m (lognot a) (lognot c))) - (let ((temp (logandc2 (logior a m) (1- m)))) - (when (<= temp b) - (setf a temp) - (loop-finish)) - (setf temp (logandc2 (logior c m) (1- m))) - (when (<= temp d) - (setf c temp) - (loop-finish)))) - finally (return (logand a c))))) - -(defun logand-derive-unsigned-high-bound (x y) - (let ((a (numeric-type-low x)) - (b (numeric-type-high x)) - (c (numeric-type-low y)) - (d (numeric-type-high y))) - (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1) - until (zerop m) do - (cond - ((not (zerop (logand b (lognot d) m))) - (let ((temp (logior (logandc2 b m) (1- m)))) - (when (>= temp a) - (setf b temp) - (loop-finish)))) - ((not (zerop (logand (lognot b) d m))) - (let ((temp (logior (logandc2 d m) (1- m)))) - (when (>= temp c) - (setf d temp) - (loop-finish))))) - finally (return (logand b d))))) - -(defun logand-derive-type-aux (x y &optional same-leaf) - (when same-leaf - (return-from logand-derive-type-aux x)) - (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) - (declare (ignore x-pos)) - (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) - (declare (ignore y-pos)) - (if (not x-neg) - ;; X must be positive. - (if (not y-neg) - ;; They must both be positive. - (cond ((and (null x-len) (null y-len)) - (specifier-type 'unsigned-byte)) - ((null x-len) - (specifier-type `(unsigned-byte* ,y-len))) - ((null y-len) - (specifier-type `(unsigned-byte* ,x-len))) - (t - (let ((low (logand-derive-unsigned-low-bound x y)) - (high (logand-derive-unsigned-high-bound x y))) - (specifier-type `(integer ,low ,high))))) - ;; X is positive, but Y might be negative. - (cond ((null x-len) - (specifier-type 'unsigned-byte)) - (t - (specifier-type `(unsigned-byte* ,x-len))))) - ;; X might be negative. - (if (not y-neg) - ;; Y must be positive. - (cond ((null y-len) - (specifier-type 'unsigned-byte)) - (t (specifier-type `(unsigned-byte* ,y-len)))) - ;; Either might be negative. - (if (and x-len y-len) - ;; The result is bounded. - (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) - ;; We can't tell squat about the result. - (specifier-type 'integer))))))) - -(defun logior-derive-unsigned-low-bound (x y) - (let ((a (numeric-type-low x)) - (b (numeric-type-high x)) - (c (numeric-type-low y)) - (d (numeric-type-high y))) - (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1) - until (zerop m) do - (cond - ((not (zerop (logandc2 (logand c m) a))) - (let ((temp (logand (logior a m) (1+ (lognot m))))) - (when (<= temp b) - (setf a temp) - (loop-finish)))) - ((not (zerop (logandc2 (logand a m) c))) - (let ((temp (logand (logior c m) (1+ (lognot m))))) - (when (<= temp d) - (setf c temp) - (loop-finish))))) - finally (return (logior a c))))) - -(defun logior-derive-unsigned-high-bound (x y) - (let ((a (numeric-type-low x)) - (b (numeric-type-high x)) - (c (numeric-type-low y)) - (d (numeric-type-high y))) - (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1) - until (zerop m) do - (unless (zerop (logand b d m)) - (let ((temp (logior (- b m) (1- m)))) - (when (>= temp a) - (setf b temp) - (loop-finish)) - (setf temp (logior (- d m) (1- m))) - (when (>= temp c) - (setf d temp) - (loop-finish)))) - finally (return (logior b d))))) - -(defun logior-derive-type-aux (x y &optional same-leaf) - (when same-leaf - (return-from logior-derive-type-aux x)) - (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) - (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) - (cond - ((and (not x-neg) (not y-neg)) - ;; Both are positive. - (if (and x-len y-len) - (let ((low (logior-derive-unsigned-low-bound x y)) - (high (logior-derive-unsigned-high-bound x y))) - (specifier-type `(integer ,low ,high))) - (specifier-type `(unsigned-byte* *)))) - ((not x-pos) - ;; X must be negative. - (if (not y-pos) - ;; Both are negative. The result is going to be negative - ;; and be the same length or shorter than the smaller. - (if (and x-len y-len) - ;; It's bounded. - (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1)) - ;; It's unbounded. - (specifier-type '(integer * -1))) - ;; X is negative, but we don't know about Y. The result - ;; will be negative, but no more negative than X. - (specifier-type - `(integer ,(or (numeric-type-low x) '*) - -1)))) - (t - ;; X might be either positive or negative. - (if (not y-pos) - ;; But Y is negative. The result will be negative. - (specifier-type - `(integer ,(or (numeric-type-low y) '*) - -1)) - ;; We don't know squat about either. It won't get any bigger. - (if (and x-len y-len) - ;; Bounded. - (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) - ;; Unbounded. - (specifier-type 'integer)))))))) - -(defun logxor-derive-unsigned-low-bound (x y) - (let ((a (numeric-type-low x)) - (b (numeric-type-high x)) - (c (numeric-type-low y)) - (d (numeric-type-high y))) - (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1) - until (zerop m) do - (cond - ((not (zerop (logandc2 (logand c m) a))) - (let ((temp (logand (logior a m) - (1+ (lognot m))))) - (when (<= temp b) - (setf a temp)))) - ((not (zerop (logandc2 (logand a m) c))) - (let ((temp (logand (logior c m) - (1+ (lognot m))))) - (when (<= temp d) - (setf c temp))))) - finally (return (logxor a c))))) - -(defun logxor-derive-unsigned-high-bound (x y) - (let ((a (numeric-type-low x)) - (b (numeric-type-high x)) - (c (numeric-type-low y)) - (d (numeric-type-high y))) - (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1) - until (zerop m) do - (unless (zerop (logand b d m)) - (let ((temp (logior (- b m) (1- m)))) - (cond - ((>= temp a) (setf b temp)) - (t (let ((temp (logior (- d m) (1- m)))) - (when (>= temp c) - (setf d temp))))))) - finally (return (logxor b d))))) - -(defun logxor-derive-type-aux (x y &optional same-leaf) - (when same-leaf - (return-from logxor-derive-type-aux (specifier-type '(eql 0)))) - (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) - (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) - (cond - ((and (not x-neg) (not y-neg)) - ;; Both are positive - (if (and x-len y-len) - (let ((low (logxor-derive-unsigned-low-bound x y)) - (high (logxor-derive-unsigned-high-bound x y))) - (specifier-type `(integer ,low ,high))) - (specifier-type '(unsigned-byte* *)))) - ((and (not x-pos) (not y-pos)) - ;; Both are negative. The result will be positive, and as long - ;; as the longer. - (specifier-type `(unsigned-byte* ,(if (and x-len y-len) - (max x-len y-len) - '*)))) - ((or (and (not x-pos) (not y-neg)) - (and (not y-pos) (not x-neg))) - ;; Either X is negative and Y is positive or vice-versa. The - ;; result will be negative. - (specifier-type `(integer ,(if (and x-len y-len) - (ash -1 (max x-len y-len)) - '*) - -1))) - ;; We can't tell what the sign of the result is going to be. - ;; All we know is that we don't create new bits. - ((and x-len y-len) - (specifier-type `(signed-byte ,(1+ (max x-len y-len))))) - (t - (specifier-type 'integer)))))) - -(macrolet ((deffrob (logfun) - (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX"))) - `(defoptimizer (,logfun derive-type) ((x y)) - (two-arg-derive-type x y #',fun-aux #',logfun))))) - (deffrob logand) - (deffrob logior) - (deffrob logxor)) - -(defoptimizer (logeqv derive-type) ((x y)) - (two-arg-derive-type x y (lambda (x y same-leaf) - (lognot-derive-type-aux - (logxor-derive-type-aux x y same-leaf))) - #'logeqv)) -(defoptimizer (lognand derive-type) ((x y)) - (two-arg-derive-type x y (lambda (x y same-leaf) - (lognot-derive-type-aux - (logand-derive-type-aux x y same-leaf))) - #'lognand)) -(defoptimizer (lognor derive-type) ((x y)) - (two-arg-derive-type x y (lambda (x y same-leaf) - (lognot-derive-type-aux - (logior-derive-type-aux x y same-leaf))) - #'lognor)) -(defoptimizer (logandc1 derive-type) ((x y)) - (two-arg-derive-type x y (lambda (x y same-leaf) - (if same-leaf - (specifier-type '(eql 0)) - (logand-derive-type-aux - (lognot-derive-type-aux x) y nil))) - #'logandc1)) -(defoptimizer (logandc2 derive-type) ((x y)) - (two-arg-derive-type x y (lambda (x y same-leaf) - (if same-leaf - (specifier-type '(eql 0)) - (logand-derive-type-aux - x (lognot-derive-type-aux y) nil))) - #'logandc2)) -(defoptimizer (logorc1 derive-type) ((x y)) - (two-arg-derive-type x y (lambda (x y same-leaf) - (if same-leaf - (specifier-type '(eql -1)) - (logior-derive-type-aux - (lognot-derive-type-aux x) y nil))) - #'logorc1)) -(defoptimizer (logorc2 derive-type) ((x y)) - (two-arg-derive-type x y (lambda (x y same-leaf) - (if same-leaf - (specifier-type '(eql -1)) - (logior-derive-type-aux - x (lognot-derive-type-aux y) nil))) - #'logorc2)) - ;;;; miscellaneous derive-type methods (defoptimizer (integer-length derive-type) ((x)) @@ -2519,6 +2503,27 @@ (hi-res (if hi (isqrt hi) '*))) (specifier-type `(integer ,lo-res ,hi-res)))))) +(defoptimizer (char-code derive-type) ((char)) + (let ((type (type-intersection (lvar-type char) (specifier-type 'character)))) + (cond ((member-type-p type) + (specifier-type + `(member + ,@(loop for member in (member-type-members type) + when (characterp member) + collect (char-code member))))) + ((sb!kernel::character-set-type-p type) + (specifier-type + `(or + ,@(loop for (low . high) + in (character-set-type-pairs type) + collect `(integer ,low ,high))))) + ((csubtypep type (specifier-type 'base-char)) + (specifier-type + `(mod ,base-char-code-limit))) + (t + (specifier-type + `(mod ,char-code-limit)))))) + (defoptimizer (code-char derive-type) ((code)) (let ((type (lvar-type code))) ;; FIXME: unions of integral ranges? It ought to be easier to do @@ -2759,7 +2764,98 @@ (specifier-type `(signed-byte ,size-high)) *universal-type*)) *universal-type*))) + +;;; Rightward ASH +#!+ash-right-vops +(progn + (defun %ash/right (integer amount) + (ash integer (- amount))) + + (deftransform ash ((integer amount)) + "Convert ASH of signed word to %ASH/RIGHT" + (unless (and (csubtypep (lvar-type integer) ; do that ourselves to avoid + (specifier-type 'sb!vm:signed-word)) ; optimization + (csubtypep (lvar-type amount) ; notes. + (specifier-type '(integer * 0)))) + (give-up-ir1-transform)) + (when (constant-lvar-p amount) + (give-up-ir1-transform)) + (let ((use (lvar-uses amount))) + (cond ((and (combination-p use) + (eql '%negate (lvar-fun-name (combination-fun use)))) + (splice-fun-args amount '%negate 1) + `(lambda (integer amount) + (declare (type unsigned-byte amount)) + (%ash/right integer (if (>= amount ,sb!vm:n-word-bits) + ,(1- sb!vm:n-word-bits) + amount)))) + (t + `(%ash/right integer (if (<= amount ,(- sb!vm:n-word-bits)) + ,(1- sb!vm:n-word-bits) + (- amount))))))) + + (deftransform ash ((integer amount)) + "Convert ASH of word to %ASH/RIGHT" + (unless (and (csubtypep (lvar-type integer) + (specifier-type 'sb!vm:word)) + (csubtypep (lvar-type amount) + (specifier-type '(integer * 0)))) + (give-up-ir1-transform)) + (when (constant-lvar-p amount) + (give-up-ir1-transform)) + (let ((use (lvar-uses amount))) + (cond ((and (combination-p use) + (eql '%negate (lvar-fun-name (combination-fun use)))) + (splice-fun-args amount '%negate 1) + `(lambda (integer amount) + (declare (type unsigned-byte amount)) + (if (>= amount ,sb!vm:n-word-bits) + 0 + (%ash/right integer amount)))) + (t + `(if (<= amount ,(- sb!vm:n-word-bits)) + 0 + (%ash/right integer (- amount))))))) + + (deftransform %ash/right ((integer amount) (integer (constant-arg unsigned-byte))) + "Convert %ASH/RIGHT by constant back to ASH" + `(ash integer ,(- (lvar-value amount)))) + + (deftransform %ash/right ((integer amount) * * :node node) + "strength reduce large variable right shift" + (let ((return-type (single-value-type (node-derived-type node)))) + (cond ((type= return-type (specifier-type '(eql 0))) + 0) + ((type= return-type (specifier-type '(eql -1))) + -1) + ((csubtypep return-type (specifier-type '(member -1 0))) + `(ash integer ,(- sb!vm:n-word-bits))) + (t + (give-up-ir1-transform))))) + (defun %ash/right-derive-type-aux (n-type shift same-arg) + (declare (ignore same-arg)) + (or (and (or (csubtypep n-type (specifier-type 'sb!vm:signed-word)) + (csubtypep n-type (specifier-type 'word))) + (csubtypep shift (specifier-type `(mod ,sb!vm:n-word-bits))) + (let ((n-low (numeric-type-low n-type)) + (n-high (numeric-type-high n-type)) + (s-low (numeric-type-low shift)) + (s-high (numeric-type-high shift))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low + (if (minusp n-low) + (ash n-low (- s-low)) + (ash n-low (- s-high)))) + :high (when n-high + (if (minusp n-high) + (ash n-high (- s-high)) + (ash n-high (- s-low))))))) + *universal-type*)) + + (defoptimizer (%ash/right derive-type) ((n shift)) + (two-arg-derive-type n shift #'%ash/right-derive-type-aux #'%ash/right)) + ) ;;; Modular functions @@ -2768,19 +2864,20 @@ ;;; ;;; and similar for other arguments. -(defun make-modular-fun-type-deriver (prototype class width) +(defun make-modular-fun-type-deriver (prototype kind width signedp) + (declare (ignore kind)) #!-sb-fluid (binding* ((info (info :function :info prototype) :exit-if-null) (fun (fun-info-derive-type info) :exit-if-null) (mask-type (specifier-type - (ecase class - (:unsigned (let ((mask (1- (ash 1 width)))) - `(integer ,mask ,mask))) - (:signed `(signed-byte ,width)))))) + (ecase signedp + ((nil) (let ((mask (1- (ash 1 width)))) + `(integer ,mask ,mask))) + ((t) `(signed-byte ,width)))))) (lambda (call) (let ((res (funcall fun call))) (when res - (if (eq class :unsigned) + (if (eq signedp nil) (logand-derive-type-aux res mask-type)))))) #!+sb-fluid (lambda (call) @@ -2788,11 +2885,11 @@ (fun (fun-info-derive-type info) :exit-if-null) (res (funcall fun call) :exit-if-null) (mask-type (specifier-type - (ecase class - (:unsigned (let ((mask (1- (ash 1 width)))) - `(integer ,mask ,mask))) - (:signed `(signed-byte ,width)))))) - (if (eq class :unsigned) + (ecase signedp + ((nil) (let ((mask (1- (ash 1 width)))) + `(integer ,mask ,mask))) + ((t) `(signed-byte ,width)))))) + (if (eq signedp nil) (logand-derive-type-aux res mask-type))))) ;;; Try to recursively cut all uses of LVAR to WIDTH bits. @@ -2807,12 +2904,13 @@ ;;; modular version, if it exists, or NIL. If we have changed ;;; anything, we need to flush old derived types, because they have ;;; nothing in common with the new code. -(defun cut-to-width (lvar class width) +(defun cut-to-width (lvar kind width signedp) (declare (type lvar lvar) (type (integer 0) width)) (let ((type (specifier-type (if (zerop width) '(eql 0) - `(,(ecase class (:unsigned 'unsigned-byte) - (:signed 'signed-byte)) + `(,(ecase signedp + ((nil) 'unsigned-byte) + ((t) 'signed-byte)) ,width))))) (labels ((reoptimize-node (node name) (setf (node-derived-type node) @@ -2822,74 +2920,226 @@ (setf (node-reoptimize node) t) (setf (block-reoptimize (node-block node)) t) (reoptimize-component (node-component node) :maybe)) + (insert-lvar-cut (lvar) + "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR + to the required bit width. Returns T if any change was made. + + When the destination of LVAR will definitely cut LVAR's value + to width (i.e. it's a logand or mask-signed-field with constant + other argument), do nothing. Otherwise, splice LOGAND/M-S-F in." + (binding* ((dest (lvar-dest lvar) :exit-if-null) + (nil (combination-p dest) :exit-if-null) + (name (lvar-fun-name (combination-fun dest) t)) + (args (combination-args dest))) + (case name + (logand + (when (= 2 (length args)) + (let ((other (if (eql (first args) lvar) + (second args) + (first args)))) + (when (and (constant-lvar-p other) + (ctypep (lvar-value other) type) + (not signedp)) + (return-from insert-lvar-cut))))) + (mask-signed-field + (when (and signedp + (eql lvar (second args)) + (constant-lvar-p (first args)) + (<= (lvar-value (first args)) width)) + (return-from insert-lvar-cut))))) + (filter-lvar lvar + (if signedp + `(mask-signed-field ,width 'dummy) + `(logand 'dummy ,(ldb (byte width 0) -1)))) + (do-uses (node lvar) + (setf (block-reoptimize (node-block node)) t) + (reoptimize-component (node-component node) :maybe)) + t) (cut-node (node &aux did-something) - (when (and (not (block-delete-p (node-block node))) - (combination-p node) - (eq (basic-combination-kind node) :known)) - (let* ((fun-ref (lvar-use (combination-fun node))) - (fun-name (leaf-source-name (ref-leaf fun-ref))) - (modular-fun (find-modular-version fun-name class width))) - (when (and modular-fun - (not (and (eq fun-name 'logand) - (csubtypep - (single-value-type (node-derived-type node)) - type)))) - (binding* ((name (etypecase modular-fun - ((eql :good) fun-name) - (modular-fun-info - (modular-fun-info-name modular-fun)) - (function - (funcall modular-fun node width))) - :exit-if-null)) - (unless (eql modular-fun :good) - (setq did-something t) - (change-ref-leaf - fun-ref - (find-free-fun name "in a strange place")) - (setf (combination-kind node) :full)) - (unless (functionp modular-fun) - (dolist (arg (basic-combination-args node)) - (when (cut-lvar arg) - (setq did-something t)))) - (when did-something - (reoptimize-node node name)) - did-something))))) - (cut-lvar (lvar &aux did-something) + "Try to cut a node to width. The primary return value is + whether we managed to cut (cleverly), and the second whether + anything was changed." + (when (block-delete-p (node-block node)) + (return-from cut-node (values t nil))) + (typecase node + (ref + (typecase (ref-leaf node) + (constant + (let* ((constant-value (constant-value (ref-leaf node))) + (new-value (if signedp + (mask-signed-field width constant-value) + (ldb (byte width 0) constant-value)))) + (cond ((= constant-value new-value) + (values t nil)) ; we knew what to do and did nothing + (t + (change-ref-leaf node (make-constant new-value) + :recklessly t) + (let ((lvar (node-lvar node))) + (setf (lvar-%derived-type lvar) + (and (lvar-has-single-use-p lvar) + (make-values-type :required (list (ctype-of new-value)))))) + (setf (block-reoptimize (node-block node)) t) + (reoptimize-component (node-component node) :maybe) + (values t t))))))) + (combination + (when (eq (basic-combination-kind node) :known) + (let* ((fun-ref (lvar-use (combination-fun node))) + (fun-name (lvar-fun-name (combination-fun node))) + (modular-fun (find-modular-version fun-name kind + signedp width))) + (when (and modular-fun + (not (and (eq fun-name 'logand) + (csubtypep + (single-value-type (node-derived-type node)) + type)))) + (binding* ((name (etypecase modular-fun + ((eql :good) fun-name) + (modular-fun-info + (modular-fun-info-name modular-fun)) + (function + (funcall modular-fun node width))) + :exit-if-null)) + (unless (eql modular-fun :good) + (setq did-something t) + (change-ref-leaf + fun-ref + (find-free-fun name "in a strange place")) + (setf (combination-kind node) :full)) + (unless (functionp modular-fun) + (dolist (arg (basic-combination-args node)) + (when (cut-lvar arg) + (setq did-something t)))) + (when did-something + (reoptimize-node node name)) + (values t did-something)))))))) + (cut-lvar (lvar &aux did-something must-insert) + "Cut all the LVAR's use nodes. If any of them wasn't handled + and its type is too wide for the operation we wish to perform + insert an explicit bit-width narrowing operation (LOGAND or + MASK-SIGNED-FIELD) between the LVAR (*) and its destination. + The narrowing operation might not be inserted if the LVAR's + destination is already such an operation, to avoid endless + recursion. + + (*) We can't easily do that for each node, and doing so might + result in code bloat, anyway. (I'm also not sure it would be + correct for complicated C/D FG)" (do-uses (node lvar) - (when (cut-node node) - (setq did-something t))) + (multiple-value-bind (handled any-change) + (cut-node node) + (setf did-something (or did-something any-change) + must-insert (or must-insert + (not (or handled + (csubtypep (single-value-type + (node-derived-type node)) + type))))))) + (when must-insert + (setf did-something (or (insert-lvar-cut lvar) did-something))) did-something)) (cut-lvar lvar)))) +(defun best-modular-version (width signedp) + ;; 1. exact width-matched :untagged + ;; 2. >/>= width-matched :tagged + ;; 3. >/>= width-matched :untagged + (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*)) + (uswidths (modular-class-widths *untagged-signed-modular-class*)) + (uwidths (merge 'list uuwidths uswidths #'< :key #'car)) + (twidths (modular-class-widths *tagged-modular-class*))) + (let ((exact (find (cons width signedp) uwidths :test #'equal))) + (when exact + (return-from best-modular-version (values width :untagged signedp)))) + (flet ((inexact-match (w) + (cond + ((eq signedp (cdr w)) (<= width (car w))) + ((eq signedp nil) (< width (car w)))))) + (let ((tgt (find-if #'inexact-match twidths))) + (when tgt + (return-from best-modular-version + (values (car tgt) :tagged (cdr tgt))))) + (let ((ugt (find-if #'inexact-match uwidths))) + (when ugt + (return-from best-modular-version + (values (car ugt) :untagged (cdr ugt)))))))) + +(defun integer-type-numeric-bounds (type) + (typecase type + (numeric-type (values (numeric-type-low type) + (numeric-type-high type))) + (union-type + (let ((low nil) + (high nil)) + (dolist (type (union-type-types type) (values low high)) + (unless (and (numeric-type-p type) + (eql (numeric-type-class type) 'integer)) + (return (values nil nil))) + (let ((this-low (numeric-type-low type)) + (this-high (numeric-type-high type))) + (setf low (min this-low (or low this-low)) + high (max this-high (or high this-high))))))))) + (defoptimizer (logand optimizer) ((x y) node) (let ((result-type (single-value-type (node-derived-type node)))) - (when (numeric-type-p result-type) - (let ((low (numeric-type-low result-type)) - (high (numeric-type-high result-type))) - (when (and (numberp low) - (numberp high) - (>= low 0)) - (let ((width (integer-length high))) - (when (some (lambda (x) (<= width x)) - (modular-class-widths *unsigned-modular-class*)) - ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH). - (cut-to-width x :unsigned width) - (cut-to-width y :unsigned width) - nil ; After fixing above, replace with T. + (multiple-value-bind (low high) + (integer-type-numeric-bounds result-type) + (when (and (numberp low) + (numberp high) + (>= low 0)) + (let ((width (integer-length high))) + (multiple-value-bind (w kind signedp) + (best-modular-version width nil) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP). + ;; + ;; FIXME: I think the FIXME (which is from APD) above + ;; implies that CUT-TO-WIDTH should do /everything/ + ;; that's required, including reoptimizing things + ;; itself that it knows are necessary. At the moment, + ;; CUT-TO-WIDTH sets up some new calls with + ;; combination-type :FULL, which later get noticed as + ;; known functions and properly converted. + ;; + ;; We cut to W not WIDTH if SIGNEDP is true, because + ;; signed constant replacement needs to know which bit + ;; in the field is the signed bit. + (let ((xact (cut-to-width x kind (if signedp w width) signedp)) + (yact (cut-to-width y kind (if signedp w width) signedp))) + (declare (ignore xact yact)) + nil) ; After fixing above, replace with T, meaning + ; "don't reoptimize this (LOGAND) node any more". ))))))) (defoptimizer (mask-signed-field optimizer) ((width x) node) (let ((result-type (single-value-type (node-derived-type node)))) - (when (numeric-type-p result-type) - (let ((low (numeric-type-low result-type)) - (high (numeric-type-high result-type))) - (when (and (numberp low) (numberp high)) - (let ((width (max (integer-length high) (integer-length low)))) - (when (some (lambda (x) (<= width x)) - (modular-class-widths *signed-modular-class*)) - ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH). - (cut-to-width x :signed width) - nil ; After fixing above, replace with T. + (multiple-value-bind (low high) + (integer-type-numeric-bounds result-type) + (when (and (numberp low) (numberp high)) + (let ((width (max (integer-length high) (integer-length low)))) + (multiple-value-bind (w kind) + (best-modular-version (1+ width) t) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T). + ;; [ see comment above in LOGAND optimizer ] + (cut-to-width x kind w t) + nil ; After fixing above, replace with T. + ))))))) + +(defoptimizer (logior optimizer) ((x y) node) + (let ((result-type (single-value-type (node-derived-type node)))) + (multiple-value-bind (low high) + (integer-type-numeric-bounds result-type) + (when (and (numberp low) + (numberp high) + (<= high 0)) + (let ((width (integer-length low))) + (multiple-value-bind (w kind) + (best-modular-version (1+ width) t) + (when w + ;; FIXME: see comment in LOGAND optimizer + (let ((xact (cut-to-width x kind w t)) + (yact (cut-to-width y kind w t))) + (declare (ignore xact yact)) + nil) ; After fixing above, replace with T ))))))) ;;; miscellanous numeric transforms @@ -2899,11 +3149,11 @@ (if (and (constant-lvar-p x) (not (constant-lvar-p y))) `(,(lvar-fun-name (basic-combination-fun node)) - y + (truly-the ,(lvar-type y) y) ,(lvar-value x)) (give-up-ir1-transform))) -(dolist (x '(= char= + * logior logand logxor)) +(dolist (x '(= char= + * logior logand logxor logtest)) (%deftransform x '(function * *) #'commutative-arg-swap "place constant arg last")) @@ -2950,6 +3200,15 @@ `(- (ash x ,len)) `(ash x ,len)))) +;;; These must come before the ones below, so that they are tried +;;; first. Since %FLOOR and %CEILING are inlined, this allows +;;; the general case to be handled by TRUNCATE transforms. +(deftransform floor ((x y)) + `(%floor x y)) + +(deftransform ceiling ((x y)) + `(%ceiling x y)) + ;;; If arg is a constant power of two, turn FLOOR into a shift and ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a ;;; remainder. @@ -3028,6 +3287,113 @@ `(if (minusp x) (- (logand (- x) ,mask)) (logand x ,mask))))) + +;;; Return an expression to calculate the integer quotient of X and +;;; constant Y, using multiplication, shift and add/sub instead of +;;; division. Both arguments must be unsigned, fit in a machine word and +;;; Y must neither be zero nor a power of two. The quotient is rounded +;;; towards zero. +;;; The algorithm is taken from the paper "Division by Invariant +;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and +;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the +;;; case of division by powers of two. +;;; The algorithm includes an adaptive precision argument. Use it, since +;;; we often have sub-word value ranges. Careful, in this case, we need +;;; p s.t 2^p > n, not the ceiling of the binary log. +;;; Also, for some reason, the paper prefers shifting to masking. Mask +;;; instead. Masking is equivalent to shifting right, then left again; +;;; all the intermediate values are still words, so we just have to shift +;;; right a bit more to compensate, at the end. +;;; +;;; The following two examples show an average case and the worst case +;;; with respect to the complexity of the generated expression, under +;;; a word size of 64 bits: +;;; +;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) -> +;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3) +;;; +;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) -> +;;; (LET* ((NUM X) +;;; (T1 (%MULTIPLY NUM 2635249153387078803))) +;;; (ASH (LDB (BYTE 64 0) +;;; (+ T1 (ASH (LDB (BYTE 64 0) +;;; (- NUM T1)) +;;; -1))) +;;; -2)) +;;; +(defun gen-unsigned-div-by-constant-expr (y max-x) + (declare (type (integer 3 #.most-positive-word) y) + (type word max-x)) + (aver (not (zerop (logand y (1- y))))) + (labels ((ld (x) + ;; the floor of the binary logarithm of (positive) X + (integer-length (1- x))) + (choose-multiplier (y precision) + (do* ((l (ld y)) + (shift l (1- shift)) + (expt-2-n+l (expt 2 (+ sb!vm:n-word-bits l))) + (m-low (truncate expt-2-n+l y) (ash m-low -1)) + (m-high (truncate (+ expt-2-n+l + (ash expt-2-n+l (- precision))) + y) + (ash m-high -1))) + ((not (and (< (ash m-low -1) (ash m-high -1)) + (> shift 0))) + (values m-high shift))))) + (let ((n (expt 2 sb!vm:n-word-bits)) + (precision (integer-length max-x)) + (shift1 0)) + (multiple-value-bind (m shift2) + (choose-multiplier y precision) + (when (and (>= m n) (evenp y)) + (setq shift1 (ld (logand y (- y)))) + (multiple-value-setq (m shift2) + (choose-multiplier (/ y (ash 1 shift1)) + (- precision shift1)))) + (cond ((>= m n) + (flet ((word (x) + `(truly-the word ,x))) + `(let* ((num x) + (t1 (%multiply-high num ,(- m n)))) + (ash ,(word `(+ t1 (ash ,(word `(- num t1)) + -1))) + ,(- 1 shift2))))) + ((and (zerop shift1) (zerop shift2)) + (let ((max (truncate max-x y))) + ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM + ;; VOP. + `(truly-the (integer 0 ,max) + (%multiply-high x ,m)))) + (t + `(ash (%multiply-high (logandc2 x ,(1- (ash 1 shift1))) ,m) + ,(- (+ shift1 shift2))))))))) + +;;; If the divisor is constant and both args are positive and fit in a +;;; machine word, replace the division by a multiplication and possibly +;;; some shifts and an addition. Calculate the remainder by a second +;;; multiplication and a subtraction. Dead code elimination will +;;; suppress the latter part if only the quotient is needed. If the type +;;; of the dividend allows to derive that the quotient will always have +;;; the same value, emit much simpler code to handle that. (This case +;;; may be rare but it's easy to detect and the compiler doesn't find +;;; this optimization on its own.) +(deftransform truncate ((x y) (word (constant-arg word)) + * + :policy (and (> speed compilation-speed) + (> speed space))) + "convert integer division to multiplication" + (let* ((y (lvar-value y)) + (x-type (lvar-type x)) + (max-x (or (and (numeric-type-p x-type) + (numeric-type-high x-type)) + most-positive-word))) + ;; Division by zero, one or powers of two is handled elsewhere. + (when (zerop (logand y (1- y))) + (give-up-ir1-transform)) + `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x)) + (rem (ldb (byte #.sb!vm:n-word-bits 0) + (- x (* quot ,y))))) + (values quot rem)))) ;;;; arithmetic and logical identity operation elimination @@ -3045,14 +3411,17 @@ (def logxor -1 (lognot x)) (def logxor 0 x)) +(defun least-zero-bit (x) + (and (/= x -1) + (1- (integer-length (logxor x (1+ x)))))) + (deftransform logand ((x y) (* (constant-arg t)) *) "fold identity operation" - (let ((y (lvar-value y))) - (unless (and (plusp y) - (= y (1- (ash 1 (integer-length y))))) - (give-up-ir1-transform)) - (unless (csubtypep (lvar-type x) - (specifier-type `(integer 0 ,y))) + (let* ((y (lvar-value y)) + (width (or (least-zero-bit y) '*))) + (unless (and (neq width 0) ; (logand x 0) handled elsewhere + (csubtypep (lvar-type x) + (specifier-type `(unsigned-byte ,width)))) (give-up-ir1-transform)) 'x)) @@ -3063,6 +3432,74 @@ (give-up-ir1-transform)) 'x)) +(deftransform logior ((x y) (* (constant-arg t)) *) + "fold identity operation" + (let* ((y (lvar-value y)) + (width (or (least-zero-bit (lognot y)) + (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere + (unless (csubtypep (lvar-type x) + (specifier-type `(integer ,(- (ash 1 width)) -1))) + (give-up-ir1-transform)) + 'x)) + +;;; Pick off easy association opportunities for constant folding. +;;; More complicated stuff that also depends on commutativity +;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should +;;; probably be handled with a more general tree-rewriting pass. +(macrolet ((def (operator &key (type 'integer) (folded operator)) + `(deftransform ,operator ((x z) (,type (constant-arg ,type))) + ,(format nil "associate ~A/~A of constants" + operator folded) + (binding* ((node (if (lvar-has-single-use-p x) + (lvar-use x) + (give-up-ir1-transform))) + (nil (or (and (combination-p node) + (eq (lvar-fun-name + (combination-fun node)) + ',folded)) + (give-up-ir1-transform))) + (y (second (combination-args node))) + (nil (or (constant-lvar-p y) + (give-up-ir1-transform))) + (y (lvar-value y))) + (unless (typep y ',type) + (give-up-ir1-transform)) + (splice-fun-args x ',folded 2) + `(lambda (x y z) + (declare (ignore y z)) + ;; (operator (folded x y) z) + ;; == (operator x (folded z y)) + (,',operator x ',(,folded (lvar-value z) y))))))) + (def logand) + (def logior) + (def logxor) + (def logtest :folded logand) + (def + :type rational) + (def + :type rational :folded -) + (def * :type rational) + (def * :type rational :folded /)) + +(deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *)) + "Fold mask-signed-field/mask-signed-field of constant width" + (binding* ((node (if (lvar-has-single-use-p x) + (lvar-use x) + (give-up-ir1-transform))) + (nil (or (combination-p node) + (give-up-ir1-transform))) + (nil (or (eq (lvar-fun-name (combination-fun node)) + 'mask-signed-field) + (give-up-ir1-transform))) + (x-width (first (combination-args node))) + (nil (or (constant-lvar-p x-width) + (give-up-ir1-transform))) + (x-width (lvar-value x-width))) + (unless (typep x-width 'unsigned-byte) + (give-up-ir1-transform)) + (splice-fun-args x 'mask-signed-field 2) + `(lambda (width x-width x) + (declare (ignore width x-width)) + (mask-signed-field ,(min (lvar-value width) x-width) x)))) + ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and ;;; (* 0 -4.0) is -0.0. (deftransform - ((x y) ((constant-arg (member 0)) rational) *) @@ -3072,6 +3509,25 @@ "convert (* x 0) to 0" 0) +(deftransform %negate ((x) (rational)) + "Eliminate %negate/%negate of rationals" + (splice-fun-args x '%negate 1) + '(the rational x)) + +(deftransform %negate ((x) (number)) + "Combine %negate/*" + (let ((use (lvar-uses x)) + arg) + (unless (and (combination-p use) + (eql '* (lvar-fun-name (combination-fun use))) + (constant-lvar-p (setf arg (second (combination-args use)))) + (numberp (setf arg (lvar-value arg)))) + (give-up-ir1-transform)) + (splice-fun-args x '* 2) + `(lambda (x y) + (declare (ignore y)) + (* x ,(- arg))))) + ;;; Return T if in an arithmetic op including lvars X and Y, the ;;; result type is not affected by the type of X. That is, Y is at ;;; least as contagious as X. @@ -3106,41 +3562,32 @@ (values (type= (numeric-contagion x y) (numeric-contagion y y))))))) +(def!type exact-number () + '(or rational (complex rational))) + ;;; Fold (+ x 0). ;;; -;;; If y is not constant, not zerop, or is contagious, or a positive -;;; float +0.0 then give up. -(deftransform + ((x y) (t (constant-arg t)) *) +;;; Only safely applicable for exact numbers. For floating-point +;;; x, one would have to first show that neither x or y are signed +;;; 0s, and that x isn't an SNaN. +(deftransform + ((x y) (exact-number (constant-arg (eql 0))) *) "fold zero arg" - (let ((val (lvar-value y))) - (unless (and (zerop val) - (not (and (floatp val) (plusp (float-sign val)))) - (not-more-contagious y x)) - (give-up-ir1-transform))) 'x) ;;; Fold (- x 0). -;;; -;;; If y is not constant, not zerop, or is contagious, or a negative -;;; float -0.0 then give up. -(deftransform - ((x y) (t (constant-arg t)) *) +(deftransform - ((x y) (exact-number (constant-arg (eql 0))) *) "fold zero arg" - (let ((val (lvar-value y))) - (unless (and (zerop val) - (not (and (floatp val) (minusp (float-sign val)))) - (not-more-contagious y x)) - (give-up-ir1-transform))) 'x) ;;; Fold (OP x +/-1) -(macrolet ((def (name result minus-result) - `(deftransform ,name ((x y) (t (constant-arg real)) *) - "fold identity operations" - (let ((val (lvar-value y))) - (unless (and (= (abs val) 1) - (not-more-contagious y x)) - (give-up-ir1-transform)) - (if (minusp val) ',minus-result ',result))))) +;;; +;;; %NEGATE might not always signal correctly. +(macrolet + ((def (name result minus-result) + `(deftransform ,name ((x y) + (exact-number (constant-arg (member 1 -1)))) + "fold identity operations" + (if (minusp (lvar-value y)) ',minus-result ',result)))) (def * x (%negate x)) (def / x (%negate x)) (def expt x (/ 1 x))) @@ -3177,6 +3624,15 @@ ((= val -1/2) '(/ (sqrt x))) (t (give-up-ir1-transform))))) +(deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *) + "recode as an ODDP check" + (let ((val (lvar-value x))) + (if (eql -1 val) + '(- 1 (* 2 (logand 1 y))) + `(if (oddp y) + ,val + ,(abs val))))) + ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these ;;; transformations? ;;; Perhaps we should have to prove that the denominator is nonzero before @@ -3198,6 +3654,24 @@ (def round) (def floor) (def ceiling)) + +(macrolet ((def (name &optional float) + (let ((x (if float '(float x) 'x))) + `(deftransform ,name ((x y) (integer (constant-arg (member 1 -1))) + *) + "fold division by 1" + `(values ,(if (minusp (lvar-value y)) + '(%negate ,x) + ',x) 0))))) + (def truncate) + (def round) + (def floor) + (def ceiling) + (def ftruncate t) + (def fround t) + (def ffloor t) + (def fceiling t)) + ;;;; character operations @@ -3287,9 +3761,7 @@ (let ((x-type (lvar-type x)) (y-type (lvar-type y)) (char-type (specifier-type 'character))) - (flet ((simple-type-p (type) - (csubtypep type (specifier-type '(or fixnum (not number))))) - (fixnum-type-p (type) + (flet ((fixnum-type-p (type) (csubtypep type (specifier-type 'fixnum)))) (cond ((same-leaf-ref-p x y) t) @@ -3298,10 +3770,10 @@ ((and (csubtypep x-type char-type) (csubtypep y-type char-type)) '(char= x y)) - ((or (fixnum-type-p x-type) (fixnum-type-p y-type)) - (commutative-arg-swap node)) - ((or (simple-type-p x-type) (simple-type-p y-type)) - '(eq x y)) + ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type)) + (if (and (constant-lvar-p x) (not (constant-lvar-p y))) + '(eq y x) + '(eq x y))) ((and (not (constant-lvar-p y)) (or (constant-lvar-p x) (and (csubtypep x-type y-type) @@ -3339,41 +3811,54 @@ ;;; Convert to EQL if both args are rational and complexp is specified ;;; and the same for both. -(deftransform = ((x y) * *) +(deftransform = ((x y) (number number) *) "open code" (let ((x-type (lvar-type x)) (y-type (lvar-type y))) - (if (and (csubtypep x-type (specifier-type 'number)) - (csubtypep y-type (specifier-type 'number))) - (cond ((or (and (csubtypep x-type (specifier-type 'float)) - (csubtypep y-type (specifier-type 'float))) - (and (csubtypep x-type (specifier-type '(complex float))) - (csubtypep y-type (specifier-type '(complex float))))) - ;; They are both floats. Leave as = so that -0.0 is - ;; handled correctly. - (give-up-ir1-transform)) - ((or (and (csubtypep x-type (specifier-type 'rational)) - (csubtypep y-type (specifier-type 'rational))) - (and (csubtypep x-type - (specifier-type '(complex rational))) - (csubtypep y-type - (specifier-type '(complex rational))))) - ;; They are both rationals and complexp is the same. - ;; Convert to EQL. - '(eql x y)) - (t - (give-up-ir1-transform - "The operands might not be the same type."))) - (give-up-ir1-transform - "The operands might not be the same type.")))) - -;;; If LVAR's type is a numeric type, then return the type, otherwise -;;; GIVE-UP-IR1-TRANSFORM. -(defun numeric-type-or-lose (lvar) - (declare (type lvar lvar)) - (let ((res (lvar-type lvar))) - (unless (numeric-type-p res) (give-up-ir1-transform)) - res)) + (cond ((or (and (csubtypep x-type (specifier-type 'float)) + (csubtypep y-type (specifier-type 'float))) + (and (csubtypep x-type (specifier-type '(complex float))) + (csubtypep y-type (specifier-type '(complex float)))) + #!+complex-float-vops + (and (csubtypep x-type (specifier-type '(or single-float (complex single-float)))) + (csubtypep y-type (specifier-type '(or single-float (complex single-float))))) + #!+complex-float-vops + (and (csubtypep x-type (specifier-type '(or double-float (complex double-float)))) + (csubtypep y-type (specifier-type '(or double-float (complex double-float)))))) + ;; They are both floats. Leave as = so that -0.0 is + ;; handled correctly. + (give-up-ir1-transform)) + ((or (and (csubtypep x-type (specifier-type 'rational)) + (csubtypep y-type (specifier-type 'rational))) + (and (csubtypep x-type + (specifier-type '(complex rational))) + (csubtypep y-type + (specifier-type '(complex rational))))) + ;; They are both rationals and complexp is the same. + ;; Convert to EQL. + '(eql x y)) + (t + (give-up-ir1-transform + "The operands might not be the same type."))))) + +(defun maybe-float-lvar-p (lvar) + (neq *empty-type* (type-intersection (specifier-type 'float) + (lvar-type lvar)))) + +(flet ((maybe-invert (node op inverted x y) + ;; Don't invert if either argument can be a float (NaNs) + (cond + ((or (maybe-float-lvar-p x) (maybe-float-lvar-p y)) + (delay-ir1-transform node :constraint) + `(or (,op x y) (= x y))) + (t + `(if (,inverted x y) nil t))))) + (deftransform >= ((x y) (number number) * :node node) + "invert or open code" + (maybe-invert node '> '< x y)) + (deftransform <= ((x y) (number number) * :node node) + "invert or open code" + (maybe-invert node '< '> x y))) ;;; See whether we can statically determine (< X Y) using type ;;; information. If X's high bound is < Y's low, then X < Y. @@ -3381,7 +3866,14 @@ ;;; NIL). If not, at least make sure any constant arg is second. (macrolet ((def (name inverse reflexive-p surely-true surely-false) `(deftransform ,name ((x y)) - (if (same-leaf-ref-p x y) + "optimize using intervals" + (if (and (same-leaf-ref-p x y) + ;; For non-reflexive functions we don't need + ;; to worry about NaNs: (non-ref-op NaN NaN) => false, + ;; but with reflexive ones we don't know... + ,@(when reflexive-p + '((and (not (maybe-float-lvar-p x)) + (not (maybe-float-lvar-p y)))))) ,reflexive-p (let ((ix (or (type-approximate-interval (lvar-type x)) (give-up-ir1-transform))) @@ -3396,6 +3888,8 @@ `(,',inverse y x)) (t (give-up-ir1-transform)))))))) + (def = = t (interval-= ix iy) (interval-/= ix iy)) + (def /= /= nil (interval-/= ix iy) (interval-= ix iy)) (def < > nil (interval-< ix iy) (interval->= ix iy)) (def > < nil (interval-< iy ix) (interval->= iy ix)) (def <= >= t (interval->= iy ix) (interval-< iy ix)) @@ -3434,15 +3928,16 @@ ;;; negated test as appropriate. If it is a degenerate one-arg call, ;;; then we transform to code that returns true. Otherwise, we bind ;;; all the arguments and expand into a bunch of IFs. -(declaim (ftype (function (symbol list boolean t) *) multi-compare)) -(defun multi-compare (predicate args not-p type) +(defun multi-compare (predicate args not-p type &optional force-two-arg-p) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) ((= nargs 1) `(progn (the ,type ,@args) t)) ((= nargs 2) (if not-p `(if (,predicate ,(first args) ,(second args)) nil t) - (values nil t))) + (if force-two-arg-p + `(,predicate ,(first args) ,(second args)) + (values nil t)))) (t (do* ((i (1- nargs) (1- i)) (last nil current) @@ -3460,8 +3955,13 @@ (define-source-transform = (&rest args) (multi-compare '= args nil 'number)) (define-source-transform < (&rest args) (multi-compare '< args nil 'real)) (define-source-transform > (&rest args) (multi-compare '> args nil 'real)) -(define-source-transform <= (&rest args) (multi-compare '> args t 'real)) -(define-source-transform >= (&rest args) (multi-compare '< args t 'real)) +;;; We cannot do the inversion for >= and <= here, since both +;;; (< NaN X) and (> NaN X) +;;; are false, and we don't have type-information available yet. The +;;; deftransforms for two-argument versions of >= and <= takes care of +;;; the inversion to > and < when possible. +(define-source-transform <= (&rest args) (multi-compare '<= args nil 'real)) +(define-source-transform >= (&rest args) (multi-compare '>= args nil 'real)) (define-source-transform char= (&rest args) (multi-compare 'char= args nil 'character)) @@ -3475,15 +3975,15 @@ 'character)) (define-source-transform char-equal (&rest args) - (multi-compare 'char-equal args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t)) (define-source-transform char-lessp (&rest args) - (multi-compare 'char-lessp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t)) (define-source-transform char-greaterp (&rest args) - (multi-compare 'char-greaterp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t)) (define-source-transform char-not-greaterp (&rest args) - (multi-compare 'char-greaterp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t)) (define-source-transform char-not-lessp (&rest args) - (multi-compare 'char-lessp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t)) ;;; This function does source transformation of N-arg inequality ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3 @@ -3539,34 +4039,57 @@ ;;;; versions, and degenerate cases are flushed. ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION. -(declaim (ftype (function (symbol t list) list) associate-args)) -(defun associate-args (function first-arg more-args) +(declaim (ftype (sfunction (symbol t list t) list) associate-args)) +(defun associate-args (fun first-arg more-args identity) (let ((next (rest more-args)) (arg (first more-args))) (if (null next) - `(,function ,first-arg ,arg) - (associate-args function `(,function ,first-arg ,arg) next)))) + `(,fun ,first-arg ,(if arg arg identity)) + (associate-args fun `(,fun ,first-arg ,arg) next identity)))) + +;;; Reduce constants in ARGS list. +(declaim (ftype (sfunction (symbol list t symbol) list) reduce-constants)) +(defun reduce-constants (fun args identity one-arg-result-type) + (let ((one-arg-constant-p (ecase one-arg-result-type + (number #'numberp) + (integer #'integerp))) + (reduced-value identity) + (reduced-p nil)) + (collect ((not-constants)) + (dolist (arg args) + (if (funcall one-arg-constant-p arg) + (setf reduced-value (funcall fun reduced-value arg) + reduced-p t) + (not-constants arg))) + ;; It is tempting to drop constants reduced to identity here, + ;; but if X is SNaN in (* X 1), we cannot drop the 1. + (if (not-constants) + (if reduced-p + `(,reduced-value ,@(not-constants)) + (not-constants)) + `(,reduced-value))))) ;;; Do source transformations for transitive functions such as +. ;;; One-arg cases are replaced with the arg and zero arg cases with -;;; the identity. ONE-ARG-RESULT-TYPE is, if non-NIL, the type to -;;; ensure (with THE) that the argument in one-argument calls is. +;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE) +;;; that the argument in one-argument calls is. +(declaim (ftype (function (symbol list t &optional symbol list) + (values t &optional (member nil t))) + source-transform-transitive)) (defun source-transform-transitive (fun args identity - &optional one-arg-result-type) - (declare (symbol fun) (list args)) + &optional (one-arg-result-type 'number) + (one-arg-prefixes '(values))) (case (length args) (0 identity) - (1 (if one-arg-result-type - `(values (the ,one-arg-result-type ,(first args))) - `(values ,(first args)))) + (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) (2 (values nil t)) - (t - (associate-args fun (first args) (rest args))))) + (t (let ((reduced-args (reduce-constants fun args identity one-arg-result-type))) + (associate-args fun (first reduced-args) (rest reduced-args) identity))))) (define-source-transform + (&rest args) - (source-transform-transitive '+ args 0 'number)) + (source-transform-transitive '+ args 0)) (define-source-transform * (&rest args) - (source-transform-transitive '* args 1 'number)) + (source-transform-transitive '* args 1)) (define-source-transform logior (&rest args) (source-transform-transitive 'logior args 0 'integer)) (define-source-transform logxor (&rest args) @@ -3575,41 +4098,30 @@ (source-transform-transitive 'logand args -1 'integer)) (define-source-transform logeqv (&rest args) (source-transform-transitive 'logeqv args -1 'integer)) - -;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM -;;; because when they are given one argument, they return its absolute -;;; value. - (define-source-transform gcd (&rest args) - (case (length args) - (0 0) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-args 'gcd (first args) (rest args))))) - + (source-transform-transitive 'gcd args 0 'integer '(abs))) (define-source-transform lcm (&rest args) - (case (length args) - (0 1) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-args 'lcm (first args) (rest args))))) + (source-transform-transitive 'lcm args 1 'integer '(abs))) ;;; Do source transformations for intransitive n-arg functions such as ;;; /. With one arg, we form the inverse. With two args we pass. ;;; Otherwise we associate into two-arg calls. -(declaim (ftype (function (symbol list t) +(declaim (ftype (function (symbol symbol list t list &optional symbol) (values list &optional (member nil t))) source-transform-intransitive)) -(defun source-transform-intransitive (function args inverse) +(defun source-transform-intransitive (fun fun* args identity one-arg-prefixes + &optional (one-arg-result-type 'number)) (case (length args) ((0 2) (values nil t)) - (1 `(,@inverse ,(first args))) - (t (associate-args function (first args) (rest args))))) + (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) + (t (let ((reduced-args + (reduce-constants fun* (rest args) identity one-arg-result-type))) + (associate-args fun (first args) reduced-args identity))))) (define-source-transform - (&rest args) - (source-transform-intransitive '- args '(%negate))) + (source-transform-intransitive '- '+ args 0 '(%negate))) (define-source-transform / (&rest args) - (source-transform-intransitive '/ args '(/ 1))) + (source-transform-intransitive '/ '* args 1 '(/ 1))) ;;;; transforming APPLY @@ -3619,10 +4131,168 @@ (define-source-transform apply (fun arg &rest more-args) (let ((args (cons arg more-args))) `(multiple-value-call ,fun - ,@(mapcar (lambda (x) - `(values ,x)) - (butlast args)) + ,@(mapcar (lambda (x) `(values ,x)) (butlast args)) (values-list ,(car (last args)))))) + +;;;; transforming references to &REST argument + +;;; We add magical &MORE arguments to all functions with &REST. If ARG names +;;; the &REST argument, this returns the lambda-vars for the context and +;;; count. +(defun possible-rest-arg-context (arg) + (when (symbolp arg) + (let* ((var (lexenv-find arg vars)) + (info (when (lambda-var-p var) + (lambda-var-arg-info var)))) + (when (and info + (eq :rest (arg-info-kind info)) + (consp (arg-info-default info))) + (values-list (arg-info-default info)))))) + +(defun mark-more-context-used (rest-var) + (let ((info (lambda-var-arg-info rest-var))) + (aver (eq :rest (arg-info-kind info))) + (destructuring-bind (context count &optional used) (arg-info-default info) + (unless used + (setf (arg-info-default info) (list context count t)))))) + +(defun mark-more-context-invalid (rest-var) + (let ((info (lambda-var-arg-info rest-var))) + (aver (eq :rest (arg-info-kind info))) + (setf (arg-info-default info) t))) + +;;; This determines of we the REF to a &REST variable is headed towards +;;; parts unknown, or if we can really use the context. +(defun rest-var-more-context-ok (lvar) + (let* ((use (lvar-use lvar)) + (var (when (ref-p use) (ref-leaf use))) + (home (when (lambda-var-p var) (lambda-var-home var))) + (info (when (lambda-var-p var) (lambda-var-arg-info var))) + (restp (when info (eq :rest (arg-info-kind info))))) + (flet ((ref-good-for-more-context-p (ref) + (let ((dest (principal-lvar-end (node-lvar ref)))) + (and (combination-p dest) + ;; If the destination is to anything but these, we're going to + ;; actually need the rest list -- and since other operations + ;; might modify the list destructively, the using the context + ;; isn't good anywhere else either. + (lvar-fun-is (combination-fun dest) + '(%rest-values %rest-ref %rest-length + %rest-null %rest-true)) + ;; If the home lambda is different and isn't DX, it might + ;; escape -- in which case using the more context isn't safe. + (let ((clambda (node-home-lambda dest))) + (or (eq home clambda) + (leaf-dynamic-extent clambda))))))) + (let ((ok (and restp + (consp (arg-info-default info)) + (not (lambda-var-specvar var)) + (not (lambda-var-sets var)) + (every #'ref-good-for-more-context-p (lambda-var-refs var))))) + (if ok + (mark-more-context-used var) + (when restp + (mark-more-context-invalid var))) + ok)))) + +;;; VALUES-LIST -> %REST-VALUES +(define-source-transform values-list (list) + (multiple-value-bind (context count) (possible-rest-arg-context list) + (if context + `(%rest-values ,list ,context ,count) + (values nil t)))) + +;;; NTH -> %REST-REF +(define-source-transform nth (n list) + (multiple-value-bind (context count) (possible-rest-arg-context list) + (if context + `(%rest-ref ,n ,list ,context ,count) + `(car (nthcdr ,n ,list))))) + +(define-source-transform elt (seq n) + (if (policy *lexenv* (= safety 3)) + (values nil t) + (multiple-value-bind (context count) (possible-rest-arg-context seq) + (if context + `(%rest-ref ,n ,seq ,context ,count) + (values nil t))))) + +;;; CAxR -> %REST-REF +(defun source-transform-car (list nth) + (multiple-value-bind (context count) (possible-rest-arg-context list) + (if context + `(%rest-ref ,nth ,list ,context ,count) + (values nil t)))) + +(define-source-transform car (list) + (source-transform-car list 0)) + +(define-source-transform cadr (list) + (or (source-transform-car list 1) + `(car (cdr ,list)))) + +(define-source-transform caddr (list) + (or (source-transform-car list 2) + `(car (cdr (cdr ,list))))) + +(define-source-transform cadddr (list) + (or (source-transform-car list 3) + `(car (cdr (cdr (cdr ,list)))))) + +;;; LENGTH -> %REST-LENGTH +(defun source-transform-length (list) + (multiple-value-bind (context count) (possible-rest-arg-context list) + (if context + `(%rest-length ,list ,context ,count) + (values nil t)))) +(define-source-transform length (list) (source-transform-length list)) +(define-source-transform list-length (list) (source-transform-length list)) + +;;; ENDP, NULL and NOT -> %REST-NULL +;;; +;;; Outside &REST convert into an IF so that IF optimizations will eliminate +;;; redundant negations. +(defun source-transform-null (x op) + (multiple-value-bind (context count) (possible-rest-arg-context x) + (cond (context + `(%rest-null ',op ,x ,context ,count)) + ((eq 'endp op) + `(if (the list ,x) nil t)) + (t + `(if ,x nil t))))) +(define-source-transform not (x) (source-transform-null x 'not)) +(define-source-transform null (x) (source-transform-null x 'null)) +(define-source-transform endp (x) (source-transform-null x 'endp)) + +(deftransform %rest-values ((list context count)) + (if (rest-var-more-context-ok list) + `(%more-arg-values context 0 count) + `(values-list list))) + +(deftransform %rest-ref ((n list context count)) + (cond ((rest-var-more-context-ok list) + `(and (< (the index n) count) + (%more-arg context n))) + ((and (constant-lvar-p n) (zerop (lvar-value n))) + `(car list)) + (t + `(nth n list)))) + +(deftransform %rest-length ((list context count)) + (if (rest-var-more-context-ok list) + 'count + `(length list))) + +(deftransform %rest-null ((op list context count)) + (aver (constant-lvar-p op)) + (if (rest-var-more-context-ok list) + `(eql 0 count) + `(,(lvar-value op) list))) + +(deftransform %rest-true ((list context count)) + (if (rest-var-more-context-ok list) + `(not (eql 0 count)) + `list)) ;;;; transforming FORMAT ;;;; @@ -3671,7 +4341,7 @@ ;;; error messages, and those don't need to be particularly fast. #+sb-xc (deftransform format ((dest control &rest args) (t simple-string &rest t) * - :policy (> speed space)) + :policy (>= speed space)) (unless (constant-lvar-p control) (give-up-ir1-transform "The control string is not a constant.")) (let ((arg-names (make-gensym-list (length args)))) @@ -3679,21 +4349,25 @@ (declare (ignore control)) (format dest (formatter ,(lvar-value control)) ,@arg-names)))) -(deftransform format ((stream control &rest args) (stream function &rest t) * - :policy (> speed space)) +(deftransform format ((stream control &rest args) (stream function &rest t)) (let ((arg-names (make-gensym-list (length args)))) `(lambda (stream control ,@arg-names) (funcall control stream ,@arg-names) nil))) -(deftransform format ((tee control &rest args) ((member t) function &rest t) * - :policy (> speed space)) +(deftransform format ((tee control &rest args) ((member t) function &rest t)) (let ((arg-names (make-gensym-list (length args)))) `(lambda (tee control ,@arg-names) (declare (ignore tee)) (funcall control *standard-output* ,@arg-names) nil))) +(deftransform pathname ((pathspec) (pathname) *) + 'pathspec) + +(deftransform pathname ((pathspec) (string) *) + '(values (parse-namestring pathspec))) + (macrolet ((def (name) `(defoptimizer (,name optimizer) ((control &rest args)) @@ -3706,7 +4380,6 @@ #+sb-xc-host ; Only we should be using these (progn (def style-warn) - (def compiler-abort) (def compiler-error) (def compiler-warn) (def compiler-style-warn) @@ -3749,7 +4422,7 @@ :format-arguments (list nargs 'cerror y x (max max1 max2)))))))))))))) -(defoptimizer (coerce derive-type) ((value type)) +(defoptimizer (coerce derive-type) ((value type) node) (cond ((constant-lvar-p type) ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2), @@ -3794,7 +4467,17 @@ (type-union result-typeoid (type-intersection (lvar-type value) (specifier-type 'rational)))))) - (t result-typeoid)))) + ((and (policy node (zerop safety)) + (csubtypep result-typeoid (specifier-type '(array * (*))))) + ;; At zero safety the deftransform for COERCE can elide dimension + ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we + ;; need to simplify the type to drop the dimension information. + (let ((vtype (simplify-vector-type result-typeoid))) + (if vtype + (specifier-type vtype) + result-typeoid))) + (t + result-typeoid)))) (t ;; OK, the result-type argument isn't constant. However, there ;; are common uses where we can still do better than just @@ -3813,17 +4496,16 @@ ;; we're prepared to handle which is basically something ;; that array-element-type can return. (or (and (member-type-p cons-type) - (null (rest (member-type-members cons-type))) + (eql 1 (member-type-size cons-type)) (null (first (member-type-members cons-type)))) (let ((car-type (cons-type-car-type cons-type))) (and (member-type-p car-type) - (null (rest (member-type-members car-type))) - (or (symbolp (first (member-type-members car-type))) - (numberp (first (member-type-members car-type))) - (and (listp (first (member-type-members - car-type))) - (numberp (first (first (member-type-members - car-type)))))) + (eql 1 (member-type-members car-type)) + (let ((elt (first (member-type-members car-type)))) + (or (symbolp elt) + (numberp elt) + (and (listp elt) + (numberp (first elt))))) (good-cons-type-p (cons-type-cdr-type cons-type)))))) (unconsify-type (good-cons-type) ;; Convert the "printed" respresentation of a cons @@ -3837,7 +4519,7 @@ (eq (first (second good-cons-type)) 'member)) `(,(second (second good-cons-type)) ,@(unconsify-type (caddr good-cons-type)))))) - (coerceable-p (c-type) + (coerceable-p (part) ;; Can the value be coerced to the given type? Coerce is ;; complicated, so we don't handle every possible case ;; here---just the most common and easiest cases: @@ -3859,13 +4541,14 @@ ;; the requested type, because (by assumption) COMPLEX ;; (and other difficult types like (COMPLEX INTEGER) ;; aren't specialized types. - (let ((coerced-type c-type)) - (or (and (subtypep coerced-type 'float) - (csubtypep value-type (specifier-type 'real))) - (and (subtypep coerced-type - '(or (complex single-float) - (complex double-float))) - (csubtypep value-type (specifier-type 'number)))))) + (let ((coerced-type (careful-specifier-type part))) + (when coerced-type + (or (and (csubtypep coerced-type (specifier-type 'float)) + (csubtypep value-type (specifier-type 'real))) + (and (csubtypep coerced-type + (specifier-type `(or (complex single-float) + (complex double-float)))) + (csubtypep value-type (specifier-type 'number))))))) (process-types (type) ;; FIXME: This needs some work because we should be able ;; to derive the resulting type better than just the @@ -3874,10 +4557,15 @@ ;; (DOUBLE-FLOAT 10d0 20d0) instead of just ;; double-float. (cond ((member-type-p type) - (let ((members (member-type-members type))) - (if (every #'coerceable-p members) - (specifier-type `(or ,@members)) - *universal-type*))) + (block punt + (let (members) + (mapc-member-type-members + (lambda (member) + (if (coerceable-p member) + (push member members) + (return-from punt *universal-type*))) + type) + (specifier-type `(or ,@members))))) ((and (cons-type-p type) (good-cons-type-p type)) (let ((c-type (unconsify-type (type-specifier type)))) @@ -3920,19 +4608,16 @@ (specifier-type (consify element-type))) (t (error "can't understand type ~S~%" element-type)))))) - (cond ((array-type-p array-type) - (get-element-type array-type)) - ((union-type-p array-type) - (apply #'type-union - (mapcar #'get-element-type (union-type-types array-type)))) - (t - *universal-type*))))) + (labels ((recurse (type) + (cond ((array-type-p type) + (get-element-type type)) + ((union-type-p type) + (apply #'type-union + (mapcar #'recurse (union-type-types type)))) + (t + *universal-type*)))) + (recurse array-type))))) -;;; Like CMU CL, we use HEAPSORT. However, other than that, this code -;;; isn't really related to the CMU CL code, since instead of trying -;;; to generalize the CMU CL code to allow START and END values, this -;;; code has been written from scratch following Chapter 7 of -;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. (define-source-transform sb!impl::sort-vector (vector start end predicate key) ;; Like CMU CL, we use HEAPSORT. However, other than that, this code ;; isn't really related to the CMU CL code, since instead of trying @@ -3984,7 +4669,7 @@ (start-1 (1- ,',start)) (current-heap-size (- ,',end ,',start)) (keyfun ,keyfun)) - (declare (type (integer -1 #.(1- most-positive-fixnum)) + (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum)) start-1)) (declare (type index current-heap-size)) (declare (type function keyfun)) @@ -4052,6 +4737,36 @@ (unless (and (constant-lvar-p quality-name) (policy-quality-name-p (lvar-value quality-name))) (give-up-ir1-transform)) - `(let* ((acons (assoc quality-name policy)) - (result (or (cdr acons) 1))) - result)) + '(%policy-quality policy quality-name)) + +(deftransform encode-universal-time + ((second minute hour date month year &optional time-zone) + ((constant-arg (mod 60)) (constant-arg (mod 60)) + (constant-arg (mod 24)) + (constant-arg (integer 1 31)) + (constant-arg (integer 1 12)) + (constant-arg (integer 1899)) + (constant-arg (rational -24 24)))) + (let ((second (lvar-value second)) + (minute (lvar-value minute)) + (hour (lvar-value hour)) + (date (lvar-value date)) + (month (lvar-value month)) + (year (lvar-value year)) + (time-zone (lvar-value time-zone))) + (if (zerop (rem time-zone 1/3600)) + (encode-universal-time second minute hour date month year time-zone) + (give-up-ir1-transform)))) + +#!-(and win32 (not sb-thread)) +(deftransform sleep ((seconds) ((integer 0 #.(expt 10 8)))) + `(sb!unix:nanosleep seconds 0)) + +#!-(and win32 (not sb-thread)) +(deftransform sleep ((seconds) ((constant-arg (real 0)))) + (let ((seconds-value (lvar-value seconds))) + (multiple-value-bind (seconds nano) + (sb!impl::split-seconds-for-sleep seconds-value) + (if (> seconds (expt 10 8)) + (give-up-ir1-transform) + `(sb!unix:nanosleep ,seconds ,nano)))))