{-# 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 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 ()

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

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

-- | 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]
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
    --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)