├── .github └── workflows │ └── build.yaml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── dune ├── dune-project ├── hack_parallel.ml ├── hack_parallel.mli ├── hack_parallel.opam ├── scripts ├── dune ├── gen_build_id.ml └── script_utils.ml └── src ├── heap ├── dune ├── hh_assert.c ├── hh_assert.h ├── hh_shared.c ├── hh_shared.h ├── hh_shared_sqlite.c ├── hh_shared_sqlite.h ├── prefix.ml ├── prefix.mli ├── sharedMem.ml ├── sharedMem.mli ├── value.ml ├── value.mli ├── workerCancel.ml └── workerCancel.mli ├── injection └── default_injector │ ├── dune │ ├── injector_config.ml │ └── injector_config.mli ├── interface ├── dune ├── hack_parallel_intf.ml ├── hack_parallel_intf.mli ├── memory.ml ├── memory.mli ├── scheduler.ml └── scheduler.mli ├── procs ├── dune ├── hack_bucket.ml ├── hack_bucket.mli ├── multiWorker.ml ├── multiWorker.mli ├── worker.ml └── worker.mli ├── socket ├── dune └── socket.ml ├── stubs ├── dune └── eventLogger.ml ├── third-party ├── hack_core │ ├── LICENSE │ ├── VERSION │ ├── dune │ ├── hack_caml.ml │ ├── hack_commutative_group.ml │ ├── hack_container.ml │ ├── hack_core_list.ml │ ├── hack_core_printf.ml │ ├── hack_monad.ml │ ├── hack_option.ml │ ├── hack_poly.ml │ ├── hack_polymorphic_compare.ml │ ├── hack_polymorphic_compare.mli │ ├── hack_result.ml │ └── hack_result.mli ├── inotify │ ├── LICENSE │ ├── dune │ └── inotify_stubs.c └── lz4 │ ├── LICENSE │ ├── Makefile │ ├── README.md │ ├── VERSION │ ├── dune │ ├── liblz4.pc.in │ ├── lz4.c │ ├── lz4.h │ ├── lz4frame.c │ ├── lz4frame.h │ ├── lz4frame_static.h │ ├── lz4hc.c │ ├── lz4hc.h │ ├── xxhash.c │ └── xxhash.h └── utils ├── collections ├── dune ├── iMap.ml ├── iSet.ml ├── intKey.ml ├── myMap.ml ├── myMap.mli ├── myMap_sig.ml ├── sMap.ml ├── sSet.ml └── stringKey.ml ├── daemon.ml ├── daemon.mli ├── disk ├── disk.ml ├── disk.mli ├── disk_sig.ml ├── dune ├── realDisk.ml ├── testDisk.ml └── testDisk.mli ├── dune ├── exit_status.ml ├── files.c ├── fork.ml ├── hack_core.ml ├── hack_path.ml ├── hack_path.mli ├── handle.ml ├── handle_stubs.c ├── hh_json ├── dune ├── hh_json.ml └── hh_json.mli ├── hh_logger.ml ├── lock.ml ├── marshal_tools.ml ├── marshal_tools.mli ├── measure.ml ├── measure.mli ├── nproc.c ├── pidLog.ml ├── printSignal.ml ├── priorities.c ├── realpath.c ├── stats.ml ├── string_utils.ml ├── sys_utils.ml ├── sysinfo.c ├── timeout.ml ├── timeout.mli └── utils.ml /.github/workflows/build.yaml: -------------------------------------------------------------------------------- 1 | name: Build 2 | on: [push] 3 | jobs: 4 | build: 5 | name: Build 6 | strategy: 7 | fail-fast: false 8 | matrix: 9 | os: 10 | - macos-latest 11 | - ubuntu-latest 12 | ocaml-version: 13 | - '4.08.1' 14 | - '4.09.0' 15 | runs-on: ${{ matrix.os }} 16 | steps: 17 | - uses: actions/checkout@v2 18 | - name: OCaml setup ${{ matrix.ocaml-version }} 19 | uses: avsm/setup-ocaml@master 20 | with: 21 | ocaml-version: ${{ matrix.ocaml-version }} 22 | # - name: Setup tmate session 23 | # uses: mxschmitt/action-tmate@v1 24 | - run: opam pin add hack_parallel.dev -n . 25 | - run: opam depext -yt hack_parallel 26 | - run: opam install -t . --deps-only 27 | - run: opam exec -- dune build 28 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | /hack_parallel.install 3 | *.merlin 4 | *.swp 5 | *.a 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2013-present, Facebook, Inc. 4 | Modified work Copyright (c) 2018-2019 Rijnard van Tonder 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: 3 | dune build -j auto --profile dev 4 | 5 | install: 6 | dune install 7 | 8 | .PHONY: clean 9 | clean: 10 | dune clean 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # README 2 | 3 | This library contains the core parallel and shared memory components used in [Hack](https://github.com/facebook/hhvm/tree/master/hphp/hack), [Flow](https://github.com/facebook/flow), and [Pyre](https://github.com/facebook/pyre-check). 4 | The internals of these components are little known outside of these projects, yet stand to benefit the OCaml community more generally, both 5 | for practical use and educational purposes. 6 | 7 | This library extracts the core components, wraps them in a tidier interface, and builds with dune. It is a personal best effort 8 | and offered 'as-is': there is no promise of maintenance, and no official support or affiliation with the projects and/or companies 9 | supporting the projects above. 10 | 11 | The code contains potentially leftover and irrelevant functions (again, best effort), and do not necessarily have the most recent upstream changes of corresponding modules. This is especially the case for 12 | modules in [procs](https://github.com/rvantonder/hack-parallel/tree/master/src/procs) and [heap](https://github.com/rvantonder/hack-parallel/tree/master/src/heap) (cf. respective [procs](https://github.com/facebook/hhvm/tree/master/hphp/hack/src/procs) and [heap](https://github.com/facebook/hhvm/tree/master/hphp/hack/src/heap) in Hack). Pull requests for 13 | upstream changes to these files are welcome. The files in the current library are current as of around mid-2018. 14 | 15 | # Install and Example 16 | 17 | Hack_parallel is available on opam: 18 | 19 | - Note: this is only available for opam 2. See [how to install opam 2](https://opam.ocaml.org/doc/Install.html). 20 | 21 | ``` 22 | opam install hack_parallel 23 | ``` 24 | 25 | Please see the example project here to get a feel for the interface: https://github.com/rvantonder/hack-parallel-example 26 | 27 | # Some more details 28 | 29 | The design decisions behind the parallel architecture and shared memory are best explained by this [video](https://www.youtube.com/watch?v=uXuYVUdFY48&t=0s&list=WL&index=28) 30 | and this part of the [documentation](https://github.com/rvantonder/hack-parallel/blob/master/src/heap/hh_shared.c#L10-L76). 31 | You can ignore the scary `THIS CODE ONLY WORKS WITH HACK`--the code does work generally, but you have to keep in mind the 32 | restrictions on memory operations as explained in the rest of the file. The motivation behind the shared memory implementation is similar to [ancient](http://git.annexia.org/?p=ocaml-ancient.git;a=blob;f=README.txt;h=e2d9103d5f1820f89e5fd9e18f245cc330e8b29d;hb=HEAD). 33 | 34 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags (:standard -w A-3-4-23-40-41-42-44-45-48-49-50-57-60)) 4 | (ocamlopt_flags (-g -Oclassic))) 5 | (release 6 | (flags (:standard -w A-3-4-23-40-41-42-44-45-48-49-50-57-60)) 7 | (ocamlopt_flags (-O3)))) 8 | 9 | (library 10 | (name hack_parallel) 11 | (public_name hack_parallel) 12 | (library_flags (-cclib -l -cclib pthread -cclib -l -cclib sqlite3)) 13 | (libraries 14 | hack_parallel.scheduler 15 | hack_parallel.memory)) 16 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.11) 2 | (name hack_parallel) 3 | -------------------------------------------------------------------------------- /hack_parallel.ml: -------------------------------------------------------------------------------- 1 | module Scheduler = Scheduler 2 | module Memory = Memory 3 | -------------------------------------------------------------------------------- /hack_parallel.mli: -------------------------------------------------------------------------------- 1 | module Scheduler : sig 2 | 3 | module Daemon : sig 4 | val check_entry_point : unit -> unit 5 | end 6 | 7 | type t 8 | 9 | val create : ?number_of_workers:int -> ?bucket_multiplier:int -> unit -> t 10 | 11 | val map_reduce 12 | : t 13 | -> ?bucket_size:int 14 | -> init:'a 15 | -> map:('a -> 'b list -> 'c) 16 | -> reduce:('c -> 'a -> 'a) 17 | -> 'b list 18 | -> 'a 19 | 20 | val iter : t -> f:('a list -> unit) -> 'a list -> unit 21 | 22 | val single_job : t -> f:('a -> 'b) -> 'a -> 'b 23 | 24 | val mock : unit -> t 25 | 26 | val destroy : t -> unit 27 | end 28 | 29 | module Memory : module type of Memory 30 | -------------------------------------------------------------------------------- /hack_parallel.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Rijnard van Tonder " 3 | authors: "Facebook. Modifications by Rijnard van Tonder" 4 | homepage: "https://github.com/rvantonder/hack_parallel" 5 | bug-reports: "https://github.com/rvantonder/hack_parallel/issues" 6 | dev-repo: "git+https://github.com/rvantonder/hack_parallel.git" 7 | license: "MIT" 8 | build: [ 9 | ["dune" "build" "-p" name "-j" jobs "@install"] 10 | ] 11 | depends: [ 12 | "ocaml" {>= "4.04.1"} 13 | "dune" {>= "1.11"} 14 | "conf-pkg-config" 15 | "conf-sqlite3" 16 | "core" {< "v0.15"} 17 | "ppx_deriving" 18 | "ppxlib" 19 | "sexplib" {< "v0.15"} 20 | ] 21 | synopsis: "Parallel and shared memory library" 22 | description: """ 23 | Parallel and shared memory components used in Facebook's Hack, Flow, and Pyre 24 | projects. 25 | """ 26 | -------------------------------------------------------------------------------- /scripts/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets get_build_id.c) 3 | (deps gen_build_id.ml script_utils.ml) 4 | (action 5 | (run ocaml -I scripts -w -3 unix.cma gen_build_id.ml get_build_id.c))) 6 | -------------------------------------------------------------------------------- /scripts/gen_build_id.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2013-present, Facebook, Inc. 3 | * 4 | * This source code is licensed under the MIT license found in the 5 | * LICENSE file in the root directory of this source tree. 6 | *) 7 | 8 | #use "script_utils.ml" 9 | 10 | (** 11 | * Computes some build identifiers based on the current commit. These IDs are 12 | * used to ensure that clients and servers are the same version, even between 13 | * releases. For example, if you build revision A and start a server, then check 14 | * out and build revision B, it's convenient for the server to restart itself 15 | * using revision B. 16 | * 17 | * This fails gracefully when neither hg nor git are installed, or when neither 18 | * .hg nor .git exist (e.g. when building from a tarball). This is fine because 19 | * you can't move between commits in such a snapshot. 20 | *) 21 | let () = 22 | let out_file = Sys.argv.(1) in 23 | let rev = 24 | try read_process_stdout "git" [|"git"; "rev-parse"; "HEAD"|] 25 | with Failure msg -> ( 26 | Printf.eprintf "Failed git rev-parse: %s\n%!" msg; 27 | try read_process_stdout "hg" [|"hg"; "id"; "-i"|] 28 | with Failure msg -> ( 29 | Printf.eprintf "Failed hg id: %s\n%!" msg; 30 | "" 31 | ) 32 | ) 33 | in 34 | let time = 35 | try read_process_stdout "git" [|"git"; "log"; "-1"; "--pretty=tformat:%ct"|] 36 | with Failure msg -> ( 37 | Printf.eprintf "Failed git log: %s\n%!" msg; 38 | try 39 | let raw = read_process_stdout "hg" [|"hg"; "log"; "-r"; "."; "-T"; "{date|hgdate}\\n"|] in 40 | String.sub raw 0 (String.index raw ' ') 41 | with 42 | | Failure msg -> ( 43 | Printf.eprintf "Failed hg log: %s\n%!" msg; 44 | "0" 45 | ) 46 | | Not_found -> "0" 47 | ) 48 | in 49 | let content = Printf.sprintf 50 | "const char* const BuildInfo_kRevision = %S;\nconst unsigned long BuildInfo_kRevisionCommitTimeUnix = %sul;\n" 51 | rev time in 52 | let do_dump = 53 | not (Sys.file_exists out_file) || string_of_file out_file <> content in 54 | if do_dump then 55 | with_out_channel out_file @@ fun oc -> 56 | output_string oc content 57 | -------------------------------------------------------------------------------- /scripts/script_utils.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2013-present, Facebook, Inc. 3 | * 4 | * This source code is licensed under the MIT license found in the 5 | * LICENSE file in the root directory of this source tree. 6 | *) 7 | 8 | let with_pipe f = 9 | let fd_r, fd_w = Unix.pipe () in 10 | try 11 | let res = f (fd_r, fd_w) in 12 | Unix.close fd_r; 13 | Unix.close fd_w; 14 | res 15 | with exn -> 16 | Unix.close fd_r; 17 | Unix.close fd_w; 18 | raise exn 19 | 20 | let with_in_channel filename f = 21 | let ic = open_in_bin filename in 22 | try let res = f ic in close_in ic; res 23 | with exn -> close_in ic; raise exn 24 | 25 | let with_out_channel filename f = 26 | let oc = open_out_bin filename in 27 | try let res = f oc in close_out oc; res 28 | with exn -> close_out oc; raise exn 29 | 30 | let read_process name args (in_r, _in_w) (out_r, out_w) (err_r, err_w) = 31 | let pid = 32 | try Unix.create_process name args in_r out_w err_w 33 | with Unix.Unix_error (Unix.ENOENT, _, _) -> 34 | (* On Windows, this is what happens if you call create_process 35 | * non_existent_thing *) 36 | raise (Failure (name ^ ": command not found")) 37 | in 38 | match Unix.waitpid [] pid with 39 | | _, Unix.WEXITED 0 -> 40 | input_line (Unix.in_channel_of_descr out_r) 41 | | _, Unix.WEXITED 127 -> 42 | (* On Linux & OSX, this is what happens if you call create_process 43 | * non_existent_thing *) 44 | raise (Failure (name ^ ": command not found")) 45 | | _, Unix.WEXITED 128 -> 46 | raise (Failure (input_line (Unix.in_channel_of_descr err_r))) 47 | | _, Unix.WEXITED code -> 48 | raise (Failure (name ^ ": exited code "^(string_of_int code))) 49 | | _, Unix.WSIGNALED signal -> 50 | raise (Failure (name ^ ": killed by signal " ^ (string_of_int signal))) 51 | | _, Unix.WSTOPPED signal -> 52 | raise (Failure (name ^ ": stopped by signal " ^ (string_of_int signal))) 53 | 54 | (* Read the first line in stdout or stderr of an external command. *) 55 | let read_process_output name args = 56 | with_pipe @@ fun in_pipe -> 57 | with_pipe @@ fun out_pipe -> 58 | read_process name args in_pipe out_pipe out_pipe 59 | 60 | (* Read the first line in stdout of an external command. *) 61 | let read_process_stdout name args = 62 | with_pipe @@ fun in_pipe -> 63 | with_pipe @@ fun out_pipe -> 64 | with_pipe @@ fun err_pipe -> 65 | read_process name args in_pipe out_pipe err_pipe 66 | 67 | let string_of_file filename = 68 | with_in_channel filename @@ fun ic -> 69 | let s = Bytes.create 32759 in 70 | let b = Buffer.create 1000 in 71 | let rec iter ic b s = 72 | let nread = input ic s 0 32759 in 73 | if nread > 0 then begin 74 | Buffer.add_subbytes b s 0 nread; 75 | iter ic b s 76 | end in 77 | iter ic b s; 78 | Buffer.contents b 79 | -------------------------------------------------------------------------------- /src/heap/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name heap) 3 | (public_name hack_parallel.heap) 4 | (wrapped false) 5 | (modules (:standard)) 6 | (c_names 7 | hh_assert 8 | hh_shared 9 | hh_shared_sqlite) 10 | (c_flags (:standard -I%{project_root}/src/third-party/lz4)) 11 | (c_library_flags (-lsqlite3)) 12 | (libraries 13 | hack_parallel.collections 14 | hack_parallel.lz4 15 | hack_parallel.stubs 16 | hack_parallel.utils)) 17 | -------------------------------------------------------------------------------- /src/heap/hh_assert.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the MIT license found in the 6 | * LICENSE file in the "hack" directory of this source tree. 7 | * 8 | */ 9 | 10 | #include "hh_assert.h" 11 | 12 | #define CAML_NAME_SPACE 13 | #include 14 | #include 15 | 16 | void raise_assertion_failure(char * msg) { 17 | caml_raise_with_string(*caml_named_value("c_assertion_failure"), msg); 18 | } 19 | -------------------------------------------------------------------------------- /src/heap/hh_assert.h: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the MIT license found in the 6 | * LICENSE file in the "hack" directory of this source tree. 7 | * 8 | */ 9 | 10 | #ifndef HH_ASSERT_H 11 | #define HH_ASSERT_H 12 | void raise_assertion_failure(char * msg); 13 | 14 | /** 15 | * Concatenate the __LINE__ and __FILE__ strings in a macro. 16 | */ 17 | #define S1(x) #x 18 | #define S2(x) S1(x) 19 | #define LOCATION __FILE__ " : " S2(__LINE__) 20 | #define assert(f) ((f) ? 0 : raise_assertion_failure(LOCATION)) 21 | #endif 22 | -------------------------------------------------------------------------------- /src/heap/hh_shared.h: -------------------------------------------------------------------------------- 1 | #ifndef HH_SHARED_H 2 | #define HH_SHARED_H 3 | 4 | #define CAML_NAME_SPACE 5 | #include 6 | 7 | /*****************************************************************************/ 8 | /* Initialization & connection. */ 9 | /*****************************************************************************/ 10 | /* Initializes the shared heap. */ 11 | /* Must be called by the master BEFORE forking the workers! */ 12 | CAMLprim value hh_shared_init( value config_val, value shm_dir_val); 13 | value hh_check_heap_overflow(void); 14 | /* Must be called by every worker before any operation is performed. */ 15 | value hh_connect(value connector); 16 | 17 | /* Reset the shared memory to its initial state */ 18 | void pyre_reset(void); 19 | 20 | /*****************************************************************************/ 21 | /* Heap diagnostics. */ 22 | /*****************************************************************************/ 23 | CAMLprim value hh_used_heap_size(void); 24 | CAMLprim value hh_wasted_heap_size(void); 25 | CAMLprim value hh_heap_size(void); 26 | CAMLprim value hh_log_level(void); 27 | CAMLprim value hh_hash_used_slots(void); 28 | CAMLprim value hh_hash_slots(void); 29 | 30 | /* Provides a counter which increases over the lifetime of the program 31 | * including all forks. Uses a global until hh_shared_init is called. 32 | * Safe to use in the early init stages of the program, as long as you fork 33 | * after hh_shared_init. Wraps around at the maximum value of an ocaml int. 34 | */ 35 | CAMLprim value hh_counter_next(void); 36 | 37 | /*****************************************************************************/ 38 | /* Worker management. */ 39 | /*****************************************************************************/ 40 | CAMLprim value hh_stop_workers(void); 41 | CAMLprim value hh_resume_workers(void); 42 | CAMLprim value hh_check_should_exit(void); 43 | CAMLprim value hh_set_can_worker_stop(value val); 44 | 45 | /*****************************************************************************/ 46 | /* Global storage. */ 47 | /*****************************************************************************/ 48 | void hh_shared_store(value data); 49 | CAMLprim value hh_shared_load(void); 50 | void hh_shared_clear(void); 51 | 52 | 53 | /*****************************************************************************/ 54 | /* Garbage collection. */ 55 | /*****************************************************************************/ 56 | CAMLprim value hh_collect(void); 57 | 58 | /*****************************************************************************/ 59 | /* Deserialization. */ 60 | /*****************************************************************************/ 61 | /* Returns the value associated to a given key, and deserialize it. */ 62 | /* The key MUST be present. */ 63 | CAMLprim value hh_get_and_deserialize(value key); 64 | 65 | /*****************************************************************************/ 66 | /* Dependency table operations. */ 67 | /*****************************************************************************/ 68 | void hh_add_dep(value ocaml_dep); 69 | CAMLprim value hh_dep_used_slots(void); 70 | CAMLprim value hh_dep_slots(void); 71 | CAMLprim value hh_get_dep(value ocaml_key); 72 | 73 | /*****************************************************************************/ 74 | /* Hashtable operations. */ 75 | /*****************************************************************************/ 76 | /* Returns the size of the value associated to a given key. 77 | * The key MUST be present. 78 | */ 79 | CAMLprim value hh_get_size(value key); 80 | /* Adds a key/value pair to the hashtable. Returns the number of bytes 81 | * allocated in the heap, or a negative number if no memory was allocated. */ 82 | value hh_add(value key, value data); 83 | /* Returns true if the key is presen in the hashtable. */ 84 | value hh_mem(value key); 85 | /* Returns one of {1, -1, -2}. 86 | * 1 -- key exists and is associated with non-zero data 87 | * -1 -- key is not present in the hash table at all 88 | * -2 -- key is present in the hash table but associated with zero-valued data. 89 | * This means that the data has been explicitly deleted. 90 | */ 91 | CAMLprim value hh_mem_status(value key); 92 | /* The following operations are only to be performed by the master. */ 93 | /* Moves the data associated to key1 to key2. 94 | * key1 must be present. key2 must be free. 95 | */ 96 | void hh_move(value key1, value key2); 97 | /* Removes a key from the hash table. */ 98 | void hh_remove(value key); 99 | 100 | /*****************************************************************************/ 101 | /* Saved State without SQLite */ 102 | /*****************************************************************************/ 103 | 104 | void hh_save_table(value out_filename); 105 | 106 | void hh_load_table(value in_filename); 107 | 108 | /*****************************************************************************/ 109 | /* Saved State with SQLite */ 110 | /*****************************************************************************/ 111 | /* Safe to call outside of sql. */ 112 | void hh_cleanup_sqlite(void); 113 | /* Safe to call outside of sql. */ 114 | void hh_hashtable_cleanup_sqlite(void); 115 | 116 | /* Dependency table. */ 117 | CAMLprim value hh_save_dep_table_sqlite( 118 | value out_filename, 119 | value build_revision 120 | ); 121 | CAMLprim value hh_load_dep_table_sqlite( 122 | value in_filename, 123 | value ignore_hh_version 124 | ); 125 | CAMLprim value hh_get_dep_sqlite(value ocaml_key); 126 | 127 | /* Hash table. */ 128 | CAMLprim value hh_save_table_sqlite(value out_filename); 129 | CAMLprim value hh_save_table_keys_sqlite(value out_filename, value keys); 130 | CAMLprim value hh_load_table_sqlite(value in_filename, value verify); 131 | CAMLprim value hh_get_sqlite(value ocaml_key); 132 | 133 | /* File information. */ 134 | CAMLprim value hh_save_file_info_init(value ml_path); 135 | CAMLprim value hh_save_file_info_free(value ml_unit); 136 | CAMLprim value hh_save_file_info_sqlite( 137 | value ml_hash, 138 | value ml_name, 139 | value ml_kind, 140 | value ml_filespec 141 | ); 142 | 143 | #endif 144 | -------------------------------------------------------------------------------- /src/heap/hh_shared_sqlite.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the MIT license found in the 6 | * LICENSE file in the "hack" directory of this source tree. 7 | * 8 | */ 9 | #ifndef NO_SQLITE3 10 | 11 | #include "hh_shared_sqlite.h" 12 | 13 | #define CAML_NAME_SPACE 14 | #include 15 | #include 16 | #include 17 | 18 | #include 19 | 20 | #include 21 | #include 22 | #include 23 | #include 24 | 25 | #include "hh_assert.h" 26 | 27 | #define ARRAY_SIZE(array) \ 28 | (sizeof(array) / sizeof((array)[0])) 29 | 30 | #define UNUSED(x) \ 31 | ((void)(x)) 32 | 33 | #define UNUSED2(a, b) \ 34 | (UNUSED(a), UNUSED(b)) 35 | 36 | 37 | const char *create_tables_sql[] = { 38 | "CREATE TABLE IF NOT EXISTS HEADER(" \ 39 | " MAGIC_CONSTANT INTEGER PRIMARY KEY NOT NULL," \ 40 | " BUILDINFO TEXT NOT NULL" \ 41 | ");", 42 | "CREATE TABLE IF NOT EXISTS NAME_INFO(" \ 43 | " HASH INTEGER PRIMARY KEY NOT NULL," \ 44 | " NAME TEXT NOT NULL," \ 45 | " NKIND INTEGER NOT NULL," \ 46 | " FILESPEC TEXT NOT NULL" \ 47 | ");", 48 | "CREATE TABLE IF NOT EXISTS DEPTABLE(" \ 49 | " KEY_VERTEX INT PRIMARY KEY NOT NULL," \ 50 | " VALUE_VERTEX BLOB NOT NULL" \ 51 | ");", 52 | }; 53 | 54 | void make_all_tables(sqlite3 *db) { 55 | assert(db); 56 | for (int i = 0; i < ARRAY_SIZE(create_tables_sql); ++i) { 57 | assert_sql(sqlite3_exec(db, create_tables_sql[i], NULL, 0, NULL), 58 | SQLITE_OK); 59 | } 60 | return; 61 | } 62 | 63 | void assert_sql_with_line( 64 | int result, 65 | int correct_result, 66 | int line_number 67 | ) { 68 | if (result == correct_result) return; 69 | fprintf(stderr, 70 | "SQL assertion failure: Line: %d -> Expected: %d, Got: %d\n", 71 | line_number, 72 | correct_result, 73 | result); 74 | static value *exn = NULL; 75 | if (!exn) exn = caml_named_value("sql_assertion_failure"); 76 | caml_raise_with_arg(*exn, Val_long(result)); 77 | } 78 | 79 | static const char *hhfi_insert_row_sql = \ 80 | "INSERT INTO NAME_INFO (HASH, NAME, NKIND, FILESPEC) VALUES (?, ?, ?, ?);"; 81 | 82 | // insert a row into the name_info table 83 | void hhfi_insert_row( 84 | sqlite3_ptr db, 85 | int64_t hash, 86 | const char *name, 87 | int64_t kind, 88 | const char *filespec 89 | ) { 90 | assert(db); 91 | assert(name); 92 | assert(filespec); 93 | const char *sql = hhfi_insert_row_sql; 94 | sqlite3_stmt *stmt = NULL; 95 | assert_sql(sqlite3_prepare_v2(db, sql, -1, &stmt, NULL), SQLITE_OK); 96 | assert_sql(sqlite3_bind_int64(stmt, 1, hash), SQLITE_OK); 97 | assert_sql(sqlite3_bind_text(stmt, 2, name, -1, SQLITE_TRANSIENT), 98 | SQLITE_OK); 99 | assert_sql(sqlite3_bind_int64(stmt, 3, kind), SQLITE_OK); 100 | assert_sql(sqlite3_bind_text(stmt, 4, filespec, -1, SQLITE_TRANSIENT), 101 | SQLITE_OK); 102 | assert_sql(sqlite3_step(stmt), SQLITE_DONE); 103 | assert_sql(sqlite3_finalize(stmt), SQLITE_OK); 104 | return; 105 | } 106 | 107 | static char *copy_malloc(const char *s) { 108 | char *d = malloc(1 + strlen(s)); 109 | assert(d); 110 | return strcpy(d, s); 111 | } 112 | 113 | static sqlite3_ptr hhfi_db = NULL; 114 | 115 | static const char *hhfi_get_filespec_sql = \ 116 | "SELECT FILESPEC FROM NAME_INFO WHERE (HASH = (?));"; 117 | 118 | char *hhfi_get_filespec( 119 | sqlite3_ptr db, 120 | int64_t hash 121 | ) { 122 | assert(db); 123 | const char *sql = hhfi_get_filespec_sql; 124 | sqlite3_stmt *stmt = NULL; 125 | assert_sql(sqlite3_prepare_v2(db, sql, -1, &stmt, NULL), SQLITE_OK); 126 | assert_sql(sqlite3_bind_int64(stmt, 1, hash), SQLITE_OK); 127 | int sqlerr = sqlite3_step(stmt); 128 | char *out = NULL; 129 | if (sqlerr == SQLITE_DONE) { 130 | // do nothing 131 | } else if (sqlerr == SQLITE_ROW) { 132 | // sqlite returns const unsigned char* 133 | out = copy_malloc((char *) sqlite3_column_text(stmt, 0)); 134 | // make sure there are no more rows 135 | assert_sql(sqlite3_step(stmt), SQLITE_DONE); 136 | } else { 137 | // unexpected sqlite status 138 | assert(0); 139 | } 140 | sqlite3_finalize(stmt); 141 | return out; 142 | } 143 | 144 | void hhfi_init_db(const char *path) { 145 | assert(hhfi_db == NULL); 146 | assert_sql(sqlite3_open(path, &hhfi_db), SQLITE_OK); 147 | assert_sql(sqlite3_exec(hhfi_db, "BEGIN TRANSACTION;", 0, 0, 0), SQLITE_OK); 148 | return; 149 | } 150 | 151 | void hhfi_free_db(void) { 152 | assert(hhfi_db != NULL); 153 | assert_sql(sqlite3_exec(hhfi_db, "END TRANSACTION;", 0, 0, 0), SQLITE_OK); 154 | assert_sql(sqlite3_close(hhfi_db), SQLITE_OK); 155 | return; 156 | } 157 | 158 | sqlite3_ptr hhfi_get_db(void) { 159 | assert(hhfi_db != NULL); 160 | return hhfi_db; 161 | } 162 | 163 | #endif /* NO_SQLITE3 */ 164 | -------------------------------------------------------------------------------- /src/heap/hh_shared_sqlite.h: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the MIT license found in the 6 | * LICENSE file in the "hack" directory of this source tree. 7 | * 8 | */ 9 | 10 | #ifndef HH_SHARED_SQLITE_H 11 | #define HH_SHARED_SQLITE_H 12 | 13 | #ifndef NO_SQLITE3 14 | 15 | #include 16 | 17 | #include 18 | 19 | typedef sqlite3 *sqlite3_ptr; 20 | 21 | #define assert_sql(x, y) (assert_sql_with_line((x), (y), __LINE__)) 22 | 23 | void assert_sql_with_line( 24 | int result, 25 | int correct_result, 26 | int line_number); 27 | 28 | void make_all_tables(sqlite3 *db); 29 | 30 | void hhfi_insert_row( 31 | sqlite3_ptr db, 32 | int64_t hash, 33 | const char *name, 34 | int64_t kind, 35 | const char *filespec 36 | ); 37 | 38 | char *hhfi_get_filespec( 39 | sqlite3_ptr db, 40 | int64_t hash 41 | ); 42 | 43 | void hhfi_init_db(const char *path); 44 | void hhfi_free_db(void); 45 | sqlite3_ptr hhfi_get_db(void); 46 | 47 | #endif /* NO_SQLITE3 */ 48 | #endif /* HH_SHARED_SQLITE_H */ 49 | -------------------------------------------------------------------------------- /src/heap/prefix.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | 12 | (*****************************************************************************) 13 | (* The prefix is used to guarantee that we are not mixing different kind of 14 | * keys in the heap. 15 | * It just creates a new prefix every time its called. 16 | * The $ at the end of the prefix ensures that we don't have ambiguities if a key 17 | * happens to start with a digit. 18 | *) 19 | (*****************************************************************************) 20 | 21 | type t = string 22 | 23 | let make = 24 | let prefix_count = ref 0 in 25 | fun () -> 26 | incr prefix_count; 27 | string_of_int !prefix_count ^ "$" 28 | 29 | let make_key prefix k = 30 | prefix ^ k 31 | 32 | let remove prefix k = 33 | let prefix_size = String.length prefix in 34 | assert (String.sub k 0 prefix_size = prefix); 35 | String.sub k prefix_size (String.length k - prefix_size) 36 | -------------------------------------------------------------------------------- /src/heap/prefix.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | 12 | (*****************************************************************************) 13 | (* The prefix is used to guarantee that we are not mixing different kind of 14 | * keys in the heap. 15 | * It just creates a new prefix every time its called. 16 | *) 17 | (*****************************************************************************) 18 | 19 | type t (* Better make the type abstract *) 20 | 21 | val make: unit -> t 22 | 23 | (* Given a prefix and a key make me a prefixed key *) 24 | val make_key: t -> string -> string 25 | 26 | (* Removes the prefix from a key *) 27 | val remove: t -> string -> string 28 | -------------------------------------------------------------------------------- /src/heap/sharedMem.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (*****************************************************************************) 12 | (* The heap shared across all the processes. 13 | * 14 | * The Heap is not exposed directly to the user (cf shared.mli), 15 | * because we don't want to mix values of different types. Instead, we want 16 | * to use a functor. 17 | *) 18 | (*****************************************************************************) 19 | 20 | type config = { 21 | global_size : int; 22 | heap_size : int; 23 | dep_table_pow : int; 24 | hash_table_pow : int; 25 | shm_dirs : string list; 26 | shm_min_avail : int; 27 | log_level : int; 28 | } 29 | 30 | type handle = private { 31 | h_fd: Unix.file_descr; 32 | h_global_size: int; 33 | h_heap_size: int; 34 | } 35 | 36 | exception Out_of_shared_memory 37 | exception Hash_table_full 38 | exception Dep_table_full 39 | exception Heap_full 40 | exception Sql_assertion_failure of int 41 | exception C_assertion_failure of string 42 | 43 | (*****************************************************************************) 44 | (* Initializes the shared memory. Must be called before forking! *) 45 | (*****************************************************************************) 46 | 47 | val init: config -> handle 48 | 49 | (*****************************************************************************) 50 | (* Connect a slave to the shared heap *) 51 | (*****************************************************************************) 52 | 53 | val connect: handle -> unit 54 | 55 | (*****************************************************************************) 56 | (* The shared memory garbage collector. It must be called every time we 57 | * free data (cf hh_shared.c for the underlying C implementation). 58 | *) 59 | (*****************************************************************************) 60 | 61 | val collect: [ `gentle | `aggressive | `always_TEST ] -> unit 62 | 63 | (*****************************************************************************) 64 | (* Must be called after the initialization of the hack server is over. 65 | * (cf serverInit.ml). 66 | *) 67 | (*****************************************************************************) 68 | 69 | val init_done: unit -> unit 70 | 71 | (*****************************************************************************) 72 | (* Serializes the dependency table and writes it to a file *) 73 | (*****************************************************************************) 74 | val save_dep_table_sqlite: string -> string -> int 75 | 76 | (*****************************************************************************) 77 | (* Loads the dependency table by reading from a file *) 78 | (*****************************************************************************) 79 | val load_dep_table_sqlite: string -> bool -> int 80 | 81 | 82 | (*****************************************************************************) 83 | (* Serializes & loads the hash table directly into memory *) 84 | (*****************************************************************************) 85 | 86 | val save_table: string -> unit 87 | val load_table: string -> unit 88 | 89 | (*****************************************************************************) 90 | (* Serializes the hash table to sqlite *) 91 | (*****************************************************************************) 92 | 93 | val save_table_sqlite: string -> int 94 | val save_table_keys_sqlite: string -> string array -> int 95 | 96 | (*****************************************************************************) 97 | (* Loads the hash table by reading from a file *) 98 | (*****************************************************************************) 99 | 100 | val load_table_sqlite: string -> bool -> int 101 | 102 | (*****************************************************************************) 103 | (* Cleans up the artifacts generated by SQL *) 104 | (*****************************************************************************) 105 | val cleanup_sqlite: unit -> unit 106 | 107 | (*****************************************************************************) 108 | (* The size of the dynamically allocated shared memory section *) 109 | (*****************************************************************************) 110 | val heap_size : unit -> int 111 | 112 | (*****************************************************************************) 113 | (* Part of the heap not reachable from hashtable entries. *) 114 | (*****************************************************************************) 115 | val wasted_heap_size: unit -> int 116 | 117 | (*****************************************************************************) 118 | (* Stats of the statically sized hash / dep tables *) 119 | (*****************************************************************************) 120 | 121 | type table_stats = { 122 | nonempty_slots : int; 123 | used_slots : int; 124 | slots : int; 125 | } 126 | 127 | val dep_stats : unit -> table_stats 128 | 129 | val hash_stats : unit -> table_stats 130 | 131 | val is_heap_overflow: unit -> bool 132 | 133 | (*****************************************************************************) 134 | (* Cache invalidation. *) 135 | (*****************************************************************************) 136 | 137 | val invalidate_caches: unit -> unit 138 | 139 | (* Size of value in GC heap *) 140 | val value_size: Obj.t -> int 141 | 142 | (*****************************************************************************) 143 | (* The signature of a shared memory hashtable. 144 | * To create one: SharedMem.NoCache(struct type = my_type_of_value end). 145 | * The call to Make will create a hashtable in shared memory (visible to 146 | * all the workers). 147 | * Use NoCache/WithCache if you want caching or not. 148 | * If you do, bear in mind that the cache must be maintained by the caller. 149 | * So you will have to invalidate the caches yourself. 150 | *) 151 | (*****************************************************************************) 152 | 153 | module type NoCache = sig 154 | type key 155 | type t 156 | module KeySet : Set.S with type elt = key 157 | module KeyMap : MyMap.S with type key = key 158 | 159 | (* Safe for concurrent writes, the first writer wins, the second write 160 | * is dismissed. 161 | *) 162 | val add : key -> t -> unit 163 | (* Safe for concurrent reads. Safe for interleaved reads and mutations, 164 | * provided the code runs on Intel architectures. 165 | *) 166 | val get : key -> t option 167 | val get_old : key -> t option 168 | val get_old_batch : KeySet.t -> t option KeyMap.t 169 | val remove_old_batch : KeySet.t -> unit 170 | val find_unsafe : key -> t 171 | val get_batch : KeySet.t -> t option KeyMap.t 172 | val remove_batch : KeySet.t -> unit 173 | val string_of_key : key -> string 174 | (* Safe for concurrent access. *) 175 | val mem : key -> bool 176 | val mem_old : key -> bool 177 | (* This function takes the elements present in the set and keep the "old" 178 | * version in a separate heap. This is useful when we want to compare 179 | * what has changed. We will be in a situation for type-checking 180 | * (cf typing/typing_redecl_service.ml) where we want to compare the type 181 | * of a class in the previous environment vs the current type. 182 | *) 183 | val oldify_batch : KeySet.t -> unit 184 | (* Reverse operation of oldify *) 185 | val revive_batch : KeySet.t -> unit 186 | 187 | module LocalChanges : sig 188 | val has_local_changes : unit -> bool 189 | val push_stack : unit -> unit 190 | val pop_stack : unit -> unit 191 | val revert_batch : KeySet.t -> unit 192 | val commit_batch : KeySet.t -> unit 193 | val revert_all : unit -> unit 194 | val commit_all : unit -> unit 195 | end 196 | end 197 | 198 | module type WithCache = sig 199 | include NoCache 200 | val write_through : key -> t -> unit 201 | val get_no_cache: key -> t option 202 | end 203 | 204 | module type UserKeyType = sig 205 | type t 206 | val to_string : t -> string 207 | val compare : t -> t -> int 208 | end 209 | 210 | module NoCache : 211 | functor (UserKeyType : UserKeyType) -> 212 | functor (Value:Value.Type) -> 213 | NoCache with type t = Value.t 214 | and type key = UserKeyType.t 215 | and module KeySet = Set.Make (UserKeyType) 216 | and module KeyMap = MyMap.Make (UserKeyType) 217 | 218 | module WithCache : 219 | functor (UserKeyType : UserKeyType) -> 220 | functor (Value:Value.Type) -> 221 | WithCache with type t = Value.t 222 | and type key = UserKeyType.t 223 | and module KeySet = Set.Make (UserKeyType) 224 | and module KeyMap = MyMap.Make (UserKeyType) 225 | 226 | module type CacheType = sig 227 | type key 228 | type value 229 | 230 | val add: key -> value -> unit 231 | val get: key -> value option 232 | val remove: key -> unit 233 | val clear: unit -> unit 234 | 235 | val string_of_key : key -> string 236 | val get_size : unit -> int 237 | end 238 | 239 | module LocalCache : 240 | functor (UserKeyType : UserKeyType) -> 241 | functor (Value : Value.Type) -> 242 | CacheType with type key = UserKeyType.t 243 | and type value = Value.t 244 | -------------------------------------------------------------------------------- /src/heap/value.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | 12 | (*****************************************************************************) 13 | (* Very simple module used to make sure we don't mix keys of different 14 | * type in the heap (cf shared.ml). 15 | * Because we have to "create" a new module every time, we have to make a new 16 | * prefix (cf prefix.ml). Since the prefixes are always different (for each 17 | * call to make), we are sure that they are not colliding. 18 | *) 19 | (*****************************************************************************) 20 | 21 | module type Type = sig 22 | type t 23 | val prefix: Prefix.t 24 | val description: string 25 | end 26 | -------------------------------------------------------------------------------- /src/heap/value.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | 12 | (*****************************************************************************) 13 | (* Very simple module used to make sure we don't mix keys of different 14 | * type in the heap (cf shared.ml). 15 | * Because we have to "create" a new module every time, we have to make a new 16 | * prefix (cf prefix.ml). Since the prefixes are always different (for each 17 | * call to make), we are sure that they are not colliding. 18 | *) 19 | (*****************************************************************************) 20 | 21 | module type Type = sig 22 | type t 23 | val prefix: Prefix.t 24 | val description: string 25 | end 26 | -------------------------------------------------------------------------------- /src/heap/workerCancel.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the MIT license found in the 6 | * LICENSE file in the "hack" directory of this source tree. 7 | * 8 | *) 9 | 10 | exception Worker_should_exit 11 | let () = Callback.register_exception "worker_should_exit" Worker_should_exit 12 | 13 | external stop_workers : unit -> unit = "hh_stop_workers" 14 | external resume_workers : unit -> unit = "hh_resume_workers" 15 | external check_should_exit : unit -> unit = "hh_check_should_exit" 16 | external set_can_worker_stop : bool -> unit = "hh_set_can_worker_stop" 17 | 18 | let on_worker_cancelled = ref (fun () -> ()) 19 | let set_on_worker_cancelled f = on_worker_cancelled := f 20 | 21 | let with_no_cancellations f = 22 | Utils.try_finally 23 | ~f:begin fun () -> 24 | set_can_worker_stop false; 25 | f () 26 | end 27 | ~finally:(fun () -> set_can_worker_stop true) 28 | 29 | let with_worker_exit f = 30 | try f () with 31 | | Worker_should_exit -> 32 | !on_worker_cancelled (); 33 | exit 0 34 | 35 | (* Check if the workers are stopped and exit if they are *) 36 | let check_should_exit () = with_worker_exit check_should_exit 37 | -------------------------------------------------------------------------------- /src/heap/workerCancel.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the MIT license found in the 6 | * LICENSE file in the "hack" directory of this source tree. 7 | * 8 | *) 9 | 10 | val stop_workers: unit -> unit 11 | val resume_workers: unit -> unit 12 | val check_should_exit: unit -> unit 13 | 14 | val set_on_worker_cancelled: (unit -> unit) -> unit 15 | val with_no_cancellations: (unit -> 'a) -> 'a 16 | val with_worker_exit: (unit -> 'a) -> 'a 17 | -------------------------------------------------------------------------------- /src/injection/default_injector/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name injection) 3 | (public_name hack_parallel.injection) 4 | (wrapped false)) 5 | -------------------------------------------------------------------------------- /src/injection/default_injector/injector_config.ml: -------------------------------------------------------------------------------- 1 | let use_error_tracing = false 2 | let use_test_stubbing = false 3 | -------------------------------------------------------------------------------- /src/injection/default_injector/injector_config.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (** This file provides only the interface, so injector configuration 12 | * can be retreived without depending on the *actual* implementation 13 | * file. This is because we want libraries to be able to refer to the config, 14 | * but the actual injector to be chosen by the binary being built. 15 | * 16 | * Note: Buck doesn't currently have a build rule to only build .mli files 17 | * into .cmi, so you need to compile against this file directly. *) 18 | val use_error_tracing: bool 19 | val use_test_stubbing: bool 20 | -------------------------------------------------------------------------------- /src/interface/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name interface) 3 | (public_name hack_parallel.interface) 4 | (modules hack_parallel_intf) 5 | (wrapped false) 6 | (libraries 7 | core_kernel 8 | hack_parallel.procs 9 | hack_parallel.socket)) 10 | 11 | (library 12 | (name memory) 13 | (public_name hack_parallel.memory) 14 | (modules memory) 15 | (libraries 16 | core_kernel 17 | hack_parallel.interface)) 18 | 19 | (library 20 | (name scheduler) 21 | (public_name hack_parallel.scheduler) 22 | (modules scheduler) 23 | (libraries 24 | core_kernel 25 | hack_parallel.interface 26 | hack_parallel.memory)) 27 | -------------------------------------------------------------------------------- /src/interface/hack_parallel_intf.ml: -------------------------------------------------------------------------------- 1 | (** Copyright (c) 2016-present, Facebook, Inc. 2 | Modified work Copyright (c) 2018-2019 Rijnard van Tonder 3 | This source code is licensed under the MIT license found in the 4 | LICENSE file in the root directory of this source tree. *) 5 | 6 | module Std = struct 7 | 8 | module SharedMem = SharedMem 9 | 10 | module String_utils = String_utils 11 | 12 | module MultiWorker = MultiWorker 13 | 14 | module Worker = Worker 15 | 16 | module Daemon = Daemon 17 | 18 | module Bucket = Hack_bucket 19 | 20 | module Socket = Socket 21 | 22 | module Lock = Lock 23 | 24 | module Marshal_tools = Marshal_tools 25 | 26 | module Measure = Measure 27 | end 28 | -------------------------------------------------------------------------------- /src/interface/memory.ml: -------------------------------------------------------------------------------- 1 | (** Copyright (c) 2016-present, Facebook, Inc. 2 | Modified work Copyright (c) 2018-2019 Rijnard van Tonder 3 | This source code is licensed under the MIT license found in the 4 | LICENSE file in the root directory of this source tree. *) 5 | 6 | module SharedMemory = Hack_parallel_intf.Std.SharedMem 7 | 8 | include SharedMemory 9 | 10 | 11 | type bytes = int 12 | 13 | type configuration = { 14 | heap_handle: Hack_parallel_intf.Std.SharedMem.handle; 15 | minor_heap_size: bytes; 16 | } 17 | 18 | 19 | let configuration: configuration option ref = ref None 20 | 21 | 22 | let initial_heap_size = 4096 * 1024 * 1024 (* 4 GB *) 23 | 24 | 25 | let worker_garbage_control = 26 | { 27 | (Gc.get ()) with 28 | Gc.minor_heap_size = 256 * 1024; (* 256 KB *) 29 | space_overhead = 100; 30 | } 31 | 32 | 33 | let initialize () = 34 | match !configuration with 35 | | None -> 36 | let minor_heap_size = 4 * 1024 * 1024 in (* 4 MB *) 37 | let space_overhead = 50 in 38 | (* Only sets the GC for the master process - the parallel 39 | workers use GC settings with less overhead. *) 40 | Gc.set { 41 | (Gc.get ()) with 42 | Gc.minor_heap_size; 43 | space_overhead; 44 | }; 45 | let shared_mem_config = 46 | let open SharedMemory in 47 | { 48 | global_size = initial_heap_size; 49 | heap_size = initial_heap_size; 50 | dep_table_pow = 19; 51 | hash_table_pow = 21; 52 | shm_dirs = ["/dev/shm"; "/ocaml_parallel"]; 53 | shm_min_avail = 1024 * 1024 * 512; (* 512 MB *) 54 | log_level = 0; 55 | } in 56 | let heap_handle = SharedMemory.init shared_mem_config in 57 | configuration := Some { heap_handle; minor_heap_size }; 58 | { heap_handle; minor_heap_size } 59 | | Some configuration -> 60 | configuration 61 | 62 | 63 | let get_heap_handle () = 64 | let { heap_handle; _ } = initialize () in 65 | heap_handle 66 | 67 | 68 | let heap_use_ratio () = 69 | Core_kernel.Float.of_int (SharedMemory.heap_size ()) /. 70 | Core_kernel.Float.of_int initial_heap_size 71 | 72 | 73 | let slot_use_ratio () = 74 | let { SharedMemory.used_slots; slots; _ } = SharedMemory.hash_stats () in 75 | Core_kernel.Float.of_int used_slots /. Core_kernel.Float.of_int slots 76 | -------------------------------------------------------------------------------- /src/interface/memory.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (*****************************************************************************) 12 | (* The heap shared across all the processes. 13 | * 14 | * The Heap is not exposed directly to the user (cf shared.mli), 15 | * because we don't want to mix values of different types. Instead, we want 16 | * to use a functor. 17 | *) 18 | (*****************************************************************************) 19 | 20 | type config = { 21 | global_size : int; 22 | heap_size : int; 23 | dep_table_pow : int; 24 | hash_table_pow : int; 25 | shm_dirs : string list; 26 | shm_min_avail : int; 27 | log_level : int; 28 | } 29 | 30 | 31 | type handle = Hack_parallel_intf.Std.SharedMem.handle 32 | 33 | exception Out_of_shared_memory 34 | exception Hash_table_full 35 | exception Dep_table_full 36 | exception Heap_full 37 | exception Sql_assertion_failure of int 38 | exception C_assertion_failure of string 39 | 40 | val get_heap_handle: unit -> handle 41 | 42 | (*****************************************************************************) 43 | (* Initializes the shared memory. Must be called before forking! *) 44 | (*****************************************************************************) 45 | 46 | val init: config -> handle 47 | 48 | (*****************************************************************************) 49 | (* Connect a slave to the shared heap *) 50 | (*****************************************************************************) 51 | 52 | val connect: handle -> unit 53 | 54 | (*****************************************************************************) 55 | (* The shared memory garbage collector. It must be called every time we 56 | * free data (cf hh_shared.c for the underlying C implementation). 57 | *) 58 | (*****************************************************************************) 59 | 60 | val collect: [ `gentle | `aggressive | `always_TEST ] -> unit 61 | 62 | (*****************************************************************************) 63 | (* Must be called after the initialization of the hack server is over. 64 | * (cf serverInit.ml). 65 | *) 66 | (*****************************************************************************) 67 | 68 | val init_done: unit -> unit 69 | 70 | (*****************************************************************************) 71 | (* Serializes the dependency table and writes it to a file *) 72 | (*****************************************************************************) 73 | val save_dep_table_sqlite: string -> string -> int 74 | 75 | (*****************************************************************************) 76 | (* Loads the dependency table by reading from a file *) 77 | (*****************************************************************************) 78 | val load_dep_table_sqlite: string -> bool -> int 79 | 80 | 81 | (*****************************************************************************) 82 | (* Serializes & loads the hash table directly into memory *) 83 | (*****************************************************************************) 84 | 85 | val save_table: string -> unit 86 | val load_table: string -> unit 87 | 88 | (*****************************************************************************) 89 | (* Serializes the hash table to sqlite *) 90 | (*****************************************************************************) 91 | 92 | val save_table_sqlite: string -> int 93 | val save_table_keys_sqlite: string -> string array -> int 94 | 95 | (*****************************************************************************) 96 | (* Loads the hash table by reading from a file *) 97 | (*****************************************************************************) 98 | 99 | val load_table_sqlite: string -> bool -> int 100 | 101 | (*****************************************************************************) 102 | (* Cleans up the artifacts generated by SQL *) 103 | (*****************************************************************************) 104 | val cleanup_sqlite: unit -> unit 105 | 106 | (*****************************************************************************) 107 | (* The size of the dynamically allocated shared memory section *) 108 | (*****************************************************************************) 109 | val heap_size : unit -> int 110 | 111 | (*****************************************************************************) 112 | (* Part of the heap not reachable from hashtable entries. *) 113 | (*****************************************************************************) 114 | val wasted_heap_size: unit -> int 115 | 116 | (*****************************************************************************) 117 | (* Stats of the statically sized hash / dep tables *) 118 | (*****************************************************************************) 119 | 120 | type table_stats = { 121 | nonempty_slots : int; 122 | used_slots : int; 123 | slots : int; 124 | } 125 | 126 | val dep_stats : unit -> table_stats 127 | 128 | val hash_stats : unit -> table_stats 129 | 130 | val is_heap_overflow: unit -> bool 131 | 132 | (*****************************************************************************) 133 | (* Cache invalidation. *) 134 | (*****************************************************************************) 135 | 136 | val invalidate_caches: unit -> unit 137 | 138 | (* Size of value in GC heap *) 139 | val value_size: Obj.t -> int 140 | 141 | (*****************************************************************************) 142 | (* The signature of a shared memory hashtable. 143 | * To create one: SharedMem.NoCache(struct type = my_type_of_value end). 144 | * The call to Make will create a hashtable in shared memory (visible to 145 | * all the workers). 146 | * Use NoCache/WithCache if you want caching or not. 147 | * If you do, bear in mind that the cache must be maintained by the caller. 148 | * So you will have to invalidate the caches yourself. 149 | *) 150 | (*****************************************************************************) 151 | 152 | module type NoCache = sig 153 | type key 154 | type t 155 | module KeySet : Set.S with type elt = key 156 | module KeyMap : MyMap.S with type key = key 157 | 158 | (* Safe for concurrent writes, the first writer wins, the second write 159 | * is dismissed. 160 | *) 161 | val add : key -> t -> unit 162 | (* Safe for concurrent reads. Safe for interleaved reads and mutations, 163 | * provided the code runs on Intel architectures. 164 | *) 165 | val get : key -> t option 166 | val get_old : key -> t option 167 | val get_old_batch : KeySet.t -> t option KeyMap.t 168 | val remove_old_batch : KeySet.t -> unit 169 | val find_unsafe : key -> t 170 | val get_batch : KeySet.t -> t option KeyMap.t 171 | val remove_batch : KeySet.t -> unit 172 | val string_of_key : key -> string 173 | (* Safe for concurrent access. *) 174 | val mem : key -> bool 175 | val mem_old : key -> bool 176 | (* This function takes the elements present in the set and keep the "old" 177 | * version in a separate heap. This is useful when we want to compare 178 | * what has changed. We will be in a situation for type-checking 179 | * (cf typing/typing_redecl_service.ml) where we want to compare the type 180 | * of a class in the previous environment vs the current type. 181 | *) 182 | val oldify_batch : KeySet.t -> unit 183 | (* Reverse operation of oldify *) 184 | val revive_batch : KeySet.t -> unit 185 | 186 | module LocalChanges : sig 187 | val has_local_changes : unit -> bool 188 | val push_stack : unit -> unit 189 | val pop_stack : unit -> unit 190 | val revert_batch : KeySet.t -> unit 191 | val commit_batch : KeySet.t -> unit 192 | val revert_all : unit -> unit 193 | val commit_all : unit -> unit 194 | end 195 | end 196 | 197 | module type WithCache = sig 198 | include NoCache 199 | val write_through : key -> t -> unit 200 | val get_no_cache: key -> t option 201 | end 202 | 203 | module type UserKeyType = sig 204 | type t 205 | val to_string : t -> string 206 | val compare : t -> t -> int 207 | end 208 | 209 | module NoCache : 210 | functor (UserKeyType : UserKeyType) -> 211 | functor (Value:Value.Type) -> 212 | NoCache with type t = Value.t 213 | and type key = UserKeyType.t 214 | and module KeySet = Set.Make (UserKeyType) 215 | and module KeyMap = MyMap.Make (UserKeyType) 216 | 217 | module WithCache : 218 | functor (UserKeyType : UserKeyType) -> 219 | functor (Value:Value.Type) -> 220 | WithCache with type t = Value.t 221 | and type key = UserKeyType.t 222 | and module KeySet = Set.Make (UserKeyType) 223 | and module KeyMap = MyMap.Make (UserKeyType) 224 | 225 | module type CacheType = sig 226 | type key 227 | type value 228 | 229 | val add: key -> value -> unit 230 | val get: key -> value option 231 | val remove: key -> unit 232 | val clear: unit -> unit 233 | 234 | val string_of_key : key -> string 235 | val get_size : unit -> int 236 | end 237 | 238 | module LocalCache : 239 | functor (UserKeyType : UserKeyType) -> 240 | functor (Value : Value.Type) -> 241 | CacheType with type key = UserKeyType.t 242 | and type value = Value.t 243 | 244 | (* Between 0.0 and 1.0 *) 245 | val heap_use_ratio: unit -> float 246 | val slot_use_ratio: unit -> float 247 | 248 | val worker_garbage_control: Gc.control 249 | -------------------------------------------------------------------------------- /src/interface/scheduler.ml: -------------------------------------------------------------------------------- 1 | (** Copyright (c) 2016-present, Facebook, Inc. 2 | Modified work Copyright (c) 2018-2019 Rijnard van Tonder 3 | This source code is licensed under the MIT license found in the 4 | LICENSE file in the root directory of this source tree. *) 5 | 6 | open Hack_parallel_intf.Std 7 | 8 | module Daemon = Daemon 9 | 10 | 11 | type t = { 12 | workers: Worker.t list; 13 | number_of_workers: int; 14 | bucket_multiplier: int; 15 | } 16 | 17 | 18 | let entry = 19 | Worker.register_entry_point ~restore:(fun _ -> ()) 20 | 21 | 22 | let create 23 | ?(number_of_workers = 1) 24 | ?(bucket_multiplier = 10) 25 | () = 26 | let heap_handle = Memory.get_heap_handle () in 27 | let workers = 28 | Hack_parallel_intf.Std.Worker.make 29 | ~saved_state:() 30 | ~entry 31 | ~nbr_procs:number_of_workers 32 | ~heap_handle 33 | ~gc_control:Memory.worker_garbage_control 34 | in 35 | Memory.connect heap_handle; 36 | { workers; number_of_workers; bucket_multiplier } 37 | 38 | 39 | let map_reduce 40 | { workers; number_of_workers; bucket_multiplier } 41 | ?bucket_size 42 | ~init 43 | ~map 44 | ~reduce 45 | work = 46 | let number_of_workers = 47 | match bucket_size with 48 | | Some exact_size when exact_size > 0 -> 49 | (List.length work / exact_size) + 1 50 | | _ -> 51 | let bucket_multiplier = Core_kernel.Int.min bucket_multiplier (1 + (List.length work / 400)) in 52 | number_of_workers * bucket_multiplier 53 | in 54 | MultiWorker.call 55 | (Some workers) 56 | ~job:map 57 | ~merge:reduce 58 | ~neutral:init 59 | ~next:(Bucket.make ~num_workers:number_of_workers work) 60 | 61 | 62 | let iter scheduler ~f work = 63 | map_reduce 64 | scheduler 65 | ~init:() 66 | ~map:(fun _ work -> f work) 67 | ~reduce:(fun _ _ -> ()) 68 | work 69 | 70 | 71 | let single_job { workers; _ } ~f work = 72 | let rec wait_until_ready handle = 73 | let { Worker.readys; _ } = Worker.select [handle] in 74 | match readys with 75 | | [] -> wait_until_ready handle 76 | | ready :: _ -> ready 77 | in 78 | match workers with 79 | | worker::_ -> 80 | Worker.call worker f work 81 | |> wait_until_ready 82 | |> Worker.get_result 83 | | [] -> 84 | failwith "This service contains no workers" 85 | 86 | 87 | let mock () = 88 | Memory.get_heap_handle () |> ignore; 89 | { workers = []; number_of_workers = 1; bucket_multiplier = 1 } 90 | 91 | 92 | let destroy _ = 93 | Worker.killall () 94 | -------------------------------------------------------------------------------- /src/interface/scheduler.mli: -------------------------------------------------------------------------------- 1 | (** Copyright (c) 2016-present, Facebook, Inc. 2 | Modified work Copyright (c) 2018-2019 Rijnard van Tonder 3 | This source code is licensed under the MIT license found in the 4 | LICENSE file in the root directory of this source tree. *) 5 | 6 | open Hack_parallel_intf.Std 7 | 8 | module Daemon = Daemon 9 | 10 | type t 11 | 12 | val create: ?number_of_workers: int -> ?bucket_multiplier: int -> unit -> t 13 | 14 | val map_reduce 15 | : t 16 | -> ?bucket_size: int 17 | -> init:'a 18 | -> map:('a -> 'b list -> 'c) 19 | -> reduce:('c -> 'a -> 'a) 20 | -> 'b list 21 | -> 'a 22 | 23 | val iter: t -> f: ('a list -> unit) -> 'a list -> unit 24 | 25 | val single_job : t -> f:('a -> 'b) -> 'a -> 'b 26 | 27 | val mock: unit -> t 28 | 29 | val destroy : t -> unit 30 | -------------------------------------------------------------------------------- /src/procs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name procs) 3 | (public_name hack_parallel.procs) 4 | (wrapped false) 5 | (libraries 6 | hack_parallel.heap 7 | hack_parallel.stubs)) 8 | -------------------------------------------------------------------------------- /src/procs/hack_bucket.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (****************************************************************************) 12 | (* Moduling Making buckets. 13 | * When we parallelize, we need to create "buckets" of tasks for the 14 | * workers. 15 | * Given a list of files, we want to split it up into buckets such that 16 | * every worker is busy long enough. If the bucket is too big, it hurts 17 | * load balancing, if it is too small, the overhead in synchronization time 18 | * hurts *) 19 | (****************************************************************************) 20 | 21 | type 'a bucket = 22 | | Job of 'a 23 | | Wait 24 | | Done 25 | 26 | type 'a next = 27 | unit -> 'a bucket 28 | 29 | let make_ bucket_size jobs = 30 | let i = ref 0 in 31 | fun () -> 32 | let bucket_size = min (Array.length jobs - !i) bucket_size in 33 | let result = Array.sub jobs !i bucket_size in 34 | i := bucket_size + !i; 35 | Array.to_list result 36 | 37 | let make_list ~num_workers jobs = 38 | let jobs = Array.of_list jobs in 39 | let bucket_size = 40 | max 1 (1 + ((Array.length jobs) / num_workers)) 41 | in 42 | make_ bucket_size jobs 43 | 44 | let of_list = function 45 | | [] -> Done 46 | | wl -> Job wl 47 | 48 | let make ~num_workers jobs = 49 | let maker = make_list ~num_workers jobs in 50 | fun () -> of_list (maker ()) 51 | 52 | type 'a of_n = { work: 'a; bucket: int; total: int } 53 | 54 | let make_n_buckets ~buckets ~split = 55 | let next_bucket = ref 0 in 56 | fun () -> 57 | let current = !next_bucket in 58 | incr next_bucket; 59 | if (current < buckets) then 60 | Job { work = split ~bucket:current; bucket = current; total = buckets } 61 | else 62 | Done 63 | -------------------------------------------------------------------------------- /src/procs/hack_bucket.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2016, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (* The general protocol for a next function is to return either Wait (indicating 12 | that workers should wait until more elements are added to the workload), or 13 | Job of a bucket, or Done to indicate there is no more work. *) 14 | type 'a bucket = 15 | | Job of 'a 16 | | Wait 17 | | Done 18 | 19 | type 'a next = 20 | unit -> 'a bucket 21 | 22 | (* Makes a bucket out of a list, without regard for number of workers or the 23 | size of the list. *) 24 | val of_list : 'a list -> 'a list bucket 25 | 26 | val make : num_workers:int -> 'a list -> 'a list next 27 | 28 | type 'a of_n = { work: 'a; bucket: int; total: int } 29 | 30 | val make_n_buckets : buckets:int -> split:(bucket:int -> 'a) -> 31 | 'a of_n next 32 | -------------------------------------------------------------------------------- /src/procs/multiWorker.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | open Hack_core 12 | 13 | type 'a nextlist = 'a list Hack_bucket.next 14 | 15 | type 'a bucket = 'a Hack_bucket.bucket = 16 | | Job of 'a 17 | | Wait 18 | | Done 19 | 20 | let single_threaded_call job merge neutral next = 21 | let x = ref (next()) in 22 | let acc = ref neutral in 23 | (* This is a just a sanity check that the job is serializable and so 24 | * that the same code will work both in single threaded and parallel 25 | * mode. 26 | *) 27 | let _ = Marshal.to_string job [Marshal.Closures] in 28 | while !x <> Done do 29 | match !x with 30 | | Wait -> 31 | (* this state should never be reached in single threaded mode, since 32 | there is no hope for ever getting out of this state *) 33 | failwith "stuck!" 34 | | Job l -> 35 | let res = job neutral l in 36 | acc := merge res !acc; 37 | x := next() 38 | | Done -> () 39 | done; 40 | !acc 41 | 42 | let multi_threaded_call 43 | (type a) (type b) (type c) 44 | workers (job: c -> a -> b) 45 | (merge: b -> c -> c) 46 | (neutral: c) 47 | (next: a Hack_bucket.next) = 48 | let rec dispatch workers handles acc = 49 | (* 'worker' represents available workers. *) 50 | (* 'handles' represents pendings jobs. *) 51 | (* 'acc' are the accumulated results. *) 52 | match workers with 53 | | [] when handles = [] -> acc 54 | | [] -> 55 | (* No worker available: wait for some workers to finish. *) 56 | collect [] handles acc 57 | | worker :: workers -> 58 | (* At least one worker is available... *) 59 | match next () with 60 | | Wait -> collect (worker :: workers) handles acc 61 | | Done -> 62 | (* ... but no more job to be distributed, let's collect results. *) 63 | dispatch [] handles acc 64 | | Job bucket -> 65 | (* ... send a job to the worker.*) 66 | let handle = 67 | Worker.call worker 68 | (fun xl -> job neutral xl) 69 | bucket in 70 | dispatch workers (handle :: handles) acc 71 | and collect workers handles acc = 72 | let { Worker.readys; waiters } = Worker.select handles in 73 | let workers = List.map ~f:Worker.get_worker readys @ workers in 74 | (* Collect the results. *) 75 | let acc = 76 | List.fold_left 77 | ~f:(fun acc h -> merge (Worker.get_result h) acc) 78 | ~init:acc 79 | readys in 80 | (* And continue.. *) 81 | dispatch workers waiters acc in 82 | dispatch workers [] neutral 83 | 84 | let call workers ~job ~merge ~neutral ~next = 85 | match workers with 86 | | None -> single_threaded_call job merge neutral next 87 | | Some workers -> multi_threaded_call workers job merge neutral next 88 | 89 | let next workers = 90 | Hack_bucket.make 91 | ~num_workers: (match workers with Some w -> List.length w | None -> 1) 92 | -------------------------------------------------------------------------------- /src/procs/multiWorker.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (* The protocol for a next function is to return a list of elements. 12 | * It will be called repeatedly until it returns an empty list. 13 | *) 14 | type 'a nextlist = 'a list Hack_bucket.next 15 | 16 | val next : 17 | Worker.t list option -> 18 | 'a list -> 19 | 'a list Hack_bucket.next 20 | 21 | (* See definition in Hack_bucket *) 22 | type 'a bucket = 'a Hack_bucket.bucket = 23 | | Job of 'a 24 | | Wait 25 | | Done 26 | 27 | val call : 28 | Worker.t list option -> 29 | job:('c -> 'a -> 'b) -> 30 | merge:('b -> 'c -> 'c) -> neutral:'c -> 31 | next:'a Hack_bucket.next -> 32 | 'c 33 | -------------------------------------------------------------------------------- /src/procs/worker.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | 12 | (*****************************************************************************) 13 | (* Module building workers. 14 | * A worker is a subprocess executing an arbitrary function. 15 | * You should first create a fixed amount of workers and then use those 16 | * because the amount of workers is limited and to make the load-balancing 17 | * of tasks better (cf multiWorker.ml). 18 | *) 19 | (*****************************************************************************) 20 | 21 | exception Worker_exited_abnormally of int * Unix.process_status 22 | 23 | (** Worker killed by Out Of Memory. *) 24 | exception Worker_oomed 25 | 26 | (** Raise this exception when sending work to a worker that is already busy. 27 | * We should never be doing that, and this is an assertion error. *) 28 | exception Worker_busy 29 | 30 | (** Raise this exception when sending work to a worker that is already killed. 31 | * We should never be doing that, and this is an assertion error. *) 32 | exception Worker_killed 33 | 34 | type send_job_failure = 35 | | Worker_already_exited of Unix.process_status 36 | | Other_send_job_failure of exn 37 | 38 | exception Worker_failed_to_send_job of send_job_failure 39 | 40 | (* The type of a worker visible to the outside world *) 41 | type t 42 | 43 | 44 | (*****************************************************************************) 45 | (* The handle is what we get back when we start a job. It's a "future" 46 | * (sometimes called a "promise"). The scheduler uses the handle to retrieve 47 | * the result of the job when the task is done (cf multiWorker.ml). 48 | *) 49 | (*****************************************************************************) 50 | type 'a handle 51 | 52 | type 'a entry 53 | val register_entry_point: 54 | restore:('a -> unit) -> 'a entry 55 | 56 | (** Creates a pool of workers. *) 57 | val make: 58 | saved_state : 'a -> 59 | entry : 'a entry -> 60 | nbr_procs : int -> 61 | gc_control : Gc.control -> 62 | heap_handle : SharedMem.handle -> 63 | t list 64 | 65 | (* Call in a sub-process (CAREFUL, GLOBALS ARE COPIED) *) 66 | val call: t -> ('a -> 'b) -> 'a -> 'b handle 67 | 68 | (* Retrieves the result (once the worker is done) hangs otherwise *) 69 | val get_result: 'a handle -> 'a 70 | 71 | (* Selects among multiple handles those which are ready. *) 72 | type 'a selected = { 73 | readys: 'a handle list; 74 | waiters: 'a handle list; 75 | } 76 | val select: 'a handle list -> 'a selected 77 | 78 | (* Returns the worker which produces this handle *) 79 | val get_worker: 'a handle -> t 80 | 81 | (* Killall the workers *) 82 | val killall: unit -> unit 83 | 84 | 85 | (* Return the id of the worker to which the current process belong. 0 means the master process *) 86 | val current_worker_id: unit -> int 87 | -------------------------------------------------------------------------------- /src/socket/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name socket) 3 | (public_name hack_parallel.socket) 4 | (wrapped false) 5 | (libraries 6 | hack_parallel.utils)) 7 | -------------------------------------------------------------------------------- /src/socket/socket.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | module Path = Hack_path 12 | 13 | (* Initializes the unix domain socket *) 14 | let unix_socket sock_name = 15 | try 16 | Sys_utils.with_umask 0o111 begin fun () -> 17 | Sys_utils.mkdir_no_fail (Filename.dirname sock_name); 18 | if Sys.file_exists sock_name then Sys.remove sock_name; 19 | let domain, addr = 20 | if Sys.win32 then 21 | Unix.(PF_INET, Unix.ADDR_INET (inet_addr_loopback, 0)) 22 | else 23 | Unix.(PF_UNIX, Unix.ADDR_UNIX sock_name) in 24 | let sock = Unix.socket domain Unix.SOCK_STREAM 0 in 25 | let _ = Unix.setsockopt sock Unix.SO_REUSEADDR true in 26 | let _ = Unix.bind sock addr in 27 | let _ = Unix.listen sock 10 in 28 | let () = 29 | match Unix.getsockname sock with 30 | | Unix.ADDR_UNIX _ -> () 31 | | Unix.ADDR_INET (_, port) -> 32 | let oc = open_out_bin sock_name in 33 | output_binary_int oc port; 34 | close_out oc in 35 | sock 36 | end 37 | with Unix.Unix_error (err, _, _) -> 38 | Printf.eprintf "%s\n" (Unix.error_message err); 39 | Exit_status.(exit Socket_error) 40 | 41 | (* So the sockaddr_un structure puts a strict limit on the length of a socket 42 | * address. This appears to be 104 chars on mac os x and 108 chars on my 43 | * centos box. *) 44 | let max_addr_length = 103 45 | let min_name_length = 17 46 | 47 | let get_path path = 48 | (* Path will resolve the realpath, in case two processes are referring to the 49 | * same socket using different paths (like with symlinks *) 50 | let path = path |> Path.make |> Path.to_string in 51 | let dir = (Filename.dirname path)^"/" in 52 | let filename = Filename.basename path in 53 | let root_part = Filename.chop_extension filename in 54 | let root_length = String.length root_part in 55 | let extension_length = String.length filename - root_length in 56 | let extension = String.sub filename root_length extension_length in 57 | 58 | (* It's possible that the directory path is too long. If so, let's give up and 59 | * use /tmp/ *) 60 | let dir = 61 | if String.length dir > max_addr_length - min_name_length 62 | then Filename.get_temp_dir_name () 63 | else dir in 64 | let max_root_part_length = 65 | max_addr_length - (String.length dir) - extension_length in 66 | let root_part = 67 | if root_length > max_root_part_length 68 | then begin 69 | let len = String.length root_part in 70 | let prefix = String.sub root_part 0 5 in 71 | let suffix = String.sub root_part (len - 5) 5 in 72 | let digest = Digest.to_hex (Digest.string root_part) in 73 | (* 5 char prefix + 5 char suffix + 2 periods *) 74 | let max_digest_length = max_root_part_length - 12 in 75 | let digest_part = if String.length digest > max_digest_length 76 | then String.sub digest 0 max_digest_length 77 | else digest in 78 | prefix ^ "." ^ digest_part ^ "." ^ suffix 79 | end else root_part in 80 | Filename.concat dir (Printf.sprintf "%s%s" root_part extension) 81 | 82 | let init_unix_socket socket_file = 83 | unix_socket (get_path socket_file) 84 | -------------------------------------------------------------------------------- /src/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name stubs) 3 | (public_name hack_parallel.stubs) 4 | (wrapped false)) 5 | -------------------------------------------------------------------------------- /src/stubs/eventLogger.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | type init_settings = { 12 | scuba_table_name : string; 13 | log_out : Unix.file_descr; (** File descriptors for the logger daemon's stdout. *) 14 | log_err : Unix.file_descr; (** File descriptors for the logger daemon's stderr. *) 15 | } 16 | 17 | type init_mode = 18 | | Event_logger_fake (** Sends everything to /dev/null. *) 19 | | Event_logger_real of init_settings 20 | 21 | let init ?log_pid:_ ?init_id:_ _ _ = () 22 | let set_init_type _ = () 23 | let log_if_initialized _ = () 24 | let master_exception _ = () 25 | let worker_exception _ = () 26 | let sharedmem_gc_ran _ _ _ _ = () 27 | let sharedmem_init_done _ = () 28 | let sharedmem_failed_anonymous_memfd_init _ = () 29 | let sharedmem_failed_to_use_shm_dir ~shm_dir:_ ~reason:_ = () 30 | let sharedmem_less_than_minimum_available 31 | ~shm_dir:_ 32 | ~shm_min_avail:_ 33 | ~avail:_ = () 34 | let find_done ~time_taken:_ ~name:_ = () 35 | let log_gc_stats () = () 36 | let flush _ = () 37 | let watchman_error _ = () 38 | let watchman_warning _ = () 39 | let watchman_died_caught _ = () 40 | let watchman_uncaught_failure _ = () 41 | let watchman_connection_reestablished _ = () 42 | let watchman_connection_reestablishment_failed _ = () 43 | let watchman_timeout _ = () 44 | let dfind_ready _ _ = () 45 | -------------------------------------------------------------------------------- /src/third-party/hack_core/VERSION: -------------------------------------------------------------------------------- 1 | 112.01.00 of Jane Street's core_kernel (https://github.com/janestreet/core_kernel) 2 | -------------------------------------------------------------------------------- /src/third-party/hack_core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name hack_core) 3 | (public_name hack_parallel.hack_core) 4 | (wrapped false)) 5 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_caml.ml: -------------------------------------------------------------------------------- 1 | (* The Caml module binds everything that is available in the standard 2 | environment so that we can easily refer to standard things even if they've 3 | been rebound. 4 | *) 5 | 6 | module Arg = Arg 7 | module Array = Array 8 | module ArrayLabels = ArrayLabels 9 | module Buffer = Buffer 10 | module Callback = Callback 11 | module Char = Char 12 | module Complex = Complex 13 | module Digest = Digest 14 | module Filename = Filename 15 | module Format = Format 16 | module Gc = Gc 17 | module Genlex = Genlex 18 | module Hashtbl = Hashtbl 19 | module Int32 = Int32 20 | module Int64 = Int64 21 | module Lazy = Lazy 22 | module Lexing = Lexing 23 | module List = List 24 | module ListLabels = ListLabels 25 | module Map = Map 26 | module Marshal = Marshal 27 | module MoreLabels = MoreLabels 28 | module Nativeint = Nativeint 29 | module Oo = Oo 30 | module Parsing = Parsing 31 | module Pervasives = Pervasives 32 | module Printexc = Printexc 33 | module Printf = Printf 34 | module Queue = Queue 35 | module Random = Random 36 | module Scanf = Scanf 37 | module Set = Set 38 | module Sort = Sort 39 | module Stack = Stack 40 | module StdLabels = StdLabels 41 | module Stream = Stream 42 | module String = String 43 | module StringLabels = StringLabels 44 | module Sys = Sys 45 | module Weak = Weak 46 | 47 | include Pervasives 48 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_commutative_group.ml: -------------------------------------------------------------------------------- 1 | (** A signature for a commutative group (in the group-theory sense). 2 | 3 | An implementation of this interface should have the following properties: 4 | 5 | 1: associativity: (a+b)+c = a+(b+c) for all elt's a,b,c 6 | 2: identity: zero+a = a+zero = a for all elt's a 7 | 3: inverses: given any elt a there exists a (unique) elt b such that a+b=b+a=zero 8 | 4: commutativity: a+b = b+a 9 | *) 10 | 11 | module type S = sig 12 | type t (* an element of the group *) 13 | 14 | val zero : t 15 | val (+) : t -> t -> t 16 | val (-) : t -> t -> t 17 | end 18 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_container.ml: -------------------------------------------------------------------------------- 1 | let fold_count fold t ~f = fold t ~init:0 ~f:(fun n a -> if f a then n + 1 else n) 2 | 3 | let fold_sum (type a) (module M : Hack_commutative_group.S with type t = a) fold t ~f = 4 | fold t ~init:M.zero ~f:(fun n a -> M.(+) n (f a)) 5 | ;; 6 | 7 | let fold_min fold t ~cmp = 8 | fold t ~init:None ~f:(fun acc elt -> 9 | match acc with 10 | | None -> Some elt 11 | | Some min -> if cmp min elt > 0 then Some elt else acc) 12 | ;; 13 | 14 | let fold_max fold t ~cmp = 15 | fold t ~init:None ~f:(fun acc elt -> 16 | match acc with 17 | | None -> Some elt 18 | | Some max -> if cmp max elt < 0 then Some elt else acc) 19 | ;; 20 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_core_printf.ml: -------------------------------------------------------------------------------- 1 | include Printf 2 | 3 | (** failwith, invalid_arg, and exit accepting printf's format. *) 4 | 5 | let failwithf fmt = ksprintf (fun s () -> failwith s) fmt 6 | let invalid_argf fmt = ksprintf (fun s () -> invalid_arg s) fmt 7 | let exitf fmt = ksprintf (fun s () -> Printf.eprintf "%s\n%!" s; exit 1) fmt 8 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_monad.ml: -------------------------------------------------------------------------------- 1 | module type Basic = sig 2 | type 'a t 3 | val bind : 'a t -> ('a -> 'b t) -> 'b t 4 | val return : 'a -> 'a t 5 | 6 | (* The [map] argument to [Monad.Make] says how to implement the monad's [map] function. 7 | [`Define_using_bind] means to define [map t ~f = bind t (fun a -> return (f a))]. 8 | [`Custom] overrides the default implementation, presumably with something more 9 | efficient. 10 | 11 | Some other functions returned by [Monad.Make] are defined in terms of [map], so 12 | passing in a more efficient [map] will improve their efficiency as well. *) 13 | val map : [ `Define_using_bind 14 | | `Custom of ('a t -> f:('a -> 'b) -> 'b t) 15 | ] 16 | end 17 | 18 | module type Infix = sig 19 | type 'a t 20 | 21 | (** [t >>= f] returns a computation that sequences the computations represented by two 22 | monad elements. The resulting computation first does [t] to yield a value [v], and 23 | then runs the computation returned by [f v]. *) 24 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 25 | 26 | (** [t >>| f] is [t >>= (fun a -> return (f a))]. *) 27 | val (>>|) : 'a t -> ('a -> 'b) -> 'b t 28 | 29 | end 30 | 31 | module type S = sig 32 | (** A monad is an abstraction of the concept of sequencing of computations. A value of 33 | type 'a monad represents a computation that returns a value of type 'a. *) 34 | include Infix 35 | 36 | module Monad_infix : Infix with type 'a t := 'a t 37 | 38 | (** [bind t f] = [t >>= f] *) 39 | val bind : 'a t -> ('a -> 'b t) -> 'b t 40 | 41 | (** [return v] returns the (trivial) computation that returns v. *) 42 | val return : 'a -> 'a t 43 | 44 | (** [map t ~f] is t >>| f. *) 45 | val map : 'a t -> f:('a -> 'b) -> 'b t 46 | 47 | (** [join t] is [t >>= (fun t' -> t')]. *) 48 | val join : 'a t t -> 'a t 49 | 50 | (** [ignore t] = map t ~f:(fun _ -> ()). *) 51 | val ignore : 'a t -> unit t 52 | 53 | val all : 'a t list -> 'a list t 54 | val all_ignore : unit t list -> unit t 55 | end 56 | 57 | module Make (M : Basic) : S with type 'a t := 'a M.t = struct 58 | 59 | let bind = M.bind 60 | let return = M.return 61 | 62 | let map_via_bind ma ~f = M.bind ma (fun a -> M.return (f a)) 63 | 64 | let map = 65 | match M.map with 66 | | `Define_using_bind -> map_via_bind 67 | | `Custom x -> x 68 | 69 | module Monad_infix = struct 70 | 71 | let (>>=) = bind 72 | 73 | let (>>|) t f = map t ~f 74 | end 75 | 76 | include Monad_infix 77 | 78 | let join t = t >>= fun t' -> t' 79 | 80 | let ignore t = map t ~f:(fun _ -> ()) 81 | 82 | let all = 83 | let rec loop vs = function 84 | | [] -> return (List.rev vs) 85 | | t :: ts -> t >>= fun v -> loop (v :: vs) ts 86 | in 87 | fun ts -> loop [] ts 88 | 89 | let rec all_ignore = function 90 | | [] -> return () 91 | | t :: ts -> t >>= fun () -> all_ignore ts 92 | 93 | end 94 | 95 | (** 96 | Multi parameter monad. 97 | The second parameter get unified across all the computation. This is used 98 | to encode monads working on a multi parameter data structure like 99 | ([('a,'b result)]). 100 | *) 101 | module type Basic2 = sig 102 | type ('a, 'd) t 103 | val bind : ('a, 'd) t -> ('a -> ('b, 'd) t) -> ('b, 'd) t 104 | val map : [ `Define_using_bind 105 | | `Custom of (('a, 'd) t -> f:('a -> 'b) -> ('b, 'd) t) 106 | ] 107 | val return : 'a -> ('a, _) t 108 | end 109 | 110 | (** Same as Infix, except the monad type has two arguments. The second is always just 111 | passed through. *) 112 | module type Infix2 = sig 113 | type ('a, 'd) t 114 | val (>>=) : ('a, 'd) t -> ('a -> ('b, 'd) t) -> ('b, 'd) t 115 | val (>>|) : ('a, 'd) t -> ('a -> 'b) -> ('b, 'd) t 116 | end 117 | 118 | (** The same as S except the monad type has two arguments. The second is always just 119 | passed through. *) 120 | module type S2 = sig 121 | include Infix2 122 | 123 | module Monad_infix : Infix2 with type ('a, 'd) t := ('a, 'd) t 124 | 125 | val bind : ('a, 'd) t -> ('a -> ('b, 'd) t) -> ('b, 'd) t 126 | 127 | val return : 'a -> ('a, _) t 128 | 129 | val map : ('a, 'd) t -> f:('a -> 'b) -> ('b, 'd) t 130 | 131 | val join : (('a, 'd) t, 'd) t -> ('a, 'd) t 132 | 133 | val ignore : (_, 'd) t -> (unit, 'd) t 134 | 135 | val all : ('a, 'd) t list -> ('a list, 'd) t 136 | 137 | val all_ignore : (unit, 'd) t list -> (unit, 'd) t 138 | end 139 | 140 | module Check_S2_refines_S (X : S) : (S2 with type ('a, 'd) t = 'a X.t) = 141 | struct 142 | type ('a, 'd) t = 'a X.t 143 | include struct 144 | open X 145 | let (>>=) = (>>=) 146 | let (>>|) = (>>|) 147 | let bind = bind 148 | let return = return 149 | let map = map 150 | let join = join 151 | let ignore = ignore 152 | let all = all 153 | let all_ignore = all_ignore 154 | end 155 | module Monad_infix = struct 156 | open X.Monad_infix 157 | let (>>=) = (>>=) 158 | let (>>|) = (>>|) 159 | end 160 | end 161 | 162 | module Make2 (M : Basic2) : S2 with type ('a, 'd) t := ('a, 'd) M.t = struct 163 | 164 | let bind = M.bind 165 | let return = M.return 166 | 167 | let map_via_bind ma ~f = M.bind ma (fun a -> M.return (f a)) 168 | 169 | let map = 170 | match M.map with 171 | | `Define_using_bind -> map_via_bind 172 | | `Custom x -> x 173 | 174 | module Monad_infix = struct 175 | 176 | let (>>=) = bind 177 | 178 | let (>>|) t f = map t ~f 179 | end 180 | 181 | include Monad_infix 182 | 183 | let join t = t >>= fun t' -> t' 184 | 185 | let ignore t = map t ~f:(fun _ -> ()) 186 | 187 | let all = 188 | let rec loop vs = function 189 | | [] -> return (List.rev vs) 190 | | t :: ts -> t >>= fun v -> loop (v :: vs) ts 191 | in 192 | fun ts -> loop [] ts 193 | 194 | let rec all_ignore = function 195 | | [] -> return () 196 | | t :: ts -> t >>= fun () -> all_ignore ts 197 | 198 | end 199 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_option.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a option 2 | 3 | let is_none = function None -> true | _ -> false 4 | 5 | let is_some = function Some _ -> true | _ -> false 6 | 7 | let value_map o ~default ~f = 8 | match o with 9 | | Some x -> f x 10 | | None -> default 11 | 12 | let iter o ~f = 13 | match o with 14 | | None -> () 15 | | Some a -> f a 16 | 17 | let map2 o1 o2 ~f = 18 | match o1, o2 with 19 | | Some a1, Some a2 -> Some (f a1 a2) 20 | | _ -> None 21 | 22 | let call x ~f = 23 | match f with 24 | | None -> () 25 | | Some f -> f x 26 | 27 | let value t ~default = 28 | match t with 29 | | None -> default 30 | | Some x -> x 31 | ;; 32 | 33 | let to_array t = 34 | match t with 35 | | None -> [||] 36 | | Some x -> [|x|] 37 | ;; 38 | 39 | let to_list t = 40 | match t with 41 | | None -> [] 42 | | Some x -> [x] 43 | ;; 44 | 45 | let min_elt t ~cmp:_ = t 46 | let max_elt t ~cmp:_ = t 47 | 48 | let sum (type a) (module M : Hack_commutative_group.S with type t = a) t ~f = 49 | match t with 50 | | None -> M.zero 51 | | Some x -> f x 52 | ;; 53 | 54 | let for_all t ~f = 55 | match t with 56 | | None -> true 57 | | Some x -> f x 58 | ;; 59 | 60 | let exists t ~f = 61 | match t with 62 | | None -> false 63 | | Some x -> f x 64 | ;; 65 | 66 | let mem ?(equal = (=)) t a = 67 | match t with 68 | | None -> false 69 | | Some a' -> equal a a' 70 | ;; 71 | 72 | let length t = 73 | match t with 74 | | None -> 0 75 | | Some _ -> 1 76 | ;; 77 | 78 | let is_empty = is_none 79 | 80 | let fold t ~init ~f = 81 | match t with 82 | | None -> init 83 | | Some x -> f init x 84 | ;; 85 | 86 | let count t ~f = 87 | match t with 88 | | None -> 0 89 | | Some a -> if f a then 1 else 0 90 | ;; 91 | 92 | let find t ~f = 93 | match t with 94 | | None -> None 95 | | Some x -> if f x then Some x else None 96 | ;; 97 | 98 | let find_map t ~f = 99 | match t with 100 | | None -> None 101 | | Some a -> f a 102 | ;; 103 | 104 | let equal f t t' = 105 | match t, t' with 106 | | None, None -> true 107 | | Some x, Some x' -> f x x' 108 | | _ -> false 109 | 110 | let some x = Some x 111 | 112 | let both x y = 113 | match x,y with 114 | | Some a, Some b -> Some (a,b) 115 | | _ -> None 116 | 117 | let first_some x y = 118 | match x with 119 | | Some _ -> x 120 | | None -> y 121 | 122 | let some_if cond x = if cond then Some x else None 123 | 124 | let merge a b ~f = 125 | match a, b with 126 | | None, x | x, None -> x 127 | | Some a, Some b -> Some (f a b) 128 | 129 | let filter t ~f = 130 | match t with 131 | | Some v as o when f v -> o 132 | | _ -> None 133 | 134 | let try_with f = 135 | try Some (f ()) 136 | with _ -> None 137 | 138 | include Hack_monad.Make (struct 139 | type 'a t = 'a option 140 | let return x = Some x 141 | let map t ~f = 142 | match t with 143 | | None -> None 144 | | Some a -> Some (f a) 145 | ;; 146 | let map = `Custom map 147 | let bind o f = 148 | match o with 149 | | None -> None 150 | | Some x -> f x 151 | end) 152 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_poly.ml: -------------------------------------------------------------------------------- 1 | (** [Hack_poly] is a convenient shorthand for [Polymorphic_compare] in the common case that one 2 | wants to use a polymorphic comparator directly in an expression, e.g. [Hack_poly.equal a 3 | b]. *) 4 | 5 | include Hack_polymorphic_compare 6 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_polymorphic_compare.ml: -------------------------------------------------------------------------------- 1 | external compare : 'a -> 'a -> int = "%compare" 2 | external ascending : 'a -> 'a -> int = "%compare" 3 | let descending x y = compare y x 4 | 5 | let (<) = (<) 6 | let (<=) = (<=) 7 | let (>) = (>) 8 | let (>=) = (>=) 9 | let (=) = (=) 10 | let (<>) = (<>) 11 | let equal = (=) 12 | let min = min 13 | let max = max 14 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_polymorphic_compare.mli: -------------------------------------------------------------------------------- 1 | (* For use in combination with [No_polymorphic_compare]. *) 2 | 3 | val compare : 'a -> 'a -> int 4 | 5 | (** [ascending] is identical to [compare]. [descending x y = ascending y x]. These are 6 | intended to be mnemonic when used like [List.sort ~cmp:ascending] and [List.sort 7 | ~cmp:descending], since they cause the list to be sorted in ascending or descending 8 | order, respectively. *) 9 | val ascending : 'a -> 'a -> int 10 | val descending : 'a -> 'a -> int 11 | 12 | val (<) : 'a -> 'a -> bool 13 | val (<=) : 'a -> 'a -> bool 14 | val (>) : 'a -> 'a -> bool 15 | val (>=) : 'a -> 'a -> bool 16 | val (=) : 'a -> 'a -> bool 17 | val (<>) : 'a -> 'a -> bool 18 | val equal : 'a -> 'a -> bool 19 | val min : 'a -> 'a -> 'a 20 | val max : 'a -> 'a -> 'a 21 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_result.ml: -------------------------------------------------------------------------------- 1 | module Stable = struct 2 | module V1 = struct 3 | type ('a, 'b) t = ('a, 'b) Pervasives.result = 4 | | Ok of 'a 5 | | Error of 'b 6 | end 7 | end 8 | 9 | include Stable.V1 10 | 11 | type ('a, 'b) _t = ('a, 'b) t 12 | 13 | include Hack_monad.Make2 (struct 14 | type ('a, 'b) t = ('a,'b) _t 15 | 16 | let bind x f = match x with 17 | | Error _ as x -> x 18 | | Ok x -> f x 19 | 20 | let map x ~f = match x with 21 | | Error _ as x -> x 22 | | Ok x -> Ok (f x) 23 | 24 | let map = `Custom map 25 | 26 | let return x = Ok x 27 | end) 28 | 29 | let fail x = Error x;; 30 | let failf format = Printf.ksprintf fail format 31 | 32 | (* This definition shadows the version created by the functor application above, but it 33 | is much more efficient. *) 34 | let map t ~f = match t with 35 | | Ok x -> Ok (f x) 36 | | Error _ as x -> x 37 | 38 | let map_error t ~f = match t with 39 | | Ok _ as x -> x 40 | | Error x -> Error (f x) 41 | 42 | let is_ok = function 43 | | Ok _ -> true 44 | | Error _ -> false 45 | 46 | let is_error = function 47 | | Ok _ -> false 48 | | Error _ -> true 49 | 50 | let ok = function 51 | | Ok x -> Some x 52 | | Error _ -> None 53 | 54 | let error = function 55 | | Ok _ -> None 56 | | Error x -> Some x 57 | 58 | let of_option opt ~error = 59 | match opt with 60 | | Some x -> Ok x 61 | | None -> Error error 62 | 63 | let iter v ~f = match v with 64 | | Ok x -> f x 65 | | Error _ -> () 66 | 67 | let iter_error v ~f = match v with 68 | | Ok _ -> () 69 | | Error x -> f x 70 | 71 | let ok_fst = function 72 | | Ok x -> `Fst x 73 | | Error x -> `Snd x 74 | 75 | let ok_if_true bool ~error = 76 | if bool 77 | then Ok () 78 | else Error error 79 | 80 | let try_with f = 81 | try Ok (f ()) 82 | with exn -> Error exn 83 | 84 | let ok_unit = Ok () 85 | 86 | let ok_exn = function 87 | | Ok x -> x 88 | | Error exn -> raise exn 89 | 90 | let ok_or_failwith = function 91 | | Ok x -> x 92 | | Error str -> failwith str 93 | 94 | module Export = struct 95 | type ('ok, 'err) _result = 96 | ('ok, 'err) t = 97 | | Ok of 'ok 98 | | Error of 'err 99 | 100 | let is_error = is_error 101 | let is_ok = is_ok 102 | end 103 | 104 | let combine t1 t2 ~ok ~err = 105 | match t1, t2 with 106 | | Ok _, Error e | Error e, Ok _ -> Error e 107 | | Ok ok1 , Ok ok2 -> Ok (ok ok1 ok2 ) 108 | | Error err1, Error err2 -> Error (err err1 err2) 109 | ;; 110 | -------------------------------------------------------------------------------- /src/third-party/hack_core/hack_result.mli: -------------------------------------------------------------------------------- 1 | (** [Result] is often used to handle error messages. *) 2 | 3 | (** ['a] is a function's expected return type, and ['b] is often an error message string. 4 | {[let ric_of_ticker = function 5 | | "IBM" -> Ok "IBM.N" 6 | | "MSFT" -> Ok "MSFT.OQ" 7 | | "AA" -> Ok "AA.N" 8 | | "CSCO" -> Ok "CSCO.OQ" 9 | | _ as ticker -> Error (sprintf "can't find ric of %s" ticker) ]} 10 | The return type of ric_of_ticker could be [string option], but [(string, string) 11 | Result.t] gives more control over the error message. *) 12 | type ('ok, 'err) t = ('ok, 'err) Pervasives.result = 13 | | Ok of 'ok 14 | | Error of 'err 15 | 16 | include Hack_monad.S2 with type ('a,'err) t := ('a,'err) t 17 | 18 | 19 | val fail : 'err -> (_, 'err) t 20 | 21 | (** e.g. [failf "Couldn't find bloogle %s" (Bloogle.to_string b)] *) 22 | val failf : ('a, unit, string, (_, string) t) format4 -> 'a 23 | 24 | val is_ok : (_, _) t -> bool 25 | val is_error : (_, _) t -> bool 26 | 27 | val ok : ('ok, _ ) t -> 'ok option 28 | val error : (_ , 'err) t -> 'err option 29 | 30 | val of_option : 'ok option -> error:'err -> ('ok, 'err) t 31 | 32 | val iter : ('ok, _ ) t -> f:('ok -> unit) -> unit 33 | val iter_error : (_ , 'err) t -> f:('err -> unit) -> unit 34 | 35 | val map : ('ok, 'err) t -> f:('ok -> 'c) -> ('c , 'err) t 36 | val map_error : ('ok, 'err) t -> f:('err -> 'c) -> ('ok, 'c ) t 37 | 38 | (* Returns Ok if both are Ok and Error otherwise. *) 39 | val combine 40 | : ('ok1, 'err) t 41 | -> ('ok2, 'err) t 42 | -> ok: ('ok1 -> 'ok2 -> 'ok3) 43 | -> err:('err -> 'err -> 'err) 44 | -> ('ok3, 'err) t 45 | 46 | (** [ok_fst] is useful with [List.partition_map]. Continuing the above example: 47 | {[ 48 | let rics, errors = List.partition_map ~f:Result.ok_fst 49 | (List.map ~f:ric_of_ticker ["AA"; "F"; "CSCO"; "AAPL"]) ]} *) 50 | val ok_fst : ('ok, 'err) t -> [ `Fst of 'ok | `Snd of 'err ] 51 | 52 | (* [ok_if_true] returns [Ok ()] if [bool] is true, and [Error error] if it is false *) 53 | val ok_if_true : bool -> error : 'err -> (unit, 'err) t 54 | 55 | val try_with : (unit -> 'a) -> ('a, exn) t 56 | 57 | (** [ok_exn t] returns [x] if [t = Ok x], and raises [exn] if [t = Error exn] *) 58 | val ok_exn : ('ok, exn) t -> 'ok 59 | 60 | (* raises Failure in the Error case *) 61 | val ok_or_failwith : ('ok, string) t -> 'ok 62 | 63 | (** [ok_unit = Ok ()], used to avoid allocation as a performance hack *) 64 | val ok_unit : (unit, _) t 65 | 66 | module Export : sig 67 | type ('ok, 'err) _result = 68 | ('ok, 'err) t = 69 | | Ok of 'ok 70 | | Error of 'err 71 | 72 | val is_ok : (_, _) t -> bool 73 | val is_error : (_, _) t -> bool 74 | end 75 | 76 | module Stable : sig 77 | module V1 : sig 78 | type ('ok, 'err) t = 79 | | Ok of 'ok 80 | | Error of 'err 81 | end 82 | end 83 | -------------------------------------------------------------------------------- /src/third-party/inotify/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name inotify) 3 | (public_name hack_parallel.inotify) 4 | (wrapped false)) 5 | -------------------------------------------------------------------------------- /src/third-party/inotify/inotify_stubs.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2006-2008 Vincent Hanquez 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * Inotify Ocaml binding - C glue 15 | */ 16 | 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | #include 29 | #include 30 | 31 | #include 32 | #include 33 | 34 | static int inotify_flag_table[] = { 35 | IN_ACCESS, IN_ATTRIB, IN_CLOSE_WRITE, IN_CLOSE_NOWRITE, 36 | IN_CREATE, IN_DELETE, IN_DELETE_SELF, IN_MODIFY, 37 | IN_MOVE_SELF, IN_MOVED_FROM, IN_MOVED_TO, IN_OPEN, 38 | IN_DONT_FOLLOW, IN_MASK_ADD, IN_ONESHOT, IN_ONLYDIR, 39 | IN_MOVE, IN_CLOSE, IN_ALL_EVENTS, 0 40 | }; 41 | 42 | static int inotify_return_table[] = { 43 | IN_ACCESS, IN_ATTRIB, IN_CLOSE_WRITE, IN_CLOSE_NOWRITE, 44 | IN_CREATE, IN_DELETE, IN_DELETE_SELF, IN_MODIFY, 45 | IN_MOVE_SELF, IN_MOVED_FROM, IN_MOVED_TO, IN_OPEN, 46 | IN_IGNORED, IN_ISDIR, IN_Q_OVERFLOW, IN_UNMOUNT, 0 47 | }; 48 | 49 | value caml_inotify_init(value unit) { 50 | CAMLparam1(unit); 51 | 52 | int fd = inotify_init(); 53 | if (fd == -1) uerror("inotify_init", Nothing); 54 | 55 | CAMLreturn(Val_int(fd)); 56 | } 57 | 58 | value caml_inotify_add_watch(value fd, value path, value selector_flags) { 59 | CAMLparam3(fd, path, selector_flags); 60 | 61 | int selector = caml_convert_flag_list(selector_flags, inotify_flag_table); 62 | 63 | int watch = inotify_add_watch(Int_val(fd), String_val(path), selector); 64 | if (watch == -1) uerror("inotify_add_watch", path); 65 | 66 | CAMLreturn(Val_int(watch)); 67 | } 68 | 69 | value caml_inotify_rm_watch(value fd, value watch) { 70 | CAMLparam2(fd, watch); 71 | 72 | int ret = inotify_rm_watch(Int_val(fd), Int_val(watch)); 73 | if (ret == -1) uerror("inotify_rm_watch", Nothing); 74 | 75 | CAMLreturn(Val_unit); 76 | } 77 | 78 | value caml_inotify_struct_size(void) { 79 | CAMLparam0(); 80 | CAMLreturn(Val_int(sizeof(struct inotify_event))); 81 | } 82 | 83 | value caml_inotify_name_max(void) { 84 | CAMLparam0(); 85 | CAMLreturn(Val_int(NAME_MAX)); 86 | } 87 | 88 | value caml_inotify_convert(value buf) { 89 | CAMLparam1(buf); 90 | CAMLlocal3(event, list, next); 91 | 92 | list = next = Val_emptylist; 93 | 94 | struct inotify_event ievent; 95 | memcpy(&ievent, String_val(buf), sizeof(struct inotify_event)); 96 | 97 | int flag; 98 | for (flag = 0; inotify_return_table[flag]; flag++) { 99 | if (!(ievent.mask & inotify_return_table[flag])) 100 | continue; 101 | 102 | next = caml_alloc_small(2, Tag_cons); 103 | Field(next, 0) = Val_int(flag); 104 | Field(next, 1) = list; 105 | list = next; 106 | } 107 | 108 | event = caml_alloc_tuple(4); 109 | Store_field(event, 0, Val_int(ievent.wd)); 110 | Store_field(event, 1, list); 111 | Store_field(event, 2, caml_copy_int32(ievent.cookie)); 112 | Store_field(event, 3, Val_int(ievent.len)); 113 | 114 | CAMLreturn(event); 115 | } 116 | -------------------------------------------------------------------------------- /src/third-party/lz4/LICENSE: -------------------------------------------------------------------------------- 1 | LZ4 Library 2 | Copyright (c) 2011-2014, Yann Collet 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without modification, 6 | are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright notice, this 12 | list of conditions and the following disclaimer in the documentation and/or 13 | other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 19 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 22 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /src/third-party/lz4/Makefile: -------------------------------------------------------------------------------- 1 | # ################################################################ 2 | # LZ4 library - Makefile 3 | # Copyright (C) Yann Collet 2011-2015 4 | # All rights reserved. 5 | # 6 | # BSD license 7 | # Redistribution and use in source and binary forms, with or without modification, 8 | # are permitted provided that the following conditions are met: 9 | # 10 | # * Redistributions of source code must retain the above copyright notice, this 11 | # list of conditions and the following disclaimer. 12 | # 13 | # * Redistributions in binary form must reproduce the above copyright notice, this 14 | # list of conditions and the following disclaimer in the documentation and/or 15 | # other materials provided with the distribution. 16 | # 17 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | # DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 21 | # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 24 | # ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | # 28 | # You can contact the author at : 29 | # - LZ4 source repository : https://github.com/Cyan4973/lz4 30 | # - LZ4 forum froup : https://groups.google.com/forum/#!forum/lz4c 31 | # ################################################################ 32 | 33 | # Version numbers 34 | VERSION ?= 129 35 | LIBVER_MAJOR=`sed -n '/define LZ4_VERSION_MAJOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < lz4.h` 36 | LIBVER_MINOR=`sed -n '/define LZ4_VERSION_MINOR/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < lz4.h` 37 | LIBVER_PATCH=`sed -n '/define LZ4_VERSION_RELEASE/s/.*[[:blank:]]\([0-9][0-9]*\).*/\1/p' < lz4.h` 38 | LIBVER=$(LIBVER_MAJOR).$(LIBVER_MINOR).$(LIBVER_PATCH) 39 | 40 | DESTDIR?= 41 | PREFIX ?= /usr/local 42 | CFLAGS ?= -O3 43 | CFLAGS += -I. -std=c99 -Wall -Wextra -Wundef -Wshadow -Wcast-align -Wcast-qual -Wstrict-prototypes -pedantic -DXXH_NAMESPACE=LZ4_ 44 | 45 | LIBDIR?= $(PREFIX)/lib 46 | INCLUDEDIR=$(PREFIX)/include 47 | 48 | 49 | # OS X linker doesn't support -soname, and use different extension 50 | # see : https://developer.apple.com/library/mac/documentation/DeveloperTools/Conceptual/DynamicLibraries/100-Articles/DynamicLibraryDesignGuidelines.html 51 | ifeq ($(shell uname), Darwin) 52 | SHARED_EXT = dylib 53 | SHARED_EXT_MAJOR = $(LIBVER_MAJOR).$(SHARED_EXT) 54 | SHARED_EXT_VER = $(LIBVER).$(SHARED_EXT) 55 | SONAME_FLAGS = -install_name $(PREFIX)/lib/liblz4.$(SHARED_EXT_MAJOR) -compatibility_version $(LIBVER_MAJOR) -current_version $(LIBVER) 56 | else 57 | SONAME_FLAGS = -Wl,-soname=liblz4.$(SHARED_EXT).$(LIBVER_MAJOR) 58 | SHARED_EXT = so 59 | SHARED_EXT_MAJOR = $(SHARED_EXT).$(LIBVER_MAJOR) 60 | SHARED_EXT_VER = $(SHARED_EXT).$(LIBVER) 61 | endif 62 | 63 | default: liblz4 64 | 65 | all: liblz4 66 | 67 | liblz4: lz4.c lz4hc.c lz4frame.c xxhash.c 68 | @echo compiling static library 69 | @$(CC) $(CPPFLAGS) $(CFLAGS) -c $^ 70 | @$(AR) rcs liblz4.a lz4.o lz4hc.o lz4frame.o xxhash.o 71 | @echo compiling dynamic library $(LIBVER) 72 | @$(CC) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) -shared $^ -fPIC $(SONAME_FLAGS) -o $@.$(SHARED_EXT_VER) 73 | @echo creating versioned links 74 | @ln -sf $@.$(SHARED_EXT_VER) $@.$(SHARED_EXT_MAJOR) 75 | @ln -sf $@.$(SHARED_EXT_VER) $@.$(SHARED_EXT) 76 | 77 | clean: 78 | @rm -f core *.o *.a *.$(SHARED_EXT) *.$(SHARED_EXT).* liblz4.pc 79 | @echo Cleaning library completed 80 | 81 | 82 | #------------------------------------------------------------------------ 83 | #make install is validated only for Linux, OSX, kFreeBSD and Hurd targets 84 | ifneq (,$(filter $(shell uname),Linux Darwin GNU/kFreeBSD GNU)) 85 | 86 | liblz4.pc: liblz4.pc.in Makefile 87 | @echo creating pkgconfig 88 | @sed -e 's|@PREFIX@|$(PREFIX)|' \ 89 | -e 's|@LIBDIR@|$(LIBDIR)|' \ 90 | -e 's|@INCLUDEDIR@|$(INCLUDEDIR)|' \ 91 | -e 's|@VERSION@|$(VERSION)|' \ 92 | $< >$@ 93 | 94 | install: liblz4 liblz4.pc 95 | @install -d -m 755 $(DESTDIR)$(LIBDIR)/pkgconfig/ $(DESTDIR)$(INCLUDEDIR)/ 96 | @install -m 755 liblz4.$(SHARED_EXT_VER) $(DESTDIR)$(LIBDIR)/liblz4.$(SHARED_EXT_VER) 97 | @cp -a liblz4.$(SHARED_EXT_MAJOR) $(DESTDIR)$(LIBDIR) 98 | @cp -a liblz4.$(SHARED_EXT) $(DESTDIR)$(LIBDIR) 99 | @cp -a liblz4.pc $(DESTDIR)$(LIBDIR)/pkgconfig/ 100 | @install -m 644 liblz4.a $(DESTDIR)$(LIBDIR)/liblz4.a 101 | @install -m 644 lz4.h $(DESTDIR)$(INCLUDEDIR)/lz4.h 102 | @install -m 644 lz4hc.h $(DESTDIR)$(INCLUDEDIR)/lz4hc.h 103 | @install -m 644 lz4frame.h $(DESTDIR)$(INCLUDEDIR)/lz4frame.h 104 | @echo lz4 static and shared library installed 105 | 106 | uninstall: 107 | @rm -f $(DESTDIR)$(LIBDIR)/liblz4.$(SHARED_EXT) 108 | @rm -f $(DESTDIR)$(LIBDIR)/liblz4.$(SHARED_EXT_MAJOR) 109 | @rm -f $(DESTDIR)$(LIBDIR)/pkgconfig/liblz4.pc 110 | @[ -x $(DESTDIR)$(LIBDIR)/liblz4.$(SHARED_EXT_VER) ] && rm -f $(DESTDIR)$(LIBDIR)/liblz4.$(SHARED_EXT_VER) 111 | @[ -f $(DESTDIR)$(LIBDIR)/liblz4.a ] && rm -f $(DESTDIR)$(LIBDIR)/liblz4.a 112 | @[ -f $(DESTDIR)$(INCLUDEDIR)/lz4.h ] && rm -f $(DESTDIR)$(INCLUDEDIR)/lz4.h 113 | @[ -f $(DESTDIR)$(INCLUDEDIR)/lz4hc.h ] && rm -f $(DESTDIR)$(INCLUDEDIR)/lz4hc.h 114 | @[ -f $(DESTDIR)$(INCLUDEDIR)/lz4frame.h ] && rm -f $(DESTDIR)$(INCLUDEDIR)/lz4frame.h 115 | @echo lz4 libraries successfully uninstalled 116 | 117 | endif 118 | -------------------------------------------------------------------------------- /src/third-party/lz4/README.md: -------------------------------------------------------------------------------- 1 | LZ4 - Library Files 2 | ================================ 3 | 4 | The __lib__ directory contains several files, but you don't necessarily need them all. 5 | 6 | To integrate fast LZ4 compression/decompression into your program, you basically just need "**lz4.c**" and "**lz4.h**". 7 | 8 | For more compression at the cost of compression speed (while preserving decompression speed), use **lz4hc** on top of regular lz4. `lz4hc` only provides compression functions. It also needs `lz4` to compile properly. 9 | 10 | If you want to produce files or data streams compatible with `lz4` command line utility, use **lz4frame**. This library encapsulates lz4-compressed blocks into the [official interoperable frame format]. In order to work properly, lz4frame needs lz4 and lz4hc, and also **xxhash**, which provides error detection algorithm. 11 | (_Advanced stuff_ : It's possible to hide xxhash symbols into a local namespace. This is what `liblz4` does, to avoid symbol duplication in case a user program would link to several libraries containing xxhash symbols.) 12 | 13 | A more complex "lz4frame_static.h" is also provided, although its usage is not recommended. It contains definitions which are not guaranteed to remain stable within future versions. Use for static linking ***only***. 14 | 15 | The other files are not source code. There are : 16 | 17 | - LICENSE : contains the BSD license text 18 | - Makefile : script to compile or install lz4 library (static or dynamic) 19 | - liblz4.pc.in : for pkg-config (make install) 20 | 21 | [official interoperable frame format]: ../lz4_Frame_format.md 22 | -------------------------------------------------------------------------------- /src/third-party/lz4/VERSION: -------------------------------------------------------------------------------- 1 | https://github.com/Cyan4973/lz4 @ r131 2 | -------------------------------------------------------------------------------- /src/third-party/lz4/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lz4) 3 | (modules) 4 | (c_names 5 | lz4 6 | lz4frame 7 | lz4hc 8 | xxhash) 9 | (public_name hack_parallel.lz4) 10 | (wrapped false)) 11 | -------------------------------------------------------------------------------- /src/third-party/lz4/liblz4.pc.in: -------------------------------------------------------------------------------- 1 | # LZ4 - Fast LZ compression algorithm 2 | # Copyright (C) 2011-2014, Yann Collet. 3 | # BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php) 4 | 5 | prefix=@PREFIX@ 6 | libdir=@LIBDIR@ 7 | includedir=@INCLUDEDIR@ 8 | 9 | Name: lz4 10 | Description: fast lossless compression algorithm library 11 | URL: http://code.google.com/p/lz4/ 12 | Version: @VERSION@ 13 | Libs: -L@LIBDIR@ -llz4 14 | Cflags: -I@INCLUDEDIR@ 15 | -------------------------------------------------------------------------------- /src/third-party/lz4/lz4frame_static.h: -------------------------------------------------------------------------------- 1 | /* 2 | LZ4 auto-framing library 3 | Header File for static linking only 4 | Copyright (C) 2011-2015, Yann Collet. 5 | 6 | BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php) 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions are 10 | met: 11 | 12 | * Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | * Redistributions in binary form must reproduce the above 15 | copyright notice, this list of conditions and the following disclaimer 16 | in the documentation and/or other materials provided with the 17 | distribution. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | You can contact the author at : 32 | - LZ4 source repository : https://github.com/Cyan4973/lz4 33 | - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c 34 | */ 35 | 36 | #pragma once 37 | 38 | #if defined (__cplusplus) 39 | extern "C" { 40 | #endif 41 | 42 | /* lz4frame_static.h should be used solely in the context of static linking. 43 | * It contains definitions which may still change overtime. 44 | * Never use it in the context of DLL linking. 45 | * */ 46 | 47 | 48 | /************************************** 49 | * Includes 50 | **************************************/ 51 | #include "lz4frame.h" 52 | 53 | 54 | /************************************** 55 | * Error management 56 | * ************************************/ 57 | #define LZ4F_LIST_ERRORS(ITEM) \ 58 | ITEM(OK_NoError) ITEM(ERROR_GENERIC) \ 59 | ITEM(ERROR_maxBlockSize_invalid) ITEM(ERROR_blockMode_invalid) ITEM(ERROR_contentChecksumFlag_invalid) \ 60 | ITEM(ERROR_compressionLevel_invalid) \ 61 | ITEM(ERROR_headerVersion_wrong) ITEM(ERROR_blockChecksum_unsupported) ITEM(ERROR_reservedFlag_set) \ 62 | ITEM(ERROR_allocation_failed) \ 63 | ITEM(ERROR_srcSize_tooLarge) ITEM(ERROR_dstMaxSize_tooSmall) \ 64 | ITEM(ERROR_frameHeader_incomplete) ITEM(ERROR_frameType_unknown) ITEM(ERROR_frameSize_wrong) \ 65 | ITEM(ERROR_srcPtr_wrong) \ 66 | ITEM(ERROR_decompressionFailed) \ 67 | ITEM(ERROR_headerChecksum_invalid) ITEM(ERROR_contentChecksum_invalid) \ 68 | ITEM(ERROR_maxCode) 69 | 70 | //#define LZ4F_DISABLE_OLD_ENUMS 71 | #ifndef LZ4F_DISABLE_OLD_ENUMS 72 | #define LZ4F_GENERATE_ENUM(ENUM) LZ4F_##ENUM, ENUM = LZ4F_##ENUM, 73 | #else 74 | #define LZ4F_GENERATE_ENUM(ENUM) LZ4F_##ENUM, 75 | #endif 76 | typedef enum { LZ4F_LIST_ERRORS(LZ4F_GENERATE_ENUM) } LZ4F_errorCodes; /* enum is exposed, to handle specific errors; compare function result to -enum value */ 77 | 78 | 79 | #if defined (__cplusplus) 80 | } 81 | #endif 82 | -------------------------------------------------------------------------------- /src/third-party/lz4/lz4hc.h: -------------------------------------------------------------------------------- 1 | /* 2 | LZ4 HC - High Compression Mode of LZ4 3 | Header File 4 | Copyright (C) 2011-2015, Yann Collet. 5 | BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php) 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | * Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | * Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following disclaimer 15 | in the documentation and/or other materials provided with the 16 | distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | You can contact the author at : 31 | - LZ4 source repository : https://github.com/Cyan4973/lz4 32 | - LZ4 public forum : https://groups.google.com/forum/#!forum/lz4c 33 | */ 34 | #pragma once 35 | 36 | 37 | #if defined (__cplusplus) 38 | extern "C" { 39 | #endif 40 | 41 | /***************************** 42 | * Includes 43 | *****************************/ 44 | #include /* size_t */ 45 | 46 | 47 | /************************************** 48 | * Block Compression 49 | **************************************/ 50 | int LZ4_compress_HC (const char* src, char* dst, int srcSize, int maxDstSize, int compressionLevel); 51 | /* 52 | LZ4_compress_HC : 53 | Destination buffer 'dst' must be already allocated. 54 | Compression completion is guaranteed if 'dst' buffer is sized to handle worst circumstances (data not compressible) 55 | Worst size evaluation is provided by function LZ4_compressBound() (see "lz4.h") 56 | srcSize : Max supported value is LZ4_MAX_INPUT_SIZE (see "lz4.h") 57 | compressionLevel : Recommended values are between 4 and 9, although any value between 0 and 16 will work. 58 | 0 means "use default value" (see lz4hc.c). 59 | Values >16 behave the same as 16. 60 | return : the number of bytes written into buffer 'dst' 61 | or 0 if compression fails. 62 | */ 63 | 64 | 65 | /* Note : 66 | Decompression functions are provided within LZ4 source code (see "lz4.h") (BSD license) 67 | */ 68 | 69 | 70 | int LZ4_sizeofStateHC(void); 71 | int LZ4_compress_HC_extStateHC(void* state, const char* src, char* dst, int srcSize, int maxDstSize, int compressionLevel); 72 | /* 73 | LZ4_compress_HC_extStateHC() : 74 | Use this function if you prefer to manually allocate memory for compression tables. 75 | To know how much memory must be allocated for the compression tables, use : 76 | int LZ4_sizeofStateHC(); 77 | 78 | Allocated memory must be aligned on 8-bytes boundaries (which a normal malloc() will do properly). 79 | 80 | The allocated memory can then be provided to the compression functions using 'void* state' parameter. 81 | LZ4_compress_HC_extStateHC() is equivalent to previously described function. 82 | It just uses externally allocated memory for stateHC. 83 | */ 84 | 85 | 86 | /************************************** 87 | * Streaming Compression 88 | **************************************/ 89 | #define LZ4_STREAMHCSIZE 262192 90 | #define LZ4_STREAMHCSIZE_SIZET (LZ4_STREAMHCSIZE / sizeof(size_t)) 91 | typedef struct { size_t table[LZ4_STREAMHCSIZE_SIZET]; } LZ4_streamHC_t; 92 | /* 93 | LZ4_streamHC_t 94 | This structure allows static allocation of LZ4 HC streaming state. 95 | State must then be initialized using LZ4_resetStreamHC() before first use. 96 | 97 | Static allocation should only be used in combination with static linking. 98 | If you want to use LZ4 as a DLL, please use construction functions below, which are future-proof. 99 | */ 100 | 101 | 102 | LZ4_streamHC_t* LZ4_createStreamHC(void); 103 | int LZ4_freeStreamHC (LZ4_streamHC_t* streamHCPtr); 104 | /* 105 | These functions create and release memory for LZ4 HC streaming state. 106 | Newly created states are already initialized. 107 | Existing state space can be re-used anytime using LZ4_resetStreamHC(). 108 | If you use LZ4 as a DLL, use these functions instead of static structure allocation, 109 | to avoid size mismatch between different versions. 110 | */ 111 | 112 | void LZ4_resetStreamHC (LZ4_streamHC_t* streamHCPtr, int compressionLevel); 113 | int LZ4_loadDictHC (LZ4_streamHC_t* streamHCPtr, const char* dictionary, int dictSize); 114 | 115 | int LZ4_compress_HC_continue (LZ4_streamHC_t* streamHCPtr, const char* src, char* dst, int srcSize, int maxDstSize); 116 | 117 | int LZ4_saveDictHC (LZ4_streamHC_t* streamHCPtr, char* safeBuffer, int maxDictSize); 118 | 119 | /* 120 | These functions compress data in successive blocks of any size, using previous blocks as dictionary. 121 | One key assumption is that previous blocks (up to 64 KB) remain read-accessible while compressing next blocks. 122 | There is an exception for ring buffers, which can be smaller 64 KB. 123 | Such case is automatically detected and correctly handled by LZ4_compress_HC_continue(). 124 | 125 | Before starting compression, state must be properly initialized, using LZ4_resetStreamHC(). 126 | A first "fictional block" can then be designated as initial dictionary, using LZ4_loadDictHC() (Optional). 127 | 128 | Then, use LZ4_compress_HC_continue() to compress each successive block. 129 | It works like LZ4_compress_HC(), but use previous memory blocks as dictionary to improve compression. 130 | Previous memory blocks (including initial dictionary when present) must remain accessible and unmodified during compression. 131 | As a reminder, size 'dst' buffer to handle worst cases, using LZ4_compressBound(), to ensure success of compression operation. 132 | 133 | If, for any reason, previous data blocks can't be preserved unmodified in memory during next compression block, 134 | you must save it to a safer memory space, using LZ4_saveDictHC(). 135 | Return value of LZ4_saveDictHC() is the size of dictionary effectively saved into 'safeBuffer'. 136 | */ 137 | 138 | 139 | 140 | /************************************** 141 | * Deprecated Functions 142 | **************************************/ 143 | /* Deprecate Warnings */ 144 | /* Should these warnings messages be a problem, 145 | it is generally possible to disable them, 146 | with -Wno-deprecated-declarations for gcc 147 | or _CRT_SECURE_NO_WARNINGS in Visual for example. 148 | You can also define LZ4_DEPRECATE_WARNING_DEFBLOCK. */ 149 | #ifndef LZ4_DEPRECATE_WARNING_DEFBLOCK 150 | # define LZ4_DEPRECATE_WARNING_DEFBLOCK 151 | # define LZ4_GCC_VERSION (__GNUC__ * 100 + __GNUC_MINOR__) 152 | # if (LZ4_GCC_VERSION >= 405) || defined(__clang__) 153 | # define LZ4_DEPRECATED(message) __attribute__((deprecated(message))) 154 | # elif (LZ4_GCC_VERSION >= 301) 155 | # define LZ4_DEPRECATED(message) __attribute__((deprecated)) 156 | # elif defined(_MSC_VER) 157 | # define LZ4_DEPRECATED(message) __declspec(deprecated(message)) 158 | # else 159 | # pragma message("WARNING: You need to implement LZ4_DEPRECATED for this compiler") 160 | # define LZ4_DEPRECATED(message) 161 | # endif 162 | #endif // LZ4_DEPRECATE_WARNING_DEFBLOCK 163 | 164 | /* compression functions */ 165 | /* these functions are planned to trigger warning messages by r131 approximately */ 166 | int LZ4_compressHC (const char* source, char* dest, int inputSize); 167 | int LZ4_compressHC_limitedOutput (const char* source, char* dest, int inputSize, int maxOutputSize); 168 | int LZ4_compressHC2 (const char* source, char* dest, int inputSize, int compressionLevel); 169 | int LZ4_compressHC2_limitedOutput (const char* source, char* dest, int inputSize, int maxOutputSize, int compressionLevel); 170 | int LZ4_compressHC_withStateHC (void* state, const char* source, char* dest, int inputSize); 171 | int LZ4_compressHC_limitedOutput_withStateHC (void* state, const char* source, char* dest, int inputSize, int maxOutputSize); 172 | int LZ4_compressHC2_withStateHC (void* state, const char* source, char* dest, int inputSize, int compressionLevel); 173 | int LZ4_compressHC2_limitedOutput_withStateHC(void* state, const char* source, char* dest, int inputSize, int maxOutputSize, int compressionLevel); 174 | int LZ4_compressHC_continue (LZ4_streamHC_t* LZ4_streamHCPtr, const char* source, char* dest, int inputSize); 175 | int LZ4_compressHC_limitedOutput_continue (LZ4_streamHC_t* LZ4_streamHCPtr, const char* source, char* dest, int inputSize, int maxOutputSize); 176 | 177 | /* Streaming functions following the older model; should no longer be used */ 178 | LZ4_DEPRECATED("use LZ4_createStreamHC() instead") void* LZ4_createHC (char* inputBuffer); 179 | LZ4_DEPRECATED("use LZ4_saveDictHC() instead") char* LZ4_slideInputBufferHC (void* LZ4HC_Data); 180 | LZ4_DEPRECATED("use LZ4_freeStreamHC() instead") int LZ4_freeHC (void* LZ4HC_Data); 181 | LZ4_DEPRECATED("use LZ4_compress_HC_continue() instead") int LZ4_compressHC2_continue (void* LZ4HC_Data, const char* source, char* dest, int inputSize, int compressionLevel); 182 | LZ4_DEPRECATED("use LZ4_compress_HC_continue() instead") int LZ4_compressHC2_limitedOutput_continue (void* LZ4HC_Data, const char* source, char* dest, int inputSize, int maxOutputSize, int compressionLevel); 183 | LZ4_DEPRECATED("use LZ4_createStreamHC() instead") int LZ4_sizeofStreamStateHC(void); 184 | LZ4_DEPRECATED("use LZ4_resetStreamHC() instead") int LZ4_resetStreamStateHC(void* state, char* inputBuffer); 185 | 186 | 187 | #if defined (__cplusplus) 188 | } 189 | #endif 190 | -------------------------------------------------------------------------------- /src/third-party/lz4/xxhash.h: -------------------------------------------------------------------------------- 1 | /* 2 | xxHash - Extremely Fast Hash algorithm 3 | Header File 4 | Copyright (C) 2012-2015, Yann Collet. 5 | 6 | BSD 2-Clause License (http://www.opensource.org/licenses/bsd-license.php) 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions are 10 | met: 11 | 12 | * Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | * Redistributions in binary form must reproduce the above 15 | copyright notice, this list of conditions and the following disclaimer 16 | in the documentation and/or other materials provided with the 17 | distribution. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | You can contact the author at : 32 | - xxHash source repository : https://github.com/Cyan4973/xxHash 33 | */ 34 | 35 | /* Notice extracted from xxHash homepage : 36 | 37 | xxHash is an extremely fast Hash algorithm, running at RAM speed limits. 38 | It also successfully passes all tests from the SMHasher suite. 39 | 40 | Comparison (single thread, Windows Seven 32 bits, using SMHasher on a Core 2 Duo @3GHz) 41 | 42 | Name Speed Q.Score Author 43 | xxHash 5.4 GB/s 10 44 | CrapWow 3.2 GB/s 2 Andrew 45 | MumurHash 3a 2.7 GB/s 10 Austin Appleby 46 | SpookyHash 2.0 GB/s 10 Bob Jenkins 47 | SBox 1.4 GB/s 9 Bret Mulvey 48 | Lookup3 1.2 GB/s 9 Bob Jenkins 49 | SuperFastHash 1.2 GB/s 1 Paul Hsieh 50 | CityHash64 1.05 GB/s 10 Pike & Alakuijala 51 | FNV 0.55 GB/s 5 Fowler, Noll, Vo 52 | CRC32 0.43 GB/s 9 53 | MD5-32 0.33 GB/s 10 Ronald L. Rivest 54 | SHA1-32 0.28 GB/s 10 55 | 56 | Q.Score is a measure of quality of the hash function. 57 | It depends on successfully passing SMHasher test set. 58 | 10 is a perfect score. 59 | 60 | A 64-bits version, named XXH64, is available since r35. 61 | It offers much better speed, but for 64-bits applications only. 62 | Name Speed on 64 bits Speed on 32 bits 63 | XXH64 13.8 GB/s 1.9 GB/s 64 | XXH32 6.8 GB/s 6.0 GB/s 65 | */ 66 | 67 | #pragma once 68 | 69 | #if defined (__cplusplus) 70 | extern "C" { 71 | #endif 72 | 73 | 74 | /***************************** 75 | * Definitions 76 | *****************************/ 77 | #include /* size_t */ 78 | typedef enum { XXH_OK=0, XXH_ERROR } XXH_errorcode; 79 | 80 | 81 | /***************************** 82 | * Namespace Emulation 83 | *****************************/ 84 | /* Motivations : 85 | 86 | If you need to include xxHash into your library, 87 | but wish to avoid xxHash symbols to be present on your library interface 88 | in an effort to avoid potential name collision if another library also includes xxHash, 89 | 90 | you can use XXH_NAMESPACE, which will automatically prefix any symbol from xxHash 91 | with the value of XXH_NAMESPACE (so avoid to keep it NULL, and avoid numeric values). 92 | 93 | Note that no change is required within the calling program : 94 | it can still call xxHash functions using their regular name. 95 | They will be automatically translated by this header. 96 | */ 97 | #ifdef XXH_NAMESPACE 98 | # define XXH_CAT(A,B) A##B 99 | # define XXH_NAME2(A,B) XXH_CAT(A,B) 100 | # define XXH32 XXH_NAME2(XXH_NAMESPACE, XXH32) 101 | # define XXH64 XXH_NAME2(XXH_NAMESPACE, XXH64) 102 | # define XXH32_createState XXH_NAME2(XXH_NAMESPACE, XXH32_createState) 103 | # define XXH64_createState XXH_NAME2(XXH_NAMESPACE, XXH64_createState) 104 | # define XXH32_freeState XXH_NAME2(XXH_NAMESPACE, XXH32_freeState) 105 | # define XXH64_freeState XXH_NAME2(XXH_NAMESPACE, XXH64_freeState) 106 | # define XXH32_reset XXH_NAME2(XXH_NAMESPACE, XXH32_reset) 107 | # define XXH64_reset XXH_NAME2(XXH_NAMESPACE, XXH64_reset) 108 | # define XXH32_update XXH_NAME2(XXH_NAMESPACE, XXH32_update) 109 | # define XXH64_update XXH_NAME2(XXH_NAMESPACE, XXH64_update) 110 | # define XXH32_digest XXH_NAME2(XXH_NAMESPACE, XXH32_digest) 111 | # define XXH64_digest XXH_NAME2(XXH_NAMESPACE, XXH64_digest) 112 | #endif 113 | 114 | 115 | /***************************** 116 | * Simple Hash Functions 117 | *****************************/ 118 | 119 | unsigned int XXH32 (const void* input, size_t length, unsigned seed); 120 | unsigned long long XXH64 (const void* input, size_t length, unsigned long long seed); 121 | 122 | /* 123 | XXH32() : 124 | Calculate the 32-bits hash of sequence "length" bytes stored at memory address "input". 125 | The memory between input & input+length must be valid (allocated and read-accessible). 126 | "seed" can be used to alter the result predictably. 127 | This function successfully passes all SMHasher tests. 128 | Speed on Core 2 Duo @ 3 GHz (single thread, SMHasher benchmark) : 5.4 GB/s 129 | XXH64() : 130 | Calculate the 64-bits hash of sequence of length "len" stored at memory address "input". 131 | Faster on 64-bits systems. Slower on 32-bits systems. 132 | */ 133 | 134 | 135 | 136 | /***************************** 137 | * Advanced Hash Functions 138 | *****************************/ 139 | typedef struct { long long ll[ 6]; } XXH32_state_t; 140 | typedef struct { long long ll[11]; } XXH64_state_t; 141 | 142 | /* 143 | These structures allow static allocation of XXH states. 144 | States must then be initialized using XXHnn_reset() before first use. 145 | 146 | If you prefer dynamic allocation, please refer to functions below. 147 | */ 148 | 149 | XXH32_state_t* XXH32_createState(void); 150 | XXH_errorcode XXH32_freeState(XXH32_state_t* statePtr); 151 | 152 | XXH64_state_t* XXH64_createState(void); 153 | XXH_errorcode XXH64_freeState(XXH64_state_t* statePtr); 154 | 155 | /* 156 | These functions create and release memory for XXH state. 157 | States must then be initialized using XXHnn_reset() before first use. 158 | */ 159 | 160 | 161 | XXH_errorcode XXH32_reset (XXH32_state_t* statePtr, unsigned seed); 162 | XXH_errorcode XXH32_update (XXH32_state_t* statePtr, const void* input, size_t length); 163 | unsigned int XXH32_digest (const XXH32_state_t* statePtr); 164 | 165 | XXH_errorcode XXH64_reset (XXH64_state_t* statePtr, unsigned long long seed); 166 | XXH_errorcode XXH64_update (XXH64_state_t* statePtr, const void* input, size_t length); 167 | unsigned long long XXH64_digest (const XXH64_state_t* statePtr); 168 | 169 | /* 170 | These functions calculate the xxHash of an input provided in multiple smaller packets, 171 | as opposed to an input provided as a single block. 172 | 173 | XXH state space must first be allocated, using either static or dynamic method provided above. 174 | 175 | Start a new hash by initializing state with a seed, using XXHnn_reset(). 176 | 177 | Then, feed the hash state by calling XXHnn_update() as many times as necessary. 178 | Obviously, input must be valid, meaning allocated and read accessible. 179 | The function returns an error code, with 0 meaning OK, and any other value meaning there is an error. 180 | 181 | Finally, you can produce a hash anytime, by using XXHnn_digest(). 182 | This function returns the final nn-bits hash. 183 | You can nonetheless continue feeding the hash state with more input, 184 | and therefore get some new hashes, by calling again XXHnn_digest(). 185 | 186 | When you are done, don't forget to free XXH state space, using typically XXHnn_freeState(). 187 | */ 188 | 189 | 190 | #if defined (__cplusplus) 191 | } 192 | #endif 193 | -------------------------------------------------------------------------------- /src/utils/collections/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name collections) 3 | (public_name hack_parallel.collections) 4 | (wrapped false)) 5 | -------------------------------------------------------------------------------- /src/utils/collections/iMap.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | include MyMap.Make (IntKey) 12 | -------------------------------------------------------------------------------- /src/utils/collections/iSet.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | include Set.Make (IntKey) 12 | -------------------------------------------------------------------------------- /src/utils/collections/intKey.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | type t = int 12 | let compare = (-) 13 | -------------------------------------------------------------------------------- /src/utils/collections/myMap.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | module type S = MyMap_sig.S 12 | module Make(Ord: Map.OrderedType) : S with type key = Ord.t = struct 13 | include Map.Make(Ord) 14 | let get x t = 15 | try Some (find x t) with Not_found -> None 16 | 17 | let find_unsafe = find 18 | 19 | let union ?combine x y = 20 | let combine = match combine with 21 | | None -> (fun _ fst _ -> Some fst) 22 | | Some f -> f 23 | in 24 | union combine x y 25 | 26 | let compare x y = compare Pervasives.compare x y 27 | let equal x y = compare x y = 0 28 | 29 | let keys m = fold (fun k _ acc -> k :: acc) m [] 30 | let values m = fold (fun _ v acc -> v :: acc) m [] 31 | let elements m = fold (fun k v acc -> (k,v)::acc) m [] 32 | 33 | let map_env f env m = 34 | fold ( 35 | fun x y (env, acc) -> 36 | let env, y = f env y in 37 | env, add x y acc 38 | ) m (env, empty) 39 | 40 | let choose x = 41 | try Some (choose x) with Not_found -> None 42 | 43 | let from_keys keys f = 44 | List.fold_left begin fun acc key -> 45 | add key (f key) acc 46 | end empty keys 47 | 48 | let add ?combine key new_value map = 49 | match combine with 50 | | None -> add key new_value map 51 | | Some combine -> begin 52 | match get key map with 53 | | None -> add key new_value map 54 | | Some old_value -> add key (combine old_value new_value) map 55 | end 56 | end 57 | -------------------------------------------------------------------------------- /src/utils/collections/myMap.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | module type S = MyMap_sig.S 12 | module Make (Ord : Map.OrderedType) : S with type key = Ord.t 13 | -------------------------------------------------------------------------------- /src/utils/collections/myMap_sig.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | module type S = sig 12 | include Map.S 13 | 14 | val add: ?combine: ('a -> 'a -> 'a) -> key -> 'a -> 'a t -> 'a t 15 | val get: key -> 'a t -> 'a option 16 | val find_unsafe: key -> 'a t -> 'a 17 | val union: ?combine:(key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t 18 | val compare: 'a t -> 'a t -> int 19 | val equal: 'a t -> 'a t -> bool 20 | val keys: 'a t -> key list 21 | val values: 'a t -> 'a list 22 | val elements: 'a t -> (key * 'a) list 23 | val map_env: ('c -> 'a -> 'c * 'b) -> 'c -> 'a t -> 'c * 'b t 24 | val choose: 'a t -> (key * 'a) option 25 | val from_keys: key list -> (key -> 'a) -> 'a t 26 | end 27 | -------------------------------------------------------------------------------- /src/utils/collections/sMap.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | include MyMap.Make (StringKey) 12 | -------------------------------------------------------------------------------- /src/utils/collections/sSet.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | include Set.Make (StringKey) 12 | -------------------------------------------------------------------------------- /src/utils/collections/stringKey.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | type t = string 12 | let compare (x: t) (y: t) = String.compare x y 13 | let to_string x = x 14 | -------------------------------------------------------------------------------- /src/utils/daemon.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | type 'a in_channel = Timeout.in_channel 12 | type 'a out_channel = Pervasives.out_channel 13 | 14 | type ('in_, 'out) channel_pair = 'in_ in_channel * 'out out_channel 15 | 16 | type ('in_, 'out) handle = { 17 | channels : ('in_, 'out) channel_pair; 18 | pid : int; 19 | } 20 | 21 | (* Windows: ensure that the serialize/deserialize functions 22 | for the custom block of "Unix.file_descr" are registred. *) 23 | let () = Lazy.force Handle.init 24 | 25 | let to_channel : 26 | 'a out_channel -> ?flags:Marshal.extern_flags list -> ?flush:bool -> 27 | 'a -> unit = 28 | fun oc ?(flags = []) ?flush:(should_flush=true) v -> 29 | Marshal.to_channel oc v flags; 30 | if should_flush then flush oc 31 | 32 | let from_channel : ?timeout:Timeout.t -> 'a in_channel -> 'a = fun ?timeout ic -> 33 | Timeout.input_value ?timeout ic 34 | 35 | let flush : 'a out_channel -> unit = Pervasives.flush 36 | 37 | let descr_of_in_channel : 'a in_channel -> Unix.file_descr = 38 | Timeout.descr_of_in_channel 39 | 40 | let descr_of_out_channel : 'a out_channel -> Unix.file_descr = 41 | Unix.descr_of_out_channel 42 | 43 | let cast_in ic = ic 44 | let cast_out oc = oc 45 | 46 | (* We cannot fork() on Windows, so in order to emulate this in a 47 | * cross-platform way, we use create_process() and set the HH_SERVER_DAEMON 48 | * environment variable to indicate which function the child should 49 | * execute. On Unix, create_process() does fork + exec, so global state is 50 | * not copied; in particular, if you have set a mutable reference the 51 | * daemon will not see it. All state must be explicitly passed via 52 | * environment variables; see set/get_context() below. 53 | * 54 | * With some factoring we could make the daemons into separate binaries 55 | * altogether and dispense with this emulation. *) 56 | 57 | module Entry : sig 58 | 59 | (* All the 'untyped' operations---that are required for the 60 | entry-points hashtable and the parameters stored in env 61 | variable---are hidden in this sub-module, behind a 'type-safe' 62 | interface. *) 63 | 64 | type ('param, 'input, 'output) t 65 | val name_of_entry: ('param, 'input, 'output) t -> string 66 | val register: 67 | string -> ('param -> ('input, 'output) channel_pair -> unit) -> 68 | ('param, 'input, 'output) t 69 | val find: 70 | ('param, 'input, 'output) t -> 71 | 'param -> 72 | ('input, 'output) channel_pair -> unit 73 | val set_context: 74 | ('param, 'input, 'output) t -> 'param -> 75 | Unix.file_descr * Unix.file_descr -> 76 | unit 77 | val get_context: 78 | unit -> 79 | (('param, 'input, 'output) t * 'param * ('input, 'output) channel_pair) 80 | val clear_context: 81 | unit -> unit 82 | 83 | end = struct 84 | 85 | type ('param, 'input, 'output) t = string 86 | 87 | let name_of_entry name = name 88 | 89 | (* Store functions as 'Obj.t' *) 90 | let entry_points : (string, Obj.t) Hashtbl.t = Hashtbl.create 23 91 | let register name f = 92 | if Hashtbl.mem entry_points name then 93 | Printf.ksprintf failwith 94 | "Daemon.register_entry_point: duplicate entry point %S." 95 | name; 96 | Hashtbl.add entry_points name (Obj.repr f); 97 | name 98 | 99 | let find name = 100 | try Obj.obj (Hashtbl.find entry_points name) 101 | with Not_found -> 102 | Printf.ksprintf failwith 103 | "Unknown entry point %S" name 104 | 105 | let set_context entry param (ic, oc) = 106 | let data = (ic, oc, param) in 107 | Unix.putenv "HH_SERVER_DAEMON" entry; 108 | let file, oc = 109 | Filename.open_temp_file 110 | ~mode:[Open_binary] 111 | ~temp_dir:Sys_utils.temp_dir_name 112 | "daemon_param" ".bin" in 113 | output_value oc data; 114 | close_out oc; 115 | Unix.putenv "HH_SERVER_DAEMON_PARAM" file 116 | 117 | (* How this works on Unix: It may appear like we are passing file descriptors 118 | * from one process to another here, but in_handle / out_handle are actually 119 | * file descriptors that are already open in the current process -- they were 120 | * created by the parent process before it did fork + exec. However, since 121 | * exec causes the child to "forget" everything, we have to pass the numbers 122 | * of these file descriptors as arguments. 123 | * 124 | * I'm not entirely sure what this does on Windows. *) 125 | let get_context () = 126 | let entry = Unix.getenv "HH_SERVER_DAEMON" in 127 | if entry = "" then raise Not_found; 128 | let (in_handle, out_handle, param) = 129 | try 130 | let file = Sys.getenv "HH_SERVER_DAEMON_PARAM" in 131 | if file = "" then raise Not_found; 132 | let ic = Sys_utils.open_in_bin_no_fail file in 133 | let res = Marshal.from_channel ic in 134 | Sys_utils.close_in_no_fail "Daemon.get_context" ic; 135 | Sys.remove file; 136 | res 137 | with _exn -> 138 | failwith "Can't find daemon parameters." in 139 | (entry, param, 140 | (Timeout.in_channel_of_descr in_handle, 141 | Unix.out_channel_of_descr out_handle)) 142 | 143 | let clear_context () = 144 | Unix.putenv "HH_SERVER_DAEMON" ""; 145 | Unix.putenv "HH_SERVER_DAEMON_PARAM" ""; 146 | 147 | end 148 | 149 | type ('param, 'input, 'output) entry = ('param, 'input, 'output) Entry.t 150 | 151 | let exec entry param ic oc = 152 | let f = Entry.find entry in 153 | try f param (ic, oc); exit 0 154 | with e -> 155 | prerr_endline (Printexc.to_string e); 156 | Printexc.print_backtrace stderr; 157 | exit 2 158 | 159 | let register_entry_point = Entry.register 160 | 161 | let fd_of_path path = 162 | Sys_utils.with_umask 0o111 begin fun () -> 163 | Sys_utils.mkdir_no_fail (Filename.dirname path); 164 | Unix.openfile path [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o666 165 | end 166 | 167 | let null_fd () = fd_of_path Sys_utils.null_path 168 | 169 | let setup_channels channel_mode = 170 | match channel_mode with 171 | | `pipe -> 172 | let parent_in, child_out = Unix.pipe () in 173 | let child_in, parent_out = Unix.pipe () in 174 | (* Close descriptors on exec so they are not leaked. *) 175 | Unix.set_close_on_exec parent_in; 176 | Unix.set_close_on_exec parent_out; 177 | (parent_in, child_out), (child_in, parent_out) 178 | | `socket -> 179 | let parent_fd, child_fd = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in 180 | (* FD's on sockets are bi-directional. *) 181 | (parent_fd, child_fd), (child_fd, parent_fd) 182 | 183 | let make_pipe (descr_in, descr_out) = 184 | let ic = Timeout.in_channel_of_descr descr_in in 185 | let oc = Unix.out_channel_of_descr descr_out in 186 | ic, oc 187 | 188 | let close_pipe channel_mode (ch_in, ch_out) = 189 | match channel_mode with 190 | | `pipe -> 191 | Timeout.close_in ch_in; 192 | close_out ch_out 193 | | `socket -> 194 | (* the in and out FD's are the same. Close only once. *) 195 | Timeout.close_in ch_in 196 | 197 | (* This only works on Unix, and should be avoided as far as possible. Use 198 | * Daemon.spawn instead. *) 199 | let fork 200 | ?(channel_mode = `pipe) 201 | (type param) 202 | (log_stdout, log_stderr) (f : param -> ('a, 'b) channel_pair -> unit) 203 | (param : param) : ('b, 'a) handle = 204 | let (parent_in, child_out), (child_in, parent_out) 205 | = setup_channels channel_mode in 206 | let (parent_in, child_out) = make_pipe (parent_in, child_out) in 207 | let (child_in, parent_out) = make_pipe (child_in, parent_out) in 208 | match Fork.fork () with 209 | | -1 -> failwith "Go get yourself a real computer" 210 | | 0 -> (* child *) 211 | (try 212 | ignore(Unix.setsid()); 213 | close_pipe channel_mode (parent_in, parent_out); 214 | Sys_utils.with_umask 0o111 begin fun () -> 215 | let fd = null_fd () in 216 | Unix.dup2 fd Unix.stdin; 217 | Unix.close fd; 218 | end; 219 | Unix.dup2 log_stdout Unix.stdout; 220 | Unix.dup2 log_stderr Unix.stderr; 221 | if log_stdout <> Unix.stdout then Unix.close log_stdout; 222 | if log_stderr <> Unix.stderr && log_stderr <> log_stdout then 223 | Unix.close log_stderr; 224 | f param (child_in, child_out); 225 | exit 0 226 | with e -> 227 | prerr_endline (Printexc.to_string e); 228 | Printexc.print_backtrace stderr; 229 | exit 1) 230 | | pid -> (* parent *) 231 | close_pipe channel_mode (child_in, child_out); 232 | { channels = parent_in, parent_out; pid } 233 | 234 | let spawn 235 | (type param) (type input) (type output) 236 | ?(channel_mode = `pipe) 237 | (stdin, stdout, stderr) 238 | (entry: (param, input, output) entry) 239 | (param: param) : (output, input) handle = 240 | let (parent_in, child_out), (child_in, parent_out) = 241 | setup_channels channel_mode in 242 | Entry.set_context entry param (child_in, child_out); 243 | let exe = Sys_utils.executable_path () in 244 | let pid = Unix.create_process exe [|exe|] stdin stdout stderr in 245 | Entry.clear_context (); 246 | (match channel_mode with 247 | | `pipe -> 248 | Unix.close child_in; 249 | Unix.close child_out; 250 | | `socket -> 251 | (* the in and out FD's are the same. Close only once. *) 252 | Unix.close child_in); 253 | if stdin <> Unix.stdin then Unix.close stdin; 254 | if stdout <> Unix.stdout then Unix.close stdout; 255 | if stderr <> Unix.stderr && stderr <> stdout then 256 | Unix.close stderr; 257 | PidLog.log 258 | ~reason:(Entry.name_of_entry entry) 259 | ~no_fail:true 260 | pid; 261 | { channels = Timeout.in_channel_of_descr parent_in, 262 | Unix.out_channel_of_descr parent_out; 263 | pid } 264 | 265 | (* for testing code *) 266 | let devnull () = 267 | let ic = Timeout.open_in "/dev/null" in 268 | let oc = open_out "/dev/null" in 269 | {channels = ic, oc; pid = 0} 270 | 271 | (** 272 | * In order for the Daemon infrastructure to work, the beginning of your 273 | * program (or very close to the beginning) must start with a call to 274 | * check_entry_point. 275 | * 276 | * Details: Daemon.spawn essentially does a fork then exec of the currently 277 | * running program. Thus, the child process will just end up running the exact 278 | * same program as the parent if you forgot to start with a check_entry_point. 279 | * The parent process sees this as a NOOP when its program starts, but a 280 | * child process (from Daemon.spawn) will use this as a GOTO to its entry 281 | * point. 282 | *) 283 | let check_entry_point () = 284 | try 285 | let entry, param, (ic, oc) = Entry.get_context () in 286 | Entry.clear_context (); 287 | exec entry param ic oc 288 | with Not_found -> () 289 | 290 | let close { channels = (ic, oc); _ } = 291 | Timeout.close_in ic; 292 | close_out oc 293 | 294 | let kill h = 295 | close h; 296 | Sys_utils.terminate_process h.pid 297 | 298 | let close_out = close_out 299 | let output_string = output_string 300 | let flush = flush 301 | 302 | let close_in = Timeout.close_in 303 | let input_char ic = Timeout.input_char ic 304 | let input_value ic = Timeout.input_value ic 305 | -------------------------------------------------------------------------------- /src/utils/daemon.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (** Type-safe versions of the channels in Pervasives. *) 12 | 13 | type 'a in_channel 14 | type 'a out_channel 15 | type ('in_, 'out) channel_pair = 'in_ in_channel * 'out out_channel 16 | 17 | val to_channel : 18 | 'a out_channel -> ?flags:Marshal.extern_flags list -> ?flush:bool -> 19 | 'a -> unit 20 | val from_channel : ?timeout:Timeout.t -> 'a in_channel -> 'a 21 | val flush : 'a out_channel -> unit 22 | 23 | (* This breaks the type safety, but is necessary in order to allow select() *) 24 | val descr_of_in_channel : 'a in_channel -> Unix.file_descr 25 | val descr_of_out_channel : 'a out_channel -> Unix.file_descr 26 | val cast_in : 'a in_channel -> Timeout.in_channel 27 | val cast_out : 'a out_channel -> Pervasives.out_channel 28 | 29 | val close_out : 'a out_channel -> unit 30 | val output_string : 'a out_channel -> string -> unit 31 | 32 | val close_in : 'a in_channel -> unit 33 | val input_char : 'a in_channel -> char 34 | val input_value : 'a in_channel -> 'b 35 | 36 | (** Spawning new process *) 37 | 38 | (* In the absence of 'fork' on Windows, its usage must be restricted 39 | to Unix specifics parts. 40 | 41 | This module provides a mechanism to "spawn" new instance of the 42 | current program, but with a custom entry point (e.g. Slaves, 43 | DfindServer, ...). Then, alternate entry points should not depend 44 | on global references that may not have been (re)initialised in the 45 | new process. 46 | 47 | All required data must be passed through the typed channels. 48 | associated to the spawned process. 49 | 50 | *) 51 | 52 | (* Alternate entry points *) 53 | type ('param, 'input, 'output) entry 54 | 55 | (* Alternate entry points must be registered at toplevel, i.e. 56 | every call to `Daemon.register_entry_point` must have been 57 | evaluated when `Daemon.check_entry_point` is called at the 58 | beginning of `ServerMain.start`. *) 59 | val register_entry_point : 60 | string -> ('param -> ('input, 'output) channel_pair -> unit) -> 61 | ('param, 'input, 'output) entry 62 | 63 | (* Handler upon spawn and forked process. *) 64 | type ('in_, 'out) handle = { 65 | channels : ('in_, 'out) channel_pair; 66 | pid : int; 67 | } 68 | 69 | (* for unit tests *) 70 | val devnull : unit -> ('a, 'b) handle 71 | 72 | val fd_of_path : string -> Unix.file_descr 73 | val null_fd : unit -> Unix.file_descr 74 | 75 | (* Fork and run a function that communicates via the typed channels *) 76 | val fork : 77 | ?channel_mode:[ `pipe | `socket ] -> 78 | (* Where the daemon's output should go *) 79 | (Unix.file_descr * Unix.file_descr) -> 80 | ('param -> ('input, 'output) channel_pair -> unit) -> 'param -> 81 | ('output, 'input) handle 82 | 83 | (* Spawn a new instance of the current process, and execute the 84 | alternate entry point. *) 85 | val spawn : 86 | ?channel_mode:[ `pipe | `socket ] -> 87 | (* Where the daemon's input and output should go *) 88 | (Unix.file_descr * Unix.file_descr * Unix.file_descr) -> 89 | ('param, 'input, 'output) entry -> 'param -> ('output, 'input) handle 90 | 91 | (* Close the typed channels associated to a 'spawned' child. *) 92 | val close : ('a, 'b) handle -> unit 93 | 94 | (* Kill a 'spawned' child and close the associated typed channels. *) 95 | val kill : ('a, 'b) handle -> unit 96 | 97 | (* Main function, that execute a alternate entry point. 98 | It should be called only once. Just before the main entry point. 99 | This function does not return when a custom entry point is selected. *) 100 | val check_entry_point : unit -> unit 101 | -------------------------------------------------------------------------------- /src/utils/disk/disk.ml: -------------------------------------------------------------------------------- 1 | module Stub = struct 2 | let cat = TestDisk.get 3 | end 4 | 5 | include (val (if Injector_config.use_test_stubbing 6 | then (module Stub : Disk_sig.S) 7 | else (module RealDisk : Disk_sig.S) 8 | )) 9 | -------------------------------------------------------------------------------- /src/utils/disk/disk.mli: -------------------------------------------------------------------------------- 1 | include Disk_sig.S 2 | -------------------------------------------------------------------------------- /src/utils/disk/disk_sig.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | val cat : string -> string 3 | end 4 | -------------------------------------------------------------------------------- /src/utils/disk/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name disk) 3 | (public_name hack_parallel.disk) 4 | (wrapped false) 5 | (libraries 6 | hack_parallel.collections 7 | hack_parallel.injection)) 8 | -------------------------------------------------------------------------------- /src/utils/disk/realDisk.ml: -------------------------------------------------------------------------------- 1 | let cat filename = 2 | let ic = open_in_bin filename in 3 | let len = in_channel_length ic in 4 | let buf = Buffer.create len in 5 | Buffer.add_channel buf ic len; 6 | let content = Buffer.contents buf in 7 | close_in ic; 8 | content 9 | -------------------------------------------------------------------------------- /src/utils/disk/testDisk.ml: -------------------------------------------------------------------------------- 1 | let files = ref SMap.empty 2 | 3 | let get x = SMap.find_unsafe x !files 4 | let set x y = files := SMap.add x y !files 5 | -------------------------------------------------------------------------------- /src/utils/disk/testDisk.mli: -------------------------------------------------------------------------------- 1 | val get : string -> string 2 | val set : string -> string -> unit 3 | -------------------------------------------------------------------------------- /src/utils/dune: -------------------------------------------------------------------------------- 1 | (copy_files ../../scripts/get_build_id.c) 2 | 3 | (library 4 | (name utils) 5 | (public_name hack_parallel.utils) 6 | (wrapped false) 7 | (modules (:standard)) 8 | (c_names 9 | files 10 | get_build_id 11 | handle_stubs 12 | nproc 13 | priorities 14 | realpath 15 | sysinfo) 16 | (libraries 17 | core 18 | str 19 | hack_parallel.collections 20 | hack_parallel.disk 21 | hack_parallel.hack_core 22 | hack_parallel.hh_json)) 23 | -------------------------------------------------------------------------------- /src/utils/exit_status.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | type t = 12 | | No_error 13 | | Build_error 14 | | Build_terminated 15 | | Checkpoint_error 16 | | Input_error 17 | | Kill_error 18 | | No_server_running 19 | | Out_of_time 20 | | Out_of_retries 21 | | Server_already_exists 22 | | Server_initializing 23 | | Type_error 24 | | Build_id_mismatch 25 | | Monitor_connection_failure 26 | | Unused_server 27 | | Lock_stolen 28 | | Lost_parent_monitor 29 | | Interrupted 30 | | Worker_oomed 31 | | Worker_busy 32 | (** An uncaught Not_found exception in the worker. *) 33 | | Worker_not_found_exception 34 | | Worker_failed_to_send_job 35 | | Socket_error 36 | | Missing_hhi 37 | | Dfind_died 38 | | Dfind_unresponsive 39 | | EventLogger_Timeout 40 | | EventLogger_restart_out_of_retries 41 | | EventLogger_broken_pipe 42 | | CantRunAI 43 | | Watchman_failed 44 | (** It is faster to exit the server (and have the Monitor restart the server) 45 | * on a Watchman fresh instance than to compute the files that have been 46 | * deleted and do an incremental check. 47 | *) 48 | | Watchman_fresh_instance 49 | | File_heap_stale 50 | | Hhconfig_deleted 51 | | Hhconfig_changed 52 | | Server_shutting_down 53 | | Server_name_not_found 54 | | IDE_malformed_request 55 | | IDE_no_server 56 | | IDE_out_of_retries 57 | | Nfs_root 58 | | IDE_init_failure 59 | | IDE_typechecker_died 60 | | Redecl_heap_overflow 61 | | Out_of_shared_memory 62 | | Shared_mem_assertion_failure 63 | | Hash_table_full 64 | | IDE_new_client_connected 65 | | Lazy_decl_bug 66 | | Decl_heap_elems_bug 67 | | Parser_heap_build_error 68 | | Heap_full 69 | | Sql_assertion_failure 70 | | Local_type_env_stale 71 | | Sql_cantopen 72 | | Sql_corrupt 73 | | Sql_misuse 74 | | Uncaught_exception 75 | 76 | exception Exit_with of t 77 | 78 | let exit_code = function 79 | | Interrupted -> -6 80 | | No_error -> 0 81 | | Build_terminated -> 1 82 | | Kill_error -> 1 83 | | Server_initializing -> 1 84 | | Server_shutting_down -> 1 85 | | Build_error -> 2 (* used in clientBuild *) 86 | | Type_error -> 2 (* used in clientCheck *) 87 | | Uncaught_exception -> 2 (* used in server *) 88 | | Hhconfig_changed -> 4 89 | | Unused_server -> 5 90 | | No_server_running -> 6 91 | | Out_of_time -> 7 92 | | Out_of_retries -> 7 93 | | Checkpoint_error -> 8 94 | | Build_id_mismatch -> 9 95 | | Monitor_connection_failure -> 9 96 | | Input_error -> 10 97 | | Lock_stolen -> 11 98 | | Lost_parent_monitor -> 12 99 | | Shared_mem_assertion_failure -> 14 100 | | Out_of_shared_memory -> 15 101 | | Hash_table_full -> 16 102 | | Heap_full -> 17 103 | | Worker_oomed -> 30 104 | | Worker_busy -> 31 105 | | Worker_not_found_exception -> 32 106 | | Worker_failed_to_send_job -> 33 107 | | Server_already_exists -> 77 108 | | Missing_hhi -> 97 109 | | Socket_error -> 98 110 | | Dfind_died -> 99 111 | | Dfind_unresponsive -> 100 112 | | EventLogger_Timeout -> 101 113 | | CantRunAI -> 102 114 | | Watchman_failed -> 103 115 | | Hhconfig_deleted -> 104 116 | | Server_name_not_found -> 105 117 | | EventLogger_broken_pipe -> 106 118 | | Redecl_heap_overflow -> 107 119 | | EventLogger_restart_out_of_retries -> 108 120 | | Watchman_fresh_instance -> 109 121 | | IDE_malformed_request -> 201 122 | | IDE_no_server -> 202 123 | | IDE_out_of_retries -> 203 124 | | Nfs_root -> 204 125 | | IDE_init_failure -> 205 126 | | IDE_typechecker_died -> 206 127 | | IDE_new_client_connected -> 207 128 | | Lazy_decl_bug -> 208 129 | | Decl_heap_elems_bug -> 209 130 | | Parser_heap_build_error -> 210 131 | | File_heap_stale -> 211 132 | | Sql_assertion_failure -> 212 133 | | Local_type_env_stale -> 213 134 | | Sql_cantopen -> 214 135 | | Sql_corrupt -> 215 136 | | Sql_misuse -> 216 137 | 138 | 139 | let exit t = 140 | let ec = exit_code t in 141 | Pervasives.exit ec 142 | 143 | let to_string = function 144 | | No_error -> "Ok" 145 | | Build_error -> "Build_error" 146 | | Build_terminated -> "Build_terminated" 147 | | Checkpoint_error -> "Checkpoint_error" 148 | | Input_error -> "Input_error" 149 | | Kill_error -> "Kill_error" 150 | | No_server_running -> "No_server_running" 151 | | Out_of_time -> "Out_of_time" 152 | | Out_of_retries -> "Out_of_retries" 153 | | Server_already_exists -> "Server_already_exists" 154 | | Server_initializing -> "Server_initializing" 155 | | Server_shutting_down -> "Server_shutting_down" 156 | | Type_error -> "Type_error" 157 | | Build_id_mismatch -> "Build_id_mismatch" 158 | | Monitor_connection_failure -> "Monitor_connection_failure" 159 | | Unused_server -> "Unused_server" 160 | | Lock_stolen -> "Lock_stolen" 161 | | Lost_parent_monitor -> "Lost_parent_monitor" 162 | | Interrupted -> "Interrupted" 163 | | Worker_oomed -> "Worker_oomed" 164 | | Worker_busy -> "Worker_busy" 165 | | Worker_not_found_exception -> "Worker_not_found_exception" 166 | | Worker_failed_to_send_job -> "Worker_failed_to_send_job" 167 | | Socket_error -> "Socket_error" 168 | | Missing_hhi -> "Missing_hhi" 169 | | Dfind_died -> "Dfind_died" 170 | | Dfind_unresponsive -> "Dfind_unresponsive" 171 | | EventLogger_Timeout -> "EventLogger_Timeout" 172 | | EventLogger_restart_out_of_retries -> "EventLogger_restart_out_of_retries" 173 | | EventLogger_broken_pipe -> "EventLogger_broken_pipe" 174 | | CantRunAI -> "CantRunAI" 175 | | Watchman_failed -> "Watchman_failed" 176 | | Watchman_fresh_instance -> "Watchman_fresh_instance" 177 | | Hhconfig_deleted -> "Hhconfig_deleted" 178 | | Hhconfig_changed -> "Hhconfig_changed" 179 | | Server_name_not_found -> "Server_name_not_found" 180 | | IDE_malformed_request -> "IDE_malformed_request" 181 | | IDE_no_server -> "IDE_no_server" 182 | | IDE_out_of_retries -> "IDE_out_of_retries" 183 | | Nfs_root -> "Nfs_root" 184 | | IDE_init_failure -> "IDE_init_failure" 185 | | IDE_typechecker_died -> "IDE_typechecker_died" 186 | | Redecl_heap_overflow -> "Redecl_heap_overflow" 187 | | Shared_mem_assertion_failure -> "Shared_mem_assertion_failure" 188 | | Out_of_shared_memory -> "Out_of_shared_memory" 189 | | Hash_table_full -> "Hash_table_full" 190 | | IDE_new_client_connected -> "IDE_new_client_connected" 191 | | Lazy_decl_bug -> "Lazy_decl_bug" 192 | | Decl_heap_elems_bug -> "Decl_heap_elems_bug" 193 | | Parser_heap_build_error -> "Parser_heap_build_error" 194 | | Heap_full -> "Heap_full" 195 | | File_heap_stale -> "File_heap_stale" 196 | | Sql_assertion_failure -> "Sql_assertion_failure" 197 | | Local_type_env_stale -> "Local_type_env_stale" 198 | | Sql_cantopen -> "Sql_cantopen" 199 | | Sql_corrupt -> "Sql_corrupt" 200 | | Sql_misuse -> "Sql_misuse" 201 | | Uncaught_exception -> "Uncaught_exception" 202 | 203 | 204 | let unpack = function 205 | | Unix.WEXITED n -> "exit", n 206 | | Unix.WSIGNALED n -> "signaled", n 207 | | Unix.WSTOPPED n -> "stopped", n 208 | -------------------------------------------------------------------------------- /src/utils/files.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | */ 10 | 11 | #define CAML_NAME_SPACE 12 | #include 13 | #include 14 | 15 | #ifndef _WIN32 16 | #include 17 | #endif 18 | 19 | #ifdef __linux__ 20 | #include 21 | #include 22 | #endif 23 | 24 | void hh_lutimes(value filename_v) { 25 | CAMLparam1(filename_v); 26 | #ifdef _WIN32 27 | /* Not implemented */ 28 | CAMLreturn0; 29 | #else 30 | char* filename = String_val(filename_v); 31 | int success = lutimes(filename, NULL); 32 | if (success != 0) { 33 | caml_failwith("lutimes failed"); 34 | } 35 | #endif 36 | CAMLreturn0; 37 | } 38 | 39 | value hh_is_nfs(value filename_v) { 40 | CAMLparam1(filename_v); 41 | #ifdef __linux__ 42 | struct statfs buf; 43 | char* filename = String_val(filename_v); 44 | int success = statfs(filename, &buf); 45 | if (success != 0) { 46 | caml_failwith("statfs failed"); 47 | } 48 | switch (buf.f_type) { 49 | #ifdef CIFS_MAGIC_NUMBER 50 | case CIFS_MAGIC_NUMBER: 51 | #endif 52 | case NFS_SUPER_MAGIC: 53 | case SMB_SUPER_MAGIC: 54 | CAMLreturn(Val_bool(1)); 55 | default: 56 | CAMLreturn(Val_bool(0)); 57 | } 58 | #endif 59 | CAMLreturn(Val_bool(0)); 60 | } 61 | -------------------------------------------------------------------------------- /src/utils/fork.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | open Hack_core 12 | 13 | (* Forking duplicates data in all buffers, so we flush them beforehand to avoid 14 | * writing the same thing twice. 15 | * 16 | * Note: by default, this only clears ocaml's internal buffers (via flush_all). 17 | * If your process has its own buffers in the program state, those must be 18 | * cleared by registering a callback with `on_fork` below to reliably avoid 19 | * writing those buffers twice as well. *) 20 | let pre_fork_callbacks : (unit -> unit) list ref = ref [flush_all] 21 | 22 | (** Sometimes it is more convenient to clear buffers in the children (to 23 | * avoid the double writing of data) instead of the parent on a successful 24 | * fork. We store those callbacks here. *) 25 | let post_fork_child_callbacks : (unit -> unit) list ref = ref [] 26 | 27 | let on_fork f = pre_fork_callbacks := f :: !pre_fork_callbacks 28 | 29 | let post_fork_child f = 30 | post_fork_child_callbacks := f :: !post_fork_child_callbacks 31 | 32 | (* You should always use this instead of Unix.fork, so that the callbacks get 33 | * invoked *) 34 | let fork () = 35 | List.iter !pre_fork_callbacks ~f:(fun f -> f()); 36 | match Unix.fork () with 37 | | 0 -> 38 | List.iter !post_fork_child_callbacks ~f:(fun f -> f()); 39 | 0 40 | | i -> 41 | i 42 | 43 | (* should only be called from hh_server, which initializes the PidLog *) 44 | let fork_and_log ?reason () = 45 | let result = fork() in 46 | (match result with 47 | | -1 -> () 48 | | 0 -> PidLog.close (); 49 | | pid -> PidLog.log ?reason pid); 50 | result 51 | 52 | let fork_and_may_log ?reason () = 53 | match reason with 54 | | None -> fork () 55 | | Some _ -> fork_and_log ?reason () 56 | -------------------------------------------------------------------------------- /src/utils/hack_core.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | module List = struct 12 | include Hack_core_list 13 | 14 | let rec fold_left_env env l ~init ~f = match l with 15 | | [] -> env, init 16 | | x :: xs -> 17 | let env, init = f env init x in 18 | fold_left_env env xs ~init ~f 19 | 20 | let rec map_env env xs ~f = match xs with 21 | | [] -> env, [] 22 | | x :: xs -> 23 | let env, x = f env x in 24 | let env, xs = map_env env xs ~f in 25 | env, x :: xs 26 | 27 | let rev_map_env env xs ~f = 28 | let f2 env init x = 29 | let env, x = f env x in 30 | env, x :: init 31 | in 32 | fold_left_env env xs ~init:[] ~f:f2 33 | 34 | let rec map2_env env l1 l2 ~f = match l1, l2 with 35 | | [], [] -> env, [] 36 | | [], _ | _, [] -> raise @@ Invalid_argument "map2_env" 37 | | x1 :: rl1, x2 :: rl2 -> 38 | let env, x = f env x1 x2 in 39 | let env, rl = map2_env env rl1 rl2 ~f in 40 | env, x :: rl 41 | 42 | let for_all2 = List.for_all2 43 | end 44 | -------------------------------------------------------------------------------- /src/utils/hack_path.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | include Sys 12 | 13 | type t = string 14 | 15 | let dummy_path : t = "" 16 | 17 | let cat = Sys_utils.cat 18 | let compare = Pervasives.compare 19 | let dirname = Filename.dirname 20 | 21 | (** 22 | * Resolves a path (using realpath) 23 | * 24 | * The advantage of using a path instead of strings is that you 25 | * don't need to care about symlinks or trailing slashes: each 26 | * path gets normalized by calling realpath. 27 | * 28 | * A few things to keep in mind: 29 | * - paths are always absolute. So the empty string "" becomes 30 | * the current directory (in absolute) 31 | *) 32 | let make path = 33 | match Sys_utils.realpath path with 34 | | Some path -> path 35 | | None -> path (* assert false? *) 36 | 37 | (** 38 | * Creates a Path without running it through `realpath`. This is unsafe because 39 | * it doesn't normalize symlinks, trailing slashes, or relative paths. The path 40 | * you pass here must be absolute, and free of symlinks (including ../). 41 | *) 42 | let make_unsafe path = path 43 | 44 | let to_string path = path 45 | 46 | let concat path more = 47 | make (Filename.concat path more) 48 | 49 | let parent path = 50 | if is_directory path 51 | then make (concat path Filename.parent_dir_name) 52 | else make (Filename.dirname path) 53 | 54 | let output = output_string 55 | 56 | let slash_escaped_string_of_path path = 57 | let buf = Buffer.create (String.length path) in 58 | String.iter (fun ch -> 59 | match ch with 60 | | '\\' -> Buffer.add_string buf "zB" 61 | | ':' -> Buffer.add_string buf "zC" 62 | | '/' -> Buffer.add_string buf "zS" 63 | | '\x00' -> Buffer.add_string buf "z0" 64 | | 'z' -> Buffer.add_string buf "zZ" 65 | | _ -> Buffer.add_char buf ch 66 | ) path; 67 | Buffer.contents buf 68 | 69 | let path_of_slash_escaped_string str = 70 | let length = String.length str in 71 | let buf = Buffer.create length in 72 | let rec consume i = 73 | if i >= length then () 74 | else 75 | let replacement = 76 | if i < length - 1 && str.[i] = 'z' 77 | then match str.[i+1] with 78 | | 'B' -> Some '\\' 79 | | 'C' -> Some ':' 80 | | 'S' -> Some '/' 81 | | '0' -> Some '\x00' 82 | | 'Z' -> Some 'z' 83 | | _ -> None 84 | else None in 85 | let c, next_i = match replacement with 86 | | Some r -> r, i+2 87 | | None -> str.[i], i+1 in 88 | Buffer.add_char buf c; 89 | consume next_i 90 | in consume 0; 91 | make (Buffer.contents buf) 92 | -------------------------------------------------------------------------------- /src/utils/hack_path.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | 12 | type t = private string 13 | 14 | val dummy_path: t 15 | val make: string -> t 16 | val make_unsafe: string -> t 17 | val to_string: t -> string 18 | val file_exists: t -> bool 19 | val is_directory: t -> bool 20 | val compare: t -> t -> int 21 | val concat: t -> string -> t 22 | val chdir: t -> unit 23 | val dirname: t -> t 24 | val getcwd: unit -> t 25 | val output: out_channel -> t -> unit 26 | val remove: t -> unit 27 | val parent: t -> t 28 | val executable_name: t 29 | val cat: t -> string 30 | 31 | val slash_escaped_string_of_path: t -> string 32 | val path_of_slash_escaped_string: string -> t 33 | -------------------------------------------------------------------------------- /src/utils/handle.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (* On Win32, unwrap the handle from the 'abstract block' representing 12 | the file descriptor otherwise it can't be marshalled or passed as 13 | an integer command-line argument. *) 14 | 15 | type handle = int 16 | external raw_get_handle : 17 | Unix.file_descr -> handle = "caml_hh_worker_get_handle" "noalloc" 18 | external raw_wrap_handle : 19 | handle -> Unix.file_descr = "caml_hh_worker_create_handle" 20 | external win_setup_handle_serialization : 21 | unit -> unit = "win_setup_handle_serialization" 22 | 23 | let init = 24 | (* Windows: register the serialize/desarialize functions 25 | for the custom block of "Unix.file_descr". *) 26 | lazy begin 27 | win_setup_handle_serialization () 28 | end 29 | 30 | let () = Lazy.force init 31 | 32 | let () = assert (Sys.win32 || Obj.is_int (Obj.repr Unix.stdin)) 33 | let get_handle = 34 | if Sys.win32 then raw_get_handle else Obj.magic 35 | let wrap_handle = 36 | if Sys.win32 then raw_wrap_handle else Obj.magic 37 | 38 | let to_in_channel h = wrap_handle h |> Unix.in_channel_of_descr 39 | let to_out_channel h = wrap_handle h |> Unix.out_channel_of_descr 40 | -------------------------------------------------------------------------------- /src/utils/handle_stubs.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | */ 10 | 11 | 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | 18 | // Ideally these would live in a handle.h file but our internal build system 19 | // can't support that at the moment. These are shared with hh_shared.c 20 | #ifdef _WIN32 21 | #define Val_handle(fd) (win_alloc_handle(fd)) 22 | #else 23 | #define Handle_val(fd) (Long_val(fd)) 24 | #define Val_handle(fd) (Val_long(fd)) 25 | #endif 26 | 27 | value caml_hh_worker_get_handle(value x) { 28 | return Val_long(Handle_val(x)); 29 | } 30 | 31 | value caml_hh_worker_create_handle(value x) { 32 | #ifdef _WIN32 33 | return Val_handle((HANDLE)Long_val(x)); 34 | #else 35 | return Val_handle(Long_val(x)); 36 | #endif 37 | } 38 | 39 | #ifdef _WIN32 40 | static void win_handle_serialize(value h, uintnat *wsize_32, uintnat *wsize_64) { 41 | serialize_int_8((int64_t)Handle_val(h)); 42 | serialize_int_1(Descr_kind_val(h)); 43 | serialize_int_1(CRT_fd_val(h)); 44 | serialize_int_1(Flags_fd_val(h)); 45 | *wsize_32 = sizeof(struct filedescr); 46 | *wsize_64 = sizeof(struct filedescr); 47 | } 48 | 49 | static uintnat win_handle_deserialize(void * dst) { 50 | struct filedescr *h= (struct filedescr *)dst; 51 | h->fd.handle = (HANDLE)caml_deserialize_sint_8(); 52 | h->kind = caml_deserialize_uint_1(); 53 | h->crt_fd = caml_deserialize_sint_1(); 54 | h->flags_fd = caml_deserialize_uint_1(); 55 | return sizeof(struct filedescr); 56 | } 57 | #endif 58 | 59 | value win_setup_handle_serialization(value unit) { 60 | (void)unit; // Dear compiler, please ignore this param 61 | #ifdef _WIN32 62 | value handle = win_alloc_handle((HANDLE)0); // Dummy handle 63 | struct custom_operations *win_handle_ops = (struct custom_operations *)Field(handle, 0); 64 | win_handle_ops->serialize = win_handle_serialize; 65 | win_handle_ops->deserialize = win_handle_deserialize; 66 | caml_register_custom_operations(win_handle_ops); 67 | #endif 68 | return Val_unit; 69 | } 70 | -------------------------------------------------------------------------------- /src/utils/hh_json/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name hh_json) 3 | (public_name hack_parallel.hh_json) 4 | (wrapped false) 5 | (libraries 6 | hack_parallel.hack_core)) 7 | -------------------------------------------------------------------------------- /src/utils/hh_json/hh_json.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (** 12 | * Hh_json parsing and pretty printing library. 13 | *) 14 | 15 | type json = 16 | JSON_Object of (string * json) list 17 | | JSON_Array of json list 18 | | JSON_String of string 19 | | JSON_Number of string 20 | | JSON_Bool of bool 21 | | JSON_Null 22 | 23 | exception Syntax_error of string 24 | 25 | val json_to_string : ?pretty:bool -> json -> string 26 | val json_to_multiline : json -> string 27 | val json_to_output: out_channel -> json -> unit 28 | val json_of_string : ?strict:bool -> string -> json 29 | val json_of_file : ?strict:bool -> string -> json 30 | 31 | val get_object_exn : json -> (string * json) list 32 | val get_array_exn : json -> json list 33 | val get_string_exn : json -> string 34 | val get_number_exn : json -> string 35 | val get_number_int_exn : json -> int 36 | val get_bool_exn : json -> bool 37 | 38 | val opt_string_to_json : string option -> json 39 | val opt_int_to_json : int option -> json 40 | 41 | val int_ : int -> json 42 | val string_ : string -> json 43 | 44 | (** Types and functions for monadic API for traversing a JSON object. *) 45 | 46 | type json_type = 47 | | Object_t 48 | | Array_t 49 | | String_t 50 | | Number_t 51 | | Integer_t 52 | | Bool_t 53 | 54 | (** 55 | * This module gives monadic recursive access to values within objects by key. 56 | * It uses the Result.t to manage control flow in the monad when an error is 57 | * encountered. It also tracks the backtrace of the keys accessed to give 58 | * detailed error messages. 59 | * 60 | * Usage: 61 | * To access the boolean value "qux" from the following json: 62 | * { "foo": { "bar" : { "baz" : { "qux" : true } } } } 63 | * Is as follows: 64 | * (return json) >>= 65 | * get_obj "foo" >>= 66 | * get_obj "bar" >>= 67 | * get_obj "baz" >>= 68 | * get_bool "qux" 69 | * 70 | * If an error is encountered along the call chain, a Result.Error is returned 71 | * with the appropriate error and the history of key accesses that arrived 72 | * there (so you can trace how far it went successfully and exactly where the 73 | * error was encountered). 74 | * 75 | * Same goes for accessing multiple fields within one object. 76 | * Suppose we have a record type: 77 | * type fbz_record = { 78 | * foo : bool; 79 | * bar : string; 80 | * baz : int; 81 | * } 82 | * 83 | * And we have JSON as a string: 84 | * let data = 85 | * "{\n"^ 86 | * " \"foo\" : true,\n"^ 87 | * " \"bar\" : \"hello\",\n"^ 88 | * " \"baz\" : 5\n"^ 89 | * "}" 90 | * in 91 | * 92 | * We parse the JSON, monadically access the fields we want, and fill in the 93 | * record by doing: 94 | * 95 | * let json = Hh_json_json_of_string data in 96 | * let open Hh_json.Access in 97 | * let accessor = return json in 98 | * let result = 99 | * accessor >>= get_bool "foo" >>= fun (foo, _) -> 100 | * accessor >>= get_string "bar" >>= fun (bar, _) -> 101 | * accessor >>= get_number_int "baz" >>= fun (baz, _) -> 102 | * return { 103 | * foo; 104 | * bar; 105 | * baz; 106 | * } 107 | * in 108 | * 109 | * The result will be the record type inside the Result monad. 110 | * 111 | * match result with 112 | * | Result.Ok (v, _) -> 113 | * Printf.eprintf "Got baz: %d" v.baz 114 | * | Result.Error access_failure -> 115 | * Printf.eprintf "JSON failure: %s" 116 | * (access_failure_to_string access_failure) 117 | * 118 | * See unit tests for more examples. 119 | *) 120 | module type Access = sig 121 | type keytrace = string list 122 | 123 | type access_failure = 124 | | Not_an_object of keytrace (** You can't access keys on a non-object JSON thing. *) 125 | | Missing_key_error of string * keytrace (** The key is missing. *) 126 | | Wrong_type_error of keytrace * json_type (** The key has the wrong type. *) 127 | 128 | (** Our type for the result monad. It isn't just the json because it tracks 129 | * a history of the keys traversed to arrive at the current point. This helps 130 | * produce more informative error states. *) 131 | type 'a m = (('a * keytrace), access_failure) Hack_result.t 132 | 133 | val access_failure_to_string : access_failure -> string 134 | 135 | val return : 'a -> 'a m 136 | 137 | val (>>=) : 'a m -> (('a * keytrace) -> 'b m) -> 'b m 138 | 139 | (** This is a comonad, but we need a little help to deal with failure *) 140 | val counit_with : (access_failure -> 'a) -> 'a m -> 'a 141 | 142 | (** 143 | * The following getters operate on a JSON_Object by accessing keys on it, 144 | * and asserting the returned value has the given expected type (types 145 | * are asserted by which getter you choose to use). 146 | * 147 | * Returns Not_an_object if the given JSON object is not a JSON_Object type, 148 | * since you can only access keys on those. 149 | * 150 | * Returns Wrong_type_error if the obtained value is not an object type. 151 | * 152 | * Returns Missing_key_error if the given key is not found in this object. 153 | * 154 | *) 155 | val get_obj : string -> json * keytrace -> json m 156 | val get_bool : string -> json * keytrace -> bool m 157 | val get_string : string -> json * keytrace -> string m 158 | val get_number : string -> json * keytrace -> string m 159 | val get_number_int : string -> json * keytrace -> int m 160 | val get_array: string -> json * keytrace -> (json list) m 161 | val get_val: string -> json * keytrace -> json m (* any expected type *) 162 | end 163 | 164 | module Access : Access 165 | -------------------------------------------------------------------------------- /src/utils/hh_logger.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | open Core 12 | 13 | let timestamp_string () = 14 | let open Unix in 15 | let tm = localtime (time ()) in 16 | let year = tm.tm_year + 1900 in 17 | Printf.sprintf "[%d-%02d-%02d %02d:%02d:%02d]" 18 | year (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec 19 | 20 | (* We might want to log to both stderr and a file. Shelling out to tee isn't cross-platform. 21 | * We could dup2 stderr to a pipe and have a child process write to both original stderr and the 22 | * file, but that's kind of overkill. This is good enough *) 23 | let dupe_log: (string * out_channel) option ref = ref None 24 | let set_log filename fd = 25 | dupe_log := Some (filename, fd) 26 | let get_log_name () = Option.map !dupe_log ~f:fst 27 | 28 | let print_raw s = 29 | let time = timestamp_string () in 30 | begin match !dupe_log with 31 | | None -> () 32 | | Some (_, dupe_log_oc) -> Printf.fprintf dupe_log_oc "%s %s%!" time s end; 33 | Printf.eprintf "%s %s%!" time s 34 | 35 | (* wraps print_raw in order to take a format string & add a newline *) 36 | let print fmt = Printf.ksprintf print_raw (fmt^^"\n") 37 | 38 | let print_duration name t = 39 | print_raw (name ^ ": "); 40 | let t2 = Unix.gettimeofday() in 41 | Printf.eprintf "%f\n%!" (t2 -. t); 42 | t2 43 | 44 | let exc ?(prefix="") e = 45 | print_raw (prefix ^ Exn.to_string e ^ "\n"); 46 | Printexc.print_backtrace stderr; 47 | () 48 | 49 | module Level : sig 50 | type t = 51 | | Off 52 | | Fatal 53 | | Error 54 | | Warn 55 | | Info 56 | | Debug 57 | val min_level : unit -> t 58 | val set_min_level : t -> unit 59 | val passes_min_level: t -> bool 60 | val log : t -> ('a, unit, string, string, string, unit) format6 -> 'a 61 | val log_duration : t -> string -> float -> float 62 | end = struct 63 | type t = 64 | | Off 65 | | Fatal 66 | | Error 67 | | Warn 68 | | Info 69 | | Debug 70 | 71 | let int_of_level = function 72 | | Off -> 6 73 | | Fatal -> 5 74 | | Error -> 4 75 | | Warn -> 3 76 | | Info -> 2 77 | | Debug -> 1 78 | 79 | let min_level_ref = ref Info 80 | let min_level () = !min_level_ref 81 | let set_min_level level = min_level_ref := level 82 | 83 | let passes_min_level level = 84 | int_of_level level >= int_of_level !min_level_ref 85 | 86 | let log level fmt = 87 | if passes_min_level level 88 | then print fmt 89 | else Printf.ifprintf () fmt 90 | 91 | let log_duration level fmt t = 92 | if passes_min_level level 93 | then print_duration fmt t 94 | else t 95 | 96 | end 97 | 98 | (* Default log instructions to INFO level *) 99 | let log ?(lvl=Level.Info) fmt = Level.log lvl fmt 100 | let log_duration fmt t = Level.log_duration Level.Info fmt t 101 | 102 | let fatal fmt = Level.log Level.Fatal fmt 103 | let error fmt = Level.log Level.Error fmt 104 | let warn fmt = Level.log Level.Warn fmt 105 | let info fmt = Level.log Level.Info fmt 106 | let debug fmt = Level.log Level.Debug fmt 107 | -------------------------------------------------------------------------------- /src/utils/lock.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | let lock_fds = ref SMap.empty 12 | 13 | (** 14 | * Basic lock operations. 15 | * 16 | * We use these for two reasons: 17 | * 1. making sure we are only running one instance of hh_server per person on a given dev box 18 | * 2. giving a way to hh_client to check if a server is running. 19 | *) 20 | 21 | let register_lock lock_file = 22 | let _ = Sys_utils.mkdir_no_fail (Filename.dirname lock_file) in 23 | Sys_utils.with_umask 0o111 begin fun () -> 24 | let fd = Unix.descr_of_out_channel (open_out lock_file) in 25 | let st = Unix.fstat fd in 26 | lock_fds := SMap.add lock_file (fd, st) !lock_fds; 27 | fd 28 | end 29 | 30 | (** 31 | * Grab or check if a file lock is available. 32 | * 33 | * Returns true if the lock is/was available, false otherwise. 34 | *) 35 | let _operations lock_file op : bool = 36 | try 37 | let fd = match SMap.get lock_file !lock_fds with 38 | | None -> register_lock lock_file 39 | | Some (fd, st) -> 40 | let identical_file = 41 | try 42 | (* Note: I'm carefully avoiding opening another fd to the 43 | * lock_file when doing this check, because closing any file 44 | * descriptor to a given file will release the locks on *all* 45 | * file descriptors that point to that file. Fortunately, stat() 46 | * gets us our information without opening a fd *) 47 | let current_st = Unix.stat lock_file in 48 | Unix.(st.st_dev = current_st.st_dev && 49 | st.st_ino = current_st.st_ino) 50 | with _ -> 51 | false 52 | in 53 | if not (Sys.win32 || identical_file) then 54 | (* Looks like someone (tmpwatch?) deleted the lock file; don't 55 | * create another one, because our socket is probably gone too. 56 | * We are dead in the water. *) 57 | raise Exit 58 | else 59 | fd 60 | in 61 | let _ = 62 | try Unix.lockf fd op 1 63 | with _ when Sys.win32 && (op = Unix.F_TLOCK || op = Unix.F_TEST) -> 64 | (* On Windows, F_TLOCK and F_TEST fail if we have the lock ourself *) 65 | (* However, we then are the only one to be able to write there. *) 66 | ignore (Unix.lseek fd 0 Unix.SEEK_SET : int); 67 | (* If we don't have the lock, the following 'write' will 68 | throw an exception. *) 69 | let wb = Unix.write fd (Bytes.make 1 ' ') 0 1 in 70 | (* When not throwing an exception, the current 71 | implementation of `Unix.write` always return `1`. But let's 72 | be protective against semantic changes, and better fails 73 | than wrongly assume that we own a lock. *) 74 | assert (wb = 1) in 75 | true 76 | with _ -> 77 | false 78 | 79 | (** 80 | * Grabs the file lock and returns true if it the lock was grabbed 81 | *) 82 | let grab lock_file : bool = _operations lock_file Unix.F_TLOCK 83 | 84 | (** 85 | * Releases a file lock. 86 | *) 87 | let release lock_file : bool = _operations lock_file Unix.F_ULOCK 88 | 89 | let blocking_grab_then_release lock_file = 90 | ignore (_operations lock_file Unix.F_LOCK); 91 | ignore (release lock_file) 92 | 93 | 94 | (** 95 | * Gets the server instance-unique integral fd for a given lock file. 96 | *) 97 | let fd_of lock_file : int = 98 | match SMap.get lock_file !lock_fds with 99 | | None -> -1 100 | | Some fd -> Obj.magic fd 101 | 102 | (** 103 | * Check if the file lock is available without grabbing it. 104 | * Returns true if the lock is free. 105 | *) 106 | let check lock_file : bool = _operations lock_file Unix.F_TEST 107 | -------------------------------------------------------------------------------- /src/utils/marshal_tools.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (** 12 | * This tool allows for marshaling directly over file descriptors (instead of 13 | * ocaml "channels") to avoid buffering so that we can safely use marshaling 14 | * and libancillary together. 15 | * 16 | * The problem: 17 | * Ocaml's marshaling is done over channels, which have their own internal 18 | * buffer. This means after reading a marshaled object from a channel, the 19 | * FD's position is not guaranteed to be pointing to the beginning of the 20 | * next marshaled object (but instead points to the position after the 21 | * buffered read). So another process cannot receive this FD (over 22 | * libancillary) to start reading the next object. 23 | * 24 | * The solution: 25 | * Start each message with a fixed-size preamble that describes the 26 | * size of the payload to read. Read precisely that many bytes directly 27 | * from the FD avoiding Ocaml channels entirely. 28 | *) 29 | 30 | exception Invalid_Int_Size_Exception 31 | exception Payload_Size_Too_Large_Exception 32 | exception Malformed_Preamble_Exception 33 | exception Writing_Preamble_Exception 34 | exception Writing_Payload_Exception 35 | exception Reading_Preamble_Exception 36 | exception Reading_Payload_Exception 37 | 38 | (* We want to marshal exceptions (or at least their message+stacktrace) over *) 39 | (* the wire. This type ensures that no one will attempt to pattern-match on *) 40 | (* the thing we marshal: 'Values of extensible variant types, for example *) 41 | (* exceptions (of extensible type exn), returned by the unmarhsaller should *) 42 | (* not be pattern-matched over, because unmarshalling does not preserve the *) 43 | (* information required for matching their constructors.' *) 44 | (* https://caml.inria.fr/pub/docs/manual-ocaml/libref/Marshal.html *) 45 | type remote_exception_data = { 46 | message : string; 47 | stack : string; 48 | } 49 | 50 | let preamble_start_sentinel = '\142' 51 | 52 | (** Size in bytes. *) 53 | let preamble_core_size = 4 54 | 55 | let expected_preamble_size = preamble_core_size + 1 56 | 57 | (** Payload size in bytes = 2^31 - 1. *) 58 | let maximum_payload_size = (1 lsl (preamble_core_size * 8)) - 1 59 | 60 | let get_preamble_core (size : int) = 61 | (* We limit payload size to 2^31 - 1 bytes. *) 62 | if size >= maximum_payload_size then 63 | raise Payload_Size_Too_Large_Exception; 64 | let rec loop i (remainder: int) acc = 65 | if i < 0 then acc 66 | else loop (i - 1) (remainder / 256) 67 | (Bytes.set acc i (Char.chr (remainder mod 256)); acc) in 68 | loop (preamble_core_size - 1) size (Bytes.create preamble_core_size) 69 | 70 | let make_preamble (size : int) = 71 | let preamble_core = get_preamble_core size in 72 | let preamble = Bytes.create (preamble_core_size + 1) in 73 | Bytes.set preamble 0 preamble_start_sentinel; 74 | Bytes.blit preamble_core 0 preamble 1 4; 75 | preamble 76 | 77 | let parse_preamble preamble = 78 | if (Bytes.length preamble) <> expected_preamble_size 79 | || (Bytes.get preamble 0) <> preamble_start_sentinel then 80 | raise Malformed_Preamble_Exception; 81 | let rec loop i acc = 82 | if i >= 5 then acc 83 | else loop (i + 1) ((acc * 256) + (int_of_char (Bytes.get preamble i))) in 84 | loop 1 0 85 | 86 | let to_fd_with_preamble fd obj = 87 | let flag_list = [] in 88 | let payload = Marshal.to_bytes obj flag_list in 89 | let size = Bytes.length payload in 90 | let preamble = make_preamble size in 91 | let preamble_bytes_written = 92 | Unix.write fd preamble 0 expected_preamble_size in 93 | if preamble_bytes_written <> expected_preamble_size then 94 | raise Writing_Preamble_Exception; 95 | let bytes_written = Unix.write fd payload 0 size in 96 | if bytes_written <> size then 97 | raise Writing_Payload_Exception; 98 | () 99 | 100 | let rec read_payload fd buffer offset to_read = 101 | if to_read = 0 then offset else begin 102 | let bytes_read = Unix.read fd buffer offset to_read in 103 | if bytes_read = 0 then offset else begin 104 | read_payload fd buffer (offset+bytes_read) (to_read-bytes_read) 105 | end 106 | end 107 | 108 | let from_fd_with_preamble fd = 109 | let preamble = Bytes.create expected_preamble_size in 110 | let bytes_read = Unix.read fd preamble 0 expected_preamble_size in 111 | if (bytes_read = 0) 112 | (* Unix manpage for read says 0 bytes read indicates end of file. *) 113 | then raise End_of_file 114 | else if (bytes_read <> expected_preamble_size) then 115 | (Printf.eprintf "Error, only read %d bytes for preamble.\n" bytes_read; 116 | raise Reading_Preamble_Exception); 117 | let payload_size = parse_preamble preamble in 118 | let payload = Bytes.create payload_size in 119 | let payload_size_read = read_payload fd payload 0 payload_size in 120 | if (payload_size_read <> payload_size) then 121 | raise Reading_Payload_Exception; 122 | Marshal.from_bytes payload 0 123 | -------------------------------------------------------------------------------- /src/utils/marshal_tools.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | exception Invalid_Int_Size_Exception 12 | exception Payload_Size_Too_Large_Exception 13 | exception Malformed_Preamble_Exception 14 | exception Writing_Preamble_Exception 15 | exception Writing_Payload_Exception 16 | exception Reading_Preamble_Exception 17 | exception Reading_Payload_Exception 18 | 19 | type remote_exception_data = { 20 | message : string; 21 | stack : string; 22 | } 23 | 24 | val to_fd_with_preamble: Unix.file_descr -> 'a -> unit 25 | val from_fd_with_preamble: Unix.file_descr -> 'a 26 | -------------------------------------------------------------------------------- /src/utils/measure.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | type record 12 | type record_data 13 | 14 | val create: unit -> record 15 | 16 | val push_global: unit -> unit 17 | val pop_global: unit -> record 18 | 19 | val serialize: record -> record_data 20 | val deserialize: record_data -> record 21 | 22 | val track_distribution: ?record:record -> string -> bucket_size:float -> unit 23 | 24 | val sample: ?record:record -> string -> float -> unit 25 | val time: ?record:record -> string -> (unit -> 'a) -> 'a 26 | 27 | val merge: ?record:record -> from:record -> unit -> unit 28 | 29 | val get_sum: ?record:record -> string -> float option 30 | 31 | val print_entry_stats: ?record:record -> string -> unit 32 | val print_stats: ?record:record -> unit -> unit 33 | val print_entry_distribution: ?record:record -> string -> unit 34 | val print_distributions: ?record:record -> unit -> unit 35 | -------------------------------------------------------------------------------- /src/utils/nproc.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2014, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | */ 10 | 11 | #include 12 | #ifdef _WIN32 13 | #include 14 | #else 15 | #include 16 | #endif 17 | 18 | value nproc(void) { 19 | CAMLparam0(); 20 | CAMLlocal1(result); 21 | #ifdef _WIN32 22 | SYSTEM_INFO sysinfo; 23 | GetSystemInfo(&sysinfo); 24 | result = Val_long(sysinfo.dwNumberOfProcessors); 25 | #else 26 | result = Val_long(sysconf(_SC_NPROCESSORS_ONLN)); 27 | #endif 28 | CAMLreturn(result); 29 | } 30 | -------------------------------------------------------------------------------- /src/utils/pidLog.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | open Hack_core 12 | 13 | let log_oc = ref None 14 | 15 | let enabled = ref true 16 | 17 | let disable () = enabled := false 18 | 19 | let init pids_file = 20 | assert (!log_oc = None); 21 | Sys_utils.with_umask 0o111 begin fun () -> 22 | Sys_utils.mkdir_no_fail (Filename.dirname pids_file); 23 | let oc = open_out pids_file in 24 | log_oc := Some oc; 25 | Unix.(set_close_on_exec (descr_of_out_channel oc)) 26 | end 27 | 28 | let log ?reason ?(no_fail=false) pid = 29 | if !enabled 30 | then 31 | let pid = Sys_utils.pid_of_handle pid in 32 | let reason = match reason with 33 | | None -> "unknown" 34 | | Some s -> s in 35 | match !log_oc with 36 | | None when no_fail -> () 37 | | None -> failwith "Can't write pid to uninitialized pids log" 38 | | Some oc -> Printf.fprintf oc "%d\t%s\n%!" pid reason 39 | 40 | exception FailedToGetPids 41 | 42 | let get_pids pids_file = 43 | try 44 | let ic = open_in pids_file in 45 | let results = ref [] in 46 | begin try 47 | while true do 48 | let row = input_line ic in 49 | if Str.string_match (Str.regexp "^\\([0-9]+\\)\t\\(.+\\)") row 0 50 | then 51 | let pid = int_of_string (Str.matched_group 1 row) in 52 | let reason = Str.matched_group 2 row in 53 | results := (pid, reason)::!results; 54 | done; 55 | with End_of_file -> () end; 56 | close_in ic; 57 | List.rev !results 58 | with Sys_error _ -> 59 | raise FailedToGetPids 60 | 61 | let close () = 62 | Hack_option.iter !log_oc ~f:close_out; 63 | log_oc := None 64 | -------------------------------------------------------------------------------- /src/utils/printSignal.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | let string_of_signal n = 12 | match n with 13 | | _ when n = Sys.sigabrt -> "sigabrt" 14 | | _ when n = Sys.sigalrm -> "sigalrm" 15 | | _ when n = Sys.sigfpe -> "sigfpe" 16 | | _ when n = Sys.sighup -> "sighup" 17 | | _ when n = Sys.sigill -> "sigill" 18 | | _ when n = Sys.sigint -> "sigint" 19 | | _ when n = Sys.sigkill -> "sigkill" 20 | | _ when n = Sys.sigpipe -> "sigpipe" 21 | | _ when n = Sys.sigquit -> "sigquit" 22 | | _ when n = Sys.sigsegv -> "sigsegv" 23 | | _ when n = Sys.sigterm -> "sigterm" 24 | | _ when n = Sys.sigusr1 -> "sigusr1" 25 | | _ when n = Sys.sigusr2 -> "sigusr2" 26 | | _ when n = Sys.sigchld -> "sigchld" 27 | | _ when n = Sys.sigcont -> "sigcont" 28 | | _ when n = Sys.sigstop -> "sigstop" 29 | | _ when n = Sys.sigtstp -> "sigtstp" 30 | | _ when n = Sys.sigttin -> "sigttin" 31 | | _ when n = Sys.sigttou -> "sigttou" 32 | | _ when n = Sys.sigvtalrm -> "sigvtalrm" 33 | | _ when n = Sys.sigprof -> "sigprof" 34 | | _ -> Printf.sprintf "unknown signal %d" n 35 | -------------------------------------------------------------------------------- /src/utils/priorities.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | */ 10 | 11 | #define CAML_NAME_SPACE 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #undef CAML_NAME_SPACE 18 | 19 | #ifdef _WIN32 20 | #include 21 | #else 22 | #include 23 | #include 24 | #include 25 | #endif 26 | 27 | /*****************************************************************************/ 28 | /* Sets CPU and IO priorities. */ 29 | /*****************************************************************************/ 30 | 31 | // glibc refused to add ioprio_set, sigh. 32 | // https://sourceware.org/bugzilla/show_bug.cgi?id=4464 33 | #define IOPRIO_CLASS_SHIFT 13 34 | #define IOPRIO_PRIO_VALUE(cl, dat) (((cl) << IOPRIO_CLASS_SHIFT) | (dat)) 35 | #define IOPRIO_WHO_PROCESS 1 36 | #define IOPRIO_CLASS_BE 2 37 | 38 | value hh_set_priorities(value cpu_prio_val, value io_prio_val) { 39 | CAMLparam2(cpu_prio_val, io_prio_val); 40 | int cpu_prio = Long_val(cpu_prio_val); 41 | int io_prio = Long_val(io_prio_val); 42 | 43 | // No need to check the return value, if we failed then whatever. 44 | #ifdef __linux__ 45 | syscall( 46 | SYS_ioprio_set, 47 | IOPRIO_WHO_PROCESS, 48 | getpid(), 49 | IOPRIO_PRIO_VALUE(IOPRIO_CLASS_BE, io_prio) 50 | ); 51 | #endif 52 | 53 | #ifdef _WIN32 54 | SetPriorityClass(GetCurrentProcess(), BELOW_NORMAL_PRIORITY_CLASS); 55 | // One might also try: PROCESS_MODE_BACKGROUND_BEGIN 56 | #else 57 | int dummy = nice(cpu_prio); 58 | (void)dummy; // https://gcc.gnu.org/bugzilla/show_bug.cgi?id=25509 59 | #endif 60 | CAMLreturn(Val_unit); 61 | } 62 | -------------------------------------------------------------------------------- /src/utils/realpath.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2014, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | */ 10 | 11 | 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | 18 | #define Val_none Val_int(0) 19 | 20 | static value 21 | Val_some( value v ) 22 | { 23 | CAMLparam1( v ); 24 | CAMLlocal1( some ); 25 | some = caml_alloc(1, 0); 26 | Store_field( some, 0, v ); 27 | CAMLreturn( some ); 28 | } 29 | 30 | CAMLprim value 31 | hh_realpath(value v) { 32 | char *input; 33 | #ifndef _WIN32 34 | char output[PATH_MAX]; 35 | #else 36 | char output[_MAX_PATH]; 37 | #endif 38 | char *result; 39 | 40 | CAMLparam1(v); 41 | 42 | input = String_val(v); 43 | #ifndef _WIN32 44 | result = realpath(input, output); 45 | #else 46 | result = _fullpath(output, input, _MAX_PATH); 47 | #endif 48 | if (result == NULL) { 49 | CAMLreturn(Val_none); 50 | } else { 51 | CAMLreturn(Val_some(caml_copy_string(output))); 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /src/utils/stats.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (* Not all stats are worth logging for every user. Things like the initial heap 12 | * size are pretty deterministic if you know the input (i.e. the files being 13 | * checked). In fact, it's *only* useful information if you know the input. 14 | * This file is for storing these types of stats: Things that would be useful 15 | * for a benchmark script to know, so it can say "for these inputs, under these 16 | * conditions, here's how hh_server behaves". 17 | *) 18 | type t = { 19 | mutable init_parsing_heap_size : int; 20 | mutable init_heap_size : int; 21 | mutable max_heap_size : int; 22 | gc_stat : Gc.stat; 23 | } 24 | 25 | let stats : t = { 26 | init_parsing_heap_size = 0; 27 | init_heap_size = 0; 28 | max_heap_size = 0; 29 | gc_stat = Gc.quick_stat (); 30 | } 31 | 32 | let get_stats () = {stats with gc_stat = Gc.quick_stat ()} 33 | 34 | let update_max_heap_size x = 35 | stats.max_heap_size <- max stats.max_heap_size x 36 | 37 | let to_json stats = 38 | Hh_json.JSON_Object [ 39 | ("init_parsing_heap_size", Hh_json.int_ stats.init_parsing_heap_size); 40 | ("init_shared_heap_size", Hh_json.int_ stats.init_heap_size); 41 | ("max_shared_heap_size", Hh_json.int_ stats.max_heap_size); 42 | ("master_heap_words", Hh_json.int_ stats.gc_stat.Gc.heap_words); 43 | ("master_top_heap_words", Hh_json.int_ stats.gc_stat.Gc.top_heap_words); 44 | ] 45 | -------------------------------------------------------------------------------- /src/utils/string_utils.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | let soi = string_of_int 12 | let string_of_char = String.make 1 13 | 14 | let string_before s n = String.sub s 0 n 15 | let string_after s n = String.sub s n (String.length s - n) 16 | 17 | let string_starts_with long short = 18 | try 19 | let long = String.sub long 0 (String.length short) in 20 | long = short 21 | with Invalid_argument _ -> 22 | false 23 | 24 | let string_ends_with long short = 25 | try 26 | let len = String.length short in 27 | let long = String.sub long (String.length long - len) len in 28 | long = short 29 | with Invalid_argument _ -> 30 | false 31 | 32 | (* Returns the index of the first occurrence of string `needle` in string 33 | `haystack`. If not found, returns -1. 34 | 35 | An implementation of the Knuth-Morris-Pratt (KMP) algorithm. *) 36 | let substring_index needle = 37 | (* see Wikipedia pseudocode *) 38 | let needle_len = String.length needle in 39 | if needle_len = 0 then raise (Invalid_argument needle); 40 | let table = Array.make needle_len 0 in 41 | table.(0) <- (-1); 42 | let pos = ref 2 and cnd = ref 0 in 43 | while !pos < needle_len do 44 | if needle.[!pos - 1] = needle.[!cnd] then 45 | (table.(!pos) <- !cnd + 1; incr pos; incr cnd) 46 | else if !cnd > 0 then 47 | cnd := table.(!cnd) 48 | else 49 | (table.(!pos) <- 0; incr pos) 50 | done; 51 | fun haystack -> 52 | let len = String.length haystack in 53 | let p = ref 0 in 54 | let q = ref 0 in 55 | while !p < len && !q < needle_len do 56 | if haystack.[!p] = needle.[!q] then (incr p; incr q) 57 | else if !q = 0 then incr p 58 | else q := table.(!q) 59 | done; 60 | if !q >= needle_len then !p - needle_len 61 | else -1 62 | 63 | let is_substring needle = 64 | let substring_index_memo = substring_index needle in 65 | fun haystack -> (substring_index_memo haystack) >= 0 66 | 67 | (* Return a copy of the string with prefixing string removed. 68 | * The function is a no-op if it s does not start with prefix. 69 | * Modeled after Python's string.lstrip. 70 | *) 71 | let lstrip s prefix = 72 | let prefix_length = String.length prefix in 73 | if string_starts_with s prefix 74 | then String.sub s prefix_length (String.length s - prefix_length) 75 | else s 76 | 77 | let rstrip s suffix = 78 | let result_length = String.length s - String.length suffix in 79 | if string_ends_with s suffix 80 | then String.sub s 0 result_length 81 | else s 82 | 83 | let rpartition s c = 84 | let sep_idx = String.rindex s c in 85 | let first = String.sub s 0 sep_idx in 86 | let second = 87 | String.sub s (sep_idx + 1) (String.length s - sep_idx - 1) in 88 | first, second 89 | 90 | let is_lowercase_char = 91 | let a_code, z_code = Char.code 'a', Char.code 'z' in 92 | fun chr -> 93 | let code = Char.code chr in 94 | a_code <= code && code <= z_code 95 | 96 | let rec is_not_lowercase str i j = 97 | if is_lowercase_char str.[i] then false 98 | else if i = j then true 99 | else is_not_lowercase str (i + 1) j 100 | 101 | (* String provides map and iter but not fold. It also is missing a char_list_of 102 | * function. Oh well. You can use fold to simulate anything you need, I suppose 103 | *) 104 | let fold_left ~f ~acc str = 105 | let acc = ref acc in 106 | String.iter (fun c -> acc := f (!acc) c) str; 107 | !acc 108 | 109 | let split c = Str.split (Str.regexp @@ Char.escaped c) 110 | 111 | (* Replaces all instances of the needle character with the replacement character 112 | *) 113 | let replace_char needle replacement = 114 | String.map (fun c -> if c = needle then replacement else c) 115 | 116 | (* Splits a string into a list of strings using "\n", "\r" or "\r\n" as 117 | * delimiters. If the string starts or ends with a delimiter, there WILL be an 118 | * empty string at the beginning or end of the list, like Str.split_delim does 119 | *) 120 | let split_into_lines str = 121 | (* To avoid unnecessary string allocations, we're going to keep a list of 122 | * the start index of each line and how long it is. Then, at the end, we can 123 | * use String.sub to create the actual strings. *) 124 | let _, (last_start, lines) = fold_left 125 | ~f: (fun (idx, (start, lines)) c -> 126 | (* For \r\n, we've already processed the newline *) 127 | if c = '\n' && idx > 0 && String.get str (idx-1) = '\r' 128 | then idx+1, (idx+1, lines) 129 | else 130 | if c = '\n' || c = '\r' 131 | then idx+1, (idx+1, (start, idx-start)::lines) 132 | else idx+1, (start, lines) 133 | ) 134 | ~acc:(0, (0, [])) 135 | str 136 | in 137 | 138 | (* Reverses the list of start,len and turns them into strings *) 139 | List.fold_left 140 | (fun lines (start, len) -> (String.sub str start len)::lines) 141 | [] 142 | ((last_start, String.length str - last_start)::lines) 143 | 144 | (* Splits a string into a list of strings using only "\n" as a delimiter. 145 | * If the string ends with a delimiter, an empty string representing the 146 | * contents after the final delimiter is NOT included (unlike Str.split_delim). 147 | *) 148 | let split_on_newlines content = 149 | let re = Str.regexp "[\n]" in 150 | let lines = Str.split_delim re content in 151 | (* don't create a list entry for the line after a trailing newline *) 152 | match List.rev lines with 153 | | "" :: rest -> List.rev rest 154 | | _ -> lines 155 | -------------------------------------------------------------------------------- /src/utils/sysinfo.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | */ 10 | 11 | #define CAML_NAME_SPACE 12 | #include 13 | #include 14 | 15 | #include 16 | #ifndef _WIN32 17 | #ifndef __APPLE__ 18 | #ifndef __OpenBSD__ 19 | #include 20 | #endif 21 | #endif 22 | #endif 23 | 24 | #ifdef _WIN32 25 | #include 26 | #endif 27 | 28 | value hh_sysinfo_totalram(void) { 29 | CAMLparam0(); 30 | #ifdef __linux__ 31 | struct sysinfo info; 32 | int success = sysinfo(&info); 33 | assert(success == 0 && "sysinfo() failed"); 34 | CAMLreturn(Val_long(info.totalram)); 35 | #else 36 | /* Not implemented */ 37 | CAMLreturn(Val_long(0)); 38 | #endif 39 | } 40 | 41 | value hh_sysinfo_uptime(void) { 42 | CAMLparam0(); 43 | #ifdef __linux__ 44 | struct sysinfo info; 45 | int success = sysinfo(&info); 46 | assert(success == 0 && "sysinfo() failed"); 47 | CAMLreturn(Val_long(info.uptime)); 48 | #else 49 | /* Not implemented */ 50 | CAMLreturn(Val_long(0)); 51 | #endif 52 | } 53 | 54 | /** 55 | * There are a bunch of functions that you expect to return a pid, 56 | * like Unix.getpid() and Unix.create_process(). However, on 57 | * Windows, instead of returning the process ID, they return a 58 | * process handle. 59 | * 60 | * Process handles seem act like pointers to a process. You can have 61 | * more than one handle that points to a single process (unlike 62 | * pids, where there is a single pid for a process). 63 | * 64 | * This isn't a problem normally, since functons like Unix.waitpid() 65 | * will take the process handle on Windows. But if you want to print 66 | * or log the pid, then you need to dereference the handle and get 67 | * the pid. And that's what this function does. 68 | */ 69 | value pid_of_handle(value handle) { 70 | CAMLparam1(handle); 71 | #ifdef _WIN32 72 | CAMLreturn(Val_int(GetProcessId((HANDLE)Long_val(handle)))); 73 | #else 74 | CAMLreturn(handle); 75 | #endif 76 | } 77 | 78 | value handle_of_pid_for_termination(value pid) { 79 | CAMLparam1(pid); 80 | #ifdef _WIN32 81 | CAMLreturn(Val_int(OpenProcess(PROCESS_TERMINATE, FALSE, Int_val(pid)))); 82 | #else 83 | CAMLreturn(pid); 84 | #endif 85 | } 86 | -------------------------------------------------------------------------------- /src/utils/timeout.mli: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the root directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | (* Helpers for handling timeout, in particular input timeout. *) 12 | 13 | type t 14 | 15 | exception Timeout 16 | 17 | (* The function `with_timeout` executes 'do_' for at most 'timeout' 18 | seconds. If the `timeout` is reached, the `on_timeout` is executed 19 | if available, otherwise the `Timeout` exception is raised. 20 | 21 | On Unix platform, this function is based on `SIGALRM`. On Windows 22 | platform, this is based on the equivalent of `select`. Hence, this 23 | module exports variant of basic input functions, adding them a 24 | `timeout` parameter. It should correspond to the parameter of the 25 | `do_` function. 26 | 27 | For `do_` function based only on computation (and not I/O), you 28 | should call the `check_timeout` function on a regular 29 | basis. Otherwise, on Windows, the timeout will never be detected. 30 | On Unix, the function `check_timeout` is no-op. 31 | 32 | On Unix, the type `in_channel` is in fact an alias for 33 | `Pervasives.in_channel`. 34 | 35 | *) 36 | val with_timeout: 37 | timeout:int -> 38 | ?on_timeout:(unit -> unit) -> 39 | do_:(t -> 'a) -> 'a 40 | 41 | val check_timeout: t -> unit 42 | 43 | type in_channel 44 | 45 | val open_in: string -> in_channel 46 | val close_in: in_channel -> unit 47 | val close_in_noerr: in_channel -> unit 48 | 49 | val in_channel_of_descr: Unix.file_descr -> in_channel 50 | val descr_of_in_channel: in_channel -> Unix.file_descr 51 | 52 | val input: ?timeout:t -> in_channel -> bytes -> int -> int -> int 53 | val really_input: ?timeout:t -> in_channel -> bytes -> int -> int -> unit 54 | val input_char: ?timeout:t -> in_channel -> char 55 | val input_line: ?timeout:t -> in_channel -> string 56 | val input_value: ?timeout:t -> in_channel -> 'a 57 | 58 | val open_process: string -> string array -> in_channel * out_channel 59 | val open_process_in: string -> string array -> in_channel 60 | val close_process_in: in_channel -> Unix.process_status 61 | val read_process: 62 | timeout:int -> 63 | ?on_timeout:(unit -> unit) -> 64 | reader:(t -> in_channel -> out_channel -> 'a) -> 65 | string -> string array -> 'a 66 | 67 | val open_connection: 68 | ?timeout:t -> Unix.sockaddr -> in_channel * out_channel 69 | val read_connection: 70 | timeout:int -> 71 | ?on_timeout:(unit -> unit) -> 72 | reader:(t -> in_channel -> out_channel -> 'a) -> 73 | Unix.sockaddr -> 'a 74 | val shutdown_connection: in_channel -> unit 75 | -------------------------------------------------------------------------------- /src/utils/utils.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Copyright (c) 2015, Facebook, Inc. 3 | * All rights reserved. 4 | * 5 | * This source code is licensed under the BSD-style license found in the 6 | * LICENSE file in the "hack" directory of this source tree. An additional grant 7 | * of patent rights can be found in the PATENTS file in the same directory. 8 | * 9 | *) 10 | 11 | open Hack_core 12 | 13 | let () = Random.self_init () 14 | let debug = ref false 15 | let profile = ref false 16 | 17 | let log = ref (fun (_ : string) -> ()) 18 | 19 | let d s = 20 | if !debug 21 | then begin 22 | print_string s; 23 | flush stdout; 24 | end 25 | 26 | let dn s = 27 | if !debug 28 | then begin 29 | print_string s; 30 | print_newline(); 31 | flush stdout; 32 | end 33 | 34 | module Map = struct end 35 | 36 | let spf = Printf.sprintf 37 | let print_endlinef fmt = Printf.ksprintf print_endline fmt 38 | let prerr_endlinef fmt = Printf.ksprintf prerr_endline fmt 39 | 40 | let opt f env = function 41 | | None -> env, None 42 | | Some x -> let env, x = f env x in env, Some x 43 | 44 | let opt_fold f env = function 45 | | None -> env 46 | | Some x -> f env x 47 | 48 | let singleton_if cond x = if cond then [x] else [] 49 | 50 | let smap_inter m1 m2 = 51 | SMap.fold ( 52 | fun x y acc -> 53 | if SMap.mem x m2 54 | then SMap.add x y acc 55 | else acc 56 | ) m1 SMap.empty 57 | 58 | let imap_inter m1 m2 = 59 | IMap.fold ( 60 | fun x y acc -> 61 | if IMap.mem x m2 62 | then IMap.add x y acc 63 | else acc 64 | ) m1 IMap.empty 65 | 66 | let smap_inter_list = function 67 | | [] -> SMap.empty 68 | | x :: rl -> 69 | List.fold_left rl ~f:smap_inter ~init:x 70 | 71 | let imap_inter_list = function 72 | | [] -> IMap.empty 73 | | x :: rl -> 74 | List.fold_left rl ~f:imap_inter ~init:x 75 | 76 | let rec wfold_left2 f env l1 l2 = 77 | match l1, l2 with 78 | | [], _ | _, [] -> env 79 | | x1 :: rl1, x2 :: rl2 -> 80 | let env = f env x1 x2 in 81 | wfold_left2 f env rl1 rl2 82 | 83 | let sl l = 84 | List.fold_right l ~f:(^) ~init:"" 85 | 86 | let maybe f env = function 87 | | None -> () 88 | | Some x -> f env x 89 | 90 | (* Since OCaml usually runs w/o backtraces enabled, the note makes errors 91 | * easier to debug. *) 92 | let unsafe_opt_note note = function 93 | | None -> raise (Invalid_argument note) 94 | | Some x -> x 95 | 96 | let unsafe_opt x = unsafe_opt_note "unsafe_opt got None" x 97 | 98 | let inter_list = function 99 | | [] -> SSet.empty 100 | | x :: rl -> 101 | List.fold_left rl ~f:SSet.inter ~init:x 102 | 103 | let rec list_last f1 f2 = 104 | function 105 | | [] -> () 106 | | [x] -> f2 x 107 | | x :: rl -> f1 x; list_last f1 f2 rl 108 | 109 | let is_prefix_dir dir fn = 110 | let prefix = dir ^ Filename.dir_sep in 111 | String.length fn > String.length prefix && 112 | String.sub fn 0 (String.length prefix) = prefix 113 | 114 | let try_with_channel oc f1 f2 = 115 | try 116 | let result = f1 oc in 117 | close_out oc; 118 | result 119 | with e -> 120 | close_out oc; 121 | f2 e 122 | 123 | let iter_n_acc n f acc = 124 | let acc = ref acc in 125 | for _i = 1 to n-1 do 126 | acc := fst (f !acc) 127 | done; 128 | f !acc 129 | 130 | let map_of_list list = 131 | List.fold_left ~f:(fun m (k, v) -> SMap.add k v m) ~init:SMap.empty list 132 | 133 | let set_of_list l = 134 | List.fold_right l ~f:SSet.add ~init:SSet.empty 135 | 136 | (* \A\B\C -> A\B\C *) 137 | let strip_ns s = 138 | if String.length s == 0 || s.[0] <> '\\' then s 139 | else String.sub s 1 ((String.length s) - 1) 140 | 141 | (* \A\B\C -> C *) 142 | let strip_all_ns s = 143 | try 144 | let base_name_start = String.rindex s '\\' + 1 in 145 | String.sub s base_name_start ((String.length s) - base_name_start) 146 | with Not_found -> s 147 | 148 | (*****************************************************************************) 149 | (* Same as List.iter2, except that we only iterate as far as the shortest 150 | * of both lists. 151 | *) 152 | (*****************************************************************************) 153 | 154 | let rec iter2_shortest f l1 l2 = 155 | match l1, l2 with 156 | | [], _ | _, [] -> () 157 | | x1 :: rl1, x2 :: rl2 -> f x1 x2; iter2_shortest f rl1 rl2 158 | 159 | let fold_fun_list acc fl = 160 | List.fold_left fl ~f:(|>) ~init:acc 161 | 162 | let compose f g x = f (g x) 163 | 164 | let try_finally ~f ~(finally: unit -> unit) = 165 | let res = try f () with e -> finally (); raise e in 166 | finally (); 167 | res 168 | 169 | let with_context ~enter ~exit ~do_ = 170 | enter (); 171 | let result = try do_ () with e -> 172 | exit (); 173 | raise e in 174 | exit (); 175 | result 176 | 177 | (* We run with exception backtraces turned off for performance reasons. But for 178 | * some kinds of catastrophic exceptions, which we never recover from (so the 179 | * performance doesn't matter) we do want the backtrace. "assert false" is one 180 | * of such conditions. 181 | *) 182 | let assert_false_log_backtrace msg = 183 | Printf.eprintf "assert false with backtrace:\n"; 184 | Hack_option.iter msg ~f:(Printf.eprintf "%s\n"); 185 | Printf.eprintf "%s" (Printexc.raw_backtrace_to_string 186 | (Printexc.get_callstack 100)); 187 | assert false 188 | 189 | (* Returns the largest element in arr strictly less than `bound` *) 190 | let infimum (arr : 'a array) 191 | (bound : 'b) 192 | (compare : 'a -> 'b -> int) : int option = 193 | let rec binary_search low high = begin 194 | if low = high then 195 | Some low 196 | else if low > high then 197 | None 198 | else begin 199 | let mid = (low + high + 1) / 2 in 200 | let test = Array.get arr mid in 201 | if compare test bound < 0 then 202 | binary_search mid high 203 | else 204 | binary_search low (mid - 1) 205 | end 206 | end in 207 | binary_search 0 ((Array.length arr) - 1) 208 | --------------------------------------------------------------------------------