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
(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)))))

22
src/code/irrat.lisp
View file

@ -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)))

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"
"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"

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

@ -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:

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

@ -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

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

@ -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)))

3
src/compiler/fndb.lisp
View file

@ -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

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

@ -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

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

@ -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:

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

@ -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:

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

@ -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:

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

@ -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:

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

@ -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))

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

@ -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

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

@ -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)))
;; y is ST0.
((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
(single-reg
(inst fcom x))
(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 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
(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)))))
(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)))
;; y is ST0.
((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
(double-reg
(inst fcomd x))
(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 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
(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)))))
(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 <)

3
xperfecthash63.lisp-expr
View file

@ -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