From 92dc2dcf5494531530f02029a68adf40339d3ce1 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 20 Sep 2021 16:22:05 -0400 Subject: [PATCH] Initial files --- Makefile | 23 +++ examples/sum-atomic-box.scm | 31 ++++ examples/sum-atomic-fxbox.scm | 31 ++++ examples/sum-mutex.scm | 29 ++++ examples/sum-no-sync.scm | 26 +++ examples/sum-spin-lock.scm | 37 ++++ package.scm | 15 ++ srfi/230.sld | 309 ++++++++++++++++++++++++++++++++++ srfi/utils.c | 42 +++++ test.scm | 115 +++++++++++++ 10 files changed, 658 insertions(+) create mode 100644 Makefile create mode 100644 examples/sum-atomic-box.scm create mode 100644 examples/sum-atomic-fxbox.scm create mode 100644 examples/sum-mutex.scm create mode 100644 examples/sum-no-sync.scm create mode 100644 examples/sum-spin-lock.scm create mode 100644 package.scm create mode 100644 srfi/230.sld create mode 100644 srfi/utils.c create mode 100644 test.scm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..c040b91 --- /dev/null +++ b/Makefile @@ -0,0 +1,23 @@ +PROGS = sum-no-sync \ + sum-mutex \ + sum-spin-lock \ + sum-atomic-fxbox \ + sum-atomic-box + +SCMFILES = $(addsuffix .scm, $(PROGS)) +CFILES = $(addsuffix .c, $(PROGS)) + +all: srfi/230.o $(PROGS) + +$(PROGS): %: %.scm + cyclone $< + ./$@ + +srfi/230.o: srfi/230.sld + cyclone srfi/230.sld + +test: all test.scm + cyclone test.scm && ./test + +clean: + rm -f $(PROGS) srfi/230.o srfi/230.c srfi/230.so *.meta *.o diff --git a/examples/sum-atomic-box.scm b/examples/sum-atomic-box.scm new file mode 100644 index 0000000..9e3681e --- /dev/null +++ b/examples/sum-atomic-box.scm @@ -0,0 +1,31 @@ +(import (scheme base) + (scheme write) + (srfi 18) + (srfi 230)) + +(define *atomic-counter* (make-atomic-box 0.0)) + +(define (task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + ;(atomic-fxbox+/fetch! *atomic-counter* 1) + (let loop () + (let ((expected (atomic-box-ref *atomic-counter*))) + (if (not (eq? expected (atomic-box-compare-and-swap! *atomic-counter* expected (+ expected 1)))) + (loop)))) + )) + +(define threads (make-vector 10)) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (let ((thread (make-thread task))) + (vector-set! threads i thread) + (thread-start! thread))) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (thread-join! (vector-ref threads i))) + +(display (atomic-box-ref *atomic-counter*)) +(newline) diff --git a/examples/sum-atomic-fxbox.scm b/examples/sum-atomic-fxbox.scm new file mode 100644 index 0000000..0dab2ac --- /dev/null +++ b/examples/sum-atomic-fxbox.scm @@ -0,0 +1,31 @@ +(import (scheme base) + (scheme write) + (srfi 18) + (srfi 230)) + +(define *atomic-counter* (make-atomic-fxbox 0)) + +(define (task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + ;(atomic-fxbox+/fetch! *atomic-counter* 1) + (let loop () + (let ((expected (atomic-fxbox-ref *atomic-counter*))) + (if (not (eq? expected (atomic-fxbox-compare-and-swap! *atomic-counter* expected (+ expected 1)))) + (loop)))) + )) + +(define threads (make-vector 10)) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (let ((thread (make-thread task))) + (vector-set! threads i thread) + (thread-start! thread))) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (thread-join! (vector-ref threads i))) + +(display (atomic-fxbox-ref *atomic-counter*)) +(newline) diff --git a/examples/sum-mutex.scm b/examples/sum-mutex.scm new file mode 100644 index 0000000..e900b41 --- /dev/null +++ b/examples/sum-mutex.scm @@ -0,0 +1,29 @@ +(import (scheme base) + (scheme write) + (srfi 18) + (srfi 230)) + +(define *lock* (make-mutex)) +(define *counter* 0) + +(define (task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + (mutex-lock! *lock*) + (set! *counter* (+ *counter* 1)) + (mutex-unlock! *lock*))) + +(define threads (make-vector 10)) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (let ((thread (make-thread task))) + (vector-set! threads i thread) + (thread-start! thread))) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (thread-join! (vector-ref threads i))) + +(display *counter*) +(newline) diff --git a/examples/sum-no-sync.scm b/examples/sum-no-sync.scm new file mode 100644 index 0000000..0bfdaa5 --- /dev/null +++ b/examples/sum-no-sync.scm @@ -0,0 +1,26 @@ +(import (scheme base) + (scheme write) + (srfi 18) + (srfi 230)) + +(define *counter* 0) + +(define (task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + (set! *counter* (+ *counter* 1)))) + +(define threads (make-vector 10)) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (let ((thread (make-thread task))) + (vector-set! threads i thread) + (thread-start! thread))) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (thread-join! (vector-ref threads i))) + +(display *counter*) +(newline) diff --git a/examples/sum-spin-lock.scm b/examples/sum-spin-lock.scm new file mode 100644 index 0000000..2e76132 --- /dev/null +++ b/examples/sum-spin-lock.scm @@ -0,0 +1,37 @@ +(import (scheme base) + (scheme write) + (srfi 18) + (srfi 230)) + +(define *flag* (make-atomic-flag)) +(define *counter* 0) + +(define (spin-lock flag) + (let loop () + (if (atomic-flag-test-and-set! flag) + (loop)))) + +(define (spin-unlock flag) + (atomic-flag-clear! flag)) + +(define (task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + (spin-lock *flag*) + (set! *counter* (+ *counter* 1)) + (spin-unlock *flag*) )) + +(define threads (make-vector 10)) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (let ((thread (make-thread task))) + (vector-set! threads i thread) + (thread-start! thread))) + +(do ((i 0 (+ i 1))) + ((= i 10)) + (thread-join! (vector-ref threads i))) + +(display *counter*) +(newline) diff --git a/package.scm b/package.scm new file mode 100644 index 0000000..74358c5 --- /dev/null +++ b/package.scm @@ -0,0 +1,15 @@ +(package + (name srfi-230) + (version 0.1) + (license "MIT") + (authors "Justin Ethier") + (maintainers "Justin Ethier ") + (description "Atomic Operations") + (tags "srfi") + (docs "https://github.com/cyclone-scheme/cyclone-winds/wiki/srfi-230") + (test "test.scm") + + (library + (name (srfi 230)) + (description "Atomic Operations"))) + diff --git a/srfi/230.sld b/srfi/230.sld new file mode 100644 index 0000000..6a8b162 --- /dev/null +++ b/srfi/230.sld @@ -0,0 +1,309 @@ +;; This file contains an implementation of SRFI 230: Atomic Operations +;; using stdatomic.h, designed specifically for Cyclone Scheme. +;; +;; Copyright (C) Justin Ethier (2021). All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-library (srfi 230) + (include-c-header "") + (include-c-header "utils.c") + (export + memory-order + memory-order? + make-atomic-flag + atomic-flag? + atomic-flag-test-and-set! + atomic-flag-clear! + make-atomic-box + atomic-box? + atomic-box-ref + atomic-box-set! + atomic-box-swap! + atomic-box-compare-and-swap! + make-atomic-fxbox + atomic-fxbox? + atomic-fxbox-ref + atomic-fxbox-set! + atomic-fxbox-swap! + atomic-fxbox-compare-and-swap! + atomic-fxbox+/fetch! + atomic-fxbox-/fetch! + atomic-fxbox-and/fetch! + atomic-fxbox-ior/fetch! + atomic-fxbox-xor/fetch! + atomic-fence +) + (import (scheme base) + (srfi 18)) + (begin + + ;; Internals + + (define-syntax memory-order + (syntax-rules () + ((memory-order symbol) 'symbol))) + + (define (memory-order? obj) + (and (memq + obj + '(relaxed acquire release acquire-release sequentially-consistent)) + #t)) + + ;; Atomic flags + + (define-c %atomic-flag-init + "(void *data, int argc, closure _, object k)" + " atomic_flag f = ATOMIC_FLAG_INIT; + atomic_flag *flag = malloc(sizeof(atomic_flag)); + make_c_opaque(opq, flag); + opaque_collect_ptr(&opq) = 1; // Allow GC to free() memory + *flag = f; + return_closcall1(data, k, &opq); ") + + (define-c %atomic-flag-tas + "(void *data, int argc, closure _, object k, object opq)" + " atomic_flag *flag = opaque_ptr(opq); + _Bool b = atomic_flag_test_and_set(flag); + return_closcall1(data, k, b ? boolean_t : boolean_f);") + + (define-c %atomic-flag-clear + "(void *data, int argc, closure _, object k, object opq)" + " atomic_flag *flag = opaque_ptr(opq); + atomic_flag_clear(flag); + return_closcall1(data, k, boolean_f);") + + (define-record-type atomic-flag + (%make-atomic-flag content) + atomic-flag? + (content atomic-flag-content atomic-flag-set-content!)) + + (define (make-atomic-flag) + (define b (%make-atomic-flag (%atomic-flag-init))) + (Cyc-minor-gc) + b) + + (define (atomic-flag-check flag) + (unless (atomic-flag? flag) + (error "Expected atomic flag but received" flag))) + + (define (atomic-flag-test-and-set! flag . o) + (atomic-flag-check flag) + (%atomic-flag-tas (atomic-flag-content flag))) + + (define (atomic-flag-clear! flag . o) + (atomic-flag-check flag) + (%atomic-flag-clear (atomic-flag-content flag))) + + ;; Atomic boxes + + (define-c %atomic-box-init + "(void *data, int argc, closure _, object k, object pair, object value)" + " pair_type *p = (pair_type*)pair; + atomic_init((uintptr_t *)&(p->pair_car), (uintptr_t)value); + //v->elements[2] = (object)ptr; + return_closcall1(data, k, pair); ") + + (define-c %atomic-box-load + "(void *data, int argc, closure _, object k, object pair)" + " pair_type *p = (pair_type*)pair; + uintptr_t c = atomic_load((uintptr_t *)(&(p->pair_car))); + return_closcall1(data, k, (object)c); ") + + (define-c %atomic-box-store + "(void *data, int argc, closure _, object k, object pair, object value)" + " pair_type *p = (pair_type*)pair; + + // Write barrier + // TODO: support objects (closure, pair, vector) that require a GC + // see Cyc_set_car_cps() in runtime.c + int do_gc = 0; + value = transport_stack_value(data, pair, value, &do_gc); + gc_mut_update((gc_thread_data *) data, car(pair), value); + add_mutation(data, pair, -1, value); // Ensure val is transported + + atomic_store((uintptr_t *)(&(p->pair_car)), (uintptr_t)value); + return_closcall1(data, k, value); ") + + (define-c %atomic-box-exchange + "(void *data, int argc, closure _, object k, object pair, object value)" + " pair_type *p = (pair_type*)pair; + + // Write barrier + // TODO: support objects (closure, pair, vector) that require a GC + // see Cyc_set_car_cps() in runtime.c + int do_gc = 0; + value = transport_stack_value(data, pair, value, &do_gc); + gc_mut_update((gc_thread_data *) data, car(pair), value); + add_mutation(data, pair, -1, value); // Ensure val is transported + + uintptr_t c = atomic_exchange((uintptr_t *)(&(p->pair_car)), (uintptr_t)value); + return_closcall1(data, k, (object)c); ") + + (define-c %atomic-box-compare-exchange + "(void *data, int argc, closure _, object k, object pair, object expected, object desired)" + " pair_type *p = (pair_type*)pair; + uintptr_t old = (uintptr_t)expected; + + // Write barrier + // TODO: support objects (closure, pair, vector) that require a GC + // see Cyc_set_car_cps() in runtime.c + int do_gc = 0; + desired = transport_stack_value(data, pair, desired, &do_gc); + gc_mut_update((gc_thread_data *) data, car(pair), desired); + add_mutation(data, pair, -1, desired); // Ensure val is transported + + atomic_compare_exchange_strong((uintptr_t *)(&(p->pair_car)), &old, (uintptr_t)desired); + return_closcall1(data, k, (object)old); + ") + + (define-record-type atomic-box + (%make-atomic-box content) + atomic-box? + (content atomic-box-content atomic-box-set-content!)) + + (define (make-atomic-box c) + (define b (%make-atomic-box (list #f))) + (%atomic-box-init (atomic-box-content b) c) + (Cyc-minor-gc) ;; Force b onto heap + b) + + (define (atomic-box-check box) + (unless (atomic-box? box) + (error "Expected atomic box but received" box))) + + (define (atomic-box-ref box . o) + (atomic-box-check box) + (%atomic-box-load (atomic-box-content box))) + + (define (atomic-box-set! box obj . o) + (atomic-box-check box) + (%atomic-box-store (atomic-box-content box) obj)) + + (define (atomic-box-swap! box obj . o) + (atomic-box-check box) + (%atomic-box-exchange (atomic-box-content box) obj)) + + (define (atomic-box-compare-and-swap! box expected desired . o) + (atomic-box-check box) + (%atomic-box-compare-exchange (atomic-box-content box) expected desired)) + + ;; Atomic fixnum boxes + + ;; native ints are stored in a C opaque, otherwise GC could + ;; think they are pointers + (define-c %atomic-fxbox-init + "(void *data, int argc, closure _, object k, object opq, object value)" + " Cyc_check_fixnum(data, value); + atomic_uintptr_t p; + atomic_init(&p, (uintptr_t)obj_obj2int(value)); + opaque_ptr(opq) = (object)p; + return_closcall1(data, k, opq); ") + + (define-c %empty-opaque + "(void *data, int argc, closure _, object k)" + " make_c_opaque(opq, NULL); + return_closcall1(data, k, &opq); ") + + (define-c %atomic-fxbox-load + "(void *data, int argc, closure _, object k, object opq)" + " uintptr_t c = atomic_load((uintptr_t *)(&(opaque_ptr(opq)))); + return_closcall1(data, k, obj_int2obj(c)); ") + + (define-c %atomic-fxbox-store + "(void *data, int argc, closure _, object k, object opq, object value)" + " atomic_store((uintptr_t *)(&(opaque_ptr(opq))), (uintptr_t)obj_obj2int(value)); + return_closcall1(data, k, value); ") + + (define-c %atomic-fxbox-compare-exchange + "(void *data, int argc, closure _, object k, object opq, object expected, object desired)" + " uintptr_t old = (uintptr_t)obj_obj2int(expected); + atomic_compare_exchange_strong((uintptr_t *)(&(opaque_ptr(opq))), &old, (uintptr_t)obj_obj2int(desired)); + return_closcall1(data, k, obj_int2obj(old)); + ") + + (define-syntax fx-num-op + (er-macro-transformer + (lambda (expr rename compare) + (let* ((scm-fnc (cadr expr)) + (fnc (caddr expr)) + (op-str (cadddr expr)) + (args "(void* data, int argc, closure _, object k, object opq, object m)") + (body + (string-append + " uintptr_t c = " op-str "((uintptr_t *)(&(opaque_ptr(opq))), (uintptr_t)obj_obj2int(m));\n" + " return_closcall1(data, k, obj_int2obj((object)c)); "))) + `(begin + (define-c ,fnc ,args ,body) + (define (,scm-fnc box n . o) + (atomic-fxbox-check box) + (,fnc (atomic-fxbox-content box) n)) +))))) + + (fx-num-op atomic-fxbox+/fetch! %atomic-fxbox-fetch-add "atomic_fetch_add") + (fx-num-op atomic-fxbox-/fetch! %atomic-fxbox-/fetch! "atomic_fetch_sub") + (fx-num-op atomic-fxbox-and/fetch! %atomic-fxbox-and/fetch! "atomic_fetch_and") + (fx-num-op atomic-fxbox-ior/fetch! %atomic-fxbox-ior/fetch! "atomic_fetch_or") + (fx-num-op atomic-fxbox-xor/fetch! %atomic-fxbox-xor/fetch! "atomic_fetch_xor") + (fx-num-op atomic-fxbox-swap! %atomic-fxbox-exchange "atomic_exchange") + + (define-record-type atomic-fxbox + (%make-atomic-fxbox content) + atomic-fxbox? + (content atomic-fxbox-content atomic-fxbox-set-content!)) + + (define (make-atomic-fxbox c) + (define b (%make-atomic-fxbox (%empty-opaque))) + (Cyc-minor-gc) ;; Force b onto heap + (%atomic-fxbox-init (atomic-fxbox-content b) c) + b) + + (define (atomic-fxbox-check box) + (unless (atomic-fxbox? box) + (error "Expected atomic fxbox but received" box))) + + (define (atomic-fxbox-ref box . o) + (atomic-fxbox-check box) + (%atomic-fxbox-load (atomic-fxbox-content box))) + + (define (atomic-fxbox-set! box obj . o) + (atomic-fxbox-check box) + (%atomic-fxbox-store (atomic-fxbox-content box) obj)) + + (define (atomic-fxbox-swap! box obj . o) + (atomic-fxbox-check box) + (%atomic-fxbox-exchange (atomic-fxbox-content box) obj)) + + (define (atomic-fxbox-compare-and-swap! box expected desired . o) + (atomic-fxbox-check box) + (%atomic-fxbox-compare-exchange (atomic-fxbox-content box) expected desired)) + + + ;; Memory synchronization + + (define (atomic-fence . o) + (%atomic-fence (if (pair? o) (car o) #f))) + + (define-c %atomic-fence + "(void *data, int argc, closure _, object k, object order)" + " atomic_thread_fence( scm2c_memory_order(order) ); + return_closcall1(data, k, boolean_t); ") + )) diff --git a/srfi/utils.c b/srfi/utils.c new file mode 100644 index 0000000..e5da3e0 --- /dev/null +++ b/srfi/utils.c @@ -0,0 +1,42 @@ +// Copyright (C) Justin Ethier (2021). All Rights Reserved. +// +// Permission is hereby granted, free of charge, to any person +// obtaining a copy of this software and associated documentation +// files (the "Software"), to deal in the Software without +// restriction, including without limitation the rights to use, copy, +// modify, merge, publish, distribute, sublicense, and/or sell copies +// of the Software, and to permit persons to whom the Software is +// furnished to do so, subject to the following conditions: +// +// The above copyright notice and this permission notice shall be +// included in all copies or substantial portions of the Software. +// +// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +// EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +// MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +// NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +// BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +// ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +// CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +// SOFTWARE. + +#include "cyclone/types.h" +static object quote_sequentially_91consistent; +static object quote_acquire_91release; +static object quote_release; +static object quote_acquire; +static object quote_relaxed; + +memory_order scm2c_memory_order(object mo) { + if (mo == quote_acquire_91release) { + return memory_order_acq_rel; + } else if (mo == quote_release) { + return memory_order_release; + } else if (mo == quote_acquire) { + return memory_order_acquire; + } else if (mo == quote_relaxed) { + return memory_order_relaxed; + } else { + return memory_order_seq_cst; + } +} diff --git a/test.scm b/test.scm new file mode 100644 index 0000000..c0f7925 --- /dev/null +++ b/test.scm @@ -0,0 +1,115 @@ +;; Copyright (C) Justin Ethier (2021). All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(import (scheme base) + (scheme write) + (srfi 18) + (srfi 230) + (cyclone test)) + +;; Atomic flags - Basic example of using flags to create a spin lock +(define *flag* (make-atomic-flag)) +(define *counter* 0) + +(define (spin-lock flag) + (let loop () + (if (atomic-flag-test-and-set! flag) + (loop)))) + +(define (spin-unlock flag) + (atomic-flag-clear! flag)) + +(define (atomic-flag-task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + (spin-lock *flag*) + (set! *counter* (+ *counter* 1)) + (spin-unlock *flag*) )) + +;; Atomic boxes +(define *atomic-box* (make-atomic-box 0.0)) + +(define (atomic-box-task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + (let loop () + (let ((expected (atomic-box-ref *atomic-box*))) + (if (not (eq? expected (atomic-box-compare-and-swap! *atomic-box* expected (+ expected 1)))) + (loop)))))) + +;; Atomic fxboxes +(define *atomic-fxbox* (make-atomic-fxbox 0)) + +(define (atomic-fxbox-task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + (let loop () + (let ((expected (atomic-fxbox-ref *atomic-fxbox*))) + (if (not (eq? expected (atomic-fxbox-compare-and-swap! *atomic-fxbox* expected (+ expected 1)))) + (loop)))) + )) + +(define *atomic-counter* (make-atomic-fxbox 0)) + +(define (atomic-counter-task) + (do ((i 0 (+ i 1))) + ((= i 100000)) + (atomic-fxbox+/fetch! *atomic-counter* 1) + )) + +;; Core task runner +(define (run thunk result-thunk) + (define threads (make-vector 10)) + + (do ((i 0 (+ i 1))) + ((= i 10)) + (let ((thread (make-thread thunk))) + (vector-set! threads i thread) + (thread-start! thread))) + + (do ((i 0 (+ i 1))) + ((= i 10)) + (thread-join! (vector-ref threads i))) + + (result-thunk)) + +;; Test cases +(test-group "atomic flag" + (test 1000000 (run atomic-flag-task + (lambda () + *counter*)))) + +(test-group "atomic box" + (test 1000000.0 (run atomic-box-task + (lambda () + (atomic-box-ref *atomic-box*))))) + +(test-group "atomic fxbox" + (test 1000000 (run atomic-fxbox-task + (lambda () + (atomic-fxbox-ref *atomic-fxbox*)))) + (test 1000000 (run atomic-counter-task + (lambda () + (atomic-fxbox-ref *atomic-counter*)))) + ) + +(test-exit)