genSym: Reimplement via CAS on 32-bit platforms

Previously the remaining use of the C implementation on 32-bit platforms
resulted in a subtle bug, #24261. This was due to the C object (which
used the RTS's `atomic_inc64` macro) being compiled without `-threaded`
yet later being used in a threaded compiler.

Side-step this issue by using the pure Haskell `genSym` implementation on
all platforms. This required implementing `fetchAddWord64Addr#` in terms
of CAS on 64-bit platforms.

compiler/GHC/Types/Unique/Supply.hs

@@ -45,15 +45,20 @@ import Foreign.Storable
 
 #include "MachDeps.h"
 
-#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) && WORD_SIZE_IN_BITS == 64
-import GHC.Word( Word64(..) )
-import GHC.Exts( fetchAddWordAddr#, plusWord#, readWordOffAddr# )
-#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
-import GHC.Exts( wordToWord64# )
+#if WORD_SIZE_IN_BITS != 64
+#define NO_FETCH_ADD
 #endif
+
+#if defined(NO_FETCH_ADD)
+import GHC.Exts ( atomicCasWord64Addr#, eqWord64# )
+#else
+import GHC.Exts( fetchAddWordAddr#, word64ToWord#, wordToWord64# )
 #endif
 
-#include "Unique.h"
+import GHC.Exts ( Addr#, State#, Word64#, RealWorld )
+
+import GHC.Word( Word64(..) )
+import GHC.Exts( plusWord64#, readWord64OffAddr# )
 
 {-
 ************************************************************************
@@ -228,25 +233,37 @@ mkSplitUniqSupply c
         (# s4, MkSplitUniqSupply (tag .|. u) x y #)
         }}}}
 
--- If a word is not 64 bits then we would need a fetchAddWord64Addr# primitive,
--- which does not exist. So we fall back on the C implementation in that case.
-
-#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) || WORD_SIZE_IN_BITS != 64
-foreign import ccall unsafe "genSym" genSym :: IO Word64
+#if defined(NO_FETCH_ADD)
+-- GHC currently does not provide this operation on 32-bit platforms,
+-- hence the CAS-based implementation.
+fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld
+                    -> (# State# RealWorld, Word64# #)
+fetchAddWord64Addr# = go
+  where
+    go ptr inc s0 =
+      case readWord64OffAddr# ptr 0# s0 of
+        (# s1, n0 #) ->
+          case atomicCasWord64Addr# ptr n0 (n0 `plusWord64#` inc) s1 of
+            (# s2, res #)
+              | 1# <- res `eqWord64#` n0 -> (# s2, n0 #)
+              | otherwise -> go ptr inc s2
 #else
+fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld
+                    -> (# State# RealWorld, Word64# #)
+fetchAddWord64Addr# addr inc s0 =
+    case fetchAddWordAddr# addr (word64ToWord# inc) s0 of
+      (# s1, res #) -> (# s1, wordToWord64# res #)
+#endif
+
 genSym :: IO Word64
 genSym = do
     let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1
     let !(Ptr counter) = ghc_unique_counter64
     let !(Ptr inc_ptr) = ghc_unique_inc
-    u <- IO $ \s0 -> case readWordOffAddr# inc_ptr 0# s0 of
-        (# s1, inc #) -> case fetchAddWordAddr# counter inc s1 of
+    u <- IO $ \s0 -> case readWord64OffAddr# inc_ptr 0# s0 of
+        (# s1, inc #) -> case fetchAddWord64Addr# counter inc s1 of
             (# s2, val #) ->
-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
-                let !u = W64# (val `plusWord#` inc) .&. mask
-#else
-                let !u = W64# (wordToWord64# (val `plusWord#` inc)) .&. mask
-#endif
+                let !u = W64# (val `plusWord64#` inc) .&. mask
                 in (# s2, u #)
 #if defined(DEBUG)
     -- Uh oh! We will overflow next time a unique is requested.
@@ -254,7 +271,6 @@ genSym = do
     massert (u /= mask)
 #endif
     return u
-#endif
 
 foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64
 foreign import ccall unsafe "&ghc_unique_inc"       ghc_unique_inc       :: Ptr Int

compiler/cbits/genSym.c

@@ -16,26 +16,3 @@ HsWord64 ghc_unique_counter64 = 0;
 HsInt ghc_unique_inc     = 1;
 #endif
 
-// This function has been added to the RTS. Here we pessimistically assume
-// that a threaded RTS is used. This function is only used for bootstrapping.
-#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
-EXTERN_INLINE StgWord64
-atomic_inc64(StgWord64 volatile* p, StgWord64 incr)
-{
-#if defined(HAVE_C11_ATOMICS)
-    return __atomic_add_fetch(p, incr, __ATOMIC_SEQ_CST);
-#else
-    return __sync_add_and_fetch(p, incr);
-#endif
-}
-#endif
-
-#define UNIQUE_BITS (sizeof (HsWord64) * 8 - UNIQUE_TAG_BITS)
-#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)
-
-HsWord64 genSym(void) {
-    HsWord64 u = atomic_inc64((StgWord64 *)&ghc_unique_counter64, ghc_unique_inc) & UNIQUE_MASK;
-    // Uh oh! We will overflow next time a unique is requested.
-    ASSERT(u != UNIQUE_MASK);
-    return u;
-}

compiler/jsbits/genSym.js

@@ -16,11 +16,3 @@ var h$ghc_unique_counter64   = h$newByteArray(8);
 h$ghc_unique_counter64.i3[0] = 0;
 h$ghc_unique_counter64.i3[1] = 0;
 
-function h$genSym() {
-  var rl = h$hs_plusWord64(h$ghc_unique_counter64.i3[1] >>> 0, h$ghc_unique_counter64.i3[0] >>> 0, 0, h$ghc_unique_inc.i3[0] >>> 0);
-  h$ret1 = (h$ret1 & HIGH_UNIQUE_MASK) >>> 0;
-  // h$ret1 contains the higher part (rh)
-  h$ghc_unique_counter64.i3[0] = rl | 0;
-  h$ghc_unique_counter64.i3[1] = h$ret1 | 0;
-  return rl; // h$ret1 still contains rh
-}