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

[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

[Git][cmucl/cmucl][issue-278-more-gencgc-debug-prints] Remove old prints that we replaced with DPRINTF
by Raymond Toy (＠rtoy) 03 Mar '24

03 Mar '24

Raymond Toy pushed to branch issue-278-more-gencgc-debug-prints at cmucl / cmucl Commits: 13659aaa by Raymond Toy at 2024-03-03T11:55:33-08:00 Remove old prints that we replaced with DPRINTF Some of these were normally off and required a recompile to enable them. - - - - - 1 changed file: - src/lisp/gencgc.c Changes: ===================================== src/lisp/gencgc.c ===================================== @@ -6756,10 +6756,6 @@ 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, (stdout, "Starting one full scan of newspace generation %d\n", generation)); @@ -6867,10 +6863,7 @@ 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, (stdout, "Finished one full scan of newspace generation %d\n", generation)); @@ -6902,9 +6895,6 @@ 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, (stdout, "Start scavenge_newspace_generation %d\n", generation)); @@ -7086,9 +7076,7 @@ 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, (stdout, "Finished scavenge_newspace_generation %d\n", generation)); } @@ -7857,11 +7845,6 @@ garbage_collect_generation(int generation, int raise) DPRINTF(gencgc_verbose, (stdout, "Done scavenging interrupt handlers\n")); -#ifdef PRINTNOISE - printf("Scavenging the binding stack (%d bytes) ...\n", - ((lispobj *) get_binding_stack_pointer() - - binding_stack) * sizeof(lispobj)); -#endif DPRINTF(gencgc_verbose, (stdout, "Scavenging the binding stack (%d bytes) ...\n", ((lispobj *) get_binding_stack_pointer() - @@ -7874,9 +7857,6 @@ garbage_collect_generation(int generation, int raise) DPRINTF(gencgc_verbose, (stdout, "Done scavenging the binding stack.\n")); -#ifdef PRINTNOISE - printf("Done scavenging the binding stack.\n"); -#endif /* * Scavenge the scavenge_hooks in case this refers to a hook added * in a prior generation GC. From here on the scavenger_hook will @@ -7884,9 +7864,6 @@ garbage_collect_generation(int generation, int raise) * doing here. */ -#ifdef PRINTNOISE - printf("Scavenging the scavenger hooks ...\n"); -#endif DPRINTF(gencgc_verbose, (stdout, "Scavenging the scavenger hooks ...\n")); @@ -7895,15 +7872,11 @@ garbage_collect_generation(int generation, int raise) DPRINTF(gencgc_verbose, (stdout, "Done scavenging the scavenger hooks.\n")); -#ifdef PRINTNOISE - printf("Done scavenging the scavenger hooks.\n"); -#endif - static_space_size = (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER) - static_space; DPRINTF(gencgc_verbose, - (stderr, "Scavenge static space: %ld bytes\n", + (stdout, "Scavenge static space: %ld bytes\n", static_space_size * sizeof(lispobj))); scavenge(static_space, static_space_size); View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/13659aaacbf1a78425564e2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/13659aaacbf1a78425564e2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-278-more-gencgc-debug-prints
by Raymond Toy (＠rtoy) 03 Mar '24

03 Mar '24

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

1 0

[Git][cmucl/cmucl][issue-243-weak-pointer-to-static-array] 5 commits: Revert "Update some comments; slightly modify scan_static_vectors to use pop"
by Raymond Toy (＠rtoy) 01 Mar '24

01 Mar '24

Raymond Toy pushed to branch issue-243-weak-pointer-to-static-array at cmucl / cmucl Commits: 9346ebc1 by Raymond Toy at 2024-03-01T08:15:23-08:00 Revert "Update some comments; slightly modify scan_static_vectors to use pop" This reverts commit 1f8a6328ba47804660e1811a8227522d86be0259. - - - - - cf831e08 by Raymond Toy at 2024-03-01T08:15:41-08:00 Revert "Clear static vector visited bit when scavenging a weak pointer to it" This reverts commit 0bcba23ea0319d26552af1766273a61a5fd6c0cd. - - - - - 275348c4 by Raymond Toy at 2024-03-01T08:16:04-08:00 Revert "Remove unmark_static_vectors_in_use and inuse_static_vector_list" This reverts commit 081dcba913e565de7a0fbcf0ad68113fec78c1e7. - - - - - b4017a0b by Raymond Toy at 2024-03-01T08:16:22-08:00 Revert "Don't need inuse list anymore" This reverts commit 8ae61cf30fe5e2f09df91e90f814adf1c75fef20. - - - - - fed6581f by Raymond Toy at 2024-03-01T08:16:40-08:00 Revert "First cut at clearing the mark during phase 1" This reverts commit c3be06f3c38118aef6137dae1df956fdf689e93a. - - - - - 1 changed file: - src/lisp/gencgc.c Changes: ===================================== src/lisp/gencgc.c ===================================== @@ -2130,6 +2130,7 @@ static lispobj(*transother[256]) (lispobj object); static int (*sizetab[256]) (lispobj * where); static struct weak_pointer *weak_pointers; +static struct weak_pointer *inuse_static_vector_list; static struct scavenger_hook *scavenger_hooks = (struct scavenger_hook *) NIL; /* Like (ceiling x y), but y is constrained to be a power of two */ @@ -2734,7 +2735,7 @@ scav_static_vector(lispobj object) int static_p; if (debug_static_array_p) { - fprintf(stderr, "Possible static vector at %p. header = 0x%08lx\n", + fprintf(stderr, "Possible static vector at %p. header = 0x%lx\n", ptr, (unsigned long) header); } @@ -2745,9 +2746,9 @@ scav_static_vector(lispobj object) * setting the MSB of the header. And clear out any * possible visited bit. */ - *ptr = (header | STATIC_VECTOR_MARK_BIT); + *ptr = (header | STATIC_VECTOR_MARK_BIT) & ~STATIC_VECTOR_VISITED_BIT; if (debug_static_array_p) { - fprintf(stderr, "Scavenged static vector @%p, header = 0x%08lx\n", + fprintf(stderr, "Scavenged static vector @%p, header = 0x%lx\n", ptr, (unsigned long) header); } } @@ -5388,14 +5389,6 @@ scav_weak_pointer(lispobj * where, lispobj object) struct weak_pointer *this_wp = (struct weak_pointer *) where; if (this_wp->mark_bit == NIL) { - lispobj *header = (lispobj *) PTR(this_wp->value); - if (maybe_static_array_p(*header)) { - printf("Scavenge wp %p to static array %p header 0x%08lx\n", - this_wp, (lispobj *) this_wp->value, *header); - - *header &= ~STATIC_VECTOR_VISITED_BIT; - } - this_wp->mark_bit = T; this_wp->next = weak_pointers; weak_pointers = this_wp; @@ -5449,14 +5442,16 @@ push_weak_pointer(struct weak_pointer* wp, struct weak_pointer **list) } /* - * Phase 2: Process the list of weak pointers to unused static - * vectors. We find the unique static vectors and add each - * corresponding weak pointer to freeable_list. For the duplicates, - * the weak pointer is broken. + * Phase 2: Find the weak pointers to static vectors that are in use + * and not in use. The vectors that are in use are added to + * inuse_list. Those that are not in use are added to freeable_list. + * Only unique vectors are added to freeable list; a duplicate has its + * weak pointer to it broken. */ static void scan_static_vectors_2(struct weak_pointer *static_vector_list, - struct weak_pointer **freeable_list) + struct weak_pointer **freeable_list, + struct weak_pointer **inuse_list) { DPRINTF(debug_static_array_p, (stdout, "Phase 2: Find unused and unused static vectors\n")); @@ -5473,23 +5468,34 @@ scan_static_vectors_2(struct weak_pointer *static_vector_list, (stdout, " wp %p value %p header 0x%08lx\n", wp, (lispobj *) wp->value, *header)); - /* - * If we haven't seen this vector before, set the visited flag - * and add it to freeable_list. If we have visited this - * vector before, break the weak pointer. - */ - if ((*header & STATIC_VECTOR_VISITED_BIT) == 0) { + if ((*header & STATIC_VECTOR_MARK_BIT) != 0) { + /* + * Static vector is in use. Add this to the in-use list. + */ DPRINTF(debug_static_array_p, - (stdout, " Visit unused vector, add to freeable list\n")); + (stdout, " In-use vector; add to in-use list\n")); - *header |= STATIC_VECTOR_VISITED_BIT; - push_weak_pointer(wp, freeable_list); + push_weak_pointer(wp, inuse_list); } else { - DPRINTF(debug_static_array_p, - (stdout, " Already visited unused vector; break weak pointer\n")); + /* + * Static vector not in use. If we haven't seen this + * vector before, set the visited flag and add it to + * freeable_list. If we have visited this vector before, + * break the weak pointer. + */ + if ((*header & STATIC_VECTOR_VISITED_BIT) == 0) { + DPRINTF(debug_static_array_p, + (stdout, " Visit unused vector, add to freeable list\n")); - wp->value = NIL; - wp->broken = T; + *header |= STATIC_VECTOR_VISITED_BIT; + push_weak_pointer(wp, freeable_list); + } else { + DPRINTF(debug_static_array_p, + (stdout, " Already visited unused vector; break weak pointer\n")); + + wp->value = NIL; + wp->broken = T; + } } } @@ -5512,15 +5518,18 @@ scan_static_vectors_3(struct weak_pointer *freeable_list) lispobj *header = (lispobj *) PTR(wp->value); lispobj *static_array = (lispobj *) PTR(wp->value); + /* + * Invariant: weak pointer must not be broken + */ + gc_assert(wp->broken == NIL); + DPRINTF(debug_static_array_p, (stdout, " wp %p value %p header 0x%08lx\n", wp, (lispobj*) wp->value, *header)); /* - * Invariants: weak pointer must not be broken and the mark - * bit must be clear. + * Invariant: Mark bit must be clear */ - gc_assert(wp->broken == NIL); gc_assert(((*header & STATIC_VECTOR_MARK_BIT) == 0)); DPRINTF(debug_static_array_p, @@ -5536,6 +5545,49 @@ scan_static_vectors_3(struct weak_pointer *freeable_list) (stdout, "Phase 3 done\n")); } +/* + * Unmark all the vectors in inuse_list. This needs to be called at + * the end of GC to unmark any live static vectors so that for the + * next GC we can tell if the static vector is used or not. + * Otherwise, the vectors will always look as if they're in use + * because the mark bit is never changed. + */ +static void +unmark_static_vectors_in_use(struct weak_pointer *inuse_list) +{ + struct weak_pointer *wp; + + DPRINTF(debug_static_array_p, + (stdout, "Phase 4: unmark static vectors\n")); + + for (wp = inuse_list; wp; wp = wp->next) { + lispobj *header = (lispobj *) PTR(wp->value); + /* + * Invariant: the weak pointer must not be broken. + * + * Note that we can't assert that the static vector is marked + * because we can have more than one weak pointer to the same + * static vector. + */ + gc_assert(wp->broken == NIL); + + DPRINTF(debug_static_array_p, + (stdout, " wp %p value %p broken %d header 0x%08lx\n", + wp, (lispobj*) wp->value, wp->broken == T, *header)); + + /* Only clear if we haven't already */ + if ((*header & STATIC_VECTOR_MARK_BIT) != 0) { + DPRINTF(debug_static_array_p, + (stdout, " Clearing mark bit\n")); + + *header &= ~STATIC_VECTOR_MARK_BIT; + } + } + + DPRINTF(debug_static_array_p, + (stdout, "Phase 4 done\n")); +} + static void scan_static_vectors(struct weak_pointer *static_vector_list) { @@ -5543,10 +5595,11 @@ scan_static_vectors(struct weak_pointer *static_vector_list) struct weak_pointer *freeable_list = NULL; /* - * For each weak pointer, either break it, or add it to the - * freeable list because it points to a unique static vector. + * For each weak pointer, add it either the inuse list or the + * freeable list. */ - scan_static_vectors_2(static_vector_list, &freeable_list); + inuse_static_vector_list = NULL; + scan_static_vectors_2(static_vector_list, &freeable_list, &inuse_static_vector_list); /* Free the unused unique static vectors. */ scan_static_vectors_3(freeable_list); @@ -5564,18 +5617,15 @@ scan_weak_pointers(void) * * Also find any weak pointers to static vectors. This * destructively modifies the next slot of the weak pointer to - * chain all the weak pointers to unused static vectors together. + * chain all the weak pointers to static vectors together. */ DPRINTF(debug_static_array_p, (stdout, "Phase 1: Process weak pointers\n")); - while (weak_pointers) { - lispobj value; - lispobj *first_pointer; - - wp = pop_weak_pointer(&weak_pointers); - value = wp->value; - first_pointer = (lispobj *) PTR(value); + while (wp) { + struct weak_pointer *next = wp->next; + lispobj value = wp->value; + lispobj *first_pointer = (lispobj *) PTR(value); wp->mark_bit = NIL; if (Pointerp(value)) { @@ -5588,29 +5638,23 @@ scan_weak_pointers(void) } } else { /* The value may be a static vector */ - lispobj *header = (lispobj *) PTR(value); - - if (maybe_static_array_p(*header)) { - if (*header & STATIC_VECTOR_MARK_BIT) { - DPRINTF(debug_static_array_p, - (stdout, " Update status bits for live vector: wp %p value %p header 0x%08lx\n", - wp, (lispobj *) wp->value, *header)); - *header = (*header & ~STATIC_VECTOR_MARK_BIT) | STATIC_VECTOR_VISITED_BIT; - } else if ((*header & STATIC_VECTOR_VISITED_BIT) == 0) { - /* Only add the vector if it is unmarked and has not been visited */ - DPRINTF(debug_static_array_p, - (stdout, " Add static vector: wp %p value %p header 0x%08lx\n", - wp, (lispobj *) wp->value, *header)); - - push_weak_pointer(wp, &static_vector_list); - } + lispobj header = *(lispobj *) PTR(value); + + if (maybe_static_array_p(header)) { + + DPRINTF(debug_static_array_p, + (stdout, " Add static vector: wp %p value %p header 0x%08lx\n", + wp, (lispobj *) wp->value, header)); + + push_weak_pointer(wp, &static_vector_list); } else { DPRINTF(debug_static_array_p, (stdout, " Skip: wp %p value %p header 0x%08lx\n", - wp, (lispobj *) wp->value, *header)); + wp, (lispobj *) wp->value, header)); } } } + wp = next; } scan_static_vectors(static_vector_list); @@ -8346,6 +8390,13 @@ collect_garbage(unsigned last_gen) } scavenger_hooks = (struct scavenger_hook *) NIL; } + + /* + * Unmark any live static vectors. This needs to be done at the + * very end when all GCs are done, lest we accidentally free a + * static vector that was actually in use. + */ + unmark_static_vectors_in_use(inuse_static_vector_list); } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/1f8a6328ba47804660e181… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/1f8a6328ba47804660e181… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-243-weak-pointer-to-static-array] 6 commits: Apply review suggestions moving comments and renaming pop/push.
by Raymond Toy (＠rtoy) 01 Mar '24

01 Mar '24

Raymond Toy pushed to branch issue-243-weak-pointer-to-static-array at cmucl / cmucl Commits: e8f9cdd0 by Raymond Toy at 2024-02-25T07:21:01-08:00 Apply review suggestions moving comments and renaming pop/push. - - - - - c3be06f3 by Raymond Toy at 2024-02-25T07:53:27-08:00 First cut at clearing the mark during phase 1 As suggested in https://gitlab.common-lisp.net/cmucl/cmucl/-/merge_requests/188#note_13750 we can clear the mark bit and set the visited bit in phase 1. However, this means that we can only add free (unmarked) static vectors which also do not have the visited bit set. Tests show that this works as expected. - - - - - 8ae61cf3 by Raymond Toy at 2024-02-25T15:15:42-08:00 Don't need inuse list anymore Remove the inuse_list because the list of static vectors only contains static vectors that can be freed. Thus, update `scan_static_vectors_2` to remove the bit of code checking for live vectors and adding them to the inuse_list that no longer exists. - - - - - 081dcba9 by Raymond Toy at 2024-02-25T15:19:17-08:00 Remove unmark_static_vectors_in_use and inuse_static_vector_list Since we don't need to keep track of the live vectors anymore, get rid of the variable `inuse_static_vector_list` and the function `unmark_static_vectors_in_use`. - - - - - 0bcba23e by Raymond Toy at 2024-02-27T07:16:10-08:00 Clear static vector visited bit when scavenging a weak pointer to it When scavenging the weak pointer to a static vector, clear out the visited bit to prevent confusion when scanning all the weak pointers. This is needed because scanning causes use to unmark live vectors and set the visited bit so we don't add other weak pointers to the now unmarked (free) static vector. Undo the change in `scav_static_vector` so we just the mark bit and don't clear the visited bit. That whould happen when we scavenge the weak pointer. - - - - - 1f8a6328 by Raymond Toy at 2024-02-28T07:46:28-08:00 Update some comments; slightly modify scan_static_vectors to use pop - - - - - 1 changed file: - src/lisp/gencgc.c Changes: ===================================== src/lisp/gencgc.c ===================================== @@ -2130,7 +2130,6 @@ static lispobj(*transother[256]) (lispobj object); static int (*sizetab[256]) (lispobj * where); static struct weak_pointer *weak_pointers; -static struct weak_pointer *inuse_static_vector_list; static struct scavenger_hook *scavenger_hooks = (struct scavenger_hook *) NIL; /* Like (ceiling x y), but y is constrained to be a power of two */ @@ -2735,7 +2734,7 @@ scav_static_vector(lispobj object) int static_p; if (debug_static_array_p) { - fprintf(stderr, "Possible static vector at %p. header = 0x%lx\n", + fprintf(stderr, "Possible static vector at %p. header = 0x%08lx\n", ptr, (unsigned long) header); } @@ -2746,9 +2745,9 @@ scav_static_vector(lispobj object) * setting the MSB of the header. And clear out any * possible visited bit. */ - *ptr = (header | STATIC_VECTOR_MARK_BIT) & ~STATIC_VECTOR_VISITED_BIT; + *ptr = (header | STATIC_VECTOR_MARK_BIT); if (debug_static_array_p) { - fprintf(stderr, "Scavenged static vector @%p, header = 0x%lx\n", + fprintf(stderr, "Scavenged static vector @%p, header = 0x%08lx\n", ptr, (unsigned long) header); } } @@ -5389,6 +5388,14 @@ scav_weak_pointer(lispobj * where, lispobj object) struct weak_pointer *this_wp = (struct weak_pointer *) where; if (this_wp->mark_bit == NIL) { + lispobj *header = (lispobj *) PTR(this_wp->value); + if (maybe_static_array_p(*header)) { + printf("Scavenge wp %p to static array %p header 0x%08lx\n", + this_wp, (lispobj *) this_wp->value, *header); + + *header &= ~STATIC_VECTOR_VISITED_BIT; + } + this_wp->mark_bit = T; this_wp->next = weak_pointers; weak_pointers = this_wp; @@ -5418,39 +5425,38 @@ size_weak_pointer(lispobj * where) return WEAK_POINTER_NWORDS; } -static inline struct weak_pointer * -pop(struct weak_pointer **list) +/* + * Pop the first element from the list `list`, updating `list`, like + * CL POP. + */ +static struct weak_pointer * +pop_weak_pointer(struct weak_pointer **list) { - /* - * Pop the first element from the list `list`, updating `list`, like CL POP. - */ struct weak_pointer *wp = *list; *list = (*list)->next; return wp; } -static inline void -push(struct weak_pointer* wp, struct weak_pointer **list) +/* + * Push wp to the head of the list, updating list, like CL PUSH. + */ +static void +push_weak_pointer(struct weak_pointer* wp, struct weak_pointer **list) { - /* - * Push wp to the head of the list, updating list, like CL PUSH. - */ wp->next = *list; *list = wp; } /* - * Phase 2: Find the weak pointers to static vectors that are in use - * and not in use. The vectors that are in use are added to - * inuse_list. Those that are not in use are added to freeable_list. - * Only unique vectors are added to freeable list; a duplicate has its - * weak pointer to it broken. + * Phase 2: Process the list of weak pointers to unused static + * vectors. We find the unique static vectors and add each + * corresponding weak pointer to freeable_list. For the duplicates, + * the weak pointer is broken. */ static void scan_static_vectors_2(struct weak_pointer *static_vector_list, - struct weak_pointer **freeable_list, - struct weak_pointer **inuse_list) + struct weak_pointer **freeable_list) { DPRINTF(debug_static_array_p, (stdout, "Phase 2: Find unused and unused static vectors\n")); @@ -5460,41 +5466,30 @@ scan_static_vectors_2(struct weak_pointer *static_vector_list, lispobj *header; /* Pop weak pointer from the list */ - wp = pop(&static_vector_list); + wp = pop_weak_pointer(&static_vector_list); header = (lispobj *) PTR(wp->value); DPRINTF(debug_static_array_p, (stdout, " wp %p value %p header 0x%08lx\n", wp, (lispobj *) wp->value, *header)); - if ((*header & STATIC_VECTOR_MARK_BIT) != 0) { - /* - * Static vector is in use. Add this to the in-use list. - */ + /* + * If we haven't seen this vector before, set the visited flag + * and add it to freeable_list. If we have visited this + * vector before, break the weak pointer. + */ + if ((*header & STATIC_VECTOR_VISITED_BIT) == 0) { DPRINTF(debug_static_array_p, - (stdout, " In-use vector; add to in-use list\n")); + (stdout, " Visit unused vector, add to freeable list\n")); - push(wp, inuse_list); + *header |= STATIC_VECTOR_VISITED_BIT; + push_weak_pointer(wp, freeable_list); } else { - /* - * Static vector not in use. If we haven't seen this - * vector before, set the visited flag and add it to - * freeable_list. If we have visited this vector before, - * break the weak pointer. - */ - if ((*header & STATIC_VECTOR_VISITED_BIT) == 0) { - DPRINTF(debug_static_array_p, - (stdout, " Visit unused vector, add to freeable list\n")); - - *header |= STATIC_VECTOR_VISITED_BIT; - push(wp, freeable_list); - } else { - DPRINTF(debug_static_array_p, - (stdout, " Already visited unused vector; break weak pointer\n")); + DPRINTF(debug_static_array_p, + (stdout, " Already visited unused vector; break weak pointer\n")); - wp->value = NIL; - wp->broken = T; - } + wp->value = NIL; + wp->broken = T; } } @@ -5517,18 +5512,15 @@ scan_static_vectors_3(struct weak_pointer *freeable_list) lispobj *header = (lispobj *) PTR(wp->value); lispobj *static_array = (lispobj *) PTR(wp->value); - /* - * Invariant: weak pointer must not be broken - */ - gc_assert(wp->broken == NIL); - DPRINTF(debug_static_array_p, (stdout, " wp %p value %p header 0x%08lx\n", wp, (lispobj*) wp->value, *header)); /* - * Invariant: Mark bit must be clear + * Invariants: weak pointer must not be broken and the mark + * bit must be clear. */ + gc_assert(wp->broken == NIL); gc_assert(((*header & STATIC_VECTOR_MARK_BIT) == 0)); DPRINTF(debug_static_array_p, @@ -5544,49 +5536,6 @@ scan_static_vectors_3(struct weak_pointer *freeable_list) (stdout, "Phase 3 done\n")); } -/* - * Unmark all the vectors in inuse_list. This needs to be called at - * the end of GC to unmark any live static vectors so that for the - * next GC we can tell if the static vector is used or not. - * Otherwise, the vectors will always look as if they're in use - * because the mark bit is never changed. - */ -static void -unmark_static_vectors_in_use(struct weak_pointer *inuse_list) -{ - struct weak_pointer *wp; - - DPRINTF(debug_static_array_p, - (stdout, "Phase 4: unmark static vectors\n")); - - for (wp = inuse_list; wp; wp = wp->next) { - lispobj *header = (lispobj *) PTR(wp->value); - /* - * Invariant: the weak pointer must not be broken. - * - * Note that we can't assert that the static vector is marked - * because we can have more than one weak pointer to the same - * static vector. - */ - gc_assert(wp->broken == NIL); - - DPRINTF(debug_static_array_p, - (stdout, " wp %p value %p broken %d header 0x%08lx\n", - wp, (lispobj*) wp->value, wp->broken == T, *header)); - - /* Only clear if we haven't already */ - if ((*header & STATIC_VECTOR_MARK_BIT) != 0) { - DPRINTF(debug_static_array_p, - (stdout, " Clearing mark bit\n")); - - *header &= ~STATIC_VECTOR_MARK_BIT; - } - } - - DPRINTF(debug_static_array_p, - (stdout, "Phase 4 done\n")); -} - static void scan_static_vectors(struct weak_pointer *static_vector_list) { @@ -5594,11 +5543,10 @@ scan_static_vectors(struct weak_pointer *static_vector_list) struct weak_pointer *freeable_list = NULL; /* - * For each weak pointer, add it either the inuse list or the - * freeable list. + * For each weak pointer, either break it, or add it to the + * freeable list because it points to a unique static vector. */ - inuse_static_vector_list = NULL; - scan_static_vectors_2(static_vector_list, &freeable_list, &inuse_static_vector_list); + scan_static_vectors_2(static_vector_list, &freeable_list); /* Free the unused unique static vectors. */ scan_static_vectors_3(freeable_list); @@ -5616,15 +5564,18 @@ scan_weak_pointers(void) * * Also find any weak pointers to static vectors. This * destructively modifies the next slot of the weak pointer to - * chain all the weak pointers to static vectors together. + * chain all the weak pointers to unused static vectors together. */ DPRINTF(debug_static_array_p, (stdout, "Phase 1: Process weak pointers\n")); - while (wp) { - struct weak_pointer *next = wp->next; - lispobj value = wp->value; - lispobj *first_pointer = (lispobj *) PTR(value); + while (weak_pointers) { + lispobj value; + lispobj *first_pointer; + + wp = pop_weak_pointer(&weak_pointers); + value = wp->value; + first_pointer = (lispobj *) PTR(value); wp->mark_bit = NIL; if (Pointerp(value)) { @@ -5637,23 +5588,29 @@ scan_weak_pointers(void) } } else { /* The value may be a static vector */ - lispobj header = *(lispobj *) PTR(value); - - if (maybe_static_array_p(header)) { - - DPRINTF(debug_static_array_p, - (stdout, " Add static vector: wp %p value %p header 0x%08lx\n", - wp, (lispobj *) wp->value, header)); - - push(wp, &static_vector_list); + lispobj *header = (lispobj *) PTR(value); + + if (maybe_static_array_p(*header)) { + if (*header & STATIC_VECTOR_MARK_BIT) { + DPRINTF(debug_static_array_p, + (stdout, " Update status bits for live vector: wp %p value %p header 0x%08lx\n", + wp, (lispobj *) wp->value, *header)); + *header = (*header & ~STATIC_VECTOR_MARK_BIT) | STATIC_VECTOR_VISITED_BIT; + } else if ((*header & STATIC_VECTOR_VISITED_BIT) == 0) { + /* Only add the vector if it is unmarked and has not been visited */ + DPRINTF(debug_static_array_p, + (stdout, " Add static vector: wp %p value %p header 0x%08lx\n", + wp, (lispobj *) wp->value, *header)); + + push_weak_pointer(wp, &static_vector_list); + } } else { DPRINTF(debug_static_array_p, (stdout, " Skip: wp %p value %p header 0x%08lx\n", - wp, (lispobj *) wp->value, header)); + wp, (lispobj *) wp->value, *header)); } } } - wp = next; } scan_static_vectors(static_vector_list); @@ -8389,13 +8346,6 @@ collect_garbage(unsigned last_gen) } scavenger_hooks = (struct scavenger_hook *) NIL; } - - /* - * Unmark any live static vectors. This needs to be done at the - * very end when all GCs are done, lest we accidentally free a - * static vector that was actually in use. - */ - unmark_static_vectors_in_use(inuse_static_vector_list); } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/f1621d3a52aeff4185614b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/f1621d3a52aeff4185614b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0