add vector-cas! and unsafe-vector*-cas!

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.11.0.1")
+(define version "6.11.0.2")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/reference/unsafe.scrbl

@@ -246,15 +246,17 @@ Unsafe versions of @racket[unbox] and @racket[set-box!], where the
 @defproc[(unsafe-vector*-length [v (and/c vector? (not/c impersonator?))]) fixnum?]
 @defproc[(unsafe-vector*-ref [v (and/c vector? (not/c impersonator?))] [k fixnum?]) any/c]
 @defproc[(unsafe-vector*-set! [v (and/c vector? (not/c impersonator?))] [k fixnum?] [val any/c]) void?]
+@defproc[(unsafe-vector*-cas! [v (and/c vector? (not/c impersonator?))] [k fixnum?] [val any/c] [val any/c]) boolean?]
 )]{
 
-Unsafe versions of @racket[vector-length], @racket[vector-ref], and
-@racket[vector-set!], where the @schemeidfont{vector*} variants can be
+Unsafe versions of @racket[vector-length], @racket[vector-ref],
+@racket[vector-set!], and @racket[vector-cas!], where the @schemeidfont{vector*} variants can be
 faster but do not work on @tech{impersonators}.
 
 A vector's size can never be larger than a @tech{fixnum}, so even
-@racket[vector-length] always returns a fixnum.}
+@racket[vector-length] always returns a fixnum.
 
+@history[#:changed "6.11.0.2" @elem{Added @racket[unsafe-vector*-cas!].}]}
 
 @deftogether[(
 @defproc[(unsafe-string-length [str string?]) fixnum?]

pkgs/racket-doc/scribblings/reference/vectors.scrbl

@@ -72,6 +72,17 @@ slot is position @racket[0], and the last slot is one less than
 
 Updates the slot @racket[pos] of @racket[vec] to contain @racket[v].}
 
+@defproc[(vector-cas! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))]
+                      [pos exact-nonnegative-integer?]
+                      [v any/c]
+                      [v any/c])
+         boolean?]{
+
+Compare and set operation for vectors. See @racket[box-cas!].
+
+@history[#:added "6.11.0.2"]
+}
+
 @defproc[(vector->list [vec vector?]) list?]{
 
 Returns a list with the same length and elements as @racket[vec].}

pkgs/racket-test-core/tests/racket/sync.rktl

@@ -1387,6 +1387,41 @@
   (err/rt-test (box-cas! (chaperone-box (box 1) g g) 1 2))
   (err/rt-test (box-cas! (box-immutable 1) 1 2)))
 
+;; ----------------------------------------
+;; vector-cas! tests
+
+;; successful cas
+(let ()
+  (define v (vector #f #t))
+  (test #t vector-cas! v 0 #f #t)
+  (test #t vector-ref v 0)
+  (test #t vector-cas! v 1 #t #f)
+  (test #f vector-ref v 1))
+
+;; unsuccessful cas
+(let ()
+  (define v (vector #f #t))
+  (test #f vector-cas! v 0 #t #f)
+  (test #f vector-ref v 0)
+  (test #f vector-cas! v 1 #f #t)
+  (test #t vector-ref v 1))
+
+;; cas using allocated data
+(let ()
+  (define v (vector '()))
+  (define x (cons 1 (vector-ref v 0)))
+  (test #t vector-cas! v 0 '() x)
+  (test x vector-ref v 0)
+  (test #t vector-cas! v 0 x '())
+  (test '() vector-ref v 0)
+  (test #f vector-cas! v 0 x '())
+  (test '() vector-ref v 0))
+
+(let ([g (lambda (x y) y)])
+  (err/rt-test (vector-cas! (impersonate-vector (vector 1) g g) 0 1 2))
+  (err/rt-test (vector-cas! (chaperone-vector (vector 1) g g) 0 1 2))
+  (err/rt-test (vector-cas! (vector-immutable 1) 0 1 2)))
+
 ;; ----------------------------------------
 
 (err/rt-test (sync/enable-break #f (make-semaphore 1)))

pkgs/racket-test-core/tests/racket/unsafe.rktl

@@ -347,6 +347,20 @@
               #:post (lambda (x) (list x (unbox b2)))
               #:literal-ok? #f))
 
+  (let ([v (vector 0 1)])
+    ;; success
+    (test-tri (list #true 1)
+              '(lambda (v ov nv) (unsafe-vector*-cas! v 0 ov nv)) v 0 1
+              #:pre (lambda () (vector-set! v 0 0))
+              #:post (lambda (x) (list x (vector-ref v 0)))
+              #:literal-ok? #f)
+    ;; failure
+    (test-tri (list #false 1)
+              '(lambda (v ov nv) (unsafe-vector*-cas! v 1 ov nv)) v 0 7
+              #:pre (lambda () (vector-set! v 1 1))
+              #:post (lambda (x) (list x (vector-ref v 1)))
+              #:literal-ok? #f))
+
   (for ([star (list values (add-star "vector"))])
     (test-bin 5 (star 'unsafe-vector-ref) #(1 5 7) 1)
     (test-un 3 (star 'unsafe-vector-length) #(1 5 7))

racket/src/racket/src/list.c

@@ -1874,12 +1874,12 @@ XFORM_SKIP_PROC
    */
 
   if (!SCHEME_MUTABLE_BOXP(box)) {
-    scheme_wrong_contract("box-cas!", "(and/c box? (not immutable?) (not impersonator?))", 0, 1, &box);
+    scheme_wrong_contract("box-cas!", "(and/c box? (not/c immutable?) (not/c impersonator?))", 0, 1, &box);
   }
 
 #ifdef MZ_USE_FUTURES
-  return mzrt_cas((volatile size_t *)(&SCHEME_BOX_VAL(box)), 
-		  (size_t)ov, (size_t)nv)
+  return mzrt_cas((volatile uintptr_t *)(&SCHEME_BOX_VAL(box)),
+                  (uintptr_t)ov, (uintptr_t)nv)
     ? scheme_true : scheme_false;
 #else
   /* For cooperative threading, no atomicity required */

racket/src/racket/src/schminc.h

@@ -14,8 +14,8 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1159
-#define EXPECTED_UNSAFE_COUNT 148
+#define EXPECTED_PRIM_COUNT 1160
+#define EXPECTED_UNSAFE_COUNT 149
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45
 #define EXPECTED_FUTURES_COUNT 15

racket/src/racket/src/schpriv.h

@@ -532,6 +532,7 @@ extern Scheme_Object *scheme_make_vector_proc;
 extern Scheme_Object *scheme_vector_immutable_proc;
 extern Scheme_Object *scheme_vector_ref_proc;
 extern Scheme_Object *scheme_vector_set_proc;
+extern Scheme_Object *scheme_vector_cas_proc;
 extern Scheme_Object *scheme_list_to_vector_proc;
 extern Scheme_Object *scheme_unsafe_vector_length_proc;
 extern Scheme_Object *scheme_unsafe_struct_ref_proc;
@@ -4435,6 +4436,7 @@ Scheme_Object *scheme_checked_set_mcar (int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_set_mcdr (int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_checked_vector_set(int argc, Scheme_Object **argv);
+Scheme_Object *scheme_checked_vector_cas(int argc, Scheme_Object **argv);
 Scheme_Object *scheme_string_length(Scheme_Object *v);
 Scheme_Object *scheme_string_eq_2(Scheme_Object *str1, Scheme_Object *str2);
 Scheme_Object *scheme_checked_string_ref(int argc, Scheme_Object *argv[]);

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.11.0.1"
+#define MZSCHEME_VERSION "6.11.0.2"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 11
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 1
+#define MZSCHEME_VERSION_W 2
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/vector.c

@@ -33,6 +33,7 @@ READ_ONLY Scheme_Object *scheme_make_vector_proc;
 READ_ONLY Scheme_Object *scheme_vector_immutable_proc;
 READ_ONLY Scheme_Object *scheme_vector_ref_proc;
 READ_ONLY Scheme_Object *scheme_vector_set_proc;
+READ_ONLY Scheme_Object *scheme_vector_cas_proc;
 READ_ONLY Scheme_Object *scheme_list_to_vector_proc;
 READ_ONLY Scheme_Object *scheme_unsafe_vector_length_proc;
 READ_ONLY Scheme_Object *scheme_unsafe_string_length_proc;
@@ -64,6 +65,7 @@ static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_vector_star_len (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_vector_star_ref (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_vector_star_set (int argc, Scheme_Object *argv[]);
+static Scheme_Object *unsafe_vector_star_cas (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_struct_ref (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_struct_set (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_struct_star_ref (int argc, Scheme_Object *argv[]);
@@ -133,6 +135,13 @@ scheme_init_vector (Scheme_Env *env)
   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("vector-set!", p, env);
 
+  REGISTER_SO(scheme_vector_cas_proc);
+  p = scheme_make_noncm_prim(scheme_checked_vector_cas,
+                             "vector-cas!",
+                             4, 4);
+  scheme_vector_cas_proc = p;
+  scheme_add_global_constant("vector-cas!", p, env);
+
   scheme_add_global_constant("vector->list", 
 			     scheme_make_immed_prim(vector_to_list, 
 						    "vector->list", 
@@ -232,6 +241,9 @@ scheme_init_unsafe_vector (Scheme_Env *env)
   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
   scheme_add_global_constant("unsafe-vector*-set!", p, env);  
 
+  p = scheme_make_immed_prim(unsafe_vector_star_cas, "unsafe-vector*-cas!", 4, 4);
+  scheme_add_global_constant("unsafe-vector*-cas!", p, env);
+
   REGISTER_SO(scheme_unsafe_struct_ref_proc);
   p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2);
   scheme_unsafe_struct_ref_proc = p;
@@ -633,6 +645,25 @@ scheme_checked_vector_set(int argc, Scheme_Object *argv[])
   return scheme_void;
 }
 
+Scheme_Object *
+scheme_checked_vector_cas(int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *vec = argv[0];
+  intptr_t i, len;
+
+  if (!SCHEME_MUTABLE_VECTORP(vec))
+    scheme_wrong_contract("vector-cas!", "(and/c vector? (not/c immutable?) (not/c impersonator?))", 0, argc, argv);
+
+  len = SCHEME_VEC_SIZE(vec);
+
+  i = scheme_extract_index("vector-cas!", 1, argc, argv, len, 0);
+
+  if (i >= len)
+    return bad_index("vector-cas!", "", argv[1], argv[0], 0);
+
+  return unsafe_vector_star_cas(argc, argv);
+}
+
 # define cons(car, cdr) scheme_make_pair(car, cdr)
 
 Scheme_Object *
@@ -1076,6 +1107,28 @@ static Scheme_Object *unsafe_vector_star_set (int argc, Scheme_Object *argv[])
   return scheme_void;
 }
 
+static Scheme_Object *unsafe_vector_star_cas (int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *vec = argv[0];
+  Scheme_Object *idx = argv[1];
+  Scheme_Object *ov = argv[2];
+  Scheme_Object *nv = argv[3];
+
+#ifdef MZ_USE_FUTURES
+  return mzrt_cas((volatile uintptr_t *)(SCHEME_VEC_ELS(vec) + SCHEME_INT_VAL(idx)),
+                  (uintptr_t)ov, (uintptr_t)nv)
+    ? scheme_true : scheme_false;
+#else
+  /* For cooperative threading, no atomicity required */
+  if (SCHEME_VEC_ELS(vec)[SCHEME_INT_VAL(idx)] == ov) {
+    SCHEME_VEC_ELS(vec)[SCHEME_INT_VAL(idx)] = nv;
+    return scheme_true;
+  } else {
+    return scheme_false;
+  }
+#endif
+}
+
 static Scheme_Object *unsafe_struct_ref (int argc, Scheme_Object *argv[])
 {
   if (SCHEME_CHAPERONEP(argv[0]))