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/875638b6a1a7f7525e82045...