{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2015 Edward Kmett, Paul Khuong and Ted Cooper
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>,
--                Ted Cooper <anthezium@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- QSBR-based RCU
-----------------------------------------------------------------------------
module Control.Concurrent.RCU.GC.Internal
  ( SRef(..)
  , RCUThread(..)
  , RCU(..)
  , runRCU
  , runOnRCU
  , ReadingRCU(..)
  , WritingRCU(..)
  , RCUState(..)
#if BENCHMARKS
  , unRCU
  , runWritingRCU
  , runReadingRCU
  , writeSRefIO
#endif
  ) where

import Control.Applicative
import Control.Concurrent
import Control.Concurrent.RCU.Class
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Primitive
import Control.Parallel
import Data.Atomics
import Data.IORef
import qualified Data.List as L
import Data.Primitive
import Prelude hiding (Read(..))
import System.Mem
import qualified Control.Monad.Fail as Fail

--------------------------------------------------------------------------------
-- * Shared References
--------------------------------------------------------------------------------

-- | Shared references
newtype SRef s a = SRef { forall s a. SRef s a -> IORef a
unSRef :: IORef a }
  deriving SRef s a -> SRef s a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s a. SRef s a -> SRef s a -> Bool
/= :: SRef s a -> SRef s a -> Bool
$c/= :: forall s a. SRef s a -> SRef s a -> Bool
== :: SRef s a -> SRef s a -> Bool
$c== :: forall s a. SRef s a -> SRef s a -> Bool
Eq

newSRefIO :: a -> IO (IORef a)
newSRefIO :: forall a. a -> IO (IORef a)
newSRefIO = forall a. a -> IO (IORef a)
newIORef
{-# INLINE newSRefIO #-}

readSRefIO :: IORef a -> IO a
readSRefIO :: forall a. IORef a -> IO a
readSRefIO = forall a. IORef a -> IO a
readIORef
{-# INLINE readSRefIO #-}

writeSRefIO :: IORef a -> a ->  IO ()
writeSRefIO :: forall a. IORef a -> a -> IO ()
writeSRefIO IORef a
r a
a = do a
a forall a b. a -> b -> b
`pseq` IO ()
writeBarrier
                     forall a. IORef a -> a -> IO ()
writeIORef IORef a
r a
a
{-# INLINE writeSRefIO #-}

--------------------------------------------------------------------------------
-- * Shared state
--------------------------------------------------------------------------------

-- | Counter for causal ordering.
newtype Counter = Counter (MutableByteArray RealWorld)

instance Eq Counter where
  Counter MutableByteArray RealWorld
m == :: Counter -> Counter -> Bool
== Counter MutableByteArray RealWorld
n = forall s. MutableByteArray s -> MutableByteArray s -> Bool
sameMutableByteArray MutableByteArray RealWorld
m MutableByteArray RealWorld
n

newCounter :: Int -> IO Counter
newCounter :: Int -> IO Counter
newCounter Int
w = do
  MutableByteArray RealWorld
b <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
8
  forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
b Int
0 Int
w
  forall (m :: * -> *) a. Monad m => a -> m a
return (MutableByteArray RealWorld -> Counter
Counter MutableByteArray RealWorld
b)
{-# INLINE newCounter #-}

readCounter :: Counter -> IO Int
readCounter :: Counter -> IO Int
readCounter (Counter MutableByteArray RealWorld
c) = forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray MutableByteArray RealWorld
c Int
0
{-# INLINE readCounter #-}

writeCounter :: Counter -> Int -> IO ()
writeCounter :: Counter -> Int -> IO ()
writeCounter (Counter MutableByteArray RealWorld
c) Int
w = forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
c Int
0 Int
w
{-# INLINE writeCounter #-}

incCounter :: Counter -> IO Int
incCounter :: Counter -> IO Int
incCounter (Counter MutableByteArray RealWorld
c) = do
  Int
x <- MutableByteArray RealWorld -> Int -> Int -> IO Int
fetchAddIntArray MutableByteArray RealWorld
c Int
0 Int
1
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Int
x forall a. Num a => a -> a -> a
+ Int
1
{-# INLINE incCounter #-}

newtype Version = Version (IORef ())

newVersion :: IO Version
newVersion :: IO Version
newVersion = IORef () -> Version
Version forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef ()

-- | State for an RCU computation.
data RCUState = RCUState
  { -- | Global state
    RCUState -> Counter
rcuStateGlobalCounter   :: {-# UNPACK #-} !Counter
  , RCUState -> IORef Version
rcuStateGlobalVersion   :: {-# UNPACK #-} !(IORef Version)
  , RCUState -> MVar [Counter]
rcuStateThreadCountersV :: {-# UNPACK #-} !(MVar [Counter])
  , RCUState -> MVar ()
rcuStateWriterLockV     :: {-# UNPACK #-} !(MVar ())
    -- | Thread state
  , RCUState -> Counter
rcuStateMyCounter       :: {-# UNPACK #-} !Counter  -- each thread's state gets its own counter
  , RCUState -> Maybe Int
rcuStatePinned          ::                !(Maybe Int)
  }

--------------------------------------------------------------------------------
-- * Read-Side Critical Sections
--------------------------------------------------------------------------------

-- | This is the basic read-side critical section for an RCU computation
newtype ReadingRCU s a = ReadingRCU { forall s a. ReadingRCU s a -> RCUState -> IO a
runReadingRCU :: RCUState -> IO a }
  deriving forall a b. a -> ReadingRCU s b -> ReadingRCU s a
forall a b. (a -> b) -> ReadingRCU s a -> ReadingRCU s b
forall s a b. a -> ReadingRCU s b -> ReadingRCU s a
forall s a b. (a -> b) -> ReadingRCU s a -> ReadingRCU s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ReadingRCU s b -> ReadingRCU s a
$c<$ :: forall s a b. a -> ReadingRCU s b -> ReadingRCU s a
fmap :: forall a b. (a -> b) -> ReadingRCU s a -> ReadingRCU s b
$cfmap :: forall s a b. (a -> b) -> ReadingRCU s a -> ReadingRCU s b
Functor

instance Applicative (ReadingRCU s) where
  pure :: forall a. a -> ReadingRCU s a
pure a
a = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  ReadingRCU RCUState -> IO (a -> b)
mf <*> :: forall a b.
ReadingRCU s (a -> b) -> ReadingRCU s a -> ReadingRCU s b
<*> ReadingRCU RCUState -> IO a
ma = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> RCUState -> IO (a -> b)
mf RCUState
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RCUState -> IO a
ma RCUState
s

instance Monad (ReadingRCU s) where
  ReadingRCU RCUState -> IO a
m >>= :: forall a b.
ReadingRCU s a -> (a -> ReadingRCU s b) -> ReadingRCU s b
>>= a -> ReadingRCU s b
f = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> do
    a
a <- RCUState -> IO a
m RCUState
s
    forall s a. ReadingRCU s a -> RCUState -> IO a
runReadingRCU (a -> ReadingRCU s b
f a
a) RCUState
s
#if !(MIN_VERSION_base(4,11,0))
  return a = ReadingRCU $ \ _ -> pure a
#endif
#if !(MIN_VERSION_base(4,13,0))
  fail = Fail.fail
#endif

instance Fail.MonadFail (ReadingRCU s) where
  fail :: forall a. String -> ReadingRCU s a
fail String
s = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s

instance Alternative (ReadingRCU s) where
  empty :: forall a. ReadingRCU s a
empty = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (f :: * -> *) a. Alternative f => f a
empty
  ReadingRCU RCUState -> IO a
ma <|> :: forall a. ReadingRCU s a -> ReadingRCU s a -> ReadingRCU s a
<|> ReadingRCU RCUState -> IO a
mb = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \RCUState
s -> RCUState -> IO a
ma RCUState
s forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RCUState -> IO a
mb RCUState
s

instance MonadPlus (ReadingRCU s) where
  mzero :: forall a. ReadingRCU s a
mzero = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
  ReadingRCU RCUState -> IO a
ma mplus :: forall a. ReadingRCU s a -> ReadingRCU s a -> ReadingRCU s a
`mplus` ReadingRCU RCUState -> IO a
mb = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \RCUState
s -> RCUState -> IO a
ma RCUState
s forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` RCUState -> IO a
mb RCUState
s

instance MonadNew (SRef s) (ReadingRCU s) where
  newSRef :: forall a. a -> ReadingRCU s (SRef s a)
newSRef a
a = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \RCUState
_ -> forall s a. IORef a -> SRef s a
SRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newSRefIO a
a

instance MonadReading (SRef s) (ReadingRCU s) where
  readSRef :: forall a. SRef s a -> ReadingRCU s a
readSRef (SRef IORef a
r) = forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall a. IORef a -> IO a
readSRefIO IORef a
r
  {-# INLINE readSRef #-}

--------------------------------------------------------------------------------
-- * Write-Side Critical Sections
--------------------------------------------------------------------------------

-- | This is the basic write-side critical section for an RCU computation
newtype WritingRCU s a = WritingRCU { forall s a. WritingRCU s a -> RCUState -> IO a
runWritingRCU :: RCUState -> IO a }
  deriving forall a b. a -> WritingRCU s b -> WritingRCU s a
forall a b. (a -> b) -> WritingRCU s a -> WritingRCU s b
forall s a b. a -> WritingRCU s b -> WritingRCU s a
forall s a b. (a -> b) -> WritingRCU s a -> WritingRCU s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WritingRCU s b -> WritingRCU s a
$c<$ :: forall s a b. a -> WritingRCU s b -> WritingRCU s a
fmap :: forall a b. (a -> b) -> WritingRCU s a -> WritingRCU s b
$cfmap :: forall s a b. (a -> b) -> WritingRCU s a -> WritingRCU s b
Functor

instance Applicative (WritingRCU s) where
  pure :: forall a. a -> WritingRCU s a
pure a
a = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  WritingRCU RCUState -> IO (a -> b)
mf <*> :: forall a b.
WritingRCU s (a -> b) -> WritingRCU s a -> WritingRCU s b
<*> WritingRCU RCUState -> IO a
ma = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> RCUState -> IO (a -> b)
mf RCUState
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RCUState -> IO a
ma RCUState
s

instance Monad (WritingRCU s) where
  WritingRCU RCUState -> IO a
m >>= :: forall a b.
WritingRCU s a -> (a -> WritingRCU s b) -> WritingRCU s b
>>= a -> WritingRCU s b
f = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> do
    a
a <- RCUState -> IO a
m RCUState
s
    forall s a. WritingRCU s a -> RCUState -> IO a
runWritingRCU (a -> WritingRCU s b
f a
a) RCUState
s
#if !(MIN_VERSION_base(4,11,0))
  return a = WritingRCU $ \ _ -> pure a
#endif
#if !(MIN_VERSION_base(4,13,0))
  fail = Fail.fail
#endif

instance Fail.MonadFail (WritingRCU s) where
  fail :: forall a. String -> WritingRCU s a
fail String
s = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s

instance Alternative (WritingRCU s) where
  empty :: forall a. WritingRCU s a
empty = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (f :: * -> *) a. Alternative f => f a
empty
  WritingRCU RCUState -> IO a
ma <|> :: forall a. WritingRCU s a -> WritingRCU s a -> WritingRCU s a
<|> WritingRCU RCUState -> IO a
mb = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \RCUState
s -> RCUState -> IO a
ma RCUState
s forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RCUState -> IO a
mb RCUState
s

instance MonadPlus (WritingRCU s) where
  mzero :: forall a. WritingRCU s a
mzero = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
  WritingRCU RCUState -> IO a
ma mplus :: forall a. WritingRCU s a -> WritingRCU s a -> WritingRCU s a
`mplus` WritingRCU RCUState -> IO a
mb = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \RCUState
s -> RCUState -> IO a
ma RCUState
s forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` RCUState -> IO a
mb RCUState
s

instance MonadNew (SRef s) (WritingRCU s) where
  newSRef :: forall a. a -> WritingRCU s (SRef s a)
newSRef a
a = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \RCUState
_ -> forall s a. IORef a -> SRef s a
SRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newSRefIO a
a

instance MonadReading (SRef s) (WritingRCU s) where
  readSRef :: forall a. SRef s a -> WritingRCU s a
readSRef (SRef IORef a
r) = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall a. IORef a -> IO a
readSRefIO IORef a
r
  {-# INLINE readSRef #-}

instance MonadWriting (SRef s) (WritingRCU s) where
  writeSRef :: forall a. SRef s a -> a -> WritingRCU s ()
writeSRef (SRef IORef a
r) a
a = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall a. IORef a -> a -> IO ()
writeSRefIO IORef a
r a
a
  {-# INLINE writeSRef #-}
  synchronize :: WritingRCU s ()
synchronize = forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU RCUState -> IO ()
synchronizeIO

synchronizeIO :: RCUState -> IO ()
synchronizeIO :: RCUState -> IO ()
synchronizeIO RCUState
s = do
  forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (RCUState -> MVar [Counter]
rcuStateThreadCountersV RCUState
s) forall a b. (a -> b) -> a -> b
$ \ [Counter]
threadCounters -> do
    Int
gc' <- Counter -> IO Int
incCounter (RCUState -> Counter
rcuStateGlobalCounter RCUState
s)
    Counter -> Int -> IO ()
writeCounter (RCUState -> Counter
rcuStateMyCounter RCUState
s) Int
gc'
    let waitForThreads :: Int -> [Counter] -> IO Bool
waitForThreads Int
i xxs :: [Counter]
xxs@(Counter
x:[Counter]
xs)
          | Int
i forall a. Ord a => a -> a -> Bool
> Int
2000 = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          | Bool
otherwise = do
            Int
tc <- Counter -> IO Int
readCounter Counter
x
            if Int
tc forall a. Eq a => a -> a -> Bool
== Int
gc' then Int -> [Counter] -> IO Bool
waitForThreads (Int
i forall a. Num a => a -> a -> a
+ Int
1) [Counter]
xs
            else do
              Int -> IO ()
threadDelay Int
1
              Int -> [Counter] -> IO Bool
waitForThreads (Int
i forall a. Num a => a -> a -> a
+ Int
1) [Counter]
xxs
        waitForThreads Int
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Bool
bad <- Int -> [Counter] -> IO Bool
waitForThreads (Int
0 :: Int) [Counter]
threadCounters
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bad forall a b. (a -> b) -> a -> b
$ do
      -- slow path
      MVar ()
m <- forall a. IO (MVar a)
newEmptyMVar
      RCUState -> MVar () -> IO ()
stuff RCUState
s MVar ()
m
      IO ()
performMinorGC
      MVar () -> IO ()
sitAndSpin MVar ()
m
  IO ()
storeLoadBarrier

stuff :: RCUState -> MVar ()  -> IO ()
stuff :: RCUState -> MVar () -> IO ()
stuff RCUState
s MVar ()
m = do
  Version IORef ()
v <- forall a. IORef a -> IO a
readIORef (RCUState -> IORef Version
rcuStateGlobalVersion RCUState
s)
  Version
v' <- IO Version
newVersion
  forall a. IORef a -> a -> IO ()
atomicWriteIORef (RCUState -> IORef Version
rcuStateGlobalVersion RCUState
s) Version
v'
  Weak (IORef ())
_ <- forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef ()
v forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar ()
m ()
  forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# NOINLINE stuff #-}

-- This is awful. It should just takeMVar
sitAndSpin :: MVar () -> IO ()
sitAndSpin :: MVar () -> IO ()
sitAndSpin MVar ()
m = forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Maybe ()
Nothing -> do
    IO ()
performMajorGC
    MVar () -> IO ()
sitAndSpin MVar ()
m

--------------------------------------------------------------------------------
-- * RCU Context
--------------------------------------------------------------------------------

-- | This is an RCU computation. It can use 'forking' and 'joining' to form
-- new threads, and then you can use 'reading' and 'writing' to run classic
-- read-side and write-side RCU computations. Writers are
-- serialized using an MVar, readers are able to proceed while writers are
-- updating.
newtype RCU s a = RCU { forall s a. RCU s a -> RCUState -> IO a
unRCU :: RCUState -> IO a }
  deriving forall a b. a -> RCU s b -> RCU s a
forall a b. (a -> b) -> RCU s a -> RCU s b
forall s a b. a -> RCU s b -> RCU s a
forall s a b. (a -> b) -> RCU s a -> RCU s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RCU s b -> RCU s a
$c<$ :: forall s a b. a -> RCU s b -> RCU s a
fmap :: forall a b. (a -> b) -> RCU s a -> RCU s b
$cfmap :: forall s a b. (a -> b) -> RCU s a -> RCU s b
Functor

instance Applicative (RCU s) where
  pure :: forall a. a -> RCU s a
pure a
a = forall s a. (RCUState -> IO a) -> RCU s a
RCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  <*> :: forall a b. RCU s (a -> b) -> RCU s a -> RCU s b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (RCU s) where
#if !(MIN_VERSION_base(4,11,0))
  return a = RCU $ \ _ -> return a
#endif
  RCU RCUState -> IO a
m >>= :: forall a b. RCU s a -> (a -> RCU s b) -> RCU s b
>>= a -> RCU s b
f = forall s a. (RCUState -> IO a) -> RCU s a
RCU forall a b. (a -> b) -> a -> b
$ \RCUState
s -> do
    a
a <- RCUState -> IO a
m RCUState
s
    forall s a. RCU s a -> RCUState -> IO a
unRCU (a -> RCU s b
f a
a) RCUState
s

instance MonadNew (SRef s) (RCU s) where
  newSRef :: forall a. a -> RCU s (SRef s a)
newSRef a
a = forall s a. (RCUState -> IO a) -> RCU s a
RCU forall a b. (a -> b) -> a -> b
$ \RCUState
_ -> forall s a. IORef a -> SRef s a
SRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newSRefIO a
a

-- | This is a basic 'RCU' thread. It may be embellished when running in a more
-- exotic context.
data RCUThread s a = RCUThread
  { forall s a. RCUThread s a -> ThreadId
rcuThreadId  :: {-# UNPACK #-} !ThreadId
  , forall s a. RCUThread s a -> MVar a
rcuThreadVar :: {-# UNPACK #-} !(MVar a)
  }

instance MonadRCU (SRef s) (RCU s) where
  type Reading (RCU s) = ReadingRCU s
  type Writing (RCU s) = WritingRCU s
  type Thread (RCU s) = RCUThread s
  forking :: forall a. RCU s a -> RCU s (Thread (RCU s) a)
forking (RCU RCUState -> IO a
m) = forall s a. (RCUState -> IO a) -> RCU s a
RCU forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> do
    MVar a
result <- forall a. IO (MVar a)
newEmptyMVar
    Int
gc <- Counter -> IO Int
readCounter (RCUState -> Counter
rcuStateGlobalCounter RCUState
s)
    Counter
threadCounter <- Int -> IO Counter
newCounter Int
gc
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (RCUState -> MVar [Counter]
rcuStateThreadCountersV RCUState
s) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Counter
threadCounter forall a. a -> [a] -> [a]
:)
    ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
      a
x <- RCUState -> IO a
m forall a b. (a -> b) -> a -> b
$ RCUState
s { rcuStateMyCounter :: Counter
rcuStateMyCounter = Counter
threadCounter }
      forall a. MVar a -> a -> IO ()
putMVar MVar a
result a
x
      forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (RCUState -> MVar [Counter]
rcuStateThreadCountersV RCUState
s) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> [a]
L.delete Counter
threadCounter
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. ThreadId -> MVar a -> RCUThread s a
RCUThread ThreadId
tid MVar a
result)
  {-# INLINE forking #-}

  joining :: forall a. Thread (RCU s) a -> RCU s a
joining (RCUThread ThreadId
_ MVar a
m) = forall s a. (RCUState -> IO a) -> RCU s a
RCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> forall a. MVar a -> IO a
readMVar MVar a
m
  {-# INLINE joining #-}

  reading :: forall a. Reading (RCU s) a -> RCU s a
reading (ReadingRCU RCUState -> IO a
m) = forall s a. (RCUState -> IO a) -> RCU s a
RCU forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> do
    Version
v <- forall a. IORef a -> IO a
readIORef (RCUState -> IORef Version
rcuStateGlobalVersion RCUState
s)
    a
x <- RCUState -> IO a
m RCUState
s
    forall (m :: * -> *) a. PrimMonad m => a -> m ()
touch Version
v
    Counter -> Int -> IO ()
writeCounter (RCUState -> Counter
rcuStateMyCounter RCUState
s) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Counter -> IO Int
readCounter (RCUState -> Counter
rcuStateGlobalCounter RCUState
s)
    forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  {-# INLINE reading #-}

  writing :: forall a. Writing (RCU s) a -> RCU s a
writing (WritingRCU RCUState -> IO a
m) = forall s a. (RCUState -> IO a) -> RCU s a
RCU forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> do
    -- Acquire the writer-serializing lock.
    forall a. MVar a -> IO a
takeMVar (RCUState -> MVar ()
rcuStateWriterLockV RCUState
s)
    a
x <- RCUState -> IO a
m RCUState
s
    RCUState -> IO ()
synchronizeIO RCUState
s
    forall a. MVar a -> a -> IO ()
putMVar (RCUState -> MVar ()
rcuStateWriterLockV RCUState
s) ()
    forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  {-# INLINE writing #-}

instance MonadIO (RCU s) where
  liftIO :: forall a. IO a -> RCU s a
liftIO IO a
m = forall s a. (RCUState -> IO a) -> RCU s a
RCU forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IO a
m
  {-# INLINE liftIO #-}

-- | Run an RCU computation.
runRCU :: (forall s. RCU s a) -> IO a
runRCU :: forall a. (forall s. RCU s a) -> IO a
runRCU forall s. RCU s a
m = do
  Version
v <- IO Version
newVersion
  forall s a. RCU s a -> RCUState -> IO a
unRCU forall s. RCU s a
m forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Counter
-> IORef Version
-> MVar [Counter]
-> MVar ()
-> Counter
-> Maybe Int
-> RCUState
RCUState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Counter
newCounter Int
0
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef Version
v
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (MVar a)
newMVar []
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (MVar a)
newMVar ()
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Counter
newCounter Int
0
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
{-# INLINE runRCU #-}

-- | Run an RCU computation in a thread pinned to a particular core.
runOnRCU :: Int -> (forall s. RCU s a) -> IO a
runOnRCU :: forall a. Int -> (forall s. RCU s a) -> IO a
runOnRCU Int
i forall s. RCU s a
m = do
  Version
v <- IO Version
newVersion
  forall s a. RCU s a -> RCUState -> IO a
unRCU forall s. RCU s a
m forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Counter
-> IORef Version
-> MVar [Counter]
-> MVar ()
-> Counter
-> Maybe Int
-> RCUState
RCUState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Counter
newCounter Int
0
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef Version
v
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (MVar a)
newMVar []
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (MVar a)
newMVar ()
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Counter
newCounter Int
0
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Int
i)
{-# INLINE runOnRCU #-}