lean4/tests/bench/binarytrees5_multicore.ml

(* https://github.com/ocaml-bench/sandmark/blob/c668eb05aebb1dc9f57f322399bea7182640518c/benchmarks/multicore-numerical/binarytrees5_multicore.ml *)
module T = Domainslib.Task

let num_domains = try int_of_string Sys.argv.(1) with _ -> 1
let max_depth = try int_of_string Sys.argv.(2) with _ -> 10

type 'a tree = Empty | Node of 'a tree * 'a tree

let rec make d =
(* if d = 0 then Empty *)
  if d = 0 then Node(Empty, Empty)
  else let d = d - 1 in Node(make d, make d)

let rec check t =
  match t with
  | Empty -> 0
  | Node(l, r) -> 1 + check l + check r

let min_depth = 4
let max_depth = max (min_depth + 2) max_depth
let stretch_depth = max_depth + 1

let () =
  (* Gc.set { (Gc.get()) with Gc.minor_heap_size = 1024 * 1024; max_overhead = -1; }; *)
  let _ = check (make stretch_depth) in
  ()
  (* Printf.printf "stretch tree of depth %i\t check: %i\n" stretch_depth c *)

let long_lived_tree = make max_depth

let values = Array.make num_domains 0

let calculate d st en ind =
  (* Printf.printf "st = %d en = %d\n" st en; *)
  let c = ref 0 in
  for _ = st to en do
  c := !c + check (make d)
  done;
  (* Printf.printf "ind = %d\n" ind; *)
  values.(ind) <- !c

let loop_depths d pool =
  for i = 0 to  ((max_depth - d) / 2 + 1) - 1 do
    let d = d + i * 2 in
    let niter = 1 lsl (max_depth - d + min_depth) in
    let rec loop acc i num_domains =
      if i = num_domains then begin
        List.rev acc |> List.iter (fun pr -> T.await pool pr)
      end else begin
        loop
          ((T.async pool (fun _ ->
            calculate d (i * niter / num_domains) (((i + 1) * niter / num_domains) - 1) i)) :: acc) 
          (i + 1)
          num_domains
        end in

    loop [] 0 num_domains;
    let _ = Array.fold_left (+) 0 values in
    ()
    (* Printf.printf "%i\t trees of depth %i\t check: %i\n" niter d sum *)
  done

let () =
  let pool = T.setup_pool ~num_domains:(num_domains - 1) () in
  T.run pool (fun _ -> loop_depths min_depth pool);
  let _ = max_depth in
  let _ = (check long_lived_tree) in
  T.teardown_pool pool