Skip to content

Commit f58ca2d

Browse files
polytypicpolytypic
committed
Add a transaction benchmark using a naïve unscalable leftist heap
1 parent 969ddad commit f58ca2d

File tree

2 files changed

+140
-0
lines changed

2 files changed

+140
-0
lines changed

‎bench/bench_leftist_heap.ml

Lines changed: 139 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,139 @@
1+
open Kcas
2+
3+
(** This is a naïve transactional leftist heap implementation.
4+
5+
⚠️ This simply cannot scale, because essentially every delete min operation
6+
updates the root. This can still be a useful benchmark of the transaction
7+
mechanism, but please do not believe for a second that this is a scalable
8+
concurrent priority queue. *)
9+
module Leftist_heap : sig
10+
type 'a t
11+
12+
val create : lt:('a -> 'a -> bool) -> 'a t
13+
14+
module Xt : sig
15+
val insert : xt:'x Xt.t -> 'a t -> 'a -> unit
16+
val delete_min_opt : xt:'x Xt.t -> 'a t -> 'a option
17+
end
18+
19+
val insert : 'a t -> 'a -> unit
20+
val delete_min_opt : 'a t -> 'a option
21+
end = struct
22+
type 'a t = { lt : 'a -> 'a -> bool; root : 'a link Loc.t }
23+
24+
and ('a, _) tdt =
25+
| Null : ('a, [> `Null ]) tdt
26+
| Node :
27+
'a link Loc.t * int Loc.t * 'a * 'a link Loc.t
28+
-> ('a, [> `Node ]) tdt
29+
30+
and 'a link = Link : ('a, [< `Null | `Node ]) tdt -> 'a link [@@unboxed]
31+
32+
let create ~lt =
33+
let root = Loc.make ~padded:true (Link Null) in
34+
Multicore_magic.copy_as_padded { lt; root }
35+
36+
module Xt = struct
37+
let npl_of ~xt = function
38+
| Link Null -> 0
39+
| Link (Node (_, npl, _, _)) -> Xt.get ~xt npl
40+
41+
let rec merge ~xt ~lt h1 h2 =
42+
match (h1, h2) with
43+
| Link Null, h2 -> h2
44+
| h1, Link Null -> h1
45+
| Link (Node (_, _, v1, _) as h1), Link (Node (_, _, v2, _) as h2) ->
46+
let (Node (h1l, npl, _, h1r) as h1 : (_, [ `Node ]) tdt), h2 =
47+
if lt v1 v2 then (h1, h2) else (h2, h1)
48+
in
49+
let l = Xt.get ~xt h1l in
50+
if l == Link Null then Xt.set ~xt h1l (Link h2)
51+
else begin
52+
let r = merge ~xt ~lt (Xt.get ~xt h1r) (Link h2) in
53+
match (npl_of ~xt l, npl_of ~xt r) with
54+
| l_npl, r_npl when l_npl < r_npl ->
55+
Xt.set ~xt h1l r;
56+
Xt.set ~xt h1r l;
57+
Xt.set ~xt npl (l_npl + 1)
58+
| _, r_npl ->
59+
Xt.set ~xt h1r r;
60+
Xt.set ~xt npl (r_npl + 1)
61+
end;
62+
Link h1
63+
64+
let insert ~xt h x =
65+
let h1 =
66+
Node (Loc.make (Link Null), Loc.make 1, x, Loc.make (Link Null))
67+
in
68+
Xt.set ~xt h.root (merge ~xt ~lt:h.lt (Link h1) (Xt.get ~xt h.root))
69+
70+
let delete_min_opt ~xt h =
71+
match Xt.get ~xt h.root with
72+
| Link Null -> None
73+
| Link (Node (h1, _, x, h2)) ->
74+
Xt.set ~xt h.root (merge ~xt ~lt:h.lt (Xt.get ~xt h1) (Xt.get ~xt h2));
75+
Some x
76+
end
77+
78+
let insert h x = Kcas.Xt.commit { tx = Xt.insert h x }
79+
let delete_min_opt h = Kcas.Xt.commit { tx = Xt.delete_min_opt h }
80+
end
81+
82+
open Multicore_bench
83+
84+
let run_one ~budgetf ~n_domains ~preload () =
85+
let n_ops =
86+
Float.to_int
87+
(Float.of_int (50 * Util.iter_factor) /. Float.log2 (Float.of_int preload))
88+
in
89+
90+
let t = Leftist_heap.create ~lt:(( < ) : int -> int -> bool) in
91+
92+
let n_ops_todo = Atomic.make 0 |> Multicore_magic.copy_as_padded in
93+
94+
let before () =
95+
Atomic.set n_ops_todo n_ops;
96+
while Option.is_some @@ Leftist_heap.delete_min_opt t do
97+
()
98+
done;
99+
let state = Random.State.make_self_init () in
100+
for _ = 1 to preload do
101+
Leftist_heap.insert t (Random.State.bits state)
102+
done
103+
in
104+
let init _ = Random.State.make_self_init () in
105+
let work _ state =
106+
let rec work () =
107+
let n = Util.alloc ~batch:100 n_ops_todo in
108+
if n <> 0 then
109+
let rec loop n =
110+
if 0 < n then
111+
let value = Random.State.bits state in
112+
if value land 1 = 0 then begin
113+
Leftist_heap.insert t value;
114+
loop (n - 1)
115+
end
116+
else begin
117+
Leftist_heap.delete_min_opt t |> ignore;
118+
loop (n - 1)
119+
end
120+
else work ()
121+
in
122+
loop n
123+
in
124+
work ()
125+
in
126+
127+
let config =
128+
Printf.sprintf "%d worker%s, %d preload" n_domains
129+
(if n_domains = 1 then "" else "s")
130+
preload
131+
in
132+
133+
Times.record ~budgetf ~n_domains ~before ~init ~work ()
134+
|> Times.to_thruput_metrics ~n:n_ops ~singular:"operation" ~config
135+
136+
let run_suite ~budgetf =
137+
Util.cross [ 10; 100; 1000 ] [ 1; 2; 4 ]
138+
|> List.concat_map @@ fun (preload, n_domains) ->
139+
run_one ~budgetf ~n_domains ~preload ()

‎bench/main.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ let benchmarks =
33
("Kcas Loc", Bench_loc.run_suite);
44
("Kcas Xt", Bench_xt.run_suite);
55
("Kcas Xt read-only", Bench_xt_ro.run_suite);
6+
("Kcas Xt Leftist_heap (unscalable)", Bench_leftist_heap.run_suite);
67
("Kcas parallel CMP", Bench_parallel_cmp.run_suite);
78
("Kcas_data Accumulator", Bench_accumulator.run_suite);
89
("Kcas_data Dllist", Bench_dllist.run_suite);

0 commit comments

Comments
 (0)