├── .gitignore ├── README.md ├── benchmark ├── Makefile ├── avltree.ml ├── bench.ml ├── btree.ml ├── dune ├── new-trees.ipynb ├── rbtree.ml ├── timing.ml ├── treap.ml ├── util.ml └── utils.py ├── dune-project ├── lib ├── avltree.ml ├── btree.ml ├── dune ├── finite_vector.ml ├── rbtree.ml ├── sort.ml └── treap.ml ├── obatcher_ds.opam ├── requirements.txt └── test ├── dune ├── test_avltree.ml ├── test_rbtree.ml └── test_treap.ml /.gitignore: -------------------------------------------------------------------------------- 1 | # Dune build directory 2 | _build/ 3 | 4 | # Python virtual environment 5 | venv/ 6 | 7 | # Python binaries 8 | __pycache__/ -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Batch Parallel Data Structures with Obatcher 2 | 3 | This is the repository for various case studies of batch parallel data structures with OBatcher (https://github.com/verse-lab/obatcher). 4 | 5 | As this requires a custom version of the library `domainslib` for Multicore OCaml, it is advisable that you create a new `opam` switch to run this. 6 | 7 | ## Build instructions 8 | 9 | First, set up OBatcher along with a new `opam` switch: 10 | 11 | ``` 12 | opam switch create obatcher_test ocaml.5.0.0 13 | eval $(opam env) 14 | opam update 15 | opam install dune batteries progress ptime cmdliner 16 | opam pin add domainslib https://github.com/phongulus/obatcher.git\#wait-for-batch 17 | ``` 18 | 19 | Note: for VSCode users, you will want to run the following as well to reinstall the prerequisites for the OCaml Platform extension in the new switch: 20 | 21 | ``` 22 | opam install ocamlformat ocaml-lsp-server 23 | ``` 24 | 25 | You can now clone and build the code in this repository. 26 | 27 | ``` 28 | git clone https://github.com/phongulus/obatcher_ds.git obatcher_ds 29 | cd obatcher_ds 30 | dune build 31 | ``` 32 | 33 | ## Running tests and benchmarks 34 | 35 | Provided tests can be simply run after building with: 36 | 37 | ``` 38 | dune runtest 39 | ``` 40 | 41 | For benchmarking, navigate to the `benchmark/` directory and use `make` commands: 42 | 43 | ``` 44 | cd benchmark 45 | make avltree-batched 46 | ``` 47 | 48 | See the Makefile for the full list of benchmarks that can be run this way. A more advisable way to run the benchmarks would be to use the provided Jupyter Notebook. It is recommended to set up a Python virtual environment for this purpose: 49 | 50 | ``` 51 | python3 -m venv venv 52 | source ./venv/bin/activate 53 | pip install -r requirements.txt 54 | ``` 55 | 56 | When running the Jupyter Notebook, use the virtual environment set up above. 57 | 58 | ## Adding more data structures 59 | 60 | TODO. -------------------------------------------------------------------------------- /benchmark/Makefile: -------------------------------------------------------------------------------- 1 | B := ../_build/default/benchmark/bench.exe 2 | WARMUP := 5 3 | ITER := 5 4 | 5 | B_PRESET := 2_000_000 6 | B_OPS := 1_000_000 7 | B_SEARCH := 0 8 | btree : btree.ml 9 | printf "Btree-Sequential\n" 10 | $(B) btree-sequential --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) 11 | 12 | printf "Btree-Coarse-Grained\n" 13 | $(B) btree-coarse-grained --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 14 | $(B) btree-coarse-grained --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 15 | $(B) btree-coarse-grained --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 16 | $(B) btree-coarse-grained --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 17 | $(B) btree-coarse-grained --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 18 | $(B) btree-coarse-grained --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 19 | $(B) btree-coarse-grained --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 20 | $(B) btree-coarse-grained --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 21 | 22 | printf "Btree-Batched\n" 23 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 24 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 25 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 26 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 27 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 28 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 29 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 30 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 31 | 32 | btree-batched : 33 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 -T 34 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 -T 35 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 -T 36 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 -T 37 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 -T 38 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 -T 39 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 -T 40 | $(B) btree-batched --init-count=$(B_PRESET) --count=$(B_OPS) --no-searches=$(B_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 -T 41 | 42 | AVL_PRESET := 2_000_000 43 | AVL_OPS := 1_000_000 44 | AVL_SEARCH := 0 45 | avltree : avltree.ml 46 | printf "Avltree-Sequential\n" 47 | $(B) avltree-sequential --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) 48 | 49 | printf "Avltree-Batched\n" 50 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 51 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 52 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 53 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 54 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 55 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 56 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 57 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 58 | 59 | avltree-batched : 60 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 -T 61 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 -T 62 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 -T 63 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 -T 64 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 -T 65 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 -T 66 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 -T 67 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 -T 68 | 69 | avltree-validate : 70 | $(B) avltree-batched --init-count=$(AVL_PRESET) --count=$(AVL_OPS) --no-searches=$(AVL_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 -T 71 | 72 | RB_PRESET := 2_000_000 73 | RB_OPS := 1_000_000 74 | RB_SEARCH := 0 75 | rbtree : rbtree.ml 76 | printf "rbtree-Sequential\n" 77 | $(B) rbtree-sequential --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) 78 | 79 | printf "rbtree-Batched\n" 80 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 81 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 82 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 83 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 84 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 85 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 86 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 87 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 88 | 89 | rbtree-batched : 90 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 91 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 92 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 93 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 94 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 95 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 96 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 97 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 98 | 99 | rbtree-validate : 100 | $(B) rbtree-batched --init-count=$(RB_PRESET) --count=$(RB_OPS) --no-searches=$(RB_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 -T 101 | 102 | TREAP_PRESET := 2_000_000 103 | TREAP_OPS := 1_000_000 104 | TREAP_SEARCH := 0 105 | treap : treap.ml 106 | printf "treap-Sequential\n" 107 | $(B) treap-sequential --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) 108 | 109 | printf "treap-Batched\n" 110 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 111 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 112 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 113 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 114 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 115 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 116 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 117 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 118 | 119 | treap-batched : 120 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 1 121 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 122 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 3 123 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 4 124 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 5 125 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 6 126 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 7 127 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 8 128 | 129 | treap-validate : 130 | $(B) treap-batched --init-count=$(TREAP_PRESET) --count=$(TREAP_OPS) --no-searches=$(TREAP_SEARCH) -i $(ITER) -w $(WARMUP) -D 2 -T -------------------------------------------------------------------------------- /benchmark/avltree.ml: -------------------------------------------------------------------------------- 1 | module IntAvltree = Obatcher_ds.Avltree.Make(Int) 2 | module BatchedIntAvltree = Domainslib.Batcher.Make1(IntAvltree) 3 | 4 | type generic_spec_args = { 5 | sorted: bool; 6 | no_searches: int; 7 | min: int; 8 | max: int; 9 | initial_count: int; 10 | should_validate: bool; 11 | search_threshold: int option; 12 | insert_threshold: int option; 13 | search_type: int option; 14 | insert_type: int option; 15 | } 16 | 17 | type generic_test_spec = { 18 | args: generic_spec_args; 19 | count: int; 20 | mutable initial_elements: int array; 21 | mutable insert_elements: int array; 22 | mutable search_elements: int array; 23 | } 24 | 25 | let generic_spec_args: generic_spec_args Cmdliner.Term.t = 26 | let open Cmdliner in 27 | let sorted = Arg.(value @@ flag @@ info ~doc:"whether the inserts should be sorted" ["s"; "sorted"]) in 28 | let no_searches = 29 | Arg.(value @@ opt (some int) None @@ info ~doc:"number of searches" ~docv:"NO_SEARCHES" ["n"; "no-searches"]) in 30 | let initial_count = 31 | Arg.(value @@ opt (some int) None @@ info ~doc:"Initial number of operations" ["init-count"]) in 32 | let min = 33 | Arg.(value @@ opt (some int) None @@ info ~doc:"Minimum value of data for random inputs" ["min"]) in 34 | let max = 35 | Arg.(value @@ opt (some int) None @@ info ~doc:"Maximum value of data for random inputs" ["max"]) in 36 | let validate = 37 | Arg.(value @@ flag @@ info ~doc:"Whether the tests should validate the results of the benchmarks" ["T"]) in 38 | let search_threshold = 39 | Arg.(value @@ opt (some int) None @@ 40 | info ~doc:"Threshold upon which searches should be sequential" ["search-threshold"]) in 41 | let insert_threshold = 42 | Arg.(value @@ opt (some int) None @@ 43 | info ~doc:"Threshold upon which inserts should be sequential" ["insert-threshold"]) in 44 | let insert_type = 45 | Arg.(value @@ opt (some int) None @@ info ~doc:"Which parallel insert to use" ["insert-type"]) in 46 | let search_type = 47 | Arg.(value @@ opt (some int) None @@ info ~doc:"Which parallel search to use" ["search-type"]) in 48 | 49 | Term.(const (fun sorted no_searches min max 50 | initial_count validate search_threshold insert_threshold search_type insert_type 51 | -> { 52 | sorted; 53 | no_searches=Option.value ~default:0 no_searches; 54 | initial_count=Option.value ~default:0 initial_count; 55 | min=Option.value ~default:0 min; 56 | max=Option.value ~default:((Int.shift_left 1 30) - 1) max; 57 | should_validate=validate; 58 | search_threshold; 59 | insert_threshold; 60 | search_type; 61 | insert_type; 62 | }) $ sorted $ no_searches $ min $ max $ initial_count $ 63 | validate $ search_threshold $ insert_threshold $ search_type $ insert_type) 64 | 65 | let generic_test_spec ~count spec_args = 66 | { args=spec_args; count: int; insert_elements=[| |]; search_elements=[| |]; initial_elements=[| |] } 67 | 68 | let generic_run test_spec f = 69 | let old_search_threshold = !Obatcher_ds.Avltree.avltree_search_sequential_threshold in 70 | let old_insert_threshold = !Obatcher_ds.Avltree.avltree_search_sequential_threshold in 71 | let old_search_type = !Obatcher_ds.Avltree.avltree_search_type in 72 | let old_insert_type = !Obatcher_ds.Avltree.avltree_insert_type in 73 | (match test_spec.args.search_threshold with None -> () | Some st -> 74 | Obatcher_ds.Avltree.avltree_search_sequential_threshold := st); 75 | (match test_spec.args.insert_threshold with None -> () | Some it -> 76 | Obatcher_ds.Avltree.avltree_insert_sequential_threshold := it); 77 | (match test_spec.args.search_type with None -> () | Some it -> 78 | Obatcher_ds.Avltree.avltree_search_type := it); 79 | (match test_spec.args.insert_type with None -> () | Some it -> 80 | Obatcher_ds.Avltree.avltree_insert_type := it); 81 | let res = f () in 82 | Obatcher_ds.Avltree.avltree_search_sequential_threshold := old_search_threshold; 83 | Obatcher_ds.Avltree.avltree_insert_sequential_threshold := old_insert_threshold; 84 | Obatcher_ds.Avltree.avltree_search_type := old_search_type; 85 | Obatcher_ds.Avltree.avltree_insert_type := old_insert_type; 86 | res 87 | 88 | let generic_init test_spec f = 89 | let min, max = test_spec.args.min, test_spec.args.max in 90 | let elements = Util.gen_random_unique_array ~min ~max (test_spec.args.initial_count + test_spec.count) in 91 | let initial_elements = Array.make test_spec.args.initial_count min in 92 | let insert_elements = Array.make test_spec.count min in 93 | let search_elements = Util.gen_random_unique_array ~min ~max test_spec.args.no_searches in 94 | Array.blit 95 | elements 0 96 | initial_elements 0 97 | test_spec.args.initial_count; 98 | Array.blit 99 | elements test_spec.args.initial_count 100 | insert_elements 0 101 | test_spec.count; 102 | if test_spec.args.sorted then 103 | Array.sort Int.compare insert_elements; 104 | test_spec.insert_elements <- insert_elements; 105 | test_spec.initial_elements <- initial_elements; 106 | test_spec.search_elements <- search_elements; 107 | generic_run test_spec @@ fun () -> f initial_elements 108 | 109 | module Sequential = struct 110 | 111 | type t = unit IntAvltree.t 112 | 113 | type test_spec = generic_test_spec 114 | 115 | type spec_args = generic_spec_args 116 | 117 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 118 | 119 | let test_spec ~count spec_args = 120 | generic_test_spec ~count spec_args 121 | 122 | let init _pool test_spec = 123 | generic_init test_spec (fun initial_elements -> 124 | let tree = IntAvltree.Sequential.new_tree () in 125 | Array.iter (fun i -> IntAvltree.Sequential.insert i () tree) 126 | initial_elements; 127 | tree 128 | ) 129 | 130 | let run _pool t test_spec = 131 | generic_run test_spec @@ fun () -> 132 | Array.iter (fun i -> 133 | IntAvltree.Sequential.insert i () t 134 | ) test_spec.insert_elements; 135 | Array.iter (fun i -> 136 | ignore @@ IntAvltree.Sequential.search i t 137 | ) test_spec.search_elements 138 | 139 | let cleanup (t: t) (test_spec: test_spec) = 140 | if test_spec.args.should_validate then begin 141 | Array.iter (fun elt -> 142 | match IntAvltree.Sequential.search elt t with 143 | | Some _ -> () 144 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 145 | ) test_spec.insert_elements; 146 | end 147 | end 148 | 149 | module CoarseGrained = struct 150 | 151 | type t = {tree: unit IntAvltree.t; mutex: Mutex.t} 152 | 153 | type test_spec = generic_test_spec 154 | 155 | type spec_args = generic_spec_args 156 | 157 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 158 | 159 | let test_spec ~count spec_args = 160 | generic_test_spec ~count spec_args 161 | 162 | let init _pool test_spec = 163 | generic_init test_spec (fun initial_elements -> 164 | let tree = IntAvltree.Sequential.new_tree () in 165 | Array.iter (fun i -> IntAvltree.Sequential.insert i () tree) 166 | initial_elements; 167 | let mutex = Mutex.create () in 168 | {tree;mutex} 169 | ) 170 | 171 | let run pool (t: t) test_spec = 172 | generic_run test_spec @@ fun () -> 173 | Domainslib.Task.parallel_for pool ~chunk_size:1 174 | ~start:0 ~finish:(Array.length test_spec.insert_elements + Array.length test_spec.search_elements - 1) 175 | ~body:(fun i -> 176 | Mutex.lock t.mutex; 177 | Fun.protect ~finally:(fun () -> Mutex.unlock t.mutex) (fun () -> 178 | if i < Array.length test_spec.insert_elements 179 | then IntAvltree.Sequential.insert test_spec.insert_elements.(i) () t.tree 180 | else ignore (IntAvltree.Sequential.search 181 | test_spec.search_elements.(i - Array.length test_spec.insert_elements) t.tree) 182 | ) 183 | ) 184 | 185 | let cleanup (t: t) (test_spec: test_spec) = 186 | if test_spec.args.should_validate then begin 187 | Array.iter (fun elt -> 188 | match IntAvltree.Sequential.search elt t.tree with 189 | | Some _ -> () 190 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 191 | ) test_spec.insert_elements 192 | end 193 | 194 | end 195 | 196 | module Batched = struct 197 | 198 | type t = unit BatchedIntAvltree.t 199 | 200 | type test_spec = generic_test_spec 201 | 202 | type spec_args = generic_spec_args 203 | 204 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 205 | 206 | let test_spec ~count spec_args = 207 | generic_test_spec ~count spec_args 208 | 209 | let init pool test_spec = 210 | generic_init test_spec (fun initial_elements -> 211 | let tree = BatchedIntAvltree.init pool in 212 | Array.iter (fun i -> BatchedIntAvltree.apply tree (Insert (i, ()))) 213 | initial_elements; 214 | tree) 215 | 216 | let run pool (tree: t) test_spec = 217 | generic_run test_spec @@ fun () -> 218 | Domainslib.Task.parallel_for pool ~chunk_size:1 219 | ~start:0 ~finish:(Array.length test_spec.insert_elements + Array.length test_spec.search_elements - 1) 220 | ~body:(fun i -> 221 | if i < Array.length test_spec.insert_elements 222 | then BatchedIntAvltree.apply tree (Insert (test_spec.insert_elements.(i), ())) 223 | else 224 | ignore (BatchedIntAvltree.apply tree (Search test_spec.search_elements.(i - Array.length test_spec.insert_elements))) 225 | ); 226 | BatchedIntAvltree.wait_for_batch tree 227 | 228 | let cleanup (t: t) (test_spec: test_spec) = 229 | if test_spec.args.should_validate then begin 230 | let t = BatchedIntAvltree.unsafe_get_internal_data t in 231 | let num_nodes = IntAvltree.Sequential.num_nodes t in 232 | if num_nodes <> Array.length test_spec.insert_elements + Array.length test_spec.initial_elements 233 | then Format.ksprintf failwith "Inserted %d elements, but found only %d in the tree" 234 | (Array.length test_spec.insert_elements + Array.length test_spec.initial_elements) 235 | num_nodes; 236 | let btree_flattened = IntAvltree.Sequential.flatten t |> Array.of_list in 237 | let all_elements = Array.concat [test_spec.insert_elements; test_spec.initial_elements] in 238 | Array.sort Int.compare all_elements; 239 | if Array.length btree_flattened <> Array.length all_elements then 240 | Format.ksprintf failwith "length of flattened btree (%d) did not match inserts (%d) (no_elements=%d)" 241 | (Array.length btree_flattened) (Array.length all_elements) (num_nodes); 242 | 243 | for i = 0 to Array.length btree_flattened - 1 do 244 | if fst btree_flattened.(i) <> all_elements.(i) then 245 | Format.ksprintf failwith "element %d of the btree was expected to be %d, but got %d" i 246 | all_elements.(i) (fst btree_flattened.(i)); 247 | done; 248 | 249 | Array.iter (fun elt -> 250 | match IntAvltree.Sequential.search elt t with 251 | | Some _ -> () 252 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 253 | ) test_spec.insert_elements; 254 | end 255 | 256 | end 257 | 258 | module ExplicitlyBatched = struct 259 | 260 | type t = unit IntAvltree.t 261 | 262 | type test_spec = { 263 | spec: generic_test_spec; 264 | mutable insert_elements: (int * unit) array; 265 | mutable search_elements: (int * (unit option -> unit)) array; 266 | } 267 | 268 | type spec_args = generic_spec_args 269 | 270 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 271 | 272 | let test_spec ~count spec_args = 273 | let spec = generic_test_spec ~count spec_args in 274 | {spec; insert_elements=[||]; search_elements=[||]} 275 | 276 | let init _pool (test_spec: test_spec) = 277 | generic_init test_spec.spec (fun initial_elements -> 278 | test_spec.insert_elements <- Array.map (fun i -> (i, ())) test_spec.spec.insert_elements; 279 | test_spec.search_elements <- Array.map (fun i -> (i, (fun _ -> ()))) test_spec.spec.search_elements; 280 | let tree = IntAvltree.Sequential.new_tree () in 281 | Array.iter (fun i -> IntAvltree.Sequential.insert i () tree) 282 | initial_elements; 283 | tree) 284 | 285 | let run pool (tree: t) test_spec = 286 | generic_run test_spec.spec @@ fun () -> 287 | if Array.length test_spec.insert_elements > 0 then 288 | IntAvltree.par_insert ~pool tree test_spec.insert_elements; 289 | if Array.length test_spec.spec.search_elements > 0 then 290 | ignore @@ IntAvltree.par_search ~pool tree test_spec.search_elements 291 | 292 | 293 | let cleanup (t: t) (test_spec: test_spec) = 294 | if test_spec.spec.args.should_validate then begin 295 | let num_nodes = IntAvltree.Sequential.num_nodes t in 296 | if num_nodes <> Array.length test_spec.insert_elements + Array.length test_spec.spec.initial_elements 297 | then Format.ksprintf failwith "Inserted %d elements, but found only %d in the tree" 298 | (Array.length test_spec.insert_elements + Array.length test_spec.spec.initial_elements) 299 | num_nodes; 300 | let btree_flattened = IntAvltree.Sequential.flatten t |> Array.of_list in 301 | let all_elements = Array.concat [test_spec.spec.insert_elements; test_spec.spec.initial_elements] in 302 | Array.sort Int.compare all_elements; 303 | if Array.length btree_flattened <> Array.length all_elements then 304 | Format.ksprintf failwith "length of flattened btree (%d) did not match inserts (%d) (no_elements=%d)" 305 | (Array.length btree_flattened) (Array.length all_elements) (num_nodes); 306 | 307 | for i = 0 to Array.length btree_flattened - 1 do 308 | if fst btree_flattened.(i) <> all_elements.(i) then 309 | Format.ksprintf failwith "element %d of the btree was expected to be %d, but got %d" i 310 | all_elements.(i) (fst btree_flattened.(i)); 311 | done; 312 | 313 | Array.iter (fun elt -> 314 | match IntAvltree.Sequential.search elt t with 315 | | Some _ -> () 316 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 317 | ) test_spec.spec.insert_elements; 318 | end 319 | 320 | end 321 | -------------------------------------------------------------------------------- /benchmark/bench.ml: -------------------------------------------------------------------------------- 1 | [@@@alert "-unstable"] 2 | module IntSet = Set.Make(Int) 3 | (* module IntBtree = Data.Btree.Make(Int) 4 | module BatchedIntBtree = Domainslib.Batcher.Make1(IntBtree) *) 5 | 6 | 7 | module type BENCHMARK = sig 8 | 9 | type t 10 | (** [t] represents the data structure being bench-marked *) 11 | 12 | type test_spec 13 | (** [test] represents a specification for a particular test of the datastructure [t]. *) 14 | 15 | type spec_args 16 | (** [spec_args] represents any additional parameters that the specification expects *) 17 | 18 | val spec_args: spec_args Cmdliner.Term.t 19 | 20 | val test_spec: count:int -> spec_args -> test_spec 21 | (** [test_spec ~initial_count ~count ~min ~max] constructs a test for data structure t *) 22 | 23 | val init: Domainslib.Task.pool -> test_spec -> t 24 | (** [init test_spec] constructs a new instance of the data structure from 25 | a given test. *) 26 | 27 | val run: Domainslib.Task.pool -> t -> test_spec -> unit 28 | (** [run pool t test] runs the test [test] on the data structure 29 | [t], using [pool] to schedule parallel tasks. *) 30 | 31 | val cleanup: t -> test_spec -> unit 32 | (** [cleanup t] will clean up any resources used by the data structure, performing consistency checks if needed *) 33 | 34 | end 35 | 36 | let benchmarks: (string, (module BENCHMARK)) Hashtbl.t = Hashtbl.create 32 37 | 38 | let () = 39 | Hashtbl.add benchmarks "rbtree-sequential" (module Rbtree.Sequential); 40 | Hashtbl.add benchmarks "rbtree-coarse-grained" (module Rbtree.CoarseGrained); 41 | Hashtbl.add benchmarks "rbtree-batched" (module Rbtree.Batched); 42 | Hashtbl.add benchmarks "rbtree-explicitly-batched" (module Rbtree.ExplicitlyBatched); 43 | 44 | Hashtbl.add benchmarks "avltree-sequential" (module Avltree.Sequential); 45 | Hashtbl.add benchmarks "avltree-coarse-grained" (module Avltree.CoarseGrained); 46 | Hashtbl.add benchmarks "avltree-batched" (module Avltree.Batched); 47 | Hashtbl.add benchmarks "avltree-explicitly-batched" (module Avltree.ExplicitlyBatched); 48 | 49 | Hashtbl.add benchmarks "treap-sequential" (module Treap.Sequential); 50 | Hashtbl.add benchmarks "treap-coarse-grained" (module Treap.CoarseGrained); 51 | Hashtbl.add benchmarks "treap-batched" (module Treap.Batched); 52 | Hashtbl.add benchmarks "treap-explicitly-batched" (module Treap.ExplicitlyBatched); 53 | 54 | Hashtbl.add benchmarks "btree-sequential" (module Btree.Sequential); 55 | Hashtbl.add benchmarks "btree-coarse-grained" (module Btree.CoarseGrained); 56 | Hashtbl.add benchmarks "btree-batched" (module Btree.Batched); 57 | Hashtbl.add benchmarks "btree-explicitly-batched" (module Btree.ExplicitlyBatched) 58 | 59 | 60 | 61 | let run_benchmark (type a) (module B: BENCHMARK with type spec_args = a) 62 | show_progress no_domains no_warmup no_iter count (args: a) = 63 | let num_domains = match no_domains with None -> Domain.recommended_domain_count () - 1 | Some d -> d - 1 in 64 | let pool = Domainslib.Task.setup_pool ~num_domains () in 65 | let test = B.test_spec ~count args in 66 | Domainslib.Task.run pool (fun () -> 67 | Timing.time ~show_progress ~no_warmup ~no_iter ~init:(fun () -> B.init pool test) ~cleanup:(fun t -> B.cleanup t test) 68 | (fun t -> 69 | B.run pool t test 70 | ) 71 | ) 72 | 73 | 74 | 75 | let () = 76 | let open Cmdliner in 77 | let info' = Cmd.info ~doc:"Run benchmarks and print result times." "bench.exe" in 78 | 79 | let show_progress = 80 | Arg.(value @@ flag @@ info ~doc:"Whether to show progress bars" ["S"; "show-progress"]) in 81 | let no_domains = 82 | Arg.(value @@ opt (some int) None @@ info ~doc:"Number of domains to use" ["D"; "no-domains"]) in 83 | let no_warmup = 84 | Arg.(value @@ opt int 10 @@ info ~doc:"Number of warmup iterations to run" ["w"; "no-warmup"]) in 85 | let no_iter = 86 | Arg.(required @@ opt (some int) None @@ info ~doc:"Number of iterations to run" ["i"; "no-iter"]) in 87 | let count = 88 | Arg.(required @@ opt (some int) None @@ info ~doc:"Number of operations to run" ["c"; "count"]) in 89 | 90 | let sub_cmds = 91 | Hashtbl.to_seq benchmarks 92 | |> Seq.map (fun (name, (module B: BENCHMARK)) -> 93 | let (b: (module BENCHMARK with type spec_args = B.spec_args)) = (module B) in 94 | let info = Cmd.info name in 95 | let action = 96 | Term.(const (run_benchmark b) 97 | $ show_progress $ no_domains $ no_warmup 98 | $ no_iter $ count $ B.spec_args) in 99 | Cmd.v info action 100 | ) 101 | |> List.of_seq in 102 | 103 | exit (Cmd.eval (Cmd.group info' sub_cmds)) 104 | -------------------------------------------------------------------------------- /benchmark/btree.ml: -------------------------------------------------------------------------------- 1 | module IntSet = Set.Make(Int) 2 | module IntBtree = Obatcher_ds.Btree.Make(Int) 3 | module BatchedIntBtree = Domainslib.Batcher.Make1(IntBtree) 4 | 5 | type generic_spec_args = { 6 | sorted: bool; 7 | no_searches: int; 8 | min: int; 9 | max: int; 10 | initial_count: int; 11 | should_validate: bool; 12 | search_threshold: int option; 13 | search_par_threshold: int option; 14 | insert_threshold: int option; 15 | branching_factor: int option; 16 | } 17 | 18 | type generic_test_spec = { 19 | args: generic_spec_args; 20 | count: int; 21 | mutable initial_elements: int array; 22 | mutable insert_elements: int array; 23 | mutable search_elements: int array; 24 | } 25 | 26 | 27 | let generic_spec_args: generic_spec_args Cmdliner.Term.t = 28 | let open Cmdliner in 29 | let sorted = Arg.(value @@ flag @@ info ~doc:"whether the inserts should be sorted" ["s"; "sorted"]) in 30 | let no_searches = 31 | Arg.(value @@ opt (some int) None @@ info ~doc:"number of searches" ~docv:"NO_SEARCHES" ["n"; "no-searches"]) in 32 | let initial_count = 33 | Arg.(value @@ opt (some int) None @@ info ~doc:"Initial number of operations" ["init-count"]) in 34 | let min = 35 | Arg.(value @@ opt (some int) None @@ info ~doc:"Minimum value of data for random inputs" ["min"]) in 36 | let max = 37 | Arg.(value @@ opt (some int) None @@ info ~doc:"Maximum value of data for random inputs" ["max"]) in 38 | let validate = 39 | Arg.(value @@ flag @@ info ~doc:"Whether the tests should validate the results of the benchmarks" ["T"]) in 40 | let search_threshold = 41 | Arg.(value @@ opt (some int) None @@ 42 | info ~doc:"Threshold upon which searches should be sequential" ["search-threshold"]) in 43 | let search_par_threshold = 44 | Arg.(value @@ opt (some int) None @@ 45 | info ~doc:"Threshold upon which searches should be done in parallel" ["search-par-threshold"]) in 46 | 47 | let insert_threshold = 48 | Arg.(value @@ opt (some int) None @@ 49 | info ~doc:"Threshold upon which searches should be sequential" ["insert-threshold"]) in 50 | let branching_factor = 51 | Arg.(value @@ opt (some int) None @@ 52 | info ~doc:"Branching factor of tree" ["branching-factor"]) in 53 | 54 | Term.(const (fun sorted no_searches min max 55 | initial_count validate search_threshold search_par_threshold insert_threshold 56 | branching_factor -> { 57 | sorted; 58 | no_searches=Option.value ~default:0 no_searches; 59 | initial_count=Option.value ~default:0 initial_count; 60 | min=Option.value ~default:0 min; 61 | max=Option.value ~default:((Int.shift_left 1 30) - 1) max; 62 | should_validate=validate; 63 | search_threshold; 64 | search_par_threshold; 65 | insert_threshold; 66 | branching_factor 67 | }) $ sorted $ no_searches $ min $ max $ initial_count $ 68 | validate $ search_threshold $ search_par_threshold $ insert_threshold $ branching_factor) 69 | 70 | let generic_test_spec ~count spec_args = 71 | { args=spec_args; count: int; insert_elements=[| |]; search_elements=[| |]; initial_elements=[| |] } 72 | 73 | let generic_run test_spec f = 74 | let old_search_threshold = !Obatcher_ds.Btree.btree_search_sequential_threshold in 75 | let old_search_par_threshold = !Obatcher_ds.Btree.btree_search_parallel_threshold in 76 | let old_insert_threshold = !Obatcher_ds.Btree.btree_search_sequential_threshold in 77 | let old_branching_factor = !Obatcher_ds.Btree.btree_max_children in 78 | Obatcher_ds.Btree.btree_search_sequential_threshold := test_spec.args.search_threshold; 79 | Obatcher_ds.Btree.btree_search_parallel_threshold := test_spec.args.search_par_threshold; 80 | Obatcher_ds.Btree.btree_insert_sequential_threshold := test_spec.args.insert_threshold; 81 | Option.iter (fun vl -> Obatcher_ds.Btree.btree_max_children := vl) 82 | test_spec.args.branching_factor; 83 | let res = f () in 84 | Obatcher_ds.Btree.btree_search_sequential_threshold := old_search_threshold; 85 | Obatcher_ds.Btree.btree_search_parallel_threshold := old_search_par_threshold; 86 | Obatcher_ds.Btree.btree_insert_sequential_threshold := old_insert_threshold; 87 | Obatcher_ds.Btree.btree_max_children := old_branching_factor; 88 | res 89 | 90 | let generic_init test_spec f = 91 | let min, max = test_spec.args.min, test_spec.args.max in 92 | let elements = Util.gen_random_unique_array ~min ~max (test_spec.args.initial_count + test_spec.count) in 93 | let initial_elements = Array.make test_spec.args.initial_count min in 94 | let insert_elements = Array.make test_spec.count min in 95 | let search_elements = Util.gen_random_unique_array ~min ~max test_spec.args.no_searches in 96 | Array.blit 97 | elements 0 98 | initial_elements 0 99 | test_spec.args.initial_count; 100 | Array.blit 101 | elements test_spec.args.initial_count 102 | insert_elements 0 103 | test_spec.count; 104 | if test_spec.args.sorted then 105 | Array.sort Int.compare insert_elements; 106 | test_spec.insert_elements <- insert_elements; 107 | test_spec.initial_elements <- initial_elements; 108 | test_spec.search_elements <- search_elements; 109 | generic_run test_spec @@ fun () -> f initial_elements 110 | 111 | 112 | module Sequential = struct 113 | 114 | type t = unit IntBtree.t 115 | 116 | type test_spec = generic_test_spec 117 | 118 | type spec_args = generic_spec_args 119 | 120 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 121 | 122 | let test_spec ~count spec_args = 123 | generic_test_spec ~count spec_args 124 | 125 | let init _pool test_spec = 126 | generic_init test_spec (fun initial_elements -> 127 | let tree = IntBtree.Sequential.init () in 128 | Array.iter (fun i -> IntBtree.Sequential.insert tree i ()) 129 | initial_elements; 130 | tree 131 | ) 132 | 133 | 134 | let run _pool t test_spec = 135 | generic_run test_spec @@ fun () -> 136 | Array.iter (fun i -> 137 | IntBtree.Sequential.insert t i () 138 | ) test_spec.insert_elements; 139 | Array.iter (fun i -> 140 | ignore @@ IntBtree.Sequential.search t i 141 | ) test_spec.search_elements 142 | 143 | let cleanup (t: t) (test_spec: test_spec) = 144 | if test_spec.args.should_validate then begin 145 | Array.iter (fun elt -> 146 | match IntBtree.Sequential.search t elt with 147 | | Some _ -> () 148 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 149 | ) test_spec.insert_elements 150 | end 151 | 152 | end 153 | 154 | 155 | module CoarseGrained = struct 156 | 157 | type t = {tree: unit IntBtree.t; mutex: Mutex.t} 158 | 159 | type test_spec = generic_test_spec 160 | 161 | type spec_args = generic_spec_args 162 | 163 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 164 | 165 | let test_spec ~count spec_args = 166 | generic_test_spec ~count spec_args 167 | 168 | let init _pool test_spec = 169 | generic_init test_spec (fun initial_elements -> 170 | let tree = IntBtree.Sequential.init () in 171 | Array.iter (fun i -> IntBtree.Sequential.insert tree i ()) 172 | initial_elements; 173 | let mutex = Mutex.create () in 174 | {tree;mutex} 175 | ) 176 | 177 | let run pool (t: t) test_spec = 178 | generic_run test_spec @@ fun () -> 179 | Domainslib.Task.parallel_for pool ~chunk_size:1 180 | ~start:0 ~finish:(Array.length test_spec.insert_elements + Array.length test_spec.search_elements - 1) 181 | ~body:(fun i -> 182 | Mutex.lock t.mutex; 183 | Fun.protect ~finally:(fun () -> Mutex.unlock t.mutex) (fun () -> 184 | if i < Array.length test_spec.insert_elements 185 | then IntBtree.Sequential.insert t.tree test_spec.insert_elements.(i) () 186 | else ignore (IntBtree.Sequential.search t.tree 187 | test_spec.search_elements.(i - Array.length test_spec.insert_elements)) 188 | ) 189 | ) 190 | 191 | let cleanup (t: t) (test_spec: test_spec) = 192 | if test_spec.args.should_validate then begin 193 | Array.iter (fun elt -> 194 | match IntBtree.Sequential.search t.tree elt with 195 | | Some _ -> () 196 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 197 | ) test_spec.insert_elements 198 | end 199 | 200 | end 201 | 202 | 203 | module Batched = struct 204 | 205 | type t = unit BatchedIntBtree.t 206 | 207 | type test_spec = generic_test_spec 208 | 209 | type spec_args = generic_spec_args 210 | 211 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 212 | 213 | let test_spec ~count spec_args = 214 | generic_test_spec ~count spec_args 215 | 216 | let init pool test_spec = 217 | generic_init test_spec (fun initial_elements -> 218 | let tree = BatchedIntBtree.init pool in 219 | Array.iter (fun i -> BatchedIntBtree.apply tree (Insert (i, ()))) 220 | initial_elements; 221 | tree) 222 | 223 | let run pool (tree: t) test_spec = 224 | generic_run test_spec @@ fun () -> 225 | Domainslib.Task.parallel_for pool ~chunk_size:1 226 | ~start:0 ~finish:(Array.length test_spec.insert_elements + Array.length test_spec.search_elements - 1) 227 | ~body:(fun i -> 228 | if i < Array.length test_spec.insert_elements 229 | then BatchedIntBtree.apply tree (Insert (test_spec.insert_elements.(i), ())) 230 | else 231 | ignore (BatchedIntBtree.apply tree (Search test_spec.search_elements.(i - Array.length test_spec.insert_elements))) 232 | ); 233 | BatchedIntBtree.wait_for_batch tree 234 | 235 | 236 | let cleanup (t: t) (test_spec: test_spec) = 237 | let t = BatchedIntBtree.unsafe_get_internal_data t in 238 | if test_spec.args.should_validate then begin 239 | if t.IntBtree.Sequential.root.no_elements <> Array.length test_spec.insert_elements + Array.length test_spec.initial_elements 240 | then Format.ksprintf failwith "Inserted %d elements, but found only %d in the tree" 241 | (Array.length test_spec.insert_elements + Array.length test_spec.initial_elements) 242 | t.IntBtree.Sequential.root.no_elements; 243 | let btree_flattened = IntBtree.flatten t.root |> Array.of_seq in 244 | let all_elements = Array.concat [test_spec.insert_elements; test_spec.initial_elements] in 245 | Array.sort Int.compare all_elements; 246 | if Array.length btree_flattened <> Array.length all_elements then 247 | Format.ksprintf failwith "length of flattened btree (%d) did not match inserts (%d) (no_elements=%d)" 248 | (Array.length btree_flattened) (Array.length all_elements) (t.root.no_elements); 249 | 250 | for i = 0 to Array.length btree_flattened - 1 do 251 | if fst btree_flattened.(i) <> all_elements.(i) then 252 | Format.ksprintf failwith "element %d of the btree was expected to be %d, but got %d" i 253 | all_elements.(i) (fst btree_flattened.(i)); 254 | done; 255 | 256 | Array.iter (fun elt -> 257 | match IntBtree.Sequential.search t elt with 258 | | Some _ -> () 259 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 260 | ) test_spec.insert_elements; 261 | end; 262 | 263 | end 264 | 265 | 266 | module ExplicitlyBatched = struct 267 | 268 | type t = unit IntBtree.t 269 | 270 | type test_spec = { 271 | spec: generic_test_spec; 272 | mutable sorted_insert_elements: (int * unit) array; 273 | mutable search_elements: (int * (unit option -> unit)) array; 274 | } 275 | 276 | type spec_args = generic_spec_args 277 | 278 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 279 | 280 | let test_spec ~count spec_args = 281 | let spec = generic_test_spec ~count spec_args in 282 | {spec; sorted_insert_elements=[||]; search_elements=[||]} 283 | 284 | let init _pool (test_spec: test_spec) = 285 | generic_init test_spec.spec (fun initial_elements -> 286 | let tree = IntBtree.Sequential.init () in 287 | test_spec.sorted_insert_elements <- Array.map (fun i -> (i, ())) test_spec.spec.insert_elements; 288 | test_spec.search_elements <- Array.map (fun i -> (i, (fun _ -> ()))) test_spec.spec.search_elements; 289 | Array.sort (fun (k1,_) (k2, _) -> Int.compare k1 k2) test_spec.sorted_insert_elements; 290 | Array.iter (fun i -> IntBtree.Sequential.insert tree i ()) 291 | initial_elements; 292 | tree) 293 | 294 | let run pool (tree: t) test_spec = 295 | generic_run test_spec.spec @@ fun () -> 296 | if Array.length test_spec.sorted_insert_elements > 0 then 297 | IntBtree.par_insert ~can_rebuild:false ~pool tree test_spec.sorted_insert_elements; 298 | if Array.length test_spec.spec.search_elements > 0 then 299 | ignore @@ IntBtree.par_search ~pool tree test_spec.search_elements 300 | 301 | let cleanup (t: t) (test: test_spec) = 302 | if test.spec.args.should_validate then begin 303 | if t.IntBtree.Sequential.root.no_elements <> Array.length test.spec.insert_elements + Array.length test.spec.initial_elements 304 | then Format.ksprintf failwith "Inserted %d elements, but found only %d in the tree" 305 | (Array.length test.spec.insert_elements + Array.length test.spec.initial_elements) 306 | t.IntBtree.Sequential.root.no_elements; 307 | let btree_flattened = IntBtree.flatten t.root |> Array.of_seq in 308 | let all_elements = Array.concat [test.spec.insert_elements; test.spec.initial_elements] in 309 | Array.sort Int.compare all_elements; 310 | if Array.length btree_flattened <> Array.length all_elements then 311 | Format.ksprintf failwith "length of flattened btree (%d) did not match inserts (%d) (no_elements=%d)" 312 | (Array.length btree_flattened) (Array.length all_elements) (t.root.no_elements); 313 | 314 | for i = 0 to Array.length btree_flattened - 1 do 315 | if fst btree_flattened.(i) <> all_elements.(i) then 316 | Format.ksprintf failwith "element %d of the btree was expected to be %d, but got %d" i 317 | all_elements.(i) (fst btree_flattened.(i)); 318 | done; 319 | 320 | Array.iter (fun elt -> 321 | match IntBtree.Sequential.search t elt with 322 | | Some _ -> () 323 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 324 | ) test.spec.insert_elements; 325 | end 326 | 327 | end 328 | 329 | -------------------------------------------------------------------------------- /benchmark/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name bench) 3 | (libraries 4 | ; command line parsing 5 | cmdliner 6 | ; timing 7 | ptime 8 | ptime.clock.os 9 | ; progress bars 10 | progress 11 | domainslib 12 | obatcher_ds) 13 | (modes native)) -------------------------------------------------------------------------------- /benchmark/rbtree.ml: -------------------------------------------------------------------------------- 1 | module IntRbtree = Obatcher_ds.Rbtree.Make(Int) 2 | module BatchedIntRbtree = Domainslib.Batcher.Make1(IntRbtree) 3 | 4 | type generic_spec_args = { 5 | sorted: bool; 6 | no_searches: int; 7 | min: int; 8 | max: int; 9 | initial_count: int; 10 | should_validate: bool; 11 | search_threshold: int option; 12 | insert_threshold: int option; 13 | } 14 | 15 | type generic_test_spec = { 16 | args: generic_spec_args; 17 | count: int; 18 | mutable initial_elements: int array; 19 | mutable insert_elements: int array; 20 | mutable search_elements: int array; 21 | } 22 | 23 | let generic_spec_args: generic_spec_args Cmdliner.Term.t = 24 | let open Cmdliner in 25 | let sorted = Arg.(value @@ flag @@ info ~doc:"whether the inserts should be sorted" ["s"; "sorted"]) in 26 | let no_searches = 27 | Arg.(value @@ opt (some int) None @@ info ~doc:"number of searches" ~docv:"NO_SEARCHES" ["n"; "no-searches"]) in 28 | let initial_count = 29 | Arg.(value @@ opt (some int) None @@ info ~doc:"Initial number of operations" ["init-count"]) in 30 | let min = 31 | Arg.(value @@ opt (some int) None @@ info ~doc:"Minimum value of data for random inputs" ["min"]) in 32 | let max = 33 | Arg.(value @@ opt (some int) None @@ info ~doc:"Maximum value of data for random inputs" ["max"]) in 34 | let validate = 35 | Arg.(value @@ flag @@ info ~doc:"Whether the tests should validate the results of the benchmarks" ["T"]) in 36 | let search_threshold = 37 | Arg.(value @@ opt (some int) None @@ 38 | info ~doc:"Threshold upon which searches should be sequential" ["search-threshold"]) in 39 | let insert_threshold = 40 | Arg.(value @@ opt (some int) None @@ 41 | info ~doc:"Threshold upon which inserts should be sequential" ["insert-threshold"]) in 42 | 43 | Term.(const (fun sorted no_searches min max 44 | initial_count validate search_threshold insert_threshold 45 | -> { 46 | sorted; 47 | no_searches=Option.value ~default:0 no_searches; 48 | initial_count=Option.value ~default:0 initial_count; 49 | min=Option.value ~default:0 min; 50 | max=Option.value ~default:((Int.shift_left 1 30) - 1) max; 51 | should_validate=validate; 52 | search_threshold; 53 | insert_threshold 54 | }) $ sorted $ no_searches $ min $ max $ initial_count $ 55 | validate $ search_threshold $ insert_threshold) 56 | 57 | let generic_test_spec ~count spec_args = 58 | { args=spec_args; count: int; insert_elements=[| |]; search_elements=[| |]; initial_elements=[| |] } 59 | 60 | let generic_run test_spec f = 61 | let old_search_threshold = !Obatcher_ds.Rbtree.rbtree_search_sequential_threshold in 62 | let old_insert_threshold = !Obatcher_ds.Rbtree.rbtree_search_sequential_threshold in 63 | (match test_spec.args.search_threshold with None -> () | Some st -> 64 | Obatcher_ds.Rbtree.rbtree_search_sequential_threshold := st); 65 | (match test_spec.args.insert_threshold with None -> () | Some it -> 66 | Obatcher_ds.Rbtree.rbtree_insert_sequential_threshold := it); 67 | let res = f () in 68 | Obatcher_ds.Rbtree.rbtree_search_sequential_threshold := old_search_threshold; 69 | Obatcher_ds.Rbtree.rbtree_insert_sequential_threshold := old_insert_threshold; 70 | res 71 | 72 | let generic_init test_spec f = 73 | let min, max = test_spec.args.min, test_spec.args.max in 74 | let elements = Util.gen_random_unique_array ~min ~max (test_spec.args.initial_count + test_spec.count) in 75 | let initial_elements = Array.make test_spec.args.initial_count min in 76 | let insert_elements = Array.make test_spec.count min in 77 | let search_elements = Util.gen_random_unique_array ~min ~max test_spec.args.no_searches in 78 | Array.blit 79 | elements 0 80 | initial_elements 0 81 | test_spec.args.initial_count; 82 | Array.blit 83 | elements test_spec.args.initial_count 84 | insert_elements 0 85 | test_spec.count; 86 | if test_spec.args.sorted then 87 | Array.sort Int.compare insert_elements; 88 | test_spec.insert_elements <- insert_elements; 89 | test_spec.initial_elements <- initial_elements; 90 | test_spec.search_elements <- search_elements; 91 | generic_run test_spec @@ fun () -> f initial_elements 92 | 93 | module Sequential = struct 94 | 95 | type t = unit IntRbtree.t 96 | 97 | type test_spec = generic_test_spec 98 | 99 | type spec_args = generic_spec_args 100 | 101 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 102 | 103 | let test_spec ~count spec_args = 104 | generic_test_spec ~count spec_args 105 | 106 | let init _pool test_spec = 107 | generic_init test_spec (fun initial_elements -> 108 | let tree = IntRbtree.Sequential.new_tree () in 109 | Array.iter (fun i -> IntRbtree.Sequential.insert i () tree) 110 | initial_elements; 111 | tree 112 | ) 113 | 114 | let run _pool t test_spec = 115 | generic_run test_spec @@ fun () -> 116 | Array.iter (fun i -> 117 | IntRbtree.Sequential.insert i () t 118 | ) test_spec.insert_elements; 119 | Array.iter (fun i -> 120 | ignore @@ IntRbtree.Sequential.search i t 121 | ) test_spec.search_elements 122 | 123 | (* let cleanup (t: t) (test_spec: test_spec) = () *) 124 | let cleanup (_: t) (_: test_spec) = () 125 | end 126 | 127 | module CoarseGrained = struct 128 | 129 | type t = {tree: unit IntRbtree.t; mutex: Mutex.t} 130 | 131 | type test_spec = generic_test_spec 132 | 133 | type spec_args = generic_spec_args 134 | 135 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 136 | 137 | let test_spec ~count spec_args = 138 | generic_test_spec ~count spec_args 139 | 140 | let init _pool test_spec = 141 | generic_init test_spec (fun initial_elements -> 142 | let tree = IntRbtree.Sequential.new_tree () in 143 | Array.iter (fun i -> IntRbtree.Sequential.insert i () tree) 144 | initial_elements; 145 | let mutex = Mutex.create () in 146 | {tree;mutex} 147 | ) 148 | 149 | let run pool (t: t) test_spec = 150 | generic_run test_spec @@ fun () -> 151 | Domainslib.Task.parallel_for pool ~chunk_size:1 152 | ~start:0 ~finish:(Array.length test_spec.insert_elements + Array.length test_spec.search_elements - 1) 153 | ~body:(fun i -> 154 | Mutex.lock t.mutex; 155 | Fun.protect ~finally:(fun () -> Mutex.unlock t.mutex) (fun () -> 156 | if i < Array.length test_spec.insert_elements 157 | then IntRbtree.Sequential.insert test_spec.insert_elements.(i) () t.tree 158 | else ignore (IntRbtree.Sequential.search 159 | test_spec.search_elements.(i - Array.length test_spec.insert_elements) t.tree) 160 | ) 161 | ) 162 | 163 | let cleanup (t: t) (test_spec: test_spec) = 164 | if test_spec.args.should_validate then begin 165 | Array.iter (fun elt -> 166 | match IntRbtree.Sequential.search elt t.tree with 167 | | Some _ -> () 168 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 169 | ) test_spec.insert_elements 170 | end 171 | 172 | end 173 | 174 | module Batched = struct 175 | 176 | type t = unit BatchedIntRbtree.t 177 | 178 | type test_spec = generic_test_spec 179 | 180 | type spec_args = generic_spec_args 181 | 182 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 183 | 184 | let test_spec ~count spec_args = 185 | generic_test_spec ~count spec_args 186 | 187 | let init pool test_spec = 188 | generic_init test_spec (fun initial_elements -> 189 | let tree = BatchedIntRbtree.init pool in 190 | Array.iter (fun i -> BatchedIntRbtree.apply tree (Insert (i, ()))) 191 | initial_elements; 192 | tree) 193 | 194 | let run pool (tree: t) test_spec = 195 | generic_run test_spec @@ fun () -> 196 | Domainslib.Task.parallel_for pool ~chunk_size:1 197 | ~start:0 ~finish:(Array.length test_spec.insert_elements + Array.length test_spec.search_elements - 1) 198 | ~body:(fun i -> 199 | if i < Array.length test_spec.insert_elements 200 | then BatchedIntRbtree.apply tree (Insert (test_spec.insert_elements.(i), ())) 201 | else 202 | ignore (BatchedIntRbtree.apply tree (Search test_spec.search_elements.(i - Array.length test_spec.insert_elements))) 203 | ); 204 | BatchedIntRbtree.wait_for_batch tree 205 | 206 | let cleanup (t: t) (test_spec: test_spec) = 207 | if test_spec.args.should_validate then begin 208 | let t = BatchedIntRbtree.unsafe_get_internal_data t in 209 | let num_nodes = IntRbtree.Sequential.num_nodes t in 210 | if num_nodes <> Array.length test_spec.insert_elements + Array.length test_spec.initial_elements 211 | then Format.ksprintf failwith "Inserted %d elements, but found only %d in the tree" 212 | (Array.length test_spec.insert_elements + Array.length test_spec.initial_elements) 213 | num_nodes; 214 | let btree_flattened = IntRbtree.Sequential.flatten t |> Array.of_list in 215 | let all_elements = Array.concat [test_spec.insert_elements; test_spec.initial_elements] in 216 | Array.sort Int.compare all_elements; 217 | if Array.length btree_flattened <> Array.length all_elements then 218 | Format.ksprintf failwith "length of flattened btree (%d) did not match inserts (%d) (no_elements=%d)" 219 | (Array.length btree_flattened) (Array.length all_elements) (num_nodes); 220 | 221 | for i = 0 to Array.length btree_flattened - 1 do 222 | if fst btree_flattened.(i) <> all_elements.(i) then 223 | Format.ksprintf failwith "element %d of the btree was expected to be %d, but got %d" i 224 | all_elements.(i) (fst btree_flattened.(i)); 225 | done; 226 | 227 | Array.iter (fun elt -> 228 | match IntRbtree.Sequential.search elt t with 229 | | Some _ -> () 230 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 231 | ) test_spec.insert_elements; 232 | end 233 | 234 | end 235 | 236 | module ExplicitlyBatched = struct 237 | 238 | type t = unit IntRbtree.t 239 | 240 | type test_spec = { 241 | spec: generic_test_spec; 242 | mutable insert_elements: (int * unit) array; 243 | mutable search_elements: (int * (unit option -> unit)) array; 244 | } 245 | 246 | type spec_args = generic_spec_args 247 | 248 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 249 | 250 | let test_spec ~count spec_args = 251 | let spec = generic_test_spec ~count spec_args in 252 | {spec; insert_elements=[||]; search_elements=[||]} 253 | 254 | let init _pool (test_spec: test_spec) = 255 | generic_init test_spec.spec (fun initial_elements -> 256 | test_spec.insert_elements <- Array.map (fun i -> (i, ())) test_spec.spec.insert_elements; 257 | test_spec.search_elements <- Array.map (fun i -> (i, (fun _ -> ()))) test_spec.spec.search_elements; 258 | let tree = IntRbtree.Sequential.new_tree () in 259 | Array.iter (fun i -> IntRbtree.Sequential.insert i () tree) 260 | initial_elements; 261 | tree) 262 | 263 | let run pool (tree: t) test_spec = 264 | generic_run test_spec.spec @@ fun () -> 265 | if Array.length test_spec.insert_elements > 0 then 266 | IntRbtree.par_insert ~pool tree test_spec.insert_elements; 267 | if Array.length test_spec.spec.search_elements > 0 then 268 | ignore @@ IntRbtree.par_search ~pool tree test_spec.search_elements 269 | 270 | 271 | let cleanup (t: t) (test_spec: test_spec) = 272 | if test_spec.spec.args.should_validate then begin 273 | let num_nodes = IntRbtree.Sequential.num_nodes t in 274 | if num_nodes <> Array.length test_spec.insert_elements + Array.length test_spec.spec.initial_elements 275 | then Format.ksprintf failwith "Inserted %d elements, but found only %d in the tree" 276 | (Array.length test_spec.insert_elements + Array.length test_spec.spec.initial_elements) 277 | num_nodes; 278 | let btree_flattened = IntRbtree.Sequential.flatten t |> Array.of_list in 279 | let all_elements = Array.concat [test_spec.spec.insert_elements; test_spec.spec.initial_elements] in 280 | Array.sort Int.compare all_elements; 281 | if Array.length btree_flattened <> Array.length all_elements then 282 | Format.ksprintf failwith "length of flattened btree (%d) did not match inserts (%d) (no_elements=%d)" 283 | (Array.length btree_flattened) (Array.length all_elements) (num_nodes); 284 | 285 | for i = 0 to Array.length btree_flattened - 1 do 286 | if fst btree_flattened.(i) <> all_elements.(i) then 287 | Format.ksprintf failwith "element %d of the btree was expected to be %d, but got %d" i 288 | all_elements.(i) (fst btree_flattened.(i)); 289 | done; 290 | 291 | Array.iter (fun elt -> 292 | match IntRbtree.Sequential.search elt t with 293 | | Some _ -> () 294 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 295 | ) test_spec.spec.insert_elements; 296 | end 297 | 298 | end -------------------------------------------------------------------------------- /benchmark/timing.ml: -------------------------------------------------------------------------------- 1 | 2 | let progress_bar ~total = 3 | let open Progress.Line in 4 | list [spinner (); bar ~width:(`Expand) total; count_to total] 5 | 6 | let step ?(show_progress=false) ~name ~total f = 7 | if show_progress then begin 8 | Format.printf "Running %s\n%!" name; 9 | Progress.with_reporter (progress_bar ~total:total) f 10 | end else f (fun _ -> ()) 11 | 12 | 13 | let time ?show_progress ?(cleanup=fun _ -> ()) ~no_warmup ~no_iter ~init f = 14 | 15 | step ?show_progress ~name:"warmup" ~total:no_warmup (fun prog -> 16 | for _ = 1 to no_warmup do let state = init () in f state; prog 1 done; 17 | ); 18 | 19 | let sum = ref 0. in 20 | let sum_sq = ref 0. in 21 | 22 | let count = ref 0. in 23 | let mean = ref 0. in 24 | let m2 = ref 0. in 25 | 26 | 27 | step ?show_progress ~name:"benchmark" ~total:no_iter (fun prog -> 28 | for _ = 1 to no_iter do 29 | 30 | let state = init () in 31 | 32 | let start_time = Ptime_clock.now () in 33 | f state; 34 | let end_time = Ptime_clock.now () in 35 | let time = Ptime.Span.to_float_s (Ptime.diff end_time start_time) in 36 | 37 | cleanup state; 38 | 39 | sum := !sum +. time; 40 | sum_sq := !sum_sq +. (time *. time); 41 | 42 | (* walford's algorithm *) 43 | count := !count +. 1.; 44 | let delta = time -. !mean in 45 | mean := !mean +. (delta /. !count); 46 | let delta2 = time -. !mean in 47 | m2 := !m2 +. delta *. delta2; 48 | 49 | prog 1 50 | done 51 | ); 52 | 53 | let var = (!sum_sq -. (!sum *. !sum)/.(Float.of_int no_iter)) /. (Float.of_int (no_iter - 1)) in 54 | let sd = Float.sqrt var in 55 | 56 | let mean, _variance, sample_variance = !mean, !m2 /. !count, !m2 /. (!count -. 1.0) in 57 | let sample_sd = Float.sqrt sample_variance in 58 | 59 | let avg_time = !sum /. Float.of_int no_iter in 60 | 61 | if !count <= 2.0 62 | then Format.printf "%.5fs ± %.5fs\n%!" avg_time sd 63 | else Format.printf "%.5fs ± %.5fs\n%!" mean sample_sd; 64 | 65 | -------------------------------------------------------------------------------- /benchmark/treap.ml: -------------------------------------------------------------------------------- 1 | module IntTreap = Obatcher_ds.Avltree.Make(Int) 2 | module BatchedIntTreap = Domainslib.Batcher.Make1(IntTreap) 3 | 4 | type generic_spec_args = { 5 | sorted: bool; 6 | no_searches: int; 7 | min: int; 8 | max: int; 9 | initial_count: int; 10 | should_validate: bool; 11 | search_threshold: int option; 12 | insert_threshold: int option; 13 | search_type: int option; 14 | insert_type: int option; 15 | } 16 | 17 | type generic_test_spec = { 18 | args: generic_spec_args; 19 | count: int; 20 | mutable initial_elements: int array; 21 | mutable insert_elements: int array; 22 | mutable search_elements: int array; 23 | } 24 | 25 | let generic_spec_args: generic_spec_args Cmdliner.Term.t = 26 | let open Cmdliner in 27 | let sorted = Arg.(value @@ flag @@ info ~doc:"whether the inserts should be sorted" ["s"; "sorted"]) in 28 | let no_searches = 29 | Arg.(value @@ opt (some int) None @@ info ~doc:"number of searches" ~docv:"NO_SEARCHES" ["n"; "no-searches"]) in 30 | let initial_count = 31 | Arg.(value @@ opt (some int) None @@ info ~doc:"Initial number of operations" ["init-count"]) in 32 | let min = 33 | Arg.(value @@ opt (some int) None @@ info ~doc:"Minimum value of data for random inputs" ["min"]) in 34 | let max = 35 | Arg.(value @@ opt (some int) None @@ info ~doc:"Maximum value of data for random inputs" ["max"]) in 36 | let validate = 37 | Arg.(value @@ flag @@ info ~doc:"Whether the tests should validate the results of the benchmarks" ["T"]) in 38 | let search_threshold = 39 | Arg.(value @@ opt (some int) None @@ 40 | info ~doc:"Threshold upon which searches should be sequential" ["search-threshold"]) in 41 | let insert_threshold = 42 | Arg.(value @@ opt (some int) None @@ 43 | info ~doc:"Threshold upon which inserts should be sequential" ["insert-threshold"]) in 44 | let insert_type = 45 | Arg.(value @@ opt (some int) None @@ info ~doc:"Which parallel insert to use" ["insert-type"]) in 46 | let search_type = 47 | Arg.(value @@ opt (some int) None @@ info ~doc:"Which parallel search to use" ["search-type"]) in 48 | 49 | Term.(const (fun sorted no_searches min max 50 | initial_count validate search_threshold insert_threshold search_type insert_type 51 | -> { 52 | sorted; 53 | no_searches=Option.value ~default:0 no_searches; 54 | initial_count=Option.value ~default:0 initial_count; 55 | min=Option.value ~default:0 min; 56 | max=Option.value ~default:((Int.shift_left 1 30) - 1) max; 57 | should_validate=validate; 58 | search_threshold; 59 | insert_threshold; 60 | search_type; 61 | insert_type; 62 | }) $ sorted $ no_searches $ min $ max $ initial_count $ 63 | validate $ search_threshold $ insert_threshold $ search_type $ insert_type) 64 | 65 | let generic_test_spec ~count spec_args = 66 | { args=spec_args; count: int; insert_elements=[| |]; search_elements=[| |]; initial_elements=[| |] } 67 | 68 | let generic_run test_spec f = 69 | let old_search_threshold = !Obatcher_ds.Avltree.avltree_search_sequential_threshold in 70 | let old_insert_threshold = !Obatcher_ds.Avltree.avltree_search_sequential_threshold in 71 | let old_search_type = !Obatcher_ds.Avltree.avltree_search_type in 72 | let old_insert_type = !Obatcher_ds.Avltree.avltree_insert_type in 73 | (match test_spec.args.search_threshold with None -> () | Some st -> 74 | Obatcher_ds.Avltree.avltree_search_sequential_threshold := st); 75 | (match test_spec.args.insert_threshold with None -> () | Some it -> 76 | Obatcher_ds.Avltree.avltree_insert_sequential_threshold := it); 77 | (match test_spec.args.search_type with None -> () | Some it -> 78 | Obatcher_ds.Avltree.avltree_search_type := it); 79 | (match test_spec.args.insert_type with None -> () | Some it -> 80 | Obatcher_ds.Avltree.avltree_insert_type := it); 81 | let res = f () in 82 | Obatcher_ds.Avltree.avltree_search_sequential_threshold := old_search_threshold; 83 | Obatcher_ds.Avltree.avltree_insert_sequential_threshold := old_insert_threshold; 84 | Obatcher_ds.Avltree.avltree_search_type := old_search_type; 85 | Obatcher_ds.Avltree.avltree_insert_type := old_insert_type; 86 | res 87 | 88 | let generic_init test_spec f = 89 | let min, max = test_spec.args.min, test_spec.args.max in 90 | let elements = Util.gen_random_unique_array ~min ~max (test_spec.args.initial_count + test_spec.count) in 91 | let initial_elements = Array.make test_spec.args.initial_count min in 92 | let insert_elements = Array.make test_spec.count min in 93 | let search_elements = Util.gen_random_unique_array ~min ~max test_spec.args.no_searches in 94 | Array.blit 95 | elements 0 96 | initial_elements 0 97 | test_spec.args.initial_count; 98 | Array.blit 99 | elements test_spec.args.initial_count 100 | insert_elements 0 101 | test_spec.count; 102 | if test_spec.args.sorted then 103 | Array.sort Int.compare insert_elements; 104 | test_spec.insert_elements <- insert_elements; 105 | test_spec.initial_elements <- initial_elements; 106 | test_spec.search_elements <- search_elements; 107 | generic_run test_spec @@ fun () -> f initial_elements 108 | 109 | module Sequential = struct 110 | 111 | type t = unit IntTreap.t 112 | 113 | type test_spec = generic_test_spec 114 | 115 | type spec_args = generic_spec_args 116 | 117 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 118 | 119 | let test_spec ~count spec_args = 120 | generic_test_spec ~count spec_args 121 | 122 | let init _pool test_spec = 123 | generic_init test_spec (fun initial_elements -> 124 | let tree = IntTreap.Sequential.new_tree () in 125 | Array.iter (fun i -> IntTreap.Sequential.insert i () tree) 126 | initial_elements; 127 | tree 128 | ) 129 | 130 | let run _pool t test_spec = 131 | generic_run test_spec @@ fun () -> 132 | Array.iter (fun i -> 133 | IntTreap.Sequential.insert i () t 134 | ) test_spec.insert_elements; 135 | Array.iter (fun i -> 136 | ignore @@ IntTreap.Sequential.search i t 137 | ) test_spec.search_elements 138 | 139 | let cleanup (t: t) (test_spec: test_spec) = 140 | if test_spec.args.should_validate then begin 141 | Array.iter (fun elt -> 142 | match IntTreap.Sequential.search elt t with 143 | | Some _ -> () 144 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 145 | ) test_spec.insert_elements; 146 | end 147 | end 148 | 149 | module CoarseGrained = struct 150 | 151 | type t = {tree: unit IntTreap.t; mutex: Mutex.t} 152 | 153 | type test_spec = generic_test_spec 154 | 155 | type spec_args = generic_spec_args 156 | 157 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 158 | 159 | let test_spec ~count spec_args = 160 | generic_test_spec ~count spec_args 161 | 162 | let init _pool test_spec = 163 | generic_init test_spec (fun initial_elements -> 164 | let tree = IntTreap.Sequential.new_tree () in 165 | Array.iter (fun i -> IntTreap.Sequential.insert i () tree) 166 | initial_elements; 167 | let mutex = Mutex.create () in 168 | {tree;mutex} 169 | ) 170 | 171 | let run pool (t: t) test_spec = 172 | generic_run test_spec @@ fun () -> 173 | Domainslib.Task.parallel_for pool ~chunk_size:1 174 | ~start:0 ~finish:(Array.length test_spec.insert_elements + Array.length test_spec.search_elements - 1) 175 | ~body:(fun i -> 176 | Mutex.lock t.mutex; 177 | Fun.protect ~finally:(fun () -> Mutex.unlock t.mutex) (fun () -> 178 | if i < Array.length test_spec.insert_elements 179 | then IntTreap.Sequential.insert test_spec.insert_elements.(i) () t.tree 180 | else ignore (IntTreap.Sequential.search 181 | test_spec.search_elements.(i - Array.length test_spec.insert_elements) t.tree) 182 | ) 183 | ) 184 | 185 | let cleanup (t: t) (test_spec: test_spec) = 186 | if test_spec.args.should_validate then begin 187 | Array.iter (fun elt -> 188 | match IntTreap.Sequential.search elt t.tree with 189 | | Some _ -> () 190 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 191 | ) test_spec.insert_elements 192 | end 193 | 194 | end 195 | 196 | module Batched = struct 197 | 198 | type t = unit BatchedIntTreap.t 199 | 200 | type test_spec = generic_test_spec 201 | 202 | type spec_args = generic_spec_args 203 | 204 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 205 | 206 | let test_spec ~count spec_args = 207 | generic_test_spec ~count spec_args 208 | 209 | let init pool test_spec = 210 | generic_init test_spec (fun initial_elements -> 211 | let tree = BatchedIntTreap.init pool in 212 | Array.iter (fun i -> BatchedIntTreap.apply tree (Insert (i, ()))) 213 | initial_elements; 214 | tree) 215 | 216 | let run pool (tree: t) test_spec = 217 | generic_run test_spec @@ fun () -> 218 | Domainslib.Task.parallel_for pool ~chunk_size:1 219 | ~start:0 ~finish:(Array.length test_spec.insert_elements + Array.length test_spec.search_elements - 1) 220 | ~body:(fun i -> 221 | if i < Array.length test_spec.insert_elements 222 | then BatchedIntTreap.apply tree (Insert (test_spec.insert_elements.(i), ())) 223 | else 224 | ignore (BatchedIntTreap.apply tree (Search test_spec.search_elements.(i - Array.length test_spec.insert_elements))) 225 | ); 226 | BatchedIntTreap.wait_for_batch tree 227 | 228 | let cleanup (t: t) (test_spec: test_spec) = 229 | if test_spec.args.should_validate then begin 230 | let t = BatchedIntTreap.unsafe_get_internal_data t in 231 | let num_nodes = IntTreap.Sequential.num_nodes t in 232 | if num_nodes <> Array.length test_spec.insert_elements + Array.length test_spec.initial_elements 233 | then Format.ksprintf failwith "Inserted %d elements, but found only %d in the tree" 234 | (Array.length test_spec.insert_elements + Array.length test_spec.initial_elements) 235 | num_nodes; 236 | let btree_flattened = IntTreap.Sequential.flatten t |> Array.of_list in 237 | let all_elements = Array.concat [test_spec.insert_elements; test_spec.initial_elements] in 238 | Array.sort Int.compare all_elements; 239 | if Array.length btree_flattened <> Array.length all_elements then 240 | Format.ksprintf failwith "length of flattened btree (%d) did not match inserts (%d) (no_elements=%d)" 241 | (Array.length btree_flattened) (Array.length all_elements) (num_nodes); 242 | 243 | for i = 0 to Array.length btree_flattened - 1 do 244 | if fst btree_flattened.(i) <> all_elements.(i) then 245 | Format.ksprintf failwith "element %d of the btree was expected to be %d, but got %d" i 246 | all_elements.(i) (fst btree_flattened.(i)); 247 | done; 248 | 249 | Array.iter (fun elt -> 250 | match IntTreap.Sequential.search elt t with 251 | | Some _ -> () 252 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 253 | ) test_spec.insert_elements; 254 | end 255 | 256 | end 257 | 258 | module ExplicitlyBatched = struct 259 | 260 | type t = unit IntTreap.t 261 | 262 | type test_spec = { 263 | spec: generic_test_spec; 264 | mutable insert_elements: (int * unit) array; 265 | mutable search_elements: (int * (unit option -> unit)) array; 266 | } 267 | 268 | type spec_args = generic_spec_args 269 | 270 | let spec_args: spec_args Cmdliner.Term.t = generic_spec_args 271 | 272 | let test_spec ~count spec_args = 273 | let spec = generic_test_spec ~count spec_args in 274 | {spec; insert_elements=[||]; search_elements=[||]} 275 | 276 | let init _pool (test_spec: test_spec) = 277 | generic_init test_spec.spec (fun initial_elements -> 278 | test_spec.insert_elements <- Array.map (fun i -> (i, ())) test_spec.spec.insert_elements; 279 | test_spec.search_elements <- Array.map (fun i -> (i, (fun _ -> ()))) test_spec.spec.search_elements; 280 | let tree = IntTreap.Sequential.new_tree () in 281 | Array.iter (fun i -> IntTreap.Sequential.insert i () tree) 282 | initial_elements; 283 | tree) 284 | 285 | let run pool (tree: t) test_spec = 286 | generic_run test_spec.spec @@ fun () -> 287 | if Array.length test_spec.insert_elements > 0 then 288 | IntTreap.par_insert ~pool tree test_spec.insert_elements; 289 | if Array.length test_spec.spec.search_elements > 0 then 290 | ignore @@ IntTreap.par_search ~pool tree test_spec.search_elements 291 | 292 | 293 | let cleanup (t: t) (test_spec: test_spec) = 294 | if test_spec.spec.args.should_validate then begin 295 | let num_nodes = IntTreap.Sequential.num_nodes t in 296 | if num_nodes <> Array.length test_spec.insert_elements + Array.length test_spec.spec.initial_elements 297 | then Format.ksprintf failwith "Inserted %d elements, but found only %d in the tree" 298 | (Array.length test_spec.insert_elements + Array.length test_spec.spec.initial_elements) 299 | num_nodes; 300 | let btree_flattened = IntTreap.Sequential.flatten t |> Array.of_list in 301 | let all_elements = Array.concat [test_spec.spec.insert_elements; test_spec.spec.initial_elements] in 302 | Array.sort Int.compare all_elements; 303 | if Array.length btree_flattened <> Array.length all_elements then 304 | Format.ksprintf failwith "length of flattened btree (%d) did not match inserts (%d) (no_elements=%d)" 305 | (Array.length btree_flattened) (Array.length all_elements) (num_nodes); 306 | 307 | for i = 0 to Array.length btree_flattened - 1 do 308 | if fst btree_flattened.(i) <> all_elements.(i) then 309 | Format.ksprintf failwith "element %d of the btree was expected to be %d, but got %d" i 310 | all_elements.(i) (fst btree_flattened.(i)); 311 | done; 312 | 313 | Array.iter (fun elt -> 314 | match IntTreap.Sequential.search elt t with 315 | | Some _ -> () 316 | | None -> Format.ksprintf failwith "Could not find inserted element %d in tree" elt 317 | ) test_spec.spec.insert_elements; 318 | end 319 | 320 | end 321 | -------------------------------------------------------------------------------- /benchmark/util.ml: -------------------------------------------------------------------------------- 1 | module IntSet = Set.Make(Int) 2 | 3 | let max_rdm_int = (Int.shift_left 1 30) - 1 4 | let gen_random_unique_array ~min ~max count = 5 | match () with 6 | | _ when max - min < count -> failwith "if min < 0 then failwith " 7 | | _ when min < 0 -> failwith "min cannot be less than 0" 8 | | _ when max > max_rdm_int -> 9 | let s = Format.sprintf "max cannot be greater than %d" max_rdm_int in failwith s 10 | | _ -> 11 | let seen_ints = ref IntSet.empty in 12 | let rec fresh_int s = 13 | let vl = min + Random.int (max - min) in 14 | if IntSet.mem vl !seen_ints 15 | then fresh_int s 16 | else (seen_ints := IntSet.add vl !seen_ints; vl) in 17 | Array.init count fresh_int 18 | 19 | let gen_random_array ~min ~max count = 20 | match () with 21 | | _ when max - min < count -> failwith "if min < 0 then failwith " 22 | | _ when min < 0 -> failwith "min cannot be less than 0" 23 | | _ when max > max_rdm_int -> 24 | let s = Format.sprintf "max cannot be greater than %d" max_rdm_int in failwith s 25 | | _ -> (); 26 | Array.init count (fun _ -> Random.int max_rdm_int) 27 | -------------------------------------------------------------------------------- /benchmark/utils.py: -------------------------------------------------------------------------------- 1 | import subprocess 2 | import matplotlib.pyplot as plt 3 | from tqdm.notebook import tqdm 4 | import csv 5 | 6 | 7 | def run_process(name, no_iters=5, count=1_000_000, 8 | domains=16, 9 | no_warmup=None, 10 | validate=False, 11 | verbose=False, 12 | init_count=None, 13 | sorted=None, 14 | no_searches=None, 15 | search_threshold=None, 16 | search_par_threshold=None, 17 | insert_threshold=None, 18 | branching_factor=None, 19 | graph_nodes=None, 20 | expensive_searches=None 21 | ): 22 | name_args = name.split(" ") 23 | cmd = ["../_build/default/benchmark/bench.exe", *name_args, "-D", str(domains), 24 | "--no-iter", str(no_iters), "--count", str(count)] 25 | if validate: 26 | cmd += ["-T"] 27 | if init_count: 28 | cmd += ["--init-count", str(init_count)] 29 | if sorted: 30 | cmd += ["-s"] 31 | if no_searches: 32 | cmd += ["--no-searches", str(no_searches)] 33 | if search_threshold: 34 | cmd += ["--search-threshold", str(search_threshold)] 35 | if search_par_threshold: 36 | cmd += ["--search-par-threshold", str(search_par_threshold)] 37 | if insert_threshold: 38 | cmd += ["--insert-threshold", str(insert_threshold)] 39 | if branching_factor: 40 | cmd += ["--branching-factor", str(branching_factor)] 41 | if graph_nodes: 42 | cmd += ["--graph-nodes", str(graph_nodes)] 43 | if expensive_searches: 44 | cmd += ["--expensive-searches"] 45 | if no_warmup: 46 | cmd += ["--no-warmup", str(int(no_warmup))] 47 | 48 | result = subprocess.run(cmd, capture_output=True, check=True) 49 | stdout = result.stdout.decode("utf-8").splitlines() 50 | for output in stdout[:-1]: 51 | print(output) 52 | [time, _, var] = stdout[-1].split() 53 | time = time.removesuffix("s").strip() 54 | var = var.removesuffix("s").strip() 55 | if verbose: 56 | print(f"time for {name} with {count} inserts was {time} +- {var}") 57 | return float(time), float(var) 58 | 59 | 60 | def run_test(op, args): 61 | if isinstance(op, str): 62 | res = run_process(op, **args) 63 | elif isinstance(op, dict): 64 | op_args = {key: op[key] 65 | for key in op if key not in {'name', 'label', 'title'}} 66 | res = run_process(op['name'], **op_args, **args) 67 | else: 68 | raise ValueError(f'Invalid operation {op}') 69 | return res 70 | 71 | 72 | def test_name(op): 73 | if isinstance(op, str): 74 | return op 75 | elif isinstance(op, dict) and 'title' in op: 76 | return op['title'] 77 | else: 78 | raise ValueError(f'Invalid operation {op}') 79 | 80 | 81 | def test_label(op): 82 | if isinstance(op, str): 83 | return op 84 | elif isinstance(op, dict) and 'label' in op: 85 | return op['label'] 86 | else: 87 | raise ValueError(f'Invalid operation {op}') 88 | 89 | 90 | def build_results(data_structures, args, param='domains', values=None): 91 | results = [] 92 | if not values: 93 | values = range(1, 9) 94 | no_searches = args.get('no_searches', 0) 95 | count = args.get('count', 0) 96 | workload_size = float(no_searches + count) 97 | for i in tqdm(values): 98 | result = {param: i} 99 | for data_structure in data_structures: 100 | time, sd = run_test(data_structure, {param: i, **args}) 101 | name = test_label(data_structure) 102 | result[name] = time 103 | result[name + "-throughput"] = workload_size / float(time) 104 | result[name + "-sd"] = sd 105 | results.append(result) 106 | return results 107 | 108 | 109 | def build_results_seq_opt(data_structures, args, sequential=None, 110 | param='domains', values=None): 111 | results = [] 112 | if not values: 113 | values = range(1, 9) 114 | no_searches = args.get('no_searches', 0) 115 | count = args.get('count', 0) 116 | workload_size = float(no_searches + count) 117 | if sequential: 118 | seq_time, _ = run_test(sequential, {param: 1, **args}) 119 | seq_throughput = workload_size / float(seq_time) 120 | seq_name = test_label(sequential) 121 | for i in tqdm(values): 122 | result = {param: i} 123 | if sequential: 124 | result[seq_name] = seq_time 125 | result[seq_name + "-throughput"] = seq_throughput 126 | result[seq_name + "-sd"] = 0 127 | for data_structure in data_structures: 128 | time, sd = run_test(data_structure, {param: i, **args}) 129 | name = test_label(data_structure) 130 | result[name] = time 131 | result[name + "-throughput"] = workload_size / float(time) 132 | result[name + "-sd"] = sd 133 | results.append(result) 134 | return results 135 | 136 | 137 | def plot_results(param, data_structures, results, title=None, xlabel=None): 138 | if not title: 139 | title = f"Comparison of {param} values on data structure" 140 | if not xlabel: 141 | xlabel = param 142 | param_values = [data[param] for data in results] 143 | _ = plt.figure(figsize=(12, 8), dpi=100, facecolor='w', edgecolor='k') 144 | for data_structure in data_structures: 145 | label = test_label(data_structure) 146 | name = test_name(data_structure) 147 | values = [data[label] for data in results] 148 | err = [data[label + "-sd"] for data in results] 149 | plt.errorbar(param_values, values, yerr=err, label=name) 150 | plt.title(title) 151 | plt.xlabel(xlabel) 152 | plt.ylabel('Time (s)') 153 | plt.legend() 154 | plt.show() 155 | 156 | 157 | def plot_throughput_results(param, data_structures, results, 158 | title=None, xlabel=None): 159 | if not title: 160 | title = f"Comparison of {param} values on data structure" 161 | if not xlabel: 162 | xlabel = param 163 | param_values = [data[param] for data in results] 164 | _ = plt.figure(figsize=(12, 8), dpi=100, facecolor='w', edgecolor='k') 165 | for data_structure in data_structures: 166 | label = test_label(data_structure) 167 | name = test_name(data_structure) 168 | values = [data[label + "-throughput"] for data in results] 169 | plt.errorbar(param_values, values, label=name) 170 | plt.title(title) 171 | plt.xlabel(xlabel) 172 | plt.ylabel('Throughput (ops/sec)') 173 | plt.legend() 174 | plt.show() 175 | 176 | 177 | def interactive_plot(): 178 | fig = plt.figure(figsize=(8, 6), dpi=100, facecolor='w', edgecolor='k') 179 | ax = fig.add_subplot(111) 180 | plt.ion() 181 | return fig, ax 182 | 183 | 184 | def build_interactive_plot(fig, ax, data_structures, params={}, title=None, 185 | xlabel=None, param=None, values=None): 186 | if not param: 187 | param = 'domains' 188 | if not values: 189 | values = range(1, 9) 190 | if not title: 191 | title = f"Comparison on value of {param} on data structure" 192 | if not xlabel: 193 | xlabel = param 194 | 195 | no_searches = params.get('no_searches', 0) 196 | count = params.get('count', 0) 197 | workload_size = float(no_searches + count) 198 | 199 | times = [] 200 | results = [] 201 | for i in values: 202 | result = {param: i} 203 | times.append(i) 204 | results.append(result) 205 | for data_structure in data_structures: 206 | t, var = run_test(data_structure, {param: i, **params}) 207 | label = test_label(data_structure) 208 | result[label] = t 209 | result[label+'-throughput'] = workload_size/t 210 | result[label+'-sd'] = var 211 | 212 | ax.clear() 213 | ax.set_title(title) 214 | ax.set_xlabel(xlabel) 215 | ax.set_ylabel('Time (s)') 216 | for data_structure in data_structures: 217 | label = test_label(data_structure) 218 | name = test_name(data_structure) 219 | available_values =\ 220 | [data[label] for data in results if label in data] 221 | available_var = [ 222 | data[label+'-sd'] 223 | for data in results if (label + '-sd') in data] 224 | available_times = times[:len(available_values)] 225 | ax.errorbar(available_times, available_values, 226 | yerr=available_var, label=name) 227 | ax.legend() 228 | fig.canvas.draw() 229 | return times, results 230 | 231 | 232 | def dump_results_to_csv(results, file_name): 233 | with open(f'{file_name}.csv', 'w', newline='') as f: 234 | fieldnames = list(results[0].keys()) 235 | writer = csv.DictWriter(f, fieldnames=fieldnames) 236 | writer.writeheader() 237 | sequential_key = None 238 | sequential_value = None 239 | 240 | sequential_throughput_key = None 241 | sequential_throughput_value = None 242 | 243 | sequential_sd_key = None 244 | sequential_sd_value = None 245 | 246 | for field in fieldnames: 247 | if field.endswith("sequential"): 248 | sequential_key = field 249 | break 250 | if field.endswith("sequential-throughput"): 251 | sequential_throughput_key = field 252 | break 253 | if field.endswith("sequential-sd"): 254 | sequential_sd_key = field 255 | break 256 | 257 | for row in results: 258 | row = row.copy() 259 | if sequential_key: 260 | if not sequential_value: 261 | sequential_value = row[sequential_key] 262 | row[sequential_key] = sequential_value 263 | if sequential_throughput_key: 264 | if not sequential_throughput_value: 265 | sequential_throughput_value =\ 266 | row[sequential_throughput_key] 267 | row[sequential_throughput_key] = sequential_throughput_value 268 | if sequential_sd_key: 269 | if not sequential_sd_value: 270 | sequential_sd_value = row[sequential_sd_key] 271 | row[sequential_sd_key] = sequential_sd_value 272 | 273 | writer.writerow(row) 274 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.10) 2 | 3 | (name obatcher_ds) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github username/reponame)) 9 | 10 | (authors "Author Name") 11 | 12 | (maintainers "Maintainer Name") 13 | 14 | (license LICENSE) 15 | 16 | (documentation https://url/to/documentation) 17 | 18 | (package 19 | (name obatcher_ds) 20 | (synopsis "A short synopsis") 21 | (description "A longer description") 22 | (depends ocaml dune domainslib) 23 | (tags 24 | (topics "to describe" your project))) 25 | 26 | ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project 27 | -------------------------------------------------------------------------------- /lib/avltree.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-32-26"] 2 | let avltree_insert_sequential_threshold = ref 1000 3 | let avltree_insert_height_threshold = ref 1 4 | let avltree_search_sequential_threshold = ref 50 5 | let avltree_search_height_threshold = ref 4 6 | let avltree_binary_search_threshold = ref 32 7 | 8 | let avltree_insert_type = ref 1 9 | (* 10 | 0: parallelise equal sub-batches, split tree accordingly 11 | 1: always split at root node, binary search in insert array 12 | 2: always split at root node, linear search in insert array 13 | 3: always split at root node, binary & linear search in insert array 14 | *) 15 | 16 | let avltree_search_type = ref 2 17 | (* 18 | 0: parallelise all queries, start at root node 19 | 1: parallelise equal sub-batches, start at root node 20 | 2: always split at root node, binary search in search array 21 | 3: always split at root node, linear search in search array 22 | 4: always split at root node, binary & linear search in search array 23 | *) 24 | 25 | (* let avltree_search_sequential_threshold = ref 1 26 | let avltree_search_height_threshold = ref 0 *) 27 | 28 | module Make (V: Map.OrderedType) = struct 29 | module Sequential = struct 30 | type side = Left | Right 31 | 32 | type 'a node = Leaf | Node of { 33 | mutable key: V.t; 34 | mutable nval: 'a; 35 | (* mutable rl: side; *) 36 | mutable height: int; 37 | mutable parent: 'a node; 38 | mutable left: 'a node; 39 | mutable right: 'a node 40 | } 41 | 42 | type 'a tree = { 43 | mutable root: 'a node 44 | } 45 | 46 | let key n = 47 | match n with 48 | | Leaf -> failwith "Key function: n is a leaf" 49 | | Node n' -> n'.key 50 | 51 | let left n = 52 | match n with 53 | | Leaf -> failwith "Left function: n is a leaf" 54 | | Node n' -> n'.left 55 | 56 | let right n = 57 | match n with 58 | | Leaf -> failwith "Right function: n is a leaf" 59 | | Node n' -> n'.right 60 | 61 | let height n = 62 | match n with 63 | | Leaf -> 0 64 | | Node n' -> n'.height 65 | 66 | let get_balance n = 67 | match n with 68 | | Leaf -> 0 69 | | Node n' -> height n'.left - height n'.right 70 | 71 | let parent n = 72 | match n with 73 | | Leaf -> failwith "Parent function: n is a leaf" 74 | | Node n' -> n'.parent 75 | 76 | let nval n = 77 | match n with 78 | | Leaf -> failwith "Value function: n is a leaf" 79 | | Node n' -> n'.nval 80 | 81 | let set_height n h = 82 | match n with 83 | | Leaf -> () 84 | | Node n' -> n'.height <- h 85 | 86 | let set_parent n p = 87 | match n with 88 | | Leaf -> () 89 | | Node n' -> n'.parent <- p 90 | 91 | let set_child n s c = 92 | match n with 93 | | Leaf -> () 94 | | Node n' -> 95 | match s with 96 | | Left -> (set_parent c n; n'.left <- c) 97 | | Right -> (set_parent c n; n'.right <- c) 98 | 99 | let expose n = 100 | match n with 101 | | Leaf -> failwith "Expose function: n is a leaf" 102 | | Node n' -> 103 | set_parent n'.left Leaf; 104 | set_parent n'.right Leaf; 105 | let l = n'.left in 106 | let r = n'.right in 107 | set_child n Left Leaf; 108 | set_child n Right Leaf; 109 | set_height n 1; 110 | (l, n, r) 111 | 112 | let merge_three_nodes nl n nr = 113 | match n with 114 | | Leaf -> failwith "Merge three nodes function: n is a leaf" 115 | | Node _ -> 116 | set_child n Left nl; 117 | set_child n Right nr; 118 | set_height n ((max (height nl) (height nr)) + 1) 119 | 120 | let root_node t = t.root 121 | 122 | let num_nodes t = 123 | let rec aux n = 124 | match n with 125 | | Leaf -> 0 126 | | Node n' -> 1 + aux n'.left + aux n'.right in 127 | aux t.root 128 | 129 | let flatten t = 130 | let rec flatten_aux n = 131 | match n with 132 | | Leaf -> [] 133 | | Node n' -> (flatten_aux n'.left) @ [(n'.key, n'.nval)] @ (flatten_aux n'.right) in 134 | flatten_aux t.root 135 | 136 | (* let rec traverse_aux n = 137 | match n with 138 | | Leaf -> () 139 | | Node n' -> begin 140 | let side = if n'.parent != Leaf && n == right (n'.parent) then "Right" else "Left" in 141 | let k = if n'.parent != Leaf then key n'.parent else -1 in 142 | Printf.printf "(%d, %d, %d, %s, height: %d), " n'.key n'.nval k side n'.height; 143 | traverse_aux n'.left; 144 | traverse_aux n'.right 145 | end 146 | 147 | let traverse t = 148 | traverse_aux t.root; Printf.printf "\n" *) 149 | 150 | let new_tree () = {root = Leaf} 151 | 152 | let new_tree_with_node n = {root = n} 153 | 154 | let new_node k v = Node { 155 | key = k; 156 | nval = v; 157 | (* rl = Left; *) 158 | height = 1; 159 | parent = Leaf; 160 | left = Leaf; 161 | right = Leaf 162 | } 163 | 164 | let rec search_aux k n = 165 | match n with 166 | | Leaf -> None 167 | | Node n' -> 168 | if k = n'.key then Some n'.nval 169 | else if k > n'.key then search_aux k n'.right 170 | else search_aux k n'.left 171 | 172 | let search k t = search_aux k t.root 173 | 174 | let rotate_left x t = 175 | let y = right x in 176 | set_child x Right (left y); 177 | if left y <> Leaf then set_parent (left y) x; 178 | set_parent y (parent x); 179 | if parent x = Leaf then t.root <- y 180 | else if x == left @@ parent x then set_child (parent x) Left y 181 | else set_child (parent x) Right y; 182 | set_child y Left x; 183 | set_height x @@ 1 + max (height @@ left x) (height @@ right x); 184 | set_height y @@ 1 + max (height @@ left y) (height @@ right y) 185 | 186 | let rotate_right x t = 187 | let y = left x in 188 | set_child x Left (right y); 189 | if right y <> Leaf then set_parent (right y) x; 190 | set_parent y (parent x); 191 | if parent x = Leaf then t.root <- y 192 | else if x == right @@ parent x then set_child (parent x) Right y 193 | else set_child (parent x) Left y; 194 | set_child y Right x; 195 | set_height x @@ 1 + max (height @@ left x) (height @@ right x); 196 | set_height y @@ 1 + max (height @@ left y) (height @@ right y) 197 | 198 | let rebalance_node n t = 199 | let () = set_height n @@ max (height (left n)) (height (right n)) + 1 in 200 | let balance = get_balance n in 201 | if balance > 1 then 202 | if height (left (left n)) >= height (right (left n)) then 203 | rotate_right n t 204 | else (rotate_left (left n) t; rotate_right n t) 205 | else if balance < -1 then 206 | if height (right (right n)) >= height (left (right n)) then 207 | rotate_left n t 208 | else (rotate_right (right n) t; rotate_left n t) 209 | 210 | let rec insert_aux new_node current_node t = 211 | if key new_node = key current_node then () 212 | else begin 213 | let () = if key new_node < key current_node then 214 | if left current_node = Leaf then 215 | set_child current_node Left new_node 216 | else insert_aux new_node (left current_node) t 217 | else 218 | if right current_node = Leaf then 219 | set_child current_node Right new_node 220 | else insert_aux new_node (right current_node) t in 221 | rebalance_node current_node t 222 | end 223 | 224 | let insert k v t = 225 | let new_node = new_node k v in 226 | if t.root = Leaf then t.root <- new_node 227 | else insert_aux new_node t.root t 228 | 229 | let rec find_min_node n = 230 | match n with 231 | | Leaf -> failwith "Find min node function: n is a leaf" 232 | | Node n' -> 233 | if n'.left == Leaf then n 234 | else find_min_node (n'.left) 235 | 236 | let rec delete_aux current_node k t = 237 | if current_node = Leaf then () 238 | else if k < key current_node then 239 | (delete_aux (left current_node) k t; rebalance_node current_node t) 240 | else if key current_node < k then 241 | (delete_aux (right current_node) k t; rebalance_node current_node t) 242 | else begin 243 | let p = parent current_node in 244 | if left current_node = Leaf then 245 | (if p == Leaf then 246 | let (_, _, r) = expose current_node in 247 | t.root <- r 248 | else if right p == current_node then 249 | set_child p Right (right current_node) 250 | else 251 | set_child p Left (right current_node)) 252 | else if right current_node = Leaf then 253 | (if p == Leaf then 254 | let (l, _, _) = expose current_node in 255 | t.root <- l 256 | else if right p == current_node then 257 | set_child p Right (left current_node) 258 | else 259 | set_child p Left (left current_node)) 260 | else 261 | let min_node = find_min_node (right current_node) in 262 | match current_node with 263 | | Leaf -> failwith "impossible error" 264 | | Node n' -> 265 | n'.key <- key min_node; 266 | n'.nval <- nval min_node; 267 | delete_aux n'.right (key min_node) t; 268 | rebalance_node current_node t; 269 | end 270 | 271 | let delete k t = 272 | if t.root = Leaf then () 273 | else delete_aux t.root k t 274 | 275 | let rec join_right tl k tr = 276 | let (l, k', c) = expose tl.root in 277 | if height c <= height tr.root + 1 then begin 278 | merge_three_nodes c k tr.root; 279 | let t' = {root = k} in 280 | if height t'.root <= height l + 1 then 281 | (merge_three_nodes l k' t'.root; {root = k'}) 282 | else begin 283 | rotate_right k t'; 284 | merge_three_nodes l k' t'.root; 285 | let t'' = {root = k'} in 286 | rotate_left k' t''; t'' 287 | end 288 | end 289 | else begin 290 | let t' = join_right {root = c} k tr in 291 | merge_three_nodes l k' t'.root; 292 | let t'' = {root = k'} in 293 | if height t'.root <= height l + 1 then t'' 294 | else begin 295 | rotate_left k' t''; t'' 296 | end 297 | end 298 | 299 | let rec join_left tl n tr = 300 | let (c, n', r) = expose tr.root in 301 | if height c <= height tl.root + 1 then begin 302 | merge_three_nodes tl.root n c; 303 | let t' = {root = n} in 304 | if height n <= height r + 1 then 305 | (merge_three_nodes n n' r; {root = n'}) 306 | else begin 307 | rotate_left n t'; 308 | merge_three_nodes t'.root n' r; 309 | let t'' = {root = n'} in 310 | rotate_right n' t''; t'' 311 | end 312 | end 313 | else begin 314 | let t' = join_left tl n {root = c} in 315 | merge_three_nodes t'.root n' r; 316 | let t'' = {root = n'} in 317 | if height t'.root <= height r + 1 then t'' 318 | else begin 319 | rotate_right n' t''; t'' 320 | end 321 | end 322 | 323 | let join tl n tr = 324 | if height tl.root > height tr.root + 1 then 325 | join_right tl n tr 326 | else if height tr.root > height tl.root + 1 then 327 | join_left tl n tr 328 | else begin 329 | merge_three_nodes tl.root n tr.root; {root = n} 330 | end 331 | 332 | let rec split t k = 333 | if t.root = Leaf then ({root = Leaf}, Leaf, {root = Leaf}) 334 | else 335 | let (l, m, r) = expose t.root in 336 | if k = key m then ({root = l}, m, {root = r}) 337 | else if k < key m then 338 | let (ll, b, lr) = split {root = l} k in 339 | (ll, b, join lr m {root = r}) 340 | else 341 | let (rl, b, rr) = split {root = r} k in 342 | (join {root = l} m rl, b, rr) 343 | 344 | let rec verify_height_invariant n = 345 | match n with 346 | | Leaf -> true 347 | | Node n' -> 348 | let height_diff = abs @@ height n'.left - height n'.right in 349 | (* if height_diff > 1 then Printf.printf "Height diff: %d, heights: %d, %d\n" height_diff (height n'.left) (height n'.right); *) 350 | height_diff <= 1 && 351 | verify_height_invariant n'.left && verify_height_invariant n'.right 352 | end 353 | 354 | type 'a t = 'a Sequential.tree 355 | 356 | type ('a, 'b) op = 357 | | Insert : V.t * 'a -> ('a, unit) op 358 | | Search : V.t -> ('a, 'a option) op 359 | 360 | type 'a wrapped_op = Mk : ('a, 'b) op * ('b -> unit) -> 'a wrapped_op 361 | 362 | let init () = Sequential.new_tree () 363 | 364 | (* let rec binary_search arr target left right = 365 | if left > right then 366 | match fst arr.(left) with 367 | | key when key >= target -> left 368 | | _ -> 0 (* No element greater than or equal to the target *) 369 | else 370 | let mid = (left + right) / 2 in 371 | match fst arr.(mid) with 372 | | key when key = target -> mid (* Found the target element *) 373 | | key when key < target -> binary_search arr target (mid + 1) right 374 | | _ -> binary_search arr target left (mid - 1) *) 375 | 376 | let binary_search arr target left right = 377 | let left = ref left and right = ref right in 378 | let mid = ref @@ (!left + !right) / 2 in 379 | let found = ref false in 380 | while !left <= !right && not !found do 381 | mid := (!left + !right) / 2; 382 | let ck = fst arr.(!mid) in 383 | if ck = target then found := true 384 | else if ck < target then left := !mid + 1 385 | else right := !mid - 1 386 | done; 387 | if !found then !mid 388 | else if fst arr.(!left) >= target then !left 389 | else 0 390 | 391 | (** Use both binary search and linear search to traverse operations array *) 392 | let rec par_search_aux_4 op_threshold height_threshold ~pool node ~keys ~range:(rstart, rstop) = 393 | let n = rstop - rstart in 394 | if n <= 0 then () 395 | else if node = Sequential.Leaf then 396 | for i = rstart to rstop - 1 do let (_,kont) = keys.(i) in kont None done 397 | (* else if n <= op_threshold || Sequential.height node <= height_threshold then *) 398 | else if n <= op_threshold then 399 | for i = rstart to rstop - 1 do let (k,kont) = keys.(i) in kont @@ Sequential.search_aux k node done 400 | (* Domainslib.Task.parallel_for pool ~start:rstart ~finish:(rstop - 1) ~body:(fun i -> 401 | let (k,kont) = keys.(i) in 402 | kont @@ Sequential.search_aux k node) *) 403 | else 404 | let k = Sequential.key node in 405 | let nval = Sequential.nval node in 406 | let s1 = ref rstart and s2 = ref rstart in 407 | if n > !avltree_binary_search_threshold then begin 408 | let split = binary_search keys k rstart rstop in 409 | s1 := split; s2 := split; 410 | while !s1 > rstart && fst keys.(!s1 - 1) = k do 411 | s1 := !s1 - 1; 412 | snd keys.(!s1) @@ Some nval; 413 | done; 414 | while !s2 < rstop && fst keys.(!s2) = k do 415 | snd keys.(!s2) @@ Some nval; 416 | s2 := !s2 + 1 417 | done; 418 | end 419 | else begin 420 | while !s1 < rstop && fst keys.(!s1) < k do s1 := !s1 + 1 done; 421 | s2 := !s1; 422 | while !s2 < rstop && fst keys.(!s2) = k do 423 | snd keys.(!s2) (Some nval); 424 | s2 := !s2 + 1 425 | done; 426 | end; 427 | (* let split = binary_search keys k rstart rstop in 428 | let s1 = ref split and s2 = ref split in 429 | while !s1 > rstart && fst keys.(!s1 - 1) = k do 430 | s1 := !s1 - 1; 431 | snd keys.(!s1) @@ Some nval; 432 | done; 433 | while !s2 < rstop && fst keys.(!s2) = k do 434 | snd keys.(!s2) @@ Some nval; 435 | s2 := !s2 + 1 436 | done; *) 437 | let l = Domainslib.Task.async pool 438 | (fun () -> par_search_aux_4 op_threshold height_threshold ~pool (Sequential.left node) ~keys ~range:(rstart, !s1)) in 439 | let r = Domainslib.Task.async pool 440 | (fun () -> par_search_aux_4 op_threshold height_threshold ~pool (Sequential.right node) ~keys ~range:(!s2, rstop)) in 441 | Domainslib.Task.await pool l; Domainslib.Task.await pool r 442 | 443 | (* Split the search operations only *) 444 | let rec par_search_aux_1 threshold pool t ~keys ~range:(rstart, rstop) = 445 | let n = rstop - rstart in 446 | if n <= 0 then () 447 | else if n > threshold then 448 | let num_par = n / threshold + if n mod threshold > 0 then 1 else 0 in 449 | Domainslib.Task.parallel_for pool ~start:0 ~finish:(num_par - 1) ~body:(fun i -> 450 | par_search_aux_1 threshold pool t ~keys ~range:(rstart + i * threshold, min rstop @@ rstart + (i + 1) * threshold) 451 | ); 452 | else 453 | for i = rstart to rstop - 1 do 454 | let (k, kont) = keys.(i) in kont @@ Sequential.search k t 455 | done 456 | 457 | (** Use binary search only to traverse operations array *) 458 | let rec par_search_aux_2 op_threshold height_threshold ~pool node ~keys ~range:(rstart, rstop) = 459 | let n = rstop - rstart in 460 | if n <= 0 then () 461 | else if node = Sequential.Leaf then 462 | for i = rstart to rstop - 1 do let (_,kont) = keys.(i) in kont None done 463 | else if n <= op_threshold then 464 | for i = rstart to rstop - 1 do let (k,kont) = keys.(i) in kont @@ Sequential.search_aux k node done 465 | else 466 | let k = Sequential.key node in 467 | let nval = Sequential.nval node in 468 | let split = binary_search keys k rstart rstop in 469 | let s1 = ref split and s2 = ref split in 470 | while !s1 > rstart && fst keys.(!s1 - 1) = k do 471 | s1 := !s1 - 1; 472 | snd keys.(!s1) @@ Some nval; 473 | done; 474 | while !s2 < rstop && fst keys.(!s2) = k do 475 | snd keys.(!s2) @@ Some nval; 476 | s2 := !s2 + 1 477 | done; 478 | let l = Domainslib.Task.async pool 479 | (fun () -> par_search_aux_2 op_threshold height_threshold ~pool (Sequential.left node) ~keys ~range:(rstart, !s1)) in 480 | let r = Domainslib.Task.async pool 481 | (fun () -> par_search_aux_2 op_threshold height_threshold ~pool (Sequential.right node) ~keys ~range:(!s2, rstop)) in 482 | Domainslib.Task.await pool l; Domainslib.Task.await pool r 483 | 484 | (** Use linear search only to traverse operations array *) 485 | let rec par_search_aux_3 op_threshold height_threshold ~pool node ~keys ~range:(rstart, rstop) = 486 | let n = rstop - rstart in 487 | if n <= 0 then () 488 | else if node = Sequential.Leaf then 489 | for i = rstart to rstop - 1 do let (_,kont) = keys.(i) in kont None done 490 | else if n <= op_threshold then 491 | for i = rstart to rstop - 1 do let (k,kont) = keys.(i) in kont @@ Sequential.search_aux k node done 492 | else 493 | let k = Sequential.key node in 494 | let nval = Sequential.nval node in 495 | let s1 = ref rstart and s2 = ref rstart in 496 | while !s1 < rstop && fst keys.(!s1) < k do s1 := !s1 + 1 done; 497 | s2 := !s1; 498 | while !s2 < rstop && fst keys.(!s2) = k do 499 | snd keys.(!s2) (Some nval); 500 | s2 := !s2 + 1 501 | done; 502 | let l = Domainslib.Task.async pool 503 | (fun () -> par_search_aux_3 op_threshold height_threshold ~pool (Sequential.left node) ~keys ~range:(rstart, !s1)) in 504 | let r = Domainslib.Task.async pool 505 | (fun () -> par_search_aux_3 op_threshold height_threshold ~pool (Sequential.right node) ~keys ~range:(!s2, rstop)) in 506 | Domainslib.Task.await pool l; Domainslib.Task.await pool r 507 | 508 | let par_search ?search_threshold ?tree_threshold ~pool (t: 'a t) keys = 509 | let search_threshold = match search_threshold with Some t -> t | None -> !avltree_search_sequential_threshold in 510 | let tree_threshold = match tree_threshold with Some t -> t | None -> !avltree_search_height_threshold in 511 | Sort.sort pool ~compare:(fun (k, _) (k', _) -> V.compare k k') keys; 512 | match !avltree_search_type with 513 | | 0 -> Domainslib.Task.parallel_for pool ~start:0 ~finish:(Array.length keys - 1) ~body:(fun i -> 514 | let (k,kont) = keys.(i) in 515 | kont @@ Sequential.search k t) 516 | | 1 -> par_search_aux_1 search_threshold pool t ~keys ~range:(0, Array.length keys) 517 | | 2 -> par_search_aux_2 search_threshold tree_threshold ~pool (Sequential.root_node t) ~keys ~range:(0, Array.length keys) 518 | | 3 -> par_search_aux_3 search_threshold tree_threshold ~pool (Sequential.root_node t) ~keys ~range:(0, Array.length keys) 519 | | 4 -> par_search_aux_4 search_threshold tree_threshold ~pool (Sequential.root_node t) ~keys ~range:(0, Array.length keys) 520 | | _ -> failwith "Invalid search type" 521 | 522 | (* let rec par_search_aux op_threshold height_threshold ~pool (t: 'a t) ~keys ~range:(rstart, rstop) = 523 | let n = rstop - rstart in 524 | if n <= 0 then () 525 | else if n <= op_threshold || Sequential.height (Sequential.root_node t) <= height_threshold then 526 | for i = rstart to rstop - 1 do let (k,kont) = keys.(i) in kont @@ Sequential.search k t done 527 | (* Domainslib.Task.parallel_for pool ~start:rstart ~finish:(rstop - 1) ~body:(fun i -> 528 | let (k,kont) = keys.(i) in 529 | kont @@ Sequential.search k t) *) 530 | else 531 | let (ln, mn, rn) = Sequential.expose @@ Sequential.root_node t in 532 | let lt = {Sequential.root = ln} and rt = {Sequential.root = rn} in 533 | let mid1 = ref rstart in 534 | while !mid1 < rstop && fst keys.(!mid1) < Sequential.key mn do mid1 := !mid1 + 1 done; 535 | let mid2 = ref !mid1 in 536 | while !mid2 < rstop && fst keys.(!mid2) <= Sequential.key mn do 537 | if fst keys.(!mid2) = Sequential.key mn then (snd keys.(!mid2)) None; 538 | mid2 := !mid2 + 1 539 | done; 540 | let _ = Domainslib.Task.async pool 541 | (fun () -> par_search_aux op_threshold height_threshold ~pool lt ~keys ~range:(rstart, !mid1)) in 542 | let _ = Domainslib.Task.async pool 543 | (fun () -> par_search_aux op_threshold height_threshold ~pool rt ~keys ~range:(!mid2, rstop)) in () *) 544 | 545 | (* Split the tree *) 546 | (* let rec par_search_aux threshold th ~pool t ~keys ~range:(rstart, rstop) = 547 | let n = rstop - rstart in 548 | if n <= 0 then () 549 | else if n > threshold then 550 | let num_par = n / threshold + if n mod threshold > 0 then 1 else 0 in 551 | Domainslib.Task.parallel_for pool ~start:0 ~finish:(num_par - 1) ~body:(fun i -> 552 | par_search_aux threshold th ~pool t ~keys ~range:(rstart + i * threshold, min rstop @@ rstart + (i + 1) * threshold) 553 | ); 554 | else 555 | for i = rstart to rstop - 1 do 556 | let (k, kont) = keys.(i) in kont @@ Sequential.search k t 557 | done *) 558 | 559 | (* Split the search operations only *) 560 | (* let rec par_search_aux threshold pool t ~keys ~range:(rstart, rstop) = 561 | let n = rstop - rstart in 562 | if n <= 0 then () 563 | else if n > threshold then 564 | let num_par = n / threshold + if n mod threshold > 0 then 1 else 0 in 565 | Domainslib.Task.parallel_for pool ~start:0 ~finish:(num_par - 1) ~body:(fun i -> 566 | par_search_aux threshold pool t ~keys ~range:(rstart + i * threshold, min rstop @@ rstart + (i + 1) * threshold) 567 | ); 568 | else 569 | for i = rstart to rstop - 1 do 570 | let (k, kont) = keys.(i) in kont @@ Sequential.search k t 571 | done *) 572 | 573 | (* let par_search ?search_threshold ?tree_threshold ~pool (t: 'a t) keys = 574 | let search_threshold = match search_threshold with Some t -> t | None -> !avltree_search_sequential_threshold in 575 | let tree_threshold = match tree_threshold with Some t -> t | None -> !avltree_search_height_threshold in 576 | Sort.sort pool ~compare:(fun (k, _) (k', _) -> V.compare k k') keys; 577 | par_search_aux search_threshold tree_threshold ~pool t ~keys ~range:(0, Array.length keys) *) 578 | 579 | (** Mix of binary and linear search in partitioning insert array *) 580 | let rec par_insert_aux_3 op_threshold height_threshold ~pool (t: 'a t) ~inserts ~range:(rstart, rstop) = 581 | let n = rstop - rstart in 582 | if n <= 0 then () 583 | else if n <= op_threshold || Sequential.height (Sequential.root_node t) <= height_threshold then 584 | for i = rstart to rstop - 1 do 585 | let (k, v) = inserts.(i) in 586 | Sequential.insert k v t 587 | done 588 | else 589 | let (ln, mn, rn) = Sequential.expose @@ Sequential.root_node t in 590 | let lt = Sequential.new_tree_with_node ln and rt = Sequential.new_tree_with_node rn in 591 | let s1 = ref rstart and s2 = ref rstart in 592 | if n > !avltree_binary_search_threshold then begin 593 | let k = Sequential.key mn in 594 | let split = binary_search inserts k rstart rstop in 595 | s1 := split; s2 := split; 596 | while !s1 > rstart && fst inserts.(!s1 - 1) = k do s1 := !s1 - 1 done; 597 | while fst inserts.(!s2) = k && !s2 >= rstop do s2 := !s2 + 1 done; 598 | end 599 | else begin 600 | while !s1 < rstop && fst inserts.(!s1) < Sequential.key mn do s1 := !s1 + 1 done; 601 | s2 := !s1; 602 | while !s2 < rstop && fst inserts.(!s2) = Sequential.key mn do s2 := !s2 + 1 done; 603 | end; 604 | let l = Domainslib.Task.async pool 605 | (fun () -> par_insert_aux_3 op_threshold height_threshold ~pool lt ~inserts ~range:(rstart, !s1)) in 606 | let r = Domainslib.Task.async pool 607 | (fun () -> par_insert_aux_3 op_threshold height_threshold ~pool rt ~inserts ~range:(!s2, rstop)) in 608 | Domainslib.Task.await pool l; Domainslib.Task.await pool r; 609 | let nt = Sequential.join lt mn rt in 610 | t.root <- nt.root 611 | 612 | (** Linear traversal of inserts *) 613 | let rec par_insert_aux_2 op_threshold height_threshold ~pool (t: 'a t) ~inserts ~range:(rstart, rstop) = 614 | let n = rstop - rstart in 615 | if n <= 0 then () 616 | else if n <= op_threshold || Sequential.height (Sequential.root_node t) <= height_threshold then 617 | for i = rstart to rstop - 1 do 618 | let (k, v) = inserts.(i) in 619 | Sequential.insert k v t 620 | done 621 | else 622 | let (ln, mn, rn) = Sequential.expose @@ Sequential.root_node t in 623 | let lt = {Sequential.root = ln} and rt = {Sequential.root = rn} in 624 | let mid1 = ref rstart in 625 | while !mid1 < rstop && fst inserts.(!mid1) < Sequential.key mn do mid1 := !mid1 + 1 done; 626 | let mid2 = ref !mid1 in 627 | while !mid2 < rstop && fst inserts.(!mid2) <= Sequential.key mn do mid2 := !mid2 + 1 done; 628 | let l = Domainslib.Task.async pool 629 | (fun () -> par_insert_aux_2 op_threshold height_threshold ~pool lt ~inserts ~range:(rstart, !mid1)) in 630 | let r = Domainslib.Task.async pool 631 | (fun () -> par_insert_aux_2 op_threshold height_threshold ~pool rt ~inserts ~range:(!mid2, rstop)) in 632 | Domainslib.Task.await pool l; Domainslib.Task.await pool r; 633 | let nt = Sequential.join lt mn rt in 634 | t.root <- nt.root 635 | 636 | (* Use binary search on the sorted inserts array *) 637 | let rec par_insert_aux_1 op_threshold height_threshold ~pool (t: 'a t) ~inserts ~range:(rstart, rstop) = 638 | let n = rstop - rstart in 639 | if n <= 0 then () 640 | else if n <= op_threshold || Sequential.height (Sequential.root_node t) <= height_threshold then 641 | for i = rstart to rstop - 1 do 642 | let (k, v) = inserts.(i) in 643 | Sequential.insert k v t 644 | done 645 | else 646 | let (ln, mn, rn) = Sequential.expose @@ Sequential.root_node t in 647 | let lt = Sequential.new_tree_with_node ln and rt = Sequential.new_tree_with_node rn in 648 | let k = Sequential.key mn in 649 | let split = binary_search inserts k rstart rstop in 650 | let s1 = ref split and s2 = ref split in 651 | while !s1 > rstart && fst inserts.(!s1 - 1) = k do s1 := !s1 - 1 done; 652 | while fst inserts.(!s2) = k && !s2 >= rstop do s2 := !s2 + 1 done; 653 | let l = Domainslib.Task.async pool 654 | (fun () -> par_insert_aux_1 op_threshold height_threshold ~pool lt ~inserts ~range:(rstart, !s1)) in 655 | let r = Domainslib.Task.async pool 656 | (fun () -> par_insert_aux_1 op_threshold height_threshold ~pool rt ~inserts ~range:(!s2, rstop)) in 657 | Domainslib.Task.await pool l; Domainslib.Task.await pool r; 658 | let nt = Sequential.join lt mn rt in 659 | t.root <- nt.root 660 | 661 | (** Split cleanly down the middle of the insertion array *) 662 | let rec par_insert_aux_0 threshold ~pool (t: 'a t) ~inserts ~range:(rstart, rstop) = 663 | let n = rstop - rstart in 664 | if n <= 0 then () 665 | else if n <= threshold then 666 | for i = rstart to rstop - 1 do 667 | let (k, v) = inserts.(i) in 668 | Sequential.insert k v t 669 | done 670 | else 671 | let mid = rstart + n / 2 in 672 | let (mk, nv) = inserts.(mid) in 673 | let (lt, mn, rt) = Sequential.split t mk in 674 | let nn = match mn with 675 | | Leaf -> Sequential.new_node mk nv 676 | | Node _ -> mn in 677 | let l = Domainslib.Task.async pool 678 | (fun () -> par_insert_aux_0 threshold ~pool lt ~inserts ~range:(rstart, mid)) in 679 | let r = Domainslib.Task.async pool 680 | (fun () -> par_insert_aux_0 threshold ~pool rt ~inserts ~range:(mid + 1, rstop)) in 681 | Domainslib.Task.await pool l; Domainslib.Task.await pool r; 682 | let (nlt, _, _) = Sequential.split lt (Sequential.key nn) in (* Make sure there's no duplicate *) 683 | let (_, _, nrt) = Sequential.split rt (Sequential.key nn) in 684 | let nt = Sequential.join lt nn rt in 685 | t.root <- nt.root 686 | 687 | let par_insert ?threshold ~pool (t: 'a t) inserts = 688 | let threshold = match threshold with Some t -> t | None -> !avltree_insert_sequential_threshold in 689 | Sort.sort pool ~compare:(fun (k, _) (k', _) -> V.compare k k') inserts; 690 | match !avltree_insert_type with 691 | | 0 -> par_insert_aux_0 threshold ~pool t ~inserts ~range:(0, Array.length inserts) 692 | | 1 -> par_insert_aux_1 threshold !avltree_insert_height_threshold ~pool t ~inserts ~range:(0, Array.length inserts) 693 | | 2 -> par_insert_aux_2 threshold !avltree_insert_height_threshold ~pool t ~inserts ~range:(0, Array.length inserts) 694 | | 3 -> par_insert_aux_3 threshold !avltree_insert_height_threshold ~pool t ~inserts ~range:(0, Array.length inserts) 695 | | _ -> failwith "Invalid insert type" 696 | 697 | let run (type a) (t: a t) (pool: Domainslib.Task.pool) (ops: a wrapped_op array) = 698 | let searches: (V.t * (a option -> unit)) list ref = ref [] in 699 | let inserts: (V.t * a) list ref = ref [] in 700 | Array.iter (fun (elt: a wrapped_op) -> match elt with 701 | | Mk (Insert (key, vl), kont) -> kont (); inserts := (key,vl) :: !inserts 702 | | Mk (Search key, kont) -> searches := (key, kont) :: !searches 703 | ) ops; 704 | 705 | (* Initiate parallel searches *) 706 | let searches = Array.of_list !searches in 707 | if Array.length searches > 0 then 708 | par_search ~pool t searches; 709 | 710 | (* Initiate parallel inserts *) 711 | let inserts = Array.of_list !inserts in 712 | if Array.length inserts > 0 then begin 713 | Sort.sort pool ~compare:(fun (k1,_) (k2,_) -> V.compare k1 k2) inserts; 714 | par_insert ~pool t inserts 715 | end 716 | 717 | end -------------------------------------------------------------------------------- /lib/btree.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-32-26"] 2 | let btree_insert_sequential_threshold = ref None 3 | let btree_search_sequential_threshold = ref None 4 | let btree_search_parallel_threshold = ref None 5 | let btree_max_children = ref 8 6 | 7 | module Make (V: Map.OrderedType) = struct 8 | 9 | let (.!()) x v = Finite_vector.get x v 10 | 11 | module Sequential = struct 12 | 13 | type 'a node = { 14 | mutable n: int; (* number of keys in node *) 15 | mutable keys: V.t Finite_vector.t; (* keys themselves *) 16 | mutable values: 'a Finite_vector.t; (* values *) 17 | leaf: bool; 18 | mutable children: 'a node Finite_vector.t; 19 | mutable no_elements: int; (* number of elements in the node and subtrees *) 20 | mutable capacity: int; 21 | mutable min_child_capacity: int; 22 | } 23 | 24 | type 'a t = { 25 | mutable root: 'a node; 26 | mutable height: int; 27 | max_children: int; 28 | } 29 | 30 | let rec size_node node = 31 | if node.leaf 32 | then Finite_vector.length node.values 33 | else Finite_vector.fold_left (fun acc vl -> acc + size_node vl) 0 node.children 34 | 35 | let size t = t.root.no_elements 36 | 37 | let rec pp_node ?(pp_child=true) ?(pp_v=fun fmt _ -> Format.fprintf fmt "") indent f fmt node = 38 | let spaces = (String.make indent ' ') in 39 | Format.fprintf fmt "%snode(n=%d,leaf=%b,no_elts=%d)\n%s - values=[%a]\n%a" 40 | spaces node.n node.leaf node.no_elements 41 | spaces (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") 42 | (fun fmt (k,vl) -> Format.fprintf fmt "%a: %a" pp_v k f vl)) 43 | (List.init node.n (fun i -> (node.keys.!(i), node.values.!(i)))) 44 | (if pp_child then 45 | Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n") 46 | (fun fmt (k, vl) -> 47 | match k with 48 | | None -> Format.fprintf fmt "%s - child(k=_):\n%a" spaces (pp_node ~pp_v (indent + 4) f) vl 49 | | Some key -> Format.fprintf fmt "%s - child(k=%a):\n%a" spaces pp_v key (pp_node ~pp_v (indent + 4) f) vl 50 | ) 51 | else fun _fmt _vl -> ()) 52 | (List.init (Finite_vector.length node.children) (fun i -> 53 | ((if i < node.n then Some node.keys.!(i) else None), node.children.!(i)))) 54 | 55 | let pp_node_internal = pp_node 56 | let pp_node ?pp_v f fmt vl = pp_node ?pp_v 0 f fmt vl 57 | let show_node ?pp_v f vl = Format.asprintf "%a" (pp_node ?pp_v f) vl 58 | let show_node_no_children ?pp_v f vl = Format.asprintf "%a" (pp_node_internal ?pp_v ~pp_child:false 0 f) vl 59 | 60 | let pp ?pp_v f fmt t = 61 | pp_node ?pp_v f fmt t.root 62 | let show ?pp_v f vl = Format.asprintf "%a" (pp ?pp_v f) vl 63 | 64 | let init ?max_children () = 65 | let max_children = match max_children with Some v -> v | None -> !btree_max_children in 66 | let root = { 67 | n=0; 68 | leaf=true; 69 | keys=Finite_vector.init ~capacity:(2 * max_children - 1) (); 70 | children=Finite_vector.init ~capacity:(2 * max_children) (); 71 | values=Finite_vector.init ~capacity:(2 * max_children - 1) (); 72 | no_elements=0; 73 | capacity=2 * max_children - 1; 74 | min_child_capacity=0; 75 | } in 76 | {root; max_children; height=1} 77 | 78 | let rec fold_int_range ~start ~stop f acc = 79 | if start >= stop 80 | then f acc start 81 | else 82 | let acc = f acc start in 83 | fold_int_range ~start:(start + 1) ~stop f acc 84 | 85 | let rec find_int_range ~start ~stop f = 86 | if stop < start 87 | then None 88 | else if start = stop then f start 89 | else match f start with 90 | | None -> find_int_range ~start:(start + 1) ~stop f 91 | | res -> res 92 | 93 | let rec find_int_range_dec ~start ~stop f = 94 | if start < stop 95 | then None 96 | else if start = stop then f stop 97 | else match f start with 98 | | None -> find_int_range_dec ~start:(start - 1) ~stop f 99 | | res -> res 100 | 101 | let rec search_node x k = 102 | let index = 103 | find_int_range ~start:0 ~stop:(x.n - 1) (fun i -> 104 | if V.compare k x.keys.!(i) <= 0 105 | then Some i 106 | else None) 107 | |> Option.value ~default:x.n in 108 | if index < x.n && V.compare x.keys.!(index) k = 0 109 | then Some (x, index) 110 | else if x.leaf then None 111 | else 112 | search_node (x.children.!(index)) k 113 | 114 | let search t k = 115 | match search_node t.root k with 116 | | Some (node, i) -> Some node.values.!(i) 117 | | None -> None 118 | 119 | let min_capacity vec = 120 | Finite_vector.fold_left (fun acc vl -> 121 | match acc with 122 | | None -> Some vl.capacity 123 | | Some vl' when vl' > vl.capacity -> Some vl.capacity 124 | | _ -> acc) None vec 125 | 126 | (* pre: x.(i) has (2 * t - 1) keys *) 127 | let split_child x i = 128 | let y = x.children.!(i) in 129 | let t = (y.n + 1) / 2 in 130 | let z = 131 | let keys = Finite_vector.split_from y.keys t in 132 | let values = Finite_vector.split_from y.values t in 133 | let children = 134 | if y.leaf then Finite_vector.init ~capacity:(2 * t) () 135 | else Finite_vector.split_from y.children t in 136 | let min_child_capacity = Option.value ~default:0 (min_capacity children) in 137 | let capacity = t * (min_child_capacity + 1) + min_child_capacity in 138 | { n = t - 1; leaf=y.leaf; keys; values; children; no_elements=t - 1; capacity; min_child_capacity } in 139 | z.no_elements <- t - 1; 140 | Finite_vector.iter (fun child -> z.no_elements <- z.no_elements + child.no_elements) z.children; 141 | 142 | (* insert z *) 143 | Finite_vector.insert x.keys i y.keys.!(t - 1); 144 | Finite_vector.insert x.values i y.values.!(t - 1); 145 | Finite_vector.insert x.children (i + 1) z; 146 | 147 | (* clip y *) 148 | y.n <- t - 1; 149 | Finite_vector.clip y.keys (t - 1); 150 | Finite_vector.clip y.values (t - 1); 151 | y.no_elements <- t - 1; 152 | Finite_vector.iter (fun child -> y.no_elements <- y.no_elements + child.no_elements) y.children; 153 | y.min_child_capacity <- Option.value ~default:0 (min_capacity y.children); 154 | y.capacity <- t * (y.min_child_capacity + 1) + y.min_child_capacity; 155 | 156 | x.n <- x.n + 1; 157 | x.min_child_capacity <- min x.min_child_capacity (min y.min_child_capacity z.min_child_capacity); 158 | x.capacity <- (2 * t - 1 - x.n) * (x.min_child_capacity + 1) + x.min_child_capacity 159 | 160 | 161 | let rec insert_node ~max_children x k vl = 162 | let index = 163 | find_int_range_dec ~start:(x.n - 1) ~stop:0 (fun i -> 164 | if V.compare k x.keys.!(i) >= 0 165 | then Some (i + 1) else None) 166 | |> Option.value ~default:0 in 167 | x.no_elements <- x.no_elements + 1; 168 | if x.leaf 169 | then begin 170 | Finite_vector.insert x.keys index k; 171 | Finite_vector.insert x.values index vl; 172 | x.capacity <- x.capacity - 1; 173 | x.n <- x.n + 1; 174 | x.capacity 175 | end else begin 176 | let child_capacity = 177 | if x.children.!(index).n = 2 * max_children - 1 178 | then begin 179 | split_child x index; 180 | if V.compare k x.keys.!(index) > 0 181 | then insert_node ~max_children x.children.!(index + 1) k vl 182 | else insert_node ~max_children x.children.!(index) k vl 183 | end 184 | else 185 | insert_node ~max_children x.children.!(index) k vl in 186 | x.min_child_capacity <- min x.min_child_capacity child_capacity; 187 | x.capacity <- (2 * max_children - 1 - x.n) * (x.min_child_capacity + 1) + x.min_child_capacity; 188 | x.capacity 189 | end 190 | 191 | let insert tree k vl = 192 | let t = tree.max_children in 193 | let r = tree.root in 194 | if r.n = 2 * t - 1 195 | then begin 196 | let s = { 197 | n=0; 198 | leaf=false; 199 | keys=Finite_vector.init ~capacity:(2 * t - 1) (); 200 | children=Finite_vector.singleton ~capacity:(2 * t) (tree.root); 201 | values=Finite_vector.init ~capacity:(2 * t - 1) (); 202 | no_elements=r.no_elements; 203 | capacity=0; 204 | min_child_capacity=r.capacity; 205 | } in 206 | tree.root <- s; 207 | tree.height <- tree.height + 1; 208 | split_child s 0; 209 | ignore (insert_node ~max_children:tree.max_children s k vl) 210 | end else 211 | ignore (insert_node ~max_children:tree.max_children r k vl) 212 | 213 | end 214 | 215 | type 'a t = 'a Sequential.t 216 | 217 | type ('elt, 'ret) op = 218 | | Insert : V.t * 'elt -> ('elt, unit) op 219 | | Search : V.t -> ('elt, 'elt option) op 220 | | Size : ('elt, int) op 221 | 222 | type 'a wrapped_op = Mk : ('a, 'b) op * ('b -> unit) -> 'a wrapped_op 223 | 224 | let init () = 225 | let max_children = !btree_max_children in 226 | Sequential.init ~max_children () 227 | 228 | let fold_left_map f accu l = 229 | let rec aux accu l_accu = function 230 | | [] -> accu, List.rev l_accu 231 | | x :: l -> 232 | let accu, x = f accu x in 233 | aux accu (x :: l_accu) l in 234 | aux accu [] l 235 | 236 | let drop_last ls = 237 | let rec loop acc last = function 238 | | [] -> List.rev acc 239 | | h :: t -> loop (last :: acc) h t in 240 | match ls with 241 | | [] -> [] 242 | | h :: t -> loop [] h t 243 | 244 | let int_pow x y = 245 | let rec loop acc x y = 246 | if y > 0 then 247 | match y mod 2 with 248 | | 0 -> loop acc (x * x) (y / 2) 249 | | _ -> loop (acc * x) x (y - 1) 250 | else 251 | acc in 252 | loop 1 x y 253 | 254 | let find_height ~t ~no_elts = 255 | if no_elts < 2 * t - 1 256 | then 1 257 | else 258 | let rec loop t no_elts h t_h t2_h = 259 | if t_h - 1 <= no_elts && no_elts <= t2_h - 1 260 | then h 261 | else 262 | let t_h_1 = t_h * t and t2_h_1 = t2_h * (2 * t) in 263 | if t2_h - 1 < no_elts && no_elts < t2_h_1 - 1 264 | then h + 1 265 | else loop t no_elts (h+1) t_h_1 t2_h_1 in 266 | loop t no_elts 1 t (2 * t) 267 | 268 | let find_split ?(root=false) ~t ~h r = 269 | let max_t = 2 * t in 270 | let min_size = int_pow t (h - 1) - 1 in 271 | let max_size = int_pow (2 * t) (h - 1) - 1 in 272 | let rec loop min_size max_size t = 273 | assert (t <= max_t); 274 | let elt_size = Int.div (r - t + 1) t in 275 | let rem_size = Int.rem (r - t + 1) t in 276 | if min_size <= elt_size && elt_size <= max_size && 277 | (rem_size = 0 || elt_size + 1 <= max_size) 278 | then (t, elt_size, rem_size) 279 | else loop min_size max_size (t + 1) in 280 | loop min_size max_size (if root then 2 else t) 281 | 282 | let partition_range ?root ~t ~h (start,stop) = 283 | let t, sub_range_size, rem = find_split ?root ~t ~h (stop - start) in 284 | let key_inds = Array.make (t - 1) 0 in 285 | let child_inds = Array.make t 0 in 286 | let rem = ref rem in 287 | let start = ref start in 288 | for i = 0 to t - 1 do 289 | let rem_comp = if !rem > 0 then (decr rem; 1) else 0 in 290 | child_inds.(i) <- min (!start + sub_range_size + rem_comp) stop; 291 | if i < t - 1 then 292 | key_inds.(i) <- !start + sub_range_size + rem_comp; 293 | start := !start + sub_range_size + rem_comp + 1; 294 | done; 295 | child_inds.(t - 1) <- stop; 296 | key_inds, child_inds 297 | 298 | let rec build_node ~max_children:t ~h start stop arr = 299 | if h <= 1 300 | then Sequential.{ 301 | n = stop - start; 302 | keys = Finite_vector.init_with ~capacity:(2 * t - 1) (stop - start) (fun i -> fst arr.(start + i)); 303 | values=Finite_vector.init_with ~capacity:(2 * t - 1) (stop - start) (fun i -> snd arr.(start + i)); 304 | leaf=true; 305 | children = Finite_vector.init ~capacity:(2 * t) (); 306 | no_elements=stop - start; 307 | capacity=(2 * t - 1 - (stop - start)); 308 | min_child_capacity=0; 309 | } 310 | else 311 | let key_inds, sub_ranges = partition_range ~t ~h (start,stop) in 312 | 313 | let children = 314 | let start = ref start in 315 | Array.map (fun stop -> 316 | let subtree = build_node ~max_children:t ~h:(h - 1) !start stop arr in 317 | start := (stop + 1); 318 | subtree 319 | ) sub_ranges in 320 | let n = Array.length key_inds in 321 | let keys = Finite_vector.init_with ~capacity:(2 * t - 1) n (fun pos -> fst arr.(key_inds.(pos))) in 322 | let values = Finite_vector.init_with ~capacity:(2 * t - 1) n (fun pos -> snd arr.(key_inds.(pos))) in 323 | let children = Finite_vector.init_with ~capacity:(2 * t) (Array.length children) 324 | (fun pos -> children.(pos)) in 325 | let min_child_capacity = Sequential.min_capacity children |> Option.value ~default:0 in 326 | let capacity = (2 * t - 1 - n) * (min_child_capacity + 1) in 327 | { 328 | n; 329 | keys; 330 | values; 331 | leaf=false; 332 | children; 333 | no_elements=stop - start; 334 | capacity; min_child_capacity 335 | } 336 | 337 | let rec par_build_node pool ~max_children:t ~h start stop arr = 338 | if h <= 1 339 | then Sequential.{ 340 | n = stop - start; 341 | keys = Finite_vector.init_with ~capacity:(2 * t - 1) (stop - start) (fun i -> fst arr.(start + i)); 342 | values=Finite_vector.init_with ~capacity:(2 * t - 1) (stop - start) (fun i -> snd arr.(start + i)); 343 | leaf=true; 344 | children = Finite_vector.init ~capacity:(2 * t) (); 345 | no_elements=stop - start; 346 | capacity=(2 * t - 1 - (stop - start)); 347 | min_child_capacity=0; 348 | } 349 | else 350 | let key_inds, sub_ranges = partition_range ~t ~h (start,stop) in 351 | 352 | let sub_ranges = 353 | let start = ref start in 354 | Array.map (fun stop -> 355 | let interval = !start, stop in 356 | start := (stop + 1); 357 | interval 358 | ) sub_ranges in 359 | let children = 360 | let child_arr = Array.make (Array.length sub_ranges) Sequential.{ 361 | n=0; children=Finite_vector.init (); keys=Finite_vector.init (); values=Finite_vector.init (); leaf=true; 362 | no_elements=0; capacity=0; min_child_capacity=0; 363 | } in 364 | Domainslib.Task.parallel_for pool ~start:0 ~finish:((Array.length sub_ranges) - 1) ~body:(fun i -> 365 | let start, stop = sub_ranges.(i) in 366 | child_arr.(i) <- par_build_node pool ~max_children:t ~h:(h-1) start stop arr 367 | ); 368 | child_arr 369 | in 370 | let n = Array.length key_inds in 371 | let keys = Finite_vector.init_with ~capacity:(2 * t - 1) n (fun pos -> fst arr.(key_inds.(pos))) in 372 | let values = Finite_vector.init_with ~capacity:(2 * t - 1) n (fun pos -> snd arr.(key_inds.(pos))) in 373 | let children = Finite_vector.init_with ~capacity:(2 * t) (Array.length children) 374 | (fun pos -> children.(pos)) in 375 | let min_child_capacity = Sequential.min_capacity children |> Option.value ~default:0 in 376 | let capacity = (2 * t - 1 - n) * (min_child_capacity + 1) + min_child_capacity in 377 | { 378 | n; 379 | keys; 380 | values; 381 | leaf=false; 382 | children; 383 | no_elements=stop - start; 384 | capacity; min_child_capacity 385 | } 386 | 387 | let build_from_sorted ?max_children:(t=3) ~pool arr = 388 | let h = find_height ~t ~no_elts:(Array.length arr) in 389 | let root = 390 | if Array.length arr <= 2 * t - 1 391 | then par_build_node pool ~max_children:t ~h:1 0 (Array.length arr) arr 392 | else 393 | let key_inds, sub_ranges = partition_range ~root:true ~t ~h (0,(Array.length arr)) in 394 | 395 | let children = 396 | let start = ref 0 in 397 | Array.map (fun stop -> 398 | let subtree = par_build_node pool ~max_children:t ~h:(h - 1) !start stop arr in 399 | start := stop + 1; 400 | subtree 401 | ) sub_ranges in 402 | let n = Array.length key_inds in 403 | let keys = Finite_vector.init_with ~capacity:(2 * t - 1) n (fun pos -> fst arr.(key_inds.(pos))) in 404 | let values = Finite_vector.init_with ~capacity:(2 * t - 1) n (fun pos -> snd arr.(key_inds.(pos))) in 405 | let children = Finite_vector.init_with ~capacity:(2 * t) (Array.length children) 406 | (fun pos -> children.(pos)) in 407 | let min_child_capacity = Sequential.min_capacity children |> Option.value ~default:0 in 408 | let capacity = (2 * t - 1 - n) * (min_child_capacity + 1) + min_child_capacity in 409 | { n; keys; values; leaf=false; children; no_elements=Array.length arr; min_child_capacity; capacity } in 410 | h, root 411 | 412 | let rec int_range_downto start stop = 413 | fun () -> 414 | if start > stop 415 | then Seq.Nil 416 | else Seq.Cons (stop, int_range_downto start (stop - 1)) 417 | 418 | let flatten t = 419 | let open Seq in 420 | let rec aux node = 421 | if node.Sequential.leaf then 422 | let elems = 423 | Array.init (Finite_vector.length node.Sequential.keys) (fun i -> 424 | node.Sequential.keys.!(i), node.Sequential.values.!(i) 425 | ) in 426 | Array.to_seq elems 427 | else begin 428 | let back = 429 | int_range_downto 1 (node.Sequential.n) |> 430 | fold_left (fun acc i -> 431 | let tl = aux (node.Sequential.children.!(i)) in 432 | let kv = node.Sequential.keys.!(i-1), node.Sequential.values.!(i-1) in 433 | let comb = cons kv tl in 434 | append comb acc 435 | ) empty in 436 | append (aux (node.Sequential.children.!(0))) back 437 | end 438 | in 439 | aux t 440 | 441 | let merge i1 i2 = 442 | let i1 = Seq.to_dispenser i1 in 443 | let i2 = Seq.to_dispenser i2 in 444 | let next i h = match h with None -> i () | Some v -> Some v in 445 | let rec aux i1 h1 i2 h2 f = 446 | match next i1 h1, next i2 h2 with 447 | | None,None -> () 448 | | (Some hd1, Some hd2) -> 449 | if hd1 < hd2 450 | then (f hd1; aux i1 None i2 (Some hd2) f) 451 | 452 | else (f hd2; aux i1 (Some hd1) i2 None f) 453 | | (Some hd1, None) -> (f hd1; aux i1 None i2 None f) 454 | | (None, Some hd2) -> (f hd2; aux i1 None i2 None f) 455 | in 456 | fun f -> aux i1 None i2 None f 457 | 458 | let par_rebuild ~pool ~max_children (root: 'a Sequential.node) (kv_arr : (V.t * 'a) array) = 459 | begin 460 | (* keys is a array of (key, index) where index is the position in the original search query *) 461 | let max_children = max_children in 462 | let batch = Array.make (Array.length kv_arr + root.no_elements) kv_arr.(0) in 463 | let i1 = kv_arr |> Array.to_seq in 464 | let i2 = flatten root in 465 | let merged = merge i1 i2 in 466 | let i = ref 0 in 467 | merged (fun vl -> batch.(!i) <- vl; incr i); 468 | build_from_sorted ~max_children ~pool batch 469 | end 470 | 471 | let rec par_search_node ?(par_threshold=6) ?(threshold=64) pool node ~height ~keys ~range:(rstart, rstop) = 472 | (* if the no elements in the node are greater than the number of keys we're searching for, then just do normal search in parallel *) 473 | let n = rstop - rstart in 474 | (* Format.printf "par_search batch_size is %d < threshold(%d), leaf?=%b, height=%d\n%!" *) 475 | (* n threshold node.Sequential.leaf height; *) 476 | if n <= 0 then () 477 | else if n = 1 then 478 | let (k,kont) = keys.(rstart) in 479 | kont 480 | (Option.map (fun (node,i) -> node.Sequential.values.!(i)) 481 | (Sequential.search_node node k)) 482 | else if (rstop - rstart) < par_threshold && height > 5 then 483 | Domainslib.Task.parallel_for pool ~start:rstart ~finish:(rstop - 1) ~body:(fun i -> 484 | let (k,kont) = keys.(i) in 485 | kont (Option.map (fun (node,i) -> 486 | node.Sequential.values.!(i)) (Sequential.search_node node k)) 487 | ) 488 | else if (rstop - rstart) < threshold && height < 3 || node.Sequential.leaf then 489 | for i = rstart to rstop - 1 do 490 | let (k,kont) = keys.(i) in 491 | kont (Option.map (fun (node,i) -> node.Sequential.values.!(i)) (Sequential.search_node node k)) 492 | done 493 | else begin 494 | let sub_intervals = 495 | Finite_vector.init 496 | ~capacity:(Finite_vector.length node.children) () in 497 | let sub_interval_size i = 498 | let (start,stop) = sub_intervals.!(i) in 499 | stop - start in 500 | 501 | let last_sub_interval_end = ref rstart in 502 | (* partition batch by children *) 503 | for i = 0 to Finite_vector.length node.keys - 1 do 504 | let interval_start = !last_sub_interval_end in 505 | while !last_sub_interval_end < rstop && 506 | V.compare (fst keys.(!last_sub_interval_end)) node.keys.!(i) < 0 do 507 | incr last_sub_interval_end 508 | done; 509 | Finite_vector.insert sub_intervals i (interval_start, !last_sub_interval_end); 510 | while !last_sub_interval_end < rstop && V.compare (fst keys.(!last_sub_interval_end)) node.keys.!(i) = 0 do 511 | (snd keys.(!last_sub_interval_end)) (Some (node.values.!(i))); 512 | incr last_sub_interval_end 513 | done 514 | done; 515 | Finite_vector.insert sub_intervals (Finite_vector.length node.keys) (!last_sub_interval_end, rstop); 516 | 517 | Domainslib.Task.parallel_for pool ~start:0 ~finish:(Finite_vector.length sub_intervals - 1) ~body:(fun i -> 518 | par_search_node ~par_threshold 519 | ~threshold pool node.children.!(i) ~keys ~height:(height - 1) 520 | ~range:sub_intervals.!(i) 521 | ); 522 | end 523 | 524 | let par_search ?par_threshold ?threshold ~pool (t: 'a t) keys = 525 | let threshold = match threshold with Some _ -> threshold | None -> !btree_search_sequential_threshold in 526 | let par_threshold = match par_threshold with Some _ -> par_threshold | None -> !btree_search_parallel_threshold in 527 | (* keys is a array of (key, index) where index is the position in the original search query *) 528 | Sort.sort pool ~compare:(fun (k, _) (k', _) -> V.compare k k') keys; 529 | (* allocate a buffer for the results *) 530 | par_search_node ?par_threshold ?threshold pool t.root ~height:t.height ~keys ~range:(0, Array.length keys) 531 | 532 | 533 | 534 | let rec par_insert_node ?(threshold=8) ~pool ~max_children (t: 'a Sequential.node) (batch: (V.t * 'a) array) start stop = 535 | if stop <= start 536 | then t.min_child_capacity 537 | else if t.leaf || (stop - start) < threshold then begin 538 | for i = start to stop - 1 do 539 | let key,vl = batch.(i) in 540 | ignore (Sequential.insert_node ~max_children t key vl) 541 | done; 542 | t.min_child_capacity 543 | end else begin 544 | t.no_elements <- t.no_elements + stop - start; 545 | let sub_intervals = Finite_vector.init ~capacity:(2 * max_children) () in 546 | let sub_interval_size i = 547 | let (start,stop) = sub_intervals.!(i) in 548 | stop - start in 549 | 550 | let last_sub_interval_end = ref start in 551 | 552 | (* partition batch by children *) 553 | for i = 0 to Finite_vector.length t.keys - 1 do 554 | let interval_start = !last_sub_interval_end in 555 | while !last_sub_interval_end < stop && 556 | V.compare (fst batch.(!last_sub_interval_end)) t.keys.!(i) < 0 do 557 | incr last_sub_interval_end 558 | done; 559 | Finite_vector.insert sub_intervals i (interval_start, !last_sub_interval_end) 560 | done; 561 | Finite_vector.insert sub_intervals (Finite_vector.length t.keys) (!last_sub_interval_end, stop); 562 | 563 | (* iterate through sub-intervals, and calculate number of splits that would be needed: *) 564 | let no_splits = ref 0 in 565 | for i = 0 to Finite_vector.length sub_intervals - 1 do 566 | if t.children.!(i).capacity < sub_interval_size i then 567 | incr no_splits; 568 | done; 569 | (* now, as splitting children requires ownership of the whole node, we handle all splitting first *) 570 | let current_sub_interval = ref 0 in 571 | while !no_splits > 0 do 572 | (* skip over sub_intervals that are within capacity *) 573 | while t.children.!(!current_sub_interval).capacity >= sub_interval_size !current_sub_interval do 574 | incr current_sub_interval 575 | done; 576 | 577 | (* found a sub interval that is over-capacity *) 578 | while t.children.!(!current_sub_interval).capacity < sub_interval_size !current_sub_interval do 579 | 580 | let (start,stop) = sub_intervals.!(!current_sub_interval) in 581 | (* if current sub-interval's node is full *) 582 | if 2 * max_children - 1 = t.children.!(!current_sub_interval).n 583 | then begin 584 | (* split the child *) 585 | Sequential.split_child t !current_sub_interval; 586 | (* re-calculate interval, and interval for new child *) 587 | let new_stop_interval = ref start in 588 | while !new_stop_interval < stop && 589 | V.compare (fst batch.(!new_stop_interval)) t.keys.!(!current_sub_interval) < 0 do 590 | incr new_stop_interval 591 | done; 592 | (* update intervals *) 593 | Finite_vector.set sub_intervals !current_sub_interval (start, !new_stop_interval); 594 | Finite_vector.insert sub_intervals (!current_sub_interval + 1) (!new_stop_interval, stop); 595 | (* update no splits: new child may also be over capacity *) 596 | if t.children.!(!current_sub_interval + 1).capacity < sub_interval_size (!current_sub_interval + 1) then 597 | incr no_splits 598 | end else if t.children.!(!current_sub_interval).capacity > 0 then begin 599 | let to_insert = t.children.!(!current_sub_interval).capacity in 600 | let min_capacity = 601 | par_insert_node ~threshold ~pool ~max_children 602 | t.children.!(!current_sub_interval) batch 603 | start (start + to_insert) in 604 | Finite_vector.set sub_intervals !current_sub_interval (start + to_insert, stop); 605 | t.min_child_capacity <- min min_capacity t.min_child_capacity; 606 | t.capacity <- 607 | (2 * max_children - 1 - t.n) * (t.min_child_capacity + 1) + t.min_child_capacity 608 | end else begin 609 | let (key,vl) = batch.(start) in 610 | (* otherwise, just insert the current element *) 611 | let min_capacity = 612 | Sequential.insert_node ~max_children 613 | t.children.!(!current_sub_interval) key vl in 614 | (* update the interval to track the fact that the start no longer needs to be inserted *) 615 | Finite_vector.set sub_intervals !current_sub_interval (start + 1, stop); 616 | (* update capacity *) 617 | t.min_child_capacity <- min min_capacity t.min_child_capacity; 618 | t.capacity <- 619 | (2 * max_children - 1 - t.n) * (t.min_child_capacity + 1) + t.min_child_capacity; 620 | end 621 | done; 622 | (* we have successfully dispatched one of the splits *) 623 | decr no_splits; 624 | done; 625 | 626 | (* now, all splits are done, do all in parallel! *) 627 | let min_child_capacity = 628 | Domainslib.Task.parallel_for_reduce pool ~start:0 ~finish:(Finite_vector.length sub_intervals - 1) ~body:(fun i -> 629 | let start,stop = sub_intervals.!(i) in 630 | par_insert_node ~pool ~max_children t.children.!(i) batch start stop 631 | ) min t.min_child_capacity in 632 | t.min_child_capacity <- min t.min_child_capacity min_child_capacity; 633 | t.capacity <- (2 * max_children - 1 - t.n) * (t.min_child_capacity + 1) + t.min_child_capacity; 634 | 635 | t.capacity 636 | end 637 | 638 | let rec par_insert ?threshold ~pool (t: 'a t) (batch: (V.t * 'a) array) start stop = 639 | let n = stop - start in 640 | if n <= 0 (* a) we are finished inserting *) 641 | then () 642 | else if t.root.leaf 643 | then begin 644 | let key,vl = batch.(start) in 645 | Sequential.insert t key vl; 646 | par_insert ?threshold ~pool t batch (start + 1) stop 647 | end 648 | else if n <= t.root.capacity (* b) we are inserting fewer elements than our capacity - good! let's go! *) 649 | then ignore (par_insert_node ?threshold ~pool ~max_children:t.max_children t.root batch start stop) 650 | else if 2 * t.max_children - 1 = t.root.n (* c) our root has reached max capacity - split! *) 651 | then begin 652 | let s = Sequential.{ 653 | n=0; 654 | leaf=false; 655 | keys=Finite_vector.init ~capacity:(2 * t.max_children - 1) (); 656 | children=Finite_vector.singleton ~capacity:(2 * t.max_children) (t.root); 657 | values=Finite_vector.init ~capacity:(2 * t.max_children - 1) (); 658 | no_elements=t.root.no_elements; 659 | capacity=0; 660 | min_child_capacity=t.root.min_child_capacity; 661 | } in 662 | t.root <- s; 663 | t.height <- t.height + 1; 664 | Sequential.split_child s 0; 665 | par_insert ?threshold ~pool t batch start stop 666 | end 667 | else if n = 1 668 | then ignore (Sequential.insert_node ~max_children:t.max_children t.root (fst batch.(start)) (snd batch.(start))) 669 | else begin (* d) insert as much as we can and repeat! *) 670 | assert (t.root.capacity > 0); 671 | let capacity = t.root.capacity in 672 | ignore (par_insert_node ?threshold ~pool ~max_children:t.max_children t.root batch start (start + capacity)); 673 | par_insert ?threshold ~pool t batch (start + capacity) stop 674 | end 675 | 676 | let par_insert ?threshold ?(can_rebuild=true) ~pool t batch = 677 | let threshold = match threshold with Some _ -> threshold | None -> !btree_insert_sequential_threshold in 678 | if Array.length batch > 0 && (Array.length batch > t.Sequential.root.no_elements) && can_rebuild 679 | then begin 680 | let height, root = par_rebuild ~pool ~max_children:t.Sequential.max_children t.root batch in 681 | t.Sequential.root <- root; 682 | t.Sequential.height <- height; 683 | end 684 | else par_insert ?threshold ~pool t batch 0 (Array.length batch) 685 | 686 | let run (type a) (t: a t) (pool: Domainslib.Task.pool) (ops: a wrapped_op array) : unit = 687 | let searches : (V.t * (a option -> unit)) list ref = ref [] in 688 | let inserts : (V.t * a) list ref = ref [] in 689 | let start_size = t.root.no_elements in 690 | Array.iter (fun (elt: a wrapped_op) -> match elt with 691 | | Mk (Insert (key,vl), kont) -> kont (); inserts := (key,vl) :: !inserts 692 | | Mk (Search key, kont) -> searches := (key, kont) :: !searches 693 | | Mk (Size,kont) -> kont start_size 694 | ) ops; 695 | let searches = Array.of_list !searches in 696 | if Array.length searches > 0 then 697 | par_search ~pool t searches; 698 | let inserts = Array.of_list !inserts in 699 | if Array.length inserts > 0 then begin 700 | Sort.sort pool ~compare:(fun (k1,_) (k2,_) -> V.compare k1 k2) 701 | inserts; 702 | par_insert ~pool t inserts 703 | end 704 | 705 | end 706 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (libraries domainslib unix batteries) 3 | (public_name obatcher_ds) 4 | (name obatcher_ds) 5 | (modes native)) 6 | -------------------------------------------------------------------------------- /lib/finite_vector.ml: -------------------------------------------------------------------------------- 1 | type 'a data = 2 | | Empty of int 3 | | Buf of 'a array 4 | 5 | let capacity = function Empty n -> n | Buf a -> Array.length a 6 | 7 | type 'a t = { mutable size: int; mutable buf: 'a data } 8 | 9 | let length t = t.size 10 | 11 | let pp f fmt t = 12 | match t.buf with 13 | | Empty cap -> Format.fprintf fmt "[| %s |]" (String.concat "; " (List.init cap (fun _ -> "_"))) 14 | | Buf arr -> 15 | Format.fprintf fmt "[| %a |]" 16 | (Format.pp_print_list ~pp_sep:(fun fmt _ -> Format.fprintf fmt "; ") 17 | (fun fmt -> function None -> Format.fprintf fmt "_" 18 | | Some vl -> f fmt vl)) 19 | (List.init (Array.length arr) (fun i -> if i < t.size then Some arr.(i) else None)) 20 | 21 | let init ?(capacity=8) () = {size=0; buf=Empty capacity} 22 | 23 | let init_with ?(capacity=8) n f = 24 | let capacity = max n capacity in 25 | let n = max n 0 in 26 | if n = 0 then {size=0; buf=Empty capacity} 27 | else 28 | let saved = ref None in 29 | let arr = Array.init capacity (fun i -> 30 | if i = n - 1 31 | then (let res = f i in saved := Some res; res) 32 | else if i < n 33 | then f i 34 | else Option.get !saved 35 | ) in 36 | {size=n; buf=Buf arr} 37 | 38 | let singleton ?(capacity=8) v = {size=1; buf=Buf (Array.make capacity v)} 39 | 40 | let to_array t = match t.buf with Empty _ -> [| |] | Buf a -> Array.sub a 0 t.size 41 | 42 | let get t i = 43 | if t.size <= i then 44 | invalid_arg "invalid index for dereference"; 45 | match t.buf with 46 | | Empty _ -> failwith "found empty buf" 47 | | Buf arr -> arr.(i) 48 | 49 | let set t i vl = 50 | if t.size <= i then 51 | invalid_arg "invalid index for dereference"; 52 | match t.buf with 53 | | Empty _ -> failwith "found empty buf" 54 | | Buf arr -> arr.(i) <- vl 55 | 56 | 57 | let fold_left f x a = 58 | match a.buf with 59 | | Empty _ -> x 60 | | Buf arr -> 61 | let r = ref x in 62 | for i = 0 to a.size - 1 do 63 | r := f !r (Array.unsafe_get arr i) 64 | done; 65 | !r 66 | 67 | let iter f a = 68 | match a.buf with 69 | | Empty _ -> () 70 | | Buf arr -> 71 | for i = 0 to a.size - 1 do 72 | f (Array.unsafe_get arr i) 73 | done 74 | 75 | let split_from t index = 76 | if t.size < index || index < 0 then 77 | invalid_arg "splitting by invalid index"; 78 | match t.buf with 79 | | Empty n -> {size=0; buf=Empty n} 80 | | Buf arr -> 81 | let new_arr = (Array.init (Array.length arr) (fun i -> 82 | if index + i < t.size 83 | then arr.(index + i) 84 | else arr.(t.size - 1) 85 | )) in 86 | let upper_buffer = { 87 | size=(t.size - index); 88 | buf=Buf new_arr 89 | } in 90 | t.size <- index; 91 | upper_buffer 92 | 93 | let drop_last t = 94 | if t.size <= 0 then 95 | invalid_arg "attempt to drop last on empty array"; 96 | if t.size > 1 then begin 97 | match t.buf with 98 | | Empty _ -> assert false 99 | | Buf arr -> 100 | arr.(t.size - 1) <- arr.(t.size - 2) 101 | end; 102 | t.size <- t.size - 1 103 | 104 | let insert t i vl = 105 | if t.size >= capacity t.buf then 106 | failwith "out of capacity"; 107 | if i >= t.size + 1 then 108 | invalid_arg "invalid index for insert"; 109 | match t.buf with 110 | | Empty cap -> 111 | let arr = Array.make cap vl in 112 | t.size <- i + 1; 113 | t.buf <- Buf arr 114 | | Buf arr -> 115 | for j = t.size downto i + 1 do 116 | arr.(j) <- arr.(j - 1); 117 | done; 118 | t.size <- t.size + 1; 119 | arr.(i) <- vl 120 | 121 | let clip t i = 122 | if i > t.size then 123 | invalid_arg "attempt to clip larger than size"; 124 | if i < 0 then 125 | invalid_arg "invalid clip size less than 0"; 126 | match t.buf with 127 | | Empty _ -> () 128 | | Buf arr -> 129 | if i > 0 then begin 130 | for j = i to t.size do 131 | arr.(j) <- arr.(j-1) 132 | done; 133 | t.size <- i 134 | end else begin 135 | t.buf <- Empty (Array.length arr); 136 | t.size <- 0 137 | end 138 | 139 | 140 | -------------------------------------------------------------------------------- /lib/sort.ml: -------------------------------------------------------------------------------- 1 | module T = Domainslib.Task 2 | 3 | let bubble_sort_threshold = 32 4 | 5 | let bubble_sort ~compare (a : 'a array) start limit = 6 | for i = start to limit - 2 do 7 | for j = i + 1 to limit - 1 do 8 | if compare a.(j) a.(i) < 0 then 9 | let t = a.(i) in 10 | a.(i) <- a.(j); 11 | a.(j) <- t; 12 | done 13 | done 14 | 15 | let merge ~compare (src : 'a array) dst start split limit = 16 | let rec loop dst_pos i j = 17 | if i = split then 18 | Array.blit src j dst dst_pos (limit - j) 19 | else if j = limit then 20 | Array.blit src i dst dst_pos (split - i) 21 | else if compare src.(i) src.(j) <= 0 then begin 22 | dst.(dst_pos) <- src.(i); 23 | loop (dst_pos + 1) (i + 1) j; 24 | end else begin 25 | dst.(dst_pos) <- src.(j); 26 | loop (dst_pos + 1) i (j + 1); 27 | end in 28 | loop start start split 29 | 30 | let rec merge_sort pool ~compare move a b start limit = 31 | if move || limit - start > bubble_sort_threshold then 32 | let split = (start + limit) / 2 in 33 | let r1 = T.async pool (fun () -> merge_sort pool ~compare (not move) a b start split) in 34 | let r2 = T.async pool (fun () -> merge_sort pool ~compare (not move) a b split limit) in 35 | T.await pool r1; 36 | T.await pool r2; 37 | if move then merge ~compare a b start split limit else merge ~compare b a start split limit 38 | else bubble_sort ~compare a start limit 39 | 40 | let sort pool ~compare a = 41 | let b = Array.copy a in 42 | merge_sort pool ~compare false a b 0 (Array.length a) -------------------------------------------------------------------------------- /lib/treap.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-32-26"] 2 | let treap_insert_sequential_threshold = ref 128 3 | let treap_insert_height_threshold = ref 7 4 | let treap_search_sequential_threshold = ref 100 5 | let treap_search_height_threshold = ref 6 6 | let treap_binary_search_threshold = ref 50 7 | 8 | let treap_insert_type = ref 1 9 | (* 10 | 0: parallelise equal sub-batches, split tree accordingly 11 | 1: always split at root node, binary search in insert array 12 | 2: always split at root node, linear search in insert array 13 | 3: always split at root node, binary & linear search in insert array 14 | *) 15 | 16 | let treap_search_type = ref 2 17 | (* 18 | 0: parallelise all queries, start at root node 19 | 1: parallelise equal sub-batches, start at root node 20 | 2: always split at root node, binary search in search array 21 | 3: always split at root node, linear search in search array 22 | 4: always split at root node, binary & linear search in search array 23 | *) 24 | 25 | module Make (V: Map.OrderedType) = struct 26 | module Sequential = struct 27 | type 'a node = Leaf | Node of { 28 | mutable key: V.t; 29 | mutable nval: 'a; 30 | mutable priority: int; 31 | mutable parent: 'a node; 32 | mutable left: 'a node; 33 | mutable right: 'a node 34 | } 35 | 36 | type 'a tree = { 37 | mutable root: 'a node 38 | } 39 | 40 | type side = Left | Right 41 | 42 | let key n = 43 | match n with 44 | | Leaf -> failwith "Key function: n is a leaf" 45 | | Node n' -> n'.key 46 | 47 | let priority n = 48 | match n with 49 | | Leaf -> 0 50 | | Node n' -> n'.priority 51 | 52 | let left n = 53 | match n with 54 | | Leaf -> failwith "Left function: n is a leaf" 55 | | Node n' -> n'.left 56 | 57 | let right n = 58 | match n with 59 | | Leaf -> failwith "Right function: n is a leaf" 60 | | Node n' -> n'.right 61 | 62 | let parent n = 63 | match n with 64 | | Leaf -> failwith "Parent function: n is a leaf" 65 | | Node n' -> n'.parent 66 | 67 | let nval n = 68 | match n with 69 | | Leaf -> failwith "Value function: n is a leaf" 70 | | Node n' -> n'.nval 71 | 72 | let set_parent n p = 73 | match n with 74 | | Leaf -> () 75 | | Node n' -> n'.parent <- p 76 | 77 | let set_child n s c = 78 | match n with 79 | | Leaf -> () 80 | | Node n' -> 81 | match s with 82 | | Left -> (set_parent c n; n'.left <- c) 83 | | Right -> (set_parent c n; n'.right <- c) 84 | 85 | let expose n = 86 | match n with 87 | | Leaf -> failwith "Expose function: n is a leaf" 88 | | Node n' -> 89 | set_parent n'.left Leaf; 90 | set_parent n'.right Leaf; 91 | let l = n'.left in 92 | let r = n'.right in 93 | set_child n Left Leaf; 94 | set_child n Right Leaf; 95 | (l, n, r) 96 | 97 | let merge_three_nodes nl n nr = 98 | match n with 99 | | Leaf -> failwith "Merge three nodes function: n is a leaf" 100 | | Node _ -> 101 | set_child n Left nl; 102 | set_child n Right nr 103 | 104 | let root_node t = t.root 105 | 106 | let num_nodes t = 107 | let rec aux n = 108 | match n with 109 | | Leaf -> 0 110 | | Node n' -> 1 + aux n'.left + aux n'.right in 111 | aux t.root 112 | 113 | let flatten t = 114 | let rec flatten_aux n = 115 | match n with 116 | | Leaf -> [] 117 | | Node n' -> (flatten_aux n'.left) @ [(n'.key, n'.nval)] @ (flatten_aux n'.right) in 118 | flatten_aux t.root 119 | 120 | let new_node k v = 121 | Node { 122 | key = k; 123 | nval = v; 124 | priority = Random.int @@ (Int.shift_left 1 30) - 1; 125 | parent = Leaf; 126 | left = Leaf; 127 | right = Leaf 128 | } 129 | 130 | let new_tree () = {root = Leaf} 131 | 132 | let new_tree_with_node n = {root = n} 133 | 134 | let rec search_aux k n = 135 | match n with 136 | | Leaf -> None 137 | | Node n' -> 138 | if k == n'.key then Some n'.nval 139 | else if k > n'.key then search_aux k n'.right 140 | else search_aux k n'.left 141 | 142 | let search k t = search_aux k t.root 143 | 144 | let rotate_left x t = 145 | let y = right x in 146 | set_child x Right (left y); 147 | if left y != Leaf then set_parent (left y) x; 148 | set_parent y (parent x); 149 | if parent x = Leaf then t.root <- y 150 | else if x == left @@ parent x then set_child (parent x) Left y 151 | else set_child (parent x) Right y; 152 | set_child y Left x 153 | 154 | let rotate_right x t = 155 | let y = left x in 156 | set_child x Left (right y); 157 | if right y != Leaf then set_parent (right y) x; 158 | set_parent y (parent x); 159 | if parent x = Leaf then t.root <- y 160 | else if x == right @@ parent x then set_child (parent x) Right y 161 | else set_child (parent x) Left y; 162 | set_child y Right x 163 | 164 | let rec rebalance n t = 165 | if n = Leaf then () else if parent n = Leaf then () else 166 | if priority n <= priority @@ parent n then () else 167 | if priority n > priority @@ parent n then begin 168 | if n == left @@ parent n then rotate_right (parent n) t 169 | else rotate_left (parent n) t; 170 | rebalance n t (* n is the "new" parent *) 171 | end 172 | 173 | let rec insert_aux new_node current_node t = 174 | if key new_node == key current_node then () 175 | else begin 176 | if key new_node < key current_node then begin 177 | if left current_node == Leaf then 178 | (set_child current_node Left new_node; rebalance new_node t) 179 | else insert_aux new_node (left current_node) t 180 | end 181 | else 182 | if right current_node == Leaf then 183 | (set_child current_node Right new_node; rebalance new_node t) 184 | else insert_aux new_node (right current_node) t 185 | end 186 | 187 | let insert k v t = 188 | let new_node = new_node k v in 189 | if t.root == Leaf then t.root <- new_node 190 | else insert_aux new_node t.root t 191 | 192 | let rec find_min_node n = 193 | match n with 194 | | Leaf -> failwith "Find min node function: n is a leaf" 195 | | Node n' -> 196 | if n'.left == Leaf then n 197 | else find_min_node (n'.left) 198 | 199 | let rec delete_aux current_node k t = 200 | if current_node == Leaf then () 201 | else if k < key current_node then 202 | delete_aux (left current_node) k t 203 | else if key current_node < k then 204 | delete_aux (right current_node) k t 205 | else begin 206 | let p = parent current_node in 207 | if left current_node = Leaf then 208 | (if p == Leaf then 209 | let (_, _, r) = expose current_node in 210 | t.root <- r 211 | else if right p == current_node then 212 | set_child p Right (right current_node) 213 | else 214 | set_child p Left (right current_node)) 215 | else if right current_node = Leaf then 216 | (if p == Leaf then 217 | let (l, _, _) = expose current_node in 218 | t.root <- l 219 | else if right p == current_node then 220 | set_child p Right (left current_node) 221 | else 222 | set_child p Left (left current_node)) 223 | else 224 | let min_node = find_min_node (right current_node) in 225 | match current_node with 226 | | Leaf -> failwith "impossible error" 227 | | Node n' -> 228 | n'.key <- key min_node; 229 | n'.nval <- nval min_node; 230 | delete_aux n'.right (key min_node) t 231 | end 232 | 233 | let delete k t = 234 | if t.root == Leaf then () 235 | else delete_aux t.root k t 236 | 237 | let rec join tl n tr = 238 | if priority n >= priority tl.root && priority n >= priority tr.root then 239 | (merge_three_nodes tl.root n tr.root; {root = n}) 240 | else begin 241 | if priority tl.root >= priority tr.root then 242 | let l1, n1, r1 = expose tl.root in 243 | let nt = join {root = r1} n tr in 244 | (merge_three_nodes l1 n1 nt.root; {root = n1}) 245 | else 246 | let l2, n2, r2 = expose tr.root in 247 | let nt = join tl n {root = l2} in 248 | (merge_three_nodes nt.root n2 r2; {root = n2}) 249 | end 250 | 251 | let rec split t k = 252 | if t.root = Leaf then ({root = Leaf}, Leaf, {root = Leaf}) 253 | else 254 | let (l, m, r) = expose t.root in 255 | if k = key m then ({root = l}, m, {root = r}) 256 | else if k < key m then 257 | let (ll, b, lr) = split {root = l} k in 258 | (ll, b, join lr m {root = r}) 259 | else 260 | let (rl, b, rr) = split {root = r} k in 261 | (join {root = l} m rl, b, rr) 262 | 263 | let rec verify_heap_property_aux n = 264 | match n with 265 | | Leaf -> true 266 | | Node n' -> if n'.priority > priority n'.left && n'.priority > priority n'.right then 267 | verify_heap_property_aux n'.left && verify_heap_property_aux n'.right 268 | else false 269 | 270 | let verify_heap_property t = verify_heap_property_aux t.root 271 | end 272 | 273 | type 'a t = 'a Sequential.tree 274 | 275 | type ('a, 'b) op = 276 | | Insert : V.t * 'a -> ('a, unit) op 277 | | Search : V.t -> ('a, 'a option) op 278 | 279 | type 'a wrapped_op = Mk : ('a, 'b) op * ('b -> unit) -> 'a wrapped_op 280 | 281 | let init () = Sequential.new_tree () 282 | 283 | let binary_search arr target left right = 284 | let left = ref left and right = ref right in 285 | let mid = ref @@ (!left + !right) / 2 in 286 | let found = ref false in 287 | while !left <= !right && not !found do 288 | mid := (!left + !right) / 2; 289 | let ck = fst arr.(!mid) in 290 | if ck = target then found := true 291 | else if ck < target then left := !mid + 1 292 | else right := !mid - 1 293 | done; 294 | if !found then !mid 295 | else if fst arr.(!left) >= target then !left 296 | else 0 297 | 298 | (** Use both binary search and linear search to traverse operations array *) 299 | let rec par_search_aux_4 op_threshold ~pool node ~keys ~range:(rstart, rstop) = 300 | let n = rstop - rstart in 301 | if n <= 0 then () 302 | else if node = Sequential.Leaf then 303 | for i = rstart to rstop - 1 do let (_,kont) = keys.(i) in kont None done 304 | else if n <= op_threshold then 305 | for i = rstart to rstop - 1 do let (k,kont) = keys.(i) in kont @@ Sequential.search_aux k node done 306 | else 307 | let k = Sequential.key node in 308 | let nval = Sequential.nval node in 309 | let s1 = ref rstart and s2 = ref rstart in 310 | if n > 200 then begin 311 | let split = binary_search keys k rstart rstop in 312 | s1 := split; s2 := split; 313 | while !s1 > rstart && fst keys.(!s1 - 1) = k do 314 | s1 := !s1 - 1; 315 | snd keys.(!s1) @@ Some nval; 316 | done; 317 | while !s2 < rstop && fst keys.(!s2) = k do 318 | snd keys.(!s2) @@ Some nval; 319 | s2 := !s2 + 1 320 | done; 321 | end 322 | else begin 323 | while !s1 < rstop && fst keys.(!s1) < k do s1 := !s1 + 1 done; 324 | s2 := !s1; 325 | while !s2 < rstop && fst keys.(!s2) = k do 326 | snd keys.(!s2) (Some nval); 327 | s2 := !s2 + 1 328 | done; 329 | end; 330 | let l = Domainslib.Task.async pool 331 | (fun () -> par_search_aux_4 op_threshold ~pool (Sequential.left node) ~keys ~range:(rstart, !s1)) in 332 | let r = Domainslib.Task.async pool 333 | (fun () -> par_search_aux_4 op_threshold ~pool (Sequential.right node) ~keys ~range:(!s2, rstop)) in 334 | Domainslib.Task.await pool l; Domainslib.Task.await pool r 335 | 336 | (* Split the search operations only *) 337 | let rec par_search_aux_1 threshold pool t ~keys ~range:(rstart, rstop) = 338 | let n = rstop - rstart in 339 | if n <= 0 then () 340 | else if n > threshold then 341 | let num_par = n / threshold + if n mod threshold > 0 then 1 else 0 in 342 | Domainslib.Task.parallel_for pool ~start:0 ~finish:(num_par - 1) ~body:(fun i -> 343 | par_search_aux_1 threshold pool t ~keys ~range:(rstart + i * threshold, min rstop @@ rstart + (i + 1) * threshold) 344 | ); 345 | else 346 | for i = rstart to rstop - 1 do 347 | let (k, kont) = keys.(i) in kont @@ Sequential.search k t 348 | done 349 | 350 | (** Use binary search only to traverse operations array *) 351 | let rec par_search_aux_2 op_threshold ~pool node ~keys ~range:(rstart, rstop) = 352 | let n = rstop - rstart in 353 | if n <= 0 then () 354 | else if node = Sequential.Leaf then 355 | for i = rstart to rstop - 1 do let (_,kont) = keys.(i) in kont None done 356 | else if n <= op_threshold then 357 | for i = rstart to rstop - 1 do let (k,kont) = keys.(i) in kont @@ Sequential.search_aux k node done 358 | else 359 | let k = Sequential.key node in 360 | let nval = Sequential.nval node in 361 | let split = binary_search keys k rstart rstop in 362 | let s1 = ref split and s2 = ref split in 363 | while !s1 > rstart && fst keys.(!s1 - 1) = k do 364 | s1 := !s1 - 1; 365 | snd keys.(!s1) @@ Some nval; 366 | done; 367 | while !s2 < rstop && fst keys.(!s2) = k do 368 | snd keys.(!s2) @@ Some nval; 369 | s2 := !s2 + 1 370 | done; 371 | let l = Domainslib.Task.async pool 372 | (fun () -> par_search_aux_2 op_threshold ~pool (Sequential.left node) ~keys ~range:(rstart, !s1)) in 373 | let r = Domainslib.Task.async pool 374 | (fun () -> par_search_aux_2 op_threshold ~pool (Sequential.right node) ~keys ~range:(!s2, rstop)) in 375 | Domainslib.Task.await pool l; Domainslib.Task.await pool r 376 | 377 | (** Use linear search only to traverse operations array *) 378 | let rec par_search_aux_3 op_threshold ~pool node ~keys ~range:(rstart, rstop) = 379 | let n = rstop - rstart in 380 | if n <= 0 then () 381 | else if node = Sequential.Leaf then 382 | for i = rstart to rstop - 1 do let (_,kont) = keys.(i) in kont None done 383 | else if n <= op_threshold then 384 | for i = rstart to rstop - 1 do let (k,kont) = keys.(i) in kont @@ Sequential.search_aux k node done 385 | else 386 | let k = Sequential.key node in 387 | let nval = Sequential.nval node in 388 | let s1 = ref rstart and s2 = ref rstart in 389 | while !s1 < rstop && fst keys.(!s1) < k do s1 := !s1 + 1 done; 390 | s2 := !s1; 391 | while !s2 < rstop && fst keys.(!s2) = k do 392 | snd keys.(!s2) (Some nval); 393 | s2 := !s2 + 1 394 | done; 395 | let l = Domainslib.Task.async pool 396 | (fun () -> par_search_aux_3 op_threshold ~pool (Sequential.left node) ~keys ~range:(rstart, !s1)) in 397 | let r = Domainslib.Task.async pool 398 | (fun () -> par_search_aux_3 op_threshold ~pool (Sequential.right node) ~keys ~range:(!s2, rstop)) in 399 | Domainslib.Task.await pool l; Domainslib.Task.await pool r 400 | 401 | let par_search ?search_threshold ~pool (t: 'a t) keys = 402 | let search_threshold = match search_threshold with Some t -> t | None -> !treap_search_sequential_threshold in 403 | Sort.sort pool ~compare:(fun (k, _) (k', _) -> V.compare k k') keys; 404 | match !treap_search_type with 405 | | 0 -> Domainslib.Task.parallel_for pool ~start:0 ~finish:(Array.length keys - 1) ~body:(fun i -> 406 | let (k,kont) = keys.(i) in 407 | kont @@ Sequential.search k t) 408 | | 1 -> par_search_aux_1 search_threshold pool t ~keys ~range:(0, Array.length keys) 409 | | 2 -> par_search_aux_2 search_threshold ~pool (Sequential.root_node t) ~keys ~range:(0, Array.length keys) 410 | | 3 -> par_search_aux_3 search_threshold ~pool (Sequential.root_node t) ~keys ~range:(0, Array.length keys) 411 | | 4 -> par_search_aux_4 search_threshold ~pool (Sequential.root_node t) ~keys ~range:(0, Array.length keys) 412 | | _ -> failwith "Invalid search type" 413 | 414 | (** Mix of binary and linear search in partitioning insert array *) 415 | let rec par_insert_aux_3 op_threshold ~pool (t: 'a t) ~inserts ~range:(rstart, rstop) = 416 | let n = rstop - rstart in 417 | if n <= 0 then () 418 | else if n <= op_threshold then 419 | for i = rstart to rstop - 1 do 420 | let (k, v) = inserts.(i) in 421 | Sequential.insert k v t 422 | done 423 | else 424 | let (ln, mn, rn) = Sequential.expose @@ Sequential.root_node t in 425 | let lt = Sequential.new_tree_with_node ln and rt = Sequential.new_tree_with_node rn in 426 | let s1 = ref rstart and s2 = ref rstart in 427 | if n > !treap_binary_search_threshold then begin 428 | let k = Sequential.key mn in 429 | let split = binary_search inserts k rstart rstop in 430 | s1 := split; s2 := split; 431 | while !s1 > rstart && fst inserts.(!s1 - 1) = k do s1 := !s1 - 1 done; 432 | while fst inserts.(!s2) = k && !s2 >= rstop do s2 := !s2 + 1 done; 433 | end 434 | else begin 435 | while !s1 < rstop && fst inserts.(!s1) < Sequential.key mn do s1 := !s1 + 1 done; 436 | s2 := !s1; 437 | while !s2 < rstop && fst inserts.(!s2) = Sequential.key mn do s2 := !s2 + 1 done; 438 | end; 439 | let l = Domainslib.Task.async pool 440 | (fun () -> par_insert_aux_3 op_threshold ~pool lt ~inserts ~range:(rstart, !s1)) in 441 | let r = Domainslib.Task.async pool 442 | (fun () -> par_insert_aux_3 op_threshold ~pool rt ~inserts ~range:(!s2, rstop)) in 443 | Domainslib.Task.await pool l; Domainslib.Task.await pool r; 444 | let nt = Sequential.join lt mn rt in 445 | t.root <- nt.root 446 | 447 | (** Linear traversal of inserts *) 448 | let rec par_insert_aux_2 op_threshold ~pool (t: 'a t) ~inserts ~range:(rstart, rstop) = 449 | let n = rstop - rstart in 450 | if n <= 0 then () 451 | else if n <= op_threshold then 452 | for i = rstart to rstop - 1 do 453 | let (k, v) = inserts.(i) in 454 | Sequential.insert k v t 455 | done 456 | else 457 | let (ln, mn, rn) = Sequential.expose @@ Sequential.root_node t in 458 | let lt = {Sequential.root = ln} and rt = {Sequential.root = rn} in 459 | let mid1 = ref rstart in 460 | while !mid1 < rstop && fst inserts.(!mid1) < Sequential.key mn do mid1 := !mid1 + 1 done; 461 | let mid2 = ref !mid1 in 462 | while !mid2 < rstop && fst inserts.(!mid2) <= Sequential.key mn do mid2 := !mid2 + 1 done; 463 | let l = Domainslib.Task.async pool 464 | (fun () -> par_insert_aux_2 op_threshold ~pool lt ~inserts ~range:(rstart, !mid1)) in 465 | let r = Domainslib.Task.async pool 466 | (fun () -> par_insert_aux_2 op_threshold ~pool rt ~inserts ~range:(!mid2, rstop)) in 467 | Domainslib.Task.await pool l; Domainslib.Task.await pool r; 468 | let nt = Sequential.join lt mn rt in 469 | t.root <- nt.root 470 | 471 | (* Use binary search on the sorted inserts array *) 472 | let rec par_insert_aux_1 op_threshold ~pool (t: 'a t) ~inserts ~range:(rstart, rstop) = 473 | let n = rstop - rstart in 474 | if n <= 0 then () 475 | else if n <= op_threshold then 476 | for i = rstart to rstop - 1 do 477 | let (k, v) = inserts.(i) in 478 | Sequential.insert k v t 479 | done 480 | else 481 | let (ln, mn, rn) = Sequential.expose @@ Sequential.root_node t in 482 | let lt = Sequential.new_tree_with_node ln and rt = Sequential.new_tree_with_node rn in 483 | let k = Sequential.key mn in 484 | let split = binary_search inserts k rstart rstop in 485 | let s1 = ref split and s2 = ref split in 486 | while !s1 > rstart && fst inserts.(!s1 - 1) = k do s1 := !s1 - 1 done; 487 | while fst inserts.(!s2) = k && !s2 >= rstop do s2 := !s2 + 1 done; 488 | let l = Domainslib.Task.async pool 489 | (fun () -> par_insert_aux_1 op_threshold ~pool lt ~inserts ~range:(rstart, !s1)) in 490 | let r = Domainslib.Task.async pool 491 | (fun () -> par_insert_aux_1 op_threshold ~pool rt ~inserts ~range:(!s2, rstop)) in 492 | Domainslib.Task.await pool l; Domainslib.Task.await pool r; 493 | let nt = Sequential.join lt mn rt in 494 | t.root <- nt.root 495 | 496 | (** Split cleanly down the middle of the insertion array *) 497 | let rec par_insert_aux_0 threshold ~pool (t: 'a t) ~inserts ~range:(rstart, rstop) = 498 | let n = rstop - rstart in 499 | if n <= 0 then () 500 | else if n <= threshold then 501 | for i = rstart to rstop - 1 do 502 | let (k, v) = inserts.(i) in 503 | Sequential.insert k v t 504 | done 505 | else 506 | let mid = rstart + n / 2 in 507 | let (mk, nv) = inserts.(mid) in 508 | let (lt, mn, rt) = Sequential.split t mk in 509 | let nn = match mn with 510 | | Leaf -> Sequential.new_node mk nv 511 | | Node _ -> mn in 512 | let l = Domainslib.Task.async pool 513 | (fun () -> par_insert_aux_0 threshold ~pool lt ~inserts ~range:(rstart, mid)) in 514 | let r = Domainslib.Task.async pool 515 | (fun () -> par_insert_aux_0 threshold ~pool rt ~inserts ~range:(mid + 1, rstop)) in 516 | Domainslib.Task.await pool l; Domainslib.Task.await pool r; 517 | let (nlt, _, _) = Sequential.split lt (Sequential.key nn) in (* Make sure there's no duplicate *) 518 | let (_, _, nrt) = Sequential.split rt (Sequential.key nn) in 519 | let nt = Sequential.join lt nn rt in 520 | t.root <- nt.root 521 | 522 | let par_insert ?threshold ~pool (t: 'a t) inserts = 523 | let threshold = match threshold with Some t -> t | None -> !treap_insert_sequential_threshold in 524 | Sort.sort pool ~compare:(fun (k, _) (k', _) -> V.compare k k') inserts; 525 | match !treap_insert_type with 526 | | 0 -> par_insert_aux_0 threshold ~pool t ~inserts ~range:(0, Array.length inserts) 527 | | 1 -> par_insert_aux_1 threshold ~pool t ~inserts ~range:(0, Array.length inserts) 528 | | 2 -> par_insert_aux_2 threshold ~pool t ~inserts ~range:(0, Array.length inserts) 529 | | 3 -> par_insert_aux_3 threshold ~pool t ~inserts ~range:(0, Array.length inserts) 530 | | _ -> failwith "Invalid insert type" 531 | 532 | let run (type a) (t: a t) (pool: Domainslib.Task.pool) (ops: a wrapped_op array) = 533 | let searches: (V.t * (a option -> unit)) list ref = ref [] in 534 | let inserts: (V.t * a) list ref = ref [] in 535 | Array.iter (fun (elt: a wrapped_op) -> match elt with 536 | | Mk (Insert (key, vl), kont) -> kont (); inserts := (key,vl) :: !inserts 537 | | Mk (Search key, kont) -> searches := (key, kont) :: !searches 538 | ) ops; 539 | 540 | (* Initiate parallel searches *) 541 | let searches = Array.of_list !searches in 542 | if Array.length searches > 0 then 543 | par_search ~pool t searches; 544 | 545 | (* Initiate parallel inserts *) 546 | let inserts = Array.of_list !inserts in 547 | if Array.length inserts > 0 then begin 548 | Sort.sort pool ~compare:(fun (k1,_) (k2,_) -> V.compare k1 k2) inserts; 549 | par_insert ~pool t inserts 550 | end 551 | 552 | end -------------------------------------------------------------------------------- /obatcher_ds.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "A short synopsis" 4 | description: "A longer description" 5 | maintainer: ["Maintainer Name"] 6 | authors: ["Author Name"] 7 | license: "LICENSE" 8 | tags: ["topics" "to describe" "your" "project"] 9 | homepage: "https://github.com/username/reponame" 10 | doc: "https://url/to/documentation" 11 | bug-reports: "https://github.com/username/reponame/issues" 12 | depends: [ 13 | "ocaml" 14 | "dune" {>= "3.10"} 15 | "domainslib" 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/username/reponame.git" 33 | -------------------------------------------------------------------------------- /requirements.txt: -------------------------------------------------------------------------------- 1 | pandas 2 | matplotlib 3 | tqdm 4 | jupyter -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (libraries obatcher_ds) 3 | (name test_avltree) 4 | (modules test_avltree)) 5 | 6 | (test 7 | (libraries obatcher_ds) 8 | (name test_rbtree) 9 | (modules test_rbtree)) 10 | 11 | (test 12 | (libraries obatcher_ds) 13 | (name test_treap) 14 | (modules test_treap)) -------------------------------------------------------------------------------- /test/test_avltree.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-32-26"] 2 | module IntAvltree = Obatcher_ds.Avltree.Make(Int);; 3 | let num_nodes = 10000000;; 4 | let max_key = num_nodes;; 5 | Printf.printf "\nTesting AVL tree with max %d nodes...\n" num_nodes;; 6 | 7 | 8 | Printf.printf "\nStarting join test for AVL...\n";; 9 | let ref_array_2 = Array.make max_key @@ -1;; 10 | let pivot = 1 + Random.full_int (max_key - 1);; 11 | Printf.printf "Pivot: %d\n" pivot;; 12 | 13 | let st = Sys.time();; 14 | let at1 = IntAvltree.Sequential.new_tree ();; 15 | let () = for _ = 1 to Random.full_int num_nodes do 16 | let k = Random.full_int pivot in 17 | let v = Random.full_int max_key in 18 | IntAvltree.Sequential.insert k v at1; 19 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 20 | done;; 21 | 22 | let at2 = IntAvltree.Sequential.new_tree ();; 23 | let () = for _ = 1 to Random.full_int num_nodes do 24 | let k = pivot + 1 + Random.full_int (max_key - pivot - 1) in 25 | let v = Random.full_int max_key in 26 | IntAvltree.Sequential.insert k v at2; 27 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 28 | done;; 29 | Printf.printf "Insertion time for AVL tree: %fs\n" (Sys.time() -. st);; 30 | 31 | let st = Sys.time();; 32 | assert (ref_array_2.(pivot) = -1);; 33 | assert (IntAvltree.Sequential.verify_height_invariant at1.root);; 34 | assert (IntAvltree.Sequential.verify_height_invariant at2.root);; 35 | let () = for i = 0 to pivot do 36 | if ref_array_2.(i) != -1 then 37 | assert (IntAvltree.Sequential.search i at1 = Some ref_array_2.(i)) 38 | done;; 39 | let () = for i = pivot + 1 to max_key - 1 do 40 | if ref_array_2.(i) != -1 then 41 | assert (IntAvltree.Sequential.search i at2 = Some ref_array_2.(i)) 42 | done;; 43 | Printf.printf "Verification time for AVL trees: %fs\n" (Sys.time() -. st);; 44 | 45 | let st = Sys.time();; 46 | let mn = IntAvltree.Sequential.new_node pivot 232;; 47 | let jt = IntAvltree.Sequential.join at1 mn at2;; 48 | Printf.printf "Join time for AVL trees: %fs\n" (Sys.time() -. st);; 49 | 50 | let st = Sys.time();; 51 | assert (IntAvltree.Sequential.verify_height_invariant jt.root);; 52 | let () = for i = 0 to max_key - 1 do 53 | if ref_array_2.(i) != -1 then 54 | assert (IntAvltree.Sequential.search i jt = Some ref_array_2.(i)) 55 | done;; 56 | Printf.printf "Verification time for joined AVL trees: %fs\n" (Sys.time() -. st);; 57 | 58 | 59 | Printf.printf "\nStarting split test for AVL trees...\n";; 60 | 61 | let at = IntAvltree.Sequential.new_tree ();; 62 | let ref_array_2 = Array.make max_key @@ -1;; 63 | 64 | let st = Sys.time();; 65 | let () = for _ = 1 to num_nodes / 2 do 66 | let k = Random.full_int (max_key / 2) in 67 | let v = Random.full_int (max_key / 2) in 68 | IntAvltree.Sequential.insert k v at; 69 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 70 | done;; 71 | 72 | let () = for _ = 1 to num_nodes / 2 do 73 | let k = Random.full_int (max_key / 2) + (max_key / 2)in 74 | let v = Random.full_int (max_key / 2) + (max_key / 2)in 75 | IntAvltree.Sequential.insert k v at; 76 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 77 | done;; 78 | Printf.printf "Insertion time for AVL tree: %fs\n" (Sys.time() -. st);; 79 | 80 | let st = Sys.time();; 81 | assert (IntAvltree.Sequential.verify_height_invariant at.root);; 82 | let () = for i = 1 to max_key - 1 do 83 | if ref_array_2.(i) != -1 then 84 | assert (IntAvltree.Sequential.search i at = Some ref_array_2.(i)) 85 | done;; 86 | Printf.printf "Verification time for AVL tree: %fs\n" (Sys.time() -. st);; 87 | 88 | let st = Sys.time();; 89 | let split_pt = Random.full_int max_key;; 90 | Printf.printf "Split at %d\n" split_pt;; 91 | let (lt, mn, rt) = IntAvltree.Sequential.split at (split_pt);; 92 | Printf.printf "Split time for AVL tree: %fs\n" (Sys.time() -. st);; 93 | 94 | let st = Sys.time();; 95 | assert (IntAvltree.Sequential.verify_height_invariant lt.root);; 96 | assert (IntAvltree.Sequential.verify_height_invariant rt.root);; 97 | let () = for i = 1 to split_pt - 1 do 98 | if ref_array_2.(i) != -1 then 99 | assert (IntAvltree.Sequential.search i lt = Some ref_array_2.(i)) 100 | done;; 101 | let () = for i = split_pt + 1 to max_key - 1 do 102 | if ref_array_2.(i) != -1 then 103 | assert (IntAvltree.Sequential.search i rt = Some ref_array_2.(i)) 104 | done;; 105 | assert (match mn with 106 | | IntAvltree.Sequential.Leaf -> ref_array_2.(split_pt) = -1 107 | | IntAvltree.Sequential.Node n' -> n'.nval = ref_array_2.(split_pt));; 108 | Printf.printf "Verification time for split AVL tree: %fs\n" (Sys.time() -. st);; 109 | 110 | 111 | Printf.printf "\nStarting deletion test for AVL...\n";; 112 | 113 | let at3 = IntAvltree.Sequential.new_tree ();; 114 | let ref_array_3 = Array.make max_key @@ -1;; 115 | let st = Sys.time();; 116 | let num_inserted = ref 0;; 117 | let () = for _ = 1 to max_key do 118 | let k = Random.full_int max_key in 119 | let v = Random.full_int max_key in 120 | IntAvltree.Sequential.insert k v at3; 121 | if ref_array_3.(k) == -1 then (ref_array_3.(k) <- v; num_inserted := !num_inserted + 1) 122 | done;; 123 | Printf.printf "Inserted %d elements into AVL tree\n" !num_inserted;; 124 | Printf.printf "Insertion time for AVL tree: %fs\n" (Sys.time() -. st);; 125 | 126 | let st = Sys.time();; 127 | let num_removed = ref 0;; 128 | let () = for k = 1 to max_key / 3 do 129 | IntAvltree.Sequential.delete k at3; 130 | if ref_array_3.(k) != -1 then (ref_array_3.(k) <- -1; num_removed := !num_removed + 1) 131 | done;; 132 | Printf.printf "Removed %d elements from AVL tree\n" !num_removed;; 133 | Printf.printf "Deletion time for AVL tree: %fs\n" (Sys.time() -. st);; 134 | 135 | let st = Sys.time();; 136 | assert (IntAvltree.Sequential.verify_height_invariant at3.root);; 137 | let num_found = ref 0;; 138 | let () = for i = 0 to max_key - 1 do 139 | if ref_array_3.(i) != -1 then 140 | (assert (IntAvltree.Sequential.search i at3 = Some ref_array_3.(i)); 141 | num_found := !num_found + 1) 142 | else 143 | assert (IntAvltree.Sequential.search i at3 = None) 144 | done;; 145 | Printf.printf "Found %d elements in AVL tree after deletion\n" !num_found;; 146 | Printf.printf "Verification time for AVL tree: %fs\n" (Sys.time() -. st);; -------------------------------------------------------------------------------- /test/test_rbtree.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-32-26"] 2 | module IntRbtree = Obatcher_ds.Rbtree.Make(Int);; 3 | let num_nodes = 10000000;; 4 | let max_key = num_nodes;; 5 | Printf.printf "\nTesting RB tree with max %d nodes...\n" num_nodes;; 6 | 7 | 8 | Printf.printf "\nStarting join test for RB tree...\n";; 9 | let ref_array_2 = Array.make max_key @@ -1;; 10 | let pivot = 1 + Random.full_int (max_key - 1);; 11 | Printf.printf "Pivot: %d\n" pivot;; 12 | 13 | let st = Sys.time();; 14 | let rbt1 = IntRbtree.Sequential.new_tree ();; 15 | let () = for _ = 1 to Random.full_int num_nodes do 16 | let k = Random.full_int pivot in 17 | let v = Random.full_int max_key in 18 | IntRbtree.Sequential.insert k v rbt1; 19 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 20 | done;; 21 | 22 | let rbt2 = IntRbtree.Sequential.new_tree ();; 23 | let () = for _ = 1 to Random.full_int num_nodes do 24 | let k = pivot + 1 + Random.full_int (max_key - pivot - 1) in 25 | let v = Random.full_int max_key in 26 | IntRbtree.Sequential.insert k v rbt2; 27 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 28 | done;; 29 | Printf.printf "Insertion time for RB tree: %fs\n" (Sys.time() -. st);; 30 | 31 | let st = Sys.time();; 32 | assert (ref_array_2.(pivot) = -1);; 33 | assert (IntRbtree.Sequential.verify_tree rbt1);; 34 | assert (IntRbtree.Sequential.verify_tree rbt2);; 35 | let () = for i = 0 to pivot do 36 | if ref_array_2.(i) != -1 then 37 | assert (IntRbtree.Sequential.search i rbt1 = Some ref_array_2.(i)) 38 | done;; 39 | let () = for i = pivot + 1 to max_key - 1 do 40 | if ref_array_2.(i) != -1 then 41 | assert (IntRbtree.Sequential.search i rbt2 = Some ref_array_2.(i)) 42 | done;; 43 | Printf.printf "Verification time for RB trees: %fs\n" (Sys.time() -. st);; 44 | 45 | (* IntRbtree.Sequential.traverse at1;; 46 | IntRbtree.Sequential.traverse at2;; *) 47 | 48 | let st = Sys.time();; 49 | let mn = IntRbtree.Sequential.new_node pivot 232;; 50 | let jt = IntRbtree.Sequential.join rbt1 mn rbt2;; 51 | Printf.printf "Join time for RB trees: %fs\n" (Sys.time() -. st);; 52 | 53 | (* IntRbtree.Sequential.traverse jt;; *) 54 | let st = Sys.time();; 55 | assert (IntRbtree.Sequential.verify_tree jt);; 56 | let () = for i = 0 to max_key - 1 do 57 | if ref_array_2.(i) != -1 then 58 | assert (IntRbtree.Sequential.search i jt = Some ref_array_2.(i)) 59 | done;; 60 | Printf.printf "Verification time for joined RB trees: %fs\n" (Sys.time() -. st);; 61 | 62 | 63 | Printf.printf "\nStarting split test for RB tree...\n";; 64 | let rbt = IntRbtree.Sequential.new_tree ();; 65 | let ref_array_1 = Array.make max_key @@ -1;; 66 | 67 | (* Insert elements *) 68 | let st = Sys.time();; 69 | let () = for _ = 1 to num_nodes do 70 | let k = Random.full_int max_key in 71 | let v = Random.full_int max_key in 72 | IntRbtree.Sequential.insert k v rbt; 73 | if ref_array_1.(k) == -1 then ref_array_1.(k) <- v 74 | done;; 75 | Printf.printf "Insertion time for RB tree: %fs\n" (Sys.time() -. st);; 76 | (* IntRbtree.Sequential.traverse rbt;; *) 77 | 78 | (* Verification of initial tree *) 79 | let st = Sys.time();; 80 | assert (let (b, _) = IntRbtree.Sequential.verify_black_depth rbt.root in b);; (* Check black depth *) 81 | assert (IntRbtree.Sequential.verify_internal_property rbt.root);; (* Check internal property *) 82 | let () = for i = 1 to max_key - 1 do (* Check whether all elements are inserted *) 83 | if ref_array_1.(i) != -1 then 84 | assert (IntRbtree.Sequential.search i rbt = Some ref_array_1.(i)) 85 | done;; 86 | Printf.printf "Verification time for RB tree: %fs\n" (Sys.time() -. st);; 87 | 88 | (* Splitting test *) 89 | let split_pt = Random.full_int max_key;; 90 | let st = Sys.time();; 91 | let (lt, mn, rt) = IntRbtree.Sequential.split rbt split_pt;; 92 | 93 | Printf.printf "Split time for RB tree: %fs\n" (Sys.time() -. st);; 94 | let st = Sys.time();; 95 | assert (IntRbtree.Sequential.verify_tree lt);; 96 | assert (IntRbtree.Sequential.verify_tree rt);; 97 | let () = for i = 1 to split_pt - 1 do 98 | if ref_array_1.(i) != -1 then 99 | assert (IntRbtree.Sequential.search i lt = Some ref_array_1.(i)) 100 | done;; 101 | let () = for i = split_pt + 1 to max_key - 1 do 102 | if ref_array_1.(i) != -1 then 103 | assert (IntRbtree.Sequential.search i rt = Some ref_array_1.(i)) 104 | done;; 105 | assert (match mn with 106 | | IntRbtree.Sequential.Leaf -> ref_array_1.(split_pt) = -1 107 | | IntRbtree.Sequential.Node n' -> n'.tval = ref_array_1.(split_pt));; 108 | Printf.printf "Verification time for split RB tree: %fs\n" (Sys.time() -. st);; 109 | 110 | 111 | Printf.printf "\nStarting deletion test for RB tree...\n";; 112 | let at3 = IntRbtree.Sequential.new_tree ();; 113 | let ref_array_3 = Array.make max_key @@ -1;; 114 | let st = Sys.time();; 115 | let num_inserted = ref 0;; 116 | let () = for _ = 1 to max_key do 117 | let k = Random.full_int max_key in 118 | let v = Random.full_int max_key in 119 | IntRbtree.Sequential.insert k v at3; 120 | if ref_array_3.(k) == -1 then (ref_array_3.(k) <- v; num_inserted := !num_inserted + 1) 121 | done;; 122 | Printf.printf "Inserted %d elements into RB tree\n" !num_inserted;; 123 | Printf.printf "Insertion time for RB tree: %fs\n" (Sys.time() -. st);; 124 | 125 | let st = Sys.time();; 126 | let num_removed = ref 0;; 127 | let () = for k = 1 to max_key / 3 do 128 | IntRbtree.Sequential.delete k at3; 129 | if ref_array_3.(k) != -1 then (ref_array_3.(k) <- -1; num_removed := !num_removed + 1) 130 | done;; 131 | Printf.printf "Removed %d elements from RB tree\n" !num_removed;; 132 | Printf.printf "Deletion time for RB tree: %fs\n" (Sys.time() -. st);; 133 | 134 | let st = Sys.time();; 135 | assert (IntRbtree.Sequential.verify_tree at3);; 136 | let num_found = ref 0;; 137 | let () = for i = 0 to max_key - 1 do 138 | if ref_array_3.(i) != -1 then 139 | (assert (IntRbtree.Sequential.search i at3 = Some ref_array_3.(i)); 140 | num_found := !num_found + 1) 141 | else 142 | assert (IntRbtree.Sequential.search i at3 = None) 143 | done;; 144 | Printf.printf "Found %d elements in RB tree after deletion\n" !num_found;; 145 | Printf.printf "Verification time for RB tree: %fs\n" (Sys.time() -. st);; -------------------------------------------------------------------------------- /test/test_treap.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-32-26"] 2 | module IntTreap = Obatcher_ds.Treap.Make(Int);; 3 | let num_nodes = 10000000;; 4 | let max_key = num_nodes;; 5 | Printf.printf "\nTesting Treap with max %d nodes...\n" num_nodes;; 6 | 7 | 8 | Printf.printf "\nStarting join test for Treap...\n";; 9 | let ref_array_2 = Array.make max_key @@ -1;; 10 | let pivot = 1 + Random.full_int (max_key - 1);; 11 | Printf.printf "Pivot: %d\n" pivot;; 12 | 13 | let st = Sys.time();; 14 | let at1 = IntTreap.Sequential.new_tree ();; 15 | let () = for _ = 1 to Random.full_int num_nodes do 16 | let k = Random.full_int pivot in 17 | let v = Random.full_int max_key in 18 | IntTreap.Sequential.insert k v at1; 19 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 20 | done;; 21 | 22 | let at2 = IntTreap.Sequential.new_tree ();; 23 | let () = for _ = 1 to Random.full_int num_nodes do 24 | let k = pivot + 1 + Random.full_int (max_key - pivot - 1) in 25 | let v = Random.full_int max_key in 26 | IntTreap.Sequential.insert k v at2; 27 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 28 | done;; 29 | Printf.printf "Insertion time for Treap: %fs\n" (Sys.time() -. st);; 30 | 31 | let st = Sys.time();; 32 | assert (ref_array_2.(pivot) = -1);; 33 | assert (IntTreap.Sequential.verify_heap_property_aux at1.root);; 34 | assert (IntTreap.Sequential.verify_heap_property_aux at2.root);; 35 | let () = for i = 0 to pivot do 36 | if ref_array_2.(i) != -1 then 37 | assert (IntTreap.Sequential.search i at1 = Some ref_array_2.(i)) 38 | done;; 39 | let () = for i = pivot + 1 to max_key - 1 do 40 | if ref_array_2.(i) != -1 then 41 | assert (IntTreap.Sequential.search i at2 = Some ref_array_2.(i)) 42 | done;; 43 | Printf.printf "Verification time for Treaps: %fs\n" (Sys.time() -. st);; 44 | 45 | let st = Sys.time();; 46 | let mn = IntTreap.Sequential.new_node pivot 232;; 47 | let jt = IntTreap.Sequential.join at1 mn at2;; 48 | Printf.printf "Join time for Treaps: %fs\n" (Sys.time() -. st);; 49 | 50 | let st = Sys.time();; 51 | assert (IntTreap.Sequential.verify_heap_property_aux jt.root);; 52 | let () = for i = 0 to max_key - 1 do 53 | if ref_array_2.(i) != -1 then 54 | assert (IntTreap.Sequential.search i jt = Some ref_array_2.(i)) 55 | done;; 56 | Printf.printf "Verification time for joined Treaps: %fs\n" (Sys.time() -. st);; 57 | 58 | 59 | Printf.printf "\nStarting split test for Treaps...\n";; 60 | 61 | let at = IntTreap.Sequential.new_tree ();; 62 | let ref_array_2 = Array.make max_key @@ -1;; 63 | 64 | let st = Sys.time();; 65 | let () = for _ = 1 to num_nodes / 2 do 66 | let k = Random.full_int (max_key / 2) in 67 | let v = Random.full_int (max_key / 2) in 68 | IntTreap.Sequential.insert k v at; 69 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 70 | done;; 71 | 72 | let () = for _ = 1 to num_nodes / 2 do 73 | let k = Random.full_int (max_key / 2) + (max_key / 2)in 74 | let v = Random.full_int (max_key / 2) + (max_key / 2)in 75 | IntTreap.Sequential.insert k v at; 76 | if ref_array_2.(k) == -1 then ref_array_2.(k) <- v 77 | done;; 78 | Printf.printf "Insertion time for Treap: %fs\n" (Sys.time() -. st);; 79 | 80 | let st = Sys.time();; 81 | assert (IntTreap.Sequential.verify_heap_property_aux at.root);; 82 | let () = for i = 1 to max_key - 1 do 83 | if ref_array_2.(i) != -1 then 84 | assert (IntTreap.Sequential.search i at = Some ref_array_2.(i)) 85 | done;; 86 | Printf.printf "Verification time for Treap: %fs\n" (Sys.time() -. st);; 87 | 88 | let st = Sys.time();; 89 | let split_pt = Random.full_int max_key;; 90 | Printf.printf "Split at %d\n" split_pt;; 91 | let (lt, mn, rt) = IntTreap.Sequential.split at (split_pt);; 92 | Printf.printf "Split time for Treap: %fs\n" (Sys.time() -. st);; 93 | 94 | let st = Sys.time();; 95 | assert (IntTreap.Sequential.verify_heap_property_aux lt.root);; 96 | assert (IntTreap.Sequential.verify_heap_property_aux rt.root);; 97 | let () = for i = 1 to split_pt - 1 do 98 | if ref_array_2.(i) != -1 then 99 | assert (IntTreap.Sequential.search i lt = Some ref_array_2.(i)) 100 | done;; 101 | let () = for i = split_pt + 1 to max_key - 1 do 102 | if ref_array_2.(i) != -1 then 103 | assert (IntTreap.Sequential.search i rt = Some ref_array_2.(i)) 104 | done;; 105 | assert (match mn with 106 | | IntTreap.Sequential.Leaf -> ref_array_2.(split_pt) = -1 107 | | IntTreap.Sequential.Node n' -> n'.nval = ref_array_2.(split_pt));; 108 | Printf.printf "Verification time for split Treap: %fs\n" (Sys.time() -. st);; 109 | 110 | 111 | Printf.printf "\nStarting deletion test for Treap...\n";; 112 | let ref_array_3 = Array.make max_key @@ -1;; 113 | let st = Sys.time();; 114 | let at3 = IntTreap.Sequential.new_tree ();; 115 | let num_inserted = ref 0;; 116 | let () = for _ = 1 to max_key do 117 | let k = Random.full_int max_key in 118 | let v = Random.full_int max_key in 119 | IntTreap.Sequential.insert k v at3; 120 | if ref_array_3.(k) == -1 then (ref_array_3.(k) <- v; num_inserted := !num_inserted + 1) 121 | done;; 122 | Printf.printf "Inserted %d elements into Treap\n" !num_inserted;; 123 | Printf.printf "Insertion time for Treap: %fs\n" (Sys.time() -. st);; 124 | 125 | let st = Sys.time();; 126 | let num_removed = ref 0;; 127 | let () = for k = 1 to max_key / 3 do 128 | IntTreap.Sequential.delete k at3; 129 | if ref_array_3.(k) != -1 then (ref_array_3.(k) <- -1; num_removed := !num_removed + 1) 130 | done;; 131 | Printf.printf "Removed %d elements from Treap\n" !num_removed;; 132 | Printf.printf "Deletion time for Treap: %fs\n" (Sys.time() -. st);; 133 | 134 | let st = Sys.time();; 135 | assert (IntTreap.Sequential.verify_heap_property_aux at3.root);; 136 | let num_found = ref 0;; 137 | let () = for i = 0 to max_key - 1 do 138 | if ref_array_3.(i) != -1 then 139 | (assert (IntTreap.Sequential.search i at3 = Some ref_array_3.(i)); 140 | num_found := !num_found + 1) 141 | else 142 | assert (IntTreap.Sequential.search i at3 = None) 143 | done;; 144 | Printf.printf "Found %d elements in Treap after deletion\n" !num_found;; 145 | Printf.printf "Verification time for Treap: %fs\n" (Sys.time() -. st);; --------------------------------------------------------------------------------