Fix trim! race where concurrent adds can violate n <= vec-length.

trim! reads n at the top of its loop, then uses that stale n to size
the new smaller vec. If concurrent adds push n past the target capacity
without changing vec (because the old vec has room), trim!'s CAS on vec
succeeds, installing a vec too small for the current n.

Fix: re-read n before creating the new vec and abort if n > new-cap.
As a safety net, after CAS succeeds, verify n <= new-cap and grow back
via ensure-free-space! if a concurrent add slipped through.

Also switch maybe-sleep to tagged form so each stress test activates
only the sleep point relevant to the invariant it tests.

Author: samth

data-lib/data/gvector.rkt

@@ -30,6 +30,12 @@
 ;;   Without CAS, thread T1 could install a small vector while T2
 ;;   installs a large n, violating the invariant.
 ;;   Similarly, trim! uses CAS when installing a smaller vector.
+;;
+;; - n re-read in trim!:
+;;   trim! re-reads n before creating the smaller vector. If n has
+;;   grown past the target capacity (from concurrent adds that didn't
+;;   need to resize vec), trim! aborts. After CAS succeeds, trim!
+;;   checks again and grows back via ensure-free-space! if needed.
 (require (for-syntax racket/base
                      syntax/contract
                      syntax/for-body)
@@ -43,14 +49,19 @@
          racket/struct)
 
 ;; When the environment variable GVECTOR_SLEEP is set at compile time,
-;; (maybe-sleep) expands to (sleep 0), widening race windows so that
-;; stress tests can exercise the CAS retry paths. When unset, it
-;; expands to (void) with no runtime cost.
+;; (maybe-sleep tag) expands to (sleep 0.01), widening the race window
+;; at the specified point so stress tests can exercise CAS retry paths.
+;; GVECTOR_SLEEP=1 activates all sleep points; GVECTOR_SLEEP=tag
+;; activates only the matching point. When unset, expands to (void).
 (define-syntax (maybe-sleep stx)
   (syntax-case stx ()
-    [(_) (if (getenv "GVECTOR_SLEEP")
-	     #'(sleep 0)
-	     #'(void))]))
+    [(_ tag)
+     (let ([env (getenv "GVECTOR_SLEEP")])
+       (if (and env
+                (or (equal? env "1")
+                    (equal? env (symbol->string (syntax-e #'tag)))))
+           #'(sleep 0.01)
+           #'(void)))]))
 
 (define DEFAULT-CAPACITY 10)
 
@@ -103,7 +114,7 @@
   (define (ensure-free-space! gv needed-free-space)
     (let loop ()
       (define v (gvector-vec gv))
-      (maybe-sleep) ; widen window for concurrent growers
+      (maybe-sleep ensure-space) ; widen window for concurrent growers
       (define new-v (grow-vec v (gvector-n gv) needed-free-space))
       (when new-v
 	;; CAS: only install if vec hasn't been replaced by another thread.
@@ -119,7 +130,7 @@
     (begin (define n (gvector-n gv))
 	   (define v
 	     (let loop ([v1 (gvector-vec gv)])
-	       (maybe-sleep) ; widen window for concurrent growers
+	       (maybe-sleep ensure-space) ; widen window for concurrent growers
 	       (define v2 (grow-vec v1 n needed-free-space))
 	       (cond [(not v2) v1]   ; already big enough
 		     ;; CAS: install new vec, retry if another thread changed it
@@ -170,24 +181,34 @@
 
 (define (trim! gv)
   ;; Invariant (1): n has already been decremented before calling trim!,
-  ;; so installing a smaller vec maintains n <= vector-length(vec).
+  ;; so installing a smaller vec maintains n <= vector-length(vec),
+  ;; provided n hasn't grown since we read it. We re-read n before
+  ;; creating the new vec to abort if concurrent adds have grown n past
+  ;; our target capacity. After CAS, we verify the invariant and grow
+  ;; back if a concurrent add slipped through.
   (let loop ()
-    (define n (gvector-n gv))
+    (define n0 (gvector-n gv))
     (define v (gvector-vec gv))
-    (maybe-sleep) ; widen window for concurrent add/trim
+    (maybe-sleep trim) ; widen window for concurrent add/trim
     (define cap (vector-length v))
     (define new-cap
       (let shrink ([new-cap cap])
-	(cond [(and (>= new-cap (* SHRINK-ON-FACTOR n))
+	(cond [(and (>= new-cap (* SHRINK-ON-FACTOR n0))
 		    (>= (quotient new-cap SHRINK-BY-FACTOR) SHRINK-MIN))
 	       (shrink (quotient new-cap SHRINK-BY-FACTOR))]
 	      [else new-cap])))
     (when (< new-cap cap)
-      (define new-v (make-vector new-cap #f))
-      (vector-copy! new-v 0 v 0 n)
-      ;; CAS: only install smaller vec if no other thread replaced vec
-      (unless (unsafe-struct*-cas! gv 0 v new-v)
-	(loop)))))
+      ;; Re-read n: if concurrent adds grew n past new-cap, abort.
+      (define n (gvector-n gv))
+      (when (<= n new-cap)
+	(define new-v (make-vector new-cap #f))
+	(vector-copy! new-v 0 v 0 n)
+	;; CAS: only install smaller vec if no other thread replaced vec
+	(when (unsafe-struct*-cas! gv 0 v new-v)
+	  ;; Safety net: if a concurrent add pushed n past new-cap
+	  ;; between our re-read and the CAS, grow back immediately.
+	  (when (> (gvector-n gv) new-cap)
+	    (ensure-free-space! gv 0)))))))
 
 ;; SLOW!
 (define (gvector-remove! gv index)
@@ -220,7 +241,7 @@
   (unless (exact-nonnegative-integer? index)
     (raise-type-error 'gvector-ref "exact nonnegative integer" index))
   (let ([v (gvector-vec gv)])
-    (maybe-sleep) ; widen window for concurrent remove/trim
+    (maybe-sleep ref) ; widen window for concurrent remove/trim
     (if (< index (gvector-n gv))
         (unsafe-vector*-ref v index)
         (cond [(eq? default none)

data-test/tests/data/gvector-sleep-stress.rkt

@@ -1,106 +1,194 @@
 #lang racket/base
-;; Stress tests that recompile data/gvector with GVECTOR_SLEEP=1 to
-;; widen race windows, exercising the CAS retry paths. The gvector
-;; module is loaded in a fresh namespace with compiled file loading
-;; disabled, so the sleep-enabled version is never cached.
+;; Stress tests that recompile data/gvector with GVECTOR_SLEEP set to
+;; widen specific race windows. Each test activates only the sleep
+;; point relevant to the invariant it tests, so other operations
+;; remain fast. The gvector module is loaded via dynamic-require with
+;; compiled file loading disabled, so the sleep-enabled version is
+;; never cached.
 
-(require rackunit)
+(require rackunit
+         racket/unsafe/ops)
 
-(define (dr sym)
-  ;; Set the env var so the compile-time switch in gvector.rkt enables sleeps,
-  ;; and disable loading compiled files so gvector.rkt is recompiled fresh.
-  (putenv "GVECTOR_SLEEP" "1")
-  (begin0
-    (parameterize ([use-compiled-file-paths '()])
-      (dynamic-require 'data/gvector sym))
-    (putenv "GVECTOR_SLEEP" "")))
+(define (make-gvector-ns tag)
+  ;; Set GVECTOR_SLEEP to the tag so only the matching maybe-sleep
+  ;; expands to (sleep 0.01). Load in a fresh namespace with compiled
+  ;; files disabled. Returns a lookup function for that namespace.
+  (putenv "GVECTOR_SLEEP" tag)
+  (define ns (make-base-namespace))
+  (parameterize ([use-compiled-file-paths '()]
+		 [current-namespace ns])
+    (dynamic-require 'data/gvector #f))
+  (putenv "GVECTOR_SLEEP" "")
+  (lambda (sym)
+    (parameterize ([use-compiled-file-paths '()]
+		   [current-namespace ns])
+      (dynamic-require 'data/gvector sym))))
 
-(define gvector?* (dr 'gvector?))
-(define make-gvector* (dr 'make-gvector))
-(define gvector-add!* (dr 'gvector-add!))
-(define gvector-ref* (dr 'gvector-ref))
-(define gvector-set!* (dr 'gvector-set!))
-(define gvector-count* (dr 'gvector-count))
-(define gvector-remove-last!* (dr 'gvector-remove-last!))
+(define ref-ns (make-gvector-ns "ref"))
+(define trim-ns (make-gvector-ns "trim"))
+(define es-ns (make-gvector-ns "ensure-space"))
 
-;; Test: parallel adds don't violate n <= vector-length(vec)
-;; This is the exact scenario from rmculpepper's review comment:
-;; two concurrent add! calls both snapshot the same n and vec,
-;; both create new vectors of different sizes.
-;; Without CAS, the smaller vector could win the vec write while
-;; the larger n wins the n write.
-(test-case "sleep-stress: parallel add invariant"
-  (for ([iter (in-range 10)])
+;; Test 1: vec-before-n ordering in gvector-ref.
+;; Only gvector-ref sleeps (tag "ref"); removes run at full speed.
+;; A reader reads vec, sleeps 10ms, then reads n. During the sleep,
+;; many concurrent removes can decrement n and trigger trim! which
+;; replaces vec with a shorter one. With correct vec-before-n ordering,
+;; the reader holds the old (large) vec and reads the new (small) n —
+;; safe. With wrong n-before-vec ordering, the reader reads the old
+;; (large) n and the new (small) vec — out of bounds.
+(test-case "sleep-stress: ref + remove (vec-before-n ordering)"
+  (define make-gvector* (ref-ns 'make-gvector))
+  (define gvector-add!* (ref-ns 'gvector-add!))
+  (define gvector-ref* (ref-ns 'gvector-ref))
+  (define gvector-count* (ref-ns 'gvector-count))
+  (define gvector-remove-last!* (ref-ns 'gvector-remove-last!))
+  (for ([iter (in-range 5)])
     (define gv (make-gvector*))
-    ;; Fill to capacity to force resize on next add
-    (for ([i 10])
+    ;; Fill with enough elements that removing triggers trim!
+    ;; trim! fires when cap >= 4*n, so starting at n=1000 with
+    ;; cap=1024, after 744 removes n=256 and cap=1024 >= 4*256,
+    ;; so trim! shrinks to 512. Further removes trigger more shrinks.
+    (for ([i 1000])
       (gvector-add!* gv i))
-    (define pool (make-parallel-thread-pool 2))
-    ;; T1 adds 1 item (needs vec of ~20), T2 adds many (needs vec of ~1010)
-    (define t1 (thread #:pool pool (lambda () (gvector-add!* gv 'from-t1))))
-    (define t2
-      (thread #:pool pool
-              (lambda ()
-                (for ([i (in-range 1000)])
-                  (gvector-add!* gv i)))))
-    (thread-wait t1)
-    (thread-wait t2)
-    (parallel-thread-pool-close pool)
-    ;; The key check: n must not exceed vector length
-    (define count (gvector-count* gv))
-    (check-true (> count 10) (format "iter ~a: count should be > 10, got ~a" iter count))))
-
-;; Test: parallel add + ref doesn't read garbage
-;; With sleeps between vec-read and n-read in gvector-ref,
-;; this exercises the vec-before-n ordering.
-(test-case "sleep-stress: parallel add + ref"
-  (for ([iter (in-range 10)])
-    (define gv (make-gvector*))
-    (define stop? #f)
     (define pool (make-parallel-thread-pool 4))
-    (define writers
-      (for/list ([t (in-range 2)])
-        (thread #:pool pool
-                (lambda ()
-                  (for ([i (in-range 500)])
-                    (gvector-add!* gv i))))))
+    (define stop? #f)
+    (define found-garbage? #f)
+    ;; Readers that access near the end of the gvector.
+    ;; Each ref takes ~10ms due to the sleep.
+    ;; Check that returned values are valid (fixnums 0-999 or #f).
     (define readers
       (for/list ([t (in-range 2)])
         (thread #:pool pool
                 (lambda ()
                   (let loop ()
                     (define n (gvector-count* gv))
                     (when (> n 0)
-                      (gvector-ref* gv (sub1 n) #f))
+                      (define val (gvector-ref* gv (sub1 n) #f))
+                      (when (and val (not (and (fixnum? val) (<= 0 val 999))))
+                        (set! found-garbage? #t)))
                     (unless stop?
                       (loop)))))))
-    (for-each thread-wait writers)
+    ;; Removers run at full speed (no sleep in remove/trim)
+    (define removers
+      (for/list ([t (in-range 2)])
+        (thread #:pool pool
+                (lambda ()
+                  (for ([_ (in-range 400)])
+                    (with-handlers ([exn:fail? void])
+                      (gvector-remove-last!* gv)))))))
+    (for-each thread-wait removers)
     (set! stop? #t)
     (parallel-thread-pool-close pool)
-    (for-each thread-wait readers)))
+    (for-each thread-wait readers)
+    (check-false found-garbage?
+                 (format "iter ~a: read garbage from beyond vector bounds" iter))))
 
-;; Test: parallel add + remove doesn't crash
-;; With sleeps in both trim! and gvector-ref, this exercises
-;; the shrink path where vec is replaced with a shorter vector.
-(test-case "sleep-stress: parallel add + remove"
-  (for ([iter (in-range 10)])
+;; Test 2: trim! under concurrent add pressure.
+;; Only trim! sleeps (tag "trim"); adds run at full speed.
+;; Exercises two protections in trim!:
+;; (a) CAS on vec: if a grower installed a larger vec during the sleep,
+;;     CAS fails and trim! retries rather than clobbering.
+;; (b) n re-read: if concurrent adds grew n past the target capacity
+;;     without changing vec (because it had room), trim! aborts.
+;; The invariant violation (n > vector-length(vec)) is transient and
+;; hard to observe because adds immediately re-grow, so the test
+;; primarily verifies no crashes or memory errors occur.
+(test-case "sleep-stress: add + remove (trim! CAS)"
+  (define make-gvector* (trim-ns 'make-gvector))
+  (define gvector-add!* (trim-ns 'gvector-add!))
+  (define gvector-ref* (trim-ns 'gvector-ref))
+  (define gvector-count* (trim-ns 'gvector-count))
+  (define gvector-remove-last!* (trim-ns 'gvector-remove-last!))
+  (for ([iter (in-range 5)])
     (define gv (make-gvector*))
-    (for ([i 200])
+    ;; Start with enough elements that removing triggers trim!
+    ;; n=1000, cap=1024. After ~744 removes, cap >= 4*n triggers shrink.
+    (for ([i 1000])
       (gvector-add!* gv i))
-    (define pool (make-parallel-thread-pool 4))
+    (define pool (make-parallel-thread-pool 6))
+    (define stop? #f)
+    (define found-garbage? #f)
+    ;; Writers add continuously so they're active during trim!'s sleep.
+    ;; Each trim! sleeps 10ms; writers must be adding during that window
+    ;; so they push n past trim!'s target capacity.
     (define writers
       (for/list ([t (in-range 2)])
         (thread #:pool pool
                 (lambda ()
-                  (for ([i (in-range 200)])
-                    (gvector-add!* gv i))))))
+                  (let loop ()
+                    (with-handlers ([exn:fail? void])
+                      (gvector-add!* gv 42))
+                    (unless stop?
+                      (loop)))))))
+    ;; Checkers continuously verify n <= vector-length(vec) directly.
+    ;; gvector-ref can't detect this because vec-before-n ordering
+    ;; makes it safe even when the invariant is transiently violated.
+    ;; We read the struct fields directly via unsafe-struct*-ref
+    ;; (vec=field 0, n=field 1) to observe the transient violation.
+    (define readers
+      (for/list ([t (in-range 2)])
+        (thread #:pool pool
+                (lambda ()
+                  (let loop ()
+                    ;; Read vec first, then n. If trim! just installed
+                    ;; a small vec and n is still large from adds,
+                    ;; we see v=small, n=large => violation.
+                    (define v (unsafe-struct*-ref gv 0))
+                    (define n (unsafe-struct*-ref gv 1))
+                    (when (> n (vector-length v))
+                      (set! found-garbage? #t))
+                    (unless stop?
+                      (loop)))))))
+    ;; Removers trigger trim! which sleeps between reading vec and CAS
     (define removers
       (for/list ([t (in-range 2)])
         (thread #:pool pool
                 (lambda ()
-                  (for ([_ (in-range 100)])
+                  (for ([_ (in-range 400)])
                     (with-handlers ([exn:fail? void])
                       (gvector-remove-last!* gv)))))))
+    (for-each thread-wait removers)
+    (set! stop? #t)
     (for-each thread-wait writers)
+    (for-each thread-wait readers)
     (parallel-thread-pool-close pool)
-    (for-each thread-wait removers)))
+    (check-false found-garbage?
+                 (format "iter ~a: read garbage from beyond vector bounds" iter))))
+
+;; Test 3: CAS in define/ensure-space!.
+;; Only ensure-space! sleeps (tag "ensure-space"); other ops fast.
+;; Two growers both read the same vec, sleep 10ms, then both try to
+;; create and install new vectors. With CAS, only one succeeds and
+;; the other retries. Without CAS, both install and the last writer
+;; wins — which may be the thread creating the smaller vec while the
+;; other thread increments n past that vec's length.
+;; Note: see comment at test about reliable detection.
+(test-case "sleep-stress: concurrent add (ensure-space! CAS)"
+  (define make-gvector* (es-ns 'make-gvector))
+  (define gvector-add!* (es-ns 'gvector-add!))
+  (define gvector-ref* (es-ns 'gvector-ref))
+  (define gvector-count* (es-ns 'gvector-count))
+  (for ([iter (in-range 5)])
+    (define gv (make-gvector*))
+    ;; Fill to capacity to force resize on next add
+    (for ([i 10])
+      (gvector-add!* gv i))
+    (define pool (make-parallel-thread-pool 2))
+    ;; Use symbols so we can distinguish from garbage memory
+    (define sentinel (gensym 'val))
+    (define t1 (thread #:pool pool (lambda () (gvector-add!* gv sentinel))))
+    (define t2
+      (thread #:pool pool
+              (lambda () (apply gvector-add!* gv (build-list 100 (lambda (_) sentinel))))))
+    (thread-wait t1)
+    (thread-wait t2)
+    (parallel-thread-pool-close pool)
+    ;; Verify invariant by reading every element.
+    ;; With a missing CAS, this may read garbage beyond the vector.
+    ;; However, detection is not guaranteed since the thread creating
+    ;; the larger vector tends to win the vec write.
+    (define count (gvector-count* gv))
+    (for ([i (in-range count)])
+      (define val (gvector-ref* gv i))
+      (check-true (or (fixnum? val) (eq? val sentinel))
+                  (format "iter ~a: garbage at index ~a: ~v" iter i val)))))