summaryrefslogtreecommitdiff
path: root/Reactor/Atomic.hs
blob: 0a0b70ccfbcf5a91d495758313f7bfe51ba0420e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
{-# LANGUAGE DeriveDataTypeable #-}
module Reactor.Atomic where

import Control.Monad
import Control.Monad.IO.Class
import Data.Bits.Atomic
import Data.Data
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import System.IO.Unsafe

newtype Atomic a = Atomic (ForeignPtr a)
  deriving (Data, Typeable)

instance (Show a, Storable a) => Show (Atomic a) where
  showsPrec d (Atomic fp) = showsPrec d $ unsafePerformIO $ withForeignPtr fp peek

atomic :: (MonadIO m, AtomicBits a, Storable a) => a -> m (Atomic a)
atomic a = liftIO $ do
  fp <- mallocForeignPtr
  withForeignPtr fp $ \p -> poke p a
  return $ Atomic fp 

withAtomic :: MonadIO m => Atomic a -> (Ptr a -> IO b) -> m b
withAtomic (Atomic fp) = liftIO . withForeignPtr fp 
{-# INLINE withAtomic #-}

atomicFetchAndAdd :: (MonadIO m, AtomicBits a) => Atomic a -> a -> m a
atomicFetchAndAdd fp a = withAtomic fp $ \p -> fetchAndAdd p a
{-# INLINE atomicFetchAndAdd #-}

atomicFetchAndAnd :: (MonadIO m, AtomicBits a) => Atomic a -> a -> m a
atomicFetchAndAnd fp a = withAtomic fp $ \p -> fetchAndAnd p a
{-# INLINE atomicFetchAndAnd #-}
  
atomicFetch :: (MonadIO m, AtomicBits a) => Atomic a -> m a 
atomicFetch fp = atomicFetchAndAdd fp 0
{-# INLINE atomicFetch #-}

atomicFetchAndSub :: (MonadIO m, AtomicBits a) => Atomic a -> a -> m a
atomicFetchAndSub fp a = withAtomic fp $ \p -> fetchAndSub p a
{-# INLINE atomicFetchAndSub #-}

atomicSubAndFetch :: (MonadIO m, AtomicBits a) => Atomic a -> a -> m a
atomicSubAndFetch fp a = withAtomic fp $ \p -> subAndFetch p a
{-# INLINE atomicSubAndFetch #-}

atomicAddAndFetch :: (MonadIO m, AtomicBits a) => Atomic a -> a -> m a
atomicAddAndFetch fp a = withAtomic fp $ \p -> subAndFetch p a
{-# INLINE atomicAddAndFetch #-}

atomicCompareAndSwapBool :: (MonadIO m, AtomicBits a) => Atomic a -> a -> a -> m Bool
atomicCompareAndSwapBool fp old new = withAtomic fp $ \p -> compareAndSwapBool p old new
{-# INLINE atomicCompareAndSwapBool #-}

atomicCompareAndSwap :: (MonadIO m, AtomicBits a) => Atomic a -> a -> a -> m a
atomicCompareAndSwap fp old new = withAtomic fp $ \p -> compareAndSwap p old new
{-# INLINE atomicCompareAndSwap #-}

atomicLockTestAndSet :: (MonadIO m, AtomicBits a) => Atomic a -> m a
atomicLockTestAndSet fp = withAtomic fp lockTestAndSet
{-# INLINE atomicLockTestAndSet #-}

atomicLockRelease :: (MonadIO m, AtomicBits a) => Atomic a -> m ()
atomicLockRelease fp = withAtomic fp lockRelease
{-# INLINE atomicLockRelease #-}

given :: (MonadIO m, AtomicBits a) => Atomic a -> m () -> m ()
given flag task = do
    i <- atomicFetch flag
    when (i /= 0) task

clearing :: (MonadIO m, AtomicBits a) => Atomic a -> m () -> m ()
clearing flag task = do
    i <- atomicFetchAndAnd flag 0
    when (i /= 0) task