Libguestfs - Aug 2015 - [PATCH] handle --debug-gc universally via at_exit hook

Several tools handle --debug-gc command-line option, by explicitly
forcing GC on every exit path.  This is tedious and prone to forgetting
some of the exit paths.

Instead, add a generic handler for --debug-gc, which installs an at_exit
hook to do the GC consistency check, and which can be called right in
the command-line parser.  Also adjust all users of --debug-gc to use
that handler.

Signed-off-by: Roman Kagan <rkagan@virtuozzo.com>
---
 customize/customize_main.ml |  9 ++-------
 mllib/common_utils.ml       |  4 ++++
 mllib/common_utils.mli      |  3 +++
 resize/resize.ml            | 13 ++++---------
 sparsify/cmdline.ml         |  6 ++----
 sparsify/sparsify.ml        |  7 ++-----
 sysprep/main.ml             | 13 ++++---------
 v2v/cmdline.ml              |  6 ++----
 v2v/v2v.ml                  |  9 ++-------
 9 files changed, 25 insertions(+), 45 deletions(-)

diff --git a/customize/customize_main.ml b/customize/customize_main.ml
index fa55c90..03c97e4 100644
--- a/customize/customize_main.ml
+++ b/customize/customize_main.ml
@@ -39,7 +39,6 @@ let main ()      | s -> attach_format := Some s
   in
   let attach_disk s = attach := (!attach_format, s) :: !attach in
-  let debug_gc = ref false in
   let domain = ref None in
   let dryrun = ref false in
   let files = ref [] in
@@ -79,7 +78,7 @@ let main ()                                             
"format" ^ " " ^ s_"Set attach disk format";
     "-c",        Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
     "--connect", Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
-    "--debug-gc", Arg.Set debug_gc,         " " ^
s_"Debug GC and memory allocations (internal)";
+    "--debug-gc", Arg.Unit set_debug_gc,    " " ^
s_"Debug GC and memory allocations (internal)";
     "-d",        Arg.String set_domain,     s_"domain" ^
" " ^ s_"Set libvirt guest name";
     "--domain",  Arg.String set_domain,     s_"domain" ^
" " ^ s_"Set libvirt guest name";
     "-n",        Arg.Set dryrun,            " " ^
s_"Perform a dry run";
@@ -174,7 +173,6 @@ read the man page virt-customize(1).
 
   (* Dereference the rest of the args. *)
   let attach = List.rev !attach in
-  let debug_gc = !debug_gc in
   let dryrun = !dryrun in
   let memsize = !memsize in
   let network = !network in
@@ -239,10 +237,7 @@ read the man page virt-customize(1).
 
   message (f_"Finishing off");
   g#shutdown ();
-  g#close ();
-
-  if debug_gc then
-    Gc.compact ()
+  g#close ()
 
 (* Finished. *)
 let () = run_main_and_handle_errors main
diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml
index ca6d470..99d2098 100644
--- a/mllib/common_utils.ml
+++ b/mllib/common_utils.ml
@@ -759,3 +759,7 @@ let read_first_line_from_file filename    let line =
input_line chan in
   close_in chan;
   line
+
+(** Install an exit hook to check gc consistency for --debug-gc *)
+let set_debug_gc () +  at_exit (fun () -> Gc.compact())
diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli
index ac232af..9d1ee6a 100644
--- a/mllib/common_utils.mli
+++ b/mllib/common_utils.mli
@@ -190,3 +190,6 @@ val last_part_of : string -> char -> string option
 val read_first_line_from_file : string -> string
 (** Read only the first line (i.e. until the first newline character)
     of a file. *)
+
+val set_debug_gc : unit -> unit
+(** Install an exit hook to check gc consistency for --debug-gc *)
diff --git a/resize/resize.ml b/resize/resize.ml
index 101b303..8ab14f7 100644
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -152,7 +152,7 @@ let string_of_expand_content_method = function
 (* Main program. *)
 let main ()    let infile, outfile, align_first, alignment, copy_boot_loader,
-    debug_gc, deletes,
+    deletes,
     dryrun, expand, expand_content, extra_partition, format, ignores,
     lv_expands, machine_readable, ntfsresize_force, output_format,
     resizes, resizes_force, shrink, sparse @@ -162,7 +162,6 @@ let main ()     
let align_first = ref "auto" in
     let alignment = ref 128 in
     let copy_boot_loader = ref true in
-    let debug_gc = ref false in
     let deletes = ref [] in
     let dryrun = ref false in
     let expand = ref "" in
@@ -196,7 +195,7 @@ let main ()        "--no-copy-boot-loader",
Arg.Clear copy_boot_loader, " " ^ s_"Don't copy boot
loader";
       "-d",        Arg.Unit set_verbose,      " " ^
s_"Enable debugging messages";
       "--debug",   Arg.Unit set_verbose,      ditto;
-      "--debug-gc",Arg.Set debug_gc,          " " ^
s_"Debug GC and memory allocations";
+      "--debug-gc",Arg.Unit set_debug_gc,     " " ^
s_"Debug GC and memory allocations";
       "--delete",  Arg.String (add deletes),  s_"part" ^
" " ^ s_"Delete partition";
       "--expand",  Arg.String set_expand,     s_"part" ^
" " ^ s_"Expand partition";
       "--no-expand-content", Arg.Clear expand_content, " "
^ s_"Don't expand content";
@@ -250,7 +249,6 @@ read the man page virt-resize(1).
     (* Dereference the rest of the args. *)
     let alignment = !alignment in
     let copy_boot_loader = !copy_boot_loader in
-    let debug_gc = !debug_gc in
     let deletes = List.rev !deletes in
     let dryrun = !dryrun in
     let expand = match !expand with "" -> None | str -> Some
str in
@@ -325,7 +323,7 @@ read the man page virt-resize(1).
           infile in
 
     infile, outfile, align_first, alignment, copy_boot_loader,
-    debug_gc, deletes,
+    deletes,
     dryrun, expand, expand_content, extra_partition, format, ignores,
     lv_expands, machine_readable, ntfsresize_force, output_format,
     resizes, resizes_force, shrink, sparse in
@@ -1366,9 +1364,6 @@ read the man page virt-resize(1).
   if not (quiet ()) then (
     print_newline ();
     wrap (s_"Resize operation completed with no errors.  Before deleting
the old disk, carefully check that the resized disk boots and works
correctly.\n");
-  );
-
-  if debug_gc then
-    Gc.compact ()
+  )
 
 let () = run_main_and_handle_errors main
diff --git a/sparsify/cmdline.ml b/sparsify/cmdline.ml
index fe388f8..b2a57c3 100644
--- a/sparsify/cmdline.ml
+++ b/sparsify/cmdline.ml
@@ -46,7 +46,6 @@ let parse_cmdline ()  
   let compress = ref false in
   let convert = ref "" in
-  let debug_gc = ref false in
   let format = ref "" in
   let ignores = ref [] in
   let in_place = ref false in
@@ -60,7 +59,7 @@ let parse_cmdline ()      "--check-tmpdir",
Arg.String set_check_tmpdir,  "ignore|..." ^ " " ^
s_"Check there is enough space in $TMPDIR";
     "--compress", Arg.Set compress,         " " ^
s_"Compressed output format";
     "--convert", Arg.Set_string convert,    s_"format" ^
" " ^ s_"Format of output disk (default: same as input)";
-    "--debug-gc", Arg.Set debug_gc,         " " ^
s_"Debug GC and memory allocations";
+    "--debug-gc", Arg.Unit set_debug_gc,    " " ^
s_"Debug GC and memory allocations";
     "--format",  Arg.Set_string format,     s_"format" ^
" " ^ s_"Format of input disk";
     "--ignore",  Arg.String (add ignores),  s_"fs" ^ "
" ^ s_"Ignore filesystem";
     "--in-place", Arg.Set in_place,         " " ^
s_"Modify the disk image in-place";
@@ -101,7 +100,6 @@ read the man page virt-sparsify(1).
   let check_tmpdir = !check_tmpdir in
   let compress = !compress in
   let convert = match !convert with "" -> None | str -> Some
str in
-  let debug_gc = !debug_gc in
   let format = match !format with "" -> None | str -> Some str
in
   let ignores = List.rev !ignores in
   let in_place = !in_place in
@@ -188,4 +186,4 @@ read the man page virt-sparsify(1).
     else
       Mode_in_place in
 
-  indisk, debug_gc, format, ignores, machine_readable, zeroes, mode
+  indisk, format, ignores, machine_readable, zeroes, mode
diff --git a/sparsify/sparsify.ml b/sparsify/sparsify.ml
index 1f631d8..30e3020 100644
--- a/sparsify/sparsify.ml
+++ b/sparsify/sparsify.ml
@@ -30,7 +30,7 @@ module G = Guestfs
 let () = Random.self_init ()
 
 let rec main () -  let indisk, debug_gc, format, ignores, machine_readable,
zeroes, mode +  let indisk, format, ignores, machine_readable, zeroes, mode     
parse_cmdline () in
 
   (match mode with
@@ -39,9 +39,6 @@ let rec main ()        format ignores machine_readable option
tmp zeroes
   | Mode_in_place ->
     In_place.run indisk format ignores machine_readable zeroes
-  );
-
-  if debug_gc then
-    Gc.compact ()
+  )
 
 let () = run_main_and_handle_errors main
diff --git a/sysprep/main.ml b/sysprep/main.ml
index da3dfd2..8b71109 100644
--- a/sysprep/main.ml
+++ b/sysprep/main.ml
@@ -34,8 +34,7 @@ let () = Sysprep_operation.bake ()
 let () = Random.self_init ()
 
 let main () -  let debug_gc, operations, g, mount_opts -    let debug_gc = ref
false in
+  let operations, g, mount_opts      let domain = ref None in
     let dryrun = ref false in
     let files = ref [] in
@@ -121,7 +120,7 @@ let main ()        "--add",     Arg.String
add_file,       s_"file" ^ " " ^ s_"Add disk image
file";
       "-c",        Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
       "--connect", Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
-      "--debug-gc", Arg.Set debug_gc,         " " ^
s_"Debug GC and memory allocations (internal)";
+      "--debug-gc", Arg.Unit set_debug_gc,    " " ^
s_"Debug GC and memory allocations (internal)";
       "-d",        Arg.String set_domain,     s_"domain" ^
" " ^ s_"Set libvirt guest name";
       "--domain",  Arg.String set_domain,     s_"domain" ^
" " ^ s_"Set libvirt guest name";
       "-n",        Arg.Set dryrun,            " " ^
s_"Perform a dry run";
@@ -207,7 +206,6 @@ read the man page virt-sysprep(1).
     in
 
     (* Dereference the rest of the args. *)
-    let debug_gc = !debug_gc in
     let dryrun = !dryrun in
     let operations = !operations in
 
@@ -234,7 +232,7 @@ read the man page virt-sysprep(1).
     add g dryrun;
     g#launch ();
 
-    debug_gc, operations, g, mount_opts in
+    operations, g, mount_opts in
 
   (* Inspection. *)
   (match Array.to_list (g#inspect_os ()) with
@@ -277,9 +275,6 @@ read the man page virt-sysprep(1).
 
   (* Finish off. *)
   g#shutdown ();
-  g#close ();
-
-  if debug_gc then
-    Gc.compact ()
+  g#close ()
 
 let () = run_main_and_handle_errors main
diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml
index eaf57dc..df65426 100644
--- a/v2v/cmdline.ml
+++ b/v2v/cmdline.ml
@@ -27,7 +27,6 @@ open Types
 open Utils
 
 let parse_cmdline () -  let debug_gc = ref false in
   let debug_overlays = ref false in
   let do_copy = ref true in
   let input_conn = ref "" in
@@ -138,7 +137,7 @@ let parse_cmdline ()    let argspec = Arg.align [
     "-b",        Arg.String add_bridge,     "in:out " ^
s_"Map bridge 'in' to 'out'";
     "--bridge",  Arg.String add_bridge,     "in:out " ^
ditto;
-    "--debug-gc",Arg.Set debug_gc,          " " ^
s_"Debug GC and memory allocations";
+    "--debug-gc",Arg.Unit set_debug_gc,     " " ^
s_"Debug GC and memory allocations";
     "--debug-overlay",Arg.Set debug_overlays,
     " " ^ s_"Save overlay files";
     "--debug-overlays",Arg.Set debug_overlays,
@@ -211,7 +210,6 @@ read the man page virt-v2v(1).
 
   (* Dereference the arguments. *)
   let args = List.rev !args in
-  let debug_gc = !debug_gc in
   let debug_overlays = !debug_overlays in
   let do_copy = !do_copy in
   let input_conn = match !input_conn with "" -> None | s ->
Some s in
@@ -385,6 +383,6 @@ read the man page virt-v2v(1).
         vmtype output_alloc in
 
   input, output,
-  debug_gc, debug_overlays, do_copy, network_map, no_trim,
+  debug_overlays, do_copy, network_map, no_trim,
   output_alloc, output_format, output_name,
   print_source, root_choice
diff --git a/v2v/v2v.ml b/v2v/v2v.ml
index 4c41ed5..f6ebdd5 100644
--- a/v2v/v2v.ml
+++ b/v2v/v2v.ml
@@ -46,7 +46,7 @@ let () = Random.self_init ()
 let rec main ()    (* Handle the command line. *)
   let input, output,
-    debug_gc, debug_overlays, do_copy, network_map, no_trim,
+    debug_overlays, do_copy, network_map, no_trim,
     output_alloc, output_format, output_name, print_source, root_choice     
Cmdline.parse_cmdline () in
 
@@ -63,8 +63,6 @@ let rec main ()      printf (f_"Source guest information
(--print-source option):\n");
     printf "\n";
     printf "%s\n" (string_of_source source);
-    if debug_gc then
-      Gc.compact ();
     exit 0
   );
 
@@ -461,10 +459,7 @@ let rec main ()    );
 
   message (f_"Finishing off");
-  delete_target_on_exit := false;  (* Don't delete target on exit. *)
-
-  if debug_gc then
-    Gc.compact ()
+  delete_target_on_exit := false  (* Don't delete target on exit. *)
 
 and inspect_source g root_choice    let roots = g#inspect_os () in
-- 
2.4.3

On Fri, Aug 28, 2015 at 05:56:04PM +0300, Roman Kagan
wrote:
> Several tools handle --debug-gc command-line option, by explicitly
> forcing GC on every exit path.  This is tedious and prone to forgetting
> some of the exit paths.
> 
> Instead, add a generic handler for --debug-gc, which installs an at_exit
> hook to do the GC consistency check, and which can be called right in
> the command-line parser.  Also adjust all users of --debug-gc to use
> that handler.
> 
> Signed-off-by: Roman Kagan <rkagan@virtuozzo.com>
ACK.  I'll push this in an hour or two once I've finished running
some (unrelated) tests.

Thanks,

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-builder quickly builds VMs from scratch
http://libguestfs.org/virt-builder.1.html