Blame support/tkthread.ml

Packit bd2e5d
(***********************************************************************)
Packit bd2e5d
(*                                                                     *)
Packit bd2e5d
(*                 MLTk, Tcl/Tk interface of OCaml                     *)
Packit bd2e5d
(*                                                                     *)
Packit bd2e5d
(*         Jacques Garrigue, Nagoya University Mathematics Dept.       *)
Packit bd2e5d
(*                                                                     *)
Packit bd2e5d
(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
Packit bd2e5d
(*  en Automatique and Kyoto University.  All rights reserved.         *)
Packit bd2e5d
(*  This file is distributed under the terms of the GNU Library        *)
Packit bd2e5d
(*  General Public License, with the special exception on linking      *)
Packit bd2e5d
(*  described in file LICENSE found in the OCaml source tree.          *)
Packit bd2e5d
(*                                                                     *)
Packit bd2e5d
(***********************************************************************)
Packit bd2e5d
Packit bd2e5d
(* $Id$ *)
Packit bd2e5d
Packit bd2e5d
let jobs : (unit -> unit) Queue.t = Queue.create ()
Packit bd2e5d
let m = Mutex.create ()
Packit bd2e5d
let with_jobs f =
Packit bd2e5d
  Mutex.lock m; let y = f jobs in Mutex.unlock m; y
Packit bd2e5d
Packit bd2e5d
let loop_id = ref None
Packit bd2e5d
let gui_safe () =
Packit bd2e5d
  !loop_id = Some(Thread.id (Thread.self ()))
Packit bd2e5d
let running () =
Packit bd2e5d
  !loop_id <> None
Packit bd2e5d
Packit bd2e5d
let has_jobs () = not (with_jobs Queue.is_empty)
Packit bd2e5d
let n_jobs () = with_jobs Queue.length
Packit bd2e5d
let do_next_job () = with_jobs Queue.take ()
Packit bd2e5d
let async j x = with_jobs (Queue.add (fun () -> j x))
Packit bd2e5d
let sync f x =
Packit bd2e5d
  if !loop_id = None then failwith "Tkthread.sync";
Packit bd2e5d
  if gui_safe () then f x else
Packit bd2e5d
  let m = Mutex.create () in
Packit bd2e5d
  let res = ref None in
Packit bd2e5d
  Mutex.lock m;
Packit bd2e5d
  let c = Condition.create () in
Packit bd2e5d
  let j x =
Packit bd2e5d
    let y = f x in Mutex.lock m; res := Some y; Mutex.unlock m;
Packit bd2e5d
    Condition.signal c
Packit bd2e5d
  in
Packit bd2e5d
  async j x;
Packit bd2e5d
  Condition.wait c m;
Packit bd2e5d
  match !res with Some y -> y | None -> assert false
Packit bd2e5d
Packit bd2e5d
let rec job_timer () =
Packit bd2e5d
  Timer.set ~ms:10 ~callback:
Packit bd2e5d
    (fun () -> for i = 1 to n_jobs () do do_next_job () done; job_timer())
Packit bd2e5d
Packit bd2e5d
let thread_main () =
Packit bd2e5d
  try
Packit bd2e5d
    loop_id := Some (Thread.id (Thread.self ()));
Packit bd2e5d
    ignore (Protocol.openTk());
Packit bd2e5d
    job_timer();
Packit bd2e5d
    Protocol.mainLoop();
Packit bd2e5d
    loop_id := None;
Packit bd2e5d
  with exn ->
Packit bd2e5d
    loop_id := None;
Packit bd2e5d
    raise exn
Packit bd2e5d
Packit bd2e5d
let start () =
Packit bd2e5d
  let th = Thread.create thread_main () in
Packit bd2e5d
  loop_id := Some (Thread.id th);
Packit bd2e5d
  th
Packit bd2e5d
Packit bd2e5d
let top = Widget.default_toplevel