Permalink
Browse files

Use gdk_threads_set_lock_functions to avoid busy waiting in GtkThreads

  • Loading branch information...
toton committed Jul 26, 2011
1 parent 75d3393 commit a5ff63e7ef3b7f70d6361bfa6065a3fdd1fe6adc
Showing with 108 additions and 4 deletions.
  1. +41 −0 src/gdk.ml
  2. +10 −0 src/gdk.mli
  3. +7 −2 src/gtkMain.ml
  4. +13 −2 src/gtkThread.ml
  5. +37 −0 src/ml_gdk.c
View
@@ -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
+
View
@@ -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
View
@@ -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
View
@@ -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 ();
View
@@ -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)

0 comments on commit a5ff63e

Please sign in to comment.