OCaml multicore GC stress test

gcstress.ml

(* GC stress/performance test.
   Uses only core GC features - no finalisers, weak references, etc. *)

type work = F : (int -> 'a) * ('a -> int) -> work

type bintree = Leaf of int | Branch of bintree * bintree
let tree =
  let rec mktree = function
    | 0 -> Leaf 1
    | n -> Branch (mktree (n-1), mktree (n-1)) in
  let rec sum = function
    | Leaf n -> n
    | Branch (a, b) -> sum a + sum b in
  F (mktree, sum)

let sorted_list =
  let rec list len acc = function
    | 0 -> acc
    | n -> list len (((n * 7843723) land (len - 1)) :: acc) (n-1) in
  let rec check acc k = function
    | [] -> acc
    | n :: ns -> check ((n - k) + acc) (k+1) ns in
  F ((fun n -> list (1 lsl n) [] (1 lsl n)), check 0 (-1))

let bit_inc =
  let rec inc i num =
    if i == Array.length num then false
    else match num.(i) with
    | None ->
       num.(i) <- Some i;
       true
    | Some _ ->
       num.(i) <- None;
       inc (i+1) num in
  let rec dec i num =
    if i == Array.length num then false
    else match num.(i) with
    | Some _ ->
       num.(i) <- None;
       true
    | None ->
       num.(i) <- Some i;
       dec (i+1) num in
  let make n =
    let num = Array.make n None in
    while inc 0 num do () done;
    num in
  let consume num =
    let copy = Array.copy num in
    let count = ref 1 in
    ignore (dec 0 copy);
    while dec 0 copy do incr count done;
    !count in
  F (make, consume)

let mutrec_fns =
  let rec fns = function
    | 0 -> fun acc -> acc + 1
    | n ->
       let l = fns (n-1) and r = fns (n-1) in
       let rec f b acc =
         if acc land 0x40 = 0 then
           r acc
         else
           if b then
             l (r acc)
           else
             (* impossible, but makes the functions look recursive *)
             g acc
       and g acc =
         if acc land 0x40 = 0 then
           l (f false acc)
         else
           f true acc
       in g in
  F (fns, fun f -> f 0)

type bigtree = Bigtree of bigtree array
let veb =
  let rec mk = function
    | 0 -> Bigtree [| |]
    | n ->
       let half = n - (n lsr 1) in
       let rootsz = 1 lsl half in
       Bigtree (Array.init rootsz (fun _ -> mk (n - half))) in
  let rec sum = function
    | Bigtree [| |] -> 1
    | Bigtree b -> Array.fold_left sum_acc 0 b
  and sum_acc s b = s + sum b in
  F (mk, sum)

let fns = [| tree; sorted_list; bit_inc; mutrec_fns; veb |]


let grow rand xs =
  let F (create, consume) = fns.(Random.State.int rand (Array.length fns)) in
  let n = Random.State.int rand 15 in
  let x = create n in
  (fun () -> let n' = consume x in assert (1 lsl n = n')) :: xs

let rec shrink rand = function
  | [] -> []
  | x :: xs when Random.State.int rand 100 < 5 ->
     x (); xs
  | x :: xs ->
     x :: shrink rand xs

let rec loop rand xs =
  if List.length xs >= 100 then () else
  loop rand (shrink rand (grow rand xs))

let noop _ _ =
  for i = 1 to 10000000
  do
    Domain.Sync.cpu_relax();
  done

let go f n =
  let rand = Random.State.make [| 42; n |] in
  let tstart = Unix.gettimeofday () in
  f rand [];
  let tend = Unix.gettimeofday () in
  (tend -. tstart) *. 1000.


let run f =
  let _ = Gc.full_major() in
  let ndoms = 3 in
  let med = ndoms / 2 in
  let others = Array.init (ndoms - 1) (fun i -> Domain.spawn (fun () -> go f i)) in
  let mine = go f (ndoms - 1) in
  let par_results =
    Array.concat [[| mine |]; Array.map Domain.join others] in
  Array.sort compare par_results;
  let seq_results = Array.init ndoms (go f) in
  Array.sort compare seq_results;
  let par_mean = Array.fold_left (fun acc e -> acc +. e) 0. par_results /. float_of_int ndoms in
  let seq_mean = Array.fold_left (fun acc e -> acc +. e) 0. seq_results /. float_of_int ndoms in
  Printf.printf "Mean:\npar: %.0fms\nseq: %.0fms\n" par_mean seq_mean;
  Printf.printf "Median:\npar: %.0fms\nseq: %.0fms\n" par_results.(med) seq_results.(med)

let _ =
  Printf.printf "**Control**\n";
  run noop;
  Printf.printf "**Main**\n";
  run loop