Complete read-only bstr and add the support of solo5

cachet-solo5.opam

@@ -0,0 +1,23 @@
+opam-version: "2.0"
+name:         "cachet"
+maintainer:   [ "Romain Calascibetta <romain.calascibetta@gmail.com>"
+                "Reynir Björnsson <reynir@reynir.dk>" ]
+authors:      [ "Romain Calascibetta <romain.calascibetta@gmail.com>"
+                "Reynir Björnsson <reynir@reynir.dk>" ]
+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"}
+]

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

lib-solo5/cachet_solo5.mli

@@ -0,0 +1,3 @@
+type file_descr
+
+val connect : ?cachesize:int -> string -> file_descr Cachet.t

lib-solo5/dune

@@ -0,0 +1,4 @@
+(library
+ (name cachet_solo5)
+ (public_name cachet-solo5)
+ (libraries cachet mirage-solo5))

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])

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