(***********************************************************************)

(*                                                                     *)

(*                 MLTk, Tcl/Tk interface of OCaml                     *)

(*                                                                     *)

(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)

(*               projet Cristal, INRIA Rocquencourt                    *)

(*            Jacques Garrigue, Kyoto University RIMS                  *)

(*                                                                     *)

(*  Copyright 2002 Institut National de Recherche en Informatique et   *)

(*  en Automatique and Kyoto University.  All rights reserved.         *)

(*  This file is distributed under the terms of the GNU Library        *)

(*  General Public License, with the special exception on linking      *)

(*  described in file LICENSE found in the OCaml source tree.          *)

(*                                                                     *)

(***********************************************************************)

(* Memory gauge *)

open Camltk

open Gc

let inited = ref None

let w = ref 300

let delay = ref 5 (* in seconds *)

let wordsize = (* officially approved *)

  if 1 lsl 31 = 0 then 4 else 8

let init () =

  let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in

  let name = Camltk.appname_get () in

    Wm.title_set top (name ^ " Memory Gauge");

    Wm.withdraw top;

    inited := Some top;

    (* this should be executed before the internal "all" binding *)

    bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None)));

    let fminors = Frame.create top [] in

      let lminors = Label.create fminors [Text "Minor collections"]

      and vminors = Label.create fminors [] in

      pack [lminors][Side Side_Left];

      pack [vminors][Side Side_Right; Fill Fill_X; Expand true];

    let fmajors = Frame.create top [] in

      let lmajors = Label.create fmajors [Text "Major collections"]

      and vmajors = Label.create fmajors [] in

      pack [lmajors][Side Side_Left];

      pack [vmajors][Side Side_Right; Fill Fill_X; Expand true];

    let fcompacts = Frame.create top [] in

      let lcompacts = Label.create fcompacts [Text "Compactions"]

      and vcompacts = Label.create fcompacts [] in

      pack [lcompacts][Side Side_Left];

      pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true];

    let fsize = Frame.create top [] in

      let lsize = Label.create fsize [Text "Heap size (bytes)"]

      and vsize = Label.create fsize [] in

      pack [lsize][Side Side_Left];

      pack [vsize][Side Side_Right; Fill Fill_X; Expand true];

    let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in

    let flive = Frame.create fheap [Background Red]

    and ffree = Frame.create fheap [Background Green]

    and fdead = Frame.create fheap [Background Black] in

      pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X];

    let display () =

      let st = Gc.stat() in

       Label.configure vminors [Text (string_of_int st.minor_collections)];

       Label.configure vmajors [Text (string_of_int st.major_collections)];

       Label.configure vcompacts [Text (string_of_int st.compactions)];

       Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))];

       let liver = (float st.live_words) /. (float st.heap_words)

       and freer = (float st.free_words) /. (float st.heap_words) in

       Place.configure flive [X (Pixels 0); Y (Pixels 0);

                              RelWidth liver; RelHeight 1.0];

       Place.configure ffree [RelX liver; Y (Pixels 0);

                              RelWidth freer; RelHeight 1.0];

       Place.configure fdead [RelX (liver +. freer); Y (Pixels 0);

                              RelWidth (1.0 -. freer -. liver); RelHeight 1.0]

    in

    let rec tim () =

      if Winfo.exists top then begin

        display();

        Timer.set (!delay * 1000) tim

      end

    in

    tim()

let rec f () =

  match !inited with

    Some w -> Wm.deiconify w

  | None -> init (); f()