Weird issue with Guile 3.0.9's `atomic-box-swap!`

possible-patch-for-swpal-and-casal.patch

diff --git a/libguile/lightening/lightening/aarch64-cpu.c b/libguile/lightening/lightening/aarch64-cpu.c
index 13aa351e9..a47900b7c 100644
--- a/libguile/lightening/lightening/aarch64-cpu.c
+++ b/libguile/lightening/lightening/aarch64-cpu.c
@@ -225,6 +225,8 @@ oxxrs(jit_state_t *_jit, int32_t Op,
 #define A64_STLR                      0xc89ffc00
 #define A64_LDAXR                     0xc85ffc00
 #define A64_STLXR                     0xc800fc00
+#define A64_SWPAL                     0xf8e08000
+#define A64_CASAL                     0xc8e0fc00
 #define A64_STRBI                     0x39000000
 #define A64_LDRBI                     0x39400000
 #define A64_LDRSBI                    0x39800000
@@ -675,6 +677,18 @@ STLXR(jit_state_t *_jit, int32_t Rt, int32_t Rn, int32_t Rm)
   return oxxx(_jit, A64_STLXR, Rt, Rn, Rm);
 }
 
+static void
+SWPAL(jit_state_t *_jit, int32_t Rt, int32_t Rn, int32_t Rs)
+{
+  return oxxx(_jit, A64_SWPAL, Rt, Rn, Rs);
+}
+
+static void
+CASAL(jit_state_t *_jit, int32_t Rt, int32_t Rn, int32_t Rs)
+{
+  return oxxx(_jit, A64_CASAL, Rt, Rn, Rs);
+}
+
 static void
 LDRSB(jit_state_t *_jit, int32_t Rt, int32_t Rn, int32_t Rm) 
 {
@@ -2532,36 +2546,17 @@ str_atomic(jit_state_t *_jit, int32_t loc, int32_t val)
 static void
 swap_atomic(jit_state_t *_jit, int32_t dst, int32_t loc, int32_t val)
 {
-  void *retry = jit_address(_jit);
-  int32_t result = jit_gpr_regno(get_temp_gpr(_jit));
-  int32_t val_or_tmp = dst == val ? jit_gpr_regno(get_temp_gpr(_jit)) : val;
-  movr(_jit, val_or_tmp, val);
-  LDAXR(_jit, dst, loc);
-  STLXR(_jit, val_or_tmp, loc, result);
-  jit_patch_there(_jit, bnei(_jit, result, 0), retry);
-  if (dst == val) unget_temp_gpr(_jit);
-  unget_temp_gpr(_jit);
+  SWPAL(_jit, dst, loc, val);
 }
 
 static void
 cas_atomic(jit_state_t *_jit, int32_t dst, int32_t loc, int32_t expected,
            int32_t desired)
 {
-  int32_t dst_or_tmp;
-  if (dst == loc || dst == expected || dst == expected)
-    dst_or_tmp = jit_gpr_regno(get_temp_gpr(_jit));
-  else
-    dst_or_tmp = dst;
-  void *retry = jit_address(_jit);
-  LDAXR(_jit, dst_or_tmp, loc);
-  jit_reloc_t bad = bner(_jit, dst_or_tmp, expected);
-  int result = jit_gpr_regno(get_temp_gpr(_jit));
-  STLXR(_jit, desired, loc, result);
-  jit_patch_there(_jit, bnei(_jit, result, 0), retry);
-  unget_temp_gpr(_jit);
-  jit_patch_here(_jit, bad);
-  movr(_jit, dst, dst_or_tmp);
-  unget_temp_gpr(_jit);
+  if (dst != expected) {
+    movr(_jit, dst, expected);
+  }
+  CASAL(_jit, desired, loc, dst);
 }
 
 static void

possible-patch-for-swpal.patch

diff --git a/libguile/lightening/lightening/aarch64-cpu.c b/libguile/lightening/lightening/aarch64-cpu.c
index 13aa351e9..15f903652 100644
--- a/libguile/lightening/lightening/aarch64-cpu.c
+++ b/libguile/lightening/lightening/aarch64-cpu.c
@@ -225,6 +225,7 @@ oxxrs(jit_state_t *_jit, int32_t Op,
 #define A64_STLR                      0xc89ffc00
 #define A64_LDAXR                     0xc85ffc00
 #define A64_STLXR                     0xc800fc00
+#define A64_SWPAL                     0xf8e08000
 #define A64_STRBI                     0x39000000
 #define A64_LDRBI                     0x39400000
 #define A64_LDRSBI                    0x39800000
@@ -675,6 +676,12 @@ STLXR(jit_state_t *_jit, int32_t Rt, int32_t Rn, int32_t Rm)
   return oxxx(_jit, A64_STLXR, Rt, Rn, Rm);
 }
 
+static void
+SWPAL(jit_state_t *_jit, int32_t Rt, int32_t Rn, int32_t Rs)
+{
+  return oxxx(_jit, A64_SWPAL, Rt, Rn, Rs);
+}
+
 static void
 LDRSB(jit_state_t *_jit, int32_t Rt, int32_t Rn, int32_t Rm) 
 {
@@ -2532,15 +2539,7 @@ str_atomic(jit_state_t *_jit, int32_t loc, int32_t val)
 static void
 swap_atomic(jit_state_t *_jit, int32_t dst, int32_t loc, int32_t val)
 {
-  void *retry = jit_address(_jit);
-  int32_t result = jit_gpr_regno(get_temp_gpr(_jit));
-  int32_t val_or_tmp = dst == val ? jit_gpr_regno(get_temp_gpr(_jit)) : val;
-  movr(_jit, val_or_tmp, val);
-  LDAXR(_jit, dst, loc);
-  STLXR(_jit, val_or_tmp, loc, result);
-  jit_patch_there(_jit, bnei(_jit, result, 0), retry);
-  if (dst == val) unget_temp_gpr(_jit);
-  unget_temp_gpr(_jit);
+  SWPAL(_jit, dst, loc, val);
 }
 
 static void

t5.c

// cc -O3 -o t5 t5.c && ./t5
//
// This program does *not* fail like the more-or-less-hopefully-equivalent-t5.scm does.

#include <stdlib.h>
#include <stdio.h>
#include <stdatomic.h>
#include <stdint.h>

atomic_uintptr_t r = 1;

static void die(char const* msg) {
  fprintf(stderr, "%s\n", msg);
  abort();
}

int main(int argc, char const* argv[]) {
  while (1) {
    uintptr_t v = atomic_load(&r);
    if (v == 0) die("got 0 from load");
    {
      uintptr_t w = v;
      if (!atomic_compare_exchange_strong(&r, &w, 0)) die("cas failure in get");
    }
    if ((v % 10000000) == 0) {
      printf("%lu\n", v);
    }
    if (atomic_exchange(&r, v + 1) != 0) die("swap failed in put");
  }

  return 0;
}

t5.scm

;; Eventually this fails with "q null in get" if `atomic-box-swap!` is used where marked (*)
;; below. It takes usually between hundreds of millions and a few billion increments to fail.
;;
;; It does NOT fail if the line marked (*) is commented out and the line below it mentioning
;; `atomic-box-compare-and-swap!` is uncommented and used instead.
;;
;; The failure happens on OSX Sonoma 14.4.1 on a MacBook Pro running an M3 Pro CPU using Guile
;; version 3.0.9 from Homebrew as of 2024-04-17.
;;
;; $ uname -a
;; Darwin tonyg.local 23.4.0 Darwin Kernel Version 23.4.0: Fri Mar 15 00:12:25 PDT 2024; root:xnu-10063.101.17~1/RELEASE_ARM64_T6030 arm64
;; $ guile --version
;; guile (GNU Guile) 3.0.9
;;
;; It does NOT happen on AMD x86_64 Debian linux with Guile 3.0.9 from Debian packaging.

(use-modules (ice-9 atomic))

(define r (make-atomic-box '(0)))

(let loop ()
  (let ((v (let ((q (atomic-box-ref r)))
             (when (null? q) (error "q null in get"))
             (unless (eq? (atomic-box-compare-and-swap! r q (cdr q)) q) (error "CAS failed in get"))
             (car q))))

    (when (zero? (remainder v 10000000)) (write v) (newline))

    (unless (null?
             (atomic-box-swap! r (list (+ v 1))) ;; (*)
             ;; (atomic-box-compare-and-swap! r '() (list (+ v 1)))
             )
      (error "swap failed in put"))

    (loop)))