[Git][ghc/ghc][wip/genSym-32] genSym: Reimplement via CAS on 32-bit platforms

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/genSym-32 at Glasgow Haskell Compiler / GHC


Commits:
e3895a2c by Ben Gamari at 2023-12-21T09:54:32-05:00
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.

- - - - -


3 changed files:

- compiler/GHC/Types/Unique/Supply.hs
- compiler/cbits/genSym.c
- compiler/jsbits/genSym.js


Changes:

=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -228,12 +228,22 @@ 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 WORD_SIZE_IN_BITS != 64
+-- 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
+#endif
 
-#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) || WORD_SIZE_IN_BITS != 64
-foreign import ccall unsafe "genSym" genSym :: IO Word64
-#else
 genSym :: IO Word64
 genSym = do
     let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1
@@ -254,7 +264,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
-}



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3895a2c10afb2df2b86a83d7e84fd8a4e8becdb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3895a2c10afb2df2b86a83d7e84fd8a4e8becdb
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231221/f60890a2/attachment-0001.html>