diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1f4dd3702623b7d43a0827f4203476d6da8d438a..c0061359a61fbb4b1bd5ef5807416f31ecf5944f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,7 +1,7 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2024/04" version: "2024-04-x86" - bootstrap: "" + bootstrap: "-B boot-2024-04-1" stages: diff --git a/src/assembly/x86/arith.lisp b/src/assembly/x86/arith.lisp index db1fcaefe201f858b1b6ea86f5ad010fa7b8facb..509172bbba65314369d8bd63ed68f301c5e08d57 100644 --- a/src/assembly/x86/arith.lisp +++ b/src/assembly/x86/arith.lisp @@ -214,7 +214,9 @@ ); eval-when (define-cond-assem-rtn generic-< < two-arg-< :l) +(define-cond-assem-rtn generic-<= <= two-arg-<= :le) (define-cond-assem-rtn generic-> > two-arg-> :g) +(define-cond-assem-rtn generic->= >= two-arg->= :ge) (define-assembly-routine (generic-eql (:cost 10) diff --git a/src/bootfiles/21e/boot-2024-04-1.lisp b/src/bootfiles/21e/boot-2024-04-1.lisp new file mode 100644 index 0000000000000000000000000000000000000000..821b7384bbcdcdd3753d95b3dfed7077e2d45a42 --- /dev/null +++ b/src/bootfiles/21e/boot-2024-04-1.lisp @@ -0,0 +1,16 @@ +;; Bootstrap file for x86 to add two-arg->= and two-arg-<= to static +;; functions list. +;; +;; Use bin/build.sh -B boot-2021-07-3 to build this (along with any +;; other bootfiles that are still needed). +#+x86 +(in-package :x86) + +#+x86 +(ext:without-package-locks + (defparameter static-functions + '(length + two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql + %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm + two-arg-<= two-arg->= two-arg-/= + ))) diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 4caf12f90126e086165f93449522c37da321b9af..8205e04b7d8700ce84629481407c3b53295caa45 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -1033,6 +1033,27 @@ ((bignum bignum) (plusp (bignum-compare x y)))) +;; This should probably be used for all architectures, but we've only +;; written all the necessary support only on x86, currently. See +;; issue #156. +#+x86 +(progn + (two-arg- two-arg-<= <= ceiling floor + ((fixnum bignum) + (bignum-plus-p y)) + ((bignum fixnum) + (not (bignum-plus-p x))) + ((bignum bignum) + (not (plusp (bignum-compare x y))))) + + (two-arg- two-arg->= >= floor ceiling + ((fixnum bignum) + (not (bignum-plus-p y))) + ((bignum fixnum) + (bignum-plus-p x)) + ((bignum bignum) + (not (minusp (bignum-compare x y)))))) + (defun two-arg-= (x y) (number-dispatch ((x number) (y number)) diff --git a/src/compiler/float-tran-dd.lisp b/src/compiler/float-tran-dd.lisp index 93de466bcf46e6017c91cd8218f29e760ee263ed..ee1c07fd2801ba0ddf941bcdb8a16afcc84931ec 100644 --- a/src/compiler/float-tran-dd.lisp +++ b/src/compiler/float-tran-dd.lisp @@ -667,7 +667,17 @@ (or (> a0 b0) (and (= a0 b0) (> a1 b1)))) - + +(declaim (inline dd<=)) +(defun dd<= (a0 a1 b0 b1) + (or (dd< a0 a1 b0 b1) + (dd= a0 a1 b0 b1))) + +(declaim (inline dd>=)) +(defun dd>= (a0 a1 b0 b1) + (or (dd> a0 a1 b0 b1) + (dd= a0 a1 b0 b1))) + (deftransform = ((a b) (vm::double-double-float vm::double-double-float) *) `(dd= (kernel:double-double-hi a) (kernel:double-double-lo a) @@ -687,4 +697,17 @@ (kernel:double-double-lo a) (kernel:double-double-hi b) (kernel:double-double-lo b))) + +(deftransform <= ((a b) (vm::double-double-float vm::double-double-float) *) + `(dd<= (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) + + +(deftransform >= ((a b) (vm::double-double-float vm::double-double-float) *) + `(dd>= (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) ) ; end progn diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 250a2b128c89352660c8bea1ae8a3e6f48778838..8ebe3a9ac53138de8c1f000492b00a4921b0f627 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -568,7 +568,7 @@ (%deftransform x '(function (rational float) *) #'float-contagion-arg1) (%deftransform x '(function (float rational) *) #'float-contagion-arg2)) -(dolist (x '(= < > + * / -)) +(dolist (x '(= < > + * / - #+x86 <= #+x86 >=)) (%deftransform x '(function (single-float double-float) *) #'float-contagion-arg1) (%deftransform x '(function (double-float single-float) *) @@ -591,7 +591,11 @@ `(,',op x (float y x))))) (frob <) (frob >) - (frob =)) + (frob =) + #+x86 + (frob <=) + #+x86 + (frob >=)) ;; Convert (/ x n) to (* x (/ n)) when x is a float and n is a power ;; of two, because (/ n) can be reprsented exactly. diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 8ba0552ff6ad470e5549141bd24b876461e008fc..123a08ad0416d0c034d8092f283ab7d62f1defd0 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3541,6 +3541,85 @@ (deftransform > ((x y) (real real) * :when :both) (ir1-transform-< y x x y '<)) +;;; Ir1-transform->=-helper -- Internal +;;; +;;; Derives the result type of the comparison X >= Y returning two +;;; values: the first true if X >= Y, and the second true if X < Y. +;;; This is the equivalent of ir1-transform-<-helper, but for >=. +#+(and x86) +(defun ir1-transform->=-helper (x y) + (flet ((maybe-convert (type) + (numeric-type->interval + (cond ((numeric-type-p type) type) + ((member-type-p type) (convert-member-type type)) + (t (give-up)))))) + (let ((xi (mapcar #'maybe-convert + (prepare-arg-for-derive-type (continuation-type x)))) + (yi (mapcar #'maybe-convert + (prepare-arg-for-derive-type (continuation-type y)))) + (definitely-true t) + (definitely-false t)) + (dolist (x-arg xi) + (dolist (y-arg yi) + (setf definitely-true (and definitely-true + (interval->= x-arg y-arg))) + (setf definitely-false (and definitely-false + (interval-< x-arg y-arg))))) + (values definitely-true definitely-false)))) + +;;; IR1-TRANSFORM->= -- Internal +;;; +;;; Like IR1-TRANSFORM-< but for >=. This is needed so that the +;;; compiler can statically determine (>= X Y) using type information. +#+(and x86) +(defun ir1-transform->= (x y first second inverse) + ;; If the leaves are the same, the (>= X Y) is true, provided that + ;; neither x nor y is a float. This happens when x or y is NaN. + (if (and (same-leaf-ref-p x y) + (not (csubtypep (continuation-type x) (specifier-type 'float)))) + 't + (multiple-value-bind (definitely-true definitely-false) + (ir1-transform->=-helper x y) + (cond (definitely-true + t) + (definitely-false + nil) + ((and (constant-continuation-p first) + (not (constant-continuation-p second))) + `(,inverse y x)) + (t + (give-up)))))) + +#+(and x86) +(deftransform <= ((x y) (real real) * :when :both) + (ir1-transform->= y x x y '>=)) + +#+(and x86) +(deftransform >= ((x y) (real real) * :when :both) + (ir1-transform->= x y x y '<=)) + + +#+(and nil x86) +(progn + ;; When x and y are integers, we want to transform <= to > and >= to + ;; <. But we don't want to do this for floats because it messes up + ;; comparisons with NaN. + ;; + ;; I'm not sure about this. The transformation is right, but + ;; perhaps what we really need is an ir-transform-<= to determine x + ;; <= y is definitely true or false, like for ir1-transform-<. + ;; + ;; For now this allows the testsuite to pass. Perhaps there's a bug + ;; in generic->=? + (deftransform <= ((x y) (integer integer) * :when :both) + ;; (<= x y) is the same as (not (> x y)) + `(not (> x y))) + + (deftransform >= ((x y) (integer integer) * :when :both) + ;; (>= x y) is the same as (not (< x y)) + `(not (< x y)))) + + ;; Like IR1-TRANSFORM-< but for CHAR<. This is needed so that the ;; vops for base-char comparison with a constant gets used when the ;; first arg is the constant. @@ -3602,8 +3681,18 @@ (def-source-transform = (&rest args) (multi-compare '= args nil)) (def-source-transform < (&rest args) (multi-compare '< args nil)) (def-source-transform > (&rest args) (multi-compare '> args nil)) -(def-source-transform <= (&rest args) (multi-compare '> args t)) -(def-source-transform >= (&rest args) (multi-compare '< args t)) +;; We want to handle <= directly as <= instead of transforming to >. +;; This is needed to handle NaN values. See issue #156. This should +;; probably apply to all architectures, but we've only implemented the +;; necessary changes for x86 right now. +#-x86 +(progn + (def-source-transform <= (&rest args) (multi-compare '> args t)) + (def-source-transform >= (&rest args) (multi-compare '< args t))) +#+x86 +(progn + (def-source-transform <= (&rest args) (multi-compare '<= args nil)) + (def-source-transform >= (&rest args) (multi-compare '>= args nil))) (def-source-transform char= (&rest args) (multi-compare 'char= args nil)) (def-source-transform char< (&rest args) (multi-compare 'char< args nil)) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index 74d51a202ecc08026e9b6b92b7a6849a9c4cf35b..197a91c94a11818a2dcf4537756bdbc372f92b4b 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -898,8 +898,9 @@ '(t t t t nil nil)))) (define-conditional-vop < :l :b :ge :ae) - +(define-conditional-vop <= :le :be :g :a) (define-conditional-vop > :g :a :le :be) +(define-conditional-vop >= :ge :ae :l :b) (define-vop (fast-if-eql/signed fast-conditional/signed) (:translate eql) @@ -1365,6 +1366,13 @@ (define-static-function two-arg-/ (x y) :translate /) +(define-static-function two-arg-< (x y) :translate <) +(define-static-function two-arg-<= (x y) :translate <=) +(define-static-function two-arg-> (x y) :translate >) +(define-static-function two-arg->= (x y) :translate >=) +(define-static-function two-arg-= (x y) :translate =) +(define-static-function two-arg-/= (x y) :translate /=) + (define-static-function two-arg-gcd (x y) :translate gcd) (define-static-function two-arg-lcm (x y) :translate lcm) diff --git a/src/compiler/x86/float-sse2.lisp b/src/compiler/x86/float-sse2.lisp index 8d6c2f702dc1a73901afa446c7d945e69399e01d..ee5d6ebdf7b18f4da2b6a8a40cbf16a28da6a0fc 100644 --- a/src/compiler/x86/float-sse2.lisp +++ b/src/compiler/x86/float-sse2.lisp @@ -1000,6 +1000,40 @@ (frob < single comiss) (frob < double comisd)) + + +(macrolet + ((frob (op size inst yep nope) + (let ((ea (ecase size + (single + 'ea-for-sf-desc) + (double + 'ea-for-df-desc))) + (name (symbolicate op "/" size "-FLOAT")) + (sc-type (symbolicate size "-REG")) + (inherit (symbolicate size "-FLOAT-COMPARE"))) + `(define-vop (,name ,inherit) + (:translate ,op) + (:info target not-p) + (:generator 3 + (sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))) + (cond (not-p + (inst jmp :p target) + (inst jmp ,nope target)) + (t + (let ((not-lab (gen-label))) + (inst jmp :p not-lab) + (inst jmp ,yep target) + (emit-label not-lab))))))))) + (frob <= single comiss :be :nbe) + (frob >= single comiss :ae :nae) + (frob <= double comisd :be :nbe) + (frob >= double comisd :ae :nae)) + ;;;; Conversion: diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 0b5235705cfaee89bbeafbdc927f3a0c652b76b5..efbac735136ed1f3ff695edecd1abdb65edabf38 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -395,10 +395,14 @@ *static-blue-bag* ; Must be last or change C code )) +;; FIXME: This should be reordered to match more closely the order +;; used for sparc and ppc. However, I (rtoy) think that requires a +;; cross-compile. (defparameter static-functions '(length two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm + two-arg-<= two-arg->= two-arg-/= )) ;;; diff --git a/tests/nan.lisp b/tests/nan.lisp index 1b885d020e50ef5fe1cab95ec8f69ee9b9db2860..3891c671ba1a2827b2cc27e69372eaeed43e1773 100644 --- a/tests/nan.lisp +++ b/tests/nan.lisp @@ -34,7 +34,11 @@ (frob double-float <) (frob double-float >) (frob single-float =) - (frob double-float =))) + (frob double-float =) + (frob single-float >=) + (frob double-float >=) + (frob single-float <=) + (frob double-float <=))) (define-test nan-single.< (:tag :nan) @@ -101,7 +105,10 @@ (ext:with-float-traps-masked (:invalid) (assert-false (stst-<3 *single-float-nan* 2f0 3f0)) (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) - (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)))) + (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)) + (assert-false (stst-<3 1f0 2f0 *single-float-nan*)) + (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) + (assert-false (stst-<3 1f0 *single-float-nan* *single-float-nan*)))) (define-test nan-double.<3 (:tag :nan) @@ -120,7 +127,10 @@ (ext:with-float-traps-masked (:invalid) (assert-false (dtst-<3 *double-float-nan* 2d0 3d0)) (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) - (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)))) + (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)) + (assert-false (dtst-<3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst-<3 1d0 *double-float-nan* *double-float-nan*)))) (define-test nan-single.>3 (:tag :nan) @@ -139,7 +149,10 @@ (ext:with-float-traps-masked (:invalid) (assert-false (stst->3 *single-float-nan* 2f0 3f0)) (assert-false (stst->3 1f0 *single-float-nan* 3f0)) - (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)))) + (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)) + (assert-false (stst->3 1f0 2f0 *single-float-nan*)) + (assert-false (stst->3 1f0 *single-float-nan* 3f0)) + (assert-false (stst->3 1f0 *single-float-nan* *single-float-nan*)))) (define-test nan-double.>3 (:tag :nan) @@ -158,7 +171,118 @@ (ext:with-float-traps-masked (:invalid) (assert-false (dtst->3 *double-float-nan* 2d0 3d0)) (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) - (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) + (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)) + (assert-false (dtst->3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst->3 1d0 *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.>= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst->= 1f0 1f0)) + (assert-true (stst->= 2f0 1f0)) + (assert-false (stst->= 0f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->= 1f0 *single-float-nan*)) + (assert-false (stst->= *single-float-nan* 1f0)) + (assert-false (stst->= *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.<= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst-<= 1f0 1f0)) + (assert-true (stst-<= 1f0 2f0)) + (assert-false (stst-<= 2f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<= 1f0 *single-float-nan*)) + (assert-false (stst-<= *single-float-nan* 1f0)) + (assert-false (stst-<= *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.>=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst->=3 1f0 1f0 1f0)) + (assert-true (stst->=3 2f0 1f0 1f0)) + (assert-false (stst->=3 0f0 1f0 1f0)) + (assert-false (stst->=3 2f0 0f0 1f0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->=3 1f0 *single-float-nan* 2f0)) + (assert-false (stst->=3 *single-float-nan* 1f0 2f0)) + (assert-false (stst->=3 *single-float-nan* *single-float-nan* 2f0)) + (assert-false (stst->=3 2f0 1f0 *single-float-nan*)) + (assert-false (stst->=3 2f0 *single-float-nan* 1f0)) + (assert-false (stst->=3 2f0 *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.<=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst-<=3 1f0 1f0 1f0)) + (assert-true (stst-<=3 1f0 2f0 2f0)) + (assert-false (stst-<=3 1f0 3f0 2f0)) + (assert-false (stst-<=3 2f0 1f0 1f0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<=3 1f0 *single-float-nan* 2f0)) + (assert-false (stst-<=3 *single-float-nan* 1f0 2f0)) + (assert-false (stst-<=3 *single-float-nan* *single-float-nan* 2f0)) + (assert-false (stst-<=3 1f0 2f0 *single-float-nan*)) + (assert-false (stst-<=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-<=3 1f0 *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.>= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst->= 1f0 1f0)) + (assert-true (dtst->= 2f0 1f0)) + (assert-false (dtst->= 0f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->= 1f0 *double-float-nan*)) + (assert-false (dtst->= *double-float-nan* 1f0)) + (assert-false (dtst->= *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.<= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst-<= 1f0 1f0)) + (assert-true (dtst-<= 1f0 2f0)) + (assert-false (dtst-<= 2f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<= 1f0 *double-float-nan*)) + (assert-false (dtst-<= *double-float-nan* 1f0)) + (assert-false (dtst-<= *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.>=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst->=3 1d0 1d0 1d0)) + (assert-true (dtst->=3 2d0 1d0 1d0)) + (assert-false (dtst->=3 0d0 1d0 1d0)) + (assert-false (dtst->=3 2d0 0d0 1d0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->=3 1d0 *double-float-nan* 2d0)) + (assert-false (dtst->=3 *double-float-nan* 1d0 2d0)) + (assert-false (dtst->=3 *double-float-nan* *double-float-nan* 2d0)) + (assert-false (dtst->=3 2d0 1d0 *double-float-nan*)) + (assert-false (dtst->=3 2d0 *double-float-nan* 1d0)) + (assert-false (dtst->=3 2d0 *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.<=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst-<=3 1d0 1d0 1d0)) + (assert-true (dtst-<=3 1d0 2d0 2d0)) + (assert-false (dtst-<=3 1d0 3d0 2d0)) + (assert-false (dtst-<=3 2d0 1d0 1d0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<=3 1d0 *double-float-nan* 2d0)) + (assert-false (dtst-<=3 *double-float-nan* 1d0 2d0)) + (assert-false (dtst-<=3 *double-float-nan* *double-float-nan* 2d0)) + (assert-false (dtst-<=3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst-<=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-<=3 1d0 *double-float-nan* *double-float-nan*)))) (define-test nan-single.= (:tag :nan)