l4/pkg/ocaml/ocaml/contrib/otherlibs/systhreads/thread_posix.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                         Objective Caml                              *)
   4 (*                                                                     *)
   5 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../../LICENSE.  *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: thread_posix.ml 7000 2005-07-31 12:32:41Z xleroy $ *)
  15
  16 (* User-level threads *)
  17
  18 type t
  19
  20 external thread_initialize : unit -> unit = "caml_thread_initialize"
  21 external thread_new : (unit -> unit) -> t = "caml_thread_new"
  22 external thread_uncaught_exception : exn -> unit =
  23             "caml_thread_uncaught_exception"
  24
  25 external yield : unit -> unit = "caml_thread_yield"
  26 external self : unit -> t = "caml_thread_self"
  27 external id : t -> int = "caml_thread_id"
  28 external join : t -> unit = "caml_thread_join"
  29 external exit : unit -> unit = "caml_thread_exit"
  30
  31 (* For new, make sure the function passed to thread_new never
  32    raises an exception. *)
  33
  34 let create fn arg =
  35   thread_new
  36     (fun () ->
  37       try
  38         fn arg; ()
  39       with exn ->
  40              flush stdout; flush stderr;
  41              thread_uncaught_exception exn)
  42
  43 (* Thread.kill is currently not implemented due to problems with
  44    cleanup handlers on several platforms *)
  45
  46 let kill th = invalid_arg "Thread.kill: not implemented"
  47
  48 (* Preemption *)
  49
  50 let preempt signal = yield()
  51
  52 (* Initialization of the scheduler *)
  53
  54 let _ =
  55   ignore(Sys.signal Sys.sigvtalrm (Sys.Signal_handle preempt));
  56   thread_initialize()
  57
  58 (* Wait functions *)
  59
  60 let delay time = ignore(Unix.select [] [] [] time)
  61
  62 let wait_read fd = ()
  63 let wait_write fd = ()
  64
  65 let wait_timed_read fd d =
  66   match Unix.select [fd] [] [] d with ([], _, _) -> false | (_, _, _) -> true
  67 let wait_timed_write fd d =
  68   match Unix.select [] [fd] [] d with (_, [], _) -> false | (_, _, _) -> true
  69 let select = Unix.select
  70
  71 let wait_pid p = Unix.waitpid [] p
  72
  73 external sigmask : Unix.sigprocmask_command -> int list -> int list = "caml_thread_sigmask"
  74 external wait_signal : int list -> int = "caml_wait_signal"