cmucl-cvs March 2024

cmucl-cvs@common-lisp.net

1 participants
54 discussions

[Git][cmucl/cmucl][issue-276-xoroshiro128starstar] Checkout ansi-test branch issue-276-xoroshiro
by Raymond Toy (＠rtoy) 13 Mar '24

13 Mar '24

Raymond Toy pushed to branch issue-276-xoroshiro128starstar at cmucl / cmucl Commits: b80289c5 by Raymond Toy at 2024-03-13T12:35:32-07:00 Checkout ansi-test branch issue-276-xoroshiro Use this branch instead of cmucl-expected-failues for running the tests associated with this merge request. - - - - - 1 changed file: - bin/run-ansi-tests.sh Changes: ===================================== bin/run-ansi-tests.sh ===================================== @@ -40,7 +40,7 @@ else fi cd ../ansi-test -git checkout cmucl-expected-failures +git checkout issue-276-xoroshiro make LISP="$LISP batch -noinit -nositeinit" # There should be no unexpected successes or failures; check these separately View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b80289c54de16cdbfb49ad2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b80289c54de16cdbfb49ad2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-276-xoroshiro128starstar] All archs use xoroshiro128** so remove the old test results.
by Raymond Toy (＠rtoy) 11 Mar '24

11 Mar '24

Raymond Toy pushed to branch issue-276-xoroshiro128starstar at cmucl / cmucl Commits: cd503821 by Raymond Toy at 2024-03-11T16:23:43-07:00 All archs use xoroshiro128** so remove the old test results. Don't need the test results for xoroshiro128+ since we use xoroshiro128** everywhere now. - - - - - 1 changed file: - tests/rng.lisp Changes: ===================================== tests/rng.lisp ===================================== @@ -49,20 +49,7 @@ (assert-equal nil (kernel::random-state-cached-p *test-state*)) (dolist (item - ;; Results for xoroshiro128+ - #-x86 - '((#x18d5f05c086e0086 (#x228f4926843b364d #x74dfe78e715c81be)) - (#x976f30b4f597b80b (#x5b6bd4558bd96a68 #x567b7f35650aea8f)) - (#xb1e7538af0e454f7 (#x13e5253e242fac52 #xed380e70d10ab60e)) - (#x011d33aef53a6260 (#x9d0764952ca00d8a #x5251a5cfedd2b4ef)) - (#xef590a651a72c279 (#xba4ef2b425bda963 #x172b965cf56c15ac)) - (#xd17a89111b29bf0f (#x458277a5e5f0a21b #xd1bccfad6564e8d)) - (#x529e44a0bc46f0a8 (#x2becb68d5a7194c7 #x3a6ec964899bb5f3)) - (#x665b7ff1e40d4aba (#xededfd481d0a19fe #x3ea213411827fe9d)) - (#x2c9010893532189b (#xd7bb59bcd8fba26f #x52de763d34fee090)) - (#x2a99cffa0dfa82ff (#xf96e892c62d6ff2e #xc0542ff85652f81e))) ;; Results for xoroshiro128** - #+x86 '((#x41db14eb317141fe (#x16dfbf3d760d0fa4 #xe9bfcf1ce2b9037c)) (#xaa4ee6e025dfec01 (#xb237e99a3c7ad367 #x96819b1fec0e0432)) (#xea080e50cb948fa5 (#xcc0fd8226093e0bc #x0e9aeaa496ce50ba)) @@ -85,17 +72,12 @@ :rand 0 :cached-p nil)) (dolist (result - ;; Results for xoroshiro128+ jump function - #-x86 '((#x291ddf8e6f6a7b67 #x1f9018a12f9e031f) - (#x88a7aa12158558d0 #xe264d785ab1472d9) - (#x207e16f73c51e7ba #x999c8a0a9a8d87c0) - (#x28f8959d3bcf5ff1 #x38091e563ab6eb98)) ;; Results for xoroshiro128** jump function - #+x86 '((#x19a22191480b0a4e #x43b3d7ee592dd4cf) - (#x76cb87035d0b6e99 #xb6827bcf2ef8267c) - (#x5125201dbdf76860 #x8984c075043869e2) - (#x2c06f0667255309f #xa48cbe2e60fc1d65) - )) + '((#x19a22191480b0a4e #x43b3d7ee592dd4cf) + (#x76cb87035d0b6e99 #xb6827bcf2ef8267c) + (#x5125201dbdf76860 #x8984c075043869e2) + (#x2c06f0667255309f #xa48cbe2e60fc1d65) + )) (kernel:random-state-jump *test-state*) (assert-equal result (multiple-value-list (64-bit-rng-state *test-state*))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/cd503821e0db3230632c240… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/cd503821e0db3230632c240… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-276-xoroshiro128starstar] 7 commits: Fix #278: Add more debugging prints for gencgc
by Raymond Toy (＠rtoy) 11 Mar '24

11 Mar '24

Raymond Toy pushed to branch issue-276-xoroshiro128starstar at cmucl / cmucl Commits: 33cf472e by Raymond Toy at 2024-03-08T15:31:41+00:00 Fix #278: Add more debugging prints for gencgc - - - - - e16b28cc by Raymond Toy at 2024-03-08T15:31:47+00:00 Merge branch 'issue-278-more-gencgc-debug-prints' into 'master' Fix #278: Add more debugging prints for gencgc Closes #278 See merge request cmucl/cmucl!193 - - - - - 9fee7762 by Raymond Toy at 2024-03-08T15:52:35+00:00 Fix #277: return least-positive float for rationals close to it - - - - - 8faafb32 by Raymond Toy at 2024-03-08T15:52:37+00:00 Merge branch 'issue-277-float-ratio-float-least-positive-float' into 'master' Fix #277: return least-positive float for rationals close to it Closes #277 See merge request cmucl/cmucl!191 - - - - - 0d6882c7 by Raymond Toy at 2024-03-10T20:12:37+00:00 Fix #274: 1d999999 hangs cmucl - - - - - 34f33e19 by Raymond Toy at 2024-03-10T20:12:38+00:00 Merge branch 'issue-274-make-float-of-huge-numbers' into 'master' Fix #274: 1d999999 hangs cmucl Closes #274 See merge request cmucl/cmucl!189 - - - - - a2e2a586 by Raymond Toy at 2024-03-11T23:16:30+00:00 Merge branch 'master' into 'issue-276-xoroshiro128starstar' # Conflicts: # src/general-info/release-21f.md - - - - - 6 changed files: - src/code/float.lisp - src/code/reader.lisp - src/i18n/locale/cmucl.pot - src/lisp/gencgc.c - src/lisp/os.h - tests/float.lisp Changes: ===================================== src/code/float.lisp ===================================== @@ -1137,7 +1137,8 @@ (floatit (ash bits -1)) #+nil (progn - (format t "1: f0, f1 = ~A ~A~%" f0 f1) + (format t "x = ~A~%" x) + (format t "1: f0, f1 = ~A~%" f0) (format t " scale = ~A~%" (1+ scale))) (scale-float f0 (1+ scale)))) @@ -1146,14 +1147,30 @@ (floatit bits) #+nil (progn - (format t "2: f0, f1 = ~A ~A~%" f0 f1) + (format t "2: f0, f1 = ~A~%" f0) (format t " scale = ~A~%" scale) - (format t "scale-float f0 = ~A~%" (scale-float f0 scale)) - (when f1 - (format t "scale-float f1 = ~A~%" - (scale-float f1 (- scale 53))))) - - (scale-float f0 scale)))))) + (format t "scale-float f0 = ~A~%" (scale-float f0 scale))) + (let ((min-exponent + ;; Compute the min (unbiased) exponent + (ecase format + (single-float + (- vm:single-float-normal-exponent-min + vm:single-float-bias + vm:single-float-digits)) + (double-float + (- vm:double-float-normal-exponent-min + vm:double-float-bias + vm:double-float-digits))))) + ;; F0 is always between 0.5 and 1. If + ;; SCALE is the min exponent, we have a + ;; denormal number just less than the + ;; least-positive float. We want to + ;; return the least-positive-float so + ;; multiply F0 by 2 (without adjusting + ;; SCALE) to get the nearest float. + (if (= scale min-exponent) + (scale-float (* 2 f0) scale) + (scale-float f0 scale)))))))) (floatit (bits) (let ((sign (if plusp 0 1))) (case format ===================================== src/code/reader.lisp ===================================== @@ -1785,7 +1785,7 @@ the end of the stream." ;; Is there an exponent letter? (cond ((eofp char) ;; If not, we've read the whole number. - (let ((num (make-float-aux number divisor + (let ((num (make-float-aux 0 number divisor *read-default-float-format* stream))) (return-from make-float (if negative-fraction (- num) num)))) @@ -1815,7 +1815,7 @@ the end of the stream." #+double-double (#\W 'kernel:double-double-float))) num) - (setq num (make-float-aux (* (expt 10 exponent) number) divisor + (setq num (make-float-aux exponent number divisor float-format stream)) (return-from make-float (if negative-fraction @@ -1823,10 +1823,55 @@ the end of the stream." num)))) (t (error _"Internal error in floating point reader."))))) -(defun make-float-aux (number divisor float-format stream) +(defun make-float-aux (exponent number divisor float-format stream) + ;; Computes x = number*10^exponent/divisor. + ;; + ;; First check to see if x can possibly fit into a float of the + ;; given format. So compute log2(x) to get an approximate value of + ;; the base 2 exponent of x. If it's too large or too small, we can + ;; 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 (/ number divisor)) + (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 @@ -1850,7 +1895,7 @@ the end of the stream." result)) (error () (%reader-error stream _"Number not representable as a ~S: ~S" - float-format (/ number divisor))))) + float-format (read-buffer-to-string))))) (defun make-ratio (stream) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8728,11 +8728,11 @@ msgid "Internal error in floating point reader." msgstr "" #: src/code/reader.lisp -msgid "Underflow" +msgid "Number not representable as a ~S: ~S" msgstr "" #: src/code/reader.lisp -msgid "Number not representable as a ~S: ~S" +msgid "Underflow" msgstr "" #: src/code/reader.lisp ===================================== src/lisp/gencgc.c ===================================== @@ -6756,10 +6756,9 @@ scavenge_newspace_generation_one_scan(int generation) { int i; -#if 0 - fprintf(stderr, "Starting one full scan of newspace generation %d\n", - generation); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Starting one full scan of newspace generation %d\n", + generation)); for (i = 0; i < last_free_page; i++) { if (PAGE_ALLOCATED(i) && !PAGE_UNBOXED(i) @@ -6864,10 +6863,10 @@ scavenge_newspace_generation_one_scan(int generation) i = last_page; } } -#if 0 - fprintf(stderr, "Finished one full scan of newspace generation %d\n", - generation); -#endif + + DPRINTF(gencgc_verbose, + (stderr, "Finished one full scan of newspace generation %d\n", + generation)); } /* Scan all weak objects and reset weak object lists */ @@ -6896,9 +6895,8 @@ scavenge_newspace_generation(int generation) struct new_area (*previous_new_areas)[] = NULL; int previous_new_areas_index; -#if 0 - fprintf(stderr, "Start scavenge_newspace_generation %d\n", generation); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Start scavenge_newspace_generation %d\n", generation)); #define SC_NS_GEN_CK 0 #if SC_NS_GEN_CK @@ -7078,9 +7076,9 @@ scavenge_newspace_generation(int generation) "*** scav.new.gen. %d: write protected page %d written to? dont_move=%d\n", generation, i, PAGE_DONT_MOVE(i)); #endif -#if 0 - fprintf(stderr, "Finished scavenge_newspace_generation %d\n", generation); -#endif + + DPRINTF(gencgc_verbose, + (stderr, "Finished scavenge_newspace_generation %d\n", generation)); } @@ -7839,20 +7837,26 @@ garbage_collect_generation(int generation, int raise) scavenge_control_stack(); #endif + DPRINTF(gencgc_verbose, + (stderr, "Scavenging interrupt handlers ...\n")); + scavenge_interrupt_handlers(); -#ifdef PRINTNOISE - printf("Scavenging the binding stack (%d bytes) ...\n", - ((lispobj *) get_binding_stack_pointer() - - binding_stack) * sizeof(lispobj)); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging interrupt handlers\n")); + + DPRINTF(gencgc_verbose, + (stderr, "Scavenging the binding stack (%d bytes) ...\n", + ((lispobj *) get_binding_stack_pointer() - + binding_stack) * sizeof(lispobj))); + /* Scavenge the binding stack. */ scavenge(binding_stack, (lispobj *) get_binding_stack_pointer() - binding_stack); -#ifdef PRINTNOISE - printf("Done scavenging the binding stack.\n"); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging the binding stack.\n")); + /* * Scavenge the scavenge_hooks in case this refers to a hook added * in a prior generation GC. From here on the scavenger_hook will @@ -7860,30 +7864,44 @@ garbage_collect_generation(int generation, int raise) * doing here. */ -#ifdef PRINTNOISE - printf("Scavenging the scavenger hooks ...\n"); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Scavenging the scavenger hooks ...\n")); + scavenge(&scavenger_hooks, 1); -#ifdef PRINTNOISE - printf("Done scavenging the scavenger hooks.\n"); -#endif + + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging the scavenger hooks.\n")); static_space_size = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER) - static_space; - if (gencgc_verbose > 1) - fprintf(stderr, "Scavenge static space: %ld bytes\n", - static_space_size * sizeof(lispobj)); + + DPRINTF(gencgc_verbose, + (stderr, "Scavenge static space: %ld bytes\n", + static_space_size * sizeof(lispobj))); + scavenge(static_space, static_space_size); + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging static space\n")); + /* * All generations but the generation being GCed need to be * scavenged. The new_space generation needs special handling as * objects may be moved in - it is handle separately below. */ - for (i = 0; i < NUM_GENERATIONS; i++) - if (i != generation && i != new_space) + for (i = 0; i < NUM_GENERATIONS; i++) { + if (i != generation && i != new_space) { + DPRINTF(gencgc_verbose, + (stderr, "Scavenge generation %lu (gen = %d, new space = %d)\n", + i, generation, new_space)); + scavenge_generation(i); + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging generation %lu\n", i)); + } + } + /* * Finally scavenge the new_space generation. Keep going until no * more objects are moved into the new generation. ===================================== src/lisp/os.h ===================================== @@ -8,7 +8,13 @@ #include "lisp.h" -#define DPRINTF(t,a) { if (t) fprintf a; } +#if defined(__GNUC__) || defined(__clang__) +#define UNLIKELY(x) __builtin_expect(!!(x), 0) +#else +#define UNLIKELY(x) (x) +#endif + +#define DPRINTF(t,a) { if (UNLIKELY(t)) fprintf a; } #ifdef DARWIN #include "Darwin-os.h" ===================================== tests/float.lisp ===================================== @@ -136,5 +136,79 @@ (ext:with-float-traps-masked (:overflow) (* 100 most-negative-double-float))))) - - \ No newline at end of file +(define-test float-ratio.single + (:tag :issues) + ;; least-positive-single-float is 1.4012985e-45. Let's test with + ;; some rationals from 7/10*10^-45 to 1.41*10^-45 to make sure they + ;; return 0 or least-positive-single-float + (let ((expo (expt 10 -45))) + ;; Need to make sure underflows are masked. + (kernel::with-float-traps-masked (:underflow) + ;; 7/10*10^-45 is just under halfway between 0 and least-positive, + ;; so the answer is 0. + (assert-equal 0f0 (kernel::float-ratio-float (* 7/10 expo) 'single-float)) + + ;; These are all more than half way to + ;; least-positive-single-float, so they should return that. + (assert-equal least-positive-single-float + (kernel::float-ratio-float (* 8/10 expo) 'single-float)) + (assert-equal least-positive-single-float + (kernel::float-ratio-float (* 1 expo) 'single-float)) + (assert-equal least-positive-single-float + (kernel::float-ratio-float (* 14/10 expo) 'single-float)) + (assert-equal least-positive-single-float + (kernel::float-ratio-float (* 2 expo) 'single-float))))) + +(define-test float-ratio.double + (:tag :issues) + ;; least-positive-double-float is 4.9406564584124654d-324. Let's + ;; test with some rationals from about 2*10^-324 to 4.94*10^-324 to make + ;; sure they return 0 or least-positive-double-float + (let ((expo (expt 10 -324))) + ;; Need to make sure underflows are masked. + (kernel::with-float-traps-masked (:underflow) + ;; 247/100*10^-324 is just under halfway between 0 and least-positive, + ;; so the answer is 0. + (assert-equal 0d0 (kernel::float-ratio-float (* 247/100 expo) 'double-float)) + + ;; These are all more than half way to + ;; least-positive-double-float, so they should return that. + (assert-equal least-positive-double-float + (kernel::float-ratio-float (* 248/100 expo) 'double-float)) + (assert-equal least-positive-double-float + (kernel::float-ratio-float (* 4 expo) 'double-float)) + (assert-equal least-positive-double-float + (kernel::float-ratio-float (* 494/100 expo) 'double-float)) + (assert-equal least-positive-double-float + (kernel::float-ratio-float (* 988/100 expo) 'double-float))))) + +(define-test reader-error.small-single-floats + (:tag :issues) + ;; Test a number less than half of least-positive-single-float, + ;; something a bit smaller, hen then something really small that + ;; used to appear to hang cmucl because it was trying to compute the + ;; a rational with a huge number of digits. + (dolist (num '("1e-46" "1e-80" "1e-999999999")) + (assert-error 'reader-error (read-from-string num) + num))) + +(define-test reader-error.small-double-floats + (:tag :issues) + ;; Like reader-error.small-single-floats but for doubles + (dolist (num '("1d-324" "1d-600" "1d-999999999")) + (assert-error 'reader-error (read-from-string num) + num))) + +(define-test reader-error.big-single-floats + (:tag :issues) + ;; Signal error for a number just a bit larger than + ;; most-positive-single-float. And a really big single-float. + (assert-error 'reader-error (read-from-string "3.5e38")) + (assert-error 'reader-error (read-from-string "1e999999999"))) + +(define-test reader-error.big-double-floats + (:tag :issues) + ;; Signal error for a number just a bit larger than + ;; most-positive-double-float. And a really big single-float. + (assert-error 'reader-error (read-from-string "1.8d308")) + (assert-error 'reader-error (read-from-string "1d999999999"))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/eb500219950faf934150d7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/eb500219950faf934150d7… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-276-xoroshiro128starstar] 2 commits: Remove old xoroshiro jump function; update comments/docstrings
by Raymond Toy (＠rtoy) 11 Mar '24

11 Mar '24

Raymond Toy pushed to branch issue-276-xoroshiro128starstar at cmucl / cmucl Commits: 7b03d6e1 by Raymond Toy at 2024-03-11T16:05:29-07:00 Remove old xoroshiro jump function; update comments/docstrings The old xoroshiro jump function is not needed since we now have a Lisp version of xoroshiro128**; we can use the new jump function everywhere now. Update the comments to match the implementation and add some docstrings. - - - - - eb500219 by Raymond Toy at 2024-03-11T16:10:39-07:00 Update pot file for new docstrings. - - - - - 2 changed files: - src/code/rand-xoroshiro.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== @@ -225,18 +225,27 @@ ;;;; Random entries: -;; Sparc and x86 have vops to implement xoroshiro-gen that are much -;; faster than the portable lisp version. Use them. -#+(or x86 sparc) +;; X86 has a vop to implement xoroshiro-gen that is about 4.5 times +;; faster than the portable lisp version below. For other +;; architectures, we use the portable version until a vop is written. +#+x86 (declaim (inline xoroshiro-gen)) -#+(or x86) +#+x86 (defun xoroshiro-gen (state) + _N"Generate the next 64-bit result from the xoroshiro128** generator + using the state in STATE, a simple-array of 2 double-floats. The + 64-bit result is returned as 2 32-bit values, with the high 32-bits + being the first value." (declare (type (simple-array double-float (2)) state) (optimize (speed 3) (safety 0))) (vm::xoroshiro-next state)) -#+(or sparc) +#-x86 (defun xoroshiro-gen (state) + _N"Generate the next 64-bit result from the xoroshiro128** generator + using the state in STATE, a simple-array of 2 double-floats. The + 64-bit result is returned as 2 32-bit values, with the high 32-bits + being the first value." (declare (type (simple-array double-float (2)) state) (optimize (speed 3) (safety 0))) (flet @@ -502,49 +511,7 @@ :format-arguments (list arg))))) ;; Jump function for the generator. See the jump function in -;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c -#-x86 -(defun random-state-jump (&optional (rng-state *random-state*)) - _N"Jump the RNG-STATE. This is equivalent to 2^64 calls to the - xoroshiro128+ generator. It can be used to generate 2^64 - non-overlapping subsequences for parallel computations." - (declare (type random-state rng-state)) - (let ((state (random-state-state rng-state)) - (s0-0 0) - (s0-1 0) - (s1-0 0) - (s1-1 0)) - (declare (type (unsigned-byte 32) s0-0 s0-1 s1-0 s1-1) - (optimize (speed 3) (safety 0))) - ;; The constants are #xbeac0467eba5facb and #xd86b048b86aa9922, - ;; and we process these numbers starting from the LSB. We want ot - ;; process these in 32-bit chunks, so word-reverse the constants. - (dolist (jump '(#xeba5facb #xbeac0467 #x86aa9922 #xd86b048b)) - (declare (type (unsigned-byte 32) jump)) - (dotimes (b 32) - (declare (fixnum b)) - (when (logbitp b jump) - (multiple-value-bind (x1 x0) - (kernel:double-float-bits (aref state 0)) - (setf s0-1 (logxor s0-1 (ldb (byte 32 0) x1)) - s0-0 (logxor s0-0 x0))) - - (multiple-value-bind (x1 x0) - (kernel:double-float-bits (aref state 1)) - (setf s1-1 (logxor s1-1 (ldb (byte 32 0) x1)) - s1-0 (logxor s1-0 x0)))) - (xoroshiro-gen state))) - - (flet ((convert (x1 x0) - (declare (type (unsigned-byte 32) x1 x0)) - (kernel:make-double-float - (if (< x1 #x80000000) x1 (- x1 #x100000000)) - x0))) - (setf (aref state 0) (convert s0-1 s0-0)) - (setf (aref state 1) (convert s1-1 s1-0))) - rng-state)) - -#+x86 +;; https://prng.di.unimi.it/xoroshiro128starstar.c (defun random-state-jump (&optional (rng-state *random-state*)) _N"Jump the RNG-STATE. This is equivalent to 2^64 calls to the xoroshiro128** generator. It can be used to generate 2^64 ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -12222,19 +12222,20 @@ msgstr "" #: src/code/rand-xoroshiro.lisp msgid "" -"Generate a uniformly distributed pseudo-random number between zero\n" -" and Arg. State, if supplied, is the random state to use." +"Generate the next 64-bit result from the xoroshiro128** generator\n" +" using the state in STATE, a simple-array of 2 double-floats. The\n" +" 64-bit result is returned as 2 32-bit values, with the high 32-bits\n" +" being the first value." msgstr "" #: src/code/rand-xoroshiro.lisp -msgid "Argument is not a positive integer or a positive float: ~S" +msgid "" +"Generate a uniformly distributed pseudo-random number between zero\n" +" and Arg. State, if supplied, is the random state to use." msgstr "" #: src/code/rand-xoroshiro.lisp -msgid "" -"Jump the RNG-STATE. This is equivalent to 2^64 calls to the\n" -" xoroshiro128+ generator. It can be used to generate 2^64\n" -" non-overlapping subsequences for parallel computations." +msgid "Argument is not a positive integer or a positive float: ~S" msgstr "" #: src/code/rand-xoroshiro.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d7dbff3925edd162a6bc7d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d7dbff3925edd162a6bc7d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-276-xoroshiro128starstar] Implement lisp version of xoroshiro128**
by Raymond Toy (＠rtoy) 11 Mar '24

11 Mar '24

Raymond Toy pushed to branch issue-276-xoroshiro128starstar at cmucl / cmucl Commits: d7dbff39 by Raymond Toy at 2024-03-11T15:48:43-07:00 Implement lisp version of xoroshiro128** For architectures that haven't implemented a vop for xoroshiro-gen, we have implemented a fairly portable version in Lisp (taking advantage of modular arithmetic). I tested this against the test vectors, and we produce the correct results. - - - - - 1 changed file: - src/code/rand-xoroshiro.lisp Changes: ===================================== src/code/rand-xoroshiro.lisp ===================================== @@ -229,123 +229,130 @@ ;; faster than the portable lisp version. Use them. #+(or x86 sparc) (declaim (inline xoroshiro-gen)) -#+(or x86 sparc) +#+(or x86) (defun xoroshiro-gen (state) (declare (type (simple-array double-float (2)) state) (optimize (speed 3) (safety 0))) (vm::xoroshiro-next state)) -#-(or x86 sparc) +#+(or sparc) (defun xoroshiro-gen (state) (declare (type (simple-array double-float (2)) state) (optimize (speed 3) (safety 0))) - ;; Portable implementation of the xoroshiro128+ generator. See - ;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c for the - ;; definitive definition. - ;; - ;; 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 = s0 + s1; - ;; - ;; s1 ^= s0; - ;; s[0] = rotl(s0, 55) ^ s1 ^ (s1 << 14); // a, b - ;; s[1] = rotl(s1, 36); // c - ;; - ;; return result; - ;; } - ;; - (flet ((rotl-55 (x1 x0) - ;; Rotate [x1|x0] left 55 bits, returning the result as two - ;; values. - (declare (type (unsigned-byte 32) x0 x1) - (optimize (speed 3) (safety 0))) - ;; x << 55 - (let ((sl55-h (ldb (byte 32 0) (ash x0 (- 55 32)))) - (sl55-l 0)) - ;; x >> 9 - (let ((sr9-h (ash x1 -9)) - (sr9-l (ldb (byte 32 0) - (logior (ash x0 -9) - (ash x1 23))))) - (values (logior sl55-h sr9-h) - (logior sl55-l sr9-l))))) - (rotl-36 (x1 x0) - ;; Rotate [x1|x0] left 36 bits, returning the result as two - ;; values. - (declare (type (unsigned-byte 32) x0 x1) - (optimize (speed 3) (safety 0))) - ;; x << 36 - (let ((sl36-h (ldb (byte 32 0) (ash x0 4)))) - ;; x >> 28 - (let ((sr28-l (ldb (byte 32 0) - (logior (ash x0 -28) - (ash x1 4)))) - (sr28-h (ash x1 -28))) - (values (logior sl36-h sr28-h) - sr28-l)))) - (shl-14 (x1 x0) - ;; Shift [x1|x0] left by 14 bits, returning the result as - ;; two values. - (declare (type (unsigned-byte 32) x1 x0) - (optimize (speed 3) (safety 0))) - (values (ldb (byte 32 0) - (logior (ash x1 14) - (ash x0 (- 14 32)))) - (ldb (byte 32 0) - (ash x0 14)))) - (make-double (hi lo) - (kernel:make-double-float - (if (< hi #x80000000) - hi - (- hi #x100000000)) - lo))) + (flet + ((make-double (hi lo) + ;; Convert [hi lo] to a double-float, where hi and lo are the + ;; high and low 32 bits of a 64-bit double-float. + (declare (type (unsigned-byte 32) hi lo)) + (kernel:make-double-float + (if (< hi #x80000000) + hi + (- hi #x100000000)) + lo)) + (mul-shift (x1 x0 shift) + ;; Perform multiplication by 2^shift+1, by doing a shift and + ;; an add. + (declare (type (unsigned-byte 32) x1 x0) + (optimize (speed 3))) + (let* ((overflow (ash x0 (- (- 32 shift)))) + (s0 (ldb (byte 32 0) (ash x0 shift))) + (s1 (logior (ldb (byte 32 0) (ash x1 shift)) + overflow))) + (multiple-value-bind (sum0 carry) + (bignum:%add-with-carry s0 x0 0) + (multiple-value-bind (sum1) + (bignum:%add-with-carry s1 x1 carry) + (values sum1 sum0))))) + (shl (x1 x0 n) + ;; Shift left [x1 x0] by n bits, where 0 <= n < 31. + (declare (type (unsigned-byte 32) x1 x0) + (type (integer 0 31) n) + (optimize (speed 3))) + (let ((out (ldb (byte n (- 32 n)) x0))) + (values (logior (ldb (byte 32 0) (ash x1 n)) out) + (ldb (byte 32 0) (ash x0 n))))) + (rotl (x1 x0 n) + ;; Rotate left [x1 x0] by n bits where n < 32. + (declare (type (unsigned-byte 32) x1 x0) + (type (integer 0 31) n) + (optimize (speed 3))) + (let ((x1-hi (ldb (byte n (- 32 n)) x1)) + (x0-hi (ldb (byte n (- 32 n)) x0))) + ;; x1-hi and x0-hi are the bits that are shifted out of x1 + ;; and x0. + (values (logior (ldb (byte 32 0) (ash x1 n)) + x0-hi) + (logior (ldb (byte 32 0) (ash x0 n)) + x1-hi)))) + (rotr (x1 x0 n) + ;; Rotate right [x1 x0] by n bits where n < 32. + (declare (type (unsigned-byte 32) x1 x0) + (type (integer 0 31) n) + (optimize (speed 3))) + (let ((x1-lo (ldb (byte n 0) x1)) + (x0-lo (ldb (byte n 0) x0)) + (-n (- n)) + (32-n (- 32 n))) + ;; x1-lo and x0-lo are the bits of x1/x0 that would be + ;; shifted out. + (values (logior (ldb (byte 32 0) (ash x1 -n)) + (ldb (byte 32 0) (ash x0-lo 32-n))) + (logior (ldb (byte 32 0) (ash x0 -n)) + (ldb (byte 32 0) (ash x1-lo 32-n))))))) + (declare (inline mul-shift shl rotl rotr)) (let ((s0-1 0) (s0-0 0) (s1-1 0) - (s1-0 0)) - (declare (type (unsigned-byte 32) s0-1 s0-0 s1-1 s1-0)) - ;; Load the state to s0 and s1. s0-1 is the high 32-bit part and - ;; s0-0 is the low 32-bit part of the 64-bit value. Similarly - ;; for s1. + (s1-0 0) + (result-1 0) + (result-0 0)) + (declare (type (unsigned-byte 32) s0-1 s0-0 s1-1 s1-0 result-1 result-0)) + ;; [s0-1 s0-0] is the first 64-bit word of the state. (multiple-value-bind (x1 x0) (kernel:double-float-bits (aref state 0)) (setf s0-1 (ldb (byte 32 0) x1) s0-0 x0)) + ;; [s1-1 s1-0] is the second 64-bit word of the state. (multiple-value-bind (x1 x0) (kernel:double-float-bits (aref state 1)) (setf s1-1 (ldb (byte 32 0) x1) s1-0 x0)) - ;; Compute the 64-bit random value: s0 + s1 - (multiple-value-prog1 - (multiple-value-bind (sum-0 c) - (bignum::%add-with-carry s0-0 s1-0 0) - (values (bignum::%add-with-carry s0-1 s1-1 c) - sum-0)) - ;; s1 ^= s0 - (setf s1-1 (logxor s1-1 s0-1) - s1-0 (logxor s1-0 s0-0)) - ;; s[0] = rotl(s0,55) ^ s1 ^ (s1 << 14) - (multiple-value-setq (s0-1 s0-0) - (rotl-55 s0-1 s0-0)) - (setf s0-1 (logxor s0-1 s1-1) - s0-0 (logxor s0-0 s1-0)) - (multiple-value-bind (s14-1 s14-0) - (shl-14 s1-1 s1-0) - (setf s0-1 (logxor s0-1 s14-1) - s0-0 (logxor s0-0 s14-0))) - - (multiple-value-bind (r1 r0) - (rotl-36 s1-1 s1-0) - (setf (aref state 0) (make-double s0-1 s0-0) - (aref state 1) (make-double r1 r0))))))) + ;; [result-1 result-0] = s0 * 5 + (multiple-value-setq (result-1 result-0) + (mul-shift s0-1 s0-0 2)) + + ;; [result-1 result-0] = rotl(result, 7) + (multiple-value-setq (result-1 result-0) + (rotl result-1 result-0 7)) + + ;; [result-1 result-0] = result*9 + (multiple-value-setq (result-1 result-0) + (mul-shift result-1 result-0 3)) + + ;; s1 ^= s0 + (setf s1-1 (logxor s1-1 s0-1) + s1-0 (logxor s1-0 s0-0)) + (multiple-value-bind (s24-hi s24-lo) + (rotl s0-1 s0-0 24) + (declare (type (unsigned-byte 32) s24-hi s24-lo)) + ;; [s24-hi s24-lo] = rotl(s0, 24) ^ s1 + (setf s24-hi (logxor s24-hi s1-1) + s24-lo (logxor s24-lo s1-0)) + (multiple-value-bind (s16-hi s16-lo) + (shl s1-1 s1-0 16) + ;; [s24-hi s24-lo] = s24 ^ (s1 << 16) = state[0] + (setf s24-hi (logxor s24-hi s16-hi) + s24-lo (logxor s24-lo s16-lo)) + (setf (aref state 0) (make-double s24-hi s24-lo)))) + (multiple-value-bind (s37-hi s37-lo) + (rotr s1-1 s1-0 (- 64 37)) + ;; [s37-hi s37-lo] = rotl(s1, 37) = state[1]. But rotating + ;; left by 37 is the same as rotating right by 64-37. + (setf (aref state 1) (make-double s37-hi s37-lo))) + ;; Return result. + (values result-1 + result-0)))) ;;; Size of the chunks returned by random-chunk. ;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d7dbff3925edd162a6bc7d6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d7dbff3925edd162a6bc7d6… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #274: 1d999999 hangs cmucl
by Raymond Toy (＠rtoy) 10 Mar '24

10 Mar '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 0d6882c7 by Raymond Toy at 2024-03-10T20:12:37+00:00 Fix #274: 1d999999 hangs cmucl - - - - - 34f33e19 by Raymond Toy at 2024-03-10T20:12:38+00:00 Merge branch 'issue-274-make-float-of-huge-numbers' into 'master' Fix #274: 1d999999 hangs cmucl Closes #274 See merge request cmucl/cmucl!189 - - - - - 3 changed files: - src/code/reader.lisp - src/i18n/locale/cmucl.pot - tests/float.lisp Changes: ===================================== src/code/reader.lisp ===================================== @@ -1785,7 +1785,7 @@ the end of the stream." ;; Is there an exponent letter? (cond ((eofp char) ;; If not, we've read the whole number. - (let ((num (make-float-aux number divisor + (let ((num (make-float-aux 0 number divisor *read-default-float-format* stream))) (return-from make-float (if negative-fraction (- num) num)))) @@ -1815,7 +1815,7 @@ the end of the stream." #+double-double (#\W 'kernel:double-double-float))) num) - (setq num (make-float-aux (* (expt 10 exponent) number) divisor + (setq num (make-float-aux exponent number divisor float-format stream)) (return-from make-float (if negative-fraction @@ -1823,10 +1823,55 @@ the end of the stream." num)))) (t (error _"Internal error in floating point reader."))))) -(defun make-float-aux (number divisor float-format stream) +(defun make-float-aux (exponent number divisor float-format stream) + ;; Computes x = number*10^exponent/divisor. + ;; + ;; First check to see if x can possibly fit into a float of the + ;; given format. So compute log2(x) to get an approximate value of + ;; the base 2 exponent of x. If it's too large or too small, we can + ;; 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 (/ number divisor)) + (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 @@ -1850,7 +1895,7 @@ the end of the stream." result)) (error () (%reader-error stream _"Number not representable as a ~S: ~S" - float-format (/ number divisor))))) + float-format (read-buffer-to-string))))) (defun make-ratio (stream) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8728,11 +8728,11 @@ msgid "Internal error in floating point reader." msgstr "" #: src/code/reader.lisp -msgid "Underflow" +msgid "Number not representable as a ~S: ~S" msgstr "" #: src/code/reader.lisp -msgid "Number not representable as a ~S: ~S" +msgid "Underflow" msgstr "" #: src/code/reader.lisp ===================================== tests/float.lisp ===================================== @@ -182,3 +182,33 @@ (assert-equal least-positive-double-float (kernel::float-ratio-float (* 988/100 expo) 'double-float))))) +(define-test reader-error.small-single-floats + (:tag :issues) + ;; Test a number less than half of least-positive-single-float, + ;; something a bit smaller, hen then something really small that + ;; used to appear to hang cmucl because it was trying to compute the + ;; a rational with a huge number of digits. + (dolist (num '("1e-46" "1e-80" "1e-999999999")) + (assert-error 'reader-error (read-from-string num) + num))) + +(define-test reader-error.small-double-floats + (:tag :issues) + ;; Like reader-error.small-single-floats but for doubles + (dolist (num '("1d-324" "1d-600" "1d-999999999")) + (assert-error 'reader-error (read-from-string num) + num))) + +(define-test reader-error.big-single-floats + (:tag :issues) + ;; Signal error for a number just a bit larger than + ;; most-positive-single-float. And a really big single-float. + (assert-error 'reader-error (read-from-string "3.5e38")) + (assert-error 'reader-error (read-from-string "1e999999999"))) + +(define-test reader-error.big-double-floats + (:tag :issues) + ;; Signal error for a number just a bit larger than + ;; most-positive-double-float. And a really big single-float. + (assert-error 'reader-error (read-from-string "1.8d308")) + (assert-error 'reader-error (read-from-string "1d999999999"))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/8faafb3259fc5f220c887c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/8faafb3259fc5f220c887c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-274-make-float-of-huge-numbers] Use builtin constants to get the range of valid exponents.
by Raymond Toy (＠rtoy) 10 Mar '24

10 Mar '24

Raymond Toy pushed to branch issue-274-make-float-of-huge-numbers at cmucl / cmucl Commits: ab7f4ce8 by Raymond Toy at 2024-03-10T12:52:20-07:00 Use builtin constants to get the range of valid exponents. Instead of hard-wiring the min and max exponents, use `vm:single-float-normal-expenent-min`, and `vm:single-float-normal-exponent-max` to get the exponents. These need to be adjusted by `vm:single-float-bias` and `vm:single-float-digits` as appropriate to go the actual signed exponents ranges. We use analogous values for double-floats. - - - - - 1 changed file: - src/code/reader.lisp Changes: ===================================== src/code/reader.lisp ===================================== @@ -1845,12 +1845,22 @@ the end of the stream." (multiple-value-bind (log2-low log2-high) (ecase float-format ((short-float single-float) - ;; Single-float exponents range is -149 to 127 - (values (* 2 -149) (* 2 127))) + ;; 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 -1074) (* 2 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))))) + ;; 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. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ab7f4ce8c13a35a79f463d5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ab7f4ce8c13a35a79f463d5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #277: return least-positive float for rationals close to it
by Raymond Toy (＠rtoy) 08 Mar '24

08 Mar '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 9fee7762 by Raymond Toy at 2024-03-08T15:52:35+00:00 Fix #277: return least-positive float for rationals close to it - - - - - 8faafb32 by Raymond Toy at 2024-03-08T15:52:37+00:00 Merge branch 'issue-277-float-ratio-float-least-positive-float' into 'master' Fix #277: return least-positive float for rationals close to it Closes #277 See merge request cmucl/cmucl!191 - - - - - 3 changed files: - src/code/float.lisp - src/general-info/release-21f.md - tests/float.lisp Changes: ===================================== src/code/float.lisp ===================================== @@ -1137,7 +1137,8 @@ (floatit (ash bits -1)) #+nil (progn - (format t "1: f0, f1 = ~A ~A~%" f0 f1) + (format t "x = ~A~%" x) + (format t "1: f0, f1 = ~A~%" f0) (format t " scale = ~A~%" (1+ scale))) (scale-float f0 (1+ scale)))) @@ -1146,14 +1147,30 @@ (floatit bits) #+nil (progn - (format t "2: f0, f1 = ~A ~A~%" f0 f1) + (format t "2: f0, f1 = ~A~%" f0) (format t " scale = ~A~%" scale) - (format t "scale-float f0 = ~A~%" (scale-float f0 scale)) - (when f1 - (format t "scale-float f1 = ~A~%" - (scale-float f1 (- scale 53))))) - - (scale-float f0 scale)))))) + (format t "scale-float f0 = ~A~%" (scale-float f0 scale))) + (let ((min-exponent + ;; Compute the min (unbiased) exponent + (ecase format + (single-float + (- vm:single-float-normal-exponent-min + vm:single-float-bias + vm:single-float-digits)) + (double-float + (- vm:double-float-normal-exponent-min + vm:double-float-bias + vm:double-float-digits))))) + ;; F0 is always between 0.5 and 1. If + ;; SCALE is the min exponent, we have a + ;; denormal number just less than the + ;; least-positive float. We want to + ;; return the least-positive-float so + ;; multiply F0 by 2 (without adjusting + ;; SCALE) to get the nearest float. + (if (= scale min-exponent) + (scale-float (* 2 f0) scale) + (scale-float f0 scale)))))))) (floatit (bits) (let ((sign (if plusp 0 1))) (case format ===================================== src/general-info/release-21f.md ===================================== @@ -44,6 +44,8 @@ public domain. * ~~#266~~ Support "~user" in namestrings * ~~#271~~ Update ASDF to 3.3.7 * ~~#272~~ Move scavenge code for static vectors to its own function + * ~~#277~~ `float-ratio-float` returns least postive float for + ratios closer to that than zero. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== tests/float.lisp ===================================== @@ -136,5 +136,49 @@ (ext:with-float-traps-masked (:overflow) (* 100 most-negative-double-float))))) - - \ No newline at end of file +(define-test float-ratio.single + (:tag :issues) + ;; least-positive-single-float is 1.4012985e-45. Let's test with + ;; some rationals from 7/10*10^-45 to 1.41*10^-45 to make sure they + ;; return 0 or least-positive-single-float + (let ((expo (expt 10 -45))) + ;; Need to make sure underflows are masked. + (kernel::with-float-traps-masked (:underflow) + ;; 7/10*10^-45 is just under halfway between 0 and least-positive, + ;; so the answer is 0. + (assert-equal 0f0 (kernel::float-ratio-float (* 7/10 expo) 'single-float)) + + ;; These are all more than half way to + ;; least-positive-single-float, so they should return that. + (assert-equal least-positive-single-float + (kernel::float-ratio-float (* 8/10 expo) 'single-float)) + (assert-equal least-positive-single-float + (kernel::float-ratio-float (* 1 expo) 'single-float)) + (assert-equal least-positive-single-float + (kernel::float-ratio-float (* 14/10 expo) 'single-float)) + (assert-equal least-positive-single-float + (kernel::float-ratio-float (* 2 expo) 'single-float))))) + +(define-test float-ratio.double + (:tag :issues) + ;; least-positive-double-float is 4.9406564584124654d-324. Let's + ;; test with some rationals from about 2*10^-324 to 4.94*10^-324 to make + ;; sure they return 0 or least-positive-double-float + (let ((expo (expt 10 -324))) + ;; Need to make sure underflows are masked. + (kernel::with-float-traps-masked (:underflow) + ;; 247/100*10^-324 is just under halfway between 0 and least-positive, + ;; so the answer is 0. + (assert-equal 0d0 (kernel::float-ratio-float (* 247/100 expo) 'double-float)) + + ;; These are all more than half way to + ;; least-positive-double-float, so they should return that. + (assert-equal least-positive-double-float + (kernel::float-ratio-float (* 248/100 expo) 'double-float)) + (assert-equal least-positive-double-float + (kernel::float-ratio-float (* 4 expo) 'double-float)) + (assert-equal least-positive-double-float + (kernel::float-ratio-float (* 494/100 expo) 'double-float)) + (assert-equal least-positive-double-float + (kernel::float-ratio-float (* 988/100 expo) 'double-float))))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/e16b28cc4171a3d42265a6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/e16b28cc4171a3d42265a6… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #278: Add more debugging prints for gencgc
by Raymond Toy (＠rtoy) 08 Mar '24

08 Mar '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 33cf472e by Raymond Toy at 2024-03-08T15:31:41+00:00 Fix #278: Add more debugging prints for gencgc - - - - - e16b28cc by Raymond Toy at 2024-03-08T15:31:47+00:00 Merge branch 'issue-278-more-gencgc-debug-prints' into 'master' Fix #278: Add more debugging prints for gencgc Closes #278 See merge request cmucl/cmucl!193 - - - - - 2 changed files: - src/lisp/gencgc.c - src/lisp/os.h Changes: ===================================== src/lisp/gencgc.c ===================================== @@ -6756,10 +6756,9 @@ scavenge_newspace_generation_one_scan(int generation) { int i; -#if 0 - fprintf(stderr, "Starting one full scan of newspace generation %d\n", - generation); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Starting one full scan of newspace generation %d\n", + generation)); for (i = 0; i < last_free_page; i++) { if (PAGE_ALLOCATED(i) && !PAGE_UNBOXED(i) @@ -6864,10 +6863,10 @@ scavenge_newspace_generation_one_scan(int generation) i = last_page; } } -#if 0 - fprintf(stderr, "Finished one full scan of newspace generation %d\n", - generation); -#endif + + DPRINTF(gencgc_verbose, + (stderr, "Finished one full scan of newspace generation %d\n", + generation)); } /* Scan all weak objects and reset weak object lists */ @@ -6896,9 +6895,8 @@ scavenge_newspace_generation(int generation) struct new_area (*previous_new_areas)[] = NULL; int previous_new_areas_index; -#if 0 - fprintf(stderr, "Start scavenge_newspace_generation %d\n", generation); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Start scavenge_newspace_generation %d\n", generation)); #define SC_NS_GEN_CK 0 #if SC_NS_GEN_CK @@ -7078,9 +7076,9 @@ scavenge_newspace_generation(int generation) "*** scav.new.gen. %d: write protected page %d written to? dont_move=%d\n", generation, i, PAGE_DONT_MOVE(i)); #endif -#if 0 - fprintf(stderr, "Finished scavenge_newspace_generation %d\n", generation); -#endif + + DPRINTF(gencgc_verbose, + (stderr, "Finished scavenge_newspace_generation %d\n", generation)); } @@ -7839,20 +7837,26 @@ garbage_collect_generation(int generation, int raise) scavenge_control_stack(); #endif + DPRINTF(gencgc_verbose, + (stderr, "Scavenging interrupt handlers ...\n")); + scavenge_interrupt_handlers(); -#ifdef PRINTNOISE - printf("Scavenging the binding stack (%d bytes) ...\n", - ((lispobj *) get_binding_stack_pointer() - - binding_stack) * sizeof(lispobj)); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging interrupt handlers\n")); + + DPRINTF(gencgc_verbose, + (stderr, "Scavenging the binding stack (%d bytes) ...\n", + ((lispobj *) get_binding_stack_pointer() - + binding_stack) * sizeof(lispobj))); + /* Scavenge the binding stack. */ scavenge(binding_stack, (lispobj *) get_binding_stack_pointer() - binding_stack); -#ifdef PRINTNOISE - printf("Done scavenging the binding stack.\n"); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging the binding stack.\n")); + /* * Scavenge the scavenge_hooks in case this refers to a hook added * in a prior generation GC. From here on the scavenger_hook will @@ -7860,30 +7864,44 @@ garbage_collect_generation(int generation, int raise) * doing here. */ -#ifdef PRINTNOISE - printf("Scavenging the scavenger hooks ...\n"); -#endif + DPRINTF(gencgc_verbose, + (stderr, "Scavenging the scavenger hooks ...\n")); + scavenge(&scavenger_hooks, 1); -#ifdef PRINTNOISE - printf("Done scavenging the scavenger hooks.\n"); -#endif + + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging the scavenger hooks.\n")); static_space_size = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER) - static_space; - if (gencgc_verbose > 1) - fprintf(stderr, "Scavenge static space: %ld bytes\n", - static_space_size * sizeof(lispobj)); + + DPRINTF(gencgc_verbose, + (stderr, "Scavenge static space: %ld bytes\n", + static_space_size * sizeof(lispobj))); + scavenge(static_space, static_space_size); + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging static space\n")); + /* * All generations but the generation being GCed need to be * scavenged. The new_space generation needs special handling as * objects may be moved in - it is handle separately below. */ - for (i = 0; i < NUM_GENERATIONS; i++) - if (i != generation && i != new_space) + for (i = 0; i < NUM_GENERATIONS; i++) { + if (i != generation && i != new_space) { + DPRINTF(gencgc_verbose, + (stderr, "Scavenge generation %lu (gen = %d, new space = %d)\n", + i, generation, new_space)); + scavenge_generation(i); + DPRINTF(gencgc_verbose, + (stderr, "Done scavenging generation %lu\n", i)); + } + } + /* * Finally scavenge the new_space generation. Keep going until no * more objects are moved into the new generation. ===================================== src/lisp/os.h ===================================== @@ -8,7 +8,13 @@ #include "lisp.h" -#define DPRINTF(t,a) { if (t) fprintf a; } +#if defined(__GNUC__) || defined(__clang__) +#define UNLIKELY(x) __builtin_expect(!!(x), 0) +#else +#define UNLIKELY(x) (x) +#endif + +#define DPRINTF(t,a) { if (UNLIKELY(t)) fprintf a; } #ifdef DARWIN #include "Darwin-os.h" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d6358eaf8804e249b8cbaa… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d6358eaf8804e249b8cbaa… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-278-more-gencgc-debug-prints] Apply review suggestions
by Raymond Toy (＠rtoy) 07 Mar '24

07 Mar '24

Raymond Toy pushed to branch issue-278-more-gencgc-debug-prints at cmucl / cmucl Commits: 0baf6aeb by Raymond Toy at 2024-03-07T08:27:59-08:00 Apply review suggestions Use `stderr` instead of `stdout` so we get unbuffered messages. For gcc and clang, define an `UNLIKELY` macro to give a hint that the `DPRINTF` condition is unlikely since `gencgc_verbose` is usually disabled. - - - - - 2 changed files: - src/lisp/gencgc.c - src/lisp/os.h Changes: ===================================== src/lisp/gencgc.c ===================================== @@ -6757,7 +6757,7 @@ scavenge_newspace_generation_one_scan(int generation) int i; DPRINTF(gencgc_verbose, - (stdout, "Starting one full scan of newspace generation %d\n", + (stderr, "Starting one full scan of newspace generation %d\n", generation)); for (i = 0; i < last_free_page; i++) { @@ -6865,7 +6865,7 @@ scavenge_newspace_generation_one_scan(int generation) } DPRINTF(gencgc_verbose, - (stdout, "Finished one full scan of newspace generation %d\n", + (stderr, "Finished one full scan of newspace generation %d\n", generation)); } @@ -6896,7 +6896,7 @@ scavenge_newspace_generation(int generation) int previous_new_areas_index; DPRINTF(gencgc_verbose, - (stdout, "Start scavenge_newspace_generation %d\n", generation)); + (stderr, "Start scavenge_newspace_generation %d\n", generation)); #define SC_NS_GEN_CK 0 #if SC_NS_GEN_CK @@ -7078,7 +7078,7 @@ scavenge_newspace_generation(int generation) #endif DPRINTF(gencgc_verbose, - (stdout, "Finished scavenge_newspace_generation %d\n", generation)); + (stderr, "Finished scavenge_newspace_generation %d\n", generation)); } @@ -7838,15 +7838,15 @@ garbage_collect_generation(int generation, int raise) #endif DPRINTF(gencgc_verbose, - (stdout, "Scavenging interrupt handlers ...\n")); + (stderr, "Scavenging interrupt handlers ...\n")); scavenge_interrupt_handlers(); DPRINTF(gencgc_verbose, - (stdout, "Done scavenging interrupt handlers\n")); + (stderr, "Done scavenging interrupt handlers\n")); DPRINTF(gencgc_verbose, - (stdout, "Scavenging the binding stack (%d bytes) ...\n", + (stderr, "Scavenging the binding stack (%d bytes) ...\n", ((lispobj *) get_binding_stack_pointer() - binding_stack) * sizeof(lispobj))); @@ -7855,7 +7855,7 @@ garbage_collect_generation(int generation, int raise) (lispobj *) get_binding_stack_pointer() - binding_stack); DPRINTF(gencgc_verbose, - (stdout, "Done scavenging the binding stack.\n")); + (stderr, "Done scavenging the binding stack.\n")); /* * Scavenge the scavenge_hooks in case this refers to a hook added @@ -7865,18 +7865,18 @@ garbage_collect_generation(int generation, int raise) */ DPRINTF(gencgc_verbose, - (stdout, "Scavenging the scavenger hooks ...\n")); + (stderr, "Scavenging the scavenger hooks ...\n")); scavenge(&scavenger_hooks, 1); DPRINTF(gencgc_verbose, - (stdout, "Done scavenging the scavenger hooks.\n")); + (stderr, "Done scavenging the scavenger hooks.\n")); static_space_size = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER) - static_space; DPRINTF(gencgc_verbose, - (stdout, "Scavenge static space: %ld bytes\n", + (stderr, "Scavenge static space: %ld bytes\n", static_space_size * sizeof(lispobj))); scavenge(static_space, static_space_size); ===================================== src/lisp/os.h ===================================== @@ -8,7 +8,13 @@ #include "lisp.h" -#define DPRINTF(t,a) { if (t) fprintf a; } +#if defined(__GNUC__) || defined(__clang__) +#define UNLIKELY(x) __builtin_expect(!!(x), 0) +#else +#define UNLIKELY(x) (x) +#endif + +#define DPRINTF(t,a) { if (UNLIKELY(t)) fprintf a; } #ifdef DARWIN #include "Darwin-os.h" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0baf6aebd505f1182657b46… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0baf6aebd505f1182657b46… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs March 2024