@@ -0,0 +1,82 @@
1+{-# LANGUAGE CPP #-}
2+
3+-- |
4+-- Module : Streamly.Atomics
5+-- Copyright : (c) 2018-2019 Composewell Technologies
6+--
7+-- License : BSD3
8+-- Maintainer : harendra.kumar@gmail.com
9+-- Stability : experimental
10+-- Portability : GHC
11+
12+module Streamly.Atomics
13+ (
14+ atomicModifyIORefCAS
15+ , atomicModifyIORefCAS_
16+ , writeBarrier
17+ , storeLoadBarrier
18+ )
19+where
20+
21+import Data.IORef (IORef, atomicModifyIORef)
22+#ifdef ghcjs_HOST_OS
23+import Data.IORef (modifyIORef)
24+#else
25+import qualified Data.Atomics as A
26+#endif
27+
28+#ifndef ghcjs_HOST_OS
29+
30+-- XXX Does it make sense to have replacements for atomicModifyIORef etc. on a
31+-- single threaded system.
32+--
33+-- Slightly faster version of CAS. Gained some improvement by avoiding the use
34+-- of "evaluate" because we know we do not have exceptions in fn.
35+{-# INLINE atomicModifyIORefCAS #-}
36+atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b
37+atomicModifyIORefCAS ref fn = do
38+ tkt <- A.readForCAS ref
39+ loop tkt retries
40+
41+ where
42+
43+ retries = 25 :: Int
44+ loop _ 0 = atomicModifyIORef ref fn
45+ loop old tries = do
46+ let (new, result) = fn $ A.peekTicket old
47+ (success, tkt) <- A.casIORef ref old new
48+ if success
49+ then return result
50+ else loop tkt (tries - 1)
51+
52+{-# INLINE atomicModifyIORefCAS_ #-}
53+atomicModifyIORefCAS_ :: IORef t -> (t -> t) -> IO ()
54+atomicModifyIORefCAS_ = A.atomicModifyIORefCAS_
55+
56+{-# INLINE writeBarrier #-}
57+writeBarrier :: IO ()
58+writeBarrier = A.writeBarrier
59+
60+{-# INLINE storeLoadBarrier #-}
61+storeLoadBarrier :: IO ()
62+storeLoadBarrier = A.storeLoadBarrier
63+
64+#else
65+
66+{-# INLINE atomicModifyIORefCAS #-}
67+atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b
68+atomicModifyIORefCAS = atomicModifyIORef
69+
70+{-# INLINE atomicModifyIORefCAS_ #-}
71+atomicModifyIORefCAS_ :: IORef a -> (a -> a) -> IO ()
72+atomicModifyIORefCAS_ = modifyIORef
73+
74+{-# INLINE writeBarrier #-}
75+writeBarrier :: IO ()
76+writeBarrier = return ()
77+
78+{-# INLINE storeLoadBarrier #-}
79+storeLoadBarrier :: IO ()
80+storeLoadBarrier = return ()
81+
82+#endif