common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Don't signal errors for (log qnan)

Browse source 
Fixes lp#2160268
This commit is contained in:
Stas Boukarev 2026-07-19 01:02:19 +03:00
parent 3751ecd356
commit 246af00412
16 changed files with 291 additions and 137 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
src/code/float.lisp
View file

@ -816,3 +816,25 @@
(t (t
(ash int exp))))))) (ash int exp)))))))
((rational) x))) ((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)))))

22
src/code/irrat.lisp
View file

@ -345,17 +345,17 @@
(clear-info :source-location :declaration s))) (clear-info :source-location :declaration s)))
(defun sqrt-double-float (number) (defun sqrt-double-float (number)
(if (< number 0) (if (quiet< number 0)
(complex 0d0 (sqrt (- number))) (complex 0d0 (sqrt (- number)))
(sqrt number))) (sqrt number)))
(defun sqrt-single-float (number) (defun sqrt-single-float (number)
(if (< number 0) (if (quiet< number 0)
(complex 0f0 (sqrt (- number))) (complex 0f0 (sqrt (- number)))
(sqrt number))) (sqrt number)))
(defun log-double-float (number) (defun log-double-float (number)
(if (< number 0) (if (quiet< number 0)
(complex (log (- number)) pi) (complex (log (- number)) pi)
(log number))) (log number)))
@ -365,18 +365,18 @@
(log number))) (log number)))
(defun log-double-float2 (number base) (defun log-double-float2 (number base)
(if (zerop base) (if (quiet= base 0d0)
0d0 0d0
(if (or (< base 0) (if (or (quiet< base 0)
(< number 0)) (quiet< number 0))
(/ (log number) (log base)) (/ (log number) (log base))
(truly-the double-float (log number base))))) (truly-the double-float (log number base)))))
(defun log-single-float2 (number base) (defun log-single-float2 (number base)
(if (zerop base) (if (quiet= base 0d0)
0.0 0.0
(if (or (< base 0) (if (or (quiet< base 0)
(< number 0)) (quiet< number 0))
(/ (log number) (log base)) (/ (log number) (log base))
(truly-the single-float (log number base))))) (truly-the single-float (log number base)))))
@ -513,7 +513,7 @@
'single-float))))) 'single-float)))))
(((foreach single-float double-float)) (((foreach single-float double-float))
;; IEEE 754 says (log -0.0) should be -inf ;; 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))) (complex (log (- number)) (coerce pi '(dispatch-type number)))
(log number))) (log number)))
((complex) ((complex)
@ -530,7 +530,7 @@
(coerce (%sqrt (- (coerce number 'double-float))) 'single-float)) (coerce (%sqrt (- (coerce number 'double-float))) 'single-float))
(coerce (%sqrt (coerce number 'double-float)) 'single-float))) (coerce (%sqrt (coerce number 'double-float)) 'single-float)))
(((foreach single-float double-float)) (((foreach single-float double-float))
(if (minusp number) (if (quiet< number 0)
(complex (coerce 0.0 '(dispatch-type number)) (complex (coerce 0.0 '(dispatch-type number))
(sqrt (- number))) (sqrt (- number)))
(sqrt number))) (sqrt number)))

3
src/cold/exports.lisp
View file

@ -2394,7 +2394,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"INLINE-VOP" "INLINE-VOP"
"WRAP-IF" "COND-DISPATCH" "WRAP-IF" "COND-DISPATCH"
"MAKE-DEFS" "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 #+sb-simd-pack
(:export "SIMD-PACK" (:export "SIMD-PACK"
"SIMD-PACK-P" "SIMD-PACK-P"

32
src/compiler/arm/float.lisp
View file

@ -371,7 +371,7 @@
(define-vop (float-compare) (define-vop (float-compare)
(:args (x) (y)) (:args (x) (y))
(:variant-vars format is-=) (:variant-vars format quiet)
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:vop-var vop) (:vop-var vop)
@ -380,11 +380,11 @@
(note-this-location vop :internal-error) (note-this-location vop :internal-error)
(ecase format (ecase format
(:single (:single
(if is-= (if quiet
(inst fcmps x y) (inst fcmps x y)
(inst fcmpes x y))) (inst fcmpes x y)))
(:double (:double
(if is-= (if quiet
(inst fcmpd x y) (inst fcmpd x y)
(inst fcmped x y)))) (inst fcmped x y))))
(inst fmstat))) (inst fmstat)))
@ -397,25 +397,27 @@
(frob single-float-compare single-reg single-float) (frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float)) (frob double-float-compare double-reg double-float))
(macrolet ((frob (translate cond sname dname is-=) (macrolet ((frob (translate cond sname dname quiet)
`(progn `(progn
(define-vop (,sname single-float-compare) (define-vop (,sname single-float-compare)
(:translate ,translate) (:translate ,translate)
(:conditional ,cond) (:conditional ,cond)
(:variant :single ,is-=)) (:variant :single ,quiet))
(define-vop (,dname double-float-compare) (define-vop (,dname double-float-compare)
(:translate ,translate) (:translate ,translate)
(:conditional ,cond) (:conditional ,cond)
(:variant :double ,is-=))))) (:variant :double ,quiet)))))
(frob < :mi </single-float </double-float nil) (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 > :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) (define-vop (float-compare-zero)
(:args (x)) (:args (x))
(:info y) (:info y)
(:ignore y) (:ignore y)
(:variant-vars format is-=) (:variant-vars format quiet)
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:vop-var vop) (:vop-var vop)
@ -424,11 +426,11 @@
(note-this-location vop :internal-error) (note-this-location vop :internal-error)
(ecase format (ecase format
(:single (:single
(if is-= (if quiet
(inst fcmpzs x) (inst fcmpzs x)
(inst fcmpezs x))) (inst fcmpezs x)))
(:double (:double
(if is-= (if quiet
(inst fcmpzd x) (inst fcmpzd x)
(inst fcmpezd x)))) (inst fcmpezd x))))
(inst fmstat))) (inst fmstat)))
@ -442,19 +444,21 @@
(frob double-float-compare-zero double-reg double-float (frob double-float-compare-zero double-reg double-float
(double-float -0d0 0d0))) (double-float -0d0 0d0)))
(macrolet ((frob (translate cond sname dname is-=) (macrolet ((frob (translate cond sname dname quiet)
`(progn `(progn
(define-vop (,sname single-float-compare-zero) (define-vop (,sname single-float-compare-zero)
(:translate ,translate) (:translate ,translate)
(:conditional ,cond) (:conditional ,cond)
(:variant :single ,is-=)) (:variant :single ,quiet))
(define-vop (,dname double-float-compare-zero) (define-vop (,dname double-float-compare-zero)
(:translate ,translate) (:translate ,translate)
(:conditional ,cond) (:conditional ,cond)
(:variant :double ,is-=))))) (:variant :double ,quiet)))))
(frob < :mi </single-float-zero </double-float-zero nil) (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 > :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: ;;;; Conversion:

28
src/compiler/arm64/float.lisp
View file

@ -519,14 +519,14 @@
(define-vop (float-compare) (define-vop (float-compare)
(:args (x) (y)) (:args (x) (y))
(:variant-vars is-=) (:variant-vars quiet)
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:vop-var vop) (:vop-var vop)
(:save-p :compute-only) (:save-p :compute-only)
(:generator 3 (:generator 3
(note-this-location vop :internal-error) (note-this-location vop :internal-error)
(if is-= (if quiet
(inst fcmp x y) (inst fcmp x y)
(inst fcmpe x y)))) (inst fcmpe x y))))
@ -538,34 +538,36 @@
(frob single-float-compare single-reg single-float) (frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float)) (frob double-float-compare double-reg double-float))
(macrolet ((frob (translate cond sname dname is-=) (macrolet ((frob (translate cond sname dname quiet)
`(progn `(progn
(define-vop (,sname single-float-compare) (define-vop (,sname single-float-compare)
(:translate ,translate) (:translate ,translate)
(:conditional ,cond) (:conditional ,cond)
(:variant ,is-=)) (:variant ,quiet))
(define-vop (,dname double-float-compare) (define-vop (,dname double-float-compare)
(:translate ,translate) (:translate ,translate)
(:conditional ,cond) (:conditional ,cond)
(:variant ,is-=))))) (:variant ,quiet)))))
(frob < :mi </single-float </double-float nil) (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 > :gt >/single-float >/double-float nil)
(frob <= :ls <=/single-float <=/double-float nil) (frob <= :ls <=/single-float <=/double-float nil)
(frob >= :ge >=/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) (define-vop (float-compare-zero)
(:args (x)) (:args (x))
(:info y) (:info y)
(:ignore y) (:ignore y)
(:variant-vars is-=) (:variant-vars quiet)
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:vop-var vop) (:vop-var vop)
(:save-p :compute-only) (:save-p :compute-only)
(:generator 2 (:generator 2
(note-this-location vop :internal-error) (note-this-location vop :internal-error)
(if is-= (if quiet
(inst fcmp x 0) (inst fcmp x 0)
(inst fcmpe x 0)))) (inst fcmpe x 0))))
@ -578,21 +580,23 @@
(frob double-float-compare-zero double-reg double-float (frob double-float-compare-zero double-reg double-float
(double-float -0d0 0d0))) (double-float -0d0 0d0)))
(macrolet ((frob (translate cond sname dname is-=) (macrolet ((frob (translate cond sname dname quiet)
`(progn `(progn
(define-vop (,sname single-float-compare-zero) (define-vop (,sname single-float-compare-zero)
(:translate ,translate) (:translate ,translate)
(:conditional ,cond) (:conditional ,cond)
(:variant ,is-=)) (:variant ,quiet))
(define-vop (,dname double-float-compare-zero) (define-vop (,dname double-float-compare-zero)
(:translate ,translate) (:translate ,translate)
(:conditional ,cond) (:conditional ,cond)
(:variant ,is-=))))) (:variant ,quiet)))))
(frob < :mi </single-float-zero </double-float-zero nil) (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 > :gt >/single-float-zero >/double-float-zero nil)
(frob <= :ls <=/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 >= :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-= (macrolet ((define-complex-float-=
(complex-complex-name complex-real-name real-complex-name (complex-complex-name complex-real-name real-complex-name

24
src/compiler/float-tran.lisp
View file

@ -530,7 +530,7 @@
(deftransform log ((x) ($type) * :node node) (deftransform log ((x) ($type) * :node node)
(let ((cast (cast-or-check-bound-type node (specifier-type 'real)))) (let ((cast (cast-or-check-bound-type node (specifier-type 'real))))
(if cast (if cast
`(if (< x 0) `(if (quiet< x 0)
(sb-vm::op-not-type1-error x '(,(type-specifier cast) . log)) (sb-vm::op-not-type1-error x '(,(type-specifier cast) . log))
($log x)) ($log x))
(give-up-ir1-transform)))) (give-up-ir1-transform))))
@ -538,10 +538,10 @@
(deftransform log ((x y) ($type $type) * :node node) (deftransform log ((x y) ($type $type) * :node node)
(let ((cast (cast-or-check-bound-type node (specifier-type 'real)))) (let ((cast (cast-or-check-bound-type node (specifier-type 'real))))
(if cast (if cast
`(if (= y 0) `(if (quiet= y 0)
(coerce 0 '$type) (coerce 0 '$type)
(if (or (< x 0) (if (or (quiet< x 0)
(< y 0)) (quiet< y 0))
(sb-vm::op-not-type2-error x y '(,(type-specifier cast) . log)) (sb-vm::op-not-type2-error x y '(,(type-specifier cast) . log))
(/ ($log x) ($log y)))) (/ ($log x) ($log y))))
(give-up-ir1-transform)))) (give-up-ir1-transform))))
@ -549,7 +549,7 @@
(deftransform sqrt ((x) ($type) * :node node) (deftransform sqrt ((x) ($type) * :node node)
(let ((cast (cast-or-check-bound-type node (specifier-type 'real)))) (let ((cast (cast-or-check-bound-type node (specifier-type 'real))))
(if cast (if cast
`(if (< x 0) `(if (quiet< x 0)
(sb-vm::op-not-type1-error x '(,(type-specifier cast) . sqrt)) (sb-vm::op-not-type1-error x '(,(type-specifier cast) . sqrt))
($sqrt x)) ($sqrt x))
(give-up-ir1-transform))))) (give-up-ir1-transform)))))
@ -557,7 +557,7 @@
(deftransform sqrt ((x) (rational) * :node node) (deftransform sqrt ((x) (rational) * :node node)
(let ((cast (cast-or-check-bound-type node (specifier-type 'real)))) (let ((cast (cast-or-check-bound-type node (specifier-type 'real))))
(if cast (if cast
`(if (< x 0) `(if (quiet< x 0)
(sb-vm::op-not-type1-error x '(,(type-specifier cast) . sqrt)) (sb-vm::op-not-type1-error x '(,(type-specifier cast) . sqrt))
(%single-float (%sqrt (%double-float x)))) (%single-float (%sqrt (%double-float x))))
(give-up-ir1-transform)))) (give-up-ir1-transform))))
@ -1574,7 +1574,7 @@
(csubtypep (lvar-type y) (specifier-type 'single-float)) (csubtypep (lvar-type y) (specifier-type 'single-float))
(let ((x (lvar-value x))) (let ((x (lvar-value x)))
(when (and (safe-single-coercion-p 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))))) `(,(lvar-fun-name (basic-combination-fun node)) ,(coerce x 'single-float) y)))))
(t (t
`(,(lvar-fun-name (basic-combination-fun node)) x (%double-float y))))) `(,(lvar-fun-name (basic-combination-fun node)) x (%double-float y)))))
@ -1586,7 +1586,7 @@
(csubtypep (lvar-type x) (specifier-type 'single-float)) (csubtypep (lvar-type x) (specifier-type 'single-float))
(let ((y (lvar-value y))) (let ((y (lvar-value y)))
(when (and (safe-single-coercion-p 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)))))) `(,(lvar-fun-name (basic-combination-fun node)) x ,(coerce y 'single-float))))))
(t (t
`(,(lvar-fun-name (basic-combination-fun node)) (%double-float x) y)))) `(,(lvar-fun-name (basic-combination-fun node)) (%double-float x) y))))
@ -1643,9 +1643,15 @@
,most-positive-exactly-double-float-integer)) ,most-positive-exactly-double-float-integer))
double-float)) double-float))
#'real-double-float-contagion-cmp nil))) #'real-double-float-contagion-cmp nil)))
(dolist (op '(= < > <= >=)) (dolist (op '(= < > <= >= quiet< quiet=))
(def op))) (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)) (%deftransform '= nil '(function ((complex double-float) single-float))
#'double-float-real-contagion nil) #'double-float-real-contagion nil)
(%deftransform '= nil '(function (single-float (complex double-float))) (%deftransform '= nil '(function (single-float (complex double-float)))

3
src/compiler/fndb.lisp
View file

@ -232,6 +232,9 @@
(defknown (max min) (real &rest real) real (defknown (max min) (real &rest real) real
(movable foldable flushable)) (movable foldable flushable))
(defknown (quiet= quiet<) (real real) boolean
(movable foldable flushable))
(defknown (+ *) (&rest number) number (defknown (+ *) (&rest number) number
(movable foldable flushable commutative)) (movable foldable flushable commutative))
(defknown - (number &rest number) number (defknown - (number &rest number) number

12
src/compiler/loongarch64/float.lisp
View file

@ -416,11 +416,13 @@
(if not-p (if not-p
(inst bceqz 5 target) (inst bceqz 5 target)
(inst bcnez 5 target))))))) (inst bcnez 5 target)))))))
(frob < fcmp.clt.s fcmp.clt.d nil </single-float </double-float) (frob < fcmp.slt.s fcmp.slt.d nil </single-float </double-float)
(frob <= fcmp.cle.s fcmp.cle.d nil <=/single-float <=/double-float) (frob quiet< fcmp.clt.s fcmp.clt.d nil quiet</single-float quiet</double-float)
(frob > fcmp.clt.s fcmp.clt.d t >/single-float >/double-float) (frob <= fcmp.sle.s fcmp.sle.d nil <=/single-float <=/double-float)
(frob >= fcmp.cle.s fcmp.cle.d t >=/single-float >=/double-float) (frob > fcmp.slt.s fcmp.slt.d t >/single-float >/double-float)
(frob = fcmp.ceq.s fcmp.ceq.d nil =/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 (macrolet ((frob (name translate
from-sc from-type from-format from-sc from-type from-format

4
src/compiler/mips/float.lisp
View file

@ -530,8 +530,10 @@
(:translate ,translate) (:translate ,translate)
(:variant :double ,op ,complement))))) (:variant :double ,op ,complement)))))
(frob < :lt nil </single-float </double-float) (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 > :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: ;;;; Conversion:

16
src/compiler/ppc/float.lisp
View file

@ -407,7 +407,7 @@
(:args (x) (y)) (:args (x) (y))
(:conditional) (:conditional)
(:info target not-p) (:info target not-p)
(:variant-vars format yep nope) (:variant-vars format yep nope quiet)
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:vop-var vop) (:vop-var vop)
@ -416,7 +416,9 @@
(note-this-location vop :internal-error) (note-this-location vop :internal-error)
(ecase format (ecase format
((:single :double) ((: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))) (inst b? :cr1 (if not-p nope yep) target)))
(macrolet ((frob (name sc ptype) (macrolet ((frob (name sc ptype)
@ -427,17 +429,19 @@
(frob single-float-compare single-reg single-float) (frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-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 `(progn
(define-vop (,sname single-float-compare) (define-vop (,sname single-float-compare)
(:translate ,translate) (:translate ,translate)
(:variant :single ,yep ,nope)) (:variant :single ,yep ,nope ,quiet))
(define-vop (,dname double-float-compare) (define-vop (,dname double-float-compare)
(:translate ,translate) (:translate ,translate)
(:variant :double ,yep ,nope))))) (:variant :double ,yep ,nope ,quiet)))))
(frob < :lt :ge </single-float </double-float) (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 > :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: ;;;; Conversion:

16
src/compiler/ppc64/float.lisp
View file

@ -442,7 +442,7 @@
(:args (x) (y)) (:args (x) (y))
(:conditional) (:conditional)
(:info target not-p) (:info target not-p)
(:variant-vars format yep nope) (:variant-vars format yep nope quiet)
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:vop-var vop) (:vop-var vop)
@ -451,7 +451,9 @@
(note-this-location vop :internal-error) (note-this-location vop :internal-error)
(ecase format (ecase format
((:single :double) ((: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))) (inst b? :cr1 (if not-p nope yep) target)))
(macrolet ((frob (name sc ptype) (macrolet ((frob (name sc ptype)
@ -462,17 +464,19 @@
(frob single-float-compare single-reg single-float) (frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-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 `(progn
(define-vop (,sname single-float-compare) (define-vop (,sname single-float-compare)
(:translate ,translate) (:translate ,translate)
(:variant :single ,yep ,nope)) (:variant :single ,yep ,nope ,quiet))
(define-vop (,dname double-float-compare) (define-vop (,dname double-float-compare)
(:translate ,translate) (:translate ,translate)
(:variant :double ,yep ,nope))))) (:variant :double ,yep ,nope ,quiet)))))
(frob < :lt :ge </single-float </double-float) (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 > :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: ;;;; Conversion:

4
src/compiler/riscv/float.lisp
View file

@ -472,10 +472,12 @@
(inst beq temp zero-tn target) (inst beq temp zero-tn target)
(inst bne temp zero-tn target))))))) (inst bne temp zero-tn target)))))))
(frob < flt nil </single-float </double-float) (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 <= fle nil <=/single-float <=/double-float)
(frob > flt t >/single-float >/double-float) (frob > flt t >/single-float >/double-float)
(frob >= fle 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: ;;;; Conversion:

26
src/compiler/sparc/float.lisp
View file

@ -756,7 +756,7 @@
(:args (x) (y)) (:args (x) (y))
(:conditional) (:conditional)
(:info target not-p) (:info target not-p)
(:variant-vars format yep nope) (:variant-vars format yep nope quiet)
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:vop-var vop) (:vop-var vop)
@ -764,9 +764,15 @@
(:generator 3 (:generator 3
(note-this-location vop :internal-error) (note-this-location vop :internal-error)
(ecase format (ecase format
(:single (inst fcmps x y)) (:single (if quiet
(:double (inst fcmpd x y)) (inst fcmps x y)
(:long (inst fcmpq 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 ;; The SPARC V9 doesn't need an instruction between a
;; floating-point compare and a floating-point branch. ;; floating-point compare and a floating-point branch.
(unless (member :sparc-v9 *backend-subfeatures*) (unless (member :sparc-v9 *backend-subfeatures*)
@ -784,21 +790,23 @@
#+long-float #+long-float
(frob long-float-compare long-reg 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 `(progn
(define-vop (,sname single-float-compare) (define-vop (,sname single-float-compare)
(:translate ,translate) (:translate ,translate)
(:variant :single ,yep ,nope)) (:variant :single ,yep ,nope ,quiet))
(define-vop (,dname double-float-compare) (define-vop (,dname double-float-compare)
(:translate ,translate) (:translate ,translate)
(:variant :double ,yep ,nope)) (:variant :double ,yep ,nope ,quiet))
#+long-float #+long-float
(define-vop (,lname long-float-compare) (define-vop (,lname long-float-compare)
(:translate ,translate) (:translate ,translate)
(:variant :long ,yep ,nope))))) (:variant :long ,yep ,nope ,quiet)))))
(frob < :l :ge </single-float </double-float #+long-float </long-float) (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 > :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 #+long-float
(deftransform eql ((x y) (long-float long-float)) (deftransform eql ((x y) (long-float long-float))

38
src/compiler/x86-64/float.lisp
View file

@ -937,6 +937,8 @@
(:temporary (:sc single-reg :from :eval) xmm) (:temporary (:sc single-reg :from :eval) xmm)
(:conditional not :p :ne) (:conditional not :p :ne)
(:vop-var vop) (:vop-var vop)
(:variant-vars quiet)
(:variant nil)
(:generator 3 (:generator 3
(when (or (location= y xmm) (when (or (location= y xmm)
(and (not (xmm-tn-p x)) (xmm-tn-p y))) (and (not (xmm-tn-p x)) (xmm-tn-p y)))
@ -953,7 +955,9 @@
(fp-immediate (fp-immediate
(setf y (register-inline-constant (tn-value y)))) (setf y (register-inline-constant (tn-value y))))
(t)) (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 ;; if PF&CF, there was a NaN involved => not equal
;; otherwise, ZF => equal ;; otherwise, ZF => equal
)) ))
@ -966,6 +970,8 @@
:target xmm)) :target xmm))
(:temporary (:sc double-reg :from :eval) xmm) (:temporary (:sc double-reg :from :eval) xmm)
(:conditional not :p :ne) (:conditional not :p :ne)
(:variant-vars quiet)
(:variant nil)
(:vop-var vop) (:vop-var vop)
(:generator 3 (:generator 3
(when (or (location= y xmm) (when (or (location= y xmm)
@ -989,7 +995,9 @@
(descriptor-reg (descriptor-reg
(setf y (ea-for-df-desc y))) (setf y (ea-for-df-desc y)))
(t)) (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 (macrolet ((define-complex-float-= (complex-complex-name complex-real-name real-complex-name
real-sc real-type real-sc real-type
@ -1049,6 +1057,8 @@
(:info) (:info)
(:vop-var vop) (:vop-var vop)
(:conditional ,@flags) (:conditional ,@flags)
(:variant-vars quiet)
(:variant nil)
(:generator 3 (:generator 3
(note-float-location ',op vop x y) (note-float-location ',op vop x y)
(sc-case y (sc-case y
@ -1063,11 +1073,15 @@
(change-vop-flags vop '(,flip)) (change-vop-flags vop '(,flip))
(rotatef x y)) (rotatef x y))
`(t))) `(t)))
(inst comisd x y))) (if quiet
(inst ucomisd x y)
(inst comisd x y))))
(define-vop (,single-name single-float-compare) (define-vop (,single-name single-float-compare)
(:translate ,op) (:translate ,op)
(:info) (:info)
(:conditional ,@flags) (:conditional ,@flags)
(:variant-vars quiet)
(:variant nil)
(:generator 3 (:generator 3
(note-float-location ',op vop x y) (note-float-location ',op vop x y)
(sc-case y (sc-case y
@ -1080,8 +1094,9 @@
(change-vop-flags vop '(,flip)) (change-vop-flags vop '(,flip))
(rotatef x y)) (rotatef x y))
`(t))) `(t)))
(if quiet
(inst comiss x y)))))) (inst ucomiss x y)
(inst comiss x y)))))))
;; UNORDERED: ZF,PF,CF <- 111; ;; UNORDERED: ZF,PF,CF <- 111;
;; GREATER_THAN: ZF,PF,CF <- 000; ;; GREATER_THAN: ZF,PF,CF <- 000;
;; LESS_THAN: ZF,PF,CF <- 001; ;; LESS_THAN: ZF,PF,CF <- 001;
@ -1093,6 +1108,19 @@
(define <= <=single-float <=double-float (not :p :a) :nb) (define <= <=single-float <=double-float (not :p :a) :nb)
(define >= >=single-float >=double-float (: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 ;;;; conversion

175
src/compiler/x86/float.lisp
View file

@ -1174,28 +1174,38 @@
(:save-p :compute-only) (:save-p :compute-only)
(:note "inline float comparison") (:note "inline float comparison")
(:ignore temp) (:ignore temp)
(:variant-vars quiet)
(:variant nil)
(:generator 3 (:generator 3
(note-this-location vop :internal-error) (note-this-location vop :internal-error)
(cond (cond
;; x is in ST0; y is in any reg. ;; x is in ST0; y is in any reg.
((zerop (tn-offset x)) ((zerop (tn-offset x))
(inst fucom y)) (if quiet
(inst fucom y)
(inst fcom y)))
;; y is in ST0; x is in another reg. ;; y is in ST0; x is in another reg.
((zerop (tn-offset y)) ((zerop (tn-offset y))
(inst fucom x)) (if quiet
(inst fucom x)
(inst fcom x)))
;; x and y are the same register, not ST0 ;; x and y are the same register, not ST0
((location= x y) ((location= x y)
(inst fxch x) (inst fxch x)
(inst fucom fr0-tn) (if quiet
(inst fucom fr0-tn)
(inst fcom fr0-tn))
(inst fxch x)) (inst fxch x))
;; x and y are different registers, neither ST0. ;; x and y are different registers, neither ST0.
(t (t
(inst fxch x) (inst fxch x)
(inst fucom y) (if quiet
(inst fucom y)
(inst fcom y))
(inst fxch x))) (inst fxch x)))
(inst fnstsw) ; status word to ax (inst fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0 (inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x40))) (inst cmp ah-tn #x40)))
(define-vop (=/single-float =/float) (define-vop (=/single-float =/float)
(:translate =) (:translate =)
@ -1209,6 +1219,14 @@
(y :scs (double-reg))) (y :scs (double-reg)))
(:arg-types double-float double-float)) (: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 #+long-float
(define-vop (=/long-float =/float) (define-vop (=/long-float =/float)
(:translate =) (:translate =)
@ -1227,40 +1245,54 @@
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:ignore temp) (:ignore temp)
(:variant-vars quiet)
(:variant nil)
(:generator 3 (:generator 3
;; Handle a few special cases. ;; Handle a few special cases.
(cond (cond
;; y is ST0. ;; y is ST0.
((and (sc-is y single-reg) (zerop (tn-offset y))) ((and (sc-is y single-reg) (zerop (tn-offset y)))
(sc-case x
(single-reg
(if quiet
(inst fucom x)
(inst fcom x)))
((single-stack descriptor-reg)
(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 (sc-case x
(single-reg (single-reg
(inst fcom x)) (unless (zerop (tn-offset x))
(copy-fp-reg-to-fr0 x)))
((single-stack descriptor-reg) ((single-stack descriptor-reg)
(inst fstp fr0)
(if (sc-is x single-stack) (if (sc-is x single-stack)
(inst fcom (ea-for-sf-stack x)) (inst fld (ea-for-sf-stack x))
(inst fcom (ea-for-sf-desc x))))) (inst fld (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 (sc-case y
(single-reg (single-reg
(inst fcom y)) (if quiet
(inst fucom y)
(inst fcom y)))
((single-stack descriptor-reg) ((single-stack descriptor-reg)
(if (sc-is y single-stack) (if quiet
(inst fcom (ea-for-sf-stack y)) (inst fucom (if (sc-is y single-stack)
(inst fcom (ea-for-sf-desc y))))) (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 fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0 (inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x01))))) (inst cmp ah-tn #x01)))))
@ -1276,44 +1308,73 @@
(:policy :fast-safe) (:policy :fast-safe)
(:note "inline float comparison") (:note "inline float comparison")
(:ignore temp) (:ignore temp)
(:variant-vars quiet)
(:variant nil)
(:generator 3 (:generator 3
;; Handle a few special cases ;; Handle a few special cases
(cond (cond
;; y is ST0. ;; y is ST0.
((and (sc-is y double-reg) (zerop (tn-offset y))) ((and (sc-is y double-reg) (zerop (tn-offset y)))
(sc-case x
(double-reg
(if quiet
(inst fucom x)
(inst fcomd x)))
((double-stack descriptor-reg)
(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 (sc-case x
(double-reg (double-reg
(inst fcomd x)) (unless (zerop (tn-offset x))
(copy-fp-reg-to-fr0 x)))
((double-stack descriptor-reg) ((double-stack descriptor-reg)
(inst fstp fr0)
(if (sc-is x double-stack) (if (sc-is x double-stack)
(inst fcomd (ea-for-df-stack x)) (inst fldd (ea-for-df-stack x))
(inst fcomd (ea-for-df-desc x))))) (inst fldd (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 (sc-case y
(double-reg (double-reg
(inst fcomd y)) (if quiet
(inst fucom y)
(inst fcomd y)))
((double-stack descriptor-reg) ((double-stack descriptor-reg)
(if (sc-is y double-stack) (if quiet
(inst fcomd (ea-for-df-stack y)) (inst fucom
(inst fcomd (ea-for-df-desc y))))) (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 fnstsw) ; status word to ax
(inst and ah-tn #x45) ; C3 C2 C0 (inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x01))))) (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 #+long-float
(define-vop (<long-float) (define-vop (<long-float)
(:translate <) (:translate <)

3
xperfecthash63.lisp-expr
View file

@ -1776,5 +1776,8 @@
(#(A49305EF D0241AE7 E55E7F8C EE9A5410) (#(A49305EF D0241AE7 E55E7F8C EE9A5410)
"(SB-PCL::%CLASS SB-PCL::%PARAMETER SB-PCL::%VARIABLE-REBINDING SPECIAL)" "(SB-PCL::%CLASS SB-PCL::%PARAMETER SB-PCL::%VARIABLE-REBINDING SPECIAL)"
"((& (>> val 8) 3))") "((& (>> 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 ;; EOF