Use gdk_threads_set_lock_functions to avoid busy waiting in GtkThreads

src/gdk.ml

@@ -790,8 +790,49 @@ module Windowing = struct
 end
 
 module Threads = struct
+  (* There are two mutexes: ocaml runtime protection and GDK protection.
+     The one that protects GDK will be used to synchronize accesses to GUI.
+     The other one is handled by the runtime system, and it is locked when OCaml code executes.
+     We will ask GDK to release both mutexes when the main loop idles.
+     This way other OCaml threads will run.
+     The only problem is that:
+       "Idles, timeouts, and input functions are executed outside of the main GTK+ lock"
+     In our particular setup the above words "the main GTK+ lock" refer to BOTH our mutexes.
+     It means that callbacks for these events need to be wrapped with
+     ml_gdk_threads_enter/leave.
+     Alternatively only the OCaml runtime mutex can be locked by these handlers,
+     but this would require special attention.
+  *)
+
+  external set_our_lock_functions : unit -> unit = "set_our_lock_functions"
+  (* Tells GDK that when GTK+ will be idling, both mutexes should be released. *)
+
   external init : unit -> unit = "ml_gdk_threads_init"
+
+  (* set_our_lock_functions asks GDK to have these two functions work on both mutexes. *)
   external enter : unit -> unit = "ml_gdk_threads_enter"
   external leave : unit -> unit = "ml_gdk_threads_leave"
+
+  (* These two functions work on the mutex inteded for GDK protection only. *)
+  external acquire_mutex_for_gdk : unit -> unit = "acquire_mutex_for_gdk"
+  external release_mutex_for_gdk : unit -> unit = "release_mutex_for_gdk"
+
   external g_thread_init : unit -> unit = "ml_g_thread_init" (* defined in ml_gdk.c *)
+
+  let initialize () =
+    g_thread_init ();
+    set_our_lock_functions ();
+    init ();
+    (* depending on how our main loop is done, we could have to grab the GDK lock now,
+       when simply using gtk_main we need so: *)
+    acquire_mutex_for_gdk () (* hopefully need not to release it just before process exits *)
+
+  let synchronize f x =
+    acquire_mutex_for_gdk ();
+    let result = f x in
+    X.flush ();
+    release_mutex_for_gdk ();
+    result
+
 end
+

src/gdk.mli

@@ -524,3 +524,13 @@ end
 module Windowing : sig
   val platform : [`QUARTZ | `WIN32 | `X11]
 end
+
+module Threads : sig
+  val initialize : unit -> unit
+  (** This is called once by GtkThread.main.
+  In general, it should be called before any other GTK/GDK functions in order to get proper behavior wrt threads. Beware "Idles, timeouts, and input functions" - need special attention. *)
+
+  val synchronize : ('a -> 'b) -> 'a -> 'b
+  (** Calls the given function with the given argument within the main GDK lock, so all the GTK can be accessed freely. This also calls [gdk_flush] before return. *)
+
+end

src/gtkMain.ml

@@ -33,6 +33,10 @@ module Main = struct
   (* external set_locale : unit -> string = "ml_gtk_set_locale" *)
   external disable_setlocale : unit -> unit = "ml_gtk_disable_setlocale"
   (* external main : unit -> unit = "ml_gtk_main" *)
+
+  external ml_gtk_main : unit -> unit = "ml_gtk_main"
+  external ml_gtk_main_quit : unit -> unit = "ml_gtk_main_quit"
+
   let init ?(setlocale=true) () =
     let setlocale =
       try Sys.getenv "GTK_SETLOCALE" <> "0" with Not_found -> setlocale in
@@ -55,9 +59,10 @@ module Main = struct
     loops := loop :: !loops;
     while Main.is_running loop do Main.iteration true done;
     if !loops <> [] then loops := List.tl !loops
-  let main_func = ref default_main
+  let main_func = ref ml_gtk_main (* instead of default_main *)
   let main () = !main_func ()
-  let quit () = if !loops <> [] then Main.quit (List.hd !loops)
+  (*let quit () = if !loops <> [] then Main.quit (List.hd !loops)*)
+  let quit = ml_gtk_main_quit
   external get_version : unit -> int * int * int = "ml_gtk_get_version"
   let version = get_version ()
   external get_current_event_time : unit -> int32

src/gtkThread.ml

@@ -43,6 +43,7 @@ let gui_safe () =
 let has_jobs () = not (with_jobs Queue.is_empty)
 let n_jobs () = with_jobs Queue.length
 let do_next_job () = with_jobs Queue.take ()
+(*
 let async j x = with_jobs
     (Queue.add (fun () ->
       GtkSignal.safe_call j x ~where:"asynchronous call"))
@@ -61,6 +62,10 @@ let sync f x =
   async j x;
   while !res = NA do Condition.wait c m done;
   match !res with Val y -> y | Exn e -> raise e | NA -> assert false
+*)
+
+let sync = Gdk.Threads.synchronize
+let async = Gdk.Threads.synchronize
 
 let do_jobs_delay = ref 0.013;;
 let set_do_jobs_delay d = do_jobs_delay := max 0. d;;
@@ -96,8 +101,14 @@ let thread_main ?set_delay_cb () =
   sync (thread_main_real ?set_delay_cb) ()
 
 let main ?set_delay_cb () =
-  GtkMain.Main.main_func := thread_main;
-  thread_main ?set_delay_cb ()
+  let this_thread = Thread.id (Thread.self ()) in
+  match !loop_id with
+    | None ->
+      loop_id := Some this_thread;
+      Gdk.Threads.initialize ();
+      GtkMain.Main.main ()
+    | Some id when id = this_thread -> GtkMain.Main.main ()
+    | Some _ -> sync GtkMain.Main.main ()
 
 let start () =
   reset ();

src/ml_gdk.c

@@ -37,6 +37,7 @@
 #include <caml/memory.h>
 #include <caml/callback.h>
 #include <caml/bigarray.h>
+#include <caml/signals.h>
 
 #include "wrappers.h"
 #include "ml_gpointer.h"
@@ -80,6 +81,42 @@ ML_0(gdk_threads_init, Unit);
 ML_0(gdk_threads_enter, Unit);
 ML_0(gdk_threads_leave, Unit);
 
+GMutex *mutex_for_gdk = NULL;
+
+CAMLprim value acquire_mutex_for_gdk(value unit)
+{
+  g_mutex_lock(mutex_for_gdk);
+  return Val_unit;
+}
+
+CAMLprim value release_mutex_for_gdk(value unit)
+{
+  g_mutex_unlock(mutex_for_gdk);
+  return Val_unit;
+}
+
+void enter_fn(void)
+{
+  /* Acquire both locks. */
+  caml_leave_blocking_section();
+  g_mutex_lock(mutex_for_gdk);
+}
+
+void leave_fn(void)
+{
+  /* Release both locks: OCaml runtime and GDK protection */
+  g_mutex_unlock(mutex_for_gdk);
+  caml_enter_blocking_section();
+}
+
+CAMLprim value set_our_lock_functions(value unit)
+{
+  if(!mutex_for_gdk) mutex_for_gdk = g_mutex_new ();
+  if(!mutex_for_gdk) caml_failwith("set_our_lock_functions "__FILE__);
+  gdk_threads_set_lock_functions(enter_fn, leave_fn);
+  return Val_unit;
+}
+
 #include "gdk_tags.c"
 
 Make_OptFlags_val (GdkModifier_val)