Libguestfs - Oct 2015 - [PATCH 1/4] ocaml: Use generational global roots.

Allow Guestfs.t handle to be garbage collected, and add a
regression test.

These are considerably more efficient than ordinary global roots, but
with the caveat that the program is not allowed to modify them without
calling a special function.  We don't modify them, so this change is
safe.

This requires OCaml >= 3.11, but we have that on RHEL 6
(since we dropped support for RHEL 5).

See also:
http://caml.inria.fr/pub/ml-archives/caml-list/2008/03/c3bf86990088236ceeb9a0f0f4c35390.en.html
---
 README            |  2 +-
 ocaml/guestfs-c.c | 16 +++++-----------
 2 files changed, 6 insertions(+), 12 deletions(-)

diff --git a/README b/README
index 8c74901..19a1fb2 100644
--- a/README
+++ b/README
@@ -84,7 +84,7 @@ The full requirements are described below.
 +--------------+-------------+---+-----------------------------------------+
 | Pod::Simple  |             | R | Part of Perl core.                      |
 +--------------+-------------+---+-----------------------------------------+
-| OCaml        |             |R/O| Required if compiling from git.         |
+| OCaml        | 3.11        |R/O| Required if compiling from git.         |
 |              |             |   | Optional if compiling from tarball.     |
 |              |             |   | To build generated files and OCaml bindings.
 +--------------+-------------+---+-----------------------------------------+
diff --git a/ocaml/guestfs-c.c b/ocaml/guestfs-c.c
index cbff846..1ee5ba7 100644
--- a/ocaml/guestfs-c.c
+++ b/ocaml/guestfs-c.c
@@ -88,12 +88,12 @@ guestfs_finalize (value gv)
 
     /* Now unregister the global roots. */
     for (i = 0; i < len; ++i) {
-      caml_remove_global_root (roots[i]);
+      caml_remove_generational_global_root (roots[i]);
       free (roots[i]);
     }
     free (roots);
 
-    caml_remove_global_root (v);
+    caml_remove_generational_global_root (v);
     free (v);
   }
 }
@@ -179,10 +179,7 @@ ocaml_guestfs_create (value environmentv, value
close_on_exitv, value unitv)
    */
   v = guestfs_int_safe_malloc (g, sizeof *v);
   *v = gv;
-  /* XXX This global root is generational, but we cannot rely on every
-   * user having the OCaml 3.11 version which supports this.
-   */
-  caml_register_global_root (v);
+  caml_register_generational_global_root (v);
   guestfs_set_private (g, "_ocaml_g", v);
 
   CAMLreturn (gv);
@@ -255,10 +252,7 @@ ocaml_guestfs_set_event_callback (value gv, value closure,
value events)
     ocaml_guestfs_raise_error (g, "set_event_callback");
   }
 
-  /* XXX This global root is generational, but we cannot rely on every
-   * user having the OCaml 3.11 version which supports this.
-   */
-  caml_register_global_root (root);
+  caml_register_generational_global_root (root);
 
   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
   guestfs_set_private (g, key, root);
@@ -280,7 +274,7 @@ ocaml_guestfs_delete_event_callback (value gv, value ehv)
 
   value *root = guestfs_get_private (g, key);
   if (root) {
-    caml_remove_global_root (root);
+    caml_remove_generational_global_root (root);
     free (root);
     guestfs_set_private (g, key, NULL);
     guestfs_delete_event_callback (g, eh);
-- 
2.5.0

** 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

---
 ocaml/Makefile.am                     |  2 ++
 ocaml/t/guestfs_065_implicit_close.ml | 32 ++++++++++++++++++++++++++++++++
 src/guestfs.pod                       |  1 +
 3 files changed, 35 insertions(+)
 create mode 100644 ocaml/t/guestfs_065_implicit_close.ml

diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am
index d838561..ea41377 100644
--- a/ocaml/Makefile.am
+++ b/ocaml/Makefile.am
@@ -111,6 +111,7 @@ test_progs_bc = \
 	t/guestfs_040_create_multiple.bc \
 	t/guestfs_050_handle_properties.bc \
 	t/guestfs_060_explicit_close.bc \
+	t/guestfs_065_implicit_close.bc \
 	t/guestfs_070_optargs.bc \
 	t/guestfs_410_close_event.bc \
 	t/guestfs_420_log_messages.bc
@@ -122,6 +123,7 @@ test_progs_opt = \
 	t/guestfs_040_create_multiple.opt \
 	t/guestfs_050_handle_properties.opt \
 	t/guestfs_060_explicit_close.opt \
+	t/guestfs_065_implicit_close.opt \
 	t/guestfs_070_optargs.opt \
 	t/guestfs_410_close_event.opt \
 	t/guestfs_420_log_messages.opt
diff --git a/ocaml/t/guestfs_065_implicit_close.ml
b/ocaml/t/guestfs_065_implicit_close.ml
new file mode 100644
index 0000000..764ec63
--- /dev/null
+++ b/ocaml/t/guestfs_065_implicit_close.ml
@@ -0,0 +1,32 @@
+(* libguestfs OCaml tests
+ * Copyright (C) 2009-2015 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA.
+ *)
+
+let close_invoked = ref 0
+
+let close _ _ _ _ +  incr close_invoked
+
+let () +  let g = new Guestfs.guestfs () in
+  ignore (g#set_event_callback close [Guestfs.EVENT_CLOSE]);
+  assert (!close_invoked = 0);
+  (* This should cause the GC to close the handle. *)
+  Gc.compact ();
+  assert  (!close_invoked = 1)
+
+let () = Gc.compact ()
diff --git a/src/guestfs.pod b/src/guestfs.pod
index 9ec7bbc..248a4d0 100644
--- a/src/guestfs.pod
+++ b/src/guestfs.pod
@@ -4169,6 +4169,7 @@ This is the numbering scheme used by the tests:
    040  create multiple handles
    050  test setting and getting config properties
    060  explicit close
+   065  implicit close (in GC'd languages)
    070  optargs
  
  - 100  launch, create partitions and LVs and filesystems
-- 
2.5.0

---
 ocaml/Makefile.am | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am
index ea41377..10a38f7 100644
--- a/ocaml/Makefile.am
+++ b/ocaml/Makefile.am
@@ -111,10 +111,11 @@ test_progs_bc = \
 	t/guestfs_040_create_multiple.bc \
 	t/guestfs_050_handle_properties.bc \
 	t/guestfs_060_explicit_close.bc \
-	t/guestfs_065_implicit_close.bc \
 	t/guestfs_070_optargs.bc \
 	t/guestfs_410_close_event.bc \
 	t/guestfs_420_log_messages.bc
+# Broken on bytecode, works on native:
+#	t/guestfs_065_implicit_close.bc
 
 test_progs_opt = \
 	t/guestfs_010_load.opt \
-- 
2.5.0

On Tue, Oct 06, 2015 at 04:05:47PM +0100, Richard W.M. Jones
wrote:
> ---
>  ocaml/Makefile.am | 3 ++-
>  1 file changed, 2 insertions(+), 1 deletion(-)
> 
> diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am
> index ea41377..10a38f7 100644
> --- a/ocaml/Makefile.am
> +++ b/ocaml/Makefile.am
> @@ -111,10 +111,11 @@ test_progs_bc = \
>  	t/guestfs_040_create_multiple.bc \
>  	t/guestfs_050_handle_properties.bc \
>  	t/guestfs_060_explicit_close.bc \
> -	t/guestfs_065_implicit_close.bc \
>  	t/guestfs_070_optargs.bc \
>  	t/guestfs_410_close_event.bc \
>  	t/guestfs_420_log_messages.bc
> +# Broken on bytecode, works on native:
> +#	t/guestfs_065_implicit_close.bc
The reason the test failed on bytecode was just a mistake in the test
which I fixed by modifying it as below.  So this patch is no longer
required.

let ()   let g = new Guestfs.guestfs () in
  ignore (g#set_event_callback close [Guestfs.EVENT_CLOSE]);
  assert (!close_invoked = 0)
(* Allow the 'g' handle to go out of scope here, to ensure there is no
 * reference held on the stack.
 *)

(* This should cause the GC to close the handle. *)
let () = Gc.compact ()

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
libguestfs lets you edit virtual machines.  Supports shell scripting,
bindings from many languages.  http://libguestfs.org

On Tuesday 06 October 2015 16:05:44 Richard W.M. Jones
wrote:
> These are considerably more efficient than ordinary global roots, but
> with the caveat that the program is not allowed to modify them without
> calling a special function.  We don't modify them, so this change is
> safe.
> 
> This requires OCaml >= 3.11, but we have that on RHEL 6
> (since we dropped support for RHEL 5).
> 
> See also:
>
http://caml.inria.fr/pub/ml-archives/caml-list/2008/03/c3bf86990088236ceeb9a0f0f4c35390.en.html
> ---
LGTM.

Maybe we need to add an OCaml version check in configure?

-- 
Pino Toscano