2863

Committed 05 Nov 2024 06:20PM UTC coverage: 30.754% (-16.6%) from 47.311%

Build # 2863

Build Type

push

buildkite

Committed by

web-flow

Commit Message

Merge pull request #16296 from MinaProtocol/dkijania/more_multi_jobs

more multi jobs in CI

Run Details

20276 of 65930 relevant lines covered (30.75%)

8631.7 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

1.28

/src/lib/transition_handler/core_extended_cache.ml

open Core

(*  *)

module type Strategy = sig
  type 'a t

  type 'a with_init_args

  val cps_create : f:(_ t -> 'b) -> 'b with_init_args

  val touch : 'a t -> 'a -> 'a list

  val remove : 'a t -> 'a -> unit

  val clear : 'a t -> unit
end

module Memoized = struct
  type 'a t = ('a, exn) Result.t

  let return : 'a t -> 'a = function
    | Result.Ok x ->
        x
    | Result.Error e ->
        raise e

  let create ~f arg =
    try Result.Ok (f arg) with Sys.Break as e -> raise e | e -> Result.Error e
end

module type Store = sig
  type ('k, 'v) t

  type 'a with_init_args

  val cps_create : f:((_, _) t -> 'b) -> 'b with_init_args

  val clear : (_, _) t -> unit

  val set : ('k, 'v) t -> key:'k -> data:'v -> unit

  val find : ('k, 'v) t -> 'k -> 'v option

  val data : (_, 'v) t -> 'v list

  val remove : ('k, _) t -> 'k -> unit
end

module type S = sig
  type ('a, 'b) t

  type 'a with_init_args

  type ('a, 'b) memo = ('a, ('b, exn) Result.t) t

  val find : ('k, 'v) t -> 'k -> 'v option

  val add : ('k, 'v) t -> key:'k -> data:'v -> unit

  val remove : ('k, _) t -> 'k -> unit

  val clear : (_, _) t -> unit

  val create : destruct:('v -> unit) option -> ('k, 'v) t with_init_args

  val call_with_cache : cache:('a, 'b) memo -> ('a -> 'b) -> 'a -> 'b

  val memoize :
       ?destruct:('b -> unit)
    -> ('a -> 'b)
    -> (('a, 'b) memo * ('a -> 'b)) with_init_args
end

module Make (Strat : Strategy) (Store : Store) :
  S with type 'a with_init_args = 'a Store.with_init_args Strat.with_init_args =
struct
  type 'a with_init_args = 'a Store.with_init_args Strat.with_init_args

  type ('k, 'v) t =
    { destruct : ('v -> unit) option
          (** Function to be called on removal of values from the store *)
    ; strat : 'k Strat.t
    ; store : ('k, 'v) Store.t  (** The actual key value store*)
    }

  type ('a, 'b) memo = ('a, ('b, exn) Result.t) t

  let clear_from_store cache key =
    match Store.find cache.store key with
    | None ->
        failwith
          "Cache.Make: strategy wants to remove a key which isn't in the store"
    | Some v ->
        Option.call ~f:cache.destruct v ;
        Store.remove cache.store key

  let touch_key cache key =
    List.iter (Strat.touch cache.strat key) ~f:(fun k ->
        clear_from_store cache k )

  let find cache k =
    let res = Store.find cache.store k in
    if Option.is_some res then touch_key cache k ;
    res

  let add cache ~key ~data =
    touch_key cache key ;
    Store.set cache.store ~key ~data

  let remove cache key =
    Option.iter (Store.find cache.store key) ~f:(fun v ->
        Strat.remove cache.strat key ;
        Option.call ~f:cache.destruct v ;
        Store.remove cache.store key )

  let clear cache =
    Option.iter cache.destruct ~f:(fun destruct ->
        List.iter (Store.data cache.store) ~f:destruct ) ;
    Strat.clear cache.strat ;
    Store.clear cache.store

  let create ~destruct =
    Strat.cps_create ~f:(fun strat ->
        Store.cps_create ~f:(fun store -> { strat; destruct; store }) )

  let call_with_cache ~cache f arg =
    match find cache arg with
    | Some v ->
        Memoized.return v
    | None ->
        touch_key cache arg ;
        let rval = Memoized.create ~f arg in
        Store.set cache.store ~key:arg ~data:rval ;
        Memoized.return rval

  let memoize ?destruct f =
    Strat.cps_create ~f:(fun strat ->
        Store.cps_create ~f:(fun store ->
            let destruct = Option.map destruct ~f:(fun f -> Result.iter ~f) in
            let cache = { strat; destruct; store } in
            let memd_f arg = call_with_cache ~cache f arg in
            (cache, memd_f) ) )
end

module Strategy = struct
  module Lru = struct
    type 'a t =
      { (* sorted in order of descending recency *)
        list : 'a Doubly_linked.t
      ; (* allows fast lookup in the list above *)
        table : ('a, 'a Doubly_linked.Elt.t) Hashtbl.t
      ; mutable maxsize : int
      ; mutable size : int
      }

    type 'a with_init_args = int -> 'a

    let kill_extra lru =
      let extra = ref [] in
      while lru.size > lru.maxsize do
        let key = Option.value_exn (Doubly_linked.remove_last lru.list) in
        Hashtbl.remove lru.table key ;
        (* remove from table *)
        lru.size <- lru.size - 1 ;
        (* reduce size by 1 *)
        extra := key :: !extra
      done ;
      !extra

    let touch lru x =
      let el = Doubly_linked.insert_first lru.list x in
      match Hashtbl.find lru.table x with
      | Some old_el ->
          Doubly_linked.remove lru.list old_el ;
          Hashtbl.set lru.table ~key:x ~data:el ;
          []
      | None ->
          Hashtbl.set lru.table ~key:x ~data:el ;
          lru.size <- lru.size + 1 ;
          kill_extra lru

    let remove lru x =
      Option.iter (Hashtbl.find lru.table x) ~f:(fun el ->
          Doubly_linked.remove lru.list el ;
          Hashtbl.remove lru.table x )

    let create maxsize =
      { list = Doubly_linked.create ()
      ; table = Hashtbl.Poly.create () ~size:100
      ; maxsize
      ; size = 0
      }

    let cps_create ~f maxsize = f (create maxsize)

    let clear lru =
      lru.size <- 0 ;
      Hashtbl.clear lru.table ;
      Doubly_linked.clear lru.list
  end

  module Keep_all = struct
    type 'a t = unit

    type 'a with_init_args = 'a

    let cps_create ~f = f ()

    let touch () _ = []

    let remove () _ = ()

    let clear () = ()
  end
end

module Store = struct
  module Table = struct
    include Hashtbl

    type 'a with_init_args = 'a

    let cps_create ~f = f (Hashtbl.Poly.create () ~size:16)
  end
end

module Keep_all = Make (Strategy.Keep_all) (Store.Table)
module Lru = Make (Strategy.Lru) (Store.Table)

let keep_one ?(destruct = ignore) f =
  let v = ref None in
  () ;
  fun x ->
    match !v with
    | Some (x', y) when Poly.( = ) x' x ->
        Memoized.return y
    | _ ->
        Option.iter !v ~f:(fun (_, y) -> Result.iter ~f:destruct y) ;
        v := None ;
        let res = Memoized.create ~f x in
        v := Some (x, res) ;
        Memoized.return res

let memoize ?destruct ?(expire = `Keep_all) f =
  match expire with
  | `Lru size ->
      snd (Lru.memoize ?destruct f size)
  | `Keep_all ->
      snd (Keep_all.memoize ?destruct f)
  | `Keep_one ->
      keep_one ?destruct f

let unit f =
  let l = Lazy.from_fun f in
  fun () -> Lazy.force l

1	open Core	1✔
2
3	(* *)
4
5	module type Strategy = sig
6	type 'a t
7
8	type 'a with_init_args
9
10	val cps_create : f:(_ t -> 'b) -> 'b with_init_args
11
12	val touch : 'a t -> 'a -> 'a list
13
14	val remove : 'a t -> 'a -> unit
15
16	val clear : 'a t -> unit
17	end
18
19	module Memoized = struct
20	type 'a t = ('a, exn) Result.t
21
22	let return : 'a t -> 'a = function
23	\| Result.Ok x ->	×
24	x
25	\| Result.Error e ->	×
26	raise e
27
28	let create ~f arg =
29	try Result.Ok (f arg) with Sys.Break as e -> raise e \| e -> Result.Error e	×
30	end
31
32	module type Store = sig
33	type ('k, 'v) t
34
35	type 'a with_init_args
36
37	val cps_create : f:((_, _) t -> 'b) -> 'b with_init_args
38
39	val clear : (_, _) t -> unit
40
41	val set : ('k, 'v) t -> key:'k -> data:'v -> unit
42
43	val find : ('k, 'v) t -> 'k -> 'v option
44
45	val data : (_, 'v) t -> 'v list
46
47	val remove : ('k, _) t -> 'k -> unit
48	end
49
50	module type S = sig
51	type ('a, 'b) t
52
53	type 'a with_init_args
54
55	type ('a, 'b) memo = ('a, ('b, exn) Result.t) t
56
57	val find : ('k, 'v) t -> 'k -> 'v option
58
59	val add : ('k, 'v) t -> key:'k -> data:'v -> unit
60
61	val remove : ('k, _) t -> 'k -> unit
62
63	val clear : (_, _) t -> unit
64
65	val create : destruct:('v -> unit) option -> ('k, 'v) t with_init_args
66
67	val call_with_cache : cache:('a, 'b) memo -> ('a -> 'b) -> 'a -> 'b
68
69	val memoize :
70	?destruct:('b -> unit)
71	-> ('a -> 'b)
72	-> (('a, 'b) memo * ('a -> 'b)) with_init_args
73	end
74
75	module Make (Strat : Strategy) (Store : Store) :
76	S with type 'a with_init_args = 'a Store.with_init_args Strat.with_init_args =
77	struct
78	type 'a with_init_args = 'a Store.with_init_args Strat.with_init_args
79
80	type ('k, 'v) t =
81	{ destruct : ('v -> unit) option
82	(** Function to be called on removal of values from the store *)
83	; strat : 'k Strat.t
84	; store : ('k, 'v) Store.t (** The actual key value store*)
85	}
86
87	type ('a, 'b) memo = ('a, ('b, exn) Result.t) t
88
89	let clear_from_store cache key =
90	match Store.find cache.store key with	×
91	\| None ->	×
92	failwith
93	"Cache.Make: strategy wants to remove a key which isn't in the store"
94	\| Some v ->	×
95	Option.call ~f:cache.destruct v ;
96	Store.remove cache.store key	×
97
98	let touch_key cache key =
99	List.iter (Strat.touch cache.strat key) ~f:(fun k ->	×
100	clear_from_store cache k )	×
101
102	let find cache k =
103	let res = Store.find cache.store k in	×
104	if Option.is_some res then touch_key cache k ;	×
105	res	×
106
107	let add cache ~key ~data =
108	touch_key cache key ;	×
109	Store.set cache.store ~key ~data	×
110
111	let remove cache key =
112	Option.iter (Store.find cache.store key) ~f:(fun v ->	×
113	Strat.remove cache.strat key ;	×
114	Option.call ~f:cache.destruct v ;	×
115	Store.remove cache.store key )	×
116
117	let clear cache =
118	Option.iter cache.destruct ~f:(fun destruct ->	×
119	List.iter (Store.data cache.store) ~f:destruct ) ;	×
120	Strat.clear cache.strat ;	×
121	Store.clear cache.store	×
122
123	let create ~destruct =
124	Strat.cps_create ~f:(fun strat ->	×
125	Store.cps_create ~f:(fun store -> { strat; destruct; store }) )	×
126
127	let call_with_cache ~cache f arg =
128	match find cache arg with	×
129	\| Some v ->	×
130	Memoized.return v
131	\| None ->	×
132	touch_key cache arg ;
133	let rval = Memoized.create ~f arg in	×
134	Store.set cache.store ~key:arg ~data:rval ;	×
135	Memoized.return rval	×
136
137	let memoize ?destruct f =
138	Strat.cps_create ~f:(fun strat ->	×
139	Store.cps_create ~f:(fun store ->	×
140	let destruct = Option.map destruct ~f:(fun f -> Result.iter ~f) in	×
141	let cache = { strat; destruct; store } in	×
142	let memd_f arg = call_with_cache ~cache f arg in	×
143	(cache, memd_f) ) )
144	end
145
146	module Strategy = struct
147	module Lru = struct
148	type 'a t =
149	{ (* sorted in order of descending recency *)
150	list : 'a Doubly_linked.t
151	; (* allows fast lookup in the list above *)
152	table : ('a, 'a Doubly_linked.Elt.t) Hashtbl.t
153	; mutable maxsize : int
154	; mutable size : int
155	}
156
157	type 'a with_init_args = int -> 'a
158
159	let kill_extra lru =
160	let extra = ref [] in	×
161	while lru.size > lru.maxsize do
162	let key = Option.value_exn (Doubly_linked.remove_last lru.list) in	×
163	Hashtbl.remove lru.table key ;	×
164	(* remove from table *)
165	lru.size <- lru.size - 1 ;	×
166	(* reduce size by 1 *)
167	extra := key :: !extra
168	done ;
169	!extra
170
171	let touch lru x =
172	let el = Doubly_linked.insert_first lru.list x in	×
173	match Hashtbl.find lru.table x with	×
174	\| Some old_el ->	×
175	Doubly_linked.remove lru.list old_el ;
176	Hashtbl.set lru.table ~key:x ~data:el ;	×
177	[]	×
178	\| None ->	×
179	Hashtbl.set lru.table ~key:x ~data:el ;
180	lru.size <- lru.size + 1 ;	×
181	kill_extra lru
182
183	let remove lru x =
184	Option.iter (Hashtbl.find lru.table x) ~f:(fun el ->	×
185	Doubly_linked.remove lru.list el ;	×
186	Hashtbl.remove lru.table x )	×
187
188	let create maxsize =
189	{ list = Doubly_linked.create ()	×
190	; table = Hashtbl.Poly.create () ~size:100	×
191	; maxsize
192	; size = 0
193	}
194
195	let cps_create ~f maxsize = f (create maxsize)	×
196
197	let clear lru =
198	lru.size <- 0 ;	×
199	Hashtbl.clear lru.table ;
200	Doubly_linked.clear lru.list	×
201	end
202
203	module Keep_all = struct
204	type 'a t = unit
205
206	type 'a with_init_args = 'a
207
208	let cps_create ~f = f ()	×
209
210	let touch () _ = []	×
211
212	let remove () _ = ()	×
213
214	let clear () = ()	×
215	end
216	end
217
218	module Store = struct
219	module Table = struct
220	include Hashtbl
221
222	type 'a with_init_args = 'a
223
224	let cps_create ~f = f (Hashtbl.Poly.create () ~size:16)	×
225	end
226	end
227
228	module Keep_all = Make (Strategy.Keep_all) (Store.Table)
229	module Lru = Make (Strategy.Lru) (Store.Table)
230
231	let keep_one ?(destruct = ignore) f =	×
232	let v = ref None in	×
233	() ;
234	fun x ->
235	match !v with	×
236	\| Some (x', y) when Poly.( = ) x' x ->	×
237	Memoized.return y	×
238	\| _ ->	×
239	Option.iter !v ~f:(fun (_, y) -> Result.iter ~f:destruct y) ;	×
240	v := None ;	×
241	let res = Memoized.create ~f x in
242	v := Some (x, res) ;	×
243	Memoized.return res
244
245	let memoize ?destruct ?(expire = `Keep_all) f =	×
246	match expire with	×
247	\| `Lru size ->	×
248	snd (Lru.memoize ?destruct f size)	×
249	\| `Keep_all ->	×
250	snd (Keep_all.memoize ?destruct f)	×
251	\| `Keep_one ->	×
252	keep_one ?destruct f
253
254	let unit f =
255	let l = Lazy.from_fun f in	×
256	fun () -> Lazy.force l	×

MinaProtocol / mina / 2863

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous