Skip to content

Commit ac5ec6e

Browse files
polytypicpolytypic
committed
Add optional capacity argument to Queue.create and Stack.create 
1 parent d168d20 commit ac5ec6e

12 files changed

+361
-94
lines changed

‎src/kcas_data/elems.ml

+11
Original file line numberDiff line numberDiff line change
@@ -41,3 +41,14 @@ let rev_prepend_to_seq t tl =
4141
| `Reversed t' -> t'
4242
in
4343
prepend_to_seq t tl ()
44+
45+
let rec of_list_rev tl length = function
46+
| [] -> tl
47+
| x :: xs ->
48+
let length = length + 1 in
49+
of_list_rev { value = x; tl; length } length xs
50+
51+
let of_list_rev = function
52+
| [] -> empty
53+
| x :: xs -> of_list_rev (singleton x) 1 xs
54+
[@@inline]

‎src/kcas_data/elems.mli

+1
Original file line numberDiff line numberDiff line change
@@ -18,3 +18,4 @@ val prepend_to_seq : 'a t -> 'a Seq.t -> 'a Seq.t
1818
val to_seq : 'a t -> 'a Seq.t
1919
val of_seq_rev : 'a Seq.t -> 'a t
2020
val rev_prepend_to_seq : 'a t -> 'a Seq.t -> 'a Seq.t
21+
val of_list_rev : 'a list -> 'a t

‎src/kcas_data/list_with_capacity.ml

+113
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,113 @@
1+
open Kcas
2+
3+
type 'a t = { capacity : int; length : int; list : 'a list; limit : int }
4+
5+
let empty_unlimited =
6+
{ capacity = Int.max_int; length = 0; list = []; limit = Int.max_int }
7+
8+
let make_empty ~capacity =
9+
if capacity = Int.max_int then empty_unlimited
10+
else { capacity; length = 0; list = []; limit = capacity }
11+
[@@inline]
12+
13+
let make ~capacity ~length ~list ~limit = { capacity; length; list; limit }
14+
[@@inline]
15+
16+
let to_rev_elems t = Elems.of_list_rev t.list [@@inline]
17+
let is_empty t = t.length = 0 [@@inline]
18+
let length t = t.length [@@inline]
19+
let capacity t = t.capacity [@@inline]
20+
let limit t = t.limit [@@inline]
21+
let list t = t.list [@@inline]
22+
23+
let tl_safe = function
24+
| { list = []; _ } as t -> t
25+
| { capacity; length; list = _ :: list; _ } as t ->
26+
let limit = if capacity = Int.max_int then capacity else t.limit in
27+
{ capacity; length = length - 1; list; limit }
28+
[@@inline]
29+
30+
let tl_or_retry = function
31+
| { list = []; _ } -> Retry.later ()
32+
| { capacity; length; list = _ :: list; _ } as t ->
33+
let limit = if capacity = Int.max_int then capacity else t.limit in
34+
{ capacity; length = length - 1; list; limit }
35+
[@@inline]
36+
37+
let hd_opt t = match t.list with [] -> None | x :: _ -> Some x [@@inline]
38+
39+
let hd_or_retry t = match t.list with [] -> Retry.later () | x :: _ -> x
40+
[@@inline]
41+
42+
let hd_unsafe t = List.hd t.list [@@inline]
43+
44+
let cons_safe x ({ capacity; _ } as t) =
45+
if capacity = Int.max_int then
46+
let { length; list; _ } = t in
47+
{ capacity; length = length + 1; list = x :: list; limit = capacity }
48+
else
49+
let { length; limit; _ } = t in
50+
if length < limit then
51+
let { list; _ } = t in
52+
{ capacity; length = length + 1; list = x :: list; limit }
53+
else t
54+
[@@inline]
55+
56+
let cons_or_retry x ({ capacity; _ } as t) =
57+
if capacity = Int.max_int then
58+
let { length; list; _ } = t in
59+
{ capacity; length = length + 1; list = x :: list; limit = capacity }
60+
else
61+
let { length; limit; _ } = t in
62+
if length < limit then
63+
let { list; _ } = t in
64+
{ capacity; length = length + 1; list = x :: list; limit }
65+
else Retry.later ()
66+
[@@inline]
67+
68+
let move ({ capacity; _ } as t) =
69+
if capacity = Int.max_int then empty_unlimited
70+
else
71+
let { length; _ } = t in
72+
if length = 0 then t
73+
else
74+
let { limit; _ } = t in
75+
{ capacity; length = 0; list = []; limit = limit - length }
76+
[@@inline]
77+
78+
let clear ({ capacity; _ } as t) =
79+
if capacity = Int.max_int then empty_unlimited
80+
else if t.length = 0 then t
81+
else make_empty ~capacity
82+
[@@inline]
83+
84+
let rec prepend_to_seq xs tl =
85+
match xs with
86+
| [] -> tl
87+
| x :: xs -> fun () -> Seq.Cons (x, prepend_to_seq xs tl)
88+
89+
let to_seq { list; _ } = prepend_to_seq list Seq.empty
90+
91+
let rev_prepend_to_seq { length; list; _ } tl =
92+
if length <= 1 then prepend_to_seq list tl
93+
else
94+
let t = ref (`Original list) in
95+
fun () ->
96+
let t =
97+
match !t with
98+
| `Original t' ->
99+
(* This is domain safe as the result is always equivalent. *)
100+
let t' = List.rev t' in
101+
t := `Reversed t';
102+
t'
103+
| `Reversed t' -> t'
104+
in
105+
prepend_to_seq t tl ()
106+
107+
let of_list ?(capacity = Int.max_int) list =
108+
let length = List.length list in
109+
let limit = Int.min 0 (capacity - length) in
110+
{ capacity; length; list; limit }
111+
112+
let of_seq_rev ?capacity xs =
113+
of_list ?capacity (Seq.fold_left (fun xs x -> x :: xs) [] xs)

‎src/kcas_data/list_with_capacity.mli

+23
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
type !'a t
2+
3+
val empty_unlimited : 'a t
4+
val make_empty : capacity:int -> 'a t
5+
val make : capacity:int -> length:int -> list:'a list -> limit:int -> 'a t
6+
val is_empty : 'a t -> bool
7+
val length : 'a t -> int
8+
val capacity : 'a t -> int
9+
val limit : 'a t -> int
10+
val list : 'a t -> 'a list
11+
val cons_safe : 'a -> 'a t -> 'a t
12+
val cons_or_retry : 'a -> 'a t -> 'a t
13+
val move : 'a t -> 'a t
14+
val clear : 'a t -> 'a t
15+
val to_rev_elems : 'a t -> 'a Elems.t
16+
val to_seq : 'a t -> 'a Seq.t
17+
val rev_prepend_to_seq : 'a t -> 'a Seq.t -> 'a Seq.t
18+
val of_seq_rev : ?capacity:int -> 'a Seq.t -> 'a t
19+
val tl_safe : 'a t -> 'a t
20+
val tl_or_retry : 'a t -> 'a t
21+
val hd_opt : 'a t -> 'a option
22+
val hd_or_retry : 'a t -> 'a
23+
val hd_unsafe : 'a t -> 'a

‎src/kcas_data/queue.ml

+106-61
Original file line numberDiff line numberDiff line change
@@ -2,127 +2,172 @@ open Kcas
22

33
type 'a t = {
44
front : 'a Elems.t Loc.t;
5-
middle : 'a Elems.t Loc.t;
6-
back : 'a Elems.t Loc.t;
5+
back : 'a List_with_capacity.t Loc.t;
6+
middle : 'a List_with_capacity.t Loc.t;
77
}
88

9-
let alloc ~front ~middle ~back =
9+
let alloc ~front ~back ~middle =
1010
(* We allocate locations in specific order to make most efficient use of the
1111
splay-tree based transaction log. *)
1212
let front = Loc.make front
13-
and middle = Loc.make middle
14-
and back = Loc.make back in
13+
and back = Loc.make back
14+
and middle = Loc.make middle in
1515
{ back; middle; front }
1616

17-
let create () = alloc ~front:Elems.empty ~middle:Elems.empty ~back:Elems.empty
17+
let create ?(capacity = Int.max_int) () =
18+
if capacity < 0 then invalid_arg "Queue.create: capacity must be non-negative";
19+
let back = List_with_capacity.make_empty ~capacity in
20+
alloc ~front:Elems.empty ~back ~middle:List_with_capacity.empty_unlimited
1821

1922
let copy q =
20-
let tx ~xt = (Xt.get ~xt q.front, Xt.get ~xt q.middle, Xt.get ~xt q.back) in
21-
let front, middle, back = Xt.commit { tx } in
22-
alloc ~front ~middle ~back
23+
let tx ~xt = (Xt.get ~xt q.front, Xt.get ~xt q.back, Xt.get ~xt q.middle) in
24+
let front, back, middle = Xt.commit { tx } in
25+
alloc ~front ~back ~middle
2326

2427
module Xt = struct
25-
let is_empty ~xt { back; middle; front } =
28+
let is_empty ~xt q =
2629
(* We access locations in order of allocation to make most efficient use of
2730
the splay-tree based transaction log. *)
28-
Xt.get ~xt front == Elems.empty
29-
&& Xt.get ~xt middle == Elems.empty
30-
&& Xt.get ~xt back == Elems.empty
31-
32-
let length ~xt { back; middle; front } =
33-
Elems.length (Xt.get ~xt front)
34-
+ Elems.length (Xt.get ~xt middle)
35-
+ Elems.length (Xt.get ~xt back)
36-
37-
let add ~xt x q = Xt.unsafe_modify ~xt q.back @@ Elems.cons x
31+
Xt.get ~xt q.front == Elems.empty
32+
&& List_with_capacity.is_empty (Xt.get ~xt q.back)
33+
&& Xt.get ~xt q.middle == List_with_capacity.empty_unlimited
34+
35+
let length ~xt q =
36+
Elems.length (Xt.get ~xt q.front)
37+
+ List_with_capacity.length (Xt.get ~xt q.back)
38+
+ List_with_capacity.length (Xt.get ~xt q.middle)
39+
40+
let try_add ~xt x q =
41+
let lwc = Xt.unsafe_update ~xt q.back (List_with_capacity.cons_safe x) in
42+
let capacity = List_with_capacity.capacity lwc in
43+
capacity = Int.max_int
44+
||
45+
let back_length = List_with_capacity.length lwc in
46+
back_length < List_with_capacity.limit lwc
47+
||
48+
let other_length =
49+
List_with_capacity.length (Xt.get ~xt q.middle)
50+
+ Elems.length (Xt.get ~xt q.front)
51+
in
52+
let limit = capacity - other_length in
53+
back_length < limit
54+
&&
55+
(Xt.set ~xt q.back
56+
(List_with_capacity.make ~capacity ~length:(back_length + 1)
57+
~list:(x :: List_with_capacity.list lwc)
58+
~limit);
59+
true)
60+
61+
let add ~xt x q = Retry.unless (try_add ~xt x q)
3862
let push = add
3963

4064
(** Cooperative helper to move elems from back to middle. *)
41-
let back_to_middle ~middle ~back =
65+
let back_to_middle ~back ~middle =
4266
let tx ~xt =
43-
let xs = Xt.exchange ~xt back Elems.empty in
44-
if xs == Elems.empty || Xt.exchange ~xt middle xs != Elems.empty then
45-
raise Exit
67+
let xs = Xt.unsafe_update ~xt back List_with_capacity.move in
68+
if
69+
List_with_capacity.length xs = 0
70+
|| Xt.exchange ~xt middle xs != List_with_capacity.empty_unlimited
71+
then raise Exit
4672
in
4773
try Xt.commit { tx } with Exit -> ()
4874

49-
let take_opt_finish ~xt front elems =
50-
let elems = Elems.rev elems in
75+
let take_opt_finish ~xt front lwc =
76+
let elems = List_with_capacity.to_rev_elems lwc in
5177
Xt.set ~xt front (Elems.tl_safe elems);
5278
Elems.hd_opt elems
5379

54-
let take_opt ~xt { back; middle; front } =
80+
let take_opt ~xt { front; back; middle } =
5581
let elems = Xt.unsafe_update ~xt front Elems.tl_safe in
5682
if elems != Elems.empty then Elems.hd_opt elems
5783
else (
5884
if not (Xt.is_in_log ~xt middle || Xt.is_in_log ~xt back) then
59-
back_to_middle ~middle ~back;
60-
let elems = Xt.exchange ~xt middle Elems.empty in
61-
if elems != Elems.empty then take_opt_finish ~xt front elems
85+
back_to_middle ~back ~middle;
86+
let lwc = Xt.exchange ~xt middle List_with_capacity.empty_unlimited in
87+
if lwc != List_with_capacity.empty_unlimited then
88+
take_opt_finish ~xt front lwc
6289
else
63-
let elems = Xt.exchange ~xt back Elems.empty in
64-
if elems != Elems.empty then take_opt_finish ~xt front elems else None)
90+
let lwc = Xt.unsafe_update ~xt back List_with_capacity.move in
91+
if List_with_capacity.length lwc <> 0 then take_opt_finish ~xt front lwc
92+
else None)
6593

6694
let take_blocking ~xt q = Xt.to_blocking ~xt (take_opt q)
6795

68-
let peek_opt_finish ~xt front elems =
69-
let elems = Elems.rev elems in
96+
let peek_opt_finish ~xt front lwc =
97+
let elems = List_with_capacity.to_rev_elems lwc in
7098
Xt.set ~xt front elems;
7199
Elems.hd_opt elems
72100

73-
let peek_opt ~xt { back; middle; front } =
101+
let peek_opt ~xt { front; back; middle } =
74102
let elems = Xt.get ~xt front in
75103
if elems != Elems.empty then Elems.hd_opt elems
76104
else (
77105
if not (Xt.is_in_log ~xt middle || Xt.is_in_log ~xt back) then
78-
back_to_middle ~middle ~back;
79-
let elems = Xt.exchange ~xt middle Elems.empty in
80-
if elems != Elems.empty then peek_opt_finish ~xt front elems
106+
back_to_middle ~back ~middle;
107+
let lwc = Xt.exchange ~xt middle List_with_capacity.empty_unlimited in
108+
if lwc != List_with_capacity.empty_unlimited then
109+
peek_opt_finish ~xt front lwc
81110
else
82-
let elems = Xt.exchange ~xt back Elems.empty in
83-
if elems != Elems.empty then peek_opt_finish ~xt front elems else None)
111+
let lwc = Xt.unsafe_update ~xt back List_with_capacity.move in
112+
if List_with_capacity.length lwc <> 0 then peek_opt_finish ~xt front lwc
113+
else None)
84114

85115
let peek_blocking ~xt q = Xt.to_blocking ~xt (peek_opt q)
86116

87-
let clear ~xt { back; middle; front } =
88-
Xt.set ~xt front Elems.empty;
89-
Xt.set ~xt middle Elems.empty;
90-
Xt.set ~xt back Elems.empty
117+
let clear ~xt q =
118+
Xt.set ~xt q.front Elems.empty;
119+
Xt.unsafe_modify ~xt q.back List_with_capacity.clear;
120+
Xt.set ~xt q.middle List_with_capacity.empty_unlimited
91121

92122
let swap ~xt q1 q2 =
93123
let front = Xt.get ~xt q1.front
94-
and middle = Xt.get ~xt q1.middle
95-
and back = Xt.get ~xt q1.back in
124+
and back = Xt.get ~xt q1.back
125+
and middle = Xt.get ~xt q1.middle in
96126
let front = Xt.exchange ~xt q2.front front
97-
and middle = Xt.exchange ~xt q2.middle middle
98-
and back = Xt.exchange ~xt q2.back back in
127+
and back = Xt.exchange ~xt q2.back back
128+
and middle = Xt.exchange ~xt q2.middle middle in
99129
Xt.set ~xt q1.front front;
100-
Xt.set ~xt q1.middle middle;
101-
Xt.set ~xt q1.back back
130+
Xt.set ~xt q1.back back;
131+
Xt.set ~xt q1.middle middle
102132

103133
let seq_of ~front ~middle ~back =
104134
(* Sequence construction is lazy, so this function is O(1). *)
105135
Seq.empty
106-
|> Elems.rev_prepend_to_seq back
107-
|> Elems.rev_prepend_to_seq middle
136+
|> List_with_capacity.rev_prepend_to_seq back
137+
|> List_with_capacity.rev_prepend_to_seq middle
108138
|> Elems.prepend_to_seq front
109139

110-
let to_seq ~xt { front; middle; back } =
111-
let front = Xt.get ~xt front
112-
and middle = Xt.get ~xt middle
113-
and back = Xt.get ~xt back in
140+
let to_seq ~xt q =
141+
let front = Xt.get ~xt q.front
142+
and back = Xt.get ~xt q.back
143+
and middle = Xt.get ~xt q.middle in
114144
seq_of ~front ~middle ~back
115145

116-
let take_all ~xt { front; middle; back } =
117-
let front = Xt.exchange ~xt front Elems.empty
118-
and middle = Xt.exchange ~xt middle Elems.empty
119-
and back = Xt.exchange ~xt back Elems.empty in
146+
let take_all ~xt q =
147+
let front = Xt.exchange ~xt q.front Elems.empty
148+
and back = Xt.unsafe_update ~xt q.back List_with_capacity.clear
149+
and middle = Xt.exchange ~xt q.middle List_with_capacity.empty_unlimited in
120150
seq_of ~front ~middle ~back
121151
end
122152

123153
let is_empty q = Kcas.Xt.commit { tx = Xt.is_empty q }
124154
let length q = Kcas.Xt.commit { tx = Xt.length q }
125-
let add x q = Loc.modify q.back @@ Elems.cons x
155+
156+
let try_add x q =
157+
let lwc = Loc.update q.back (List_with_capacity.cons_safe x) in
158+
let capacity = List_with_capacity.capacity lwc in
159+
capacity = Int.max_int
160+
||
161+
let back_length = List_with_capacity.length lwc in
162+
back_length < List_with_capacity.limit lwc
163+
|| Kcas.Xt.commit { tx = Xt.try_add x q }
164+
165+
let add x q =
166+
let lwc = Loc.update q.back (List_with_capacity.cons_safe x) in
167+
if List_with_capacity.capacity lwc <> Int.max_int then
168+
if List_with_capacity.length lwc = List_with_capacity.limit lwc then
169+
Kcas.Xt.commit { tx = Xt.add x q }
170+
126171
let push = add
127172

128173
let take_opt q =

0 commit comments

Comments
 (0)