package core

  1. Overview
  2. Docs
package core
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file core_thread.ml

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
open! Import

let threads_have_been_created = ref false

include Thread

let sexp_of_t t = [%message "thread" ~id:(id t : int)]

let create_should_raise = ref false

let create ~on_uncaught_exn f arg =
  if !create_should_raise
  then raise_s [%message "Thread.create requested to raise"];
  threads_have_been_created := true;
  let f arg : unit =
    let exit =
      match on_uncaught_exn with
      | `Print_to_stderr -> false
      | `Kill_whole_process -> true
    in
    Exn.handle_uncaught ~exit (fun () -> f arg)
  in
  create f arg
;;

let threads_have_been_created () = !threads_have_been_created

let wait_signal sigs = wait_signal (List.map ~f:Signal.to_caml_int sigs)

let sigmask cmd sigs =
  let cmd =
    match cmd with
    | `Set -> Unix.SIG_SETMASK
    | `Block -> Unix.SIG_BLOCK
    | `Unblock -> Unix.SIG_UNBLOCK
  in
  let sigs = List.map ~f:Signal.to_caml_int sigs in
  List.map ~f:Signal.of_caml_int (sigmask cmd sigs)
;;

let num_threads () =
  let rec find_thread_count = function
    | [] -> None
    | line :: xs ->
      if String.is_prefix line ~prefix:"Threads:" then
        begin
          try
            Some (int_of_string
                    (String.strip (snd (String.lsplit2_exn line ~on:':'))))
          with
          | _ -> None
        end
      else find_thread_count xs
  in
  try
    find_thread_count
      (In_channel.read_lines
         ("/proc/" ^ string_of_int (Unix.getpid ()) ^ "/status"))
  with _ -> None
;;

let block_forever () =
  Event.sync (Event.receive (Event.new_channel ()))
;;

[%%import "config.h"]

[%%ifdef JSC_PTHREAD_NP]
external setaffinity_self_exn : int Array.t -> unit        = "pthread_np_setaffinity_self"
external getaffinity_self_exn : unit        -> int Array.t = "pthread_np_getaffinity_self"

let setaffinity_self_exn =
  let setaffinity_self_exn cpuset =
    setaffinity_self_exn (Int.Set.to_array cpuset)
  in
  Ok setaffinity_self_exn
;;

let getaffinity_self_exn =
  let getaffinity_self_exn () =
    Int.Set.of_array (getaffinity_self_exn ())
  in
  Ok getaffinity_self_exn
;;
[%%else]

let not_supported name =
  Error.of_string
    (sprintf
       "%s: non-portable pthread extension is not supported on this platform"
       name)
;;

let setaffinity_self_exn = Error (not_supported "pthread_setaffinity_np")
let getaffinity_self_exn = Error (not_supported "pthread_getaffinity_np")
[%%endif]

module For_testing = struct
  let create_should_raise = create_should_raise
end
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct