90 lines
4.0 KiB
OCaml
90 lines
4.0 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* 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()
|