package hack_parallel

  1. Overview
  2. Docs
Parallel and shared memory library

Install

Dune Dependency

Authors

Maintainers

Sources

1.0.1.tar.gz
md5=ba7c72bc207e326b72e294fc76f6ad2c
sha512=5020d47f97bea2f88e2a40411894d03232a7f2282606926c93c7d4c96d72e94a966be852897a9b16f7e0893ba376512045abb9d93020a7c03c3def4f3d918f8e

doc/src/hack_parallel.utils/sys_utils.ml.html

Source file sys_utils.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
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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
*)

open Hack_core

exception NotADirectory of string

external realpath: string -> string option = "hh_realpath"
external is_nfs: string -> bool = "hh_is_nfs"

(** Hack_option type intead of exception throwing. *)
let get_env name =
  try Some (Sys.getenv name) with
  | Not_found -> None

let getenv_user () =
  let user_var = if Sys.win32 then "USERNAME" else "USER" in
  let logname_var = "LOGNAME" in
  let user = get_env user_var in
  let logname = get_env logname_var in
  Hack_option.first_some user logname

let getenv_home () =
  let home_var = if Sys.win32 then "APPDATA" else "HOME" in
  get_env home_var

let getenv_term () =
  let term_var = "TERM" in (* This variable does not exist on windows. *)
  get_env term_var

let path_sep = if Sys.win32 then ";" else ":"
let null_path = if Sys.win32 then "nul" else "/dev/null"
let temp_dir_name =
  if Sys.win32 then Filename.get_temp_dir_name () else "/tmp"

let getenv_path () =
  let path_var = "PATH" in (* Same variable on windows *)
  get_env path_var

let open_in_no_fail fn =
  try open_in fn
  with e ->
    let e = Printexc.to_string e in
    Printf.fprintf stderr "Could not open_in: '%s' (%s)\n" fn e;
    exit 3

let open_in_bin_no_fail fn =
  try open_in_bin fn
  with e ->
    let e = Printexc.to_string e in
    Printf.fprintf stderr "Could not open_in_bin: '%s' (%s)\n" fn e;
    exit 3

let close_in_no_fail fn ic =
  try close_in ic with e ->
    let e = Printexc.to_string e in
    Printf.fprintf stderr "Could not close: '%s' (%s)\n" fn e;
    exit 3

let open_out_no_fail fn =
  try open_out fn
  with e ->
    let e = Printexc.to_string e in
    Printf.fprintf stderr "Could not open_out: '%s' (%s)\n" fn e;
    exit 3

let open_out_bin_no_fail fn =
  try open_out_bin fn
  with e ->
    let e = Printexc.to_string e in
    Printf.fprintf stderr "Could not open_out_bin: '%s' (%s)\n" fn e;
    exit 3

let close_out_no_fail fn oc =
  try close_out oc with e ->
    let e = Printexc.to_string e in
    Printf.fprintf stderr "Could not close: '%s' (%s)\n" fn e;
    exit 3

let cat = Disk.cat

let cat_no_fail filename =
  let ic = open_in_bin_no_fail filename in
  let len = in_channel_length ic in
  let buf = Buffer.create len in
  Buffer.add_channel buf ic len;
  let content = Buffer.contents buf in
  close_in_no_fail filename ic;
  content

let nl_regexp = Str.regexp "[\r\n]"
let split_lines = Str.split nl_regexp

(** Returns true if substring occurs somewhere inside str. *)
let string_contains str substring =
  (* regexp_string matches only this string and nothing else. *)
  let re = Str.regexp_string substring in
  try (Str.search_forward re str 0) >= 0 with Not_found -> false

let exec_read cmd =
  let ic = Unix.open_process_in cmd in
  let result = input_line ic in
  assert (Unix.close_process_in ic = Unix.WEXITED 0);
  result

let exec_read_lines ?(reverse=false) cmd =
  let ic = Unix.open_process_in cmd in
  let result = ref [] in
  (try
     while true do
       result := input_line ic :: !result
     done;
   with End_of_file -> ());
  assert (Unix.close_process_in ic = Unix.WEXITED 0);
  if not reverse then List.rev !result else !result

(** Deletes the file given by "path". If it is a directory, recursively
 * deletes all its contents then removes the directory itself. *)
let rec rm_dir_tree path =
  try begin
    let stats = Unix.lstat path in
    match stats.Unix.st_kind with
    | Unix.S_DIR ->
        let contents = Sys.readdir path in
        List.iter (Array.to_list contents) ~f:(fun name ->
            let name = Filename.concat path name in
            rm_dir_tree name);
        Unix.rmdir path
    | Unix.S_LNK | Unix.S_REG | Unix.S_CHR | Unix.S_BLK | Unix.S_FIFO
    | Unix.S_SOCK ->
        Unix.unlink path
  end with
  (* Path has been deleted out from under us - can ignore it. *)
  | Sys_error(s) when s = Printf.sprintf "%s: No such file or directory" path ->
      ()
  | Unix.Unix_error(Unix.ENOENT, _, _) ->
      ()

let restart () =
  let cmd = Sys.argv.(0) in
  let argv = Sys.argv in
  Unix.execv cmd argv

let logname_impl () =
  match getenv_user () with
  | Some user -> user
  | None ->
      (* If this function is generally useful, it can be lifted to toplevel
         in this file, but this is the only place we need it for now. *)
      let exec_try_read cmd =
        let ic = Unix.open_process_in cmd in
        let out = try Some (input_line ic) with End_of_file -> None in
        let status = Unix.close_process_in ic in
        match out, status with
        | Some _, Unix.WEXITED 0 -> out
        | _ -> None in
      try Utils.unsafe_opt (exec_try_read "logname") with Invalid_argument _ ->
      try Utils.unsafe_opt (exec_try_read "id -un") with Invalid_argument _ ->
        "[unknown]"

let logname_ref = ref None
let logname () =
  if !logname_ref = None then logname_ref := Some (logname_impl ());
  Utils.unsafe_opt !logname_ref

let with_umask umask f =
  let old_umask = ref 0 in
  Utils.with_context
    ~enter:(fun () -> old_umask := Unix.umask umask)
    ~exit:(fun () -> ignore (Unix.umask !old_umask))
    ~do_:f
let with_umask umask f =
  if Sys.win32 then f () else with_umask umask f

let read_stdin_to_string () =
  let buf = Buffer.create 4096 in
  try
    while true do
      Buffer.add_string buf (input_line stdin);
      Buffer.add_char buf '\n'
    done;
    assert false
  with End_of_file ->
    Buffer.contents buf

let read_all ?(buf_size=4096) ic =
  let buf = Buffer.create buf_size in
  (try
     while true do
       let data = Bytes.create buf_size in
       let bytes_read = input ic data 0 buf_size in
       if bytes_read = 0 then raise Exit;
       Buffer.add_subbytes buf data 0 bytes_read;
     done
   with Exit -> ());
  Buffer.contents buf

(**
 * Like Python's os.path.expanduser, though probably doesn't cover some cases.
 * Roughly follow's bash's tilde expansion:
 * http://www.gnu.org/software/bash/manual/html_node/Tilde-Expansion.html
 *
 * ~/foo -> /home/bob/foo if $HOME = "/home/bob"
 * ~joe/foo -> /home/joe/foo if joe's home is /home/joe
*)
let expanduser path =
  Str.substitute_first
    (Str.regexp "^~\\([^/]*\\)")
    begin fun s ->
      match Str.matched_group 1 s with
      | "" ->
          begin
            match getenv_home () with
            | None -> (Unix.getpwuid (Unix.getuid())).Unix.pw_dir
            | Some home -> home
          end
      | unixname ->
          try (Unix.getpwnam unixname).Unix.pw_dir
          with Not_found -> Str.matched_string s end
    path

(* Turns out it's surprisingly complex to figure out the path to the current
   executable, which we need in order to extract its embedded libraries. If
   argv[0] is a path, then we can use that; sometimes it's just the exe name,
   so we have to search $PATH for it the same way shells do. for example:
   https://www.gnu.org/software/bash/manual/html_node/Command-Search-and-Execution.html
   There are other options which might be more reliable when they exist, like
   using the `_` env var set by bash, or /proc/self/exe on Linux, but they are
   not portable. *)
let executable_path : unit -> string =
  let executable_path_ = ref None in
  let dir_sep = Filename.dir_sep.[0] in
  let search_path path =
    let paths =
      match getenv_path () with
      | None -> failwith "Unable to determine executable path"
      | Some paths ->
          Str.split (Str.regexp_string path_sep) paths in
    let path = List.fold_left paths ~f:begin fun acc p ->
        match acc with
        | Some _ -> acc
        | None -> realpath (expanduser (Filename.concat p path))
      end ~init:None
    in
    match path with
    | Some path -> path
    | None -> failwith "Unable to determine executable path"
  in
  fun () -> match !executable_path_ with
    | Some path -> path
    | None ->
        let path = Sys.executable_name in
        let path =
          if String.contains path dir_sep then
            match realpath path with
            | Some path -> path
            | None -> failwith "Unable to determine executable path"
          else search_path path
        in
        executable_path_ := Some path;
        path

let lines_of_in_channel ic =
  let rec loop accum =
    match try Some(input_line ic) with _e -> None with
    | None -> List.rev accum
    | Some(line) -> loop (line::accum)
  in
  loop []

let lines_of_file filename =
  let ic = open_in filename in
  try
    let result = lines_of_in_channel ic in
    let _ = close_in ic in
    result
  with _ ->
    close_in ic;
    []


let read_file file =
  let ic = open_in_bin file  in
  let size = in_channel_length ic in
  let buf = String.create size in
  really_input ic buf 0 size;
  close_in ic;
  buf

let write_file ~file s =
  let chan = open_out file in
  (output_string chan s; close_out chan)

let append_file ~file s =
  let chan = open_out_gen [Open_wronly; Open_append; Open_creat] 0o666 file in
  (output_string chan s; close_out chan)

(* could be in control section too *)

let filemtime file =
  (Unix.stat file).Unix.st_mtime

external lutimes : string -> unit = "hh_lutimes"

let try_touch ~follow_symlinks file =
  try
    if follow_symlinks then Unix.utimes file 0.0 0.0
    else lutimes file
  with _ ->
    ()

let rec mkdir_p = function
  | "" -> failwith "Unexpected empty directory, should never happen"
  | d when not (Sys.file_exists d) ->
      mkdir_p (Filename.dirname d);
      Unix.mkdir d 0o770;
  | d when Sys.is_directory d -> ()
  | d -> raise (NotADirectory d)

(* Emulate "mkdir -p", i.e., no error if already exists. *)
let mkdir_no_fail dir =
  with_umask 0 begin fun () ->
    (* Don't set sticky bit since the socket opening code wants to remove any
     * old sockets it finds, which may be owned by a different user. *)
    try Unix.mkdir dir 0o777 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
  end

let unlink_no_fail fn =
  try Unix.unlink fn with Unix.Unix_error (Unix.ENOENT, _, _) -> ()

let readlink_no_fail fn =
  if Sys.win32 && Sys.file_exists fn then
    cat fn
  else
    try Unix.readlink fn with _ -> fn

let splitext filename =
  let root = Filename.chop_extension filename in
  let root_length = String.length root in
  (* -1 because the extension includes the period, e.g. ".foo" *)
  let ext_length = String.length filename - root_length - 1 in
  let ext = String.sub filename (root_length + 1) ext_length in
  root, ext

let is_test_mode () =
  try
    ignore @@ Sys.getenv "HH_TEST_MODE";
    true
  with _ -> false

let symlink =
  (* Dummy implementation of `symlink` on Windows: we create a text
     file containing the targeted-file's path. Symlink are available
     on Windows since Vista, but until Seven (included), one should
     have administratrive rights in order to create symlink. *)
  let win32_symlink source dest = write_file ~file:dest source in
  if Sys.win32
  then win32_symlink
  else
    (* 4.03 adds an optional argument to Unix.symlink that we want to ignore
    *)
    fun source dest -> Unix.symlink source dest

(* Creates a symlink at <dir>/<linkname.ext> to
 * <dir>/<pluralized ext>/<linkname>-<timestamp>.<ext> *)
let make_link_of_timestamped linkname =
  let open Unix in
  let dir = Filename.dirname linkname in
  mkdir_no_fail dir;
  let base = Filename.basename linkname in
  let base, ext = splitext base in
  let dir = Filename.concat dir (Printf.sprintf "%ss" ext) in
  mkdir_no_fail dir;
  let tm = localtime (time ()) in
  let year = tm.tm_year + 1900 in
  let time_str = Printf.sprintf "%d-%02d-%02d-%02d-%02d-%02d"
      year (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec in
  let filename = Filename.concat dir
      (Printf.sprintf "%s-%s.%s" base time_str ext) in
  unlink_no_fail linkname;
  symlink filename linkname;
  filename

let setsid =
  (* Not implemented on Windows. Let's just return the pid *)
  if Sys.win32 then Unix.getpid else Unix.setsid

let set_signal = if not Sys.win32 then Sys.set_signal else (fun _ _ -> ())
let signal =
  if not Sys.win32
  then (fun a b -> ignore (Sys.signal a b))
  else (fun _ _ -> ())

external get_total_ram : unit -> int = "hh_sysinfo_totalram"
external uptime : unit -> int = "hh_sysinfo_uptime"
external nproc: unit -> int = "nproc"

let total_ram = get_total_ram ()
let nbr_procs = nproc ()

external set_priorities : cpu_priority:int -> io_priority:int -> unit =
  "hh_set_priorities"

external pid_of_handle: int -> int = "pid_of_handle"
external handle_of_pid_for_termination: int -> int =
  "handle_of_pid_for_termination"

let terminate_process pid = Unix.kill pid Sys.sigkill

let lstat path =
  (* WTF, on Windows `lstat` fails if a directory path ends with an
     '/' (or a '\', whatever) *)
  Unix.lstat @@
  if Sys.win32 && String_utils.string_ends_with path Filename.dir_sep then
    String.sub path 0 (String.length path - 1)
  else
    path

let normalize_filename_dir_sep =
  let dir_sep_char = String.get Filename.dir_sep 0 in
  String.map (fun c -> if c = dir_sep_char then '/' else c)


let name_of_signal = function
  | s when s = Sys.sigabrt -> "SIGABRT (Abnormal termination)"
  | s when s = Sys.sigalrm -> "SIGALRM (Timeout)"
  | s when s = Sys.sigfpe -> "SIGFPE (Arithmetic exception)"
  | s when s = Sys.sighup -> "SIGHUP (Hangup on controlling terminal)"
  | s when s = Sys.sigill -> "SIGILL (Invalid hardware instruction)"
  | s when s = Sys.sigint -> "SIGINT (Interactive interrupt (ctrl-C))"
  | s when s = Sys.sigkill -> "SIGKILL (Termination)"
  | s when s = Sys.sigpipe -> "SIGPIPE (Broken pipe)"
  | s when s = Sys.sigquit -> "SIGQUIT (Interactive termination)"
  | s when s = Sys.sigsegv -> "SIGSEGV (Invalid memory reference)"
  | s when s = Sys.sigterm -> "SIGTERM (Termination)"
  | s when s = Sys.sigusr1 -> "SIGUSR1 (Application-defined signal 1)"
  | s when s = Sys.sigusr2 -> "SIGUSR2 (Application-defined signal 2)"
  | s when s = Sys.sigchld -> "SIGCHLD (Child process terminated)"
  | s when s = Sys.sigcont -> "SIGCONT (Continue)"
  | s when s = Sys.sigstop -> "SIGSTOP (Stop)"
  | s when s = Sys.sigtstp -> "SIGTSTP (Interactive stop)"
  | s when s = Sys.sigttin -> "SIGTTIN (Terminal read from background process)"
  | s when s = Sys.sigttou -> "SIGTTOU (Terminal write from background process)"
  | s when s = Sys.sigvtalrm -> "SIGVTALRM (Timeout in virtual time)"
  | s when s = Sys.sigprof -> "SIGPROF (Profiling interrupt)"
  | s when s = Sys.sigbus -> "SIGBUS (Bus error)"
  | s when s = Sys.sigpoll -> "SIGPOLL (Pollable event)"
  | s when s = Sys.sigsys -> "SIGSYS (Bad argument to routine)"
  | s when s = Sys.sigtrap -> "SIGTRAP (Trace/breakpoint trap)"
  | s when s = Sys.sigurg -> "SIGURG (Urgent condition on socket)"
  | s when s = Sys.sigxcpu -> "SIGXCPU (Timeout in cpu time)"
  | s when s = Sys.sigxfsz -> "SIGXFSZ (File size limit exceeded)"
  | other -> string_of_int other
OCaml

Innovation. Community. Security.