overhead.ml

(* see sizeclasses.h *)
let wfrag_whsize_small = [|
 (*  0:*) 255; 0; 0; 0; 0;
  (*  5:*) 0; 0; 0; 0; 1;
  (* 10:*) 0; 1; 0; 1; 0;
  (* 15:*) 1; 0; 0; 1; 0;
  (* 20:*) 2; 1; 0; 2; 1;
  (* 25:*) 0; 2; 1; 0; 3;
  (* 30:*) 2; 1; 0; 0; 3;
  (* 35:*) 2; 1; 0; 4; 3;
  (* 40:*) 2; 1; 0; 4; 3;
  (* 45:*) 2; 1; 0; 5; 4;
  (* 50:*) 3; 2; 1; 0; 5;
  (* 55:*) 4; 3; 2; 1; 0;
  (* 60:*) 5; 4; 3; 2; 1;
  (* 65:*) 0; 7; 6; 5; 4;
  (* 70:*) 3; 2; 1; 0; 7;
  (* 75:*) 6; 5; 4; 3; 2;
  (* 80:*) 1; 0; 7; 6; 5;
  (* 85:*) 4; 3; 2; 1; 0;
  (* 90:*) 9; 8; 7; 6; 5;
  (* 95:*) 4; 3; 2; 1; 0;
  (*100:*) 8; 7; 6; 5; 4;
  (*105:*) 3; 2; 1; 0; 9;
  (*110:*) 8; 7; 6; 5; 4;
  (*115:*) 3; 2; 1; 0; 9;
  (*120:*) 8; 7; 6; 5; 4;
  (*125:*) 3; 2; 1; 0 |]


let pool_wsize = 4096
let pool_header_wsize = 4

let large_alloc_header_sz = 3

let max_pool = Int.min (pool_wsize - pool_header_wsize - large_alloc_header_sz) 512

let wfrag_whsize =
  Array.init (max_pool-1) @@ fun i ->
  if i < Array.length wfrag_whsize_small then wfrag_whsize_small.(i)
  else large_alloc_header_sz - 1

let padding_sizes =
  let ar = Array.make (2*Array.length wfrag_whsize) 0 in
    let () = wfrag_whsize |> Array.iteri @@ fun size wfrag ->
    let target_padding = size + wfrag in
    (* to achieve an allocation + fragment size = target_padding,
      you need to allocate [size] words *)
    ar.(target_padding) <- size;
  in
  for i = 1 to Array.length ar-1 do
    (* if we can't achieve a padding exactly then approximate *)
    if ar.(i) = 0 then
      ar.(i) <- ar.(i-1)
  done;
  ar


type size_info = {
  item_size: int;
  items_per_pool: int;
  total_pool_overhead: int;
  item0_size: int
}

(* decreasing order of total_pool_overhead *)
let compare_size_info a b =
  Int.compare b.total_pool_overhead a.total_pool_overhead

let sizes =
  wfrag_whsize |> Array.mapi @@ fun item_size wfrag ->
  if item_size = 0 then
    { item_size = 0; items_per_pool = 0; total_pool_overhead = -1; item0_size = 0 }
  else
  let slot_size = item_size + wfrag in
  let items_per_pool =
    (pool_wsize - pool_header_wsize) / slot_size
  in
  if item_size < Array.length wfrag_whsize_small then
    let total_pool_overhead = pool_wsize - items_per_pool * item_size in
    { item_size; items_per_pool; total_pool_overhead; item0_size = item_size }
  else
    let padding = pool_wsize - pool_header_wsize - items_per_pool * slot_size in
    let padding = padding_sizes.(padding) in
    let total_pool_overhead = items_per_pool * wfrag + wfrag_whsize.(padding) in
    { item_size; items_per_pool = (items_per_pool+1); total_pool_overhead; item0_size = padding }

let qstat () =
  if Sys.ocaml_release.major > 4 then Gc.quick_stat () else Gc.stat ()

let live_allocated q = q.Gc.live_words + q.fragments

let measure_used_words f =
  Gc.compact ();
  let q0 = qstat () in
  let r = f () in
  Gc.compact ();
  let q1 = qstat () in
  let _alive = Sys.opaque_identity r in
  live_allocated q1 - live_allocated q0

let alloc_pool a_i  t =
        if t.item_size > 0 then
        for j = 0 to t.items_per_pool - 1 do
          let item_size = if j = 0 then t.item0_size else t.item_size in
          a_i.(j) <- if item_size < 2 then [||] else Array.make (item_size - 1) 0
        done

let offset = measure_used_words Fun.id

let ctrl = Gc.get ()

let pools = 10 * ctrl.minor_heap_size / pool_wsize

let a = Array.make_matrix pools (pool_wsize/2) [||]

(* 
let reset () =
  for i = 1 to 10 do
    Array.fill a.(i) 0 (Array.length a.(0)) [||];
  done

let check_size t =
  if t.item_size > 1 then begin
  let f () =
    for i = 1 to 10 do
      alloc_pool a.(i) t;
    done
  in
  let actual = (measure_used_words f - offset)/10 in
  let expected = pool_wsize - pool_header_wsize in
  if actual <> expected then begin
    let wfrag = wfrag_whsize.(t.item_size) in
    let slot_size = t.item_size + wfrag in
    let wfrag0 = wfrag_whsize.(t.item0_size) in
    let slot0_size = t.item0_size + wfrag0 in
    let sum = slot_size * (t.items_per_pool - 1) + slot0_size in
    Printf.eprintf "item_size=%d, wfrag=%d, slot_size=%d, item0_size=%d, wfrag0=%d, slot0_size=%d, items_per_pool=%d, sum=%d, used_words=%d, delta=%d\n%!" t.item_size wfrag slot_size t.item0_size wfrag0 slot0_size t.items_per_pool sum actual (actual - expected)
  end
  end

  let () = sizes |> Array.iter check_size; reset ()
*)

let () = Array.sort compare_size_info sizes

let max_overhead_exact = ref 0


let pp_kib ppf words =
  Format.fprintf ppf "%d KiB" (words * Sys.word_size / 8 / 1024)

let q0 =
  Gc.full_major ();
  Gc.quick_stat ()

let run_size i t =
    if t.item_size >= 2 then begin
      for i = 0 to Array.length a - 1 do
        Array.fill a.(i) 0 (Array.length a.(i) - 1) [||]
      done;

      for i = 0 to Array.length a - 1 do
        alloc_pool a.(i) t
      done;

      Gc.minor ();
      let q = Gc.quick_stat () in

      let live_words = q0.live_words + Obj.reachable_words (Obj.repr a) in
      let actual_overhead = 100 * (q.Gc.top_heap_words - live_words) / live_words in
      max_overhead_exact := Int.max !max_overhead_exact actual_overhead;
    
    end

let () =
  sizes |> Array.iteri run_size;
  Gc.full_major ();
  let q = Gc.quick_stat () in
  Format.printf "top_heap: %a@." pp_kib q.Gc.top_heap_words;
  Format.printf "space_overhead ((top_heap_words - exact_live)/exact live): %d%%@." !max_overhead_exact;
  Format.printf "space_overhead (configured): %d%%@." ctrl.space_overhead