{-# 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 qualified Data.List as L
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
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,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 :: 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
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,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 :: 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
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 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
#if !(MIN_VERSION_base(4,11,0))
return a = RCU $ \ _ -> return a
#endif
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]
L.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)