master: Don't signal errors for (log qnan)
stassats via Sbcl-commits <[email protected]> Sat, 18 Jul 2026 23:50:18 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 246af004128d9e0d567bacf79a61c7acf43b2512 (commit)
from 3751ecd35626f8ca2dd5e74bb086b687c36a757a (commit)
- Log -----------------------------------------------------------------
commit 246af004128d9e0d567bacf79a61c7acf43b2512
Author: Stas Boukarev <[email protected]>
Date: Sun Jul 19 01:02:19 2026 +0300
Don't signal errors for (log qnan)
Fixes lp#2160268
---
src/code/float.lisp | 22 +++++
src/code/irrat.lisp | 22 ++---
src/cold/exports.lisp | 3 +-
src/compiler/arm/float.lisp | 32 ++++---
src/compiler/arm64/float.lisp | 28 +++---
src/compiler/float-tran.lisp | 24 +++--
src/compiler/fndb.lisp | 3 +
src/compiler/loongarch64/float.lisp | 12 ++-
src/compiler/mips/float.lisp | 4 +-
src/compiler/ppc/float.lisp | 16 ++--
src/compiler/ppc64/float.lisp | 16 ++--
src/compiler/riscv/float.lisp | 4 +-
src/compiler/sparc/float.lisp | 26 +++--
src/compiler/x86-64/float.lisp | 38 +++++++-
src/compiler/x86/float.lisp | 183 ++++++++++++++++++++++++------------
xperfecthash63.lisp-expr | 3 +
16 files changed, 295 insertions(+), 141 deletions(-)
diff --git a/src/code/float.lisp b/src/code/float.lisp
index 35bf3895c..383120ffa 100644
--- a/src/code/float.lisp
+++ b/src/code/float.lisp
@@ -816,3 +816,25 @@
(t
(ash int exp)))))))
((rational) x)))
+
+#-sb-xc-host
+(make-defs (($fun < =))
+ (defun quiet$fun (x y)
+ (declare (explicit-check))
+ (number-dispatch ((x real) (y real))
+ ((single-float single-float)
+ (quiet$fun x y))
+ ((double-float double-float)
+ (quiet$fun x y))
+ ((single-float double-float)
+ (quiet$fun (coerce x 'double-float) y))
+ ((double-float single-float)
+ (quiet$fun x (coerce y 'double-float)))
+ (((foreach single-float double-float) rational)
+ (unless (float-nan-p x)
+ ($fun x y)))
+ ((rational (foreach single-float double-float))
+ (unless (float-nan-p y)
+ ($fun x y)))
+ ((rational rational)
+ ($fun x y)))))
diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index c343ece4a..ea148e5b9 100644
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -345,17 +345,17 @@
(clear-info :source-location :declaration s)))
(defun sqrt-double-float (number)
- (if (< number 0)
+ (if (quiet< number 0)
(complex 0d0 (sqrt (- number)))
(sqrt number)))
(defun sqrt-single-float (number)
- (if (< number 0)
+ (if (quiet< number 0)
(complex 0f0 (sqrt (- number)))
(sqrt number)))
(defun log-double-float (number)
- (if (< number 0)
+ (if (quiet< number 0)
(complex (log (- number)) pi)
(log number)))
@@ -365,18 +365,18 @@
(log number)))
(defun log-double-float2 (number base)
- (if (zerop base)
+ (if (quiet= base 0d0)
0d0
- (if (or (< base 0)
- (< number 0))
+ (if (or (quiet< base 0)
+ (quiet< number 0))
(/ (log number) (log base))
(truly-the double-float (log number base)))))
(defun log-single-float2 (number base)
- (if (zerop base)
+ (if (quiet= base 0d0)
0.0
- (if (or (< base 0)
- (< number 0))
+ (if (or (quiet< base 0)
+ (quiet< number 0))
(/ (log number) (log base))
(truly-the single-float (log number base)))))
@@ -513,7 +513,7 @@
'single-float)))))
(((foreach single-float double-float))
;; IEEE 754 says (log -0.0) should be -inf
- (if (< number 0.0)
+ (if (quiet< number 0.0)
(complex (log (- number)) (coerce pi '(dispatch-type number)))
(log number)))
((complex)
@@ -530,7 +530,7 @@
(coerce (%sqrt (- (coerce number 'double-float))) 'single-float))
(coerce (%sqrt (coerce number 'double-float)) 'single-float)))
(((foreach single-float double-float))
- (if (minusp number)
+ (if (quiet< number 0)
(complex (coerce 0.0 '(dispatch-type number))
(sqrt (- number)))
(sqrt number)))
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index d8d47ed2a..95ce5bb77 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -2394,7 +2394,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"INLINE-VOP"
"WRAP-IF" "COND-DISPATCH"
"MAKE-DEFS"
- "COPY-REMOVE" "COPY-REMOVE-IF" "COPY-REMOVE-IF-NOT")
+ "COPY-REMOVE" "COPY-REMOVE-IF" "COPY-REMOVE-IF-NOT"
+ "QUIET=" "QUIET<")
#+sb-simd-pack
(:export "SIMD-PACK"
"SIMD-PACK-P"
diff --git a/src/compiler/arm/float.lisp b/src/compiler/arm/float.lisp
index cedfd28bf..fe4316d2a 100644
--- a/src/compiler/arm/float.lisp
+++ b/src/compiler/arm/float.lisp
@@ -371,7 +371,7 @@
(define-vop (float-compare)
(:args (x) (y))
- (:variant-vars format is-=)
+ (:variant-vars format quiet)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
@@ -380,11 +380,11 @@
(note-this-location vop :internal-error)
(ecase format
(:single
- (if is-=
+ (if quiet
(inst fcmps x y)
(inst fcmpes x y)))
(:double
- (if is-=
+ (if quiet
(inst fcmpd x y)
(inst fcmped x y))))
(inst fmstat)))
@@ -397,25 +397,27 @@
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float))
-(macrolet ((frob (translate cond sname dname is-=)
+(macrolet ((frob (translate cond sname dname quiet)
`(progn
(define-vop (,sname single-float-compare)
(:translate ,translate)
(:conditional ,cond)
- (:variant :single ,is-=))
+ (:variant :single ,quiet))
(define-vop (,dname double-float-compare)
(:translate ,translate)
(:conditional ,cond)
- (:variant :double ,is-=)))))
+ (:variant :double ,quiet)))))
(frob < :mi </single-float </double-float nil)
+ (frob quiet< :mi quiet</single-float quiet</double-float t)
(frob > :gt >/single-float >/double-float nil)
- (frob = :eq =/single-float =/double-float t))
+ (frob = :eq =/single-float =/double-float t)
+ (frob quiet= :eq quiet=/single-float quiet=/double-float t))
(define-vop (float-compare-zero)
(:args (x))
(:info y)
(:ignore y)
- (:variant-vars format is-=)
+ (:variant-vars format quiet)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
@@ -424,11 +426,11 @@
(note-this-location vop :internal-error)
(ecase format
(:single
- (if is-=
+ (if quiet
(inst fcmpzs x)
(inst fcmpezs x)))
(:double
- (if is-=
+ (if quiet
(inst fcmpzd x)
(inst fcmpezd x))))
(inst fmstat)))
@@ -442,19 +444,21 @@
(frob double-float-compare-zero double-reg double-float
(double-float -0d0 0d0)))
-(macrolet ((frob (translate cond sname dname is-=)
+(macrolet ((frob (translate cond sname dname quiet)
`(progn
(define-vop (,sname single-float-compare-zero)
(:translate ,translate)
(:conditional ,cond)
- (:variant :single ,is-=))
+ (:variant :single ,quiet))
(define-vop (,dname double-float-compare-zero)
(:translate ,translate)
(:conditional ,cond)
- (:variant :double ,is-=)))))
+ (:variant :double ,quiet)))))
(frob < :mi </single-float-zero </double-float-zero nil)
+ (frob quiet< :mi quiet</single-float-zero quiet</double-float-zero t)
(frob > :gt >/single-float-zero >/double-float-zero nil)
- (frob = :eq eql/single-float-zero eql/double-float-zero t))
+ (frob = :eq eql/single-float-zero eql/double-float-zero t)
+ (frob quiet= :eq quiet=/single-float-zero quiet=/double-float-zero t))
;;;; Conversion:
diff --git a/src/compiler/arm64/float.lisp b/src/compiler/arm64/float.lisp
index d7ac4d482..f09736679 100644
--- a/src/compiler/arm64/float.lisp
+++ b/src/compiler/arm64/float.lisp
@@ -519,14 +519,14 @@
(define-vop (float-compare)
(:args (x) (y))
- (:variant-vars is-=)
+ (:variant-vars quiet)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
(:save-p :compute-only)
(:generator 3
(note-this-location vop :internal-error)
- (if is-=
+ (if quiet
(inst fcmp x y)
(inst fcmpe x y))))
@@ -538,34 +538,36 @@
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float))
-(macrolet ((frob (translate cond sname dname is-=)
+(macrolet ((frob (translate cond sname dname quiet)
`(progn
(define-vop (,sname single-float-compare)
(:translate ,translate)
(:conditional ,cond)
- (:variant ,is-=))
+ (:variant ,quiet))
(define-vop (,dname double-float-compare)
(:translate ,translate)
(:conditional ,cond)
- (:variant ,is-=)))))
+ (:variant ,quiet)))))
(frob < :mi </single-float </double-float nil)
+ (frob quiet< :mi quiet</single-float quiet</double-float t)
(frob > :gt >/single-float >/double-float nil)
(frob <= :ls <=/single-float <=/double-float nil)
(frob >= :ge >=/single-float >=/double-float nil)
- (frob = :eq =/single-float =/double-float t))
+ (frob = :eq =/single-float =/double-float nil)
+ (frob quiet= :eq quiet=/single-float quiet=/double-float t))
(define-vop (float-compare-zero)
(:args (x))
(:info y)
(:ignore y)
- (:variant-vars is-=)
+ (:variant-vars quiet)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
(:save-p :compute-only)
(:generator 2
(note-this-location vop :internal-error)
- (if is-=
+ (if quiet
(inst fcmp x 0)
(inst fcmpe x 0))))
@@ -578,21 +580,23 @@
(frob double-float-compare-zero double-reg double-float
(double-float -0d0 0d0)))
-(macrolet ((frob (translate cond sname dname is-=)
+(macrolet ((frob (translate cond sname dname quiet)
`(progn
(define-vop (,sname single-float-compare-zero)
(:translate ,translate)
(:conditional ,cond)
- (:variant ,is-=))
+ (:variant ,quiet))
(define-vop (,dname double-float-compare-zero)
(:translate ,translate)
(:conditional ,cond)
- (:variant ,is-=)))))
+ (:variant ,quiet)))))
(frob < :mi </single-float-zero </double-float-zero nil)
+ (frob quiet< :mi quiet</single-float-zero quiet</double-float-zero t)
(frob > :gt >/single-float-zero >/double-float-zero nil)
(frob <= :ls <=/single-float-zero <=/double-float-zero nil)
(frob >= :ge >=/single-float-zero >=/double-float-zero nil)
- (frob = :eq =/single-float-zero =/double-float-zero t))
+ (frob = :eq =/single-float-zero =/double-float-zero nil)
+ (frob quiet= :eq quiet=/single-float-zero quiet=/double-float-zero t))
(macrolet ((define-complex-float-=
(complex-complex-name complex-real-name real-complex-name
diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 176d0895c..56092a6b4 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -530,7 +530,7 @@
(deftransform log ((x) ($type) * :node node)
(let ((cast (cast-or-check-bound-type node (specifier-type 'real))))
(if cast
- `(if (< x 0)
+ `(if (quiet< x 0)
(sb-vm::op-not-type1-error x '(,(type-specifier cast) . log))
($log x))
(give-up-ir1-transform))))
@@ -538,10 +538,10 @@
(deftransform log ((x y) ($type $type) * :node node)
(let ((cast (cast-or-check-bound-type node (specifier-type 'real))))
(if cast
- `(if (= y 0)
+ `(if (quiet= y 0)
(coerce 0 '$type)
- (if (or (< x 0)
- (< y 0))
+ (if (or (quiet< x 0)
+ (quiet< y 0))
(sb-vm::op-not-type2-error x y '(,(type-specifier cast) . log))
(/ ($log x) ($log y))))
(give-up-ir1-transform))))
@@ -549,7 +549,7 @@
(deftransform sqrt ((x) ($type) * :node node)
(let ((cast (cast-or-check-bound-type node (specifier-type 'real))))
(if cast
- `(if (< x 0)
+ `(if (quiet< x 0)
(sb-vm::op-not-type1-error x '(,(type-specifier cast) . sqrt))
($sqrt x))
(give-up-ir1-transform)))))
@@ -557,7 +557,7 @@
(deftransform sqrt ((x) (rational) * :node node)
(let ((cast (cast-or-check-bound-type node (specifier-type 'real))))
(if cast
- `(if (< x 0)
+ `(if (quiet< x 0)
(sb-vm::op-not-type1-error x '(,(type-specifier cast) . sqrt))
(%single-float (%sqrt (%double-float x))))
(give-up-ir1-transform))))
@@ -1574,7 +1574,7 @@
(csubtypep (lvar-type y) (specifier-type 'single-float))
(let ((x (lvar-value x)))
(when (and (safe-single-coercion-p x)
- (= x (coerce x 'single-float)))
+ (sb-xc:= x (coerce x 'single-float)))
`(,(lvar-fun-name (basic-combination-fun node)) ,(coerce x 'single-float) y)))))
(t
`(,(lvar-fun-name (basic-combination-fun node)) x (%double-float y)))))
@@ -1586,7 +1586,7 @@
(csubtypep (lvar-type x) (specifier-type 'single-float))
(let ((y (lvar-value y)))
(when (and (safe-single-coercion-p y)
- (= y (coerce y 'single-float)))
+ (sb-xc:= y (coerce y 'single-float)))
`(,(lvar-fun-name (basic-combination-fun node)) x ,(coerce y 'single-float))))))
(t
`(,(lvar-fun-name (basic-combination-fun node)) (%double-float x) y))))
@@ -1643,9 +1643,15 @@
,most-positive-exactly-double-float-integer))
double-float))
#'real-double-float-contagion-cmp nil)))
- (dolist (op '(= < > <= >=))
+ (dolist (op '(= < > <= >= quiet< quiet=))
(def op)))
+(make-defs (($fun < =))
+ (defoptimizer (quiet$fun constraint-propagate-if) ((x y))
+ (values nil nil
+ (list (list '$fun x (lvar-type y)))
+ (list (list '$fun x (lvar-type y) t)))))
+
(%deftransform '= nil '(function ((complex double-float) single-float))
#'double-float-real-contagion nil)
(%deftransform '= nil '(function (single-float (complex double-float)))
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 720d6a32b..b3e7fa019 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -232,6 +232,9 @@
(defknown (max min) (real &rest real) real
(movable foldable flushable))
+(defknown (quiet= quiet<) (real real) boolean
+ (movable foldable flushable))
+
(defknown (+ *) (&rest number) number
(movable foldable flushable commutative))
(defknown - (number &rest number) number
diff --git a/src/compiler/loongarch64/float.lisp b/src/compiler/loongarch64/float.lisp
index f2ca5ad5a..a74806628 100644
--- a/src/compiler/loongarch64/float.lisp
+++ b/src/compiler/loongarch64/float.lisp
@@ -416,11 +416,13 @@
(if not-p
(inst bceqz 5 target)
(inst bcnez 5 target)))))))
- (frob < fcmp.clt.s fcmp.clt.d nil </single-float </double-float)
- (frob <= fcmp.cle.s fcmp.cle.d nil <=/single-float <=/double-float)
- (frob > fcmp.clt.s fcmp.clt.d t >/single-float >/double-float)
- (frob >= fcmp.cle.s fcmp.cle.d t >=/single-float >=/double-float)
- (frob = fcmp.ceq.s fcmp.ceq.d nil =/single-float =/double-float))
+ (frob < fcmp.slt.s fcmp.slt.d nil </single-float </double-float)
+ (frob quiet< fcmp.clt.s fcmp.clt.d nil quiet</single-float quiet</double-float)
+ (frob <= fcmp.sle.s fcmp.sle.d nil <=/single-float <=/double-float)
+ (frob > fcmp.slt.s fcmp.slt.d t >/single-float >/double-float)
+ (frob >= fcmp.sle.s fcmp.sle.d t >=/single-float >=/double-float)
+ (frob = fcmp.seq.s fcmp.seq.d nil =/single-float =/double-float)
+ (frob quiet= fcmp.ceq.s fcmp.ceq.d nil quiet=/single-float quiet=/double-float))
(macrolet ((frob (name translate
from-sc from-type from-format
diff --git a/src/compiler/mips/float.lisp b/src/compiler/mips/float.lisp
index 2bd68ce11..d13f336ff 100644
--- a/src/compiler/mips/float.lisp
+++ b/src/compiler/mips/float.lisp
@@ -530,8 +530,10 @@
(:translate ,translate)
(:variant :double ,op ,complement)))))
(frob < :lt nil </single-float </double-float)
+ (frob quiet< :ult nil quiet</single-float quiet</double-float)
(frob > :ngt t >/single-float >/double-float)
- (frob = :seq nil =/single-float =/double-float))
+ (frob = :seq nil =/single-float =/double-float)
+ (frob quiet= :eq nil quiet=/single-float quiet=/double-float))
;;;; Conversion:
diff --git a/src/compiler/ppc/float.lisp b/src/compiler/ppc/float.lisp
index 8ad8c77dd..a7c93125b 100644
--- a/src/compiler/ppc/float.lisp
+++ b/src/compiler/ppc/float.lisp
@@ -407,7 +407,7 @@
(:args (x) (y))
(:conditional)
(:info target not-p)
- (:variant-vars format yep nope)
+ (:variant-vars format yep nope quiet)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
@@ -416,7 +416,9 @@
(note-this-location vop :internal-error)
(ecase format
((:single :double)
- (inst fcmpo :cr1 x y)))
+ (if quiet
+ (inst fcmpu :cr1 x y)
+ (inst fcmpo :cr1 x y))))
(inst b? :cr1 (if not-p nope yep) target)))
(macrolet ((frob (name sc ptype)
@@ -427,17 +429,19 @@
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float))
-(macrolet ((frob (translate yep nope sname dname)
+(macrolet ((frob (translate yep nope sname dname &optional quiet)
`(progn
(define-vop (,sname single-float-compare)
(:translate ,translate)
- (:variant :single ,yep ,nope))
+ (:variant :single ,yep ,nope ,quiet))
(define-vop (,dname double-float-compare)
(:translate ,translate)
- (:variant :double ,yep ,nope)))))
+ (:variant :double ,yep ,nope ,quiet)))))
(frob < :lt :ge </single-float </double-float)
+ (frob quiet< :lt :ge quiet</single-float quiet</double-float)
(frob > :gt :le >/single-float >/double-float)
- (frob = :eq :ne =/single-float =/double-float))
+ (frob = :eq :ne =/single-float =/double-float)
+ (frob quiet= :eq :ne quiet=/single-float quiet=/double-float))
;;;; Conversion:
diff --git a/src/compiler/ppc64/float.lisp b/src/compiler/ppc64/float.lisp
index 3ab6e82f8..cbb5dc1db 100644
--- a/src/compiler/ppc64/float.lisp
+++ b/src/compiler/ppc64/float.lisp
@@ -442,7 +442,7 @@
(:args (x) (y))
(:conditional)
(:info target not-p)
- (:variant-vars format yep nope)
+ (:variant-vars format yep nope quiet)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
@@ -451,7 +451,9 @@
(note-this-location vop :internal-error)
(ecase format
((:single :double)
- (inst fcmpo :cr1 x y)))
+ (if quiet
+ (inst fcmpu :cr1 x y)
+ (inst fcmpo :cr1 x y))))
(inst b? :cr1 (if not-p nope yep) target)))
(macrolet ((frob (name sc ptype)
@@ -462,17 +464,19 @@
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float))
-(macrolet ((frob (translate yep nope sname dname)
+(macrolet ((frob (translate yep nope sname dname &optional quiet)
`(progn
(define-vop (,sname single-float-compare)
(:translate ,translate)
- (:variant :single ,yep ,nope))
+ (:variant :single ,yep ,nope ,quiet))
(define-vop (,dname double-float-compare)
(:translate ,translate)
- (:variant :double ,yep ,nope)))))
+ (:variant :double ,yep ,nope ,quiet)))))
(frob < :lt :ge </single-float </double-float)
+ (frob quiet< :lt :ge quiet</single-float quiet</double-float t)
(frob > :gt :le >/single-float >/double-float)
- (frob = :eq :ne =/single-float =/double-float))
+ (frob = :eq :ne =/single-float =/double-float)
+ (frob quiet= :eq :ne quiet=/single-float quiet=/double-float t))
;;;; Conversion:
diff --git a/src/compiler/riscv/float.lisp b/src/compiler/riscv/float.lisp
index a8868c419..658a1b6ed 100644
--- a/src/compiler/riscv/float.lisp
+++ b/src/compiler/riscv/float.lisp
@@ -472,10 +472,12 @@
(inst beq temp zero-tn target)
(inst bne temp zero-tn target)))))))
(frob < flt nil </single-float </double-float)
+ (frob quiet< flt nil quiet</single-float quiet</double-float)
(frob <= fle nil <=/single-float <=/double-float)
(frob > flt t >/single-float >/double-float)
(frob >= fle t >=/single-float >=/double-float)
- (frob = feq nil =/single-float =/double-float))
+ (frob = feq nil =/single-float =/double-float)
+ (frob quiet= feq nil quiet=/single-float quiet=/double-float))
;;;; Conversion:
diff --git a/src/compiler/sparc/float.lisp b/src/compiler/sparc/float.lisp
index eca828d38..19661cb66 100644
--- a/src/compiler/sparc/float.lisp
+++ b/src/compiler/sparc/float.lisp
@@ -756,7 +756,7 @@
(:args (x) (y))
(:conditional)
(:info target not-p)
- (:variant-vars format yep nope)
+ (:variant-vars format yep nope quiet)
(:policy :fast-safe)
(:note "inline float comparison")
(:vop-var vop)
@@ -764,9 +764,15 @@
(:generator 3
(note-this-location vop :internal-error)
(ecase format
- (:single (inst fcmps x y))
- (:double (inst fcmpd x y))
- (:long (inst fcmpq x y)))
+ (:single (if quiet
+ (inst fcmps x y)
+ (inst fcmpes x y)))
+ (:double (if quiet
+ (inst fcmpd x y)
+ (inst fcmped x y)))
+ (:long (if quiet
+ (inst fcmpq x y)
+ (inst fcmpeq x y))))
;; The SPARC V9 doesn't need an instruction between a
;; floating-point compare and a floating-point branch.
(unless (member :sparc-v9 *backend-subfeatures*)
@@ -784,21 +790,23 @@
#+long-float
(frob long-float-compare long-reg long-float))
-(macrolet ((frob (translate yep nope sname dname #+long-float lname)
+(macrolet ((frob (translate yep nope sname dname #+long-float lname &optional quiet)
`(progn
(define-vop (,sname single-float-compare)
(:translate ,translate)
- (:variant :single ,yep ,nope))
+ (:variant :single ,yep ,nope ,quiet))
(define-vop (,dname double-float-compare)
(:translate ,translate)
- (:variant :double ,yep ,nope))
+ (:variant :double ,yep ,nope ,quiet))
#+long-float
(define-vop (,lname long-float-compare)
(:translate ,translate)
- (:variant :long ,yep ,nope)))))
+ (:variant :long ,yep ,nope ,quiet)))))
(frob < :l :ge </single-float </double-float #+long-float </long-float)
+ (frob quiet< :l :ge quiet</single-float quiet</double-float #+long-float quiet</long-float t)
(frob > :g :le >/single-float >/double-float #+long-float >/long-float)
- (frob = :eq :ne =/single-float =/double-float #+long-float =/long-float))
+ (frob = :eq :ne =/single-float =/double-float #+long-float =/long-float)
+ (frob quiet= :eq :ne quiet=/single-float quiet=/double-float #+long-float quiet=/long-float t))
#+long-float
(deftransform eql ((x y) (long-float long-float))
diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp
index 83bb0407f..5e8b507ec 100644
--- a/src/compiler/x86-64/float.lisp
+++ b/src/compiler/x86-64/float.lisp
@@ -937,6 +937,8 @@
(:temporary (:sc single-reg :from :eval) xmm)
(:conditional not :p :ne)
(:vop-var vop)
+ (:variant-vars quiet)
+ (:variant nil)
(:generator 3
(when (or (location= y xmm)
(and (not (xmm-tn-p x)) (xmm-tn-p y)))
@@ -953,7 +955,9 @@
(fp-immediate
(setf y (register-inline-constant (tn-value y))))
(t))
- (inst comiss xmm y)
+ (if quiet
+ (inst ucomiss xmm y)
+ (inst comiss xmm y))
;; if PF&CF, there was a NaN involved => not equal
;; otherwise, ZF => equal
))
@@ -966,6 +970,8 @@
:target xmm))
(:temporary (:sc double-reg :from :eval) xmm)
(:conditional not :p :ne)
+ (:variant-vars quiet)
+ (:variant nil)
(:vop-var vop)
(:generator 3
(when (or (location= y xmm)
@@ -989,7 +995,9 @@
(descriptor-reg
(setf y (ea-for-df-desc y)))
(t))
- (inst comisd xmm y)))
+ (if quiet
+ (inst ucomisd xmm y)
+ (inst comisd xmm y))))
(macrolet ((define-complex-float-= (complex-complex-name complex-real-name real-complex-name
real-sc real-type
@@ -1049,6 +1057,8 @@
(:info)
(:vop-var vop)
(:conditional ,@flags)
+ (:variant-vars quiet)
+ (:variant nil)
(:generator 3
(note-float-location ',op vop x y)
(sc-case y
@@ -1063,11 +1073,15 @@
(change-vop-flags vop '(,flip))
(rotatef x y))
`(t)))
- (inst comisd x y)))
+ (if quiet
+ (inst ucomisd x y)
+ (inst comisd x y))))
(define-vop (,single-name single-float-compare)
(:translate ,op)
(:info)
(:conditional ,@flags)
+ (:variant-vars quiet)
+ (:variant nil)
(:generator 3
(note-float-location ',op vop x y)
(sc-case y
@@ -1080,8 +1094,9 @@
(change-vop-flags vop '(,flip))
(rotatef x y))
`(t)))
-
- (inst comiss x y))))))
+ (if quiet
+ (inst ucomiss x y)
+ (inst comiss x y)))))))
;; UNORDERED: ZF,PF,CF <- 111;
;; GREATER_THAN: ZF,PF,CF <- 000;
;; LESS_THAN: ZF,PF,CF <- 001;
@@ -1093,6 +1108,19 @@
(define <= <=single-float <=double-float (not :p :a) :nb)
(define >= >=single-float >=double-float (:nb)))
+
+(define-vop (quiet<double-float <double-float)
+ (:translate quiet<)
+ (:variant t))
+(define-vop (quiet<single-float <single-float)
+ (:translate quiet<)
+ (:variant t))
+(define-vop (quiet=/double-float =/double-float)
+ (:translate quiet=)
+ (:variant t))
+(define-vop (quiet=/single-float =/single-float)
+ (:translate quiet=)
+ (:variant t))
;;;; conversion
diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index 0bcafb93d..859be33cc 100644
--- a/src/compiler/x86/float.lisp
+++ b/src/compiler/x86/float.lisp
@@ -1174,28 +1174,38 @@
(:save-p :compute-only)
(:note "inline float comparison")
(:ignore temp)
+ (:variant-vars quiet)
+ (:variant nil)
(:generator 3
- (note-this-location vop :internal-error)
- (cond
+ (note-this-location vop :internal-error)
+ (cond
;; x is in ST0; y is in any reg.
((zerop (tn-offset x))
- (inst fucom y))
+ (if quiet
+ (inst fucom y)
+ (inst fcom y)))
;; y is in ST0; x is in another reg.
((zerop (tn-offset y))
- (inst fucom x))
+ (if quiet
+ (inst fucom x)
+ (inst fcom x)))
;; x and y are the same register, not ST0
((location= x y)
(inst fxch x)
- (inst fucom fr0-tn)
+ (if quiet
+ (inst fucom fr0-tn)
+ (inst fcom fr0-tn))
(inst fxch x))
;; x and y are different registers, neither ST0.
(t
(inst fxch x)
- (inst fucom y)
+ (if quiet
+ (inst fucom y)
+ (inst fcom y))
(inst fxch x)))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
- (inst cmp ah-tn #x40)))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
+ (inst cmp ah-tn #x40)))
(define-vop (=/single-float =/float)
(:translate =)
@@ -1209,6 +1219,14 @@
(y :scs (double-reg)))
(:arg-types double-float double-float))
+(define-vop (quiet=/single-float =/single-float)
+ (:variant t)
+ (:translate quiet=))
+
+(define-vop (quiet=/double-float =/double-float)
+ (:variant t)
+ (:translate quiet=))
+
#+long-float
(define-vop (=/long-float =/float)
(:translate =)
@@ -1227,40 +1245,54 @@
(:policy :fast-safe)
(:note "inline float comparison")
(:ignore temp)
+ (:variant-vars quiet)
+ (:variant nil)
(:generator 3
;; Handle a few special cases.
(cond
- ;; y is ST0.
- ((and (sc-is y single-reg) (zerop (tn-offset y)))
- (sc-case x
- (single-reg
- (inst fcom x))
- ((single-stack descriptor-reg)
- (if (sc-is x single-stack)
- (inst fcom (ea-for-sf-stack x))
- (inst fcom (ea-for-sf-desc x)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45))
-
- ;; general case when y is not in ST0
- (t
- ;; x to ST0
- (sc-case x
+ ;; y is ST0.
+ ((and (sc-is y single-reg) (zerop (tn-offset y)))
+ (sc-case x
(single-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
+ (if quiet
+ (inst fucom x)
+ (inst fcom x)))
((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x single-stack)
- (inst fld (ea-for-sf-stack x))
- (inst fld (ea-for-sf-desc x)))))
+ (if quiet
+ (inst fucom (if (sc-is x single-stack)
+ (ea-for-sf-stack x)
+ (ea-for-sf-desc x)))
+ (inst fcom (if (sc-is x single-stack)
+ (ea-for-sf-stack x)
+ (ea-for-sf-desc x))))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45))
+
+ ;; general case when y is not in ST0
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x single-stack)
+ (inst fld (ea-for-sf-stack x))
+ (inst fld (ea-for-sf-desc x)))))
(sc-case y
(single-reg
- (inst fcom y))
+ (if quiet
+ (inst fucom y)
+ (inst fcom y)))
((single-stack descriptor-reg)
- (if (sc-is y single-stack)
- (inst fcom (ea-for-sf-stack y))
- (inst fcom (ea-for-sf-desc y)))))
+ (if quiet
+ (inst fucom (if (sc-is y single-stack)
+ (ea-for-sf-stack y)
+ (ea-for-sf-desc y)))
+ (inst fcom (if (sc-is y single-stack)
+ (ea-for-sf-stack y)
+ (ea-for-sf-desc y))))))
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x01)))))
@@ -1276,44 +1308,73 @@
(:policy :fast-safe)
(:note "inline float comparison")
(:ignore temp)
+ (:variant-vars quiet)
+ (:variant nil)
(:generator 3
;; Handle a few special cases
(cond
- ;; y is ST0.
- ((and (sc-is y double-reg) (zerop (tn-offset y)))
- (sc-case x
- (double-reg
- (inst fcomd x))
- ((double-stack descriptor-reg)
- (if (sc-is x double-stack)
- (inst fcomd (ea-for-df-stack x))
- (inst fcomd (ea-for-df-desc x)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45))
-
- ;; General case when y is not in ST0.
- (t
- ;; x to ST0
- (sc-case x
+ ;; y is ST0.
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ (sc-case x
(double-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
+ (if quiet
+ (inst fucom x)
+ (inst fcomd x)))
((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
+ (if quiet
+ (inst fucom
+ (if (sc-is x double-stack)
+ (ea-for-df-stack x)
+ (ea-for-df-desc x)))
+ (inst fcomd
+ (if (sc-is x double-stack)
+ (ea-for-df-stack x)
+ (ea-for-df-desc x))))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45))
+
+ ;; General case when y is not in ST0.
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
(sc-case y
(double-reg
- (inst fcomd y))
+ (if quiet
+ (inst fucom y)
+ (inst fcomd y)))
((double-stack descriptor-reg)
- (if (sc-is y double-stack)
- (inst fcomd (ea-for-df-stack y))
- (inst fcomd (ea-for-df-desc y)))))
+ (if quiet
+ (inst fucom
+ (if (sc-is y double-stack)
+ (ea-for-df-stack y)
+ (ea-for-df-desc y)))
+ (inst fcomd
+ (if (sc-is y double-stack)
+ (ea-for-df-stack y)
+ (ea-for-df-desc y))))))
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x01)))))
+(define-vop (quiet<double-float <double-float)
+ (:args (x :scs (double-reg))
+ (y :scs (double-reg)))
+ (:translate quiet<)
+ (:variant t))
+(define-vop (quiet<single-float <single-float)
+ (:args (x :scs (single-reg))
+ (y :scs (single-reg)))
+ (:translate quiet<)
+ (:variant t))
+
#+long-float
(define-vop (<long-float)
(:translate <)
diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr
index a677443c1..e3f3bb137 100644
--- a/xperfecthash63.lisp-expr
+++ b/xperfecthash63.lisp-expr
@@ -1776,5 +1776,8 @@
(#(A49305EF D0241AE7 E55E7F8C EE9A5410)
"(SB-PCL::%CLASS SB-PCL::%PARAMETER SB-PCL::%VARIABLE-REBINDING SPECIAL)"
"((& (>> val 8) 3))")
+(#(359CB801 4D28C61A 53351B33 A2DD0906 B9B79FF6)
+ "(FUNCTION SB-IMPL::PREDICATE SB-IMPL::KEY SB-IMPL::TEST SB-IMPL::TEST-NOT)"
+ "((& (^ (>> val 3) (>> val 6)) 7))")
)
;; EOF
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL