From d286f3ad0e2709753a9c261b4931e8c3aba0512c Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 5 Aug 2024 21:17:08 +0200 Subject: [PATCH 1/2] Implement Rowex.remove and apply ocamlformat.0.26.2 --- .ocamlformat | 3 +- atomic/atomic.mli | 18 +- atomic/atomic_pre412.ml | 11 +- bench/bench_find.ml | 114 +- bench/bench_insert.ml | 79 +- bin/find.ml | 46 +- bin/insert.ml | 52 +- bin/make.ml | 54 +- bin/rwx.ml | 113 +- conf/atomic.ml | 3 +- conf/endian.ml | 10 +- conf/flush.ml | 47 +- conf/sse.ml | 68 +- fuzz/dune | 2 +- fuzz/fuzz.ml | 189 ++- fuzz/fuzz_rowex.ml | 114 +- fuzz/monolith.ml | 28 +- ipc/ipc.ml | 60 +- ipc/ipc.mli | 2 - lib/art.ml | 1027 ++++++------ lib/art.mli | 4 +- lib/dune | 2 +- lib/hashset.ml | 187 +-- lib/hashset.mli | 67 +- lib/mem.ml | 199 ++- lib/mem.mli | 4 +- lib/part.ml | 256 +-- lib/part.mli | 16 +- lib/persistent.ml | 565 ++++--- lib/persistent.mli | 24 +- lib/rowex.ml | 1901 +++++++++++++-------- lib/rowex.mli | 64 +- test/check.ml | 14 + test/fiber.ml | 174 +- test/fiber.mli | 14 - test/parallel_index.ml | 207 ++- test/persistent.ml | 3461 ++++++++++++++++++++------------------- test/ring.ml | 109 +- test/test.ml | 975 ++++++----- test/test_ring.ml | 33 +- test/tmp.ml | 54 +- test/tmp.mli | 3 +- 42 files changed, 5839 insertions(+), 4534 deletions(-) create mode 100644 test/check.ml diff --git a/.ocamlformat b/.ocamlformat index 4272785..1dfb748 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,2 +1 @@ -version=0.25.1 -disable=true +version=0.26.2 diff --git a/atomic/atomic.mli b/atomic/atomic.mli index 5a0d827..8dd164f 100644 --- a/atomic/atomic.mli +++ b/atomic/atomic.mli @@ -26,34 +26,34 @@ backward-compatible with older versions of OCaml without having to import additional compatibility layers. *) +type (* ! *) 'a t (** An atomic (mutable) reference to a value of type ['a]. *) -type (* ! *)'a t -(** Create an atomic reference. *) val make : 'a -> 'a t +(** Create an atomic reference. *) -(** Get the current value of the atomic reference. *) val get : 'a t -> 'a +(** Get the current value of the atomic reference. *) -(** Set a new value for the atomic reference. *) val set : 'a t -> 'a -> unit +(** Set a new value for the atomic reference. *) -(** Set a new value for the atomic reference, and return the current value. *) val exchange : 'a t -> 'a -> 'a +(** Set a new value for the atomic reference, and return the current value. *) +val compare_and_set : 'a t -> 'a -> 'a -> bool (** [compare_and_set r seen v] sets the new value of [r] to [v] only if its current value is physically equal to [seen] -- the comparison and the set occur atomically. Returns [true] if the comparison succeeded (so the set happened) and [false] otherwise. *) -val compare_and_set : 'a t -> 'a -> 'a -> bool +val fetch_and_add : int t -> int -> int (** [fetch_and_add r n] atomically increments the value of [r] by [n], and returns the current value (before the increment). *) -val fetch_and_add : int t -> int -> int -(** [incr r] atomically increments the value of [r] by [1]. *) val incr : int t -> unit +(** [incr r] atomically increments the value of [r] by [1]. *) -(** [decr r] atomically decrements the value of [r] by [1]. *) val decr : int t -> unit +(** [decr r] atomically decrements the value of [r] by [1]. *) diff --git a/atomic/atomic_pre412.ml b/atomic/atomic_pre412.ml index f9a289d..c673af9 100644 --- a/atomic/atomic_pre412.ml +++ b/atomic/atomic_pre412.ml @@ -17,9 +17,9 @@ external ( == ) : 'a -> 'a -> bool = "%eq" external ( + ) : int -> int -> int = "%addint" external ignore : 'a -> unit = "%ignore" -type 'a t = {mutable v: 'a} +type 'a t = { mutable v : 'a } -let make v = {v} +let make v = { v } let get r = r.v let set r v = r.v <- v @@ -36,14 +36,13 @@ let[@inline never] compare_and_set r seen v = if cur == seen then ( r.v <- v; (* END ATOMIC *) - true - ) else - false + true) + else false let[@inline never] fetch_and_add r n = (* BEGIN ATOMIC *) let cur = r.v in - r.v <- (cur + n); + r.v <- cur + n; (* END ATOMIC *) cur diff --git a/bench/bench_find.ml b/bench/bench_find.ml index 2b7f77c..92a5eb8 100644 --- a/bench/bench_find.ml +++ b/bench/bench_find.ml @@ -7,18 +7,19 @@ external random_seed : unit -> int array = "caml_sys_random_seed" let seed = "1NYFZiWgaFHf7EhBe6QhvABW5lKcCYs5vcnFi3YsqOU=" let seed = Base64.decode_exn seed + let seed = let res = Array.make (String.length seed / 2) 0 in - for i = 0 to (String.length seed / 2) - 1 - do res.(i) <- (Char.code seed.[i * 2] lsl 8) lor (Char.code seed.[i * 2 + 1]) done ; + for i = 0 to (String.length seed / 2) - 1 do + res.(i) <- (Char.code seed.[i * 2] lsl 8) lor Char.code seed.[(i * 2) + 1] + done; res let () = let random_seed = seed in Random.full_init random_seed -let ( <.> ) f g = fun x -> f (g x) - +let ( <.> ) f g x = f (g x) let random_max = 16. let random_normal n = @@ -27,55 +28,74 @@ let random_normal n = for i = 0 to (m / 2) - 1 do let x = ref 0. and y = ref 0. and rsq = ref 0. in while - x := (Random.float random_max /. random_max *. 2.0) -. 1. ; - y := (Random.float random_max /. random_max *. 2.0) -. 1. ; - rsq := (!x *. !x) +. (!y *. !y) ; + x := (Random.float random_max /. random_max *. 2.0) -. 1.; + y := (Random.float random_max /. random_max *. 2.0) -. 1.; + rsq := (!x *. !x) +. (!y *. !y); !rsq >= 1. || !rsq = 0. - do () done ; + do + () + done; let f = sqrt (-2.0 *. log !rsq /. !rsq) in - values.(i * 2) <- !x *. f ; + values.(i * 2) <- !x *. f; values.((i * 2) + 1) <- !y *. f - done ; + done; Array.map (abs <.> Float.to_int <.> ( *. ) random_max) values let random_string ln = let rs = Bytes.create ln in let ic = open_in "/dev/urandom" in - really_input ic rs 0 ln ; - close_in ic ; - for i = 0 to ln - 1 do if Bytes.get rs i = '\000' then Bytes.set rs i '\001' done ; + really_input ic rs 0 ln; + close_in ic; + for i = 0 to ln - 1 do + if Bytes.get rs i = '\000' then Bytes.set rs i '\001' + done; Bytes.unsafe_to_string rs -let db = Array.map (fun v -> random_string (succ v), v) (random_normal 1000) - +let db = Array.map (fun v -> (random_string (succ v), v)) (random_normal 1000) let art = Art.make () -let () = Array.iter - (fun (k, v) -> Art.insert art (Art.unsafe_key k) v ; - match Art.find art (Art.unsafe_key k) with - | v' -> assert (v = v') - | exception Not_found -> assert false) db + +let () = + Array.iter + (fun (k, v) -> + Art.insert art (Art.unsafe_key k) v; + match Art.find art (Art.unsafe_key k) with + | v' -> assert (v = v') + | exception Not_found -> assert false) + db let tbl = Hashtbl.create 0x100 let () = Array.iter (fun (k, v) -> Hashtbl.add tbl k v) db let test0 = - Test.make ~name:"art" @@ Staged.stage @@ fun () -> - Array.iter (fun (k, _) -> - let _ = Art.find art (Art.unsafe_key k) in ()) db + Test.make ~name:"art" @@ Staged.stage + @@ fun () -> + Array.iter + (fun (k, _) -> + let _ = Art.find art (Art.unsafe_key k) in + ()) + db let test1 = - Test.make ~name:"hashtbl" @@ Staged.stage @@ fun () -> - Array.iter (fun (k ,_) -> let _ = Hashtbl.find tbl k in ()) db + Test.make ~name:"hashtbl" @@ Staged.stage + @@ fun () -> + Array.iter + (fun (k, _) -> + let _ = Hashtbl.find tbl k in + ()) + db -let test = Test.make_grouped ~name:"find" [ test0; test1; ] +let test = Test.make_grouped ~name:"find" [ test0; test1 ] let benchmark () = let ols = - Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] in + Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] + in let instances = - Instance.[ minor_allocated; major_allocated; monotonic_clock ] in + Instance.[ minor_allocated; major_allocated; monotonic_clock ] + in let cfg = - Benchmark.cfg ~limit:3000 ~quota:(Time.second 2.0) ~kde:(Some 1000) () in + Benchmark.cfg ~limit:3000 ~quota:(Time.second 2.0) ~kde:(Some 1000) () + in let raw_results = Benchmark.all cfg instances test in let results = List.map (fun instance -> Analyze.all ols instance raw_results) instances @@ -93,21 +113,23 @@ let () = let results = benchmark () in match Sys.argv with | [| _; "cli" |] -> - let open Notty_unix in - List.iter - (fun v -> Bechamel_notty.Unit.add v (Measure.unit v)) - Instance.[ minor_allocated; major_allocated; monotonic_clock ] ; - let window = - match winsize Unix.stdout with - | Some (w, h) -> { Bechamel_notty.w; h } - | None -> { Bechamel_notty.w = 80; h = 1 } in - let results, _ = benchmark () in - img (window, results) |> eol |> output_image + let open Notty_unix in + List.iter + (fun v -> Bechamel_notty.Unit.add v (Measure.unit v)) + Instance.[ minor_allocated; major_allocated; monotonic_clock ]; + let window = + match winsize Unix.stdout with + | Some (w, h) -> { Bechamel_notty.w; h } + | None -> { Bechamel_notty.w = 80; h = 1 } + in + let results, _ = benchmark () in + img (window, results) |> eol |> output_image | [| _; "json" |] | _ -> - let results = - let open Bechamel_js in - emit ~dst:(Channel stdout) nothing ~compare:String.compare ~x_label:Measure.run - ~y_label:(Measure.label Instance.monotonic_clock) - results in - Rresult.R.failwith_error_msg results - + let results = + let open Bechamel_js in + emit ~dst:(Channel stdout) nothing ~compare:String.compare + ~x_label:Measure.run + ~y_label:(Measure.label Instance.monotonic_clock) + results + in + Rresult.R.failwith_error_msg results diff --git a/bench/bench_insert.ml b/bench/bench_insert.ml index 1dcbb1b..061fef1 100644 --- a/bench/bench_insert.ml +++ b/bench/bench_insert.ml @@ -1,8 +1,7 @@ open Bechamel open Toolkit -let ( <.> ) f g = fun x -> f (g x) - +let ( <.> ) f g x = f (g x) let random_max = 32767. let random_normal n = @@ -11,46 +10,55 @@ let random_normal n = for i = 0 to (m / 2) - 1 do let x = ref 0. and y = ref 0. and rsq = ref 0. in while - x := (Random.float random_max /. random_max *. 2.0) -. 1. ; - y := (Random.float random_max /. random_max *. 2.0) -. 1. ; - rsq := (!x *. !x) +. (!y *. !y) ; + x := (Random.float random_max /. random_max *. 2.0) -. 1.; + y := (Random.float random_max /. random_max *. 2.0) -. 1.; + rsq := (!x *. !x) +. (!y *. !y); !rsq >= 1. || !rsq = 0. - do () done ; + do + () + done; let f = sqrt (-2.0 *. log !rsq /. !rsq) in - values.(i * 2) <- !x *. f ; + values.(i * 2) <- !x *. f; values.((i * 2) + 1) <- !y *. f - done ; + done; Array.map (abs <.> Float.to_int <.> ( *. ) random_max) values let random_string ln = let rs = Bytes.create ln in let ic = open_in "/dev/urandom" in - really_input ic rs 0 ln ; - close_in ic ; - for i = 0 to ln - 1 do if Bytes.get rs i = '\000' then Bytes.set rs i '\001' done ; + really_input ic rs 0 ln; + close_in ic; + for i = 0 to ln - 1 do + if Bytes.get rs i = '\000' then Bytes.set rs i '\001' + done; Bytes.unsafe_to_string rs -let db = Array.map (fun v -> random_string v, v) (random_normal 1000) +let db = Array.map (fun v -> (random_string v, v)) (random_normal 1000) let test0 = - Test.make ~name:"art" @@ Staged.stage @@ fun () -> + Test.make ~name:"art" @@ Staged.stage + @@ fun () -> let tree = Art.make () in Array.iter (fun (k, v) -> Art.insert tree (Art.unsafe_key k) v) db let test1 = - Test.make ~name:"hashtbl" @@ Staged.stage @@ fun () -> + Test.make ~name:"hashtbl" @@ Staged.stage + @@ fun () -> let tbl = Hashtbl.create 0x100 in Array.iter (fun (k, v) -> Hashtbl.add tbl k v) db -let test = Test.make_grouped ~name:"insert" [ test0; test1; ] +let test = Test.make_grouped ~name:"insert" [ test0; test1 ] let benchmark () = let ols = - Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] in + Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] + in let instances = - Instance.[ minor_allocated; major_allocated; monotonic_clock ] in + Instance.[ minor_allocated; major_allocated; monotonic_clock ] + in let cfg = - Benchmark.cfg ~limit:3000 ~quota:(Time.second 2.0) ~kde:(Some 1000) () in + Benchmark.cfg ~limit:3000 ~quota:(Time.second 2.0) ~kde:(Some 1000) () + in let raw_results = Benchmark.all cfg instances test in let results = List.map (fun instance -> Analyze.all ols instance raw_results) instances @@ -68,20 +76,23 @@ let () = let results = benchmark () in match Sys.argv with | [| _; "cli" |] -> - let open Notty_unix in - List.iter - (fun v -> Bechamel_notty.Unit.add v (Measure.unit v)) - Instance.[ minor_allocated; major_allocated; monotonic_clock ] ; - let window = - match winsize Unix.stdout with - | Some (w, h) -> { Bechamel_notty.w; h } - | None -> { Bechamel_notty.w = 80; h = 1 } in - let results, _ = benchmark () in - img (window, results) |> eol |> output_image + let open Notty_unix in + List.iter + (fun v -> Bechamel_notty.Unit.add v (Measure.unit v)) + Instance.[ minor_allocated; major_allocated; monotonic_clock ]; + let window = + match winsize Unix.stdout with + | Some (w, h) -> { Bechamel_notty.w; h } + | None -> { Bechamel_notty.w = 80; h = 1 } + in + let results, _ = benchmark () in + img (window, results) |> eol |> output_image | [| _; "json" |] | _ -> - let results = - let open Bechamel_js in - emit ~dst:(Channel stdout) nothing ~compare:String.compare ~x_label:Measure.run - ~y_label:(Measure.label Instance.monotonic_clock) - results in - Rresult.R.failwith_error_msg results + let results = + let open Bechamel_js in + emit ~dst:(Channel stdout) nothing ~compare:String.compare + ~x_label:Measure.run + ~y_label:(Measure.label Instance.monotonic_clock) + results + in + Rresult.R.failwith_error_msg results diff --git a/bin/find.ml b/bin/find.ml index 18e979f..377f8ff 100644 --- a/bin/find.ml +++ b/bin/find.ml @@ -3,15 +3,18 @@ open Rresult let reporter ppf = let report src level ~over k msgf = let k _ = - over () ; - k () in + over (); + k () + in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("%a[%a]: " ^^ fmt ^^ "\n%!") Logs_fmt.pp_header (level, header) Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in { Logs.report } type fmt = Fmt : string * (int -> unit, Format.formatter, unit) format -> fmt @@ -26,18 +29,21 @@ let find _ fmt path (key : Rowex.key) = let* () = open_index (reader uid) ~path:(Fpath.to_string path) in let* result = find key in let* () = close in - return result in + return result + in match Part.(run closed th0) with - | _closed, value -> show fmt value ; `Ok () + | _closed, value -> + show fmt value; + `Ok () | exception Not_found -> - `Error (false, Fmt.str "%S does not exists." (key :> string)) + `Error (false, Fmt.str "%S does not exists." (key :> string)) open Cmdliner let setup_logs style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer () ; - Logs.set_level level ; - Logs.set_reporter (reporter Fmt.stderr) ; + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (reporter Fmt.stderr); Option.is_none level let common_options = "COMMON OPTIONS" @@ -55,21 +61,24 @@ let setup_logs = Term.(const setup_logs $ renderer $ verbosity) let fmt = let parser str = try R.ok (Fmt (str, Scanf.format_from_string str "%d")) - with Scanf.Scan_failure _ -> R.error_msgf "Invalid format: %S" str in + with Scanf.Scan_failure _ -> R.error_msgf "Invalid format: %S" str + in let pp ppf (Fmt (str, _)) = Fmt.string ppf str in Arg.conv (parser, pp) let existing_file = - let parser str = match Fpath.of_string str with + let parser str = + match Fpath.of_string str with | Ok _ as v when Sys.file_exists str -> v | Ok v -> R.error_msgf "%a does not exist." Fpath.pp v - | Error _ as err -> err in + | Error _ as err -> err + in Arg.conv (parser, Fpath.pp) let key = let parser str = - try R.ok (Rowex.key str) - with _ -> R.error_msgf "Invalid key: %S" str in + try R.ok (Rowex.key str) with _ -> R.error_msgf "Invalid key: %S" str + in let pp : Rowex.key Fmt.t = fun ppf key -> Fmt.string ppf (key :> string) in Arg.conv (parser, pp) @@ -88,8 +97,11 @@ let key = let cmd = let doc = "A simple executable to search an occurence into a index file." in let man = - [ `S Manpage.s_description - ; `P "$(tname) searches for the value associated with the given key." ] in + [ + `S Manpage.s_description; + `P "$(tname) searches for the value associated with the given key."; + ] + in Cmd.v (Cmd.info "find" ~doc ~man) Term.(ret (const find $ setup_logs $ fmt $ file $ key)) diff --git a/bin/insert.ml b/bin/insert.ml index d83d130..0d9ed70 100644 --- a/bin/insert.ml +++ b/bin/insert.ml @@ -3,15 +3,18 @@ open Rresult let reporter ppf = let report src level ~over k msgf = let k _ = - over () ; - k () in + over (); + k () + in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("%a[%a]: " ^^ fmt ^^ "\n%!") Logs_fmt.pp_header (level, header) Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in { Logs.report } let insert _ path (key : Rowex.key) value = @@ -23,15 +26,20 @@ let insert _ path (key : Rowex.key) value = match res with | Ok () -> return (`Ok ()) | Error `Already_exists -> - return (`Error (false, Fmt.str "%S already exists into %a." (key :> string) Fpath.pp path)) in + return + (`Error + ( false, + Fmt.str "%S already exists into %a." (key :> string) Fpath.pp path + )) + in Part.(run closed th0) |> snd open Cmdliner let setup_logs style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer () ; - Logs.set_level level ; - Logs.set_reporter (reporter Fmt.stderr) ; + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (reporter Fmt.stderr); Option.is_none level let common_options = "COMMON OPTIONS" @@ -47,17 +55,19 @@ let renderer = let setup_logs = Term.(const setup_logs $ renderer $ verbosity) let existing_file = - let parser str = match Fpath.of_string str with - | Ok _ as v when Sys.file_exists str - && Sys.file_exists (str ^ ".socket") -> v + let parser str = + match Fpath.of_string str with + | Ok _ as v when Sys.file_exists str && Sys.file_exists (str ^ ".socket") -> + v | Ok v -> R.error_msgf "%a (or its socket) does not exist." Fpath.pp v - | Error _ as err -> err in + | Error _ as err -> err + in Arg.conv (parser, Fpath.pp) let key = let parser str = - try R.ok (Rowex.key str) - with _ -> R.error_msgf "Invalid key: %S" str in + try R.ok (Rowex.key str) with _ -> R.error_msgf "Invalid key: %S" str + in let pp : Rowex.key Fmt.t = fun ppf key -> Fmt.string ppf (key :> string) in Arg.conv (parser, pp) @@ -74,10 +84,18 @@ let value = Arg.(required & pos 2 (some int) None & info [] ~doc) let cmd = - let doc = "A simple executable to insert an occurence into a index file with a specific value." in + let doc = + "A simple executable to insert an occurence into a index file with a \ + specific value." + in let man = - [ `S Manpage.s_description - ; `P "$(tname) inserts a value associated with the given key into the given index." ] in + [ + `S Manpage.s_description; + `P + "$(tname) inserts a value associated with the given key into the given \ + index."; + ] + in Cmd.v (Cmd.info "insert" ~doc ~man) Term.(ret (const insert $ setup_logs $ file $ key $ value)) diff --git a/bin/make.ml b/bin/make.ml index 156d07d..324e090 100644 --- a/bin/make.ml +++ b/bin/make.ml @@ -3,37 +3,40 @@ open Rresult let reporter ppf = let report src level ~over k msgf = let k _ = - over () ; - k () in + over (); + k () + in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("%a[%a]: " ^^ fmt ^^ "\n%!") Logs_fmt.pp_header (level, header) Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in { Logs.report } let make _ path = let th0 = let open Part in - create (Fpath.to_string path) in + create (Fpath.to_string path) + in match Part.(run closed th0) with | _closed, Ok () -> `Ok () - | _closed, Error (`Msg err) -> - `Error (false, Fmt.str "%s." err) + | _closed, Error (`Msg err) -> `Error (false, Fmt.str "%s." err) | exception exn -> - Logs.err (fun m -> m "Got an error while creating %a: %s" - Fpath.pp path (Printexc.to_string exn)) ; - `Error (false, Fmt.str "Got an error while creating %a." - Fpath.pp path) + Logs.err (fun m -> + m "Got an error while creating %a: %s" Fpath.pp path + (Printexc.to_string exn)); + `Error (false, Fmt.str "Got an error while creating %a." Fpath.pp path) open Cmdliner let setup_logs style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer () ; - Logs.set_level level ; - Logs.set_reporter (reporter Fmt.stderr) ; + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (reporter Fmt.stderr); Option.is_none level let common_options = "COMMON OPTIONS" @@ -49,11 +52,16 @@ let renderer = let setup_logs = Term.(const setup_logs $ renderer $ verbosity) let non_existing_file = - let parser str = match Fpath.of_string str with - | Ok _ as v when not (Sys.file_exists str) - && not (Sys.file_exists (str ^ ".socket")) -> v - | Ok v -> R.error_msgf "The index (and its socket) %a already exists." Fpath.pp v - | Error _ as err -> err in + let parser str = + match Fpath.of_string str with + | Ok _ as v + when (not (Sys.file_exists str)) + && not (Sys.file_exists (str ^ ".socket")) -> + v + | Ok v -> + R.error_msgf "The index (and its socket) %a already exists." Fpath.pp v + | Error _ as err -> err + in Arg.conv (parser, Fpath.pp) let file = @@ -62,11 +70,7 @@ let file = let cmd = let doc = "A simple executable to create a new index." in - let man = - [ `S Manpage.s_description - ; `P "$(tname) creates a new index." ] in - Cmd.v - (Cmd.info "make" ~doc ~man) - Term.(ret (const make $ setup_logs $ file)) + let man = [ `S Manpage.s_description; `P "$(tname) creates a new index." ] in + Cmd.v (Cmd.info "make" ~doc ~man) Term.(ret (const make $ setup_logs $ file)) let () = Cmd.(exit @@ eval cmd) diff --git a/bin/rwx.ml b/bin/rwx.ml index 453f22c..0f9fe5b 100644 --- a/bin/rwx.ml +++ b/bin/rwx.ml @@ -3,15 +3,18 @@ let () = Printexc.record_backtrace true let reporter ppf = let report src level ~over k msgf = let k _ = - over () ; - k () in + over (); + k () + in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("%a[%a]: " ^^ fmt ^^ "\n%!") Logs_fmt.pp_header (level, header) Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in { Logs.report } let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () @@ -21,57 +24,59 @@ let () = Logs.set_level ~all:true (Some Logs.Debug) let insert state key value = let th0 = let open Part in - insert key value in + insert key value + in match Part.run state th0 with | state, Ok () -> state | state, Error `Already_exists -> - Fmt.pr "# %S already exists.\n%!" (key :> string) ; - state + Fmt.pr "# %S already exists.\n%!" (key :> string); + state let lookup state key = let th0 = let open Part in - find key in + find key + in match Part.run state th0 with | state, value -> - Fmt.pr "> %S => %10d.\n%!" (key :> string) value ; - state + Fmt.pr "> %S => %10d.\n%!" (key :> string) value; + state | exception Not_found -> - Fmt.pr "> %S does not exists.\n%!" (key :> string) ; - state + Fmt.pr "> %S does not exists.\n%!" (key :> string); + state -let parse_key key = - try Ok (Rowex.key key) with _ -> Error `Invalid_key +let parse_key key = try Ok (Rowex.key key) with _ -> Error `Invalid_key let parse_value value = try Ok (int_of_string value) with _ -> Error `Invalid_value let read_eval_print_loop path = let rec loop state = - Fmt.pr ": %!" ; + Fmt.pr ": %!"; match Astring.String.cuts ~sep:" " (input_line stdin) with - | [ "insert"; key; value; ] -> - ( match parse_key key, parse_value value with - | Ok key, Ok value -> - let state = insert state key value in - loop state - | Error _, _ -> - Fmt.pr "# Invalid key %S.\n%!" key ; - loop state - | _, Error _ -> - Fmt.pr "# Invalid value %S.\n%!" value ; - loop state ) - | [ "lookup"; key; ] -> - ( match parse_key key with - | Ok key -> lookup state key |> loop - | Error _ -> - Fmt.pr "# Invalid key %S.\n%!" key ; - loop state ) + | [ "insert"; key; value ] -> ( + match (parse_key key, parse_value value) with + | Ok key, Ok value -> + let state = insert state key value in + loop state + | Error _, _ -> + Fmt.pr "# Invalid key %S.\n%!" key; + loop state + | _, Error _ -> + Fmt.pr "# Invalid value %S.\n%!" value; + loop state) + | [ "lookup"; key ] -> ( + match parse_key key with + | Ok key -> lookup state key |> loop + | Error _ -> + Fmt.pr "# Invalid key %S.\n%!" key; + loop state) | [ "quit" ] -> Part.run state Part.close | vs -> - Fmt.pr "> Invalid command: %S.\n%!" (String.concat " " vs) ; - loop state - | exception End_of_file -> Part.run state Part.close in + Fmt.pr "> Invalid command: %S.\n%!" (String.concat " " vs); + loop state + | exception End_of_file -> Part.run state Part.close + in let th0 = Part.(open_index writer ~path) in let state, () = Part.(run closed th0) in let _closed = loop state in @@ -80,32 +85,36 @@ let read_eval_print_loop path = let create path len = let th0 = let open Part in - create ~len path in + create ~len path + in match Part.(run closed th0) with | _closed, Ok () -> () - | _closed, Error (`Msg err) -> - Fmt.epr "%s." err + | _closed, Error (`Msg err) -> Fmt.epr "%s." err (* XXX(dinosaure): hard-part, see [coreutils/dd.c] or [xstrtoumax]. *) let size_of_string str = let open Astring in - let m, n = match String.head ~rev:true str with - | Some 'K' | Some 'k' -> 1_024, 1 - | Some 'M' | Some 'm' -> 1_048_576, 1_024 - | _ -> 1, 0 in + let m, n = + match String.head ~rev:true str with + | Some 'K' | Some 'k' -> (1_024, 1) + | Some 'M' | Some 'm' -> (1_048_576, 1_024) + | _ -> (1, 0) + in match String.cut ~sep:"." str with | Some (a, b) -> - let a = int_of_string a in - let b = int_of_string (String.take ~sat:Astring.Char.Ascii.is_digit b) in - a * m + (b * n) + let a = int_of_string a in + let b = int_of_string (String.take ~sat:Astring.Char.Ascii.is_digit b) in + (a * m) + (b * n) | None -> - let a = int_of_string (String.take ~sat:Astring.Char.Ascii.is_digit str) in - a * m + let a = + int_of_string (String.take ~sat:Astring.Char.Ascii.is_digit str) + in + a * m -let () = match Sys.argv with - | [| _; path; |] when Sys.file_exists path -> - read_eval_print_loop path +let () = + match Sys.argv with + | [| _; path |] when Sys.file_exists path -> read_eval_print_loop path | [| _; "create"; len; path |] -> - let len = size_of_string len in - create path len + let len = size_of_string len in + create path len | _ -> Format.eprintf "%s [create ] \n%!" Sys.argv.(0) diff --git a/conf/atomic.ml b/conf/atomic.ml index 1dff24e..5e4ca30 100644 --- a/conf/atomic.ml +++ b/conf/atomic.ml @@ -2,6 +2,5 @@ let parse s = Scanf.sscanf s "%d.%d" (fun major minor -> (major, minor)) let () = let version = parse Sys.ocaml_version in - if version >= (4, 12) && version < (5, 0) - then print_string "atomic_stdlib.ml" + if version >= (4, 12) && version < (5, 0) then print_string "atomic_stdlib.ml" else print_string "atomic_pre412.ml" diff --git a/conf/endian.ml b/conf/endian.ml index 1bf1eef..4fa7964 100644 --- a/conf/endian.ml +++ b/conf/endian.ml @@ -1,11 +1,9 @@ -external is_big_endian - : unit -> bool - = "caml_is_big_endian" [@@noalloc] +external is_big_endian : unit -> bool = "caml_is_big_endian" [@@noalloc] let _ = - let flags = match is_big_endian () with - | true -> [ "-DART_BIG_ENDIAN" ] - | false -> [ ] in + let flags = + match is_big_endian () with true -> [ "-DART_BIG_ENDIAN" ] | false -> [] + in (* XXX(dinosaure): we assume, by default, a little endian * architecture. It seems a bit difficult to really check * if we are on a little-endian architecture but more easily diff --git a/conf/flush.ml b/conf/flush.ml index 0163a3b..daca208 100644 --- a/conf/flush.ml +++ b/conf/flush.ml @@ -1,14 +1,6 @@ -external is_cpu_clflush_present - : unit -> bool - = "is_cpu_clflush_present" - -external is_cpu_clflushopt_present - : unit -> bool - = "is_cpu_clflushopt_present" - -external is_cpu_clwb_present - : unit -> bool - = "is_cpu_clwb_present" +external is_cpu_clflush_present : unit -> bool = "is_cpu_clflush_present" +external is_cpu_clflushopt_present : unit -> bool = "is_cpu_clflushopt_present" +external is_cpu_clwb_present : unit -> bool = "is_cpu_clwb_present" open Configurator.V1.C_define.Value @@ -16,24 +8,25 @@ let __aarch64__ = "__aarch64__" let _ = let c = Configurator.V1.create "sse" in - let defines = Configurator.V1.C_define.import - c ~includes:[] [ (__aarch64__, Switch) ] in + let defines = + Configurator.V1.C_define.import c ~includes:[] [ (__aarch64__, Switch) ] + in match List.assoc_opt __aarch64__ defines with | Some (Switch true) -> - Format.printf "dc cvac: true\n%!" ; - let flags = [ "-DART_DC_CVAC" ] in - Configurator.V1.Flags.write_sexp "flush.sexp" flags + Format.printf "dc cvac: true\n%!"; + let flags = [ "-DART_DC_CVAC" ] in + Configurator.V1.Flags.write_sexp "flush.sexp" flags | _ -> - let clflush = is_cpu_clflush_present () in - let clflushopt = is_cpu_clflushopt_present () in - let clwb = is_cpu_clwb_present () in + let clflush = is_cpu_clflush_present () in + let clflushopt = is_cpu_clflushopt_present () in + let clwb = is_cpu_clwb_present () in - Format.printf "clflush: %b\n%!" clflush ; - Format.printf "clflushopt: %b\n%!" clflushopt ; - Format.printf "clwb: %b\n%!" clwb ; + Format.printf "clflush: %b\n%!" clflush; + Format.printf "clflushopt: %b\n%!" clflushopt; + Format.printf "clwb: %b\n%!" clwb; - let flags = [] in - let flags = if clflush then "-DART_CLFLUSH" :: flags else flags in - let flags = if clflushopt then "-DART_CLFLUSHOPT" :: flags else flags in - let flags = if clwb then "-DART_CLWB" :: flags else flags in - Configurator.V1.Flags.write_sexp "flush.sexp" flags + let flags = [] in + let flags = if clflush then "-DART_CLFLUSH" :: flags else flags in + let flags = if clflushopt then "-DART_CLFLUSHOPT" :: flags else flags in + let flags = if clwb then "-DART_CLWB" :: flags else flags in + Configurator.V1.Flags.write_sexp "flush.sexp" flags diff --git a/conf/sse.ml b/conf/sse.ml index 8731a1e..2976133 100644 --- a/conf/sse.ml +++ b/conf/sse.ml @@ -11,52 +11,58 @@ let _msc_ver = "_MSC_VER" open Configurator.V1.C_define.Value let sse2_support lst = - match List.assoc_opt _m_amd64 lst, - List.assoc_opt _m_x64 lst, - List.assoc_opt _m_ix86_fp lst, - List.assoc_opt __sse2__ lst with + match + ( List.assoc_opt _m_amd64 lst, + List.assoc_opt _m_x64 lst, + List.assoc_opt _m_ix86_fp lst, + List.assoc_opt __sse2__ lst ) + with | Some (Switch true), _, _, _ -> true | _, Some (Switch true), _, _ -> true - | _, _, Some (Int 2), _ -> true + | _, _, Some (Int 2), _ -> true | _, _, _, Some (Switch true) -> true | _ -> false let ssse3_support lst = - match List.assoc_opt __ssse3__ lst with - | Some (Switch v) -> v - | _ -> false + match List.assoc_opt __ssse3__ lst with Some (Switch v) -> v | _ -> false let neon_support lst = - match List.assoc_opt __aarch64__ lst, - List.assoc_opt __arm_neon lst with + match (List.assoc_opt __aarch64__ lst, List.assoc_opt __arm_neon lst) with | Some (Switch true), _ -> true | _, Some (Switch true) -> true | _ -> false let _ = let c = Configurator.V1.create "sse" in - let defines = Configurator.V1.C_define.import - c ~includes:[] - [ (_m_amd64, Switch) - ; (_m_x64, Switch) - ; (__i386__, Switch) - ; (_msc_ver, Switch) - ; (__sse2__, Switch) - ; (__ssse3__, Switch) - ; (__aarch64__, Switch) - ; (__arm_neon, Switch) ] in - let defines = match List.assoc_opt __i386__ defines, - List.assoc_opt _msc_ver defines with + let defines = + Configurator.V1.C_define.import c ~includes:[] + [ + (_m_amd64, Switch); + (_m_x64, Switch); + (__i386__, Switch); + (_msc_ver, Switch); + (__sse2__, Switch); + (__ssse3__, Switch); + (__aarch64__, Switch); + (__arm_neon, Switch); + ] + in + let defines = + match + (List.assoc_opt __i386__ defines, List.assoc_opt _msc_ver defines) + with | Some (Switch true), Some (Switch true) -> - Configurator.V1.C_define.import c ~includes:[] [ (_m_ix86_fp, Int) ] @ defines - | _ -> defines in + Configurator.V1.C_define.import c ~includes:[] [ (_m_ix86_fp, Int) ] + @ defines + | _ -> defines + in let flags = - match sse2_support defines, - ssse3_support defines, - neon_support defines with - | true, true, false -> [ "-DART_SSSE3"; "-mssse3" - ; "-DART_SSE2"; "-msse2" ] + match + (sse2_support defines, ssse3_support defines, neon_support defines) + with + | true, true, false -> [ "-DART_SSSE3"; "-mssse3"; "-DART_SSE2"; "-msse2" ] | true, false, false -> [ "-DART_SSE2"; "-msse2" ] - | false, false, true -> [ "-DART_NEON"; ] - | _ -> [] in + | false, false, true -> [ "-DART_NEON" ] + | _ -> [] + in Configurator.V1.Flags.write_sexp "sse.sexp" flags diff --git a/fuzz/dune b/fuzz/dune index 96ebdeb..94285c7 100644 --- a/fuzz/dune +++ b/fuzz/dune @@ -11,7 +11,7 @@ (executable (name fuzz_rowex) (modules fuzz_rowex) - (libraries rowex.mem crowbar)) + (libraries logs.fmt fmt.tty rowex.mem crowbar)) (rule (alias runtest) diff --git a/fuzz/fuzz.ml b/fuzz/fuzz.ml index 4108cc6..8fd9121 100644 --- a/fuzz/fuzz.ml +++ b/fuzz/fuzz.ml @@ -2,20 +2,25 @@ open Crowbar let const x _ = x -let key = map [ bytes ] @@ fun k -> - if k = "" then bad_test () ; - try let k = Art.key k in k +let key = + map [ bytes ] @@ fun k -> + if k = "" then bad_test (); + try + let k = Art.key k in + k with Invalid_argument _ -> bad_test () let add = map [ key; int ] @@ fun k v -> `Add (k, v) let lookup = map [ key ] @@ fun k -> `Lookup k -let action = choose [ lookup; add; ] +let action = choose [ lookup; add ] let test = list1 action - let failf fmt = Fmt.kstr fail fmt + type action = [ `Add of Art.key * int | `Lookup of Art.key ] -let pp : action Fmt.t = fun ppf v -> match v with +let pp : action Fmt.t = + fun ppf v -> + match v with | `Add (k, n) -> Fmt.pf ppf "(`Add (%S, %d))" (k :> string) n | `Lookup k -> Fmt.pf ppf "(`Lookup %S)" (k :> string) @@ -25,16 +30,17 @@ let () = add_test ~name:"art0" [ test ] @@ fun (tests : action list) -> let tbl = Hashtbl.create (List.length tests) in let art = Art.make () in - List.iter (function + List.iter + (function | `Add (k, v) -> - Art.insert art k v ; - Hashtbl.add tbl (k :> string) v - | `Lookup k -> - match Art.find art k, Hashtbl.find tbl (k :> string) with - | v0, v1 -> check_eq v0 v1 - | exception Not_found -> - if Hashtbl.mem tbl (k :> string) - then failf "Error with: @[%a@]" Fmt.(Dump.list pp) tests) + Art.insert art k v; + Hashtbl.add tbl (k :> string) v + | `Lookup k -> ( + match (Art.find art k, Hashtbl.find tbl (k :> string)) with + | v0, v1 -> check_eq v0 v1 + | exception Not_found -> + if Hashtbl.mem tbl (k :> string) then + failf "Error with: @[%a@]" Fmt.(Dump.list pp) tests)) tests let pp_binding ppf ((k : Art.key), v) = @@ -45,29 +51,45 @@ let pp_binding ppf ((k : Art.key), v) = let () = add_test ~name:"art1" [ list (pair key int) ] @@ fun lst -> let art = Art.make () in - let check = fun (k, v0) -> Art.insert art k v0 ; match Art.find art k with + let check (k, v0) = + Art.insert art k v0; + match Art.find art k with | v1 -> check_eq v0 v1 - | exception Not_found -> failf "Error with: @[%a@]" Fmt.(Dump.list pp_binding) lst in + | exception Not_found -> + failf "Error with: @[%a@]" Fmt.(Dump.list pp_binding) lst + in List.iter check lst let unique equal lst = let rec go k acc = function | [] -> acc - | (k', _) as hd :: tl -> if equal k k' then go k acc tl else go k' (hd :: acc) tl in - match List.rev lst with - | [] -> [] - | (k, v) :: lst -> - go k [ k, v ] lst + | ((k', _) as hd) :: tl -> + if equal k k' then go k acc tl else go k' (hd :: acc) tl + in + match List.rev lst with [] -> [] | (k, v) :: lst -> go k [ (k, v) ] lst let () = add_test ~name:"art2" [ list (pair key int) ] @@ fun lst -> let art = Art.make () in - List.iter (fun (k, v) -> Art.insert art k v) lst ; - let uniq = List.stable_sort (fun ((a : Art.key), _) ((b : Art.key), _) -> String.compare (a:>string) (b:>string)) lst in - let uniq = unique (fun (a:Art.key) (b:Art.key) -> String.equal (a:>string) (b:>string)) uniq in - let check = fun (k, v0) -> match Art.find art k with + List.iter (fun (k, v) -> Art.insert art k v) lst; + let uniq = + List.stable_sort + (fun ((a : Art.key), _) ((b : Art.key), _) -> + String.compare (a :> string) (b :> string)) + lst + in + let uniq = + unique + (fun (a : Art.key) (b : Art.key) -> + String.equal (a :> string) (b :> string)) + uniq + in + let check (k, v0) = + match Art.find art k with | v1 -> check_eq v0 v1 - | exception Not_found -> failf "Error with: @[%a@]" Fmt.(Dump.list pp_binding) lst in + | exception Not_found -> + failf "Error with: @[%a@]" Fmt.(Dump.list pp_binding) lst + in List.iter check uniq (* XXX(dinosaure): we can use [String.compare] but I would like to @@ -75,50 +97,99 @@ let () = let string_compare a b = let idx = ref 0 in let res = ref 0 in - while !idx < String.length a && !idx < String.length b && - ( res := Char.code a.[!idx] - Char.code b.[!idx] - ; !res = 0 ) - do incr idx done ; + while + !idx < String.length a + && !idx < String.length b + && + (res := Char.code a.[!idx] - Char.code b.[!idx]; + !res = 0) + do + incr idx + done; if !res = 0 && String.length a = String.length b then 0 - else if !res = 0 - then ( if !idx = String.length a then 0 - Char.code b.[!idx] - else Char.code a.[!idx] ) + else if !res = 0 then + if !idx = String.length a then 0 - Char.code b.[!idx] + else Char.code a.[!idx] else !res let () = add_test ~name:"art/minimum" [ list1 (pair key int) ] @@ fun lst -> let art = Art.make () in - List.iter (fun (k, v) -> Art.insert art k v) lst ; - let uniq = List.stable_sort (fun ((a : Art.key), _) ((b : Art.key), _) -> string_compare (a:>string) (b:>string)) lst in - let uniq = unique (fun (a:Art.key) (b:Art.key) -> String.equal (a:>string) (b:>string)) uniq in - let (k0, v0) = List.hd uniq in - let (k1, v1) = Art.minimum art in - check_eq ~pp:(fun ppf (v:Art.key) -> Fmt.pf ppf "%S" (v :> string)) k0 k1 ; + List.iter (fun (k, v) -> Art.insert art k v) lst; + let uniq = + List.stable_sort + (fun ((a : Art.key), _) ((b : Art.key), _) -> + string_compare (a :> string) (b :> string)) + lst + in + let uniq = + unique + (fun (a : Art.key) (b : Art.key) -> + String.equal (a :> string) (b :> string)) + uniq + in + let k0, v0 = List.hd uniq in + let k1, v1 = Art.minimum art in + check_eq ~pp:(fun ppf (v : Art.key) -> Fmt.pf ppf "%S" (v :> string)) k0 k1; check_eq ~pp:Fmt.int v0 v1 let () = - add_test ~name:"art/remove0" [ list1 (pair key int); list1 (pair key int) ] @@ fun l0 l1 -> + add_test ~name:"art/remove0" [ list1 (pair key int); list1 (pair key int) ] + @@ fun l0 l1 -> let tree = Art.make () in - List.iter (fun (k, v) -> Art.insert tree k v) l0 ; - List.iter (fun (k, v) -> Art.insert tree k v) l1 ; - List.iter (fun (k, _) -> try Art.remove tree k with Not_found -> () (* XXX(dinosaure): double remove *)) l1 ; - let check = fun (k, v0) -> match List.assoc k l1 with + List.iter (fun (k, v) -> Art.insert tree k v) l0; + List.iter (fun (k, v) -> Art.insert tree k v) l1; + List.iter + (fun (k, _) -> + try Art.remove tree k + with Not_found -> () (* XXX(dinosaure): double remove *)) + l1; + let check (k, v0) = + match List.assoc k l1 with | _ -> () | exception Not_found -> - let v1 = Art.find tree k in - check_eq v0 v1 in - let l0 = List.stable_sort (fun ((a : Art.key), _) ((b : Art.key), _) -> String.compare (a:>string) (b:>string)) l0 in - let l0 = unique (fun (a:Art.key) (b:Art.key) -> String.equal (a:>string) (b:>string)) l0 in + let v1 = Art.find tree k in + check_eq v0 v1 + in + let l0 = + List.stable_sort + (fun ((a : Art.key), _) ((b : Art.key), _) -> + String.compare (a :> string) (b :> string)) + l0 + in + let l0 = + unique + (fun (a : Art.key) (b : Art.key) -> + String.equal (a :> string) (b :> string)) + l0 + in List.iter check l0 -module Map = Map.Make(struct type t = Art.key let compare (a:Art.key) (b:Art.key) = String.compare (a:>string) (b:>string) end) +module Map = Map.Make (struct + type t = Art.key + + let compare (a : Art.key) (b : Art.key) = + String.compare (a :> string) (b :> string) +end) let incl_mt m t = - try Map.iter (fun k v -> let v' = Art.find t k in if v <> v' then raise Not_found) m ; true + try + Map.iter + (fun k v -> + let v' = Art.find t k in + if v <> v' then raise Not_found) + m; + true with Not_found -> false let incl_tm t m = - try Art.iter ~f:(fun k v () -> let v' = Map.find k m in if v <> v' then raise Not_found) () t ; true + try + Art.iter + ~f:(fun k v () -> + let v' = Map.find k m in + if v <> v' then raise Not_found) + () t; + true with Not_found -> false let () = @@ -126,11 +197,15 @@ let () = let arr = Array.of_list lst in let len = Array.length arr in let tree = Art.make () and map = ref Map.empty in - Array.iter (fun (k, v) -> Art.insert tree k v ; map := Map.add k v !map) arr ; - check_eq (incl_mt !map tree) true ; - for i = 0 to len / 3 - 1 do + Array.iter + (fun (k, v) -> + Art.insert tree k v; + map := Map.add k v !map) + arr; + check_eq (incl_mt !map tree) true; + for i = 0 to (len / 3) - 1 do let k, _ = arr.(i) in let () = try Art.remove tree k with Not_found -> () in - map := ( try Map.remove k !map with Not_found -> !map ) - done ; + map := try Map.remove k !map with Not_found -> !map + done; check_eq (incl_mt !map tree && incl_tm tree !map) true diff --git a/fuzz/fuzz_rowex.ml b/fuzz/fuzz_rowex.ml index 14cf967..57c92a8 100644 --- a/fuzz/fuzz_rowex.ml +++ b/fuzz/fuzz_rowex.ml @@ -1,21 +1,107 @@ +let reporter ppf = + let report src level ~over k msgf = + let k _ = + over (); + k () + in + let with_metadata header _tags k ppf fmt = + Format.kfprintf k ppf + ("%a[%a]: " ^^ fmt ^^ "\n%!") + Logs_fmt.pp_header (level, header) + Fmt.(styled `Magenta string) + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in + { Logs.report } + +(* +let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () +let () = Logs.set_reporter (reporter Fmt.stdout) +let () = Logs.set_level ~all:true (Some Logs.Debug) +*) + open Crowbar -let key = map [ bytes ] @@ fun k -> - if k = "" then bad_test () ; - try let k = Rowex.key k in k +let key = + map [ bytes ] @@ fun k -> + if k = "" then bad_test (); + try + let k = Rowex.key k in + k with Invalid_argument _ -> bad_test () -let memory = Bytes.create 0xFFFFFFF -module Mem = Mem.Make (struct let memory = memory end) -module Art = Rowex.Make (Mem) +let memory = Bytes.make 0xfffffff '\000' + +module Mem = Mem.Make (struct + let memory = memory +end) + +module Art = Rowex.Make (Mem) let () = add_test ~name:"simple" [ list (pair key int) ] @@ fun lst -> - let root = Art.make () in - List.fold_left (fun acc (k, v) -> match Art.insert root k v with - | () -> (k, v) :: acc - | exception Out_of_memory -> bad_test () - | exception Rowex.Duplicate -> acc) [] lst - |> List.iter @@ fun (k, v) -> match Art.find root k with - | v' -> check_eq v v' - | exception Not_found -> failf "%S not found" (k :> string) + let tree = Art.make () in + List.fold_left + (fun acc (k, v) -> + match Art.insert tree k v with + | () -> (k, v) :: acc + | exception Out_of_memory -> bad_test () + | exception Rowex.Duplicate -> acc) + [] lst + |> List.iter @@ fun (k, v) -> + match Art.find tree k with + | v' -> check_eq v v' + | exception Not_found -> failf "%S not found" (k :> string) + +let unique equal lst = + let rec go k acc = function + | [] -> acc + | ((k', _) as hd) :: tl -> + if equal k k' then go k acc tl else go k' (hd :: acc) tl + in + match List.rev lst with [] -> [] | (k, v) :: lst -> go k [ (k, v) ] lst + +let () = + add_test ~name:"remove" [ list1 (pair key int); list1 (pair key int) ] + @@ fun l0 l1 -> + let tree = Art.make () in + let l0 = + List.fold_left + (fun acc (k, v) -> + match Art.insert tree k v with + | () -> (k, v) :: acc + | exception Out_of_memory -> bad_test () + | exception Rowex.Duplicate -> acc) + [] l0 + in + let l1 = + List.fold_left + (fun acc (k, v) -> + match Art.insert tree k v with + | () -> (k, v) :: acc + | exception Out_of_memory -> bad_test () + | exception Rowex.Duplicate -> acc) + [] l1 + in + List.iter (fun (k, _) -> try Art.remove tree k with Not_found -> ()) l1; + let check (k, v0) = + match List.assoc k l1 with + | _ -> () + | exception Not_found -> + let v1 = Art.find tree k in + check_eq v0 v1 + in + let l0 = + List.stable_sort + (fun ((a : Rowex.key), _) ((b : Rowex.key), _) -> + String.compare (a :> string) (b :> string)) + l0 + in + let l0 = + unique + (fun (a : Rowex.key) (b : Rowex.key) -> + String.equal (a :> string) (b :> string)) + l0 + in + List.iter check l0 diff --git a/fuzz/monolith.ml b/fuzz/monolith.ml index 76565b2..a564a0d 100644 --- a/fuzz/monolith.ml +++ b/fuzz/monolith.ml @@ -1,12 +1,15 @@ open Monolith open PPrint -module Map = Map.Make (struct type t = Art.key let compare (a : Art.key) (b : Art.key) = - String.compare (a :> string) (b :> string) end) +module Map = Map.Make (struct + type t = Art.key -let char_without_d0 () = match Gen.char () with - | '\000' -> Gen.reject () - | chr -> chr + let compare (a : Art.key) (b : Art.key) = + String.compare (a :> string) (b :> string) +end) + +let char_without_d0 () = + match Gen.char () with '\000' -> Gen.reject () | chr -> chr let key = easily_constructible @@ -39,12 +42,19 @@ module Reference = struct let make () = Hashtbl.create 0x100 let is_empty tbl = Hashtbl.length tbl = 0 let insert tbl key value = Hashtbl.add tbl key value - let find_opt tbl key = match Hashtbl.find tbl key with - | v -> Some v - | exception Not_found -> None + + let find_opt tbl key = + match Hashtbl.find tbl key with v -> Some v | exception Not_found -> None end -module Equivalence = Make (Reference) (struct include Art type t = int Art.t end) +module Equivalence = + Make + (Reference) + (struct + include Art + + type t = int Art.t + end) let () = let t = declare_abstract_type () in diff --git a/ipc/ipc.ml b/ipc/ipc.ml index 5581067..a460ec2 100644 --- a/ipc/ipc.ml +++ b/ipc/ipc.ml @@ -7,67 +7,65 @@ external get_uint64 : string -> int -> int64 = "%caml_string_get64" external set_uint64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64" let get_leuint64 str off = - if Sys.big_endian - then swap64 (get_uint64 str off) - else get_uint64 str off + if Sys.big_endian then swap64 (get_uint64 str off) else get_uint64 str off let set_leuint64 buf off v = - if Sys.big_endian - then set_uint64 buf off (swap64 v) - else set_uint64 buf off v + if Sys.big_endian then set_uint64 buf off (swap64 v) else set_uint64 buf off v let rec fully_read_leint64 fd = let tmp = Bytes.create 8 in go fd tmp 0 8 + and go fd tmp off len = if len = 0 then get_leuint64 (Bytes.unsafe_to_string tmp) 0 - else let len' = Unix.read fd tmp off len in - go fd tmp (off + len') (len - len') + else + let len' = Unix.read fd tmp off len in + go fd tmp (off + len') (len - len') let rec fully_write_leint64 fd v = let tmp = Bytes.create 8 in - set_leuint64 tmp 0 v ; + set_leuint64 tmp 0 v; go fd tmp 0 8 + and go fd tmp off len = - if len > 0 - then let len' = Unix.write fd tmp off len in - go fd tmp (off + len') (len - len') + if len > 0 then + let len' = Unix.write fd tmp off len in + go fd tmp (off + len') (len - len') open Rresult type t = Unix.file_descr let is_empty t = - match Unix.select [ t ] [] [] 0. with - | [ _ ], _, _ -> false - | _ -> true + match Unix.select [ t ] [] [] 0. with [ _ ], _, _ -> false | _ -> true let dequeue t = - Unix.lockf t Unix.F_LOCK 0 ; + Unix.lockf t Unix.F_LOCK 0; let v = fully_read_leint64 t in - Log.debug (fun m -> m "dequeue %Ld" v) ; - Unix.lockf t Unix.F_ULOCK 0 ; + Log.debug (fun m -> m "dequeue %Ld" v); + Unix.lockf t Unix.F_ULOCK 0; v let enqueue t v = - Unix.lockf t Unix.F_LOCK 0 ; - Log.debug (fun m -> m "enqueue %Ld" v) ; - fully_write_leint64 t v ; + Unix.lockf t Unix.F_LOCK 0; + Log.debug (fun m -> m "enqueue %Ld" v); + fully_write_leint64 t v; Unix.lockf t Unix.F_ULOCK 0 let close t = Unix.close t - -let connect path = - Unix.openfile path Unix.[ O_RDWR ] 0o600 +let connect path = Unix.openfile path Unix.[ O_RDWR ] 0o600 let create path = - try Unix.mkfifo path 0o600 ; - R.ok () - with Unix.Unix_error (err, f, v) -> - R.error_msgf "%s(%s): %s" f v (Unix.error_message err) - | exn -> raise exn + try + Unix.mkfifo path 0o600; + R.ok () + with + | Unix.Unix_error (err, f, v) -> + R.error_msgf "%s(%s): %s" f v (Unix.error_message err) + | exn -> raise exn let with_lock ~f t = - Unix.lockf t Unix.F_LOCK 0 ; + Unix.lockf t Unix.F_LOCK 0; let v = f t in - Unix.lockf t Unix.F_ULOCK 0 ; v + Unix.lockf t Unix.F_ULOCK 0; + v diff --git a/ipc/ipc.mli b/ipc/ipc.mli index 8dd1492..4c3b7b2 100644 --- a/ipc/ipc.mli +++ b/ipc/ipc.mli @@ -22,7 +22,5 @@ val dequeue : t -> int64 val enqueue : t -> int64 -> unit val connect : string -> t val close : t -> unit - val create : string -> (unit, [> `Msg of string ]) result - val with_lock : f:(t -> 'a) -> t -> 'a diff --git a/lib/art.ml b/lib/art.ml index 23786a4..f7fb485 100644 --- a/lib/art.ml +++ b/lib/art.ml @@ -7,9 +7,9 @@ module String = struct end external ( <= ) : 'a -> 'a -> bool = "%lessequal" + let ( <= ) (x : int) y = x <= y [@@inline] let min (a : int) b = if a <= b then a else b [@@inline] - let ( .!{} ) = Bytes.unsafe_get let ( .!{}<- ) = Bytes.unsafe_set @@ -18,37 +18,36 @@ type key = string (* + \000 *) let ( .![] ) str i = String.unsafe_get str i type 'a kind = - | N4 : n4 kind - | N16 : n16 kind - | N48 : n48 kind + | N4 : n4 kind + | N16 : n16 kind + | N48 : n48 kind | N256 : n256 kind | NULL : unit kind + and n4 = bytes + (* XXX(dinosaure): [Obj.(size (repr "\000\000\000\000"))] < [Obj.(size (repr { _= 0; _= 0; }))] *) and n16 = bytes and n48 = bytes and n256 = N256_Key -type 'a record = - { prefix : bytes - ; mutable prefix_length : int - ; mutable count : int - ; kind : 'a kind - ; keys : 'a } - -type 'a node = - { header : header - ; children : 'a elt array } -and 'a leaf = - { value : 'a - ; key : key } -and 'a elt = - | Leaf of 'a leaf - | Node of 'a node +type 'a record = { + prefix : bytes; + mutable prefix_length : int; + mutable count : int; + kind : 'a kind; + keys : 'a; +} + +type 'a node = { header : header; children : 'a elt array } +and 'a leaf = { value : 'a; key : key } +and 'a elt = Leaf of 'a leaf | Node of 'a node and header = Header : 'a record -> header [@@unboxed] -let key : string -> key = fun key -> - if String.contains key '\000' then invalid_arg "Invalid key" ; key +let key : string -> key = + fun key -> + if String.contains key '\000' then invalid_arg "Invalid key"; + key external unsafe_key : string -> key = "%identity" @@ -59,123 +58,141 @@ let[@coverage off] pp_char ppf = function | chr -> Fmt.pf ppf "%02x" (Char.code chr) let[@coverage off] pp_n4 ppf keys = - Fmt.pf ppf "%a" - Fmt.(Dump.array pp_char) - (Array.init 4 (fun i -> keys.!{i})) + Fmt.pf ppf "%a" Fmt.(Dump.array pp_char) (Array.init 4 (fun i -> keys.!{i})) let[@coverage off] pp_n16 ppf keys = - Fmt.pf ppf "%a" - Fmt.(Dump.array pp_char) - (Array.init 16 (fun i -> keys.!{i})) + Fmt.pf ppf "%a" Fmt.(Dump.array pp_char) (Array.init 16 (fun i -> keys.!{i})) let[@coverage off] pp_n48 ppf keys = Fmt.pf ppf "%a" Fmt.(Dump.array pp_char) (Array.init 48 (fun i -> keys.!{i})) let[@coverage off] pp_n256 _ppf N256_Key = () -let[@coverage off] pp_keys : type a. kind:a kind -> a Fmt.t = fun ~kind -> match kind with +let[@coverage off] pp_keys : type a. kind:a kind -> a Fmt.t = + fun ~kind -> + match kind with | N4 -> pp_n4 | N16 -> pp_n16 | N48 -> pp_n48 | N256 -> pp_n256 | NULL -> Fmt.nop -let[@coverage off] pp_kind : type a. a kind Fmt.t = fun ppf -> function +let[@coverage off] pp_kind : type a. a kind Fmt.t = + fun ppf -> function | N4 -> Fmt.string ppf "N4" | N16 -> Fmt.string ppf "N16" | N48 -> Fmt.string ppf "N48" | N256 -> Fmt.string ppf "N256" | NULL -> Fmt.string ppf "NULL" -let[@coverage off] pp_record : type a. a record Fmt.t = fun ppf r -> +let[@coverage off] pp_record : type a. a record Fmt.t = + fun ppf r -> match r.kind with | NULL -> Fmt.string ppf "" | _ -> - Fmt.pf ppf "{ @[prefix= %S;@ \ - prefix_length= %d;@ \ - count= %d;@ \ - kind= %a;@ \ - value= @[%a@];@] }" - (Bytes.unsafe_to_string r.prefix) r.prefix_length - r.count pp_kind r.kind - (pp_keys ~kind:r.kind) r.keys + Fmt.pf ppf + "{ @[prefix= %S;@ prefix_length= %d;@ count= %d;@ kind= %a;@ \ + value= @[%a@];@] }" + (Bytes.unsafe_to_string r.prefix) + r.prefix_length r.count pp_kind r.kind (pp_keys ~kind:r.kind) r.keys let[@coverage off] pp_header ppf (Header record) = pp_record ppf record let[@coverage off] rec pp_elt pp_value ppf = function - | Leaf { key; value; } -> - Fmt.pf ppf "{:leaf @[key= %S;@ value= @[%a@];@] }" key pp_value value - | Node { header= Header { kind= NULL; _ }; _ } -> - Fmt.string ppf "" - | Node { header; children; } -> - Fmt.pf ppf "{:node @[hdr= @[%a@];@ children= @[%a@];@] }" - pp_header header Fmt.(Dump.array (pp_elt pp_value)) children + | Leaf { key; value } -> + Fmt.pf ppf "{:leaf @[key= %S;@ value= @[%a@];@] }" key pp_value + value + | Node { header = Header { kind = NULL; _ }; _ } -> Fmt.string ppf "" + | Node { header; children } -> + Fmt.pf ppf "{:node @[hdr= @[%a@];@ children= @[%a@];@] }" + pp_header header + Fmt.(Dump.array (pp_elt pp_value)) + children let[@coverage off] pp pp_value ppf tree = pp_elt pp_value ppf !tree let ctz v = let n = ref 0 and x = ref v and y = ref 0 in - if Sys.word_size = 64 - then ( n := 63 ; y := !x lsl 32 ; if !y != 0 then ( n := !n - 32 ; x := !y ) ) - else ( n := 31 ) ; - y := !x lsl 16 ; if !y != 0 then ( n := !n - 16 ; x := !y ) ; - y := !x lsl 8 ; if !y != 0 then ( n := !n - 8 ; x := !y ) ; - y := !x lsl 4 ; if !y != 0 then ( n := !n - 4 ; x := !y ) ; - y := !x lsl 2 ; if !y != 0 then ( n := !n - 2 ; x := !y ) ; - y := !x lsl 1 ; if !y != 0 then ( n := !n - 1 ; ) ; + if Sys.word_size = 64 then ( + n := 63; + y := !x lsl 32; + if !y != 0 then ( + n := !n - 32; + x := !y)) + else n := 31; + y := !x lsl 16; + if !y != 0 then ( + n := !n - 16; + x := !y); + y := !x lsl 8; + if !y != 0 then ( + n := !n - 8; + x := !y); + y := !x lsl 4; + if !y != 0 then ( + n := !n - 4; + x := !y); + y := !x lsl 2; + if !y != 0 then ( + n := !n - 2; + x := !y); + y := !x lsl 1; + if !y != 0 then n := !n - 1; !n - 1 [@@inline] let empty_record = - { prefix= Bytes.empty; prefix_length= 0 - ; count= 0 - ; kind= NULL; keys= () } + { prefix = Bytes.empty; prefix_length = 0; count = 0; kind = NULL; keys = () } let empty_header = Header empty_record -let empty_node = { header= empty_header; children= [||] } +let empty_node = { header = empty_header; children = [||] } let empty_elt = Node empty_node let n4 prefix : n4 record = let record = - { prefix; prefix_length= 0; - count= 0; - kind= N4; keys= Bytes.make 4 '\000' } in + { + prefix; + prefix_length = 0; + count = 0; + kind = N4; + keys = Bytes.make 4 '\000'; + } + in record let n4_shift n4 = function | 0 -> - n4.!{3} <- n4.!{2} - ; n4.!{2} <- n4.!{1} - ; n4.!{1} <- n4.!{0} + n4.!{3} <- n4.!{2}; + n4.!{2} <- n4.!{1}; + n4.!{1} <- n4.!{0} | 1 -> - n4.!{3} <- n4.!{2} - ; n4.!{2} <- n4.!{1} - | _ (* 2 *) -> - n4.!{3} <- n4.!{2} + n4.!{3} <- n4.!{2}; + n4.!{2} <- n4.!{1} + | _ (* 2 *) -> n4.!{3} <- n4.!{2} let n16 prefix : n16 record = let record = - { prefix; prefix_length= 0; - count= 0; - kind= N16; keys= Bytes.make 16 '\000' } in + { + prefix; + prefix_length = 0; + count = 0; + kind = N16; + keys = Bytes.make 16 '\000'; + } + in record -let n16_shift keys n = - Bytes.unsafe_blit keys n keys (n + 1) (16 - (n + 1)) +let n16_shift keys n = Bytes.unsafe_blit keys n keys (n + 1) (16 - (n + 1)) let n48 prefix : n48 record = let keys = Bytes.make 256 '\048' in - let record = - { prefix; prefix_length= 0; - count= 0; - kind= N48; keys; } in + let record = { prefix; prefix_length = 0; count = 0; kind = N48; keys } in record let n256 prefix : n256 record = let record = - { prefix; prefix_length= 0; - count= 0; - kind= N256; keys= N256_Key; } in + { prefix; prefix_length = 0; count = 0; kind = N256; keys = N256_Key } + in record let memcmp a b ~off ~len = @@ -183,479 +200,543 @@ let memcmp a b ~off ~len = let len1 = len asr 2 in for i = 0 to len1 - 1 do - let i = off + i * 4 in - if String.unsafe_get_uint32 a i <> String.unsafe_get_uint32 b i - then raise_notrace Not_found ; - done ; + let i = off + (i * 4) in + if String.unsafe_get_uint32 a i <> String.unsafe_get_uint32 b i then + raise_notrace Not_found + done; for i = 0 to len0 - 1 do - let i = off + len1 * 4 + i in - if a.![i] <> b.![i] then raise_notrace Not_found ; + let i = off + (len1 * 4) + i in + if a.![i] <> b.![i] then raise_notrace Not_found done -;; -let copy_header : type a b. src:a record -> dst:b record -> unit = fun ~src ~dst -> - dst.count <- src.count ; +let copy_header : type a b. src:a record -> dst:b record -> unit = + fun ~src ~dst -> + dst.count <- src.count; dst.prefix_length <- src.prefix_length -let add_child_n256 - : n256 record -> 'a elt array -> char -> 'a elt -> unit - = fun record children chr node -> - record.count <- record.count + 1 ; - Array.unsafe_set children (Char.code chr) node - -let add_child_n48 - : n48 record -> 'a elt ref -> 'a elt array -> char -> 'a elt -> unit - = fun record tree children chr node -> - if record.count < 48 - then ( let pos = ref 0 in - while Array.unsafe_get children !pos != empty_elt do incr pos done - ; record.keys.!{Char.code chr} <- Char.unsafe_chr !pos - ; record.count <- record.count + 1 - ; Array.unsafe_set children !pos node ) - else ( let node256 = n256 record.prefix in - copy_header ~src:record ~dst:node256 ; - let children = Array.init 256 (fun i -> - let k = Char.code (record.keys.!{i}) in - if k <> 48 then Array.unsafe_get children k else empty_elt) in - add_child_n256 node256 children chr node ; - tree := Node { header= Header node256; children } ) - -let add_child_n16 - : n16 record -> 'a elt ref -> 'a elt array -> char -> 'a elt -> unit - = fun record tree children chr node -> - if record.count < 16 - then ( let mask = (1 lsl record.count) - 1 in - let bit = ref 0 in - let idx = ref 0 in - for i = 0 to 15 do if chr < record.keys.!{i} then bit := !bit lor (1 lsl i) done ; - bit := !bit land mask ; - if !bit <> 0 - then ( idx := ctz !bit - ; n16_shift record.keys !idx - ; Array.blit children !idx children (!idx + 1) (record.count - !idx) ) - else idx := record.count ; - record.keys.!{!idx} <- chr ; - Array.unsafe_set children (!idx) node ; - record.count <- record.count + 1 ) - else ( let node48 = n48 record.prefix in - for i = 0 to record.count - 1 do node48.keys.!{Char.code record.keys.!{i}} <- Char.unsafe_chr i done ; - copy_header ~src:record ~dst:node48 ; - let children' = Array.make 48 empty_elt in - Array.blit children 0 children' 0 16 ; - let null = ref empty_elt in - add_child_n48 node48 null children' chr node ; - tree := Node { header= Header node48; children= children' } ) +let add_child_n256 : n256 record -> 'a elt array -> char -> 'a elt -> unit = + fun record children chr node -> + record.count <- record.count + 1; + Array.unsafe_set children (Char.code chr) node + +let add_child_n48 : + n48 record -> 'a elt ref -> 'a elt array -> char -> 'a elt -> unit = + fun record tree children chr node -> + if record.count < 48 then ( + let pos = ref 0 in + while Array.unsafe_get children !pos != empty_elt do + incr pos + done; + record.keys.!{Char.code chr} <- Char.unsafe_chr !pos; + record.count <- record.count + 1; + Array.unsafe_set children !pos node) + else + let node256 = n256 record.prefix in + copy_header ~src:record ~dst:node256; + let children = + Array.init 256 (fun i -> + let k = Char.code record.keys.!{i} in + if k <> 48 then Array.unsafe_get children k else empty_elt) + in + add_child_n256 node256 children chr node; + tree := Node { header = Header node256; children } + +let add_child_n16 : + n16 record -> 'a elt ref -> 'a elt array -> char -> 'a elt -> unit = + fun record tree children chr node -> + if record.count < 16 then ( + let mask = (1 lsl record.count) - 1 in + let bit = ref 0 in + let idx = ref 0 in + for i = 0 to 15 do + if chr < record.keys.!{i} then bit := !bit lor (1 lsl i) + done; + bit := !bit land mask; + if !bit <> 0 then ( + idx := ctz !bit; + n16_shift record.keys !idx; + Array.blit children !idx children (!idx + 1) (record.count - !idx)) + else idx := record.count; + record.keys.!{!idx} <- chr; + Array.unsafe_set children !idx node; + record.count <- record.count + 1) + else + let node48 = n48 record.prefix in + for i = 0 to record.count - 1 do + node48.keys.!{Char.code record.keys.!{i}} <- Char.unsafe_chr i + done; + copy_header ~src:record ~dst:node48; + let children' = Array.make 48 empty_elt in + Array.blit children 0 children' 0 16; + let null = ref empty_elt in + add_child_n48 node48 null children' chr node; + tree := Node { header = Header node48; children = children' } let rec iter_child_n4 keys idx max chr = - if idx < max then ( if Char.code chr <= Char.code keys.!{idx} - then idx - else iter_child_n4 keys (succ idx) max chr ) + if idx < max then + if Char.code chr <= Char.code keys.!{idx} then idx + else iter_child_n4 keys (succ idx) max chr else max -let add_child_n4 - : n4 record -> 'a elt ref -> 'a elt array -> char -> 'a elt -> unit - = fun record tree children chr node -> - if record.count < 4 - then ( let idx = iter_child_n4 record.keys 0 record.count chr in - n4_shift record.keys idx ; - Array.blit children idx children (idx + 1) (record.count - idx) ; - record.keys.!{idx} <- chr ; - Array.unsafe_set children (idx) node ; - record.count <- record.count + 1 ) - else ( let node16 = n16 record.prefix in - let children' = Array.make 16 empty_elt in - Array.blit children 0 children' 0 4 ; - Bytes.unsafe_blit record.keys 0 node16.keys 0 4 ; - copy_header ~src:record ~dst:node16 ; - let null = ref empty_elt in - add_child_n16 node16 null children' chr node ; - tree := Node { header= Header node16; children= children'; } ) - -let not_found = (-1) - -let find_child - : 'a node -> char -> int - = fun { header= Header record; _ } chr -> - let res = ref not_found in - let code = Char.code chr in - - ( match record.kind with - | N4 -> - let m = record.count in - if m > 0 && Char.code record.keys.!{0} = code - then res := 0 - else if m > 1 && Char.code record.keys.!{1} = code - then res := 1 - else if m > 2 && Char.code record.keys.!{2} = code - then res := 2 - else if m > 3 && Char.code record.keys.!{3} = code - then res := 3 - | N16 -> - (* TODO(dinosaure): can be replaced by SSE instr. *) - let bit = ref 0 in - for i = 0 to 15 do if record.keys.!{i} = chr then bit := !bit lor (1 lsl i) done ; - let mask = (1 lsl record.count) - 1 in - if !bit land mask <> 0 then res := ctz !bit - | N48 -> - let i = Char.code (record.keys.!{code}) in - if i <> 48 then res := i - | N256 -> res := code - | NULL -> (()[@coverage off]) ) - ; !res -;; - -let check_prefix ~prefix ?(prefix_offset= 0) ~prefix_length ~off key len = +let add_child_n4 : + n4 record -> 'a elt ref -> 'a elt array -> char -> 'a elt -> unit = + fun record tree children chr node -> + if record.count < 4 then ( + let idx = iter_child_n4 record.keys 0 record.count chr in + n4_shift record.keys idx; + Array.blit children idx children (idx + 1) (record.count - idx); + record.keys.!{idx} <- chr; + Array.unsafe_set children idx node; + record.count <- record.count + 1) + else + let node16 = n16 record.prefix in + let children' = Array.make 16 empty_elt in + Array.blit children 0 children' 0 4; + Bytes.unsafe_blit record.keys 0 node16.keys 0 4; + copy_header ~src:record ~dst:node16; + let null = ref empty_elt in + add_child_n16 node16 null children' chr node; + tree := Node { header = Header node16; children = children' } + +let not_found = -1 + +let find_child : 'a node -> char -> int = + fun { header = Header record; _ } chr -> + let res = ref not_found in + let code = Char.code chr in + + (match record.kind with + | N4 -> + let m = record.count in + if m > 0 && Char.code record.keys.!{0} = code then res := 0 + else if m > 1 && Char.code record.keys.!{1} = code then res := 1 + else if m > 2 && Char.code record.keys.!{2} = code then res := 2 + else if m > 3 && Char.code record.keys.!{3} = code then res := 3 + | N16 -> + (* TODO(dinosaure): can be replaced by SSE instr. *) + let bit = ref 0 in + for i = 0 to 15 do + if record.keys.!{i} = chr then bit := !bit lor (1 lsl i) + done; + let mask = (1 lsl record.count) - 1 in + if !bit land mask <> 0 then res := ctz !bit + | N48 -> + let i = Char.code record.keys.!{code} in + if i <> 48 then res := i + | N256 -> res := code + | NULL -> () [@coverage off]); + !res + +let check_prefix ~prefix ?(prefix_offset = 0) ~prefix_length ~off key len = let max = min prefix_length (len - off) in let idx = ref 0 in - while !idx < max && prefix.!{prefix_offset + !idx} = key.![off + !idx] - do incr idx done ; !idx + while !idx < max && prefix.!{prefix_offset + !idx} = key.![off + !idx] do + incr idx + done; + !idx let rec minimum = function | Leaf leaf -> leaf - | Node { header= Header { kind= N4; _ }; children; } -> - minimum (Array.unsafe_get children 0) - | Node { header= Header { kind= N16; _ }; children; } -> - minimum (Array.unsafe_get children 0) - | Node { header= Header { kind= N48; keys; _ }; children; } -> - let idx = ref 0 in - while keys.!{!idx} = '\048' do incr idx done ; - idx := Char.code keys.!{!idx} ; minimum (Array.unsafe_get children !idx) - | Node { header= Header { kind= N256; _ }; children; } -> - let idx = ref 0 in - while Array.unsafe_get children !idx == empty_elt do incr idx done ; - minimum (Array.unsafe_get children !idx) - | Node { header= Header { kind= NULL; _ }; _ } -> invalid_arg "empty tree" + | Node { header = Header { kind = N4; _ }; children } -> + minimum (Array.unsafe_get children 0) + | Node { header = Header { kind = N16; _ }; children } -> + minimum (Array.unsafe_get children 0) + | Node { header = Header { kind = N48; keys; _ }; children } -> + let idx = ref 0 in + while keys.!{!idx} = '\048' do + incr idx + done; + idx := Char.code keys.!{!idx}; + minimum (Array.unsafe_get children !idx) + | Node { header = Header { kind = N256; _ }; children } -> + let idx = ref 0 in + while Array.unsafe_get children !idx == empty_elt do + incr idx + done; + minimum (Array.unsafe_get children !idx) + | Node { header = Header { kind = NULL; _ }; _ } -> invalid_arg "empty tree" let rec maximum = function | Leaf leaf -> leaf - | Node { header= Header { kind= N4; count; _ }; children; } -> - maximum (Array.unsafe_get children (count - 1)) - | Node { header= Header { kind= N16; count; _ }; children; } -> - maximum (Array.unsafe_get children (count - 1)) - | Node { header= Header { kind= N48; keys; _ }; children; } -> - let idx = ref 255 in - while keys.!{!idx} = '\048' do decr idx done ; - idx := Char.code keys.!{!idx} ; maximum (Array.unsafe_get children !idx) - | Node { header= Header { kind= N256; _ }; children; } -> - let idx = ref 255 in - while Array.unsafe_get children !idx == empty_elt do decr idx done ; - maximum (Array.unsafe_get children !idx) - | Node { header= Header { kind= NULL; _ }; _ } -> invalid_arg "empty tree" - -let prefix_mismatch ({ header= Header header; _ } as node) ~off key len = + | Node { header = Header { kind = N4; count; _ }; children } -> + maximum (Array.unsafe_get children (count - 1)) + | Node { header = Header { kind = N16; count; _ }; children } -> + maximum (Array.unsafe_get children (count - 1)) + | Node { header = Header { kind = N48; keys; _ }; children } -> + let idx = ref 255 in + while keys.!{!idx} = '\048' do + decr idx + done; + idx := Char.code keys.!{!idx}; + maximum (Array.unsafe_get children !idx) + | Node { header = Header { kind = N256; _ }; children } -> + let idx = ref 255 in + while Array.unsafe_get children !idx == empty_elt do + decr idx + done; + maximum (Array.unsafe_get children !idx) + | Node { header = Header { kind = NULL; _ }; _ } -> invalid_arg "empty tree" + +let prefix_mismatch ({ header = Header header; _ } as node) ~off key len = let plen = header.prefix_length in let max = min (min plen 10) (len - off) in let idx = ref 0 in - while !idx < max && header.prefix.!{!idx} = key.![off + !idx] - do incr idx done ; - - if !idx = max && plen > 10 - then - ( let leaf = minimum (Node node) in - let max = (min (String.length leaf.key) len) - off in - while !idx < max - 4 - && String.unsafe_get_uint32 leaf.key (off + !idx) = String.unsafe_get_uint32 key (off + !idx) - do idx := !idx + 4 done ; - while !idx < max - && leaf.key.![off + !idx] = key.![off + !idx] - do incr idx done ) ; + while !idx < max && header.prefix.!{!idx} = key.![off + !idx] do + incr idx + done; + + if !idx = max && plen > 10 then ( + let leaf = minimum (Node node) in + let max = min (String.length leaf.key) len - off in + while + !idx < max - 4 + && String.unsafe_get_uint32 leaf.key (off + !idx) + = String.unsafe_get_uint32 key (off + !idx) + do + idx := !idx + 4 + done; + while !idx < max && leaf.key.![off + !idx] = key.![off + !idx] do + incr idx + done); !idx -;; let longest_common_prefix ~off k1 k2 = - let max = (min (String.length k1) (String.length k2)) - off in + let max = min (String.length k1) (String.length k2) - off in let idx = ref 0 in - while !idx < max && k1.![off + !idx] = k2.![off + !idx] - do incr idx done ; !idx + while !idx < max && k1.![off + !idx] = k2.![off + !idx] do + incr idx + done; + !idx let leaf_matches { key; _ } ~off key' len' = - if String.length key <> len' then raise Not_found ; + if String.length key <> len' then raise Not_found; if len' - off > 0 then memcmp key key' ~off ~len:(len' - off) (* TODO(dinosaure): check all the key, (see optimistic match). *) -let rec _find ~key ~key_len depth elt = match elt with +let rec _find ~key ~key_len depth elt = + match elt with | Leaf leaf -> - leaf_matches leaf key ~off:depth key_len ; leaf.value - | Node { header= Header { kind= NULL; _ }; _ } -> raise Not_found - | Node ({ header= Header header; children; } as node) -> - let plen = header.prefix_length in - let depth = - if plen > 0 && plen <= 10 - then ( let plen' = check_prefix ~prefix:header.prefix ~prefix_length:plen ~off:depth key key_len in - if plen' <> min 10 plen then raise Not_found - ; depth + plen ) - else if plen > 10 - then ( let prefix = Bytes.unsafe_of_string (minimum elt).key in - let plen' = check_prefix ~prefix ~prefix_offset:depth ~prefix_length:plen ~off:depth key key_len in - if plen' <> plen then raise Not_found - ; depth + plen ) - else depth in - let x = find_child node key.![depth] in - if x = not_found || Array.unsafe_get children x == empty_elt - then raise Not_found - else _find ~key ~key_len (depth + 1) (Array.unsafe_get children x) + leaf_matches leaf key ~off:depth key_len; + leaf.value + | Node { header = Header { kind = NULL; _ }; _ } -> raise Not_found + | Node ({ header = Header header; children } as node) -> + let plen = header.prefix_length in + let depth = + if plen > 0 && plen <= 10 then ( + let plen' = + check_prefix ~prefix:header.prefix ~prefix_length:plen ~off:depth + key key_len + in + if plen' <> min 10 plen then raise Not_found; + depth + plen) + else if plen > 10 then ( + let prefix = Bytes.unsafe_of_string (minimum elt).key in + let plen' = + check_prefix ~prefix ~prefix_offset:depth ~prefix_length:plen + ~off:depth key key_len + in + if plen' <> plen then raise Not_found; + depth + plen) + else depth + in + let x = find_child node key.![depth] in + if x = not_found || Array.unsafe_get children x == empty_elt then + raise Not_found + else _find ~key ~key_len (depth + 1) (Array.unsafe_get children x) let find tree key = let key_len = String.length key in _find ~key ~key_len 0 !tree let find_opt tree key = - match find tree key with - | v -> Some v - | exception Not_found -> None - -let rec insert tree elt key_a len_a value_a depth = match elt with - | Node { header= Header { kind= NULL; _ }; _ } -> - tree := (Leaf { key= key_a; value= value_a; }) - | Node ({ header= Header record; children; } as node) -> - let plen = record.prefix_length in - let pdiff = prefix_mismatch node ~off:depth key_a len_a in - - if pdiff >= plen - then - let chr = key_a.![depth + plen] in - let leaf = Leaf { key= key_a; value= value_a; } in - match find_child node chr, record.kind with - | -1, N256 -> add_child_n256 record children chr leaf - | -1, N48 -> add_child_n48 record tree children chr leaf - | -1, N16 -> add_child_n16 record tree children chr leaf - | -1, N4 -> add_child_n4 record tree children chr leaf - | idx, _ -> - let cur = ref (Array.unsafe_get children (idx)) in - insert cur (Array.unsafe_get children idx) key_a len_a value_a (depth + plen + 1) ; - Array.unsafe_set children idx !cur - else - ( let node4 = n4 (Bytes.make 10 '\000') (* TODO(dinosaure): check that! *) in + match find tree key with v -> Some v | exception Not_found -> None + +let rec insert tree elt key_a len_a value_a depth = + match elt with + | Node { header = Header { kind = NULL; _ }; _ } -> + tree := Leaf { key = key_a; value = value_a } + | Node ({ header = Header record; children } as node) -> + let plen = record.prefix_length in + let pdiff = prefix_mismatch node ~off:depth key_a len_a in + + if pdiff >= plen then ( + let chr = key_a.![depth + plen] in + let leaf = Leaf { key = key_a; value = value_a } in + match (find_child node chr, record.kind) with + | -1, N256 -> add_child_n256 record children chr leaf + | -1, N48 -> add_child_n48 record tree children chr leaf + | -1, N16 -> add_child_n16 record tree children chr leaf + | -1, N4 -> add_child_n4 record tree children chr leaf + | idx, _ -> + let cur = ref (Array.unsafe_get children idx) in + insert cur + (Array.unsafe_get children idx) + key_a len_a value_a + (depth + plen + 1); + Array.unsafe_set children idx !cur) + else + let node4 = + n4 (Bytes.make 10 '\000') + (* TODO(dinosaure): check that! *) + in let children' = Array.make 4 empty_elt in let null = ref empty_elt in - node4.prefix_length <- pdiff - ; Bytes.unsafe_blit record.prefix 0 node4.prefix 0 (min 10 pdiff) - ; if plen <= 10 - then ( add_child_n4 node4 null children' record.prefix.!{pdiff} elt - ; let plen' = plen - (pdiff + 1) in - record.prefix_length <- plen' - ; Bytes.unsafe_blit record.prefix (pdiff + 1) record.prefix 0 (min 10 plen') ) - else ( let plen' = plen - (pdiff + 1) in - record.prefix_length <- plen' - ; let bot = minimum elt in - add_child_n4 node4 null children' bot.key.![depth + pdiff] elt - ; Bytes.blit_string bot.key (depth + pdiff + 1) record.prefix 0 (min 10 plen') ) - ; add_child_n4 node4 null children' key_a.![depth + pdiff] (Leaf { key= key_a; value= value_a; }) - ; tree := (Node { header= Header node4; children= children'; }) ) - | Leaf leaf -> - try - leaf_matches leaf ~off:depth key_a len_a ; tree := (Leaf { leaf with value= value_a }) - with Not_found -> - let node4 = n4 (Bytes.make 10 '\000') (* TODO(dinosaure): check that! *) in - let children = Array.make 4 empty_elt in - let null = ref empty_elt in - let plon = longest_common_prefix ~off:depth leaf.key key_a in - node4.prefix_length <- plon ; - Bytes.blit_string key_a depth node4.prefix 0 (min 10 plon) ; - add_child_n4 node4 null children leaf.key.![depth + plon] elt ; - add_child_n4 node4 null children key_a.![depth + plon] (Leaf { key= key_a; value= value_a; }) ; - tree := (Node { header= Header node4; children; }) -;; - -let insert tree key value = - insert tree !tree key (String.length key) value 0 - -let remove_child_n256 - : n256 record -> 'a elt ref -> 'a elt array -> char -> unit - = fun record tree children chr -> - children.(Char.code chr) <- empty_elt ; - record.count <- record.count - 1 ; - if record.count = 37 - then ( let node48 = n48 record.prefix in - copy_header ~src:record ~dst:node48 ; - let children' = Array.make 48 empty_elt in - let pos = ref 0 in - for i = 0 to 255 do - if children.(i) != empty_elt - then ( children'.(!pos) <- children.(i) - ; node48.keys.!{i} <- Char.unsafe_chr !pos - ; incr pos ) - done ; - tree := Node { header= Header node48; children= children' } ) - -let remove_child_n48 - : n48 record -> 'a elt ref -> 'a elt array -> char -> unit - = fun record tree children chr -> - let pos = Char.code record.keys.!{Char.code chr} in - record.keys.!{Char.code chr} <- '\048' ; - children.(pos) <- empty_elt ; - record.count <- record.count - 1 ; - if record.count = 12 - then ( let node16 = n16 record.prefix in - let children' = Array.make 16 empty_elt in - copy_header ~src:record ~dst:node16 ; - let child = ref 0 in - for i = 0 to 255 do - let pos = Char.code record.keys.!{i} in - if pos <> 48 - then ( node16.keys.!{!child} <- Char.chr i - ; children'.(!child) <- children.(pos) - ; incr child ) - done ; - tree := Node { header= Header node16; children= children' } ) - -let remove_child_n16 - : n16 record -> 'a elt ref -> 'a elt array -> int -> unit - = fun record tree children pos -> - Bytes.blit record.keys (pos + 1) record.keys pos (record.count - 1 - pos) ; - Array.blit children (pos + 1) children pos (record.count - 1 - pos) ; - for pos = record.count - 1 to 15 do children.(pos) <- empty_elt done ; - record.count <- record.count - 1 ; - if record.count == 3 - then ( let node4 = n4 record.prefix in - let children' = Array.make 4 empty_elt in - copy_header ~src:record ~dst:node4 ; - Bytes.unsafe_blit record.keys 0 node4.keys 0 3 - ; Array.blit children 0 children' 0 3 - ; copy_header ~src:record ~dst:node4 - ; tree := Node { header= Header node4; children= children' } ) - -let unsafe_get_key : type a. a record -> int -> char = fun record n -> match record.kind with + node4.prefix_length <- pdiff; + Bytes.unsafe_blit record.prefix 0 node4.prefix 0 (min 10 pdiff); + (if plen <= 10 then ( + add_child_n4 node4 null children' record.prefix.!{pdiff} elt; + let plen' = plen - (pdiff + 1) in + record.prefix_length <- plen'; + Bytes.unsafe_blit record.prefix (pdiff + 1) record.prefix 0 + (min 10 plen')) + else + let plen' = plen - (pdiff + 1) in + record.prefix_length <- plen'; + let bot = minimum elt in + add_child_n4 node4 null children' bot.key.![depth + pdiff] elt; + Bytes.blit_string bot.key + (depth + pdiff + 1) + record.prefix 0 (min 10 plen')); + add_child_n4 node4 null children' + key_a.![depth + pdiff] + (Leaf { key = key_a; value = value_a }); + tree := Node { header = Header node4; children = children' } + | Leaf leaf -> ( + try + leaf_matches leaf ~off:depth key_a len_a; + tree := Leaf { leaf with value = value_a } + with Not_found -> + let node4 = + n4 (Bytes.make 10 '\000') + (* TODO(dinosaure): check that! *) + in + let children = Array.make 4 empty_elt in + let null = ref empty_elt in + let plon = longest_common_prefix ~off:depth leaf.key key_a in + node4.prefix_length <- plon; + Bytes.blit_string key_a depth node4.prefix 0 (min 10 plon); + add_child_n4 node4 null children leaf.key.![depth + plon] elt; + add_child_n4 node4 null children + key_a.![depth + plon] + (Leaf { key = key_a; value = value_a }); + tree := Node { header = Header node4; children }) + +let insert tree key value = insert tree !tree key (String.length key) value 0 + +let remove_child_n256 : + n256 record -> 'a elt ref -> 'a elt array -> char -> unit = + fun record tree children chr -> + children.(Char.code chr) <- empty_elt; + record.count <- record.count - 1; + if record.count = 37 then ( + let node48 = n48 record.prefix in + copy_header ~src:record ~dst:node48; + let children' = Array.make 48 empty_elt in + let pos = ref 0 in + for i = 0 to 255 do + if children.(i) != empty_elt then ( + children'.(!pos) <- children.(i); + node48.keys.!{i} <- Char.unsafe_chr !pos; + incr pos) + done; + tree := Node { header = Header node48; children = children' }) + +let remove_child_n48 : n48 record -> 'a elt ref -> 'a elt array -> char -> unit + = + fun record tree children chr -> + let pos = Char.code record.keys.!{Char.code chr} in + record.keys.!{Char.code chr} <- '\048'; + children.(pos) <- empty_elt; + record.count <- record.count - 1; + if record.count = 12 then ( + let node16 = n16 record.prefix in + let children' = Array.make 16 empty_elt in + copy_header ~src:record ~dst:node16; + let child = ref 0 in + for i = 0 to 255 do + let pos = Char.code record.keys.!{i} in + if pos <> 48 then ( + node16.keys.!{!child} <- Char.chr i; + children'.(!child) <- children.(pos); + incr child) + done; + tree := Node { header = Header node16; children = children' }) + +let remove_child_n16 : n16 record -> 'a elt ref -> 'a elt array -> int -> unit = + fun record tree children pos -> + Bytes.blit record.keys (pos + 1) record.keys pos (record.count - 1 - pos); + Array.blit children (pos + 1) children pos (record.count - 1 - pos); + for pos = record.count - 1 to 15 do + children.(pos) <- empty_elt + done; + record.count <- record.count - 1; + if record.count == 3 then ( + let node4 = n4 record.prefix in + let children' = Array.make 4 empty_elt in + copy_header ~src:record ~dst:node4; + Bytes.unsafe_blit record.keys 0 node4.keys 0 3; + Array.blit children 0 children' 0 3; + copy_header ~src:record ~dst:node4; + tree := Node { header = Header node4; children = children' }) + +let unsafe_get_key : type a. a record -> int -> char = + fun record n -> + match record.kind with | N4 -> Bytes.unsafe_get record.keys n | N16 -> Bytes.unsafe_get record.keys n | N48 -> Bytes.unsafe_get record.keys n | N256 -> Char.unsafe_chr n - | NULL -> (assert false[@coverage off]) - -let remove_child_n4 - : n4 record -> 'a elt ref -> 'a elt array -> int -> unit - = fun record tree children pos -> - Bytes.blit record.keys (pos + 1) record.keys pos (record.count - 1 - pos) ; - Array.blit children (pos + 1) children pos (record.count - 1 - pos) ; - for pos = record.count - 1 to 3 do children.(pos) <- empty_elt done ; - if (record.count - 1 - pos) = 0 then children.(pos) <- empty_elt ; - (* XXX(dinosaure): remove trailing children. *) - record.count <- record.count - 1 ; - if record.count = 1 - then - match children.(0) with - | Leaf _ -> tree := children.(0) - | Node { header= Header ({ prefix_length; _ } as hdr); _ } as child -> + | NULL -> assert false [@coverage off] + +let remove_child_n4 : n4 record -> 'a elt ref -> 'a elt array -> int -> unit = + fun record tree children pos -> + Bytes.blit record.keys (pos + 1) record.keys pos (record.count - 1 - pos); + Array.blit children (pos + 1) children pos (record.count - 1 - pos); + for pos = record.count - 1 to 3 do + children.(pos) <- empty_elt + done; + if record.count - 1 - pos = 0 then children.(pos) <- empty_elt; + (* XXX(dinosaure): remove trailing children. *) + record.count <- record.count - 1; + if record.count = 1 then + match children.(0) with + | Leaf _ -> tree := children.(0) + | Node { header = Header ({ prefix_length; _ } as hdr); _ } as child -> let prefix = ref record.prefix_length in - if !prefix < 10 - then ( Bytes.unsafe_set record.prefix !prefix (unsafe_get_key record 0) - ; incr prefix ) ; - if !prefix < 10 - then ( let sub = min prefix_length (10 - !prefix) in - Bytes.blit hdr.prefix 0 record.prefix !prefix sub ; - prefix := !prefix + sub ) ; - Bytes.blit record.prefix 0 hdr.prefix 0 (min !prefix 10) ; - hdr.prefix_length <- hdr.prefix_length + record.prefix_length + 1 ; + if !prefix < 10 then ( + Bytes.unsafe_set record.prefix !prefix (unsafe_get_key record 0); + incr prefix); + if !prefix < 10 then ( + let sub = min prefix_length (10 - !prefix) in + Bytes.blit hdr.prefix 0 record.prefix !prefix sub; + prefix := !prefix + sub); + Bytes.blit record.prefix 0 hdr.prefix 0 (min !prefix 10); + hdr.prefix_length <- hdr.prefix_length + record.prefix_length + 1; tree := child -let remove_child - : 'a node -> 'a elt ref -> char -> int -> unit - = fun { header= Header record; children } tree chr pos -> - match record.kind with - | N4 -> remove_child_n4 record tree children pos - | N16 -> remove_child_n16 record tree children pos - | N48 -> remove_child_n48 record tree children chr - | N256 -> remove_child_n256 record tree children chr - | NULL -> (()[@coverage off]) - -let rec remove - : 'a elt -> 'a t -> string -> int -> int -> unit - = fun elt tree key key_len depth -> match elt with - | Node ({ header= Header header; children; } as node) -> +let remove_child : 'a node -> 'a elt ref -> char -> int -> unit = + fun { header = Header record; children } tree chr pos -> + match record.kind with + | N4 -> remove_child_n4 record tree children pos + | N16 -> remove_child_n16 record tree children pos + | N48 -> remove_child_n48 record tree children chr + | N256 -> remove_child_n256 record tree children chr + | NULL -> () [@coverage off] + +let rec remove : 'a elt -> 'a t -> string -> int -> int -> unit = + fun elt tree key key_len depth -> + match elt with + | Node ({ header = Header header; children } as node) -> ( let plen = header.prefix_length in let depth = - if plen > 0 && plen <= 10 - then ( let plen' = check_prefix ~prefix:header.prefix ~prefix_length:plen ~off:depth key key_len in - if plen' <> min 10 plen then raise Not_found - ; depth + plen ) - else if plen > 10 - then ( let prefix = Bytes.unsafe_of_string (minimum elt).key in - let plen' = check_prefix ~prefix ~prefix_offset:depth ~prefix_length:plen ~off:depth key key_len in - if plen' <> plen then raise Not_found - ; depth + plen ) - else depth in + if plen > 0 && plen <= 10 then ( + let plen' = + check_prefix ~prefix:header.prefix ~prefix_length:plen ~off:depth + key key_len + in + if plen' <> min 10 plen then raise Not_found; + depth + plen) + else if plen > 10 then ( + let prefix = Bytes.unsafe_of_string (minimum elt).key in + let plen' = + check_prefix ~prefix ~prefix_offset:depth ~prefix_length:plen + ~off:depth key key_len + in + if plen' <> plen then raise Not_found; + depth + plen) + else depth + in let x = find_child node key.![depth] in - if x = not_found || Array.unsafe_get children x == empty_elt - then raise Not_found + if x = not_found || Array.unsafe_get children x == empty_elt then + raise Not_found else - ( match children.(x) with + match children.(x) with | Leaf leaf -> - leaf_matches leaf ~off:depth key key_len ; - remove_child node tree key.![depth] x + leaf_matches leaf ~off:depth key key_len; + remove_child node tree key.![depth] x | Node _ as child -> - let cur = ref child in - remove child cur key key_len (succ depth) - ; children.(x) <- !cur ) - | Leaf leaf -> - leaf_matches leaf ~off:depth key key_len ; tree := empty_elt + let cur = ref child in + remove child cur key key_len (succ depth); + children.(x) <- !cur) + | Leaf leaf -> + leaf_matches leaf ~off:depth key key_len; + tree := empty_elt let rec iter ~f acc = function - | Leaf { key; value; } -> f key value acc + | Leaf { key; value } -> f key value acc | Node { children; _ } -> - let acc = ref acc in - for i = 0 to Array.length children - 1 do acc := iter ~f !acc children.(i) done ; - !acc + let acc = ref acc in + for i = 0 to Array.length children - 1 do + acc := iter ~f !acc children.(i) + done; + !acc let leaf_prefix_matches leaf prefix = - if String.length leaf.key < String.length prefix - then raise Not_found + if String.length leaf.key < String.length prefix then raise Not_found else memcmp leaf.key prefix ~off:0 ~len:(String.length prefix) let rec prefix_iter ~prefix ~f acc tree = - if !tree == empty_elt then raise Not_found ; + if !tree == empty_elt then raise Not_found; go ~prefix ~f acc 0 !tree + and go ~prefix ~f acc depth elt = match elt with | Node _ when depth = String.length prefix -> - leaf_prefix_matches (minimum elt) prefix ; (* XXX(dinosaure): or [Not_found] *) - iter ~f acc elt + leaf_prefix_matches (minimum elt) prefix; + (* XXX(dinosaure): or [Not_found] *) + iter ~f acc elt | Leaf leaf -> - leaf_prefix_matches leaf prefix ; (* XXX(dinosaure): or [Not_found] *) - f leaf.key leaf.value acc - | Node ({ header= Header { prefix_length= 0; _ }; children; } as node) -> - let x = find_child node prefix.![depth] in - if x = not_found || Array.unsafe_get children x == empty_elt - then raise Not_found ; - go ~prefix ~f acc (depth + 1) (Array.unsafe_get children x) - | Node ({ header= Header { prefix_length; _ }; children; } as node) -> - let plen = prefix_mismatch node ~off:depth prefix (String.length prefix) in - let plen = if plen > prefix_length then prefix_length else plen in - if plen = 0 then raise Not_found ; - if plen + depth = String.length prefix - then iter ~f acc elt - else - let x = find_child node prefix.![depth + prefix_length] in - ( if x = not_found || Array.unsafe_get children x == empty_elt - then raise Not_found - ; go ~prefix ~f acc (depth + prefix_length + 1) (Array.unsafe_get children x) ) + leaf_prefix_matches leaf prefix; + (* XXX(dinosaure): or [Not_found] *) + f leaf.key leaf.value acc + | Node ({ header = Header { prefix_length = 0; _ }; children } as node) -> + let x = find_child node prefix.![depth] in + if x = not_found || Array.unsafe_get children x == empty_elt then + raise Not_found; + go ~prefix ~f acc (depth + 1) (Array.unsafe_get children x) + | Node ({ header = Header { prefix_length; _ }; children } as node) -> + let plen = + prefix_mismatch node ~off:depth prefix (String.length prefix) + in + let plen = if plen > prefix_length then prefix_length else plen in + if plen = 0 then raise Not_found; + if plen + depth = String.length prefix then iter ~f acc elt + else + let x = find_child node prefix.![depth + prefix_length] in + if x = not_found || Array.unsafe_get children x == empty_elt then + raise Not_found; + go ~prefix ~f acc + (depth + prefix_length + 1) + (Array.unsafe_get children x) let minimum tree = - let { value; key; } = minimum !tree in - key, value + let { value; key } = minimum !tree in + (key, value) let maximum tree = - let { value; key; } = maximum !tree in - key, value + let { value; key } = maximum !tree in + (key, value) let make () = ref empty_elt - let is_empty v = !v == empty_elt let remove tree key = - if !tree == empty_elt then raise Not_found ; + if !tree == empty_elt then raise Not_found; remove !tree tree key (String.length key) 0 let iter ~f acc tree = iter ~f acc !tree -type 'a enumerate = End | More of key * 'a * 'a elt * 'a enumerate +type 'a enumerate = End | More of key * 'a * 'a elt * 'a enumerate -let rec cons_enum elt e = match elt with - | Leaf { key; value; } -> More (key, value, empty_elt, e) +let rec cons_enum elt e = + match elt with + | Leaf { key; value } -> More (key, value, empty_elt, e) | Node { children; _ } -> - Array.fold_left (fun e elt -> cons_enum elt e) e children + Array.fold_left (fun e elt -> cons_enum elt e) e children -let rec seq_of_enum c () = match c with +let rec seq_of_enum c () = + match c with | End -> Seq.Nil | More (k, v, t, r) -> Seq.Cons ((k, v), seq_of_enum (cons_enum t r)) @@ -663,5 +744,5 @@ let to_seq tree = seq_of_enum (cons_enum !tree End) let of_seq seq = let tree = make () in - Seq.iter (fun (k, v) -> insert tree k v) seq ; + Seq.iter (fun (k, v) -> insert tree k v) seq; tree diff --git a/lib/art.mli b/lib/art.mli index 131b285..0a41f10 100644 --- a/lib/art.mli +++ b/lib/art.mli @@ -18,7 +18,6 @@ type key = private string (** The type of the tree keys. A {i null-terminated} [string]. *) val key : string -> key - external unsafe_key : string -> key = "%identity" val make : unit -> 'a t @@ -67,7 +66,8 @@ val of_seq : (key * 'a) Seq.t -> 'a t val to_seq : 'a t -> (key * 'a) Seq.t (** Iterate on the whole map, in increasing order of keys. *) -val prefix_iter : prefix:key -> f:(key -> 'a -> 'acc -> 'acc) -> 'acc -> 'a t -> 'acc +val prefix_iter : + prefix:key -> f:(key -> 'a -> 'acc -> 'acc) -> 'acc -> 'a t -> 'acc (** [prefix_iter ~prefix ~f a t] computes [(f kN dN .. (f k1 d1 a) ...)], where [k1 ... kN] are prefixed by [prefix] in [t] (in increasing order), and [d1 ... dN] are associated data. diff --git a/lib/dune b/lib/dune index 3eef9e5..d47a97d 100644 --- a/lib/dune +++ b/lib/dune @@ -11,7 +11,7 @@ (name rowex) (modules rowex) (public_name rowex) - (libraries atomic ipc fmt logs) + (libraries hxd.core hxd.string atomic ipc fmt logs) (ocamlopt_flags -O3) (foreign_stubs (language c) diff --git a/lib/hashset.ml b/lib/hashset.ml index 020d070..e534364 100644 --- a/lib/hashset.ml +++ b/lib/hashset.ml @@ -18,9 +18,11 @@ (* We do dynamic hashing, and resize the table and rehash the elements when buckets become too long. *) -type 'a t = - { mutable size: int; (* number of elements *) - mutable data: 'a list array } (* the buckets *) +type 'a t = { + mutable size : int; (* number of elements *) + mutable data : 'a list array; +} +(* the buckets *) let create initial_size = let s = min (max 1 initial_size) Sys.max_array_length in @@ -32,50 +34,48 @@ let clear h = done; h.size <- 0 -let copy h = - { size = h.size; - data = Array.copy h.data } +let copy h = { size = h.size; data = Array.copy h.data } let resize hashfun tbl = let odata = tbl.data in let osize = Array.length odata in - let nsize = min (2 * osize + 1) Sys.max_array_length in - if nsize <> osize then begin + let nsize = min ((2 * osize) + 1) Sys.max_array_length in + if nsize <> osize then ( let ndata = Array.make nsize [] in let rec insert_bucket = function - [] -> () + | [] -> () | key :: rest -> - insert_bucket rest; (* preserve original order of elements *) - let nidx = (hashfun key) mod nsize in - ndata.(nidx) <- key :: ndata.(nidx) in + insert_bucket rest; + (* preserve original order of elements *) + let nidx = hashfun key mod nsize in + ndata.(nidx) <- key :: ndata.(nidx) + in for i = 0 to osize - 1 do insert_bucket odata.(i) done; - tbl.data <- ndata; - end + tbl.data <- ndata) let add h key = - let i = (Hashtbl.hash key) mod (Array.length h.data) in + let i = Hashtbl.hash key mod Array.length h.data in let bucket = h.data.(i) in - if not (List.mem key bucket) then begin + if not (List.mem key bucket) then ( h.data.(i) <- key :: bucket; h.size <- succ h.size; - if h.size > Array.length h.data lsl 1 then resize Hashtbl.hash h - end + if h.size > Array.length h.data lsl 1 then resize Hashtbl.hash h) let remove h key = let rec remove_bucket = function - [] -> - [] + | [] -> [] | k :: next -> - if k = key - then begin h.size <- pred h.size; next end - else k :: remove_bucket next in - let i = (Hashtbl.hash key) mod (Array.length h.data) in + if k = key then ( + h.size <- pred h.size; + next) + else k :: remove_bucket next + in + let i = Hashtbl.hash key mod Array.length h.data in h.data.(i) <- remove_bucket h.data.(i) -let mem h key = - List.mem key h.data.((Hashtbl.hash key) mod (Array.length h.data)) +let mem h key = List.mem key h.data.(Hashtbl.hash key mod Array.length h.data) let cardinal h = let d = h.data in @@ -93,11 +93,8 @@ let iter f h = let fold f h init = let rec do_bucket b accu = - match b with - [] -> - accu - | k :: rest -> - do_bucket rest (f k accu) in + match b with [] -> accu | k :: rest -> do_bucket rest (f k accu) + in let d = h.data in let accu = ref init in for i = 0 to Array.length d - 1 do @@ -107,68 +104,66 @@ let fold f h init = (* Functorial interface *) -module type HashedType = - sig - type t - val equal: t -> t -> bool - val hash: t -> int - end - -module type S = - sig - type elt - type t - val create: int -> t - val clear: t -> unit - val copy: t -> t - val add: t -> elt -> unit - val remove: t -> elt -> unit - val mem : t -> elt -> bool - val cardinal: t -> int - val iter: (elt -> unit) -> t -> unit - val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a - end - -module Make(H: HashedType): (S with type elt = H.t) = - struct - type elt = H.t - type set = elt t - type t = set - let create = create - let clear = clear - let copy = copy - - let safehash key = (H.hash key) land max_int - - let rec mem_in_bucket key = function - | [] -> false - | x :: r -> H.equal key x || mem_in_bucket key r - - let add h key = - let i = (safehash key) mod (Array.length h.data) in - let bucket = h.data.(i) in - if not (mem_in_bucket key bucket) then begin - h.data.(i) <- key :: bucket; - h.size <- succ h.size; - if h.size > Array.length h.data lsl 1 then resize safehash h - end - - let remove h key = - let rec remove_bucket = function - [] -> - [] - | k :: next -> - if H.equal k key - then begin h.size <- pred h.size; next end - else k :: remove_bucket next in - let i = (safehash key) mod (Array.length h.data) in - h.data.(i) <- remove_bucket h.data.(i) - - let mem h key = - mem_in_bucket key h.data.((safehash key) mod (Array.length h.data)) - - let cardinal = cardinal - - let iter = iter - let fold = fold - end +module type HashedType = sig + type t + + val equal : t -> t -> bool + val hash : t -> int +end + +module type S = sig + type elt + type t + + val create : int -> t + val clear : t -> unit + val copy : t -> t + val add : t -> elt -> unit + val remove : t -> elt -> unit + val mem : t -> elt -> bool + val cardinal : t -> int + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a +end + +module Make (H : HashedType) : S with type elt = H.t = struct + type elt = H.t + type set = elt t + type t = set + + let create = create + let clear = clear + let copy = copy + let safehash key = H.hash key land max_int + + let rec mem_in_bucket key = function + | [] -> false + | x :: r -> H.equal key x || mem_in_bucket key r + + let add h key = + let i = safehash key mod Array.length h.data in + let bucket = h.data.(i) in + if not (mem_in_bucket key bucket) then ( + h.data.(i) <- key :: bucket; + h.size <- succ h.size; + if h.size > Array.length h.data lsl 1 then resize safehash h) + + let remove h key = + let rec remove_bucket = function + | [] -> [] + | k :: next -> + if H.equal k key then ( + h.size <- pred h.size; + next) + else k :: remove_bucket next + in + let i = safehash key mod Array.length h.data in + h.data.(i) <- remove_bucket h.data.(i) + + let mem h key = + mem_in_bucket key h.data.(safehash key mod Array.length h.data) + + let cardinal = cardinal + let iter = iter + let fold = fold +end diff --git a/lib/hashset.mli b/lib/hashset.mli index 5d7eb8a..4b6d8d5 100644 --- a/lib/hashset.mli +++ b/lib/hashset.mli @@ -13,8 +13,8 @@ (* *) (**************************************************************************) -(* This module implements imperative sets as hash tables. - Operations like union, intersection or difference are not provided, +(* This module implements imperative sets as hash tables. + Operations like union, intersection or difference are not provided, since there is no way to implement them easily (i.e. more easily than iterating over sets). *) @@ -58,42 +58,42 @@ val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b where [e1 ... eN] are the elements in [s]. The order in which the elements are passed to [f] is unspecified. *) - (*s Functorial interface *) -module type HashedType = - sig - type t - (* The type of the elements. *) - val equal : t -> t -> bool - (* The equality predicate used to compare elements. *) - val hash : t -> int - (* A hashing function on elements. It must be such that if two elements are - equal according to [equal], then they have identical hash values - as computed by [hash]. - Examples: suitable ([equal], [hash]) pairs for arbitrary element - types include - ([(=)], {!Hashset.hash}) for comparing objects by structure, and - ([(==)], {!Hashset.hash}) for comparing objects by addresses - (e.g. for mutable or cyclic keys). *) - end +module type HashedType = sig + type t + (* The type of the elements. *) + + val equal : t -> t -> bool + (* The equality predicate used to compare elements. *) + + val hash : t -> int + (* A hashing function on elements. It must be such that if two elements are + equal according to [equal], then they have identical hash values + as computed by [hash]. + Examples: suitable ([equal], [hash]) pairs for arbitrary element + types include + ([(=)], {!Hashset.hash}) for comparing objects by structure, and + ([(==)], {!Hashset.hash}) for comparing objects by addresses + (e.g. for mutable or cyclic keys). *) +end (* The input signature of the functor {!Hashset.Make}. *) -module type S = - sig - type elt - type t - val create : int -> t - val clear : t -> unit - val copy : t -> t - val add : t -> elt -> unit - val remove : t -> elt -> unit - val mem : t -> elt -> bool - val cardinal : t -> int - val iter : (elt -> unit) -> t -> unit - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - end +module type S = sig + type elt + type t + + val create : int -> t + val clear : t -> unit + val copy : t -> t + val add : t -> elt -> unit + val remove : t -> elt -> unit + val mem : t -> elt -> bool + val cardinal : t -> int + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a +end (* The output signature of the functor {!Hashset.Make}. *) module Make (H : HashedType) : S with type elt = H.t @@ -104,4 +104,3 @@ module Make (H : HashedType) : S with type elt = H.t interface, but use the hashing and equality functions specified in the functor argument [H] instead of generic equality and hashing. *) - diff --git a/lib/mem.ml b/lib/mem.ml index 1c94ac4..6e36c56 100644 --- a/lib/mem.ml +++ b/lib/mem.ml @@ -1,6 +1,7 @@ open Rowex let src = Logs.Src.create "rowex.mem" + module Log = (val Logs.src_log src : Logs.LOG) external bytes_get_uint16 : bytes -> int -> int = "%caml_bytes_get16" @@ -14,33 +15,27 @@ external swap32 : int32 -> int32 = "%bswap_int32" external swap64 : int64 -> int64 = "%bswap_int64" let bytes_get_leuint16 = - if Sys.big_endian - then fun buf idx -> swap16 (bytes_get_uint16 buf idx) + if Sys.big_endian then fun buf idx -> swap16 (bytes_get_uint16 buf idx) else bytes_get_uint16 let bytes_get_leuint32 = - if Sys.big_endian - then fun buf idx -> swap32 (bytes_get_uint32 buf idx) + if Sys.big_endian then fun buf idx -> swap32 (bytes_get_uint32 buf idx) else bytes_get_uint32 let bytes_get_leuint64 = - if Sys.big_endian - then fun buf idx -> swap64 (bytes_get_uint64 buf idx) + if Sys.big_endian then fun buf idx -> swap64 (bytes_get_uint64 buf idx) else bytes_get_uint64 let bytes_set_leuint16 = - if Sys.big_endian - then fun buf idx v -> bytes_set_uint16 buf idx (swap16 v) + if Sys.big_endian then fun buf idx v -> bytes_set_uint16 buf idx (swap16 v) else bytes_set_uint16 let bytes_set_leuint32 = - if Sys.big_endian - then fun buf idx v -> bytes_set_uint32 buf idx (swap32 v) + if Sys.big_endian then fun buf idx v -> bytes_set_uint32 buf idx (swap32 v) else bytes_set_uint32 let bytes_set_leuint64 = - if Sys.big_endian - then fun buf idx v -> bytes_set_uint64 buf idx (swap64 v) + if Sys.big_endian then fun buf idx v -> bytes_set_uint64 buf idx (swap64 v) else bytes_set_uint64 (** This module does not want to provide an optimised version of ROWEX nor @@ -49,47 +44,57 @@ let bytes_set_leuint64 = regardless ACID properties. Don't use it! *) -module Make (Memory : sig val memory : bytes end) = struct +module Make (Memory : sig + val memory : bytes +end) = +struct type 'a t = 'a open Memory let bind x f = f x let return x = x - let get : type c v. 'a Addr.t -> (c, v) value -> v t = fun addr t -> - let addr = Addr.unsafe_to_int addr in (* TODO(dinosaure): [(addr :> int)] does not work, why? *) + + let get : type c v. 'a Addr.t -> (c, v) value -> v t = + fun addr t -> + let addr = Addr.unsafe_to_int addr in + (* TODO(dinosaure): [(addr :> int)] does not work, why? *) match t with | Int8 -> Bytes.get memory addr |> Char.code | LEInt when Sys.word_size = 32 -> bytes_get_leuint32 memory addr |> Int32.to_int | LEInt when Sys.word_size = 64 -> bytes_get_leuint64 memory addr |> Int64.to_int - | LEInt16 -> - bytes_get_leuint16 memory addr - | LEInt31 -> - bytes_get_leuint32 memory addr |> Int32.to_int - | LEInt64 -> - bytes_get_leuint64 memory addr - | LEInt128 -> - Bytes.sub_string memory addr (addr + 16) + | LEInt16 -> bytes_get_leuint16 memory addr + | LEInt31 -> bytes_get_leuint32 memory addr |> Int32.to_int + | LEInt64 -> bytes_get_leuint64 memory addr + | LEInt128 -> Bytes.sub_string memory addr (addr + 16) | Addr_rd when Sys.word_size = 32 -> bytes_get_leuint32 memory addr |> Int32.to_int |> Addr.of_int_to_rdonly + | Addr_rdwr when Sys.word_size = 32 -> + bytes_get_leuint32 memory addr |> Int32.to_int |> Addr.of_int_to_rdwr | Addr_rd when Sys.word_size = 64 -> bytes_get_leuint64 memory addr |> Int64.to_int |> Addr.of_int_to_rdonly + | Addr_rdwr when Sys.word_size = 64 -> + bytes_get_leuint64 memory addr |> Int64.to_int |> Addr.of_int_to_rdwr | C_string -> let buf = Buffer.create 0x10 in let idx = ref 0 in - while Bytes.get memory (addr + !idx) <> '\000' - do Buffer.add_char buf (Bytes.get memory (addr + !idx)) ; incr idx done ; - Log.debug (fun m -> m "%016x loaded (%d byte(s)): %S" addr !idx (Buffer.contents buf)); + while Bytes.get memory (addr + !idx) <> '\000' do + Buffer.add_char buf (Bytes.get memory (addr + !idx)); + incr idx + done; + Log.debug (fun m -> m "%016x loaded (%d byte(s)):" addr !idx); + Log.debug (fun m -> + m "@[%a@]" (Hxd_string.pp Hxd.default) (Buffer.contents buf)); Buffer.contents buf - | LEInt | Addr_rd -> assert false + | LEInt | Addr_rd | Addr_rdwr -> assert false let atomic_get : type v. 'a rd Addr.t -> (atomic, v) value -> v t = - fun addr k -> get addr k + fun addr k -> get addr k let atomic_set : type v. 'a wr Addr.t -> (atomic, v) value -> v -> unit t = - fun addr t v -> + fun addr t v -> let addr = Addr.unsafe_to_int addr in match t with | Int8 -> Bytes.set memory addr (Char.chr v) @@ -97,19 +102,19 @@ module Make (Memory : sig val memory : bytes end) = struct bytes_set_leuint32 memory addr (Int32.of_int v) | LEInt when Sys.word_size = 64 -> bytes_set_leuint64 memory addr (Int64.of_int v) - | LEInt16 -> - bytes_set_leuint16 memory addr v - | LEInt31 -> - bytes_set_leuint32 memory addr (Int32.of_int v) - | LEInt64 -> - bytes_set_leuint64 memory addr v - | LEInt128 -> - Bytes.blit memory addr (Bytes.of_string v) 0 16 + | LEInt16 -> bytes_set_leuint16 memory addr v + | LEInt31 -> bytes_set_leuint32 memory addr (Int32.of_int v) + | LEInt64 -> bytes_set_leuint64 memory addr v + | LEInt128 -> Bytes.blit memory addr (Bytes.of_string v) 0 16 | Addr_rd when Sys.word_size = 32 -> bytes_set_leuint32 memory addr (Int32.of_int (Addr.unsafe_to_int v)) + | Addr_rdwr when Sys.word_size = 32 -> + bytes_set_leuint32 memory addr (Int32.of_int (Addr.unsafe_to_int v)) | Addr_rd when Sys.word_size = 64 -> bytes_set_leuint64 memory addr (Int64.of_int (Addr.unsafe_to_int v)) - | LEInt | Addr_rd -> assert false + | Addr_rdwr when Sys.word_size = 64 -> + bytes_set_leuint64 memory addr (Int64.of_int (Addr.unsafe_to_int v)) + | LEInt | Addr_rd | Addr_rdwr -> assert false let now () = int_of_float (Unix.gettimeofday ()) let free = Hashtbl.create 0x10 @@ -117,70 +122,88 @@ module Make (Memory : sig val memory : bytes end) = struct let brk = ref 0 let delete addr len = - try let vs = Hashtbl.find free len in - Hashtbl.add free len (Addr.unsafe_to_int addr :: vs) - with Not_found -> - Hashtbl.add free len [ Addr.unsafe_to_int addr ] + try + let vs = Hashtbl.find free len in + Hashtbl.add free len (Addr.unsafe_to_int addr :: vs) + with Not_found -> Hashtbl.add free len [ Addr.unsafe_to_int addr ] let collect () = let commit = now () in - Hashtbl.filter_map_inplace (fun time (addr, len) -> - if time < commit - then ( delete (Addr.of_int_to_rdwr addr) len ; None ) - else Some (addr, len)) keep + Hashtbl.filter_map_inplace + (fun time (addr, len) -> + if time < commit then ( + delete (Addr.of_int_to_rdwr addr) len; + None) + else Some (addr, len)) + keep let lint ~kind addr len payloads = Bytes.blit_string (String.concat "" payloads) 0 memory addr len; - if kind = `Node then bytes_set_leuint64 memory (addr + _header_owner) (Int64.of_int (now ())) + if kind = `Node then + bytes_set_leuint64 memory (addr + _header_owner) (Int64.of_int (now ())) let allocate ~kind ?len payloads = - let len = match len with + let len = + match len with | Some len -> len - | None -> List.fold_left (fun a s -> a + String.length s) 0 payloads in + | None -> List.fold_left (fun a s -> a + String.length s) 0 payloads + in let rec alloc tries = - if tries <= 0 - then - if !brk + len > Bytes.length memory - then raise Out_of_memory - else ( let addr = !brk in - lint ~kind addr len payloads - ; brk := !brk + len - ; Addr.of_int_to_rdwr addr ) - else match Hashtbl.find_opt free len with - | None | Some [] -> collect () ; alloc (pred tries) - | Some (cell :: rest) -> - Hashtbl.replace free len rest; - lint ~kind cell len payloads; - Addr.of_int_to_rdwr cell in + if tries <= 0 then ( + if !brk + len > Bytes.length memory then raise Out_of_memory + else + let addr = !brk in + lint ~kind addr len payloads; + brk := !brk + len; + Addr.of_int_to_rdwr addr) + else + match Hashtbl.find_opt free len with + | None | Some [] -> + collect (); + alloc (pred tries) + | Some (cell :: rest) -> + Hashtbl.replace free len rest; + lint ~kind cell len payloads; + Addr.of_int_to_rdwr cell + in alloc 1 - let collect : _ Addr.t -> len:int -> uid:int -> unit = fun addr ~len ~uid:time -> + let collect : _ Addr.t -> len:int -> uid:int -> unit = + fun addr ~len ~uid:time -> Hashtbl.add keep time (Addr.unsafe_to_int addr, len) - let fetch_add - : rdwr Addr.t -> (atomic, int) value -> int -> int t - = fun addr t v -> - let v' = get addr t in - atomic_set addr t (v + v') ; v' - - let fetch_or - : rdwr Addr.t -> (atomic, int) value -> int -> int t - = fun addr t v -> - let v' = get addr t in - atomic_set addr t (v lor v') ; v' - - let fetch_sub - : rdwr Addr.t -> (atomic, int) value -> int -> int t - = fun addr t v -> - let v' = get addr t in - atomic_set addr t (v - v') ; v' - - let compare_exchange - : type v. ?weak:bool -> rdwr Addr.t -> (atomic, v) value -> v Atomic.t -> v -> bool t - = fun ?weak:_ addr t seen v -> - let v' = get addr t in - if v' = Atomic.get seen then ( atomic_set addr t v ; true ) - else false + let fetch_add : rdwr Addr.t -> (atomic, int) value -> int -> int t = + fun addr t v -> + let v' = get addr t in + atomic_set addr t (v + v'); + v' + + let fetch_or : rdwr Addr.t -> (atomic, int) value -> int -> int t = + fun addr t v -> + let v' = get addr t in + atomic_set addr t (v lor v'); + v' + + let fetch_sub : rdwr Addr.t -> (atomic, int) value -> int -> int t = + fun addr t v -> + let v' = get addr t in + atomic_set addr t (v - v'); + v' + + let compare_exchange : + type v. + ?weak:bool -> + rdwr Addr.t -> + (atomic, v) value -> + v Atomic.t -> + v -> + bool t = + fun ?weak:_ addr t seen v -> + let v' = get addr t in + if v' = Atomic.get seen then ( + atomic_set addr t v; + true) + else false let pause_intrinsic = () let persist _addr ~len:_ = () diff --git a/lib/mem.mli b/lib/mem.mli index e789e67..305fa05 100644 --- a/lib/mem.mli +++ b/lib/mem.mli @@ -1 +1,3 @@ -module Make (S : sig val memory : bytes end) : Rowex.S with type 'a t = 'a +module Make (S : sig + val memory : bytes +end) : Rowex.S with type 'a t = 'a diff --git a/lib/part.ml b/lib/part.ml index 7064f66..2e67302 100644 --- a/lib/part.ml +++ b/lib/part.ml @@ -1,6 +1,7 @@ open Rowex let src = Logs.Src.create "part" + module Log = (val Logs.src_log src : Logs.LOG) external msync : Persistent.memory -> unit = "part_msync" [@@noalloc] @@ -10,8 +11,11 @@ type 'c capabilities = | Writer : rdwr capabilities type ('fd, 'c) fd = - | Truncate_and_file_descr : Ipc.t * Unix.file_descr -> (Unix.file_descr, rdwr) fd + | Truncate_and_file_descr : + Ipc.t * Unix.file_descr + -> (Unix.file_descr, rdwr) fd | Truncate : Ipc.t -> (none, ro) fd + and none = | let reader uid = Reader uid @@ -21,7 +25,9 @@ type 'c opened = | constraint 'c = < .. > type closed = | type 'v state = - | Opened : 'c Persistent.mmu * 'c capabilities * ('fd, 'c) fd -> 'c opened state + | Opened : + 'c Persistent.mmu * 'c capabilities * ('fd, 'c) fd + -> 'c opened state | Closed : closed state let closed = Closed @@ -30,21 +36,26 @@ type ('p, 'q, 'a) t = | Return : 'a -> ('p, 'p, 'a) t | Bind : ('p, 'q, 'a) t * ('a -> ('q, 'r, 'b) t) -> ('p, 'r, 'b) t | Open : 'c capabilities * string -> (closed, 'c opened, unit) t - | Create : string * int -> (closed, closed, (unit, [> `Msg of string ]) result) t + | Create : + string * int + -> (closed, closed, (unit, [> `Msg of string ]) result) t | Close : ('c opened, closed, unit) t | Find : key -> ('c rd opened, 'c rd opened, int) t - | Insert : key * int -> (rdwr opened, rdwr opened, (unit, [> `Already_exists ]) result) t + | Remove : key -> (rdwr opened, rdwr opened, unit) t + | Insert : + key * int + -> (rdwr opened, rdwr opened, (unit, [> `Already_exists ]) result) t let return x = Return x let open_index c ~path = Open (c, path) let find key = Find key let insert key value = Insert (key, value) +let remove key = Remove key let close = Close let bind x f = Bind (x, f) -let create ?(len= 1048576) path = Create (path, len) +let create ?(len = 1048576) path = Create (path, len) let ( let* ) = bind - let is_closed : type v. v state -> bool = function | Closed -> true | Opened _ -> false @@ -94,117 +105,168 @@ let signal_readers readers = let rec waiting_readers trc readers = match Persistent.Hashset.cardinal readers with | 0 -> () - | _len when Ipc.is_empty trc -> - waiting_readers trc readers + | _len when Ipc.is_empty trc -> waiting_readers trc readers | _len -> - let pid = Ipc.dequeue trc in - let pid = Int64.to_int pid in - if Persistent.Hashset.mem readers pid - then Persistent.Hashset.remove readers pid ; - waiting_readers trc readers - -let truncate - : type v c. Ipc.t -> (v, c) fd -> readers:int Persistent.Hashset.t -> Persistent.memory -> len:int64 -> Persistent.memory - = fun ipc -> function + let pid = Ipc.dequeue trc in + let pid = Int64.to_int pid in + if Persistent.Hashset.mem readers pid then + Persistent.Hashset.remove readers pid; + waiting_readers trc readers + +let truncate : + type v c. + Ipc.t -> + (v, c) fd -> + readers:int Persistent.Hashset.t -> + Persistent.memory -> + len:int64 -> + Persistent.memory = + fun ipc -> function | Truncate _ -> fun ~readers:_ _memory ~len:_ -> failwith "Illegal truncate" - | Truncate_and_file_descr (trc, fd) -> fun ~readers memory ~len -> - let old = Unix.LargeFile.fstat fd in - let len = Int64.(div (add len (of_int page_size)) (of_int page_size)) in - let len = Int64.(mul len (of_int page_size)) in - try - let f _ipc = - signal_readers readers ; waiting_readers trc readers ; msync memory ; - Unix.LargeFile.ftruncate fd len ; - let memory = Mmap.V1.map_file fd - ~pos:0L Bigarray.char Bigarray.c_layout true [| Int64.to_int len |] in - Bigarray.array1_of_genarray memory in - Ipc.with_lock ~f ipc - with Unix.Unix_error (err, f, arg) as exn -> - Log.err (fun m -> m "%s(%s) : %s (ftruncate 'fd:%Ld ~len:%Ld)" - f arg (Unix.error_message err) old.Unix.LargeFile.st_size len) ; - raise exn + | Truncate_and_file_descr (trc, fd) -> ( + fun ~readers memory ~len -> + let old = Unix.LargeFile.fstat fd in + let len = Int64.(div (add len (of_int page_size)) (of_int page_size)) in + let len = Int64.(mul len (of_int page_size)) in + try + let f _ipc = + signal_readers readers; + waiting_readers trc readers; + msync memory; + Unix.LargeFile.ftruncate fd len; + let memory = + Mmap.V1.map_file fd ~pos:0L Bigarray.char Bigarray.c_layout true + [| Int64.to_int len |] + in + Bigarray.array1_of_genarray memory + in + Ipc.with_lock ~f ipc + with Unix.Unix_error (err, f, arg) as exn -> + Log.err (fun m -> + m "%s(%s) : %s (ftruncate 'fd:%Ld ~len:%Ld)" f arg + (Unix.error_message err) old.Unix.LargeFile.st_size len); + raise exn) let rec remap trc path mmu _sigusr1 = let f _ipc = let fd = Unix.openfile path Unix.[ O_RDWR ] 0o644 in let len = (Unix.fstat fd).st_size in - let memory = Mmap.V1.map_file fd ~pos:0L Bigarray.char Bigarray.c_layout true [| len |] in + let memory = + Mmap.V1.map_file fd ~pos:0L Bigarray.char Bigarray.c_layout true [| len |] + in let memory = Bigarray.array1_of_genarray memory in - Unix.close fd ; memory in - Ipc.enqueue trc (Int64.of_int (Unix.getpid ())) ; + Unix.close fd; + memory + in + Ipc.enqueue trc (Int64.of_int (Unix.getpid ())); let memory = Ipc.with_lock ~f (Persistent.ipc mmu) in - Persistent.unsafe_set_memory mmu memory ; - Log.info (fun m -> m "Reader updated its virtual memory.") ; + Persistent.unsafe_set_memory mmu memory; + Log.info (fun m -> m "Reader updated its virtual memory."); Sys.set_signal Sys.sigusr1 (Signal_handle (remap trc path mmu)) -let rec run - : type a p q. p state -> (p, q, a) t -> q state * a - = fun s m -> match m, s with - | Return x, _ -> s, x - | Bind (m, f), _ -> let s, x = run s m in run s (f x) +let rec run : type a p q. p state -> (p, q, a) t -> q state * a = + fun s m -> + match (m, s) with + | Return x, _ -> (s, x) + | Bind (m, f), _ -> + let s, x = run s m in + run s (f x) | Find key, Opened (mmu, capabilities, fd) -> - Opened (mmu, capabilities, fd), - Persistent.(run mmu (Persistent.find mmu key)) + ( Opened (mmu, capabilities, fd), + Persistent.(run mmu (Persistent.find mmu key)) ) + | Remove key, Opened (mmu, capabilities, fd) -> + ( Opened (mmu, capabilities, fd), + Persistent.(run mmu (Persistent.remove mmu key)) ) | Insert (key, value), Opened (mmu, capabilities, fd) -> - Opened (mmu, capabilities, fd), - ( try Persistent.(run mmu (insert mmu key value)) ; Ok () - with Rowex.Duplicate -> Error `Already_exists ) + ( Opened (mmu, capabilities, fd), + try + Persistent.(run mmu (insert mmu key value)); + Ok () + with Rowex.Duplicate -> Error `Already_exists ) | Open (Reader uid, path), Closed -> - let ipc = Ipc.connect (Fmt.str "%s.socket" path) in - let trc = Ipc.connect (Fmt.str "%s-truncate.socket" path) in - let f _ipc = + let ipc = Ipc.connect (Fmt.str "%s.socket" path) in + let trc = Ipc.connect (Fmt.str "%s-truncate.socket" path) in + let f _ipc = + let fd = Unix.openfile path Unix.[ O_RDWR ] 0o644 in + let len = ((Unix.fstat fd).st_size + page_size) / page_size in + let len = len * page_size in + let memory = + Mmap.V1.map_file fd ~pos:0L Bigarray.char Bigarray.c_layout true + [| len |] + in + let memory = Bigarray.array1_of_genarray memory in + Unix.close fd; + memory + in + let memory = Ipc.with_lock ~f ipc in + let mmu = + Persistent.ro ~truncate:(truncate ipc (Truncate trc)) ipc memory + in + Sys.set_signal Sys.sigusr1 (Signal_handle (remap trc path mmu)); + (* TODO(dinosaure): keep [trc] to properly close it! *) + Ipc.enqueue ipc uid; + (Opened (mmu, Reader uid, Truncate trc), ()) + | Close, Opened (mmu, Reader uid, Truncate trc) -> + let ipc = Persistent.ipc mmu in + Ipc.enqueue ipc uid; + Ipc.close ipc; + Ipc.close trc; + (Closed, ()) + | Open (Writer, path), Closed -> let fd = Unix.openfile path Unix.[ O_RDWR ] 0o644 in let len = ((Unix.fstat fd).st_size + page_size) / page_size in let len = len * page_size in - let memory = Mmap.V1.map_file fd - ~pos:0L Bigarray.char Bigarray.c_layout true [| len |] in + let memory = + Mmap.V1.map_file fd ~pos:0L Bigarray.char Bigarray.c_layout true + [| len |] + in let memory = Bigarray.array1_of_genarray memory in - Unix.close fd ; memory in - let memory = Ipc.with_lock ~f ipc in - let mmu = Persistent.ro ~truncate:(truncate ipc (Truncate trc)) ipc memory in - Sys.set_signal Sys.sigusr1 (Signal_handle (remap trc path mmu)) ; - (* TODO(dinosaure): keep [trc] to properly close it! *) - Ipc.enqueue ipc uid ; Opened (mmu, Reader uid, Truncate trc), () - | Close, Opened (mmu, Reader uid, Truncate trc) -> - let ipc = Persistent.ipc mmu in - Ipc.enqueue ipc uid ; - Ipc.close ipc ; Ipc.close trc ; Closed, () - | Open (Writer, path), Closed -> - let fd = Unix.openfile path Unix.[ O_RDWR ] 0o644 in - let len = ((Unix.fstat fd).st_size + page_size) / page_size in - let len = len * page_size in - let memory = Mmap.V1.map_file fd - ~pos:0L Bigarray.char Bigarray.c_layout true [| len |] in - let memory = Bigarray.array1_of_genarray memory in - let ipc = Ipc.connect (Fmt.str "%s.socket" path) in - let trc = Ipc.connect (Fmt.str "%s-truncate.socket" path) in - let mmu = Persistent.rdwr - ~truncate:(truncate ipc (Truncate_and_file_descr (trc, fd))) ipc memory in - (* TODO(dinosaure): keep [trc] to properly close it! *) - Opened (mmu, Writer, Truncate_and_file_descr (trc, fd)), () - | Create (path, len), Closed -> - let fd = Unix.openfile path Unix.[ O_CREAT; O_RDWR ] 0o644 in - let _ = Unix.lseek fd len Unix.SEEK_SET in - let len = (len + page_size) / page_size in - let len = len * page_size in - let memory = Mmap.V1.map_file fd - ~pos:0L Bigarray.char Bigarray.c_layout true [| len |] in - let memory = Bigarray.array1_of_genarray memory in - ( match Ipc.create (Fmt.str "%s.socket" path), - Ipc.create (Fmt.str "%s-truncate.socket" path) with - | Ok (), Ok () -> let ipc = Ipc.connect (Fmt.str "%s.socket" path) in let trc = Ipc.connect (Fmt.str "%s-truncate.socket" path) in - let _mmu = Persistent.rdwr - ~truncate:(truncate ipc (Truncate trc)) ipc memory in - let _mmu = Persistent.run _mmu - (Persistent.make ~truncate:(truncate ipc (Truncate trc)) ipc memory) in - Ipc.close ipc ; Ipc.close trc ; Unix.close fd ; Closed, Ok () - | Error err, _ | _, Error err -> Closed, Error err ) - | Close, Opened (mmu, Writer, (Truncate_and_file_descr (trc, fd))) -> - let ipc = Persistent.ipc mmu in - Ipc.close ipc ; Ipc.close trc ; - Unix.close fd ; Closed, () + let mmu = + Persistent.rdwr + ~truncate:(truncate ipc (Truncate_and_file_descr (trc, fd))) + ipc memory + in + (* TODO(dinosaure): keep [trc] to properly close it! *) + (Opened (mmu, Writer, Truncate_and_file_descr (trc, fd)), ()) + | Create (path, len), Closed -> ( + let fd = Unix.openfile path Unix.[ O_CREAT; O_RDWR ] 0o644 in + let _ = Unix.lseek fd len Unix.SEEK_SET in + let len = (len + page_size) / page_size in + let len = len * page_size in + let memory = + Mmap.V1.map_file fd ~pos:0L Bigarray.char Bigarray.c_layout true + [| len |] + in + let memory = Bigarray.array1_of_genarray memory in + match + ( Ipc.create (Fmt.str "%s.socket" path), + Ipc.create (Fmt.str "%s-truncate.socket" path) ) + with + | Ok (), Ok () -> + let ipc = Ipc.connect (Fmt.str "%s.socket" path) in + let trc = Ipc.connect (Fmt.str "%s-truncate.socket" path) in + let _mmu = + Persistent.rdwr ~truncate:(truncate ipc (Truncate trc)) ipc memory + in + let _mmu = + Persistent.run _mmu + (Persistent.make + ~truncate:(truncate ipc (Truncate trc)) + ipc memory) + in + Ipc.close ipc; + Ipc.close trc; + Unix.close fd; + (Closed, Ok ()) + | Error err, _ | _, Error err -> (Closed, Error err)) + | Close, Opened (mmu, Writer, Truncate_and_file_descr (trc, fd)) -> + let ipc = Persistent.ipc mmu in + Ipc.close ipc; + Ipc.close trc; + Unix.close fd; + (Closed, ()) (* XXX(dinosaure): see ocaml/ocaml#12161 *) let () = at_exit Gc.full_major diff --git a/lib/part.mli b/lib/part.mli index e57f2e0..a4d34f7 100644 --- a/lib/part.mli +++ b/lib/part.mli @@ -60,24 +60,26 @@ val writer : rdwr capabilities type 'a opened constraint 'a = < .. > type closed - type ('p, 'q, 'a) t type 'v state val closed : closed state - val return : 'a -> ('p, 'p, 'a) t val open_index : 'c capabilities -> path:string -> (closed, 'c opened, unit) t val find : key -> ('c rd opened, 'c rd opened, int) t -val insert : key -> int -> (rdwr opened, rdwr opened, (unit, [> `Already_exists ]) result) t + +val insert : + key -> + int -> + (rdwr opened, rdwr opened, (unit, [> `Already_exists ]) result) t + +val remove : key -> (rdwr opened, rdwr opened, unit) t val close : ('c opened, closed, unit) t -val create : ?len:int -> string - -> (closed, closed, (unit, [> `Msg of string ]) result) t +val create : + ?len:int -> string -> (closed, closed, (unit, [> `Msg of string ]) result) t val bind : ('p, 'q, 'a) t -> ('a -> ('q, 'r, 'b) t) -> ('p, 'r, 'b) t - val run : 'p state -> ('p, 'q, 'a) t -> 'q state * 'a val is_closed : 'p state -> bool - val ( let* ) : ('p, 'q, 'a) t -> ('a -> ('q, 'r, 'b) t) -> ('p, 'r, 'b) t diff --git a/lib/persistent.ml b/lib/persistent.ml index f2b77c9..367b7ea 100644 --- a/lib/persistent.ml +++ b/lib/persistent.ml @@ -1,289 +1,304 @@ open Rowex module Hashset = Hashset -type memory = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t +type memory = + (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + type truncate = readers:int Hashset.t -> memory -> len:int64 -> memory -external persist - : memory -> int -> int -> unit - = "caml_persist" [@@noalloc] +external persist : memory -> int -> int -> unit = "caml_persist" [@@noalloc] -external atomic_get_uint8 - : memory -> int -> int - = "caml_atomic_get_uint8" [@@noalloc] +external atomic_get_uint8 : memory -> int -> int = "caml_atomic_get_uint8" +[@@noalloc] -external atomic_set_uint8 - : memory -> int -> int -> unit - = "caml_atomic_set_uint8" [@@noalloc] +external atomic_set_uint8 : memory -> int -> int -> unit + = "caml_atomic_set_uint8" +[@@noalloc] -external atomic_get_leuintnat - : memory -> int -> int - = "caml_atomic_get_leuintnat" [@@noalloc] +external atomic_get_leuintnat : memory -> int -> int + = "caml_atomic_get_leuintnat" +[@@noalloc] -external atomic_set_leuintnat - : memory -> int -> int -> unit - = "caml_atomic_set_leuintnat" [@@noalloc] +external atomic_set_leuintnat : memory -> int -> int -> unit + = "caml_atomic_set_leuintnat" +[@@noalloc] -external atomic_get_leuint16 - : memory -> int -> int - = "caml_atomic_get_leuint16" [@@noalloc] +external atomic_get_leuint16 : memory -> int -> int = "caml_atomic_get_leuint16" +[@@noalloc] -external atomic_set_leuint16 - : memory -> int -> int -> unit - = "caml_atomic_set_leuint16" [@@noalloc] +external atomic_set_leuint16 : memory -> int -> int -> unit + = "caml_atomic_set_leuint16" +[@@noalloc] -external atomic_get_leuint31 - : memory -> int -> int - = "caml_atomic_get_leuint31" [@@noalloc] +external atomic_get_leuint31 : memory -> int -> int = "caml_atomic_get_leuint31" +[@@noalloc] -external atomic_set_leuint31 - : memory -> int -> int -> unit - = "caml_atomic_set_leuint31" [@@noalloc] +external atomic_set_leuint31 : memory -> int -> int -> unit + = "caml_atomic_set_leuint31" +[@@noalloc] -external atomic_get_leuint64 - : memory -> int -> (int64[@unboxed]) - = "bytecode_compilation_not_supported" - "caml_atomic_get_leuint64" [@@noalloc] +external atomic_get_leuint64 : memory -> int -> (int64[@unboxed]) + = "bytecode_compilation_not_supported" "caml_atomic_get_leuint64" +[@@noalloc] -external atomic_set_leuint64 - : memory -> int -> (int64[@unboxed]) -> unit - = "bytecode_compilation_not_supported" - "caml_atomic_set_leuint64" [@@noalloc] +external atomic_set_leuint64 : memory -> int -> (int64[@unboxed]) -> unit + = "bytecode_compilation_not_supported" "caml_atomic_set_leuint64" +[@@noalloc] -external atomic_get_leuint128 - : memory -> int -> bytes -> unit - = "caml_atomic_get_leuint128" [@@noalloc] +external atomic_get_leuint128 : memory -> int -> bytes -> unit + = "caml_atomic_get_leuint128" +[@@noalloc] -external atomic_fetch_add_leuint16 - : memory -> int -> int -> int - = "caml_atomic_fetch_add_leuint16" [@@noalloc] +external atomic_fetch_add_leuint16 : memory -> int -> int -> int + = "caml_atomic_fetch_add_leuint16" +[@@noalloc] -external atomic_fetch_add_leuintnat - : memory -> int -> int -> int - = "caml_atomic_fetch_add_leuintnat" [@@noalloc] +external atomic_fetch_add_leuintnat : memory -> int -> int -> int + = "caml_atomic_fetch_add_leuintnat" +[@@noalloc] -external atomic_fetch_sub_leuintnat - : memory -> int -> int -> int - = "caml_atomic_fetch_sub_leuintnat" [@@noalloc] +external atomic_fetch_sub_leuintnat : memory -> int -> int -> int + = "caml_atomic_fetch_sub_leuintnat" +[@@noalloc] -external atomic_fetch_or_leuintnat - : memory -> int -> int -> int - = "caml_atomic_fetch_or_leuintnat" [@@noalloc] +external atomic_fetch_or_leuintnat : memory -> int -> int -> int + = "caml_atomic_fetch_or_leuintnat" +[@@noalloc] external pause_intrinsic : unit -> unit = "caml_pause_intrinsic" [@@noalloc] -external atomic_compare_exchange_strong - : memory -> int -> int Atomic.t -> int -> bool - = "caml_atomic_compare_exchange_strong_leuintnat" [@@noalloc] - -external atomic_compare_exchange_weak - : memory -> int -> int Atomic.t -> int -> bool - = "caml_atomic_compare_exchange_weak_leuintnat" [@@noalloc] - -external get_c_string - : memory -> int -> string - = "caml_get_c_string" +external atomic_compare_exchange_strong : + memory -> int -> int Atomic.t -> int -> bool + = "caml_atomic_compare_exchange_strong_leuintnat" +[@@noalloc] -external get_leint31 - : memory -> int -> int - = "caml_get_leint31" [@@noalloc] +external atomic_compare_exchange_weak : + memory -> int -> int Atomic.t -> int -> bool + = "caml_atomic_compare_exchange_weak_leuintnat" +[@@noalloc] -external get_leintnat - : memory -> int -> int - = "caml_get_leintnat" [@@noalloc] +external get_c_string : memory -> int -> string = "caml_get_c_string" +external get_leint31 : memory -> int -> int = "caml_get_leint31" [@@noalloc] +external get_leintnat : memory -> int -> int = "caml_get_leintnat" [@@noalloc] -external to_memory - : (_, _, Bigarray.c_layout) Bigarray.Array1.t -> memory - = "caml_to_memory" [@@noalloc] +external to_memory : (_, _, Bigarray.c_layout) Bigarray.Array1.t -> memory + = "caml_to_memory" +[@@noalloc] [@@@warning "-30"] -type 'c mmu = - { mutable brk : int - ; mutable memory : memory - ; root : 'c Addr.t - ; ipc : Ipc.t - ; truncate : truncate - ; free : (int, free_cell list) Hashtbl.t - ; keep : (int, keep_cell list) Hashtbl.t - ; readers : int Hashset.t } -and free_cell = - { addr : int - ; time : int } -and keep_cell = - { addr : int - ; len : int } +type 'c mmu = { + mutable brk : int; + mutable memory : memory; + root : 'c Addr.t; + ipc : Ipc.t; + truncate : truncate; + free : (int, free_cell list) Hashtbl.t; + keep : (int, keep_cell list) Hashtbl.t; + readers : int Hashset.t; +} + +and free_cell = { addr : int; time : int } +and keep_cell = { addr : int; len : int } let append tbl k cell = - try let vs = Hashtbl.find tbl k in Hashtbl.replace tbl k (cell :: vs) + try + let vs = Hashtbl.find tbl k in + Hashtbl.replace tbl k (cell :: vs) with Not_found -> Hashtbl.add tbl k [ cell ] -let append_keep_cell mmu ~time ~addr ~len = - append mmu.keep time { addr; len; } - -let append_free_cell mmu ~len ~addr ~time = - append mmu.free len { addr; time; } - +let append_keep_cell mmu ~time ~addr ~len = append mmu.keep time { addr; len } +let append_free_cell mmu ~len ~addr ~time = append mmu.free len { addr; time } let size_of_word = Sys.word_size / 8 let ro ~truncate ipc memory = let root = atomic_get_leuintnat memory size_of_word in let brk = atomic_get_leuintnat memory 0 in - { brk; memory; root= Addr.of_int_to_rdonly root; ipc; truncate - ; free= Hashtbl.create 0x100 - ; keep= Hashtbl.create 0x100 - ; readers= Hashset.create 0x100 } + { + brk; + memory; + root = Addr.of_int_to_rdonly root; + ipc; + truncate; + free = Hashtbl.create 0x100; + keep = Hashtbl.create 0x100; + readers = Hashset.create 0x100; + } let rdwr ~truncate ipc memory = let root = atomic_get_leuintnat memory size_of_word in let brk = atomic_get_leuintnat memory 0 in - { brk; memory; root= Addr.of_int_to_rdwr root; ipc; truncate - ; free= Hashtbl.create 0x100 - ; keep= Hashtbl.create 0x100 - ; readers= Hashset.create 0x100 } + { + brk; + memory; + root = Addr.of_int_to_rdwr root; + ipc; + truncate; + free = Hashtbl.create 0x100; + keep = Hashtbl.create 0x100; + readers = Hashset.create 0x100; + } let ipc { ipc; _ } = ipc let unsafe_set_memory mmu memory = mmu.memory <- memory -external bigarray_unsafe_set_uint8 : memory -> int -> int -> unit = "%caml_ba_set_1" -external bigarray_unsafe_set_uint32 : memory -> int -> int32 -> unit = "%caml_bigstring_set32" -external string_unsafe_get_uint32 : string -> int -> int32 = "%caml_string_get32" +external bigarray_unsafe_set_uint8 : memory -> int -> int -> unit + = "%caml_ba_set_1" + +external bigarray_unsafe_set_uint32 : memory -> int -> int32 -> unit + = "%caml_bigstring_set32" + +external string_unsafe_get_uint32 : string -> int -> int32 + = "%caml_string_get32" -let rec blitv payloads memory dst_off = match payloads with +let rec blitv payloads memory dst_off = + match payloads with | hd :: tl -> - let len = String.length hd in - let len0 = len land 3 in - let len1 = len asr 2 in - for i = 0 to len1 - 1 do - let i = i * 4 in - let v = string_unsafe_get_uint32 hd i in - bigarray_unsafe_set_uint32 memory (dst_off + i) v - done ; - for i = 0 to len0 - 1 do - let i = len1 * 4 + i in - bigarray_unsafe_set_uint8 memory (dst_off + i) (Char.code hd.[i]) - done ; - blitv tl memory (dst_off + len) + let len = String.length hd in + let len0 = len land 3 in + let len1 = len asr 2 in + for i = 0 to len1 - 1 do + let i = i * 4 in + let v = string_unsafe_get_uint32 hd i in + bigarray_unsafe_set_uint32 memory (dst_off + i) v + done; + for i = 0 to len0 - 1 do + let i = (len1 * 4) + i in + bigarray_unsafe_set_uint8 memory (dst_off + i) (Char.code hd.[i]) + done; + blitv tl memory (dst_off + len) | [] -> () let invalid_arg fmt = Format.kasprintf invalid_arg fmt - let src = Logs.Src.create "persistent" + module Log = (val Logs.src_log src : Logs.LOG) type 'a t = - | Atomic_get : 'c rd Addr.t * (atomic, 'a) value -> 'a t - | Atomic_set : 'c wr Addr.t * (atomic, 'a) value * 'a -> unit t - | Fetch_add : rdwr Addr.t * (atomic, int) value * int -> int t - | Fetch_or : rdwr Addr.t * (atomic, int) value * int -> int t - | Fetch_sub : rdwr Addr.t * (atomic, int) value * int -> int t - | Pause_intrinsic : unit t - | Compare_exchange : rdwr Addr.t * (atomic, 'a) value * 'a Atomic.t * 'a * bool -> bool t - | Get : 'c rd Addr.t * ('t, 'a) value -> 'a t - | Allocate : [ `Node | `Leaf ] * string list * int -> rdwr Addr.t t - | Delete : _ Addr.t * int -> unit t - | Collect : _ Addr.t * int * int -> unit t - | Persist : 'c wr Addr.t * int -> unit t - | Bind : 'a t * ('a -> 'b t) -> 'b t - | Return : 'a -> 'a t - | Unsafe_set_brk : int -> unit t + | Atomic_get : 'c rd Addr.t * (atomic, 'a) value -> 'a t + | Atomic_set : 'c wr Addr.t * (atomic, 'a) value * 'a -> unit t + | Fetch_add : rdwr Addr.t * (atomic, int) value * int -> int t + | Fetch_or : rdwr Addr.t * (atomic, int) value * int -> int t + | Fetch_sub : rdwr Addr.t * (atomic, int) value * int -> int t + | Pause_intrinsic : unit t + | Compare_exchange : + rdwr Addr.t * (atomic, 'a) value * 'a Atomic.t * 'a * bool + -> bool t + | Get : 'c rd Addr.t * ('t, 'a) value -> 'a t + | Allocate : [ `Node | `Leaf ] * string list * int -> rdwr Addr.t t + | Delete : _ Addr.t * int -> unit t + | Collect : _ Addr.t * int * int -> unit t + | Persist : 'c wr Addr.t * int -> unit t + | Bind : 'a t * ('a -> 'b t) -> 'b t + | Return : 'a -> 'a t + | Unsafe_set_brk : int -> unit t let pf = Format.fprintf -let pp : type a. a t fmt = fun ppf v -> - let open Rowex in match v with +let pp : type a. a t fmt = + fun ppf v -> + let open Rowex in + match v with | Atomic_get (addr, v) -> - pf ppf "atomic_get %016x : %a" (addr :> int) pp_value v + pf ppf "atomic_get %016x : %a" (addr :> int) pp_value v | Atomic_set (addr, v, x) -> - pf ppf "atomic_set %016x (%a : %a)" (addr :> int) (pp_of_value v) x pp_value v + pf ppf "atomic_set %016x (%a : %a)" + (addr :> int) + (pp_of_value v) x pp_value v | Fetch_add (addr, v, x) -> - pf ppf "fetch_add %016x (%a : %a)" (addr :> int) (pp_of_value v) x pp_value v + pf ppf "fetch_add %016x (%a : %a)" + (addr :> int) + (pp_of_value v) x pp_value v | Fetch_or (addr, v, x) -> - pf ppf "fetch_or %016x (%a : %a)" (addr :> int) (pp_of_value v) x pp_value v + pf ppf "fetch_or %016x (%a : %a)" + (addr :> int) + (pp_of_value v) x pp_value v | Fetch_sub (addr, v, x) -> - pf ppf "fetch_sub %016x (%a : %a)" (addr :> int) (pp_of_value v) x pp_value v + pf ppf "fetch_sub %016x (%a : %a)" + (addr :> int) + (pp_of_value v) x pp_value v | Collect (addr, len, uid) -> - pf ppf "collect %016x %d %d" (addr :> int) len uid - | Delete (addr, len) -> - pf ppf "delete %016x %d" (addr :> int) len - | Get (addr, v) -> - pf ppf "get %016x : %a" (addr :> int) pp_value v - | Allocate (`Node, _, len) -> - pf ppf "allocate %3d (node)" len - | Allocate (`Leaf, _, len) -> - pf ppf "allocate %3d (leaf)" len - | Pause_intrinsic -> - pf ppf "pause_intrinsic" - | Persist (addr, len) -> - pf ppf "persist %016x (%d)" (addr :> int) len + pf ppf "collect %016x %d %d" (addr :> int) len uid + | Delete (addr, len) -> pf ppf "delete %016x %d" (addr :> int) len + | Get (addr, v) -> pf ppf "get %016x : %a" (addr :> int) pp_value v + | Allocate (`Node, _, len) -> pf ppf "allocate %3d (node)" len + | Allocate (`Leaf, _, len) -> pf ppf "allocate %3d (leaf)" len + | Pause_intrinsic -> pf ppf "pause_intrinsic" + | Persist (addr, len) -> pf ppf "persist %016x (%d)" (addr :> int) len | Compare_exchange (addr, v, x, y, weak) -> - pf ppf "compare_exchange weak:%b %016x (%a : %a) (%a : %a)" weak (addr :> int) - (pp_of_value v) (Atomic.get x) pp_value v - (pp_of_value v) y pp_value v + pf ppf "compare_exchange weak:%b %016x (%a : %a) (%a : %a)" weak + (addr :> int) + (pp_of_value v) (Atomic.get x) pp_value v (pp_of_value v) y pp_value v | Bind (Allocate (_, _, len), _) -> - pf ppf "allocate %d byte(s) >>= fun _ ->" len + pf ppf "allocate %d byte(s) >>= fun _ ->" len | Bind _ -> pf ppf ">>=" | Return _ -> pf ppf "return *" | Unsafe_set_brk v -> pf ppf "unsafe_set_brk %016x" v -let ( <.> ) f g = fun x -> f (g x) +let ( <.> ) f g x = f (g x) module S = struct type nonrec 'a t = 'a t let bind x f = Bind (x, f) let return x = Return x - let get addr value = Get (addr, value) - let atomic_get addr k = Atomic_get (addr, k) let atomic_set addr k v = Atomic_set (addr, k, v) - let fetch_add addr k n = Fetch_add (addr, k, n) - let fetch_or addr k n = Fetch_or (addr, k, n) - let fetch_sub addr k n = Fetch_sub (addr, k, n) + let fetch_add addr k n = Fetch_add (addr, k, n) + let fetch_or addr k n = Fetch_or (addr, k, n) + let fetch_sub addr k n = Fetch_sub (addr, k, n) - let compare_exchange ?(weak= false) addr k expected desired = + let compare_exchange ?(weak = false) addr k expected desired = Compare_exchange (addr, k, expected, desired, weak) let pause_intrinsic = Pause_intrinsic let persist addr ~len = Persist (addr, len) let allocate ~kind ?len payloads = - let len = match len with + let len = + match len with | Some len -> len - | None -> List.fold_right (( + ) <.> String.length) payloads 0 in + | None -> List.fold_right (( + ) <.> String.length) payloads 0 + in Allocate (kind, payloads, len) let delete addr len = Delete (addr, len) - let collect addr ~len ~uid = Collect (addr, len, uid) - let pp = pp end -include Make(S) +include Make (S) let find { root; _ } key = find root key let insert { root; _ } key value = insert root key value +let remove { root; _ } key = remove root key let make ~truncate ipc memory = let ( >>= ) x f = S.bind x f in S.atomic_set (Addr.of_int_to_wronly 0) LEInt (size_of_word * 2) >>= fun () -> - (Unsafe_set_brk (size_of_word * 2)) >>= fun () -> + Unsafe_set_brk (size_of_word * 2) >>= fun () -> make () >>= fun root -> - S.atomic_set (Addr.of_int_to_wronly size_of_word) LEInt (root :> int) >>= fun () -> + S.atomic_set (Addr.of_int_to_wronly size_of_word) LEInt (root :> int) + >>= fun () -> S.return - { brk= size_of_word * 2; memory; root; ipc; truncate - ; free= Hashtbl.create 0x100 - ; keep= Hashtbl.create 0x100 - ; readers= Hashset.create 0x100 } + { + brk = size_of_word * 2; + memory; + root; + ipc; + truncate; + free = Hashtbl.create 0x100; + keep = Hashtbl.create 0x100; + readers = Hashset.create 0x100; + } let pp ppf addr = pp (formatter ~commit:(fun () -> S.return ()) ppf) addr let free_cells mmu time = try let cells = Hashtbl.find mmu.keep time in - List.iter (fun { addr; len; } -> append_free_cell mmu ~len ~addr ~time) cells + List.iter (fun { addr; len } -> append_free_cell mmu ~len ~addr ~time) cells with _ -> () (* XXX(dinosaure): [collect] must be protected by a global lock if we use @@ -291,22 +306,25 @@ let free_cells mmu time = multiple readers and multiple writes, we associate one [ringbuffer] for each writer. *) let collect ({ ipc; _ } as mmu) = - Log.debug (fun m -> m "collect") ; + Log.debug (fun m -> m "collect"); let rec mark_and_sweep () = - if Ipc.is_empty ipc - then () + if Ipc.is_empty ipc then () else let res = Int64.to_int (Ipc.dequeue ipc) in - if Hashset.mem mmu.readers res - then ( Hashset.remove mmu.readers res - ; free_cells mmu res - ; mark_and_sweep () ) - else ( Hashset.add mmu.readers res ; mark_and_sweep () ) in + if Hashset.mem mmu.readers res then ( + Hashset.remove mmu.readers res; + free_cells mmu res; + mark_and_sweep ()) + else ( + Hashset.add mmu.readers res; + mark_and_sweep ()) + in mark_and_sweep () let older_reader { ipc; _ } = let time = Ipc.dequeue ipc in - Ipc.enqueue ipc time (* XXX(dinosaure): don't forget reader. *) ; Int64.to_int time + Ipc.enqueue ipc time (* XXX(dinosaure): don't forget reader. *); + Int64.to_int time let _header_owner = Rowex._header_owner let _chunk = 1048576 @@ -321,125 +339,136 @@ let rec resize_and_ralloc mmu ~kind requested payloads = let brk = brk * 8 in let f _ipc = let len' = Bigarray.Array1.dim mmu.memory + _chunk in - let memory = mmu.truncate ~readers:mmu.readers mmu.memory ~len:(Int64.of_int len') in - mmu.memory <- memory in - Ipc.with_lock ~f mmu.ipc ; - if brk + requested <= Bigarray.Array1.dim mmu.memory - then ralloc mmu ~kind requested payloads + let memory = + mmu.truncate ~readers:mmu.readers mmu.memory ~len:(Int64.of_int len') + in + mmu.memory <- memory + in + Ipc.with_lock ~f mmu.ipc; + if brk + requested <= Bigarray.Array1.dim mmu.memory then + ralloc mmu ~kind requested payloads else raise Out_of_memory and ralloc mmu ~kind len payloads = let brk = 1 + ((mmu.brk - 1) / 8) in - let brk = brk * 8 in (* XXX(dinosaure): align memory. *) - Logs.debug (fun m -> m "brk:%016x, allocate %d byte(s)" brk len) ; - if brk + len <= Bigarray.Array1.dim mmu.memory - then ( let time = - if Ipc.is_empty mmu.ipc - then 0 (* TODO(dinosaure): check that! Why we don't use [Unix.getppid] - to note the owner of this node? *) - else older_reader mmu in - blitv payloads mmu.memory brk - ; atomic_set_leuintnat mmu.memory 0 (brk + len) - ; if kind = `Node then atomic_set_leuintnat mmu.memory (brk + _header_owner) time - ; Logs.debug (fun m -> m "brk:%016x" (brk + len)) - ; mmu.brk <- brk + len - ; Addr.of_int_to_rdwr brk ) + let brk = brk * 8 in + (* XXX(dinosaure): align memory. *) + Logs.debug (fun m -> m "brk:%016x, allocate %d byte(s)" brk len); + if brk + len <= Bigarray.Array1.dim mmu.memory then ( + let time = + if Ipc.is_empty mmu.ipc then 0 + (* TODO(dinosaure): check that! Why we don't use [Unix.getppid] + to note the owner of this node? *) + else older_reader mmu + in + blitv payloads mmu.memory brk; + atomic_set_leuintnat mmu.memory 0 (brk + len); + if kind = `Node then + atomic_set_leuintnat mmu.memory (brk + _header_owner) time; + Logs.debug (fun m -> m "brk:%016x" (brk + len)); + mmu.brk <- brk + len; + Addr.of_int_to_rdwr brk) else resize_and_ralloc mmu ~kind len payloads (* XXX(dinosaure): second chance or allocate *) let alloc mmu ~kind len payloads = - Log.debug (fun m -> m "alloc[1]") ; - try match Hashtbl.find mmu.free len with + Log.debug (fun m -> m "alloc[1]"); + try + match Hashtbl.find mmu.free len with | [] -> raise Not_found | cell :: tl -> - let time = older_reader mmu in - Hashtbl.replace mmu.free len tl ; - blitv payloads mmu.memory cell.addr ; - if kind = `Node then atomic_set_leuintnat mmu.memory (cell.addr + _header_owner) time ; - Addr.of_int_to_rdwr cell.addr + let time = older_reader mmu in + Hashtbl.replace mmu.free len tl; + blitv payloads mmu.memory cell.addr; + if kind = `Node then + atomic_set_leuintnat mmu.memory (cell.addr + _header_owner) time; + Addr.of_int_to_rdwr cell.addr with Not_found -> ralloc mmu ~kind len payloads (* XXX(dinosaure): first chance or collect *) let alloc mmu ~kind len payloads = - Log.debug (fun m -> m "alloc[0]") ; - if Ipc.is_empty mmu.ipc - then ralloc mmu ~kind len payloads + Log.debug (fun m -> m "alloc[0]"); + if Ipc.is_empty mmu.ipc then ralloc mmu ~kind len payloads else - try match Hashtbl.find mmu.free len with + try + match Hashtbl.find mmu.free len with | [] -> raise Not_found | cell :: tl -> - let time = older_reader mmu in - Hashtbl.replace mmu.free len tl ; - blitv payloads mmu.memory cell.addr ; - if kind = `Node then atomic_set_leuintnat mmu.memory (cell.addr + _header_owner) time ; - Addr.of_int_to_rdwr cell.addr - with Not_found -> collect mmu ; alloc mmu ~kind len payloads - -let rec run : type c a. c mmu -> a t -> a = fun ({ memory; _ } as mmu) cmd -> - let () = match cmd with + let time = older_reader mmu in + Hashtbl.replace mmu.free len tl; + blitv payloads mmu.memory cell.addr; + if kind = `Node then + atomic_set_leuintnat mmu.memory (cell.addr + _header_owner) time; + Addr.of_int_to_rdwr cell.addr + with Not_found -> + collect mmu; + alloc mmu ~kind len payloads + +let rec run : type c a. c mmu -> a t -> a = + fun ({ memory; _ } as mmu) cmd -> + let () = + match cmd with | Bind _ | Return _ -> () - | cmd -> Log.debug (fun m -> m "%a" S.pp cmd) in + | cmd -> Log.debug (fun m -> m "%a" S.pp cmd) + in match cmd with - | Atomic_get (addr, Int8) -> - atomic_get_uint8 memory (addr :> int) - | Atomic_set (addr, Int8, v) -> - atomic_set_uint8 memory (addr :> int) v - | Atomic_get (addr, LEInt) -> - atomic_get_leuintnat memory (addr :> int) - | Atomic_set (addr, LEInt, v) -> - atomic_set_leuintnat memory (addr :> int) v - | Atomic_get (addr, LEInt16) -> - atomic_get_leuint16 memory (addr :> int) - | Atomic_set (addr, LEInt16, v) -> - atomic_set_leuint16 memory (addr :> int) v - | Atomic_get (addr, LEInt31) -> - atomic_get_leuint31 memory (addr :> int) - | Atomic_set (addr, LEInt31, v) -> - atomic_set_leuint31 memory (addr :> int) v - | Atomic_get (addr, LEInt64) -> - atomic_get_leuint64 memory (addr :> int) - | Atomic_set (addr, LEInt64, v) -> - atomic_set_leuint64 memory (addr :> int) v + | Atomic_get (addr, Int8) -> atomic_get_uint8 memory (addr :> int) + | Atomic_set (addr, Int8, v) -> atomic_set_uint8 memory (addr :> int) v + | Atomic_get (addr, LEInt) -> atomic_get_leuintnat memory (addr :> int) + | Atomic_set (addr, LEInt, v) -> atomic_set_leuintnat memory (addr :> int) v + | Atomic_get (addr, LEInt16) -> atomic_get_leuint16 memory (addr :> int) + | Atomic_set (addr, LEInt16, v) -> atomic_set_leuint16 memory (addr :> int) v + | Atomic_get (addr, LEInt31) -> atomic_get_leuint31 memory (addr :> int) + | Atomic_set (addr, LEInt31, v) -> atomic_set_leuint31 memory (addr :> int) v + | Atomic_get (addr, LEInt64) -> atomic_get_leuint64 memory (addr :> int) + | Atomic_set (addr, LEInt64, v) -> atomic_set_leuint64 memory (addr :> int) v | Atomic_get (addr, LEInt128) -> - let res = Bytes.create 16 in - atomic_get_leuint128 memory (addr :> int) res ; - Bytes.unsafe_to_string res + let res = Bytes.create 16 in + atomic_get_leuint128 memory (addr :> int) res; + Bytes.unsafe_to_string res | Atomic_get (addr, Addr_rd) -> - Addr.of_int_to_rdonly (atomic_get_leuintnat memory (addr :> int)) + Addr.of_int_to_rdonly (atomic_get_leuintnat memory (addr :> int)) + | Atomic_get (addr, Addr_rdwr) -> + Addr.of_int_to_rdwr (atomic_get_leuintnat memory (addr :> int)) | Atomic_set (addr, Addr_rd, v) -> - atomic_set_leuintnat memory (addr :> int) (v :> int) + atomic_set_leuintnat memory (addr :> int) (v :> int) + | Atomic_set (addr, Addr_rdwr, v) -> + atomic_set_leuintnat memory (addr :> int) (v :> int) | Fetch_add (addr, LEInt16, v) -> - atomic_fetch_add_leuint16 memory (addr :> int) v + atomic_fetch_add_leuint16 memory (addr :> int) v | Fetch_add (addr, LEInt, v) -> - atomic_fetch_add_leuintnat memory (addr :> int) v + atomic_fetch_add_leuintnat memory (addr :> int) v | Fetch_sub (addr, LEInt, v) -> - atomic_fetch_sub_leuintnat memory (addr :> int) v + atomic_fetch_sub_leuintnat memory (addr :> int) v | Fetch_or (addr, LEInt, v) -> - atomic_fetch_or_leuintnat memory (addr :> int) v + atomic_fetch_or_leuintnat memory (addr :> int) v | Pause_intrinsic -> pause_intrinsic () | Compare_exchange (addr, LEInt, a, b, true) -> - atomic_compare_exchange_weak memory (addr :> int) a b + atomic_compare_exchange_weak memory (addr :> int) a b | Compare_exchange (addr, LEInt, a, b, false) -> - atomic_compare_exchange_strong memory (addr :> int) a b + atomic_compare_exchange_strong memory (addr :> int) a b | Get (addr, C_string) -> - let res = get_c_string memory (addr :> int) in - Log.debug (fun m -> m "Get %S." res) ; res + let res = get_c_string memory (addr :> int) in + Log.debug (fun m -> m "Get %S." res); + res | Get (addr, LEInt31) -> get_leint31 memory (addr :> int) | Get (addr, LEInt) -> get_leintnat memory (addr :> int) | Persist (addr, len) -> persist memory (addr :> int) len | Return v -> v | Bind (Allocate (kind, payloads, len), f) -> - let len' = List.fold_left (fun a x -> String.length x + a) 0 payloads in - assert (len = len') ; - let addr = alloc mmu ~kind len payloads in - run mmu (f addr) + let len' = List.fold_left (fun a x -> String.length x + a) 0 payloads in + assert (len = len'); + let addr = alloc mmu ~kind len payloads in + run mmu (f addr) | Collect _ -> () | Bind (Delete (addr, len), f) -> - append_free_cell mmu ~len ~addr:(addr :> int) ~time:0 ; - run mmu (f ()) + append_free_cell mmu ~len ~addr:(addr :> int) ~time:0; + run mmu (f ()) | Bind (Collect (addr, len, uid), f) -> - append_keep_cell mmu ~time:uid ~addr:(addr :> int) ~len ; - run mmu (f ()) - | Bind (v, f) -> let v = run mmu v in run mmu (f v) + append_keep_cell mmu ~time:uid ~addr:(addr :> int) ~len; + run mmu (f ()) + | Bind (v, f) -> + let v = run mmu v in + run mmu (f v) | Unsafe_set_brk v -> mmu.brk <- v | cmd -> invalid_arg "Invalid operation: %a" S.pp cmd diff --git a/lib/persistent.mli b/lib/persistent.mli index 613fa53..8770e80 100644 --- a/lib/persistent.mli +++ b/lib/persistent.mli @@ -1,6 +1,7 @@ open Rowex -type memory = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t +type memory = + (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t type truncate = readers:int Hashset.t -> memory -> len:int64 -> memory (** The type of functions to {i truncate}. @@ -25,27 +26,26 @@ type 'c mmu val ro : truncate:truncate -> Ipc.t -> memory -> ro mmu val rdwr : truncate:truncate -> Ipc.t -> memory -> rdwr mmu - val find : 'c rd mmu -> key -> int t val insert : rdwr mmu -> key -> int -> unit t +val remove : rdwr mmu -> key -> unit t val make : truncate:truncate -> Ipc.t -> memory -> rdwr mmu t - val run : 'c mmu -> 'a t -> 'a val ipc : 'c mmu -> Ipc.t (** / **) -external atomic_set_leuintnat - : memory -> int -> int -> unit - = "caml_atomic_set_leuintnat" [@@noalloc] +external atomic_set_leuintnat : memory -> int -> int -> unit + = "caml_atomic_set_leuintnat" +[@@noalloc] -external atomic_get_leuintnat - : memory -> int -> int - = "caml_atomic_get_leuintnat" [@@noalloc] +external atomic_get_leuintnat : memory -> int -> int + = "caml_atomic_get_leuintnat" +[@@noalloc] -external to_memory - : (_, _, Bigarray.c_layout) Bigarray.Array1.t -> memory - = "caml_to_memory" [@@noalloc] +external to_memory : (_, _, Bigarray.c_layout) Bigarray.Array1.t -> memory + = "caml_to_memory" +[@@noalloc] val unsafe_set_memory : 'c mmu -> memory -> unit diff --git a/lib/rowex.ml b/lib/rowex.ml index e017f31..c1bdfbb 100644 --- a/lib/rowex.ml +++ b/lib/rowex.ml @@ -2,21 +2,25 @@ let () = Printexc.record_backtrace true exception Duplicate -let (.![]) = String.unsafe_get +let ( .![] ) = String.unsafe_get (* XXX(dinosaure): see [art.ml] about this unsafe access. *) external ( <= ) : 'a -> 'a -> bool = "%lessequal" + let ( <= ) (x : int) y = x <= y [@@inline] let min (a : int) b = if a <= b then a else b [@@inline] type key = string -let key : string -> key = fun key -> - if String.contains key '\000' then invalid_arg "Invalid key" ; key +let key : string -> key = + fun key -> + if String.contains key '\000' then invalid_arg "Invalid key"; + key external unsafe_key : string -> key = "%identity" let src = Logs.Src.create "rowex" + module Log = (val Logs.src_log src : Logs.LOG) module String = struct @@ -31,7 +35,6 @@ external bytes_set64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u" external string_get16 : string -> int -> int = "%caml_string_get16u" let const x _ = x - let size_of_word = Sys.word_size / 8 external bswap64 : int64 -> int64 = "%bswap_int64" @@ -43,51 +46,46 @@ external bswap32 : int32 -> int32 = "%bswap_int32" it's a shame to add these C functions. The compiler should add such primitives. *) -external uint64_of_uint : int -> (int64[@unboxed]) = - "bytecode_compilation_not_supported" - "caml_uint64_of_uint" [@@noalloc] +external uint64_of_uint : int -> (int64[@unboxed]) + = "bytecode_compilation_not_supported" "caml_uint64_of_uint" +[@@noalloc] -external uint32_of_uint : int -> (int32[@unboxed]) = - "bytecode_compilation_not_supported" - "caml_uint32_of_uint" [@@noalloc] +external uint32_of_uint : int -> (int32[@unboxed]) + = "bytecode_compilation_not_supported" "caml_uint32_of_uint" +[@@noalloc] let leintnat_to_string v = - if Sys.word_size = 64 && Sys.big_endian - then + if Sys.word_size = 64 && Sys.big_endian then ( let v = bswap64 (uint64_of_uint v) in let res = Bytes.create 8 in - bytes_set64 res 0 v ; - Bytes.unsafe_to_string res - else if Sys.word_size = 64 - then + bytes_set64 res 0 v; + Bytes.unsafe_to_string res) + else if Sys.word_size = 64 then ( let v = uint64_of_uint v in let res = Bytes.create 8 in - bytes_set64 res 0 v ; - Bytes.unsafe_to_string res - else if Sys.word_size = 32 && Sys.big_endian - then + bytes_set64 res 0 v; + Bytes.unsafe_to_string res) + else if Sys.word_size = 32 && Sys.big_endian then ( let v = bswap32 (uint32_of_uint v) in let res = Bytes.create 4 in - bytes_set32 res 0 v ; - Bytes.unsafe_to_string res - else if Sys.word_size = 32 - then + bytes_set32 res 0 v; + Bytes.unsafe_to_string res) + else if Sys.word_size = 32 then ( let v = uint32_of_uint v in let res = Bytes.create 4 in - bytes_set32 res 0 v ; - Bytes.unsafe_to_string res + bytes_set32 res 0 v; + Bytes.unsafe_to_string res) else assert false (* TODO? *) [@@inline] let leint31_to_string v = - if Sys.big_endian - then + if Sys.big_endian then ( let res = Bytes.create 4 in - bytes_set32 res 0 (bswap32 (Int32.of_int v)) ; - Bytes.unsafe_to_string res + bytes_set32 res 0 (bswap32 (Int32.of_int v)); + Bytes.unsafe_to_string res) else let res = Bytes.create 4 in - bytes_set32 res 0 (Int32.of_int v) ; + bytes_set32 res 0 (Int32.of_int v); Bytes.unsafe_to_string res [@@inline] @@ -124,13 +122,11 @@ let leint31_to_string v = and 'a t = 'a tree option ]} *) -type 'a rd = < rd : unit; .. > as 'a -type 'a wr = < wr : unit; .. > as 'a - -type ro = < rd : unit; > -type wo = < wr : unit; > - -type rdwr = < rd : unit; wr : unit; > +type 'a rd = < rd : unit ; .. > as 'a +type 'a wr = < wr : unit ; .. > as 'a +type ro = < rd : unit > +type wo = < wr : unit > +type rdwr = < rd : unit ; wr : unit > module rec Leaf : sig type t [@@immediate] @@ -148,40 +144,34 @@ and Addr : sig type 'a t = private int val length : int - - val null : ro t + val null : rdwr t val is_null : 'a t -> bool - external of_int_to_rdonly : int -> ro t = "%identity" external of_int_to_wronly : int -> wo t = "%identity" external of_int_to_rdwr : int -> rdwr t = "%identity" - external to_wronly : 'a wr t -> wo t = "%identity" external to_rdonly : 'a rd t -> ro t = "%identity" - external unsafe_to_leaf : 'a t -> Leaf.t = "%identity" external unsafe_of_leaf : Leaf.t -> 'a t = "%identity" external unsafe_to_int : _ t -> int = "%identity" - + external unsafe_to_rdwr : _ t -> rdwr t = "%identity" val ( + ) : 'a t -> int -> 'a t end = struct type 'a t = int let length = Sys.word_size / 8 - let null = 1 lsl (Sys.word_size - 2) let is_null x = x = null [@@inline always] external of_int_to_rdonly : int -> ro t = "%identity" external of_int_to_wronly : int -> wo t = "%identity" external of_int_to_rdwr : int -> rdwr t = "%identity" - external to_wronly : 'a wr t -> wo t = "%identity" external to_rdonly : 'a rd t -> ro t = "%identity" - external unsafe_to_leaf : 'a t -> Leaf.t = "%identity" external unsafe_of_leaf : Leaf.t -> 'a t = "%identity" external unsafe_to_int : _ t -> int = "%identity" + external unsafe_to_rdwr : _ t -> rdwr t = "%identity" let ( + ) addr v = addr + v [@@inline always] end @@ -189,17 +179,19 @@ end let string_of_null_addr = leintnat_to_string (Addr.null :> int) type ('c, 'a) value = - | Int8 : (atomic, int) value - | LEInt : (atomic, int) value - | LEInt16 : (atomic, int) value - | LEInt31 : (atomic, int) value - | LEInt64 : (atomic, int64) value + | Int8 : (atomic, int) value + | LEInt : (atomic, int) value + | LEInt16 : (atomic, int) value + | LEInt31 : (atomic, int) value + | LEInt64 : (atomic, int64) value | LEInt128 : (atomic, string) value (* XXX(dinosaure): a Int128 does not exist in OCaml, so we load it into a simple (little-endian) [string]. However, the access to the value must be atomic and be saved into a string then. *) - | Addr_rd : (atomic, ro Addr.t) value + | Addr_rd : (atomic, ro Addr.t) value + | Addr_rdwr : (atomic, rdwr Addr.t) value | C_string : (non_atomic, string) value + and atomic = Atomic and non_atomic = Non_atomic @@ -208,21 +200,27 @@ module type S = sig val bind : 'a t -> ('a -> 'b t) -> 'b t val return : 'a -> 'a t - val atomic_get : 'a rd Addr.t -> (atomic, 'v) value -> 'v t val atomic_set : 'a wr Addr.t -> (atomic, 'v) value -> 'v -> unit t val persist : 'a wr Addr.t -> len:int -> unit t + val fetch_add : rdwr Addr.t -> (atomic, int) value -> int -> int t + val fetch_or : rdwr Addr.t -> (atomic, int) value -> int -> int t + val fetch_sub : rdwr Addr.t -> (atomic, int) value -> int -> int t + + val compare_exchange : + ?weak:bool -> + rdwr Addr.t -> + (atomic, 'a) value -> + 'a Atomic.t -> + 'a -> + bool t - val fetch_add : rdwr Addr.t -> (atomic, int) value -> int -> int t - val fetch_or : rdwr Addr.t -> (atomic, int) value -> int -> int t - val fetch_sub : rdwr Addr.t -> (atomic, int) value -> int -> int t - - val compare_exchange : ?weak:bool -> rdwr Addr.t -> (atomic, 'a) value -> 'a Atomic.t -> 'a -> bool t val pause_intrinsic : unit t - val get : 'a rd Addr.t -> ('t, 'v) value -> 'v t - val allocate : kind:[ `Leaf | `Node ] -> ?len:int -> string list -> rdwr Addr.t t + val allocate : + kind:[ `Leaf | `Node ] -> ?len:int -> string list -> rdwr Addr.t t + val delete : _ Addr.t -> int -> unit t val collect : _ Addr.t -> len:int -> uid:int -> unit t end @@ -231,7 +229,8 @@ type 'a fmt = Format.formatter -> 'a -> unit let pf ppf fmt = Format.fprintf ppf fmt -let pp_value : type c a. (c, a) value fmt = fun ppf -> function +let pp_value : type c a. (c, a) value fmt = + fun ppf -> function | LEInt -> pf ppf "leintnat" | LEInt31 -> pf ppf "leint31" | LEInt16 -> pf ppf "leint16" @@ -239,18 +238,20 @@ let pp_value : type c a. (c, a) value fmt = fun ppf -> function | LEInt128 -> pf ppf "leint128" | Int8 -> pf ppf "int8" | Addr_rd -> pf ppf "addr" + | Addr_rdwr -> pf ppf "addr" | C_string -> pf ppf "c_string" -let fmt fmt = fun ppf -> pf ppf fmt +let fmt fmt ppf = pf ppf fmt let pp_of_value : type c a. (c, a) value -> a fmt = function - | LEInt -> fun ppf v -> if v < 0 then pf ppf "%16x" v else pf ppf "%10d" v + | LEInt -> fun ppf v -> if v < 0 then pf ppf "%16x" v else pf ppf "%10d" v | LEInt31 -> fmt "%10d" | LEInt16 -> fmt "%5d" | LEInt64 -> fmt "%19Ld" | LEInt128 -> fmt "%S" | Int8 -> fmt "%3d" | Addr_rd -> fun ppf addr -> pf ppf "%016x" (addr :> int) + | Addr_rdwr -> fun ppf addr -> pf ppf "%016x" (addr :> int) | C_string -> fmt "%S" module Value = struct @@ -261,15 +262,14 @@ module Value = struct let leint64 = LEInt64 let leint128 = LEInt128 let addr_rd = Addr_rd + let addr_rdwr = Addr_rdwr let c_string = C_string end let _cache_line_size = 64 let _write_latency_in_ns = 0 let _cpu_freq_mhz = 2100 - -let ( <.> ) f g = fun x -> f (g x) - +let ( <.> ) f g x = f (g x) let _prefix = 4 let _header_prefix = 0 let _header_prefix_count = _header_prefix + _prefix @@ -279,8 +279,10 @@ let _header_prefix_count = _header_prefix + _prefix [prefix] to help a pessimistic check. *) let _header_kind = _header_prefix_count + 4 + let _header_owner = if Sys.word_size = 64 then _header_kind + 8 else _header_kind + 4 + (* XXX(dinosaure): [owner] is a unique identifier (like a PID) to tell us which process requires a node to be alive. It helps us to collect and re-use nodes which are not needed anymore by any readers. @@ -305,18 +307,17 @@ let _header_depth = let _header_count = _header_depth + 4 let _header_compact_count = _header_count + 2 - let _header_length = _header_compact_count + 2 -let () = match Sys.word_size = 64 with - | true -> assert (_header_length = 32) +let () = + match Sys.word_size = 64 with + | true -> assert (_header_length = 32) | false -> assert (_header_length = 24) let _bits_kind = Sys.word_size - 3 - -let _n4_kind = 0b00 -let _n16_kind = 0b01 -let _n48_kind = 0b10 +let _n4_kind = 0b00 +let _n16_kind = 0b01 +let _n48_kind = 0b10 let _n256_kind = 0b11 (* XXX(dinosaure): note for me, [msync(2)] does not ensure the **order** of @@ -350,8 +351,8 @@ module Make (S : S) = struct open S - let get_version addr = - atomic_get Addr.(addr + _header_kind) Value.leintnat [@@inline] + let get_version addr = atomic_get Addr.(addr + _header_kind) Value.leintnat + [@@inline] let get_type addr = let* value = atomic_get Addr.(addr + _header_kind) Value.leintnat in @@ -378,30 +379,27 @@ module Make (S : S) = struct let p0 = Int64.(to_int (logand value 0xffffL)) in let p1 = Int64.(to_int (logand (shift_right value 16) 0xffffL)) in let prefix = Bytes.create _prefix in - bytes_set16 prefix 0 p0 ; - bytes_set16 prefix 2 p1 ; - return (Bytes.unsafe_to_string prefix, - Int64.(to_int (shift_right value 32))) + bytes_set16 prefix 0 p0; + bytes_set16 prefix 2 p1; + return (Bytes.unsafe_to_string prefix, Int64.(to_int (shift_right value 32))) let ( >>= ) x f = bind x f let set_prefix addr ~prefix ~prefix_count flush = - if prefix_count = 0 - then atomic_set Addr.(addr + _header_prefix) Value.leint64 0L + if prefix_count = 0 then + atomic_set Addr.(addr + _header_prefix) Value.leint64 0L else let p0 = string_get16 prefix 0 in let p1 = string_get16 prefix 2 in let prefix = Int64.(logor (shift_left (of_int p1) 16) (of_int p0)) in let rs = Int64.(logor (shift_left (of_int prefix_count) 32) prefix) in atomic_set Addr.(addr + _header_prefix) Value.leint64 rs >>= fun () -> - if flush - then persist Addr.(addr + _header_prefix) ~len:8 - else return () + if flush then persist Addr.(addr + _header_prefix) ~len:8 else return () (**** FIND CHILD ****) let _n4_align_length = - let len = ((_header_length + 4) + Addr.length) / Addr.length in + let len = (_header_length + 4 + Addr.length) / Addr.length in (len * Addr.length) - (_header_length + 4) (* XXX(dinosaure): to be sure that addresses are aligned, we fill the * gap between the header, 4 bytes (needed by N4) and addresses. By this @@ -409,40 +407,54 @@ module Make (S : S) = struct let n4_find_child addr k = let* _0 = atomic_get Addr.(addr + _header_length + 0) Value.int8 in - if _0 = k - then atomic_get Addr.(addr + _header_length + 4 + _n4_align_length + (Addr.length * 0)) - Value.addr_rd else - let* _1 = atomic_get Addr.(addr + _header_length + 1) Value.int8 in - if _1 = k - then atomic_get Addr.(addr + _header_length + 4 + _n4_align_length + (Addr.length * 1)) - Value.addr_rd else - let* _2 = atomic_get Addr.(addr + _header_length + 2) Value.int8 in - if _2 = k - then atomic_get Addr.(addr + _header_length + 4 + _n4_align_length + (Addr.length * 2)) - Value.addr_rd else - let* _3 = atomic_get Addr.(addr + _header_length + 3) Value.int8 in - if _3 = k - then atomic_get Addr.(addr + _header_length + 4 + _n4_align_length + (Addr.length * 3)) - Value.addr_rd else - ( Log.debug (fun m -> m "No child for %02x into N4" k) - ; return Addr.null ) + if _0 = k then + atomic_get + Addr.(addr + _header_length + 4 + _n4_align_length + (Addr.length * 0)) + Value.addr_rd + else + let* _1 = atomic_get Addr.(addr + _header_length + 1) Value.int8 in + if _1 = k then + atomic_get + Addr.( + addr + _header_length + 4 + _n4_align_length + (Addr.length * 1)) + Value.addr_rd + else + let* _2 = atomic_get Addr.(addr + _header_length + 2) Value.int8 in + if _2 = k then + atomic_get + Addr.( + addr + _header_length + 4 + _n4_align_length + (Addr.length * 2)) + Value.addr_rd + else + let* _3 = atomic_get Addr.(addr + _header_length + 3) Value.int8 in + if _3 = k then + atomic_get + Addr.( + addr + _header_length + 4 + _n4_align_length + (Addr.length * 3)) + Value.addr_rd + else ( + Log.debug (fun m -> m "no child for %02x into node4" k); + return Addr.(to_rdonly null)) external n16_get_child : int -> int -> string -> int = "caml_n16_get_child" - [@@noalloc] + [@@noalloc] + external ctz : int -> int = "caml_ctz" [@@noalloc] (* XXX(dinosaure): despite [art.ml], [N4] and [N16] aren't order. We must check all children. *) let rec _n16_find_child addr k bitfield = - if bitfield = 0 then return Addr.null + if bitfield = 0 then return Addr.(to_rdonly null) else let p = ctz bitfield in let* k' = atomic_get Addr.(addr + _header_length + p) Value.int8 in - let* value = atomic_get - Addr.(addr + _header_length + 16 + (p * Addr.length)) Value.addr_rd in - if not (Addr.is_null value) && k' = (k lxor 128) - then return value + let* value = + atomic_get + Addr.(addr + _header_length + 16 + (p * Addr.length)) + Value.addr_rd + in + if (not (Addr.is_null value)) && k' = k lxor 128 then return value else _n16_find_child addr k (bitfield lxor (1 lsl p)) let n16_find_child addr k = @@ -454,10 +466,11 @@ module Make (S : S) = struct let n48_find_child addr k = let* pos' = atomic_get Addr.(addr + _header_length + k) Value.int8 in - if pos' <> 48 - then atomic_get Addr.(addr + _header_length + 256 + (Addr.length * pos')) + if pos' <> 48 then + atomic_get + Addr.(addr + _header_length + 256 + (Addr.length * pos')) Value.addr_rd - else return Addr.null + else return Addr.(to_rdonly null) let n256_find_child addr k = atomic_get Addr.(addr + _header_length + (Addr.length * k)) Value.addr_rd @@ -473,37 +486,48 @@ module Make (S : S) = struct let rec _node_any_child addr ~header child idx max = if idx = max then return child else - let* child' : ro Addr.t = atomic_get + let* (child' : ro Addr.t) = + atomic_get Addr.(addr + _header_length + header + (idx * Addr.length)) - Value.addr_rd in + Value.addr_rd + in if (child' :> int) land 1 = 1 then return child' - else _node_any_child addr ~header (if not (Addr.is_null child') - then child' - else child) + else + _node_any_child addr ~header + (if not (Addr.is_null child') then child' else child) (succ idx) max [@@inline] - let n4_any_child addr = _node_any_child addr ~header:(4 + _n4_align_length) Addr.null 0 4 - let n16_any_child addr = _node_any_child addr ~header:16 Addr.null 0 16 - let n48_any_child addr = _node_any_child addr ~header:256 Addr.null 0 48 - let n256_any_child addr = _node_any_child addr ~header:0 Addr.null 0 256 + let n4_any_child addr = + _node_any_child addr ~header:(4 + _n4_align_length) + Addr.(to_rdonly null) + 0 4 + + let n16_any_child addr = + _node_any_child addr ~header:16 Addr.(to_rdonly null) 0 16 + + let n48_any_child addr = + _node_any_child addr ~header:256 Addr.(to_rdonly null) 0 48 + + let n256_any_child addr = + _node_any_child addr ~header:0 Addr.(to_rdonly null) 0 256 (* XXX(dinosaure): thx @Drup. *) - type formatter = - { commit : unit -> unit S.t - ; ppf : Format.formatter } + type formatter = { commit : unit -> unit S.t; ppf : Format.formatter } - let formatter ~commit ppf = { commit; ppf; } + let formatter ~commit ppf = { commit; ppf } - let kfprintf - : (formatter -> unit S.t -> 'a) -> formatter -> - ('b, Format.formatter, unit, 'a) format4 -> 'b - = fun k ppft fmt -> Format.kfprintf (fun _ppf -> k ppft @@ ppft.commit ()) - ppft.ppf fmt + let kfprintf : + (formatter -> unit S.t -> 'a) -> + formatter -> + ('b, Format.formatter, unit, 'a) format4 -> + 'b = + fun k ppft fmt -> + Format.kfprintf (fun _ppf -> k ppft @@ ppft.commit ()) ppft.ppf fmt - let fprintf - : formatter -> ('a, Format.formatter, unit, unit S.t) format4 -> 'a - = fun ppft fmt -> kfprintf (fun _ t -> t) ppft fmt + let fprintf : + formatter -> ('a, Format.formatter, unit, unit S.t) format4 -> 'a = + fun ppft fmt -> kfprintf (fun _ t -> t) ppft fmt let[@coverage off] pp_char ppf = function | '\x21' .. '\x7e' as chr -> Fmt.char ppf chr @@ -525,8 +549,11 @@ module Make (S : S) = struct let pp_n48 ppf addr = let rec go arr i = if i = 48 then return arr - else let* chr = atomic_get Addr.(addr + _header_length + i) Value.int8 in - ( arr.(i) <- Char.unsafe_chr chr ; go arr (succ i) ) in + else + let* chr = atomic_get Addr.(addr + _header_length + i) Value.int8 in + arr.(i) <- Char.unsafe_chr chr; + go arr (succ i) + in let* arr = go (Array.make 48 '\000') 0 in fprintf ppf "%a" Fmt.(Dump.array pp_char) arr @@ -553,29 +580,34 @@ module Make (S : S) = struct let pp_record ppf addr = let* prefix, prefix_count = get_prefix addr in let* depth = get Addr.(addr + _header_depth) Value.leint31 in - let* () = fprintf ppf - "{ @[prefix= %S;@ prefix_count= %d;@ depth= %d;@ kind= " - prefix prefix_count depth in + let* () = + fprintf ppf "{ @[prefix= %S;@ prefix_count= %d;@ depth= %d;@ kind= " + prefix prefix_count depth + in let* () = pp_kind ppf addr in let* () = fprintf ppf ";@] }" in return () let rec pp_children ~header ~n:max ppf addr = let rec go ~header idx arr = - if idx < max - then - let addr = Addr.(addr + _header_length + header + (idx * Addr.length)) in + if idx < max then ( + let addr = + Addr.(addr + _header_length + header + (idx * Addr.length)) + in let* addr = atomic_get addr Value.addr_rd in - ( arr.(idx) <- addr ; go ~header (succ idx) arr ) - else return arr in - let* arr = go ~header 0 (Array.init max (fun _ -> Addr.null)) in + arr.(idx) <- addr; + go ~header (succ idx) arr) + else return arr + in + let* arr = go ~header 0 (Array.init max (fun _ -> Addr.(to_rdonly null))) in let rec pp ppf = function | [] -> return () | [ x ] -> pp_elt ppf x | x :: r -> - let* () = pp_elt ppf x in - let* () = fprintf ppf ";@ " in - pp ppf r in + let* () = pp_elt ppf x in + let* () = fprintf ppf ";@ " in + pp ppf r + in let* () = fprintf ppf "[|@[" in let* () = pp ppf (Array.to_list arr) in let* () = fprintf ppf "@]|]" in @@ -583,8 +615,7 @@ module Make (S : S) = struct and pp_elt ppf (addr : ro Addr.t) = if Addr.is_null addr then fprintf ppf "" - else if (addr :> int) land 1 = 1 - then + else if (addr :> int) land 1 = 1 then let leaf = Leaf.prj (Addr.unsafe_to_leaf addr) in let* key = get leaf Value.c_string in let len = (String.length key + size_of_word) / size_of_word in @@ -593,9 +624,13 @@ module Make (S : S) = struct let* value = get Addr.(leaf + len) Value.leintnat in fprintf ppf "{:leaf @[key= %S;@ value= %d;@] }" key value else - let* n, header = get_type addr >>| function - | 0 -> 4, 4 + _n4_align_length - | 1 -> 16, 16 | 2 -> 48, 256 | _ -> 256, 0 in + let* n, header = + get_type addr >>| function + | 0 -> (4, 4 + _n4_align_length) + | 1 -> (16, 16) + | 2 -> (48, 256) + | _ -> (256, 0) + in let* () = fprintf ppf "{:node @[hdr= @[" in let* () = pp_record ppf addr in let* () = fprintf ppf "@];@ key= @[" in @@ -605,8 +640,7 @@ module Make (S : S) = struct let* () = fprintf ppf "@];@] }" in return () - let pp ppf (root : _ rd Addr.t) = - pp_elt ppf (Addr.to_rdonly root) + let pp ppf (root : _ rd Addr.t) = pp_elt ppf (Addr.to_rdonly root) let any_child (addr : _ rd Addr.t) = let* ty = get_type addr in @@ -617,38 +651,38 @@ module Make (S : S) = struct | 3 -> n256_any_child addr | _ -> assert false - let rec minimum - : ro Addr.t -> ro Addr.t t - = fun addr -> + let rec minimum : ro Addr.t -> ro Addr.t t = + fun addr -> if (addr :> int) land 1 = 1 then return addr - else let* addr = any_child addr in minimum addr + else + let* addr = any_child addr in + minimum addr - let minimum (addr : _ rd Addr.t) = minimum (Addr.to_rdonly addr) - [@@inline] + let minimum (addr : _ rd Addr.t) = minimum (Addr.to_rdonly addr) [@@inline] + + let pp_type_of_int ppf = function + | 0 -> Fmt.string ppf "node4" + | 1 -> Fmt.string ppf "node16" + | 2 -> Fmt.string ppf "node48" + | 3 -> Fmt.string ppf "node256" + | _ -> assert false let find_child (addr : _ rd Addr.t) chr = let k = Char.code chr in let* ty = get_type addr in - Log.debug (fun m -> m "find_child node %c" chr) ; + Log.debug (fun m -> + m "find child with %02x byte (%a)" (Char.code chr) pp_type_of_int ty); match ty with - | 0 -> n4_find_child addr k - | 1 -> - Log.debug (fun m -> m "find_child_n16 node %c" chr) ; - n16_find_child addr k - | 2 -> - Log.debug (fun m -> m "find_child_n48 node %c" chr) ; - n48_find_child addr k - | 3 -> - Log.debug (fun m -> m "find_child_n256 node %c" chr) ; - n256_find_child addr k + | 0 -> n4_find_child addr k + | 1 -> n16_find_child addr k + | 2 -> n48_find_child addr k + | 3 -> n256_find_child addr k | _ -> assert false let rec _check_prefix ~key ~key_len ~prefix ~level idx max = - if idx < max - then ( if prefix.[idx] <> key.[level + idx] - then raise Not_found - else _check_prefix ~key ~key_len ~prefix ~level (succ idx) max ) - ;; + if idx < max then + if prefix.[idx] <> key.[level + idx] then raise Not_found + else _check_prefix ~key ~key_len ~prefix ~level (succ idx) max (* XXX(dinosaure): @@ -662,45 +696,42 @@ module Make (S : S) = struct let check_prefix (addr : _ rd Addr.t) ~key ~key_len level = let* depth = get Addr.(addr + _header_depth) Value.leint31 in - if key_len < depth - then raise Not_found (* XXX(dinosaure): we miss something! *) + if key_len < depth then + raise Not_found (* XXX(dinosaure): we miss something! *) else let* prefix, prefix_count = get_prefix addr in - if prefix_count + level < depth - then return (depth - level) (* XXX(dinosaure): optimistic match *) - else if prefix_count > 0 - then + if prefix_count + level < depth then return (depth - level) + (* XXX(dinosaure): optimistic match *) + else if prefix_count > 0 then ( (* XXX(dinosaure): this case appears when [prefix_count > 0] and [prefix_count + level < depth]. This case is possible because [depth = length(prefix) = min prefix_count _prefix]! That means that [depth] does not include all of the [prefix_count] but only a part of it (only what we can save into [prefix]). *) - let idx = (level + prefix_count) - depth + let idx = level + prefix_count - depth and max = min prefix_count _prefix in - _check_prefix ~key ~key_len ~prefix ~level idx max ; + _check_prefix ~key ~key_len ~prefix ~level idx max; - if prefix_count > _prefix - then return (max + (prefix_count - _prefix)) - (* XXX(dinosaure): optimistic match *) - else return (- max) (* prefix_count <= _prefix + level >= depth *) + if prefix_count > _prefix then return (max + (prefix_count - _prefix)) + (* XXX(dinosaure): optimistic match *) + else return (-max) (* prefix_count <= _prefix + level >= depth *)) else return 0 (* prefix_count:0 + level >= depth *) let memcmp a b = - if String.length a <> String.length b then raise Not_found ; + if String.length a <> String.length b then raise Not_found; let len = String.length a in let len0 = len land 3 in let len1 = len asr 2 in for i = 0 to len1 - 1 do let i = i * 4 in - if String.unsafe_get_uint32 a i <> String.unsafe_get_uint32 b i - then raise Not_found; - done ; + if String.unsafe_get_uint32 a i <> String.unsafe_get_uint32 b i then + raise Not_found + done; for i = 0 to len0 - 1 do let i = (len1 * 4) + i in - if a.[i] <> b.[i] then raise Not_found ; + if a.[i] <> b.[i] then raise Not_found done - ;; (* XXX(dinosaure): @@ -711,9 +742,11 @@ module Make (S : S) = struct type pessimistic = | Match of { level : int } | Skipped_level - | No_match of { non_matching_key : char - ; non_matching_prefix : string - ; level : int } + | No_match of { + non_matching_key : char; + non_matching_prefix : string; + level : int; + } (* XXX(dinosaure): [level] keeps 2 int31 values. It is initialised with: [level = (level lsl 31) lor level]. When we [succ level], we update only @@ -722,99 +755,94 @@ module Make (S : S) = struct /!\ Overflow is possible... *) - let rec _check_prefix_pessimistic - ~key ~minimum ~prefix ~prefix_count ~level idx max = - Log.debug (fun m -> m "check_prefix_pessimistic idx:%d, max:%d" idx max) ; - if idx = max then return (Match { level= level land 0x7fffffff }) + let rec _check_prefix_pessimistic ~key ~minimum ~prefix ~prefix_count ~level + idx max = + if idx = max then return (Match { level = level land 0x7fffffff }) else let* chr = (* XXX(dinosaure): note that a minimum, a leaf is, in ANYWAY, a constant value. It's why we can keep it as a [addr Lazy.t] without any trouble. *) - if idx >= _prefix - then Lazy.force minimum >>| fun key' -> - Log.debug (fun m -> m "Get the byte %d from the minimum %S." (level land 0x7fffffff) key') ; - key'.![level land 0x7fffffff] - else return prefix.[idx] in - Log.debug (fun m -> m "(prefix | minimum(node).key)[%d]:%02x <> key.[%d]:%02x" idx (Char.code chr) (level land 0x7fffffff) - (Char.code key.![level land 0x7fffffff])) ; - if chr <> key.![level land 0x7fffffff] - then + if idx >= _prefix then + Lazy.force minimum >>| fun key' -> key'.![level land 0x7fffffff] + else return prefix.[idx] + in + if chr <> key.![level land 0x7fffffff] then let non_matching_key = chr in let* non_matching_prefix = - if prefix_count > _prefix - then + if prefix_count > _prefix then ( let res = Bytes.make _prefix '\000' in let* key = Lazy.force minimum in - let len = min + let len = + min (prefix_count - ((level land 0x7fffffff) - (level lsr 31)) - 1) - _prefix in - Log.debug (fun m -> m "len:%d > 0 then blit %S %d bytes 0 %d" len key ((level land 0x7fffffff) + 1) len) ; - if len > 0 - then Bytes.blit_string key ((level land 0x7fffffff) + 1) res 0 len ; - return (Bytes.unsafe_to_string res) + _prefix + in + if len > 0 then + Bytes.blit_string key ((level land 0x7fffffff) + 1) res 0 len; + return (Bytes.unsafe_to_string res)) else let res = Bytes.make _prefix '\000' in - Log.debug (fun m -> m "blit %S (idx:%d + 1) res 0 (prefix_count:%d - idx:%d - 1)" prefix idx prefix_count idx) ; - if prefix_count - idx - 1 > 0 - then Bytes.blit_string prefix (idx + 1) res 0 - (prefix_count - idx - 1) ; - return (Bytes.unsafe_to_string res) in - return (No_match { non_matching_key - ; non_matching_prefix - ; level= level land 0x7fffffff }) - else _check_prefix_pessimistic - ~key ~minimum ~prefix ~prefix_count ~level:(succ level) (succ idx) max + if prefix_count - idx - 1 > 0 then + Bytes.blit_string prefix (idx + 1) res 0 (prefix_count - idx - 1); + return (Bytes.unsafe_to_string res) + in + return + (No_match + { + non_matching_key; + non_matching_prefix; + level = level land 0x7fffffff; + }) + else + _check_prefix_pessimistic ~key ~minimum ~prefix ~prefix_count + ~level:(succ level) (succ idx) max let check_prefix_pessimistic (addr : _ rd Addr.t) ~key level = let* prefix, prefix_count = get_prefix addr in - Log.debug (fun m -> m "prefix: %S, prefix-count: %d." prefix prefix_count) ; let* depth = get Addr.(addr + _header_depth) Value.leint31 in - if prefix_count + level < depth - then return Skipped_level - else if prefix_count > 0 - then - let idx = (level + prefix_count) - depth in + if prefix_count + level < depth then return Skipped_level + else if prefix_count > 0 then + let idx = level + prefix_count - depth in let max = prefix_count in - let minimum = Lazy.from_fun @@ fun () -> + let minimum = + Lazy.from_fun @@ fun () -> let* leaf = minimum addr in - get (Leaf.prj (Addr.unsafe_to_leaf leaf)) Value.c_string in - _check_prefix_pessimistic ~key ~minimum - ~prefix ~prefix_count - ~level:((level lsl 31) lor level) idx max + get (Leaf.prj (Addr.unsafe_to_leaf leaf)) Value.c_string + in + _check_prefix_pessimistic ~key ~minimum ~prefix ~prefix_count + ~level:((level lsl 31) lor level) + idx max else return (Match { level }) - (* XXX(dinosaure): even if [level] still is the same, - it seems that [_check_prefix_pessimistic] can return with - an other [level] value. *) + (* XXX(dinosaure): even if [level] still is the same, + it seems that [_check_prefix_pessimistic] can return with + an other [level] value. *) - let rec _lookup - (node : _ rd Addr.t) ~key ~key_len ~optimistic_match level = + let rec _lookup (node : _ rd Addr.t) ~key ~key_len ~optimistic_match level = let* res = check_prefix node ~key ~key_len level in let optimistic_match = if res > 0 then true else optimistic_match in - let level = level + (abs res) in - if key_len < level then raise Not_found ; + let level = level + abs res in + if key_len < level then raise Not_found; let* node = find_child node key.![level] in - if Addr.is_null node then raise Not_found ; - if (node :> int) land 1 = 1 (* XXX(dinosaure): it is a leaf. *) - then ( let leaf = Leaf.prj (Addr.unsafe_to_leaf node) in - if level < key_len - 1 || optimistic_match - then - let* key' = get leaf Value.c_string in - memcmp key key' ; - let len = (String.length key + size_of_word) / size_of_word in - (* padding *) - let len = len * size_of_word in - get Addr.(leaf + len) Value.leintnat - else - let len = (String.length key + size_of_word) / size_of_word in - (* padding *) - let len = len * size_of_word in - get Addr.(leaf + len) Value.leintnat ) + if Addr.is_null node then raise Not_found; + if (node :> int) land 1 = 1 (* XXX(dinosaure): it is a leaf. *) then + let leaf = Leaf.prj (Addr.unsafe_to_leaf node) in + if level < key_len - 1 || optimistic_match then ( + let* key' = get leaf Value.c_string in + memcmp key key'; + let len = (String.length key + size_of_word) / size_of_word in + (* padding *) + let len = len * size_of_word in + get Addr.(leaf + len) Value.leintnat) + else + let len = (String.length key + size_of_word) / size_of_word in + (* padding *) + let len = len * size_of_word in + get Addr.(leaf + len) Value.leintnat else _lookup node ~key ~key_len ~optimistic_match (succ level) - let lookup - : _ rd Addr.t -> key:string -> key_len:int -> int t - = fun (node : _ rd Addr.t) ~key ~key_len -> + let lookup : _ rd Addr.t -> key:string -> key_len:int -> int t = + fun (node : _ rd Addr.t) ~key ~key_len -> let node = Addr.unsafe_to_int node in let node = Addr.of_int_to_rdonly node in _lookup node ~key ~key_len ~optimistic_match:false 0 @@ -829,9 +857,9 @@ module Make (S : S) = struct type zero = Z type 'a node = - | N4 : rdwr Addr.t -> zero node - | N16 : rdwr Addr.t -> zero succ node - | N48 : rdwr Addr.t -> zero succ succ node + | N4 : rdwr Addr.t -> zero node + | N16 : rdwr Addr.t -> zero succ node + | N48 : rdwr Addr.t -> zero succ succ node | N256 : rdwr Addr.t -> zero succ succ succ node [@@@warning "+37"] @@ -852,118 +880,136 @@ module Make (S : S) = struct and [movnt64] to ensure a synchro between readers and writers. *) let add_child_n256 (N256 addr) k (value : ro Addr.t) flush = - if flush - then - let* () = atomic_set + if flush then + let* () = + atomic_set Addr.(to_wronly (addr + _header_length + (k * Addr.length))) - Value.addr_rd value in - let* () = persist Addr.(to_wronly (addr + _header_length + (k * Addr.length))) ~len:8 in - let* _ = fetch_add - Addr.(addr + _header_count) - Value.leint16 1 in + Value.addr_rd value + in + let* () = + persist + Addr.(to_wronly (addr + _header_length + (k * Addr.length))) + ~len:8 + in + let* _ = fetch_add Addr.(addr + _header_count) Value.leint16 1 in return true else - let* () = atomic_set + let* () = + atomic_set Addr.(addr + _header_length + (k * Addr.length)) - Value.addr_rd value in - let* _ = fetch_add - Addr.(addr + _header_count) - Value.leint16 1 in + Value.addr_rd value + in + let* _ = fetch_add Addr.(addr + _header_count) Value.leint16 1 in return true (* TODO(dinosaure): [P-ART] is different from [ROWEX]. *) + (* TODO(dinosaure): use [persist]? *) let add_child_n48 (N48 addr) k value _flush = let* compact_count = - atomic_get Addr.(addr + _header_compact_count) Value.leint16 in - if compact_count = 48 - then return false + atomic_get Addr.(addr + _header_compact_count) Value.leint16 + in + if compact_count = 48 then return false else - let* () = atomic_set + let* () = + atomic_set Addr.(addr + _header_length + 256 + (compact_count * Addr.length)) - Value.addr_rd value in - let* () = atomic_set - Addr.(addr + _header_length + k) - Value.int8 compact_count in - let* _ = fetch_add - Addr.(addr + _header_compact_count) - Value.leint16 1 in - let* _ = fetch_add - Addr.(addr + _header_count) - Value.leint16 1 in + Value.addr_rd value + in + let* () = + atomic_set Addr.(addr + _header_length + k) Value.int8 compact_count + in + let* _ = fetch_add Addr.(addr + _header_compact_count) Value.leint16 1 in + let* _ = fetch_add Addr.(addr + _header_count) Value.leint16 1 in return true let add_child_n16 (N16 addr) k (value : ro Addr.t) flush = let* compact_count = - atomic_get Addr.(addr + _header_compact_count) Value.leint16 in - if compact_count = 16 - then return false + atomic_get Addr.(addr + _header_compact_count) Value.leint16 + in + if compact_count = 16 then return false else - let* _next_index = fetch_add - Addr.(addr + _header_compact_count) - Value.leint16 1 in - let* _ = fetch_add - Addr.(addr + _header_count) - Value.leint16 1 in - if flush - then - let* () = atomic_set + let* _next_index = + fetch_add Addr.(addr + _header_compact_count) Value.leint16 1 + in + let* _ = fetch_add Addr.(addr + _header_count) Value.leint16 1 in + if flush then + let* () = + atomic_set Addr.(addr + _header_length + compact_count) - Value.int8 (k lxor 128) in + Value.int8 (k lxor 128) + in let* () = persist addr ~len:8 in - let* () = atomic_set - Addr.(to_wronly - (addr + _header_length + 16 - + (compact_count * Addr.length))) - Value.addr_rd value in - let* () = persist - Addr.(to_wronly - (addr + _header_length + 16 - + (compact_count * Addr.length))) - ~len:Addr.length in + let* () = + atomic_set + Addr.( + to_wronly + (addr + _header_length + 16 + (compact_count * Addr.length))) + Value.addr_rd value + in + let* () = + persist + Addr.( + to_wronly + (addr + _header_length + 16 + (compact_count * Addr.length))) + ~len:Addr.length + in return true else - let* () = atomic_set + let* () = + atomic_set Addr.(addr + _header_length + compact_count) - Value.int8 (k lxor 128) in - let* () = atomic_set + Value.int8 (k lxor 128) + in + let* () = + atomic_set Addr.(addr + _header_length + 16 + (compact_count * Addr.length)) - Value.addr_rd value in + Value.addr_rd value + in return true let add_child_n4 (N4 addr) k (value : ro Addr.t) flush = let* compact_count = - atomic_get Addr.(addr + _header_compact_count) Value.leint16 in - if compact_count = 4 - then return false + atomic_get Addr.(addr + _header_compact_count) Value.leint16 + in + if compact_count = 4 then return false else - let* _next_index = fetch_add - Addr.(addr + _header_compact_count) - Value.leint16 1 in - let* _ = fetch_add - Addr.(addr + _header_count) - Value.leint16 1 in - if flush - then - let* () = atomic_set - Addr.(addr + _header_length + compact_count) - Value.int8 k in + let* _next_index = + fetch_add Addr.(addr + _header_compact_count) Value.leint16 1 + in + let* _ = fetch_add Addr.(addr + _header_count) Value.leint16 1 in + if flush then + let* () = + atomic_set Addr.(addr + _header_length + compact_count) Value.int8 k + in let* () = persist addr ~len:_sizeof_n4 in - let* () = atomic_set - Addr.(to_wronly (addr + _header_length + 4 + _n4_align_length - + (compact_count * Addr.length))) - Value.addr_rd value in - let* () = persist - Addr.(to_wronly (addr + _header_length + 4 + _n4_align_length - + (compact_count * Addr.length))) - ~len:Addr.length in + let* () = + atomic_set + Addr.( + to_wronly + (addr + _header_length + 4 + _n4_align_length + + (compact_count * Addr.length))) + Value.addr_rd value + in + let* () = + persist + Addr.( + to_wronly + (addr + _header_length + 4 + _n4_align_length + + (compact_count * Addr.length))) + ~len:Addr.length + in return true else - let* () = atomic_set - Addr.(addr + _header_length + compact_count) - Value.int8 k in - let* () = atomic_set - Addr.(addr + _header_length + 4 + _n4_align_length + (compact_count * Addr.length)) - Value.addr_rd value in + let* () = + atomic_set Addr.(addr + _header_length + compact_count) Value.int8 k + in + let* () = + atomic_set + Addr.( + addr + _header_length + 4 + _n4_align_length + + (compact_count * Addr.length)) + Value.addr_rd value + in return true let write_unlock addr = @@ -974,7 +1020,7 @@ module Make (S : S) = struct let* _ = fetch_add Addr.(addr + _header_kind) Value.leintnat 0b11 in return () - let is_obsolete version = (version land 1 = 1) + let is_obsolete version = version land 1 = 1 let _read_unlock_or_restart addr expected = let* value = atomic_get Addr.(addr + _header_kind) Value.leintnat in @@ -984,8 +1030,7 @@ module Make (S : S) = struct (* XXX(dinosaure): spin-lock *) let rec until_is_locked addr version = - if version land 0b10 = 0b10 - then + if version land 0b10 = 0b10 then let* () = pause_intrinsic in let* version = atomic_get Addr.(addr + _header_kind) Value.leintnat in until_is_locked addr version @@ -995,22 +1040,35 @@ module Make (S : S) = struct let rec write_lock_or_restart addr need_to_restart = let* version = atomic_get Addr.(addr + _header_kind) Value.leintnat in let* version = until_is_locked addr version in - if is_obsolete version - then ( need_to_restart := true ; return () ) + if is_obsolete version then ( + need_to_restart := true; + return ()) else - let* res = compare_exchange ~weak:true Addr.(addr + _header_kind) - Value.leintnat (Atomic.make version) (version + 0b10) in + let* res = + compare_exchange ~weak:true + Addr.(addr + _header_kind) + Value.leintnat (Atomic.make version) (version + 0b10) + in if not res then write_lock_or_restart addr need_to_restart else return () [@@inline] + let write_unlock_obsolete addr = + fetch_add Addr.(addr + _header_kind) Value.leintnat 0b11 + let lock_version_or_restart addr version need_to_restart = - if (version land 0b10 = 0b10)|| (version land 1 = 1) - then ( need_to_restart := true ; return version) + if version land 0b10 = 0b10 || version land 1 = 1 then ( + need_to_restart := true; + return version) else - let* set = compare_exchange Addr.(addr + _header_kind) - Value.leintnat (Atomic.make version) (version + 0b10) in + let* set = + compare_exchange + Addr.(addr + _header_kind) + Value.leintnat (Atomic.make version) (version + 0b10) + in if set then return (version + 0b10) - else ( need_to_restart := true ; return version ) + else ( + need_to_restart := true; + return version) (***** CHANGE/UPDATE CHILD *****) @@ -1021,58 +1079,72 @@ module Make (S : S) = struct Should we protect [addr] with typed constructor? *) - let rec _n4_update_child addr k ptr i = - let* compact_count = atomic_get Addr.(addr + _header_compact_count) - Value.leint16 in - if i < compact_count - then + let rec _n4_update_child (addr : 'a wr Addr.t) k ptr i = + let* compact_count = + atomic_get Addr.(addr + _header_compact_count) Value.leint16 + in + if i < compact_count then let* key = atomic_get Addr.(addr + _header_length + i) Value.int8 in - let* child = atomic_get - Addr.(addr + _header_length + 4 + _n4_align_length + (i * Addr.length)) Value.addr_rd in - if not (Addr.is_null child) && key = k - then atomic_set Addr.(addr + _header_length + 4 + _n4_align_length + (i * Addr.length)) + let* child = + atomic_get + Addr.( + addr + _header_length + 4 + _n4_align_length + (i * Addr.length)) + Value.addr_rd + in + if (not (Addr.is_null child)) && key = k then + atomic_set + Addr.( + addr + _header_length + 4 + _n4_align_length + (i * Addr.length)) Value.addr_rd ptr else _n4_update_child addr k ptr (succ i) else assert false (* XXX(dinosaure): impossible or integrity problem! *) let n4_update_child addr k ptr = _n4_update_child addr k ptr 0 - let rec _n16_child_pos addr k bitfield = + let rec _n16_child_pos addr k bitfield : rdwr Addr.t t = if bitfield = 0 then assert false else let p = ctz bitfield in let* k' = atomic_get Addr.(addr + _header_length + p) Value.int8 in - let* value = atomic_get - Addr.(addr + _header_length + 16 + (p * Addr.length)) Value.addr_rd in - if not (Addr.is_null value) && k' = (k lxor 128) - then return Addr.(to_rdonly - (addr + _header_length + 16 + (p * Addr.length))) + let* value = + atomic_get + Addr.(addr + _header_length + 16 + (p * Addr.length)) + Value.addr_rd + in + if (not (Addr.is_null value)) && k' = k lxor 128 then + return Addr.(addr + _header_length + 16 + (p * Addr.length)) else _n16_child_pos addr k (bitfield lxor (1 lsl p)) let _n16_child_pos addr k = let* compact_count = - atomic_get Addr.(addr + _header_compact_count) Value.leint16 in + atomic_get Addr.(addr + _header_compact_count) Value.leint16 + in let* keys = atomic_get Addr.(addr + _header_length) Value.leint128 in let bitfield = n16_get_child compact_count k keys in _n16_child_pos addr k bitfield let n16_update_child addr k ptr = let* addr = _n16_child_pos addr k in - let addr = Addr.of_int_to_wronly (addr :> int) in (* XXX(dinosaure): unsafe! *) + let addr = Addr.of_int_to_wronly (addr :> int) in + (* XXX(dinosaure): unsafe! *) atomic_set addr Value.addr_rd ptr let n48_update_child addr k ptr = let* idx = atomic_get Addr.(addr + _header_length + k) Value.int8 in atomic_set - Addr.(addr + _header_length + 256 + (idx * Addr.length)) Value.addr_rd ptr + Addr.(addr + _header_length + 256 + (idx * Addr.length)) + Value.addr_rd ptr let n256_update_child addr k ptr = atomic_set - Addr.(addr + _header_length + (k * Addr.length)) Value.addr_rd ptr + Addr.(addr + _header_length + (k * Addr.length)) + Value.addr_rd ptr let update_child addr k ptr = let* ty = get_type addr in - Log.debug (fun m -> m "Update child %02x" k) ; + Log.debug (fun m -> + m "%016x[%02x] <- %02x" (Addr.unsafe_to_int addr) k + (Addr.unsafe_to_int ptr)); match ty with | 0 -> n4_update_child addr k ptr | 1 -> n16_update_child addr k ptr @@ -1086,91 +1158,130 @@ module Make (S : S) = struct let n16 addr = N16 addr let n48 addr = N48 addr let n256 addr = N256 addr - let _count = String.make 2 '\000' let _compact_count = String.make 2 '\000' - let _n4_ks = String.make 4 '\000' let _n4_vs = String.concat "" (List.init 4 (const string_of_null_addr)) let _n4_align = String.make _n4_align_length '\xff' let alloc_n4 ~prefix:p ~prefix_count ~level = let prefix = Bytes.make 4 '\000' in - Bytes.blit_string p 0 prefix 0 (min _prefix (String.length p)) ; + Bytes.blit_string p 0 prefix 0 (min _prefix (String.length p)); let prefix_count = leint31_to_string prefix_count in let k = leintnat_to_string ((_n4_kind lsl _bits_kind) lor 0b100) in let o = leintnat_to_string 0 in let l = leint31_to_string level in allocate ~kind:`Node - [ Bytes.unsafe_to_string prefix; prefix_count; k; o; l; _count - ; _compact_count; _n4_ks; _n4_align; _n4_vs ] - ~len:_sizeof_n4 >>| n4 + [ + Bytes.unsafe_to_string prefix; + prefix_count; + k; + o; + l; + _count; + _compact_count; + _n4_ks; + _n4_align; + _n4_vs; + ] + ~len:_sizeof_n4 + >>| n4 let _n16_ks = String.make 16 '\000' let _n16_vs = String.concat "" (List.init 16 (const string_of_null_addr)) let alloc_n16 ~prefix:p ~prefix_count ~level = let prefix = Bytes.make 4 '\000' in - Bytes.blit_string p 0 prefix 0 (min _prefix (String.length p)) ; + Bytes.blit_string p 0 prefix 0 (min _prefix (String.length p)); let prefix_count = leint31_to_string prefix_count in let k = leintnat_to_string ((_n16_kind lsl _bits_kind) lor 0b100) in let o = leintnat_to_string 0 in let l = leint31_to_string level in allocate ~kind:`Node - [ Bytes.unsafe_to_string prefix; prefix_count; k; o; l; _count - ; _compact_count; _n16_ks; _n16_vs ] - ~len:_sizeof_n16 >>| n16 + [ + Bytes.unsafe_to_string prefix; + prefix_count; + k; + o; + l; + _count; + _compact_count; + _n16_ks; + _n16_vs; + ] + ~len:_sizeof_n16 + >>| n16 let _n48_ks = String.make 256 '\048' let _n48_vs = String.concat "" (List.init 48 (const string_of_null_addr)) let alloc_n48 ~prefix:p ~prefix_count ~level = let prefix = Bytes.make 4 '\000' in - Bytes.blit_string p 0 prefix 0 (min _prefix (String.length p)) ; + Bytes.blit_string p 0 prefix 0 (min _prefix (String.length p)); let prefix_count = leint31_to_string prefix_count in let k = leintnat_to_string ((_n48_kind lsl _bits_kind) lor 0b100) in let o = leintnat_to_string 0 in let l = leint31_to_string level in allocate ~kind:`Node - [ Bytes.unsafe_to_string prefix; prefix_count; k; o; l; _count - ; _compact_count; _n48_ks; _n48_vs ] - ~len:_sizeof_n48 >>| n48 + [ + Bytes.unsafe_to_string prefix; + prefix_count; + k; + o; + l; + _count; + _compact_count; + _n48_ks; + _n48_vs; + ] + ~len:_sizeof_n48 + >>| n48 let _n256_vs = String.concat "" (List.init 256 (const string_of_null_addr)) let alloc_n256 ~prefix:p ~prefix_count ~level = let prefix = Bytes.make 4 '\000' in - Bytes.blit_string p 0 prefix 0 (min _prefix (String.length p)) ; + Bytes.blit_string p 0 prefix 0 (min _prefix (String.length p)); let prefix_count = leint31_to_string prefix_count in let k = leintnat_to_string ((_n256_kind lsl _bits_kind) lor 0b100) in let o = leintnat_to_string 0 in let l = leint31_to_string level in allocate ~kind:`Node - [ Bytes.unsafe_to_string prefix; prefix_count; k; o; l; _count - ; _compact_count; _n256_vs ] - ~len:_sizeof_n256 >>| n256 + [ + Bytes.unsafe_to_string prefix; + prefix_count; + k; + o; + l; + _count; + _compact_count; + _n256_vs; + ] + ~len:_sizeof_n256 + >>| n256 (***** COPY CHILD (assert (sizeof(N0) <= sizeof(N1))) *****) let rec _copy_n4_into_n16 ~compact_count n4 n16 i = - if i = compact_count - then return () + if i = compact_count then return () else - let* value = atomic_get Addr.(n4 + _header_length + 4 + _n4_align_length + (i * Addr.length)) - Value.addr_rd in + let* value = + atomic_get + Addr.(n4 + _header_length + 4 + _n4_align_length + (i * Addr.length)) + Value.addr_rd + in match Addr.is_null value with - | true -> _copy_n4_into_n16 ~compact_count n4 n16 (succ i) + | true -> _copy_n4_into_n16 ~compact_count n4 n16 (succ i) | false -> - let* key = atomic_get Addr.(n4 + _header_length + i) Value.int8 in - let* _ = add_child_n16 n16 key value false in - (* XXX(dinosaure): assert (_ = true); *) - Log.debug (fun m -> m " N16> copy %02x (%016x)" - key (value :> int)) ; - _copy_n4_into_n16 ~compact_count n4 n16 (succ i) + let* key = atomic_get Addr.(n4 + _header_length + i) Value.int8 in + let* _ = add_child_n16 n16 key value false in + (* XXX(dinosaure): assert (_ = true); *) + _copy_n4_into_n16 ~compact_count n4 n16 (succ i) let copy_n4_into_n16 (N4 n4) n16 = let* compact_count = - atomic_get Addr.(n4 + _header_compact_count) Value.leint16 in + atomic_get Addr.(n4 + _header_compact_count) Value.leint16 + in _copy_n4_into_n16 ~compact_count n4 n16 0 (* XXX(dinosaure): [copy_n4_into_n4] is called when: @@ -1182,72 +1293,98 @@ module Make (S : S) = struct [null]. *) let rec _copy_n4_into_n4 nx ny i = - if i = 4 - then return () + if i = 4 then return () else - let* value = atomic_get Addr.(nx + _header_length + 4 + _n4_align_length + (i * Addr.length)) - Value.addr_rd in + let* value = + atomic_get + Addr.(nx + _header_length + 4 + _n4_align_length + (i * Addr.length)) + Value.addr_rd + in match Addr.is_null value with - | true -> _copy_n4_into_n4 nx ny (succ i) + | true -> _copy_n4_into_n4 nx ny (succ i) | false -> - let* key = atomic_get Addr.(nx + _header_length + i) Value.int8 in - let* _ = add_child_n4 ny key value false in - (* XXX(dinosaure): assert (_ = true); *) - _copy_n4_into_n4 nx ny (succ i) + let* key = atomic_get Addr.(nx + _header_length + i) Value.int8 in + let* _ = add_child_n4 ny key value false in + (* XXX(dinosaure): assert (_ = true); *) + _copy_n4_into_n4 nx ny (succ i) let copy_n4_into_n4 (N4 nx) ny = _copy_n4_into_n4 nx ny 0 let rec _copy_n16_into_n48 ~compact_count n16 n48 i = - if i = compact_count - then return () + if i = compact_count then return () else - let* value = atomic_get - Addr.(n16 + _header_length + 16 + (i * Addr.length)) Value.addr_rd in + let* value = + atomic_get + Addr.(n16 + _header_length + 16 + (i * Addr.length)) + Value.addr_rd + in match Addr.is_null value with - | true -> _copy_n16_into_n48 ~compact_count n16 n48 (succ i) + | true -> _copy_n16_into_n48 ~compact_count n16 n48 (succ i) | false -> - let* key = atomic_get Addr.(n16 + _header_length + i) Value.int8 in - let* _ = add_child_n48 n48 (key lxor 128) value false in - (* XXX(dinosaure): assert (_ = true); *) - _copy_n16_into_n48 ~compact_count n16 n48 (succ i) + let* key = atomic_get Addr.(n16 + _header_length + i) Value.int8 in + let* _ = add_child_n48 n48 (key lxor 128) value false in + (* XXX(dinosaure): assert (_ = true); *) + _copy_n16_into_n48 ~compact_count n16 n48 (succ i) let copy_n16_into_n48 (N16 n16) n48 = - let* compact_count = atomic_get Addr.(n16 + _header_compact_count) - Value.leint16 in + let* compact_count = + atomic_get Addr.(n16 + _header_compact_count) Value.leint16 + in _copy_n16_into_n48 ~compact_count n16 n48 0 let rec _copy_n16_into_n16 nx ny i = - if i = 16 - then return () + if i = 16 then return () else - let* value = atomic_get - Addr.(nx + _header_length + 16 + (i * Addr.length)) Value.addr_rd in + let* value = + atomic_get + Addr.(nx + _header_length + 16 + (i * Addr.length)) + Value.addr_rd + in match Addr.is_null value with - | true -> _copy_n16_into_n16 nx ny (succ i) + | true -> _copy_n16_into_n16 nx ny (succ i) | false -> - let* key = atomic_get Addr.(nx + _header_length + i) Value.int8 in - let* _ = add_child_n16 ny (key lxor 128) value false in - (* XXX(dinosaure): ssert (_ = true); *) - _copy_n16_into_n16 nx ny (succ i) + let* key = atomic_get Addr.(nx + _header_length + i) Value.int8 in + let* _ = add_child_n16 ny (key lxor 128) value false in + (* XXX(dinosaure): ssert (_ = true); *) + _copy_n16_into_n16 nx ny (succ i) let copy_n16_into_n16 (N16 nx) ny = _copy_n16_into_n16 nx ny 0 + let rec _copy_n16_into_n4 nx ny i = + if i = 16 then return () + else + let* value = + atomic_get + Addr.(nx + _header_length + 16 + (i * Addr.length)) + Value.addr_rd + in + match Addr.is_null value with + | true -> _copy_n16_into_n4 nx ny (succ i) + | false -> + let* key = atomic_get Addr.(nx + _header_length + i) Value.int8 in + let* _ = add_child_n4 ny (key lxor 128) value false in + (* XXX(dinosaure): ssert (_ = true); *) + _copy_n16_into_n4 nx ny (succ i) + + let copy_n16_into_n4 (N16 nx) (N4 _ as ny) = _copy_n16_into_n4 nx ny 0 + let rec _copy_n48_into_n256 n48 n256 k = if k = 256 then return () else let* index = atomic_get Addr.(n48 + _header_length + k) Value.int8 in match index with - | 48 -> _copy_n48_into_n256 n48 n256 (succ k) + | 48 -> _copy_n48_into_n256 n48 n256 (succ k) | _ -> - let* value = atomic_get - Addr.(n48 + _header_length + 256 + (index * Addr.length)) - Value.addr_rd in - let* _ = add_child_n256 n256 k value false in - (* XXX(dinosaure): assert (_ = true); *) - _copy_n48_into_n256 n48 n256 (succ k) + let* value = + atomic_get + Addr.(n48 + _header_length + 256 + (index * Addr.length)) + Value.addr_rd + in + let* _ = add_child_n256 n256 k value false in + (* XXX(dinosaure): assert (_ = true); *) + _copy_n48_into_n256 n48 n256 (succ k) - let copy_n48_into_n256 (N48 n48) n256 = - _copy_n48_into_n256 n48 n256 0 + let copy_n48_into_n256 (N48 n48) n256 = _copy_n48_into_n256 n48 n256 0 let rec _copy_n48_into_n48 nx ny k = if k = 256 then return () @@ -1256,39 +1393,72 @@ module Make (S : S) = struct match index with | 48 -> _copy_n48_into_n48 nx ny (succ k) | _ -> - let* value = atomic_get - Addr.(nx + _header_length + 256 + (index * Addr.length)) - Value.addr_rd in - let* _ = add_child_n48 ny k value false in - (* XXX(dinosaure): assert (_ = true); *) - _copy_n48_into_n48 nx ny (succ k) + let* value = + atomic_get + Addr.(nx + _header_length + 256 + (index * Addr.length)) + Value.addr_rd + in + let* _ = add_child_n48 ny k value false in + (* XXX(dinosaure): assert (_ = true); *) + _copy_n48_into_n48 nx ny (succ k) let copy_n48_into_n48 (N48 nx) ny = _copy_n48_into_n48 nx ny 0 + let rec _copy_n48_into_n16 nx ny k = + if k = 256 then return () + else + let* index = atomic_get Addr.(nx + _header_length + k) Value.int8 in + match index with + | 48 -> _copy_n48_into_n16 nx ny (succ k) + | _ -> + let* value = + atomic_get + Addr.(nx + _header_length + 256 + (index * Addr.length)) + Value.addr_rd + in + let* _ = add_child_n16 ny k value false in + (* XXX(dinosaure): assert (_ = true); *) + _copy_n48_into_n16 nx ny (succ k) + + let copy_n48_into_n16 (N48 nx) (N16 _ as ny) = _copy_n48_into_n16 nx ny 0 + + let rec _copy_n256_into_n48 nx ny k = + if k = 256 then return () + else + let* value = + atomic_get Addr.(nx + _header_length + (k * Addr.length)) Value.addr_rd + in + let* _ = + if not (Addr.is_null value) then add_child_n48 ny k value false + else return true + in + _copy_n256_into_n48 nx ny (succ k) + + let copy_n256_into_n48 (N256 nx) (N48 _ as ny) = _copy_n256_into_n48 nx ny 0 + let _insert_grow_n4_n16 (N4 addr as n4) p k kp value need_to_restart = let* inserted = add_child_n4 n4 k value true in if inserted then write_unlock addr else - ( Log.debug (fun m -> m "We must grow the N4 node to a N16 node") - ; let* prefix, prefix_count = get_prefix addr in - let* level = get Addr.(addr + _header_depth) Value.leint31 in - let* N16 addr' as n16 = alloc_n16 ~prefix ~prefix_count ~level in - Log.debug (fun m -> m "Copy N4 children into new N16 node") - ; let* () = copy_n4_into_n16 n4 n16 in - let* _ = add_child_n16 n16 k value false in - (* XXX(dinosaure): assert (_ = true); *) - let* () = write_lock_or_restart p need_to_restart in - if !need_to_restart - then ( let* () = delete addr' - (_header_length + 16 + (Addr.length * 16)) in - write_unlock addr ) - else - let* () = persist addr' ~len:_sizeof_n16 in - let* () = update_child p kp (Addr.to_rdonly addr') in - let* () = write_unlock p in - let* () = write_unlock_and_obsolete addr in - let* uid = atomic_get Addr.(addr + _header_owner) Value.leintnat in - collect addr ~len:(_header_length + 4 + _n4_align_length + (Addr.length * 4)) ~uid ) + let* prefix, prefix_count = get_prefix addr in + let* level = get Addr.(addr + _header_depth) Value.leint31 in + let* (N16 addr' as n16) = alloc_n16 ~prefix ~prefix_count ~level in + let* () = copy_n4_into_n16 n4 n16 in + let* _ = add_child_n16 n16 k value false in + (* XXX(dinosaure): assert (_ = true); *) + let* () = write_lock_or_restart p need_to_restart in + if !need_to_restart then + let* () = delete addr' (_header_length + 16 + (Addr.length * 16)) in + write_unlock addr + else + let* () = persist addr' ~len:_sizeof_n16 in + let* () = update_child p kp (Addr.to_rdonly addr') in + let* () = write_unlock p in + let* () = write_unlock_and_obsolete addr in + let* uid = atomic_get Addr.(addr + _header_owner) Value.leintnat in + collect addr + ~len:(_header_length + 4 + _n4_align_length + (Addr.length * 4)) + ~uid let _insert_grow_n16_n48 (N16 addr as n16) p k kp value need_to_restart = let* inserted = add_child_n16 n16 k value true in @@ -1296,15 +1466,14 @@ module Make (S : S) = struct else let* prefix, prefix_count = get_prefix addr in let* level = get Addr.(addr + _header_depth) Value.leint31 in - let* N48 addr' as n48 = alloc_n48 ~prefix ~prefix_count ~level in + let* (N48 addr' as n48) = alloc_n48 ~prefix ~prefix_count ~level in let* () = copy_n16_into_n48 n16 n48 in - let* _ = add_child_n48 n48 k value false in + let* _ = add_child_n48 n48 k value false in (* XXX(dinosaure): assert (_ = true); *) let* () = write_lock_or_restart p need_to_restart in - if !need_to_restart - then ( let* () = delete addr' - (_header_length + 256 + (Addr.length * 48)) in - write_unlock addr ) + if !need_to_restart then + let* () = delete addr' (_header_length + 256 + (Addr.length * 48)) in + write_unlock addr else let* () = persist addr' ~len:_sizeof_n48 in let* () = update_child p kp (Addr.to_rdonly addr') in @@ -1319,15 +1488,14 @@ module Make (S : S) = struct else let* prefix, prefix_count = get_prefix addr in let* level = get Addr.(addr + _header_depth) Value.leint31 in - let* N256 addr' as n256 = alloc_n256 ~prefix ~prefix_count ~level in + let* (N256 addr' as n256) = alloc_n256 ~prefix ~prefix_count ~level in let* () = copy_n48_into_n256 n48 n256 in - let* _ = add_child_n256 n256 k value false in + let* _ = add_child_n256 n256 k value false in (* XXX(dinosaure): assert (_ = true); *) let* () = write_lock_or_restart p need_to_restart in - if !need_to_restart - then ( let* () = delete addr' - (_header_length + 256 + (Addr.length * 256)) in - write_unlock addr ) + if !need_to_restart then + let* () = delete addr' (_header_length + 256 + (Addr.length * 256)) in + write_unlock addr else let* () = persist addr' ~len:_sizeof_n256 in let* () = update_child p kp (Addr.to_rdonly addr') in @@ -1339,33 +1507,37 @@ module Make (S : S) = struct let insert_compact_n4 (N4 addr as n4) p k kp value need_to_restart = let* prefix, prefix_count = get_prefix addr in let* level = get Addr.(addr + _header_depth) Value.leint31 in - let* N4 addr' as n4' = alloc_n4 ~prefix ~prefix_count ~level in + let* (N4 addr' as n4') = alloc_n4 ~prefix ~prefix_count ~level in let* () = copy_n4_into_n4 n4 n4' in - let* _ = add_child_n4 n4' k value false in + let* _ = add_child_n4 n4' k value false in (* XXX(dinosaure): assert (_ = true); *) let* () = write_lock_or_restart p need_to_restart in - if !need_to_restart - then ( let* () = delete addr' (_header_length + 4 + _n4_align_length + (Addr.length * 4)) in - write_unlock addr ) + if !need_to_restart then + let* () = + delete addr' (_header_length + 4 + _n4_align_length + (Addr.length * 4)) + in + write_unlock addr else let* () = persist addr' ~len:_sizeof_n4 in let* () = update_child p kp (Addr.to_rdonly addr') in let* () = write_unlock p in let* () = write_unlock_and_obsolete addr in let* uid = atomic_get Addr.(addr + _header_owner) Value.leintnat in - collect addr ~len:(_header_length + 4 + _n4_align_length + (Addr.length * 4)) ~uid + collect addr + ~len:(_header_length + 4 + _n4_align_length + (Addr.length * 4)) + ~uid let insert_compact_n16 (N16 addr as n16) p k kp value need_to_restart = let* prefix, prefix_count = get_prefix addr in let* level = get Addr.(addr + _header_depth) Value.leint31 in - let* N16 addr' as n16' = alloc_n16 ~prefix ~prefix_count ~level in + let* (N16 addr' as n16') = alloc_n16 ~prefix ~prefix_count ~level in let* () = copy_n16_into_n16 n16 n16' in - let* _ = add_child_n16 n16' k value false in + let* _ = add_child_n16 n16' k value false in (* XXX(dinosaure): assert (_ = true); *) let* () = write_lock_or_restart p need_to_restart in - if !need_to_restart - then ( let* () = delete addr' (_header_length + 16 + (Addr.length * 16)) in - write_unlock addr ) + if !need_to_restart then + let* () = delete addr' (_header_length + 16 + (Addr.length * 16)) in + write_unlock addr else let* () = persist addr' ~len:_sizeof_n16 in let* () = update_child p kp (Addr.to_rdonly addr') in @@ -1377,14 +1549,14 @@ module Make (S : S) = struct let insert_compact_n48 (N48 addr as n48) p k kp value need_to_restart = let* prefix, prefix_count = get_prefix addr in let* level = get Addr.(addr + _header_depth) Value.leint31 in - let* N48 addr' as n48' = alloc_n48 ~prefix ~prefix_count ~level in + let* (N48 addr' as n48') = alloc_n48 ~prefix ~prefix_count ~level in let* () = copy_n48_into_n48 n48 n48' in - let* _ = add_child_n48 n48' k value false in + let* _ = add_child_n48 n48' k value false in (* XXX(dinosaure): assert (_ = true); *) let* () = write_lock_or_restart p need_to_restart in - if !need_to_restart - then ( let* () = delete addr' (_header_length + 256 + (Addr.length * 48)) in - write_unlock addr ) + if !need_to_restart then + let* () = delete addr' (_header_length + 256 + (Addr.length * 48)) in + write_unlock addr else let* () = persist addr' ~len:_sizeof_n48 in let* () = update_child p kp (Addr.to_rdonly addr') in @@ -1397,47 +1569,66 @@ module Make (S : S) = struct let* ty = get_type n in match ty with | 0 -> - let* compact_count = - atomic_get Addr.(n + _header_compact_count) Value.leint16 in - let* count = atomic_get Addr.(n + _header_count) Value.leint16 in - Log.debug (fun m -> m "insert %02x into N4 (compact_count: %d, count: %d)" - k compact_count count) ; - if compact_count = 4 && count <= 3 - then insert_compact_n4 (N4 n) p k kp value need_to_restart - else _insert_grow_n4_n16 (N4 n) p k kp value need_to_restart + let* compact_count = + atomic_get Addr.(n + _header_compact_count) Value.leint16 + in + let* count = atomic_get Addr.(n + _header_count) Value.leint16 in + if compact_count = 4 && count <= 3 then + insert_compact_n4 (N4 n) p k kp value need_to_restart + else _insert_grow_n4_n16 (N4 n) p k kp value need_to_restart | 1 -> - let* compact_count = - atomic_get Addr.(n + _header_compact_count) Value.leint16 in - let* count = atomic_get Addr.(n + _header_count) Value.leint16 in - if compact_count = 16 && count <= 14 - then insert_compact_n16 (N16 n) p k kp value need_to_restart - else _insert_grow_n16_n48 (N16 n) p k kp value need_to_restart + let* compact_count = + atomic_get Addr.(n + _header_compact_count) Value.leint16 + in + let* count = atomic_get Addr.(n + _header_count) Value.leint16 in + if compact_count = 16 && count <= 14 then + insert_compact_n16 (N16 n) p k kp value need_to_restart + else _insert_grow_n16_n48 (N16 n) p k kp value need_to_restart | 2 -> - let* compact_count = - atomic_get Addr.(n + _header_compact_count) Value.leint16 in - let* count = atomic_get Addr.(n + _header_count) Value.leint16 in - if compact_count = 48 && count <> 48 - then insert_compact_n48 (N48 n) p k kp value need_to_restart - else _insert_grow_n48_n256 (N48 n) p k kp value need_to_restart + let* compact_count = + atomic_get Addr.(n + _header_compact_count) Value.leint16 + in + let* count = atomic_get Addr.(n + _header_count) Value.leint16 in + if compact_count = 48 && count <> 48 then + insert_compact_n48 (N48 n) p k kp value need_to_restart + else _insert_grow_n48_n256 (N48 n) p k kp value need_to_restart | 3 -> - Log.debug (fun m -> m "insert %02x into N256" k); - (* TODO(dinosaure): [P-ART] uses [insertCompact] and [ROWEX] - just do a simple [insert]. I'm not sure about this part! *) - let* _ = add_child_n256 (N256 n) k value true in - let* () = write_unlock n in - return () + Log.debug (fun m -> + m "%016x[%02x] <- %016x (node256)" (Addr.unsafe_to_int n) k + (Addr.unsafe_to_int value)); + (* TODO(dinosaure): [P-ART] uses [insertCompact] and [ROWEX] + just do a simple [insert]. I'm not sure about this part! *) + let* _ = add_child_n256 (N256 n) k value true in + let* () = write_unlock n in + return () | _ -> assert false let check_or_raise_duplicate ~level:off a b = - Log.debug (fun m -> m "check duplicate ~level:%d %S %S" off a b) ; - if String.length a = String.length b - then ( let idx = ref (String.length a - 1) in - while !idx >= off && a.[!idx] = b.[!idx] do decr idx done ; - if !idx < off then raise Duplicate ) + if String.length a = String.length b then ( + let idx = ref (String.length a - 1) in + while !idx >= off && a.[!idx] = b.[!idx] do + decr idx + done; + if !idx < off then raise Duplicate) + + let pp_hex ppf s = + for idx = 0 to String.length s - 1 do + let c = s.[idx] in + Format.fprintf ppf "%02x" (int_of_char c) + done + + let rec max_hex = 8 + + and pp_key ~level ppf key = + if level >= String.length key || level < 0 then Fmt.pf ppf "ε" + else + let key = String.(sub key level (length key - level)) in + if String.length key >= max_hex then + Fmt.pf ppf "%a..." pp_hex (String.sub key 0 max_hex) + else Fmt.pf ppf "%a" pp_hex key let rec insert root key leaf = let rec restart () = insert root key leaf - (* XXX(dinosaure): with [multicore] (eg. ['a t = 'a]), it should be posible to raise an exception [Restart] and simulate a [goto] as ROWEX explains. However, if we took the monadic-view of ['a t], [Restart] will leak. @@ -1445,137 +1636,157 @@ module Make (S : S) = struct So we call [restart] and ensure that the call is tail-recursive (and can be optimised by OCaml). Then, we compile with [-unbox-closures] to avoid allocation on this area - but we need to introspect such optimisation. *) - - and _insert (node : rdwr Addr.t) parent pk level = + and _insert (node : rdwr Addr.t) parent kp level = let need_to_restart = ref false in let* version = get_version node in let* res = check_prefix_pessimistic node ~key level in - ( match res with + match res with | Skipped_level -> restart () - | No_match { non_matching_key; non_matching_prefix; level= level'; } -> - Log.debug (fun m -> m "check_prefix_pessimistic %016x ~key:%S %d : \ - No_match { non_matching_key: %c; \ - non_matching_prefix: %S; level: %d }" - (node :> int) key level non_matching_key - non_matching_prefix level') ; - if level' > String.length key then raise Duplicate ; - (* XXX(dinosaure): such [if] is may be wrong... TODO! *) - let* _version = lock_version_or_restart node version need_to_restart in - if !need_to_restart then (restart[@tailcall]) () else - let* prefix, _ = get_prefix node in - Log.debug (fun m -> m "prefix of the current node %016x: %S" (node :> int) prefix) ; - let* N4 addr as n4 = - alloc_n4 ~prefix ~prefix_count:(level' - level) ~level:level' in - let* _ = add_child_n4 n4 (Char.code key.![level']) leaf - false in - let* _ = add_child_n4 n4 (Char.code non_matching_key) - (Addr.to_rdonly node) false in - let* () = persist addr ~len:_sizeof_n4 in - let* () = write_lock_or_restart parent need_to_restart in - if !need_to_restart - then - let* () = delete addr (_header_length + 4 + (Addr.length * 4)) in - let* () = write_unlock node in - (restart[@tailcall]) () - else - (* XXX(dinosaure): red-zone, it's not possible to install a new node - and truncate the prefix in a single operation. As a consequence, a - reader may see the intermediate state. To solve this problem, we - augment each node with a 'level' field, which stores the hieght of - the node including the prefix and which never changes after a node - has been created. - - With this additional information, the intermediate state is safe, - because **the reader will detect that the prefix has to be - skipped**. Similarly, it is also possible that a reader sees the - final state without seen the new node. In that situation, the - reader can detect the missing prefix using level field and - retrieve the missing key from database. - - With P-ART, the C++ code tries to simulate the inconsistence with - the macro CRASH_SPLIT. We did not integrate it here. *) - let* () = update_child parent pk (Addr.to_rdonly addr) in - let* () = write_unlock parent in - let* _, prefix_count = get_prefix node in - Log.debug (fun m -> m "set-prefix: level':%d" level') ; - Log.debug (fun m -> m "set-prefix: level :%d" level ) ; - Log.debug (fun m -> m "set-prefix: prefix-count:%d" prefix_count) ; - Log.debug (fun m -> m "set-prefix %016x ~prefix:%S ~prefix_count:%d" (node :> int) non_matching_prefix (prefix_count - ((level' - level) + 1))) ; - let* () = set_prefix node ~prefix:non_matching_prefix - ~prefix_count:(prefix_count - ((level' - level) + 1)) true in - let* () = write_unlock node in - return () - | Match { level= level' } -> - Log.debug (fun m -> m "check_prefix_pessimistic %016x ~key:%S %d : \ - Match { %d }" - (node :> int) key level level') ; - let level = level' in - let* next = find_child node key.![level] in - Log.debug (fun m -> m "child is null: %b." (Addr.is_null next)) ; - if Addr.is_null next - then - let* _version = - lock_version_or_restart node version need_to_restart in - if !need_to_restart then (restart[@tailcall]) () else - ( let* () = insert_and_unlock node parent (Char.code key.![level]) - pk leaf need_to_restart in - if !need_to_restart then (restart[@tailcall]) () - else return () ) - else if (next :> int) land 1 = 1 - then - let () = Log.debug (fun m -> m "the child is a leaf.") in - let* key' = get (Leaf.prj (Addr.unsafe_to_leaf next)) - Value.c_string in - check_or_raise_duplicate ~level:(level + 1) key key' ; - (* XXX(dinosaure): in the C impl., this check does **not** exists but: - - create () - - insert "foo" 0 - - insert "foo" 1 - seems to work. So, the check try find the diff between [key] and - [key'] from the end of these strings. The worst case is when - [key = key'] of course but we should assume that the user does not - want to insert several times the same key. *) + | No_match { non_matching_key; non_matching_prefix; level = level' } -> + if level' > String.length key then raise Duplicate; + (* XXX(dinosaure): such [if] is may be wrong... TODO! *) let* _version = - lock_version_or_restart node version need_to_restart in - if !need_to_restart then (restart[@tailcall]) () else - ( let prefix = Bytes.make _prefix '\000' in - let prefix_count = ref 0 in - let top = min (String.length key - (level + 1)) - (String.length key' - (level + 1)) in - while !prefix_count < top - && key.[level + 1 + !prefix_count] = - key'.[level + 1 + !prefix_count] - do if !prefix_count < 4 - then Bytes.set prefix !prefix_count - key.[level + 1 + !prefix_count] ; - incr prefix_count done ; - Log.debug (fun m -> m "prefix:%S (count: %d)" - (Bytes.unsafe_to_string prefix) !prefix_count) ; - let* N4 addr as n4 = - alloc_n4 ~prefix:(Bytes.unsafe_to_string prefix) - ~prefix_count:!prefix_count - ~level:(level + 1 + !prefix_count) in - (* XXX(dinosaure): Imagine you add "foo" and "fo" into an empty tree - (see [ctor]), we have: 1) a prefix "o" 2) an alteration between - the end of "fo" and the last "o" of "foo". In that case, we must - have an ~illegal~ access on these strings - fortunately, OCaml - always pads a string with at least, one '\000'. So even if it - seems an unsafe access, it is ~safe~ in this **specific** - context. *) - let* _ = add_child_n4 n4 - (Char.code key.![level + 1 + !prefix_count]) leaf false in - let* _ = add_child_n4 n4 - (Char.code key'.![level + 1 + !prefix_count]) next false in + lock_version_or_restart node version need_to_restart + in + if !need_to_restart then (restart [@tailcall]) () + else + let* prefix, _ = get_prefix node in + let* (N4 addr as n4) = + alloc_n4 ~prefix ~prefix_count:(level' - level) ~level:level' + in + let* _ = add_child_n4 n4 (Char.code key.![level']) leaf false in + let* _ = + add_child_n4 n4 + (Char.code non_matching_key) + (Addr.to_rdonly node) false + in let* () = persist addr ~len:_sizeof_n4 in - Log.debug (fun m -> m "Update key.[%d] = %c." level key.[level]) ; - let* _ = update_child node - (Char.code key.[level]) (Addr.to_rdonly addr) in - let* _ = write_unlock node in - return () ) - else - let () = Log.debug (fun m -> m "the child is a node.") in - _insert (Addr.of_int_to_rdwr (next :> int)) node - (Char.code key.[level]) (succ level) ) in + let* () = write_lock_or_restart parent need_to_restart in + if !need_to_restart then + let* () = delete addr (_header_length + 4 + (Addr.length * 4)) in + let* () = write_unlock node in + (restart [@tailcall]) () + else + (* XXX(dinosaure): red-zone, it's not possible to install a new node + and truncate the prefix in a single operation. As a consequence, a + reader may see the intermediate state. To solve this problem, we + augment each node with a 'level' field, which stores the hieght of + the node including the prefix and which never changes after a node + has been created. + + With this additional information, the intermediate state is safe, + because **the reader will detect that the prefix has to be + skipped**. Similarly, it is also possible that a reader sees the + final state without seen the new node. In that situation, the + reader can detect the missing prefix using level field and + retrieve the missing key from database. + + With P-ART, the C++ code tries to simulate the inconsistence with + the macro CRASH_SPLIT. We did not integrate it here. *) + let* () = update_child parent kp (Addr.to_rdonly addr) in + let* () = write_unlock parent in + let* _, prefix_count = get_prefix node in + let* () = + set_prefix node ~prefix:non_matching_prefix + ~prefix_count:(prefix_count - (level' - level + 1)) + true + in + let* () = write_unlock node in + return () + | Match { level = level' } -> + let level = level' in + let* next = find_child node key.![level] in + Log.debug (fun m -> + m "%016x[%02x] is null? %b" (Addr.unsafe_to_int node) + (Char.code key.![level]) + (Addr.is_null next)); + if Addr.is_null next then + let* _version = + lock_version_or_restart node version need_to_restart + in + if !need_to_restart then (restart [@tailcall]) () + else + let* () = + insert_and_unlock node parent + (Char.code key.![level]) + kp leaf need_to_restart + in + if !need_to_restart then (restart [@tailcall]) () else return () + else if (next :> int) land 1 = 1 then ( + let () = + Log.debug (fun m -> + m "%016x[%02x] is a leaf" (Addr.unsafe_to_int node) + (Char.code key.![level])) + in + let* key' = + get (Leaf.prj (Addr.unsafe_to_leaf next)) Value.c_string + in + check_or_raise_duplicate ~level:(level + 1) key key'; + (* XXX(dinosaure): in the C impl., this check does **not** exists but: + - create () + - insert "foo" 0 + - insert "foo" 1 + seems to work. So, the check try find the diff between [key] and + [key'] from the end of these strings. The worst case is when + [key = key'] of course but we should assume that the user does not + want to insert several times the same key. *) + let* _version = + lock_version_or_restart node version need_to_restart + in + if !need_to_restart then (restart [@tailcall]) () + else + let prefix = Bytes.make _prefix '\000' in + let prefix_count = ref 0 in + let top = + min + (String.length key - (level + 1)) + (String.length key' - (level + 1)) + in + while + !prefix_count < top + && key.[level + 1 + !prefix_count] + = key'.[level + 1 + !prefix_count] + do + if !prefix_count < 4 then + Bytes.set prefix !prefix_count key.[level + 1 + !prefix_count]; + incr prefix_count + done; + let* (N4 addr as n4) = + alloc_n4 + ~prefix:(Bytes.unsafe_to_string prefix) + ~prefix_count:!prefix_count + ~level:(level + 1 + !prefix_count) + in + (* XXX(dinosaure): Imagine you add "foo" and "fo" into an empty tree + (see [ctor]), we have: 1) a prefix "o" 2) an alteration between + the end of "fo" and the last "o" of "foo". In that case, we must + have an ~illegal~ access on these strings - fortunately, OCaml + always pads a string with at least, one '\000'. So even if it + seems an unsafe access, it is ~safe~ in this **specific** + context. *) + let* _ = + add_child_n4 n4 + (Char.code key.![level + 1 + !prefix_count]) + leaf false + in + let* _ = + add_child_n4 n4 + (Char.code key'.![level + 1 + !prefix_count]) + next false + in + let* () = persist addr ~len:_sizeof_n4 in + let* _ = + update_child node (Char.code key.[level]) (Addr.to_rdonly addr) + in + let* _ = write_unlock node in + return ()) + else + _insert + (Addr.of_int_to_rdwr (next :> int)) + node + (Char.code key.[level]) + (succ level) + in (* XXX(dinosaure): [ctor] creates a [N256] node on the [root]. So, the case to enlarge the current [root] node **can not** appears and the "parent" @@ -1587,23 +1798,375 @@ module Make (S : S) = struct [Addr.null]. According to the comment below, this write access should not be used to write something into [Addr.null] but we need to play the game of the type-system. *) - _insert root Addr.(of_int_to_rdwr (null :> int)) 0 0 + let _n4_get_second_child addr key = + let rec go i = + let* compact_count = + atomic_get Addr.(addr + _header_compact_count) Value.leint16 + in + if i < compact_count then + let* child = + atomic_get + Addr.( + addr + _header_length + 4 + _n4_align_length + (Addr.length * i)) + Value.addr_rdwr + in + if not (Addr.is_null child) then + let* k = atomic_get Addr.(addr + _header_length + i) Value.int8 in + if k != key then return (child, Char.unsafe_chr k) else go (succ i) + else go (succ i) + else return (Addr.null, '\000') + in + go 0 + + let _get_second_child addr chr = + let key = Char.code chr in + let* ty = get_type addr in + match ty with 0 -> _n4_get_second_child addr key | _ -> assert false + + let _n4_remove ~force:_ ?(flush = true) addr key = + let rec go i = + let* compact_count = + atomic_get Addr.(addr + _header_compact_count) Value.leint16 + in + if i < compact_count then + let* child = + atomic_get + Addr.( + addr + _header_length + 4 + _n4_align_length + (Addr.length * i)) + Value.addr_rdwr + in + let* k = atomic_get Addr.(addr + _header_length + i) Value.int8 in + if (not (Addr.is_null child)) && k == key then + let* () = + atomic_set + Addr.( + to_wronly + (addr + _header_length + 4 + _n4_align_length + + (i * Addr.length))) + Value.addr_rd + Addr.(to_rdonly null) + in + let* () = + if flush then + persist + Addr.( + to_wronly + (addr + _header_length + 4 + _n4_align_length + + (i * Addr.length))) + ~len:Addr.length + else return () + in + let* _ = fetch_sub Addr.(addr + _header_count) Value.leint16 1 in + return true + else go (succ i) + else go (succ i) + in + go 0 + + let _n16_remove ~force ?(flush = true) addr key = + let* count = atomic_get Addr.(addr + _header_count) Value.leint16 in + if count <= 3 && not force then return false + else + let* leaf = _n16_child_pos addr key in + let* () = + atomic_set Addr.(to_wronly leaf) Value.addr_rd Addr.(to_rdonly null) + in + let* () = + if flush then persist Addr.(to_wronly leaf) ~len:Addr.length + else return () + in + let* _ = fetch_sub Addr.(addr + _header_count) Value.leint16 1 in + return true + + let _n48_remove ~force ?(flush = true) addr key = + let* count = atomic_get Addr.(addr + _header_count) Value.leint16 in + if count <= 12 && not force then return false + else + let* () = + if flush then + let* child_index = + atomic_get Addr.(addr + _header_length + key) Value.int8 + in + let leaf = + Addr.(addr + _header_length + 256 + (child_index * Addr.length)) + in + let* () = + atomic_set Addr.(to_wronly leaf) Value.addr_rd Addr.(to_rdonly null) + in + let* () = persist Addr.(to_wronly leaf) ~len:Addr.length in + let* () = + atomic_set + Addr.(to_wronly (addr + _header_length + key)) + Value.int8 48 + in + persist Addr.(to_wronly (addr + _header_length + (key / 8))) ~len:64 + else + let* child_index = + atomic_get Addr.(addr + _header_length + key) Value.int8 + in + let leaf = + Addr.(addr + _header_length + 256 + (child_index * Addr.length)) + in + let* () = + atomic_set Addr.(to_wronly leaf) Value.addr_rd Addr.(to_rdonly null) + in + atomic_set + Addr.(to_wronly (addr + _header_length + key)) + Value.int8 48 + in + let* _ = fetch_sub Addr.(addr + _header_count) Value.leint16 1 in + return true + + let _n256_remove ~force ?(flush = true) addr key = + let* count = atomic_get Addr.(addr + _header_count) Value.leint16 in + if count <= 37 && not force then return false + else + let leaf = Addr.(addr + _header_length + (Addr.length * key)) in + let* () = + atomic_set Addr.(to_wronly leaf) Value.addr_rd Addr.(to_rdonly null) + in + let* () = + if flush then persist Addr.(to_wronly leaf) ~len:Addr.length + else return () + in + let* _ = fetch_sub Addr.(addr + _header_count) Value.leint16 1 in + return true + + let _remove ~force ?flush addr chr = + let k = Char.code chr in + let* ty = get_type addr in + match ty with + | 0 -> _n4_remove ~force ?flush addr k + | 1 -> _n16_remove ~force ?flush addr k + | 2 -> _n48_remove ~force ?flush addr k + | 3 -> _n256_remove ~force ?flush addr k + | _ -> assert false + + let addr : type a. a node -> rdwr Addr.t = function + | N4 addr -> addr + | N16 addr -> addr + | N48 addr -> addr + | N256 addr -> addr + + let length : type a. a node -> int = function + | N4 _ -> _sizeof_n4 + | N16 _ -> _sizeof_n16 + | N48 _ -> _sizeof_n48 + | N256 _ -> _sizeof_n256 + + let shrink : + type v. + v succ node -> v node -> _ Addr.t -> char -> char -> bool ref -> unit t = + fun n n_small p k kp need_to_restart -> + let* () = write_lock_or_restart p need_to_restart in + if !need_to_restart then + let* () = delete (addr n_small) (length n_small) in + write_unlock (addr n) + else + let* _ = _remove ~force:true ~flush:true (addr n) k in + let* () = + match (n, n_small) with + | N16 _, N4 _ -> copy_n16_into_n4 n n_small + | N48 _, N16 _ -> copy_n48_into_n16 n n_small + | N256 _, N48 _ -> copy_n256_into_n48 n n_small + in + let* () = persist Addr.(to_wronly (addr n_small)) ~len:(length n_small) in + let* () = update_child p (Char.code kp) (Addr.to_rdonly (addr n_small)) in + let* () = write_unlock p in + let* _ = write_unlock_obsolete (addr n) in + let* uid = atomic_get Addr.(addr n + _header_owner) Value.leintnat in + let n_length = length n in + collect (addr n) ~len:n_length ~uid + + let remove_and_shrink n p k kp need_to_restart = + let* res = _remove ~force:(Addr.is_null p) ~flush:true n k in + if res then write_unlock n + else + let* ty = get_type n in + (* TODO(dinosaure): repetition with [remove_and_unlock]. *) + let* level = get Addr.(n + _header_depth) Value.leint31 in + let* prefix, prefix_count = get_prefix n in + match ty with + | 1 -> + let* n_small = alloc_n4 ~prefix ~prefix_count ~level in + shrink (N16 n) n_small p k kp need_to_restart + | 2 -> + let* n_small = alloc_n16 ~prefix ~prefix_count ~level in + shrink (N48 n) n_small p k kp need_to_restart + | 3 -> + let* n_small = alloc_n48 ~prefix ~prefix_count ~level in + shrink (N256 n) n_small p k kp need_to_restart + | _ -> assert false + + let remove_and_unlock n p k kp need_to_restart = + let* ty = get_type n in + match ty with + | 0 -> + let* _ = _n4_remove ~force:false ~flush:true n (Char.code k) in + write_unlock n + | _ -> remove_and_shrink n p k kp need_to_restart + + let add_prefix_before n0 n1 k = + let* p0, p0_length = get_prefix n0 in + let* p1, p1_length = get_prefix n1 in + let prefix_copy_count = min _prefix (p1_length + 1) in + let p0' = Bytes.of_string p0 in + Bytes.blit p0' 0 p0' prefix_copy_count + (min p0_length (_prefix - prefix_copy_count)); + Bytes.blit_string p1 0 p0' 0 (min prefix_copy_count p1_length); + if p1_length < _prefix then Bytes.set p0' (prefix_copy_count - 1) k; + let p0_count' = p1_length + 1 in + set_prefix n0 + ~prefix:(Bytes.unsafe_to_string p0') + ~prefix_count:p0_count' true + + let rec remove root key : unit t = + let rec restart () = remove root key + and _remove (next_node : _ wr Addr.t) (node : _ wr Addr.t) ~key ~key_len + (node_key : char) level = + let parent = node in + let parent_key = node_key in + let node = next_node in + let need_to_restart = ref false in + let* version = get_version node in + let* res = check_prefix node ~key ~key_len level in + let level = level + abs res in + if key_len < level then + let* version' = atomic_get Addr.(node + _header_kind) Value.leintnat in + if is_obsolete version || version != version' then + (restart [@tailcall]) () + else raise Not_found + else + let* next_node = find_child node key.![level] in + Log.debug (fun m -> + m "next node %016x (from %016x[%02x]) is a leaf? %b" + (Addr.unsafe_to_int next_node) + (Addr.unsafe_to_int node) + (Char.code key.![level]) + (Addr.unsafe_to_int next_node land 1 = 1)); + let next_node = Addr.unsafe_to_rdwr next_node in + if Addr.is_null next_node then ( + Log.debug (fun m -> + m "search %02x from %a (node:%016x, level:%d): not found" + (Char.code key.![level]) + (pp_key ~level) key (Addr.unsafe_to_int node) level); + let* version' = + atomic_get Addr.(node + _header_kind) Value.leintnat + in + if is_obsolete version || version != version' then + (restart [@tailcall]) () + else raise Not_found) + else if + Addr.unsafe_to_int next_node land 1 + = 1 (* XXX(dinosaure): it is a leaf. *) + then ( + let* _version = + lock_version_or_restart node version need_to_restart + in + Log.debug (fun m -> + m "lock %016x, need to restart? %b" (Addr.unsafe_to_int node) + !need_to_restart); + if !need_to_restart then (restart [@tailcall]) () + else + let* count = atomic_get Addr.(node + _header_count) Value.leint16 in + if count == 2 && node != root then ( + (* XXX(dinosaure): [get_type node == 0] (N4) *) + let* second_node, second_node_k = + _get_second_child node key.![level] + in + Log.debug (fun m -> + m "second node of %016x is %016x" (Addr.unsafe_to_int node) + (Addr.unsafe_to_int second_node)); + if + (second_node :> int) land 1 + = 1 (* XXX(dinosaure): it is a leaf. *) + then + let* () = write_lock_or_restart parent need_to_restart in + if !need_to_restart then + let* () = write_unlock node in + (restart [@tailcall]) () + else + let* () = + update_child parent (Char.code parent_key) + (Addr.to_rdonly second_node) + in + let* () = write_unlock parent in + let* uid = + atomic_get Addr.(node + _header_owner) Value.leintnat + in + collect node + ~len: + (_header_length + 4 + _n4_align_length + (Addr.length * 4)) + ~uid + else + let* version_child = get_version second_node in + let* _ = + lock_version_or_restart second_node version_child + need_to_restart + in + if !need_to_restart then + let* () = write_unlock node in + (restart [@tailcall]) () + else + let* () = write_lock_or_restart parent need_to_restart in + if !need_to_restart then + let* () = write_unlock node in + let* () = write_unlock second_node in + (restart [@tailcall]) () + else + let* () = + update_child parent (Char.code parent_key) + (Addr.to_rdonly second_node) + in + let* () = + add_prefix_before second_node node second_node_k + in + let* () = write_unlock parent in + let* _ = write_unlock_obsolete node in + let* uid = + atomic_get Addr.(node + _header_owner) Value.leintnat + in + let* () = + collect node + ~len: + (_header_length + 4 + _n4_align_length + + (Addr.length * 4)) + ~uid + in + write_unlock second_node) + else + let* () = + remove_and_unlock node parent key.![level] parent_key + need_to_restart + in + if !need_to_restart then (restart [@tailcall]) () else return ()) + else _remove next_node node ~key ~key_len key.![level] (succ level) + in + _remove root + Addr.(of_int_to_rdwr (null :> int)) + ~key ~key_len:(String.length key) '\000' 0 + + let remove root key = + Log.debug (fun m -> m "Remove"); + Log.debug (fun m -> m "@[%a@]" (Hxd_string.pp Hxd.default) key); + remove root key + let make () = - let* N256 addr = alloc_n256 ~prefix:"" ~prefix_count:0 ~level:0 in - return (addr) + let* (N256 addr) = alloc_n256 ~prefix:"" ~prefix_count:0 ~level:0 in + return addr let insert root key value = - Log.debug (fun m -> m "Insert %S." key) ; - let len = (String.length key + size_of_word) / size_of_word in (* padding *) + Log.debug (fun m -> m "Insert"); + Log.debug (fun m -> m "@[%a@]" (Hxd_string.pp Hxd.default) key); + let len = (String.length key + size_of_word) / size_of_word in + (* padding *) let len = len * size_of_word in let pad = String.make (len - String.length key) '\000' in let value = leintnat_to_string value in let* leaf = allocate ~kind:`Leaf [ key; pad; value ] in - Log.debug (fun m -> m "Insert %S at %016x" key (leaf :> int)) ; - let* () = insert root key (Addr.unsafe_of_leaf (Leaf.inj leaf)) in - Log.debug (fun m -> m "%S inserted." key) ; return () + insert root key (Addr.unsafe_of_leaf (Leaf.inj leaf)) [@@@warning "-32"] end diff --git a/lib/rowex.mli b/lib/rowex.mli index 9e7c2f3..0aac205 100644 --- a/lib/rowex.mli +++ b/lib/rowex.mli @@ -14,41 +14,37 @@ type key = private string val key : string -> key external unsafe_key : string -> key = "%identity" -type 'a rd = < rd : unit; .. > as 'a -type 'a wr = < wr : unit; .. > as 'a - -type ro = < rd : unit; > -type wo = < wr : unit; > - -type rdwr = < rd : unit; wr : unit; > +type 'a rd = < rd : unit ; .. > as 'a +type 'a wr = < wr : unit ; .. > as 'a +type ro = < rd : unit > +type wo = < wr : unit > +type rdwr = < rd : unit ; wr : unit > module Addr : sig type 'a t = private int - val null : ro t + val null : rdwr t val is_null : 'a t -> bool - external of_int_to_rdonly : int -> ro t = "%identity" external of_int_to_wronly : int -> wo t = "%identity" external of_int_to_rdwr : int -> rdwr t = "%identity" - external to_wronly : 'a wr t -> wo t = "%identity" external to_rdonly : 'a rd t -> ro t = "%identity" - external unsafe_to_int : _ t -> int = "%identity" - val ( + ) : 'a t -> int -> 'a t end type ('c, 'a) value = - | Int8 : (atomic, int) value - | LEInt : (atomic, int) value - | LEInt16 : (atomic, int) value - | LEInt31 : (atomic, int) value - | LEInt64 : (atomic, int64) value + | Int8 : (atomic, int) value + | LEInt : (atomic, int) value + | LEInt16 : (atomic, int) value + | LEInt31 : (atomic, int) value + | LEInt64 : (atomic, int64) value | LEInt128 : (atomic, string) value - | Addr_rd : (atomic, ro Addr.t) value + | Addr_rd : (atomic, ro Addr.t) value + | Addr_rdwr : (atomic, rdwr Addr.t) value | C_string : (non_atomic, string) value + and atomic = Atomic and non_atomic = Non_atomic @@ -62,7 +58,6 @@ module type S = sig val bind : 'a t -> ('a -> 'b t) -> 'b t val return : 'a -> 'a t - val atomic_get : 'a rd Addr.t -> (atomic, 'v) value -> 'v t val atomic_set : 'a wr Addr.t -> (atomic, 'v) value -> 'v -> unit t @@ -85,11 +80,17 @@ module type S = sig and we prefer to assume a correct write order than a micro-optimization. *) - val fetch_add : rdwr Addr.t -> (atomic, int) value -> int -> int t - val fetch_or : rdwr Addr.t -> (atomic, int) value -> int -> int t - val fetch_sub : rdwr Addr.t -> (atomic, int) value -> int -> int t + val fetch_add : rdwr Addr.t -> (atomic, int) value -> int -> int t + val fetch_or : rdwr Addr.t -> (atomic, int) value -> int -> int t + val fetch_sub : rdwr Addr.t -> (atomic, int) value -> int -> int t - val compare_exchange : ?weak:bool -> rdwr Addr.t -> (atomic, 'a) value -> 'a Atomic.t -> 'a -> bool t + val compare_exchange : + ?weak:bool -> + rdwr Addr.t -> + (atomic, 'a) value -> + 'a Atomic.t -> + 'a -> + bool t val pause_intrinsic : unit t (** [pause_intrinsic] provides a hint to the processor that the code @@ -113,7 +114,9 @@ module type S = sig So, [uid] helps the allocator to ensure {i consistency} between multiple processes. *) - val allocate : kind:[ `Leaf | `Node ] -> ?len:int -> string list -> rdwr Addr.t t + val allocate : + kind:[ `Leaf | `Node ] -> ?len:int -> string list -> rdwr Addr.t t + val delete : _ Addr.t -> int -> unit t val collect : _ Addr.t -> len:int -> uid:int -> unit t end @@ -128,17 +131,22 @@ module Make (S : S) : sig val find : 'a rd Addr.t -> key -> int t val insert : rdwr Addr.t -> key -> int -> unit t val make : unit -> rdwr Addr.t t + val remove : rdwr Addr.t -> key -> unit t (** / *) type pessimistic = | Match of { level : int } | Skipped_level - | No_match of { non_matching_key : char - ; non_matching_prefix : string - ; level : int } + | No_match of { + non_matching_key : char; + non_matching_prefix : string; + level : int; + } + + val check_prefix_pessimistic : + 'a rd Addr.t -> key:string -> int -> pessimistic t - val check_prefix_pessimistic : 'a rd Addr.t -> key:string -> int -> pessimistic t val check_prefix : 'a rd Addr.t -> key:string -> key_len:int -> int -> int t val find_child : 'a rd Addr.t -> char -> ro Addr.t t end diff --git a/test/check.ml b/test/check.ml new file mode 100644 index 0000000..15594ad --- /dev/null +++ b/test/check.ml @@ -0,0 +1,14 @@ +module Impl = struct + type 'a t = 'a + + let bind x f = f x + let return x = x + + let atomic_get (t : 'a rd Addr.t) v = + match vtable.(t :> int), v with + | (Int8, cell), Int8 -> TracedAtomic.get cell + | (LEInt16, cell), Int8 -> TracedAtomic.get cell land 0xf + | (LEInt, cell), Int8 -> TracedAtomic.get cell land 0xf + | (LEInt31, cell), Int8 -> TracedAtomic.get cell land 0xf + | (LEInt64, cell), Int8 -> Int64.(to_int (logand (TracedAtomic.get cell) 0xfL)) +end diff --git a/test/fiber.ml b/test/fiber.ml index 91a5c09..a262838 100644 --- a/test/fiber.ml +++ b/test/fiber.ml @@ -1,4 +1,5 @@ let src = Logs.Src.create "fiber" + module Log = (val Logs.src_log src : Logs.LOG) let () = Printexc.record_backtrace true @@ -6,11 +7,8 @@ let () = Printexc.record_backtrace true type 'a t = ('a -> unit) -> unit let return x k = k x - let ( >>> ) a b k = a (fun () -> b k) - let ( >>= ) t f k = t (fun x -> f x k) - let ( >>| ) t f k = t (fun x -> k (f x)) let both a b = @@ -19,7 +17,6 @@ let both a b = module Ivar = struct type 'a state = Full of 'a | Empty of ('a -> unit) Queue.t - type 'a t = { mutable state : 'a state } let create () = { state = Empty (Queue.create ()) } @@ -28,7 +25,7 @@ module Ivar = struct match t.state with | Full _ -> failwith "Ivar.fill" | Empty q -> - t.state <- Full x ; + t.state <- Full x; Queue.iter (fun f -> f x) q let read t k = match t.state with Full x -> k x | Empty q -> Queue.push k q @@ -42,7 +39,7 @@ end let fork f k = let ivar = Ivar.create () in - f () (fun x -> Ivar.fill ivar x) ; + f () (fun x -> Ivar.fill ivar x); k ivar let fork_and_join f g = @@ -73,42 +70,52 @@ let safe_close fd = try Unix.close fd with _exn -> () let _reporter pid ppf = let report src level ~over k msgf = let k _ = - over () ; - k () in + over (); + k () + in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("[%06d]%a[%a]: " ^^ fmt ^^ "\n%!") pid Logs_fmt.pp_header (level, header) Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in { Logs.report } let create_process ?file prgn = - let out0, out1 = match file with + let out0, out1 = + match file with | None -> Unix.pipe () | Some filename -> - Log.debug (fun m -> m "Save result of children into %s." filename) ; - let ic = Unix.openfile filename Unix.[ O_RDONLY; O_CREAT; O_TRUNC ] 0o644 in - let oc = Unix.openfile filename Unix.[ O_WRONLY; O_CREAT; O_TRUNC ] 0o644 in - ic, oc in + Log.debug (fun m -> m "Save result of children into %s." filename); + let ic = + Unix.openfile filename Unix.[ O_RDONLY; O_CREAT; O_TRUNC ] 0o644 + in + let oc = + Unix.openfile filename Unix.[ O_WRONLY; O_CREAT; O_TRUNC ] 0o644 + in + (ic, oc) + in match Unix.fork () with | 0 -> ( - Unix.close out0 ; + Unix.close out0; let oc = Unix.out_channel_of_descr out1 in try let res = prgn () in - Log.debug (fun m -> m "End of the process %d." (Unix.getpid ())) ; - Marshal.to_channel oc res [ Marshal.No_sharing ] ; - Log.debug (fun m -> m "Result of %d marshalled." (Unix.getpid ())) ; - flush oc ; close_out oc ; + Log.debug (fun m -> m "End of the process %d." (Unix.getpid ())); + Marshal.to_channel oc res [ Marshal.No_sharing ]; + Log.debug (fun m -> m "Result of %d marshalled." (Unix.getpid ())); + flush oc; + close_out oc; exit 0 with exn -> - Log.err (fun m -> m "Got an error: %S" (Printexc.to_string exn)) ; - Log.err (fun m -> m "Backtrace: %s" (Printexc.get_backtrace ())) ; + Log.err (fun m -> m "Got an error: %S" (Printexc.to_string exn)); + Log.err (fun m -> m "Backtrace: %s" (Printexc.get_backtrace ())); exit 127) | pid -> - Unix.close out1 ; + Unix.close out1; (out0, pid) let get_concurrency () = @@ -116,27 +123,29 @@ let get_concurrency () = let ic = Unix.open_process_in "getconf _NPROCESSORS_ONLN" in let close () = ignore (Unix.close_process_in ic) in let sc = Scanf.Scanning.from_channel ic in - try Scanf.bscanf sc "%d" (fun n -> close () ; n) - with exn -> close () ; raise exn + try + Scanf.bscanf sc "%d" (fun n -> + close (); + n) + with exn -> + close (); + raise exn with - | Not_found | Sys_error _ | Failure _ | Scanf.Scan_failure _ - | End_of_file | Unix.Unix_error (_, _, _) -> 1 + | Not_found | Sys_error _ | Failure _ | Scanf.Scan_failure _ | End_of_file + | Unix.Unix_error (_, _, _) + -> + 1 let concurrency = ref (get_concurrency ()) - let running = Hashtbl.create ~random:false !concurrency - let waiting_for_slot = Queue.create () - let set_concurrency n = concurrency := n - let get_concurrency () = !concurrency let throttle () = - if Hashtbl.length running >= !concurrency - then ( + if Hashtbl.length running >= !concurrency then ( let ivar = Ivar.create () in - Queue.push ivar waiting_for_slot ; + Queue.push ivar waiting_for_slot; Ivar.read ivar) else return () @@ -149,36 +158,39 @@ let restart_throttle () = done let signals = - [ Sys.sigabrt, "SIGABRT" - ; Sys.sigalrm, "SIGALRM" - ; Sys.sigfpe, "SIGFPE" - ; Sys.sighup, "SIGHUP" - ; Sys.sigill, "SIGILL" - ; Sys.sigint, "SIGINT" - ; Sys.sigkill, "SIGKILL" - ; Sys.sigpipe, "SIGPIPIE" - ; Sys.sigquit, "SIGQUIT" - ; Sys.sigsegv, "SIGSEGV" - ; Sys.sigterm, "SIGTERM" - ; Sys.sigusr1, "SIGUSR1" - ; Sys.sigusr2, "SIGUSR2" - ; Sys.sigchld, "SIGCHLD" - ; Sys.sigcont, "SIGCONT" - ; Sys.sigstop, "SIGSTOP" - ; Sys.sigtstp, "SIGTSTP" - ; Sys.sigttin, "SIGTTIN" - ; Sys.sigttou, "SIGTTOU" - ; Sys.sigvtalrm, "SIGVTALRM" - ; Sys.sigprof, "SIGPROF" - ; Sys.sigbus, "SIGBUS" - ; Sys.sigpoll, "SIGPOLL" - ; Sys.sigsys, "SIGSYS" - ; Sys.sigtrap, "SIGTRAP" - ; Sys.sigurg, "SIGURG" - ; Sys.sigxcpu, "SIGXCPU" - ; Sys.sigxfsz, "SIGXFSZ" ] - -let pp_signal ppf signal = match List.assoc_opt signal signals with + [ + (Sys.sigabrt, "SIGABRT"); + (Sys.sigalrm, "SIGALRM"); + (Sys.sigfpe, "SIGFPE"); + (Sys.sighup, "SIGHUP"); + (Sys.sigill, "SIGILL"); + (Sys.sigint, "SIGINT"); + (Sys.sigkill, "SIGKILL"); + (Sys.sigpipe, "SIGPIPIE"); + (Sys.sigquit, "SIGQUIT"); + (Sys.sigsegv, "SIGSEGV"); + (Sys.sigterm, "SIGTERM"); + (Sys.sigusr1, "SIGUSR1"); + (Sys.sigusr2, "SIGUSR2"); + (Sys.sigchld, "SIGCHLD"); + (Sys.sigcont, "SIGCONT"); + (Sys.sigstop, "SIGSTOP"); + (Sys.sigtstp, "SIGTSTP"); + (Sys.sigttin, "SIGTTIN"); + (Sys.sigttou, "SIGTTOU"); + (Sys.sigvtalrm, "SIGVTALRM"); + (Sys.sigprof, "SIGPROF"); + (Sys.sigbus, "SIGBUS"); + (Sys.sigpoll, "SIGPOLL"); + (Sys.sigsys, "SIGSYS"); + (Sys.sigtrap, "SIGTRAP"); + (Sys.sigurg, "SIGURG"); + (Sys.sigxcpu, "SIGXCPU"); + (Sys.sigxfsz, "SIGXFSZ"); + ] + +let pp_signal ppf signal = + match List.assoc_opt signal signals with | Some str -> Format.fprintf ppf "%s" str | None -> Format.fprintf ppf "%d" signal @@ -186,34 +198,36 @@ let run_process ?file prgn = throttle () >>= fun () -> let fd, pid = create_process ?file prgn in let ivar = Ivar.create () in - Hashtbl.add running pid ivar ; + Hashtbl.add running pid ivar; Ivar.read ivar >>= fun status -> let ic = Unix.in_channel_of_descr fd in match status with | Unix.WEXITED 0 -> - let res = Marshal.from_channel ic in - safe_close fd ; - return (Ok res) + let res = Marshal.from_channel ic in + safe_close fd; + return (Ok res) | Unix.WEXITED n -> - safe_close fd ; - return (Error n) + safe_close fd; + return (Error n) | Unix.WSIGNALED signal -> - Log.warn (fun m -> m "The processus %6d terminated with a signal: %a." pid pp_signal signal) ; - safe_close fd ; - return (Error 255) + Log.warn (fun m -> + m "The processus %6d terminated with a signal: %a." pid pp_signal + signal); + safe_close fd; + return (Error 255) | Unix.WSTOPPED _ -> assert false let run fiber = let result = ref None in - fiber (fun x -> result := Some x) ; + fiber (fun x -> result := Some x); let rec loop () = - if Hashtbl.length running > 0 - then ( + if Hashtbl.length running > 0 then ( let pid, status = Unix.wait () in let ivar = Hashtbl.find running pid in - Hashtbl.remove running pid ; - Ivar.fill ivar status ; - restart_throttle () ; + Hashtbl.remove running pid; + Ivar.fill ivar status; + restart_throttle (); loop ()) - else match !result with Some x -> x | None -> failwith "fiber" in + else match !result with Some x -> x | None -> failwith "fiber" + in loop () diff --git a/test/fiber.mli b/test/fiber.mli index e36e295..ccedfe7 100644 --- a/test/fiber.mli +++ b/test/fiber.mli @@ -1,31 +1,17 @@ type 'a t - type 'a ivar val return : 'a -> 'a t - val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t - val ( >>> ) : unit t -> unit t -> unit t - val both : 'a t -> 'b t -> ('a * 'b) t - val fork : (unit -> 'a t) -> 'a ivar t - val fork_and_join : (unit -> 'a t) -> (unit -> 'b t) -> ('a * 'b) t - val fork_and_join_unit : (unit -> unit t) -> (unit -> unit t) -> unit t - val parallel_map : 'a list -> f:('a -> 'b t) -> 'b list t - val parallel_iter : 'a list -> f:('a -> unit t) -> unit t - val run_process : ?file:string -> (unit -> 'a) -> ('a, int) result t - val run : 'a t -> 'a - val set_concurrency : int -> unit - val get_concurrency : unit -> int diff --git a/test/parallel_index.ml b/test/parallel_index.ml index a6c958b..8193459 100644 --- a/test/parallel_index.ml +++ b/test/parallel_index.ml @@ -3,16 +3,20 @@ let () = Printexc.record_backtrace true let reporter ppf = let report src level ~over k msgf = let k _ = - over () ; - k () in + over (); + k () + in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("%a[%a][%a]: " ^^ fmt ^^ "\n%!") Logs_fmt.pp_header (level, header) - Fmt.(styled `Blue (fmt "%10d")) (Unix.getpid ()) + Fmt.(styled `Blue (fmt "%10d")) + (Unix.getpid ()) Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in { Logs.report } open Rresult @@ -23,107 +27,123 @@ let size_of_word = Sys.word_size / 8 let exists state v key = match Part.(run state (find (Rowex.unsafe_key key))) with | state, v' -> - if v <> v' - then ( Logs.err (fun m -> m "Wrong value for %s." (key :> string)) ; exit 1 ) - else ( Logs.debug (fun m -> m "%s => %d." (key :> string) v) ; true, state ) - | exception Not_found -> false, state + if v <> v' then ( + Logs.err (fun m -> m "Wrong value for %s." (key :> string)); + exit 1) + else ( + Logs.debug (fun m -> m "%s => %d." (key :> string) v); + (true, state)) + | exception Not_found -> (false, state) -type kind = [ `Simple_consumer_simple_producer - | `Multiple_consumer_simple_producer ] +type kind = + [ `Simple_consumer_simple_producer | `Multiple_consumer_simple_producer ] let test ~kind dataset path = - Logs.debug (fun m -> m "Create the index.") ; + Logs.debug (fun m -> m "Create the index."); let fiber0 () = let th0 = let open Part in - let rec go ic n = match input_line ic with + let rec go ic n = + match input_line ic with | line -> - Logs.debug (fun m -> m "Insert %S." line) ; - let* _res = Part.insert (Rowex.unsafe_key line) n in - go ic (succ n) + Logs.debug (fun m -> m "Insert %S." line); + let* _res = Part.insert (Rowex.unsafe_key line) n in + go ic (succ n) | exception End_of_file -> - Logs.debug (fun m -> m "End of writer") ; - close_in ic ; close in - Logs.debug (fun m -> m "Start the writer.") ; + Logs.debug (fun m -> m "End of writer"); + close_in ic; + close + in + Logs.debug (fun m -> m "Start the writer."); let* () = open_index writer ~path in - go (open_in (Fpath.to_string dataset)) 0 in - let _closed, () = Part.(run closed th0) in () in + go (open_in (Fpath.to_string dataset)) 0 + in + let _closed, () = Part.(run closed th0) in + () + in let fiber1 dataset () = let rec go state dataset queue = let ress = Array.make (Array.length dataset) false in let fold (idx, state) key = - let res, state = exists state idx key in - ress.(idx) <- res ; - succ idx, state in - let _, state = Array.fold_left fold (0, state) dataset in - if not (Array.for_all identity ress) - then ( let _missing = - let fold acc = function - | true -> acc - | false -> succ acc in - Array.fold_left fold 0 ress in - Logs.debug (fun m -> m "Missing %d elements." _missing) - ; Queue.push ress queue - ; go state dataset queue ) - else - ( Logs.debug (fun m -> m "End of reader: @[%a@]" - Fmt.(Dump.array bool) ress) - ; Queue.push ress queue - ; state, Queue.fold (fun ress x -> x :: ress) [] queue ) in - Logs.debug (fun m -> m "Start the reader.") ; + let res, state = exists state idx key in + ress.(idx) <- res; + (succ idx, state) + in + let _, state = Array.fold_left fold (0, state) dataset in + if not (Array.for_all identity ress) then ( + let _missing = + let fold acc = function true -> acc | false -> succ acc in + Array.fold_left fold 0 ress + in + Logs.debug (fun m -> m "Missing %d elements." _missing); + Queue.push ress queue; + go state dataset queue) + else ( + Logs.debug (fun m -> + m "End of reader: @[%a@]" Fmt.(Dump.array bool) ress); + Queue.push ress queue; + (state, Queue.fold (fun ress x -> x :: ress) [] queue)) + in + Logs.debug (fun m -> m "Start the reader."); let uid = Unix.getpid () in let uid = Int64.of_int uid in let state, () = Part.(run closed (open_index (reader uid) ~path)) in let state, resss = go state dataset (Queue.create ()) in let _closed, () = Part.(run state close) in - resss in + resss + in let dataset = - let rec go ic acc = match input_line ic with + let rec go ic acc = + match input_line ic with | line -> go ic (line :: acc) | exception End_of_file -> - close_in ic ; Array.of_list (List.rev acc) in - go (open_in (Fpath.to_string dataset)) [] in + close_in ic; + Array.of_list (List.rev acc) + in + go (open_in (Fpath.to_string dataset)) [] + in match kind with - | `Multiple_consumer_simple_producer -> - let open Fiber in - let readers () = - let f _ = - let temp = R.failwith_error_msg (Tmp.tmp "fiber-%s") in - Logs.debug (fun m -> m "Run one reader.\n%!") ; - run_process ~file:(Fpath.to_string temp) (fiber1 dataset) >>= fun _res -> - return () in - parallel_iter ~f (List.init (get_concurrency () - 1) identity) >>= fun () -> - return (Ok ()) in - let writer () = run_process fiber0 in - ( fork_and_join writer readers >>= function - | Ok (), Ok () -> - Fmt.pr ">>> %d reader(s) terminate correctly.\n%!" (get_concurrency () - 1) ; - return (Ok ()) - | Error exit, _ -> - return (R.error_msgf "Reader exits with %03d" exit) - | _, Error exit -> - return (R.error_msgf "Writer exits with %03d" exit) ) - | `Simple_consumer_simple_producer -> - let open Fiber in - let temp = R.failwith_error_msg (Tmp.tmp "fiber-%s") in - ( fork_and_join + | `Multiple_consumer_simple_producer -> ( + let open Fiber in + let readers () = + let f _ = + let temp = R.failwith_error_msg (Tmp.tmp "fiber-%s") in + Logs.debug (fun m -> m "Run one reader.\n%!"); + run_process ~file:(Fpath.to_string temp) (fiber1 dataset) + >>= fun _res -> return () + in + parallel_iter ~f (List.init (get_concurrency () - 1) identity) + >>= fun () -> return (Ok ()) + in + let writer () = run_process fiber0 in + fork_and_join writer readers >>= function + | Ok (), Ok () -> + Fmt.pr ">>> %d reader(s) terminate correctly.\n%!" + (get_concurrency () - 1); + return (Ok ()) + | Error exit, _ -> return (R.error_msgf "Reader exits with %03d" exit) + | _, Error exit -> return (R.error_msgf "Writer exits with %03d" exit)) + | `Simple_consumer_simple_producer -> ( + let open Fiber in + let temp = R.failwith_error_msg (Tmp.tmp "fiber-%s") in + fork_and_join (fun () -> run_process fiber0) (fun () -> run_process ~file:(Fpath.to_string temp) (fiber1 dataset)) >>= function | Ok (), Ok histogram -> - Fmt.pr ">>> %d iteration(s).\n%!" (List.length histogram) ; - return (Ok ()) - | Error exit, _ -> - return (R.error_msgf "Reader exits with %03d" exit) - | _, Error exit -> - return (R.error_msgf "Writer exits with %03d" exit) ) + Fmt.pr ">>> %d iteration(s).\n%!" (List.length histogram); + return (Ok ()) + | Error exit, _ -> return (R.error_msgf "Reader exits with %03d" exit) + | _, Error exit -> return (R.error_msgf "Writer exits with %03d" exit)) let main multiple_readers dataset () () () = Tmp.tmp "index-%s" >>= fun path -> - Logs.debug (fun m -> m "Index file: %a" Fpath.pp path) ; - let kind = match multiple_readers with - | true -> `Multiple_consumer_simple_producer - | false -> `Simple_consumer_simple_producer in + Logs.debug (fun m -> m "Index file: %a" Fpath.pp path); + let kind = + match multiple_readers with + | true -> `Multiple_consumer_simple_producer + | false -> `Simple_consumer_simple_producer + in let path = Fpath.to_string path in match Part.(run closed (create path)) with | _closed, Ok () -> Fiber.run (test ~kind dataset path) @@ -132,23 +152,25 @@ let main multiple_readers dataset () () () = open Cmdliner let setup_logs style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer () ; - Logs.set_level level ; + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; Logs.set_reporter (reporter Fmt.stderr) let setup_logs = Term.(const setup_logs $ Fmt_cli.style_renderer () $ Logs_cli.level ()) -let setup_concurrency v = - Fiber.set_concurrency v +let setup_concurrency v = Fiber.set_concurrency v let setup_concurrency = - Term.(const setup_concurrency $ Arg.(value & opt int (Fiber.get_concurrency ()) & info [ "c"; "concurrency" ])) + Term.( + const setup_concurrency + $ Arg.( + value & opt int (Fiber.get_concurrency ()) & info [ "c"; "concurrency" ])) let setup_tmp = function | Some path -> - let _ = R.failwith_error_msg (Bos.OS.Dir.create ~path:true path) in - Tmp.set_default_dir path + let _ = R.failwith_error_msg (Bos.OS.Dir.create ~path:true path) in + Tmp.set_default_dir path | None -> () let fpath = Arg.conv (Fpath.of_string, Fpath.pp) @@ -157,21 +179,24 @@ let setup_tmp = Term.(const setup_tmp $ Arg.(value & opt (some fpath) None & info [ "tmp" ])) let existing_file = - let parser x = match Fpath.of_string x with + let parser x = + match Fpath.of_string x with | Ok _ as v when Sys.file_exists x -> v | Ok v -> R.error_msgf "%a not found" Fpath.pp v - | Error _ as err -> err in + | Error _ as err -> err + in Arg.conv (parser, Fpath.pp) let dataset = Arg.(required & opt (some existing_file) None & info [ "dataset" ]) -let multiple_readers = - Arg.(value & flag & info [ "multiple-readers" ]) +let multiple_readers = Arg.(value & flag & info [ "multiple-readers" ]) let main = - Cmd.v - (Cmd.info "ring") - Term.(term_result (const main $ multiple_readers $ dataset $ setup_concurrency $ setup_tmp $ setup_logs)) + Cmd.v (Cmd.info "ring") + Term.( + term_result + (const main $ multiple_readers $ dataset $ setup_concurrency $ setup_tmp + $ setup_logs)) let () = Cmd.(exit @@ eval main) diff --git a/test/persistent.ml b/test/persistent.ml index 48507e5..2e38307 100644 --- a/test/persistent.ml +++ b/test/persistent.ml @@ -28,8 +28,8 @@ let random_index : (_ Part.state, _) result Lazy.t = let path = Fpath.to_string path in match Part.(run closed (create path)) with | state, Ok () -> - let state, () = Part.(run state (open_index writer ~path)) in - Ok state + let state, () = Part.(run state (open_index writer ~path)) in + Ok state | _closed, Error err -> Error err let state_of_optional_path = function @@ -49,21 +49,25 @@ let find state key = let reporter ppf = let report src level ~over k msgf = let k _ = - over () ; - k () in + over (); + k () + in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("%a[%a][%a]: " ^^ fmt ^^ "\n%!") Logs_fmt.pp_header (level, header) - Fmt.(styled `Blue (fmt "%10d")) (Unix.getpid ()) + Fmt.(styled `Blue (fmt "%10d")) + (Unix.getpid ()) Fmt.(styled `Magenta string) - (Logs.Src.name src) in - msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt + in { Logs.report } let setup_logs style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer () ; - Logs.set_level level ; + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; Logs.set_reporter (reporter Fmt.stderr) let () = setup_logs (Some `Ansi_tty) (Some Logs.Debug) @@ -75,21 +79,23 @@ let test01 = let open Part in let* _ = insert (Rowex.key "abc") 1 in let* v' = find (Rowex.key "abc") in - Alcotest.(check int) "abc" v' 1 ; + Alcotest.(check int) "abc" v' 1; let* _ = insert (Rowex.key "ab") 2 in let* v' = find (Rowex.key "ab") in - Alcotest.(check int) "ab" v' 2 ; + Alcotest.(check int) "ab" v' 2; let* _ = insert (Rowex.key "abcde") 3 in let* v0 = find (Rowex.key "abc") in let* v1 = find (Rowex.key "ab") in let* v2 = find (Rowex.key "abcde") in - Alcotest.(check int) "abc" v0 1 ; - Alcotest.(check int) "ab" v1 2 ; - Alcotest.(check int) "abcde" v2 3 ; - return () in + Alcotest.(check int) "abc" v0 1; + Alcotest.(check int) "ab" v1 2; + Alcotest.(check int) "abcde" v2 3; + return () + in match Part.run state th0 with | _not_closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let test02 = @@ -105,56 +111,66 @@ let test02 = let* v1 = find (Rowex.key "a1") in let* v2 = find (Rowex.key "a2") in let* v3 = find (Rowex.key "a3") in - Alcotest.(check int) "a0" v0 0 ; - Alcotest.(check int) "a1" v1 1 ; - Alcotest.(check int) "a2" v2 2 ; - Alcotest.(check int) "a3" v3 3 ; + Alcotest.(check int) "a0" v0 0; + Alcotest.(check int) "a1" v1 1; + Alcotest.(check int) "a2" v2 2; + Alcotest.(check int) "a3" v3 3; let* _ = insert (Rowex.key "a4") 4 in let* v0 = find (Rowex.key "a0") in let* v1 = find (Rowex.key "a1") in let* v2 = find (Rowex.key "a2") in let* v3 = find (Rowex.key "a3") in let* v4 = find (Rowex.key "a4") in - Alcotest.(check int) "a0" v0 0 ; - Alcotest.(check int) "a1" v1 1 ; - Alcotest.(check int) "a2" v2 2 ; - Alcotest.(check int) "a3" v3 3 ; - Alcotest.(check int) "a4" v4 4 ; - return () in + Alcotest.(check int) "a0" v0 0; + Alcotest.(check int) "a1" v1 1; + Alcotest.(check int) "a2" v2 2; + Alcotest.(check int) "a3" v3 3; + Alcotest.(check int) "a4" v4 4; + return () + in match Part.run state th0 with | _not_closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let random_string len = let res = Bytes.create len in - for i = 0 to len - 1 do Bytes.set res i (Char.chr (1 + Random.int 255)) done ; + for i = 0 to len - 1 do + Bytes.set res i (Char.chr (1 + Random.int 255)) + done; Bytes.unsafe_to_string res let test03 = Alcotest.test_case "test03" `Quick @@ fun path -> let max = 500 in let state = state_of_optional_path path in - let vs = List.init max (fun _ -> random_string (1 + Random.int 63), Random.int max) in + let vs = + List.init max (fun _ -> (random_string (1 + Random.int 63), Random.int max)) + in let th0 = let open Part in let rec go0 = function | [] -> return () | (k, v) :: r -> - let* _ = Part.insert (Rowex.key k) v in - Alcotest.(check pass) (Fmt.str "insert %S" k) () () ; - go0 r in + let* _ = Part.insert (Rowex.key k) v in + Alcotest.(check pass) (Fmt.str "insert %S" k) () (); + go0 r + in let* () = go0 vs in let rec go1 = function | [] -> return () | (k, v) :: r -> - let* v' = find (Rowex.key k) in - Alcotest.(check int) (Fmt.str "%S" k) v' v ; - go1 r in - go1 vs in + let* v' = find (Rowex.key k) in + Alcotest.(check int) (Fmt.str "%S" k) v' v; + go1 r + in + go1 vs + in match Part.run state th0 with | _not_closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let test04 = @@ -169,15 +185,18 @@ let test04 = let* _ = insert (Rowex.key "amartabali@dps.centrim.net.id") 4 in let* _ = insert (Rowex.key "achatv@cbn.net.id") 5 in let* _ = insert (Rowex.key "bali@tuguhotels.com") 6 in - let* _ = insert (Rowex.key "baliminimalist@yahoo.com") 7 in (* prefix with [li] on a n16 node *) + let* _ = insert (Rowex.key "baliminimalist@yahoo.com") 7 in + (* prefix with [li] on a n16 node *) let* v0 = find (Rowex.key "bali@tuguhotels.com") in let* v1 = find (Rowex.key "baliminimalist@yahoo.com") in - Alcotest.(check int) "bali@tuguhotels.com" v0 6 ; - Alcotest.(check int) "baliminimalist@yahoo.com" v1 7 ; - return () in + Alcotest.(check int) "bali@tuguhotels.com" v0 6; + Alcotest.(check int) "baliminimalist@yahoo.com" v1 7; + return () + in match Part.run state th0 with | _not_closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let test05 = @@ -189,1750 +208,1768 @@ let test05 = let* v0 = find (Rowex.key "bali@tuguhotels.com") in let* v1 = find (Rowex.key "baliminimalist@yahoo.com") in let* v2 = find (Rowex.key "bliss@thebale.com") in - Alcotest.(check int) "bali@tuguhotels.com" v0 6 ; - Alcotest.(check int) "baliminimalist@yahoo.com" v1 7 ; - Alcotest.(check int) "bliss@thebale.com" v2 8 ; - return () in + Alcotest.(check int) "bali@tuguhotels.com" v0 6; + Alcotest.(check int) "baliminimalist@yahoo.com" v1 7; + Alcotest.(check int) "bliss@thebale.com" v2 8; + return () + in match Part.run state th0 with | _not_closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let test06 = Alcotest.test_case "test06" `Quick @@ fun path -> let state = state_of_optional_path path in let elts = - [ "adhidharma@denpasar.wasantara.net.id" - ; "centralreservation@ramayanahotel.com" - ; "apribadi@balimandira.com" - ; "cdagenhart@ifc.org" - ; "dana_supriyanto@interconti.com" - ; "dos@novotelbali.com" - ; "daniel@hotelpadma.com" - ; "daniel@balibless.com" - ; "djoko_p@jayakartahotelsresorts.com" - ; "expdepot@indosat.net.id" - ; "feby.adamsyah@idn.xerox.com" - ; "christian_rizal@interconti.com" - ; "singgih93@mailcity.com" - ; "idonk_gebhoy@yahoo.com" - ; "info@houseofbali.com" - ; "kyohana@toureast.net" - ; "sales@nusaduahotel.com" - ; "jayakarta@mataram.wasantara.net.id" - ; "mapindo@indo.net.id" - ; "sm@ramayanahotel.com" - ; "anekabeach@dps.centrin.net.id" - ; "yogya@jayakartahotelsresorts.com" - ; "garudawisatajaya@indo.net.id" - ; "ketut@kbatur.com" - ; "bondps@bonansatours.com" - ; "witamgr@dps.centrin.net.id" - ; "dtedja@indosat.net.id" - ; "info@stpbali.ac.id" - ; "baliprestigeho@dps.centrin.net.id" - ; "pamilu@mas-travel.com" - ; "amandabl@indosat.net.id" - ; "marketing@csdwholiday.com" - ; "luha89@yahoo.com" - ; "indahsuluh2002@yahoo.com.sg" - ; "imz1991@yahoo.com" - ; "gus_war81@yahoo.com" - ; "kf034@indosat.net.id" - ; "800produkwil@posindonesia.co.id" - ; "kontak.synergi@yahoo.com" - ; "oekaoeka@yahoo.com" - ; "fitrianti@hotmail.com" - ; "meylina310@yahoo.com" - ; "h4ntoro@yahoo.com" - ; "novi_enbe@yahoo.com" - ; "dila_dewata@yahoo.co.id" - ; "tiena_asfary@yahoo.co.id" - ; "da_lawoffice@yahoo.com" - ; "rini@ncsecurities.biz" - ; "sudarnoto_hakim@yahoo.com" - ; "wastioke@yahoo.com" - ; "leebahri@yahoo.com." - ; "lia_kiara97@yahoo.com" - ; "rido@weddingku.com" - ; "b_astuti@telkomsel.co.id" ] in + [ + "adhidharma@denpasar.wasantara.net.id"; + "centralreservation@ramayanahotel.com"; + "apribadi@balimandira.com"; + "cdagenhart@ifc.org"; + "dana_supriyanto@interconti.com"; + "dos@novotelbali.com"; + "daniel@hotelpadma.com"; + "daniel@balibless.com"; + "djoko_p@jayakartahotelsresorts.com"; + "expdepot@indosat.net.id"; + "feby.adamsyah@idn.xerox.com"; + "christian_rizal@interconti.com"; + "singgih93@mailcity.com"; + "idonk_gebhoy@yahoo.com"; + "info@houseofbali.com"; + "kyohana@toureast.net"; + "sales@nusaduahotel.com"; + "jayakarta@mataram.wasantara.net.id"; + "mapindo@indo.net.id"; + "sm@ramayanahotel.com"; + "anekabeach@dps.centrin.net.id"; + "yogya@jayakartahotelsresorts.com"; + "garudawisatajaya@indo.net.id"; + "ketut@kbatur.com"; + "bondps@bonansatours.com"; + "witamgr@dps.centrin.net.id"; + "dtedja@indosat.net.id"; + "info@stpbali.ac.id"; + "baliprestigeho@dps.centrin.net.id"; + "pamilu@mas-travel.com"; + "amandabl@indosat.net.id"; + "marketing@csdwholiday.com"; + "luha89@yahoo.com"; + "indahsuluh2002@yahoo.com.sg"; + "imz1991@yahoo.com"; + "gus_war81@yahoo.com"; + "kf034@indosat.net.id"; + "800produkwil@posindonesia.co.id"; + "kontak.synergi@yahoo.com"; + "oekaoeka@yahoo.com"; + "fitrianti@hotmail.com"; + "meylina310@yahoo.com"; + "h4ntoro@yahoo.com"; + "novi_enbe@yahoo.com"; + "dila_dewata@yahoo.co.id"; + "tiena_asfary@yahoo.co.id"; + "da_lawoffice@yahoo.com"; + "rini@ncsecurities.biz"; + "sudarnoto_hakim@yahoo.com"; + "wastioke@yahoo.com"; + "leebahri@yahoo.com."; + "lia_kiara97@yahoo.com"; + "rido@weddingku.com"; + "b_astuti@telkomsel.co.id"; + ] + in let th0 = let open Part in let rec go0 idx = function | [] -> return () | key :: r -> - let* _ = insert (Rowex.key key) idx in - go0 (succ idx) r in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) + let* _ = insert (Rowex.key key) idx in + go0 (succ idx) r + in let* () = go0 0 elts in let* _ = insert (Rowex.key "garudawisata@indo.net.id") (-1) in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) let* v0 = find (Rowex.key "garudawisatajaya@indo.net.id") in let* v1 = find (Rowex.key "garudawisata@indo.net.id") in - Alcotest.(check int) "garudawisatajaya@indo.net.id" v0 22 ; - Alcotest.(check int) "garudawisata@indo.net.id" v1 (-1) ; + Alcotest.(check int) "garudawisatajaya@indo.net.id" v0 22; + Alcotest.(check int) "garudawisata@indo.net.id" v1 (-1); let rec go1 idx = function | [] -> return () | key :: r -> - let* v' = find (Rowex.key key) in - Alcotest.(check int) key idx v' ; - go1 (succ idx) r in - go1 0 elts in + let* v' = find (Rowex.key key) in + Alcotest.(check int) key idx v'; + go1 (succ idx) r + in + go1 0 elts + in match Part.run state th0 with | _not_closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let test07 = Alcotest.test_case "test07" `Quick @@ fun _file -> let path = Rresult.R.get_ok (Bos.OS.File.tmp "index-%s") in let elts = - [ "adhidharma@denpasar.wasantara.net.id" - ; "centralreservation@ramayanahotel.com" - ; "apribadi@balimandira.com" - ; "cdagenhart@ifc.org" - ; "dana_supriyanto@interconti.com" - ; "dos@novotelbali.com" - ; "daniel@hotelpadma.com" - ; "daniel@balibless.com" - ; "djoko_p@jayakartahotelsresorts.com" - ; "expdepot@indosat.net.id" - ; "feby.adamsyah@idn.xerox.com" - ; "christian_rizal@interconti.com" - ; "singgih93@mailcity.com" - ; "idonk_gebhoy@yahoo.com" - ; "info@houseofbali.com" - ; "kyohana@toureast.net" - ; "sales@nusaduahotel.com" - ; "jayakarta@mataram.wasantara.net.id" - ; "mapindo@indo.net.id" - ; "sm@ramayanahotel.com" - ; "anekabeach@dps.centrin.net.id" - ; "yogya@jayakartahotelsresorts.com" - ; "garudawisatajaya@indo.net.id" - ; "ketut@kbatur.com" - ; "bondps@bonansatours.com" - ; "witamgr@dps.centrin.net.id" - ; "dtedja@indosat.net.id" - ; "info@stpbali.ac.id" - ; "baliprestigeho@dps.centrin.net.id" - ; "pamilu@mas-travel.com" - ; "amandabl@indosat.net.id" - ; "marketing@csdwholiday.com" - ; "luha89@yahoo.com" - ; "indahsuluh2002@yahoo.com.sg" - ; "imz1991@yahoo.com" - ; "gus_war81@yahoo.com" - ; "kf034@indosat.net.id" - ; "800produkwil@posindonesia.co.id" - ; "kontak.synergi@yahoo.com" - ; "oekaoeka@yahoo.com" - ; "fitrianti@hotmail.com" - ; "meylina310@yahoo.com" - ; "h4ntoro@yahoo.com" - ; "novi_enbe@yahoo.com" - ; "dila_dewata@yahoo.co.id" - ; "tiena_asfary@yahoo.co.id" - ; "da_lawoffice@yahoo.com" - ; "rini@ncsecurities.biz" - ; "sudarnoto_hakim@yahoo.com" - ; "wastioke@yahoo.com" - ; "leebahri@yahoo.com." - ; "lia_kiara97@yahoo.com" - ; "rido@weddingku.com" - ; "b_astuti@telkomsel.co.id" - ; "garudawisata@indo.net.id" - ; "grfurniture@yahoo.com" - ; "gosyen2000@hotmail.com" - ; "hvhfood@indosat.net.id" - ; "hr@astonbali.com" - ; "hary@wibisono-family.com" - ; "fadlycak'p@yahoo.com" - ; "ida_sampurniah@telkomsel.co.id" - ; "muslim-pariwisata-bali@yahoogroups.com" - ; "harisnira@yahoo.com" - ; "sales@houseofbali.com" - ; "baim_ron@yahoo.com" - ; "ilhambali222@yahoo.com" - ; "bungjon@gmail.com" - ; "diar@bdg.centrin.net.id" - ; "elmienruge@hotmail.com" ] in + [ + "adhidharma@denpasar.wasantara.net.id"; + "centralreservation@ramayanahotel.com"; + "apribadi@balimandira.com"; + "cdagenhart@ifc.org"; + "dana_supriyanto@interconti.com"; + "dos@novotelbali.com"; + "daniel@hotelpadma.com"; + "daniel@balibless.com"; + "djoko_p@jayakartahotelsresorts.com"; + "expdepot@indosat.net.id"; + "feby.adamsyah@idn.xerox.com"; + "christian_rizal@interconti.com"; + "singgih93@mailcity.com"; + "idonk_gebhoy@yahoo.com"; + "info@houseofbali.com"; + "kyohana@toureast.net"; + "sales@nusaduahotel.com"; + "jayakarta@mataram.wasantara.net.id"; + "mapindo@indo.net.id"; + "sm@ramayanahotel.com"; + "anekabeach@dps.centrin.net.id"; + "yogya@jayakartahotelsresorts.com"; + "garudawisatajaya@indo.net.id"; + "ketut@kbatur.com"; + "bondps@bonansatours.com"; + "witamgr@dps.centrin.net.id"; + "dtedja@indosat.net.id"; + "info@stpbali.ac.id"; + "baliprestigeho@dps.centrin.net.id"; + "pamilu@mas-travel.com"; + "amandabl@indosat.net.id"; + "marketing@csdwholiday.com"; + "luha89@yahoo.com"; + "indahsuluh2002@yahoo.com.sg"; + "imz1991@yahoo.com"; + "gus_war81@yahoo.com"; + "kf034@indosat.net.id"; + "800produkwil@posindonesia.co.id"; + "kontak.synergi@yahoo.com"; + "oekaoeka@yahoo.com"; + "fitrianti@hotmail.com"; + "meylina310@yahoo.com"; + "h4ntoro@yahoo.com"; + "novi_enbe@yahoo.com"; + "dila_dewata@yahoo.co.id"; + "tiena_asfary@yahoo.co.id"; + "da_lawoffice@yahoo.com"; + "rini@ncsecurities.biz"; + "sudarnoto_hakim@yahoo.com"; + "wastioke@yahoo.com"; + "leebahri@yahoo.com."; + "lia_kiara97@yahoo.com"; + "rido@weddingku.com"; + "b_astuti@telkomsel.co.id"; + "garudawisata@indo.net.id"; + "grfurniture@yahoo.com"; + "gosyen2000@hotmail.com"; + "hvhfood@indosat.net.id"; + "hr@astonbali.com"; + "hary@wibisono-family.com"; + "fadlycak'p@yahoo.com"; + "ida_sampurniah@telkomsel.co.id"; + "muslim-pariwisata-bali@yahoogroups.com"; + "harisnira@yahoo.com"; + "sales@houseofbali.com"; + "baim_ron@yahoo.com"; + "ilhambali222@yahoo.com"; + "bungjon@gmail.com"; + "diar@bdg.centrin.net.id"; + "elmienruge@hotmail.com"; + ] + in let th0 = let open Part in let* res = create (Fpath.to_string path) in match res with | Error (`Msg err) -> Alcotest.failf "%s." err | Ok () -> - let* () = open_index writer ~path:(Fpath.to_string path) in - let rec go0 idx = function - | [] -> return () - | key :: r -> - let* _ = insert (Rowex.key key) idx in - go0 (succ idx) r in - let* () = go0 0 elts in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) - let* _ = insert (Rowex.key "galaxygarden2006@yahoo.com") (-1) in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) - let rec go1 idx = function - | [] -> close - | key :: r -> - let* v' = find (Rowex.key key) in - Alcotest.(check int) key v' idx ; - go1 (succ idx) r in - go1 0 elts in + let* () = open_index writer ~path:(Fpath.to_string path) in + let rec go0 idx = function + | [] -> return () + | key :: r -> + let* _ = insert (Rowex.key key) idx in + go0 (succ idx) r + in + let* () = go0 0 elts in + let* _ = insert (Rowex.key "galaxygarden2006@yahoo.com") (-1) in + let rec go1 idx = function + | [] -> close + | key :: r -> + let* v' = find (Rowex.key key) in + Alcotest.(check int) key v' idx; + go1 (succ idx) r + in + go1 0 elts + in match Part.(run closed th0) with | _closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let test08 = Alcotest.test_case "test08" `Quick @@ fun _path -> let path = Rresult.R.get_ok (Bos.OS.File.tmp "index-%s") in let elts = - [ "adhidharma@denpasar.wasantara.net.id" - ; "centralreservation@ramayanahotel.com" - ; "apribadi@balimandira.com" - ; "cdagenhart@ifc.org" - ; "dana_supriyanto@interconti.com" - ; "dos@novotelbali.com" - ; "daniel@hotelpadma.com" - ; "daniel@balibless.com" - ; "djoko_p@jayakartahotelsresorts.com" - ; "expdepot@indosat.net.id" - ; "feby.adamsyah@idn.xerox.com" - ; "christian_rizal@interconti.com" - ; "singgih93@mailcity.com" - ; "idonk_gebhoy@yahoo.com" - ; "info@houseofbali.com" - ; "kyohana@toureast.net" - ; "sales@nusaduahotel.com" - ; "jayakarta@mataram.wasantara.net.id" - ; "mapindo@indo.net.id" - ; "sm@ramayanahotel.com" - ; "anekabeach@dps.centrin.net.id" - ; "yogya@jayakartahotelsresorts.com" - ; "garudawisatajaya@indo.net.id" - ; "ketut@kbatur.com" - ; "bondps@bonansatours.com" - ; "witamgr@dps.centrin.net.id" - ; "dtedja@indosat.net.id" - ; "info@stpbali.ac.id" - ; "baliprestigeho@dps.centrin.net.id" - ; "pamilu@mas-travel.com" - ; "amandabl@indosat.net.id" - ; "marketing@csdwholiday.com" - ; "luha89@yahoo.com" - ; "indahsuluh2002@yahoo.com.sg" - ; "imz1991@yahoo.com" - ; "gus_war81@yahoo.com" - ; "kf034@indosat.net.id" - ; "800produkwil@posindonesia.co.id" - ; "kontak.synergi@yahoo.com" - ; "oekaoeka@yahoo.com" - ; "fitrianti@hotmail.com" - ; "meylina310@yahoo.com" - ; "h4ntoro@yahoo.com" - ; "novi_enbe@yahoo.com" - ; "dila_dewata@yahoo.co.id" - ; "tiena_asfary@yahoo.co.id" - ; "da_lawoffice@yahoo.com" - ; "rini@ncsecurities.biz" - ; "sudarnoto_hakim@yahoo.com" - ; "wastioke@yahoo.com" - ; "leebahri@yahoo.com." - ; "lia_kiara97@yahoo.com" - ; "rido@weddingku.com" - ; "b_astuti@telkomsel.co.id" - ; "garudawisata@indo.net.id" - ; "grfurniture@yahoo.com" - ; "gosyen2000@hotmail.com" - ; "hvhfood@indosat.net.id" - ; "hr@astonbali.com" - ; "hary@wibisono-family.com" - ; "fadlycak'p@yahoo.com" - ; "ida_sampurniah@telkomsel.co.id" - ; "muslim-pariwisata-bali@yahoogroups.com" - ; "harisnira@yahoo.com" - ; "sales@houseofbali.com" - ; "baim_ron@yahoo.com" - ; "ilhambali222@yahoo.com" - ; "bungjon@gmail.com" - ; "diar@bdg.centrin.net.id" - ; "elmienruge@hotmail.com" - ; "galaxygarden2006@yahoo.com" - ; "gorisata@indosat.net.id" - ; "maulitasarihani@yahoo.com" - ; "hamiluddakwah@gmail.com.au" - ; "bounty@indo.net.id," - ; "michi@ritzcarlton-bali.com," - ; "orridor@dps.centrin.net.id," - ; "ngumina@hotmail.com," - ; "made@mas-travel.com," - ; "evi@mas-travel.com," - ; "wibawa@mas-travel.com," - ; "saihubaly@yahoo.co.id," - ; "swa_candra@yahoo.com," - ; "picapica@denpasar.wasantara.net.id," - ; "griyasantrian@santrian.com," - ; "yuni6671@gmail.com," - ; "phbalichef@indo.net.id," - ; "vendra@keratonjimbaranresort.com," - ; "bali@pansea.com," - ; "sales@legianbeachbali.com," - ; "purchasing@meliabali.com," - ; "swacandra@telkom.net," - ; "lysbeth@paintballbali.com," - ; "trvlindo@upg.mega.net.id," - ; "lim_thefaith@yahoo.com," - ; "uungtb@yahoo.com.au," - ; "vivaldil307@hotmail.com," - ; "iodakon@yahoo.co.id," - ; "reservation@pendawahotel.com," - ; "ptbon@dps.centrin.net.id," - ; "ptlamak@indosat.net.id," - ; "sculpt@indo.net.id," - ; "memedi-gwkbali@dps.centrin.net.id," - ; "info@leisuredream.com," - ; "indra_wijaya@hero.co.id," - ; "ndbconvex@bagus-discovery.com," - ; "Endro@bma-merdeka.com," - ; "wsuardana@indosat.net.id," - ; "bali@esmirada.com," - ; "BAL.Purchasing@fourseasons.com," - ; "ruby@marthatilaar-spa.com," - ; "villaseminyak@eksadata.com," - ; "sariati@sanurbeach.aerowisata.com," - ; "info@jenggala-bali.com," - ; "chef@nusaduahotel.com," - ; "info@balicateringcompany.com," - ; "moka@dps.mega.net.id," - ; "zsa@eyeview.info," - ; "winarios@indosat.net.id," - ; "project@balihai-rsort.com," - ; "vivi@kopibali.com," - ; "peninsulabali@dps.centrin.net.id," - ; "ust.july@mas-travel.com," - ; "ubud@pansea.com," - ; "ustad_july@yahoo.com," - ; "thebarbali@hotmail.com," - ; "trustbali@balidream.com," - ; "teraoka@his-bali.com," - ; "candle@dps.centrin.net.id," - ; "waterbom@denpasar.wasantara.net.id," - ; "ib.suparsa@yahoo.com," - ; "budhipra@nesiancea.com," - ; "info@kindvillabintang.com," - ; "pch@novotelbali.com," - ; "parigata@indosat.net.id," - ; "mail@grandmirage.com," - ; "ananda_resort@hotmail.com," - ; "info@risatabali.com," - ; "gwkbali@indosat.net.id," - ; "rai@gosharestaurant.com," - ; "santika@santikabali.com," - ; "sahidbl@indosat.net.id," - ; "tubanrestaurant@yahoo.com," - ; "sales@thejimbaranbali.com," - ; "info@thejimbaranbali.com," - ; "sari@bubbagumpbali.com," - ; "Winnie@grandlingga.com," - ; "juaidy_asia@yahoo.com," - ; "vicmgr@i-xplore.com," - ; "langka@theclubstore.co.id," - ; "lilakresna@ConradBali.com," - ; "wayan.atmaja@luxurycollecton.com," - ; "Cisabali@indo.net.id," - ; "garrant@indo.net.id," - ; "owenwister@yahoo.com," - ; "tiara@dps.mega.net.id," - ; "info@nzmuslim.net," - ; "yuanito.kurniawan@sea.ccamatil.com," - ; "pitamaha@indosat.net.id," - ; "yunani@theclubstore.co.id," - ; "deklis@hotmail.com," - ; "cianjur@indo.net.id," - ; "mahajayatower@hotmail.com," - ; "endra@centrin.net.id," - ; "wayan.dirayana@fourseasons.com," - ; "balinaga@dps.centrin.net.id," - ; "tiaradwt@dps.centrin.net.id," - ; "candrator@hotmail.com," - ; "altaraspa@yahoo.com," - ; "fani@clubbali.com," - ; "Itudm@dps.centrin.net.id," - ; "baliratuspa@biz.net.id," - ; "kawasspa@indosat.net.id," - ; "hatoe7@yahoo.co.jp," - ; "sales@mimpi.com," - ; "theroyal@indosat.net.id," - ; "chakra_92@yahoo.com," - ; "u_dmtdps@sosro.com," - ; "januar@citramedia.net," - ; "januar@balivisioncomp.com," - ; "admin@balivisioncomp.com," - ; "ansri@dps.mega.net.id," - ; "info@rijasaresort-villas.com," - ; "sales@komaneka.com," - ; "multigun@indo.net.id," - ; "ishwari@bagus-discovery.com," - ; "utami@bali-exoticwedding.com," - ; "putra_wirata@hotmail.com," - ; "arte@dps.centrin.net.id," - ; "hamiludd2kwah@yahoo.com.au," - ; "btu_cipluk@yahoo.com," - ; "agus@indo-journey.com," - ; "agus.winarko@gmail.com," - ; "agus.amirudin@wilmar.co.id," - ; "adamsilver@lycos.com," - ; "yayasanlaroyba@yahoo.co.id," - ; "luminaABC@hotmail.com," - ; "umasapna@coconuthomes.com," - ; "udsupradinasty@yahoo.co.id," - ; "ticketing@bagus-discovery.com," - ; "tejo@pttropical.co.id," - ; "syamklw@yahoo.com," - ; "sutiarso21@yahoo.com," - ; "silvia_maniz@yahoo.com," - ; "yenny_kurniawaty@telkomsel.co.id," - ; "lega@kramatdjatigroup.com," - ; "stadiumcafe@indonet.id," - ; "agencyfreestylebali@yahoo.com," - ; "yayaqdarma@yahoo.co.id," - ; "hanafiid@yahoo.com," - ; "ricky_dvt@yahoo.co.id," - ; "teuku_umar@binus-centre.com," - ; "flp_bali@yahoo.com," - ; "andy@ritzcarlton-bali.com," - ; "bapakbakery@dps.centrin.net.id," - ; "siddiq@teacher.com," - ; "clipper@indo.net.id," - ; "puricendana@yahoo.com," - ; "info@ripcurlschoolsurf.com," - ; "sales@ramabeachhotel.com," - ; "healing@indosat.net.id," - ; "djinaldi@yahoo.co.uk," - ; "rotary.bali.kuta@gmail.com," - ; "dadang@ma-joly.com," - ; "takenoko_bali@yahoo.co.id," - ; "hrd@novotelbali.com," - ; "purwa@kcb-tours.com," - ; "anggie.gendut@england.com," - ; "novyog@indo.net.id," - ; "reservation@meliabali.com," - ; "sales@meliabali.com," - ; "info@rkeconsulting.com," - ; "andisetiaji@abacus-ind.co.id," - ; "sales.corp@swissgrandbali.com," - ; "karsana.wirajaya@trac.astra.co.id," - ; "muliatr@indosat.net.id," - ; "nita@surfer-girl.com," - ; "diah.permana@bagus-discovery.com," - ; "purwabali@yahoo.com," - ; "oly@islandconcpets.com," - ; "info@islandconcepts.com," - ; "gag@indo.net.id," - ; "gkumala@indosat.net.id," - ; "thegardeniavillas@meliabali.com," - ; "purchasing.mgr@thelegianbali.com," - ; "info@paradisebaliholidays.com," - ; "agus.winarko@bagus-discovery.com," - ; "cozytimes26@yahoo.com," - ; "info@papua-adventures.com," - ; "lokasaribali@hotmail.com," - ; "wahana@baliforyou.com," - ; "Stephen@victuslife.com," - ; "operations@atlasbalitours.com," - ; "balicoffeeshop@hotmail.com," - ; "mayakutacentre@telkom.net," - ; "rikmawan@dps.centrin.net.id," - ; "ndbt@bagus-discovery.com," - ; "info@indographs.com," - ; "aridwan_sgb@yahoo.com," - ; "bali@atmosphere.co.id," - ; "plmgrd@indosat.net.id," - ; "balibless@padmaubud.biz," - ; "baliaura@yahoo.com," - ; "andalan@bali.net," - ; "dmandiri@indo.net.id," - ; "pernadi@rad.net.id," - ; "Tabetha@BeyondMenus.com," - ; "adityafood@yahoo.com," - ; "sarana_com@yahoo.com," - ; "pasadena@chek.com," ] in + [ + "adhidharma@denpasar.wasantara.net.id"; + "centralreservation@ramayanahotel.com"; + "apribadi@balimandira.com"; + "cdagenhart@ifc.org"; + "dana_supriyanto@interconti.com"; + "dos@novotelbali.com"; + "daniel@hotelpadma.com"; + "daniel@balibless.com"; + "djoko_p@jayakartahotelsresorts.com"; + "expdepot@indosat.net.id"; + "feby.adamsyah@idn.xerox.com"; + "christian_rizal@interconti.com"; + "singgih93@mailcity.com"; + "idonk_gebhoy@yahoo.com"; + "info@houseofbali.com"; + "kyohana@toureast.net"; + "sales@nusaduahotel.com"; + "jayakarta@mataram.wasantara.net.id"; + "mapindo@indo.net.id"; + "sm@ramayanahotel.com"; + "anekabeach@dps.centrin.net.id"; + "yogya@jayakartahotelsresorts.com"; + "garudawisatajaya@indo.net.id"; + "ketut@kbatur.com"; + "bondps@bonansatours.com"; + "witamgr@dps.centrin.net.id"; + "dtedja@indosat.net.id"; + "info@stpbali.ac.id"; + "baliprestigeho@dps.centrin.net.id"; + "pamilu@mas-travel.com"; + "amandabl@indosat.net.id"; + "marketing@csdwholiday.com"; + "luha89@yahoo.com"; + "indahsuluh2002@yahoo.com.sg"; + "imz1991@yahoo.com"; + "gus_war81@yahoo.com"; + "kf034@indosat.net.id"; + "800produkwil@posindonesia.co.id"; + "kontak.synergi@yahoo.com"; + "oekaoeka@yahoo.com"; + "fitrianti@hotmail.com"; + "meylina310@yahoo.com"; + "h4ntoro@yahoo.com"; + "novi_enbe@yahoo.com"; + "dila_dewata@yahoo.co.id"; + "tiena_asfary@yahoo.co.id"; + "da_lawoffice@yahoo.com"; + "rini@ncsecurities.biz"; + "sudarnoto_hakim@yahoo.com"; + "wastioke@yahoo.com"; + "leebahri@yahoo.com."; + "lia_kiara97@yahoo.com"; + "rido@weddingku.com"; + "b_astuti@telkomsel.co.id"; + "garudawisata@indo.net.id"; + "grfurniture@yahoo.com"; + "gosyen2000@hotmail.com"; + "hvhfood@indosat.net.id"; + "hr@astonbali.com"; + "hary@wibisono-family.com"; + "fadlycak'p@yahoo.com"; + "ida_sampurniah@telkomsel.co.id"; + "muslim-pariwisata-bali@yahoogroups.com"; + "harisnira@yahoo.com"; + "sales@houseofbali.com"; + "baim_ron@yahoo.com"; + "ilhambali222@yahoo.com"; + "bungjon@gmail.com"; + "diar@bdg.centrin.net.id"; + "elmienruge@hotmail.com"; + "galaxygarden2006@yahoo.com"; + "gorisata@indosat.net.id"; + "maulitasarihani@yahoo.com"; + "hamiluddakwah@gmail.com.au"; + "bounty@indo.net.id,"; + "michi@ritzcarlton-bali.com,"; + "orridor@dps.centrin.net.id,"; + "ngumina@hotmail.com,"; + "made@mas-travel.com,"; + "evi@mas-travel.com,"; + "wibawa@mas-travel.com,"; + "saihubaly@yahoo.co.id,"; + "swa_candra@yahoo.com,"; + "picapica@denpasar.wasantara.net.id,"; + "griyasantrian@santrian.com,"; + "yuni6671@gmail.com,"; + "phbalichef@indo.net.id,"; + "vendra@keratonjimbaranresort.com,"; + "bali@pansea.com,"; + "sales@legianbeachbali.com,"; + "purchasing@meliabali.com,"; + "swacandra@telkom.net,"; + "lysbeth@paintballbali.com,"; + "trvlindo@upg.mega.net.id,"; + "lim_thefaith@yahoo.com,"; + "uungtb@yahoo.com.au,"; + "vivaldil307@hotmail.com,"; + "iodakon@yahoo.co.id,"; + "reservation@pendawahotel.com,"; + "ptbon@dps.centrin.net.id,"; + "ptlamak@indosat.net.id,"; + "sculpt@indo.net.id,"; + "memedi-gwkbali@dps.centrin.net.id,"; + "info@leisuredream.com,"; + "indra_wijaya@hero.co.id,"; + "ndbconvex@bagus-discovery.com,"; + "Endro@bma-merdeka.com,"; + "wsuardana@indosat.net.id,"; + "bali@esmirada.com,"; + "BAL.Purchasing@fourseasons.com,"; + "ruby@marthatilaar-spa.com,"; + "villaseminyak@eksadata.com,"; + "sariati@sanurbeach.aerowisata.com,"; + "info@jenggala-bali.com,"; + "chef@nusaduahotel.com,"; + "info@balicateringcompany.com,"; + "moka@dps.mega.net.id,"; + "zsa@eyeview.info,"; + "winarios@indosat.net.id,"; + "project@balihai-rsort.com,"; + "vivi@kopibali.com,"; + "peninsulabali@dps.centrin.net.id,"; + "ust.july@mas-travel.com,"; + "ubud@pansea.com,"; + "ustad_july@yahoo.com,"; + "thebarbali@hotmail.com,"; + "trustbali@balidream.com,"; + "teraoka@his-bali.com,"; + "candle@dps.centrin.net.id,"; + "waterbom@denpasar.wasantara.net.id,"; + "ib.suparsa@yahoo.com,"; + "budhipra@nesiancea.com,"; + "info@kindvillabintang.com,"; + "pch@novotelbali.com,"; + "parigata@indosat.net.id,"; + "mail@grandmirage.com,"; + "ananda_resort@hotmail.com,"; + "info@risatabali.com,"; + "gwkbali@indosat.net.id,"; + "rai@gosharestaurant.com,"; + "santika@santikabali.com,"; + "sahidbl@indosat.net.id,"; + "tubanrestaurant@yahoo.com,"; + "sales@thejimbaranbali.com,"; + "info@thejimbaranbali.com,"; + "sari@bubbagumpbali.com,"; + "Winnie@grandlingga.com,"; + "juaidy_asia@yahoo.com,"; + "vicmgr@i-xplore.com,"; + "langka@theclubstore.co.id,"; + "lilakresna@ConradBali.com,"; + "wayan.atmaja@luxurycollecton.com,"; + "Cisabali@indo.net.id,"; + "garrant@indo.net.id,"; + "owenwister@yahoo.com,"; + "tiara@dps.mega.net.id,"; + "info@nzmuslim.net,"; + "yuanito.kurniawan@sea.ccamatil.com,"; + "pitamaha@indosat.net.id,"; + "yunani@theclubstore.co.id,"; + "deklis@hotmail.com,"; + "cianjur@indo.net.id,"; + "mahajayatower@hotmail.com,"; + "endra@centrin.net.id,"; + "wayan.dirayana@fourseasons.com,"; + "balinaga@dps.centrin.net.id,"; + "tiaradwt@dps.centrin.net.id,"; + "candrator@hotmail.com,"; + "altaraspa@yahoo.com,"; + "fani@clubbali.com,"; + "Itudm@dps.centrin.net.id,"; + "baliratuspa@biz.net.id,"; + "kawasspa@indosat.net.id,"; + "hatoe7@yahoo.co.jp,"; + "sales@mimpi.com,"; + "theroyal@indosat.net.id,"; + "chakra_92@yahoo.com,"; + "u_dmtdps@sosro.com,"; + "januar@citramedia.net,"; + "januar@balivisioncomp.com,"; + "admin@balivisioncomp.com,"; + "ansri@dps.mega.net.id,"; + "info@rijasaresort-villas.com,"; + "sales@komaneka.com,"; + "multigun@indo.net.id,"; + "ishwari@bagus-discovery.com,"; + "utami@bali-exoticwedding.com,"; + "putra_wirata@hotmail.com,"; + "arte@dps.centrin.net.id,"; + "hamiludd2kwah@yahoo.com.au,"; + "btu_cipluk@yahoo.com,"; + "agus@indo-journey.com,"; + "agus.winarko@gmail.com,"; + "agus.amirudin@wilmar.co.id,"; + "adamsilver@lycos.com,"; + "yayasanlaroyba@yahoo.co.id,"; + "luminaABC@hotmail.com,"; + "umasapna@coconuthomes.com,"; + "udsupradinasty@yahoo.co.id,"; + "ticketing@bagus-discovery.com,"; + "tejo@pttropical.co.id,"; + "syamklw@yahoo.com,"; + "sutiarso21@yahoo.com,"; + "silvia_maniz@yahoo.com,"; + "yenny_kurniawaty@telkomsel.co.id,"; + "lega@kramatdjatigroup.com,"; + "stadiumcafe@indonet.id,"; + "agencyfreestylebali@yahoo.com,"; + "yayaqdarma@yahoo.co.id,"; + "hanafiid@yahoo.com,"; + "ricky_dvt@yahoo.co.id,"; + "teuku_umar@binus-centre.com,"; + "flp_bali@yahoo.com,"; + "andy@ritzcarlton-bali.com,"; + "bapakbakery@dps.centrin.net.id,"; + "siddiq@teacher.com,"; + "clipper@indo.net.id,"; + "puricendana@yahoo.com,"; + "info@ripcurlschoolsurf.com,"; + "sales@ramabeachhotel.com,"; + "healing@indosat.net.id,"; + "djinaldi@yahoo.co.uk,"; + "rotary.bali.kuta@gmail.com,"; + "dadang@ma-joly.com,"; + "takenoko_bali@yahoo.co.id,"; + "hrd@novotelbali.com,"; + "purwa@kcb-tours.com,"; + "anggie.gendut@england.com,"; + "novyog@indo.net.id,"; + "reservation@meliabali.com,"; + "sales@meliabali.com,"; + "info@rkeconsulting.com,"; + "andisetiaji@abacus-ind.co.id,"; + "sales.corp@swissgrandbali.com,"; + "karsana.wirajaya@trac.astra.co.id,"; + "muliatr@indosat.net.id,"; + "nita@surfer-girl.com,"; + "diah.permana@bagus-discovery.com,"; + "purwabali@yahoo.com,"; + "oly@islandconcpets.com,"; + "info@islandconcepts.com,"; + "gag@indo.net.id,"; + "gkumala@indosat.net.id,"; + "thegardeniavillas@meliabali.com,"; + "purchasing.mgr@thelegianbali.com,"; + "info@paradisebaliholidays.com,"; + "agus.winarko@bagus-discovery.com,"; + "cozytimes26@yahoo.com,"; + "info@papua-adventures.com,"; + "lokasaribali@hotmail.com,"; + "wahana@baliforyou.com,"; + "Stephen@victuslife.com,"; + "operations@atlasbalitours.com,"; + "balicoffeeshop@hotmail.com,"; + "mayakutacentre@telkom.net,"; + "rikmawan@dps.centrin.net.id,"; + "ndbt@bagus-discovery.com,"; + "info@indographs.com,"; + "aridwan_sgb@yahoo.com,"; + "bali@atmosphere.co.id,"; + "plmgrd@indosat.net.id,"; + "balibless@padmaubud.biz,"; + "baliaura@yahoo.com,"; + "andalan@bali.net,"; + "dmandiri@indo.net.id,"; + "pernadi@rad.net.id,"; + "Tabetha@BeyondMenus.com,"; + "adityafood@yahoo.com,"; + "sarana_com@yahoo.com,"; + "pasadena@chek.com,"; + ] + in let th0 = let open Part in let* res = create (Fpath.to_string path) in match res with | Error (`Msg err) -> Alcotest.failf "%s." err | Ok () -> - let* () = open_index writer ~path:(Fpath.to_string path) in - let rec go0 idx = function - | [] -> return () - | key :: r -> - let* _ = insert (Rowex.key key) idx in - go0 (succ idx) r in - let* () = go0 0 elts in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) - let* _ = insert (Rowex.key "sales@pica-pica.com,") (-1) in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) - let* v' = find (Rowex.key "sales@pica-pica.com,") in - Alcotest.(check int) "sales@pica-pica.com," v' (-1) ; - let rec go1 idx = function - | [] -> close - | key :: r -> - let* v' = find (Rowex.key key) in - Alcotest.(check int) key v' idx ; - go1 (succ idx) r in - go1 0 elts in + let* () = open_index writer ~path:(Fpath.to_string path) in + let rec go0 idx = function + | [] -> return () + | key :: r -> + let* _ = insert (Rowex.key key) idx in + go0 (succ idx) r + in + let* () = go0 0 elts in + let* _ = insert (Rowex.key "sales@pica-pica.com,") (-1) in + let* v' = find (Rowex.key "sales@pica-pica.com,") in + Alcotest.(check int) "sales@pica-pica.com," v' (-1); + let rec go1 idx = function + | [] -> close + | key :: r -> + let* v' = find (Rowex.key key) in + Alcotest.(check int) key v' idx; + go1 (succ idx) r + in + go1 0 elts + in match Part.(run closed th0) with | _closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let test09 = Alcotest.test_case "test09" `Quick @@ fun _path -> let path = Rresult.R.get_ok (Bos.OS.File.tmp "index-%s") in let elts = - [ "adhidharma@denpasar.wasantara.net.id" - ; "centralreservation@ramayanahotel.com" - ; "apribadi@balimandira.com" - ; "cdagenhart@ifc.org" - ; "dana_supriyanto@interconti.com" - ; "dos@novotelbali.com" - ; "daniel@hotelpadma.com" - ; "daniel@balibless.com" - ; "djoko_p@jayakartahotelsresorts.com" - ; "expdepot@indosat.net.id" - ; "feby.adamsyah@idn.xerox.com" - ; "christian_rizal@interconti.com" - ; "singgih93@mailcity.com" - ; "idonk_gebhoy@yahoo.com" - ; "info@houseofbali.com" - ; "kyohana@toureast.net" - ; "sales@nusaduahotel.com" - ; "jayakarta@mataram.wasantara.net.id" - ; "mapindo@indo.net.id" - ; "sm@ramayanahotel.com" - ; "anekabeach@dps.centrin.net.id" - ; "yogya@jayakartahotelsresorts.com" - ; "garudawisatajaya@indo.net.id" - ; "ketut@kbatur.com" - ; "bondps@bonansatours.com" - ; "witamgr@dps.centrin.net.id" - ; "dtedja@indosat.net.id" - ; "info@stpbali.ac.id" - ; "baliprestigeho@dps.centrin.net.id" - ; "pamilu@mas-travel.com" - ; "amandabl@indosat.net.id" - ; "marketing@csdwholiday.com" - ; "luha89@yahoo.com" - ; "indahsuluh2002@yahoo.com.sg" - ; "imz1991@yahoo.com" - ; "gus_war81@yahoo.com" - ; "kf034@indosat.net.id" - ; "800produkwil@posindonesia.co.id" - ; "kontak.synergi@yahoo.com" - ; "oekaoeka@yahoo.com" - ; "fitrianti@hotmail.com" - ; "meylina310@yahoo.com" - ; "h4ntoro@yahoo.com" - ; "novi_enbe@yahoo.com" - ; "dila_dewata@yahoo.co.id" - ; "tiena_asfary@yahoo.co.id" - ; "da_lawoffice@yahoo.com" - ; "rini@ncsecurities.biz" - ; "sudarnoto_hakim@yahoo.com" - ; "wastioke@yahoo.com" - ; "leebahri@yahoo.com." - ; "lia_kiara97@yahoo.com" - ; "rido@weddingku.com" - ; "b_astuti@telkomsel.co.id" - ; "garudawisata@indo.net.id" - ; "grfurniture@yahoo.com" - ; "gosyen2000@hotmail.com" - ; "hvhfood@indosat.net.id" - ; "hr@astonbali.com" - ; "hary@wibisono-family.com" - ; "fadlycak'p@yahoo.com" - ; "ida_sampurniah@telkomsel.co.id" - ; "muslim-pariwisata-bali@yahoogroups.com" - ; "harisnira@yahoo.com" - ; "sales@houseofbali.com" - ; "baim_ron@yahoo.com" - ; "ilhambali222@yahoo.com" - ; "bungjon@gmail.com" - ; "diar@bdg.centrin.net.id" - ; "elmienruge@hotmail.com" - ; "galaxygarden2006@yahoo.com" - ; "gorisata@indosat.net.id" - ; "maulitasarihani@yahoo.com" - ; "hamiluddakwah@gmail.com.au" - ; "bounty@indo.net.id," - ; "michi@ritzcarlton-bali.com," - ; "orridor@dps.centrin.net.id," - ; "ngumina@hotmail.com," - ; "made@mas-travel.com," - ; "evi@mas-travel.com," - ; "wibawa@mas-travel.com," - ; "saihubaly@yahoo.co.id," - ; "swa_candra@yahoo.com," - ; "picapica@denpasar.wasantara.net.id," - ; "griyasantrian@santrian.com," - ; "yuni6671@gmail.com," - ; "phbalichef@indo.net.id," - ; "vendra@keratonjimbaranresort.com," - ; "bali@pansea.com," - ; "sales@legianbeachbali.com," - ; "purchasing@meliabali.com," - ; "swacandra@telkom.net," - ; "lysbeth@paintballbali.com," - ; "trvlindo@upg.mega.net.id," - ; "lim_thefaith@yahoo.com," - ; "uungtb@yahoo.com.au," - ; "vivaldil307@hotmail.com," - ; "iodakon@yahoo.co.id," - ; "reservation@pendawahotel.com," - ; "ptbon@dps.centrin.net.id," - ; "ptlamak@indosat.net.id," - ; "sculpt@indo.net.id," - ; "memedi-gwkbali@dps.centrin.net.id," - ; "info@leisuredream.com," - ; "indra_wijaya@hero.co.id," - ; "ndbconvex@bagus-discovery.com," - ; "Endro@bma-merdeka.com," - ; "wsuardana@indosat.net.id," - ; "bali@esmirada.com," - ; "BAL.Purchasing@fourseasons.com," - ; "ruby@marthatilaar-spa.com," - ; "villaseminyak@eksadata.com," - ; "sariati@sanurbeach.aerowisata.com," - ; "info@jenggala-bali.com," - ; "chef@nusaduahotel.com," - ; "info@balicateringcompany.com," - ; "moka@dps.mega.net.id," - ; "zsa@eyeview.info," - ; "winarios@indosat.net.id," - ; "project@balihai-rsort.com," - ; "vivi@kopibali.com," - ; "peninsulabali@dps.centrin.net.id," - ; "ust.july@mas-travel.com," - ; "ubud@pansea.com," - ; "ustad_july@yahoo.com," - ; "thebarbali@hotmail.com," - ; "trustbali@balidream.com," - ; "teraoka@his-bali.com," - ; "candle@dps.centrin.net.id," - ; "waterbom@denpasar.wasantara.net.id," - ; "ib.suparsa@yahoo.com," - ; "budhipra@nesiancea.com," - ; "info@kindvillabintang.com," - ; "pch@novotelbali.com," - ; "parigata@indosat.net.id," - ; "mail@grandmirage.com," - ; "ananda_resort@hotmail.com," - ; "info@risatabali.com," - ; "gwkbali@indosat.net.id," - ; "rai@gosharestaurant.com," - ; "santika@santikabali.com," - ; "sahidbl@indosat.net.id," - ; "tubanrestaurant@yahoo.com," - ; "sales@thejimbaranbali.com," - ; "info@thejimbaranbali.com," - ; "sari@bubbagumpbali.com," - ; "Winnie@grandlingga.com," - ; "juaidy_asia@yahoo.com," - ; "vicmgr@i-xplore.com," - ; "langka@theclubstore.co.id," - ; "lilakresna@ConradBali.com," - ; "wayan.atmaja@luxurycollecton.com," - ; "Cisabali@indo.net.id," - ; "garrant@indo.net.id," - ; "owenwister@yahoo.com," - ; "tiara@dps.mega.net.id," - ; "info@nzmuslim.net," - ; "yuanito.kurniawan@sea.ccamatil.com," - ; "pitamaha@indosat.net.id," - ; "yunani@theclubstore.co.id," - ; "deklis@hotmail.com," - ; "cianjur@indo.net.id," - ; "mahajayatower@hotmail.com," - ; "endra@centrin.net.id," - ; "wayan.dirayana@fourseasons.com," - ; "balinaga@dps.centrin.net.id," - ; "tiaradwt@dps.centrin.net.id," - ; "candrator@hotmail.com," - ; "altaraspa@yahoo.com," - ; "fani@clubbali.com," - ; "Itudm@dps.centrin.net.id," - ; "baliratuspa@biz.net.id," - ; "kawasspa@indosat.net.id," - ; "hatoe7@yahoo.co.jp," - ; "sales@mimpi.com," - ; "theroyal@indosat.net.id," - ; "chakra_92@yahoo.com," - ; "u_dmtdps@sosro.com," - ; "januar@citramedia.net," - ; "januar@balivisioncomp.com," - ; "admin@balivisioncomp.com," - ; "ansri@dps.mega.net.id," - ; "info@rijasaresort-villas.com," - ; "sales@komaneka.com," - ; "multigun@indo.net.id," - ; "ishwari@bagus-discovery.com," - ; "utami@bali-exoticwedding.com," - ; "putra_wirata@hotmail.com," - ; "arte@dps.centrin.net.id," - ; "hamiludd2kwah@yahoo.com.au," - ; "btu_cipluk@yahoo.com," - ; "agus@indo-journey.com," - ; "agus.winarko@gmail.com," - ; "agus.amirudin@wilmar.co.id," - ; "adamsilver@lycos.com," - ; "yayasanlaroyba@yahoo.co.id," - ; "luminaABC@hotmail.com," - ; "umasapna@coconuthomes.com," - ; "udsupradinasty@yahoo.co.id," - ; "ticketing@bagus-discovery.com," - ; "tejo@pttropical.co.id," - ; "syamklw@yahoo.com," - ; "sutiarso21@yahoo.com," - ; "silvia_maniz@yahoo.com," - ; "yenny_kurniawaty@telkomsel.co.id," - ; "lega@kramatdjatigroup.com," - ; "stadiumcafe@indonet.id," - ; "agencyfreestylebali@yahoo.com," - ; "yayaqdarma@yahoo.co.id," - ; "hanafiid@yahoo.com," - ; "ricky_dvt@yahoo.co.id," - ; "teuku_umar@binus-centre.com," - ; "flp_bali@yahoo.com," - ; "andy@ritzcarlton-bali.com," - ; "bapakbakery@dps.centrin.net.id," - ; "siddiq@teacher.com," - ; "clipper@indo.net.id," - ; "puricendana@yahoo.com," - ; "info@ripcurlschoolsurf.com," - ; "sales@ramabeachhotel.com," - ; "healing@indosat.net.id," - ; "djinaldi@yahoo.co.uk," - ; "rotary.bali.kuta@gmail.com," - ; "dadang@ma-joly.com," - ; "takenoko_bali@yahoo.co.id," - ; "hrd@novotelbali.com," - ; "purwa@kcb-tours.com," - ; "anggie.gendut@england.com," - ; "novyog@indo.net.id," - ; "reservation@meliabali.com," - ; "sales@meliabali.com," - ; "info@rkeconsulting.com," - ; "andisetiaji@abacus-ind.co.id," - ; "sales.corp@swissgrandbali.com," - ; "karsana.wirajaya@trac.astra.co.id," - ; "muliatr@indosat.net.id," - ; "nita@surfer-girl.com," - ; "diah.permana@bagus-discovery.com," - ; "purwabali@yahoo.com," - ; "oly@islandconcpets.com," - ; "info@islandconcepts.com," - ; "gag@indo.net.id," - ; "gkumala@indosat.net.id," - ; "thegardeniavillas@meliabali.com," - ; "purchasing.mgr@thelegianbali.com," - ; "info@paradisebaliholidays.com," - ; "agus.winarko@bagus-discovery.com," - ; "cozytimes26@yahoo.com," - ; "info@papua-adventures.com," - ; "lokasaribali@hotmail.com," - ; "wahana@baliforyou.com," - ; "Stephen@victuslife.com," - ; "operations@atlasbalitours.com," - ; "balicoffeeshop@hotmail.com," - ; "mayakutacentre@telkom.net," - ; "rikmawan@dps.centrin.net.id," - ; "ndbt@bagus-discovery.com," - ; "info@indographs.com," - ; "aridwan_sgb@yahoo.com," - ; "bali@atmosphere.co.id," - ; "plmgrd@indosat.net.id," - ; "balibless@padmaubud.biz," - ; "baliaura@yahoo.com," - ; "andalan@bali.net," - ; "dmandiri@indo.net.id," - ; "pernadi@rad.net.id," - ; "Tabetha@BeyondMenus.com," - ; "adityafood@yahoo.com," - ; "sarana_com@yahoo.com," - ; "pasadena@chek.com," - ; "sales@pica-pica.com," - ; "menara_fbi@hotmail.com," - ; "home_treasure@hotmail.com," - ; "aamsalim@dps.centrin.net.id," - ; "shell_enoproduction@yahoo.com," - ; "geckoleather@hotmail.com," - ; "milagro_bali@hotmail.com," - ; "gemini19id@yahoo.com," - ; "karyacargo@dps.centrin.net.id," - ; "darabali@indo.net.id," - ; "padiprada@hotmail.com," - ; "vijowiz@yahoo.com," - ; "cafejimbaran@mekarsaribali.com," - ; "isnamks@yahoo.com," - ; "sales@allseasonslegian.com," - ; "chitra@cangguclub.com," - ; "cheriaM@xl.co.id," - ; "geo-trek@dps.centrin.net.id," - ; "sales@balipasadena.com," - ; "sales@villahening.com," - ; "fc@novotelbali.com," - ; "maolbing83@yahoo.co.id," - ; "info@dimensitropika.com," - ; "news@tabloidpiknik.com," - ; "mediacentre@bali-tourism.com," - ; "bioland-bali@telkom.net," - ; "glf-bali@indo.net.id," - ; "info@asiabali.com," - ; "takanit@yahoo.com," - ; "jamal@hrbc-bali.co.id," - ; "naniek@alilahotels.com," - ; "ndbtdps@dps.mega.net.id," - ; "mbcbali_jaka@yahoo.com," - ; "masnyonya@telkom.net," - ; "merrystravel@dps.centrin.net.id," - ; "mail@baliintermedia.com," - ; "mitrakridamandiri@hotmail.com," - ; "kartikaplz@denpasar.wasantara.net.id," - ; "oedps@indosat.net.id," - ; "jalirest@indosat.net.id," - ; "jenni_hartatik@interconti.com," - ; "info@alamkulkul.com," - ; "info@aggacitta.com," - ; "info@jasatours.com," - ; "iskandar.Liemena@idn.xerox.com," - ; "info@lorinresortsababai.com," - ; "ketutsukarta@telkom.net," - ; "renata.hutasoit@hyattintl.com," - ; "sukiato@hotelpadma.com," - ; "salesser@idola.net.id," - ; "sales@bali-clubaqua.com," - ; "sales@amandaresort.com," - ; "sales@balimandira.com," ] in + [ + "adhidharma@denpasar.wasantara.net.id"; + "centralreservation@ramayanahotel.com"; + "apribadi@balimandira.com"; + "cdagenhart@ifc.org"; + "dana_supriyanto@interconti.com"; + "dos@novotelbali.com"; + "daniel@hotelpadma.com"; + "daniel@balibless.com"; + "djoko_p@jayakartahotelsresorts.com"; + "expdepot@indosat.net.id"; + "feby.adamsyah@idn.xerox.com"; + "christian_rizal@interconti.com"; + "singgih93@mailcity.com"; + "idonk_gebhoy@yahoo.com"; + "info@houseofbali.com"; + "kyohana@toureast.net"; + "sales@nusaduahotel.com"; + "jayakarta@mataram.wasantara.net.id"; + "mapindo@indo.net.id"; + "sm@ramayanahotel.com"; + "anekabeach@dps.centrin.net.id"; + "yogya@jayakartahotelsresorts.com"; + "garudawisatajaya@indo.net.id"; + "ketut@kbatur.com"; + "bondps@bonansatours.com"; + "witamgr@dps.centrin.net.id"; + "dtedja@indosat.net.id"; + "info@stpbali.ac.id"; + "baliprestigeho@dps.centrin.net.id"; + "pamilu@mas-travel.com"; + "amandabl@indosat.net.id"; + "marketing@csdwholiday.com"; + "luha89@yahoo.com"; + "indahsuluh2002@yahoo.com.sg"; + "imz1991@yahoo.com"; + "gus_war81@yahoo.com"; + "kf034@indosat.net.id"; + "800produkwil@posindonesia.co.id"; + "kontak.synergi@yahoo.com"; + "oekaoeka@yahoo.com"; + "fitrianti@hotmail.com"; + "meylina310@yahoo.com"; + "h4ntoro@yahoo.com"; + "novi_enbe@yahoo.com"; + "dila_dewata@yahoo.co.id"; + "tiena_asfary@yahoo.co.id"; + "da_lawoffice@yahoo.com"; + "rini@ncsecurities.biz"; + "sudarnoto_hakim@yahoo.com"; + "wastioke@yahoo.com"; + "leebahri@yahoo.com."; + "lia_kiara97@yahoo.com"; + "rido@weddingku.com"; + "b_astuti@telkomsel.co.id"; + "garudawisata@indo.net.id"; + "grfurniture@yahoo.com"; + "gosyen2000@hotmail.com"; + "hvhfood@indosat.net.id"; + "hr@astonbali.com"; + "hary@wibisono-family.com"; + "fadlycak'p@yahoo.com"; + "ida_sampurniah@telkomsel.co.id"; + "muslim-pariwisata-bali@yahoogroups.com"; + "harisnira@yahoo.com"; + "sales@houseofbali.com"; + "baim_ron@yahoo.com"; + "ilhambali222@yahoo.com"; + "bungjon@gmail.com"; + "diar@bdg.centrin.net.id"; + "elmienruge@hotmail.com"; + "galaxygarden2006@yahoo.com"; + "gorisata@indosat.net.id"; + "maulitasarihani@yahoo.com"; + "hamiluddakwah@gmail.com.au"; + "bounty@indo.net.id,"; + "michi@ritzcarlton-bali.com,"; + "orridor@dps.centrin.net.id,"; + "ngumina@hotmail.com,"; + "made@mas-travel.com,"; + "evi@mas-travel.com,"; + "wibawa@mas-travel.com,"; + "saihubaly@yahoo.co.id,"; + "swa_candra@yahoo.com,"; + "picapica@denpasar.wasantara.net.id,"; + "griyasantrian@santrian.com,"; + "yuni6671@gmail.com,"; + "phbalichef@indo.net.id,"; + "vendra@keratonjimbaranresort.com,"; + "bali@pansea.com,"; + "sales@legianbeachbali.com,"; + "purchasing@meliabali.com,"; + "swacandra@telkom.net,"; + "lysbeth@paintballbali.com,"; + "trvlindo@upg.mega.net.id,"; + "lim_thefaith@yahoo.com,"; + "uungtb@yahoo.com.au,"; + "vivaldil307@hotmail.com,"; + "iodakon@yahoo.co.id,"; + "reservation@pendawahotel.com,"; + "ptbon@dps.centrin.net.id,"; + "ptlamak@indosat.net.id,"; + "sculpt@indo.net.id,"; + "memedi-gwkbali@dps.centrin.net.id,"; + "info@leisuredream.com,"; + "indra_wijaya@hero.co.id,"; + "ndbconvex@bagus-discovery.com,"; + "Endro@bma-merdeka.com,"; + "wsuardana@indosat.net.id,"; + "bali@esmirada.com,"; + "BAL.Purchasing@fourseasons.com,"; + "ruby@marthatilaar-spa.com,"; + "villaseminyak@eksadata.com,"; + "sariati@sanurbeach.aerowisata.com,"; + "info@jenggala-bali.com,"; + "chef@nusaduahotel.com,"; + "info@balicateringcompany.com,"; + "moka@dps.mega.net.id,"; + "zsa@eyeview.info,"; + "winarios@indosat.net.id,"; + "project@balihai-rsort.com,"; + "vivi@kopibali.com,"; + "peninsulabali@dps.centrin.net.id,"; + "ust.july@mas-travel.com,"; + "ubud@pansea.com,"; + "ustad_july@yahoo.com,"; + "thebarbali@hotmail.com,"; + "trustbali@balidream.com,"; + "teraoka@his-bali.com,"; + "candle@dps.centrin.net.id,"; + "waterbom@denpasar.wasantara.net.id,"; + "ib.suparsa@yahoo.com,"; + "budhipra@nesiancea.com,"; + "info@kindvillabintang.com,"; + "pch@novotelbali.com,"; + "parigata@indosat.net.id,"; + "mail@grandmirage.com,"; + "ananda_resort@hotmail.com,"; + "info@risatabali.com,"; + "gwkbali@indosat.net.id,"; + "rai@gosharestaurant.com,"; + "santika@santikabali.com,"; + "sahidbl@indosat.net.id,"; + "tubanrestaurant@yahoo.com,"; + "sales@thejimbaranbali.com,"; + "info@thejimbaranbali.com,"; + "sari@bubbagumpbali.com,"; + "Winnie@grandlingga.com,"; + "juaidy_asia@yahoo.com,"; + "vicmgr@i-xplore.com,"; + "langka@theclubstore.co.id,"; + "lilakresna@ConradBali.com,"; + "wayan.atmaja@luxurycollecton.com,"; + "Cisabali@indo.net.id,"; + "garrant@indo.net.id,"; + "owenwister@yahoo.com,"; + "tiara@dps.mega.net.id,"; + "info@nzmuslim.net,"; + "yuanito.kurniawan@sea.ccamatil.com,"; + "pitamaha@indosat.net.id,"; + "yunani@theclubstore.co.id,"; + "deklis@hotmail.com,"; + "cianjur@indo.net.id,"; + "mahajayatower@hotmail.com,"; + "endra@centrin.net.id,"; + "wayan.dirayana@fourseasons.com,"; + "balinaga@dps.centrin.net.id,"; + "tiaradwt@dps.centrin.net.id,"; + "candrator@hotmail.com,"; + "altaraspa@yahoo.com,"; + "fani@clubbali.com,"; + "Itudm@dps.centrin.net.id,"; + "baliratuspa@biz.net.id,"; + "kawasspa@indosat.net.id,"; + "hatoe7@yahoo.co.jp,"; + "sales@mimpi.com,"; + "theroyal@indosat.net.id,"; + "chakra_92@yahoo.com,"; + "u_dmtdps@sosro.com,"; + "januar@citramedia.net,"; + "januar@balivisioncomp.com,"; + "admin@balivisioncomp.com,"; + "ansri@dps.mega.net.id,"; + "info@rijasaresort-villas.com,"; + "sales@komaneka.com,"; + "multigun@indo.net.id,"; + "ishwari@bagus-discovery.com,"; + "utami@bali-exoticwedding.com,"; + "putra_wirata@hotmail.com,"; + "arte@dps.centrin.net.id,"; + "hamiludd2kwah@yahoo.com.au,"; + "btu_cipluk@yahoo.com,"; + "agus@indo-journey.com,"; + "agus.winarko@gmail.com,"; + "agus.amirudin@wilmar.co.id,"; + "adamsilver@lycos.com,"; + "yayasanlaroyba@yahoo.co.id,"; + "luminaABC@hotmail.com,"; + "umasapna@coconuthomes.com,"; + "udsupradinasty@yahoo.co.id,"; + "ticketing@bagus-discovery.com,"; + "tejo@pttropical.co.id,"; + "syamklw@yahoo.com,"; + "sutiarso21@yahoo.com,"; + "silvia_maniz@yahoo.com,"; + "yenny_kurniawaty@telkomsel.co.id,"; + "lega@kramatdjatigroup.com,"; + "stadiumcafe@indonet.id,"; + "agencyfreestylebali@yahoo.com,"; + "yayaqdarma@yahoo.co.id,"; + "hanafiid@yahoo.com,"; + "ricky_dvt@yahoo.co.id,"; + "teuku_umar@binus-centre.com,"; + "flp_bali@yahoo.com,"; + "andy@ritzcarlton-bali.com,"; + "bapakbakery@dps.centrin.net.id,"; + "siddiq@teacher.com,"; + "clipper@indo.net.id,"; + "puricendana@yahoo.com,"; + "info@ripcurlschoolsurf.com,"; + "sales@ramabeachhotel.com,"; + "healing@indosat.net.id,"; + "djinaldi@yahoo.co.uk,"; + "rotary.bali.kuta@gmail.com,"; + "dadang@ma-joly.com,"; + "takenoko_bali@yahoo.co.id,"; + "hrd@novotelbali.com,"; + "purwa@kcb-tours.com,"; + "anggie.gendut@england.com,"; + "novyog@indo.net.id,"; + "reservation@meliabali.com,"; + "sales@meliabali.com,"; + "info@rkeconsulting.com,"; + "andisetiaji@abacus-ind.co.id,"; + "sales.corp@swissgrandbali.com,"; + "karsana.wirajaya@trac.astra.co.id,"; + "muliatr@indosat.net.id,"; + "nita@surfer-girl.com,"; + "diah.permana@bagus-discovery.com,"; + "purwabali@yahoo.com,"; + "oly@islandconcpets.com,"; + "info@islandconcepts.com,"; + "gag@indo.net.id,"; + "gkumala@indosat.net.id,"; + "thegardeniavillas@meliabali.com,"; + "purchasing.mgr@thelegianbali.com,"; + "info@paradisebaliholidays.com,"; + "agus.winarko@bagus-discovery.com,"; + "cozytimes26@yahoo.com,"; + "info@papua-adventures.com,"; + "lokasaribali@hotmail.com,"; + "wahana@baliforyou.com,"; + "Stephen@victuslife.com,"; + "operations@atlasbalitours.com,"; + "balicoffeeshop@hotmail.com,"; + "mayakutacentre@telkom.net,"; + "rikmawan@dps.centrin.net.id,"; + "ndbt@bagus-discovery.com,"; + "info@indographs.com,"; + "aridwan_sgb@yahoo.com,"; + "bali@atmosphere.co.id,"; + "plmgrd@indosat.net.id,"; + "balibless@padmaubud.biz,"; + "baliaura@yahoo.com,"; + "andalan@bali.net,"; + "dmandiri@indo.net.id,"; + "pernadi@rad.net.id,"; + "Tabetha@BeyondMenus.com,"; + "adityafood@yahoo.com,"; + "sarana_com@yahoo.com,"; + "pasadena@chek.com,"; + "sales@pica-pica.com,"; + "menara_fbi@hotmail.com,"; + "home_treasure@hotmail.com,"; + "aamsalim@dps.centrin.net.id,"; + "shell_enoproduction@yahoo.com,"; + "geckoleather@hotmail.com,"; + "milagro_bali@hotmail.com,"; + "gemini19id@yahoo.com,"; + "karyacargo@dps.centrin.net.id,"; + "darabali@indo.net.id,"; + "padiprada@hotmail.com,"; + "vijowiz@yahoo.com,"; + "cafejimbaran@mekarsaribali.com,"; + "isnamks@yahoo.com,"; + "sales@allseasonslegian.com,"; + "chitra@cangguclub.com,"; + "cheriaM@xl.co.id,"; + "geo-trek@dps.centrin.net.id,"; + "sales@balipasadena.com,"; + "sales@villahening.com,"; + "fc@novotelbali.com,"; + "maolbing83@yahoo.co.id,"; + "info@dimensitropika.com,"; + "news@tabloidpiknik.com,"; + "mediacentre@bali-tourism.com,"; + "bioland-bali@telkom.net,"; + "glf-bali@indo.net.id,"; + "info@asiabali.com,"; + "takanit@yahoo.com,"; + "jamal@hrbc-bali.co.id,"; + "naniek@alilahotels.com,"; + "ndbtdps@dps.mega.net.id,"; + "mbcbali_jaka@yahoo.com,"; + "masnyonya@telkom.net,"; + "merrystravel@dps.centrin.net.id,"; + "mail@baliintermedia.com,"; + "mitrakridamandiri@hotmail.com,"; + "kartikaplz@denpasar.wasantara.net.id,"; + "oedps@indosat.net.id,"; + "jalirest@indosat.net.id,"; + "jenni_hartatik@interconti.com,"; + "info@alamkulkul.com,"; + "info@aggacitta.com,"; + "info@jasatours.com,"; + "iskandar.Liemena@idn.xerox.com,"; + "info@lorinresortsababai.com,"; + "ketutsukarta@telkom.net,"; + "renata.hutasoit@hyattintl.com,"; + "sukiato@hotelpadma.com,"; + "salesser@idola.net.id,"; + "sales@bali-clubaqua.com,"; + "sales@amandaresort.com,"; + "sales@balimandira.com,"; + ] + in let th0 = let open Part in let* res = create (Fpath.to_string path) in match res with | Error (`Msg err) -> Alcotest.failf "%s." err | Ok () -> - let* () = open_index writer ~path:(Fpath.to_string path) in - let rec go0 idx = function - | [] -> return () - | key :: r -> - let* _ = insert (Rowex.key key) idx in - go0 (succ idx) r in - let* () = go0 0 elts in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) - let* _ = insert (Rowex.key "reservation@ramacandidasahotel.com,") (-1) in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) - let* v' = find (Rowex.key "reservation@ramacandidasahotel.com,") in - Alcotest.(check int) "reservation@ramacandidasahotel.com," v' (-1) ; - let rec go1 idx = function - | [] -> close - | key :: r -> - let* v' = find (Rowex.key key) in - Alcotest.(check int) key v' idx ; - go1 (succ idx) r in - go1 0 elts in + let* () = open_index writer ~path:(Fpath.to_string path) in + let rec go0 idx = function + | [] -> return () + | key :: r -> + let* _ = insert (Rowex.key key) idx in + go0 (succ idx) r + in + let* () = go0 0 elts in + let* _ = + insert (Rowex.key "reservation@ramacandidasahotel.com,") (-1) + in + let* v' = find (Rowex.key "reservation@ramacandidasahotel.com,") in + Alcotest.(check int) "reservation@ramacandidasahotel.com," v' (-1); + let rec go1 idx = function + | [] -> close + | key :: r -> + let* v' = find (Rowex.key key) in + Alcotest.(check int) key v' idx; + go1 (succ idx) r + in + go1 0 elts + in match Part.(run closed th0) with | _closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" let test10 = Alcotest.test_case "test10" `Quick @@ fun _path -> let path = Rresult.R.get_ok (Bos.OS.File.tmp "index-%s") in let elts = - [ "adhidharma@denpasar.wasantara.net.id" - ; "centralreservation@ramayanahotel.com" - ; "apribadi@balimandira.com" - ; "cdagenhart@ifc.org" - ; "dana_supriyanto@interconti.com" - ; "dos@novotelbali.com" - ; "daniel@hotelpadma.com" - ; "daniel@balibless.com" - ; "djoko_p@jayakartahotelsresorts.com" - ; "expdepot@indosat.net.id" - ; "feby.adamsyah@idn.xerox.com" - ; "christian_rizal@interconti.com" - ; "singgih93@mailcity.com" - ; "idonk_gebhoy@yahoo.com" - ; "info@houseofbali.com" - ; "kyohana@toureast.net" - ; "sales@nusaduahotel.com" - ; "jayakarta@mataram.wasantara.net.id" - ; "mapindo@indo.net.id" - ; "sm@ramayanahotel.com" - ; "anekabeach@dps.centrin.net.id" - ; "yogya@jayakartahotelsresorts.com" - ; "garudawisatajaya@indo.net.id" - ; "ketut@kbatur.com" - ; "bondps@bonansatours.com" - ; "witamgr@dps.centrin.net.id" - ; "dtedja@indosat.net.id" - ; "info@stpbali.ac.id" - ; "baliprestigeho@dps.centrin.net.id" - ; "pamilu@mas-travel.com" - ; "amandabl@indosat.net.id" - ; "marketing@csdwholiday.com" - ; "luha89@yahoo.com" - ; "indahsuluh2002@yahoo.com.sg" - ; "imz1991@yahoo.com" - ; "gus_war81@yahoo.com" - ; "kf034@indosat.net.id" - ; "800produkwil@posindonesia.co.id" - ; "kontak.synergi@yahoo.com" - ; "oekaoeka@yahoo.com" - ; "fitrianti@hotmail.com" - ; "meylina310@yahoo.com" - ; "h4ntoro@yahoo.com" - ; "novi_enbe@yahoo.com" - ; "dila_dewata@yahoo.co.id" - ; "tiena_asfary@yahoo.co.id" - ; "da_lawoffice@yahoo.com" - ; "rini@ncsecurities.biz" - ; "sudarnoto_hakim@yahoo.com" - ; "wastioke@yahoo.com" - ; "leebahri@yahoo.com." - ; "lia_kiara97@yahoo.com" - ; "rido@weddingku.com" - ; "b_astuti@telkomsel.co.id" - ; "garudawisata@indo.net.id" - ; "grfurniture@yahoo.com" - ; "gosyen2000@hotmail.com" - ; "hvhfood@indosat.net.id" - ; "hr@astonbali.com" - ; "hary@wibisono-family.com" - ; "fadlycak'p@yahoo.com" - ; "ida_sampurniah@telkomsel.co.id" - ; "muslim-pariwisata-bali@yahoogroups.com" - ; "harisnira@yahoo.com" - ; "sales@houseofbali.com" - ; "baim_ron@yahoo.com" - ; "ilhambali222@yahoo.com" - ; "bungjon@gmail.com" - ; "diar@bdg.centrin.net.id" - ; "elmienruge@hotmail.com" - ; "galaxygarden2006@yahoo.com" - ; "gorisata@indosat.net.id" - ; "maulitasarihani@yahoo.com" - ; "hamiluddakwah@gmail.com.au" - ; "bounty@indo.net.id," - ; "michi@ritzcarlton-bali.com," - ; "orridor@dps.centrin.net.id," - ; "ngumina@hotmail.com," - ; "made@mas-travel.com," - ; "evi@mas-travel.com," - ; "wibawa@mas-travel.com," - ; "saihubaly@yahoo.co.id," - ; "swa_candra@yahoo.com," - ; "picapica@denpasar.wasantara.net.id," - ; "griyasantrian@santrian.com," - ; "yuni6671@gmail.com," - ; "phbalichef@indo.net.id," - ; "vendra@keratonjimbaranresort.com," - ; "bali@pansea.com," - ; "sales@legianbeachbali.com," - ; "purchasing@meliabali.com," - ; "swacandra@telkom.net," - ; "lysbeth@paintballbali.com," - ; "trvlindo@upg.mega.net.id," - ; "lim_thefaith@yahoo.com," - ; "uungtb@yahoo.com.au," - ; "vivaldil307@hotmail.com," - ; "iodakon@yahoo.co.id," - ; "reservation@pendawahotel.com," - ; "ptbon@dps.centrin.net.id," - ; "ptlamak@indosat.net.id," - ; "sculpt@indo.net.id," - ; "memedi-gwkbali@dps.centrin.net.id," - ; "info@leisuredream.com," - ; "indra_wijaya@hero.co.id," - ; "ndbconvex@bagus-discovery.com," - ; "Endro@bma-merdeka.com," - ; "wsuardana@indosat.net.id," - ; "bali@esmirada.com," - ; "BAL.Purchasing@fourseasons.com," - ; "ruby@marthatilaar-spa.com," - ; "villaseminyak@eksadata.com," - ; "sariati@sanurbeach.aerowisata.com," - ; "info@jenggala-bali.com," - ; "chef@nusaduahotel.com," - ; "info@balicateringcompany.com," - ; "moka@dps.mega.net.id," - ; "zsa@eyeview.info," - ; "winarios@indosat.net.id," - ; "project@balihai-rsort.com," - ; "vivi@kopibali.com," - ; "peninsulabali@dps.centrin.net.id," - ; "ust.july@mas-travel.com," - ; "ubud@pansea.com," - ; "ustad_july@yahoo.com," - ; "thebarbali@hotmail.com," - ; "trustbali@balidream.com," - ; "teraoka@his-bali.com," - ; "candle@dps.centrin.net.id," - ; "waterbom@denpasar.wasantara.net.id," - ; "ib.suparsa@yahoo.com," - ; "budhipra@nesiancea.com," - ; "info@kindvillabintang.com," - ; "pch@novotelbali.com," - ; "parigata@indosat.net.id," - ; "mail@grandmirage.com," - ; "ananda_resort@hotmail.com," - ; "info@risatabali.com," - ; "gwkbali@indosat.net.id," - ; "rai@gosharestaurant.com," - ; "santika@santikabali.com," - ; "sahidbl@indosat.net.id," - ; "tubanrestaurant@yahoo.com," - ; "sales@thejimbaranbali.com," - ; "info@thejimbaranbali.com," - ; "sari@bubbagumpbali.com," - ; "Winnie@grandlingga.com," - ; "juaidy_asia@yahoo.com," - ; "vicmgr@i-xplore.com," - ; "langka@theclubstore.co.id," - ; "lilakresna@ConradBali.com," - ; "wayan.atmaja@luxurycollecton.com," - ; "Cisabali@indo.net.id," - ; "garrant@indo.net.id," - ; "owenwister@yahoo.com," - ; "tiara@dps.mega.net.id," - ; "info@nzmuslim.net," - ; "yuanito.kurniawan@sea.ccamatil.com," - ; "pitamaha@indosat.net.id," - ; "yunani@theclubstore.co.id," - ; "deklis@hotmail.com," - ; "cianjur@indo.net.id," - ; "mahajayatower@hotmail.com," - ; "endra@centrin.net.id," - ; "wayan.dirayana@fourseasons.com," - ; "balinaga@dps.centrin.net.id," - ; "tiaradwt@dps.centrin.net.id," - ; "candrator@hotmail.com," - ; "altaraspa@yahoo.com," - ; "fani@clubbali.com," - ; "Itudm@dps.centrin.net.id," - ; "baliratuspa@biz.net.id," - ; "kawasspa@indosat.net.id," - ; "hatoe7@yahoo.co.jp," - ; "sales@mimpi.com," - ; "theroyal@indosat.net.id," - ; "chakra_92@yahoo.com," - ; "u_dmtdps@sosro.com," - ; "januar@citramedia.net," - ; "januar@balivisioncomp.com," - ; "admin@balivisioncomp.com," - ; "ansri@dps.mega.net.id," - ; "info@rijasaresort-villas.com," - ; "sales@komaneka.com," - ; "multigun@indo.net.id," - ; "ishwari@bagus-discovery.com," - ; "utami@bali-exoticwedding.com," - ; "putra_wirata@hotmail.com," - ; "arte@dps.centrin.net.id," - ; "hamiludd2kwah@yahoo.com.au," - ; "btu_cipluk@yahoo.com," - ; "agus@indo-journey.com," - ; "agus.winarko@gmail.com," - ; "agus.amirudin@wilmar.co.id," - ; "adamsilver@lycos.com," - ; "yayasanlaroyba@yahoo.co.id," - ; "luminaABC@hotmail.com," - ; "umasapna@coconuthomes.com," - ; "udsupradinasty@yahoo.co.id," - ; "ticketing@bagus-discovery.com," - ; "tejo@pttropical.co.id," - ; "syamklw@yahoo.com," - ; "sutiarso21@yahoo.com," - ; "silvia_maniz@yahoo.com," - ; "yenny_kurniawaty@telkomsel.co.id," - ; "lega@kramatdjatigroup.com," - ; "stadiumcafe@indonet.id," - ; "agencyfreestylebali@yahoo.com," - ; "yayaqdarma@yahoo.co.id," - ; "hanafiid@yahoo.com," - ; "ricky_dvt@yahoo.co.id," - ; "teuku_umar@binus-centre.com," - ; "flp_bali@yahoo.com," - ; "andy@ritzcarlton-bali.com," - ; "bapakbakery@dps.centrin.net.id," - ; "siddiq@teacher.com," - ; "clipper@indo.net.id," - ; "puricendana@yahoo.com," - ; "info@ripcurlschoolsurf.com," - ; "sales@ramabeachhotel.com," - ; "healing@indosat.net.id," - ; "djinaldi@yahoo.co.uk," - ; "rotary.bali.kuta@gmail.com," - ; "dadang@ma-joly.com," - ; "takenoko_bali@yahoo.co.id," - ; "hrd@novotelbali.com," - ; "purwa@kcb-tours.com," - ; "anggie.gendut@england.com," - ; "novyog@indo.net.id," - ; "reservation@meliabali.com," - ; "sales@meliabali.com," - ; "info@rkeconsulting.com," - ; "andisetiaji@abacus-ind.co.id," - ; "sales.corp@swissgrandbali.com," - ; "karsana.wirajaya@trac.astra.co.id," - ; "muliatr@indosat.net.id," - ; "nita@surfer-girl.com," - ; "diah.permana@bagus-discovery.com," - ; "purwabali@yahoo.com," - ; "oly@islandconcpets.com," - ; "info@islandconcepts.com," - ; "gag@indo.net.id," - ; "gkumala@indosat.net.id," - ; "thegardeniavillas@meliabali.com," - ; "purchasing.mgr@thelegianbali.com," - ; "info@paradisebaliholidays.com," - ; "agus.winarko@bagus-discovery.com," - ; "cozytimes26@yahoo.com," - ; "info@papua-adventures.com," - ; "lokasaribali@hotmail.com," - ; "wahana@baliforyou.com," - ; "Stephen@victuslife.com," - ; "operations@atlasbalitours.com," - ; "balicoffeeshop@hotmail.com," - ; "mayakutacentre@telkom.net," - ; "rikmawan@dps.centrin.net.id," - ; "ndbt@bagus-discovery.com," - ; "info@indographs.com," - ; "aridwan_sgb@yahoo.com," - ; "bali@atmosphere.co.id," - ; "plmgrd@indosat.net.id," - ; "balibless@padmaubud.biz," - ; "baliaura@yahoo.com," - ; "andalan@bali.net," - ; "dmandiri@indo.net.id," - ; "pernadi@rad.net.id," - ; "Tabetha@BeyondMenus.com," - ; "adityafood@yahoo.com," - ; "sarana_com@yahoo.com," - ; "pasadena@chek.com," - ; "sales@pica-pica.com," - ; "menara_fbi@hotmail.com," - ; "home_treasure@hotmail.com," - ; "aamsalim@dps.centrin.net.id," - ; "shell_enoproduction@yahoo.com," - ; "geckoleather@hotmail.com," - ; "milagro_bali@hotmail.com," - ; "gemini19id@yahoo.com," - ; "karyacargo@dps.centrin.net.id," - ; "darabali@indo.net.id," - ; "padiprada@hotmail.com," - ; "vijowiz@yahoo.com," - ; "cafejimbaran@mekarsaribali.com," - ; "isnamks@yahoo.com," - ; "sales@allseasonslegian.com," - ; "chitra@cangguclub.com," - ; "cheriaM@xl.co.id," - ; "geo-trek@dps.centrin.net.id," - ; "sales@balipasadena.com," - ; "sales@villahening.com," - ; "fc@novotelbali.com," - ; "maolbing83@yahoo.co.id," - ; "info@dimensitropika.com," - ; "news@tabloidpiknik.com," - ; "mediacentre@bali-tourism.com," - ; "bioland-bali@telkom.net," - ; "glf-bali@indo.net.id," - ; "info@asiabali.com," - ; "takanit@yahoo.com," - ; "jamal@hrbc-bali.co.id," - ; "naniek@alilahotels.com," - ; "ndbtdps@dps.mega.net.id," - ; "mbcbali_jaka@yahoo.com," - ; "masnyonya@telkom.net," - ; "merrystravel@dps.centrin.net.id," - ; "mail@baliintermedia.com," - ; "mitrakridamandiri@hotmail.com," - ; "kartikaplz@denpasar.wasantara.net.id," - ; "oedps@indosat.net.id," - ; "jalirest@indosat.net.id," - ; "jenni_hartatik@interconti.com," - ; "info@alamkulkul.com," - ; "info@aggacitta.com," - ; "info@jasatours.com," - ; "iskandar.Liemena@idn.xerox.com," - ; "info@lorinresortsababai.com," - ; "ketutsukarta@telkom.net," - ; "renata.hutasoit@hyattintl.com," - ; "sukiato@hotelpadma.com," - ; "salesser@idola.net.id," - ; "sales@bali-clubaqua.com," - ; "sales@amandaresort.com," - ; "sales@balimandira.com," - ; "reservation@ramacandidasahotel.com," - ; "reservation@puriwulandari.net," - ; "nathanhotel@eksadata.com," - ; "rudi_chandra@kartikaplaza.co.id," - ; "ndcmdo@indosat.net.id," - ; "reservation@ramayanahotel.com," - ; "paradiso_bowlingbilliard@hotmail.com," - ; "perdana@balioffice.com," - ; "putribali@denpasar.wasantara.net.id," - ; "psmovers@indo.net.id," - ; "ops@thebale.com," - ; "hapsar@burung.org," - ; "ramayana@dps.mega.net.id," - ; "securanto@yahoo.com," - ; "info@villakendil.com," - ; "reservation@mpkm.co.id," - ; "info@armaresort.com," - ; "sales@balihaicruises.com," - ; "warsaubud@hotmail.com," - ; "bali_promo@plasa.com," - ; "gratindo@hotmail.com," - ; "rupadhatu89@yahoo.co.uk," - ; "info@balivillage.com," - ; "info@tomahouse.com," - ; "sales.ta@swissgrandbali.com," - ; "baliwastafel@yahoo.com," - ; "product.dps@marintur.co.id," - ; "marindps@indo.net.id," - ; "operation@cnptours.com," - ; "panoramahtl@indo.net.id," - ; "pru@indo.net.id," - ; "balivillage@indo.net.id," - ; "huzni@holidayvilla.com," - ; "info@balibmrdive.com," - ; "gadis0381@yahoo.com," - ; "info@balijazzfestival.com," - ; "triple_ebali@yahoo.com," - ; "pimage@indosat.net," - ; "kikuyaart@yahoo.com," - ; "polystar@cbn.net.id," - ; "devie@mpkm.co.id," - ; "duasisi@indo.net.id," - ; "info@palanquinbali.com," - ; "dhvbali@indosat.net.id," - ; "hussain@indo.net.id," - ; "orientalrugs_imsharif@hotmail.com," - ; "utut-irawan@ramayanahotel.com," - ; "randd98@hotmail.com," - ; "purbasari@divre7.telkom.co.id," - ; "mobnas_intim@indo.net.id," - ; "dwilasmin@yahoo.com," - ; "info@downtownbali.com," - ; "info@hotellumbung.com," - ; "info@balitonys.com," - ; "info@thevillas.net," - ; "reservation@the-dusun.com," - ; "info@theahimsa.com," - ; "info@sienna-villas.com," - ; "sababai@indosat.net.id," - ; "sales@putubalivilla.com," - ; "sales@akhyativillas.com," - ; "desamuda@indosat.net.id," - ; "reservation@amandaresort.com," - ; "info@alubali.com," - ; "vilarm@indo.net.id," - ; "intansalesbali@intanhotels.com," - ; "info@theoberoi-bali.com," - ; "legian@ghmhotels.com," - ; "reservation@rakharismavilla.com," - ; "wakagangga@wakaexperience.com," - ; "awing-awang@balivision.com," - ; "info@segaravillage.com," - ; "nsindhu@denpasar.wasantara.net.id," - ; "besakih@indosat.net.id," - ; "reservation@sanur.pphotels.com," - ; "info@santrian.com," - ; "info@sanurbeach.aerowisata.com," - ; "info@villaaya.com," - ; "balihyatt.inquiries@hyattintl.com," - ; "sales@coconuthomes.com," - ; "reservation@nirwanabaliresort.com," - ; "sales@balimeridien.com," - ; "bali@tuguhotels.com," - ; "villa_kharista@hommsindonesia.com," - ; "surgavillas@dps.centrin.net.id," - ; "gm@canggu.com," - ; "info@legianparadisohotel.com," - ; "sales@grand-balibeach.com," - ; "info@bintang-bali-hotel.com," - ; "sales.bali@saphir-hotels.com," - ; "rock@hardrockhotels.net," - ; "info@thevirabali.com," - ; "inrisata@indosat.net.id," - ; "reservation@ramabeachhotel.com," - ; "sales@jatra.com," - ; "reservation@balidynasty.com," - ; "infoadmin@mercurekutabali.com," - ; "reservation.bali@patra-jasa.com," - ; "sales@ramayanahotel.com," - ; "info@kutaparadisohotel.com," - ; "reservation@discoverykartikaplza.com," - ; "info@bluepointbayvillas.com," - ; "bcr@indosat.net.id," - ; "sales@pat-mase.com," - ; "fsrb@fourseasons.com," - ; "info@keratonjimbaranresort.com," - ; "reservation@balihai-resort.com," - ; "reservation@hotelpadma.com," - ; "adeboer@alilahotels.com," - ; "sales@kutalagoonresort.com," - ; "sales@courtyard-bali.com," - ; "balisani@indo.net.id," - ; "sales@baliholidayresort.net," - ; "sales@adhidharmahotel.com," - ; "info@whiterose.co.id," - ; "nkutabh@indosat.net.id," - ; "jhrbali@indo.net.id," - ; "rgarden@indosat.net.id," - ; "winacott@indosat.net.id," - ; "info@theoasis.info," - ; "reservation@kutaseaviewhotel.com," - ; "kbchotel@indosat.net.id," - ; "info@harris-kuta-bali.com," - ; "reservation@grandistanarama.com," - ; "sales@sahidrayabali.com," - ; "sales@pelangibali.com," - ; "info@jayakarta-lombok.com," - ; "info@hotelombak.com," - ; "hotel@novotel-lombok.com," - ; "lombokraya_htl@telkom.net," - ; "info@theoberoi-lombok.com," - ; "stay@quncivillas.com," - ; "info@poovillaclub.aerowisata.com," - ; "wakamaya@wakaexperience.com," - ; "info@senggigibeach.aerowisata.com" - ; "alfabeta_ba@yahoo.com," - ; "lombok@intanhotels.com," - ; "hirlo@mataram.wasantara.net.id," - ; "sales.senggigi@sheraton.com," - ; "tulamben@mimpi.com," - ; "waterg@dps.centrin.net.id," - ; "puribaguscandidasa@bagus-dscovery.com," - ; "ramacan@denpasar,wasantara.net.id," - ; "p_saron@indo.net.id," - ; "itha@ripcurl.co.id," - ; "pwilantari@anantara.com," - ; "novie@base.co.id," - ; "manager@annorabali.com," - ; "luh_g_astitiningsih@telkomsel.co.id," - ; "kesuma.putra@kasihibuhospital.com," - ; "frisa.andarina@kasihibuhospital.com," - ; "cok.wijaya@sampoerna.com," - ; "hamartapartners@yahoo.com," - ; "mudita@indosat.com," - ; "info@phoenixgraha.com," - ; "Ni.Wiratni@sampoerna.com," - ; "budi.wiadnyana@trac.astra.co.id," - ; "Budi.Yasa@sampoerna.com," - ; "purnama.dewi@kasihibuhospital.com," - ; "david.clark5@btinternet.com" - ; "manager@mibank.com" - ; "reserv@nusa-lembongan.com," - ; "awinarta@anantara.com," - ; "info@sulyresort.com," - ; "sales@candibeachbali.com," - ; "sales@kamandaluresort.com," - ; "sales@ibahbali.com," - ; "bumiubud@dps.centrin.net.id," - ; "sales@barong-resort.com," - ; "info@bagusjati.com," - ; "wakapadma@wakaexperience.com," - ; "komaneka@indosat.net.id," - ; "tjampuan@indo.net.id," - ; "sales@koriubud.com," - ; "sahadewa@dps.centrin.net.id," - ; "pertiwi@indosat.net.id," - ; "kumarasakti@dps.centrin.net.id," - ; "chamsari@indosat.net," - ; "info@cahayadewatahotel.com," - ; "payogan@indosat.net.id," - ; "info@mayaubud.com," - ; "wakadiume@wakaexperience.com," - ; "balipacung@telkom.net," - ; "reservation@wantilangolfvillas.com," - ; "sales@bali-activities.com," - ; "wakanusa@wakaexperience.com," - ; "twfv@dps.centrin.net.id," - ; "menjangan@mimpi.com," - ; "wakashorea@wakaexperience.com," - ; "mbr-bali@indo.net.id," - ; "kayumanis@baliprivatevilla.com," - ; "resort@damai.com," - ; "apummer@alilahotels.com," - ; "sales@balihandarakosaido.com," - ; "bali@purisaron.com," - ; "sales@alampurivilla.com," - ; "info@villasemana.com," - ; "home@themansionbali.com," - ; "info@santimandalaresort.com," - ; "natura@indosat.net.id," - ; "puribaguslovina@bagus-discovery.com," - ; "agustiansyah@takaful.com," - ; "dewimoes@yahoo.com," - ; "denie@bigfoot.com," - ; "deden@bali-exoticwedding.com," - ; "deddydiva@yahoo.com," - ; "budivirgono@yahoo.co.id," - ; "budi@bmnlawoffice.info," - ; "ritzbc@indosat.net.id," - ; "eurobali@indosat.net.id," - ; "neginohige@hotmail.com," - ; "waow_one@yahoo.co.id," - ; "rini_wulandari1970@yahoo.co.id," - ; "priharyati@itpc.or.jp," - ; "kucing_puri@yahoo.co.jp," - ; "fadlycakp@yahoo.com," - ; "eh_juniadi@yahoo.com," - ; "balibusser@yahoo.com," - ; "bayu@bmnlawoffice.info," - ; "hanifah@bniaga.co.id," - ; "bali@indomultimedia.co.id," - ; "ary@balidestinationtravel.com," - ; "admin@sectorbarrestaurant.com," - ; "gendut@england.com," - ; "novyog@indo.net.id,anggie," - ; "amin@paradisebaliholidays.com," - ; "leebahri@yahoo.com," - ; "info@dsmbali.or.id," - ; "heni@bali-exoticwedding.com," - ; "zakat_bali@yahoo.com," - ; "tothesolo@yahoo.com," - ; "hardwoodindonesia@yahoo.com," - ; "fuay@yahoo.com," - ; "fuay@walla.com," - ; "ef_architect@yahoo.com," - ; "ennymei@telkom.net," - ; "wulandari@firststatebali.com," - ; "ihwan@pollowindonesia.com," - ; "haryo.santoso@trac.astra.co.id," - ; "andrie.yudhianto@gmail.com," - ; "fidiyono_bali@yahoo.com," - ; "fauzantan@yahoo.com," - ; "faisal_silin@yahoo.com," - ; "elkahiri@yahoo.co.id," - ; "bernitha_widinansari@yahoo.co.id," - ; "a6us_kurniawan@yahoo.co.id," - ; "itha_ersita@yahoo.com," - ; "elly@pantravel.co.id," - ; "iva@nikkobali.com," - ; "elly@intrareps.com," - ; "sbtours@indosat.net.id," - ; "wisantaradps@yahoo.com," - ; "jawi@dps.centrin.net.id," - ; "info@baliadventuretours.com," - ; "alampuri@resortgallery.com," - ; "beauty_rahma@yahoo.com," - ; "dsartika@internux.net.id," - ; "sri.hadibudi@bagus-discovery.com," - ; "freddy@bali-tourism-board.com," - ; "wiwid@ripcurl.co.id," - ; "ratna.wijayanti@aig.com," - ; "nurnirwan@yahoo.com," - ; "grandjv@indo.net.id," - ; "bukitpratama@yahoo.com," - ; "awie_kasasi@yahoo.com," - ; "gdiezzmewth@yahoo.co.id," - ; "gandjar@earthling.net," - ; "cubenenni@yahoo.com," - ; "rani@bluepointbayvillas.com," - ; "preman_surabaya3@yahoo.com," - ; "nenyjon77@yahoo.com," - ; "mf_ulfa@yahoo.com," - ; "meutyahafid@yahoo.com," - ; "mayanto@yahoo.com," - ; "marketing@balivisioncomputer.com," - ; "alwin007@yahoo.com," - ; "nathansugiarto@yahoo.com" - ; "dianpuri69@yahoo.com," - ; "sales@astonbali.com," - ; "ngurah_rai56@yahoo.com" - ; "herjun_jp@yahoo.co.id," - ; "zip_fmmaros@yahoo.com," - ; "icendol@yahoo.com," - ; "nediarjuliadi@yahoo.com," - ; "info@novotelbali.com," - ; "w_promoplus@yahoo.com" - ; "salesrrb@indosat.net.id," - ; "phio_19@yahoo.com" - ; "marinasenggigi@yahoo.co.id" - ; "iik_young@yahoo.com" - ; "igmastika@idp.co.id" - ; "hnry_stwn@yahoo.com" - ; "aulFrancisKacingenta_39@yahoo.com" - ; "bit_bali@yahoo.com," - ; "gunawanpnj@yahoo.com," - ; "baligh.inquires@hyattintl.com," - ; "balihai@q-net.net.id," - ; "bliss@thebale.com," - ; "info@villasekarnusadua.com," - ; "balidesa@indosat.net.id," - ; "info@swiss-bellhotel-baliaga.com," - ; "thewestinresortbali@westin.com," - ; "sheraton.laguna@luxurycollection.com," - ; "melia.benoa@solmelia.com," - ; "sales@nikkobali.com," - ; "btbbtbfauzanbabijanuitem_jelut@yahoo.com," - ; "info@balihilton.com," - ; "balireef@balireef-resort.com," - ; "vl_bintang@denpasar.wasantara.net.id," - ; "ptanjung@indo.net.id," - ; "pbenoa@denpasar.wasantara.net.id," - ; "suites@baliroyal.com," - ; "cbmrsv@indosat.net.id," - ; "sales@nusaduahotel.com," - ; "evi@discountvoucherbooklet.com," - ; "Malelakfauzansubandi@yahoo.co.id," - ; "koko_dic@yahoo.com," - ; "yusyunikamiyani@yahoo.com," - ; "widya.Riani@hrdap.mail.a.rd.honda.co.jp," - ; "novita_vasiska@yahoo.com," - ; "ngk-jkt4@cbn.net.id," - ; "lies@wika-ngk.co.id," - ; "mulyadi_kbi@yahoo.co.id," - ; "dutaos@telkom.net," - ; "neoazuma@yahoo.co.id," - ; "ikmar@citra.co.id," - ; "t_hadi_g@cp.co.id," - ; "chandra@mailcda.com," - ; "nina@mailcda.com," - ; "rsuryamega@3selaras.com," - ; "petrgilx@yahoo.co.uk," - ; "bali@interconti.com," - ; "rputra@pardic.co.id," - ; "steven_dp@yahoo.com," - ; "bevan@bahanagv.co.id" - ; "balikita1@yahoo.com" - ; "aguswiguna@yahoo.co.id," - ; "eddy@mgholiday.com," - ; "widiaharika@yahoo.com," - ; "srilestari@mycondradbali.com," - ; "dsujatha@indosat.net.id," - ; "clate.m@infusionsoft.com," - ; "stevenbali@hotmail.com," - ; "info@bali-tourism-board.com," - ; "trauining@triatma-mapindo.ac.id," - ; "rosariyanti@xl.co.id," - ; "mgr_eo@yahoo.co.id," - ; "missd@bigpond.net.au," - ; "getanjali.anand@seejobs.org," - ; "gus_krisna@yahoo.com" - ; "tazgirls_2512@yahoo.com," - ; "santhiarsa@yahoo.com," - ; "dmsbali@yahoo.com," - ; "andri_budiarto@multibintang.co.id," - ; "Wiboko_rinarto@telkomsel.co.id," - ; "caracraft@hotmail.com," - ; "plastic_centre_sanur@hotmail.com," - ; "sandangjaya@yahoo.com," - ; "assa_tour@yahoo.com," - ; "zefanya_production@hotmail.com," - ; "etha@dps.centrin.net.id," - ; "kewayang@dps.centrin.net.id," - ; "pahalakencana@dps.centrin.net.id," - ; "balipermata@telkom.net," - ; "ops@thebale.com" - ; "sales@amandaresort.com" - ; "kartikaplz@denpasar.wasantara.net.id" - ; "ketutsukarta@telkom.net" - ; "mail@baliintermedia.com" - ; "merrystravel@dps.centrin.net.id" - ; "masnyonya@telkom.net" - ; "mbcbali_jaka@yahoo.com" - ; "ndbtdps@dps.mega.net.id" - ; "naniek@alilahotels.com" - ; "nathanhotel@eksadata.com" - ; "jalirest@indosat.net.id" - ; "oedps@indosat.net.id" - ; "jenni_hartatik@interconti.com" - ; "psmovers@indo.net.id" - ; "putribali@denpasar.wasantara.net.id" - ; "perdana@balioffice.com" - ; "paradiso_bowlingbilliard@hotmail.com" - ; "reservation@ramayanahotel.com" - ; "renata.hutasoit@hyattintl.com" - ; "rudi_chandra@kartikaplaza.co.id" - ; "ramayana@dps.mega.net.id" - ; "reservation@puriwulandari.net" - ; "reservation@ramacandidasahotel.com" - ; "wibawa@mas-travel.com" - ; "ndcmdo@indosat.net.id" - ; "pimage@indosat.net" - ; "mobnas_intim@indo.net.id" - ; "purbasari@divre7.telkom.co.id" - ; "randd98@hotmail.com" - ; "utut-irawan@ramayanahotel.com" - ; "orientalrugs_imsharif@hotmail.com" - ; "hussain@indo.net.id" - ; "dhvbali@indosat.net.id" - ; "huzni@holidayvilla.com" - ; "duasisi@indo.net.id" - ; "dwilasmin@yahoo.com" - ; "jamal@hrbc-bali.co.id" - ; "kikuyaart@yahoo.com" - ; "sales@bali-clubaqua.com" - ; "triple_ebali@yahoo.com" - ; "info@balijazzfestival.com" - ; "gadis0381@yahoo.com" - ; "hapsar@burung.org" - ; "info@palanquinbali.com" - ; "info@villakendil.com" - ; "info@lorinresortsababai.com" - ; "iskandar.Liemena@idn.xerox.com" - ; "info@jasatours.com" - ; "info@aggacitta.com" - ; "info@alamkulkul.com" - ; "polystar@cbn.net.id" - ; "santika@santikabali.com" - ; "sales@balimandira.com" - ; "info@thejimbaranbali.com" - ; "sales@thejimbaranbali.com" - ; "tubanrestaurant@yahoo.com" - ; "ib.suparsa@yahoo.com" - ; "vicmgr@i-xplore.com" - ; "info@risatabali.com" - ; "ananda_resort@hotmail.com" - ; "parigata@indosat.net.id" - ; "pch@novotelbali.com" - ; "Winnie@grandlingga.com" - ; "BAL.Purchasing@fourseasons.com" - ; "juaidy_asia@yahoo.com" - ; "sariati@sanurbeach.aerowisata.com" - ; "purchasing@meliabali.com" - ; "sales@legianbeachbali.com" - ; "bali@pansea.com" - ; "vendra@keratonjimbaranresort.com" - ; "phbalichef@indo.net.id" - ; "yuni6671@gmail.com" - ; "griyasantrian@santrian.com" - ; "bounty@indo.net.id" - ; "swa_candra@yahoo.com" - ; "swacandra@telkom.net" - ; "info@kindvillabintang.com" - ; "vivi@kopibali.com" - ; "salesser@idola.net.id" - ; "sukiato@hotelpadma.com" - ; "stadiumcafe@indonet.id" - ; "trvlindo@upg.mega.net.id" - ; "thegardeniavillas@meliabali.com" - ; "teraoka@his-bali.com" - ; "trustbali@balidream.com" - ; "thebarbali@hotmail.com" - ; "ustad_july@yahoo.com" - ; "ubud@pansea.com" - ; "sari@bubbagumpbali.com" - ; "villaseminyak@eksadata.com" - ; "devie@mpkm.co.id" - ; "waterbom@denpasar.wasantara.net.id" - ; "winarios@indosat.net.id" - ; "zsa@eyeview.info" - ; "moka@dps.mega.net.id" - ; "matt.lloyd@roamfree.com" - ; "info@balicateringcompany.com" - ; "chef@nusaduahotel.com" - ; "info@jenggala-bali.com" - ; "gwkbali@indosat.net.id" - ; "project@balihai-rsort.com" - ; "peninsulabali@dps.centrin.net.id" - ; "ust.july@mas-travel.com" - ; "ndbt@bagus-discovery.com" - ; "info@tomahouse.com" - ; "info@paradisebaliholidays.com" - ; "agus.winarko@bagus-discovery.com" - ; "cozytimes26@yahoo.com" - ; "info@papua-adventures.com" - ; "lokasaribali@hotmail.com" - ; "plmgrd@indosat.net.id" - ; "Stephen@victuslife.com" - ; "gkumala@indosat.net.id" - ; "balicoffeeshop@hotmail.com" - ; "dmandiri@indo.net.id" - ; "rikmawan@dps.centrin.net.id" - ; "pernadi@rad.net.id" - ; "info@indographs.com" - ; "aridwan_sgb@yahoo.com" - ; "sales.corp@swissgrandbali.com" - ; "operations@atlasbalitours.com" - ; "wahana@baliforyou.com" - ; "hrd@novotelbali.com" - ; "purwa@kcb-tours.com" - ; "anggie.gendut@england.com" ] in + [ + "adhidharma@denpasar.wasantara.net.id"; + "centralreservation@ramayanahotel.com"; + "apribadi@balimandira.com"; + "cdagenhart@ifc.org"; + "dana_supriyanto@interconti.com"; + "dos@novotelbali.com"; + "daniel@hotelpadma.com"; + "daniel@balibless.com"; + "djoko_p@jayakartahotelsresorts.com"; + "expdepot@indosat.net.id"; + "feby.adamsyah@idn.xerox.com"; + "christian_rizal@interconti.com"; + "singgih93@mailcity.com"; + "idonk_gebhoy@yahoo.com"; + "info@houseofbali.com"; + "kyohana@toureast.net"; + "sales@nusaduahotel.com"; + "jayakarta@mataram.wasantara.net.id"; + "mapindo@indo.net.id"; + "sm@ramayanahotel.com"; + "anekabeach@dps.centrin.net.id"; + "yogya@jayakartahotelsresorts.com"; + "garudawisatajaya@indo.net.id"; + "ketut@kbatur.com"; + "bondps@bonansatours.com"; + "witamgr@dps.centrin.net.id"; + "dtedja@indosat.net.id"; + "info@stpbali.ac.id"; + "baliprestigeho@dps.centrin.net.id"; + "pamilu@mas-travel.com"; + "amandabl@indosat.net.id"; + "marketing@csdwholiday.com"; + "luha89@yahoo.com"; + "indahsuluh2002@yahoo.com.sg"; + "imz1991@yahoo.com"; + "gus_war81@yahoo.com"; + "kf034@indosat.net.id"; + "800produkwil@posindonesia.co.id"; + "kontak.synergi@yahoo.com"; + "oekaoeka@yahoo.com"; + "fitrianti@hotmail.com"; + "meylina310@yahoo.com"; + "h4ntoro@yahoo.com"; + "novi_enbe@yahoo.com"; + "dila_dewata@yahoo.co.id"; + "tiena_asfary@yahoo.co.id"; + "da_lawoffice@yahoo.com"; + "rini@ncsecurities.biz"; + "sudarnoto_hakim@yahoo.com"; + "wastioke@yahoo.com"; + "leebahri@yahoo.com."; + "lia_kiara97@yahoo.com"; + "rido@weddingku.com"; + "b_astuti@telkomsel.co.id"; + "garudawisata@indo.net.id"; + "grfurniture@yahoo.com"; + "gosyen2000@hotmail.com"; + "hvhfood@indosat.net.id"; + "hr@astonbali.com"; + "hary@wibisono-family.com"; + "fadlycak'p@yahoo.com"; + "ida_sampurniah@telkomsel.co.id"; + "muslim-pariwisata-bali@yahoogroups.com"; + "harisnira@yahoo.com"; + "sales@houseofbali.com"; + "baim_ron@yahoo.com"; + "ilhambali222@yahoo.com"; + "bungjon@gmail.com"; + "diar@bdg.centrin.net.id"; + "elmienruge@hotmail.com"; + "galaxygarden2006@yahoo.com"; + "gorisata@indosat.net.id"; + "maulitasarihani@yahoo.com"; + "hamiluddakwah@gmail.com.au"; + "bounty@indo.net.id,"; + "michi@ritzcarlton-bali.com,"; + "orridor@dps.centrin.net.id,"; + "ngumina@hotmail.com,"; + "made@mas-travel.com,"; + "evi@mas-travel.com,"; + "wibawa@mas-travel.com,"; + "saihubaly@yahoo.co.id,"; + "swa_candra@yahoo.com,"; + "picapica@denpasar.wasantara.net.id,"; + "griyasantrian@santrian.com,"; + "yuni6671@gmail.com,"; + "phbalichef@indo.net.id,"; + "vendra@keratonjimbaranresort.com,"; + "bali@pansea.com,"; + "sales@legianbeachbali.com,"; + "purchasing@meliabali.com,"; + "swacandra@telkom.net,"; + "lysbeth@paintballbali.com,"; + "trvlindo@upg.mega.net.id,"; + "lim_thefaith@yahoo.com,"; + "uungtb@yahoo.com.au,"; + "vivaldil307@hotmail.com,"; + "iodakon@yahoo.co.id,"; + "reservation@pendawahotel.com,"; + "ptbon@dps.centrin.net.id,"; + "ptlamak@indosat.net.id,"; + "sculpt@indo.net.id,"; + "memedi-gwkbali@dps.centrin.net.id,"; + "info@leisuredream.com,"; + "indra_wijaya@hero.co.id,"; + "ndbconvex@bagus-discovery.com,"; + "Endro@bma-merdeka.com,"; + "wsuardana@indosat.net.id,"; + "bali@esmirada.com,"; + "BAL.Purchasing@fourseasons.com,"; + "ruby@marthatilaar-spa.com,"; + "villaseminyak@eksadata.com,"; + "sariati@sanurbeach.aerowisata.com,"; + "info@jenggala-bali.com,"; + "chef@nusaduahotel.com,"; + "info@balicateringcompany.com,"; + "moka@dps.mega.net.id,"; + "zsa@eyeview.info,"; + "winarios@indosat.net.id,"; + "project@balihai-rsort.com,"; + "vivi@kopibali.com,"; + "peninsulabali@dps.centrin.net.id,"; + "ust.july@mas-travel.com,"; + "ubud@pansea.com,"; + "ustad_july@yahoo.com,"; + "thebarbali@hotmail.com,"; + "trustbali@balidream.com,"; + "teraoka@his-bali.com,"; + "candle@dps.centrin.net.id,"; + "waterbom@denpasar.wasantara.net.id,"; + "ib.suparsa@yahoo.com,"; + "budhipra@nesiancea.com,"; + "info@kindvillabintang.com,"; + "pch@novotelbali.com,"; + "parigata@indosat.net.id,"; + "mail@grandmirage.com,"; + "ananda_resort@hotmail.com,"; + "info@risatabali.com,"; + "gwkbali@indosat.net.id,"; + "rai@gosharestaurant.com,"; + "santika@santikabali.com,"; + "sahidbl@indosat.net.id,"; + "tubanrestaurant@yahoo.com,"; + "sales@thejimbaranbali.com,"; + "info@thejimbaranbali.com,"; + "sari@bubbagumpbali.com,"; + "Winnie@grandlingga.com,"; + "juaidy_asia@yahoo.com,"; + "vicmgr@i-xplore.com,"; + "langka@theclubstore.co.id,"; + "lilakresna@ConradBali.com,"; + "wayan.atmaja@luxurycollecton.com,"; + "Cisabali@indo.net.id,"; + "garrant@indo.net.id,"; + "owenwister@yahoo.com,"; + "tiara@dps.mega.net.id,"; + "info@nzmuslim.net,"; + "yuanito.kurniawan@sea.ccamatil.com,"; + "pitamaha@indosat.net.id,"; + "yunani@theclubstore.co.id,"; + "deklis@hotmail.com,"; + "cianjur@indo.net.id,"; + "mahajayatower@hotmail.com,"; + "endra@centrin.net.id,"; + "wayan.dirayana@fourseasons.com,"; + "balinaga@dps.centrin.net.id,"; + "tiaradwt@dps.centrin.net.id,"; + "candrator@hotmail.com,"; + "altaraspa@yahoo.com,"; + "fani@clubbali.com,"; + "Itudm@dps.centrin.net.id,"; + "baliratuspa@biz.net.id,"; + "kawasspa@indosat.net.id,"; + "hatoe7@yahoo.co.jp,"; + "sales@mimpi.com,"; + "theroyal@indosat.net.id,"; + "chakra_92@yahoo.com,"; + "u_dmtdps@sosro.com,"; + "januar@citramedia.net,"; + "januar@balivisioncomp.com,"; + "admin@balivisioncomp.com,"; + "ansri@dps.mega.net.id,"; + "info@rijasaresort-villas.com,"; + "sales@komaneka.com,"; + "multigun@indo.net.id,"; + "ishwari@bagus-discovery.com,"; + "utami@bali-exoticwedding.com,"; + "putra_wirata@hotmail.com,"; + "arte@dps.centrin.net.id,"; + "hamiludd2kwah@yahoo.com.au,"; + "btu_cipluk@yahoo.com,"; + "agus@indo-journey.com,"; + "agus.winarko@gmail.com,"; + "agus.amirudin@wilmar.co.id,"; + "adamsilver@lycos.com,"; + "yayasanlaroyba@yahoo.co.id,"; + "luminaABC@hotmail.com,"; + "umasapna@coconuthomes.com,"; + "udsupradinasty@yahoo.co.id,"; + "ticketing@bagus-discovery.com,"; + "tejo@pttropical.co.id,"; + "syamklw@yahoo.com,"; + "sutiarso21@yahoo.com,"; + "silvia_maniz@yahoo.com,"; + "yenny_kurniawaty@telkomsel.co.id,"; + "lega@kramatdjatigroup.com,"; + "stadiumcafe@indonet.id,"; + "agencyfreestylebali@yahoo.com,"; + "yayaqdarma@yahoo.co.id,"; + "hanafiid@yahoo.com,"; + "ricky_dvt@yahoo.co.id,"; + "teuku_umar@binus-centre.com,"; + "flp_bali@yahoo.com,"; + "andy@ritzcarlton-bali.com,"; + "bapakbakery@dps.centrin.net.id,"; + "siddiq@teacher.com,"; + "clipper@indo.net.id,"; + "puricendana@yahoo.com,"; + "info@ripcurlschoolsurf.com,"; + "sales@ramabeachhotel.com,"; + "healing@indosat.net.id,"; + "djinaldi@yahoo.co.uk,"; + "rotary.bali.kuta@gmail.com,"; + "dadang@ma-joly.com,"; + "takenoko_bali@yahoo.co.id,"; + "hrd@novotelbali.com,"; + "purwa@kcb-tours.com,"; + "anggie.gendut@england.com,"; + "novyog@indo.net.id,"; + "reservation@meliabali.com,"; + "sales@meliabali.com,"; + "info@rkeconsulting.com,"; + "andisetiaji@abacus-ind.co.id,"; + "sales.corp@swissgrandbali.com,"; + "karsana.wirajaya@trac.astra.co.id,"; + "muliatr@indosat.net.id,"; + "nita@surfer-girl.com,"; + "diah.permana@bagus-discovery.com,"; + "purwabali@yahoo.com,"; + "oly@islandconcpets.com,"; + "info@islandconcepts.com,"; + "gag@indo.net.id,"; + "gkumala@indosat.net.id,"; + "thegardeniavillas@meliabali.com,"; + "purchasing.mgr@thelegianbali.com,"; + "info@paradisebaliholidays.com,"; + "agus.winarko@bagus-discovery.com,"; + "cozytimes26@yahoo.com,"; + "info@papua-adventures.com,"; + "lokasaribali@hotmail.com,"; + "wahana@baliforyou.com,"; + "Stephen@victuslife.com,"; + "operations@atlasbalitours.com,"; + "balicoffeeshop@hotmail.com,"; + "mayakutacentre@telkom.net,"; + "rikmawan@dps.centrin.net.id,"; + "ndbt@bagus-discovery.com,"; + "info@indographs.com,"; + "aridwan_sgb@yahoo.com,"; + "bali@atmosphere.co.id,"; + "plmgrd@indosat.net.id,"; + "balibless@padmaubud.biz,"; + "baliaura@yahoo.com,"; + "andalan@bali.net,"; + "dmandiri@indo.net.id,"; + "pernadi@rad.net.id,"; + "Tabetha@BeyondMenus.com,"; + "adityafood@yahoo.com,"; + "sarana_com@yahoo.com,"; + "pasadena@chek.com,"; + "sales@pica-pica.com,"; + "menara_fbi@hotmail.com,"; + "home_treasure@hotmail.com,"; + "aamsalim@dps.centrin.net.id,"; + "shell_enoproduction@yahoo.com,"; + "geckoleather@hotmail.com,"; + "milagro_bali@hotmail.com,"; + "gemini19id@yahoo.com,"; + "karyacargo@dps.centrin.net.id,"; + "darabali@indo.net.id,"; + "padiprada@hotmail.com,"; + "vijowiz@yahoo.com,"; + "cafejimbaran@mekarsaribali.com,"; + "isnamks@yahoo.com,"; + "sales@allseasonslegian.com,"; + "chitra@cangguclub.com,"; + "cheriaM@xl.co.id,"; + "geo-trek@dps.centrin.net.id,"; + "sales@balipasadena.com,"; + "sales@villahening.com,"; + "fc@novotelbali.com,"; + "maolbing83@yahoo.co.id,"; + "info@dimensitropika.com,"; + "news@tabloidpiknik.com,"; + "mediacentre@bali-tourism.com,"; + "bioland-bali@telkom.net,"; + "glf-bali@indo.net.id,"; + "info@asiabali.com,"; + "takanit@yahoo.com,"; + "jamal@hrbc-bali.co.id,"; + "naniek@alilahotels.com,"; + "ndbtdps@dps.mega.net.id,"; + "mbcbali_jaka@yahoo.com,"; + "masnyonya@telkom.net,"; + "merrystravel@dps.centrin.net.id,"; + "mail@baliintermedia.com,"; + "mitrakridamandiri@hotmail.com,"; + "kartikaplz@denpasar.wasantara.net.id,"; + "oedps@indosat.net.id,"; + "jalirest@indosat.net.id,"; + "jenni_hartatik@interconti.com,"; + "info@alamkulkul.com,"; + "info@aggacitta.com,"; + "info@jasatours.com,"; + "iskandar.Liemena@idn.xerox.com,"; + "info@lorinresortsababai.com,"; + "ketutsukarta@telkom.net,"; + "renata.hutasoit@hyattintl.com,"; + "sukiato@hotelpadma.com,"; + "salesser@idola.net.id,"; + "sales@bali-clubaqua.com,"; + "sales@amandaresort.com,"; + "sales@balimandira.com,"; + "reservation@ramacandidasahotel.com,"; + "reservation@puriwulandari.net,"; + "nathanhotel@eksadata.com,"; + "rudi_chandra@kartikaplaza.co.id,"; + "ndcmdo@indosat.net.id,"; + "reservation@ramayanahotel.com,"; + "paradiso_bowlingbilliard@hotmail.com,"; + "perdana@balioffice.com,"; + "putribali@denpasar.wasantara.net.id,"; + "psmovers@indo.net.id,"; + "ops@thebale.com,"; + "hapsar@burung.org,"; + "ramayana@dps.mega.net.id,"; + "securanto@yahoo.com,"; + "info@villakendil.com,"; + "reservation@mpkm.co.id,"; + "info@armaresort.com,"; + "sales@balihaicruises.com,"; + "warsaubud@hotmail.com,"; + "bali_promo@plasa.com,"; + "gratindo@hotmail.com,"; + "rupadhatu89@yahoo.co.uk,"; + "info@balivillage.com,"; + "info@tomahouse.com,"; + "sales.ta@swissgrandbali.com,"; + "baliwastafel@yahoo.com,"; + "product.dps@marintur.co.id,"; + "marindps@indo.net.id,"; + "operation@cnptours.com,"; + "panoramahtl@indo.net.id,"; + "pru@indo.net.id,"; + "balivillage@indo.net.id,"; + "huzni@holidayvilla.com,"; + "info@balibmrdive.com,"; + "gadis0381@yahoo.com,"; + "info@balijazzfestival.com,"; + "triple_ebali@yahoo.com,"; + "pimage@indosat.net,"; + "kikuyaart@yahoo.com,"; + "polystar@cbn.net.id,"; + "devie@mpkm.co.id,"; + "duasisi@indo.net.id,"; + "info@palanquinbali.com,"; + "dhvbali@indosat.net.id,"; + "hussain@indo.net.id,"; + "orientalrugs_imsharif@hotmail.com,"; + "utut-irawan@ramayanahotel.com,"; + "randd98@hotmail.com,"; + "purbasari@divre7.telkom.co.id,"; + "mobnas_intim@indo.net.id,"; + "dwilasmin@yahoo.com,"; + "info@downtownbali.com,"; + "info@hotellumbung.com,"; + "info@balitonys.com,"; + "info@thevillas.net,"; + "reservation@the-dusun.com,"; + "info@theahimsa.com,"; + "info@sienna-villas.com,"; + "sababai@indosat.net.id,"; + "sales@putubalivilla.com,"; + "sales@akhyativillas.com,"; + "desamuda@indosat.net.id,"; + "reservation@amandaresort.com,"; + "info@alubali.com,"; + "vilarm@indo.net.id,"; + "intansalesbali@intanhotels.com,"; + "info@theoberoi-bali.com,"; + "legian@ghmhotels.com,"; + "reservation@rakharismavilla.com,"; + "wakagangga@wakaexperience.com,"; + "awing-awang@balivision.com,"; + "info@segaravillage.com,"; + "nsindhu@denpasar.wasantara.net.id,"; + "besakih@indosat.net.id,"; + "reservation@sanur.pphotels.com,"; + "info@santrian.com,"; + "info@sanurbeach.aerowisata.com,"; + "info@villaaya.com,"; + "balihyatt.inquiries@hyattintl.com,"; + "sales@coconuthomes.com,"; + "reservation@nirwanabaliresort.com,"; + "sales@balimeridien.com,"; + "bali@tuguhotels.com,"; + "villa_kharista@hommsindonesia.com,"; + "surgavillas@dps.centrin.net.id,"; + "gm@canggu.com,"; + "info@legianparadisohotel.com,"; + "sales@grand-balibeach.com,"; + "info@bintang-bali-hotel.com,"; + "sales.bali@saphir-hotels.com,"; + "rock@hardrockhotels.net,"; + "info@thevirabali.com,"; + "inrisata@indosat.net.id,"; + "reservation@ramabeachhotel.com,"; + "sales@jatra.com,"; + "reservation@balidynasty.com,"; + "infoadmin@mercurekutabali.com,"; + "reservation.bali@patra-jasa.com,"; + "sales@ramayanahotel.com,"; + "info@kutaparadisohotel.com,"; + "reservation@discoverykartikaplza.com,"; + "info@bluepointbayvillas.com,"; + "bcr@indosat.net.id,"; + "sales@pat-mase.com,"; + "fsrb@fourseasons.com,"; + "info@keratonjimbaranresort.com,"; + "reservation@balihai-resort.com,"; + "reservation@hotelpadma.com,"; + "adeboer@alilahotels.com,"; + "sales@kutalagoonresort.com,"; + "sales@courtyard-bali.com,"; + "balisani@indo.net.id,"; + "sales@baliholidayresort.net,"; + "sales@adhidharmahotel.com,"; + "info@whiterose.co.id,"; + "nkutabh@indosat.net.id,"; + "jhrbali@indo.net.id,"; + "rgarden@indosat.net.id,"; + "winacott@indosat.net.id,"; + "info@theoasis.info,"; + "reservation@kutaseaviewhotel.com,"; + "kbchotel@indosat.net.id,"; + "info@harris-kuta-bali.com,"; + "reservation@grandistanarama.com,"; + "sales@sahidrayabali.com,"; + "sales@pelangibali.com,"; + "info@jayakarta-lombok.com,"; + "info@hotelombak.com,"; + "hotel@novotel-lombok.com,"; + "lombokraya_htl@telkom.net,"; + "info@theoberoi-lombok.com,"; + "stay@quncivillas.com,"; + "info@poovillaclub.aerowisata.com,"; + "wakamaya@wakaexperience.com,"; + "info@senggigibeach.aerowisata.com"; + "alfabeta_ba@yahoo.com,"; + "lombok@intanhotels.com,"; + "hirlo@mataram.wasantara.net.id,"; + "sales.senggigi@sheraton.com,"; + "tulamben@mimpi.com,"; + "waterg@dps.centrin.net.id,"; + "puribaguscandidasa@bagus-dscovery.com,"; + "ramacan@denpasar,wasantara.net.id,"; + "p_saron@indo.net.id,"; + "itha@ripcurl.co.id,"; + "pwilantari@anantara.com,"; + "novie@base.co.id,"; + "manager@annorabali.com,"; + "luh_g_astitiningsih@telkomsel.co.id,"; + "kesuma.putra@kasihibuhospital.com,"; + "frisa.andarina@kasihibuhospital.com,"; + "cok.wijaya@sampoerna.com,"; + "hamartapartners@yahoo.com,"; + "mudita@indosat.com,"; + "info@phoenixgraha.com,"; + "Ni.Wiratni@sampoerna.com,"; + "budi.wiadnyana@trac.astra.co.id,"; + "Budi.Yasa@sampoerna.com,"; + "purnama.dewi@kasihibuhospital.com,"; + "david.clark5@btinternet.com"; + "manager@mibank.com"; + "reserv@nusa-lembongan.com,"; + "awinarta@anantara.com,"; + "info@sulyresort.com,"; + "sales@candibeachbali.com,"; + "sales@kamandaluresort.com,"; + "sales@ibahbali.com,"; + "bumiubud@dps.centrin.net.id,"; + "sales@barong-resort.com,"; + "info@bagusjati.com,"; + "wakapadma@wakaexperience.com,"; + "komaneka@indosat.net.id,"; + "tjampuan@indo.net.id,"; + "sales@koriubud.com,"; + "sahadewa@dps.centrin.net.id,"; + "pertiwi@indosat.net.id,"; + "kumarasakti@dps.centrin.net.id,"; + "chamsari@indosat.net,"; + "info@cahayadewatahotel.com,"; + "payogan@indosat.net.id,"; + "info@mayaubud.com,"; + "wakadiume@wakaexperience.com,"; + "balipacung@telkom.net,"; + "reservation@wantilangolfvillas.com,"; + "sales@bali-activities.com,"; + "wakanusa@wakaexperience.com,"; + "twfv@dps.centrin.net.id,"; + "menjangan@mimpi.com,"; + "wakashorea@wakaexperience.com,"; + "mbr-bali@indo.net.id,"; + "kayumanis@baliprivatevilla.com,"; + "resort@damai.com,"; + "apummer@alilahotels.com,"; + "sales@balihandarakosaido.com,"; + "bali@purisaron.com,"; + "sales@alampurivilla.com,"; + "info@villasemana.com,"; + "home@themansionbali.com,"; + "info@santimandalaresort.com,"; + "natura@indosat.net.id,"; + "puribaguslovina@bagus-discovery.com,"; + "agustiansyah@takaful.com,"; + "dewimoes@yahoo.com,"; + "denie@bigfoot.com,"; + "deden@bali-exoticwedding.com,"; + "deddydiva@yahoo.com,"; + "budivirgono@yahoo.co.id,"; + "budi@bmnlawoffice.info,"; + "ritzbc@indosat.net.id,"; + "eurobali@indosat.net.id,"; + "neginohige@hotmail.com,"; + "waow_one@yahoo.co.id,"; + "rini_wulandari1970@yahoo.co.id,"; + "priharyati@itpc.or.jp,"; + "kucing_puri@yahoo.co.jp,"; + "fadlycakp@yahoo.com,"; + "eh_juniadi@yahoo.com,"; + "balibusser@yahoo.com,"; + "bayu@bmnlawoffice.info,"; + "hanifah@bniaga.co.id,"; + "bali@indomultimedia.co.id,"; + "ary@balidestinationtravel.com,"; + "admin@sectorbarrestaurant.com,"; + "gendut@england.com,"; + "novyog@indo.net.id,anggie,"; + "amin@paradisebaliholidays.com,"; + "leebahri@yahoo.com,"; + "info@dsmbali.or.id,"; + "heni@bali-exoticwedding.com,"; + "zakat_bali@yahoo.com,"; + "tothesolo@yahoo.com,"; + "hardwoodindonesia@yahoo.com,"; + "fuay@yahoo.com,"; + "fuay@walla.com,"; + "ef_architect@yahoo.com,"; + "ennymei@telkom.net,"; + "wulandari@firststatebali.com,"; + "ihwan@pollowindonesia.com,"; + "haryo.santoso@trac.astra.co.id,"; + "andrie.yudhianto@gmail.com,"; + "fidiyono_bali@yahoo.com,"; + "fauzantan@yahoo.com,"; + "faisal_silin@yahoo.com,"; + "elkahiri@yahoo.co.id,"; + "bernitha_widinansari@yahoo.co.id,"; + "a6us_kurniawan@yahoo.co.id,"; + "itha_ersita@yahoo.com,"; + "elly@pantravel.co.id,"; + "iva@nikkobali.com,"; + "elly@intrareps.com,"; + "sbtours@indosat.net.id,"; + "wisantaradps@yahoo.com,"; + "jawi@dps.centrin.net.id,"; + "info@baliadventuretours.com,"; + "alampuri@resortgallery.com,"; + "beauty_rahma@yahoo.com,"; + "dsartika@internux.net.id,"; + "sri.hadibudi@bagus-discovery.com,"; + "freddy@bali-tourism-board.com,"; + "wiwid@ripcurl.co.id,"; + "ratna.wijayanti@aig.com,"; + "nurnirwan@yahoo.com,"; + "grandjv@indo.net.id,"; + "bukitpratama@yahoo.com,"; + "awie_kasasi@yahoo.com,"; + "gdiezzmewth@yahoo.co.id,"; + "gandjar@earthling.net,"; + "cubenenni@yahoo.com,"; + "rani@bluepointbayvillas.com,"; + "preman_surabaya3@yahoo.com,"; + "nenyjon77@yahoo.com,"; + "mf_ulfa@yahoo.com,"; + "meutyahafid@yahoo.com,"; + "mayanto@yahoo.com,"; + "marketing@balivisioncomputer.com,"; + "alwin007@yahoo.com,"; + "nathansugiarto@yahoo.com"; + "dianpuri69@yahoo.com,"; + "sales@astonbali.com,"; + "ngurah_rai56@yahoo.com"; + "herjun_jp@yahoo.co.id,"; + "zip_fmmaros@yahoo.com,"; + "icendol@yahoo.com,"; + "nediarjuliadi@yahoo.com,"; + "info@novotelbali.com,"; + "w_promoplus@yahoo.com"; + "salesrrb@indosat.net.id,"; + "phio_19@yahoo.com"; + "marinasenggigi@yahoo.co.id"; + "iik_young@yahoo.com"; + "igmastika@idp.co.id"; + "hnry_stwn@yahoo.com"; + "aulFrancisKacingenta_39@yahoo.com"; + "bit_bali@yahoo.com,"; + "gunawanpnj@yahoo.com,"; + "baligh.inquires@hyattintl.com,"; + "balihai@q-net.net.id,"; + "bliss@thebale.com,"; + "info@villasekarnusadua.com,"; + "balidesa@indosat.net.id,"; + "info@swiss-bellhotel-baliaga.com,"; + "thewestinresortbali@westin.com,"; + "sheraton.laguna@luxurycollection.com,"; + "melia.benoa@solmelia.com,"; + "sales@nikkobali.com,"; + "btbbtbfauzanbabijanuitem_jelut@yahoo.com,"; + "info@balihilton.com,"; + "balireef@balireef-resort.com,"; + "vl_bintang@denpasar.wasantara.net.id,"; + "ptanjung@indo.net.id,"; + "pbenoa@denpasar.wasantara.net.id,"; + "suites@baliroyal.com,"; + "cbmrsv@indosat.net.id,"; + "sales@nusaduahotel.com,"; + "evi@discountvoucherbooklet.com,"; + "Malelakfauzansubandi@yahoo.co.id,"; + "koko_dic@yahoo.com,"; + "yusyunikamiyani@yahoo.com,"; + "widya.Riani@hrdap.mail.a.rd.honda.co.jp,"; + "novita_vasiska@yahoo.com,"; + "ngk-jkt4@cbn.net.id,"; + "lies@wika-ngk.co.id,"; + "mulyadi_kbi@yahoo.co.id,"; + "dutaos@telkom.net,"; + "neoazuma@yahoo.co.id,"; + "ikmar@citra.co.id,"; + "t_hadi_g@cp.co.id,"; + "chandra@mailcda.com,"; + "nina@mailcda.com,"; + "rsuryamega@3selaras.com,"; + "petrgilx@yahoo.co.uk,"; + "bali@interconti.com,"; + "rputra@pardic.co.id,"; + "steven_dp@yahoo.com,"; + "bevan@bahanagv.co.id"; + "balikita1@yahoo.com"; + "aguswiguna@yahoo.co.id,"; + "eddy@mgholiday.com,"; + "widiaharika@yahoo.com,"; + "srilestari@mycondradbali.com,"; + "dsujatha@indosat.net.id,"; + "clate.m@infusionsoft.com,"; + "stevenbali@hotmail.com,"; + "info@bali-tourism-board.com,"; + "trauining@triatma-mapindo.ac.id,"; + "rosariyanti@xl.co.id,"; + "mgr_eo@yahoo.co.id,"; + "missd@bigpond.net.au,"; + "getanjali.anand@seejobs.org,"; + "gus_krisna@yahoo.com"; + "tazgirls_2512@yahoo.com,"; + "santhiarsa@yahoo.com,"; + "dmsbali@yahoo.com,"; + "andri_budiarto@multibintang.co.id,"; + "Wiboko_rinarto@telkomsel.co.id,"; + "caracraft@hotmail.com,"; + "plastic_centre_sanur@hotmail.com,"; + "sandangjaya@yahoo.com,"; + "assa_tour@yahoo.com,"; + "zefanya_production@hotmail.com,"; + "etha@dps.centrin.net.id,"; + "kewayang@dps.centrin.net.id,"; + "pahalakencana@dps.centrin.net.id,"; + "balipermata@telkom.net,"; + "ops@thebale.com"; + "sales@amandaresort.com"; + "kartikaplz@denpasar.wasantara.net.id"; + "ketutsukarta@telkom.net"; + "mail@baliintermedia.com"; + "merrystravel@dps.centrin.net.id"; + "masnyonya@telkom.net"; + "mbcbali_jaka@yahoo.com"; + "ndbtdps@dps.mega.net.id"; + "naniek@alilahotels.com"; + "nathanhotel@eksadata.com"; + "jalirest@indosat.net.id"; + "oedps@indosat.net.id"; + "jenni_hartatik@interconti.com"; + "psmovers@indo.net.id"; + "putribali@denpasar.wasantara.net.id"; + "perdana@balioffice.com"; + "paradiso_bowlingbilliard@hotmail.com"; + "reservation@ramayanahotel.com"; + "renata.hutasoit@hyattintl.com"; + "rudi_chandra@kartikaplaza.co.id"; + "ramayana@dps.mega.net.id"; + "reservation@puriwulandari.net"; + "reservation@ramacandidasahotel.com"; + "wibawa@mas-travel.com"; + "ndcmdo@indosat.net.id"; + "pimage@indosat.net"; + "mobnas_intim@indo.net.id"; + "purbasari@divre7.telkom.co.id"; + "randd98@hotmail.com"; + "utut-irawan@ramayanahotel.com"; + "orientalrugs_imsharif@hotmail.com"; + "hussain@indo.net.id"; + "dhvbali@indosat.net.id"; + "huzni@holidayvilla.com"; + "duasisi@indo.net.id"; + "dwilasmin@yahoo.com"; + "jamal@hrbc-bali.co.id"; + "kikuyaart@yahoo.com"; + "sales@bali-clubaqua.com"; + "triple_ebali@yahoo.com"; + "info@balijazzfestival.com"; + "gadis0381@yahoo.com"; + "hapsar@burung.org"; + "info@palanquinbali.com"; + "info@villakendil.com"; + "info@lorinresortsababai.com"; + "iskandar.Liemena@idn.xerox.com"; + "info@jasatours.com"; + "info@aggacitta.com"; + "info@alamkulkul.com"; + "polystar@cbn.net.id"; + "santika@santikabali.com"; + "sales@balimandira.com"; + "info@thejimbaranbali.com"; + "sales@thejimbaranbali.com"; + "tubanrestaurant@yahoo.com"; + "ib.suparsa@yahoo.com"; + "vicmgr@i-xplore.com"; + "info@risatabali.com"; + "ananda_resort@hotmail.com"; + "parigata@indosat.net.id"; + "pch@novotelbali.com"; + "Winnie@grandlingga.com"; + "BAL.Purchasing@fourseasons.com"; + "juaidy_asia@yahoo.com"; + "sariati@sanurbeach.aerowisata.com"; + "purchasing@meliabali.com"; + "sales@legianbeachbali.com"; + "bali@pansea.com"; + "vendra@keratonjimbaranresort.com"; + "phbalichef@indo.net.id"; + "yuni6671@gmail.com"; + "griyasantrian@santrian.com"; + "bounty@indo.net.id"; + "swa_candra@yahoo.com"; + "swacandra@telkom.net"; + "info@kindvillabintang.com"; + "vivi@kopibali.com"; + "salesser@idola.net.id"; + "sukiato@hotelpadma.com"; + "stadiumcafe@indonet.id"; + "trvlindo@upg.mega.net.id"; + "thegardeniavillas@meliabali.com"; + "teraoka@his-bali.com"; + "trustbali@balidream.com"; + "thebarbali@hotmail.com"; + "ustad_july@yahoo.com"; + "ubud@pansea.com"; + "sari@bubbagumpbali.com"; + "villaseminyak@eksadata.com"; + "devie@mpkm.co.id"; + "waterbom@denpasar.wasantara.net.id"; + "winarios@indosat.net.id"; + "zsa@eyeview.info"; + "moka@dps.mega.net.id"; + "matt.lloyd@roamfree.com"; + "info@balicateringcompany.com"; + "chef@nusaduahotel.com"; + "info@jenggala-bali.com"; + "gwkbali@indosat.net.id"; + "project@balihai-rsort.com"; + "peninsulabali@dps.centrin.net.id"; + "ust.july@mas-travel.com"; + "ndbt@bagus-discovery.com"; + "info@tomahouse.com"; + "info@paradisebaliholidays.com"; + "agus.winarko@bagus-discovery.com"; + "cozytimes26@yahoo.com"; + "info@papua-adventures.com"; + "lokasaribali@hotmail.com"; + "plmgrd@indosat.net.id"; + "Stephen@victuslife.com"; + "gkumala@indosat.net.id"; + "balicoffeeshop@hotmail.com"; + "dmandiri@indo.net.id"; + "rikmawan@dps.centrin.net.id"; + "pernadi@rad.net.id"; + "info@indographs.com"; + "aridwan_sgb@yahoo.com"; + "sales.corp@swissgrandbali.com"; + "operations@atlasbalitours.com"; + "wahana@baliforyou.com"; + "hrd@novotelbali.com"; + "purwa@kcb-tours.com"; + "anggie.gendut@england.com"; + ] + in let th0 = let open Part in let* res = create (Fpath.to_string path) in match res with | Error (`Msg err) -> Alcotest.failf "%s." err | Ok () -> - let* () = open_index writer ~path:(Fpath.to_string path) in - let rec go0 idx = function - | [] -> return () - | key :: r -> - let* _ = insert (Rowex.key key) idx in - go0 (succ idx) r in - let* _ = go0 0 elts in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) - let* _ = insert (Rowex.key "novyog@indo.net.id") (-1) in - (* let reporter = Logs.reporter () in - Logs.set_reporter Logs.nop_reporter ; - Fmt.epr "%a\n%!" Part.pp state ; - Logs.set_reporter reporter ; *) - let* v' = find (Rowex.key "novyog@indo.net.id") in - Alcotest.(check int) "novyog@indo.net.id" v' (-1) ; - let rec go1 idx = function - | [] -> close - | key :: r -> - let* v' = find (Rowex.key key) in - Alcotest.(check int) key v' idx ; - go1 (succ idx) r in - go1 0 elts in + let* () = open_index writer ~path:(Fpath.to_string path) in + let rec go0 idx = function + | [] -> return () + | key :: r -> + let* _ = insert (Rowex.key key) idx in + go0 (succ idx) r + in + let* _ = go0 0 elts in + let* _ = insert (Rowex.key "novyog@indo.net.id") (-1) in + let* v' = find (Rowex.key "novyog@indo.net.id") in + Alcotest.(check int) "novyog@indo.net.id" v' (-1); + let rec go1 idx = function + | [] -> close + | key :: r -> + let* v' = find (Rowex.key key) in + Alcotest.(check int) key v' idx; + go1 (succ idx) r + in + go1 0 elts + in match Part.(run closed th0) with | _closed, () -> () - | exception Rowex.Duplicate -> Alcotest.failf "Insert a duplicate into the index" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" | exception Not_found -> Alcotest.failf "Key not found" +let test11 = + Alcotest.test_case "test11" `Quick @@ fun path -> + let state = state_of_optional_path path in + let th0 = + let open Part in + let* _ = insert (Rowex.key "abc") 1 in + let* _ = insert (Rowex.key "ab") 2 in + let* _ = insert (Rowex.key "abcde") 3 in + let* _ = remove (Rowex.key "abcde") in + find (Rowex.key "abcde") + in + match Part.run state th0 with + | _not_closed, _ -> Alcotest.failf "Unexpected good process" + | exception Rowex.Duplicate -> + Alcotest.failf "Insert a duplicate into the index" + | exception Not_found -> () + open Cmdliner let filename = - let parser x = match Fpath.of_string x with - | Ok v when not (Sys.file_exists x) -> - ( match Part.(run closed (create (Fpath.to_string v))) with - | _closed, Ok () -> Ok (Fpath.to_string v) - | _closed, Error err -> Error err ) + let parser x = + match Fpath.of_string x with + | Ok v when not (Sys.file_exists x) -> ( + match Part.(run closed (create (Fpath.to_string v))) with + | _closed, Ok () -> Ok (Fpath.to_string v) + | _closed, Error err -> Error err) | Ok v -> Rresult.R.error_msgf "%a already exists" Fpath.pp v - | Error _ as err -> err in + | Error _ as err -> err + in let pp ppf _ = Fmt.pf ppf "#index" in Arg.conv (parser, pp) @@ -1940,5 +1977,21 @@ let filename = let doc = "The persistent index file." in Arg.(value & opt (some filename) None & info [ "index" ] ~doc) -let () = Alcotest.run_with_args "rowex" filename - [ "simple", [ test01; test02; test03; test04; test05; test06; test07; test08; test09; test10 ] ] +let () = + Alcotest.run_with_args "rowex" filename + [ + ( "simple", + [ + test01; + test02; + test03; + test04; + test05; + test06; + test07; + test08; + test09; + test10; + test11; + ] ); + ] diff --git a/test/ring.ml b/test/ring.ml index a3b638e..c7ab7e3 100644 --- a/test/ring.ml +++ b/test/ring.ml @@ -22,96 +22,106 @@ let size_of_word = Sys.word_size / 8 let create ~order filename = let len = Ringbuffer.size_of_order order in - let fd = Unix.openfile filename Unix.[ O_CREAT; O_RDWR ] 0o644 in - let _ = Unix.lseek fd len Unix.SEEK_SET in - let memory = Mmap.V1.map_file fd ~pos:0L Bigarray.int Bigarray.c_layout true [| len |] in + let fd = Unix.openfile filename Unix.[ O_CREAT; O_RDWR ] 0o644 in + let _ = Unix.lseek fd len Unix.SEEK_SET in + let memory = + Mmap.V1.map_file fd ~pos:0L Bigarray.int Bigarray.c_layout true [| len |] + in let memory = Bigarray.array1_of_genarray memory in let memory = to_memory memory in - atomic_set_leuintnat memory (size_of_word * 0) Seq_cst 0 ; - atomic_set_leuintnat memory (size_of_word * 1) Seq_cst 0 ; - atomic_set_leuintnat memory (size_of_word * 2) Seq_cst (-1) ; + atomic_set_leuintnat memory (size_of_word * 0) Seq_cst 0; + atomic_set_leuintnat memory (size_of_word * 1) Seq_cst 0; + atomic_set_leuintnat memory (size_of_word * 2) Seq_cst (-1); for i = 0 to (1 lsl ((order :> int) + 1)) - 1 do atomic_set_leuintnat memory (size_of_word * (3 + i)) Seq_cst (-1) - done ; + done; Unix.close fd let load ~order filename = let filename = Fpath.to_string filename in let len = Ringbuffer.size_of_order order in - let fd = Unix.openfile filename Unix.[ O_CREAT; O_RDWR ] 0o644 in - let _ = Unix.lseek fd len Unix.SEEK_SET in - let memory = Mmap.V1.map_file fd ~pos:0L Bigarray.int Bigarray.c_layout true [| len |] in + let fd = Unix.openfile filename Unix.[ O_CREAT; O_RDWR ] 0o644 in + let _ = Unix.lseek fd len Unix.SEEK_SET in + let memory = + Mmap.V1.map_file fd ~pos:0L Bigarray.int Bigarray.c_layout true [| len |] + in let memory = Bigarray.array1_of_genarray memory in let memory = to_memory memory in - fd, memory + (fd, memory) let order = Ringbuffer.order_of_int 15 let zero = Addr.of_int_rdwr 0 -let random_filename = Lazy.from_fun @@ fun () -> +let random_filename = + Lazy.from_fun @@ fun () -> let filename = Rresult.R.failwith_error_msg (Bos.OS.File.tmp "ring-%s") in - create ~order (Fpath.to_string filename) ; filename + create ~order (Fpath.to_string filename); + filename let load ~order = function | Some filename -> load ~order filename | None -> load ~order (Lazy.force random_filename) let push ring v = rrun ring Ringbuffer.(enqueue ~order ~non_empty:false zero v) -let pop ?(non_empty= false) ring = rrun ring Ringbuffer.(dequeue ~order ~non_empty zero) -let peek ?(non_empty= false) ring = rrun ring Ringbuffer.(peek ~order ~non_empty zero) + +let pop ?(non_empty = false) ring = + rrun ring Ringbuffer.(dequeue ~order ~non_empty zero) + +let peek ?(non_empty = false) ring = + rrun ring Ringbuffer.(peek ~order ~non_empty zero) let test01 = Alcotest.test_case "test01" `Quick @@ fun filename -> let fd, ring = load ~order filename in - push ring 1 ; - push ring 2 ; - push ring 3 ; - push ring 4 ; - Alcotest.(check int) "1" (pop ring) 1 ; - Alcotest.(check int) "2" (pop ring) 2 ; - Alcotest.(check int) "3" (pop ring) 3 ; - Alcotest.(check int) "4" (pop ring) 4 ; + push ring 1; + push ring 2; + push ring 3; + push ring 4; + Alcotest.(check int) "1" (pop ring) 1; + Alcotest.(check int) "2" (pop ring) 2; + Alcotest.(check int) "3" (pop ring) 3; + Alcotest.(check int) "4" (pop ring) 4; Unix.close fd -;; let test02 = Alcotest.test_case "test02" `Quick @@ fun filename -> let fd, ring = load ~order filename in - push ring 1 ; - Alcotest.(check int) "1" (pop ring) 1 ; - Alcotest.(check int) "null" (pop ring) (lnot 0) ; - push ring 2 ; - Alcotest.(check int) "2" (pop ring) 2 ; - Alcotest.(check int) "null" (pop ring) (lnot 0) ; + push ring 1; + Alcotest.(check int) "1" (pop ring) 1; + Alcotest.(check int) "null" (pop ring) (lnot 0); + push ring 2; + Alcotest.(check int) "2" (pop ring) 2; + Alcotest.(check int) "null" (pop ring) (lnot 0); Unix.close fd -;; let test03 = Alcotest.test_case "test03" `Quick @@ fun filename -> let fd, ring = load ~order filename in - push ring 1 ; - Alcotest.(check int) "1" (peek ring) 1 ; - push ring 2 ; - Alcotest.(check int) "1" (peek ring) 1 ; - push ring 3 ; - Alcotest.(check int) "1" (peek ring) 1 ; - Alcotest.(check int) "1" (pop ring) 1 ; - Alcotest.(check int) "2" (peek ring) 2 ; - Alcotest.(check int) "2" (pop ring) 2 ; - Alcotest.(check int) "3" (peek ring) 3 ; - Alcotest.(check int) "3" (pop ring) 3 ; - Alcotest.(check int) "null" (peek ring) (lnot 0) ; + push ring 1; + Alcotest.(check int) "1" (peek ring) 1; + push ring 2; + Alcotest.(check int) "1" (peek ring) 1; + push ring 3; + Alcotest.(check int) "1" (peek ring) 1; + Alcotest.(check int) "1" (pop ring) 1; + Alcotest.(check int) "2" (peek ring) 2; + Alcotest.(check int) "2" (pop ring) 2; + Alcotest.(check int) "3" (peek ring) 3; + Alcotest.(check int) "3" (pop ring) 3; + Alcotest.(check int) "null" (peek ring) (lnot 0); Unix.close fd -;; open Cmdliner let filename = - let parser x = match Fpath.of_string x with + let parser x = + match Fpath.of_string x with | Ok v when not (Sys.file_exists x) -> - create ~order (Fpath.to_string v) ; Ok v + create ~order (Fpath.to_string v); + Ok v | Ok v -> Rresult.R.error_msgf "%a already exists" Fpath.pp v - | Error _ as err -> err in + | Error _ as err -> err + in let pp ppf _ = Fmt.pf ppf "#ring" in Arg.conv (parser, pp) @@ -119,5 +129,6 @@ let filename = let doc = "The persistent ring file." in Arg.(value & opt (some filename) None & info [ "ring" ] ~doc) -let () = Alcotest.run_with_args "ring" filename - [ "simple", [ test01; test02; test03 ] ] +let () = + Alcotest.run_with_args "ring" filename + [ ("simple", [ test01; test02; test03 ]) ] diff --git a/test/test.ml b/test/test.ml index 0ca4c45..fba5738 100644 --- a/test/test.ml +++ b/test/test.ml @@ -3,192 +3,223 @@ let () = Printexc.record_backtrace true let test01 = Alcotest.test_case "test01" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "") 0 ; + Art.insert tree (Art.key "") 0; Art.insert tree (Art.key "") 1 -;; let test02 = Alcotest.test_case "test02" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "") 0 ; - Art.insert tree (Art.key "\042") 1 ; - Art.insert tree (Art.key "") 2 ; + Art.insert tree (Art.key "") 0; + Art.insert tree (Art.key "\042") 1; + Art.insert tree (Art.key "") 2; let res = Art.find_opt tree (Art.key "toto") in Alcotest.(check (option int)) "res" res None -;; let test03 = Alcotest.test_case "test03" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "") 0 ; - Art.insert tree (Art.key "\042") 1 ; + Art.insert tree (Art.key "") 0; + Art.insert tree (Art.key "\042") 1; let res0 = Art.find_opt tree (Art.key "") in let res1 = Art.find_opt tree (Art.key "toto") in - Alcotest.(check (option int)) "res0" res0 (Some 0) ; + Alcotest.(check (option int)) "res0" res0 (Some 0); Alcotest.(check (option int)) "res1" res1 None -;; let test04 = Alcotest.test_case "test04" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "") 1 ; - Art.insert tree (Art.key "[\128") 2 ; - Art.insert tree (Art.key "") 3 ; - Art.insert tree (Art.key "\025\025\b7\025\128") 4 ; + Art.insert tree (Art.key "") 1; + Art.insert tree (Art.key "[\128") 2; + Art.insert tree (Art.key "") 3; + Art.insert tree (Art.key "\025\025\b7\025\128") 4; let res = Art.find_opt tree (Art.key "\003") in Alcotest.(check (option int)) "res" res None -;; let test05 = Alcotest.test_case "test05" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "toto") 1 ; - Art.insert tree (Art.key "") 2 ; - Art.insert tree (Art.key "titi") 3 ; - Art.insert tree (Art.key "") 4 ; + Art.insert tree (Art.key "toto") 1; + Art.insert tree (Art.key "") 2; + Art.insert tree (Art.key "titi") 3; + Art.insert tree (Art.key "") 4; let res0 = Art.find_opt tree (Art.key "toto") in let res1 = Art.find_opt tree (Art.key "") in let res2 = Art.find_opt tree (Art.key "titi") in - Alcotest.(check (option int)) "res0" res0 (Some 1) ; - Alcotest.(check (option int)) "res1" res1 (Some 4) ; + Alcotest.(check (option int)) "res0" res0 (Some 1); + Alcotest.(check (option int)) "res1" res1 (Some 4); Alcotest.(check (option int)) "res2" res2 (Some 3) -;; let test06 = Alcotest.test_case "test06" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "toto") 1 ; - Art.insert tree (Art.key "tutu") 2 ; - Art.insert tree (Art.key "titi") 3 ; - Art.insert tree (Art.key "") 4 ; + Art.insert tree (Art.key "toto") 1; + Art.insert tree (Art.key "tutu") 2; + Art.insert tree (Art.key "titi") 3; + Art.insert tree (Art.key "") 4; let res0 = Art.find_opt tree (Art.key "toto") in let res1 = Art.find_opt tree (Art.key "tutu") in let res2 = Art.find_opt tree (Art.key "titi") in let res3 = Art.find_opt tree (Art.key "") in - Alcotest.(check (option int)) "res0" res0 (Some 1) ; - Alcotest.(check (option int)) "res1" res1 (Some 2) ; - Alcotest.(check (option int)) "res2" res2 (Some 3) ; + Alcotest.(check (option int)) "res0" res0 (Some 1); + Alcotest.(check (option int)) "res1" res1 (Some 2); + Alcotest.(check (option int)) "res2" res2 (Some 3); Alcotest.(check (option int)) "res3" res3 (Some 4) -;; let test07 = Alcotest.test_case "test07" `Quick @@ fun () -> let tree = Art.make () in let res0 = Art.find_opt tree (Art.key "") in - Art.insert tree (Art.key "\241\241") 1 ; - Art.insert tree (Art.key "\241\241\003\232") 2 ; + Art.insert tree (Art.key "\241\241") 1; + Art.insert tree (Art.key "\241\241\003\232") 2; Alcotest.(check (option int)) "res0" res0 None -;; let test08 = Alcotest.test_case "test08" `Quick @@ fun () -> let tree = Art.make () in let res0 = Art.find_opt tree (Art.key "foo") in - Art.insert tree (Art.key "\251\250\250\250\250") 1 ; - Art.insert tree (Art.key "\251\250\250") 2 ; + Art.insert tree (Art.key "\251\250\250\250\250") 1; + Art.insert tree (Art.key "\251\250\250") 2; let res1 = Art.find_opt tree (Art.key "\251\250\250\250\250") in let res2 = Art.find_opt tree (Art.key "\251\250\250") in - Alcotest.(check (option int)) "res0" res0 None ; - Alcotest.(check (option int)) "res1" res1 (Some 1) ; + Alcotest.(check (option int)) "res0" res0 None; + Alcotest.(check (option int)) "res1" res1 (Some 1); Alcotest.(check (option int)) "res2" res2 (Some 2) -;; let test09 = Alcotest.test_case "test09" `Quick @@ fun () -> let tree = Art.make () in let res0 = Art.find_opt tree (Art.key "foo") in - Art.insert tree (Art.key "\185\185\001\001") 1 ; - Art.insert tree (Art.key "\185\185") 2 ; - Art.insert tree (Art.key "\185\185") 3 ; + Art.insert tree (Art.key "\185\185\001\001") 1; + Art.insert tree (Art.key "\185\185") 2; + Art.insert tree (Art.key "\185\185") 3; let res1 = Art.find_opt tree (Art.key "\185\185") in - Alcotest.(check (option int)) "res0" res0 None ; + Alcotest.(check (option int)) "res0" res0 None; Alcotest.(check (option int)) "res1" res1 (Some 3) -;; let test10 = Alcotest.test_case "test10" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "\134") 1 ; - Art.insert tree (Art.key "\021\n\135\131\2105\161=\142\028\152\006\031\188\191\201\134\194Fu\253\132\1279v_\200&\238") 2 ; - Art.insert tree (Art.key "\182\206\219:n4\156\173Mu\012\223;\215\197") 3 ; - Art.insert tree (Art.key "bG>\229") 4 ; - Art.insert tree (Art.key "[\183\191\201\169M\210\183\015oK%\252\021\187\158e\138\202\193\129\145-") 5 ; - Art.insert tree (Art.key "\191\175\151\144\012\226\211Y\182\226 +\245\153\204\002\148\149\219^4Aq\189\201\003") 6 ; - Art.insert tree (Art.key "\182\024\023\145\178\206\\wW0\138\157\223\184]\137g\031\029\"k\132") 7 ; - Art.insert tree (Art.key "'g\253s\029?\243b]l\197\197^\168\244") 8 ; - Art.insert tree (Art.key "\027^L") 9 ; - Art.insert tree (Art.key "-^\213\151") 10 ; - Art.insert tree (Art.key "\004") 11 ; - Art.insert tree (Art.key "\\\217\023\023\023\200\131\226\250\246") 12 ; - Art.insert tree (Art.key "\207\251y\235\214\164`6\017)h( \179\215]5'\151\178\208") 13 ; - Art.insert tree (Art.key "\n\209 \\\235z^\183") 14 ; - Art.insert tree (Art.key "]\218") 15 ; - Art.insert tree (Art.key "\127\252N\155\2162\145") 16 ; - Art.insert tree (Art.key "|V\232Z\210&O\234\197\229w\127O\250\154h\236\224\254") 17 ; - Art.insert tree (Art.key "A)\139\0289\017\020\194\192<\143.!") 18 ; - Art.insert tree (Art.key "\153\207e\194\027\\\128\016U") 19 ; - Art.insert tree (Art.key "\130:\228PMO;IA\253|=\169\023\031X\233\181gdx") 21 ; - Art.insert tree (Art.key "\177\144w\215\250\024\247") 22 ; - Art.insert tree (Art.key "\016\242\174\217\\\173o\134\182,}\240\193\179") 23 ; - Art.insert tree (Art.key "\161\132?Uy\162v\228\023\015G&F>\177") 24 ; - Art.insert tree (Art.key "\195:\018\180 \004\152\018\143\231z\212\255\024W\159\147|\006\2069Z\218\006\006\241\166u\167N\024\019'") 25 ; - Art.insert tree (Art.key "\203\162\138\133\129_a(\178\028\177") 26 ; - Art.insert tree (Art.key "\250\027\150\191\162\216;\024\023\245%\238\224") 27 ; - Art.insert tree (Art.key "\\\020\224\t\253U\231\022-\t\249\151Z\014") 28 ; - Art.insert tree (Art.key "\147\238\011y(\247\135}K\1952W\004~n") 29 ; - Art.insert tree (Art.key "\130\018Iz|\165l\177_\161N\187#\205\159*)") 30 ; - Art.insert tree (Art.key "\222\226\200\005fM") 31 ; - Art.insert tree (Art.key "\224o;Zu\192\248[\144Q?\167\131\194\1608\014j\224\254") 32 ; - Art.insert tree (Art.key "\219jsv\n\226") 33 ; - Art.insert tree (Art.key "\003@3\150\229\tJ\134") 34 ; - Art.insert tree (Art.key "\022$") 35 ; - Art.insert tree (Art.key "\198\156\241\138ga9\239\237\212\151\189\1311\220\247") 36 ; - Art.insert tree (Art.key "\210\156\146s\212a\187\244Up\022U\019\207\179\244") 37 ; - Art.insert tree (Art.key "\145\015\001\210\n\142\215P\003A\137k\218\130>\b\017") 38 ; - Art.insert tree (Art.key "\241\165\1348\226") 39 ; - Art.insert tree (Art.key "\211\205\132h") 39 ; - Art.insert tree (Art.key "\220\255\153\015N\167@KA\183n\141") 40 ; - Art.insert tree (Art.key "\184O\129\147\031\225\168>\182\210\252\211\255!\234\157\134\153\198E\169w\217") 41 ; - Art.insert tree (Art.key "\157z\229L\236]\2548\015w\174V\011\250\n\135~U^\139#\180") 42 ; - Art.insert tree (Art.key "\233v\250\2500\218\184\195\177r\003p") 43 ; - Art.insert tree (Art.key "Yu\177C>\165-\228") 44 ; - Art.insert tree (Art.key "wA\191") 45 ; - Art.insert tree (Art.key ",\031\253\195\031\\\135eb\014\189q\183\023\180\184b") 46 ; - Art.insert tree (Art.key "\006\254\211}") 47 ; - Art.insert tree (Art.key "\137;\155\134qD\225T\193\"\005\133\012H\019]N") 48 ; - Art.insert tree (Art.key "\020*\017\225q\147\198\2532\253\171B\184u=7\174s\209\174r\011\224\030") 49 ; - Art.insert tree (Art.key "\014R\220\202&") 50 ; - Art.insert tree (Art.key "O\128)\231\192O\184f{\223\232") 51 ; - Alcotest.(check int) "N48 -> N256" (Art.find tree (Art.key "O\128)\231\192O\184f{\223\232")) 51 -;; + Art.insert tree (Art.key "\134") 1; + Art.insert tree + (Art.key + "\021\n\ + \135\131\2105\161=\142\028\152\006\031\188\191\201\134\194Fu\253\132\1279v_\200&\238") + 2; + Art.insert tree (Art.key "\182\206\219:n4\156\173Mu\012\223;\215\197") 3; + Art.insert tree (Art.key "bG>\229") 4; + Art.insert tree + (Art.key + "[\183\191\201\169M\210\183\015oK%\252\021\187\158e\138\202\193\129\145-") + 5; + Art.insert tree + (Art.key + "\191\175\151\144\012\226\211Y\182\226 \ + +\245\153\204\002\148\149\219^4Aq\189\201\003") + 6; + Art.insert tree + (Art.key + "\182\024\023\145\178\206\\wW0\138\157\223\184]\137g\031\029\"k\132") + 7; + Art.insert tree (Art.key "'g\253s\029?\243b]l\197\197^\168\244") 8; + Art.insert tree (Art.key "\027^L") 9; + Art.insert tree (Art.key "-^\213\151") 10; + Art.insert tree (Art.key "\004") 11; + Art.insert tree (Art.key "\\\217\023\023\023\200\131\226\250\246") 12; + Art.insert tree + (Art.key "\207\251y\235\214\164`6\017)h( \179\215]5'\151\178\208") + 13; + Art.insert tree (Art.key "\n\209 \\\235z^\183") 14; + Art.insert tree (Art.key "]\218") 15; + Art.insert tree (Art.key "\127\252N\155\2162\145") 16; + Art.insert tree + (Art.key "|V\232Z\210&O\234\197\229w\127O\250\154h\236\224\254") + 17; + Art.insert tree (Art.key "A)\139\0289\017\020\194\192<\143.!") 18; + Art.insert tree (Art.key "\153\207e\194\027\\\128\016U") 19; + Art.insert tree (Art.key "\130:\228PMO;IA\253|=\169\023\031X\233\181gdx") 21; + Art.insert tree (Art.key "\177\144w\215\250\024\247") 22; + Art.insert tree (Art.key "\016\242\174\217\\\173o\134\182,}\240\193\179") 23; + Art.insert tree (Art.key "\161\132?Uy\162v\228\023\015G&F>\177") 24; + Art.insert tree + (Art.key + "\195:\018\180 \ + \004\152\018\143\231z\212\255\024W\159\147|\006\2069Z\218\006\006\241\166u\167N\024\019'") + 25; + Art.insert tree (Art.key "\203\162\138\133\129_a(\178\028\177") 26; + Art.insert tree (Art.key "\250\027\150\191\162\216;\024\023\245%\238\224") 27; + Art.insert tree (Art.key "\\\020\224\t\253U\231\022-\t\249\151Z\014") 28; + Art.insert tree (Art.key "\147\238\011y(\247\135}K\1952W\004~n") 29; + Art.insert tree (Art.key "\130\018Iz|\165l\177_\161N\187#\205\159*)") 30; + Art.insert tree (Art.key "\222\226\200\005fM") 31; + Art.insert tree + (Art.key "\224o;Zu\192\248[\144Q?\167\131\194\1608\014j\224\254") + 32; + Art.insert tree (Art.key "\219jsv\n\226") 33; + Art.insert tree (Art.key "\003@3\150\229\tJ\134") 34; + Art.insert tree (Art.key "\022$") 35; + Art.insert tree + (Art.key "\198\156\241\138ga9\239\237\212\151\189\1311\220\247") + 36; + Art.insert tree + (Art.key "\210\156\146s\212a\187\244Up\022U\019\207\179\244") + 37; + Art.insert tree + (Art.key "\145\015\001\210\n\142\215P\003A\137k\218\130>\b\017") + 38; + Art.insert tree (Art.key "\241\165\1348\226") 39; + Art.insert tree (Art.key "\211\205\132h") 39; + Art.insert tree (Art.key "\220\255\153\015N\167@KA\183n\141") 40; + Art.insert tree + (Art.key + "\184O\129\147\031\225\168>\182\210\252\211\255!\234\157\134\153\198E\169w\217") + 41; + Art.insert tree + (Art.key "\157z\229L\236]\2548\015w\174V\011\250\n\135~U^\139#\180") + 42; + Art.insert tree (Art.key "\233v\250\2500\218\184\195\177r\003p") 43; + Art.insert tree (Art.key "Yu\177C>\165-\228") 44; + Art.insert tree (Art.key "wA\191") 45; + Art.insert tree + (Art.key ",\031\253\195\031\\\135eb\014\189q\183\023\180\184b") + 46; + Art.insert tree (Art.key "\006\254\211}") 47; + Art.insert tree (Art.key "\137;\155\134qD\225T\193\"\005\133\012H\019]N") 48; + Art.insert tree + (Art.key + "\020*\017\225q\147\198\2532\253\171B\184u=7\174s\209\174r\011\224\030") + 49; + Art.insert tree (Art.key "\014R\220\202&") 50; + Art.insert tree (Art.key "O\128)\231\192O\184f{\223\232") 51; + Alcotest.(check int) + "N48 -> N256" + (Art.find tree (Art.key "O\128)\231\192O\184f{\223\232")) + 51 let test11 = Alcotest.test_case "test11" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "foo") 1 ; - Alcotest.(check int) "foo" (Art.find tree (Art.key "foo")) 1 ; - Art.insert tree (Art.key "fo") 2 ; - Alcotest.(check int) "foo" (Art.find tree (Art.key "foo")) 1 ; - Alcotest.(check int) "fo" (Art.find tree (Art.key "fo")) 2 ; - Art.insert tree (Art.key "foobar") 3 ; - Alcotest.(check int) "foo" (Art.find tree (Art.key "foo")) 1 ; - Alcotest.(check int) "fo" (Art.find tree (Art.key "fo")) 2 ; + Art.insert tree (Art.key "foo") 1; + Alcotest.(check int) "foo" (Art.find tree (Art.key "foo")) 1; + Art.insert tree (Art.key "fo") 2; + Alcotest.(check int) "foo" (Art.find tree (Art.key "foo")) 1; + Alcotest.(check int) "fo" (Art.find tree (Art.key "fo")) 2; + Art.insert tree (Art.key "foobar") 3; + Alcotest.(check int) "foo" (Art.find tree (Art.key "foo")) 1; + Alcotest.(check int) "fo" (Art.find tree (Art.key "fo")) 2; Alcotest.(check int) "foobar" (Art.find tree (Art.key "foobar")) 3 -;; let test12 = Alcotest.test_case "test12" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "a0") 0 ; - Art.insert tree (Art.key "a1") 1 ; - Art.insert tree (Art.key "a2") 2 ; - Art.insert tree (Art.key "a3") 3 ; - Alcotest.(check int) "a0" (Art.find tree (Art.key "a0")) 0 ; - Alcotest.(check int) "a1" (Art.find tree (Art.key "a1")) 1 ; - Alcotest.(check int) "a2" (Art.find tree (Art.key "a2")) 2 ; + Art.insert tree (Art.key "a0") 0; + Art.insert tree (Art.key "a1") 1; + Art.insert tree (Art.key "a2") 2; + Art.insert tree (Art.key "a3") 3; + Alcotest.(check int) "a0" (Art.find tree (Art.key "a0")) 0; + Alcotest.(check int) "a1" (Art.find tree (Art.key "a1")) 1; + Alcotest.(check int) "a2" (Art.find tree (Art.key "a2")) 2; Alcotest.(check int) "a3" (Art.find tree (Art.key "a3")) 3 -;; let test13 = Alcotest.test_case "test13" `Quick @@ fun () -> @@ -197,15 +228,14 @@ let test13 = let k3 = Art.key (String.make 20 'a' ^ "foobar") in let k4 = Art.key (String.make 20 'a' ^ "barfoo") in let tree = Art.make () in - Art.insert tree k1 1 ; - Art.insert tree k2 2 ; - Art.insert tree k3 3 ; - Art.insert tree k4 4 ; - Alcotest.(check int) (k1 :> string) (Art.find tree k1) 1 ; - Alcotest.(check int) (k2 :> string) (Art.find tree k2) 2 ; - Alcotest.(check int) (k3 :> string) (Art.find tree k3) 3 ; + Art.insert tree k1 1; + Art.insert tree k2 2; + Art.insert tree k3 3; + Art.insert tree k4 4; + Alcotest.(check int) (k1 :> string) (Art.find tree k1) 1; + Alcotest.(check int) (k2 :> string) (Art.find tree k2) 2; + Alcotest.(check int) (k3 :> string) (Art.find tree k3) 3; Alcotest.(check int) (k4 :> string) (Art.find tree k4) 4 -;; let test14 = Alcotest.test_case "test14" `Quick @@ fun () -> @@ -215,27 +245,39 @@ let test14 = let k4 = Art.key (String.make 10 'a') in let k5 = Art.key (String.make 12 'a') in let tree = Art.make () in - Art.insert tree k1 1 ; - Art.insert tree k2 2 ; - Art.insert tree k3 3 ; - Alcotest.(check int) (k1 :> string) (Art.find tree k1) 1 ; - Alcotest.(check int) (k2 :> string) (Art.find tree k2) 2 ; - Alcotest.(check int) (k3 :> string) (Art.find tree k3) 3 ; + Art.insert tree k1 1; + Art.insert tree k2 2; + Art.insert tree k3 3; + Alcotest.(check int) (k1 :> string) (Art.find tree k1) 1; + Alcotest.(check int) (k2 :> string) (Art.find tree k2) 2; + Alcotest.(check int) (k3 :> string) (Art.find tree k3) 3; (* XXX(dinosaure): see around out of prefix. *) - Alcotest.check_raises (k4 :> string) Not_found (fun () -> ignore @@ Art.find tree k4) ; - Alcotest.check_raises (k5 :> string) Not_found (fun () -> ignore @@ Art.find tree k5) -;; + Alcotest.check_raises + (k4 :> string) + Not_found + (fun () -> ignore @@ Art.find tree k4); + Alcotest.check_raises + (k5 :> string) + Not_found + (fun () -> ignore @@ Art.find tree k5) let test15 = Alcotest.test_case "test15" `Quick @@ fun () -> - let ks = Array.init 200 (function 0 -> Art.key "" | i -> Art.key (String.make 1 (Char.unsafe_chr i))) in + let ks = + Array.init 200 (function + | 0 -> Art.key "" + | i -> Art.key (String.make 1 (Char.unsafe_chr i))) + in let tree = Art.make () in - Array.iteri (fun i k -> Art.insert tree k i) ks ; - Alcotest.check_raises "not found" Not_found (fun () -> ignore @@ Art.find tree (Art.key "\255")) -;; + Array.iteri (fun i k -> Art.insert tree k i) ks; + Alcotest.check_raises "not found" Not_found (fun () -> + ignore @@ Art.find tree (Art.key "\255")) -let key = Alcotest.testable (fun ppf (v : Art.key) -> Fmt.pf ppf "%S" (v :> string)) - (fun (a:Art.key) (b:Art.key) -> String.equal (a:>string) (b:>string)) +let key = + Alcotest.testable + (fun ppf (v : Art.key) -> Fmt.pf ppf "%S" (v :> string)) + (fun (a : Art.key) (b : Art.key) -> + String.equal (a :> string) (b :> string)) let test16 = Alcotest.test_case "test16" `Quick @@ fun () -> @@ -244,180 +286,219 @@ let test16 = let k3 = Art.key "\003" in let k4 = Art.key "\004" in let tree = Art.make () in - Art.insert tree k4 4 ; - Art.insert tree k3 3 ; - Art.insert tree k2 2 ; - Art.insert tree k1 1 ; + Art.insert tree k4 4; + Art.insert tree k3 3; + Art.insert tree k2 2; + Art.insert tree k1 1; Alcotest.(check (pair key int)) "minimum" (Art.minimum tree) (k1, 1) -;; let test17 = Alcotest.test_case "test17" `Quick @@ fun () -> - let ks = Array.init 16 (fun i -> Art.key (String.make 1 (Char.unsafe_chr (i + 1)))) in + let ks = + Array.init 16 (fun i -> Art.key (String.make 1 (Char.unsafe_chr (i + 1)))) + in let tree = Art.make () in - Array.iteri (fun i k -> Art.insert tree k i) ks ; - Alcotest.(check (pair key int)) "minimum" (Art.minimum tree) (Art.key "\001", 0) ; -;; + Array.iteri (fun i k -> Art.insert tree k i) ks; + Alcotest.(check (pair key int)) + "minimum" (Art.minimum tree) + (Art.key "\001", 0) let test18 = Alcotest.test_case "test18" `Quick @@ fun () -> - let ks = Array.init 48 (fun i -> Art.key (String.make 1 (Char.unsafe_chr (i + 48)))) in + let ks = + Array.init 48 (fun i -> Art.key (String.make 1 (Char.unsafe_chr (i + 48)))) + in let tree = Art.make () in - Array.iteri (fun i k -> Art.insert tree k i) ks ; - Alcotest.(check (pair key int)) "minimum" (Art.minimum tree) (Art.key "\048", 0) ; -;; + Array.iteri (fun i k -> Art.insert tree k i) ks; + Alcotest.(check (pair key int)) + "minimum" (Art.minimum tree) + (Art.key "\048", 0) let test19 = Alcotest.test_case "test19" `Quick @@ fun () -> - let ks = Array.init 256 @@ function - | 0 -> Art.key "" - | n -> Art.key (String.make 1 (Char.unsafe_chr n)) in + let ks = + Array.init 256 @@ function + | 0 -> Art.key "" + | n -> Art.key (String.make 1 (Char.unsafe_chr n)) + in let tree = Art.make () in - Array.iteri (fun i k -> Art.insert tree k i) ks ; - Alcotest.(check (pair key int)) "minimum" (Art.minimum tree) (Art.key "", 0) ; -;; + Array.iteri (fun i k -> Art.insert tree k i) ks; + Alcotest.(check (pair key int)) "minimum" (Art.minimum tree) (Art.key "", 0) let test20 = Alcotest.test_case "test20" `Quick @@ fun () -> let tree = Art.make () in - Alcotest.check_raises "minimum" (Invalid_argument "empty tree") @@ fun () -> ignore (Art.minimum tree) ; -;; + Alcotest.check_raises "minimum" (Invalid_argument "empty tree") @@ fun () -> + ignore (Art.minimum tree) let test21 = Alcotest.test_case "test21" `Quick @@ fun () -> let tree = Art.make () in let foo = Art.key "foo" in - Art.insert tree foo () ; - Alcotest.(check unit) "find" (Art.find tree foo) () ; - Art.remove tree foo ; - Alcotest.check_raises "find" Not_found @@ fun () -> ignore (Art.find tree foo) ; -;; + Art.insert tree foo (); + Alcotest.(check unit) "find" (Art.find tree foo) (); + Art.remove tree foo; + Alcotest.check_raises "find" Not_found @@ fun () -> ignore (Art.find tree foo) let test22 = Alcotest.test_case "test22" `Quick @@ fun () -> let k0 = Art.key "foo\001" in let k1 = Art.key "foo\002" in let tree = Art.make () in - Art.insert tree k0 () ; - Art.insert tree k1 () ; - Alcotest.(check unit) "find" (Art.find tree k0) () ; - Alcotest.(check unit) "find" (Art.find tree k0) () ; - Art.remove tree k0 ; - Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree k0)) ; - Alcotest.(check unit) "find" (Art.find tree k1) () ; - Art.remove tree k1 ; - Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree k1)) ; -;; + Art.insert tree k0 (); + Art.insert tree k1 (); + Alcotest.(check unit) "find" (Art.find tree k0) (); + Alcotest.(check unit) "find" (Art.find tree k0) (); + Art.remove tree k0; + Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree k0)); + Alcotest.(check unit) "find" (Art.find tree k1) (); + Art.remove tree k1; + Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree k1)) let test23 = Alcotest.test_case "test23" `Quick @@ fun () -> let tree = Art.make () in - Alcotest.check_raises "remove" Not_found (fun () -> Art.remove tree (Art.key "a")) ; - Art.insert tree (Art.key "a") () ; - Art.insert tree (Art.key "b") () ; - Alcotest.check_raises "remove" Not_found (fun () -> Art.remove tree (Art.key "c")) ; - for i = 0x7f to 0xff do Art.insert tree (Art.key (String.make 1 (Char.unsafe_chr i))) () done ; - Alcotest.check_raises "remove" Not_found (fun () -> Art.remove tree (Art.key "c")) ; - Art.remove tree (Art.key "a") ; - Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree (Art.key "a"))) ; -;; + Alcotest.check_raises "remove" Not_found (fun () -> + Art.remove tree (Art.key "a")); + Art.insert tree (Art.key "a") (); + Art.insert tree (Art.key "b") (); + Alcotest.check_raises "remove" Not_found (fun () -> + Art.remove tree (Art.key "c")); + for i = 0x7f to 0xff do + Art.insert tree (Art.key (String.make 1 (Char.unsafe_chr i))) () + done; + Alcotest.check_raises "remove" Not_found (fun () -> + Art.remove tree (Art.key "c")); + Art.remove tree (Art.key "a"); + Alcotest.check_raises "find" Not_found (fun () -> + ignore (Art.find tree (Art.key "a"))) let test24 = Alcotest.test_case "test24" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "f") () ; - Art.insert tree (Art.key "foo") () ; - Art.insert tree (Art.key "foobar") () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "f")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "foo")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "foobar")) () ; - Art.remove tree (Art.key "foobar") ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "f")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "foo")) () ; - Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree (Art.key "foobar"))) ; -;; + Art.insert tree (Art.key "f") (); + Art.insert tree (Art.key "foo") (); + Art.insert tree (Art.key "foobar") (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "f")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "foo")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "foobar")) (); + Art.remove tree (Art.key "foobar"); + Alcotest.(check unit) "find" (Art.find tree (Art.key "f")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "foo")) (); + Alcotest.check_raises "find" Not_found (fun () -> + ignore (Art.find tree (Art.key "foobar"))) let test25 = Alcotest.test_case "test25" `Quick @@ fun () -> let tree = Art.make () in - Art.insert tree (Art.key "foo") 0 ; - Art.insert tree (Art.key "foobar") 1 ; - Art.insert tree (Art.key "foobar!") 2 ; - Alcotest.(check int) "find" (Art.find tree (Art.key "foo")) 0 ; - Alcotest.(check int) "find" (Art.find tree (Art.key "foobar")) 1 ; - Alcotest.(check int) "find" (Art.find tree (Art.key "foobar!")) 2 ; - Art.remove tree (Art.key "foo") ; - Alcotest.(check int) "find" (Art.find tree (Art.key "foobar")) 1 ; - Alcotest.(check int) "find" (Art.find tree (Art.key "foobar!")) 2 ; - Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree (Art.key "foo"))) ; -;; + Art.insert tree (Art.key "foo") 0; + Art.insert tree (Art.key "foobar") 1; + Art.insert tree (Art.key "foobar!") 2; + Alcotest.(check int) "find" (Art.find tree (Art.key "foo")) 0; + Alcotest.(check int) "find" (Art.find tree (Art.key "foobar")) 1; + Alcotest.(check int) "find" (Art.find tree (Art.key "foobar!")) 2; + Art.remove tree (Art.key "foo"); + Alcotest.(check int) "find" (Art.find tree (Art.key "foobar")) 1; + Alcotest.(check int) "find" (Art.find tree (Art.key "foobar!")) 2; + Alcotest.check_raises "find" Not_found (fun () -> + ignore (Art.find tree (Art.key "foo"))) let test26 = Alcotest.test_case "test26" `Quick @@ fun () -> let tree = Art.make () in - for i = 0 to 4 do Art.insert tree (Art.key (String.make 1 (Char.chr (i + 48)))) () done ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "0")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "1")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "2")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "3")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "4")) () ; - Art.remove tree (Art.key "4") ; - Art.remove tree (Art.key "3") ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "0")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "1")) () ; - Alcotest.(check unit) "find" (Art.find tree (Art.key "2")) () ; - Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree (Art.key "4"))) ; - Alcotest.check_raises "find" Not_found (fun () -> ignore (Art.find tree (Art.key "3"))) ; -;; + for i = 0 to 4 do + Art.insert tree (Art.key (String.make 1 (Char.chr (i + 48)))) () + done; + Alcotest.(check unit) "find" (Art.find tree (Art.key "0")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "1")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "2")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "3")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "4")) (); + Art.remove tree (Art.key "4"); + Art.remove tree (Art.key "3"); + Alcotest.(check unit) "find" (Art.find tree (Art.key "0")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "1")) (); + Alcotest.(check unit) "find" (Art.find tree (Art.key "2")) (); + Alcotest.check_raises "find" Not_found (fun () -> + ignore (Art.find tree (Art.key "4"))); + Alcotest.check_raises "find" Not_found (fun () -> + ignore (Art.find tree (Art.key "3"))) let test27 = Alcotest.test_case "test27" `Quick @@ fun () -> let tree = Art.make () in - for i = 0 to 17 do Art.insert tree (Art.key (String.make 1 (Char.chr (i + 65)))) () done ; - Alcotest.(check pass) "remove" (Art.remove tree (Art.key "A")) () ; - Alcotest.(check pass) "remove" (Art.remove tree (Art.key "B")) () ; - Alcotest.(check pass) "remove" (Art.remove tree (Art.key "C")) () ; - Alcotest.(check pass) "remove" (Art.remove tree (Art.key "D")) () ; - Alcotest.(check pass) "remove" (Art.remove tree (Art.key "E")) () ; - Alcotest.(check pass) "remove" (Art.remove tree (Art.key "F")) () ; -;; + for i = 0 to 17 do + Art.insert tree (Art.key (String.make 1 (Char.chr (i + 65)))) () + done; + Alcotest.(check pass) "remove" (Art.remove tree (Art.key "A")) (); + Alcotest.(check pass) "remove" (Art.remove tree (Art.key "B")) (); + Alcotest.(check pass) "remove" (Art.remove tree (Art.key "C")) (); + Alcotest.(check pass) "remove" (Art.remove tree (Art.key "D")) (); + Alcotest.(check pass) "remove" (Art.remove tree (Art.key "E")) (); + Alcotest.(check pass) "remove" (Art.remove tree (Art.key "F")) () let test28 = Alcotest.test_case "test28" `Quick @@ fun () -> let tree = Art.make () in - for i = 1 to 50 do Art.insert tree (Art.key (String.make 1 (Char.chr i))) () done ; + for i = 1 to 50 do + Art.insert tree (Art.key (String.make 1 (Char.chr i))) () + done; for i = 1 to 38 do - Alcotest.(check pass) "remove" (Art.remove tree (Art.key (String.make 1 (Char.chr i)))) () - done ; -;; + Alcotest.(check pass) + "remove" + (Art.remove tree (Art.key (String.make 1 (Char.chr i)))) + () + done let test29 = Alcotest.test_case "test29" `Quick @@ fun () -> let tree = Art.make () in - for i = 1 to 50 do Art.insert tree (Art.key (String.make 1 (Char.chr i))) i done ; - let f (key:Art.key) value acc = - Alcotest.(check int) "iter" (Char.code (key :> string).[0]) value ; - succ acc in - Alcotest.(check int) "iter" (Art.iter ~f 0 tree) 50 ; -;; + for i = 1 to 50 do + Art.insert tree (Art.key (String.make 1 (Char.chr i))) i + done; + let f (key : Art.key) value acc = + Alcotest.(check int) "iter" (Char.code (key :> string).[0]) value; + succ acc + in + Alcotest.(check int) "iter" (Art.iter ~f 0 tree) 50 module Caml_test = struct - module Map = Map.Make(struct type t = Art.key let compare (a:Art.key) (b:Art.key) = String.compare (a:>string) (b:>string) end) + module Map = Map.Make (struct + type t = Art.key + + let compare (a : Art.key) (b : Art.key) = + String.compare (a :> string) (b :> string) + end) let incl_mt m t = - try Map.iter (fun k v -> let v' = Art.find t k in if v <> v' then raise Not_found) m ; true + try + Map.iter + (fun k v -> + let v' = Art.find t k in + if v <> v' then raise Not_found) + m; + true with Not_found -> false let domain_tm t m = - try Art.iter ~f:(fun k _ () -> if not (Map.mem k m) then raise Not_found) () t ; true + try + Art.iter ~f:(fun k _ () -> if not (Map.mem k m) then raise Not_found) () t; + true with Not_found -> false let incl_tm t m = - try Art.iter ~f:(fun k v () -> let v' = Map.find k m in if v <> v' then raise Not_found) () t ; true + try + Art.iter + ~f:(fun k v () -> + let v' = Map.find k m in + if v <> v' then raise Not_found) + () t; + true with Not_found -> false let to_list t = - Art.iter ~f:(fun k v a -> (k, v) :: a) [] t |> List.stable_sort Stdlib.compare + Art.iter ~f:(fun k v a -> (k, v) :: a) [] t + |> List.stable_sort Stdlib.compare let check_to_seq t = let l0 = to_list t in @@ -429,115 +510,188 @@ module Caml_test = struct Alcotest.test_case "caml" `Quick @@ fun () -> let len = Array.length data in let tree = Art.make () and map = ref Map.empty in - Array.iter (fun (k, v) -> Art.insert tree k v ; map := Map.add k v !map) data ; - Alcotest.(check bool) "insert" (incl_mt !map tree && domain_tm tree !map) true ; + Array.iter + (fun (k, v) -> + Art.insert tree k v; + map := Map.add k v !map) + data; + Alcotest.(check bool) + "insert" + (incl_mt !map tree && domain_tm tree !map) + true; (* check_to_seq_of_seq tree ; *) - check_to_seq tree ; - for i = 0 to len / 3 - 1 do - let (k, _) = data.(i) in - Fmt.pr ">>> remove %S.\n%!" (k :> string) ; - Art.remove tree k ; map := Map.remove k !map done ; + check_to_seq tree; + for i = 0 to (len / 3) - 1 do + let k, _ = data.(i) in + Fmt.pr ">>> remove %S.\n%!" (k :> string); + Art.remove tree k; + map := Map.remove k !map + done; Fmt.pr "map: @[%a@].\n%!" - Fmt.(Dump.iter_bindings Map.iter (any "map") (using (fun (x:Art.key) -> (x :> string)) (fmt "%S")) int) !map ; - Fmt.pr "art: @[%a@].\n%!" - (Art.pp Fmt.int) tree ; - Alcotest.(check bool) "incl_mt" (incl_mt !map tree) true ; - Alcotest.(check bool) "incl_tm" (incl_tm tree !map) true ; - Alcotest.(check bool) "remove" (incl_mt !map tree && incl_tm tree !map) true ; + Fmt.( + Dump.iter_bindings Map.iter (any "map") + (using (fun (x : Art.key) -> (x :> string)) (fmt "%S")) + int) + !map; + Fmt.pr "art: @[%a@].\n%!" (Art.pp Fmt.int) tree; + Alcotest.(check bool) "incl_mt" (incl_mt !map tree) true; + Alcotest.(check bool) "incl_tm" (incl_tm tree !map) true; + Alcotest.(check bool) "remove" (incl_mt !map tree && incl_tm tree !map) true; (* check_to_seq_of_seq tree ; *) - check_to_seq tree ; - ;; + check_to_seq tree end let test30 = let data = - [| Art.key ":v\171\225]\154\143x\235#\162\182+\184\196\178'e\220R\238\2506b\245w\231'\011\003\150", 0 - ; Art.key "\185\026\129\171^\b\254\236\1290\169.\247\178\022\240\147%M\133 x\229\020\177.\236\139\017\224\255!\249\201\153K2u\210\247\019\226F\019Q\029\224\1348\194a\240\168\030\217kIsJm\249\247\031{", 1 - ; Art.key "\164\165\128\156\213\157\236Jx\180\025\186\156F<\215\1905`\246n\007G\206\026b\242\210-Iy\021|@\224cO[\194\213&\r\172\185\185$51Lz\244;\172Ky\195\237s\177\199>\129q\243", 2 - ; Art.key "\r\183\028)\128N\227\236\253\234\146\248\206Q\188\145+\139\2001\197,\250\182vr\026\217\246\142w\159U\230\206x\020\221`\168\198\200\1372E\170\139,Zu.h\250\026\190*\131@b\019\228v\137C", 3 - ; Art.key "MX\015\219v\232\187\22041\241\175 \201\200'\"\133\238D\246\232\156(\241\t\141\187\185\019\165\193\129z\214\140\153\236]\127\172\255\159\135W\b\250y\255\202}\b#\134vMR\150\148!\014K\139\184", 4 - ; Art.key "\155\200:", 5 |] in - Caml_test.test data + [| + ( Art.key + ":v\171\225]\154\143x\235#\162\182+\184\196\178'e\220R\238\2506b\245w\231'\011\003\150", + 0 ); + ( Art.key + "\185\026\129\171^\b\254\236\1290\169.\247\178\022\240\147%M\133 \ + x\229\020\177.\236\139\017\224\255!\249\201\153K2u\210\247\019\226F\019Q\029\224\1348\194a\240\168\030\217kIsJm\249\247\031{", + 1 ); + ( Art.key + "\164\165\128\156\213\157\236Jx\180\025\186\156F<\215\1905`\246n\007G\206\026b\242\210-Iy\021|@\224cO[\194\213&\r\172\185\185$51Lz\244;\172Ky\195\237s\177\199>\129q\243", + 2 ); + ( Art.key + "\r\183\028)\128N\227\236\253\234\146\248\206Q\188\145+\139\2001\197,\250\182vr\026\217\246\142w\159U\230\206x\020\221`\168\198\200\1372E\170\139,Zu.h\250\026\190*\131@b\019\228v\137C", + 3 ); + ( Art.key + "MX\015\219v\232\187\22041\241\175 \ + \201\200'\"\133\238D\246\232\156(\241\t\141\187\185\019\165\193\129z\214\140\153\236]\127\172\255\159\135W\b\250y\255\202}\b#\134vMR\150\148!\014K\139\184", + 4 ); + (Art.key "\155\200:", 5); + |] + in + Caml_test.test data let test31 = Alcotest.test_case "test31" `Quick @@ fun () -> let t = Art.make () in - Art.insert t (Art.unsafe_key "127.0.0.1:33650") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33652") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33654") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33656") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33658") 0 ; + Art.insert t (Art.unsafe_key "127.0.0.1:33650") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33652") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33654") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33656") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33658") 0; match Art.find_opt t (Art.unsafe_key "127.0.0.1:33660") with | None -> () | Some _ -> Alcotest.fail "Impossible, 127.0.0.1:33660 does not exist" -;; let test32 = Alcotest.test_case "test32" `Quick @@ fun () -> let t = Art.make () in - Art.insert t (Art.unsafe_key "\253w\247R\241\002'\240E2K\186\250^}*\159\232\255\148\187\248\144\167\194\165\162j1\154\018\140\139\137\189MV;\232\139Z\237\238,n\240\227\t_\191\152\243\142\184\188\012\150\187+\185/\006\233\192") 0 ; - Art.insert t (Art.unsafe_key "\131\206P\133\150\213\b{\005,-\194\209\165*B\227\135B\212N\027Z6\214\015\254\253F*#QM\t>~\025\018\181d\232\253\219\140\240\rU3A\253\242]nE\207\156a\128\139\0195\137W\136") 1 ; - Art.insert t (Art.unsafe_key ",Q2$\163d\012\007\220=\199p\t\238\189\152\193\134N\150\018\246$\t\027\\5%\184\020\210\024G\138\144\2532\165mx\219\210\161\167?=\194\212\199)\211\022P\027\153L\158[KX\140\212)\011") 2 ; - Art.insert t (Art.unsafe_key "\236(F\"\248\241\213s\015Q\2515jc\238\235\224V\184\138\156x\138\029\017\249\188N\219\145+\028\243Ni\b\1444\nU\155J\1880\146\t\192=\196\021!\161\1337r\247\027\254\132\213w\254\152\155") 3 ; - Art.insert t (Art.unsafe_key "\191*\134\\\\\220\n\216\247M\193\172\015\012J\233\219\004+\171K \161\240\0300\020%\180p\132\223\228\018\149\205\192\023\201\128\016&\146\155\017\2067\026\248\180\142\146\164+R\220W\165|K\137\180\199b") 4 ; - Art.remove t (Art.unsafe_key ",Q2$\163d\012\007\220=\199p\t\238\189\152\193\134N\150\018\246$\t\027\\5%\184\020\210\024G\138\144\2532\165mx\219\210\161\167?=\194\212\199)\211\022P\027\153L\158[KX\140\212)\011") ; - Art.remove t (Art.unsafe_key "\236(F\"\248\241\213s\015Q\2515jc\238\235\224V\184\138\156x\138\029\017\249\188N\219\145+\028\243Ni\b\1444\nU\155J\1880\146\t\192=\196\021!\161\1337r\247\027\254\132\213w\254\152\155") ; - Art.remove t (Art.unsafe_key "\191*\134\\\\\220\n\216\247M\193\172\015\012J\233\219\004+\171K \161\240\0300\020%\180p\132\223\228\018\149\205\192\023\201\128\016&\146\155\017\2067\026\248\180\142\146\164+R\220W\165|K\137\180\199b") ; - let v0 = Art.find t (Art.unsafe_key "\253w\247R\241\002'\240E2K\186\250^}*\159\232\255\148\187\248\144\167\194\165\162j1\154\018\140\139\137\189MV;\232\139Z\237\238,n\240\227\t_\191\152\243\142\184\188\012\150\187+\185/\006\233\192") in - let v1 = Art.find t (Art.unsafe_key "\131\206P\133\150\213\b{\005,-\194\209\165*B\227\135B\212N\027Z6\214\015\254\253F*#QM\t>~\025\018\181d\232\253\219\140\240\rU3A\253\242]nE\207\156a\128\139\0195\137W\136") in - Alcotest.(check int) "v0" v0 0 ; - Alcotest.(check int) "v1" v1 1 ; -;; + Art.insert t + (Art.unsafe_key + "\253w\247R\241\002'\240E2K\186\250^}*\159\232\255\148\187\248\144\167\194\165\162j1\154\018\140\139\137\189MV;\232\139Z\237\238,n\240\227\t_\191\152\243\142\184\188\012\150\187+\185/\006\233\192") + 0; + Art.insert t + (Art.unsafe_key + "\131\206P\133\150\213\b{\005,-\194\209\165*B\227\135B\212N\027Z6\214\015\254\253F*#QM\t>~\025\018\181d\232\253\219\140\240\rU3A\253\242]nE\207\156a\128\139\0195\137W\136") + 1; + Art.insert t + (Art.unsafe_key + ",Q2$\163d\012\007\220=\199p\t\238\189\152\193\134N\150\018\246$\t\027\\5%\184\020\210\024G\138\144\2532\165mx\219\210\161\167?=\194\212\199)\211\022P\027\153L\158[KX\140\212)\011") + 2; + Art.insert t + (Art.unsafe_key + "\236(F\"\248\241\213s\015Q\2515jc\238\235\224V\184\138\156x\138\029\017\249\188N\219\145+\028\243Ni\b\1444\n\ + U\155J\1880\146\t\192=\196\021!\161\1337r\247\027\254\132\213w\254\152\155") + 3; + Art.insert t + (Art.unsafe_key + "\191*\134\\\\\220\n\ + \216\247M\193\172\015\012J\233\219\004+\171K \ + \161\240\0300\020%\180p\132\223\228\018\149\205\192\023\201\128\016&\146\155\017\2067\026\248\180\142\146\164+R\220W\165|K\137\180\199b") + 4; + Art.remove t + (Art.unsafe_key + ",Q2$\163d\012\007\220=\199p\t\238\189\152\193\134N\150\018\246$\t\027\\5%\184\020\210\024G\138\144\2532\165mx\219\210\161\167?=\194\212\199)\211\022P\027\153L\158[KX\140\212)\011"); + Art.remove t + (Art.unsafe_key + "\236(F\"\248\241\213s\015Q\2515jc\238\235\224V\184\138\156x\138\029\017\249\188N\219\145+\028\243Ni\b\1444\n\ + U\155J\1880\146\t\192=\196\021!\161\1337r\247\027\254\132\213w\254\152\155"); + Art.remove t + (Art.unsafe_key + "\191*\134\\\\\220\n\ + \216\247M\193\172\015\012J\233\219\004+\171K \ + \161\240\0300\020%\180p\132\223\228\018\149\205\192\023\201\128\016&\146\155\017\2067\026\248\180\142\146\164+R\220W\165|K\137\180\199b"); + let v0 = + Art.find t + (Art.unsafe_key + "\253w\247R\241\002'\240E2K\186\250^}*\159\232\255\148\187\248\144\167\194\165\162j1\154\018\140\139\137\189MV;\232\139Z\237\238,n\240\227\t_\191\152\243\142\184\188\012\150\187+\185/\006\233\192") + in + let v1 = + Art.find t + (Art.unsafe_key + "\131\206P\133\150\213\b{\005,-\194\209\165*B\227\135B\212N\027Z6\214\015\254\253F*#QM\t>~\025\018\181d\232\253\219\140\240\rU3A\253\242]nE\207\156a\128\139\0195\137W\136") + in + Alcotest.(check int) "v0" v0 0; + Alcotest.(check int) "v1" v1 1 let test33 = Alcotest.test_case "test33" `Quick @@ fun () -> let t = Art.make () in - Art.insert t (Art.unsafe_key "127.0.0.1:33650") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33652") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33654") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33656") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33658") 0 ; - ( try Art.remove t (Art.unsafe_key "127.0.0.1:33660") ; Alcotest.fail "127.0.0.1:33660 does not exist" - with Not_found -> Alcotest.(check pass) "remove" () () ) ; - Art.remove t (Art.unsafe_key "127.0.0.1:33658") ; + Art.insert t (Art.unsafe_key "127.0.0.1:33650") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33652") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33654") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33656") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33658") 0; + (try + Art.remove t (Art.unsafe_key "127.0.0.1:33660"); + Alcotest.fail "127.0.0.1:33660 does not exist" + with Not_found -> Alcotest.(check pass) "remove" () ()); + Art.remove t (Art.unsafe_key "127.0.0.1:33658"); match Art.find_opt t (Art.unsafe_key "127.0.0.1:33658") with | None -> Alcotest.(check pass) "remove" () () | Some _ -> Alcotest.fail "Unexpected value for 127.0.0.1:33658" -;; let test34 = Alcotest.test_case "test34" `Quick @@ fun () -> let t = Art.make () in - Art.insert t (Art.unsafe_key "127.0.0.1:33650") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33652") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33654") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33656") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.1:33658") 0 ; - Art.insert t (Art.unsafe_key "127.0.0.2:33658") 0 ; - Art.insert t (Art.unsafe_key "192.168.1.1:33658") 0 ; - let lst = Art.prefix_iter ~prefix:(Art.unsafe_key "127.0.0.1") ~f:(fun key _ acc -> (key :> string) :: acc) [] t in + Art.insert t (Art.unsafe_key "127.0.0.1:33650") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33652") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33654") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33656") 0; + Art.insert t (Art.unsafe_key "127.0.0.1:33658") 0; + Art.insert t (Art.unsafe_key "127.0.0.2:33658") 0; + Art.insert t (Art.unsafe_key "192.168.1.1:33658") 0; + let lst = + Art.prefix_iter + ~prefix:(Art.unsafe_key "127.0.0.1") + ~f:(fun key _ acc -> (key :> string) :: acc) + [] t + in let lst = List.sort String.compare lst in - Alcotest.(check (list string)) "prefix" lst - [ "127.0.0.1:33650" - ; "127.0.0.1:33652" - ; "127.0.0.1:33654" - ; "127.0.0.1:33656" - ; "127.0.0.1:33658" ] -;; + Alcotest.(check (list string)) + "prefix" lst + [ + "127.0.0.1:33650"; + "127.0.0.1:33652"; + "127.0.0.1:33654"; + "127.0.0.1:33656"; + "127.0.0.1:33658"; + ] let test35 = Alcotest.test_case "test35" `Quick @@ fun () -> let k v = Art.unsafe_key v in let t = Art.make () in let k0 = k "\139" in - let k1 = k "\139\139\139\139\011\137\139\139\139\146\139\139\255\255\255\127\139\139\139\139\139\139" in - let k2 = k "\139\139\139\139\011\137\139\139\139\146\139\139\255\255\255\127\139\139\139\139\139\139\002" in - Art.insert t k0 0 ; - Art.insert t k1 1 ; - Art.insert t k2 2 ; - Fmt.pr "@[%a@]\n%!" Art.(pp Fmt.int) t ; - Alcotest.(check int) "0" (Art.find t k0) 0 ; - Alcotest.(check int) "1" (Art.find t k1) 1 ; + let k1 = + k + "\139\139\139\139\011\137\139\139\139\146\139\139\255\255\255\127\139\139\139\139\139\139" + in + let k2 = + k + "\139\139\139\139\011\137\139\139\139\146\139\139\255\255\255\127\139\139\139\139\139\139\002" + in + Art.insert t k0 0; + Art.insert t k1 1; + Art.insert t k2 2; + Fmt.pr "@[%a@]\n%!" Art.(pp Fmt.int) t; + Alcotest.(check int) "0" (Art.find t k0) 0; + Alcotest.(check int) "1" (Art.find t k1) 1; Alcotest.(check int) "2" (Art.find t k2) 2 let test36 = @@ -549,21 +703,20 @@ let test36 = let k1 = k "\255\255\004\026" in let k2 = k "@\014" in let k3 = k "\016" in - Art.insert t0 k0 0 ; - Art.insert t0 k1 1 ; - Art.insert t1 k2 2 ; - Art.insert t1 k3 3 ; - Art.insert t1 k3 4 ; + Art.insert t0 k0 0; + Art.insert t0 k1 1; + Art.insert t1 k2 2; + Art.insert t1 k3 3; + Art.insert t1 k3 4; Alcotest.(check pass) "make" () () let unique equal lst = let rec go k acc = function | [] -> acc - | (k', _) as hd :: tl -> if equal k k' then go k acc tl else go k' (hd :: acc) tl in - match List.rev lst with - | [] -> [] - | (k, v) :: lst -> - go k [ k, v ] lst + | ((k', _) as hd) :: tl -> + if equal k k' then go k acc tl else go k' (hd :: acc) tl + in + match List.rev lst with [] -> [] | (k, v) :: lst -> go k [ (k, v) ] lst let test37 = Alcotest.test_case "test37" `Quick @@ fun () -> @@ -575,102 +728,144 @@ let test37 = let k3 = k "\255\255\255\254\1650\127" in let k4 = k "\128" in let k5 = k "\255\128" in - let l0 = [ k0, 0; k1, 1; k2, 3 ] in - let l1 = [ k3, 4; k4, 5; k5, 6 ] in - List.iter (fun (k, v) -> Art.insert tree k v) l0 ; - List.iter (fun (k, v) -> Art.insert tree k v) l1 ; - Fmt.epr "@[%a@]\n%!" Art.(pp Fmt.int) tree ; - List.iter (fun (k, _) -> try Art.remove tree k with Not_found -> () (* XXX(dinosaure): double remove *)) l1 ; - let check = fun ((k : Art.key), v0) -> + let l0 = [ (k0, 0); (k1, 1); (k2, 3) ] in + let l1 = [ (k3, 4); (k4, 5); (k5, 6) ] in + List.iter (fun (k, v) -> Art.insert tree k v) l0; + List.iter (fun (k, v) -> Art.insert tree k v) l1; + Fmt.epr "@[%a@]\n%!" Art.(pp Fmt.int) tree; + List.iter + (fun (k, _) -> + try Art.remove tree k + with Not_found -> () (* XXX(dinosaure): double remove *)) + l1; + let check ((k : Art.key), v0) = match List.assoc_opt k l1 with | Some _ -> Alcotest.(check pass) (Fmt.str "%S" (k :> string)) () () | None -> - let v1 = Art.find tree k in - Alcotest.(check int) (Fmt.str "%S" (k :> string)) v0 v1 in - let l0 = List.stable_sort (fun ((a : Art.key), _) ((b : Art.key), _) -> String.compare (a:>string) (b:>string)) l0 in - let l0 = unique (fun (a:Art.key) (b:Art.key) -> String.equal (a:>string) (b:>string)) l0 in + let v1 = Art.find tree k in + Alcotest.(check int) (Fmt.str "%S" (k :> string)) v0 v1 + in + let l0 = + List.stable_sort + (fun ((a : Art.key), _) ((b : Art.key), _) -> + String.compare (a :> string) (b :> string)) + l0 + in + let l0 = + unique + (fun (a : Art.key) (b : Art.key) -> + String.equal (a :> string) (b :> string)) + l0 + in List.iter check l0 module Ordered = struct type t = Art.key - let compare (a : t) (b : t) = - String.compare (a :> string) (b :> string) + let compare (a : t) (b : t) = String.compare (a :> string) (b :> string) end module Map = Map.Make (Ordered) let incl_mt m t = - try Map.iter (fun k v -> let v' = Art.find t k in if v <> v' then raise Not_found) m ; true + try + Map.iter + (fun k v -> + let v' = Art.find t k in + if v <> v' then raise Not_found) + m; + true with Not_found -> false let incl_tm t m = - try Art.iter ~f:(fun k v () -> let v' = Map.find k m in if v <> v' then raise Not_found) () t ; true + try + Art.iter + ~f:(fun k v () -> + let v' = Map.find k m in + if v <> v' then raise Not_found) + () t; + true with Not_found -> false let test38 = Alcotest.test_case "test38" `Quick @@ fun () -> let k v = Art.unsafe_key v in let t = Art.make () in - let k0 = k "}}}}}}}}}}}}}}t}}}}}}\177\177\177\164\151\002\255\127}}}}}}}}}}}}}}\151\002\255\127}}}}}}}}}}}}t}}}}" in - let k1 = k "}}}}}}}}}}}}}}t}}}}}}\177\177\177\177\151\002\255\127}}}}}}}}}}}}}}}}c" in + let k0 = + k + "}}}}}}}}}}}}}}t}}}}}}\177\177\177\164\151\002\255\127}}}}}}}}}}}}}}\151\002\255\127}}}}}}}}}}}}t}}}}" + in + let k1 = + k "}}}}}}}}}}}}}}t}}}}}}\177\177\177\177\151\002\255\127}}}}}}}}}}}}}}}}c" + in let k2 = k "}}}}}}}}}}}}" in - Art.insert t k0 0 ; - Art.insert t k1 1 ; - Art.insert t k2 2 ; + Art.insert t k0 0; + Art.insert t k1 1; + Art.insert t k2 2; let m = Map.empty |> Map.add k0 0 |> Map.add k1 1 |> Map.add k2 2 in - Alcotest.(check bool) "incl_mt" (incl_mt m t) true ; - Alcotest.(check int) (k0 :> string) (Art.find t k0) 0 ; - Fmt.epr "@[%a@]\n%!" (Art.pp Fmt.int) t ; - Art.remove t k0 ; + Alcotest.(check bool) "incl_mt" (incl_mt m t) true; + Alcotest.(check int) (k0 :> string) (Art.find t k0) 0; + Fmt.epr "@[%a@]\n%!" (Art.pp Fmt.int) t; + Art.remove t k0; let m = Map.remove k0 m in Alcotest.(check bool) "incl_mt && incl_tm" (incl_mt m t && incl_tm t m) true let random_integers num range = let data = Array.make num (Art.key "", 0) in - for i = 0 to num - 1 do data.(i) <- (Art.key (string_of_int (Random.int range)), i) done ; + for i = 0 to num - 1 do + data.(i) <- (Art.key (string_of_int (Random.int range)), i) + done; data let () = Alcotest.run "art" - [ "art", [ test01 - ; test02 - ; test03 - ; test04 - ; test05 - ; test06 - ; test07 - ; test08 - ; test09 - ; test10 - ; test11 - ; test12 - ; test13 - ; test14 - ; test15 - ; test31 - ; test35 - ; test36 - ; test38 ] - ; "minimum", [ test16 - ; test17 - ; test18 - ; test19 - ; test20 ] - ; "remove", [ test21 - ; test22 - ; test23 - ; test24 - ; test25 - ; test26 - ; test27 - ; test28 - ; test32 - ; test33 - ; test37 ] - ; "iter", [ test29 ] - ; "prefix_iter", [ test34 ] - ; "caml", [ (Caml_test.test Art.[| key "0", 0; key "1", 1; key "2", 2; key "3", 3 |]) - ; (Caml_test.test Art.[| key "3", 3; key "2", 2; key "1", 1; key "0", 0 |]) - ; test30 - ; (Caml_test.test (random_integers 20_000 1_000_000_000)) ] ] + [ + ( "art", + [ + test01; + test02; + test03; + test04; + test05; + test06; + test07; + test08; + test09; + test10; + test11; + test12; + test13; + test14; + test15; + test31; + test35; + test36; + test38; + ] ); + ("minimum", [ test16; test17; test18; test19; test20 ]); + ( "remove", + [ + test21; + test22; + test23; + test24; + test25; + test26; + test27; + test28; + test32; + test33; + test37; + ] ); + ("iter", [ test29 ]); + ("prefix_iter", [ test34 ]); + ( "caml", + [ + Caml_test.test + Art.[| (key "0", 0); (key "1", 1); (key "2", 2); (key "3", 3) |]; + Caml_test.test + Art.[| (key "3", 3); (key "2", 2); (key "1", 1); (key "0", 0) |]; + test30; + Caml_test.test (random_integers 20_000 1_000_000_000); + ] ); + ] diff --git a/test/test_ring.ml b/test/test_ring.ml index 2d1ee16..fbe8418 100644 --- a/test/test_ring.ml +++ b/test/test_ring.ml @@ -4,37 +4,40 @@ let pp_process_status ppf = function | Unix.WSTOPPED n -> Format.fprintf ppf "(WSTOPPED %d)" n let res = ref true - let exit_success = 0 let exit_failure = 1 - let properly_exited = function Unix.WEXITED 0 -> true | _ -> false - let count = ref 0 let show filename = let ic = open_in filename in - let rec go ic = match input_line ic with - | line -> Format.printf "%s\n%!" line ; go ic - | exception End_of_file -> close_in ic in + let rec go ic = + match input_line ic with + | line -> + Format.printf "%s\n%!" line; + go ic + | exception End_of_file -> close_in ic + in go ic let run order len = let filename = Format.asprintf "%02d-ring.log" !count in - incr count ; + incr count; let log = Unix.openfile filename Unix.[ O_RDWR; O_CREAT; O_TRUNC ] 0o644 in let pid = Unix.create_process_env "./rb.exe" [| "./rb.exe"; "--tmp=./tmp"; string_of_int order; string_of_int len |] - [||] Unix.stdin Unix.stdout log in + [||] Unix.stdin Unix.stdout log + in let _, status = Unix.waitpid [] pid in - Unix.close log ; res := !res && properly_exited status ; - Format.printf ">>> ./rb.exe --tmp=./tmp %d %d: %a.\n%!" order len pp_process_status status ; - if not (properly_exited status) - then show filename + Unix.close log; + res := !res && properly_exited status; + Format.printf ">>> ./rb.exe --tmp=./tmp %d %d: %a.\n%!" order len + pp_process_status status; + if not (properly_exited status) then show filename let () = - run 15 10 ; - run 15 100 ; - run 15 1000 ; + run 15 10; + run 15 100; + run 15 1000; if !res then exit exit_success else exit exit_failure diff --git a/test/tmp.ml b/test/tmp.ml index f310f99..2507cbd 100644 --- a/test/tmp.ml +++ b/test/tmp.ml @@ -14,12 +14,12 @@ let default_dir_init = let from_env var ~absent = match try Some (Sys.getenv var) with Not_found -> None with | None -> absent - | Some v -> - match Fpath.of_string v with - | Error (`Msg err) -> failwith err - | Ok v -> v in - if Sys.os_type = "Win32" - then from_env "TEMP" ~absent:Fpath.(v "./") + | Some v -> ( + match Fpath.of_string v with + | Error (`Msg err) -> failwith err + | Ok v -> v) + in + if Sys.os_type = "Win32" then from_env "TEMP" ~absent:Fpath.(v "./") else from_env "TMPDIR" ~absent:Fpath.(v "/tmp") let default_dir = ref default_dir_init @@ -29,30 +29,32 @@ let default_dir () = !default_dir let create_tmp_path mode dir pat = let err () = R.error_msgf "create temporary file %s in %a: too many failing attemps" - (Fmt.str pat "XXXXXX") Fpath.pp dir in + (Fmt.str pat "XXXXXX") Fpath.pp dir + in let rec go count = - if count < 0 then err () else - let file = rand_path dir pat in - let sfile = Fpath.to_string file in - let open_flags = Unix.[ O_WRONLY; O_CREAT; O_EXCL; ] in - try Ok (file, Unix.openfile sfile open_flags mode) - with - | Unix.Unix_error (Unix.EEXIST, _, _) -> go (count - 1) - | Unix.Unix_error (Unix.EINTR, _, _) -> go count - | Unix.Unix_error (e, _, _) -> - R.error_msgf "create temporary file %a: %s" Fpath.pp file (Unix.error_message e) in + if count < 0 then err () + else + let file = rand_path dir pat in + let sfile = Fpath.to_string file in + let open_flags = Unix.[ O_WRONLY; O_CREAT; O_EXCL ] in + try Ok (file, Unix.openfile sfile open_flags mode) with + | Unix.Unix_error (Unix.EEXIST, _, _) -> go (count - 1) + | Unix.Unix_error (Unix.EINTR, _, _) -> go count + | Unix.Unix_error (e, _, _) -> + R.error_msgf "create temporary file %a: %s" Fpath.pp file + (Unix.error_message e) + in go 1000 type pattern = (string -> string, Format.formatter, unit, string) format4 -let tmp ?(mode= 0o644) ?dir pat = - let dir = match dir with - | None -> default_dir () - | Some d -> d in +let tmp ?(mode = 0o644) ?dir pat = + let dir = match dir with None -> default_dir () | Some d -> d in create_tmp_path mode dir pat >>= fun (file, fd) -> - let rec close fd = try Unix.close fd with + let rec close fd = + try Unix.close fd with | Unix.Unix_error (Unix.EINTR, _, _) -> close fd - | Unix.Unix_error _ -> () in - close fd ; Ok file - - + | Unix.Unix_error _ -> () + in + close fd; + Ok file diff --git a/test/tmp.mli b/test/tmp.mli index f641bc4..3bcea66 100644 --- a/test/tmp.mli +++ b/test/tmp.mli @@ -3,4 +3,5 @@ val set_default_dir : Fpath.t -> unit type pattern = (string -> string, Format.formatter, unit, string) format4 -val tmp : ?mode:int -> ?dir:Fpath.t -> pattern -> (Fpath.t, [> `Msg of string ]) result +val tmp : + ?mode:int -> ?dir:Fpath.t -> pattern -> (Fpath.t, [> `Msg of string ]) result From f15c2cb19d6315015d6625d3fffa36361beb1d39 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 5 Aug 2024 21:19:37 +0200 Subject: [PATCH 2/2] rowex requires hxd for debugging --- rowex.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/rowex.opam b/rowex.opam index 6897fdd..aeff16b 100644 --- a/rowex.opam +++ b/rowex.opam @@ -23,6 +23,7 @@ depends: [ "cmdliner" {>= "1.1.0"} "fpath" "mmap" + "hxd" {>= "0.3.2"} "crowbar" {>= "0.2" & with-test} ] available: