Set benchmarks to test lfu

Makefile

@@ -0,0 +1,3 @@
+.PHONY: bench
+bench:
+	dune exec bench/replay.exe lru 5001

bench/dune

@@ -1,7 +1,19 @@
 (executable
+ (modules main)
  (name main)
  (libraries bechamel bechamel-notty notty.unix lru cachecache))
 
+(executable
+ (modules
+  lru_trace_definition
+  replay
+  trace_auto_file_format_intf
+  trace_auto_file_format)
+ (preprocess
+  (pps ppx_repr))
+ (name replay)
+ (libraries cachecache fmt ppx_repr repr mtime mtime.clock.os cmdliner))
+
 (alias
  (name runtest)
  (package cachecache-bench)

bench/lru_trace_definition.ml

@@ -0,0 +1,29 @@
+(** File format of a trace listing the interactions with repr's LRU *)
+
+module V0 = struct
+  let version = 0
+
+  type header = { instance_count : int } [@@deriving repr]
+
+  type op = Add of string | Find of string | Mem of string | Clear
+  [@@deriving repr]
+
+  type row = { instance_id : int; op : op } [@@deriving repr]
+end
+
+module Latest = V0
+include Latest
+
+include Trace_auto_file_format.Make (struct
+  module Latest = Latest
+
+  let magic = Trace_auto_file_format.Magic.of_string "LRUtrace"
+
+  let get_version_converter = function
+    | 0 ->
+        Trace_auto_file_format.create_version_converter ~header_t:V0.header_t
+          ~row_t:V0.row_t ~upgrade_header:Fun.id ~upgrade_row:Fun.id
+    | i ->
+        let msg = Fmt.str "Unknown Raw_actions_trace version %d" i in
+        failwith msg
+end)

bench/replay.ml

@@ -0,0 +1,117 @@
+type span = Mtime.span
+
+let span_t = Repr.map Repr.float (fun _ -> assert false) Mtime.Span.to_s
+
+type stats = {
+  mutable add : int;
+  mutable mem : int;
+  mutable find : int;
+  mutable hit : int;
+  mutable miss : int;
+  (* mutable discard : int; *)
+  mutable add_span : span;
+  mutable mem_span : span;
+  mutable find_span : span;
+  mutable total_runtime_span : span;
+}
+[@@deriving repr ~pp]
+
+module K = struct
+  include String
+
+  let hash = Hashtbl.hash
+end
+
+let pr_bench test_name metric_name value =
+  Format.printf
+    {|{"results": [{"name": "%s", "metrics": [{"name": "%s", "value": %f, "units": "ms"}]}]}@.|}
+    test_name metric_name value
+
+module Make (Cache : Cachecache.S.Cache with type key = K.t) = struct
+  let bench cap =
+    let stats =
+      {
+        add = 0;
+        mem = 0;
+        find = 0;
+        hit = 0;
+        miss = 0;
+        (* discard = 0; *)
+        add_span = Mtime.Span.zero;
+        mem_span = Mtime.Span.zero;
+        find_span = Mtime.Span.zero;
+        total_runtime_span = Mtime.Span.zero;
+      }
+    in
+    let open Lru_trace_definition in
+    let _, { instance_count }, seq =
+      open_reader "/home/cha//Downloads/lru.trace"
+    in
+    let caches = List.init instance_count (fun _ -> Cache.v cap) in
+    let counter = Mtime_clock.counter () in
+    Seq.iter
+      (fun { instance_id; op } ->
+        let cache = List.nth caches instance_id in
+        match op with
+        | Add k ->
+            let before = Mtime_clock.count counter in
+            Cache.replace cache k ();
+            let after = Mtime_clock.count counter in
+            stats.total_runtime_span <-
+              Mtime.Span.(abs_diff after before |> add stats.total_runtime_span);
+            stats.add_span <-
+              Mtime.Span.(abs_diff after before |> add stats.add_span);
+            stats.add <- stats.add + 1
+        | Find k ->
+            let before = Mtime_clock.count counter in
+            ignore (Cache.find_opt cache k : _ option);
+            let after = Mtime_clock.count counter in
+            stats.total_runtime_span <-
+              Mtime.Span.(abs_diff after before |> add stats.total_runtime_span);
+            stats.find_span <-
+              Mtime.Span.(abs_diff after before |> add stats.find_span);
+            stats.find <- stats.find + 1
+        | Mem k ->
+            let before = Mtime_clock.count counter in
+            let b = Cache.mem cache k in
+            let after = Mtime_clock.count counter in
+            stats.total_runtime_span <-
+              Mtime.Span.(abs_diff after before |> add stats.total_runtime_span);
+            stats.mem_span <-
+              Mtime.Span.(abs_diff after before |> add stats.mem_span);
+            if b then stats.hit <- stats.hit + 1
+            else stats.miss <- stats.miss + 1;
+            stats.mem <- stats.mem + 1
+        | _ -> assert false)
+      seq;
+    (* Fmt.pr "%a\n" pp_stats stats *)
+    pr_bench "add" "add_metric" (Mtime.Span.to_ms stats.add_span);
+    pr_bench "mem" "mem_metric" (Mtime.Span.to_ms stats.mem_span);
+    pr_bench "find" "find_metric" (Mtime.Span.to_ms stats.find_span);
+    pr_bench "total_runtime" "total_runtime_metric"
+      (Mtime.Span.to_ms stats.total_runtime_span)
+end
+
+include Cachecache.Lru.Make (K)
+module Lru = Cachecache.Lru.Make (K)
+module Lfu = Cachecache.Lfu.Make (K)
+module Bench_lru = Make (Lru)
+module Bench_lfu = Make (Lfu)
+
+let main algo cap =
+  match algo with `Lru -> Bench_lru.bench cap | `Lfu -> Bench_lfu.bench cap
+
+open Cmdliner
+
+let algo =
+  let l = [ ("lru", `Lru); ("lfu", `Lfu) ] in
+  let i = Arg.info [] in
+  Arg.(required @@ pos 0 (some (enum l)) None i)
+
+let cap =
+  let i = Arg.info [] in
+  Arg.(required @@ pos 1 (some int) None i)
+
+let main_t = Term.(const main $ algo $ cap)
+let cmd = Cmd.v (Cmd.info "replay") main_t
+let () = exit (Cmd.eval cmd)

bench/trace_auto_file_format.ml

@@ -0,0 +1,213 @@
+(*****************************************************************************)
+(*                                                                           *)
+(* Open Source License                                                       *)
+(* Copyright (c) 2021-2022 Tarides <contact@tarides.com>                     *)
+(*                                                                           *)
+(* Permission is hereby granted, free of charge, to any person obtaining a   *)
+(* copy of this software and associated documentation files (the "Software"),*)
+(* to deal in the Software without restriction, including without limitation *)
+(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
+(* and/or sell copies of the Software, and to permit persons to whom the     *)
+(* Software is furnished to do so, subject to the following conditions:      *)
+(*                                                                           *)
+(* The above copyright notice and this permission notice shall be included   *)
+(* in all copies or substantial portions of the Software.                    *)
+(*                                                                           *)
+(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
+(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
+(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
+(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
+(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
+(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
+(* DEALINGS IN THE SOFTWARE.                                                 *)
+(*                                                                           *)
+(*****************************************************************************)
+
+include Trace_auto_file_format_intf
+
+type ('latest_header, 'latest_row, 'header, 'row) version_converter' = {
+  header_t : 'header Repr.ty;
+  row_t : 'row Repr.ty;
+  upgrade_header : 'header -> 'latest_header;
+  upgrade_row : 'row -> 'latest_row;
+}
+(** Contains everything needed to read a file as if it is written using the
+    lastest version. *)
+
+(** A box containing the above record *)
+type (_, _) version_converter =
+  | Version_converter :
+      ('latest_header, 'latest_row, 'header, 'row) version_converter'
+      -> ('latest_header, 'latest_row) version_converter
+
+let create_version_converter :
+    header_t:'header Repr.ty ->
+    row_t:'row Repr.ty ->
+    upgrade_header:('header -> 'latest_header) ->
+    upgrade_row:('row -> 'latest_row) ->
+    ('latest_header, 'latest_row) version_converter =
+ fun ~header_t ~row_t ~upgrade_header ~upgrade_row ->
+  Version_converter { header_t; row_t; upgrade_header; upgrade_row }
+
+module Magic : MAGIC = struct
+  type t = string
+
+  let of_string s =
+    if String.length s <> 8 then
+      invalid_arg "Magic.of_string, string should have 8 chars";
+    s
+
+  let to_string s = s
+  let pp ppf s = Format.fprintf ppf "%s" (String.escaped s)
+end
+
+module type FILE_FORMAT =
+  FILE_FORMAT
+    with type magic := Magic.t
+    with type ('a, 'b) version_converter := ('a, 'b) version_converter
+
+module type S =
+  S
+    with type File_format.magic := Magic.t
+    with type ('a, 'b) File_format.version_converter :=
+      ('a, 'b) version_converter
+
+(** Variable size integer. Very similar to what can be found in
+    "repr/type_binary.ml", but working straight off channels. [Var_int.read_exn]
+    reads the chars one by one from the provided [chan]. The recursion stops as
+    soon as a read char has its 8th bit equal to [0]. [Var_int.write] could be
+    implemented using [Repr.encode_bin int], but since [read_exn] can't be
+    implemented using repr, [write] isn't either. *)
+module Var_int = struct
+  let chars =
+    Array.init 256 (fun i -> Bytes.unsafe_to_string (Bytes.make 1 (Char.chr i)))
+
+  let write : int -> out_channel -> unit =
+    let int i k =
+      let rec aux n k =
+        if n >= 0 && n < 128 then k chars.(n)
+        else
+          let out = 128 lor (n land 127) in
+          k chars.(out);
+          aux (n lsr 7) k
+      in
+      aux i k
+    in
+    fun i chan -> int i (output_string chan)
+
+  let read_exn : in_channel -> int =
+   fun chan ->
+    let max_bits = Sys.word_size - 1 in
+    let rec aux n p =
+      let () =
+        if p >= max_bits then raise (failwith "Failed to decode varint")
+      in
+      let i = input_char chan |> Char.code in
+      let n = n + ((i land 127) lsl p) in
+      if i >= 0 && i < 128 then n else aux n (p + 7)
+    in
+    aux 0 0
+end
+
+module Make (Ff : FILE_FORMAT) = struct
+  module File_format = Ff
+
+  let decode_i32 = Repr.(decode_bin int32 |> unstage)
+  let encode_i32 = Repr.(encode_bin int32 |> unstage)
+  let encode_lheader = Repr.(encode_bin Ff.Latest.header_t |> unstage)
+  let encode_lrow = Repr.(encode_bin Ff.Latest.row_t |> unstage)
+
+  let read_with_prefix_exn : (string -> int ref -> 'a) -> in_channel -> 'a =
+   fun decode chan ->
+    (* First read the prefix *)
+    let len = Var_int.read_exn chan in
+    (* Then read the repr. *)
+    let offset_ref = ref 0 in
+    let v =
+      (* This could fail if [len] is not long enough for repr (corruption) *)
+      decode (really_input_string chan len) offset_ref
+    in
+    let () =
+      if len <> !offset_ref then
+        let msg =
+          Fmt.str
+            "A value read in the Trace was expected to take %d bytes, but it \
+             took only %d."
+            len !offset_ref
+        in
+        raise (failwith msg)
+    in
+    v
+
+  let decoded_seq_of_encoded_chan_with_prefixes :
+      'a Repr.ty -> in_channel -> 'a Seq.t =
+   fun repr chan ->
+    let decode = Repr.decode_bin repr |> Repr.unstage in
+    let produce_row () =
+      try
+        let row = read_with_prefix_exn decode chan in
+        Some (row, ())
+      with End_of_file -> None
+    in
+    Seq.unfold produce_row ()
+
+  let open_reader : string -> int * Ff.Latest.header * Ff.Latest.row Seq.t =
+   fun path ->
+    let chan = open_in_bin path in
+    let len = LargeFile.in_channel_length chan in
+    let () =
+      if len < 12L then
+        let msg = Fmt.str "File '%s' should be at least 12 byte long" path in
+        raise (failwith msg)
+    in
+
+    let magic = Magic.of_string (really_input_string chan 8) in
+    let () =
+      if magic <> Ff.magic then
+        let msg =
+          Fmt.str "File '%s' has magic '%a'. Expected '%a'." path Magic.pp magic
+            Magic.pp Ff.magic
+        in
+        raise (failwith msg)
+    in
+
+    let offset_ref = ref 0 in
+    let version = decode_i32 (really_input_string chan 4) offset_ref in
+    let (Version_converter vc) =
+      assert (!offset_ref = 4);
+      Ff.get_version_converter (Int32.to_int version)
+    in
+
+    let header =
+      let decode_header = Repr.(decode_bin vc.header_t |> unstage) in
+      read_with_prefix_exn decode_header chan |> vc.upgrade_header
+    in
+    let seq =
+      decoded_seq_of_encoded_chan_with_prefixes vc.row_t chan
+      |> Seq.map vc.upgrade_row
+    in
+    (Int32.to_int version, header, seq)
+
+  type writer = { channel : out_channel; buffer : Buffer.t }
+
+  let create channel header =
+    let buffer = Buffer.create 0 in
+    output_string channel (Magic.to_string Ff.magic);
+    encode_i32 (Int32.of_int Ff.Latest.version) (output_string channel);
+    encode_lheader header (Buffer.add_string buffer);
+    Var_int.write (Buffer.length buffer) channel;
+    output_string channel (Buffer.contents buffer);
+    Buffer.clear buffer;
+    { channel; buffer }
+
+  let create_file path header = create (open_out path) header
+
+  let append_row { channel; buffer; _ } row =
+    encode_lrow row (Buffer.add_string buffer);
+    Var_int.write (Buffer.length buffer) channel;
+    output_string channel (Buffer.contents buffer);
+    Buffer.clear buffer
+
+  let flush { channel; _ } = flush channel
+  let close { channel; _ } = close_out channel
+end