Add box-cas!' and unsafe-box*-cas!'.

These primitives atomically update a box to a new value, as long
as the current value is the same as a provided value.  They also
are future-safe.

When futures are enabled, they use low-level hardware instructions
to perform the change atomically.

collects/scribblings/reference/data.scrbl

@@ -115,7 +115,28 @@ For any @racket[v], @racket[(unbox (box v))] returns @racket[v].
 @defproc[(set-box! [box (and/c box? (not/c immutable?))]
                    [v any/c]) void?]{
 
-Sets the content of @racket[box] to @racket[v].}
+Sets the content of @racket[box] to @racket[v].
+
+@defproc[(box-cas! [loc box?] [old any/c] [new any/c]) boolean?]{
+  Atomically updates the contents of @racket[loc] to @racket[new], provided
+  that @racket[loc] currently contains a value that is @racket[eq?] to
+  @racket[old].  When Racket is compiled with support for @tech{futures},
+  this uses a hardware @emph{compare and set} operation.
+
+  If no other @tech{threads} or @tech{futures} attempt to access
+  @racket[loc], this is equivalent to 
+  @racketblock[
+  (and (eq? old (unbox loc)) (set-box! loc new) #t)]
+  
+  Uses of @racket[box-cas!] be performed safely in parallel with other
+  operations. In contrast, other atomic operations are not safe to perform in
+  parallel, and they therefore prevent a computation from continuing in
+  parallel. 
+
+  If @racket[loc] is a @tech{chaperone} or @tech{impersonator} of a box, the
+  @exnraise[exn:fail:contract].}
+
+}
 
 @; ----------------------------------------------------------------------
 @include-section["hashes.scrbl"]

collects/scribblings/reference/unsafe.scrbl

@@ -213,6 +213,10 @@ Unsafe versions of @racket[unbox] and @racket[set-box!], where the
 @schemeidfont{box*} variants can be faster but do not work on
 @tech{impersonators}.}
 
+@defproc[(unsafe-box*-cas! [loc box?] [old any/c] [new any/c]) boolean?]{
+  Unsafe version of @racket[box-cas!].  Like @racket[unsafe-set-box*!], it does
+  not work on impersonators.
+}
 
 @deftogether[(
 @defproc[(unsafe-vector-length [v vector?]) fixnum?]

collects/tests/future/future.rkt

@@ -748,8 +748,102 @@ We should also test deep continuations.
    0
    (touch
     (for/fold ([t (func (lambda () 0))]) ([i (in-range 10000)])
-      (func (lambda () (touch t))))))
-  
+      (func (lambda () (touch t))))))  
+
+  ;; box-cas! tests
+
+  ;; successful cas
+  (let ()
+    (define b (box #f))
+    (check-equal? (box-cas! b #f #true) #true)
+    (check-equal? (unbox b) #true))
+
+  ;; unsuccessful cas
+  (let ()
+    (define b (box #f))
+    (check-equal? (box-cas! b #true #f) #f)
+    (check-equal? (unbox b) #f))
+
+  ;; cas using allocated data
+  (let ()
+    (define b (box '()))
+    (define x (cons 1 (unbox b)))
+    (check-equal? (box-cas! b '() x) #true)
+    (check-equal? (unbox b) x)
+    (check-equal? (box-cas! b x '()) #true)
+    (check-equal? (unbox b) '())
+    (check-equal? (box-cas! b x '()) #f)
+    (check-equal? (unbox b) '()))
+
+  ;; failure tests
+  (let ()
+    (define (f x) (box-cas! x 1 2))    
+    (define (g x y) y)
+
+    (define b (box 1))
+    
+    (check-equal? (with-handlers ([exn:fail? (lambda _ 'num)]) 
+                    (touch (future (lambda () (f 2))))) 
+                  'num)
+    (check-equal? (with-handlers ([exn:fail? (lambda _ 'list)]) 
+                    (touch (future (lambda () (f (list 1))))))
+                  'list)
+    
+    (check-equal? (with-handlers ([exn:fail? (lambda _ 'chap)]) 
+                    (touch (future (lambda () (f (chaperone-box b g g))))))
+                  'chap)
+    
+    (check-equal? (with-handlers ([exn:fail? (lambda _ 'imp)]) 
+                    (touch (future (lambda () (f (impersonate-box b g g))))))
+                  'imp)
+    (check-equal? (unbox b) 1))
+
+  (let ()
+    (define b (box 0))
+    ;; inc and dec, with retry loops
+    (define (inc) 
+      (let loop ()
+	(define cur (unbox b))
+	(unless (box-cas! b cur (+ cur 1))
+	  (loop))))
+    (define (dec) 
+      (let loop ()
+	(define cur (unbox b))
+	(unless (box-cas! b cur (- cur 1))
+	  (loop))))
+    (define (inc-dec-loop)
+      (for ([i (in-range 100000000)])
+	   (inc)
+	   (dec)))
+    (define t1 (func inc-dec-loop))
+    (define t2 (func inc-dec-loop))
+    (touch t1)
+    (touch t2)
+    (check-equal? (unbox b) 0))
+
+  (let ()
+    (define b1 (box #true))
+    (define (neg-bad)
+      (let loop ()
+        (unless (box-cas! b1 #true #false)
+          (unless (box-cas! b1 #false #true)
+            (loop)))))
+    (define b2 (box #true))
+    (define (neg-good)
+      (unless (box-cas! b2 #true #false)
+        (box-cas! b2 #false #true)))
+
+    (check-equal? (unbox b1) #true)
+    (neg-bad)
+    (check-equal? (unbox b1) #false)
+    (neg-bad)
+    (check-equal? (unbox b1) #true)
+
+    (check-equal? (unbox b2) #true)
+    (neg-good)
+    (check-equal? (unbox b2) #false)
+    (neg-good)
+    (check-equal? (unbox b2) #true))
   )
 
 (run-tests future)

collects/tests/racket/unsafe.rktl

@@ -241,6 +241,21 @@
                                           (lambda (b v) v)
                                           (lambda (b v) v)))
 
+  (let ([b (box 0)]
+        [b2 (box 1)])    
+    ;; success
+    (test-tri (list #true 1)
+              'unsafe-box*-cas! b 0 1
+              #:pre (lambda () (set-box! b 0))
+              #:post (lambda (x) (list x (unbox b)))
+              #:literal-ok? #f)
+    ;; failure
+    (test-tri (list #false 1)
+              'unsafe-box*-cas! b2 0 7
+              #:pre (lambda () (set-box! b2 1))
+              #:post (lambda (x) (list x (unbox b2)))
+              #: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))

src/racket/src/future.h

@@ -271,4 +271,6 @@ Scheme_Object *scheme_fsemaphore_wait(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_fsemaphore_post(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_fsemaphore_try_wait(int argc, Scheme_Object *argv[]);
 
+Scheme_Object *scheme_box_cas(int argc, Scheme_Object *argv[]);
+
 #endif

src/racket/src/jit_ts.c

@@ -114,6 +114,7 @@ define_ts_l_s(scheme_jit_make_vector, FSRC_OTHER)
 # endif
 define_ts_ss_i(scheme_equal, FSRC_MARKS)
 define_ts_sss_s(extract_one_cc_mark_to_tag, FSRC_MARKS)
+define_ts_iS_s(scheme_box_cas, FSRC_MARKS)
 #endif
 
 #ifdef JIT_APPLY_TS_PROCS
@@ -179,6 +180,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
 # define ts_scheme_make_complex scheme_make_complex
 # define ts_scheme_unbox scheme_unbox
 # define ts_scheme_set_box scheme_set_box
+# define ts_scheme_box_cas scheme_box_cas
 # define ts_scheme_vector_length scheme_vector_length
 # define ts_scheme_flvector_length scheme_flvector_length
 # define ts_scheme_fxvector_length scheme_fxvector_length

src/racket/src/jitinline.c

@@ -2824,7 +2824,81 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
     jit_retval(JIT_R0);
     return 1;
   } else if (!for_branch) {
-    if (IS_NAMED_PRIM(rator, "vector-set!")
+    if   (IS_NAMED_PRIM(rator, "box-cas!") || (IS_NAMED_PRIM(rator, "unsafe-box*-cas!"))) { 
+
+      GC_CAN_IGNORE jit_insn *ref, *ref3, *refr, *reffalse, *reftrue;
+      int unsafe = 0; // unused so far
+
+      if (IS_NAMED_PRIM(rator, "unsafe-box*-cas!")) {
+        unsafe = 1;
+      }
+
+      // generate code to evaluate the arguments
+      scheme_generate_app(app, NULL, 3, jitter, 0, 0, 2);
+      CHECK_LIMIT();
+      mz_rs_sync();
+
+      mz_rs_ldr(JIT_R1);
+
+      __START_TINY_JUMPS__(1);
+
+      if (!unsafe) {
+        // Fail if this isn't a pointer (0x1 is the integer tag)
+        ref3 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1);
+        // Get the type tag, fail if it isn't a box
+        ref = mz_beqi_t(jit_forward(), JIT_R1, scheme_box_type, JIT_R2);
+        // jump to here if it wasn't a pointer
+        mz_patch_branch(ref3);
+        
+        // call scheme_box_cas to raise the exception
+        // we use mz_finish_lwe because it will capture the stack
+        // and the ts_ version because we may be in a future
+        JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
+        jit_movi_l(JIT_R0, 3);
+        mz_prepare(2);
+        jit_pusharg_p(JIT_RUNSTACK);
+        jit_pusharg_l(JIT_R0);
+        CHECK_LIMIT();      
+        (void)mz_finish_lwe(ts_scheme_box_cas, refr); /* doesn't return */
+        
+        // jump to here if the type tag tests succeed
+        mz_patch_branch(ref);
+      }
+
+      /* box is in JIT_R1 */
+      jit_addi_l(JIT_R1, JIT_R1, (intptr_t)&SCHEME_BOX_VAL(0x0));
+      mz_rs_ldxi(JIT_R0, 1); /* old val */
+      mz_rs_ldxi(JIT_V1, 2); /* new val */
+
+#ifdef MZ_USE_FUTURES
+      if (scheme_is_multiprocessor(0)) {
+        jit_lock_cmpxchgr_l(JIT_R1, JIT_V1); /* implicitly uses JIT_R0 */
+        reffalse = (JNEm(jit_forward(), 0,0,0), _jit.x.pc);
+      } else
+#endif
+        {
+          jit_ldr_p(JIT_R2, JIT_R1);
+          reffalse = jit_bner_p(jit_forward(), JIT_R2, JIT_R0);
+          jit_str_p(JIT_R1, JIT_V1);
+        }
+      
+      jit_movi_p(JIT_R0, scheme_true);
+      reftrue = jit_jmpi(jit_forward());
+      
+      mz_patch_branch(reffalse);
+      jit_movi_p(JIT_R0, scheme_false);
+      
+      mz_patch_branch(reftrue);
+
+      __END_TINY_JUMPS__(1);
+
+      // pop off 3 arguments
+      mz_rs_inc(3);
+      mz_runstack_popped(jitter, 3);
+
+      return 1;
+
+    } else if (IS_NAMED_PRIM(rator, "vector-set!")
         || IS_NAMED_PRIM(rator, "unsafe-vector-set!")
         || IS_NAMED_PRIM(rator, "unsafe-vector*-set!")
         || IS_NAMED_PRIM(rator, "flvector-set!")

src/racket/src/lightning/i386/asm.h

@@ -459,6 +459,7 @@ typedef _uc		jit_insn;
 
 /* Above variants don't seem to work */
 #define CMPXCHGr(RS, RD)          	(_jit_B(0xF), _O_r_X(0xb1 	     ,_r4(RD)		,0,RS,0,0		))
+#define CMPXCHGQr(RS, RD)          	(_REX(0, 0, 0), _jit_B(0xF), _O_r_X(0xb1 ,_r4(RD)	,0,RS,0,0		))
 #define CMPXCHGWr(RS, RD)          	(_d16(), _jit_B(0xF), _O_r_X(0xb1    ,_r4(RD)		,0,RS,0,0		))
 
 #define LOCK_PREFIX(i) (_jit_B(0xf0), i)

src/racket/src/lightning/i386/core.h

@@ -702,8 +702,13 @@ XFORM_NONGCING static intptr_t _CHECK_TINY(intptr_t diff) { if ((diff < -128) ||
 # define jit_sti_i(id, rs) _jit_sti_i(id, rs)
 #endif
 
-# define jit_lock_cmpxchgr_i(rd, rs) LOCK_PREFIX(CMPXCHGr(rd, rs))
-# define jit_lock_cmpxchgr_s(rd, rs) LOCK_PREFIX(CMPXCHGWr(rd, rs))
+#define jit_lock_cmpxchgr_i(rd, rs) LOCK_PREFIX(CMPXCHGr(rd, rs))
+#define jit_lock_cmpxchgr_s(rd, rs) LOCK_PREFIX(CMPXCHGWr(rd, rs))
+#ifdef JIT_X86_64
+# define jit_lock_cmpxchgr_l(rd, rs) LOCK_PREFIX(CMPXCHGQr(rd, rs))
+#else
+# define jit_lock_cmpxchgr_l(rd, rs) jit_lock_cmpxchgr_i(rd, rs)
+#endif
 
 /* Extra */
 #define jit_nop()			NOP_()

src/racket/src/list.c

@@ -88,6 +88,7 @@ static Scheme_Object *immutable_box (int argc, Scheme_Object *argv[]);
 static Scheme_Object *box_p (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unbox (int argc, Scheme_Object *argv[]);
 static Scheme_Object *set_box (int argc, Scheme_Object *argv[]);
+Scheme_Object *scheme_box_cas (int argc, Scheme_Object *argv[]);
 static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv);
 static Scheme_Object *impersonate_box(int argc, Scheme_Object **argv);
 
@@ -448,6 +449,10 @@ scheme_init_list (Scheme_Env *env)
   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;  
   scheme_add_global_constant(SETBOX, p, env);
 
+  p = scheme_make_immed_prim(scheme_box_cas, "box-cas!", 3, 3);
+  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;  
+  scheme_add_global_constant("box-cas!", p, env);
+
   scheme_add_global_constant("chaperone-box",
                              scheme_make_prim_w_arity(chaperone_box,
                                                       "chaperone-box",
@@ -792,6 +797,11 @@ scheme_init_unsafe_list (Scheme_Env *env)
   p = scheme_make_immed_prim(unsafe_set_box_star, "unsafe-set-box*!", 2, 2);
   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
   scheme_add_global_constant("unsafe-set-box*!", p, env);
+
+  p = scheme_make_prim_w_arity(scheme_box_cas, "unsafe-box*-cas!", 3, 3);
+  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
+  scheme_add_global_constant("unsafe-box*-cas!", p, env);
+
 }
 
 Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
@@ -1610,6 +1620,51 @@ Scheme_Object *scheme_unbox(Scheme_Object *obj)
   return (Scheme_Object *)SCHEME_BOX_VAL(obj);
 }
 
+#ifndef MZ_USE_FUTURES
+
+Scheme_Object *scheme_box_cas(int argc, Scheme_Object *argv[])
+XFORM_SKIP_PROC
+/* For cooperative threading, no atomicity required */
+{
+  Scheme_Object *box = argv[0];
+  Scheme_Object *ov = argv[1];
+  Scheme_Object *nv = argv[2];
+
+  if (!SCHEME_MUTABLE_BOXP(box)) || (SCHEME_NP_CHAPERONEP(box)) {
+    scheme_wrong_type("cas!", "unchaperoned mutable box", 0, 1, &box);
+  }
+
+  if (SCHEME_BOX_VAL(box) == ov) {
+    SCHEME_BOX_VAL(box) = nv;
+    return scheme_true;
+  } else {
+    return scheme_false;
+  }
+}
+
+#else
+
+Scheme_Object *scheme_box_cas(int argc, Scheme_Object *argv[])
+XFORM_SKIP_PROC
+{
+  Scheme_Object *box = argv[0];
+  Scheme_Object *ov = argv[1];
+  Scheme_Object *nv = argv[2];
+
+  /* This procedure is used for both the safe and unsafe version, but
+   * the JIT elides the checking for the unsafe version.
+   */
+  if ((!SCHEME_MUTABLE_BOXP(box)) || (SCHEME_NP_CHAPERONEP(box))) {
+    scheme_wrong_type("box-cas!", "unchaperoned mutable box", 0, 1, &box);
+  }
+
+  return mzrt_cas((volatile size_t *)(&SCHEME_BOX_VAL(box)), 
+		  (size_t)ov, (size_t)nv)
+    ? scheme_true : scheme_false;
+}
+
+#endif
+
 static void chaperone_set_box(Scheme_Object *obj, Scheme_Object *v)
 {
   Scheme_Chaperone *px;

src/racket/src/schminc.h

@@ -14,8 +14,8 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1046
-#define EXPECTED_UNSAFE_COUNT 78
+#define EXPECTED_PRIM_COUNT 1047
+#define EXPECTED_UNSAFE_COUNT 79
 #define EXPECTED_FLFXNUM_COUNT 68
 #define EXPECTED_FUTURES_COUNT 13
 

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.3.0.4"
+#define MZSCHEME_VERSION "5.3.0.5"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 4
+#define MZSCHEME_VERSION_W 5
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)