1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
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. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* User-level threads *)
17
18 type t
19
20 external thread_initialize : unit -> unit = "caml_thread_initialize"
21 external thread_cleanup : unit -> unit = "caml_thread_cleanup"
22 external thread_new : (unit -> unit) -> t = "caml_thread_new"
23 external thread_uncaught_exception : exn -> unit =
24 "caml_thread_uncaught_exception"
25
26 external yield : unit -> unit = "caml_thread_yield"
27 external self : unit -> t = "caml_thread_self" [@@noalloc]
28 external id : t -> int = "caml_thread_id" [@@noalloc]
29 external join : t -> unit = "caml_thread_join"
30 external exit : unit -> unit = "caml_thread_exit"
31
32 (* For new, make sure the function passed to thread_new never
33 raises an exception. *)
34
35 let create fn arg =
36 thread_new
37 (fun () ->
38 try
39 fn arg; ()
40 with exn ->
41 flush stdout; flush stderr;
42 thread_uncaught_exception exn)
43
44 (* Thread.kill is currently not implemented due to problems with
45 cleanup handlers on several platforms *)
46
47 let kill th = invalid_arg "Thread.kill: not implemented"
48
49 (* Preemption *)
50
51 let preempt signal = yield()
52
53 (* Initialization of the scheduler *)
54
55 let preempt_signal =
56 match Sys.os_type with
57 | "Win32" -> Sys.sigterm
58 | _ -> Sys.sigvtalrm
59
60 let () =
61 Sys.set_signal preempt_signal (Sys.Signal_handle preempt);
62 thread_initialize ();
63 Callback.register "Thread.at_shutdown" (fun () ->
64 thread_cleanup();
65 (* In case of DLL-embedded OCaml the preempt_signal handler
66 will point to nowhere after DLL unloading and an accidental
67 preempt_signal will crash the main program. So restore the
68 default handler. *)
69 Sys.set_signal preempt_signal Sys.Signal_default
70 )
71
72 (* Wait functions *)
73
74 let delay = Unix.sleepf
75
76 let wait_read fd = ()
77 let wait_write fd = ()
78
79 let wait_timed_read fd d =
80 match Unix.select [fd] [] [] d with ([], _, _) -> false | (_, _, _) -> true
81 let wait_timed_write fd d =
82 match Unix.select [] [fd] [] d with (_, [], _) -> false | (_, _, _) -> true
83 let select = Unix.select
84
85 let wait_pid p = Unix.waitpid [] p
86
87 external sigmask : Unix.sigprocmask_command -> int list -> int list
88 = "caml_thread_sigmask"
89 external wait_signal : int list -> int = "caml_wait_signal"
90