perf(runtime): add a padded variant of atomic counter

src/runtime-prototype/bench/disruptor/SingleOps.hs

@@ -3,13 +3,15 @@
 module Main where
 
 import Control.Monad
+import Control.Concurrent.Async
 import Data.Time
 import Data.Word
 import Data.Atomics.Counter
 import Data.IORef
 import System.CPUTime
 
 import StuntDouble.Histogram
+import qualified StuntDouble.AtomicCounterPadded as Padded
 
 ------------------------------------------------------------------------
 
@@ -20,12 +22,21 @@ main = do
   many "getCPUTime" (return ()) (const getCPUTime)
 
   many "incrCounter1" (newCounter 0) (incrCounter 1)
+  many "incrCounter1Padded" (Padded.newCounter 0) (Padded.incrCounter 1)
+
+  manyConcurrent "incrCounter1Concurrent"
+    3 (newCounter 0) (incrCounter 1)
+  manyConcurrent "incrCounter1PaddedConcurrent"
+    3 (Padded.newCounter 0) (Padded.incrCounter 1)
 
   many "modifyIORef'" (newIORef (0 :: Int)) (\r -> modifyIORef' r succ)
 
   many "atomicModifyIORef'"
     (newIORef (0 :: Int)) (\r -> atomicModifyIORef' r (\n -> ((n + 1), ())))
 
+  manyConcurrent "atomicModifyIORef'Concurrent" 3
+    (newIORef (0 :: Int)) (\r -> atomicModifyIORef' r (\n -> ((n + 1), ())))
+
 many :: String -> IO a -> (a -> IO b) -> IO ()
 many name create use = do
   h <- newHistogram
@@ -35,6 +46,16 @@ many name create use = do
   putStrLn ""
   prettyPrintHistogram name h
 
+manyConcurrent :: String -> Int -> IO a -> (a -> IO b) -> IO ()
+manyConcurrent name n create use = do
+  h <- newHistogram
+  r <- create
+  as <- replicateM n (async (replicateM 500000 (once h (use r))))
+  mapM_ wait as
+  putStrLn ""
+  putStrLn ""
+  prettyPrintHistogram name h
+
 once :: Histogram -> IO a -> IO ()
 once h io = do
   start <- fromInteger <$> getCPUTime

src/runtime-prototype/src/StuntDouble/AtomicCounterPadded.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-- Inspired by:
+--   https://github.com/jberryman/unagi-chan/blob/master/src/Data/Atomics/Counter/Fat.hs
+-- and:
+--   https://hackage.haskell.org/package/atomic-primops-0.8.4/docs/src/Data.Atomics.Counter.html
+
+module StuntDouble.AtomicCounterPadded
+    ( AtomicCounter()
+    , newCounter
+    , incrCounter
+    , readCounter
+    ) where
+
+import Control.Monad.Primitive (RealWorld)
+import Data.Primitive.MachDeps (sIZEOF_INT)
+import GHC.Exts
+import GHC.Types
+
+------------------------------------------------------------------------
+
+data AtomicCounter = AtomicCounter (MutableByteArray# RealWorld)
+
+sIZEOF_CACHELINE :: Int
+sIZEOF_CACHELINE = 64
+{-# INLINE sIZEOF_CACHELINE #-}
+
+-- | Create a new atomic counter padded with 64-bytes (an x86 cache line) on
+-- either side to try to avoid false sharing.
+newCounter :: Int -> IO AtomicCounter
+newCounter (I# n) = IO $ \realWorld ->
+  let I# sz = sIZEOF_CACHELINE in
+  case newAlignedPinnedByteArray# sz sz realWorld of
+    (# realWorld', arr #) -> case writeIntArray# arr 0# n realWorld' of
+      realWorld'' -> (# realWorld'', AtomicCounter arr #)
+{-# INLINE newCounter #-}
+
+incrCounter :: Int -> AtomicCounter -> IO Int
+incrCounter (I# incr) (AtomicCounter arr) =
+  IO (\realWorld -> case fetchAddIntArray# arr 0# incr realWorld of
+                      (# realWorld', i #) -> (# realWorld', I# i #))
+{-# INLINE incrCounter #-}
+
+readCounter :: AtomicCounter -> IO Int
+readCounter (AtomicCounter arr) =
+  IO (\realWorld -> case readIntArray# arr 0# realWorld of
+                      (# realWorld', i #) -> (# realWorld', I# i #))
+{-# INLINE readCounter #-}

src/runtime-prototype/src/StuntDouble/Histogram/SingleProducer.hs

@@ -51,8 +51,8 @@ newHistogram = Histogram
 -- compression loss is less than @1%@.
 measure :: RealFrac a => a -> Histogram -> IO Int
 measure v h = do
-  modifyIORef' (histoSum h)     (+ round v)
-  modifyIORef' (histoCount h)   (+ 1)
+  modifyIORef' (histoSum   h) (+ round v)
+  modifyIORef' (histoCount h) (+ 1)
   let ix = fromIntegral (compress v)
   count <- Vector.read (histoValues h) ix
   Vector.write (histoValues h) ix (count + 1)

src/runtime-prototype/stunt-double.cabal

@@ -35,6 +35,7 @@ library
     StuntDouble.Envelope
     StuntDouble.FreeMonad
     StuntDouble.Frontend.Http
+    StuntDouble.AtomicCounterPadded
     StuntDouble.Histogram
     StuntDouble.Histogram.SingleProducer
     StuntDouble.IO
@@ -72,6 +73,8 @@ library
       aeson
     , async
     , atomic-primops
+    , primitive
+    , ghc-prim
     , brick
     , bytestring
     , hashable
@@ -207,6 +210,7 @@ benchmark bench-disruptor-singleops
   main-is:        SingleOps.hs
   build-depends:
       atomic-primops
+    , async
     , base
     , stunt-double
     , time