{-# 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 #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2015 Edward Kmett 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.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 ()

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

-- | Shared references
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 #-}

--------------------------------------------------------------------------------
-- * 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 = 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

-- counterInc :: Word64
-- counterInc = 2 -- online threads will never overflow to 0

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 #-}

-- | State for an RCU computation.
data RCUState = RCUState
  { -- | Global state
    RCUState -> Counter
rcuStateGlobalCounter       :: {-# UNPACK #-} !Counter
  , RCUState -> IORef [Counter]
rcuStateThreadCountersR     :: {-# UNPACK #-} !(IORef [Counter])
  , RCUState -> MVar ()
rcuStateThreadCountersLockV :: {-# UNPACK #-} !(MVar ())
  , RCUState -> MVar ()
rcuStateWriterLockV         :: {-# UNPACK #-} !(MVar ())
    -- | Thread state
  , RCUState -> Counter
rcuStateMyCounter           :: {-# UNPACK #-} !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 { 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 #-}

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

-- | This is the basic write-side critical section for an RCU computation
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
  -- Get this thread's counter.
  Word64
mc <- Counter -> IO Word64
readCounter Counter
rcuStateMyCounter
  -- If this thread is not offline already, take it offline.
  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

  -- Loop through thread counters, waiting for online threads to catch up
  -- and skipping offline threads.
  [Counter]
threadCounters <- IORef [Counter] -> IO [Counter]
forall a. IORef a -> IO a
readSRefIO IORef [Counter]
rcuStateThreadCountersR
  -- Increment the global counter.
  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
  -- Wait for each online reader to copy the new global counter.
  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
          -- spin for 999 iterations before sleeping
          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 -- TODO: Figure out how to make GHC emit e.g. "rep; nop"
                        -- inline to tell the CPU we're in a busy-wait loop.
                        -- For now, FFI call a C function with inline "rep; nop".
                        -- This approach is apparently about 10 times heavier than
                        -- just inlining the instruction in your program text :(
                        -- urcu uses "caa_cpu_relax()" decorated with a compiler
                        -- reordering barrier in this case.
          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

--------------------------------------------------------------------------------
-- * 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 { 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

-- | This is a basic 'RCU' thread. It may be embellished when running in a more
-- exotic context.
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
    -- Create an MVar the new thread can use to return a result.
    MVar a
result <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar

    -- Create a counter for the new thread, and add it to the list.
    Counter
threadCounter <- IO Counter
newCounter
    -- Wouldn't <$$> be nice here...
    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

    -- Spawn the new thread, whose return value goes in @result@.
    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

      -- After the new thread has completed, mark its counter as offline
      -- and remove this counter from the list writers poll.
      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
    --mc <- readCounter rcuStateMyCounter
    -- If this thread was offline, take a snapshot of the global counter so
    -- writers will wait.
    --when (mc == offline) $ 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
    -- Make sure that the counter goes online before reads begin.
    IO ()
storeLoadBarrier

    -- Run a read-side critical section.
    a
x <- RCUState -> IO a
m RCUState
s

    -- Announce a quiescent state after the read-side critical section.
    -- TODO: Make this tunable/optional.
    IO ()
storeLoadBarrier
    --writeCounter rcuStateMyCounter =<< readCounter rcuStateGlobalCounter
    Counter -> Word64 -> IO ()
writeCounter Counter
rcuStateMyCounter Word64
offline
    IO ()
storeLoadBarrier

    -- Return the result of the read-side critical section.
    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
    -- Acquire the writer-serializing lock.
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
rcuStateWriterLockV

    -- Run a write-side critical section.
    a
x <- RCUState -> IO a
m RCUState
s

    -- Guarantee that writes in this critical section happen before writes in
    -- subsequent critical sections.
    RCUState -> IO ()
synchronizeIO RCUState
s

    -- Release the writer-serializing lock.
    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 #-}

-- | Run an RCU computation.
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 #-}

-- | Run an RCU computation in a thread pinned to a particular core.
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)