From 2a6ee6553b6bd398a12c6621de489e678af586d9 Mon Sep 17 00:00:00 2001 From: Romain Slootmaekers Date: Fri, 13 Apr 2018 17:59:07 +0200 Subject: [PATCH 1/2] compiles on 4.05.0 + Lwt.4.0.0 --- src/_tags | 6 ++--- src/binary.ml | 4 ++-- src/bsmgr.ml | 8 +++---- src/dbx.ml | 1 - src/flog0.ml | 2 +- src/indexz.ml | 1 - src/key_count_test.ml | 2 +- src/leaf.ml | 2 +- src/log.ml | 2 +- src/lwt_unix_ext.ml | 11 +++++----- src/mlog.ml | 1 - src/myocamlbuild.ml | 4 +++- src/posix.ml | 40 ++++++++++++++++++++++++++++++++++ src/posix.mli | 39 +++++++++------------------------ src/{posix.c => posix_stubs.c} | 0 src/test.ml | 5 ----- src/tree.ml | 14 ++++++------ src/tree_test.ml | 16 +++++++------- 18 files changed, 86 insertions(+), 72 deletions(-) create mode 100644 src/posix.ml rename src/{posix.c => posix_stubs.c} (100%) diff --git a/src/_tags b/src/_tags index d16c438..e69edb4 100644 --- a/src/_tags +++ b/src/_tags @@ -2,10 +2,10 @@ true: annot true: debug true: package(lwt) true: package(lwt.unix) -true: package(lwt.preemptive) -<**/*.ml>: warn_error_A + +<**/*.ml>: warn_A <**/*_test.ml>: -warn_error_A, warn_A -: warn_error_A +: warn_A : use_libbaardskeerder : package(oUnit), use_libbaardskeerder <*_test.*>: package(oUnit), package(quickcheck) diff --git a/src/binary.ml b/src/binary.ml index 4bf0604..c07cb7b 100644 --- a/src/binary.ml +++ b/src/binary.ml @@ -39,8 +39,8 @@ let run_writer ?buffer_size:(bs=64): ('a writer) -> 'a -> (string * int) = let ord = Char.code and uchr = Char.unsafe_chr -and uget = String.unsafe_get -and uset = String.unsafe_set +and uget = Bytes.unsafe_get +and uset = Bytes.unsafe_set let check l s o = if not (o >= 0 && o <= String.length s - l) diff --git a/src/bsmgr.ml b/src/bsmgr.ml index 63156d0..1923c74 100644 --- a/src/bsmgr.ml +++ b/src/bsmgr.ml @@ -17,10 +17,8 @@ * along with Baardskeerder. If not, see . *) -open Unix open Tree open Arg -open Log open Dbx open Sync @@ -56,7 +54,7 @@ let get_store = function | _ -> invalid_arg "get_store" let () = - let command = ref Help in + let command = ref (Help:command) in let dump () = command := Dump in let dump_stream () = command := DumpStream in @@ -139,7 +137,7 @@ let () = then return () else let key = make_key i in - get key >>= fun v -> + get key >>= fun _v -> loop (i+1) in loop 0 @@ -255,7 +253,7 @@ let () = let module MyRewrite = Rewrite.Rewrite(MyF)(MyF)(MyStore) in MyLog.make !fn >>= fun l0 -> let now0 = MyLog.now l0 in - let (x0,y0,g0) = now0 in + let (x0,y0,_g0) = now0 in let now0' = Time.make x0 y0 true in MyLog.init !fn2 now0' >>= fun () -> MyLog.make !fn2 >>= fun l1 -> diff --git a/src/dbx.ml b/src/dbx.ml index aa65f59..90787ef 100644 --- a/src/dbx.ml +++ b/src/dbx.ml @@ -21,7 +21,6 @@ open Base open Tree open Log open Entry -open Slab open Commit open Catchup open Prefix diff --git a/src/flog0.ml b/src/flog0.ml index 319a985..054a94a 100644 --- a/src/flog0.ml +++ b/src/flog0.ml @@ -88,7 +88,7 @@ struct let () = Pack.vint_to b o in let () = Pack.vint_to b m.td in let () = time_to b m.t0 in - let block = String.create _METADATA_SIZE in + let block = Bytes.create _METADATA_SIZE in let () = Buffer.blit b 0 block 0 (Buffer.length b) in diff --git a/src/indexz.ml b/src/indexz.ml index 5a4495e..b5ec5f7 100644 --- a/src/indexz.ml +++ b/src/indexz.ml @@ -18,7 +18,6 @@ *) open Base -open Index type index_z = pos * (kp list) * (kp list) diff --git a/src/key_count_test.ml b/src/key_count_test.ml index 969c86c..c35ffc6 100644 --- a/src/key_count_test.ml +++ b/src/key_count_test.ml @@ -6,7 +6,7 @@ module MDB = DB(Mlog) let setup () = let log = Mlog.make "mlog" in List.iter - (fun k -> MDB.set log k (String.uppercase k)) + (fun k -> MDB.set log k (String.uppercase_ascii k)) ["a";"b";"c";"d";"e";"f";"g";"h";]; log diff --git a/src/leaf.ml b/src/leaf.ml index cffb0bd..4508205 100644 --- a/src/leaf.ml +++ b/src/leaf.ml @@ -37,7 +37,7 @@ let leaf_borrow_right left right = match right with let leaf_borrow_left left right = let rev = List.rev left in match rev with - | h0 :: ((k1,_) :: t as left'rev) -> + | h0 :: ((k1,_) :: _t as left'rev) -> let right' = h0 :: right in let left' = List.rev left'rev in left' , k1, right' diff --git a/src/log.ml b/src/log.ml index 98c72b0..1befed3 100644 --- a/src/log.ml +++ b/src/log.ml @@ -19,7 +19,7 @@ open Entry open Base -open Slab + module type LOG = sig type t diff --git a/src/lwt_unix_ext.ml b/src/lwt_unix_ext.ml index 8fc79f2..46747d1 100644 --- a/src/lwt_unix_ext.ml +++ b/src/lwt_unix_ext.ml @@ -27,7 +27,7 @@ external pread_job : Unix.file_descr -> int -> int -> [ `unix_pread ] job = external pread_result : [ `unix_pread ] job -> string -> int -> int = "lwt_unix_ext_pread_result" external pread_free : [ `unix_pread ] job -> unit = - "lwt_unix_ext_pread_free" "noalloc" + "lwt_unix_ext_pread_free" [@@noalloc] let pread ch buf pos len offset = if pos < 0 || len < 0 || pos > String.length buf - len then @@ -60,7 +60,7 @@ external pwrite_job : Unix.file_descr -> string -> int -> int -> int -> [ `unix_ external pwrite_result : [ `unix_pwrite ] job -> int = "lwt_unix_ext_pwrite_result" external pwrite_free : [ `unix_pwrite ] job -> unit = - "lwt_unix_ext_pwrite_free" "noalloc" + "lwt_unix_ext_pwrite_free" [@@noalloc] let pwrite ch buf pos len offset = if pos < 0 || len < 0 || pos > String.length buf - len then @@ -70,9 +70,10 @@ let pwrite ch buf pos len offset = | true -> Lwt_unix.wait_write ch >>= fun () -> Lwt_unix.execute_job - (pwrite_job (Lwt_unix.unix_file_descr ch) buf pos len offset) - pwrite_result - pwrite_free + ~async_method:Async_detach + ~job:(pwrite_job (Lwt_unix.unix_file_descr ch) buf pos len offset) + ~result:pwrite_result + ~free:pwrite_free | false -> wrap_syscall Lwt_unix.Write ch (fun () -> stub_pwrite (Lwt_unix.unix_file_descr ch) buf pos len offset) diff --git a/src/mlog.ml b/src/mlog.ml index 299db7a..33be5ee 100644 --- a/src/mlog.ml +++ b/src/mlog.ml @@ -19,7 +19,6 @@ open Entry open Base -open Slab type s = { mutable es: entry array; diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml index 139d4cc..4caec58 100644 --- a/src/myocamlbuild.ml +++ b/src/myocamlbuild.ml @@ -45,7 +45,9 @@ let _ = dispatch & function S[ A"-lbaardskeerder_c";]; dep ["link"; "ocaml"; "link_libbaardskeerder"] - ["libbaardskeerder_c.a"]; + ["libbaardskeerder_c.a"; + "posix_stubs.o" + ]; flag ["compile"; "c"] (S[A"-ccopt"; A"-I.."; A"-ccopt"; A"-msse4.2"; diff --git a/src/posix.ml b/src/posix.ml new file mode 100644 index 0000000..b832497 --- /dev/null +++ b/src/posix.ml @@ -0,0 +1,40 @@ +(* pread *) +external pread_into_exactly: Unix.file_descr -> string -> int -> int -> unit + = "_bs_posix_pread_into_exactly" +(* pwrite *) +external pwrite_exactly: Unix.file_descr -> string -> int -> int -> unit + = "_bs_posix_pwrite_exactly" + +(* fsync *) +external fsync: Unix.file_descr -> unit + = "_bs_posix_fsync" +(* fdatasync *) +external fdatasync: Unix.file_descr -> unit + = "_bs_posix_fdatasync" + +(* fallocate *) +external fallocate_FALLOC_FL_KEEP_SIZE: unit -> int + = "_bs_posix_fallocate_FALLOC_FL_KEEP_SIZE" +external fallocate_FALLOC_FL_PUNCH_HOLE: unit -> int + = "_bs_posix_fallocate_FALLOC_FL_PUNCH_HOLE" +external fallocate: Unix.file_descr -> int -> int -> int -> unit + = "_bs_posix_fallocate" + +(* posix_fadvise *) +type posix_fadv = POSIX_FADV_NORMAL + | POSIX_FADV_SEQUENTIAL + | POSIX_FADV_RANDOM + | POSIX_FADV_NOREUSE + | POSIX_FADV_WILLNEED + | POSIX_FADV_DONTNEED + +external posix_fadvise: Unix.file_descr -> int -> int -> posix_fadv -> unit + = "_bs_posix_fadvise" + +(* stat blksize *) +external fstat_blksize: Unix.file_descr -> int + = "_bs_posix_fstat_blksize" + +(* fiemap ioctl *) +external ioctl_fiemap: Unix.file_descr -> (int64 * int64 * int64 * int32) list + = "_bs_posix_ioctl_fiemap" diff --git a/src/posix.mli b/src/posix.mli index 1e5f6e0..5de3aa5 100644 --- a/src/posix.mli +++ b/src/posix.mli @@ -17,29 +17,16 @@ * along with Baardskeerder. If not, see . *) -(* pread *) -external pread_into_exactly: Unix.file_descr -> string -> int -> int -> unit - = "_bs_posix_pread_into_exactly" -(* pwrite *) -external pwrite_exactly: Unix.file_descr -> string -> int -> int -> unit - = "_bs_posix_pwrite_exactly" +val pread_into_exactly: Unix.file_descr -> string -> int -> int -> unit +val pwrite_exactly: Unix.file_descr -> string -> int -> int -> unit +val fsync: Unix.file_descr -> unit +val fdatasync: Unix.file_descr -> unit -(* fsync *) -external fsync: Unix.file_descr -> unit - = "_bs_posix_fsync" -(* fdatasync *) -external fdatasync: Unix.file_descr -> unit - = "_bs_posix_fdatasync" -(* fallocate *) -external fallocate_FALLOC_FL_KEEP_SIZE: unit -> int - = "_bs_posix_fallocate_FALLOC_FL_KEEP_SIZE" -external fallocate_FALLOC_FL_PUNCH_HOLE: unit -> int - = "_bs_posix_fallocate_FALLOC_FL_PUNCH_HOLE" -external fallocate: Unix.file_descr -> int -> int -> int -> unit - = "_bs_posix_fallocate" +val fallocate_FALLOC_FL_KEEP_SIZE: unit -> int +val fallocate_FALLOC_FL_PUNCH_HOLE: unit -> int +val fallocate: Unix.file_descr -> int -> int -> int -> unit -(* posix_fadvise *) type posix_fadv = POSIX_FADV_NORMAL | POSIX_FADV_SEQUENTIAL | POSIX_FADV_RANDOM @@ -47,13 +34,7 @@ type posix_fadv = POSIX_FADV_NORMAL | POSIX_FADV_WILLNEED | POSIX_FADV_DONTNEED -external posix_fadvise: Unix.file_descr -> int -> int -> posix_fadv -> unit - = "_bs_posix_fadvise" +val posix_fadvise: Unix.file_descr -> int -> int -> posix_fadv -> unit +val fstat_blksize: Unix.file_descr -> int -(* stat blksize *) -external fstat_blksize: Unix.file_descr -> int - = "_bs_posix_fstat_blksize" - -(* fiemap ioctl *) -external ioctl_fiemap: Unix.file_descr -> (int64 * int64 * int64 * int32) list - = "_bs_posix_ioctl_fiemap" +val ioctl_fiemap: Unix.file_descr -> (int64 * int64 * int64 * int32) list diff --git a/src/posix.c b/src/posix_stubs.c similarity index 100% rename from src/posix.c rename to src/posix_stubs.c diff --git a/src/test.ml b/src/test.ml index 2ea1af8..3ecc244 100644 --- a/src/test.ml +++ b/src/test.ml @@ -18,11 +18,6 @@ *) open OUnit -open Log -open Tree -open Entry -open Base -open Index let suite = "correctness" >::: diff --git a/src/tree.ml b/src/tree.ml index 97a7243..533210e 100644 --- a/src/tree.ml +++ b/src/tree.ml @@ -61,7 +61,7 @@ module DB = functor (L:LOG ) -> struct let pos' = loop p0 kps in descend pos' in - let rec descend_root () = + let descend_root () = if Slab.is_empty slab then let pos = L.last t in @@ -593,7 +593,7 @@ module DB = functor (L:LOG ) -> struct let range (t:L.t) (first:k option) (finc:bool) (last:k option) (linc:bool) (max:int option) = let acc = ref [] in - let f k vpos = + let f k _vpos = let () = acc := k :: !acc in return () in @@ -637,7 +637,7 @@ module DB = functor (L:LOG ) -> struct | Value _ -> failwith "Tree._fold_reverse_range_while: unexpected entry Value" | Leaf leaf -> walk_leaf s leaf | Index index -> walk_index s index - | Commit c -> failwith "Tree._fold_reverse_range_while: unexpected entry Commit" + | Commit _c -> failwith "Tree._fold_reverse_range_while: unexpected entry Commit" and walk_leaf s leaf = let rec loop s' = function | [] -> return (true, s') @@ -657,13 +657,13 @@ module DB = functor (L:LOG ) -> struct and walk_index s (p, kps) = let rec loop s' = function | [] -> walk s' p - | (k, p') :: kps when left_of_range k -> + | (k, p') :: _kps when left_of_range k -> (* Need to check one index entry left of the lowest 'valid' * entry, since it might point to some more valid keys *) walk s' p' - | (k, p') :: kps when right_of_range k -> + | (k, _p') :: kps when right_of_range k -> loop s' kps - | (k, p') :: kps -> + | (_k, p') :: kps -> walk s' p' >>= fun (cont, s'') -> if cont then @@ -786,7 +786,7 @@ module DB = functor (L:LOG ) -> struct | Leaf l -> return (c + List.length l) | Index (p0, kps) -> _kc_descend t slab p0 c >>= fun c' -> - foldl (fun acc (k,p) -> _kc_descend t slab p acc) c' kps + foldl (fun acc (_k,p) -> _kc_descend t slab p acc) c' kps | Commit _ -> failwith "reaced a second commit on descend" in let _kc_descend_root t slab = diff --git a/src/tree_test.ml b/src/tree_test.ml index b8cc0f9..3089c01 100644 --- a/src/tree_test.ml +++ b/src/tree_test.ml @@ -63,7 +63,7 @@ let mem_wrap t = OUnit.bracket mem_setup t mem_teardown let check q kvs = List.iter (fun k -> - let v = String.uppercase k in + let v = String.uppercase_ascii k in let vo = Base.OK v in OUnit.assert_equal vo (q.get q.log k)) kvs @@ -141,7 +141,7 @@ let insert_delete_1 q = -let set_all q kvs = List.iter (fun k -> let v = String.uppercase k in q.set q.log k v) kvs +let set_all q kvs = List.iter (fun k -> let v = String.uppercase_ascii k in q.set q.log k v) kvs let delete_all_check q kvs = let rec loop acc = function @@ -199,7 +199,7 @@ let insert_delete_bug q = "g"; "m"; "q"; "t"; "w";"z"] in - List.iter (fun k -> let v = String.uppercase k in q.set q.log k v) kvs; + List.iter (fun k -> let v = String.uppercase_ascii k in q.set q.log k v) kvs; _ok_delete q "a"; _ok_delete q "b"; _ok_delete q "j"; @@ -210,10 +210,10 @@ let insert_delete_bug2 q = "g";"j"; "m"; "q"; "t"; "w";"z"] in - List.iter (fun k -> let v = String.uppercase k in q.set q.log k v) kvs; + List.iter (fun k -> let v = String.uppercase_ascii k in q.set q.log k v) kvs; _ok_delete q "a"; let kvs' = List.filter ( (<>) "a") kvs in - List.iter (fun k -> let vo = Base.OK (String.uppercase k) in + List.iter (fun k -> let vo = Base.OK (String.uppercase_ascii k) in let vo2 = q.get q.log k in OUnit.assert_equal vo vo2) kvs' @@ -223,7 +223,7 @@ let insert_delete_bug3 q = "k";"l";"m";"n";"o"; "p";] in - List.iter (fun k -> let v = String.uppercase k in q.set q.log k v) kvs; + List.iter (fun k -> let v = String.uppercase_ascii k in q.set q.log k v) kvs; set_all q kvs; check q kvs; _ok_delete q "a"; @@ -308,7 +308,7 @@ let insert_delete_permutations_generic n q = try q.clear q.log; if n mod 500 = 0 then Printf.printf "n=%i\n%!" n; - Array.iter (fun k -> q.set q.log k (String.uppercase k)) a; + Array.iter (fun k -> q.set q.log k (String.uppercase_ascii k)) a; check q (Array.to_list a); Array.iter (fun k -> let () = check_invariants q in _ok_delete q k) a; check_empty q @@ -356,7 +356,7 @@ let insert_static_delete_permutations_generic n (q: 'a q) = q.clear q.log; (*Printf.printf "-----\n"; *) if n mod 500 = 0 then Printf.printf "n=%i\n%!" n; - List.iter (fun k -> q.set q.log k (String.uppercase k)) kvs; + List.iter (fun k -> q.set q.log k (String.uppercase_ascii k)) kvs; check q kvs; Array.iter (fun k -> check_invariants q; _ok_delete q k) a; check_empty q From a4c71ca4f13f913dc6cf2809c65379eda6e5a8bb Mon Sep 17 00:00:00 2001 From: Romain Slootmaekers Date: Fri, 13 Apr 2018 18:17:18 +0200 Subject: [PATCH 2/2] cleanup --- src/baardskeerder.mli | 2 -- src/base.ml | 4 --- src/base_test.ml | 4 +-- src/bsmgr.ml | 10 ++++---- src/catchup.ml | 44 +++++++++++++------------------- src/catchup_test.ml | 6 ++--- src/dbx.ml | 48 +++++++++++++++++------------------ src/dbx_test.ml | 29 ++++++++++----------- src/entry.ml | 11 ++++++++ src/flog.ml | 22 ++++++++-------- src/flog0.ml | 59 ++++++++++++++++++++++--------------------- src/flog_test.ml | 32 +++++++++++------------ src/mlog.ml | 26 +++++++++---------- src/mlog_lwt_test.ml | 7 +++-- src/pack.ml | 18 +++---------- src/pos.ml | 8 ++++++ src/prefix.ml | 2 +- src/prefix_test.ml | 9 +++---- src/range_test.ml | 4 +-- src/rewrite.ml | 7 +++-- src/rewrite_test.ml | 2 +- src/slab.ml | 11 ++++---- src/store.ml | 8 +++--- src/sync.ml | 6 ++--- src/tree.ml | 37 +++++++++++++-------------- src/tree_test.ml | 23 ++++++++--------- 26 files changed, 210 insertions(+), 229 deletions(-) diff --git a/src/baardskeerder.mli b/src/baardskeerder.mli index 2405caa..da854e3 100644 --- a/src/baardskeerder.mli +++ b/src/baardskeerder.mli @@ -25,8 +25,6 @@ type action = | Set of k * v | Delete of k -type ('a,'b) result = | OK of 'a | NOK of 'b - val init : string -> unit val make : string -> t val close : t -> unit diff --git a/src/base.ml b/src/base.ml index 852b705..c1a3e18 100644 --- a/src/base.ml +++ b/src/base.ml @@ -32,10 +32,6 @@ type action = |Delete of k -type ('a,'b) result = - | OK of 'a - | NOK of 'b - type kp = k * pos let kpl2s l = diff --git a/src/base_test.ml b/src/base_test.ml index 954e36b..55eb760 100644 --- a/src/base_test.ml +++ b/src/base_test.ml @@ -1,3 +1,3 @@ let ok_or_fail = function - | Base.OK () -> Mlog.return () - | Base.NOK _ -> failwith "NOK" + | Ok () -> Mlog.return () + | Error _ -> failwith "Error" diff --git a/src/bsmgr.ml b/src/bsmgr.ml index 1923c74..fd03fe3 100644 --- a/src/bsmgr.ml +++ b/src/bsmgr.ml @@ -152,8 +152,8 @@ let () = else let key = make_key i in delete key >>= function - | Base.OK () -> loop (i+1) - | Base.NOK k -> failwith (Printf.sprintf "%s not found" k) + | Ok () -> loop (i+1) + | Error k -> failwith (Printf.sprintf "%s not found" k) in loop 0 in @@ -165,7 +165,7 @@ let () = let rec loop i = let kn = b+ i in if i = m || kn >= n - then return (Base.OK ()) + then return (Ok ()) else let k = make_key kn in MyDBX.set tx k v >>= fun () -> @@ -181,8 +181,8 @@ let () = then MyLog.sync db else set_tx i >>= function - | Base.OK () -> loop (i+m) - | Base.NOK k -> failwith (Printf.sprintf "NOK %s" k) + | Ok () -> loop (i+m) + | Error k -> failwith (Printf.sprintf "Error %s" k) in loop 0 in diff --git a/src/catchup.ml b/src/catchup.ml index 27da244..7c85133 100644 --- a/src/catchup.ml +++ b/src/catchup.ml @@ -10,19 +10,12 @@ module Catchup(L: LOG) = struct let (>>=) = L.bind let read_value log pos = - (L.read log pos) >>= (function - | Value v -> L.return v - | e -> failwith (Printf.sprintf "Catchup:%s is not a value" (entry2s e)) - ) + L.read log pos >>= fun e -> + L.return (get_value e) let read_commit log pos = - L.bind - (L.read log pos) - (function - | Commit c -> L.return c - | e -> failwith (Printf.sprintf "Catchup:%s is not commit" (entry2s e)) - ) - + L.read log pos >>= fun e -> + L.return (get_commit e) let translate_caction log = function | CSet (k,vp) -> read_value log vp >>= fun v -> L.return (Set (k,v)) @@ -42,21 +35,20 @@ module Catchup(L: LOG) = struct let catchup (i0: int64) (f : 'a -> int64 -> action list -> 'a L.m) (a0:'a) (log : L.t) = let start = (i0, 0,false) in let rec go_back acc p = - L.bind - (L.read log p) - (function - | Commit c -> - let t0 = Commit.get_time c in - if t0 =>: start - then - let p' = Commit.get_previous c in - go_back (p::acc) p' - else - L.return acc - | NIL -> - L.return acc - | e -> failwith (Printf.sprintf "Catchup:%s is not commit" (entry2s e)) - ) + L.read log p >>= + function + | Commit c -> + let t0 = Commit.get_time c in + if t0 =>: start + then + let p' = Commit.get_previous c in + go_back (p::acc) p' + else + L.return acc + | NIL -> + L.return acc + | Value _ | Leaf _ | Index _ as e -> Entry.wrong "commit|nil" e + in go_back [] (L.last log) >>= fun ps -> match ps with diff --git a/src/catchup_test.ml b/src/catchup_test.ml index 39055b8..fb2589e 100644 --- a/src/catchup_test.ml +++ b/src/catchup_test.ml @@ -8,11 +8,11 @@ module MDBX = DBX(Mlog) let (>>=) = Mlog.bind -let ok_set tx ki vi = MDBX.set tx ki vi >>= fun () -> return (Base.OK ()) +let ok_set tx ki vi = MDBX.set tx ki vi >>= fun () -> return (Ok ()) let ok_unit x = match x with - | Base.OK () -> Mlog.return () - | Base.NOK _ -> failwith "should not happen" + | Ok () -> Mlog.return () + | Error _ -> failwith "should not happen" let catchup1 () = let fn = "mlog" in diff --git a/src/dbx.ml b/src/dbx.ml index 90787ef..253f050 100644 --- a/src/dbx.ml +++ b/src/dbx.ml @@ -49,11 +49,11 @@ module DBX(L:LOG) = struct let delete tx k = DBL._delete tx.log tx.slab k >>= fun r -> let r' = match r with - | OK _ -> + | Ok _ -> let a = CDelete k in let () = tx.cactions <- a :: tx.cactions in - OK () - | NOK k -> NOK k + Ok () + | Error k -> Error k in return r' @@ -65,7 +65,7 @@ module DBX(L:LOG) = struct let tx = {log;slab;cactions = []} in f tx >>= fun txr -> match txr with - | OK a -> + | Ok _a -> let root = Slab.length tx.slab -1 in let previous = L.last log in let pos = Inner root in @@ -77,7 +77,7 @@ module DBX(L:LOG) = struct let slab' = Slab.compact tx.slab in L.write log slab' >>= fun () -> return txr - | NOK k -> return txr + | Error _k -> return txr @@ -93,15 +93,15 @@ module DBX(L:LOG) = struct let prefix_keys (tx:tx) (prefix : string) (max: int option) = PrL.prefix_keys tx.log tx.slab prefix max - let multi_delete (tx:tx) (keys: k list) : (int,k) Base.result L.m = + let multi_delete (tx:tx) (keys: k list) : (int,k) result L.m = let rec _inner (acc:int) keys = match keys with - | [] -> let r = OK acc in + | [] -> let r = Ok acc in return r | k :: keys -> begin delete tx k >>= function - | OK r -> _inner (acc+1) keys - | NOK k -> return (NOK k) + | Ok _r -> _inner (acc+1) keys + | Error k -> return (Error k) end in _inner 0 keys @@ -110,19 +110,19 @@ module DBX(L:LOG) = struct let rec _inner tx acc : (int,Base.k) result L.m = prefix_keys tx prefix max >>= fun keys -> match keys with - | [] -> return (OK acc) + | [] -> return (Ok acc) | keys -> begin multi_delete tx keys >>= fun r -> match r with - | OK i -> + | Ok i -> _inner tx (acc + i) - | r -> return r + | Error _ -> return r end in _inner tx 0 >>= function - | OK i -> return i - | NOK k -> failwith (Printf.sprintf "delete_prefix: %s" k) + | Ok i -> return i + | Error k -> failwith (Printf.sprintf "delete_prefix: %s" k) let log_update (log:L.t) ?(diff = true) (f: tx -> ('a,'b) result L.m) = let previous = L.last log in @@ -134,7 +134,7 @@ module DBX(L:LOG) = struct else Commit.get_lookup lc in return lu | NIL -> return previous - | e -> failwith (Printf.sprintf "log_update: %s is not commit" (entry2s e)) + | Value _ | Index _ | Leaf _ as e -> wrong "Commit|Nil" e in let now = L.now log in let fut = if diff then Time.next_major now else now in @@ -144,7 +144,7 @@ module DBX(L:LOG) = struct _find_lookup () >>= fun lookup -> f tx >>= function - | OK x -> + | Ok x -> begin let sl = Slab.length tx.slab in if sl > 0 @@ -157,7 +157,7 @@ module DBX(L:LOG) = struct let _ = Slab.add tx.slab c in let slab' = Slab.compact tx.slab in L.write log slab' >>= fun () -> - return (OK x) + return (Ok x) end else (* This is an empty transaction *) begin @@ -165,7 +165,7 @@ module DBX(L:LOG) = struct begin function | Commit lc -> return (Commit.get_pos lc) | NIL -> return (Inner (-1)) - | e -> failwith (Printf.sprintf "log_update %s is not a commit" (entry2s e)) + | Value _ | Leaf _ | Index _ as e -> wrong "commit|nil" e end >>= fun ppos -> let commit = make_commit @@ -179,16 +179,16 @@ module DBX(L:LOG) = struct let _ = Slab.add tx.slab c in let slab' = Slab.compact tx.slab in L.write log slab' >>= fun () -> - return (OK x) + return (Ok x) end end - | NOK k -> return (NOK k) + | Error k -> return (Error k) let commit_last (log:L.t) = let pp = L.last log in - (L.read log pp >>= function - | Commit lc -> L.return lc - | e -> failwith (Printf.sprintf "_read_commit: %s is not commit" (entry2s e)) + (L.read log pp >>= fun entry -> + let lc = get_commit entry in + L.return lc ) >>= fun lc -> let time = Commit.get_time lc in let slab = Slab.make time in @@ -213,6 +213,6 @@ module DBX(L:LOG) = struct CaL.translate_cactions log cas >>= fun actions -> L.return (Some (i, actions, explicit)) | NIL -> L.return None - | e -> failwith (Printf.sprintf "last_update: %s should be commit" (entry2s e)) + | Value _ | Index _ | Leaf _ as e -> wrong "commit|nil" e end diff --git a/src/dbx_test.ml b/src/dbx_test.ml index 153061c..497fe77 100644 --- a/src/dbx_test.ml +++ b/src/dbx_test.ml @@ -24,7 +24,6 @@ open Prefix module MDBX = DBX(Mlog) module MDB = DB(Mlog) module MPR = Prefix(Mlog) -open Base open Base_test let (>>=) = Mlog.bind @@ -37,7 +36,7 @@ let _setup () = let _ok_set tx k v = MDBX.set tx k v >>= fun () -> - Mlog.return (OK ()) + Mlog.return (Ok ()) let get_after_delete () = let mlog = _setup() in @@ -49,7 +48,7 @@ let get_after_delete () = Mlog.return r in let v2 = MDBX.with_tx mlog test in - OUnit.assert_equal (NOK "a") v2 + OUnit.assert_equal (Error "a") v2 @@ -59,7 +58,7 @@ let get_after_log_update () = and v = "A" in let _ = MDBX.log_update mlog (fun tx -> _ok_set tx k v) in let test = MDB.get mlog k in - OUnit.assert_equal (NOK k) test + OUnit.assert_equal (Error k) test let get_after_log_updates() = let mlog = _setup() in @@ -73,7 +72,7 @@ let get_after_log_updates() = >>= ok_or_fail >>= fun () -> let test = MDB.get mlog k in Mlog.dump mlog; - OUnit.assert_equal (NOK k) test + OUnit.assert_equal (Error k) test let update_commit_get() = let mlog = _setup() in @@ -84,12 +83,12 @@ let update_commit_get() = MDBX.commit_last mlog >>= fun () -> Mlog.dump mlog; MDB.get mlog k >>= fun vo2 -> - OUnit.assert_equal vo2 (OK v) + OUnit.assert_equal vo2 (Ok v) let delete_empty () = let mlog = _setup() in let k = "non-existing" in - OUnit.assert_equal (Base.NOK k) (MDBX.with_tx mlog (fun tx -> MDBX.delete tx k)) + OUnit.assert_equal (Error k) (MDBX.with_tx mlog (fun tx -> MDBX.delete tx k)) let delete_prefix () = @@ -98,7 +97,7 @@ let delete_prefix () = (fun tx -> let rec loop i = if i = 16 - then Mlog.return (OK ()) + then Mlog.return (Ok ()) else let k = Printf.sprintf "a%03i" i in let v = "X" in @@ -112,16 +111,16 @@ let delete_prefix () = let prefix = "a00" in MDBX.with_tx mlog (fun tx -> MDBX.delete_prefix tx prefix - >>= fun c -> Mlog.return (OK c)) + >>= fun c -> Mlog.return (Ok c)) >>= function - | OK c -> OUnit.assert_equal ~printer:string_of_int 10 c - | NOK _ -> failwith "can't happen" + | Ok c -> OUnit.assert_equal ~printer:string_of_int 10 c + | Error _ -> failwith "can't happen" let log_nothing () = let mlog = _setup() in - let ok = OK () in + let ok = Ok () in let x = MDBX.log_update mlog (fun _ -> Mlog.return ok) in OUnit.assert_equal ok x; () @@ -130,18 +129,18 @@ let log_nothing () = let log_bug2() = let mlog = _setup() in let _ = MDBX.log_update mlog (fun tx -> _ok_set tx "k" "v") in - let ok = OK () in + let ok = Ok () in let _ = MDBX.log_update mlog (fun _ -> Mlog.return ok) in () let log_bug3() = let mlog = _setup () in let _ = MDBX.log_update mlog ~diff:true (fun tx -> _ok_set tx "x" "X") in - let _ = MDBX.log_update mlog ~diff:true (fun _ -> Mlog.return (OK ())) in + let _ = MDBX.log_update mlog ~diff:true (fun _ -> Mlog.return (Ok ())) in MDBX.commit_last mlog >>= fun () -> Mlog.dump mlog; MDB.get mlog "x" >>= fun r -> - OUnit.assert_equal r (OK "X"); + OUnit.assert_equal r (Ok "X"); () diff --git a/src/entry.ml b/src/entry.ml index 8bf9f21..9a69a09 100644 --- a/src/entry.ml +++ b/src/entry.ml @@ -33,6 +33,7 @@ type entry = | Index of index | Commit of commit + type dir = | Leaf_down of leaf_z | Index_down of index_z @@ -49,3 +50,13 @@ let entry2s = function let string_of_dir = function | Leaf_down l -> Printf.sprintf "Leaf_down %s" (lz2s l) | Index_down i -> Printf.sprintf "Index_down (%s)" (iz2s i) + +let wrong expected e = Printf.sprintf "%s is not a %s" (entry2s e) expected |> failwith + +let get_value = function + | Value v -> v + | NIL | Leaf _ | Index _ | Commit _ as e -> wrong "value" e + +let get_commit = function + | Commit c -> c + | NIL | Value _ | Leaf _ | Index _ as e -> wrong "commit" e diff --git a/src/flog.ml b/src/flog.ml index e9bd12d..9dfdc1c 100644 --- a/src/flog.ml +++ b/src/flog.ml @@ -137,7 +137,7 @@ module SerDes = struct and index_tag = chr3 and commit_tag = chr4 - let calculate_size_commit = + let _calculate_size_commit = calculate_size_envelope (fun (_:int) -> Binary.size_char8 + Binary.size_uint64) and commit_writer = Binary.const Binary.write_char8 commit_tag >> @@ -155,7 +155,7 @@ module SerDes = struct Binary.return $ Commit c - let calculate_size_value = + let _calculate_size_value = calculate_size_envelope (fun s -> Binary.size_uint8 + Binary.size_uint8 + Binary.size_string s) and value_writer = @@ -323,7 +323,7 @@ struct and deserialize_commit = deserialize_helper SerDes.commit_reader let serialize_value = serialize_helper SerDes.value_writer - and deserialize_value = deserialize_helper SerDes.value_reader + and _deserialize_value = deserialize_helper SerDes.value_reader let serialize_leaf h = serialize_helper (SerDes.leaf_writer h) and deserialize_leaf = deserialize_helper SerDes.leaf_reader @@ -471,7 +471,7 @@ struct let sl = Slab.length slab in let h = Hashtbl.create sl in let start = ref t.offset in - let rec do_one i e = + let do_one i e = begin let s = serialize_entry h e in let size = String.length s + String.length marker' in @@ -562,9 +562,9 @@ struct let lookup t = let p = last t in - read t p >>= function - | Commit c -> return (Commit.get_lookup c) - | _ -> failwith "Flog.lookup: can only do commit" + read t p >>= fun e -> + let c = get_commit e in + return (Commit.get_lookup c) let sync t = (* Retrieve current commit offset *) @@ -621,8 +621,6 @@ struct let compare = Pervasives.compare end - open OffsetOrder - module OffsetSet = Set.Make(OffsetOrder) type compact_state = { @@ -763,13 +761,13 @@ struct | Leaf _ | Value _ | Index _ -> invalid_arg "Flog.compact: no commit entry at given offset" - let set_metadata t s = + let set_metadata _t _s = failwith "not implemented" - let unset_metadata t = + let unset_metadata _t = failwith "not implemented" - let get_metadata t = + let get_metadata _t = failwith "not implemented" end (* module / functor *) diff --git a/src/flog0.ml b/src/flog0.ml index 054a94a..7debfcf 100644 --- a/src/flog0.ml +++ b/src/flog0.ml @@ -17,8 +17,6 @@ * along with Baardskeerder. If not, see . *) -open Store - open Base open Entry open Unix @@ -157,10 +155,8 @@ struct | INDEX -> Buffer.add_char b '\x03' | VALUE -> Buffer.add_char b '\x04' - open Pack let input_tag input = - let tc = input.s.[input.p] in - let () = input.p <- input.p + 1 in + let tc = Pack.input_char input in match tc with | '\x01' -> COMMIT | '\x02' -> LEAF @@ -170,7 +166,8 @@ struct let inflate_action input = - let t = input_char input in + let t = Pack.input_char input in + let open Pack in match t with | 'D' -> let k = input_string input in Commit.CDelete k @@ -197,11 +194,11 @@ struct Commit.make_commit ~pos ~previous ~lookup t actions explicit - let inflate_value input = input_string input + let inflate_value input = Pack.input_string input let input_suffix_list input = - let prefix = input_string input in - let suffixes = input_list input input_kp in + let prefix = Pack.input_string input in + let suffixes = Pack.input_list input input_kp in let kps = List.map (fun (s,p) -> (prefix ^s, p)) suffixes in kps @@ -209,8 +206,8 @@ struct let inflate_index input = - let _ = input_vint input in (* spindle *) - let p0 = input_vint input in + let _ = Pack.input_vint input in (* spindle *) + let p0 = Pack.input_vint input in let kps = input_suffix_list input in Outer (0, p0), kps @@ -222,7 +219,7 @@ struct | VALUE -> Value (inflate_value input) let inflate_entry es = - let input = make_input es 0 in + let input = Pack.make_input es 0 in input_entry input @@ -255,7 +252,7 @@ struct let _add_buffer b mb = let l = Buffer.length mb in - size_to b l; + Pack.size_to b l; Buffer.add_buffer b mb; l + 4 @@ -263,7 +260,7 @@ struct let l = String.length v in let mb = Buffer.create (l+5) in tag_to mb VALUE; - string_to mb v; + Pack.string_to mb v; _add_buffer b mb let pos_remap mb h p = @@ -272,10 +269,11 @@ struct | Inner x when x = -1-> (0,0) (* TODO: don't special case with -1 *) | Inner x -> Hashtbl.find h x in - vint_to mb s; - vint_to mb o + Pack.vint_to mb s; + Pack.vint_to mb o let kps_to mb h kps = + let open Pack in let px = Leaf.shared_prefix kps in let pxs = String.length px in string_to mb px; @@ -303,16 +301,19 @@ struct _add_buffer b mb - let deflate_action b h = function + let deflate_action b h = + let open Pack in + function | Commit.CSet (k,p) -> - Buffer.add_char b 'S'; - string_to b k; - pos_remap b h p + Buffer.add_char b 'S'; + string_to b k; + pos_remap b h p | Commit.CDelete k -> - Buffer.add_char b 'D'; - string_to b k + Buffer.add_char b 'D'; + string_to b k let deflate_commit b h c = + let open Pack in let mb = Buffer.create 8 in tag_to mb COMMIT; let pos = Commit.get_pos c in @@ -453,10 +454,10 @@ struct let lookup t = let p = last t in - read t p >>= function - | Commit c -> let lu = Commit.get_lookup c in return lu - | e -> failwith "can only do commits" - + read t p >>= fun e -> + let c = get_commit e in + let lu = Commit.get_lookup c in + return lu let init ?(d=8) fn t0 = S.init fn >>= fun s -> @@ -498,7 +499,7 @@ struct match eso with | Some es -> begin - let input = make_input es 0 in + let input = Pack.make_input es 0 in let e = input_entry input in let next = tbr + 4 + String.length es in let lt' = @@ -506,7 +507,7 @@ struct | Commit c -> let time = Commit.get_time c in (0, tbr), time - | e -> lt + | NIL | Index _ | Leaf _ | Value _ -> lt in _scan_forward lt' next @@ -533,7 +534,7 @@ struct let f = t.filename ^ ".meta" in let o = f ^ ".new" in let b = Buffer.create 128 in - size_to b (String.length s); + Pack.size_to b (String.length s); Buffer.add_string b s; let s' = Buffer.contents b in S.init o >>= fun fd -> diff --git a/src/flog_test.ml b/src/flog_test.ml index 863e00b..90c24c0 100644 --- a/src/flog_test.ml +++ b/src/flog_test.ml @@ -23,8 +23,6 @@ open Unix open Tree open Flog -open Base - module MyFlog = Flog(Store.Sync) @@ -52,7 +50,7 @@ let test_uintN wf rf l n () = let l' = String.length s in OUnit.assert_equal ~printer:string_of_int l l'; - let s' = String.create (l' + 10) in + let s' = Bytes.create (l' + 10) in let o = Random.int 10 in String.blit s 0 s' o l'; @@ -183,7 +181,7 @@ let test_database_set_get _ db = FDB.set db k v; let vo' = FDB.get db k in - let vo = OK v in + let vo = Ok v in OUnit.assert_equal vo vo' let test_database_multi_action _ db = @@ -196,15 +194,15 @@ let test_database_multi_action _ db = FDB.set db k1 v1; FDB.set db k2 v2; let my_get k = FDB.get db k in - OUnit.assert_equal (OK v1) (my_get k1); - OUnit.assert_equal (OK v2) (my_get k2); + OUnit.assert_equal (Ok v1) (my_get k1); + OUnit.assert_equal (Ok v2) (my_get k2); FDB.set db k1 v1'; - OUnit.assert_equal (OK v1') (my_get k1); + OUnit.assert_equal (Ok v1') (my_get k1); let r = FDB.delete db k2 in - OUnit.assert_equal (Base.OK ()) r; - OUnit.assert_equal (NOK k2) (my_get k2) + OUnit.assert_equal (Ok ()) r; + OUnit.assert_equal (Error k2) (my_get k2) let test_database_reopen fn db = @@ -223,8 +221,8 @@ let test_database_reopen fn db = let vo1' = my_get k1 and vo2' = my_get k2 in - OUnit.assert_equal (OK v1) vo1'; - OUnit.assert_equal (OK v2) vo2'; + OUnit.assert_equal (Ok v1) vo1'; + OUnit.assert_equal (Ok v2) vo2'; MyFlog.close db' @@ -238,7 +236,7 @@ let test_database_sync fn db = MyFlog.sync db; MyFlog.sync db; let my_get k = FDB.get db k in - let vo = OK v in + let vo = Ok v in OUnit.assert_equal (my_get k) vo; MyFlog.close db; @@ -290,7 +288,7 @@ let test_compaction_basic fn db = let db' = MyFlog.make fn in let my_get k = FDB.get db' k in - OUnit.assert_equal (my_get "foo") (OK "bal"); + OUnit.assert_equal (my_get "foo") (Ok "bal"); MyFlog.close db'; dump_fiemap fn @@ -320,7 +318,7 @@ let test_compaction_lengthy fn db = | n -> let key = Printf.sprintf "key_%d" n in let r = FDB.delete db key in - assert (r = Base.OK ()); + assert (r = Ok ()); loop2 (pred n) in @@ -349,7 +347,7 @@ let test_compaction_all_states m c fn db = | i when i = (n - 1) -> () | i -> let key = Printf.sprintf "key_%d" i in - OUnit.assert_equal (NOK key) (FDB.get db key); + OUnit.assert_equal (Error key) (FDB.get db key); check_deleted n (pred i) in @@ -358,7 +356,7 @@ let test_compaction_all_states m c fn db = | i -> let key = Printf.sprintf "key_%d" i and value = Printf.sprintf "value_%d" i in - OUnit.assert_equal (OK value) (FDB.get db key); + OUnit.assert_equal (Ok value) (FDB.get db key); check_existing (pred i) in @@ -368,7 +366,7 @@ let test_compaction_all_states m c fn db = MyFlog.compact ~min_blocks:m db; let key = Printf.sprintf "key_%d" n in let r = FDB.delete db key in - assert (r = Base.OK ()); + assert (r = Ok ()); check_deleted n t; check_existing (pred n); test_loop t (pred n) diff --git a/src/mlog.ml b/src/mlog.ml index 33be5ee..c0e2004 100644 --- a/src/mlog.ml +++ b/src/mlog.ml @@ -118,23 +118,21 @@ let last t = let size (_:entry) = 1 -let read t = function - | Outer (s, o) -> - if o < 0 - then NIL - else Array.get (Array.get t.spindles s).es o - | Inner _ -> failwith "can't read inner" +let read t pos = + let s,o = get_out pos in + if o < 0 + then NIL + else Array.get (Array.get t.spindles s).es o let lookup (t:t) = let (p0:pos) = last t in - match p0 with - | Inner _ -> failwith "can't do inner" - | p0 -> bind (read t p0) - (function - | Commit c -> Commit.get_lookup c - | e -> failwith "no commit" - ) + bind + (read t p0) + (fun e -> + let c = get_commit e in + Commit.get_lookup c + ) let dump ?out:(o=stdout) (t:t) = Printf.fprintf o "Next = %d %d\n" t.current_spindle @@ -154,7 +152,7 @@ let dump ?out:(o=stdout) (t:t) = let clear (t:t) = Array.iteri - (fun i s -> + (fun _i s -> s.next <- 0; Array.fill s.es 0 (Array.length s.es) NIL) t.spindles; diff --git a/src/mlog_lwt_test.ml b/src/mlog_lwt_test.ml index ab80952..d33381c 100644 --- a/src/mlog_lwt_test.ml +++ b/src/mlog_lwt_test.ml @@ -1,8 +1,7 @@ -open Lwt +open Lwt.Infix open OUnit open Tree -open Base module MDB = DB(Mlog_lwt) @@ -18,8 +17,8 @@ let test_set db = let test_set_get db = MDB.set db "key" "value" >>= fun () -> MDB.get db "key" >>= fun vo -> - OUnit.assert_equal vo (OK "value"); - return () + OUnit.assert_equal vo (Ok "value"); + Lwt.return_unit let basic = "basic" >::: [ diff --git a/src/pack.ml b/src/pack.ml index 171fd67..b109814 100644 --- a/src/pack.ml +++ b/src/pack.ml @@ -1,18 +1,8 @@ -let size_from s pos = - let byte_of i= Char.code s.[pos + i] in - let b0 = byte_of 0 - and b1 = byte_of 1 - and b2 = byte_of 2 - and b3 = byte_of 3 in - let result = b0 lor (b1 lsl 8) lor (b2 lsl 16) lor (b3 lsl 24) - in result - -let set_size s size = - s.[0] <- Char.unsafe_chr (size land 0xff); - s.[1] <- Char.unsafe_chr ((size land 0xff00) lsr 8); - s.[2] <- Char.unsafe_chr ((size land 0xff0000) lsr 16); - s.[3] <- Char.unsafe_chr ((size land 0xff000000) lsr 24) +external _set32_prim : string -> int -> int32 -> unit = "%caml_string_set32" +external _get32_prim : string -> int -> int32 = "%caml_string_get32" +let size_from s pos = _get32_prim s pos |> Int32.to_int +let set_size (b:Bytes.t) size = Int32.of_int size |>_set32_prim b 0 module Pack = struct diff --git a/src/pos.ml b/src/pos.ml index d5d54ec..98fc279 100644 --- a/src/pos.ml +++ b/src/pos.ml @@ -26,6 +26,14 @@ type pos = let out s o = Outer (s, o) +let get_out = function + | Outer (s, o) -> (s,o) + | Inner _ -> failwith "expected Outer, not Inner" + +let get_in = function + | Inner p -> p + | Outer _ -> failwith "expected Inner, not Outer" + let pos2s = function | Outer (s, o) -> Printf.sprintf "Outer (%d, %d)" s o | Inner p -> Printf.sprintf "Inner %i" p diff --git a/src/prefix.ml b/src/prefix.ml index 489dd27..5ba781b 100644 --- a/src/prefix.ml +++ b/src/prefix.ml @@ -33,7 +33,7 @@ module Prefix = functor (L:LOG ) -> struct let rec loop count acc = function | [] -> return (count,acc) - | (k, vpos) :: t -> + | (k, _vpos) :: t -> if t_max count then let ok = prefix_ok prefix k in diff --git a/src/prefix_test.ml b/src/prefix_test.ml index ee9081d..fafe5f6 100644 --- a/src/prefix_test.ml +++ b/src/prefix_test.ml @@ -7,7 +7,6 @@ module MDB = DB(Mlog) module MDBX = DBX(Mlog) module MPrefix = Prefix(Mlog) -open Base open Base_test let (>>=) = Mlog.bind @@ -15,7 +14,7 @@ let printer r = Pretty.string_of_list (fun s -> s) r let _ok_set tx k v = MDBX.set tx k v >>= fun () -> - Mlog.return (OK ()) + Mlog.return (Ok ()) let prefix_keys () = let fn = "bla" in @@ -27,7 +26,7 @@ let prefix_keys () = (fun tx -> let rec loop i = if i = 16 - then Mlog.return (OK()) + then Mlog.return (Ok()) else let k = Printf.sprintf "a%03i" i in let v = "x" in @@ -47,14 +46,14 @@ let prefix_keys () = let prefix_keys_latest () = let log = Mlog.make "mlog" in - List.iter (fun k -> MDB.set log k (String.uppercase k)) + List.iter (fun k -> MDB.set log k (String.uppercase_ascii k)) ["a";"b";"b";"c";"d_0";"d_1"; "d_2";"e";"f";"g"]; let r = MPrefix.prefix_keys_latest log "d" None in OUnit.assert_equal ~printer ["d_0";"d_1";"d_2"] r let prefix_keys_latest_max () = let log = Mlog.make "mlog" in - List.iter (fun k -> MDB.set log k (String.uppercase k)) + List.iter (fun k -> MDB.set log k (String.uppercase_ascii k)) ["a";"b";"b";"c";"d_0";"d_1"; "d_2";"e";"f";"g"]; let r = MPrefix.prefix_keys_latest log "d" (Some 2) in OUnit.assert_equal ~printer ["d_0";"d_1";] r diff --git a/src/range_test.ml b/src/range_test.ml index ae96a8e..9d3c416 100644 --- a/src/range_test.ml +++ b/src/range_test.ml @@ -25,14 +25,14 @@ let printer r = Pretty.string_of_list (fun s -> s) r let setup () = let log = Mlog.make "mlog" in - List.iter (fun k -> MDB.set log k (String.uppercase k)) ["a";"b";"c";"d";"e";"f";"g"]; + List.iter (fun k -> MDB.set log k (String.uppercase_ascii k)) ["a";"b";"c";"d";"e";"f";"g"]; log let teardown _ = () let range_all log = let r = MDB.range log None true None true None in - OUnit.assert_equal ~printer ["a";"b";"c";"d";"e";"f";"g"] r;; + OUnit.assert_equal ~printer ["a";"b";"c";"d";"e";"f";"g"] r let range_some log = let r = MDB.range log None true None true (Some 5) in diff --git a/src/rewrite.ml b/src/rewrite.ml index 35cde0a..216022b 100644 --- a/src/rewrite.ml +++ b/src/rewrite.ml @@ -18,7 +18,6 @@ *) open Log -open Pos open Entry open Base open Dbx @@ -60,7 +59,7 @@ struct DBX1.with_tx l1 ~inc (fun tx -> M.iter (fun (k,v) -> DBX1.set tx k v) u.kvs - >>= fun () -> return (OK ()) + >>= fun () -> return (Ok ()) ) in let read_value pos = @@ -89,8 +88,8 @@ struct begin let () = Printf.printf "fat\n%!" in apply_update acc1 false >>= function - | OK () -> return (make_update ()) - | NOK k -> failwith "todo" + | Ok() -> return (make_update ()) + | Error _k -> failwith "todo" end else return acc1 diff --git a/src/rewrite_test.ml b/src/rewrite_test.ml index 504b53f..706b3f8 100644 --- a/src/rewrite_test.ml +++ b/src/rewrite_test.ml @@ -58,7 +58,7 @@ let test_presence () = let empty = Slab.make fut in M.iter (fun (k,v) -> - let vo = Base.OK v in + let vo = Ok v in MDB._get m1 empty k >>= fun vo' -> return (OUnit.assert_equal vo' vo)) kvs >>= fun () -> let m1t = LLog.now m1 in diff --git a/src/slab.ml b/src/slab.ml index f0f4ca0..6e40b00 100644 --- a/src/slab.ml +++ b/src/slab.ml @@ -77,10 +77,9 @@ let iteri_rev slab f = loop (slab.nes -1) -let read slab pos = match pos with - | Inner x -> slab.es.(x) - | Outer _ -> failwith "can't read outer" - +let read slab pos = + let x = get_in pos in + slab.es.(x) let dump s = let do_one i e = Printf.printf "%i:%s\n%!" i (entry2s e) in @@ -94,7 +93,7 @@ let mark slab = | Inner x -> if x >=0 then r.(x) <- true in let maybe_mark2 (_,p) = maybe_mark p in - let mark (i:int) e = + let mark (_i:int) e = match e with | NIL | Value _ -> () | Commit c -> @@ -151,7 +150,7 @@ let compact s = in let esa = s.es in let size = s.nes in - let r = Array.create size NIL in + let r = Array.make size NIL in let rec loop c i = if i = size then { es = r; nes = c; time = s.time} diff --git a/src/store.ml b/src/store.ml index 7d34895..9df95b9 100644 --- a/src/store.ml +++ b/src/store.ml @@ -59,7 +59,7 @@ struct let s' = if o + l < sl then s - else s ^ (String.create (o + l - sl)) + else s ^ (Bytes.create (o + l - sl)) in String.blit d p s' o l; @@ -110,7 +110,7 @@ struct let next (T (_, o)) = !o let read (T (fd, _)) o l = - let s = String.create l in + let s = Bytes.create l in Posix.pread_into_exactly fd s l o; return s @@ -182,7 +182,7 @@ struct let next (T (_, o)) = !o let read (T (fd, _)) o l = - let s = String.create l in + let s = Bytes.create l in let rec loop o' = function | 0 -> return () @@ -207,7 +207,7 @@ struct in loop p o l - let append (T (fd, o) as t) d p l = + let append (T (_fd, o) as t) d p l = let o' = !o in write t d p l o' >>= fun () -> diff --git a/src/sync.ml b/src/sync.ml index 0a229e8..cfe35f4 100644 --- a/src/sync.ml +++ b/src/sync.ml @@ -32,9 +32,9 @@ module Sync (L:LOG) = struct let fold_actions t0 (f:'a -> Time.t -> caction -> 'a) a0 log = let read_commit p = - L.read log p >>= function - | Commit c -> return c - | _ -> failwith "not a commit node" + L.read log p >>= fun e -> + let c = get_commit e in + return c in let no_prev = Pos.Outer (0, 0) in let rec build ps p = diff --git a/src/tree.ml b/src/tree.ml index 533210e..93ff63e 100644 --- a/src/tree.ml +++ b/src/tree.ml @@ -25,7 +25,6 @@ open Entry open Base open Leaf open Index -open Slab module DB = functor (L:LOG ) -> struct @@ -40,18 +39,18 @@ module DB = functor (L:LOG ) -> struct let rec descend pos = _read pos >>= fun e -> match e with - | NIL -> return (NOK k) - | Value v -> return (OK v) + | NIL -> return (Error k) + | Value v -> return (Ok v) | Leaf l -> descend_leaf l | Index i -> descend_index i | Commit _ -> let msg = Printf.sprintf "descend reached a second commit %s" (Pos.pos2s pos) in failwith msg and descend_leaf = function - | [] -> return (NOK k) + | [] -> return (Error k) | (k0,p0) :: t -> if k= k0 then descend p0 else if k > k0 then descend_leaf t - else return (NOK k) + else return (Error k) and descend_index (p0, kps) = let rec loop pi = function | [] -> pi @@ -68,7 +67,7 @@ module DB = functor (L:LOG ) -> struct L.read t pos >>= fun e -> match e with | Commit c -> descend (Commit.get_lookup c) - | NIL -> return (NOK k) + | NIL -> return (Error k) | Index _ | Leaf _ | Value _ -> failwith "descend_root does not start at appropriate level" else let pos = Slab.last slab in @@ -483,10 +482,10 @@ module DB = functor (L:LOG ) -> struct in descend_root () >>= fun trail_o -> match trail_o with - | None -> return (NOK k) + | None -> return (Error k) | Some trail -> let start = Slab.next slab in delete_start slab start trail >>= fun (rp':pos) -> - return (OK rp') + return (Ok rp') let delete (t:L.t) k = @@ -494,15 +493,15 @@ module DB = functor (L:LOG ) -> struct let fut = Time.next_major now in let slab = Slab.make fut in _delete t slab k >>= function - | OK (pos:pos) -> + | Ok (pos:pos) -> let caction = Commit.CDelete k in let previous = L.last t in let lookup = pos in let commit = Commit.make_commit ~pos ~previous ~lookup fut [caction] false in let _ = Slab.add_commit slab commit in L.write t slab >>= fun () -> - return (OK ()) - | NOK k -> return (NOK k) + return (Ok ()) + | Error k -> return (Error k) let _range t @@ -603,9 +602,10 @@ module DB = functor (L:LOG ) -> struct let range_entries (t:L.t) (first: k option) (finc:bool) (last:k option) (linc:bool) (max:int option) = let acc = ref [] in let f k vpos = - L.read t vpos >>= function - | Value v -> let () = acc := (k,v)::!acc in return () - | _ -> failwith "should be value" + L.read t vpos >>= fun e -> + let v = get_value e in + let () = acc := (k,v)::!acc in + return () in _range t first finc last linc max f >>= fun _ -> return (List.rev !acc) @@ -711,10 +711,7 @@ module DB = functor (L:LOG ) -> struct | Some c -> count' < c in L.read t o >>= fun entry -> - let v = match entry with - | Entry.Value v -> v - | _ -> failwith "Not a value" - in + let v = get_value entry in return (cont, (count', (k,v)::acc)) end in @@ -724,8 +721,8 @@ module DB = functor (L:LOG ) -> struct let confirm (t:L.t) (s:Slab.t) k v = let set_needed () = _get t s k >>= function - | NOK _ -> return true - | OK vc -> return (vc <> v) + | Error _ -> return true + | Ok vc -> return (vc <> v) in set_needed () >>= fun sn -> if sn diff --git a/src/tree_test.ml b/src/tree_test.ml index 3089c01..6f2f9f2 100644 --- a/src/tree_test.ml +++ b/src/tree_test.ml @@ -31,14 +31,14 @@ type 'a q = read: 'a -> Base.pos -> entry; clear: 'a -> unit; set: 'a -> Base.k -> Base.v -> unit; - get: 'a -> Base.k -> (Base.v,Base.k) Base.result; - delete :'a -> Base.k -> (unit,Base.k) Base.result; + get: 'a -> Base.k -> (Base.v,Base.k) result; + delete :'a -> Base.k -> (unit,Base.k) result; dump :?out:out_channel -> 'a -> unit; } let _ok_delete q a = let r = q.delete q.log a in - assert (r = Base.OK ()); + assert (r = Ok ()); () let mem_setup () = @@ -64,7 +64,7 @@ let mem_wrap t = OUnit.bracket mem_setup t mem_teardown let check q kvs = List.iter (fun k -> let v = String.uppercase_ascii k in - let vo = Base.OK v in + let vo = Ok v in OUnit.assert_equal vo (q.get q.log k)) kvs let check_empty q = @@ -128,7 +128,7 @@ let check_invariants (q: 'a q) = failwith s let check_not q kvs = - List.iter (fun k -> OUnit.assert_equal (Base.NOK k) (q.get q.log k)) kvs + List.iter (fun k -> OUnit.assert_equal (Error k) (q.get q.log k)) kvs @@ -213,7 +213,7 @@ let insert_delete_bug2 q = List.iter (fun k -> let v = String.uppercase_ascii k in q.set q.log k v) kvs; _ok_delete q "a"; let kvs' = List.filter ( (<>) "a") kvs in - List.iter (fun k -> let vo = Base.OK (String.uppercase_ascii k) in + List.iter (fun k -> let vo = Ok (String.uppercase_ascii k) in let vo2 = q.get q.log k in OUnit.assert_equal vo vo2) kvs' @@ -453,7 +453,7 @@ let qc_insert_lookup log = fun kvs -> then (a, ks) else - let vo = Base.OK v in + let vo = Ok v in let vo' = MDB.get log k in (a && (vo' = vo), k :: ks) ) @@ -468,7 +468,7 @@ let qc_insert_delete log = fun kvs -> if List.mem k ks then ks else let r = MDB.delete log k in - assert (r = Base.OK ()); + assert (r = Ok ()); k :: ks ) kvs [] @@ -480,12 +480,11 @@ let qc_replace log = fun (k, vs) -> match vs with | [] -> begin let vo = MDB.get log k in - let open Base in match vo with - | OK _ -> false - | NOK _ -> true + | Ok _ -> false + | Error _ -> true end - | _ -> MDB.get log k = Base.OK (List.nth vs (List.length vs - 1)) + | _ -> MDB.get log k = Ok (List.nth vs (List.length vs - 1)) let qc_key_value_list = let open QuickCheck in