[Libguestfs] [PATCH 2/4] ocaml: Allow Guestfs.t handle to be garbage collected.

** NB: This is an API break for OCaml programs using Guestfs.event_callback. ** Because of the way I implemented Guestfs.event_callback which had the Guestfs.t handle as the first parameter, we had to store the (OCaml) Guestfs.t handle in the C handle's private data area. To do that, we had to create a global root pointing to the handle. This of course meant that the handle could not be garbage collected (thanks Roman Kagan for spotting this). This changes the API of Guestfs.event_callback so that a handle is no longer passed. The OCaml handle can now be garbage collected again. For programs that need the Guestfs.t handle in the callback function (which turns out to be *none* of the OCaml programs we have written), you can do: g#set_event_callback (callback_fn g) [Guestfs.EVENT_FOO]; But since the closure passed to Guestfs.set_event_callback is still (unavoidably) registered as a global root, that will trap a reference to the handle, so the handle won't be able to be garbage collected until you delete the callback. --- generator/ocaml.ml | 10 +++------- mllib/progress.ml | 4 ++-- ocaml/guestfs-c.c | 24 +++--------------------- ocaml/t/guestfs_410_close_event.ml | 2 +- ocaml/t/guestfs_420_log_messages.ml | 2 +- ocaml/t/guestfs_430_progress_messages.ml | 2 +- 6 files changed, 11 insertions(+), 33 deletions(-) diff --git a/generator/ocaml.ml b/generator/ocaml.ml index 8b4e1aa..5d92fcb 100644 --- a/generator/ocaml.ml +++ b/generator/ocaml.ml @@ -107,8 +107,7 @@ val event_all : event list type event_handle (** The opaque event handle which can be used to delete event callbacks. *) -type event_callback = - t -> event -> event_handle -> string -> int64 array -> unit +type event_callback = event -> event_handle -> string -> int64 array -> unit (** The event callback. *) val set_event_callback : t -> event_callback -> event list -> event_handle @@ -117,9 +116,7 @@ val set_event_callback : t -> event_callback -> event list -> event_handle Note that if the closure captures a reference to the handle, this reference will prevent the handle from being - automatically closed by the garbage collector. Since the - handle is passed to the event callback, with careful programming - it should be possible to avoid capturing the handle in the closure. *) + automatically closed by the garbage collector. *) val delete_event_callback : t -> event_handle -> unit (** [delete_event_callback g eh] removes a previously registered @@ -321,8 +318,7 @@ let event_all = [ type event_handle = int -type event_callback = - t -> event -> event_handle -> string -> int64 array -> unit +type event_callback = event -> event_handle -> string -> int64 array -> unit external set_event_callback : t -> event_callback -> event list -> event_handle = \"ocaml_guestfs_set_event_callback\" diff --git a/mllib/progress.ml b/mllib/progress.ml index 8cf5875..b6b3b60 100644 --- a/mllib/progress.ml +++ b/mllib/progress.ml @@ -38,13 +38,13 @@ let set_up_progress_bar ?(machine_readable = false) (g : Guestfs.guestfs) = let bar = progress_bar_init ~machine_readable in (* Reset the progress bar before every libguestfs function. *) - let enter_callback g event evh buf array = + let enter_callback event evh buf array = if event = G.EVENT_ENTER then progress_bar_reset bar in (* A progress event: move the progress bar. *) - let progress_callback g event evh buf array = + let progress_callback event evh buf array = if event = G.EVENT_PROGRESS && Array.length array >= 4 then ( let position = array.(2) and total = array.(3) in diff --git a/ocaml/guestfs-c.c b/ocaml/guestfs-c.c index 1ee5ba7..08998af 100644 --- a/ocaml/guestfs-c.c +++ b/ocaml/guestfs-c.c @@ -78,8 +78,6 @@ guestfs_finalize (value gv) size_t len, i; value **roots = get_all_event_callbacks (g, &len); - value *v = guestfs_get_private (g, "_ocaml_g"); - /* Close the handle: this could invoke callbacks from the list * above, which is why we don't want to delete them before * closing the handle. @@ -92,9 +90,6 @@ guestfs_finalize (value gv) free (roots[i]); } free (roots); - - caml_remove_generational_global_root (v); - free (v); } } @@ -156,7 +151,6 @@ ocaml_guestfs_create (value environmentv, value close_on_exitv, value unitv) CAMLlocal1 (gv); unsigned flags = 0; guestfs_h *g; - value *v; if (environmentv != Val_int (0) && !Bool_val (Field (environmentv, 0))) @@ -174,14 +168,6 @@ ocaml_guestfs_create (value environmentv, value close_on_exitv, value unitv) gv = Val_guestfs (g); - /* Store the OCaml handle into the C handle. This is only so we can - * map the C handle to the OCaml handle in event_callback_wrapper. - */ - v = guestfs_int_safe_malloc (g, sizeof *v); - *v = gv; - caml_register_generational_global_root (v); - guestfs_set_private (g, "_ocaml_g", v); - CAMLreturn (gv); } @@ -358,14 +344,10 @@ event_callback_wrapper_locked (guestfs_h *g, const uint64_t *array, size_t array_len) { CAMLparam0 (); - CAMLlocal5 (gv, evv, ehv, bufv, arrayv); + CAMLlocal4 (evv, ehv, bufv, arrayv); CAMLlocal2 (rv, v); - value *root; size_t i; - root = guestfs_get_private (g, "_ocaml_g"); - gv = *root; - /* Only one bit should be set in 'event'. Which one? */ evv = Val_int (event_bitmask_to_event (event)); @@ -380,9 +362,9 @@ event_callback_wrapper_locked (guestfs_h *g, Store_field (arrayv, i, v); } - value args[5] = { gv, evv, ehv, bufv, arrayv }; + value args[4] = { evv, ehv, bufv, arrayv }; - rv = caml_callbackN_exn (*(value*)data, 5, args); + rv = caml_callbackN_exn (*(value*)data, 4, args); /* Callbacks shouldn't throw exceptions. There's not much we can do * except to print it. diff --git a/ocaml/t/guestfs_410_close_event.ml b/ocaml/t/guestfs_410_close_event.ml index e8dd626..13c3220 100644 --- a/ocaml/t/guestfs_410_close_event.ml +++ b/ocaml/t/guestfs_410_close_event.ml @@ -18,7 +18,7 @@ let close_invoked = ref 0 -let close _ _ _ _ _ = +let close _ _ _ _ = incr close_invoked let () = diff --git a/ocaml/t/guestfs_420_log_messages.ml b/ocaml/t/guestfs_420_log_messages.ml index 673a88f..b58dbd9 100644 --- a/ocaml/t/guestfs_420_log_messages.ml +++ b/ocaml/t/guestfs_420_log_messages.ml @@ -20,7 +20,7 @@ open Printf let log_invoked = ref 0 -let log g ev eh buf array = +let log ev eh buf array = let eh : int = Obj.magic eh in printf "event logged: event=%s eh=%d buf=%S array=[%s]\n" diff --git a/ocaml/t/guestfs_430_progress_messages.ml b/ocaml/t/guestfs_430_progress_messages.ml index 26deee0..3d1cc3f 100644 --- a/ocaml/t/guestfs_430_progress_messages.ml +++ b/ocaml/t/guestfs_430_progress_messages.ml @@ -18,7 +18,7 @@ let callback_invoked = ref 0 -let callback _ _ _ _ _ = incr callback_invoked +let callback _ _ _ _ = incr callback_invoked let () = let g = new Guestfs.guestfs () in -- 2.5.0