From b1a8e22ac31db8939e46f1d56eeefebdcea2dd96 Mon Sep 17 00:00:00 2001
From: Sebastian Ullrich <sebasti@nullri.ch>
Date: Fri, 17 May 2019 13:24:10 +0200
Subject: [PATCH] feat(tests/playground/rbmap_checkpoint): add rbmap_shared
 benchmark (rbmap_checkpoint with freq=1)

---
 tests/playground/Makefile            | 10 ++--
 tests/playground/rbmap_checkpoint.ml | 72 ++++++++++++++++++++++++++++
 2 files changed, 79 insertions(+), 3 deletions(-)
 create mode 100644 tests/playground/rbmap_checkpoint.ml

diff --git a/tests/playground/Makefile b/tests/playground/Makefile
index 141a85dcc5..0c338e98cd 100644
--- a/tests/playground/Makefile
+++ b/tests/playground/Makefile
@@ -1,7 +1,7 @@
 ## CONFIG
 
 BENCH=ulimit -s unlimited && bench
-CROSS_BENCHES = binarytrees deriv expr_const_folding rbmap
+CROSS_BENCHES = binarytrees deriv expr_const_folding rbmap rbmap_shared
 
 # basic version usable without Nix
 #CROSS_CATS = .lean .perf.lean .hs .gc.hs .perf.hs .llvm.hs .ml .gc.ml .perf.ml
@@ -23,8 +23,9 @@ OCAML ?= ocamlopt.opt
 
 all: report_cross.csv
 
-# make gets confused by the .cpp files otherwise
-%.lean: ;
+# disable some built-in rules
+%.lean:
+%.out: %
 
 %.lean.cpp: %.lean
 	$(LEAN_BIN)/lean --cpp=$@ $<
@@ -66,6 +67,9 @@ bench/binarytrees.%.bench: BENCH_PARAMS = 21
 
 bench/rbmap.%.bench: BENCH_PARAMS = 7000000
 
+rbmap_shared.%.out: rbmap_checkpoint.%.out; ln -f $< $@
+bench/rbmap_shared.%.bench: BENCH_PARAMS = 500000 1
+
 bench/%gc.hs.bench: %hs.out | bench
 	./$< +RTS -t --machine-readable -RTS $(BENCH_PARAMS) 2> $@
 
diff --git a/tests/playground/rbmap_checkpoint.ml b/tests/playground/rbmap_checkpoint.ml
new file mode 100644
index 0000000000..ff12588f81
--- /dev/null
+++ b/tests/playground/rbmap_checkpoint.ml
@@ -0,0 +1,72 @@
+type color =
+| Red
+| Black;;
+
+type node =
+| Leaf
+| Node of color * node * int * bool * node;;
+
+let balance1 kv vv t n =
+match n with
+| Node (c, Node (Red, l, kx, vx, r1), ky, vy, r2) -> Node (Red, Node (Black, l, kx, vx, r1), ky, vy, Node (Black, r2, kv, vv, t))
+| Node (c, l1, ky, vy, Node (Red, l2, kx, vx, r)) -> Node (Red, Node (Black, l1, ky, vy, l2), kx, vx, Node (Black, r, kv, vv, t))
+| Node (c, l,  ky, vy, r)                         -> Node (Black, Node (Red, l, ky, vy, r), kv, vv, t)
+| n -> Leaf;;
+
+let balance2 t kv vv n =
+match n with
+| Node (_, Node (Red, l, kx1, vx1, r1), ky, vy, r2)  -> Node (Red, Node (Black, t, kv, vv, l), kx1, vx1, Node (Black, r1, ky, vy, r2))
+| Node (_, l1, ky, vy, Node (Red, l2, kx2, vx2, r2)) -> Node (Red, Node (Black, t, kv, vv, l1), ky, vy, Node (Black, l2, kx2, vx2, r2))
+| Node (_, l, ky, vy, r)                             -> Node (Black, t, kv, vv, Node (Red, l, ky, vy, r))
+| n   -> Leaf;;
+
+let is_red t =
+match t with
+| Node (Red, _, _, _, _) -> true
+| _ -> false;;
+
+let rec ins t kx vx =
+match t with
+| Leaf -> Node (Red, Leaf, kx, vx, Leaf)
+| Node (Red, a, ky, vy, b) ->
+  if kx < ky then Node (Red, ins a kx vx, ky, vy, b)
+  else if ky = kx then Node (Red, a, kx, vx, b)
+  else Node (Red, a, ky, vy, ins b kx vx)
+| Node (Black, a, ky, vy, b) ->
+  if kx < ky then
+    (if is_red a then balance1 ky vy b (ins a kx vx)
+      else Node (Black, (ins a kx vx), ky, vy, b))
+  else if kx = ky then Node (Black, a, kx, vx, b)
+  else if is_red b then balance2 a ky vy (ins b kx vx)
+       else Node (Black, a, ky, vy, (ins b kx vx));;
+
+let set_black n =
+match n with
+| Node (_, l, k, v, r) -> Node (Black, l, k, v, r)
+| e                    -> e;;
+
+let insert t k v =
+if is_red t then set_black (ins t k v)
+else ins t k v;;
+
+let rec fold f n d =
+match n with
+| Leaf -> d
+| Node(_, l, k, v, r) -> fold f r (f k v (fold f l d));;
+
+let rec mk_map_aux freq n m r =
+if n = 0 then m::r
+else let n = n-1 in
+     let m = insert m n (n mod 10 == 0) in
+     let r = if n mod freq == 0 then m::r else r in
+     mk_map_aux freq n m r;;
+
+let mk_map n freq = mk_map_aux freq n Leaf [];;
+
+let main n freq =
+let m = mk_map n freq in
+let v = fold (fun k v r -> if v then r + 1 else r) (List.hd m) 0 in
+Printf.printf "%8d\n" v;
+v;;
+
+main (int_of_string Sys.argv.(1)) (int_of_string Sys.argv.(2));;