l4/pkg/ocaml/contrib/otherlibs/labltk/frx/frx_mem.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16 (* Memory gauge *)
  17 open Camltk
  18 open Gc
  19
  20 let inited = ref None
  21 let w = ref 300
  22 let delay = ref 5 (* in seconds *)
  23 let wordsize = (* officially approved *)
  24   if 1 lsl 31 = 0 then 4 else 8
  25
  26
  27 let init () =
  28   let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in
  29   let name = Camltk.appname_get () in
  30     Wm.title_set top (name ^ " Memory Gauge");
  31     Wm.withdraw top;
  32     inited := Some top;
  33     (* this should be executed before the internal "all" binding *)
  34     bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None)));
  35     let fminors = Frame.create top [] in
  36       let lminors = Label.create fminors [Text "Minor collections"]
  37       and vminors = Label.create fminors [] in
  38       pack [lminors][Side Side_Left];
  39       pack [vminors][Side Side_Right; Fill Fill_X; Expand true];
  40     let fmajors = Frame.create top [] in
  41       let lmajors = Label.create fmajors [Text "Major collections"]
  42       and vmajors = Label.create fmajors [] in
  43       pack [lmajors][Side Side_Left];
  44       pack [vmajors][Side Side_Right; Fill Fill_X; Expand true];
  45     let fcompacts = Frame.create top [] in
  46       let lcompacts = Label.create fcompacts [Text "Compactions"]
  47       and vcompacts = Label.create fcompacts [] in
  48       pack [lcompacts][Side Side_Left];
  49       pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true];
  50     let fsize = Frame.create top [] in
  51       let lsize = Label.create fsize [Text "Heap size (bytes)"]
  52       and vsize = Label.create fsize [] in
  53       pack [lsize][Side Side_Left];
  54       pack [vsize][Side Side_Right; Fill Fill_X; Expand true];
  55     let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in
  56     let flive = Frame.create fheap [Background Red]
  57     and ffree = Frame.create fheap [Background Green]
  58     and fdead = Frame.create fheap [Background Black] in
  59       pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X];
  60
  61     let display () =
  62       let st = Gc.stat() in
  63        Label.configure vminors [Text (string_of_int st.minor_collections)];
  64        Label.configure vmajors [Text (string_of_int st.major_collections)];
  65        Label.configure vcompacts [Text (string_of_int st.compactions)];
  66        Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))];
  67        let liver = (float st.live_words) /. (float st.heap_words)
  68        and freer = (float st.free_words) /. (float st.heap_words) in
  69        Place.configure flive [X (Pixels 0); Y (Pixels 0);
  70                               RelWidth liver; RelHeight 1.0];
  71        Place.configure ffree [RelX liver; Y (Pixels 0);
  72                               RelWidth freer; RelHeight 1.0];
  73        Place.configure fdead [RelX (liver +. freer); Y (Pixels 0);
  74                               RelWidth (1.0 -. freer -. liver); RelHeight 1.0]
  75
  76     in
  77     let rec tim () =
  78       if Winfo.exists top then begin
  79         display();
  80         Timer.set (!delay * 1000) tim
  81       end
  82     in
  83     tim()
  84
  85
  86 let rec f () =
  87   match !inited with
  88     Some w -> Wm.deiconify w
  89   | None -> init (); f()