src/memory.ml

   1 (******************************************************************************)
   2 (*  SXSI : XPath evaluator                                                    *)
   3 (*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
   4 (*  Copyright NICTA 2008                                                      *)
   5 (*  Distributed under the terms of the LGPL (see LICENCE)                     *)
   6 (******************************************************************************)
   7
   8 let globals = Hashtbl.create 107
   9 let cpt = ref 0
  10
  11 let register v str =
  12   let _cpt = !cpt in
  13   let f = (* This function must not take v as argument, otherwise
  14              v won't be garbage collected *)
  15     fun _ -> Hashtbl.remove globals _cpt
  16   in
  17     Hashtbl.add globals _cpt str;
  18     incr cpt;
  19     Gc.finalise f v
  20 ;;
  21
  22 let schedule_stats =
  23   let first = ref true in
  24     function () -> if !first
  25     then
  26       let show_leaked_values () =
  27         Printf.eprintf "Memory debugging requested :\n%!";
  28         Printf.eprintf "Triggering major collection :%!";
  29         Gc.full_major();
  30         Printf.eprintf " ok\n%!";
  31         Printf.eprintf "Triggering memory compaction :%!";
  32         Gc.compact();
  33         Printf.eprintf " ok\n%!";
  34         let i = Hashtbl.length globals in
  35           Printf.eprintf "%i object%s leaked\n%!" i (if i < 2 then "" else "s");
  36           Hashtbl.iter (fun key msg ->
  37                           Printf.printf "Value %i, registered at %s has not been collected\n" key msg) globals
  38       in at_exit show_leaked_values; first := false
  39     else ()
  40