Adding (util concurrent atomic)

Author: ktakashi

sitelib/util/concurrent/atomic.scm

@@ -0,0 +1,53 @@
+;;; -*- mode: scheme; coding: utf-8 -*-
+;;;
+;;; util/concurrent/atomic.scm - Atomic operations
+;;;  
+;;;   Copyright (c) 2024  Takashi Kato  <ktakashi@ymail.com>
+;;;   
+;;;   Redistribution and use in source and binary forms, with or without
+;;;   modification, are permitted provided that the following conditions
+;;;   are met:
+;;;   
+;;;   1. Redistributions of source code must retain the above copyright
+;;;      notice, this list of conditions and the following disclaimer.
+;;;  
+;;;   2. Redistributions in binary form must reproduce the above copyright
+;;;      notice, this list of conditions and the following disclaimer in the
+;;;      documentation and/or other materials provided with the distribution.
+;;;  
+;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;  
+
+#!nounbound
+(library (util concurrent atomic)
+    (export atomic? make-atomic
+	    atomic-fixnum? make-atomic-fixnum
+
+	    atomic-load atomic-store!
+	    atomic-fixnum-load atomic-fixnum-store!
+
+	    atomic-fixnum-add! atomic-fixnum-sub!
+	    atomic-fixnum-inc! atomic-fixnum-dec!
+	    atomic-fixnum-or! atomic-fixnum-xor! atomic-fixnum-and!
+
+	    atomic-exchange! atomic-fixnum-exchange!
+
+	    atomic-compare-and-swap!
+
+	    *memory-order:relaxed*
+	    *memory-order:consume*
+	    *memory-order:acquire*
+	    *memory-order:release*
+	    *memory-order:acq-rel*
+	    *memory-order:seq-cst*)
+    (import (sagittarius atomic)))

src/atomic.c

@@ -332,15 +332,17 @@ extern void Sg__Init_sagittarius_atomic();
 void Sg__InitAtomic()
 {
   SgObject lib = Sg_FindLibrary(SG_INTERN("(sagittarius atomic)"), TRUE);
+
+  Sg__Init_sagittarius_atomic();
+
 #define insert_binding(name, value)					\
   Sg_MakeBinding(SG_LIBRARY(lib), SG_INTERN(#name), SG_MAKE_INT(value), TRUE)
 
-  insert_binding(memory-order:relaxed, memory_order_relaxed);
-  insert_binding(memory-order:consume, memory_order_consume);
-  insert_binding(memory-order:acquire, memory_order_acquire);
-  insert_binding(memory-order:release, memory_order_release);
-  insert_binding(memory-order:acq-rel, memory_order_acq_rel);
-  insert_binding(memory-order:seq-cst, memory_order_seq_cst);
+  insert_binding(*memory-order:relaxed*, memory_order_relaxed);
+  insert_binding(*memory-order:consume*, memory_order_consume);
+  insert_binding(*memory-order:acquire*, memory_order_acquire);
+  insert_binding(*memory-order:release*, memory_order_release);
+  insert_binding(*memory-order:acq-rel*, memory_order_acq_rel);
+  insert_binding(*memory-order:seq-cst*, memory_order_seq_cst);
 
-  Sg__Init_sagittarius_atomic();
 }

src/lib_atomic.stub

@@ -66,4 +66,9 @@
 
 (define-c-proc atomic-compare-and-swap! (a::<atomic> e v :optional (success::<memory-order> (default-memory-order)) (failure::<memory-order> (default-memory-order))) ::<boolean> Sg_AtomicCompareAndSwap)
 
+(define (atomic-fixnum-inc! atomic . opts)
+  (apply atomic-fixnum-add! atomic 1 opts))
+(define (atomic-fixnum-dec! atomic . opts)
+  (apply atomic-fixnum-sub! atomic 1 opts))
+
 )

test/tests/sagittarius/atomic.scm

@@ -13,11 +13,22 @@
 (test-assert (atomic-fixnum? (make-atomic-fixnum 100)))
 (test-error (make-atomic-fixnum #t))
 
+(test-assert (fixnum? *memory-order:relaxed*))
+(test-assert (fixnum? *memory-order:consume*))
+(test-assert (fixnum? *memory-order:acquire*))
+(test-assert (fixnum? *memory-order:release*))
+(test-assert (fixnum? *memory-order:acq-rel*))
+(test-assert (fixnum? *memory-order:seq-cst*))
+
 (test-group "Basic check"
  (let ()
    (define atomic-boolean (make-atomic #t))
    (atomic-exchange! atomic-boolean #f)
    (test-equal #f (atomic-load atomic-boolean))
+   (test-error (atomic-load atomic-boolean #f))
+   ;; it's a bit depending on the platform specific value,
+   ;; I hope memory order can't be this number
+   (test-error (atomic-load atomic-boolean #xffffffff))
 
    (test-equal #t (atomic-compare-and-swap! atomic-boolean #f #t))
    (test-equal #t (atomic-load atomic-boolean)))
@@ -39,6 +50,10 @@
    (test-equal 150 (atomic-fixnum-load atomic-fixnum))
    (test-assert (atomic-fixnum-sub! atomic-fixnum 50))
    (test-equal 100 (atomic-fixnum-load atomic-fixnum))
+   (test-assert (atomic-fixnum-inc! atomic-fixnum))
+   (test-equal 101 (atomic-fixnum-load atomic-fixnum))
+   (test-assert (atomic-fixnum-dec! atomic-fixnum))
+   (test-equal 100 (atomic-fixnum-load atomic-fixnum))
 
    (test-error (atomic-store! atomic-fixnum 'symbol))