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

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

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

-- | Shared references
newtype SRef s a = SRef { 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

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

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

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

newtype Version = Version (IORef ())

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

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

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

-- | This is the basic read-side critical section for an RCU computation
newtype ReadingRCU s a = ReadingRCU { 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
s = do
  MVar [Counter] -> ([Counter] -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (RCUState -> MVar [Counter]
rcuStateThreadCountersV RCUState
s) (([Counter] -> IO ()) -> IO ()) -> ([Counter] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ [Counter]
threadCounters -> do
    Int
gc' <- Counter -> IO Int
incCounter (RCUState -> Counter
rcuStateGlobalCounter RCUState
s)
    Counter -> Int -> IO ()
writeCounter (RCUState -> Counter
rcuStateMyCounter RCUState
s) Int
gc'
    let waitForThreads :: Int -> [Counter] -> IO Bool
waitForThreads Int
i xxs :: [Counter]
xxs@(Counter
x:[Counter]
xs)
          | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2000 = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          | Bool
otherwise = do
            Int
tc <- Counter -> IO Int
readCounter Counter
x
            if Int
tc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
gc' then Int -> [Counter] -> IO Bool
waitForThreads (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Counter]
xs
            else do
              Int -> IO ()
threadDelay Int
1
              Int -> [Counter] -> IO Bool
waitForThreads (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Counter]
xxs
        waitForThreads Int
_ [] = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Bool
bad <- Int -> [Counter] -> IO Bool
waitForThreads (Int
0 :: Int) [Counter]
threadCounters
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bad (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- slow path
      MVar ()
m <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
      RCUState -> MVar () -> IO ()
stuff RCUState
s MVar ()
m
      IO ()
performMinorGC
      MVar () -> IO ()
sitAndSpin MVar ()
m
  IO ()
storeLoadBarrier

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

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

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

-- | This is an RCU computation. It can use 'forking' and 'joining' to form
-- new threads, and then you can use 'reading' and 'writing' to run classic
-- read-side and write-side RCU computations. Writers are
-- serialized using an MVar, readers are able to proceed while writers are
-- updating.
newtype RCU s a = RCU { 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
$ \ RCUState
s -> do
    MVar a
result <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
    Int
gc <- Counter -> IO Int
readCounter (RCUState -> Counter
rcuStateGlobalCounter RCUState
s)
    Counter
threadCounter <- Int -> IO Counter
newCounter Int
gc
    MVar [Counter] -> ([Counter] -> IO [Counter]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (RCUState -> MVar [Counter]
rcuStateThreadCountersV RCUState
s) (([Counter] -> IO [Counter]) -> IO ())
-> ([Counter] -> IO [Counter]) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Counter] -> IO [Counter]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Counter] -> IO [Counter])
-> ([Counter] -> [Counter]) -> [Counter] -> IO [Counter]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Counter
threadCounter Counter -> [Counter] -> [Counter]
forall a. a -> [a] -> [a]
:)
    ThreadId
tid <- IO () -> IO ThreadId
forkIO (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
      MVar [Counter] -> ([Counter] -> IO [Counter]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (RCUState -> MVar [Counter]
rcuStateThreadCountersV RCUState
s) (([Counter] -> IO [Counter]) -> IO ())
-> ([Counter] -> IO [Counter]) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Counter] -> IO [Counter]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Counter] -> IO [Counter])
-> ([Counter] -> [Counter]) -> [Counter] -> IO [Counter]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Counter -> [Counter] -> [Counter]
forall a. Eq a => a -> [a] -> [a]
L.delete Counter
threadCounter
    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
$ \ RCUState
s -> do
    Version
v <- IORef Version -> IO Version
forall a. IORef a -> IO a
readIORef (RCUState -> IORef Version
rcuStateGlobalVersion RCUState
s)
    a
x <- RCUState -> IO a
m RCUState
s
    Version -> IO ()
forall (m :: * -> *) a. PrimMonad m => a -> m ()
touch Version
v
    Counter -> Int -> IO ()
writeCounter (RCUState -> Counter
rcuStateMyCounter RCUState
s) (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Counter -> IO Int
readCounter (RCUState -> Counter
rcuStateGlobalCounter RCUState
s)
    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
$ \ RCUState
s -> do
    -- Acquire the writer-serializing lock.
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (RCUState -> MVar ()
rcuStateWriterLockV RCUState
s)
    a
x <- RCUState -> IO a
m RCUState
s
    RCUState -> IO ()
synchronizeIO RCUState
s
    MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (RCUState -> MVar ()
rcuStateWriterLockV RCUState
s) ()
    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 = do
  Version
v <- IO Version
newVersion
  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 Version
-> MVar [Counter]
-> MVar ()
-> Counter
-> Maybe Int
-> RCUState
RCUState (Counter
 -> IORef Version
 -> MVar [Counter]
 -> MVar ()
 -> Counter
 -> Maybe Int
 -> RCUState)
-> IO Counter
-> IO
     (IORef Version
      -> MVar [Counter] -> MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Counter
newCounter Int
0
                       IO
  (IORef Version
   -> MVar [Counter] -> MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (IORef Version)
-> IO
     (MVar [Counter] -> MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Version -> IO (IORef Version)
forall a. a -> IO (IORef a)
newIORef Version
v
                       IO (MVar [Counter] -> MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (MVar [Counter])
-> IO (MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Counter] -> IO (MVar [Counter])
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
<*> Int -> IO Counter
newCounter Int
0
                       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 = do
  Version
v <- IO Version
newVersion
  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 Version
-> MVar [Counter]
-> MVar ()
-> Counter
-> Maybe Int
-> RCUState
RCUState (Counter
 -> IORef Version
 -> MVar [Counter]
 -> MVar ()
 -> Counter
 -> Maybe Int
 -> RCUState)
-> IO Counter
-> IO
     (IORef Version
      -> MVar [Counter] -> MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Counter
newCounter Int
0
                       IO
  (IORef Version
   -> MVar [Counter] -> MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (IORef Version)
-> IO
     (MVar [Counter] -> MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Version -> IO (IORef Version)
forall a. a -> IO (IORef a)
newIORef Version
v
                       IO (MVar [Counter] -> MVar () -> Counter -> Maybe Int -> RCUState)
-> IO (MVar [Counter])
-> IO (MVar () -> Counter -> Maybe Int -> RCUState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Counter] -> IO (MVar [Counter])
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
<*> Int -> IO Counter
newCounter Int
0
                       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)
{-# INLINE runOnRCU #-}