- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][issue-176-site-name-is-nil] Update release notes for this issue
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-176-site-name-is-nil at cmucl / cmucl Commits: d749f539 by Raymond Toy at 2023-03-13T07:50:12-07:00 Update release notes for this issue - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -76,6 +76,7 @@ public domain. * ~~#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` + * ~~#176~~ `SHORT-SITE-NAME` and `LONG-SITE-NAME` return `NIL`. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d749f53994ce1d318aafd09… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d749f53994ce1d318aafd09… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-176-site-name-is-nil
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed new branch issue-176-site-name-is-nil at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-176-site-name-is-nil You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] Update release notes
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: 6e59b0b2 by Raymond Toy at 2023-03-13T07:36:59-07:00 Update release notes - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -49,6 +49,7 @@ public domain. * ~~#108~~ Update ASDF * ~~#112~~ CLX can't connect to X server via inet sockets * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF. + * ~~#120~~ `SOFTWARE-TYPE` and `SOFTWARE-VERSION` are implemented in C. * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM * ~~#122~~ gcc 11 can't build cmucl * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6e59b0b21eabe3bf27347bf… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6e59b0b21eabe3bf27347bf… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] 2 commits: Use static buffer to hold results
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: a47e8963 by Raymond Toy at 2023-03-13T07:31:19-07:00 Use static buffer to hold results Instead of dynamically allocating space to the the results for `software-type` and `software-version`, use a static string in each function. Fill the string with desired result and return it. The Lisp interface needs to be updated not to free the memory now since it's not dynamically allocated. - - - - - 98ae551c by Raymond Toy at 2023-03-13T07:33:45-07:00 Update pot files. The location of the docstrings have moved and have changed, so the pot files need to be updated. - - - - - 4 changed files: - src/code/misc.lisp - src/i18n/locale/cmucl-linux-os.pot - src/i18n/locale/cmucl.pot - src/lisp/os-common.c Changes: ===================================== src/code/misc.lisp ===================================== @@ -199,9 +199,7 @@ (alien:extern-alien "os_software_type" (function (alien:* c-call:c-string))))) (unless (zerop (sap-int (alien:alien-sap software-type))) - (alien:cast software-type c-call:c-string))) - (when software-type - (alien:free-alien software-type)))))) + (alien:cast software-type c-call:c-string))))))) *software-type*) (defvar *software-version* nil @@ -219,9 +217,7 @@ (alien:extern-alien "os_software_version" (function (alien:* c-call:c-string))))) (unless (zerop (sap-int (alien:alien-sap version))) - (alien:cast version c-call:c-string))) - (when version - (alien:free-alien version))))) + (alien:cast version c-call:c-string)))))) *software-version*)) (defvar *short-site-name* (intl:gettext "Unknown") ===================================== src/i18n/locale/cmucl-linux-os.pot ===================================== @@ -15,10 +15,6 @@ msgstr "" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" -#: src/code/linux-os.lisp -msgid "Returns a string describing version of the supporting software." -msgstr "" - #: src/code/linux-os.lisp msgid "Unix system call getrusage failed: ~A." msgstr "" ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -5605,14 +5605,14 @@ msgid "" " NIL if no such character exists." msgstr "" -#: src/code/misc.lisp +#: src/code/misc-doc.lisp src/code/misc.lisp msgid "" "Returns the documentation string of Doc-Type for X, or NIL if\n" " none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,\n" " SETF, and T." msgstr "" -#: src/code/misc.lisp +#: src/code/misc-doc.lisp src/code/misc.lisp msgid "~S is not the name of a structure type." msgstr "" @@ -5643,13 +5643,21 @@ msgid "Returns a string giving the name of the local machine." msgstr "" #: src/code/misc.lisp -msgid "The value of SOFTWARE-TYPE. Set in FOO-os.lisp." +msgid "The value of SOFTWARE-TYPE." msgstr "" #: src/code/misc.lisp msgid "Returns a string describing the supporting software." msgstr "" +#: src/code/misc.lisp +msgid "Version string for supporting software" +msgstr "" + +#: src/code/misc.lisp +msgid "Returns a string describing version of the supporting software." +msgstr "" + #: src/code/misc.lisp msgid "The value of SHORT-SITE-NAME. Set in library:site-init.lisp." msgstr "" ===================================== src/lisp/os-common.c ===================================== @@ -817,43 +817,47 @@ os_get_locale_codeset() #endif char* -os_software_version() +os_software_version(void) { - int status; struct utsname uts; - char *version = NULL; + /* + * Buffer large enough to hold the release and version that's used + * for Linux and Solaris. + */ + static char result[sizeof(uts.release) + sizeof(uts.version)]; + + int status; status = uname(&uts); - if (status == 0) { - int version_length; + if (status != 0) { + return NULL; + } + #if defined(UNAME_RELEASE_AND_VERSION) - version_length = strlen(uts.release) + strlen(uts.version) + 2; - version = malloc(version_length); - if (version) { - strcpy(version, uts.release); - strcat(version, " "); - strcat(version, uts.version); - } + strcpy(result, uts.release); + strcat(result, " "); + strcat(result, uts.version); #else - version = strdup(uts.version); + strcpy(result, uts.version); #endif - } - return version; + return result; } #undef UNAME_RELEASE_AND_VERSION char* -os_software_type() +os_software_type(void) { int status; struct utsname uts; - char *os_name = NULL; + static char os_name[sizeof(uts.sysname)]; status = uname(&uts); - if (status == 0) { - os_name = strdup(uts.sysname); + if (status != 0) { + return NULL; } + + strcpy(os_name, uts.sysname); return os_name; } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d8f99abf569c7ae830abeb… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d8f99abf569c7ae830abeb… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-158-darwin-pathnames-utf8] Disable darwin test
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-158-darwin-pathnames-utf8 at cmucl / cmucl Commits: 623caa85 by Raymond Toy at 2023-03-12T16:57:42-07:00 Disable darwin test The test assumes that we're normalizing pathnames on Darwin, but we're not currently doing that. Hence disable the test for now, but leave it in. - - - - - 1 changed file: - tests/issues.lisp Changes: ===================================== tests/issues.lisp ===================================== @@ -838,7 +838,8 @@ (path (make-pathname :directory (list :relative name) :name name :type name))) - #+darwin + ;; Enable this when we implement normalization for Darwin + #+(and nil darwin) (let ((expected '(4352 4456 4543))) ;; Tests that on Darwin the Hangul pathname has been normalized ;; correctly. We fill in the directory, name, and type components View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/623caa858be07f609f666a1… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/623caa858be07f609f666a1… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[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