/usr/lib/ocaml/lablgtk2/gtkThread.ml is in liblablgtk2-ocaml-dev 2.18.5+dfsg-1build1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | (**************************************************************************)
(* Lablgtk *)
(* *)
(* This program is free software; you can redistribute it *)
(* and/or modify it under the terms of the GNU Library General *)
(* Public License as published by the Free Software Foundation *)
(* version 2, with the exception described in file COPYING which *)
(* comes with the library. *)
(* *)
(* 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 Library General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Library General *)
(* Public License along with this program; if not, write to the *)
(* Free Software Foundation, Inc., 59 Temple Place, Suite 330, *)
(* Boston, MA 02111-1307 USA *)
(* *)
(* *)
(**************************************************************************)
(* $Id$ *)
open GtkMain
(* Job handling for Windows *)
let jobs : (unit -> unit) Queue.t = Queue.create ()
let m = Mutex.create ()
let with_jobs f =
Mutex.lock m; let y = f jobs in Mutex.unlock m; y
let loop_id = ref None
let reset () = loop_id := None
let cannot_sync () =
match !loop_id with None -> true
| Some id -> Thread.id (Thread.self ()) = id
let gui_safe () =
not (Sys.os_type = "Win32") || !loop_id = Some(Thread.id (Thread.self ()))
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 has_timeout = ref false
let async j x = with_jobs
(fun jobs ->
Queue.add (fun () ->
GtkSignal.safe_call j x ~where:"asynchronous call") jobs;
if not !has_timeout then begin
has_timeout := true;
ignore (Glib.Timeout.add 1 (fun () -> has_timeout := false; false))
end)
type 'a result = Val of 'a | Exn of exn | NA
let sync f x =
if cannot_sync () then f x else
let m = Mutex.create () in
let res = ref NA in
Mutex.lock m;
let c = Condition.create () in
let j x =
let y = try Val (f x) with e -> Exn e in
Mutex.lock m; res := y; Mutex.unlock m;
Condition.signal c
in
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 do_jobs_delay = ref 0.013;;
let set_do_jobs_delay d = do_jobs_delay := max 0. d;;
let do_jobs () =
for i = 1 to n_jobs () do do_next_job () done;
true
(* We check first whether there are some event pending, and run
some iterations. We then need to delay, thus focing a thread switch. *)
let busy_waiting =
ref (try Sys.getenv "LABLGTK_BUSY_WAIT" <> "0" with _ -> false)
let thread_main_real () =
try
let loop = (Glib.Main.create true) in
Main.loops := loop :: !Main.loops;
Glib.Main.wrap_poll_func (); (* mark polling as blocking *)
loop_id := Some (Thread.id (Thread.self ()));
while Glib.Main.is_running loop do
if not !busy_waiting then
ignore (Glib.Main.iteration true) (* blocking *)
else begin
let i = ref 0 in
(* Non blocking busy waiting *)
Thread.delay !do_jobs_delay;
while !i < 100 && Glib.Main.pending () do
Glib.Main.iteration true;
incr i
done
end;
do_jobs ()
done;
Main.loops := List.tl !Main.loops;
with exn ->
Main.loops := List.tl !Main.loops;
raise exn
let thread_main () =
sync thread_main_real ()
let main () =
GtkMain.Main.main_func := thread_main;
thread_main ()
let start () =
reset ();
Thread.create main ()
(* The code below would do nothing...
let _ =
let mutex = Mutex.create () in
let depth = ref 0 in
GtkSignal.enter_callback :=
(fun () -> if !depth = 0 then Mutex.lock mutex; incr depth);
GtkSignal.exit_callback :=
(fun () -> decr depth; if !depth = 0 then Mutex.unlock mutex)
*)
|