external alloc_dependent_memory : (int [@untaged]) -> unit = "abort" "caml_alloc_dependent_memory"
external free_dependent_memory : (int [@untaged]) -> unit = "abort" "caml_free_dependent_memory"

let printf = Printf.printf

let by_words = ref 0
let word_size = Sys.word_size / 8 (* word size in bytes *)

type 'a data = Bytes of bytes
             | BigArr of 'a

let dealloc words () =
  by_words := !by_words - words


let alloc_bytes size =
  let by = Bytes.create size in
  let words = size / word_size in
  by_words := !by_words + words;
  Gc.finalise_last (dealloc words) by;
  Bytes by

let minor_heap_size = Gc.((get ()).minor_heap_size)
let ba_words = ref 0
let ba_allocated = ref 0
let alloc_ba size =
  let ba = Bigarray.(Array1.create char c_layout size) in
  let words = size / word_size in
  ba_words := !ba_words + words;
  alloc_dependent_memory size;
  Gc.finalise_last (fun () ->
      free_dependent_memory size;
      ba_words := !ba_words - words) ba;

  ba_allocated := !ba_words + words;
  if !ba_allocated > minor_heap_size then begin
    ba_allocated := 0;
    ignore(Gc.major_slice (-1));
  end;
  BigArr ba

let kmgt size =
  let size = size * word_size in
  let sprintf = Printf.sprintf in
  if size < 512 * 1024 then
    sprintf "%.2fk" (float size /. 0x1.0p10)
  else if size < 512 * 1024 * 1024 then
    sprintf "%.2fk" (float size /. 0x1.0p20)
  else if size < 512 * 1024 * 1024 * 1024 then
    sprintf "%.2fg" (float size /. 0x1.0p30)
  else
    sprintf "%.2ft" (float size /. 0x1.0p40)

let statm () =
  let open Scanf in
  let fd = Scanning.from_file "/proc/self/statm" in
  let result = bscanf fd "%i %i %i"
                 (fun size resident shared -> (size, resident, shared) ) in
  Scanning.close_in fd;
  result

let gc_stat =
  let f () =
    while true do
      let stat = Gc.stat () in
      let vss, _, _ = statm () in
      printf "% 9s vss; % 9s heap; % 9s live; % 9s ba; % 9s by\n%!"
        (kmgt (vss * 4096 / word_size)) (kmgt stat.heap_words)
        (kmgt stat.live_words) (kmgt !ba_words) (kmgt !by_words);
      flush stdout;
      Unix.sleepf 0.5;
    done
  in
  Thread.create f ()

let rec trigger _ =
  printf "***\n%!";
  Gc.major ();
  Unix.alarm 2 |> ignore;
  Sys.(set_signal sigalrm (Signal_handle trigger))


let _ =
  Sys.(set_signal sigalrm (Signal_handle trigger));
  Unix.alarm 2 |> ignore;
  let q = Queue.create () in
  while true do
    let data1 = alloc_ba (4096 * 1024) in
    Queue.push data1 q;
    let data2 = alloc_bytes (4096 * 1024) in
    Queue.push data2 q;
    let _data1 = alloc_ba (4096 * 1024) in
    let _data2 = alloc_bytes (4096 * 1024) in
    while (Queue.length q > 1000) do
      ignore(Queue.pop q);
    done;
    Thread.yield ();
  done