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

[Git][cmucl/cmucl][master] 2 commits: Fix #293: Allow restarts for FP overflow in reader
by Raymond Toy (＠rtoy) 19 Apr '24

19 Apr '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: c40327d1 by Raymond Toy at 2024-04-19T14:13:56+00:00 Fix #293: Allow restarts for FP overflow in reader - - - - - 787626ad by Raymond Toy at 2024-04-19T14:14:04+00:00 Merge branch 'issue-293-restart-on-reader-fp-overflow' into 'master' Fix #293: Allow restarts for FP overflow in reader Closes #293, #275, and #287 See merge request cmucl/cmucl!201 - - - - - 5 changed files: - src/code/bignum.lisp - src/code/reader.lisp - src/general-info/release-21f.md - src/i18n/locale/cmucl.pot - tests/float.lisp Changes: ===================================== src/code/bignum.lisp ===================================== @@ -2032,7 +2032,7 @@ down to individual words.") (declare (type bignum-index len)) (let ((exp (+ exp bias))) (when (> exp max) - (error 'simple-type-error + (error 'floating-point-overflow :datum x :format-control (intl:gettext "Too large to be represented as a ~S:~% ~S") :format-arguments (list format x) ===================================== src/code/reader.lisp ===================================== @@ -1823,6 +1823,51 @@ the end of the stream." num)))) (t (error _"Internal error in floating point reader."))))) +(defun restart-overflow (sign-num sign-div float-format stream) + (flet + ((floating-point-infinity (sign float-format) + (ecase float-format + ((short-float single-float) + (if (minusp sign) + ext:single-float-negative-infinity + ext:single-float-positive-infinity)) + ((double-float long-float) + (if (minusp sign) + ext:double-float-negative-infinity + ext:double-float-positive-infinity)) + #+double-double + ((kernel::double-double-float) + (if (minusp sign) + kernel::double-double-float-negative-infinity + kernel::double-double-float-positive-infinity)))) + (largest-float (sign float-format) + (ecase float-format + ((short-float single-float) + (if (minusp sign) + most-negative-single-float + most-positive-single-float)) + ((double-float long-float) + (if (minusp sign) + most-negative-double-float + most-positive-double-float)) + #+double-double + ((kernel::double-double-float) + (if (minusp sign) + ext:most-negative-double-double-float + ext:most-positive-double-double-float))))) + + (restart-case + (%reader-error stream _"Floating-point overflow reading ~S: ~S" + float-format (read-buffer-to-string)) + (infinity () + :report (lambda (stream) + (format stream "Return floating-point infinity")) + (floating-point-infinity (* sign-num sign-div) float-format)) + (largest-float () + :report (lambda (stream) + (format stream "Return largest floating-point value")) + (largest-float (* sign-num sign-div) float-format))))) + (defun make-float-aux (exponent number divisor float-format stream) ;; Computes x = number*10^exponent/divisor. ;; @@ -1867,7 +1912,7 @@ the end of the stream." (error 'floating-point-underflow)) (when (>= log2-num log2-high) ;; Number is definitely too large; signal an error - (error "Overflow")))))))) + (error 'floating-point-overflow)))))))) ;; Otherwise the number might fit, so we carefully compute the result. (handler-case @@ -1893,11 +1938,15 @@ the end of the stream." :report (lambda (stream) (format stream "Return ~A" zero)) zero)))) + (floating-point-overflow () + ;; Resignal a reader error, but allow the user to replace + ;; overflow with another value. + (restart-overflow (signum number) (signum divisor) + float-format stream)) (error () (%reader-error stream _"Number not representable as a ~S: ~S" float-format (read-buffer-to-string)))))) - (defun make-ratio (stream) ;;assume *read-buffer* contains a legal ratio. Build the number from ;;the string. ===================================== src/general-info/release-21f.md ===================================== @@ -66,6 +66,7 @@ public domain. * ~~#288~~ Re-enable `deftransform` for random integers. * ~~#290~~ Pprint `with-float-traps-masked` better * ~~#291~~ Pprint `handler-case` neatly. + * ~~#293~~ Allow restarts for FP overflow in reader. * ~~#297~~ Pprint `new-assem:assemble` with less indentation. * Other changes: * Improvements to the PCL implementation of CLOS: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8749,6 +8749,10 @@ msgstr "" msgid "Internal error in floating point reader." msgstr "" +#: src/code/reader.lisp +msgid "Floating-point overflow reading ~S: ~S" +msgstr "" + #: src/code/reader.lisp msgid "Floating point underflow when reading ~S: ~S" msgstr "" ===================================== tests/float.lisp ===================================== @@ -287,4 +287,49 @@ (invoke-restart 'lisp::continue)))) (read-from-string string))))))) +(define-test fp-overflow-restarts.infinity + (:tag :issues) + ;; Test that the "infinity" restart from reader on floating-point + ;; overflow returns an infinity of the correct type and sign. + (dolist (item (list (list "4e38" ext:single-float-positive-infinity) + (list "-4e38" ext:single-float-negative-infinity) + (list "2d308" ext:double-float-positive-infinity) + (list "-2d308" ext:double-float-negative-infinity) + ;; These test the short-cut case in the reader for + ;; very large numbers. + (list "4e999" ext:single-float-positive-infinity) + (list "-4e999" ext:single-float-negative-infinity) + (list "1d999" ext:double-float-positive-infinity) + (list "-1d999" ext:double-float-negative-infinity))) + (destructuring-bind (string expected-result) + item + (assert-equal expected-result + (values (handler-bind ((reader-error + (lambda (c) + (declare (ignore c)) + (invoke-restart 'lisp::infinity)))) + (read-from-string string))))))) +(define-test fp-overflow-restarts.huge + (:tag :issues) + ;; Test that the "largest-float" restart from reader on + ;; floating-point overflow returns the largest float of the correct + ;; type and sign. + (dolist (item (list (list "4e38" most-positive-single-float) + (list "-4e38" most-negative-single-float) + (list "2d308" most-positive-double-float) + (list "-2d308" most-negative-double-float) + ;; These test the short-cut case in the reader for + ;; very large numbers. + (list "4e999" most-positive-single-float) + (list "-4e999" most-negative-single-float) + (list "1d999" most-positive-double-float) + (list "-1d999" most-negative-double-float))) + (destructuring-bind (string expected-result) + item + (assert-equal expected-result + (handler-bind ((reader-error + (lambda (c) + (declare (ignore c)) + (values (invoke-restart 'lisp::largest-float))))) + (read-from-string string)))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/07c9c06b3d8f1c2f7072c9… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/07c9c06b3d8f1c2f7072c9… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-304-debug-handlers-defn
by Raymond Toy (＠rtoy) 17 Apr '24

17 Apr '24

Raymond Toy pushed new branch issue-304-debug-handlers-defn at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-304-debug-handlers-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-293-restart-on-reader-fp-overflow] 5 commits: Fix #296: Fix disassembly of MOVD instruction
by Raymond Toy (＠rtoy) 11 Apr '24

11 Apr '24

Raymond Toy pushed to branch issue-293-restart-on-reader-fp-overflow at cmucl / cmucl Commits: 0cbb2264 by Raymond Toy at 2024-04-10T03:10:16+00:00 Fix #296: Fix disassembly of MOVD instruction - - - - - df78595e by Raymond Toy at 2024-04-10T03:10:20+00:00 Merge branch 'issue-296-fix-movd-disassembly' into 'master' Fix #296: Fix disassembly of MOVD instruction Closes #296 and #300 See merge request cmucl/cmucl!207 - - - - - e88d7ffe by Raymond Toy at 2024-04-11T22:11:51+00:00 Fix #275: FP underflow in reader allows restart with 0 - - - - - 07c9c06b by Raymond Toy at 2024-04-11T22:11:55+00:00 Merge branch 'issue-275b-signal-float-underflow' into 'master' Fix #275: FP underflow in reader allows restart with 0 Closes #275 and #287 See merge request cmucl/cmucl!197 - - - - - c4cfca89 by Raymond Toy at 2024-04-11T16:01:24-07:00 Merge branch 'master' into issue-293-restart-on-reader-fp-overflow - - - - - 2 changed files: - src/compiler/x86/insts.lisp - src/general-info/release-21f.md Changes: ===================================== src/compiler/x86/insts.lisp ===================================== @@ -509,6 +509,14 @@ (print-byte-reg value stream dstate) (print-mem-access value stream t dstate))) +(defun print-word-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-word-reg value stream dstate) + (print-mem-access value stream nil dstate))) + (defun print-label (value stream dstate) (declare (ignore dstate)) (princ (if (and (numberp value) (minusp value)) @@ -716,7 +724,11 @@ (disassem:define-argument-type byte-reg/mem :prefilter #'prefilter-reg/mem :printer #'print-byte-reg/mem) - +(disassem:define-argument-type word-reg/mem + ;; Like reg/mem but if the reg/mem field is a register, it's a word + ;; register. + :prefilter #'prefilter-reg/mem + :printer #'print-word-reg/mem) ;;; ;;; added by jrd ;;; @@ -3478,7 +3490,7 @@ ;;; We do not support the MMX version of this instruction. (define-instruction movd (segment dst src) (:printer ext-xmm-reg/mem ((prefix #x66) (op #x6e))) - (:printer ext-xmm-reg/mem ((prefix #x66) (op #x7e)) + (:printer ext-xmm-reg/mem ((prefix #x66) (op #x7e) (reg/mem nil :type 'word-reg/mem)) '(:name :tab reg/mem ", " reg)) (:emitter (cond ((xmm-register-p dst) ===================================== src/general-info/release-21f.md ===================================== @@ -56,6 +56,7 @@ public domain. * ~~#271~~ Update ASDF to 3.3.7 * ~~#272~~ Move scavenge code for static vectors to its own function * ~~#274~~ 1d99999999 hangs + * ~~#275~~ FP underflow in reader allows restarting with 0 * ~~#276~~ Implement xoroshiro128** generator for x86 * ~~#277~~ `float-ratio-float` returns 0 for numbers close to least-positive-float View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/da48651df72c0685a095cc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/da48651df72c0685a095cc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #275: FP underflow in reader allows restart with 0
by Raymond Toy (＠rtoy) 11 Apr '24

11 Apr '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: e88d7ffe by Raymond Toy at 2024-04-11T22:11:51+00:00 Fix #275: FP underflow in reader allows restart with 0 - - - - - 07c9c06b by Raymond Toy at 2024-04-11T22:11:55+00:00 Merge branch 'issue-275b-signal-float-underflow' into 'master' Fix #275: FP underflow in reader allows restart with 0 Closes #275 and #287 See merge request cmucl/cmucl!197 - - - - - 4 changed files: - src/code/reader.lisp - src/general-info/release-21f.md - src/i18n/locale/cmucl.pot - tests/float.lisp Changes: ===================================== src/code/reader.lisp ===================================== @@ -1832,56 +1832,70 @@ the end of the stream." ;; throw an error immediately. We don't need to be super accurate ;; with the limits. The rest of the code will handle it correctly, ;; even if we're too small or too large. - (unless (zerop number) - (flet ((fast-log2 (n) - ;; For an integer, the integer-length is close enough to - ;; the log2 of the number. - (integer-length n))) - ;; log2(x) = log(number*10^exponent/divisor) - ;; = exponent*log2(10) + log2(number)-log2(divisor) - (let ((log2-num (+ (* exponent #.(kernel::log2 10d0)) - (fast-log2 number) - (- (fast-log2 divisor))))) - (multiple-value-bind (log2-low log2-high) - (ecase float-format - ((short-float single-float) - ;; Single-float exponents range is -149 to 127, but we - ;; don't need to be super-accurate since we're - ;; multiplying the values by 2. - (values (* 2 (- vm:single-float-normal-exponent-min - vm:single-float-bias - vm:single-float-digits)) - (* 2 (- vm:single-float-normal-exponent-max - vm:single-float-bias)))) - ((double-float long-float - #+double-double kernel:double-double-float) - (values (* 2 (- vm:double-float-normal-exponent-min - vm:double-float-bias - vm:double-float-digits)) - (* 2 (- vm:double-float-normal-exponent-max - vm:double-float-bias))))) - ;; Double-float exponent range is -1074 to -1023 - (unless (< log2-low log2-num log2-high) - ;; The number is definitely too large or too small to fit. - ;; Signal an error. - (%reader-error stream _"Number not representable as a ~S: ~S" - float-format (read-buffer-to-string))))))) - - ;; Otherwise the number might fit, so we carefully compute the result. - (handler-case - (with-float-traps-masked (:underflow) - (let* ((ratio (/ (* (expt 10 exponent) number) - divisor)) - (result (coerce ratio float-format))) - (when (and (zerop result) (not (zerop number))) - ;; The number we've read is so small that it gets - ;; converted to 0.0, but is not actually zero. Signal an - ;; error. See CLHS 2.3.1.1. - (error _"Underflow")) - result)) - (error () - (%reader-error stream _"Number not representable as a ~S: ~S" - float-format (read-buffer-to-string))))) + (flet ((handle-extreme-numbers () + (unless (zerop number) + (flet ((fast-log2 (n) + ;; For an integer, the integer-length is close enough to + ;; the log2 of the number. + (integer-length n))) + ;; log2(x) = log(number*10^exponent/divisor) + ;; = exponent*log2(10) + log2(number)-log2(divisor) + (let ((log2-num (+ (* exponent #.(kernel::log2 10d0)) + (fast-log2 number) + (- (fast-log2 divisor))))) + (multiple-value-bind (log2-low log2-high) + (ecase float-format + ((short-float single-float) + ;; Single-float exponents range is -149 to 127, but we + ;; don't need to be super-accurate since we're + ;; multiplying the values by 2. + (values (* 2 (- vm:single-float-normal-exponent-min + vm:single-float-bias + vm:single-float-digits)) + (* 2 (- vm:single-float-normal-exponent-max + vm:single-float-bias)))) + ((double-float long-float + #+double-double kernel:double-double-float) + ;; Double-float exponent range is -1074 to -1023 + (values (* 2 (- vm:double-float-normal-exponent-min + vm:double-float-bias + vm:double-float-digits)) + (* 2 (- vm:double-float-normal-exponent-max + vm:double-float-bias))))) + (when (<= log2-num log2-low) + ;; Number is definitely too small; signal an underflow. + (error 'floating-point-underflow)) + (when (>= log2-num log2-high) + ;; Number is definitely too large; signal an error + (error "Overflow")))))))) + + ;; Otherwise the number might fit, so we carefully compute the result. + (handler-case + (with-float-traps-masked (:underflow) + (handle-extreme-numbers) + (let* ((ratio (/ (* (expt 10 exponent) number) + divisor)) + (result (coerce ratio float-format))) + (when (and (zerop result) (not (zerop number))) + ;; The number we've read is so small that it gets + ;; converted to 0.0, but is not actually zero. Signal an + ;; error. See CLHS 2.3.1.1. + (error 'floating-point-underflow)) + result)) + (floating-point-underflow () + ;; Resignal a reader error, but allow the user to continue with + ;; 0. + (let ((zero (coerce 0 float-format))) + (restart-case + (%reader-error stream _"Floating point underflow when reading ~S: ~S" + float-format (read-buffer-to-string)) + (continue () + :report (lambda (stream) + (format stream "Return ~A" zero)) + zero)))) + (error () + (%reader-error stream _"Number not representable as a ~S: ~S" + float-format (read-buffer-to-string)))))) (defun make-ratio (stream) ===================================== src/general-info/release-21f.md ===================================== @@ -56,6 +56,7 @@ public domain. * ~~#271~~ Update ASDF to 3.3.7 * ~~#272~~ Move scavenge code for static vectors to its own function * ~~#274~~ 1d99999999 hangs + * ~~#275~~ FP underflow in reader allows restarting with 0 * ~~#276~~ Implement xoroshiro128** generator for x86 * ~~#277~~ `float-ratio-float` returns 0 for numbers close to least-positive-float ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8750,11 +8750,11 @@ msgid "Internal error in floating point reader." msgstr "" #: src/code/reader.lisp -msgid "Number not representable as a ~S: ~S" +msgid "Floating point underflow when reading ~S: ~S" msgstr "" #: src/code/reader.lisp -msgid "Underflow" +msgid "Number not representable as a ~S: ~S" msgstr "" #: src/code/reader.lisp ===================================== tests/float.lisp ===================================== @@ -247,3 +247,44 @@ (assert-equal 0.9999999999999999d0 (rounding-test 3d0)))) +(define-test reader.underflow-enabled + (:tag :issues) + ;; Test with FP underflow enabled, we can still read denormals + ;; without problem. For this test we only care that we get a + ;; number, not the actual value. + (dolist (n (list least-positive-single-float + least-positive-normalized-single-float + (/ (+ least-positive-single-float + least-positive-normalized-single-float) + 2) + least-positive-double-float + least-positive-normalized-double-float + (/ (+ least-positive-double-float + least-positive-normalized-double-float) + 2) + )) + (assert-true (floatp + (ext:with-float-traps-enabled (:underflow) + (read-from-string (format nil "~A" n))))))) + +(define-test reader-restarts.underflow + (:tag :issues) + ;; Test that we get a restart when reading floating-point numbers + ;; that are too small to fit in a float. Invoke the restart to + ;; return 0. All the numbers must be less than half the + ;; leasst-positive float. + (dolist (item '(("1e-46" 0f0) + ("1e-999" 0f0) + ("1d-324" 0d0) + ("1d-999" 0d0))) + (destructuring-bind (string expected-value) + item + (assert-equal expected-value + (values (handler-bind + ((reader-error + (lambda (c) + (declare (ignore c)) + (invoke-restart 'lisp::continue)))) + (read-from-string string))))))) + + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/df78595ef611a98eb5fe6c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/df78595ef611a98eb5fe6c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-293-restart-on-reader-fp-overflow] Add issue #293 to release notes.
by Raymond Toy (＠rtoy) 10 Apr '24

10 Apr '24

Raymond Toy pushed to branch issue-293-restart-on-reader-fp-overflow at cmucl / cmucl Commits: da48651d by Raymond Toy at 2024-04-10T14:28:16-07:00 Add issue #293 to release notes. - - - - - 1 changed file: - src/general-info/release-21f.md Changes: ===================================== src/general-info/release-21f.md ===================================== @@ -65,6 +65,7 @@ public domain. * ~~#288~~ Re-enable `deftransform` for random integers. * ~~#290~~ Pprint `with-float-traps-masked` better * ~~#291~~ Pprint `handler-case` neatly. + * ~~#293~~ Allow restarts for FP overflow in reader. * ~~#297~~ Pprint `new-assem:assemble` with less indentation. * Other changes: * Improvements to the PCL implementation of CLOS: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/da48651df72c0685a095cca… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/da48651df72c0685a095cca… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-275b-signal-float-underflow] Add issue #275 to release notes.
by Raymond Toy (＠rtoy) 10 Apr '24

10 Apr '24

Raymond Toy pushed to branch issue-275b-signal-float-underflow at cmucl / cmucl Commits: 6b933b4a by Raymond Toy at 2024-04-10T14:26:39-07:00 Add issue #275 to release notes. - - - - - 1 changed file: - src/general-info/release-21f.md Changes: ===================================== src/general-info/release-21f.md ===================================== @@ -56,6 +56,7 @@ public domain. * ~~#271~~ Update ASDF to 3.3.7 * ~~#272~~ Move scavenge code for static vectors to its own function * ~~#274~~ 1d99999999 hangs + * ~~#275~~ FP underflow in reader allows restarting with 0 * ~~#276~~ Implement xoroshiro128** generator for x86 * ~~#277~~ `float-ratio-float` returns 0 for numbers close to least-positive-float View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6b933b4a49b664564b45b28… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6b933b4a49b664564b45b28… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-275b-signal-float-underflow] 4 commits: Add test reading denormals with underflow enabled.
by Raymond Toy (＠rtoy) 10 Apr '24

10 Apr '24

Raymond Toy pushed to branch issue-275b-signal-float-underflow at cmucl / cmucl Commits: f3b2f7d8 by Raymond Toy at 2024-04-10T08:12:12-07:00 Add test reading denormals with underflow enabled. We should be able to read denormals without problems even if FP underflow is enabled. - - - - - e27ac073 by Raymond Toy at 2024-04-10T13:08:05-07:00 Fix underflow test that was underflowing In the test, we had underflow enabled, but computed numbers that would underflow. Hence, only wrap the part that reads floats with underflow enabled. - - - - - 1e3a49ea by Raymond Toy at 2024-04-10T13:10:29-07:00 Just enable underflow only around reading from the string - - - - - 3f4072b5 by Raymond Toy at 2024-04-10T13:11:16-07:00 Handle underflow for very tiny numbers Previously, when the numbers were very tiny, we signaled a reader-error but didn't have a restart to return 0. Modify the code so that when we have very tiny numbers, we signal a `floating-point-underflow` error that we can catch and establish a restart to return 0. For very large numbers that overflow, we just signal a reader-error for now. Update cmucl.pot too for the new string. - - - - - 3 changed files: - src/code/reader.lisp - src/i18n/locale/cmucl.pot - tests/float.lisp Changes: ===================================== src/code/reader.lisp ===================================== @@ -1832,67 +1832,70 @@ the end of the stream." ;; throw an error immediately. We don't need to be super accurate ;; with the limits. The rest of the code will handle it correctly, ;; even if we're too small or too large. - (unless (zerop number) - (flet ((fast-log2 (n) - ;; For an integer, the integer-length is close enough to - ;; the log2 of the number. - (integer-length n))) - ;; log2(x) = log(number*10^exponent/divisor) - ;; = exponent*log2(10) + log2(number)-log2(divisor) - (let ((log2-num (+ (* exponent #.(kernel::log2 10d0)) - (fast-log2 number) - (- (fast-log2 divisor))))) - (multiple-value-bind (log2-low log2-high) - (ecase float-format - ((short-float single-float) - ;; Single-float exponents range is -149 to 127, but we - ;; don't need to be super-accurate since we're - ;; multiplying the values by 2. - (values (* 2 (- vm:single-float-normal-exponent-min - vm:single-float-bias - vm:single-float-digits)) - (* 2 (- vm:single-float-normal-exponent-max - vm:single-float-bias)))) - ((double-float long-float - #+double-double kernel:double-double-float) - ;; Double-float exponent range is -1074 to -1023 - (values (* 2 (- vm:double-float-normal-exponent-min - vm:double-float-bias - vm:double-float-digits)) - (* 2 (- vm:double-float-normal-exponent-max - vm:double-float-bias))))) - (unless (< log2-low log2-num log2-high) - ;; The number is definitely too large or too small to fit. - ;; Signal an error. - (%reader-error stream _"Number not representable as a ~S: ~S" - float-format (read-buffer-to-string))))))) - - ;; Otherwise the number might fit, so we carefully compute the result. - (handler-case - (with-float-traps-masked (:underflow) - (let* ((ratio (/ (* (expt 10 exponent) number) - divisor)) - (result (coerce ratio float-format))) - (when (and (zerop result) (not (zerop number))) - ;; The number we've read is so small that it gets - ;; converted to 0.0, but is not actually zero. Signal an - ;; error. See CLHS 2.3.1.1. - (error 'floating-point-underflow)) - result)) - (floating-point-underflow () - ;; Resignal a reader error, but allow the user to continue with - ;; 0. - (let ((zero (coerce 0 float-format))) - (restart-case - (%reader-error stream _"Floating point underflow when reading ~S: ~S" - float-format (read-buffer-to-string)) - (continue () - :report (lambda (stream) - (format stream "Return ~A" zero)) - zero)))) - (error () - (%reader-error stream _"Number not representable as a ~S: ~S" - float-format (read-buffer-to-string))))) + (flet ((handle-extreme-numbers () + (unless (zerop number) + (flet ((fast-log2 (n) + ;; For an integer, the integer-length is close enough to + ;; the log2 of the number. + (integer-length n))) + ;; log2(x) = log(number*10^exponent/divisor) + ;; = exponent*log2(10) + log2(number)-log2(divisor) + (let ((log2-num (+ (* exponent #.(kernel::log2 10d0)) + (fast-log2 number) + (- (fast-log2 divisor))))) + (multiple-value-bind (log2-low log2-high) + (ecase float-format + ((short-float single-float) + ;; Single-float exponents range is -149 to 127, but we + ;; don't need to be super-accurate since we're + ;; multiplying the values by 2. + (values (* 2 (- vm:single-float-normal-exponent-min + vm:single-float-bias + vm:single-float-digits)) + (* 2 (- vm:single-float-normal-exponent-max + vm:single-float-bias)))) + ((double-float long-float + #+double-double kernel:double-double-float) + ;; Double-float exponent range is -1074 to -1023 + (values (* 2 (- vm:double-float-normal-exponent-min + vm:double-float-bias + vm:double-float-digits)) + (* 2 (- vm:double-float-normal-exponent-max + vm:double-float-bias))))) + (when (<= log2-num log2-low) + ;; Number is definitely too small; signal an underflow. + (error 'floating-point-underflow)) + (when (>= log2-num log2-high) + ;; Number is definitely too large; signal an error + (error "Overflow")))))))) + + ;; Otherwise the number might fit, so we carefully compute the result. + (handler-case + (with-float-traps-masked (:underflow) + (handle-extreme-numbers) + (let* ((ratio (/ (* (expt 10 exponent) number) + divisor)) + (result (coerce ratio float-format))) + (when (and (zerop result) (not (zerop number))) + ;; The number we've read is so small that it gets + ;; converted to 0.0, but is not actually zero. Signal an + ;; error. See CLHS 2.3.1.1. + (error 'floating-point-underflow)) + result)) + (floating-point-underflow () + ;; Resignal a reader error, but allow the user to continue with + ;; 0. + (let ((zero (coerce 0 float-format))) + (restart-case + (%reader-error stream _"Floating point underflow when reading ~S: ~S" + float-format (read-buffer-to-string)) + (continue () + :report (lambda (stream) + (format stream "Return ~A" zero)) + zero)))) + (error () + (%reader-error stream _"Number not representable as a ~S: ~S" + float-format (read-buffer-to-string)))))) (defun make-ratio (stream) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8750,11 +8750,11 @@ msgid "Internal error in floating point reader." msgstr "" #: src/code/reader.lisp -msgid "Number not representable as a ~S: ~S" +msgid "Floating point underflow when reading ~S: ~S" msgstr "" #: src/code/reader.lisp -msgid "Floating point underflow when reading ~S: ~S" +msgid "Number not representable as a ~S: ~S" msgstr "" #: src/code/reader.lisp ===================================== tests/float.lisp ===================================== @@ -247,3 +247,44 @@ (assert-equal 0.9999999999999999d0 (rounding-test 3d0)))) +(define-test reader.underflow-enabled + (:tag :issues) + ;; Test with FP underflow enabled, we can still read denormals + ;; without problem. For this test we only care that we get a + ;; number, not the actual value. + (dolist (n (list least-positive-single-float + least-positive-normalized-single-float + (/ (+ least-positive-single-float + least-positive-normalized-single-float) + 2) + least-positive-double-float + least-positive-normalized-double-float + (/ (+ least-positive-double-float + least-positive-normalized-double-float) + 2) + )) + (assert-true (floatp + (ext:with-float-traps-enabled (:underflow) + (read-from-string (format nil "~A" n))))))) + +(define-test reader-restarts.underflow + (:tag :issues) + ;; Test that we get a restart when reading floating-point numbers + ;; that are too small to fit in a float. Invoke the restart to + ;; return 0. All the numbers must be less than half the + ;; leasst-positive float. + (dolist (item '(("1e-46" 0f0) + ("1e-999" 0f0) + ("1d-324" 0d0) + ("1d-999" 0d0))) + (destructuring-bind (string expected-value) + item + (assert-equal expected-value + (values (handler-bind + ((reader-error + (lambda (c) + (declare (ignore c)) + (invoke-restart 'lisp::continue)))) + (read-from-string string))))))) + + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9a811166998f97f907d0f8… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9a811166998f97f907d0f8… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-275b-signal-float-underflow] 23 commits: Fix #298: Add with-float-rounding-mode macro
by Raymond Toy (＠rtoy) 10 Apr '24

10 Apr '24

Raymond Toy pushed to branch issue-275b-signal-float-underflow at cmucl / cmucl Commits: 7543b720 by Raymond Toy at 2024-04-02T08:10:23-07:00 Fix #298: Add with-float-rounding-mode macro Add `ext:with-float-rounding-mode` macro to set the FP rounding mode to be used when executing the body. - - - - - bf417b47 by Raymond Toy at 2024-04-02T08:33:30-07:00 Update cmucl.pot with new docstrings - - - - - e32034e0 by Raymond Toy at 2024-04-02T08:33:52-07:00 Add tests for with-float-rounding-mode Not 100% sure the expected results are right. They seem plausible, but I didn't actually analyze that the rounding is correct. - - - - - 3cdf6b8f by Raymond Toy at 2024-04-06T08:33:14-07:00 Reorder bug list to be numerically ascending. No other changes. - - - - - 62631e15 by Raymond Toy at 2024-04-07T22:52:52+00:00 Fix #297: Print new-assem:assemble with less indentation - - - - - 7bec290f by Raymond Toy at 2024-04-07T22:53:01+00:00 Merge branch 'issue-297-pprint-assemble' into 'master' Fix #297: Print new-assem:assemble with less indentation Closes #297 See merge request cmucl/cmucl!203 - - - - - bb1bc462 by Raymond Toy at 2024-04-07T22:53:45+00:00 Fix #300: Reduce code duplication in random - - - - - 94a2c674 by Raymond Toy at 2024-04-07T22:53:51+00:00 Merge branch 'issue-300-reduce-code-dup-in-random' into 'master' Fix #300: Reduce code duplication in random Closes #300 See merge request cmucl/cmucl!206 - - - - - 6ba75434 by Carl Shapiro at 2024-04-07T23:19:27+00:00 Make variable names consistent. - - - - - b8923ba5 by Raymond Toy at 2024-04-08T00:00:36+00:00 Fix #295: Add docstring for define-assembly-routine - - - - - e77ded50 by Raymond Toy at 2024-04-08T00:00:39+00:00 Merge branch 'issue-295-docstring-for-define-assembly-routine' into 'master' Fix #295: Add docstring for define-assembly-routine Closes #295 See merge request cmucl/cmucl!204 - - - - - 0e716eab by Raymond Toy at 2024-04-07T17:02:55-07:00 Fix typos caused by renaming We renamed `old-rounding-mode` to `old-mode`, but forgot to update all uses. - - - - - 6181fd24 by Raymond Toy at 2024-04-08T05:52:20-07:00 Fix up docstring for with-float-rounding-mode Mention that the allowed values are the same as the values for the rounding-mode in `set-floating-point-modes`. Change indentation of docstring slightly so that it prints nicely via `describe`. (Emacs doesn't indent the docstring by the right amount for `describe`.) - - - - - 659c41bc by Raymond Toy at 2024-04-08T05:58:05-07:00 Remove extra trailing space after period. - - - - - 1cb2cb14 by Raymond Toy at 2024-04-08T13:00:08+00:00 Fix #294: Implement assembly routine for xoroshiro update - - - - - 574eef63 by Raymond Toy at 2024-04-08T13:00:12+00:00 Merge branch 'issue-294-xoroshiro-lisp-assem-routine' into 'master' Fix #294: Implement assembly routine for xoroshiro update Closes #294 See merge request cmucl/cmucl!202 - - - - - 07a1669b by Raymond Toy at 2024-04-08T06:05:43-07:00 Update cmucl.pot for changed docstring for with-float-rounding-mode. - - - - - a46a530e by Raymond Toy at 2024-04-08T14:00:18+00:00 Merge branch 'issue-298-with-float-rounding-mode' into 'master' Fix #298: Add with-float-rounding-mode macro Closes #298 See merge request cmucl/cmucl!205 - - - - - aa42e51a by Raymond Toy at 2024-04-09T16:19:13+00:00 Fix #299: Use xoroshiro assembly routine for x86 - - - - - 149c45e1 by Raymond Toy at 2024-04-09T16:19:41+00:00 Merge branch 'issue-299-enable-xoroshiro-assem-routine' into 'master' Fix #299: Use xoroshiro assembly routine for x86 Closes #299, #295, #300, #297, and #294 See merge request cmucl/cmucl!208 - - - - - d9983ea5 by Raymond Toy at 2024-04-09T11:59:46-07:00 Add comment about using -V and use a better version Explain why we use `-V` for `bin/make-dist.sh`. And instead of using "ci-build" as the version, use `git describe --dirty` as the version. This lets us know better what version was actually used for the build. - - - - - 9f4e552c by Raymond Toy at 2024-04-09T21:48:00-07:00 Disable underflow trap when converting the ratio to a float. Update cmucl.pot for the changed strings too. - - - - - 9a811166 by Raymond Toy at 2024-04-09T21:50:03-07:00 Merge branch 'master' into issue-275b-signal-float-underflow - - - - - 16 changed files: - .gitlab-ci.yml - bin/make-dist.sh - src/assembly/assemfile.lisp - src/assembly/x86/arith.lisp - src/assembly/x86/support.lisp - src/bootfiles/21e/boot-2023-08.lisp - src/code/exports.lisp - src/code/float-trap.lisp - src/code/pprint.lisp - src/code/rand-xoroshiro.lisp - src/code/reader.lisp - src/compiler/x86/arith.lisp - src/general-info/release-21f.md - src/i18n/locale/cmucl.pot - tests/float.lisp - tests/pprint.lisp Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1,7 +1,7 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2023/08" - version: "2023-08-x86" - bootstrap: "-B boot-2023-08" + version: "xoroshiro-assembly-x86" + bootstrap: "" stages: @@ -48,7 +48,9 @@ linux:build: # Regular build using the cross-compiled result or snapshot - bin/build.sh $bootstrap -R -C "x86_linux_clang" -o snapshot/bin/lisp # - bin/build.sh $bootstrap -R -C "x86_linux" -o snapshot/bin/lisp - - bin/make-dist.sh -I dist linux-4 + # Use -V to specify the version in case some tag makes git + # describe return something that make-dist.sh doesn't like. + - bin/make-dist.sh -V `git describe --dirty` -I dist linux-4 linux:test: stage: test @@ -131,7 +133,9 @@ osx:build: # Regular build using the cross-compiled result or snapshot. # Need /opt/local/bin to get msgmerge and msgfmt programs. - PATH=/opt/local/bin:$PATH bin/build.sh $bootstrap -R -C "" -o snapshot/bin/lisp - - bin/make-dist.sh -I dist darwin-4 + # Use -V to specify the version in case some tag makes git + # describe return something that make-dist.sh doesn't like. + - bin/make-dist.sh -V `git describe --dirty` -I dist darwin-4 osx:test: stage: test ===================================== bin/make-dist.sh ===================================== @@ -98,6 +98,8 @@ def_arch_os # ("snapshot-yyyy-mm") or a release number.. GIT_HASH="`(cd src; git describe --dirty 2>/dev/null)`" +echo GIT_HASH = ${GIT_HASH} + if expr "X${GIT_HASH}" : 'Xsnapshot-[0-9][0-9][0-9][0-9]-[01][0-9]' > /dev/null; then DEFAULT_VERSION=`expr "${GIT_HASH}" : "snapshot-$.*$"` fi ===================================== src/assembly/assemfile.lisp ===================================== @@ -209,7 +209,61 @@ ,(reg-spec-temp res)))) results)))))) +;;; Define-Assembly-Routine -- Public +;;; +;;; Parse the code to produce an assembly routine and create a VOP +;;; that calls the assembly routine. (defmacro define-assembly-routine (name&options vars &rest code) + "Define-Assembly-Routine (Name&Options Vars Code*) + Define a Lisp assembly routine, and a VOP to that calls the assembly + routine, if enabled. (A VOP is not created if the reader + conditional #+assembler precedes the definition of the assembly + routine.) + + Name&Options + A list giving the name of the assembly routine and options + describing the assembly routine options and VOP options. The + format is (Name ({Key Value})*) where Name is the name of the + assembly routine. Options is a list of options: + + Options + + :Cost Cost + The cost of the VOP. This is used in the generated VOP. + + :Policy {:Small | :Fast | :Safe | :Fast-Safe} + The policy for the VOP. + + :Translate Name + The translation for the VOP. + + :Arg-Types arg-types + :Result-Types result-types + The template restrictions for the arguments of the VOP and the + results of the VOP. + + :Return-Style {:Raw :Full-Call :None} + + Vars is a list of the arguments and returned results and + temporaries used by the assembly routine. + + :Arg Arg-Name (SC*) SC-Offset + Input argument for the assembly routine with the name + Arg-Name. The argument must be one of the SC types. The register + assigned to this argument is given by SC-Offset which must be + the offset for the register holding this argument. + + :Res Res-Name SC SC-Offset + Result of the assembly routine with the name Res-Name. The + result must be a register of the specified storage class SC. The + Sc-offset is the register used for the result. + + :Temp Temp-Name SC SC-Offset + Like :Res, except this names a temporary register that the + assembly routine can use. + + Code + The code for the assembly routine." (multiple-value-bind (name options) (if (atom name&options) (values name&options nil) ===================================== src/assembly/x86/arith.lisp ===================================== @@ -411,3 +411,121 @@ (inst pop y) (inst pop k) (inst ret)) + +;;; Support for the xoroshiro128** generator. See +;;; https://prng.di.unimi.it/xoroshiro128starstar.c for the official +;;; code. +;;; +;;; This is what we're implementing, where s[] is our state vector. +;;; +;;; static uint64_t s[2]; +;;; static inline uint64_t rotl(const uint64_t x, int k) { +;;; return (x << k) | (x >> (64 - k)); +;;; } +;;; +;;; uint64_t next(void) { +;;; const uint64_t s0 = s[0]; +;;; uint64_t s1 = s[1]; +;;; const uint64_t result = rotl(s0 * 5, 7) * 9; +;;; +;;; s1 ^= s0; +;;; s[0] = rotl(s0, 24) ^ s1 ^ (s1 << 16); // a, b +;;; s[1] = rotl(s1, 37); // c +;;; +;;; return result; +;;; } +;;; +;;; A VOP is also generated to call this assembly routine. This +;;; routine computes a new 64-bit random number and also updates the +;;; state, which is (simple-array (double-float) (2)). +#+random-xoroshiro +(define-assembly-routine + (xoroshiro-update + (:translate kernel::random-xoroshiro-update) + (:return-style :raw) + (:cost 30) + (:policy :fast-safe) + (:arg-types simple-array-double-float) + (:result-types unsigned-num unsigned-num)) + ((:arg state descriptor-reg edx-offset) + (:res r1 unsigned-reg ecx-offset) + (:res r0 unsigned-reg ebx-offset) + (:temp s0 double-reg xmm0-offset) + (:temp s1 double-reg xmm1-offset) + (:temp t0 double-reg xmm2-offset) + (:temp t1 double-reg xmm3-offset)) + + ;; s0 = state[0] + (inst movsd s0 (make-ea :dword :base state + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 0)) + vm:other-pointer-type))) + ;; t0 = s0 * 5 = s0 << 2 + s0 + (inst movapd t0 s0) ; t0 = s0 + (inst psllq t0 2) ; t0 = t0 << 2 = 4*t0 + (inst paddq t0 s0) ; t0 = t0 + s0 = 5*t0 + + ;; t0 = rotl(t0, 7) = t0 << 7 | t0 >> (64-7) + ;; = rotl(s0*5, 7) + (inst movapd t1 t0) ; t1 = t0 + (inst psllq t1 7) ; t1 = t0 << 7 + (inst psrlq t0 (- 64 7)) ; t0 = t0 >> 57 + (inst orpd t0 t1) ; t0 = t0 << 7 | t0 >> 57 = rotl(t0, 7) + + ;; t0 = t0 * 9 = t0 << 3 + t0 + ;; = rotl(s0*5, 7) * 9 + (inst movapd t1 t0) ; t1 = t0 + (inst psllq t1 3) ; t1 = t0 << 3 + (inst paddq t0 t1) ; t0 = t0 << 3 + t0 = 9*t0 + + ;; Save the result as two 32-bit results. r1 is the high 32 bits + ;; and r0 is the low 32. + (inst movd r0 t0) + (inst psrlq t0 32) + (inst movd r1 t0) + + ;; s1 = state[1] + (inst movsd s1 (make-ea :dword :base state + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 1)) + vm:other-pointer-type))) + (inst xorpd s1 s0) ; s1 = s1 ^ s0 + + ;; s0 can now be reused as a temp. + ;; s0 = rotl(s0, 24) + (inst movapd t0 s0) ; t0 = s0 + (inst psllq t0 24) ; t0 = s0 << 24 + (inst psrlq s0 (- 64 24)) ; s0 = s0 >> 40 + (inst orpd s0 t0) ; s0 = s0 | t0 = rotl(s0, 24) + + ;; s0 = s0 ^ s1 = rotl(s0, 24) ^ s1 + (inst xorpd s0 s1) + + ;; s0 = s0 ^ (s1 << 16) + (inst movapd t0 s1) ; t0 = s1 + (inst psllq t0 16) ; t0 = s1 << 16 + (inst xorpd s0 t0) ; s0 = rotl(s0, 24) ^ s1 ^ (s1 << 16) + + ;; Save s0 to state[0] + (inst movsd (make-ea :dword :base state + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 0)) + vm:other-pointer-type)) + s0) + + ;; s1 = rotl(s1, 37) + (inst movapd t0 s1) ; t0 = s1 + (inst psllq t0 37) ; t0 = s1 << 37 + (inst psrlq s1 (- 64 37)) ; s1 = s1 >> 27 + (inst orpd s1 t0) ; s1 = t0 | s1 = rotl(s1, 37) + + ;; Save s1 to state[1] + (inst movsd (make-ea :dword :base state + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 8 1)) + vm:other-pointer-type)) + s1)) ===================================== src/assembly/x86/support.lisp ===================================== @@ -39,7 +39,7 @@ (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw - `(inst ret)) + `((inst ret))) (:full-call `( (inst pop eax-tn) ===================================== src/bootfiles/21e/boot-2023-08.lisp ===================================== @@ -2,3 +2,46 @@ ;; *SOFTWARE-VERSION* from the LISP package to the SYSTEM package. (ext:without-package-locks (unintern 'lisp::*software-version* "LISP")) + +#+(or random-mt19937 random-xoroshiro) +(in-package "C") +#+(or random-mt19937 random-xoroshiro) +(deftransform random ((num &optional state) + ((integer 1 #.(expt 2 32)) &optional *)) + _N"use inline (unsigned-byte 32) operations" + (let* ((num-type (continuation-type num)) + (num-high (cond ((numeric-type-p num-type) + (numeric-type-high num-type)) + ((union-type-p num-type) + ;; Find the maximum of the union type. We + ;; know this works because if we're in this + ;; routine, NUM must be a subtype of + ;; (INTEGER 1 2^32), so each member of the + ;; union must be a subtype too. + (reduce #'max (union-type-types num-type) + :key #'numeric-type-high)) + (t + (give-up))))) + ;; Rather than doing (rem (random-chunk) num-high), we do, + ;; essentially, (rem (* num-high (random-chunk)) #x100000000). I + ;; (rtoy) believe this approach doesn't have the bias issue with + ;; doing rem. This method works by treating (random-chunk) as if + ;; it were a 32-bit fraction between 0 and 1, exclusive. Multiply + ;; this by num-high to get a random number between 0 and num-high, + ;; This should have no bias. + (cond ((constant-continuation-p num) + (if (= num-high (expt 2 32)) + '(random-chunk (or state *random-state*)) + '(values (bignum::%multiply + (random-chunk (or state *random-state*)) + num)))) + ((< num-high (expt 2 32)) + '(values (bignum::%multiply (random-chunk (or state *random-state*)) + num))) + ((= num-high (expt 2 32)) + '(if (= num (expt 2 32)) + (random-chunk (or state *random-state*)) + (values (bignum::%multiply (random-chunk (or state *random-state*)) + num)))) + (t + (error (intl:gettext "Shouldn't happen")))))) ===================================== src/code/exports.lisp ===================================== @@ -1591,7 +1591,8 @@ "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P" "FLOAT-SIGNALING-NAN-P" "WITH-FLOAT-TRAPS-MASKED" - "WITH-FLOAT-TRAPS-ENABLED") + "WITH-FLOAT-TRAPS-ENABLED" + "WITH-FLOAT-ROUNDING-MODE") ;; More float extensions #+double-double (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT" ===================================== src/code/float-trap.lisp ===================================== @@ -27,7 +27,8 @@ decode-floating-point-modes encode-floating-point-modes with-float-traps-masked - with-float-traps-enabled)) + with-float-traps-enabled + with-float-rounding-mode)) (in-package "VM") (eval-when (compile load eval) @@ -495,3 +496,34 @@ accrued exceptions are cleared at the start of the body to support their testing within, and restored on exit.")) +(defmacro with-float-rounding-mode ((rounding-mode) &body body) + _N"Execute BODY with the floating-point rounding mode set to + ROUNDING-MODE. ROUNDING-MODE must be a one: + + :NEAREST + the default mode of round to nearest even. + :ZERO + round numbers down towards zero. Positive numbers round down + and negative numbers round up. + :POSITIVE-INFINITY + round numbers up towards positive infinity. + :NEGATIVE-INFINITY + round numbers down towards negative infinity. + + These are the same as the possible values for the rounding mode in + SET-FLOATING-POINT-MODES. + + Only the rounding mode is restored on exit; other floating-point + modes are not modified." + (let ((old-mode (gensym "OLD-MODE-")) + (new-mode (gensym "NEW-MODE-"))) + `(let ((,old-mode (ldb float-rounding-mode (floating-point-modes))) + (,new-mode (cdr (assoc ,rounding-mode rounding-mode-alist)))) + (unwind-protect + (progn + (setf (floating-point-modes) + (dpb ,new-mode float-rounding-mode (floating-point-modes))) + ,@body) + ;; Restore just the rounding mode to the original value. + (setf (floating-point-modes) + (dpb ,old-mode float-rounding-mode (floating-point-modes))))))) ===================================== src/code/pprint.lisp ===================================== @@ -2088,6 +2088,7 @@ When annotations are present, invoke them at the right positions." (c:define-vop pprint-define-vop) (c:sc-case pprint-sc-case) (c:define-assembly-routine pprint-define-assembly) + (new-assem:assemble pprint-multiple-value-bind) (c:deftransform pprint-defun) (c:defoptimizer pprint-defun) (ext:with-float-traps-masked pprint-with-like) ===================================== src/code/rand-xoroshiro.lisp ===================================== @@ -238,7 +238,7 @@ being the first value." (declare (type (simple-array double-float (2)) state) (optimize (speed 3) (safety 0))) - (vm::xoroshiro-next state)) + (kernel::random-xoroshiro-update state)) #-x86 (defun xoroshiro-gen (state) @@ -490,11 +490,8 @@ (declare (inline %random-single-float %random-double-float)) (cond ((typep arg '(integer 1 #x100000000)) - ;; Do the same thing as the deftransform would do. - (if (= arg (expt 2 32)) - (random-chunk state) - (values (bignum::%multiply (random-chunk state) - arg)))) + ;; Let the compiler deftransform take care of this case. + (random arg state)) ((and (typep arg 'single-float) (> arg 0.0F0)) (%random-single-float arg state)) ((and (typep arg 'double-float) (> arg 0.0D0)) ===================================== src/code/reader.lisp ===================================== @@ -1869,15 +1869,16 @@ the end of the stream." ;; Otherwise the number might fit, so we carefully compute the result. (handler-case - (let* ((ratio (/ (* (expt 10 exponent) number) - divisor)) - (result (coerce ratio float-format))) - (when (and (zerop result) (not (zerop number))) - ;; The number we've read is so small that it gets - ;; converted to 0.0, but is not actually zero. Signal an - ;; error. See CLHS 2.3.1.1. - (error _"Underflow")) - result) + (with-float-traps-masked (:underflow) + (let* ((ratio (/ (* (expt 10 exponent) number) + divisor)) + (result (coerce ratio float-format))) + (when (and (zerop result) (not (zerop number))) + ;; The number we've read is so small that it gets + ;; converted to 0.0, but is not actually zero. Signal an + ;; error. See CLHS 2.3.1.1. + (error 'floating-point-underflow)) + result)) (floating-point-underflow () ;; Resignal a reader error, but allow the user to continue with ;; 0. ===================================== src/compiler/x86/arith.lisp ===================================== @@ -1695,118 +1695,9 @@ (in-package "VM") +;; The update routine is a Lisp assembly routine with a corresponding +;; VOP. This lets the compiler know about the VOP so we can use it. #+random-xoroshiro -(progn -(defknown xoroshiro-next ((simple-array double-float (2))) +(defknown kernel::random-xoroshiro-update ((simple-array double-float (2))) (values (unsigned-byte 32) (unsigned-byte 32)) (movable)) - -(define-vop (xoroshiro-next) - (:policy :fast-safe) - (:translate xoroshiro-next) - (:args (state :scs (descriptor-reg) :to (:result 3))) - (:arg-types simple-array-double-float) - (:results (r1 :scs (unsigned-reg)) - (r0 :scs (unsigned-reg))) - (:result-types unsigned-num unsigned-num) - (:temporary (:sc double-reg) s0) - (:temporary (:sc double-reg) s1) - (:temporary (:sc double-reg) t0) - (:temporary (:sc double-reg) t1) - (:generator 10 - ;; See https://prng.di.unimi.it/xoroshiro128starstar.c for the official code. - ;; - ;; This is what we're implementing, where s[] is our state vector. - ;; - ;; static uint64_t s[2]; - ;; static inline uint64_t rotl(const uint64_t x, int k) { - ;; return (x << k) | (x >> (64 - k)); - ;; } - ;; - ;; uint64_t next(void) { - ;; const uint64_t s0 = s[0]; - ;; uint64_t s1 = s[1]; - ;; const uint64_t result = rotl(s0 * 5, 7) * 9; - ;; - ;; s1 ^= s0; - ;; s[0] = rotl(s0, 24) ^ s1 ^ (s1 << 16); // a, b - ;; s[1] = rotl(s1, 37); // c - ;; - ;; return result; - ;; } - - ;; s0 = state[0] - (inst movsd s0 (make-ea :dword :base state - :disp (- (+ (* vm:vector-data-offset - vm:word-bytes) - (* 8 0)) - vm:other-pointer-type))) - ;; t0 = s0 * 5 = s0 << 2 + s0 - (inst movapd t0 s0) ; t0 = s0 - (inst psllq t0 2) ; t0 = t0 << 2 = 4*t0 - (inst paddq t0 s0) ; t0 = t0 + s0 = 5*t0 - - ;; t0 = rotl(t0, 7) = t0 << 7 | t0 >> (64-7) - ;; = rotl(s0*5, 7) - (inst movapd t1 t0) ; t1 = t0 - (inst psllq t1 7) ; t1 = t0 << 7 - (inst psrlq t0 (- 64 7)) ; t0 = t0 >> 57 - (inst orpd t0 t1) ; t0 = t0 << 7 | t0 >> 57 = rotl(t0, 7) - - ;; t0 = t0 * 9 = t0 << 3 + t0 - ;; = rotl(s0*5, 7) * 9 - (inst movapd t1 t0) ; t1 = t0 - (inst psllq t1 3) ; t1 = t0 << 3 - (inst paddq t0 t1) ; t0 = t0 << 3 + t0 = 9*t0 - - ;; Save the result as two 32-bit results. r1 is the high 32 bits - ;; and r0 is the low 32. - (inst movd r0 t0) - (inst psrlq t0 32) - (inst movd r1 t0) - - ;; s1 = state[1] - (inst movsd s1 (make-ea :dword :base state - :disp (- (+ (* vm:vector-data-offset - vm:word-bytes) - (* 8 1)) - vm:other-pointer-type))) - (inst xorpd s1 s0) ; s1 = s1 ^ s0 - - ;; s0 can now be reused as a temp. - ;; s0 = rotl(s0, 24) - (inst movapd t0 s0) ; t0 = s0 - (inst psllq t0 24) ; t0 = s0 << 24 - (inst psrlq s0 (- 64 24)) ; s0 = s0 >> 40 - (inst orpd s0 t0) ; s0 = s0 | t0 = rotl(s0, 24) - - ;; s0 = s0 ^ s1 = rotl(s0, 24) ^ s1 - (inst xorpd s0 s1) - - ;; s0 = s0 ^ (s1 << 16) - (inst movapd t0 s1) ; t0 = s1 - (inst psllq t0 16) ; t0 = s1 << 16 - (inst xorpd s0 t0) ; s0 = rotl(s0, 24) ^ s1 ^ (s1 << 16) - - ;; Save s0 to state[0] - (inst movsd (make-ea :dword :base state - :disp (- (+ (* vm:vector-data-offset - vm:word-bytes) - (* 8 0)) - vm:other-pointer-type)) - s0) - - ;; s1 = rotl(s1, 37) - (inst movapd t0 s1) ; t0 = s1 - (inst psllq t0 37) ; t0 = s1 << 37 - (inst psrlq s1 (- 64 37)) ; s1 = s1 >> 27 - (inst orpd s1 t0) ; s1 = t0 | s1 = rotl(s1, 37) - - ;; Save s1 to state[1] - (inst movsd (make-ea :dword :base state - :disp (- (+ (* vm:vector-data-offset - vm:word-bytes) - (* 8 1)) - vm:other-pointer-type)) - s1))) -) ===================================== src/general-info/release-21f.md ===================================== @@ -51,8 +51,8 @@ public domain. * ~~#261~~ Remove `get-system-info` from "bsd-os.lisp" * ~~#268~~ Can't clone ansi-test repo on Mac OS CI box * ~~#265~~ CI for mac os is broken - * ~~#269~~ Add function to get user's home directory * ~~#266~~ Support "~user" in namestrings + * ~~#269~~ Add function to get user's home directory * ~~#271~~ Update ASDF to 3.3.7 * ~~#272~~ Move scavenge code for static vectors to its own function * ~~#274~~ 1d99999999 hangs @@ -65,6 +65,7 @@ public domain. * ~~#288~~ Re-enable `deftransform` for random integers. * ~~#290~~ Pprint `with-float-traps-masked` better * ~~#291~~ Pprint `handler-case` neatly. + * ~~#297~~ Pprint `new-assem:assemble` with less indentation. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -4868,6 +4868,28 @@ msgid "" " their testing within, and restored on exit." msgstr "" +#: src/code/float-trap.lisp +msgid "" +"Execute BODY with the floating-point rounding mode set to\n" +" ROUNDING-MODE. ROUNDING-MODE must be a one:\n" +"\n" +" :NEAREST\n" +" the default mode of round to nearest even.\n" +" :ZERO\n" +" round numbers down towards zero. Positive numbers round down\n" +" and negative numbers round up.\n" +" :POSITIVE-INFINITY\n" +" round numbers up towards positive infinity.\n" +" :NEGATIVE-INFINITY\n" +" round numbers down towards negative infinity.\n" +"\n" +" These are the same as the possible values for the rounding mode in\n" +" SET-FLOATING-POINT-MODES.\n" +"\n" +" Only the rounding mode is restored on exit; other floating-point\n" +" modes are not modified." +msgstr "" + #: src/code/float.lisp msgid "Return true if the float X is denormalized." msgstr "" @@ -8731,10 +8753,6 @@ msgstr "" msgid "Number not representable as a ~S: ~S" msgstr "" -#: src/code/reader.lisp -msgid "Underflow" -msgstr "" - #: src/code/reader.lisp msgid "Floating point underflow when reading ~S: ~S" msgstr "" ===================================== tests/float.lisp ===================================== @@ -213,35 +213,37 @@ (assert-error 'reader-error (read-from-string "1.8d308")) (assert-error 'reader-error (read-from-string "1d999999999"))) -(define-test reader.float-underflow +(defun rounding-test (x) + (declare (double-float x) + (optimize (speed 3))) + (* x (/ 1d0 x))) + +(define-test rounding-mode.nearest (:tag :issues) - (lisp::with-float-traps-enabled (:underflow) - ;; A denormal - (assert-error 'reader-error - (read-from-string "1e-40")) - (assert-error 'reader-error - (read-from-string (format nil "~A" least-positive-single-float))) - ;; The same for double-floats - (assert-error 'reader-error - (read-from-string "1d-308")) - (assert-error 'reader-error - (read-from-string (format nil "~A" least-positive-double-float))))) - -(define-test reader.float-underflow + (ext:with-float-rounding-mode (:nearest) + (assert-equal 1d0 (rounding-test 3d0)))) + +(define-test rounding-mode.zero.1 (:tag :issues) - (lisp::with-float-traps-enabled (:underflow) - ;; The expected string comes from make-float-aux. - (let ((expected "Floating point underflow when reading ~S: ~S")) - (flet ((test-reader-underflow (string) - ;; Test that the we got a reader-error when a number - ;; would underflow and that the message says we got an - ;; underflow. - (let ((condition (nth-value 1 (ignore-errors (read-from-string string))))) - (assert-equal 'reader-error (type-of condition)) - (assert-equal expected (lisp::reader-error-format-control condition))))) - ;; Underflow single-floats - (test-reader-underflow "1e-40") - (test-reader-underflow (format nil "~A" least-positive-single-float)) - ;; Underflow double-floats - (test-reader-underflow "1d-308") - (test-reader-underflow (format nil "~A" least-positive-double-float)))))) + (ext:with-float-rounding-mode (:zero) + (assert-equal 0.9999999999999999d0 + (rounding-test 3d0)))) + +(define-test rounding-mode.zero.2 + (:tag :issues) + (ext:with-float-rounding-mode (:zero) + (assert-equal 0.9999999999999999d0 + (rounding-test -3d0)))) + +(define-test rounding-mode.positive-infinity + (:tag :issues) + (ext:with-float-rounding-mode (:positive-infinity) + (assert-equal 1.0000000000000002d0 + (rounding-test 3d0)))) + +(define-test rounding-mode.negative-infinity + (:tag :issues) + (ext:with-float-rounding-mode (:negative-infinity) + (assert-equal 0.9999999999999999d0 + (rounding-test 3d0)))) + ===================================== tests/pprint.lisp ===================================== @@ -121,3 +121,17 @@ (:no-error () (format nil "Nothing bad happened."))) s)))) + +(define-test pprint.assemble + (:tag :issues) + (assert-equal + " +(NEW-ASSEM:ASSEMBLE (C:*CODE-SEGMENT* 'X86::XOROSHIRO-UPDATE) + X86::XOROSHIRO-UPDATE + (PUSH (CONS 'X86::XOROSHIRO-UPDATE X86::XOROSHIRO-UPDATE) + C::*ASSEMBLER-ROUTINES*))" + (with-output-to-string (s) + (pprint '(new-assem:assemble (c::*code-segment* 'vm::xoroshiro-update) + vm::xoroshiro-update + (push (cons 'vm::xoroshiro-update vm::xoroshiro-update) c::*assembler-routines*)) + s)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/875638b6a1a7f7525e8204… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/875638b6a1a7f7525e8204… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #296: Fix disassembly of MOVD instruction
by Raymond Toy (＠rtoy) 10 Apr '24

10 Apr '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 0cbb2264 by Raymond Toy at 2024-04-10T03:10:16+00:00 Fix #296: Fix disassembly of MOVD instruction - - - - - df78595e by Raymond Toy at 2024-04-10T03:10:20+00:00 Merge branch 'issue-296-fix-movd-disassembly' into 'master' Fix #296: Fix disassembly of MOVD instruction Closes #296 and #300 See merge request cmucl/cmucl!207 - - - - - 1 changed file: - src/compiler/x86/insts.lisp Changes: ===================================== src/compiler/x86/insts.lisp ===================================== @@ -509,6 +509,14 @@ (print-byte-reg value stream dstate) (print-mem-access value stream t dstate))) +(defun print-word-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-word-reg value stream dstate) + (print-mem-access value stream nil dstate))) + (defun print-label (value stream dstate) (declare (ignore dstate)) (princ (if (and (numberp value) (minusp value)) @@ -716,7 +724,11 @@ (disassem:define-argument-type byte-reg/mem :prefilter #'prefilter-reg/mem :printer #'print-byte-reg/mem) - +(disassem:define-argument-type word-reg/mem + ;; Like reg/mem but if the reg/mem field is a register, it's a word + ;; register. + :prefilter #'prefilter-reg/mem + :printer #'print-word-reg/mem) ;;; ;;; added by jrd ;;; @@ -3478,7 +3490,7 @@ ;;; We do not support the MMX version of this instruction. (define-instruction movd (segment dst src) (:printer ext-xmm-reg/mem ((prefix #x66) (op #x6e))) - (:printer ext-xmm-reg/mem ((prefix #x66) (op #x7e)) + (:printer ext-xmm-reg/mem ((prefix #x66) (op #x7e) (reg/mem nil :type 'word-reg/mem)) '(:name :tab reg/mem ", " reg)) (:emitter (cond ((xmm-register-p dst) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d9983ea57162a21367d9ff… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d9983ea57162a21367d9ff… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Add comment about using -V and use a better version
by Raymond Toy (＠rtoy) 09 Apr '24

09 Apr '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d9983ea5 by Raymond Toy at 2024-04-09T11:59:46-07:00 Add comment about using -V and use a better version Explain why we use `-V` for `bin/make-dist.sh`. And instead of using "ci-build" as the version, use `git describe --dirty` as the version. This lets us know better what version was actually used for the build. - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -48,7 +48,9 @@ linux:build: # Regular build using the cross-compiled result or snapshot - bin/build.sh $bootstrap -R -C "x86_linux_clang" -o snapshot/bin/lisp # - bin/build.sh $bootstrap -R -C "x86_linux" -o snapshot/bin/lisp - - bin/make-dist.sh -V ci-build -I dist linux-4 + # Use -V to specify the version in case some tag makes git + # describe return something that make-dist.sh doesn't like. + - bin/make-dist.sh -V `git describe --dirty` -I dist linux-4 linux:test: stage: test @@ -131,7 +133,9 @@ osx:build: # Regular build using the cross-compiled result or snapshot. # Need /opt/local/bin to get msgmerge and msgfmt programs. - PATH=/opt/local/bin:$PATH bin/build.sh $bootstrap -R -C "" -o snapshot/bin/lisp - - bin/make-dist.sh -V ci-build -I dist darwin-4 + # Use -V to specify the version in case some tag makes git + # describe return something that make-dist.sh doesn't like. + - bin/make-dist.sh -V `git describe --dirty` -I dist darwin-4 osx:test: stage: test View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d9983ea57162a21367d9ffa… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d9983ea57162a21367d9ffa… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0