Skip to content

Commit 3c387f1

Browse files
committed
WIP
1 parent 5247b99 commit 3c387f1

File tree

1 file changed

+53
-80
lines changed

1 file changed

+53
-80
lines changed

src/kcas_data/queue.ml

+53-80
Original file line numberDiff line numberDiff line change
@@ -1,57 +1,40 @@
11
open Kcas
22

3-
let unique = ref ()
4-
let null () = Obj.magic unique
5-
63
module Elems = struct
74
type 'a t = { value : 'a; tl : 'a t; length : int }
85

9-
let rec empty = { value = null (); tl = empty; length = 0 }
6+
let rec empty = { value = Obj.magic (); tl = empty; length = 0 }
107
let[@inline] length t = t.length lxor (t.length asr (Sys.int_size - 1))
118

129
let rec rev_append length t tl =
1310
if length = 0 then tl
1411
else rev_append (length - 1) t.tl { value = t.value; tl; length }
1512

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
1715

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
2418
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
3824
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 }
4527

4628
let rec prepend_to_seq t tl =
29+
(* TODO: handle reverse! *)
4730
if t == empty then tl
4831
else fun () -> Seq.Cons (t.value, prepend_to_seq t.tl tl)
4932
end
5033

5134
module Back = struct
5235
type 'a t = { length : int; front : 'a; elems : 'a Elems.t }
5336

54-
let empty = { length = -1; front = null (); elems = Elems.empty }
37+
let empty = { length = -1; front = Obj.magic (); elems = Elems.empty }
5538
let[@inline] length t = lnot t.length
5639

5740
let[@inline] snoc x t =
@@ -81,14 +64,14 @@ module Back = struct
8164
in
8265
Elems.prepend_to_seq t tl ()
8366
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
8568
end
8669

8770
type 'a t = { front : 'a Elems.t Loc.t; back : 'a Back.t Loc.t }
8871

8972
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
9275
Multicore_magic.copy_as_padded { front; back }
9376

9477
let create () = alloc ~front:Elems.empty ~back:Back.empty
@@ -109,48 +92,40 @@ module Xt = struct
10992
let push = add
11093

11194
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
11697
let back = Xt.get ~xt t.back in
11798
if back.length = -1 then None else Some back.front
118-
else Some res
99+
else Some (Elems.head front)
119100

120101
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
125104
let back = Xt.get ~xt t.back in
126105
if back.length = -1 then Retry.later () else back.front
127-
else res
106+
else Elems.head front
128107

129108
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
134111
let back = Xt.exchange ~xt t.back Back.empty in
135112
if back.length = -1 then None
136113
else begin
137-
Xt.set ~xt t.front back.elems;
114+
if back.length <> -2 then Xt.set ~xt t.front back.elems;
138115
Some back.front
139116
end
140-
else Some res
117+
else Some (Elems.head front)
141118

142119
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
147122
let back = Xt.exchange ~xt t.back Back.empty in
148123
if back.length = -1 then Retry.later ()
149124
else begin
150-
Xt.set ~xt t.front back.elems;
125+
if back.length <> -2 then Xt.set ~xt t.front back.elems;
151126
back.front
152127
end
153-
else res
128+
else Elems.head front
154129

155130
let clear ~xt t =
156131
Xt.set ~xt t.front Elems.empty;
@@ -176,8 +151,8 @@ module Xt = struct
176151
seq_of ~front ~back
177152
end
178153

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 }
181156

182157
let add x t =
183158
(* Fenceless is safe as we always update. *)
@@ -187,40 +162,38 @@ let push = add
187162

188163
let take_opt t =
189164
(* 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)
194168

195169
let take_blocking ?timeoutf t =
196170
(* 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
201174

202175
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)
207180

208181
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
213186

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 }
215188
let clear t = Kcas.Xt.commit { tx = Xt.clear t }
216189
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
220193

221194
exception Empty
222195

223196
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
225198
let top = peek
226-
let take s = take_opt s |> of_option
199+
let take t = take_opt t |> of_option

0 commit comments

Comments
 (0)