{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_HADDOCK not-home #-}
module Control.Concurrent.RCU.QSBR.Internal
( SRef(..)
, RCUThread(..)
, RCU(..)
, runRCU
, runOnRCU
, ReadingRCU(..)
, WritingRCU(..)
, RCUState(..)
#if BENCHMARKS
, unRCU
, runWritingRCU
, runReadingRCU
, writeSRefIO
, RCUState(..)
#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 Data.List
import Data.Primitive
import Foreign
import qualified Control.Monad.Fail as Fail
import Prelude hiding (Read(..))
foreign import ccall unsafe "pause.h" pause :: IO ()
newtype SRef s a = SRef { SRef s a -> IORef a
unSRef :: IORef a }
deriving SRef s a -> SRef s a -> Bool
(SRef s a -> SRef s a -> Bool)
-> (SRef s a -> SRef s a -> Bool) -> Eq (SRef s a)
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 :: a -> IO (IORef a)
newSRefIO = a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef
{-# INLINE newSRefIO #-}
readSRefIO :: IORef a -> IO a
readSRefIO :: IORef a -> IO a
readSRefIO = IORef a -> IO a
forall a. IORef a -> IO a
readIORef
{-# INLINE readSRefIO #-}
writeSRefIO :: IORef a -> a -> IO ()
writeSRefIO :: IORef a -> a -> IO ()
writeSRefIO IORef a
r a
a = do a
a a -> IO () -> IO ()
forall a b. a -> b -> b
`pseq` IO ()
writeBarrier
IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
r a
a
{-# INLINE writeSRefIO #-}
newtype Counter = Counter (MutableByteArray RealWorld)
instance Eq Counter where
Counter MutableByteArray RealWorld
m == :: Counter -> Counter -> Bool
== Counter MutableByteArray RealWorld
n = MutableByteArray RealWorld -> MutableByteArray RealWorld -> Bool
forall s. MutableByteArray s -> MutableByteArray s -> Bool
sameMutableByteArray MutableByteArray RealWorld
m MutableByteArray RealWorld
n
offline :: Word64
offline :: Word64
offline = Word64
0
online :: Word64
online :: Word64
online = Word64
1
newCounter :: IO Counter
newCounter :: IO Counter
newCounter = do
MutableByteArray RealWorld
b <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
8
MutableByteArray (PrimState IO) -> Int -> Word64 -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
b Int
0 Word64
online
Counter -> IO Counter
forall (m :: * -> *) a. Monad m => a -> m a
return (MutableByteArray RealWorld -> Counter
Counter MutableByteArray RealWorld
b)
{-# INLINE newCounter #-}
readCounter :: Counter -> IO Word64
readCounter :: Counter -> IO Word64
readCounter (Counter MutableByteArray RealWorld
c) = MutableByteArray (PrimState IO) -> Int -> IO Word64
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
c Int
0
{-# INLINE readCounter #-}
writeCounter :: Counter -> Word64 -> IO ()
writeCounter :: Counter -> Word64 -> IO ()
writeCounter (Counter MutableByteArray RealWorld
c) Word64
w = MutableByteArray (PrimState IO) -> Int -> Word64 -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
c Int
0 Word64
w
{-# INLINE writeCounter #-}
incCounter :: Counter -> IO Word64
incCounter :: Counter -> IO Word64
incCounter Counter
c = do
Word64
x <- (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2) (Word64 -> Word64) -> IO Word64 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Counter -> IO Word64
readCounter Counter
c
Counter -> Word64 -> IO ()
writeCounter Counter
c Word64
x
Word64 -> IO Word64
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
x
{-# INLINE incCounter #-}
data RCUState = RCUState
{
RCUState -> Counter
rcuStateGlobalCounter :: {-# UNPACK #-} !Counter
, RCUState -> IORef [Counter]
rcuStateThreadCountersR :: {-# UNPACK #-} !(IORef [Counter])
, RCUState -> MVar ()
rcuStateThreadCountersLockV :: {-# UNPACK #-} !(MVar ())
, RCUState -> MVar ()
rcuStateWriterLockV :: {-# UNPACK #-} !(MVar ())
, RCUState -> Counter
rcuStateMyCounter :: {-# UNPACK #-} !Counter
, RCUState -> Maybe Int
rcuStatePinned :: !(Maybe Int)
}
newtype ReadingRCU s a = ReadingRCU { ReadingRCU s a -> RCUState -> IO a
runReadingRCU :: RCUState -> IO a }
deriving a -> ReadingRCU s b -> ReadingRCU s a
(a -> b) -> ReadingRCU s a -> ReadingRCU s b
(forall a b. (a -> b) -> ReadingRCU s a -> ReadingRCU s b)
-> (forall a b. a -> ReadingRCU s b -> ReadingRCU s a)
-> Functor (ReadingRCU s)
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
<$ :: a -> ReadingRCU s b -> ReadingRCU s a
$c<$ :: forall s a b. a -> ReadingRCU s b -> ReadingRCU s a
fmap :: (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 :: a -> ReadingRCU s a
pure a
a = (RCUState -> IO a) -> ReadingRCU s a
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO a) -> ReadingRCU s a)
-> (RCUState -> IO a) -> ReadingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
ReadingRCU RCUState -> IO (a -> b)
mf <*> :: ReadingRCU s (a -> b) -> ReadingRCU s a -> ReadingRCU s b
<*> ReadingRCU RCUState -> IO a
ma = (RCUState -> IO b) -> ReadingRCU s b
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO b) -> ReadingRCU s b)
-> (RCUState -> IO b) -> ReadingRCU s b
forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> RCUState -> IO (a -> b)
mf RCUState
s IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RCUState -> IO a
ma RCUState
s
instance Monad (ReadingRCU s) where
return :: a -> ReadingRCU s a
return a
a = (RCUState -> IO a) -> ReadingRCU s a
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO a) -> ReadingRCU s a)
-> (RCUState -> IO a) -> ReadingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
ReadingRCU RCUState -> IO a
m >>= :: ReadingRCU s a -> (a -> ReadingRCU s b) -> ReadingRCU s b
>>= a -> ReadingRCU s b
f = (RCUState -> IO b) -> ReadingRCU s b
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO b) -> ReadingRCU s b)
-> (RCUState -> IO b) -> ReadingRCU s b
forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> do
a
a <- RCUState -> IO a
m RCUState
s
ReadingRCU s b -> RCUState -> IO b
forall s a. ReadingRCU s a -> RCUState -> IO a
runReadingRCU (a -> ReadingRCU s b
f a
a) RCUState
s
#if !(MIN_VERSION_base(4,13,0))
fail = Fail.fail
#endif
instance Fail.MonadFail (ReadingRCU s) where
fail :: String -> ReadingRCU s a
fail String
s = (RCUState -> IO a) -> ReadingRCU s a
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO a) -> ReadingRCU s a)
-> (RCUState -> IO a) -> ReadingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s
instance Alternative (ReadingRCU s) where
empty :: ReadingRCU s a
empty = (RCUState -> IO a) -> ReadingRCU s a
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO a) -> ReadingRCU s a)
-> (RCUState -> IO a) -> ReadingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IO a
forall (f :: * -> *) a. Alternative f => f a
empty
ReadingRCU RCUState -> IO a
ma <|> :: ReadingRCU s a -> ReadingRCU s a -> ReadingRCU s a
<|> ReadingRCU RCUState -> IO a
mb = (RCUState -> IO a) -> ReadingRCU s a
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO a) -> ReadingRCU s a)
-> (RCUState -> IO a) -> ReadingRCU s a
forall a b. (a -> b) -> a -> b
$ \RCUState
s -> RCUState -> IO a
ma RCUState
s IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RCUState -> IO a
mb RCUState
s
instance MonadPlus (ReadingRCU s) where
mzero :: ReadingRCU s a
mzero = (RCUState -> IO a) -> ReadingRCU s a
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO a) -> ReadingRCU s a)
-> (RCUState -> IO a) -> ReadingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
ReadingRCU RCUState -> IO a
ma mplus :: ReadingRCU s a -> ReadingRCU s a -> ReadingRCU s a
`mplus` ReadingRCU RCUState -> IO a
mb = (RCUState -> IO a) -> ReadingRCU s a
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO a) -> ReadingRCU s a)
-> (RCUState -> IO a) -> ReadingRCU s a
forall a b. (a -> b) -> a -> b
$ \RCUState
s -> RCUState -> IO a
ma RCUState
s IO a -> IO a -> IO a
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 :: a -> ReadingRCU s (SRef s a)
newSRef a
a = (RCUState -> IO (SRef s a)) -> ReadingRCU s (SRef s a)
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO (SRef s a)) -> ReadingRCU s (SRef s a))
-> (RCUState -> IO (SRef s a)) -> ReadingRCU s (SRef s a)
forall a b. (a -> b) -> a -> b
$ \RCUState
_ -> IORef a -> SRef s a
forall s a. IORef a -> SRef s a
SRef (IORef a -> SRef s a) -> IO (IORef a) -> IO (SRef s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (IORef a)
forall a. a -> IO (IORef a)
newSRefIO a
a
instance MonadReading (SRef s) (ReadingRCU s) where
readSRef :: SRef s a -> ReadingRCU s a
readSRef (SRef IORef a
r) = (RCUState -> IO a) -> ReadingRCU s a
forall s a. (RCUState -> IO a) -> ReadingRCU s a
ReadingRCU ((RCUState -> IO a) -> ReadingRCU s a)
-> (RCUState -> IO a) -> ReadingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IORef a -> IO a
forall a. IORef a -> IO a
readSRefIO IORef a
r
{-# INLINE readSRef #-}
newtype WritingRCU s a = WritingRCU { WritingRCU s a -> RCUState -> IO a
runWritingRCU :: RCUState -> IO a }
deriving a -> WritingRCU s b -> WritingRCU s a
(a -> b) -> WritingRCU s a -> WritingRCU s b
(forall a b. (a -> b) -> WritingRCU s a -> WritingRCU s b)
-> (forall a b. a -> WritingRCU s b -> WritingRCU s a)
-> Functor (WritingRCU s)
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
<$ :: a -> WritingRCU s b -> WritingRCU s a
$c<$ :: forall s a b. a -> WritingRCU s b -> WritingRCU s a
fmap :: (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 :: a -> WritingRCU s a
pure a
a = (RCUState -> IO a) -> WritingRCU s a
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO a) -> WritingRCU s a)
-> (RCUState -> IO a) -> WritingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
WritingRCU RCUState -> IO (a -> b)
mf <*> :: WritingRCU s (a -> b) -> WritingRCU s a -> WritingRCU s b
<*> WritingRCU RCUState -> IO a
ma = (RCUState -> IO b) -> WritingRCU s b
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO b) -> WritingRCU s b)
-> (RCUState -> IO b) -> WritingRCU s b
forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> RCUState -> IO (a -> b)
mf RCUState
s IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RCUState -> IO a
ma RCUState
s
instance Monad (WritingRCU s) where
return :: a -> WritingRCU s a
return a
a = (RCUState -> IO a) -> WritingRCU s a
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO a) -> WritingRCU s a)
-> (RCUState -> IO a) -> WritingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
WritingRCU RCUState -> IO a
m >>= :: WritingRCU s a -> (a -> WritingRCU s b) -> WritingRCU s b
>>= a -> WritingRCU s b
f = (RCUState -> IO b) -> WritingRCU s b
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO b) -> WritingRCU s b)
-> (RCUState -> IO b) -> WritingRCU s b
forall a b. (a -> b) -> a -> b
$ \ RCUState
s -> do
a
a <- RCUState -> IO a
m RCUState
s
WritingRCU s b -> RCUState -> IO b
forall s a. WritingRCU s a -> RCUState -> IO a
runWritingRCU (a -> WritingRCU s b
f a
a) RCUState
s
#if !(MIN_VERSION_base(4,13,0))
fail = Fail.fail
#endif
instance Fail.MonadFail (WritingRCU s) where
fail :: String -> WritingRCU s a
fail String
s = (RCUState -> IO a) -> WritingRCU s a
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO a) -> WritingRCU s a)
-> (RCUState -> IO a) -> WritingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s
instance Alternative (WritingRCU s) where
empty :: WritingRCU s a
empty = (RCUState -> IO a) -> WritingRCU s a
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO a) -> WritingRCU s a)
-> (RCUState -> IO a) -> WritingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IO a
forall (f :: * -> *) a. Alternative f => f a
empty
WritingRCU RCUState -> IO a
ma <|> :: WritingRCU s a -> WritingRCU s a -> WritingRCU s a
<|> WritingRCU RCUState -> IO a
mb = (RCUState -> IO a) -> WritingRCU s a
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO a) -> WritingRCU s a)
-> (RCUState -> IO a) -> WritingRCU s a
forall a b. (a -> b) -> a -> b
$ \RCUState
s -> RCUState -> IO a
ma RCUState
s IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RCUState -> IO a
mb RCUState
s
instance MonadPlus (WritingRCU s) where
mzero :: WritingRCU s a
mzero = (RCUState -> IO a) -> WritingRCU s a
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO a) -> WritingRCU s a)
-> (RCUState -> IO a) -> WritingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
WritingRCU RCUState -> IO a
ma mplus :: WritingRCU s a -> WritingRCU s a -> WritingRCU s a
`mplus` WritingRCU RCUState -> IO a
mb = (RCUState -> IO a) -> WritingRCU s a
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO a) -> WritingRCU s a)
-> (RCUState -> IO a) -> WritingRCU s a
forall a b. (a -> b) -> a -> b
$ \RCUState
s -> RCUState -> IO a
ma RCUState
s IO a -> IO a -> IO a
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 :: a -> WritingRCU s (SRef s a)
newSRef a
a = (RCUState -> IO (SRef s a)) -> WritingRCU s (SRef s a)
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO (SRef s a)) -> WritingRCU s (SRef s a))
-> (RCUState -> IO (SRef s a)) -> WritingRCU s (SRef s a)
forall a b. (a -> b) -> a -> b
$ \RCUState
_ -> IORef a -> SRef s a
forall s a. IORef a -> SRef s a
SRef (IORef a -> SRef s a) -> IO (IORef a) -> IO (SRef s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (IORef a)
forall a. a -> IO (IORef a)
newSRefIO a
a
instance MonadReading (SRef s) (WritingRCU s) where
readSRef :: SRef s a -> WritingRCU s a
readSRef (SRef IORef a
r) = (RCUState -> IO a) -> WritingRCU s a
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO a) -> WritingRCU s a)
-> (RCUState -> IO a) -> WritingRCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IORef a -> IO a
forall a. IORef a -> IO a
readSRefIO IORef a
r
{-# INLINE readSRef #-}
instance MonadWriting (SRef s) (WritingRCU s) where
writeSRef :: SRef s a -> a -> WritingRCU s ()
writeSRef (SRef IORef a
r) a
a = (RCUState -> IO ()) -> WritingRCU s ()
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU ((RCUState -> IO ()) -> WritingRCU s ())
-> (RCUState -> IO ()) -> WritingRCU s ()
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeSRefIO IORef a
r a
a
{-# INLINE writeSRef #-}
synchronize :: WritingRCU s ()
synchronize = (RCUState -> IO ()) -> WritingRCU s ()
forall s a. (RCUState -> IO a) -> WritingRCU s a
WritingRCU RCUState -> IO ()
synchronizeIO
synchronizeIO :: RCUState -> IO ()
synchronizeIO :: RCUState -> IO ()
synchronizeIO RCUState { Counter
rcuStateGlobalCounter :: Counter
rcuStateGlobalCounter :: RCUState -> Counter
rcuStateGlobalCounter
, Counter
rcuStateMyCounter :: Counter
rcuStateMyCounter :: RCUState -> Counter
rcuStateMyCounter
, IORef [Counter]
rcuStateThreadCountersR :: IORef [Counter]
rcuStateThreadCountersR :: RCUState -> IORef [Counter]
rcuStateThreadCountersR
, Maybe Int
rcuStatePinned :: Maybe Int
rcuStatePinned :: RCUState -> Maybe Int
rcuStatePinned } = do
Word64
mc <- Counter -> IO Word64
readCounter Counter
rcuStateMyCounter
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
mc Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
offline) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> Word64 -> IO ()
writeCounter Counter
rcuStateMyCounter Word64
offline
[Counter]
threadCounters <- IORef [Counter] -> IO [Counter]
forall a. IORef a -> IO a
readSRefIO IORef [Counter]
rcuStateThreadCountersR
Word64
gc' <- Counter -> IO Word64
incCounter Counter
rcuStateGlobalCounter
let busyWaitPeriod :: Word64
busyWaitPeriod = case Maybe Int
rcuStatePinned of Just Int
_ -> Word64
1000
Maybe Int
Nothing -> Word64
2
let waitForThread :: Word64 -> Counter -> IO ()
waitForThread !(Word64
n :: Word64) Counter
threadCounter = do
Word64
tc <- Counter -> IO Word64
readCounter Counter
threadCounter
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
tc Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
offline Bool -> Bool -> Bool
&& Word64
tc Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
gc') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
if Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
busyWaitPeriod Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
then IO ()
yield
else IO ()
pause
Word64 -> Counter -> IO ()
waitForThread (Word64 -> Word64
forall a. Enum a => a -> a
succ Word64
n) Counter
threadCounter
[Counter] -> (Counter -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Counter]
threadCounters (Word64 -> Counter -> IO ()
waitForThread Word64
1)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
mc Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
offline) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> Word64 -> IO ()
writeCounter Counter
rcuStateMyCounter Word64
gc'
IO ()
storeLoadBarrier
newtype RCU s a = RCU { RCU s a -> RCUState -> IO a
unRCU :: RCUState -> IO a }
deriving a -> RCU s b -> RCU s a
(a -> b) -> RCU s a -> RCU s b
(forall a b. (a -> b) -> RCU s a -> RCU s b)
-> (forall a b. a -> RCU s b -> RCU s a) -> Functor (RCU s)
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
<$ :: a -> RCU s b -> RCU s a
$c<$ :: forall s a b. a -> RCU s b -> RCU s a
fmap :: (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 :: a -> RCU s a
pure = a -> RCU s a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: RCU s (a -> b) -> RCU s a -> RCU s 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
return :: a -> RCU s a
return a
a = (RCUState -> IO a) -> RCU s a
forall s a. (RCUState -> IO a) -> RCU s a
RCU ((RCUState -> IO a) -> RCU s a) -> (RCUState -> IO a) -> RCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
RCU RCUState -> IO a
m >>= :: RCU s a -> (a -> RCU s b) -> RCU s b
>>= a -> RCU s b
f = (RCUState -> IO b) -> RCU s b
forall s a. (RCUState -> IO a) -> RCU s a
RCU ((RCUState -> IO b) -> RCU s b) -> (RCUState -> IO b) -> RCU s b
forall a b. (a -> b) -> a -> b
$ \RCUState
s -> do
a
a <- RCUState -> IO a
m RCUState
s
RCU s b -> RCUState -> IO b
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 :: a -> RCU s (SRef s a)
newSRef a
a = (RCUState -> IO (SRef s a)) -> RCU s (SRef s a)
forall s a. (RCUState -> IO a) -> RCU s a
RCU ((RCUState -> IO (SRef s a)) -> RCU s (SRef s a))
-> (RCUState -> IO (SRef s a)) -> RCU s (SRef s a)
forall a b. (a -> b) -> a -> b
$ \RCUState
_ -> IORef a -> SRef s a
forall s a. IORef a -> SRef s a
SRef (IORef a -> SRef s a) -> IO (IORef a) -> IO (SRef s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO (IORef a)
forall a. a -> IO (IORef a)
newSRefIO a
a
data RCUThread s a = RCUThread
{ RCUThread s a -> ThreadId
rcuThreadId :: {-# UNPACK #-} !ThreadId
, 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 :: RCU s a -> RCU s (Thread (RCU s) a)
forking (RCU RCUState -> IO a
m) = (RCUState -> IO (RCUThread s a)) -> RCU s (RCUThread s a)
forall s a. (RCUState -> IO a) -> RCU s a
RCU ((RCUState -> IO (RCUThread s a)) -> RCU s (RCUThread s a))
-> (RCUState -> IO (RCUThread s a)) -> RCU s (RCUThread s a)
forall a b. (a -> b) -> a -> b
$ \ s :: RCUState
s@RCUState { MVar ()
rcuStateThreadCountersLockV :: MVar ()
rcuStateThreadCountersLockV :: RCUState -> MVar ()
rcuStateThreadCountersLockV
, IORef [Counter]
rcuStateThreadCountersR :: IORef [Counter]
rcuStateThreadCountersR :: RCUState -> IORef [Counter]
rcuStateThreadCountersR
, Maybe Int
rcuStatePinned :: Maybe Int
rcuStatePinned :: RCUState -> Maybe Int
rcuStatePinned } -> do
MVar a
result <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
Counter
threadCounter <- IO Counter
newCounter
MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
rcuStateThreadCountersLockV ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ ()
_ -> IORef [Counter] -> [Counter] -> IO ()
forall a. IORef a -> a -> IO ()
writeSRefIO IORef [Counter]
rcuStateThreadCountersR ([Counter] -> IO ())
-> ([Counter] -> [Counter]) -> [Counter] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Counter
threadCounter Counter -> [Counter] -> [Counter]
forall a. a -> [a] -> [a]
:) ([Counter] -> IO ()) -> IO [Counter] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef [Counter] -> IO [Counter]
forall a. IORef a -> IO a
readSRefIO IORef [Counter]
rcuStateThreadCountersR
IO ()
storeLoadBarrier
let frk :: IO () -> IO ThreadId
frk = (IO () -> IO ThreadId)
-> (Int -> IO () -> IO ThreadId)
-> Maybe Int
-> IO ()
-> IO ThreadId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO () -> IO ThreadId
forkIO Int -> IO () -> IO ThreadId
forkOn Maybe Int
rcuStatePinned
ThreadId
tid <- IO () -> IO ThreadId
frk (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
a
x <- RCUState -> IO a
m (RCUState -> IO a) -> RCUState -> IO a
forall a b. (a -> b) -> a -> b
$ RCUState
s { rcuStateMyCounter :: Counter
rcuStateMyCounter = Counter
threadCounter }
MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
result a
x
IO ()
writeBarrier
Counter -> Word64 -> IO ()
writeCounter Counter
threadCounter Word64
offline
MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
rcuStateThreadCountersLockV ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ ()
_ -> IORef [Counter] -> [Counter] -> IO ()
forall a. IORef a -> a -> IO ()
writeSRefIO IORef [Counter]
rcuStateThreadCountersR ([Counter] -> IO ())
-> ([Counter] -> [Counter]) -> [Counter] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Counter -> [Counter] -> [Counter]
forall a. Eq a => a -> [a] -> [a]
delete Counter
threadCounter ([Counter] -> IO ()) -> IO [Counter] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef [Counter] -> IO [Counter]
forall a. IORef a -> IO a
readSRefIO IORef [Counter]
rcuStateThreadCountersR
RCUThread s a -> IO (RCUThread s a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> MVar a -> RCUThread s a
forall s a. ThreadId -> MVar a -> RCUThread s a
RCUThread ThreadId
tid MVar a
result)
{-# INLINE forking #-}
joining :: Thread (RCU s) a -> RCU s a
joining (RCUThread _ m) = (RCUState -> IO a) -> RCU s a
forall s a. (RCUState -> IO a) -> RCU s a
RCU ((RCUState -> IO a) -> RCU s a) -> (RCUState -> IO a) -> RCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
m
{-# INLINE joining #-}
reading :: Reading (RCU s) a -> RCU s a
reading (ReadingRCU m) = (RCUState -> IO a) -> RCU s a
forall s a. (RCUState -> IO a) -> RCU s a
RCU ((RCUState -> IO a) -> RCU s a) -> (RCUState -> IO a) -> RCU s a
forall a b. (a -> b) -> a -> b
$ \ s :: RCUState
s@RCUState { Counter
rcuStateMyCounter :: Counter
rcuStateMyCounter :: RCUState -> Counter
rcuStateMyCounter
, Counter
rcuStateGlobalCounter :: Counter
rcuStateGlobalCounter :: RCUState -> Counter
rcuStateGlobalCounter } -> do
Counter -> Word64 -> IO ()
writeCounter Counter
rcuStateMyCounter (Word64 -> IO ()) -> IO Word64 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Counter -> IO Word64
readCounter Counter
rcuStateGlobalCounter
IO ()
storeLoadBarrier
a
x <- RCUState -> IO a
m RCUState
s
IO ()
storeLoadBarrier
Counter -> Word64 -> IO ()
writeCounter Counter
rcuStateMyCounter Word64
offline
IO ()
storeLoadBarrier
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
{-# INLINE reading #-}
writing :: Writing (RCU s) a -> RCU s a
writing (WritingRCU m) = (RCUState -> IO a) -> RCU s a
forall s a. (RCUState -> IO a) -> RCU s a
RCU ((RCUState -> IO a) -> RCU s a) -> (RCUState -> IO a) -> RCU s a
forall a b. (a -> b) -> a -> b
$ \ s :: RCUState
s@RCUState { MVar ()
rcuStateWriterLockV :: MVar ()
rcuStateWriterLockV :: RCUState -> MVar ()
rcuStateWriterLockV } -> do
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
rcuStateWriterLockV
a
x <- RCUState -> IO a
m RCUState
s
RCUState -> IO ()
synchronizeIO RCUState
s
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
rcuStateWriterLockV ()
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
{-# INLINE writing #-}
instance MonadIO (RCU s) where
liftIO :: IO a -> RCU s a
liftIO IO a
m = (RCUState -> IO a) -> RCU s a
forall s a. (RCUState -> IO a) -> RCU s a
RCU ((RCUState -> IO a) -> RCU s a) -> (RCUState -> IO a) -> RCU s a
forall a b. (a -> b) -> a -> b
$ \ RCUState
_ -> IO a
m
{-# INLINE liftIO #-}
runRCU :: (forall s. RCU s a) -> IO a
runRCU :: (forall s. RCU s a) -> IO a
runRCU forall s. RCU s a
m =
RCU Any a -> RCUState -> IO a
forall s a. RCU s a -> RCUState -> IO a
unRCU RCU Any a
forall s. RCU s a
m (RCUState -> IO a) -> IO RCUState -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Counter
-> IORef [Counter]
-> MVar ()
-> MVar ()
-> Counter
-> Maybe Int
-> RCUState
RCUState (Counter
-> IORef [Counter]
-> MVar ()
-> MVar ()
-> Counter
-> Maybe Int
-> RCUState)
-> IO Counter
-> IO
(IORef [Counter]
-> MVar () -> MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Counter
newCounter
IO
(IORef [Counter]
-> MVar () -> MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (IORef [Counter])
-> IO (MVar () -> MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Counter] -> IO (IORef [Counter])
forall a. a -> IO (IORef a)
newIORef []
IO (MVar () -> MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (MVar ()) -> IO (MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
IO (MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (MVar ()) -> IO (Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
IO (Counter -> Maybe Int -> RCUState)
-> IO Counter -> IO (Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Counter
newCounter
IO (Maybe Int -> RCUState) -> IO (Maybe Int) -> IO RCUState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
{-# INLINE runRCU #-}
runOnRCU :: Int -> (forall s. RCU s a) -> IO a
runOnRCU :: Int -> (forall s. RCU s a) -> IO a
runOnRCU Int
i forall s. RCU s a
m =
RCU Any a -> RCUState -> IO a
forall s a. RCU s a -> RCUState -> IO a
unRCU RCU Any a
forall s. RCU s a
m (RCUState -> IO a) -> IO RCUState -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Counter
-> IORef [Counter]
-> MVar ()
-> MVar ()
-> Counter
-> Maybe Int
-> RCUState
RCUState (Counter
-> IORef [Counter]
-> MVar ()
-> MVar ()
-> Counter
-> Maybe Int
-> RCUState)
-> IO Counter
-> IO
(IORef [Counter]
-> MVar () -> MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Counter
newCounter
IO
(IORef [Counter]
-> MVar () -> MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (IORef [Counter])
-> IO (MVar () -> MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Counter] -> IO (IORef [Counter])
forall a. a -> IO (IORef a)
newIORef []
IO (MVar () -> MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (MVar ()) -> IO (MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
IO (MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (MVar ()) -> IO (Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
IO (Counter -> Maybe Int -> RCUState)
-> IO Counter -> IO (Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Counter
newCounter
IO (Maybe Int -> RCUState) -> IO (Maybe Int) -> IO RCUState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i)