let do_timing = 
  try ignore (Sys.getenv "TIMING") ; true
  with Not_found -> false

external set_gc_timing : bool -> unit  = "caml_set_gc_timing" "noalloc"
external get_gc_time   : unit -> float = "caml_get_gc_time"
external get_tick      : unit -> float = "caml_get_tick"

let bpw = float_of_int (Sys.word_size / 8)

let gc_alloc_mem () =
  let s = Gc.quick_stat () in
  let mi = s.Gc.minor_words
  and pr = s.Gc.promoted_words
  and ma = s.Gc.major_words in
  (mi -. pr +. ma) *. bpw,
  s.Gc.heap_words,
  s.Gc.minor_collections, s.Gc.major_collections, s.Gc.compactions







type chrono = {
    mutable tick         : float ;
    mutable gc_tick      : float ;
    mutable gc_alloc     : float ;
    mutable gc_heap      : int ;
    mutable gc_collec_mi : int ;
    mutable gc_collec_ma : int ;
    mutable gc_collec_co : int ;
  }

let make_chrono () = {
  tick         = 0. ;
  gc_tick      = 0. ;
  gc_alloc     = 0. ;
  gc_heap      = 0 ;
  gc_collec_mi = 0 ;
  gc_collec_ma = 0 ;
  gc_collec_co = 0 ;
}


let chrono_start c =
  if do_timing then begin
    c.tick    <- get_tick () ;
    c.gc_tick <- get_gc_time () ;
    let mem, _, mi, ma, co = gc_alloc_mem () in
    c.gc_alloc     <- mem ;
    c.gc_collec_mi <- mi ;
    c.gc_collec_ma <- ma ;
    c.gc_collec_co <- co
  end

let chrono_stop c =
  if do_timing then begin
    c.tick    <- get_tick () -. c.tick ;
    c.gc_tick <- get_gc_time () -. c.gc_tick ;
    let n_mem, h, n_mi, n_ma, n_co = gc_alloc_mem () in
    c.gc_alloc     <- n_mem -. c.gc_alloc ;
    c.gc_heap      <- h ;
    c.gc_collec_mi <- n_mi - c.gc_collec_mi ;
    c.gc_collec_ma <- n_ma - c.gc_collec_ma ;  
    c.gc_collec_co <- n_co - c.gc_collec_co ;
  end

let chrono_accum c1 c2 =
  c1.tick         <- c1.tick +. c2.tick ;
  c1.gc_tick      <- c1.gc_tick +. c2.gc_tick ;
  c1.gc_alloc     <- c1.gc_alloc +. c2.gc_alloc ;
  c1.gc_heap      <- max c1.gc_heap c2.gc_heap ;
  c1.gc_collec_mi <- c1.gc_collec_mi + c2.gc_collec_mi ;
  c1.gc_collec_ma <- c1.gc_collec_ma + c2.gc_collec_ma ;
  c1.gc_collec_co <- c1.gc_collec_co + c2.gc_collec_co






let string_of_time t =
  if t = 0.        then
    "0ms"
  else if t < 1e-3 then
    "<1ms"
  else if t < 1.   then
    Printf.sprintf "%.3fs" t
  else let m = floor (t /. 60.) in
  if m < 1.        then 
    Printf.sprintf "%.2fs" t
  else let s = t -. m *. 60. in
  Printf.sprintf "%.0fm %.2fs" m s

let string_of_mem b =
  let b = int_of_float b in
  let g, b = 
    let v = b / (1 lsl 30) in
    if v > 0 
    then string_of_int v ^ "G ", b - v * (1 lsl 30)
    else "", b in
  let m, b =
    let v = b / (1 lsl 20) in
    if v > 0 
    then g ^ string_of_int v ^ "M ", b - v * (1 lsl 20)
    else g, b in
  let k, b =
    let v = b / (1 lsl 10) in
    if v > 0 
    then m ^ string_of_int v ^ "K ", b - v * (1 lsl 10)
    else m, b in
  let b = 
    if b > 0
    then k ^ string_of_int b 
    else k in
  b

let string_of_memw w =
  string_of_mem (float_of_int w *. bpw)

let string_of_coll c =
  let mi = c.gc_collec_mi
  and ma = c.gc_collec_ma
  and co = c.gc_collec_co in
  let mi = if mi > 0 then string_of_int mi ^ "m " else "" in
  let ma = if ma > 0 then string_of_int ma ^ "M " else "" in
  let co = if co > 0 then string_of_int co ^ "C"  else "" in
  mi ^ ma ^ co


let pp_chrono msg c =
  let tp  = c.tick -. c.gc_tick 
  and tg  = c.gc_tick
  and mem = c.gc_alloc in
  Printf.sprintf
    "%-15s: %8s (GC %-9s, alloc %-20s, heap %-15s, collec %s)"
    msg
    (string_of_time tp) (string_of_time tg)
    (string_of_mem mem) (string_of_memw c.gc_heap)
    (string_of_coll c)

let pp_time msg c =
  if do_timing 
  then prerr_endline (pp_chrono msg c)



let main = 
  make_chrono ()

let start () = 
  chrono_start main

let stop msg =
  chrono_stop main ;
  pp_time msg main


let _ = 
  set_gc_timing do_timing ;
  if do_timing
  then
    at_exit (fun () ->
      let s = Gc.quick_stat () in
      prerr_endline
        ("top_heap_words = " ^ string_of_memw s.Gc.top_heap_words))