diff --git a/cachet-solo5.opam b/cachet-solo5.opam new file mode 100644 index 0000000..ed57829 --- /dev/null +++ b/cachet-solo5.opam @@ -0,0 +1,23 @@ +opam-version: "2.0" +name: "cachet" +maintainer: [ "Romain Calascibetta " + "Reynir Björnsson " ] +authors: [ "Romain Calascibetta " + "Reynir Björnsson " ] +homepage: "https://git.robur.coop/robur/cachet" +bug-reports: "https://git.robur.coop/robur/cachet" +dev-repo: "git+https://git.robur.coop/robur/cachet" +doc: "https://robur-coop.github.io/cachet/" +license: "MIT" +synopsis: "A simple cache system for mmap" +description: """A small library that provides a simple cache system for page-by-page read access on a block device.""" + +build: [ "dune" "build" "-p" name "-j" jobs ] +run-test: [ "dune" "runtest" "-p" name "-j" jobs ] + +depends: [ + "ocaml" {>= "4.14.0"} + "dune" {>= "3.5.0"} + "cachet" {= version} + "mirage-solo5" {>= "0.7.0"} +] diff --git a/lib-solo5/cachet_solo5.ml b/lib-solo5/cachet_solo5.ml new file mode 100644 index 0000000..91e1633 --- /dev/null +++ b/lib-solo5/cachet_solo5.ml @@ -0,0 +1,63 @@ +let failwithf fmt = Format.kasprintf failwith fmt + +open Solo5_os.Solo5 + +type solo5_block_info = { capacity: int64; block_size: int64 } +type file_descr = int64 + +external solo5_block_acquire : string -> solo5_result * int64 * solo5_block_info + = "mirage_solo5_block_acquire" + +external solo5_block_read : + int64 -> int64 -> Cachet.bigstring -> int -> int -> solo5_result + = "mirage_solo5_block_read_3" + +external set_uint8 : Cachet.bigstring -> int -> int -> unit = "%caml_ba_set_1" + +external set_int32_ne : Cachet.bigstring -> int -> int32 -> unit + = "%caml_bigstring_set32" + +let _max_int31 = 2147483647L +let _max_int63 = 9223372036854775807L +let bstr_empty = Bigarray.Array1.create Bigarray.char Bigarray.c_layout 0 + +let bstr_create len = + let bstr = Bigarray.Array1.create Bigarray.char Bigarray.c_layout len in + let len0 = len land 3 in + let len1 = len lsr 2 in + for i = 0 to len1 - 1 do + let i = i * 4 in + set_int32_ne bstr i 0l + done; + for i = 0 to len0 - 1 do + let i = (len1 * 4) + i in + set_uint8 bstr i 0 + done; + bstr + +let connect ?cachesize name = + match solo5_block_acquire name with + | SOLO5_R_AGAIN, _, _ -> assert false + | SOLO5_R_EINVAL, _, _ -> failwithf "connect(%s): Invalid argument" name + | SOLO5_R_EUNSPEC, _, _ -> failwithf "connect(%s): Unspecified error" name + | SOLO5_R_OK, handle, info -> + if Sys.word_size == 32 && info.capacity > _max_int31 then + failwithf "connect(%s): Too large block device" name; + if Sys.word_size == 64 && info.capacity > _max_int63 then + failwithf "connect(%s): Too large block device" name; + if Sys.word_size == 32 && info.block_size > _max_int31 then + failwithf "connect(%s): Too large page size" name; + if Sys.word_size == 64 && info.block_size > _max_int63 then + failwithf "connect(%s): Too large page size" name; + let max = Int64.to_int info.capacity in + let pagesize = Int64.to_int info.block_size in + let map handle ~pos _len = + if pos > max then bstr_empty + else + let len = Int.min (max - pos) pagesize in + let raw = bstr_create pagesize in + match solo5_block_read handle (Int64.of_int pos) raw 0 len with + | SOLO5_R_OK -> raw + | _ -> bstr_empty + in + Cachet.make ?cachesize ~pagesize ~map handle diff --git a/lib-solo5/cachet_solo5.mli b/lib-solo5/cachet_solo5.mli new file mode 100644 index 0000000..64263bc --- /dev/null +++ b/lib-solo5/cachet_solo5.mli @@ -0,0 +1,3 @@ +type file_descr + +val connect : ?cachesize:int -> string -> file_descr Cachet.t diff --git a/lib-solo5/dune b/lib-solo5/dune new file mode 100644 index 0000000..ad215d9 --- /dev/null +++ b/lib-solo5/dune @@ -0,0 +1,4 @@ +(library + (name cachet_solo5) + (public_name cachet-solo5) + (libraries cachet mirage-solo5)) diff --git a/lib/cachet.ml b/lib/cachet.ml index f531b75..cdf5138 100644 --- a/lib/cachet.ml +++ b/lib/cachet.ml @@ -4,6 +4,38 @@ type bigstring = external swap16 : int -> int = "%bswap16" external swap32 : int32 -> int32 = "%bswap_int32" external swap64 : int64 -> int64 = "%bswap_int64" +external get_uint8 : bigstring -> int -> int = "%caml_ba_ref_1" +external set_uint8 : bigstring -> int -> int -> unit = "%caml_ba_set_1" +external get_int32_ne : bigstring -> int -> int32 = "%caml_bigstring_get32" + +external set_int32_ne : bigstring -> int -> int32 -> unit + = "%caml_bigstring_set32" + +let memcpy src ~src_off dst ~dst_off ~len = + if + len < 0 + || src_off < 0 + || src_off > Bigarray.Array1.dim src - len + || dst_off < 0 + || dst_off > Bigarray.Array1.dim dst - len + then invalid_arg "memcpy"; + let len0 = len land 3 in + let len1 = len lsr 2 in + for i = 0 to len1 - 1 do + let i = i * 4 in + let v = get_int32_ne src (src_off + i) in + set_int32_ne dst (dst_off + i) v + done; + for i = 0 to len0 - 1 do + let i = (len1 * 4) + i in + let v = get_uint8 src (src_off + i) in + set_uint8 dst (dst_off + i) v + done + +let memmove src ~src_off dst ~dst_off ~len = + let src = Bigarray.Array1.sub src src_off len in + let dst = Bigarray.Array1.sub dst dst_off len in + Bigarray.Array1.blit src dst module Bstr = struct type t = bigstring @@ -113,6 +145,85 @@ module Bstr = struct else go (succ idx) 0 in go 0 0 + + let is_suffix ~affix bstr = + let max_idx_affix = String.length affix - 1 in + let max_idx_bstr = length bstr - 1 in + if max_idx_affix > max_idx_bstr then false + else + let rec go idx = + if idx > max_idx_affix then true + else if affix.[max_idx_affix - idx] != bstr.{max_idx_bstr - idx} then + false + else go (succ idx) + in + go 0 + + exception Break + + let for_all sat bstr = + try + for idx = 0 to length bstr - 1 do + if sat bstr.{idx} == false then raise_notrace Break + done; + true + with Break -> false + + let exists sat bstr = + try + for idx = 0 to length bstr - 1 do + if sat bstr.{idx} then raise_notrace Break + done; + false + with Break -> true + + let equal a b = + if length a == length b then + try + let len = length a in + let len0 = len land 3 in + let len1 = len lsr 2 in + for i = 0 to len1 - 1 do + let i = i * 4 in + if get_int32_ne a i <> get_int32_ne b i then raise_notrace Break + done; + for i = 0 to len0 - 1 do + let i = (len1 * 4) + i in + if get_uint8 a i != get_uint8 b i then raise_notrace Break + done; + true + with Break -> false + else false + + let with_range ?(first = 0) ?(len = max_int) bstr = + if len < 0 then invalid_arg "Cachet.Bstr.with_range"; + if len == 0 then empty + else + let bstr_len = length bstr in + let max_idx = bstr_len - 1 in + let last = + match len with + | len when len = max_int -> max_idx + | len -> + let last = first + len - 1 in + if last > max_idx then max_idx else last + in + let first = if first < 0 then 0 else first in + if first = 0 && last = max_idx then bstr + else sub bstr ~off:first ~len:(last + 1 - first) + + let with_index_range ?(first = 0) ?last bstr = + let bstr_len = length bstr in + let max_idx = bstr_len - 1 in + let last = + match last with + | None -> max_idx + | Some last -> if last > max_idx then max_idx else last + in + let first = if first < 0 then 0 else first in + if first > max_idx || last < 0 || first > last then empty + else if first == 0 && last = max_idx then bstr + else sub bstr ~off:first ~len:(last + 1 - first) end external hash : (int32[@unboxed]) -> int -> (int32[@unboxed]) diff --git a/lib/cachet.mli b/lib/cachet.mli index fdeb50b..9e5eec1 100644 --- a/lib/cachet.mli +++ b/lib/cachet.mli @@ -1,6 +1,12 @@ type bigstring = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t +val memcpy : + bigstring -> src_off:int -> bigstring -> dst_off:int -> len:int -> unit + +val memmove : + bigstring -> src_off:int -> bigstring -> dst_off:int -> len:int -> unit + module Bstr : sig (** A read-only bigstring. *) @@ -93,14 +99,13 @@ module Bstr : sig val is_empty : t -> bool val is_prefix : affix:string -> t -> bool val is_infix : affix:string -> t -> bool - (* val is_suffix : affix:string -> t -> bool val for_all : (char -> bool) -> t -> bool val exists : (char -> bool) -> t -> bool val equal : t -> t -> bool - val compare : t -> t -> int val with_range : ?first:int -> ?len:int -> t -> t val with_index_range : ?first:int -> ?last:int -> t -> t + (* val trim : ?drop:(char -> bool) -> t -> t val span : ?rev:bool -> ?min:int -> ?max:int -> ?sat:(char -> bool) -> t -> t * t val take : ?rev:bool -> ?min:int -> ?max:int -> ?sat:(char -> bool) -> t -> t