<commit_before>(*
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the "hack" directory of this source tree.
 *
 *)

open Hh_core

(* Don't change the ordering of this record without updating hh_shared_init in
 * hh_shared.c, which indexes into config objects *)
type config = {
  global_size: int;
  heap_size: int;
  dep_table_pow: int;
  hash_table_pow: int;
  shm_dirs: string list;
  shm_min_avail: int;
  log_level: int;
  sample_rate: float;
}

(* Allocated in C only. *)
type handle = private {
  h_fd: Unix.file_descr;
  h_global_size: int;
  h_heap_size: int;
}

exception Out_of_shared_memory

exception Hash_table_full

exception Dep_table_full

exception Heap_full

exception Revision_length_is_zero

exception Sql_assertion_failure of int

exception Failed_anonymous_memfd_init

exception Less_than_minimum_available of int

exception Failed_to_use_shm_dir of string

exception C_assertion_failure of string

let () =
  Callback.register_exception "out_of_shared_memory" Out_of_shared_memory;
  Callback.register_exception "hash_table_full" Hash_table_full;
  Callback.register_exception "dep_table_full" Dep_table_full;
  Callback.register_exception "heap_full" Heap_full;
  Callback.register_exception "revision_length_is_zero" Revision_length_is_zero;
  Callback.register_exception "sql_assertion_failure" (Sql_assertion_failure 0);
  Callback.register_exception
    "failed_anonymous_memfd_init"
    Failed_anonymous_memfd_init;
  Callback.register_exception
    "less_than_minimum_available"
    (Less_than_minimum_available 0);
  Callback.register_exception
    "c_assertion_failure"
    (C_assertion_failure "dummy string")

(*****************************************************************************)
(* Initializes the shared memory. Must be called before forking. *)
(*****************************************************************************)
external hh_shared_init :
  config:config -> shm_dir:string option -> num_workers:int -> handle
  = "hh_shared_init"

let anonymous_init config ~num_workers =
  hh_shared_init ~config ~shm_dir:None ~num_workers

let rec shm_dir_init config ~num_workers = function
  | [] ->
    Hh_logger.log "We've run out of filesystems to use for shared memory";
    raise Out_of_shared_memory
  | shm_dir :: shm_dirs ->
    let shm_min_avail = config.shm_min_avail in
    begin
      (* For some reason statvfs is segfaulting when the directory doesn't
       * exist, instead of returning -1 and an errno *)
      try
        if not (Sys.file_exists shm_dir) then
          raise (Failed_to_use_shm_dir "shm_dir does not exist");
        hh_shared_init ~config ~shm_dir:(Some shm_dir) ~num_workers
      with
      | Less_than_minimum_available avail ->
        EventLogger.(
          log_if_initialized (fun () ->
              sharedmem_less_than_minimum_available
                ~shm_dir
                ~shm_min_avail
                ~avail));
        if !Utils.debug then
          Hh_logger.log
            "Filesystem %s only has %d bytes available, which is less than the minimum %d bytes"
            shm_dir
            avail
            config.shm_min_avail;
        shm_dir_init config ~num_workers shm_dirs
      | Unix.Unix_error (e, fn, arg) ->
        let fn_string =
          if fn = "" then
            ""
          else
            Utils.spf " thrown by %s(%s)" fn arg
        in
        let reason =
          Utils.spf "Unix error%s: %s" fn_string (Unix.error_message e)
        in
        EventLogger.(
          log_if_initialized (fun () ->
              sharedmem_failed_to_use_shm_dir ~shm_dir ~reason));
        if !Utils.debug then
          Hh_logger.log "Failed to use shm dir `%s`: %s" shm_dir reason;
        shm_dir_init config ~num_workers shm_dirs
      | Failed_to_use_shm_dir reason ->
        EventLogger.(
          log_if_initialized (fun () ->
              sharedmem_failed_to_use_shm_dir ~shm_dir ~reason));
        if !Utils.debug then
          Hh_logger.log "Failed to use shm dir `%s`: %s" shm_dir reason;
        shm_dir_init config ~num_workers shm_dirs
    end

let init config ~num_workers =
  try anonymous_init config ~num_workers
  with Failed_anonymous_memfd_init ->
    EventLogger.(
      log_if_initialized (fun () -> sharedmem_failed_anonymous_memfd_init ()));
    if !Utils.debug then Hh_logger.log "Failed to use anonymous memfd init";
    shm_dir_init config ~num_workers config.shm_dirs

external allow_removes : bool -> unit = "hh_allow_removes"

external allow_hashtable_writes_by_current_process : bool -> unit
  = "hh_allow_hashtable_writes_by_current_process"

external connect : handle -> worker_id:int -> unit = "hh_connect"

(*****************************************************************************)
(* The shared memory garbage collector. It must be called every time we
 * free data (cf hh_shared.c for the underlying C implementation).
 *)
(*****************************************************************************)
external hh_collect : unit -> unit = "hh_collect" [@@noalloc]

(*****************************************************************************)
(* Serializes the dependency table and writes it to a file *)
(*****************************************************************************)

external loaded_dep_table_filename_c : unit -> string
  = "hh_get_loaded_dep_table_filename"

external get_in_memory_dep_table_entry_count : unit -> int
  = "hh_get_in_memory_dep_table_entry_count"

let loaded_dep_table_filename () =
  let fn = loaded_dep_table_filename_c () in
  if String.equal "" fn then<commit_msg>[hack] remove Utils.debug in shared_mem.ml<commit_after>(*
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the "hack" directory of this source tree.
 *
 *)

open Hh_core

(* Don't change the ordering of this record without updating hh_shared_init in
 * hh_shared.c, which indexes into config objects *)
type config = {
  global_size: int;
  heap_size: int;
  dep_table_pow: int;
  hash_table_pow: int;
  shm_dirs: string list;
  shm_min_avail: int;
  log_level: int;
  sample_rate: float;
}

(* Allocated in C only. *)
type handle = private {
  h_fd: Unix.file_descr;
  h_global_size: int;
  h_heap_size: int;
}

exception Out_of_shared_memory

exception Hash_table_full

exception Dep_table_full

exception Heap_full

exception Revision_length_is_zero

exception Sql_assertion_failure of int

exception Failed_anonymous_memfd_init

exception Less_than_minimum_available of int

exception Failed_to_use_shm_dir of string

exception C_assertion_failure of string

let () =
  Callback.register_exception "out_of_shared_memory" Out_of_shared_memory;
  Callback.register_exception "hash_table_full" Hash_table_full;
  Callback.register_exception "dep_table_full" Dep_table_full;
  Callback.register_exception "heap_full" Heap_full;
  Callback.register_exception "revision_length_is_zero" Revision_length_is_zero;
  Callback.register_exception "sql_assertion_failure" (Sql_assertion_failure 0);
  Callback.register_exception
    "failed_anonymous_memfd_init"
    Failed_anonymous_memfd_init;
  Callback.register_exception
    "less_than_minimum_available"
    (Less_than_minimum_available 0);
  Callback.register_exception
    "c_assertion_failure"
    (C_assertion_failure "dummy string")

(*****************************************************************************)
(* Initializes the shared memory. Must be called before forking. *)
(*****************************************************************************)
external hh_shared_init :
  config:config -> shm_dir:string option -> num_workers:int -> handle
  = "hh_shared_init"

let anonymous_init config ~num_workers =
  hh_shared_init ~config ~shm_dir:None ~num_workers

let rec shm_dir_init config ~num_workers = function
  | [] ->
    Hh_logger.log "We've run out of filesystems to use for shared memory";
    raise Out_of_shared_memory
  | shm_dir :: shm_dirs ->
    let shm_min_avail = config.shm_min_avail in
    begin
      (* For some reason statvfs is segfaulting when the directory doesn't
       * exist, instead of returning -1 and an errno *)
      try
        if not (Sys.file_exists shm_dir) then
          raise (Failed_to_use_shm_dir "shm_dir does not exist");
        hh_shared_init ~config ~shm_dir:(Some shm_dir) ~num_workers
      with
      | Less_than_minimum_available avail ->
        EventLogger.(
          log_if_initialized (fun () ->
              sharedmem_less_than_minimum_available
                ~shm_dir
                ~shm_min_avail
                ~avail));
        Hh_logger.log
          "Filesystem %s only has %d bytes available, which is less than the minimum %d bytes"
          shm_dir
          avail
          config.shm_min_avail;
        shm_dir_init config ~num_workers shm_dirs
      | Unix.Unix_error (e, fn, arg) ->
        let fn_string =
          if fn = "" then
            ""
          else
            Utils.spf " thrown by %s(%s)" fn arg
        in
        let reason =
          Utils.spf "Unix error%s: %s" fn_string (Unix.error_message e)
        in
        EventLogger.(
          log_if_initialized (fun () ->
              sharedmem_failed_to_use_shm_dir ~shm_dir ~reason));
        Hh_logger.log "Failed to use shm dir `%s`: %s" shm_dir reason;
        shm_dir_init config ~num_workers shm_dirs
      | Failed_to_use_shm_dir reason ->
        EventLogger.(
          log_if_initialized (fun () ->
              sharedmem_failed_to_use_shm_dir ~shm_dir ~reason));
        Hh_logger.log "Failed to use shm dir `%s`: %s" shm_dir reason;
        shm_dir_init config ~num_workers shm_dirs
    end

let init config ~num_workers =
  try anonymous_init config ~num_workers
  with Failed_anonymous_memfd_init ->
    EventLogger.(
      log_if_initialized (fun () -> sharedmem_failed_anonymous_memfd_init ()));
    Hh_logger.log "Failed to use anonymous memfd init";
    shm_dir_init config ~num_workers config.shm_dirs

external allow_removes : bool -> unit = "hh_allow_removes"

external allow_hashtable_writes_by_current_process : bool -> unit
  = "hh_allow_hashtable_writes_by_current_process"

external connect : handle -> worker_id:int -> unit = "hh_connect"

(*****************************************************************************)
(* The shared memory garbage collector. It must be called every time we
 * free data (cf hh_shared.c for the underlying C implementation).
 *)
(*****************************************************************************)
external hh_collect : unit -> unit = "hh_collect" [@@noalloc]

(*****************************************************************************)
(* Serializes the dependency table and writes it to a file *)
(*****************************************************************************)

external loaded_dep_table_filename_c : unit -> string
  = "hh_get_loaded_dep_table_filename"

external get_in_memory_dep_table_entry_count : unit -> int
  = "hh_get_in_memory_dep_table_entry_count"

let loaded_dep_table_filename () =
  let fn = loaded_dep_table_filename_c () in
  if String.equal "" fn then
{'fraction_non_alphanumeric': 0.1509467508222953, 'fraction_numerical': 0.0012445550715619166, 'mean_word_length': 3.8345509239363986, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 43, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1166778', 'n_tokens_mistral': 3501, 'n_tokens_neox': 3365, 'n_words': 873}