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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
{-# LANGUAGE TypeFamilies, CPP, BangPatterns #-}
{-|
A strawman implementation of concurrent Dequeues. This
implementation is so simple that it also makes a good reference
implementation for debugging.
The queue representation is simply an IORef containing a Data.Sequence.
Also see "Data.Concurrent.Deque.Reference.DequeInstance".
By convention a module of this name is also provided.
-}
module Data.Concurrent.Deque.Reference
(SimpleDeque(..),
newQ, nullQ, newBoundedQ, pushL, pushR, tryPopR, tryPopL, tryPushL, tryPushR,
_is_using_CAS -- Internal
)
where
import Prelude hiding (length)
import qualified Data.Concurrent.Deque.Class as C
import Data.Sequence
import Data.IORef
#ifdef USE_CAS
#warning "abstract-deque: reference implementation using CAS..."
import Data.CAS (atomicModifyIORefCAS)
-- Toggle these and compare performance:
modify = atomicModifyIORefCAS
_is_using_CAS = True
#else
modify = atomicModifyIORef
_is_using_CAS = False
#endif
{-# INLINE modify #-}
modify :: IORef a -> (a -> (a, b)) -> IO b
_is_using_CAS :: Bool
-- | Stores a size bound (if any) as well as a mutable Seq.
data SimpleDeque elt = DQ {-# UNPACK #-} !Int !(IORef (Seq elt))
newQ :: IO (SimpleDeque elt)
newQ = do r <- newIORef empty
return $! DQ 0 r
newBoundedQ :: Int -> IO (SimpleDeque elt)
newBoundedQ lim =
do r <- newIORef empty
return $! DQ lim r
pushL :: SimpleDeque t -> t -> IO ()
pushL (DQ 0 qr) !x = do
() <- modify qr addleft
return ()
where
-- Here we are very strict to avoid stack leaks.
addleft !s = extended `seq` pair
where extended = x <| s
pair = (extended, ())
pushL (DQ n _) _ = error$ "should not call pushL on Deque with size bound "++ show n
tryPopR :: SimpleDeque a -> IO (Maybe a)
tryPopR (DQ _ qr) = modify qr $ \ s ->
case viewr s of
EmptyR -> (empty, Nothing)
s' :> x -> (s', Just x)
nullQ :: SimpleDeque elt -> IO Bool
nullQ (DQ _ qr) =
do s <- readIORef qr
case viewr s of
EmptyR -> return True
_ :> _ -> return False
-- -- This simplistic version simply spins:
-- popR q = do x <- tryPopR q
-- case x of
-- Nothing -> popR q
-- Just x -> return x
-- popL q = do x <- tryPopL q
-- case x of
-- Nothing -> popL q
-- Just x -> return x
tryPopL :: SimpleDeque a -> IO (Maybe a)
tryPopL (DQ _ qr) = modify qr $ \s ->
case viewl s of
EmptyL -> (empty, Nothing)
x :< s' -> (s', Just x)
pushR :: SimpleDeque t -> t -> IO ()
pushR (DQ 0 qr) x = modify qr (\s -> (s |> x, ()))
pushR (DQ n _) _ = error$ "should not call pushR on Deque with size bound "++ show n
tryPushL :: SimpleDeque a -> a -> IO Bool
tryPushL q@(DQ 0 _) v = pushL q v >> return True
tryPushL (DQ lim qr) v =
modify qr $ \s ->
if length s == lim
then (s, False)
else (v <| s, True)
tryPushR :: SimpleDeque a -> a -> IO Bool
tryPushR q@(DQ 0 _) v = pushR q v >> return True
tryPushR (DQ lim qr) v =
modify qr $ \s ->
if length s == lim
then (s, False)
else (s |> v, True)
--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------
instance C.DequeClass SimpleDeque where
newQ = newQ
nullQ = nullQ
pushL = pushL
tryPopR = tryPopR
leftThreadSafe _ = True
rightThreadSafe _ = True
instance C.PopL SimpleDeque where
tryPopL = tryPopL
instance C.PushR SimpleDeque where
pushR = pushR
instance C.BoundedL SimpleDeque where
tryPushL = tryPushL
newBoundedQ = newBoundedQ
instance C.BoundedR SimpleDeque where
tryPushR = tryPushR
|
