cmucl-cvs March 2023

cmucl-cvs@common-lisp.net

1 participants
73 discussions

[Git][cmucl/cmucl][issue-158-darwin-pathnames-utf8] Disable Darwin path normalization stuff.
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-158-darwin-pathnames-utf8 at cmucl / cmucl Commits: 2fb8db98 by Raymond Toy at 2023-03-12T16:17:13-07:00 Disable Darwin path normalization stuff. Don't set up Unicode stuff needed for Darwin path normalization. The code remains, but initialization and enabling of these items are removed from the initial function. - - - - - 2 changed files: - src/code/lispinit.lisp - src/code/save.lisp Changes: ===================================== src/code/lispinit.lisp ===================================== @@ -308,8 +308,7 @@ ;;; in Unwind-Protects will get executed. (declaim (special *lisp-initialization-functions* - *load-time-values* - *enable-darwin-path-normalization*)) + *load-time-values*)) (eval-when (compile) (defmacro print-and-call (name) @@ -345,7 +344,6 @@ (setf *type-system-initialized* nil) (setf *break-on-signals* nil) (setf unix::*filename-encoding* :null) - (setf *enable-darwin-path-normalization* nil) #+gengc (setf conditions::*handler-clusters* nil) (setq intl::*default-domain* "cmucl") (setq intl::*locale* "C") ===================================== src/code/save.lisp ===================================== @@ -316,17 +316,6 @@ ;; we've possibly changed the environment variables and ;; pathnames. (environment-init) - #+darwin - (progn - ;; Get some unicode stuff needed for decomposing strings. - ;; This is needed on Darwin to normalize pathname - ;; objects, which needs this information. If we don't, - ;; we'll load the information at runtime when creating - ;; the path to "unidata.dat", which then calls decompose - ;; again, and so on. - (lisp::load-decomp) - (lisp::load-combining) - (setf *enable-darwin-path-normalization* t)) ;; Set the locale for lisp (intl::setlocale) (ext::process-command-strings process-command-line) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2fb8db98f6766d5d38c8c2c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2fb8db98f6766d5d38c8c2c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] 6 commits: Fix #157: (directory "**/") only returns directories
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: b3de9354 by Raymond Toy at 2023-03-09T14:46:48+00:00 Fix #157: (directory "**/") only returns directories - - - - - 39e30fad by Raymond Toy at 2023-03-09T14:46:48+00:00 Merge branch 'issue-157-directory-no-magic-wildcarding' into 'master' Fix #157: (directory "**/") only returns directories Closes #157 See merge request cmucl/cmucl!127 - - - - - 0038d3d9 by Raymond Toy at 2023-03-09T11:18:21-08:00 Update release notes with recently closed bugs - - - - - d51eb4b8 by Raymond Toy at 2023-03-12T19:05:39+00:00 Fix #175: Simplify branching in x86 float compare vops - - - - - a7237e1d by Raymond Toy at 2023-03-12T19:05:39+00:00 Merge branch 'issue-175-simplify-float-compare-vops' into 'master' Fix #175: Simplify branching in x86 float compare vops Closes #175 See merge request cmucl/cmucl!129 - - - - - a61a38a6 by Raymond Toy at 2023-03-12T12:32:24-07:00 Merge branch 'master' into issue-156-take-2-nan-comparison - - - - - 5 changed files: - src/code/filesys.lisp - src/compiler/x86/float-sse2.lisp - src/general-info/release-21e.md - + tests/nan.lisp - tests/pathname.lisp Changes: ===================================== src/code/filesys.lisp ===================================== @@ -1122,11 +1122,7 @@ optionally keeping some of the most recent old versions." (let ((results nil)) (enumerate-search-list (pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild - :defaults *default-pathname-defaults*) - :wild)) + *default-pathname-defaults*)) (enumerate-matches (name pathname nil :follow-links follow-links) (when (or all (let ((slash (position #\/ name :from-end t))) ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -945,7 +945,7 @@ (frob double ucomisd)) (macrolet - ((frob (op size inst yep nope) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -953,28 +953,52 @@ 'ea-for-df-desc))) (name (symbolicate op "/" size "-FLOAT")) (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) + (inherit (symbolicate size "-FLOAT-COMPARE")) + (reverse-args-p (eq op '<))) `(define-vop (,name ,inherit) + ;; The compare instructions take a reg argument for the + ;; first arg and reg or mem argument for the second. When + ;; inverting the arguments we must also invert which of + ;; the argument can be a mem argument. + (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg))) + (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg)))) (:translate ,op) (:info target not-p) (:generator 3 - (sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp ,nope target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp ,yep target) - (emit-label not-lab))))))))) - (frob < single comiss :b :nb) - (frob > single comiss :a :na) - (frob < double comisd :b :nb) - (frob > double comisd :a :na)) + ;; Note: x < y is the same as y > x. We reverse the + ;; args to reduce the number of jump instructions + ;; needed. + ,(if reverse-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y))))) + ;; Consider the case of x > y. + ;; + ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In + ;; the normal case (not-p false), we want to jump to the + ;; target when x > y. This happens when CF = 0. Hence, + ;; we won't jump to the target when there's a NaN, as + ;; desired. + ;; + ;; For the not-p case, we want to jump to target when x + ;; <= y. This means CF = 1 or ZF = 1. But NaN sets + ;; these bits too, so we jump to the target for NaN or x + ;; <= y, as desired. + ;; + ;; For the case of x < y, we can use the equivalent y > + ;; x. Thus if we swap the args, the same logic applies. + (inst jmp (if (not not-p) :a :be) target)))))) + (frob > single comiss) + (frob > double comisd) + (frob < single comiss) + (frob < double comisd)) ===================================== src/general-info/release-21e.md ===================================== @@ -65,7 +65,17 @@ public domain. * ~~#142~~ `(random 0)` signals incorrect error * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream` * ~~#149~~ Call setlocale(3C) on startup + * ~~#150~~ Add aliases for external format cp949 and euckr + * ~~#151~~ Change `*default-external-format*` to `:utf-8`. * ~~#155~~ Wrap help strings neatly + * ~~#157~~ `(directory "foo/**/")` only returns directories now + * ~~#163~~ Add commandline option `-version` and `--version` to get lisp version + * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT` + * ~~#166~~ Fix incorect type declaration for exponent from `integer-decode-float` + * ~~#167~~ Lowe bound for `decode-float-exponent` type was off by one. + * ~~#168~~ Don't use negated forms for jmp instructions when possible + * ~~#169~~ Add pprinter for `define-vop` and `sc-case` + * ~~#173~~ Add pprinter for `define-assembly-routine` * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== tests/nan.lisp ===================================== @@ -0,0 +1,209 @@ +;;; Tests for NaN comparisons. +(defpackage :nan-tests + (:use :cl :lisp-unit)) + +(in-package :nan-tests) + +(defparameter *single-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + +(defparameter *double-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (macrolet + ((frob (ntype op) + (let* ((name (ext:symbolicate (if (eq ntype 'single-float) + "S" + "D") + "TST-" op)) + (name3 (ext:symbolicate name "3"))) + + `(progn + (defun ,name (x y) + (declare (,ntype x y)) + (,op x y)) + (defun ,name3 (x y z) + (declare (,ntype x y z)) + (,op x y z)))))) + (frob single-float <) + (frob single-float >) + (frob double-float <) + (frob double-float >) + (frob single-float =) + (frob double-float =))) + +(define-test nan-single.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-< 1f0 2f0)) + (assert-false (stst-< 1f0 1f0)) + (assert-false (stst-< 1f0 0f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-< *single-float-nan* 1f0)) + (assert-false (stst-< 1f0 *single-float-nan*)) + (assert-false (stst-< *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-< 1d0 2d0)) + (assert-false (dtst-< 1d0 1d0)) + (assert-false (dtst-< 1d0 0d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-< *double-float-nan* 1d0)) + (assert-false (dtst-< 1d0 *double-float-nan*)) + (assert-false (dtst-< *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-> 2f0 1f0)) + (assert-false (stst-> 1f0 1f0)) + (assert-false (stst-> 0f0 1f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-> *single-float-nan* 1f0)) + (assert-false (stst-> 1f0 *single-float-nan*)) + (assert-false (stst-> *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-> 2d0 1d0)) + (assert-false (dtst-> 1d0 1d0)) + (assert-false (dtst-> 0d0 1d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-> *double-float-nan* 1d0)) + (assert-false (dtst-> 1d0 *double-float-nan*)) + (assert-false (dtst-> *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.<3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-<3 1f0 2f0 3f0)) + (assert-false (stst-<3 1f0 2f0 2f0)) + (assert-false (stst-<3 1f0 1f0 2f0)) + (assert-false (stst-<3 1f0 0f0 2f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<3 *single-float-nan* 2f0 3f0)) + (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) + (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.<3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst-<3 1d0 2d0 3d0)) + (assert-false (dtst-<3 1d0 2d0 2d0)) + (assert-false (dtst-<3 1d0 1d0 2d0)) + (assert-false (dtst-<3 1d0 0d0 2d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)))) + +(define-test nan-single.>3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst->3 3f0 2f0 1f0)) + (assert-false (stst->3 3f0 1f0 1f0)) + (assert-false (stst->3 2f0 2f0 1f0)) + (assert-false (stst->3 0f0 2f0 1f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->3 *single-float-nan* 2f0 3f0)) + (assert-false (stst->3 1f0 *single-float-nan* 3f0)) + (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.>3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst->3 3d0 2d0 1d0)) + (assert-false (dtst->3 3d0 1d0 1d0)) + (assert-false (dtst->3 2d0 2d0 1d0)) + (assert-false (dtst->3 0d0 2d0 1d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) + +(define-test nan-single.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1f0 1f0)) + (assert-false (stst-= 2f0 1f0)) + (assert-false (stst-= 0f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *single-float-nan* 1f0)) + (assert-false (stst-= 1f0 *single-float-nan*)) + (assert-false (stst-= *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1d0 1d0)) + (assert-false (stst-= 2d0 1d0)) + (assert-false (stst-= 0d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *double-float-nan* 1d0)) + (assert-false (stst-= 1d0 *double-float-nan*)) + (assert-false (stst-= *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-=3 1f0 1f0 1f0)) + (assert-false (stst-=3 1f0 1f0 0f0)) + (assert-false (stst-=3 0f0 1f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-=3 *single-float-nan* 1f0 1f0)) + (assert-false (stst-=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-=3 1f0 1f0 *single-float-nan*)))) + +(define-test nan-double.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (dtst-=3 1d0 1d0 1d0)) + (assert-false (dtst-=3 1d0 1d0 0d0)) + (assert-false (dtst-=3 0d0 1d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-=3 *double-float-nan* 1d0 1d0)) + (assert-false (dtst-=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-=3 1d0 1d0 *double-float-nan*)))) ===================================== tests/pathname.lisp ===================================== @@ -72,4 +72,14 @@ :directory '(:absolute "system2" "module4") :name nil :type nil) (parse-namestring "ASDFTEST:system2;module4;")))) - + + + +(define-test directory.dirs + (let ((files (directory "src/assembly/**/"))) + ;; Verify that we only returned directories + (loop for f in files + for name = (pathname-name f) + and type = (pathname-type f) + do + (assert-true (and (null name) (null type)) f)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/dd3bbe83eeb868486a31d4… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/dd3bbe83eeb868486a31d4… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Add deftransforms for >= for floats and rationals
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: dd3bbe83 by Raymond Toy at 2023-03-11T15:25:33-08:00 Add deftransforms for >= for floats and rationals Add a deftransform for >= (and <=) to hande when the two args are different types of floats, just like how < is done. Likewise, add a deftransform to handle comparisons between a float and rational. This is the same as how it's handled for < and friends. - - - - - 1 changed file: - src/compiler/float-tran.lisp Changes: ===================================== src/compiler/float-tran.lisp ===================================== @@ -568,7 +568,7 @@ (%deftransform x '(function (rational float) *) #'float-contagion-arg1) (%deftransform x '(function (float rational) *) #'float-contagion-arg2)) -(dolist (x '(= < > + * / -)) +(dolist (x '(= < > + * / - #+x86 <= #+x86 >=)) (%deftransform x '(function (single-float double-float) *) #'float-contagion-arg1) (%deftransform x '(function (double-float single-float) *) @@ -591,7 +591,11 @@ `(,',op x (float y x))))) (frob <) (frob >) - (frob =)) + (frob =) + #+x86 + (frob <=) + #+x86 + (frob >=)) ;; Convert (/ x n) to (* x (/ n)) when x is a float and n is a power ;; of two, because (/ n) can be reprsented exactly. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dd3bbe83eeb868486a31d46… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dd3bbe83eeb868486a31d46… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #175: Simplify branching in x86 float compare vops
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d51eb4b8 by Raymond Toy at 2023-03-12T19:05:39+00:00 Fix #175: Simplify branching in x86 float compare vops - - - - - a7237e1d by Raymond Toy at 2023-03-12T19:05:39+00:00 Merge branch 'issue-175-simplify-float-compare-vops' into 'master' Fix #175: Simplify branching in x86 float compare vops Closes #175 See merge request cmucl/cmucl!129 - - - - - 2 changed files: - src/compiler/x86/float-sse2.lisp - + tests/nan.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -945,7 +945,7 @@ (frob double ucomisd)) (macrolet - ((frob (op size inst yep nope) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -953,28 +953,52 @@ 'ea-for-df-desc))) (name (symbolicate op "/" size "-FLOAT")) (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) + (inherit (symbolicate size "-FLOAT-COMPARE")) + (reverse-args-p (eq op '<))) `(define-vop (,name ,inherit) + ;; The compare instructions take a reg argument for the + ;; first arg and reg or mem argument for the second. When + ;; inverting the arguments we must also invert which of + ;; the argument can be a mem argument. + (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg))) + (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg)))) (:translate ,op) (:info target not-p) (:generator 3 - (sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp ,nope target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp ,yep target) - (emit-label not-lab))))))))) - (frob < single comiss :b :nb) - (frob > single comiss :a :na) - (frob < double comisd :b :nb) - (frob > double comisd :a :na)) + ;; Note: x < y is the same as y > x. We reverse the + ;; args to reduce the number of jump instructions + ;; needed. + ,(if reverse-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y))))) + ;; Consider the case of x > y. + ;; + ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In + ;; the normal case (not-p false), we want to jump to the + ;; target when x > y. This happens when CF = 0. Hence, + ;; we won't jump to the target when there's a NaN, as + ;; desired. + ;; + ;; For the not-p case, we want to jump to target when x + ;; <= y. This means CF = 1 or ZF = 1. But NaN sets + ;; these bits too, so we jump to the target for NaN or x + ;; <= y, as desired. + ;; + ;; For the case of x < y, we can use the equivalent y > + ;; x. Thus if we swap the args, the same logic applies. + (inst jmp (if (not not-p) :a :be) target)))))) + (frob > single comiss) + (frob > double comisd) + (frob < single comiss) + (frob < double comisd)) ;;;; Conversion: ===================================== tests/nan.lisp ===================================== @@ -0,0 +1,209 @@ +;;; Tests for NaN comparisons. +(defpackage :nan-tests + (:use :cl :lisp-unit)) + +(in-package :nan-tests) + +(defparameter *single-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + +(defparameter *double-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (macrolet + ((frob (ntype op) + (let* ((name (ext:symbolicate (if (eq ntype 'single-float) + "S" + "D") + "TST-" op)) + (name3 (ext:symbolicate name "3"))) + + `(progn + (defun ,name (x y) + (declare (,ntype x y)) + (,op x y)) + (defun ,name3 (x y z) + (declare (,ntype x y z)) + (,op x y z)))))) + (frob single-float <) + (frob single-float >) + (frob double-float <) + (frob double-float >) + (frob single-float =) + (frob double-float =))) + +(define-test nan-single.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-< 1f0 2f0)) + (assert-false (stst-< 1f0 1f0)) + (assert-false (stst-< 1f0 0f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-< *single-float-nan* 1f0)) + (assert-false (stst-< 1f0 *single-float-nan*)) + (assert-false (stst-< *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-< 1d0 2d0)) + (assert-false (dtst-< 1d0 1d0)) + (assert-false (dtst-< 1d0 0d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-< *double-float-nan* 1d0)) + (assert-false (dtst-< 1d0 *double-float-nan*)) + (assert-false (dtst-< *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-> 2f0 1f0)) + (assert-false (stst-> 1f0 1f0)) + (assert-false (stst-> 0f0 1f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-> *single-float-nan* 1f0)) + (assert-false (stst-> 1f0 *single-float-nan*)) + (assert-false (stst-> *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-> 2d0 1d0)) + (assert-false (dtst-> 1d0 1d0)) + (assert-false (dtst-> 0d0 1d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-> *double-float-nan* 1d0)) + (assert-false (dtst-> 1d0 *double-float-nan*)) + (assert-false (dtst-> *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.<3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-<3 1f0 2f0 3f0)) + (assert-false (stst-<3 1f0 2f0 2f0)) + (assert-false (stst-<3 1f0 1f0 2f0)) + (assert-false (stst-<3 1f0 0f0 2f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<3 *single-float-nan* 2f0 3f0)) + (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) + (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.<3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst-<3 1d0 2d0 3d0)) + (assert-false (dtst-<3 1d0 2d0 2d0)) + (assert-false (dtst-<3 1d0 1d0 2d0)) + (assert-false (dtst-<3 1d0 0d0 2d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)))) + +(define-test nan-single.>3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst->3 3f0 2f0 1f0)) + (assert-false (stst->3 3f0 1f0 1f0)) + (assert-false (stst->3 2f0 2f0 1f0)) + (assert-false (stst->3 0f0 2f0 1f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->3 *single-float-nan* 2f0 3f0)) + (assert-false (stst->3 1f0 *single-float-nan* 3f0)) + (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.>3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst->3 3d0 2d0 1d0)) + (assert-false (dtst->3 3d0 1d0 1d0)) + (assert-false (dtst->3 2d0 2d0 1d0)) + (assert-false (dtst->3 0d0 2d0 1d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) + +(define-test nan-single.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1f0 1f0)) + (assert-false (stst-= 2f0 1f0)) + (assert-false (stst-= 0f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *single-float-nan* 1f0)) + (assert-false (stst-= 1f0 *single-float-nan*)) + (assert-false (stst-= *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1d0 1d0)) + (assert-false (stst-= 2d0 1d0)) + (assert-false (stst-= 0d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *double-float-nan* 1d0)) + (assert-false (stst-= 1d0 *double-float-nan*)) + (assert-false (stst-= *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-=3 1f0 1f0 1f0)) + (assert-false (stst-=3 1f0 1f0 0f0)) + (assert-false (stst-=3 0f0 1f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-=3 *single-float-nan* 1f0 1f0)) + (assert-false (stst-=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-=3 1f0 1f0 *single-float-nan*)))) + +(define-test nan-double.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (dtst-=3 1d0 1d0 1d0)) + (assert-false (dtst-=3 1d0 1d0 0d0)) + (assert-false (dtst-=3 0d0 1d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-=3 *double-float-nan* 1d0 1d0)) + (assert-false (dtst-=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-=3 1d0 1d0 *double-float-nan*)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0038d3d9a489ffcf47bb15… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0038d3d9a489ffcf47bb15… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] Address review comments
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 183e2ad0 by Raymond Toy at 2023-03-12T10:53:28-07:00 Address review comments - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -945,23 +945,7 @@ (frob double ucomisd)) (macrolet - ((gen-code (op sc-type inst ea) - ;; When the operation is >, the second arg (y) can be a - ;; register or a descriptor. When the operation is <, the args - ;; are swapped and we want to allow x to be a register or - ;; descriptor. - (if (eq op '<) - `(sc-case x - (,sc-type - (inst ,inst y x)) - (descriptor-reg - (inst ,inst y (,ea x)))) - `(sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))))) - (frob (op size inst) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -969,21 +953,32 @@ 'ea-for-df-desc))) (name (symbolicate op "/" size "-FLOAT")) (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) + (inherit (symbolicate size "-FLOAT-COMPARE")) + (reverse-args-p (eq op '<))) `(define-vop (,name ,inherit) - ;; When the operation is <, we want to rewrite x < y to y - ;; > x. In that case, we want to allow x to be in a - ;; descriptor. For >, y is allowed to be a descriptor. - ,@(when (eq op '<) - `((:args (x :scs (,sc-type descriptor-reg)) - (y :scs (,sc-type))))) + ;; The compare instructions take a reg argument for the + ;; first arg and reg or mem argument for the second. When + ;; inverting the arguments we must also invert which of + ;; the argument can be a mem argument. + (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg))) + (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg)))) (:translate ,op) (:info target not-p) (:generator 3 ;; Note: x < y is the same as y > x. We reverse the ;; args to reduce the number of jump instructions ;; needed. - (gen-code ,op ,sc-type ,inst ,ea) + ,(if reverse-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y))))) ;; Consider the case of x > y. ;; ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/183e2ad0845d1a7c12c4312… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/183e2ad0845d1a7c12c4312… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Add deftransform for >= and <= for integers.
by Raymond Toy (＠rtoy) 11 Mar '23

11 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 7ae79da6 by Raymond Toy at 2023-03-10T18:37:11-08:00 Add deftransform for >= and <= for integers. See the comments in the code for this change. I'm not sure this is what we want, but the testsuite passes now when it was previously failing. The failure had something to do with utf-16-be external format and there were warnings about `(>= foo 0)` having to use `generic->=` because the first type was `unsigned-byte`. This doesn't happen anymore. - - - - - 1 changed file: - src/compiler/srctran.lisp Changes: ===================================== src/compiler/srctran.lisp ===================================== @@ -3537,6 +3537,29 @@ (deftransform > ((x y) (real real) * :when :both) (ir1-transform-< y x x y '<)) + +#+x86 +(progn + ;; When x and y are integers, we want to transform <= to > and >= to + ;; <. But we don't want to do this for floats because it messes up + ;; comparisons with NaN. + ;; + ;; I'm not sure about this. The transformation is right, but + ;; perhaps what we really need is an ir-transform-<= to determine x + ;; <= y is definitely true or false, like for ir1-transform-<. + ;; + ;; For now this allows the testsuite to pass. Perhaps there's a bug + ;; in generic->=? + (deftransform <= ((x y) (integer integer) * :when :both) + ;; (<= x y) is the same as (not (> x y)) + `(not (> x y))) + + + (deftransform >= ((x y) (integer integer) * :when :both) + ;; (>= x y) is the same as (not (< x y)) + `(not (< x y)))) + + ;; Like IR1-TRANSFORM-< but for CHAR<. This is needed so that the ;; vops for base-char comparison with a constant gets used when the ;; first arg is the constant. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7ae79da601d4a56ba939417… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7ae79da601d4a56ba939417… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Split the <= and >= macros from the others
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 60c39207 by Raymond Toy at 2023-03-10T14:51:32-08:00 Split the <= and >= macros from the others When !129 lands we'll probably need to rework the vops for <= and >=, so let's split these out now, even if they're basically duplicating the code. The < and > vops are going to be replaced, and I have not thought exactly how these will fit with < and > yet. But since <= and >= don't quite fully work, keep them separate. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -972,12 +972,42 @@ (inst jmp ,yep target) (emit-label not-lab))))))))) (frob < single comiss :b :nb) - (frob <= single comiss :be :nbe) (frob > single comiss :a :na) - (frob >= single comiss :ae :nae) (frob < double comisd :b :nb) + (frob > double comisd :a :na)) + + + +(macrolet + ((frob (op size inst yep nope) + (let ((ea (ecase size + (single + 'ea-for-sf-desc) + (double + 'ea-for-df-desc))) + (name (symbolicate op "/" size "-FLOAT")) + (sc-type (symbolicate size "-REG")) + (inherit (symbolicate size "-FLOAT-COMPARE"))) + `(define-vop (,name ,inherit) + (:translate ,op) + (:info target not-p) + (:generator 3 + (sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))) + (cond (not-p + (inst jmp :p target) + (inst jmp ,nope target)) + (t + (let ((not-lab (gen-label))) + (inst jmp :p not-lab) + (inst jmp ,yep target) + (emit-label not-lab))))))))) + (frob <= single comiss :be :nbe) + (frob >= single comiss :ae :nae) (frob <= double comisd :be :nbe) - (frob > double comisd :a :na) (frob >= double comisd :ae :nae)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/60c3920704106eef2bc45ee… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/60c3920704106eef2bc45ee… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] Remove old macros for < and >.
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 1e7d1ddc by Raymond Toy at 2023-03-10T12:09:54-08:00 Remove old macros for < and >. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -944,87 +944,6 @@ (frob single ucomiss) (frob double ucomisd)) -#+nil -(macrolet - ((gen-code (swap-args-p sc-type inst ea) - (if swap-args-p - `(sc-case x - (,sc-type - (inst ,inst y x)) - (descriptor-reg - (inst ,inst y (,ea x)))) - `(sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))))) - (frob (op size inst swap-args-p) - (let ((ea (ecase size - (single - 'ea-for-sf-desc) - (double - 'ea-for-df-desc))) - (name (symbolicate op "/" size "-FLOAT")) - (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) - `(define-vop (,name ,inherit) - (:translate ,op) - (:info target not-p) - (:generator 3 - (gen-code ,swap-args-p ,sc-type ,inst ,ea) - ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In - ;; the normal case (not-p false), we want to jump to the - ;; target when x > y. This happens when CF = 0. Hence, - ;; we won't jump to the target when there's a NaN, as - ;; desired. - ;; - ;; For the not-p case, we want to jump to target when x - ;; <= y. This means CF = 1 or ZF = 1. But NaN sets - ;; these bits too, so we jump to the target for NaN or x - ;; <= y, as desired. - (inst jmp (if (not not-p) :a :be) target)))))) - (frob > single comiss nil) - (frob > double comisd nil)) - -#+nil -(macrolet - ((gen-code (swap-args-p sc-type inst ea) - (if swap-args-p - `(sc-case x - (,sc-type - (inst ,inst y x)) - (descriptor-reg - (inst ,inst y (,ea x)))) - `(sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))))) - (frob (op size inst swap-args-p) - (let ((ea (ecase size - (single - 'ea-for-sf-desc) - (double - 'ea-for-df-desc))) - (name (symbolicate op "/" size "-FLOAT")) - (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) - `(define-vop (,name ,inherit) - (:args (x :scs (,sc-type descriptor-reg)) - (y :scs (,sc-type))) - (:translate ,op) - (:info target not-p) - (:temporary (:sc ,sc-type) load-x) - (:generator 3 - ;; Note: x < y is the same as y > x. We reverse the - ;; args to reduce the number of jump instructions - ;; needed. Then the logic for the branches is the same - ;; as for the case y > x above. - (gen-code ,swap-args-p ,sc-type ,inst ,ea) - (inst jmp (if (not not-p) :a :be) target)))))) - (frob < single comiss t) - (frob < double comisd t)) - (macrolet ((gen-code (op sc-type inst ea) ;; When the operation is >, the second arg (y) can be a View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/1e7d1ddcf57f37b66262f21… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/1e7d1ddcf57f37b66262f21… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] 3 commits: First cut at using a common macro for both > and <.
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 225335b5 by Raymond Toy at 2023-03-10T11:42:37-08:00 First cut at using a common macro for both > and <. This works, but I think it should be cleaned up a bit. - - - - - 1ef34feb by Raymond Toy at 2023-03-10T12:05:04-08:00 Refactor comparison vops into one macro to handle them all. Previously we had two macros: one for < and one for >. They are very similar so we combine them into one macro to handle both operations. - - - - - 552d91f3 by Raymond Toy at 2023-03-10T12:06:57-08:00 Remove unused swap-args-p arg to frob We can determine whether we want to swap or not from the operation, so we don't need this arg to frob anymore. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -944,8 +944,21 @@ (frob single ucomiss) (frob double ucomisd)) +#+nil (macrolet - ((frob (op size inst) + ((gen-code (swap-args-p sc-type inst ea) + (if swap-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))))) + (frob (op size inst swap-args-p) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -958,11 +971,7 @@ (:translate ,op) (:info target not-p) (:generator 3 - (sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))) + (gen-code ,swap-args-p ,sc-type ,inst ,ea) ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In ;; the normal case (not-p false), we want to jump to the ;; target when x > y. This happens when CF = 0. Hence, @@ -974,11 +983,24 @@ ;; these bits too, so we jump to the target for NaN or x ;; <= y, as desired. (inst jmp (if (not not-p) :a :be) target)))))) - (frob > single comiss) - (frob > double comisd)) + (frob > single comiss nil) + (frob > double comisd nil)) +#+nil (macrolet - ((frob (op size inst) + ((gen-code (swap-args-p sc-type inst ea) + (if swap-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))))) + (frob (op size inst swap-args-p) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -998,12 +1020,69 @@ ;; args to reduce the number of jump instructions ;; needed. Then the logic for the branches is the same ;; as for the case y > x above. - (sc-case x - (,sc-type - (inst ,inst y x)) - (descriptor-reg - (inst ,inst y (,ea x)))) + (gen-code ,swap-args-p ,sc-type ,inst ,ea) + (inst jmp (if (not not-p) :a :be) target)))))) + (frob < single comiss t) + (frob < double comisd t)) + +(macrolet + ((gen-code (op sc-type inst ea) + ;; When the operation is >, the second arg (y) can be a + ;; register or a descriptor. When the operation is <, the args + ;; are swapped and we want to allow x to be a register or + ;; descriptor. + (if (eq op '<) + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))))) + (frob (op size inst) + (let ((ea (ecase size + (single + 'ea-for-sf-desc) + (double + 'ea-for-df-desc))) + (name (symbolicate op "/" size "-FLOAT")) + (sc-type (symbolicate size "-REG")) + (inherit (symbolicate size "-FLOAT-COMPARE"))) + `(define-vop (,name ,inherit) + ;; When the operation is <, we want to rewrite x < y to y + ;; > x. In that case, we want to allow x to be in a + ;; descriptor. For >, y is allowed to be a descriptor. + ,@(when (eq op '<) + `((:args (x :scs (,sc-type descriptor-reg)) + (y :scs (,sc-type))))) + (:translate ,op) + (:info target not-p) + (:generator 3 + ;; Note: x < y is the same as y > x. We reverse the + ;; args to reduce the number of jump instructions + ;; needed. + (gen-code ,op ,sc-type ,inst ,ea) + ;; Consider the case of x > y. + ;; + ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In + ;; the normal case (not-p false), we want to jump to the + ;; target when x > y. This happens when CF = 0. Hence, + ;; we won't jump to the target when there's a NaN, as + ;; desired. + ;; + ;; For the not-p case, we want to jump to target when x + ;; <= y. This means CF = 1 or ZF = 1. But NaN sets + ;; these bits too, so we jump to the target for NaN or x + ;; <= y, as desired. + ;; + ;; For the case of x < y, we can use the equivalent y > + ;; x. Thus if we swap the args, the same logic applies. (inst jmp (if (not not-p) :a :be) target)))))) + (frob > single comiss) + (frob > double comisd) (frob < single comiss) (frob < double comisd)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5ad9f2d825f2e986e04fa2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5ad9f2d825f2e986e04fa2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] Remove unused mover arg from the macro for < comparisons
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 5ad9f2d8 by Raymond Toy at 2023-03-10T09:25:46-08:00 Remove unused mover arg from the macro for < comparisons We don't need the mover arg anymore since we've changed x to be a descriptor instead of y. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -978,7 +978,7 @@ (frob > double comisd)) (macrolet - ((frob (op size inst mover) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -1004,8 +1004,8 @@ (descriptor-reg (inst ,inst y (,ea x)))) (inst jmp (if (not not-p) :a :be) target)))))) - (frob < single comiss movss) - (frob < double comisd movsd)) + (frob < single comiss) + (frob < double comisd)) ;;;; Conversion: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5ad9f2d825f2e986e04fa2d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5ad9f2d825f2e986e04fa2d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs March 2023