X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=72c2695d5a007acdfff01bde5ea60e13e4bbe8c2;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=889753468dee1cbb3cc8c5bb8a925bcc0e4cd8be;hpb=0aad9fb773a97e400b727dd8673494491e56a464;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 8897534..72c2695 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -123,10 +123,15 @@ (t (values nil t)))) ;;; And similarly for LIST*. -(define-source-transform list* (&rest args) - (case (length args) - (2 `(cons ,(first args) ,(second args))) - (t (values nil t)))) +(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))) ;;; Translate RPLACx to LET and SETF. (define-source-transform rplaca (x y) @@ -142,10 +147,25 @@ (define-source-transform nth (n l) `(car (nthcdr ,n ,l))) -(define-source-transform last (x) `(sb!impl::last1 ,x)) +(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 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) @@ -183,8 +203,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. @@ -322,6 +342,37 @@ nil (set-bound y (consp x))))))) +(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) + ;; 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 some platforms like 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.) + (and (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 ;;; is open if either X or Y is open. @@ -335,21 +386,19 @@ (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 @@ -511,15 +560,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 @@ -563,27 +610,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)) @@ -687,8 +751,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 @@ -816,6 +881,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) @@ -891,11 +974,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))))) @@ -1011,7 +1096,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 @@ -1054,25 +1139,23 @@ ;;; 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 '()) + (let ((xset (alloc-xset)) + (fp-zeroes '()) (misc-types '())) (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)) + (t + (push type misc-types)))) + (if (and (xset-empty-p xset) (not fp-zeroes)) + (apply #'type-union misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -1706,6 +1789,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 @@ -1713,6 +1806,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) @@ -2533,6 +2648,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 @@ -2782,19 +2918,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) @@ -2802,11 +2939,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. @@ -2821,12 +2958,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) @@ -2842,7 +2980,7 @@ (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))) + (modular-fun (find-modular-version fun-name kind signedp width))) (when (and modular-fun (not (and (eq fun-name 'logand) (csubtypep @@ -2875,6 +3013,30 @@ 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)))))))) + (defoptimizer (logand optimizer) ((x y) node) (let ((result-type (single-value-type (node-derived-type node)))) (when (numeric-type-p result-type) @@ -2884,13 +3046,14 @@ (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 (w kind signedp) + (best-modular-version width nil) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP). + (cut-to-width x kind width signedp) + (cut-to-width y kind width signedp) + nil ; After fixing above, replace with T. + )))))))) (defoptimizer (mask-signed-field optimizer) ((width x) node) (let ((result-type (single-value-type (node-derived-type node)))) @@ -2899,12 +3062,13 @@ (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 (w kind) + (best-modular-version width t) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T). + (cut-to-width x kind width t) + nil ; After fixing above, replace with T. + )))))))) ;;; miscellanous numeric transforms @@ -3120,41 +3284,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))) @@ -3191,6 +3346,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 @@ -3301,9 +3465,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) @@ -3314,7 +3476,7 @@ '(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)) + ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type)) '(eq x y)) ((and (not (constant-lvar-p y)) (or (constant-lvar-p x) @@ -3353,41 +3515,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. @@ -3395,7 +3570,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))) @@ -3410,6 +3592,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)) @@ -3448,15 +3632,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) @@ -3474,8 +3659,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-inforation 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)) @@ -3489,15 +3679,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 @@ -3685,7 +3875,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)))) @@ -3693,15 +3883,13 @@ (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)) @@ -3726,7 +3914,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) @@ -3833,17 +4020,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 @@ -3857,7 +4043,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: @@ -3879,13 +4065,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 @@ -3894,10 +4081,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)))) @@ -3940,19 +4132,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 @@ -4004,7 +4193,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)) @@ -4072,7 +4261,4 @@ (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))