1
1
open Kcas
2
2
3
- let unique = ref ()
4
- let null () = Obj. magic unique
5
-
6
3
module Elems = struct
7
4
type 'a t = { value : 'a ; tl : 'a t ; length : int }
8
5
9
- let rec empty = { value = null () ; tl = empty; length = 0 }
6
+ let rec empty = { value = Obj. magic () ; tl = empty; length = 0 }
10
7
let [@ inline] length t = t.length lxor (t.length asr (Sys. int_size - 1 ))
11
8
12
9
let rec rev_append length t tl =
13
10
if length = 0 then tl
14
11
else rev_append (length - 1 ) t.tl { value = t.value; tl; length }
15
12
16
- let tl_safe t = if - 2 < = t.length then t.tl else t
13
+ let rec head i t = if i = - 2 then t.value else head (i + 1 ) t.tl
14
+ let [@ inline] head t = if t.length < 0 then head t.length t else t.value
17
15
18
- let [@ inline] tl res t =
19
- let length = t.length in
20
- if - 2 < = length then begin
21
- if length <> 0 then res := t.value;
22
- t.tl
23
- end
16
+ let [@ inline] tl t =
17
+ if - 2 < = t.length then t.tl
24
18
else
25
- let length = lnot length in
26
- let t =
27
- rev_append (length - 1 ) t.tl { value = t.value; tl = empty; length }
28
- in
29
- res := t.value;
30
- t.tl
31
-
32
- let peek res t =
33
- let length = t.length in
34
- if - 2 < = length then begin
35
- if length <> 0 then res := t.value;
36
- t
37
- end
19
+ let length = lnot t.length - 1 in
20
+ rev_append (length - 1 ) t.tl { value = t.value; tl = empty; length }
21
+
22
+ let [@ inline] peek t =
23
+ if - 2 < = t.length then t
38
24
else
39
- let length = lnot length in
40
- let t =
41
- rev_append (length - 1 ) t.tl { value = t.value; tl = empty; length }
42
- in
43
- res := t.value;
44
- t
25
+ let length = lnot t.length in
26
+ rev_append (length - 1 ) t.tl { value = t.value; tl = empty; length }
45
27
46
28
let rec prepend_to_seq t tl =
29
+ (* TODO: handle reverse! *)
47
30
if t == empty then tl
48
31
else fun () -> Seq. Cons (t.value, prepend_to_seq t.tl tl)
49
32
end
50
33
51
34
module Back = struct
52
35
type 'a t = { length : int ; front : 'a ; elems : 'a Elems .t }
53
36
54
- let empty = { length = - 1 ; front = null () ; elems = Elems. empty }
37
+ let empty = { length = - 1 ; front = Obj. magic () ; elems = Elems. empty }
55
38
let [@ inline] length t = lnot t.length
56
39
57
40
let [@ inline] snoc x t =
@@ -81,14 +64,14 @@ module Back = struct
81
64
in
82
65
Elems. prepend_to_seq t tl ()
83
66
in
84
- if t.length < = - 2 then Seq. cons t.front tl else tl
67
+ if t.length < = - 2 then fun () -> Seq. Cons ( t.front, tl) else tl
85
68
end
86
69
87
70
type 'a t = { front : 'a Elems .t Loc .t ; back : 'a Back .t Loc .t }
88
71
89
72
let alloc ~front ~back =
90
- let front = Loc. make ~padded: true front
91
- and back = Loc. make ~padded: true back in
73
+ let front = Loc. make ~padded: true front in
74
+ let back = Loc. make ~padded: true back in
92
75
Multicore_magic. copy_as_padded { front; back }
93
76
94
77
let create () = alloc ~front: Elems. empty ~back: Back. empty
@@ -109,48 +92,40 @@ module Xt = struct
109
92
let push = add
110
93
111
94
let peek_opt ~xt t =
112
- let res = ref (null () ) in
113
- Xt. unsafe_modify ~xt t.front @@ Elems. peek res;
114
- let res = ! res in
115
- if res == null () then
95
+ let front = Xt. unsafe_update ~xt t.front Elems. peek in
96
+ if front.length = 0 then
116
97
let back = Xt. get ~xt t.back in
117
98
if back.length = - 1 then None else Some back.front
118
- else Some res
99
+ else Some ( Elems. head front)
119
100
120
101
let peek_blocking ~xt t =
121
- let res = ref (null () ) in
122
- Xt. unsafe_modify ~xt t.front @@ Elems. peek res;
123
- let res = ! res in
124
- if res == null () then
102
+ let front = Xt. unsafe_update ~xt t.front Elems. peek in
103
+ if front.length = 0 then
125
104
let back = Xt. get ~xt t.back in
126
105
if back.length = - 1 then Retry. later () else back.front
127
- else res
106
+ else Elems. head front
128
107
129
108
let take_opt ~xt t =
130
- let res = ref (null () ) in
131
- Xt. unsafe_modify ~xt t.front @@ Elems. tl res;
132
- let res = ! res in
133
- if res == null () then
109
+ let front = Xt. unsafe_update ~xt t.front Elems. tl in
110
+ if front.length = 0 then
134
111
let back = Xt. exchange ~xt t.back Back. empty in
135
112
if back.length = - 1 then None
136
113
else begin
137
- Xt. set ~xt t.front back.elems;
114
+ if back.length <> - 2 then Xt. set ~xt t.front back.elems;
138
115
Some back.front
139
116
end
140
- else Some res
117
+ else Some ( Elems. head front)
141
118
142
119
let take_blocking ~xt t =
143
- let res = ref (null () ) in
144
- Xt. unsafe_modify ~xt t.front @@ Elems. tl res;
145
- let res = ! res in
146
- if res == null () then
120
+ let front = Xt. unsafe_update ~xt t.front Elems. tl in
121
+ if front.length = 0 then
147
122
let back = Xt. exchange ~xt t.back Back. empty in
148
123
if back.length = - 1 then Retry. later ()
149
124
else begin
150
- Xt. set ~xt t.front back.elems;
125
+ if back.length <> - 2 then Xt. set ~xt t.front back.elems;
151
126
back.front
152
127
end
153
- else res
128
+ else Elems. head front
154
129
155
130
let clear ~xt t =
156
131
Xt. set ~xt t.front Elems. empty;
@@ -176,8 +151,8 @@ module Xt = struct
176
151
seq_of ~front ~back
177
152
end
178
153
179
- let is_empty q = Kcas.Xt. commit { tx = Xt. is_empty q }
180
- let length q = Kcas.Xt. commit { tx = Xt. length q }
154
+ let is_empty t = Kcas.Xt. commit { tx = Xt. is_empty t }
155
+ let length t = Kcas.Xt. commit { tx = Xt. length t }
181
156
182
157
let add x t =
183
158
(* Fenceless is safe as we always update. *)
@@ -187,40 +162,38 @@ let push = add
187
162
188
163
let take_opt t =
189
164
(* Fenceless is safe as we revert to a transaction in case we didn't update. *)
190
- let front = Loc. fenceless_update t.front Elems. tl_safe in
191
- let length = front.length in
192
- if 0 < length || length = - 2 then Some front.value
193
- else Kcas.Xt. commit { tx = Xt. take_opt t }
165
+ let front = Loc. fenceless_update t.front Elems. tl in
166
+ if front.length = 0 then Kcas.Xt. commit { tx = Xt. take_opt t }
167
+ else Some (Elems. head front)
194
168
195
169
let take_blocking ?timeoutf t =
196
170
(* Fenceless is safe as we revert to a transaction in case we didn't update. *)
197
- let front = Loc. fenceless_update t.front Elems. tl_safe in
198
- let length = front.length in
199
- if 0 < length || length = - 2 then front.value
200
- else Kcas.Xt. commit ?timeoutf { tx = Xt. take_blocking t }
171
+ let front = Loc. fenceless_update t.front Elems. tl in
172
+ if front.length = 0 then Kcas.Xt. commit ?timeoutf { tx = Xt. take_blocking t }
173
+ else Elems. head front
201
174
202
175
let peek_opt t =
203
- let front = Loc. get t.front in
204
- let length = front.length in
205
- if 0 < length || length = - 2 then Some front.value
206
- else Kcas.Xt. commit { tx = Xt. peek_opt t }
176
+ (* Fenceless is safe as we revert to a transaction in case we didn't update. *)
177
+ let front = Loc. fenceless_update t. front Elems. peek in
178
+ if front.length = 0 then Kcas.Xt. commit { tx = Xt. peek_opt t }
179
+ else Some ( Elems. head front)
207
180
208
181
let peek_blocking ?timeoutf t =
209
- let front = Loc. get t.front in
210
- let length = front.length in
211
- if 0 < length || length = - 2 then front.value
212
- else Kcas.Xt. commit ?timeoutf { tx = Xt. peek_blocking t }
182
+ (* Fenceless is safe as we revert to a transaction in case we didn't update. *)
183
+ let front = Loc. fenceless_update t. front Elems. peek in
184
+ if front.length = 0 then Kcas.Xt. commit ?timeoutf { tx = Xt. peek_blocking t }
185
+ else Elems. head front
213
186
214
- let take_all q = Kcas.Xt. commit { tx = Xt. take_all q }
187
+ let take_all t = Kcas.Xt. commit { tx = Xt. take_all t }
215
188
let clear t = Kcas.Xt. commit { tx = Xt. clear t }
216
189
let swap t1 t2 = Kcas.Xt. commit { tx = Xt. swap t1 t2 }
217
- let to_seq q = Kcas.Xt. commit { tx = Xt. to_seq q }
218
- let iter f q = Seq. iter f @@ to_seq q
219
- let fold f a q = Seq. fold_left f a @@ to_seq q
190
+ let to_seq t = Kcas.Xt. commit { tx = Xt. to_seq t }
191
+ let iter f t = Seq. iter f @@ to_seq t
192
+ let fold f a t = Seq. fold_left f a @@ to_seq t
220
193
221
194
exception Empty
222
195
223
196
let [@ inline] of_option = function None -> raise Empty | Some value -> value
224
- let peek s = peek_opt s |> of_option
197
+ let peek t = peek_opt t |> of_option
225
198
let top = peek
226
- let take s = take_opt s |> of_option
199
+ let take t = take_opt t |> of_option
0 commit comments