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
-
bf417b47
by Raymond Toy at 2024-04-02T08:33:30-07:00
-
e32034e0
by Raymond Toy at 2024-04-02T08:33:52-07:00
-
3cdf6b8f
by Raymond Toy at 2024-04-06T08:33:14-07:00
-
62631e15
by Raymond Toy at 2024-04-07T22:52:52+00:00
-
7bec290f
by Raymond Toy at 2024-04-07T22:53:01+00:00
-
bb1bc462
by Raymond Toy at 2024-04-07T22:53:45+00:00
-
94a2c674
by Raymond Toy at 2024-04-07T22:53:51+00:00
-
6ba75434
by Carl Shapiro at 2024-04-07T23:19:27+00:00
-
b8923ba5
by Raymond Toy at 2024-04-08T00:00:36+00:00
-
e77ded50
by Raymond Toy at 2024-04-08T00:00:39+00:00
-
0e716eab
by Raymond Toy at 2024-04-07T17:02:55-07:00
-
6181fd24
by Raymond Toy at 2024-04-08T05:52:20-07:00
-
659c41bc
by Raymond Toy at 2024-04-08T05:58:05-07:00
-
1cb2cb14
by Raymond Toy at 2024-04-08T13:00:08+00:00
-
574eef63
by Raymond Toy at 2024-04-08T13:00:12+00:00
-
07a1669b
by Raymond Toy at 2024-04-08T06:05:43-07:00
-
a46a530e
by Raymond Toy at 2024-04-08T14:00:18+00:00
-
aa42e51a
by Raymond Toy at 2024-04-09T16:19:13+00:00
-
149c45e1
by Raymond Toy at 2024-04-09T16:19:41+00:00
-
d9983ea5
by Raymond Toy at 2024-04-09T11:59:46-07:00
-
9f4e552c
by Raymond Toy at 2024-04-09T21:48:00-07:00
-
9a811166
by Raymond Toy at 2024-04-09T21:50:03-07:00
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:
1 | 1 | variables:
|
2 | 2 | download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2023/08"
|
3 | - version: "2023-08-x86"
|
|
4 | - bootstrap: "-B boot-2023-08"
|
|
3 | + version: "xoroshiro-assembly-x86"
|
|
4 | + bootstrap: ""
|
|
5 | 5 | |
6 | 6 | |
7 | 7 | stages:
|
... | ... | @@ -48,7 +48,9 @@ linux:build: |
48 | 48 | # Regular build using the cross-compiled result or snapshot
|
49 | 49 | - bin/build.sh $bootstrap -R -C "x86_linux_clang" -o snapshot/bin/lisp
|
50 | 50 | # - bin/build.sh $bootstrap -R -C "x86_linux" -o snapshot/bin/lisp
|
51 | - - bin/make-dist.sh -I dist linux-4
|
|
51 | + # Use -V to specify the version in case some tag makes git
|
|
52 | + # describe return something that make-dist.sh doesn't like.
|
|
53 | + - bin/make-dist.sh -V `git describe --dirty` -I dist linux-4
|
|
52 | 54 | |
53 | 55 | linux:test:
|
54 | 56 | stage: test
|
... | ... | @@ -131,7 +133,9 @@ osx:build: |
131 | 133 | # Regular build using the cross-compiled result or snapshot.
|
132 | 134 | # Need /opt/local/bin to get msgmerge and msgfmt programs.
|
133 | 135 | - PATH=/opt/local/bin:$PATH bin/build.sh $bootstrap -R -C "" -o snapshot/bin/lisp
|
134 | - - bin/make-dist.sh -I dist darwin-4
|
|
136 | + # Use -V to specify the version in case some tag makes git
|
|
137 | + # describe return something that make-dist.sh doesn't like.
|
|
138 | + - bin/make-dist.sh -V `git describe --dirty` -I dist darwin-4
|
|
135 | 139 | |
136 | 140 | osx:test:
|
137 | 141 | stage: test
|
... | ... | @@ -98,6 +98,8 @@ def_arch_os |
98 | 98 | # ("snapshot-yyyy-mm") or a release number..
|
99 | 99 | GIT_HASH="`(cd src; git describe --dirty 2>/dev/null)`"
|
100 | 100 | |
101 | +echo GIT_HASH = ${GIT_HASH}
|
|
102 | + |
|
101 | 103 | if expr "X${GIT_HASH}" : 'Xsnapshot-[0-9][0-9][0-9][0-9]-[01][0-9]' > /dev/null; then
|
102 | 104 | DEFAULT_VERSION=`expr "${GIT_HASH}" : "snapshot-\(.*\)"`
|
103 | 105 | fi
|
... | ... | @@ -209,7 +209,61 @@ |
209 | 209 | ,(reg-spec-temp res))))
|
210 | 210 | results))))))
|
211 | 211 | |
212 | +;;; Define-Assembly-Routine -- Public
|
|
213 | +;;;
|
|
214 | +;;; Parse the code to produce an assembly routine and create a VOP
|
|
215 | +;;; that calls the assembly routine.
|
|
212 | 216 | (defmacro define-assembly-routine (name&options vars &rest code)
|
217 | + "Define-Assembly-Routine (Name&Options Vars Code*)
|
|
218 | + Define a Lisp assembly routine, and a VOP to that calls the assembly
|
|
219 | + routine, if enabled. (A VOP is not created if the reader
|
|
220 | + conditional #+assembler precedes the definition of the assembly
|
|
221 | + routine.)
|
|
222 | + |
|
223 | + Name&Options
|
|
224 | + A list giving the name of the assembly routine and options
|
|
225 | + describing the assembly routine options and VOP options. The
|
|
226 | + format is (Name ({Key Value})*) where Name is the name of the
|
|
227 | + assembly routine. Options is a list of options:
|
|
228 | + |
|
229 | + Options
|
|
230 | + |
|
231 | + :Cost Cost
|
|
232 | + The cost of the VOP. This is used in the generated VOP.
|
|
233 | + |
|
234 | + :Policy {:Small | :Fast | :Safe | :Fast-Safe}
|
|
235 | + The policy for the VOP.
|
|
236 | + |
|
237 | + :Translate Name
|
|
238 | + The translation for the VOP.
|
|
239 | + |
|
240 | + :Arg-Types arg-types
|
|
241 | + :Result-Types result-types
|
|
242 | + The template restrictions for the arguments of the VOP and the
|
|
243 | + results of the VOP.
|
|
244 | + |
|
245 | + :Return-Style {:Raw :Full-Call :None}
|
|
246 | +
|
|
247 | + Vars is a list of the arguments and returned results and
|
|
248 | + temporaries used by the assembly routine.
|
|
249 | + |
|
250 | + :Arg Arg-Name (SC*) SC-Offset
|
|
251 | + Input argument for the assembly routine with the name
|
|
252 | + Arg-Name. The argument must be one of the SC types. The register
|
|
253 | + assigned to this argument is given by SC-Offset which must be
|
|
254 | + the offset for the register holding this argument.
|
|
255 | + |
|
256 | + :Res Res-Name SC SC-Offset
|
|
257 | + Result of the assembly routine with the name Res-Name. The
|
|
258 | + result must be a register of the specified storage class SC. The
|
|
259 | + Sc-offset is the register used for the result.
|
|
260 | + |
|
261 | + :Temp Temp-Name SC SC-Offset
|
|
262 | + Like :Res, except this names a temporary register that the
|
|
263 | + assembly routine can use.
|
|
264 | + |
|
265 | + Code
|
|
266 | + The code for the assembly routine."
|
|
213 | 267 | (multiple-value-bind (name options)
|
214 | 268 | (if (atom name&options)
|
215 | 269 | (values name&options nil)
|
... | ... | @@ -411,3 +411,121 @@ |
411 | 411 | (inst pop y)
|
412 | 412 | (inst pop k)
|
413 | 413 | (inst ret))
|
414 | + |
|
415 | +;;; Support for the xoroshiro128** generator. See
|
|
416 | +;;; https://prng.di.unimi.it/xoroshiro128starstar.c for the official
|
|
417 | +;;; code.
|
|
418 | +;;;
|
|
419 | +;;; This is what we're implementing, where s[] is our state vector.
|
|
420 | +;;;
|
|
421 | +;;; static uint64_t s[2];
|
|
422 | +;;; static inline uint64_t rotl(const uint64_t x, int k) {
|
|
423 | +;;; return (x << k) | (x >> (64 - k));
|
|
424 | +;;; }
|
|
425 | +;;;
|
|
426 | +;;; uint64_t next(void) {
|
|
427 | +;;; const uint64_t s0 = s[0];
|
|
428 | +;;; uint64_t s1 = s[1];
|
|
429 | +;;; const uint64_t result = rotl(s0 * 5, 7) * 9;
|
|
430 | +;;;
|
|
431 | +;;; s1 ^= s0;
|
|
432 | +;;; s[0] = rotl(s0, 24) ^ s1 ^ (s1 << 16); // a, b
|
|
433 | +;;; s[1] = rotl(s1, 37); // c
|
|
434 | +;;;
|
|
435 | +;;; return result;
|
|
436 | +;;; }
|
|
437 | +;;;
|
|
438 | +;;; A VOP is also generated to call this assembly routine. This
|
|
439 | +;;; routine computes a new 64-bit random number and also updates the
|
|
440 | +;;; state, which is (simple-array (double-float) (2)).
|
|
441 | +#+random-xoroshiro
|
|
442 | +(define-assembly-routine
|
|
443 | + (xoroshiro-update
|
|
444 | + (:translate kernel::random-xoroshiro-update)
|
|
445 | + (:return-style :raw)
|
|
446 | + (:cost 30)
|
|
447 | + (:policy :fast-safe)
|
|
448 | + (:arg-types simple-array-double-float)
|
|
449 | + (:result-types unsigned-num unsigned-num))
|
|
450 | + ((:arg state descriptor-reg edx-offset)
|
|
451 | + (:res r1 unsigned-reg ecx-offset)
|
|
452 | + (:res r0 unsigned-reg ebx-offset)
|
|
453 | + (:temp s0 double-reg xmm0-offset)
|
|
454 | + (:temp s1 double-reg xmm1-offset)
|
|
455 | + (:temp t0 double-reg xmm2-offset)
|
|
456 | + (:temp t1 double-reg xmm3-offset))
|
|
457 | + |
|
458 | + ;; s0 = state[0]
|
|
459 | + (inst movsd s0 (make-ea :dword :base state
|
|
460 | + :disp (- (+ (* vm:vector-data-offset
|
|
461 | + vm:word-bytes)
|
|
462 | + (* 8 0))
|
|
463 | + vm:other-pointer-type)))
|
|
464 | + ;; t0 = s0 * 5 = s0 << 2 + s0
|
|
465 | + (inst movapd t0 s0) ; t0 = s0
|
|
466 | + (inst psllq t0 2) ; t0 = t0 << 2 = 4*t0
|
|
467 | + (inst paddq t0 s0) ; t0 = t0 + s0 = 5*t0
|
|
468 | + |
|
469 | + ;; t0 = rotl(t0, 7) = t0 << 7 | t0 >> (64-7)
|
|
470 | + ;; = rotl(s0*5, 7)
|
|
471 | + (inst movapd t1 t0) ; t1 = t0
|
|
472 | + (inst psllq t1 7) ; t1 = t0 << 7
|
|
473 | + (inst psrlq t0 (- 64 7)) ; t0 = t0 >> 57
|
|
474 | + (inst orpd t0 t1) ; t0 = t0 << 7 | t0 >> 57 = rotl(t0, 7)
|
|
475 | + |
|
476 | + ;; t0 = t0 * 9 = t0 << 3 + t0
|
|
477 | + ;; = rotl(s0*5, 7) * 9
|
|
478 | + (inst movapd t1 t0) ; t1 = t0
|
|
479 | + (inst psllq t1 3) ; t1 = t0 << 3
|
|
480 | + (inst paddq t0 t1) ; t0 = t0 << 3 + t0 = 9*t0
|
|
481 | + |
|
482 | + ;; Save the result as two 32-bit results. r1 is the high 32 bits
|
|
483 | + ;; and r0 is the low 32.
|
|
484 | + (inst movd r0 t0)
|
|
485 | + (inst psrlq t0 32)
|
|
486 | + (inst movd r1 t0)
|
|
487 | + |
|
488 | + ;; s1 = state[1]
|
|
489 | + (inst movsd s1 (make-ea :dword :base state
|
|
490 | + :disp (- (+ (* vm:vector-data-offset
|
|
491 | + vm:word-bytes)
|
|
492 | + (* 8 1))
|
|
493 | + vm:other-pointer-type)))
|
|
494 | + (inst xorpd s1 s0) ; s1 = s1 ^ s0
|
|
495 | + |
|
496 | + ;; s0 can now be reused as a temp.
|
|
497 | + ;; s0 = rotl(s0, 24)
|
|
498 | + (inst movapd t0 s0) ; t0 = s0
|
|
499 | + (inst psllq t0 24) ; t0 = s0 << 24
|
|
500 | + (inst psrlq s0 (- 64 24)) ; s0 = s0 >> 40
|
|
501 | + (inst orpd s0 t0) ; s0 = s0 | t0 = rotl(s0, 24)
|
|
502 | + |
|
503 | + ;; s0 = s0 ^ s1 = rotl(s0, 24) ^ s1
|
|
504 | + (inst xorpd s0 s1)
|
|
505 | + |
|
506 | + ;; s0 = s0 ^ (s1 << 16)
|
|
507 | + (inst movapd t0 s1) ; t0 = s1
|
|
508 | + (inst psllq t0 16) ; t0 = s1 << 16
|
|
509 | + (inst xorpd s0 t0) ; s0 = rotl(s0, 24) ^ s1 ^ (s1 << 16)
|
|
510 | + |
|
511 | + ;; Save s0 to state[0]
|
|
512 | + (inst movsd (make-ea :dword :base state
|
|
513 | + :disp (- (+ (* vm:vector-data-offset
|
|
514 | + vm:word-bytes)
|
|
515 | + (* 8 0))
|
|
516 | + vm:other-pointer-type))
|
|
517 | + s0)
|
|
518 | + |
|
519 | + ;; s1 = rotl(s1, 37)
|
|
520 | + (inst movapd t0 s1) ; t0 = s1
|
|
521 | + (inst psllq t0 37) ; t0 = s1 << 37
|
|
522 | + (inst psrlq s1 (- 64 37)) ; s1 = s1 >> 27
|
|
523 | + (inst orpd s1 t0) ; s1 = t0 | s1 = rotl(s1, 37)
|
|
524 | + |
|
525 | + ;; Save s1 to state[1]
|
|
526 | + (inst movsd (make-ea :dword :base state
|
|
527 | + :disp (- (+ (* vm:vector-data-offset
|
|
528 | + vm:word-bytes)
|
|
529 | + (* 8 1))
|
|
530 | + vm:other-pointer-type))
|
|
531 | + s1)) |
... | ... | @@ -39,7 +39,7 @@ |
39 | 39 | (def-vm-support-routine generate-return-sequence (style)
|
40 | 40 | (ecase style
|
41 | 41 | (:raw
|
42 | - `(inst ret))
|
|
42 | + `((inst ret)))
|
|
43 | 43 | (:full-call
|
44 | 44 | `(
|
45 | 45 | (inst pop eax-tn)
|
... | ... | @@ -2,3 +2,46 @@ |
2 | 2 | ;; *SOFTWARE-VERSION* from the LISP package to the SYSTEM package.
|
3 | 3 | (ext:without-package-locks
|
4 | 4 | (unintern 'lisp::*software-version* "LISP"))
|
5 | + |
|
6 | +#+(or random-mt19937 random-xoroshiro)
|
|
7 | +(in-package "C")
|
|
8 | +#+(or random-mt19937 random-xoroshiro)
|
|
9 | +(deftransform random ((num &optional state)
|
|
10 | + ((integer 1 #.(expt 2 32)) &optional *))
|
|
11 | + _N"use inline (unsigned-byte 32) operations"
|
|
12 | + (let* ((num-type (continuation-type num))
|
|
13 | + (num-high (cond ((numeric-type-p num-type)
|
|
14 | + (numeric-type-high num-type))
|
|
15 | + ((union-type-p num-type)
|
|
16 | + ;; Find the maximum of the union type. We
|
|
17 | + ;; know this works because if we're in this
|
|
18 | + ;; routine, NUM must be a subtype of
|
|
19 | + ;; (INTEGER 1 2^32), so each member of the
|
|
20 | + ;; union must be a subtype too.
|
|
21 | + (reduce #'max (union-type-types num-type)
|
|
22 | + :key #'numeric-type-high))
|
|
23 | + (t
|
|
24 | + (give-up)))))
|
|
25 | + ;; Rather than doing (rem (random-chunk) num-high), we do,
|
|
26 | + ;; essentially, (rem (* num-high (random-chunk)) #x100000000). I
|
|
27 | + ;; (rtoy) believe this approach doesn't have the bias issue with
|
|
28 | + ;; doing rem. This method works by treating (random-chunk) as if
|
|
29 | + ;; it were a 32-bit fraction between 0 and 1, exclusive. Multiply
|
|
30 | + ;; this by num-high to get a random number between 0 and num-high,
|
|
31 | + ;; This should have no bias.
|
|
32 | + (cond ((constant-continuation-p num)
|
|
33 | + (if (= num-high (expt 2 32))
|
|
34 | + '(random-chunk (or state *random-state*))
|
|
35 | + '(values (bignum::%multiply
|
|
36 | + (random-chunk (or state *random-state*))
|
|
37 | + num))))
|
|
38 | + ((< num-high (expt 2 32))
|
|
39 | + '(values (bignum::%multiply (random-chunk (or state *random-state*))
|
|
40 | + num)))
|
|
41 | + ((= num-high (expt 2 32))
|
|
42 | + '(if (= num (expt 2 32))
|
|
43 | + (random-chunk (or state *random-state*))
|
|
44 | + (values (bignum::%multiply (random-chunk (or state *random-state*))
|
|
45 | + num))))
|
|
46 | + (t
|
|
47 | + (error (intl:gettext "Shouldn't happen")))))) |
... | ... | @@ -1591,7 +1591,8 @@ |
1591 | 1591 | "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
|
1592 | 1592 | "FLOAT-SIGNALING-NAN-P"
|
1593 | 1593 | "WITH-FLOAT-TRAPS-MASKED"
|
1594 | - "WITH-FLOAT-TRAPS-ENABLED")
|
|
1594 | + "WITH-FLOAT-TRAPS-ENABLED"
|
|
1595 | + "WITH-FLOAT-ROUNDING-MODE")
|
|
1595 | 1596 | ;; More float extensions
|
1596 | 1597 | #+double-double
|
1597 | 1598 | (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT"
|
... | ... | @@ -27,7 +27,8 @@ |
27 | 27 | decode-floating-point-modes
|
28 | 28 | encode-floating-point-modes
|
29 | 29 | with-float-traps-masked
|
30 | - with-float-traps-enabled))
|
|
30 | + with-float-traps-enabled
|
|
31 | + with-float-rounding-mode))
|
|
31 | 32 | (in-package "VM")
|
32 | 33 | |
33 | 34 | (eval-when (compile load eval)
|
... | ... | @@ -495,3 +496,34 @@ |
495 | 496 | accrued exceptions are cleared at the start of the body to support
|
496 | 497 | their testing within, and restored on exit."))
|
497 | 498 | |
499 | +(defmacro with-float-rounding-mode ((rounding-mode) &body body)
|
|
500 | + _N"Execute BODY with the floating-point rounding mode set to
|
|
501 | + ROUNDING-MODE. ROUNDING-MODE must be a one:
|
|
502 | + |
|
503 | + :NEAREST
|
|
504 | + the default mode of round to nearest even.
|
|
505 | + :ZERO
|
|
506 | + round numbers down towards zero. Positive numbers round down
|
|
507 | + and negative numbers round up.
|
|
508 | + :POSITIVE-INFINITY
|
|
509 | + round numbers up towards positive infinity.
|
|
510 | + :NEGATIVE-INFINITY
|
|
511 | + round numbers down towards negative infinity.
|
|
512 | + |
|
513 | + These are the same as the possible values for the rounding mode in
|
|
514 | + SET-FLOATING-POINT-MODES.
|
|
515 | + |
|
516 | + Only the rounding mode is restored on exit; other floating-point
|
|
517 | + modes are not modified."
|
|
518 | + (let ((old-mode (gensym "OLD-MODE-"))
|
|
519 | + (new-mode (gensym "NEW-MODE-")))
|
|
520 | + `(let ((,old-mode (ldb float-rounding-mode (floating-point-modes)))
|
|
521 | + (,new-mode (cdr (assoc ,rounding-mode rounding-mode-alist))))
|
|
522 | + (unwind-protect
|
|
523 | + (progn
|
|
524 | + (setf (floating-point-modes)
|
|
525 | + (dpb ,new-mode float-rounding-mode (floating-point-modes)))
|
|
526 | + ,@body)
|
|
527 | + ;; Restore just the rounding mode to the original value.
|
|
528 | + (setf (floating-point-modes)
|
|
529 | + (dpb ,old-mode float-rounding-mode (floating-point-modes))))))) |
... | ... | @@ -2088,6 +2088,7 @@ When annotations are present, invoke them at the right positions." |
2088 | 2088 | (c:define-vop pprint-define-vop)
|
2089 | 2089 | (c:sc-case pprint-sc-case)
|
2090 | 2090 | (c:define-assembly-routine pprint-define-assembly)
|
2091 | + (new-assem:assemble pprint-multiple-value-bind)
|
|
2091 | 2092 | (c:deftransform pprint-defun)
|
2092 | 2093 | (c:defoptimizer pprint-defun)
|
2093 | 2094 | (ext:with-float-traps-masked pprint-with-like)
|
... | ... | @@ -238,7 +238,7 @@ |
238 | 238 | being the first value."
|
239 | 239 | (declare (type (simple-array double-float (2)) state)
|
240 | 240 | (optimize (speed 3) (safety 0)))
|
241 | - (vm::xoroshiro-next state))
|
|
241 | + (kernel::random-xoroshiro-update state))
|
|
242 | 242 | |
243 | 243 | #-x86
|
244 | 244 | (defun xoroshiro-gen (state)
|
... | ... | @@ -490,11 +490,8 @@ |
490 | 490 | (declare (inline %random-single-float %random-double-float))
|
491 | 491 | (cond
|
492 | 492 | ((typep arg '(integer 1 #x100000000))
|
493 | - ;; Do the same thing as the deftransform would do.
|
|
494 | - (if (= arg (expt 2 32))
|
|
495 | - (random-chunk state)
|
|
496 | - (values (bignum::%multiply (random-chunk state)
|
|
497 | - arg))))
|
|
493 | + ;; Let the compiler deftransform take care of this case.
|
|
494 | + (random arg state))
|
|
498 | 495 | ((and (typep arg 'single-float) (> arg 0.0F0))
|
499 | 496 | (%random-single-float arg state))
|
500 | 497 | ((and (typep arg 'double-float) (> arg 0.0D0))
|
... | ... | @@ -1869,15 +1869,16 @@ the end of the stream." |
1869 | 1869 | |
1870 | 1870 | ;; Otherwise the number might fit, so we carefully compute the result.
|
1871 | 1871 | (handler-case
|
1872 | - (let* ((ratio (/ (* (expt 10 exponent) number)
|
|
1873 | - divisor))
|
|
1874 | - (result (coerce ratio float-format)))
|
|
1875 | - (when (and (zerop result) (not (zerop number)))
|
|
1876 | - ;; The number we've read is so small that it gets
|
|
1877 | - ;; converted to 0.0, but is not actually zero. Signal an
|
|
1878 | - ;; error. See CLHS 2.3.1.1.
|
|
1879 | - (error _"Underflow"))
|
|
1880 | - result)
|
|
1872 | + (with-float-traps-masked (:underflow)
|
|
1873 | + (let* ((ratio (/ (* (expt 10 exponent) number)
|
|
1874 | + divisor))
|
|
1875 | + (result (coerce ratio float-format)))
|
|
1876 | + (when (and (zerop result) (not (zerop number)))
|
|
1877 | + ;; The number we've read is so small that it gets
|
|
1878 | + ;; converted to 0.0, but is not actually zero. Signal an
|
|
1879 | + ;; error. See CLHS 2.3.1.1.
|
|
1880 | + (error 'floating-point-underflow))
|
|
1881 | + result))
|
|
1881 | 1882 | (floating-point-underflow ()
|
1882 | 1883 | ;; Resignal a reader error, but allow the user to continue with
|
1883 | 1884 | ;; 0.
|
... | ... | @@ -1695,118 +1695,9 @@ |
1695 | 1695 | |
1696 | 1696 | (in-package "VM")
|
1697 | 1697 | |
1698 | +;; The update routine is a Lisp assembly routine with a corresponding
|
|
1699 | +;; VOP. This lets the compiler know about the VOP so we can use it.
|
|
1698 | 1700 | #+random-xoroshiro
|
1699 | -(progn
|
|
1700 | -(defknown xoroshiro-next ((simple-array double-float (2)))
|
|
1701 | +(defknown kernel::random-xoroshiro-update ((simple-array double-float (2)))
|
|
1701 | 1702 | (values (unsigned-byte 32) (unsigned-byte 32))
|
1702 | 1703 | (movable)) |
1703 | - |
|
1704 | -(define-vop (xoroshiro-next)
|
|
1705 | - (:policy :fast-safe)
|
|
1706 | - (:translate xoroshiro-next)
|
|
1707 | - (:args (state :scs (descriptor-reg) :to (:result 3)))
|
|
1708 | - (:arg-types simple-array-double-float)
|
|
1709 | - (:results (r1 :scs (unsigned-reg))
|
|
1710 | - (r0 :scs (unsigned-reg)))
|
|
1711 | - (:result-types unsigned-num unsigned-num)
|
|
1712 | - (:temporary (:sc double-reg) s0)
|
|
1713 | - (:temporary (:sc double-reg) s1)
|
|
1714 | - (:temporary (:sc double-reg) t0)
|
|
1715 | - (:temporary (:sc double-reg) t1)
|
|
1716 | - (:generator 10
|
|
1717 | - ;; See https://prng.di.unimi.it/xoroshiro128starstar.c for the official code.
|
|
1718 | - ;;
|
|
1719 | - ;; This is what we're implementing, where s[] is our state vector.
|
|
1720 | - ;;
|
|
1721 | - ;; static uint64_t s[2];
|
|
1722 | - ;; static inline uint64_t rotl(const uint64_t x, int k) {
|
|
1723 | - ;; return (x << k) | (x >> (64 - k));
|
|
1724 | - ;; }
|
|
1725 | - ;;
|
|
1726 | - ;; uint64_t next(void) {
|
|
1727 | - ;; const uint64_t s0 = s[0];
|
|
1728 | - ;; uint64_t s1 = s[1];
|
|
1729 | - ;; const uint64_t result = rotl(s0 * 5, 7) * 9;
|
|
1730 | - ;;
|
|
1731 | - ;; s1 ^= s0;
|
|
1732 | - ;; s[0] = rotl(s0, 24) ^ s1 ^ (s1 << 16); // a, b
|
|
1733 | - ;; s[1] = rotl(s1, 37); // c
|
|
1734 | - ;;
|
|
1735 | - ;; return result;
|
|
1736 | - ;; }
|
|
1737 | - |
|
1738 | - ;; s0 = state[0]
|
|
1739 | - (inst movsd s0 (make-ea :dword :base state
|
|
1740 | - :disp (- (+ (* vm:vector-data-offset
|
|
1741 | - vm:word-bytes)
|
|
1742 | - (* 8 0))
|
|
1743 | - vm:other-pointer-type)))
|
|
1744 | - ;; t0 = s0 * 5 = s0 << 2 + s0
|
|
1745 | - (inst movapd t0 s0) ; t0 = s0
|
|
1746 | - (inst psllq t0 2) ; t0 = t0 << 2 = 4*t0
|
|
1747 | - (inst paddq t0 s0) ; t0 = t0 + s0 = 5*t0
|
|
1748 | - |
|
1749 | - ;; t0 = rotl(t0, 7) = t0 << 7 | t0 >> (64-7)
|
|
1750 | - ;; = rotl(s0*5, 7)
|
|
1751 | - (inst movapd t1 t0) ; t1 = t0
|
|
1752 | - (inst psllq t1 7) ; t1 = t0 << 7
|
|
1753 | - (inst psrlq t0 (- 64 7)) ; t0 = t0 >> 57
|
|
1754 | - (inst orpd t0 t1) ; t0 = t0 << 7 | t0 >> 57 = rotl(t0, 7)
|
|
1755 | - |
|
1756 | - ;; t0 = t0 * 9 = t0 << 3 + t0
|
|
1757 | - ;; = rotl(s0*5, 7) * 9
|
|
1758 | - (inst movapd t1 t0) ; t1 = t0
|
|
1759 | - (inst psllq t1 3) ; t1 = t0 << 3
|
|
1760 | - (inst paddq t0 t1) ; t0 = t0 << 3 + t0 = 9*t0
|
|
1761 | - |
|
1762 | - ;; Save the result as two 32-bit results. r1 is the high 32 bits
|
|
1763 | - ;; and r0 is the low 32.
|
|
1764 | - (inst movd r0 t0)
|
|
1765 | - (inst psrlq t0 32)
|
|
1766 | - (inst movd r1 t0)
|
|
1767 | - |
|
1768 | - ;; s1 = state[1]
|
|
1769 | - (inst movsd s1 (make-ea :dword :base state
|
|
1770 | - :disp (- (+ (* vm:vector-data-offset
|
|
1771 | - vm:word-bytes)
|
|
1772 | - (* 8 1))
|
|
1773 | - vm:other-pointer-type)))
|
|
1774 | - (inst xorpd s1 s0) ; s1 = s1 ^ s0
|
|
1775 | - |
|
1776 | - ;; s0 can now be reused as a temp.
|
|
1777 | - ;; s0 = rotl(s0, 24)
|
|
1778 | - (inst movapd t0 s0) ; t0 = s0
|
|
1779 | - (inst psllq t0 24) ; t0 = s0 << 24
|
|
1780 | - (inst psrlq s0 (- 64 24)) ; s0 = s0 >> 40
|
|
1781 | - (inst orpd s0 t0) ; s0 = s0 | t0 = rotl(s0, 24)
|
|
1782 | - |
|
1783 | - ;; s0 = s0 ^ s1 = rotl(s0, 24) ^ s1
|
|
1784 | - (inst xorpd s0 s1)
|
|
1785 | - |
|
1786 | - ;; s0 = s0 ^ (s1 << 16)
|
|
1787 | - (inst movapd t0 s1) ; t0 = s1
|
|
1788 | - (inst psllq t0 16) ; t0 = s1 << 16
|
|
1789 | - (inst xorpd s0 t0) ; s0 = rotl(s0, 24) ^ s1 ^ (s1 << 16)
|
|
1790 | - |
|
1791 | - ;; Save s0 to state[0]
|
|
1792 | - (inst movsd (make-ea :dword :base state
|
|
1793 | - :disp (- (+ (* vm:vector-data-offset
|
|
1794 | - vm:word-bytes)
|
|
1795 | - (* 8 0))
|
|
1796 | - vm:other-pointer-type))
|
|
1797 | - s0)
|
|
1798 | - |
|
1799 | - ;; s1 = rotl(s1, 37)
|
|
1800 | - (inst movapd t0 s1) ; t0 = s1
|
|
1801 | - (inst psllq t0 37) ; t0 = s1 << 37
|
|
1802 | - (inst psrlq s1 (- 64 37)) ; s1 = s1 >> 27
|
|
1803 | - (inst orpd s1 t0) ; s1 = t0 | s1 = rotl(s1, 37)
|
|
1804 | - |
|
1805 | - ;; Save s1 to state[1]
|
|
1806 | - (inst movsd (make-ea :dword :base state
|
|
1807 | - :disp (- (+ (* vm:vector-data-offset
|
|
1808 | - vm:word-bytes)
|
|
1809 | - (* 8 1))
|
|
1810 | - vm:other-pointer-type))
|
|
1811 | - s1)))
|
|
1812 | -) |
... | ... | @@ -51,8 +51,8 @@ public domain. |
51 | 51 | * ~~#261~~ Remove `get-system-info` from "bsd-os.lisp"
|
52 | 52 | * ~~#268~~ Can't clone ansi-test repo on Mac OS CI box
|
53 | 53 | * ~~#265~~ CI for mac os is broken
|
54 | - * ~~#269~~ Add function to get user's home directory
|
|
55 | 54 | * ~~#266~~ Support "~user" in namestrings
|
55 | + * ~~#269~~ Add function to get user's home directory
|
|
56 | 56 | * ~~#271~~ Update ASDF to 3.3.7
|
57 | 57 | * ~~#272~~ Move scavenge code for static vectors to its own function
|
58 | 58 | * ~~#274~~ 1d99999999 hangs
|
... | ... | @@ -65,6 +65,7 @@ public domain. |
65 | 65 | * ~~#288~~ Re-enable `deftransform` for random integers.
|
66 | 66 | * ~~#290~~ Pprint `with-float-traps-masked` better
|
67 | 67 | * ~~#291~~ Pprint `handler-case` neatly.
|
68 | + * ~~#297~~ Pprint `new-assem:assemble` with less indentation.
|
|
68 | 69 | * Other changes:
|
69 | 70 | * Improvements to the PCL implementation of CLOS:
|
70 | 71 | * Changes to building procedure:
|
... | ... | @@ -4868,6 +4868,28 @@ msgid "" |
4868 | 4868 | " their testing within, and restored on exit."
|
4869 | 4869 | msgstr ""
|
4870 | 4870 | |
4871 | +#: src/code/float-trap.lisp
|
|
4872 | +msgid ""
|
|
4873 | +"Execute BODY with the floating-point rounding mode set to\n"
|
|
4874 | +" ROUNDING-MODE. ROUNDING-MODE must be a one:\n"
|
|
4875 | +"\n"
|
|
4876 | +" :NEAREST\n"
|
|
4877 | +" the default mode of round to nearest even.\n"
|
|
4878 | +" :ZERO\n"
|
|
4879 | +" round numbers down towards zero. Positive numbers round down\n"
|
|
4880 | +" and negative numbers round up.\n"
|
|
4881 | +" :POSITIVE-INFINITY\n"
|
|
4882 | +" round numbers up towards positive infinity.\n"
|
|
4883 | +" :NEGATIVE-INFINITY\n"
|
|
4884 | +" round numbers down towards negative infinity.\n"
|
|
4885 | +"\n"
|
|
4886 | +" These are the same as the possible values for the rounding mode in\n"
|
|
4887 | +" SET-FLOATING-POINT-MODES.\n"
|
|
4888 | +"\n"
|
|
4889 | +" Only the rounding mode is restored on exit; other floating-point\n"
|
|
4890 | +" modes are not modified."
|
|
4891 | +msgstr ""
|
|
4892 | + |
|
4871 | 4893 | #: src/code/float.lisp
|
4872 | 4894 | msgid "Return true if the float X is denormalized."
|
4873 | 4895 | msgstr ""
|
... | ... | @@ -8731,10 +8753,6 @@ msgstr "" |
8731 | 8753 | msgid "Number not representable as a ~S: ~S"
|
8732 | 8754 | msgstr ""
|
8733 | 8755 | |
8734 | -#: src/code/reader.lisp
|
|
8735 | -msgid "Underflow"
|
|
8736 | -msgstr ""
|
|
8737 | - |
|
8738 | 8756 | #: src/code/reader.lisp
|
8739 | 8757 | msgid "Floating point underflow when reading ~S: ~S"
|
8740 | 8758 | msgstr ""
|
... | ... | @@ -213,35 +213,37 @@ |
213 | 213 | (assert-error 'reader-error (read-from-string "1.8d308"))
|
214 | 214 | (assert-error 'reader-error (read-from-string "1d999999999")))
|
215 | 215 | |
216 | -(define-test reader.float-underflow
|
|
216 | +(defun rounding-test (x)
|
|
217 | + (declare (double-float x)
|
|
218 | + (optimize (speed 3)))
|
|
219 | + (* x (/ 1d0 x)))
|
|
220 | + |
|
221 | +(define-test rounding-mode.nearest
|
|
217 | 222 | (:tag :issues)
|
218 | - (lisp::with-float-traps-enabled (:underflow)
|
|
219 | - ;; A denormal
|
|
220 | - (assert-error 'reader-error
|
|
221 | - (read-from-string "1e-40"))
|
|
222 | - (assert-error 'reader-error
|
|
223 | - (read-from-string (format nil "~A" least-positive-single-float)))
|
|
224 | - ;; The same for double-floats
|
|
225 | - (assert-error 'reader-error
|
|
226 | - (read-from-string "1d-308"))
|
|
227 | - (assert-error 'reader-error
|
|
228 | - (read-from-string (format nil "~A" least-positive-double-float)))))
|
|
229 | - |
|
230 | -(define-test reader.float-underflow
|
|
223 | + (ext:with-float-rounding-mode (:nearest)
|
|
224 | + (assert-equal 1d0 (rounding-test 3d0))))
|
|
225 | + |
|
226 | +(define-test rounding-mode.zero.1
|
|
231 | 227 | (:tag :issues)
|
232 | - (lisp::with-float-traps-enabled (:underflow)
|
|
233 | - ;; The expected string comes from make-float-aux.
|
|
234 | - (let ((expected "Floating point underflow when reading ~S: ~S"))
|
|
235 | - (flet ((test-reader-underflow (string)
|
|
236 | - ;; Test that the we got a reader-error when a number
|
|
237 | - ;; would underflow and that the message says we got an
|
|
238 | - ;; underflow.
|
|
239 | - (let ((condition (nth-value 1 (ignore-errors (read-from-string string)))))
|
|
240 | - (assert-equal 'reader-error (type-of condition))
|
|
241 | - (assert-equal expected (lisp::reader-error-format-control condition)))))
|
|
242 | - ;; Underflow single-floats
|
|
243 | - (test-reader-underflow "1e-40")
|
|
244 | - (test-reader-underflow (format nil "~A" least-positive-single-float))
|
|
245 | - ;; Underflow double-floats
|
|
246 | - (test-reader-underflow "1d-308")
|
|
247 | - (test-reader-underflow (format nil "~A" least-positive-double-float)))))) |
|
228 | + (ext:with-float-rounding-mode (:zero)
|
|
229 | + (assert-equal 0.9999999999999999d0
|
|
230 | + (rounding-test 3d0))))
|
|
231 | + |
|
232 | +(define-test rounding-mode.zero.2
|
|
233 | + (:tag :issues)
|
|
234 | + (ext:with-float-rounding-mode (:zero)
|
|
235 | + (assert-equal 0.9999999999999999d0
|
|
236 | + (rounding-test -3d0))))
|
|
237 | + |
|
238 | +(define-test rounding-mode.positive-infinity
|
|
239 | + (:tag :issues)
|
|
240 | + (ext:with-float-rounding-mode (:positive-infinity)
|
|
241 | + (assert-equal 1.0000000000000002d0
|
|
242 | + (rounding-test 3d0))))
|
|
243 | + |
|
244 | +(define-test rounding-mode.negative-infinity
|
|
245 | + (:tag :issues)
|
|
246 | + (ext:with-float-rounding-mode (:negative-infinity)
|
|
247 | + (assert-equal 0.9999999999999999d0
|
|
248 | + (rounding-test 3d0))))
|
|
249 | + |
... | ... | @@ -121,3 +121,17 @@ |
121 | 121 | (:no-error ()
|
122 | 122 | (format nil "Nothing bad happened.")))
|
123 | 123 | s))))
|
124 | + |
|
125 | +(define-test pprint.assemble
|
|
126 | + (:tag :issues)
|
|
127 | + (assert-equal
|
|
128 | + "
|
|
129 | +(NEW-ASSEM:ASSEMBLE (C:*CODE-SEGMENT* 'X86::XOROSHIRO-UPDATE)
|
|
130 | + X86::XOROSHIRO-UPDATE
|
|
131 | + (PUSH (CONS 'X86::XOROSHIRO-UPDATE X86::XOROSHIRO-UPDATE)
|
|
132 | + C::*ASSEMBLER-ROUTINES*))"
|
|
133 | + (with-output-to-string (s)
|
|
134 | + (pprint '(new-assem:assemble (c::*code-segment* 'vm::xoroshiro-update)
|
|
135 | + vm::xoroshiro-update
|
|
136 | + (push (cons 'vm::xoroshiro-update vm::xoroshiro-update) c::*assembler-routines*))
|
|
137 | + s)))) |