open Gc

(* adjustable parameters, should be a functor ? *)
let space_overhead = 100
let gamma = 3.0 (* time in major slice attached to a minor GC  / time for minor GC 
                : should use a real estimation, here just a guess !!! *)
let reactivity = 0.6 (* between 0.5 and 1.0, less or equal than 0.5 is not very reasonable:
                       it is likely to double the minor_heap_size at each major GC, Decrease 
                        if reactivity is not important to you *)
let retraction_coef = 0.9 (* between 0.0 and 1.0. the smaller, the less oscillation
                             in the minor heap size. 0.0: never decrease minor heap *)
let debug = ref 1 (* between 0 and 4, 2 and above is for debugging only *)
let max_minor_heap_size = 1 lsl 25 (* the names is clear, 
                                      rounded to the power of 2 below *) 

let major_heap_increment_ratio = 0.5 (* proportional heap increment ratio *)

(* End of tuning constants *)

(* Justification:
We use a model saying that the time in each GC slice is 

T = K * (m + gamma * r * m * f) where

m = minor heap size (goes away in O())
gamma = define above
r = ratio of promoted word at each minor cycle
f = (space_overhead + 100) / space_overhead used as an estimation
    of free space in major heap after collection
K a time constant

in the sum abobe: 
- K * m is the time in the minor GC
- K * gamma * r * m * f is the time in the major GC slice for each minor GC

If gamma * f is more than 1 (which is likely), it is easy to see that 
increasing m, if it decreases r enough, will both increase overall speed and
time is a GC slice, increasing therefore both speed and reactivity.

More precisely, the model says that this is OK to double the size of the 
minor heap when 1 + gamma * f * r > 2*(1 + gamma * f * r') where r is the ratio 
associated to m and r' is the ratio associated to 2*m.

The code below keeps and update a table of ponderated average value of 
1 + gamma * f * r for all used heap size and tries to make sensible decision
looking at it.
*)

let param = get ()
let _ = set { param with space_overhead = space_overhead }

let main_coef = (* gamma * f *)
  gamma *.
  (float) (space_overhead + 100) /.(float) (space_overhead)

let ratio_double = 1.0 /. reactivity 
let ratio_half = ratio_double /. retraction_coef

(* tranlated log2 of the minor heap size, used at initialization only *)
let index m = 
  let rec fn i m = 
    if m <= 32768 then i else fn (i + 1) (m / 2)
  in
  fn 0 m

(* a table to store 1 + gamma * f * r for each heap size *)
let max_index = index max_minor_heap_size
let model_table = Array.create (max_index+1) None

let old_heap_words = ref (quick_stat ()).heap_words
let old_promoted_words = ref 0.0
let old_minor_collections = ref 0
let minor_heap_size = ref param.minor_heap_size 
let minor_heap_index_size = ref (index param.minor_heap_size)

let _ = create_alarm (fun () -> 
  let s = quick_stat () in

  (* tweak minor heap size *)
  let promoted_words = s.promoted_words in
  let minor_collections = s.minor_collections in
  let delta_promoted_words = promoted_words -. !old_promoted_words in
  let delta_minor_collections = minor_collections - !old_minor_collections in
  old_promoted_words := promoted_words;
  old_minor_collections := minor_collections;
  let ratio = delta_promoted_words /. (float) delta_minor_collections 
                                   /. (float) !minor_heap_size 
  in
  let new_model = 1.0 +. gamma *. ratio in
  let i = !minor_heap_index_size in
  let mean_model = match model_table.(i) with None -> new_model |
    Some r -> (r +. new_model) /. 2.0
  in
  model_table.(i) <- Some mean_model;
  if !debug > 2 then begin
    let i = ref 0 in
    while !i <= max_index && model_table.(!i) <> None do
      match model_table.(!i) with
      | None -> assert false
      | Some r ->  Printf.fprintf stderr "model(%d) = %f - " !i r; incr i
    done;
    Printf.fprintf stderr "\n"; flush stderr;
  end;

  let lower_double, lower_half =
    if i <= 0 then true, false else 
      match model_table.(i-1) with
      | None -> false, true
      | Some r -> let x = 2.0 *. mean_model /. r in
		  (i < max_index) && x < ratio_double, x > ratio_half
  in
  let upper_double, upper_half =
    if i >= max_index then false, true else 
      match model_table.(i+1) with 
      | None -> true, false
      | Some r -> let x = 2.0 *. r /. mean_model in 
		  x < ratio_double, (i > 0) && x > ratio_half
  in
  if !debug > 2 then begin
   Printf.fprintf stderr "ld = %b, lh = %b, ud = %b, uh = %b\n" 
     lower_double lower_half upper_double upper_half;
     flush stderr;
  end;
  if (lower_half && not upper_double) || (upper_half && not lower_double) then begin
    minor_heap_size := !minor_heap_size / 2;
    minor_heap_index_size := i - 1;
    if !debug > 0 then begin
      Printf.fprintf stderr "MHS HALFED <- %d (model %f)\n" !minor_heap_size mean_model;
      flush stderr;
    end;
    set { (get ()) with minor_heap_size = !minor_heap_size }
  end else
  if (lower_double && not upper_half) || (upper_double && not lower_half)  then begin
    minor_heap_size := !minor_heap_size * 2;
    minor_heap_index_size := i + 1;
    if !debug > 0 then begin
      Printf.fprintf stderr "MHS DOUBLED <- %d (model %f)\n" !minor_heap_size mean_model;
      flush stderr; 
    end;
    set { (get ()) with minor_heap_size = !minor_heap_size }
  end else
    if !debug > 1 then begin
      Printf.fprintf stderr "MHS UNCHANGED (model %f) mean_model\n" mean_model;
      flush stderr; 
    end;

  (* tweak major heap increment to be a fraction of major heap size *)
  if !old_heap_words <> s.heap_words then begin
    old_heap_words := s.heap_words; 
    let major_heap_increment = max (124*1024) (int_of_float (float s.heap_words *. major_heap_increment_ratio) )in
(*  Printf.fprintf stderr "MHI <- %d \n" major_heap_increment;
    flush stderr; *)
    set { (get ()) with major_heap_increment = major_heap_increment; }
  end;
)