From 4ce972d6e3749e347e801b31fcc5cbc27a7be974 Mon Sep 17 00:00:00 2001 From: cha Date: Mon, 23 May 2022 15:56:09 +0200 Subject: [PATCH 01/22] initial commit, update Dllist with vector library --- cachecache.opam | 1 + src/dllist.ml | 71 ++++++++++++++++++++++++++----------------------- src/dune | 2 +- 3 files changed, 39 insertions(+), 35 deletions(-) diff --git a/cachecache.opam b/cachecache.opam index ad5687f..9e4b65f 100644 --- a/cachecache.opam +++ b/cachecache.opam @@ -30,6 +30,7 @@ depends: [ "dune" {>= "2.0"} "ocaml" {>= "4.07.1"} "fmt" + "vector" "alcotest" {with-test} "gospel" {with-test} "fpath" {with-test} diff --git a/src/dllist.ml b/src/dllist.ml index ff50f6a..3259db2 100644 --- a/src/dllist.ml +++ b/src/dllist.ml @@ -1,8 +1,8 @@ type 'a t = { - contents : 'a array; + contents : 'a Vector.t; witness : 'a; - prev : int array; - next : int array; + prev : int Vector.t; + next : int Vector.t; mutable first : int; mutable last : int; mutable free : int; @@ -12,10 +12,10 @@ type 'a t = { let create c witness = { - contents = Array.make c witness; + contents = Vector.make c ~dummy:witness; witness; - prev = Array.init c pred; - next = Array.init c (fun i -> if i = c - 1 then -1 else succ i); + prev = Vector.init c ~dummy:0 pred; + next = Vector.init c ~dummy:0 (fun i -> if i = c - 1 then -1 else succ i); first = -1; last = -1; free = 0; @@ -31,32 +31,32 @@ let clear t = let o = t.cap - 1 in let o1 = 0 in for i = o1 to o do - t.contents.(i) <- t.witness; - t.prev.(i) <- -1; - t.next.(i) <- -1 + Vector.set t.contents i t.witness; + Vector.set t.prev i (-1); + Vector.set t.next i (-1) done let append t v = let removed = if t.free <> -1 then ( let index = t.free in - t.free <- t.next.(t.free); - if t.free <> -1 then t.prev.(t.free) <- -1; - t.next.(index) <- t.first; - if t.size = 0 then t.last <- index else t.prev.(t.first) <- index; + t.free <- Vector.get t.next t.free; + if t.free <> -1 then Vector.set t.prev t.free (-1); + Vector.set t.next index t.first; + if t.size = 0 then t.last <- index else Vector.set t.prev t.first index; t.first <- index; - t.contents.(index) <- v; + Vector.set t.contents index v; t.size <- t.size + 1; None) else - let removed = Some t.contents.(t.last) in + let removed = Some (Vector.get t.contents t.last) in let new_first = t.last in - t.last <- t.prev.(t.last); - t.contents.(new_first) <- v; - t.next.(t.last) <- -1; - t.prev.(new_first) <- -1; - t.next.(new_first) <- t.first; - t.prev.(t.first) <- new_first; + t.last <- Vector.get t.prev t.last; + Vector.set t.contents new_first v; + Vector.set t.next t.last (-1); + Vector.set t.prev new_first (-1); + Vector.set t.next new_first t.first; + Vector.set t.prev t.first new_first; t.first <- new_first; removed in @@ -64,24 +64,27 @@ let append t v = let promote t i = if i <> t.first then ( - t.next.(t.prev.(i)) <- t.next.(i); - if i <> t.last then t.prev.(t.next.(i)) <- t.prev.(i) - else t.last <- t.prev.(i); - t.prev.(t.first) <- i; - t.next.(i) <- t.first; - t.prev.(i) <- -1; + Vector.set t.next (Vector.get t.prev i) (Vector.get t.next i); + if i <> t.last then + Vector.set t.prev (Vector.get t.next i) (Vector.get t.prev i) + else t.last <- Vector.get t.prev i; + Vector.set t.prev t.first i; + Vector.set t.next i t.first; + Vector.set t.prev i (-1); t.first <- i); t.first let remove t i = - if i <> t.first then t.next.(t.prev.(i)) <- t.next.(i); - if i <> t.last then t.prev.(t.next.(i)) <- t.prev.(i) - else t.last <- t.prev.(t.last); - if t.free <> -1 then t.prev.(t.free) <- i; - t.next.(i) <- t.free; - t.prev.(i) <- -1; + if i <> t.first then + Vector.set t.next (Vector.get t.prev i) (Vector.get t.next i); + if i <> t.last then + Vector.set t.prev (Vector.get t.next i) (Vector.get t.prev i) + else t.last <- Vector.get t.prev t.last; + if t.free <> -1 then Vector.set t.prev t.free i; + Vector.set t.next i t.free; + Vector.set t.prev i (-1); t.free <- i; t.size <- t.size - 1 -let get t i1 = t.contents.(i1) +let get t i1 = Vector.get t.contents i1 let length t = t.size diff --git a/src/dune b/src/dune index 89c7dac..b2c5a17 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,7 @@ (library (public_name cachecache) (name cachecache) - (libraries fmt)) + (libraries fmt vector)) ; (rule ; (alias runtest) From 0f4334380aa05fcf74dc94ab76e75c490ea322d6 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Tue, 24 May 2022 14:48:34 +0200 Subject: [PATCH 02/22] dllist with dynamics arrays -- started --- src/dllist.ml | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/dllist.mli | 3 +++ src/lfu.ml | 46 +++++++++++++++++++----------------- 3 files changed, 91 insertions(+), 21 deletions(-) diff --git a/src/dllist.ml b/src/dllist.ml index 3259db2..01576ba 100644 --- a/src/dllist.ml +++ b/src/dllist.ml @@ -88,3 +88,66 @@ let remove t i = let get t i1 = Vector.get t.contents i1 let length t = t.size +let is_empty t = Vector.is_empty t.contents + +let get_ends t = + if not (Vector.is_empty t.contents) then (t.first, t.last) + else raise Not_found + +let insert_head t v = + let removed = + if t.free <> -1 then ( + let new_index = t.free in + t.free <- Vector.get t.next t.free; + if t.free <> -1 then Vector.set t.prev t.free (-1); + Vector.set t.prev new_index t.last; + if t.size = 0 then t.first <- new_index + else Vector.set t.next t.last new_index; + t.last <- new_index; + Vector.set t.contents new_index v; + t.size <- t.size + 1; + None) + else + let removed = Some (Vector.get t.contents t.last) in + let new_first = t.last in + t.last <- Vector.get t.prev t.last; + Vector.set t.contents new_first v; + Vector.set t.next t.last (-1); + Vector.set t.prev new_first (-1); + Vector.set t.next new_first t.first; + Vector.set t.prev t.first new_first; + t.first <- new_first; + removed + in + (t.first, removed) + +let insert_before t v i = + let removed = + if t.free <> -1 then ( + let new_index = t.free in + t.free <- Vector.get t.next t.free; + if t.free <> -1 then Vector.set t.prev t.free (-1); + let i_prev = Vector.get t.prev i in + Vector.set t.prev new_index i_prev; + Vector.set t.next i_prev new_index; + Vector.set t.prev i new_index; + Vector.set t.next new_index i; + if t.size = 0 then ( + t.first <- new_index; + t.last <- new_index); + Vector.set t.contents new_index v; + t.size <- t.size + 1; + None) + else + let removed = Some (Vector.get t.contents t.last) in + let new_first = t.last in + t.last <- Vector.get t.prev t.last; + Vector.set t.contents new_first v; + Vector.set t.next t.last (-1); + Vector.set t.prev new_first (-1); + Vector.set t.next new_first t.first; + Vector.set t.prev t.first new_first; + t.first <- new_first; + removed + in + (t.first, removed) diff --git a/src/dllist.mli b/src/dllist.mli index 2b3f93a..2c7e8ae 100644 --- a/src/dllist.mli +++ b/src/dllist.mli @@ -7,3 +7,6 @@ val promote : 'a t -> int -> int val remove : 'a t -> int -> unit val get : 'a t -> int -> 'a val clear : 'a t -> unit +val is_empty : 'a t -> bool +val get_ends : 'a t -> int * int +val insert_before : 'a t -> 'a -> int diff --git a/src/lfu.ml b/src/lfu.ml index 58033bb..8635388 100644 --- a/src/lfu.ml +++ b/src/lfu.ml @@ -8,20 +8,22 @@ struct module H = Hashtbl.Make (K) type key = K.t - type freq_cell = (int * key Dbllist.t) Dbllist.cell - type key_cell = key Dbllist.cell + type freq_index = int + type key_index = int type 'a t = { - value : (freq_cell * key_cell * 'a) H.t; - frequency : (int * key Dbllist.t) Dbllist.t; + value : (freq_index * key_index * 'a) H.t; + frequency : (int * key Dllist.t) Dllist.t; cap : int; stats : Stats.t; } + let dummy : K.t = Obj.magic (ref 0) + let unsafe_v c = { value = H.create c; - frequency = Dbllist.create (); + frequency = Dllist.create 0 (0, Dllist.create 0 dummy); cap = c; stats = Stats.v (); } @@ -37,7 +39,7 @@ struct let clear t = H.clear t.value; - Dbllist.clear t.frequency; + Dllist.clear t.frequency; Stats.clear t.stats let update t k = @@ -80,19 +82,21 @@ struct let add t k v = if H.length t.value = 0 then - let first_freq_list = Dbllist.create () in - let new_cell = Dbllist.append first_freq_list k in - let first_freq_cell = Dbllist.append t.frequency (1, first_freq_list) in - H.replace t.value k (first_freq_cell, new_cell, v) + let first_freq_list = Dllist.create 0 dummy in + let new_key_index, _opt = Dllist.append first_freq_list k in + let first_key_index, _opt = + Dllist.append t.frequency (1, first_freq_list) + in + H.replace t.value k (first_key_index, new_key_index, v) else - let first_freq_cell, _last_freq_cell = Dbllist.get t.frequency in - let freq, _freq_list = first_freq_cell.content in + let first_freq_index, _last_freq_index = Dllist.get_ends t.frequency in + + let freq, _key_list = Dllist.get t.frequency first_freq_index in (if freq <> 1 then - let real_first_freq_list = Dbllist.create () in - ignore - (Dbllist.append_before t.frequency first_freq_cell - (1, real_first_freq_list) - : freq_cell)); + let real_first_freq_list = Dllist.create 0 dummy in + + Dllist.append_before t.frequency first_freq_cell (1, real_first_freq_list)); + let first_freq_cell, _last_freq_cell = Dbllist.get t.frequency in let _freq, freq_list = first_freq_cell.content in let new_cell = Dbllist.append freq_list k in @@ -121,11 +125,11 @@ struct let remove t k = try - let freq_cell, key_cell, _value = H.find t.value k in + let freq_index, key_index, _value = H.find t.value k in H.remove t.value k; - let _freq, freq_list = freq_cell.content in - Dbllist.remove freq_list key_cell; - if Dbllist.is_empty freq_list then Dbllist.remove t.frequency freq_cell; + let _freq, freq_list = Dllist.get t.frequency freq_index in + Dllist.remove freq_list key_index; + (* if Dbllist.is_empty freq_list then Dllist.remove t.frequency freq_cell; *) Stats.remove t.stats with Not_found -> () end From 3b27ee70efc5d465314e1debc37cee65d4ec5ca8 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Wed, 25 May 2022 10:52:33 +0200 Subject: [PATCH 03/22] Dllist changed with external contents array --- src/chunk_lst.ml | 1 + src/dllist2.ml | 89 ++++++++++++++++++++++++++++++++++++++++++++++++ src/dllist2.mli | 10 ++++++ src/lfu.ml | 6 +++- 4 files changed, 105 insertions(+), 1 deletion(-) create mode 100644 src/chunk_lst.ml create mode 100644 src/dllist2.ml create mode 100644 src/dllist2.mli diff --git a/src/chunk_lst.ml b/src/chunk_lst.ml new file mode 100644 index 0000000..dbfb783 --- /dev/null +++ b/src/chunk_lst.ml @@ -0,0 +1 @@ +type 'a t = { contents : 'a array; free : int } \ No newline at end of file diff --git a/src/dllist2.ml b/src/dllist2.ml new file mode 100644 index 0000000..2ef00a0 --- /dev/null +++ b/src/dllist2.ml @@ -0,0 +1,89 @@ +type 'a t = { + contents : 'a array; + witness : 'a; + prev : int array; + next : int array; + mutable first : int; + mutable last : int; + mutable free : int; + cap : int; + mutable size : int; +} + +type 'a l = { contents : 'a array; mutable free : int } + +let create l c witness = + { + contents = l.contents; + witness; + prev = Array.init c pred; + next = Array.init c (fun i -> if i = c - 1 then -1 else succ i); + first = -1; + last = -1; + free = l.free; + cap = c; + size = 0; + } + +let clear t = + t.first <- -1; + t.last <- -1; + t.free <- 0; + t.size <- 0; + let o = t.cap - 1 in + let o1 = 0 in + for i = o1 to o do + t.contents.(i) <- t.witness; + t.prev.(i) <- -1; + t.next.(i) <- -1 + done + +let append t v = + let removed = + if t.free <> -1 then ( + let index = t.free in + t.free <- t.next.(t.free); + if t.free <> -1 then t.prev.(t.free) <- -1; + t.next.(index) <- t.first; + if t.size = 0 then t.last <- index else t.prev.(t.first) <- index; + t.first <- index; + t.contents.(index) <- v; + t.size <- t.size + 1; + None) + else + let removed = Some t.contents.(t.last) in + let new_first = t.last in + t.last <- t.prev.(t.last); + t.contents.(new_first) <- v; + t.next.(t.last) <- -1; + t.prev.(new_first) <- -1; + t.next.(new_first) <- t.first; + t.prev.(t.first) <- new_first; + t.first <- new_first; + removed + in + (t.first, removed) + +let promote t i = + if i <> t.first then ( + t.next.(t.prev.(i)) <- t.next.(i); + if i <> t.last then t.prev.(t.next.(i)) <- t.prev.(i) + else t.last <- t.prev.(i); + t.prev.(t.first) <- i; + t.next.(i) <- t.first; + t.prev.(i) <- -1; + t.first <- i); + t.first + +let remove t i = + if i <> t.first then t.next.(t.prev.(i)) <- t.next.(i); + if i <> t.last then t.prev.(t.next.(i)) <- t.prev.(i) + else t.last <- t.prev.(t.last); + if t.free <> -1 then t.prev.(t.free) <- i; + t.next.(i) <- t.free; + t.prev.(i) <- -1; + t.free <- i; + t.size <- t.size - 1 + +let get t i1 = t.contents.(i1) +let length t = t.size diff --git a/src/dllist2.mli b/src/dllist2.mli new file mode 100644 index 0000000..d0f9182 --- /dev/null +++ b/src/dllist2.mli @@ -0,0 +1,10 @@ +type 'a t +type 'a l + +val create : 'a l -> int -> 'a -> 'a t +val length : 'a t -> int +val append : 'a t -> 'a -> int * 'a option +val promote : 'a t -> int -> int +val remove : 'a t -> int -> unit +val get : 'a t -> int -> 'a +val clear : 'a t -> unit diff --git a/src/lfu.ml b/src/lfu.ml index 8635388..04b8079 100644 --- a/src/lfu.ml +++ b/src/lfu.ml @@ -18,12 +18,16 @@ struct stats : Stats.t; } + type 'a l = { contents : 'a array; mutable free : int } + let dummy : K.t = Obj.magic (ref 0) let unsafe_v c = + let key_lst = { contents = Array.make c dummy; free = 0 } in + let freq_lst = { contents = Array.make c dummy; free = 0 } in { value = H.create c; - frequency = Dllist.create 0 (0, Dllist.create 0 dummy); + frequency = Dllist.create freq_lst 0 (0, Dllist.create key_lst 0 dummy); cap = c; stats = Stats.v (); } From dc078a6a79ca6588f976c47b2cc8e2201b687b39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Pascutto?= Date: Wed, 25 May 2022 11:21:27 +0200 Subject: [PATCH 04/22] new dllist implementation --- src/dllist.ml | 202 +++++++++++++++++------------------------------- src/dllist.mli | 17 ++-- src/dllist2.ml | 89 --------------------- src/dllist2.mli | 10 --- src/lru.ml | 4 +- 5 files changed, 80 insertions(+), 242 deletions(-) delete mode 100644 src/dllist2.ml delete mode 100644 src/dllist2.mli diff --git a/src/dllist.ml b/src/dllist.ml index 01576ba..3ef2fac 100644 --- a/src/dllist.ml +++ b/src/dllist.ml @@ -1,153 +1,91 @@ type 'a t = { - contents : 'a Vector.t; + cap : int; witness : 'a; - prev : int Vector.t; - next : int Vector.t; + contents : 'a array; + mutable free : int; + prev : int array; + next : int array; +} + +type 'a l = { mutable first : int; mutable last : int; - mutable free : int; - cap : int; mutable size : int; + t : 'a t; } -let create c witness = +let create cap witness = { - contents = Vector.make c ~dummy:witness; + cap; witness; - prev = Vector.init c ~dummy:0 pred; - next = Vector.init c ~dummy:0 (fun i -> if i = c - 1 then -1 else succ i); - first = -1; - last = -1; + contents = Array.make cap witness; free = 0; - cap = c; - size = 0; + prev = Array.init cap pred; + next = Array.init cap (fun i -> if i = cap - 1 then -1 else succ i); } -let clear t = - t.first <- -1; - t.last <- -1; - t.free <- 0; - t.size <- 0; - let o = t.cap - 1 in - let o1 = 0 in - for i = o1 to o do - Vector.set t.contents i t.witness; - Vector.set t.prev i (-1); - Vector.set t.next i (-1) - done +let create_list t = { first = -1; last = -1; size = 0; t } -let append t v = - let removed = - if t.free <> -1 then ( - let index = t.free in - t.free <- Vector.get t.next t.free; - if t.free <> -1 then Vector.set t.prev t.free (-1); - Vector.set t.next index t.first; - if t.size = 0 then t.last <- index else Vector.set t.prev t.first index; - t.first <- index; - Vector.set t.contents index v; - t.size <- t.size + 1; - None) - else - let removed = Some (Vector.get t.contents t.last) in - let new_first = t.last in - t.last <- Vector.get t.prev t.last; - Vector.set t.contents new_first v; - Vector.set t.next t.last (-1); - Vector.set t.prev new_first (-1); - Vector.set t.next new_first t.first; - Vector.set t.prev t.first new_first; - t.first <- new_first; - removed +let clear l = + let rec aux i = + if i = -1 then () + else ( + l.t.contents.(i) <- l.t.witness; + l.t.prev.(i) <- -1; + l.t.next.(i) <- -1; + aux l.t.next.(i)) in - (t.first, removed) - -let promote t i = - if i <> t.first then ( - Vector.set t.next (Vector.get t.prev i) (Vector.get t.next i); - if i <> t.last then - Vector.set t.prev (Vector.get t.next i) (Vector.get t.prev i) - else t.last <- Vector.get t.prev i; - Vector.set t.prev t.first i; - Vector.set t.next i t.first; - Vector.set t.prev i (-1); - t.first <- i); - t.first + aux l.first; + l.first <- -1; + l.last <- -1; + l.size <- 0 -let remove t i = - if i <> t.first then - Vector.set t.next (Vector.get t.prev i) (Vector.get t.next i); - if i <> t.last then - Vector.set t.prev (Vector.get t.next i) (Vector.get t.prev i) - else t.last <- Vector.get t.prev t.last; - if t.free <> -1 then Vector.set t.prev t.free i; - Vector.set t.next i t.free; - Vector.set t.prev i (-1); - t.free <- i; - t.size <- t.size - 1 - -let get t i1 = Vector.get t.contents i1 -let length t = t.size -let is_empty t = Vector.is_empty t.contents - -let get_ends t = - if not (Vector.is_empty t.contents) then (t.first, t.last) - else raise Not_found - -let insert_head t v = +let append l v = let removed = - if t.free <> -1 then ( - let new_index = t.free in - t.free <- Vector.get t.next t.free; - if t.free <> -1 then Vector.set t.prev t.free (-1); - Vector.set t.prev new_index t.last; - if t.size = 0 then t.first <- new_index - else Vector.set t.next t.last new_index; - t.last <- new_index; - Vector.set t.contents new_index v; - t.size <- t.size + 1; + if l.t.free <> -1 then ( + let index = l.t.free in + l.t.free <- l.t.next.(l.t.free); + if l.t.free <> -1 then l.t.prev.(l.t.free) <- -1; + l.t.next.(index) <- l.first; + if l.size = 0 then l.last <- index else l.t.prev.(l.first) <- index; + l.first <- index; + l.t.contents.(index) <- v; + l.size <- l.size + 1; None) else - let removed = Some (Vector.get t.contents t.last) in - let new_first = t.last in - t.last <- Vector.get t.prev t.last; - Vector.set t.contents new_first v; - Vector.set t.next t.last (-1); - Vector.set t.prev new_first (-1); - Vector.set t.next new_first t.first; - Vector.set t.prev t.first new_first; - t.first <- new_first; + let removed = Some l.t.contents.(l.last) in + let new_first = l.last in + l.last <- l.t.prev.(l.last); + l.t.contents.(new_first) <- v; + l.t.next.(l.last) <- -1; + l.t.prev.(new_first) <- -1; + l.t.next.(new_first) <- l.first; + l.t.prev.(l.first) <- new_first; + l.first <- new_first; removed in - (t.first, removed) + (l.first, removed) -let insert_before t v i = - let removed = - if t.free <> -1 then ( - let new_index = t.free in - t.free <- Vector.get t.next t.free; - if t.free <> -1 then Vector.set t.prev t.free (-1); - let i_prev = Vector.get t.prev i in - Vector.set t.prev new_index i_prev; - Vector.set t.next i_prev new_index; - Vector.set t.prev i new_index; - Vector.set t.next new_index i; - if t.size = 0 then ( - t.first <- new_index; - t.last <- new_index); - Vector.set t.contents new_index v; - t.size <- t.size + 1; - None) - else - let removed = Some (Vector.get t.contents t.last) in - let new_first = t.last in - t.last <- Vector.get t.prev t.last; - Vector.set t.contents new_first v; - Vector.set t.next t.last (-1); - Vector.set t.prev new_first (-1); - Vector.set t.next new_first t.first; - Vector.set t.prev t.first new_first; - t.first <- new_first; - removed - in - (t.first, removed) +let promote l i = + if i <> l.first then ( + l.t.next.(l.t.prev.(i)) <- l.t.next.(i); + if i <> l.last then l.t.prev.(l.t.next.(i)) <- l.t.prev.(i) + else l.last <- l.t.prev.(i); + l.t.prev.(l.first) <- i; + l.t.next.(i) <- l.first; + l.t.prev.(i) <- -1; + l.first <- i); + l.first + +let remove l i = + if i <> l.first then l.t.next.(l.t.prev.(i)) <- l.t.next.(i); + if i <> l.last then l.t.prev.(l.t.next.(i)) <- l.t.prev.(i) + else l.last <- l.t.prev.(l.last); + if l.t.free <> -1 then l.t.prev.(l.t.free) <- i; + l.t.next.(i) <- l.t.free; + l.t.prev.(i) <- -1; + l.t.free <- i; + l.size <- l.size - 1 + +let get l i1 = l.t.contents.(i1) +let length l = l.size diff --git a/src/dllist.mli b/src/dllist.mli index 2c7e8ae..646f9ea 100644 --- a/src/dllist.mli +++ b/src/dllist.mli @@ -1,12 +1,11 @@ type 'a t +type 'a l val create : int -> 'a -> 'a t -val length : 'a t -> int -val append : 'a t -> 'a -> int * 'a option -val promote : 'a t -> int -> int -val remove : 'a t -> int -> unit -val get : 'a t -> int -> 'a -val clear : 'a t -> unit -val is_empty : 'a t -> bool -val get_ends : 'a t -> int * int -val insert_before : 'a t -> 'a -> int +val create_list : 'a t -> 'a l +val length : 'a l -> int +val append : 'a l -> 'a -> int * 'a option +val promote : 'a l -> int -> int +val remove : 'a l -> int -> unit +val get : 'a l -> int -> 'a +val clear : 'a l -> unit diff --git a/src/dllist2.ml b/src/dllist2.ml deleted file mode 100644 index 2ef00a0..0000000 --- a/src/dllist2.ml +++ /dev/null @@ -1,89 +0,0 @@ -type 'a t = { - contents : 'a array; - witness : 'a; - prev : int array; - next : int array; - mutable first : int; - mutable last : int; - mutable free : int; - cap : int; - mutable size : int; -} - -type 'a l = { contents : 'a array; mutable free : int } - -let create l c witness = - { - contents = l.contents; - witness; - prev = Array.init c pred; - next = Array.init c (fun i -> if i = c - 1 then -1 else succ i); - first = -1; - last = -1; - free = l.free; - cap = c; - size = 0; - } - -let clear t = - t.first <- -1; - t.last <- -1; - t.free <- 0; - t.size <- 0; - let o = t.cap - 1 in - let o1 = 0 in - for i = o1 to o do - t.contents.(i) <- t.witness; - t.prev.(i) <- -1; - t.next.(i) <- -1 - done - -let append t v = - let removed = - if t.free <> -1 then ( - let index = t.free in - t.free <- t.next.(t.free); - if t.free <> -1 then t.prev.(t.free) <- -1; - t.next.(index) <- t.first; - if t.size = 0 then t.last <- index else t.prev.(t.first) <- index; - t.first <- index; - t.contents.(index) <- v; - t.size <- t.size + 1; - None) - else - let removed = Some t.contents.(t.last) in - let new_first = t.last in - t.last <- t.prev.(t.last); - t.contents.(new_first) <- v; - t.next.(t.last) <- -1; - t.prev.(new_first) <- -1; - t.next.(new_first) <- t.first; - t.prev.(t.first) <- new_first; - t.first <- new_first; - removed - in - (t.first, removed) - -let promote t i = - if i <> t.first then ( - t.next.(t.prev.(i)) <- t.next.(i); - if i <> t.last then t.prev.(t.next.(i)) <- t.prev.(i) - else t.last <- t.prev.(i); - t.prev.(t.first) <- i; - t.next.(i) <- t.first; - t.prev.(i) <- -1; - t.first <- i); - t.first - -let remove t i = - if i <> t.first then t.next.(t.prev.(i)) <- t.next.(i); - if i <> t.last then t.prev.(t.next.(i)) <- t.prev.(i) - else t.last <- t.prev.(t.last); - if t.free <> -1 then t.prev.(t.free) <- i; - t.next.(i) <- t.free; - t.prev.(i) <- -1; - t.free <- i; - t.size <- t.size - 1 - -let get t i1 = t.contents.(i1) -let length t = t.size diff --git a/src/dllist2.mli b/src/dllist2.mli deleted file mode 100644 index d0f9182..0000000 --- a/src/dllist2.mli +++ /dev/null @@ -1,10 +0,0 @@ -type 'a t -type 'a l - -val create : 'a l -> int -> 'a -> 'a t -val length : 'a t -> int -val append : 'a t -> 'a -> int * 'a option -val promote : 'a t -> int -> int -val remove : 'a t -> int -> unit -val get : 'a t -> int -> 'a -val clear : 'a t -> unit diff --git a/src/lru.ml b/src/lru.ml index 34f23ad..10f82c8 100644 --- a/src/lru.ml +++ b/src/lru.ml @@ -13,7 +13,7 @@ struct type 'a t = { tbl : (int * 'a) H.t; - lst : K.t Dllist.t; + lst : K.t Dllist.l; cap : int; stats : Stats.t; } @@ -21,7 +21,7 @@ struct let unsafe_v c = { tbl = H.create c; - lst = Dllist.create c dummy; + lst = Dllist.create c dummy |> Dllist.create_list; cap = c; stats = Stats.v (); } From a64d09a72b8da90e4f8f0328e245ed97477b0872 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Wed, 25 May 2022 14:17:19 +0200 Subject: [PATCH 05/22] update lfu to work with dllist -> bugs to correct --- src/dllist.ml | 27 +++++++++++++ src/dllist.mli | 5 +++ src/lfu.ml | 108 ++++++++++++++++++++++++------------------------- 3 files changed, 86 insertions(+), 54 deletions(-) diff --git a/src/dllist.ml b/src/dllist.ml index 3ef2fac..ddd3074 100644 --- a/src/dllist.ml +++ b/src/dllist.ml @@ -25,6 +25,8 @@ let create cap witness = } let create_list t = { first = -1; last = -1; size = 0; t } +let next l i = l.t.next.(i) +let ends l = (l.first, l.last) let clear l = let rec aux i = @@ -89,3 +91,28 @@ let remove l i = let get l i1 = l.t.contents.(i1) let length l = l.size +let is_empty l = l.size = 0 + +let append_before l i v = + let new_index = l.t.free in + l.t.free <- l.t.next.(l.t.free); + if l.t.free <> -1 then l.t.prev.(l.t.free) <- -1; + if l.first = i then l.first <- new_index + else l.t.next.(l.t.prev.(i)) <- new_index; + l.t.next.(new_index) <- i; + l.t.prev.(i) <- new_index; + l.t.contents.(new_index) <- v; + l.size <- l.size + 1; + new_index + +let append_after l i v = + let new_index = l.t.free in + l.t.free <- l.t.next.(l.t.free); + if l.t.free <> -1 then l.t.prev.(l.t.free) <- -1; + if l.last = i then l.last <- new_index + else l.t.prev.(l.t.next.(i)) <- new_index; + l.t.prev.(new_index) <- i; + l.t.next.(i) <- new_index; + l.t.contents.(new_index) <- v; + l.size <- l.size + 1; + new_index \ No newline at end of file diff --git a/src/dllist.mli b/src/dllist.mli index 646f9ea..f183768 100644 --- a/src/dllist.mli +++ b/src/dllist.mli @@ -9,3 +9,8 @@ val promote : 'a l -> int -> int val remove : 'a l -> int -> unit val get : 'a l -> int -> 'a val clear : 'a l -> unit +val is_empty : 'a l -> bool +val append_before : 'a l -> int -> 'a -> int +val append_after : 'a l -> int -> 'a -> int +val next : 'a l -> int -> int +val ends : 'a l -> int * int \ No newline at end of file diff --git a/src/lfu.ml b/src/lfu.ml index 04b8079..8524c9c 100644 --- a/src/lfu.ml +++ b/src/lfu.ml @@ -8,29 +8,25 @@ struct module H = Hashtbl.Make (K) type key = K.t - type freq_index = int - type key_index = int + (* type freq_index = int + type key_index = int *) type 'a t = { - value : (freq_index * key_index * 'a) H.t; - frequency : (int * key Dllist.t) Dllist.t; + tbl : key Dllist.t; + value : (int * int * 'a) H.t; + frequency : (int * key Dllist.l) Dllist.l; cap : int; stats : Stats.t; } - type 'a l = { contents : 'a array; mutable free : int } - let dummy : K.t = Obj.magic (ref 0) let unsafe_v c = - let key_lst = { contents = Array.make c dummy; free = 0 } in - let freq_lst = { contents = Array.make c dummy; free = 0 } in - { - value = H.create c; - frequency = Dllist.create freq_lst 0 (0, Dllist.create key_lst 0 dummy); - cap = c; - stats = Stats.v (); - } + let tbl = Dllist.create c dummy in + let freq = + Dllist.create c (-1, Dllist.create_list tbl) |> Dllist.create_list + in + { tbl; value = H.create c; frequency = freq; cap = c; stats = Stats.v () } let v c = if c <= 0 then invalid_arg "capacity must be strictly positive"; @@ -47,27 +43,30 @@ struct Stats.clear t.stats let update t k = - let freq_cell, key_cell, _value = H.find t.value k in - let freq, freq_list = freq_cell.content in - let freq_next, _freq_next_list = freq_cell.next.content in - (if freq <> freq_next - 1 then - let real_next_freq_list = Dbllist.create () in - let real_freq = freq + 1 in - ignore - (Dbllist.append_after t.frequency freq_cell + let freq_index, key_index, _value = H.find t.value k in + let freq, freq_list = Dllist.get t.frequency freq_index in + let freq_next, _freq_next_list = + Dllist.(get t.frequency (next t.frequency freq_index)) + in + let new_freq_index = + if freq <> freq_next - 1 then + let real_next_freq_list = Dllist.create_list t.tbl in + let real_freq = freq + 1 in + Dllist.append_before t.frequency freq_index (real_freq, real_next_freq_list) - : freq_cell)); - Dbllist.remove freq_list key_cell; - let _freq_next, freq_next_list = freq_cell.next.content in - if Dbllist.is_empty freq_list then Dbllist.remove t.frequency freq_cell; - let last = Dbllist.append freq_next_list k in - (freq_cell.next, last) + else freq_next + in + Dllist.remove freq_list key_index; + let _freq_next, freq_next_list = Dllist.get t.frequency new_freq_index in + if Dllist.is_empty freq_list then Dllist.remove t.frequency freq_index; + let new_key_index, _opt = Dllist.append freq_next_list k in + (new_freq_index, new_key_index) let find t k = - let _freq_cell, _key_cell, v = H.find t.value k in + let _freq_index, _key_index, v = H.find t.value k in Stats.hit t.stats; - let new_freq_cell, new_last_cell = update t k in - H.replace t.value k (new_freq_cell, new_last_cell, v); + let new_freq_index, new_last_index = update t k in + H.replace t.value k (new_freq_index, new_last_index, v); v let find_opt t k = @@ -86,43 +85,45 @@ struct let add t k v = if H.length t.value = 0 then - let first_freq_list = Dllist.create 0 dummy in + let first_freq_list = Dllist.create_list t.tbl in let new_key_index, _opt = Dllist.append first_freq_list k in let first_key_index, _opt = Dllist.append t.frequency (1, first_freq_list) in H.replace t.value k (first_key_index, new_key_index, v) else - let first_freq_index, _last_freq_index = Dllist.get_ends t.frequency in - + let first_freq_index, _last_freq_index = Dllist.ends t.frequency in let freq, _key_list = Dllist.get t.frequency first_freq_index in - (if freq <> 1 then - let real_first_freq_list = Dllist.create 0 dummy in - Dllist.append_before t.frequency first_freq_cell (1, real_first_freq_list)); + let new_first_freq_index = + if freq <> 1 then + let real_first_freq_list = Dllist.create_list t.tbl in + Dllist.append_after t.frequency first_freq_index + (1, real_first_freq_list) + else first_freq_index + in - let first_freq_cell, _last_freq_cell = Dbllist.get t.frequency in - let _freq, freq_list = first_freq_cell.content in - let new_cell = Dbllist.append freq_list k in - H.replace t.value k (first_freq_cell, new_cell, v) + let _freq, freq_list = Dllist.get t.frequency new_first_freq_index in + let new_index, _opt = Dllist.append freq_list k in + H.replace t.value k (new_first_freq_index, new_index, v) let replace t k v = try - let _freq_cell, _key_cell, _value = H.find t.value k in - let new_freq_cell, new_last_cell = update t k in + let _freq_index, _key_index, _value = H.find t.value k in + let new_freq_index, new_key_index = update t k in Stats.replace t.stats; - H.replace t.value k (new_freq_cell, new_last_cell, v) + H.replace t.value k (new_freq_index, new_key_index, v) with Not_found -> Stats.add (H.length t.value + 1) t.stats; if H.length t.value < t.cap then add t k v else - let first_freq_cell, _last_freq_cell = Dbllist.get t.frequency in - let _freq, freq_list = first_freq_cell.content in - let first_cell, _last_cell = Dbllist.get freq_list in - Dbllist.remove freq_list first_cell; - if Dbllist.is_empty freq_list then - Dbllist.remove t.frequency first_freq_cell; - let remove_key = first_cell.content in + let first_freq_index, _last_freq_index = Dllist.ends t.frequency in + let _freq, freq_list = Dllist.get t.frequency first_freq_index in + let first_index, _last_index = Dllist.ends freq_list in + let remove_key = Dllist.get freq_list first_index in + Dllist.remove freq_list first_index; + if Dllist.is_empty freq_list then + Dllist.remove t.frequency first_freq_index; H.remove t.value remove_key; Stats.discard t.stats; add t k v @@ -131,9 +132,8 @@ struct try let freq_index, key_index, _value = H.find t.value k in H.remove t.value k; - let _freq, freq_list = Dllist.get t.frequency freq_index in - Dllist.remove freq_list key_index; - (* if Dbllist.is_empty freq_list then Dllist.remove t.frequency freq_cell; *) + let _freq, key_list = Dllist.get t.frequency freq_index in + Dllist.remove key_list key_index; Stats.remove t.stats with Not_found -> () end From 9d1ab1e12d4f9e6533b482fbbfa71b6324e37946 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Wed, 25 May 2022 15:03:10 +0200 Subject: [PATCH 06/22] add display --- src/dbllist.ml | 3 ++- src/dbllist.mli | 3 ++- src/dllist.ml | 15 +++++++++++++++ src/dllist.mli | 3 ++- src/lfu.ml | 12 ++++++++++++ 5 files changed, 33 insertions(+), 3 deletions(-) diff --git a/src/dbllist.ml b/src/dbllist.ml index a85b8e1..e5f86e2 100644 --- a/src/dbllist.ml +++ b/src/dbllist.ml @@ -53,7 +53,8 @@ let append_after l c v = new_cell let clear l = l := Nil -let get l = match !l with Nil -> assert false | List l -> (l.first, l.last) +let ends l = match !l with Nil -> assert false | List l -> (l.first, l.last) +let get c = c.content let remove t c = match !t with diff --git a/src/dbllist.mli b/src/dbllist.mli index dea08c5..3a94b1a 100644 --- a/src/dbllist.mli +++ b/src/dbllist.mli @@ -12,5 +12,6 @@ val append : 'a t -> 'a -> 'a cell val append_before : 'a t -> 'a cell -> 'a -> 'a cell val append_after : 'a t -> 'a cell -> 'a -> 'a cell val clear : 'a t -> unit -val get : 'a t -> 'a cell * 'a cell +val ends : 'a t -> 'a cell * 'a cell val remove : 'a t -> 'a cell -> unit +val get : 'a cell -> 'a diff --git a/src/dllist.ml b/src/dllist.ml index ddd3074..291b37f 100644 --- a/src/dllist.ml +++ b/src/dllist.ml @@ -14,6 +14,18 @@ type 'a l = { t : 'a t; } +let status l = + Fmt.pr "first : %d\n" l.first; + Fmt.pr "last : %d\n" l.last; + for i = 0 to Array.length l.t.prev - 1 do + Fmt.pr " %d " l.t.prev.(i) + done; + Fmt.pr "\n\n"; + for i = 0 to Array.length l.t.next - 1 do + Fmt.pr " %d " l.t.next.(i) + done; + Fmt.pr "\n\n" + let create cap witness = { cap; @@ -45,6 +57,8 @@ let clear l = let append l v = let removed = if l.t.free <> -1 then ( + Fmt.pr ":)\n"; + status l; let index = l.t.free in l.t.free <- l.t.next.(l.t.free); if l.t.free <> -1 then l.t.prev.(l.t.free) <- -1; @@ -66,6 +80,7 @@ let append l v = l.first <- new_first; removed in + (l.first, removed) let promote l i = diff --git a/src/dllist.mli b/src/dllist.mli index f183768..3ad2a1e 100644 --- a/src/dllist.mli +++ b/src/dllist.mli @@ -13,4 +13,5 @@ val is_empty : 'a l -> bool val append_before : 'a l -> int -> 'a -> int val append_after : 'a l -> int -> 'a -> int val next : 'a l -> int -> int -val ends : 'a l -> int * int \ No newline at end of file +val ends : 'a l -> int * int +val status : 'a l -> unit \ No newline at end of file diff --git a/src/lfu.ml b/src/lfu.ml index 8524c9c..2239777 100644 --- a/src/lfu.ml +++ b/src/lfu.ml @@ -23,6 +23,7 @@ struct let unsafe_v c = let tbl = Dllist.create c dummy in + let freq = Dllist.create c (-1, Dllist.create_list tbl) |> Dllist.create_list in @@ -43,6 +44,7 @@ struct Stats.clear t.stats let update t k = + Fmt.pr "u\n"; let freq_index, key_index, _value = H.find t.value k in let freq, freq_list = Dllist.get t.frequency freq_index in let freq_next, _freq_next_list = @@ -63,6 +65,7 @@ struct (new_freq_index, new_key_index) let find t k = + Fmt.pr "-\n"; let _freq_index, _key_index, v = H.find t.value k in Stats.hit t.stats; let new_freq_index, new_last_index = update t k in @@ -76,6 +79,7 @@ struct None let mem t k = + Fmt.pr "m\n"; try ignore (find t k); true @@ -84,6 +88,10 @@ struct false let add t k v = + Fmt.pr "add---\n"; + Dllist.status t.frequency; + Fmt.pr "/add---\n"; + if H.length t.value = 0 then let first_freq_list = Dllist.create_list t.tbl in let new_key_index, _opt = Dllist.append first_freq_list k in @@ -108,6 +116,9 @@ struct H.replace t.value k (new_first_freq_index, new_index, v) let replace t k v = + Fmt.pr "R---\n"; + Dllist.status t.frequency; + Fmt.pr "/R---\n"; try let _freq_index, _key_index, _value = H.find t.value k in let new_freq_index, new_key_index = update t k in @@ -129,6 +140,7 @@ struct add t k v let remove t k = + Fmt.pr "r\n"; try let freq_index, key_index, _value = H.find t.value k in H.remove t.value k; From a290dff5a6c6a256be5c27b79713e4eafaba8f2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Pascutto?= Date: Wed, 25 May 2022 18:54:55 +0200 Subject: [PATCH 07/22] wip --- src/dllist.ml | 90 ++++++++++++++++++++++++++++---------------------- src/dllist.mli | 19 ++++++----- src/dune | 1 + src/lfu.ml | 62 ++++++++++++++++------------------ src/lru.ml | 2 +- test/lfu.ml | 88 ++++++++++++++++++++++++------------------------ 6 files changed, 134 insertions(+), 128 deletions(-) diff --git a/src/dllist.ml b/src/dllist.ml index 291b37f..b135802 100644 --- a/src/dllist.ml +++ b/src/dllist.ml @@ -14,17 +14,14 @@ type 'a l = { t : 'a t; } -let status l = - Fmt.pr "first : %d\n" l.first; - Fmt.pr "last : %d\n" l.last; - for i = 0 to Array.length l.t.prev - 1 do - Fmt.pr " %d " l.t.prev.(i) - done; - Fmt.pr "\n\n"; - for i = 0 to Array.length l.t.next - 1 do - Fmt.pr " %d " l.t.next.(i) - done; - Fmt.pr "\n\n" +type 'a c = int + +let status ppf l = + Fmt.pf ppf "first : %d@\n" l.first; + Fmt.pf ppf "last : %d@\n" l.last; + Fmt.(pf ppf "free : %a@\n" int) l.t.free; + Fmt.(pf ppf "prev : %a@\n" (array ~sep:sp int)) l.t.prev; + Fmt.(pf ppf "next : %a@\n@\n" (array ~sep:sp int)) l.t.next let create cap witness = { @@ -37,7 +34,11 @@ let create cap witness = } let create_list t = { first = -1; last = -1; size = 0; t } -let next l i = l.t.next.(i) + +let next l i = + let n = l.t.next.(i) in + if n = -1 then i else n + let ends l = (l.first, l.last) let clear l = @@ -57,77 +58,86 @@ let clear l = let append l v = let removed = if l.t.free <> -1 then ( - Fmt.pr ":)\n"; - status l; let index = l.t.free in l.t.free <- l.t.next.(l.t.free); if l.t.free <> -1 then l.t.prev.(l.t.free) <- -1; - l.t.next.(index) <- l.first; - if l.size = 0 then l.last <- index else l.t.prev.(l.first) <- index; - l.first <- index; + l.t.next.(index) <- -1; + if l.size = 0 then l.first <- index else l.t.next.(l.last) <- index; + l.t.prev.(index) <- l.last; + l.last <- index; l.t.contents.(index) <- v; l.size <- l.size + 1; None) else - let removed = Some l.t.contents.(l.last) in - let new_first = l.last in - l.last <- l.t.prev.(l.last); - l.t.contents.(new_first) <- v; - l.t.next.(l.last) <- -1; - l.t.prev.(new_first) <- -1; - l.t.next.(new_first) <- l.first; - l.t.prev.(l.first) <- new_first; - l.first <- new_first; + let removed = Some l.t.contents.(l.first) in + let index = l.first in + l.t.prev.(l.t.next.(l.first)) <- -1; + l.first <- l.t.next.(l.first); + l.t.prev.(index) <- l.last; + l.t.next.(l.last) <- index; + l.last <- index; + l.t.contents.(index) <- v; + l.t.next.(index) <- -1; removed in - + assert (l.first <> -1); (l.first, removed) let promote l i = - if i <> l.first then ( - l.t.next.(l.t.prev.(i)) <- l.t.next.(i); - if i <> l.last then l.t.prev.(l.t.next.(i)) <- l.t.prev.(i) - else l.last <- l.t.prev.(i); - l.t.prev.(l.first) <- i; - l.t.next.(i) <- l.first; - l.t.prev.(i) <- -1; - l.first <- i); - l.first + if i <> l.last then ( + l.t.prev.(l.t.next.(i)) <- l.t.prev.(i); + if i <> l.first then l.t.next.(l.t.prev.(i)) <- l.t.next.(i) + else l.first <- l.t.next.(i); + l.t.next.(l.last) <- i; + l.t.prev.(i) <- l.last; + l.t.next.(i) <- -1; + l.last <- i); + l.last let remove l i = - if i <> l.first then l.t.next.(l.t.prev.(i)) <- l.t.next.(i); + Fmt.epr "%a@." status l; + Fmt.epr "%d@." i; + if i <> l.first then l.t.next.(l.t.prev.(i)) <- l.t.next.(i) + else l.first <- l.t.next.(l.first); if i <> l.last then l.t.prev.(l.t.next.(i)) <- l.t.prev.(i) else l.last <- l.t.prev.(l.last); if l.t.free <> -1 then l.t.prev.(l.t.free) <- i; l.t.next.(i) <- l.t.free; l.t.prev.(i) <- -1; l.t.free <- i; - l.size <- l.size - 1 + l.size <- l.size - 1; + l.t.contents.(i) <- l.t.witness -let get l i1 = l.t.contents.(i1) +let get l i = l.t.contents.(i) let length l = l.size let is_empty l = l.size = 0 let append_before l i v = let new_index = l.t.free in + assert (new_index <> -1); l.t.free <- l.t.next.(l.t.free); if l.t.free <> -1 then l.t.prev.(l.t.free) <- -1; if l.first = i then l.first <- new_index else l.t.next.(l.t.prev.(i)) <- new_index; l.t.next.(new_index) <- i; + l.t.prev.(new_index) <- l.t.prev.(i); l.t.prev.(i) <- new_index; l.t.contents.(new_index) <- v; l.size <- l.size + 1; + assert (l.first <> -1); new_index let append_after l i v = let new_index = l.t.free in + assert (new_index <> -1); l.t.free <- l.t.next.(l.t.free); if l.t.free <> -1 then l.t.prev.(l.t.free) <- -1; if l.last = i then l.last <- new_index else l.t.prev.(l.t.next.(i)) <- new_index; l.t.prev.(new_index) <- i; + l.t.next.(new_index) <- l.t.next.(i); l.t.next.(i) <- new_index; l.t.contents.(new_index) <- v; l.size <- l.size + 1; - new_index \ No newline at end of file + assert (l.first <> -1); + new_index diff --git a/src/dllist.mli b/src/dllist.mli index 3ad2a1e..18d46e3 100644 --- a/src/dllist.mli +++ b/src/dllist.mli @@ -1,17 +1,18 @@ type 'a t type 'a l +type 'a c val create : int -> 'a -> 'a t val create_list : 'a t -> 'a l val length : 'a l -> int -val append : 'a l -> 'a -> int * 'a option -val promote : 'a l -> int -> int -val remove : 'a l -> int -> unit -val get : 'a l -> int -> 'a +val append : 'a l -> 'a -> 'a c * 'a option +val promote : 'a l -> 'a c -> 'a c +val remove : 'a l -> 'a c -> unit +val get : 'a l -> 'a c -> 'a val clear : 'a l -> unit val is_empty : 'a l -> bool -val append_before : 'a l -> int -> 'a -> int -val append_after : 'a l -> int -> 'a -> int -val next : 'a l -> int -> int -val ends : 'a l -> int * int -val status : 'a l -> unit \ No newline at end of file +val append_before : 'a l -> 'a c -> 'a -> 'a c +val append_after : 'a l -> 'a c -> 'a -> 'a c +val next : 'a l -> 'a c -> 'a c +val ends : 'a l -> 'a c * 'a c +val status : 'a l Fmt.t diff --git a/src/dune b/src/dune index b2c5a17..96d033b 100644 --- a/src/dune +++ b/src/dune @@ -1,6 +1,7 @@ (library (public_name cachecache) (name cachecache) + (flags :standard -w -21) (libraries fmt vector)) ; (rule diff --git a/src/lfu.ml b/src/lfu.ml index 2239777..958ca5b 100644 --- a/src/lfu.ml +++ b/src/lfu.ml @@ -12,22 +12,19 @@ struct type key_index = int *) type 'a t = { - tbl : key Dllist.t; - value : (int * int * 'a) H.t; + lsts : key Dllist.t; + value : ((int * key Dllist.l) Dllist.c * key Dllist.c * 'a) H.t; frequency : (int * key Dllist.l) Dllist.l; cap : int; stats : Stats.t; } - let dummy : K.t = Obj.magic (ref 0) + let dummy = Obj.magic (ref 0) let unsafe_v c = - let tbl = Dllist.create c dummy in - - let freq = - Dllist.create c (-1, Dllist.create_list tbl) |> Dllist.create_list - in - { tbl; value = H.create c; frequency = freq; cap = c; stats = Stats.v () } + let lsts = Dllist.create c dummy in + let freq = Dllist.create c dummy |> Dllist.create_list in + { lsts; value = H.create c; frequency = freq; cap = c; stats = Stats.v () } let v c = if c <= 0 then invalid_arg "capacity must be strictly positive"; @@ -44,28 +41,31 @@ struct Stats.clear t.stats let update t k = - Fmt.pr "u\n"; + Fmt.pr "u@."; + Fmt.epr "FREQ @[%a@]@." Dllist.status t.frequency; let freq_index, key_index, _value = H.find t.value k in let freq, freq_list = Dllist.get t.frequency freq_index in - let freq_next, _freq_next_list = - Dllist.(get t.frequency (next t.frequency freq_index)) - in + let next = Dllist.next t.frequency freq_index in + let freq_next, _freq_next_list = Dllist.get t.frequency next in let new_freq_index = - if freq <> freq_next - 1 then - let real_next_freq_list = Dllist.create_list t.tbl in + if freq + 1 <> freq_next then + let real_next_freq_list = Dllist.create_list t.lsts in let real_freq = freq + 1 in - Dllist.append_before t.frequency freq_index + Dllist.append_after t.frequency freq_index (real_freq, real_next_freq_list) - else freq_next + else next in + Fmt.epr "HELLO0@."; + Fmt.epr "FREQ @[%a@]@." Dllist.status t.frequency; Dllist.remove freq_list key_index; + Fmt.epr "HELLO1@."; let _freq_next, freq_next_list = Dllist.get t.frequency new_freq_index in if Dllist.is_empty freq_list then Dllist.remove t.frequency freq_index; let new_key_index, _opt = Dllist.append freq_next_list k in (new_freq_index, new_key_index) let find t k = - Fmt.pr "-\n"; + Fmt.pr "-@."; let _freq_index, _key_index, v = H.find t.value k in Stats.hit t.stats; let new_freq_index, new_last_index = update t k in @@ -79,7 +79,7 @@ struct None let mem t k = - Fmt.pr "m\n"; + Fmt.pr "m@."; try ignore (find t k); true @@ -88,12 +88,9 @@ struct false let add t k v = - Fmt.pr "add---\n"; - Dllist.status t.frequency; - Fmt.pr "/add---\n"; - + Fmt.pr "a@."; if H.length t.value = 0 then - let first_freq_list = Dllist.create_list t.tbl in + let first_freq_list = Dllist.create_list t.lsts in let new_key_index, _opt = Dllist.append first_freq_list k in let first_key_index, _opt = Dllist.append t.frequency (1, first_freq_list) @@ -102,23 +99,19 @@ struct else let first_freq_index, _last_freq_index = Dllist.ends t.frequency in let freq, _key_list = Dllist.get t.frequency first_freq_index in - let new_first_freq_index = if freq <> 1 then - let real_first_freq_list = Dllist.create_list t.tbl in - Dllist.append_after t.frequency first_freq_index + let real_first_freq_list = Dllist.create_list t.lsts in + Dllist.append_before t.frequency first_freq_index (1, real_first_freq_list) else first_freq_index in - let _freq, freq_list = Dllist.get t.frequency new_first_freq_index in let new_index, _opt = Dllist.append freq_list k in H.replace t.value k (new_first_freq_index, new_index, v) let replace t k v = - Fmt.pr "R---\n"; - Dllist.status t.frequency; - Fmt.pr "/R---\n"; + Fmt.pr "R@."; try let _freq_index, _key_index, _value = H.find t.value k in let new_freq_index, new_key_index = update t k in @@ -127,7 +120,8 @@ struct with Not_found -> Stats.add (H.length t.value + 1) t.stats; if H.length t.value < t.cap then add t k v - else + else ( + Fmt.pr "d@."; let first_freq_index, _last_freq_index = Dllist.ends t.frequency in let _freq, freq_list = Dllist.get t.frequency first_freq_index in let first_index, _last_index = Dllist.ends freq_list in @@ -137,10 +131,10 @@ struct Dllist.remove t.frequency first_freq_index; H.remove t.value remove_key; Stats.discard t.stats; - add t k v + add t k v) let remove t k = - Fmt.pr "r\n"; + Fmt.pr "r@."; try let freq_index, key_index, _value = H.find t.value k in H.remove t.value k; diff --git a/src/lru.ml b/src/lru.ml index 10f82c8..edeb0d0 100644 --- a/src/lru.ml +++ b/src/lru.ml @@ -12,7 +12,7 @@ struct let dummy : K.t = Obj.magic (ref 0) type 'a t = { - tbl : (int * 'a) H.t; + tbl : (K.t Dllist.c * 'a) H.t; lst : K.t Dllist.l; cap : int; stats : Stats.t; diff --git a/test/lfu.ml b/test/lfu.ml index 4327cbb..53c4304 100644 --- a/test/lfu.ml +++ b/test/lfu.ml @@ -46,23 +46,23 @@ struct if i = 0 then l else let k = add_fresh_value db_t t in - if check then ( - Alcotest.(check bool) - "[Though-DB] Value just added is found (mem)" true - (DB_Cached.mem db_t k); + if check then + (* Alcotest.(check bool) *) + (* "[Though-DB] Value just added is found (mem)" true *) + (* (DB_Cached.mem db_t k); *) + (* Alcotest.(check key) *) + (* "[Through-DB] Value just added is found (find)" k *) + (* (DB_Cached.find db_t k); *) + (* Alcotest.(check bool) *) + (* "[Through-cache] Value just added is found (mem)" true *) + (* (DB_Cached.Cache.mem db_t k); *) + (* Alcotest.(check key) *) + (* "[Through-cache] Value just added is found in cache (find)" k *) + (* (DB_Cached.Cache.find db_t k); *) + (* Alcotest.(check bool) *) + (* "[Direct] Value just added is found (mem)" true (Cache.mem t k); *) Alcotest.(check key) - "[Through-DB] Value just added is found (find)" k - (DB_Cached.find db_t k); - Alcotest.(check bool) - "[Through-cache] Value just added is found (mem)" true - (DB_Cached.Cache.mem db_t k); - Alcotest.(check key) - "[Through-cache] Value just added is found in cache (find)" k - (DB_Cached.Cache.find db_t k); - Alcotest.(check bool) - "[Direct] Value just added is found (mem)" true (Cache.mem t k); - Alcotest.(check key) - "[Direct] Value just added is found (find)" k (Cache.find t k)); + "[Direct] Value just added is found (find)" k (Cache.find t k); loop (k :: l) (i - 1) in loop [] n @@ -96,11 +96,11 @@ struct Alcotest.(check int) "[Direct] Size is still ten" 10 (Cache.size t); Alcotest.(check bool) "[Direct] Unused value are removed" false (Cache.mem t h); - Alcotest.(check bool) - "[Through-cache] Unused value are removed" true - (DB_Cached.Cache.mem db_t h); - Alcotest.(check bool) - "[Through-DB] Unused value are removed" true (DB_Cached.mem db_t h); + (* Alcotest.(check bool) *) + (* "[Through-cache] Unused value are removed" true *) + (* (DB_Cached.Cache.mem db_t h); *) + (* Alcotest.(check bool) *) + (* "[Through-DB] Unused value are removed" true (DB_Cached.mem db_t h); *) Alcotest.(check bool) "[Direct] Added value is still present" true (Cache.mem t k) | [] -> assert false @@ -119,22 +119,22 @@ struct removed; List.iter (fun k -> - Alcotest.(check bool) - "[Through-DB] Removed values are not present" false - (DB_Cached.mem db_t k); - Alcotest.(check bool) - "[Through-cache] Removed values are not present" false - (DB_Cached.Cache.mem db_t k); + (* Alcotest.(check bool) *) + (* "[Through-DB] Removed values are not present" false *) + (* (DB_Cached.mem db_t k); *) + (* Alcotest.(check bool) *) + (* "[Through-cache] Removed values are not present" false *) + (* (DB_Cached.Cache.mem db_t k); *) Alcotest.(check bool) "[Direct] Removed values are not present" false (Cache.mem t k)) removed; List.iter (fun k -> - Alcotest.(check bool) - "[Through-DB] Other values are present" true (DB_Cached.mem db_t k); - Alcotest.(check bool) - "[Through-cache] Other values are present" true - (DB_Cached.Cache.mem db_t k); + (* Alcotest.(check bool) *) + (* "[Through-DB] Other values are present" true (DB_Cached.mem db_t k); *) + (* Alcotest.(check bool) *) + (* "[Through-cache] Other values are present" true *) + (* (DB_Cached.Cache.mem db_t k); *) Alcotest.(check bool) "[Direct] Other values are present" true (Cache.mem t k)) kept; @@ -144,23 +144,23 @@ struct Cache.remove t k) kept; List.iter - (fun k -> - Alcotest.(check bool) - "[Through-DB] Removed values are not present" false - (DB_Cached.mem db_t k); - Alcotest.(check bool) - "[Through-cache] Removed values are not present" false - (DB_Cached.Cache.mem db_t k); + (fun _k -> + (* Alcotest.(check bool) *) + (* "[Through-DB] Removed values are not present" false *) + (* (DB_Cached.mem db_t k); *) + (* Alcotest.(check bool) *) + (* "[Through-cache] Removed values are not present" false *) + (* (DB_Cached.Cache.mem db_t k); *) Alcotest.(check bool) "[Direct] Cache is empty" true (Cache.is_empty t)) kept; let new_value = add_fresh_values ~check:false db_t t (cap / 2) in List.iter (fun k -> - Alcotest.(check bool) - "[Through-DB] New values are present" true (DB_Cached.mem db_t k); - Alcotest.(check bool) - "[Through-cache] New values are present" true - (DB_Cached.Cache.mem db_t k); + (* Alcotest.(check bool) *) + (* "[Through-DB] New values are present" true (DB_Cached.mem db_t k); *) + (* Alcotest.(check bool) *) + (* "[Through-cache] New values are present" true *) + (* (DB_Cached.Cache.mem db_t k); *) Alcotest.(check bool) "[Direct] New values are present after a remove" true (Cache.mem t k)) new_value From f73e06841a176ca224e9c7bee6118a67e0247b17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Pascutto?= Date: Fri, 27 May 2022 08:03:18 +0200 Subject: [PATCH 08/22] final bugfix --- cachecache.opam | 1 - src/chunk_lst.ml | 2 +- src/dllist.ml | 27 ++++---------- src/dllist.mli | 22 +++++++++--- src/dune | 1 - src/lfu.ml | 48 ++++++++++++------------- test/lfu.ml | 92 ++++++++++++++++++++++++------------------------ 7 files changed, 94 insertions(+), 99 deletions(-) diff --git a/cachecache.opam b/cachecache.opam index 9e4b65f..ad5687f 100644 --- a/cachecache.opam +++ b/cachecache.opam @@ -30,7 +30,6 @@ depends: [ "dune" {>= "2.0"} "ocaml" {>= "4.07.1"} "fmt" - "vector" "alcotest" {with-test} "gospel" {with-test} "fpath" {with-test} diff --git a/src/chunk_lst.ml b/src/chunk_lst.ml index dbfb783..5cca134 100644 --- a/src/chunk_lst.ml +++ b/src/chunk_lst.ml @@ -1 +1 @@ -type 'a t = { contents : 'a array; free : int } \ No newline at end of file +type 'a t = { contents : 'a array; free : int } diff --git a/src/dllist.ml b/src/dllist.ml index b135802..a88bb4d 100644 --- a/src/dllist.ml +++ b/src/dllist.ml @@ -16,13 +16,6 @@ type 'a l = { type 'a c = int -let status ppf l = - Fmt.pf ppf "first : %d@\n" l.first; - Fmt.pf ppf "last : %d@\n" l.last; - Fmt.(pf ppf "free : %a@\n" int) l.t.free; - Fmt.(pf ppf "prev : %a@\n" (array ~sep:sp int)) l.t.prev; - Fmt.(pf ppf "next : %a@\n@\n" (array ~sep:sp int)) l.t.next - let create cap witness = { cap; @@ -80,14 +73,13 @@ let append l v = l.t.next.(index) <- -1; removed in - assert (l.first <> -1); - (l.first, removed) + (l.last, removed) let promote l i = if i <> l.last then ( l.t.prev.(l.t.next.(i)) <- l.t.prev.(i); - if i <> l.first then l.t.next.(l.t.prev.(i)) <- l.t.next.(i) - else l.first <- l.t.next.(i); + if i = l.first then l.first <- l.t.next.(i) + else l.t.next.(l.t.prev.(i)) <- l.t.next.(i); l.t.next.(l.last) <- i; l.t.prev.(i) <- l.last; l.t.next.(i) <- -1; @@ -95,12 +87,10 @@ let promote l i = l.last let remove l i = - Fmt.epr "%a@." status l; - Fmt.epr "%d@." i; - if i <> l.first then l.t.next.(l.t.prev.(i)) <- l.t.next.(i) - else l.first <- l.t.next.(l.first); - if i <> l.last then l.t.prev.(l.t.next.(i)) <- l.t.prev.(i) - else l.last <- l.t.prev.(l.last); + if i = l.first then l.first <- l.t.next.(l.first) + else l.t.next.(l.t.prev.(i)) <- l.t.next.(i); + if i = l.last then l.last <- l.t.prev.(l.last) + else l.t.prev.(l.t.next.(i)) <- l.t.prev.(i); if l.t.free <> -1 then l.t.prev.(l.t.free) <- i; l.t.next.(i) <- l.t.free; l.t.prev.(i) <- -1; @@ -114,7 +104,6 @@ let is_empty l = l.size = 0 let append_before l i v = let new_index = l.t.free in - assert (new_index <> -1); l.t.free <- l.t.next.(l.t.free); if l.t.free <> -1 then l.t.prev.(l.t.free) <- -1; if l.first = i then l.first <- new_index @@ -124,7 +113,6 @@ let append_before l i v = l.t.prev.(i) <- new_index; l.t.contents.(new_index) <- v; l.size <- l.size + 1; - assert (l.first <> -1); new_index let append_after l i v = @@ -139,5 +127,4 @@ let append_after l i v = l.t.next.(i) <- new_index; l.t.contents.(new_index) <- v; l.size <- l.size + 1; - assert (l.first <> -1); new_index diff --git a/src/dllist.mli b/src/dllist.mli index 18d46e3..8c2f084 100644 --- a/src/dllist.mli +++ b/src/dllist.mli @@ -1,6 +1,21 @@ -type 'a t -type 'a l -type 'a c +type 'a t = private { + cap : int; + witness : 'a; + contents : 'a array; + mutable free : int; + prev : int array; + next : int array; +} +(*@ invariant cap > 0 *) + +type 'a l = private { + mutable first : int; + mutable last : int; + mutable size : int; + t : 'a t; +} + +type 'a c = int val create : int -> 'a -> 'a t val create_list : 'a t -> 'a l @@ -15,4 +30,3 @@ val append_before : 'a l -> 'a c -> 'a -> 'a c val append_after : 'a l -> 'a c -> 'a -> 'a c val next : 'a l -> 'a c -> 'a c val ends : 'a l -> 'a c * 'a c -val status : 'a l Fmt.t diff --git a/src/dune b/src/dune index 96d033b..b2c5a17 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,6 @@ (library (public_name cachecache) (name cachecache) - (flags :standard -w -21) (libraries fmt vector)) ; (rule diff --git a/src/lfu.ml b/src/lfu.ml index 958ca5b..9400a82 100644 --- a/src/lfu.ml +++ b/src/lfu.ml @@ -41,35 +41,32 @@ struct Stats.clear t.stats let update t k = - Fmt.pr "u@."; - Fmt.epr "FREQ @[%a@]@." Dllist.status t.frequency; let freq_index, key_index, _value = H.find t.value k in let freq, freq_list = Dllist.get t.frequency freq_index in let next = Dllist.next t.frequency freq_index in let freq_next, _freq_next_list = Dllist.get t.frequency next in let new_freq_index = - if freq + 1 <> freq_next then - let real_next_freq_list = Dllist.create_list t.lsts in - let real_freq = freq + 1 in - Dllist.append_after t.frequency freq_index - (real_freq, real_next_freq_list) - else next + if freq_next = freq + 1 then next + else + let new_next = Dllist.create_list t.lsts in + (* FIXME: t.frequency could be full at this point, and append_after would fail *) + Dllist.append_after t.frequency freq_index (freq + 1, new_next) in - Fmt.epr "HELLO0@."; - Fmt.epr "FREQ @[%a@]@." Dllist.status t.frequency; Dllist.remove freq_list key_index; - Fmt.epr "HELLO1@."; let _freq_next, freq_next_list = Dllist.get t.frequency new_freq_index in - if Dllist.is_empty freq_list then Dllist.remove t.frequency freq_index; + if Dllist.is_empty freq_list then + (* FIXME: this should happen before, to leave room for the new value if + t.frequency is full *) + Dllist.remove t.frequency freq_index; let new_key_index, _opt = Dllist.append freq_next_list k in + assert (_opt = None); (new_freq_index, new_key_index) let find t k = - Fmt.pr "-@."; let _freq_index, _key_index, v = H.find t.value k in Stats.hit t.stats; - let new_freq_index, new_last_index = update t k in - H.replace t.value k (new_freq_index, new_last_index, v); + let new_freq_index, new_key_index = update t k in + H.replace t.value k (new_freq_index, new_key_index, v); v let find_opt t k = @@ -79,7 +76,6 @@ struct None let mem t k = - Fmt.pr "m@."; try ignore (find t k); true @@ -88,30 +84,31 @@ struct false let add t k v = - Fmt.pr "a@."; - if H.length t.value = 0 then + if H.length t.value = 0 then ( let first_freq_list = Dllist.create_list t.lsts in let new_key_index, _opt = Dllist.append first_freq_list k in + assert (_opt = None); let first_key_index, _opt = Dllist.append t.frequency (1, first_freq_list) in - H.replace t.value k (first_key_index, new_key_index, v) + assert (_opt = None); + H.replace t.value k (first_key_index, new_key_index, v)) else let first_freq_index, _last_freq_index = Dllist.ends t.frequency in let freq, _key_list = Dllist.get t.frequency first_freq_index in let new_first_freq_index = - if freq <> 1 then + if freq = 1 then first_freq_index + else let real_first_freq_list = Dllist.create_list t.lsts in Dllist.append_before t.frequency first_freq_index (1, real_first_freq_list) - else first_freq_index in let _freq, freq_list = Dllist.get t.frequency new_first_freq_index in let new_index, _opt = Dllist.append freq_list k in + assert (_opt = None); H.replace t.value k (new_first_freq_index, new_index, v) let replace t k v = - Fmt.pr "R@."; try let _freq_index, _key_index, _value = H.find t.value k in let new_freq_index, new_key_index = update t k in @@ -120,8 +117,7 @@ struct with Not_found -> Stats.add (H.length t.value + 1) t.stats; if H.length t.value < t.cap then add t k v - else ( - Fmt.pr "d@."; + else let first_freq_index, _last_freq_index = Dllist.ends t.frequency in let _freq, freq_list = Dllist.get t.frequency first_freq_index in let first_index, _last_index = Dllist.ends freq_list in @@ -131,15 +127,15 @@ struct Dllist.remove t.frequency first_freq_index; H.remove t.value remove_key; Stats.discard t.stats; - add t k v) + add t k v let remove t k = - Fmt.pr "r@."; try let freq_index, key_index, _value = H.find t.value k in H.remove t.value k; let _freq, key_list = Dllist.get t.frequency freq_index in Dllist.remove key_list key_index; + if Dllist.is_empty key_list then Dllist.remove t.frequency freq_index; Stats.remove t.stats with Not_found -> () end diff --git a/test/lfu.ml b/test/lfu.ml index 53c4304..0c4c278 100644 --- a/test/lfu.ml +++ b/test/lfu.ml @@ -46,23 +46,23 @@ struct if i = 0 then l else let k = add_fresh_value db_t t in - if check then - (* Alcotest.(check bool) *) - (* "[Though-DB] Value just added is found (mem)" true *) - (* (DB_Cached.mem db_t k); *) - (* Alcotest.(check key) *) - (* "[Through-DB] Value just added is found (find)" k *) - (* (DB_Cached.find db_t k); *) - (* Alcotest.(check bool) *) - (* "[Through-cache] Value just added is found (mem)" true *) - (* (DB_Cached.Cache.mem db_t k); *) - (* Alcotest.(check key) *) - (* "[Through-cache] Value just added is found in cache (find)" k *) - (* (DB_Cached.Cache.find db_t k); *) - (* Alcotest.(check bool) *) - (* "[Direct] Value just added is found (mem)" true (Cache.mem t k); *) + if check then ( + Alcotest.(check bool) + "[Though-DB] Value just added is found (mem)" true + (DB_Cached.mem db_t k); Alcotest.(check key) - "[Direct] Value just added is found (find)" k (Cache.find t k); + "[Through-DB] Value just added is found (find)" k + (DB_Cached.find db_t k); + Alcotest.(check bool) + "[Through-cache] Value just added is found (mem)" true + (DB_Cached.Cache.mem db_t k); + Alcotest.(check key) + "[Through-cache] Value just added is found in cache (find)" k + (DB_Cached.Cache.find db_t k); + Alcotest.(check bool) + "[Direct] Value just added is found (mem)" true (Cache.mem t k); + Alcotest.(check key) + "[Direct] Value just added is found (find)" k (Cache.find t k)); loop (k :: l) (i - 1) in loop [] n @@ -88,19 +88,19 @@ struct | h :: tl -> List.iter (fun k -> - Alcotest.(check bool) - "[Direct] Added values are still present" true (Cache.mem t k)) + Alcotest.(check key) + "[Direct] Added values are still present" k (Cache.find t k)) tl; let k = K.v () in Cache.replace t k k; Alcotest.(check int) "[Direct] Size is still ten" 10 (Cache.size t); Alcotest.(check bool) "[Direct] Unused value are removed" false (Cache.mem t h); - (* Alcotest.(check bool) *) - (* "[Through-cache] Unused value are removed" true *) - (* (DB_Cached.Cache.mem db_t h); *) - (* Alcotest.(check bool) *) - (* "[Through-DB] Unused value are removed" true (DB_Cached.mem db_t h); *) + Alcotest.(check bool) + "[Through-cache] Unused value are removed" true + (DB_Cached.Cache.mem db_t h); + Alcotest.(check bool) + "[Through-DB] Unused value are removed" true (DB_Cached.mem db_t h); Alcotest.(check bool) "[Direct] Added value is still present" true (Cache.mem t k) | [] -> assert false @@ -119,22 +119,22 @@ struct removed; List.iter (fun k -> - (* Alcotest.(check bool) *) - (* "[Through-DB] Removed values are not present" false *) - (* (DB_Cached.mem db_t k); *) - (* Alcotest.(check bool) *) - (* "[Through-cache] Removed values are not present" false *) - (* (DB_Cached.Cache.mem db_t k); *) + Alcotest.(check bool) + "[Through-DB] Removed values are not present" false + (DB_Cached.mem db_t k); + Alcotest.(check bool) + "[Through-cache] Removed values are not present" false + (DB_Cached.Cache.mem db_t k); Alcotest.(check bool) "[Direct] Removed values are not present" false (Cache.mem t k)) removed; List.iter (fun k -> - (* Alcotest.(check bool) *) - (* "[Through-DB] Other values are present" true (DB_Cached.mem db_t k); *) - (* Alcotest.(check bool) *) - (* "[Through-cache] Other values are present" true *) - (* (DB_Cached.Cache.mem db_t k); *) + Alcotest.(check bool) + "[Through-DB] Other values are present" true (DB_Cached.mem db_t k); + Alcotest.(check bool) + "[Through-cache] Other values are present" true + (DB_Cached.Cache.mem db_t k); Alcotest.(check bool) "[Direct] Other values are present" true (Cache.mem t k)) kept; @@ -144,23 +144,23 @@ struct Cache.remove t k) kept; List.iter - (fun _k -> - (* Alcotest.(check bool) *) - (* "[Through-DB] Removed values are not present" false *) - (* (DB_Cached.mem db_t k); *) - (* Alcotest.(check bool) *) - (* "[Through-cache] Removed values are not present" false *) - (* (DB_Cached.Cache.mem db_t k); *) + (fun k -> + Alcotest.(check bool) + "[Through-DB] Removed values are not present" false + (DB_Cached.mem db_t k); + Alcotest.(check bool) + "[Through-cache] Removed values are not present" false + (DB_Cached.Cache.mem db_t k); Alcotest.(check bool) "[Direct] Cache is empty" true (Cache.is_empty t)) kept; let new_value = add_fresh_values ~check:false db_t t (cap / 2) in List.iter (fun k -> - (* Alcotest.(check bool) *) - (* "[Through-DB] New values are present" true (DB_Cached.mem db_t k); *) - (* Alcotest.(check bool) *) - (* "[Through-cache] New values are present" true *) - (* (DB_Cached.Cache.mem db_t k); *) + Alcotest.(check bool) + "[Through-DB] New values are present" true (DB_Cached.mem db_t k); + Alcotest.(check bool) + "[Through-cache] New values are present" true + (DB_Cached.Cache.mem db_t k); Alcotest.(check bool) "[Direct] New values are present after a remove" true (Cache.mem t k)) new_value From bed3a5eee4fe93322d92063b5ffa97ee063d4834 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Fri, 27 May 2022 16:13:50 +0200 Subject: [PATCH 09/22] bug fixed --- src/dllist.ml | 9 +++++++++ src/dllist.mli | 2 ++ src/lfu.ml | 45 ++++++++++++++++++++++++++++++++++----------- 3 files changed, 45 insertions(+), 11 deletions(-) diff --git a/src/dllist.ml b/src/dllist.ml index a88bb4d..5d74ca5 100644 --- a/src/dllist.ml +++ b/src/dllist.ml @@ -16,6 +16,15 @@ type 'a l = { type 'a c = int +let status ppf l = + Fmt.pf ppf "first : %d@\n" l.first; + Fmt.pf ppf "last : %d@\n" l.last; + Fmt.(pf ppf "free : %a@\n" int) l.t.free; + Fmt.(pf ppf "prev : %a@\n" (array ~sep:sp int)) l.t.prev; + Fmt.(pf ppf "next : %a@\n@\n" (array ~sep:sp int)) l.t.next + +let is_full l = l.t.free == -1 + let create cap witness = { cap; diff --git a/src/dllist.mli b/src/dllist.mli index 8c2f084..b3673cc 100644 --- a/src/dllist.mli +++ b/src/dllist.mli @@ -30,3 +30,5 @@ val append_before : 'a l -> 'a c -> 'a -> 'a c val append_after : 'a l -> 'a c -> 'a -> 'a c val next : 'a l -> 'a c -> 'a c val ends : 'a l -> 'a c * 'a c +val status : Format.formatter -> 'a l -> unit +val is_full : 'a l -> bool \ No newline at end of file diff --git a/src/lfu.ml b/src/lfu.ml index 9400a82..c7901b4 100644 --- a/src/lfu.ml +++ b/src/lfu.ml @@ -45,19 +45,31 @@ struct let freq, freq_list = Dllist.get t.frequency freq_index in let next = Dllist.next t.frequency freq_index in let freq_next, _freq_next_list = Dllist.get t.frequency next in + + Dllist.remove freq_list key_index; let new_freq_index = - if freq_next = freq + 1 then next + if freq_next = freq + 1 then ( + if Dllist.is_empty freq_list then Dllist.remove t.frequency freq_index; + next) else let new_next = Dllist.create_list t.lsts in - (* FIXME: t.frequency could be full at this point, and append_after would fail *) - Dllist.append_after t.frequency freq_index (freq + 1, new_next) + if not (Dllist.is_full t.frequency) then ( + let r = + Dllist.append_after t.frequency freq_index (freq + 1, new_next) + in + if Dllist.is_empty freq_list then Dllist.remove t.frequency freq_index; + r) + else ( + Dllist.remove t.frequency freq_index; + let res = + if next = -1 then + let r, _opt = Dllist.append t.frequency (freq + 1, new_next) in + r + else Dllist.append_before t.frequency next (freq + 1, new_next) + in + res) in - Dllist.remove freq_list key_index; let _freq_next, freq_next_list = Dllist.get t.frequency new_freq_index in - if Dllist.is_empty freq_list then - (* FIXME: this should happen before, to leave room for the new value if - t.frequency is full *) - Dllist.remove t.frequency freq_index; let new_key_index, _opt = Dllist.append freq_next_list k in assert (_opt = None); (new_freq_index, new_key_index) @@ -113,21 +125,32 @@ struct let _freq_index, _key_index, _value = H.find t.value k in let new_freq_index, new_key_index = update t k in Stats.replace t.stats; + Fmt.pr "R"; H.replace t.value k (new_freq_index, new_key_index, v) with Not_found -> Stats.add (H.length t.value + 1) t.stats; - if H.length t.value < t.cap then add t k v - else + if H.length t.value < t.cap then ( + Fmt.pr "a"; + add t k v) + else ( + Fmt.pr "d"; let first_freq_index, _last_freq_index = Dllist.ends t.frequency in let _freq, freq_list = Dllist.get t.frequency first_freq_index in + assert (not (Dllist.is_empty freq_list)); let first_index, _last_index = Dllist.ends freq_list in + + Fmt.epr "avFREQ @[%a@]@." Dllist.status t.frequency; + Fmt.epr "avFREQ @[%a@]@." Dllist.status freq_list; + Fmt.pr "first index = %d\n" first_freq_index; + let remove_key = Dllist.get freq_list first_index in + Fmt.epr "apFREQ @[%a@]@." Dllist.status t.frequency; Dllist.remove freq_list first_index; if Dllist.is_empty freq_list then Dllist.remove t.frequency first_freq_index; H.remove t.value remove_key; Stats.discard t.stats; - add t k v + add t k v) let remove t k = try From e30ba01c6d6a5093d669aaff7a9f9c9c1afd4f29 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Fri, 27 May 2022 16:20:41 +0200 Subject: [PATCH 10/22] bug fixed --- src/dllist.mli | 2 +- src/dune | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/dllist.mli b/src/dllist.mli index b3673cc..a7a19be 100644 --- a/src/dllist.mli +++ b/src/dllist.mli @@ -31,4 +31,4 @@ val append_after : 'a l -> 'a c -> 'a -> 'a c val next : 'a l -> 'a c -> 'a c val ends : 'a l -> 'a c * 'a c val status : Format.formatter -> 'a l -> unit -val is_full : 'a l -> bool \ No newline at end of file +val is_full : 'a l -> bool diff --git a/src/dune b/src/dune index b2c5a17..89c7dac 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,7 @@ (library (public_name cachecache) (name cachecache) - (libraries fmt vector)) + (libraries fmt)) ; (rule ; (alias runtest) From e36e6d3899520e9a78e3ace3e32a3b0f6dd23e05 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Fri, 27 May 2022 17:01:11 +0200 Subject: [PATCH 11/22] first commit --- bench/lru_trace_definition.ml | 29 ++++ bench/replay.ml | 31 ++++ bench/trace_auto_file_format.ml | 213 +++++++++++++++++++++++++++ bench/trace_auto_file_format_intf.ml | 113 ++++++++++++++ 4 files changed, 386 insertions(+) create mode 100644 bench/lru_trace_definition.ml create mode 100644 bench/replay.ml create mode 100644 bench/trace_auto_file_format.ml create mode 100644 bench/trace_auto_file_format_intf.ml diff --git a/bench/lru_trace_definition.ml b/bench/lru_trace_definition.ml new file mode 100644 index 0000000..c82153b --- /dev/null +++ b/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) diff --git a/bench/replay.ml b/bench/replay.ml new file mode 100644 index 0000000..47e3365 --- /dev/null +++ b/bench/replay.ml @@ -0,0 +1,31 @@ +module K = struct + include String + + let hash = Hashtbl.hash +end + +module Lru = + Lru.M.Make + (K) + (struct + type t = unit + + let weight _ = 1 + end) + +let () = + let open Lru_trace_definition in + let _, { instance_count }, seq = + open_reader "/home/cha//Downloads/lru.trace" + in + ignore instance_count; + let lru = Lru.v 5000 in + (*instane lru*) + Seq.iter + (fun { instance_id; op } -> + match (instance_id, op) with + | 1, Add k -> Lru.replace lru k () + | 1, Find k -> ignore (Lru.find_opt lru k) + | 1, Mem k -> ignore (Lru.mem lru k) + | _ -> ()) + seq diff --git a/bench/trace_auto_file_format.ml b/bench/trace_auto_file_format.ml new file mode 100644 index 0000000..5db1cd8 --- /dev/null +++ b/bench/trace_auto_file_format.ml @@ -0,0 +1,213 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-2022 Tarides *) +(* *) +(* 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 diff --git a/bench/trace_auto_file_format_intf.ml b/bench/trace_auto_file_format_intf.ml new file mode 100644 index 0000000..78bc0af --- /dev/null +++ b/bench/trace_auto_file_format_intf.ml @@ -0,0 +1,113 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-2022 Tarides *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Utility to simplify the management of files using the following layout: + + - Magic (Magic.t, 8 bytes) + - Version (int32, 4 bytes) + - Length of header (varint, >=1 byte) + - Header (header_t, _ bytes) + - Arbitrary long series of rows, of unspecified length, each prefixed by + their length: + - Length of row (varint, >=1 byte) + - Row (row_t, _ bytes) *) + +module type MAGIC = sig + type t + + val of_string : string -> t + val to_string : t -> string + val pp : Format.formatter -> t -> unit +end + +(** Manually defined *) +module type FILE_FORMAT = sig + (** The latest up-to-date definition of the file format *) + module Latest : sig + val version : int + + type header [@@deriving repr] + type row [@@deriving repr] + end + + type magic + + val magic : magic + + type ('a, 'b) version_converter + + val get_version_converter : + int -> (Latest.header, Latest.row) version_converter + (** [get_version_converter v] is a converter that can upgrade headers and rows + from a version [i] to [Latest.version]. It may raise [Invalid_argument] if *) +end + +(** Automatically defined *) +module type S = sig + module File_format : FILE_FORMAT + + val open_reader : + string -> int * File_format.Latest.header * File_format.Latest.row Seq.t + + type writer + + val create : out_channel -> File_format.Latest.header -> writer + val create_file : string -> File_format.Latest.header -> writer + val append_row : writer -> File_format.Latest.row -> unit + val flush : writer -> unit + val close : writer -> unit +end + +module type Trace_auto_file_format = sig + type ('a, 'b) version_converter + + val 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 + (** Create a value that contains everything needed to upgrade on-the-fly a + file version to the latest version defined by the file format. *) + + module type MAGIC = MAGIC + + module Magic : MAGIC + + 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 + + (** Derive the IO operations from a file format. *) + module Make (File_format : FILE_FORMAT) : + S with module File_format = File_format +end From 5ec36dae9742ddb46a76a04c59b78d874573511b Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Fri, 27 May 2022 17:25:00 +0200 Subject: [PATCH 12/22] add pp to bench --- bench/dune | 12 ++++++++++++ bench/replay.ml | 28 ++++++++++++++++------------ 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/bench/dune b/bench/dune index 13fd944..63e670d 100644 --- a/bench/dune +++ b/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)) + (alias (name runtest) (package cachecache-bench) diff --git a/bench/replay.ml b/bench/replay.ml index 47e3365..c47ab90 100644 --- a/bench/replay.ml +++ b/bench/replay.ml @@ -1,19 +1,16 @@ +type stats = { mutable add : int; mutable mem : int; mutable find : int } +[@@deriving repr ~pp] + module K = struct include String let hash = Hashtbl.hash end -module Lru = - Lru.M.Make - (K) - (struct - type t = unit - - let weight _ = 1 - end) +module Lru = Cachecache.Lru.Make (K) let () = + let stats = { add = 0; mem = 0; find = 0 } in let open Lru_trace_definition in let _, { instance_count }, seq = open_reader "/home/cha//Downloads/lru.trace" @@ -24,8 +21,15 @@ let () = Seq.iter (fun { instance_id; op } -> match (instance_id, op) with - | 1, Add k -> Lru.replace lru k () - | 1, Find k -> ignore (Lru.find_opt lru k) - | 1, Mem k -> ignore (Lru.mem lru k) + | 1, Add k -> + Lru.replace lru k (); + stats.add <- stats.add + 1 + | 1, Find k -> + ignore (Lru.find_opt lru k); + stats.find <- stats.find + 1 + | 1, Mem k -> + ignore (Lru.mem lru k); + stats.mem <- stats.mem + 1 | _ -> ()) - seq + seq; + Fmt.pr "%a\n" pp_stats stats From 90f649188b7b94e4fd72bc87fbc32a68f29cc3bd Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Fri, 27 May 2022 17:35:58 +0200 Subject: [PATCH 13/22] match bench on differents instances id --- bench/replay.ml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/bench/replay.ml b/bench/replay.ml index c47ab90..9f7a292 100644 --- a/bench/replay.ml +++ b/bench/replay.ml @@ -15,20 +15,19 @@ let () = let _, { instance_count }, seq = open_reader "/home/cha//Downloads/lru.trace" in - ignore instance_count; - let lru = Lru.v 5000 in - (*instane lru*) + let lrus = List.init instance_count (fun _ -> Lru.v 5000) in Seq.iter (fun { instance_id; op } -> - match (instance_id, op) with - | 1, Add k -> + let lru = List.nth lrus instance_id in + match op with + | Add k -> Lru.replace lru k (); stats.add <- stats.add + 1 - | 1, Find k -> - ignore (Lru.find_opt lru k); + | Find k -> + ignore (Lru.find_opt lru k : _ option); stats.find <- stats.find + 1 - | 1, Mem k -> - ignore (Lru.mem lru k); + | Mem k -> + ignore (Lru.mem lru k : bool); stats.mem <- stats.mem + 1 | _ -> ()) seq; From 90fc0fe2527f6201caafbe8e9acf82a887afaefe Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Fri, 27 May 2022 18:01:06 +0200 Subject: [PATCH 14/22] add mtime lib and counters --- bench/dune | 2 +- bench/replay.ml | 37 +++++++++++++++++++++++++++++++++++-- 2 files changed, 36 insertions(+), 3 deletions(-) diff --git a/bench/dune b/bench/dune index 63e670d..641d69a 100644 --- a/bench/dune +++ b/bench/dune @@ -12,7 +12,7 @@ (preprocess (pps ppx_repr)) (name replay) - (libraries cachecache fmt ppx_repr repr)) + (libraries cachecache fmt ppx_repr repr mtime mtime.clock.os)) (alias (name runtest) diff --git a/bench/replay.ml b/bench/replay.ml index 9f7a292..c3fcefc 100644 --- a/bench/replay.ml +++ b/bench/replay.ml @@ -1,4 +1,15 @@ -type stats = { mutable add : int; mutable mem : int; mutable find : int } +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 add_span : span; + mutable mem_span : span; + mutable find_span : span; +} [@@deriving repr ~pp] module K = struct @@ -10,7 +21,17 @@ end module Lru = Cachecache.Lru.Make (K) let () = - let stats = { add = 0; mem = 0; find = 0 } in + let stats = + { + add = 0; + mem = 0; + find = 0; + add_span = Mtime.Span.zero; + mem_span = Mtime.Span.zero; + find_span = Mtime.Span.zero; + } + in + let counter = Mtime_clock.counter () in let open Lru_trace_definition in let _, { instance_count }, seq = open_reader "/home/cha//Downloads/lru.trace" @@ -21,13 +42,25 @@ let () = let lru = List.nth lrus instance_id in match op with | Add k -> + let before = Mtime_clock.count counter in Lru.replace lru k (); + let after = Mtime_clock.count counter in + 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 (Lru.find_opt lru k : _ option); + let after = Mtime_clock.count counter in + 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 ignore (Lru.mem lru k : bool); + let after = Mtime_clock.count counter in + stats.mem_span <- + Mtime.Span.(abs_diff after before |> add stats.mem_span); stats.mem <- stats.mem + 1 | _ -> ()) seq; From 1eb7957a89c60588dacc4a5563408e5810805db2 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Fri, 27 May 2022 18:18:18 +0200 Subject: [PATCH 15/22] functorize replay --- bench/replay.ml | 98 +++++++++++++++++++++++++---------------------- src/cachecache.ml | 1 + src/lfu.ml | 15 ++------ 3 files changed, 57 insertions(+), 57 deletions(-) diff --git a/bench/replay.ml b/bench/replay.ml index c3fcefc..869657d 100644 --- a/bench/replay.ml +++ b/bench/replay.ml @@ -18,50 +18,58 @@ module K = struct let hash = Hashtbl.hash end +module Make (Cache : Cachecache.S.Cache with type key = K.t) = struct + let bench cap = + let stats = + { + add = 0; + mem = 0; + find = 0; + add_span = Mtime.Span.zero; + mem_span = Mtime.Span.zero; + find_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.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.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 + ignore (Cache.mem cache k : bool); + let after = Mtime_clock.count counter in + stats.mem_span <- + Mtime.Span.(abs_diff after before |> add stats.mem_span); + stats.mem <- stats.mem + 1 + | _ -> assert false) + seq; + Fmt.pr "%a\n" pp_stats stats +end + module Lru = Cachecache.Lru.Make (K) +module Lfu = Cachecache.Lfu.Make (K) +module Bench_lru = Make (Lru) +module Bench_lfu = Make (Lfu) -let () = - let stats = - { - add = 0; - mem = 0; - find = 0; - add_span = Mtime.Span.zero; - mem_span = Mtime.Span.zero; - find_span = Mtime.Span.zero; - } - in - let counter = Mtime_clock.counter () in - let open Lru_trace_definition in - let _, { instance_count }, seq = - open_reader "/home/cha//Downloads/lru.trace" - in - let lrus = List.init instance_count (fun _ -> Lru.v 5000) in - Seq.iter - (fun { instance_id; op } -> - let lru = List.nth lrus instance_id in - match op with - | Add k -> - let before = Mtime_clock.count counter in - Lru.replace lru k (); - let after = Mtime_clock.count counter in - 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 (Lru.find_opt lru k : _ option); - let after = Mtime_clock.count counter in - 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 - ignore (Lru.mem lru k : bool); - let after = Mtime_clock.count counter in - stats.mem_span <- - Mtime.Span.(abs_diff after before |> add stats.mem_span); - stats.mem <- stats.mem + 1 - | _ -> ()) - seq; - Fmt.pr "%a\n" pp_stats stats +let () = Bench_lru.bench 5000 +let () = Bench_lfu.bench 5000 diff --git a/src/cachecache.ml b/src/cachecache.ml index 22eb78a..bd74d20 100644 --- a/src/cachecache.ml +++ b/src/cachecache.ml @@ -1,3 +1,4 @@ module Lru = Lru module Lfu = Lfu +module S = S module Through = Through diff --git a/src/lfu.ml b/src/lfu.ml index c7901b4..23357fb 100644 --- a/src/lfu.ml +++ b/src/lfu.ml @@ -125,32 +125,23 @@ struct let _freq_index, _key_index, _value = H.find t.value k in let new_freq_index, new_key_index = update t k in Stats.replace t.stats; - Fmt.pr "R"; H.replace t.value k (new_freq_index, new_key_index, v) with Not_found -> Stats.add (H.length t.value + 1) t.stats; - if H.length t.value < t.cap then ( - Fmt.pr "a"; - add t k v) - else ( - Fmt.pr "d"; + if H.length t.value < t.cap then add t k v + else let first_freq_index, _last_freq_index = Dllist.ends t.frequency in let _freq, freq_list = Dllist.get t.frequency first_freq_index in assert (not (Dllist.is_empty freq_list)); let first_index, _last_index = Dllist.ends freq_list in - Fmt.epr "avFREQ @[%a@]@." Dllist.status t.frequency; - Fmt.epr "avFREQ @[%a@]@." Dllist.status freq_list; - Fmt.pr "first index = %d\n" first_freq_index; - let remove_key = Dllist.get freq_list first_index in - Fmt.epr "apFREQ @[%a@]@." Dllist.status t.frequency; Dllist.remove freq_list first_index; if Dllist.is_empty freq_list then Dllist.remove t.frequency first_freq_index; H.remove t.value remove_key; Stats.discard t.stats; - add t k v) + add t k v let remove t k = try From 2fd859878ab6eead6a76530ca6304d76bb8ed25a Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Fri, 27 May 2022 18:42:54 +0200 Subject: [PATCH 16/22] cli for replay --- bench/dune | 2 +- bench/replay.ml | 19 +++++++++++++++++-- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/bench/dune b/bench/dune index 641d69a..5689a84 100644 --- a/bench/dune +++ b/bench/dune @@ -12,7 +12,7 @@ (preprocess (pps ppx_repr)) (name replay) - (libraries cachecache fmt ppx_repr repr mtime mtime.clock.os)) + (libraries cachecache fmt ppx_repr repr mtime mtime.clock.os cmdliner)) (alias (name runtest) diff --git a/bench/replay.ml b/bench/replay.ml index 869657d..51b24e8 100644 --- a/bench/replay.ml +++ b/bench/replay.ml @@ -71,5 +71,20 @@ module Lfu = Cachecache.Lfu.Make (K) module Bench_lru = Make (Lru) module Bench_lfu = Make (Lfu) -let () = Bench_lru.bench 5000 -let () = Bench_lfu.bench 5000 +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) From cd43db5aae2ca202c320b765c7609e0f32621127 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Tue, 31 May 2022 11:54:29 +0200 Subject: [PATCH 17/22] update bench --- bench/replay.ml | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/bench/replay.ml b/bench/replay.ml index 51b24e8..e1f7bf6 100644 --- a/bench/replay.ml +++ b/bench/replay.ml @@ -6,9 +6,13 @@ 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] @@ -18,6 +22,11 @@ module K = struct 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 = @@ -25,9 +34,13 @@ module Make (Cache : Cachecache.S.Cache with type key = K.t) = struct 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 @@ -44,6 +57,8 @@ module Make (Cache : Cachecache.S.Cache with type key = K.t) = struct 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 @@ -51,19 +66,32 @@ module Make (Cache : Cachecache.S.Cache with type key = K.t) = struct 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 - ignore (Cache.mem cache k : bool); + 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 + (* 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 module Lru = Cachecache.Lru.Make (K) From dda6030667808c1f1035eb64ed305e31adac00db Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Tue, 31 May 2022 14:11:22 +0200 Subject: [PATCH 18/22] add makefile --- bench/Makefile | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 bench/Makefile diff --git a/bench/Makefile b/bench/Makefile new file mode 100644 index 0000000..8c69309 --- /dev/null +++ b/bench/Makefile @@ -0,0 +1,3 @@ +.PHONY: bench +bench: + time dune exec ./bench/replay.exe lru 5001 \ No newline at end of file From 1804d5cbe1b854136664d95c8d782ceb9380cc87 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Tue, 31 May 2022 14:14:21 +0200 Subject: [PATCH 19/22] add makefile --- Makefile | 3 +++ bench/Makefile | 3 --- 2 files changed, 3 insertions(+), 3 deletions(-) create mode 100644 Makefile delete mode 100644 bench/Makefile diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..7b34ad4 --- /dev/null +++ b/Makefile @@ -0,0 +1,3 @@ +.PHONY: bench +bench: + dune exec bench/replay.exe lru 5001 \ No newline at end of file diff --git a/bench/Makefile b/bench/Makefile deleted file mode 100644 index 8c69309..0000000 --- a/bench/Makefile +++ /dev/null @@ -1,3 +0,0 @@ -.PHONY: bench -bench: - time dune exec ./bench/replay.exe lru 5001 \ No newline at end of file From 9ce2a24816dcbc452003d35736a4596049ea171b Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Tue, 31 May 2022 14:22:18 +0200 Subject: [PATCH 20/22] add libraries in opam file --- cachecache-bench.opam | 2 ++ cachecache.opam | 2 ++ 2 files changed, 4 insertions(+) diff --git a/cachecache-bench.opam b/cachecache-bench.opam index b1791a7..ace9bfb 100644 --- a/cachecache-bench.opam +++ b/cachecache-bench.opam @@ -10,6 +10,8 @@ bug-reports: "https://github.com/pascutto/cachecache/issues" depends: [ "dune" {>= "2.0"} "ocaml" {>= "4.07.1"} + "ppx_repr" + "mtime.clock.os" "bechamel" {with-test} "bechamel-notty" {with-test} "notty" {with-test} diff --git a/cachecache.opam b/cachecache.opam index ad5687f..3cd02d3 100644 --- a/cachecache.opam +++ b/cachecache.opam @@ -30,6 +30,8 @@ depends: [ "dune" {>= "2.0"} "ocaml" {>= "4.07.1"} "fmt" + "ppx_repr" + "mtime.clock.os" "alcotest" {with-test} "gospel" {with-test} "fpath" {with-test} From 51e661e194a5d2d1722eaf84be96d0caab5579ff Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Tue, 31 May 2022 14:40:30 +0200 Subject: [PATCH 21/22] remove cache arg to dune command --- Makefile | 2 +- bench/replay.ml | 12 +++--------- 2 files changed, 4 insertions(+), 10 deletions(-) diff --git a/Makefile b/Makefile index 7b34ad4..21ced90 100644 --- a/Makefile +++ b/Makefile @@ -1,3 +1,3 @@ .PHONY: bench bench: - dune exec bench/replay.exe lru 5001 \ No newline at end of file + dune exec bench/replay.exe 5001 \ No newline at end of file diff --git a/bench/replay.ml b/bench/replay.ml index e1f7bf6..9660a7f 100644 --- a/bench/replay.ml +++ b/bench/replay.ml @@ -99,20 +99,14 @@ 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 +let main cap = Bench_lru.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) + Arg.(required @@ pos 0 (some int) None i) -let main_t = Term.(const main $ algo $ cap) +let main_t = Term.(const main $ cap) let cmd = Cmd.v (Cmd.info "replay") main_t let () = exit (Cmd.eval cmd) From a657dd112130d436eaeebdaf47128e1a39e7cf67 Mon Sep 17 00:00:00 2001 From: Lucccyo Date: Tue, 31 May 2022 14:56:16 +0200 Subject: [PATCH 22/22] change branch name --- Makefile | 2 +- bench/replay.ml | 17 +++++++++++------ cachecache-bench.opam | 2 +- 3 files changed, 13 insertions(+), 8 deletions(-) diff --git a/Makefile b/Makefile index 21ced90..7b34ad4 100644 --- a/Makefile +++ b/Makefile @@ -1,3 +1,3 @@ .PHONY: bench bench: - dune exec bench/replay.exe 5001 \ No newline at end of file + dune exec bench/replay.exe lru 5001 \ No newline at end of file diff --git a/bench/replay.ml b/bench/replay.ml index 9660a7f..d3e63d7 100644 --- a/bench/replay.ml +++ b/bench/replay.ml @@ -86,27 +86,32 @@ module Make (Cache : Cachecache.S.Cache with type key = K.t) = struct 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 cap = Bench_lru.bench cap +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 0 (some int) None i) + Arg.(required @@ pos 1 (some int) None i) -let main_t = Term.(const main $ cap) +let main_t = Term.(const main $ algo $ cap) let cmd = Cmd.v (Cmd.info "replay") main_t -let () = exit (Cmd.eval cmd) +let () = exit (Cmd.eval cmd) \ No newline at end of file diff --git a/cachecache-bench.opam b/cachecache-bench.opam index ace9bfb..b47c563 100644 --- a/cachecache-bench.opam +++ b/cachecache-bench.opam @@ -15,7 +15,7 @@ depends: [ "bechamel" {with-test} "bechamel-notty" {with-test} "notty" {with-test} - "lru" {with-test} + "lru" ] build: [ ["dune" "subst"] {pinned}