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(a)virtuozzo.com&gt; --- 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