2817

Committed 23 Oct 2024 05:55PM UTC coverage: 33.411% (-27.7%) from 61.089%

Build # 2817

Build Type

push

buildkite

Committed by

web-flow

Commit Message

Merge pull request #16270 from MinaProtocol/dkijania/fix_promotion_job

Fix verify promoted docker check

Run Details

22271 of 66658 relevant lines covered (33.41%)

131054.24 hits per line

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

1.13

/src/lib/cache_lib/impl.ml

open Async_kernel
open Core_kernel

module type Inputs_intf = sig
  val handle_unconsumed_cache_item :
    logger:Logger.t -> cache_exceptions:bool -> cache_name:string -> unit
end

module Make (Inputs : Inputs_intf) : Intf.Main.S = struct
  module rec Cache : sig
    include
      Intf.Cache.S with type ('t, 'cache_t) cached := ('t, 'cache_t) Cached.t

    val logger : _ t -> Logger.t

    val cache_exceptions : _ t -> bool

    val remove :
      'elt t -> [ `Consumed | `Unconsumed | `Failure ] -> 'elt -> unit
  end = struct
    type 'a t =
      { name : string
      ; on_add : 'a -> unit
      ; on_remove : [ `Consumed | `Unconsumed | `Failure ] -> 'a -> unit
      ; element_to_string : 'a -> string
      ; set : ('a, 'a Intf.final_state) Hashtbl.t
      ; logger : Logger.t
      ; cache_exceptions : bool
      }

    let name { name; _ } = name

    let logger { logger; _ } = logger

    let cache_exceptions { cache_exceptions; _ } = cache_exceptions

    let create (type elt) ~name ~logger ~cache_exceptions ~on_add ~on_remove
        ~element_to_string (module Elt : Hashtbl.Key_plain with type t = elt) :
        elt t =
      let set = Hashtbl.create ~growth_allowed:true ?size:None (module Elt) in
      let logger = Logger.extend logger [ ("cache", `String name) ] in
      { name
      ; on_add
      ; on_remove
      ; element_to_string
      ; set
      ; logger
      ; cache_exceptions
      }

    let final_state t x = Hashtbl.find t.set x

    let register_exn t x =
      let final_state = Ivar.create () in
      Hashtbl.add_exn t.set ~key:x ~data:final_state ;
      t.on_add x ;
      Cached.create t x final_state

    let element_to_string t = t.element_to_string

    let mem t x = Hashtbl.mem t.set x

    let remove t reason x = Hashtbl.remove t.set x ; t.on_remove reason x

    let to_list t = Hashtbl.keys t.set
  end

  and Cached : sig
    include Intf.Cached.S

    val create : 'elt Cache.t -> 'elt -> 'elt Intf.final_state -> ('elt, 'elt) t
  end = struct
    type (_, _) t =
      | Base :
          { data : 'a
          ; cache : 'a Cache.t
          ; mutable transformed : bool
          ; final_state : 'a Intf.final_state
          }
          -> ('a, 'a) t
      | Derivative :
          { original : 'a
          ; mutant : 'b
          ; cache : 'a Cache.t
          ; mutable transformed : bool
          ; final_state : 'a Intf.final_state
          }
          -> ('b, 'a) t
      | Pure : 'a -> ('a, _) t

    let pure x = Pure x

    let is_pure : type a b. (a, b) t -> bool = function
      | Base _ ->
          false
      | Derivative _ ->
          false
      | Pure _ ->
          true

    let cache : type a b. (a, b) t -> b Cache.t = function
      | Base x ->
          x.cache
      | Derivative x ->
          x.cache
      | Pure _ ->
          failwith "cannot access cache of pure Cached.t"

    let value : type a b. (a, b) t -> a = function
      | Base x ->
          x.data
      | Derivative x ->
          x.mutant
      | Pure x ->
          x

    let original : type a b. (a, b) t -> b = function
      | Base x ->
          x.data
      | Derivative x ->
          x.original
      | Pure _ ->
          failwith "cannot access original of pure Cached.t"

    let final_state : type a b. (a, b) t -> b Intf.final_state = function
      | Base x ->
          x.final_state
      | Derivative x ->
          x.final_state
      | Pure _ ->
          failwith "cannot access consumed state of pure Cached.t"

    let was_consumed : type a b. (a, b) t -> bool = function
      | Base x ->
          Ivar.is_full x.final_state || x.transformed
      | Derivative x ->
          Ivar.is_full x.final_state || x.transformed
      | Pure _ ->
          false

    let was_finalized : type a b. (a, b) t -> bool = function
      | Base x ->
          Ivar.is_full x.final_state
      | Derivative x ->
          Ivar.is_full x.final_state
      | Pure _ ->
          false

    let mark_failed : type a b. (a, b) t -> unit = function
      | Base x ->
          if Ivar.is_full x.final_state then
            [%log' error (Logger.create ())] "Ivar.fill bug is here!" ;
          Ivar.fill x.final_state `Failed
      | Derivative x ->
          if Ivar.is_full x.final_state then
            [%log' error (Logger.create ())] "Ivar.fill bug is here!" ;
          Ivar.fill x.final_state `Failed
      | Pure _ ->
          failwith "cannot set consumed state of pure Cached.t"

    let mark_success : type a b. (a, b) t -> unit = function
      | Base x ->
          if Ivar.is_full x.final_state then
            [%log' error (Logger.create ())] "Ivar.fill bug is here!" ;
          Ivar.fill x.final_state (`Success x.data)
      | Derivative x ->
          if Ivar.is_full x.final_state then
            [%log' error (Logger.create ())] "Ivar.fill bug is here!" ;
          Ivar.fill x.final_state (`Success x.original)
      | Pure _ ->
          failwith "cannot set consumed state of pure Cached.t"

    let attach_finalizer t =
      Gc.Expert.add_finalizer (Heap_block.create_exn t) (fun block ->
          let t = Heap_block.value block in
          if not (was_consumed t) then (
            let cache = cache t in
            Cache.remove cache `Unconsumed (original t) ;
            Inputs.handle_unconsumed_cache_item ~logger:(Cache.logger cache)
              ~cache_exceptions:(Cache.cache_exceptions cache)
              ~cache_name:(Cache.name cache) ) ) ;
      t

    let create cache data final_state =
      attach_finalizer (Base { data; cache; transformed = false; final_state })

    let assert_not_consumed t msg =
      let open Error in
      if was_consumed t then
        raise
          (createf "%s: %s" msg
             (Cache.element_to_string (cache t) (original t)) )

    let assert_not_finalized t msg =
      let open Error in
      if was_finalized t then
        raise
          (createf "%s: %s" msg
             (Cache.element_to_string (cache t) (original t)) )

    let peek (type a b) (t : (a, b) t) : a =
      assert_not_finalized t "cannot peek at finalized Cached.t" ;
      value t

    let mark_transformed : type a b. (a, b) t -> unit = function
      | Base x ->
          x.transformed <- true
      | Derivative x ->
          x.transformed <- true
      | Pure _ ->
          failwith "cannot set transformed status for pure Cached.t"

    let transform (type a b) (t : (a, b) t) ~(f : a -> 'c) : ('c, b) t =
      assert_not_consumed t "cannot consume Cached.t twice" ;
      mark_transformed t ;
      attach_finalizer
        (Derivative
           { original = original t
           ; mutant = f (value t)
           ; cache = cache t
           ; transformed = false
           ; final_state = final_state t
           } )

    let invalidate_with_failure (type a b) (t : (a, b) t) : a =
      assert_not_finalized t "Cached item has already been finalized" ;
      mark_failed t ;
      Cache.remove (cache t) `Failure (original t) ;
      value t

    let invalidate_with_success (type a b) (t : (a, b) t) : a =
      assert_not_finalized t "Cached item has already been finalized" ;
      mark_success t ;
      Cache.remove (cache t) `Consumed (original t) ;
      value t

    let sequence_deferred (type a b) (t : (a Deferred.t, b) t) :
        (a, b) t Deferred.t =
      let open Deferred.Let_syntax in
      let%map x = peek t in
      transform t ~f:(Fn.const x)

    let sequence_result (type a b) (t : ((a, 'e) Result.t, b) t) :
        ((a, b) t, 'e) Result.t =
      match peek t with
      | Ok x ->
          Ok (transform t ~f:(Fn.const x))
      | Error err ->
          [%log' error (Cache.logger (cache t))]
            "Cached.sequence_result called on an already consumed Cached.t" ;
          ignore (invalidate_with_failure t : (a, 'e) Result.t) ;
          Error err
  end

  module Transmuter_cache :
    Intf.Transmuter_cache.F
      with module Cached := Cached
       and module Cache := Cache = struct
    module Make
        (Transmuter : Intf.Transmuter.S)
        (Registry : Intf.Registry.S with type element := Transmuter.Target.t)
        (Name : Intf.Constant.S with type t := string) :
      Intf.Transmuter_cache.S
        with module Cached := Cached
         and module Cache := Cache
         and type source = Transmuter.Source.t
         and type target = Transmuter.Target.t = struct
      type source = Transmuter.Source.t

      type target = Transmuter.Target.t

      type t = Transmuter.Target.t Cache.t

      let create ~logger =
        Cache.create ~logger ~name:Name.t ~on_add:Registry.element_added
          ~on_remove:Registry.element_removed
          ~element_to_string:Transmuter.Target.to_string
          (module Transmuter.Target)

      let register_exn t x =
        let target = Cache.register_exn t (Transmuter.transmute x) in
        Cached.transform target ~f:(Fn.const x)

      let final_state t x = Cache.final_state t (Transmuter.transmute x)

      let mem t x = Cache.mem t (Transmuter.transmute x)
    end
  end
end

let%test_module "cache_lib test instance" =
  ( module struct
    let dropped_cache_items = ref 0

    include Make (struct
      let handle_unconsumed_cache_item ~logger:_ ~cache_exceptions:_
          ~cache_name:_ =
        incr dropped_cache_items
    end)

    let setup () = dropped_cache_items := 0

    let with_item ~f =
      Bytes.create 10 |> Bytes.to_string
      |> String.map ~f:(fun _ -> Char.of_int_exn (Random.bits () land 0xff))
      |> f

    let with_cache ~logger ~cache_exceptions ~f =
      Cache.create ~name:"test" ~logger ~cache_exceptions ~on_add:ignore
        ~on_remove:(fun _ _ -> ())
        ~element_to_string:Fn.id
        (module String)
      |> f

    let%test_unit "cached objects do not trigger unconsumption hook when \
                   invalidated" =
      setup () ;
      let logger = Logger.null () in
      with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->
          with_item ~f:(fun data ->
              let x = Cache.register_exn cache data in
              ignore (Cached.invalidate_with_success x : string) ) ;
          Gc.full_major () ;
          assert (!dropped_cache_items = 0) )

    let%test_unit "cached objects are garbage collected independently of caches"
        =
      setup () ;
      let logger = Logger.null () in
      with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->
          with_item ~f:(fun data ->
              ignore (Cache.register_exn cache data : (string, string) Cached.t) ) ;
          Gc.full_major () ;
          assert (!dropped_cache_items = 1) )

    let%test_unit "cached objects are garbage collected independently of data" =
      setup () ;
      let logger = Logger.null () in
      with_item ~f:(fun data ->
          with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->
              ignore (Cache.register_exn cache data : (string, string) Cached.t) ) ;
          Gc.full_major () ;
          assert (!dropped_cache_items = 1) )

    let%test_unit "cached objects are not unexpectedly garbage collected" =
      setup () ;
      let logger = Logger.null () in
      with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->
          with_item ~f:(fun data ->
              let cached = Cache.register_exn cache data in
              Gc.full_major () ;
              assert (!dropped_cache_items = 0) ;
              ignore (Cached.invalidate_with_success cached : string) ) ) ;
      Gc.full_major () ;
      assert (!dropped_cache_items = 0)

    let%test_unit "garbage collection of derived cached objects do not trigger \
                   unconsumption handler for parents" =
      setup () ;
      let logger = Logger.null () in
      with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->
          with_item ~f:(fun data ->
              ignore
                ( Cache.register_exn cache data
                  |> Cached.transform ~f:(Fn.const 5)
                  |> Cached.transform ~f:(Fn.const ())
                  : (unit, string) Cached.t ) ) ;
          Gc.full_major () ;
          assert (!dropped_cache_items = 1) )

    let%test_unit "properly invalidated derived cached objects do not trigger \
                   any unconsumption handler calls" =
      setup () ;
      let logger = Logger.null () in
      with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->
          with_item ~f:(fun data ->
              Cache.register_exn cache data
              |> Cached.transform ~f:(Fn.const 5)
              |> Cached.transform ~f:(Fn.const ())
              |> Cached.invalidate_with_success ) ;
          Gc.full_major () ;
          assert (!dropped_cache_items = 0) )

    let%test_unit "invalidate original cached object would also remove the \
                   derived cached object" =
      setup () ;
      let logger = Logger.null () in
      with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->
          with_item ~f:(fun data ->
              let src = Cache.register_exn cache data in
              let _der =
                src
                |> Cached.transform ~f:(Fn.const 5)
                |> Cached.transform ~f:(Fn.const ())
              in
              ignore (Cached.invalidate_with_success src : string) ) ;
          Gc.full_major () ;
          assert (!dropped_cache_items = 0) )

    let%test_unit "deriving a cached object inhabits its parent's final_state" =
      setup () ;
      with_cache ~logger:(Logger.null ()) ~cache_exceptions:false
        ~f:(fun cache ->
          with_item ~f:(fun data ->
              let src = Cache.register_exn cache data in
              let der = Cached.transform src ~f:(Fn.const 5) in
              let src_final_state = Cached.final_state src in
              let der_final_state = Cached.final_state der in
              assert (Ivar.equal src_final_state der_final_state) ) )
  end )

1	open Async_kernel	3✔
2	open Core_kernel
3
4	module type Inputs_intf = sig
5	val handle_unconsumed_cache_item :
6	logger:Logger.t -> cache_exceptions:bool -> cache_name:string -> unit
7	end
8
9	module Make (Inputs : Inputs_intf) : Intf.Main.S = struct
10	module rec Cache : sig
11	include
12	Intf.Cache.S with type ('t, 'cache_t) cached := ('t, 'cache_t) Cached.t
13
14	val logger : _ t -> Logger.t
15
16	val cache_exceptions : _ t -> bool
17
18	val remove :
19	'elt t -> [ `Consumed \| `Unconsumed \| `Failure ] -> 'elt -> unit
20	end = struct
21	type 'a t =
22	{ name : string
23	; on_add : 'a -> unit
24	; on_remove : [ `Consumed \| `Unconsumed \| `Failure ] -> 'a -> unit
25	; element_to_string : 'a -> string
26	; set : ('a, 'a Intf.final_state) Hashtbl.t
27	; logger : Logger.t
28	; cache_exceptions : bool
29	}
30
31	let name { name; _ } = name	×
32
33	let logger { logger; _ } = logger	×
34
35	let cache_exceptions { cache_exceptions; _ } = cache_exceptions	×
36
37	let create (type elt) ~name ~logger ~cache_exceptions ~on_add ~on_remove
38	~element_to_string (module Elt : Hashtbl.Key_plain with type t = elt) :
39	elt t =
40	let set = Hashtbl.create ~growth_allowed:true ?size:None (module Elt) in	×
41	let logger = Logger.extend logger [ ("cache", `String name) ] in	×
42	{ name	×
43	; on_add
44	; on_remove
45	; element_to_string
46	; set
47	; logger
48	; cache_exceptions
49	}
50
51	let final_state t x = Hashtbl.find t.set x	×
52
53	let register_exn t x =
54	let final_state = Ivar.create () in	×
55	Hashtbl.add_exn t.set ~key:x ~data:final_state ;	×
56	t.on_add x ;	×
57	Cached.create t x final_state	×
58
59	let element_to_string t = t.element_to_string	×
60
61	let mem t x = Hashtbl.mem t.set x	×
62
63	let remove t reason x = Hashtbl.remove t.set x ; t.on_remove reason x	×
64
65	let to_list t = Hashtbl.keys t.set	×
66	end
67
68	and Cached : sig
69	include Intf.Cached.S
70
71	val create : 'elt Cache.t -> 'elt -> 'elt Intf.final_state -> ('elt, 'elt) t
72	end = struct
73	type (_, _) t =
74	\| Base :
75	{ data : 'a
76	; cache : 'a Cache.t
77	; mutable transformed : bool
78	; final_state : 'a Intf.final_state
79	}
80	-> ('a, 'a) t
81	\| Derivative :
82	{ original : 'a
83	; mutant : 'b
84	; cache : 'a Cache.t
85	; mutable transformed : bool
86	; final_state : 'a Intf.final_state
87	}
88	-> ('b, 'a) t
89	\| Pure : 'a -> ('a, _) t
90
91	let pure x = Pure x	×
92
93	let is_pure : type a b. (a, b) t -> bool = function
94	\| Base _ ->	×
95	false
96	\| Derivative _ ->	×
97	false
98	\| Pure _ ->	×
99	true
100
101	let cache : type a b. (a, b) t -> b Cache.t = function
102	\| Base x ->	×
103	x.cache
104	\| Derivative x ->	×
105	x.cache
106	\| Pure _ ->	×
107	failwith "cannot access cache of pure Cached.t"
108
109	let value : type a b. (a, b) t -> a = function
110	\| Base x ->	×
111	x.data
112	\| Derivative x ->	×
113	x.mutant
114	\| Pure x ->	×
115	x
116
117	let original : type a b. (a, b) t -> b = function
118	\| Base x ->	×
119	x.data
120	\| Derivative x ->	×
121	x.original
122	\| Pure _ ->	×
123	failwith "cannot access original of pure Cached.t"
124
125	let final_state : type a b. (a, b) t -> b Intf.final_state = function
126	\| Base x ->	×
127	x.final_state
128	\| Derivative x ->	×
129	x.final_state
130	\| Pure _ ->	×
131	failwith "cannot access consumed state of pure Cached.t"
132
133	let was_consumed : type a b. (a, b) t -> bool = function
134	\| Base x ->	×
135	Ivar.is_full x.final_state \|\| x.transformed	×
136	\| Derivative x ->	×
137	Ivar.is_full x.final_state \|\| x.transformed	×
138	\| Pure _ ->	×
139	false
140
141	let was_finalized : type a b. (a, b) t -> bool = function
142	\| Base x ->	×
143	Ivar.is_full x.final_state
144	\| Derivative x ->	×
145	Ivar.is_full x.final_state
146	\| Pure _ ->	×
147	false
148
149	let mark_failed : type a b. (a, b) t -> unit = function
150	\| Base x ->	×
151	if Ivar.is_full x.final_state then
152	[%log' error (Logger.create ())] "Ivar.fill bug is here!" ;	×
153	Ivar.fill x.final_state `Failed	×
154	\| Derivative x ->	×
155	if Ivar.is_full x.final_state then
156	[%log' error (Logger.create ())] "Ivar.fill bug is here!" ;	×
157	Ivar.fill x.final_state `Failed	×
158	\| Pure _ ->	×
159	failwith "cannot set consumed state of pure Cached.t"
160
161	let mark_success : type a b. (a, b) t -> unit = function
162	\| Base x ->	×
163	if Ivar.is_full x.final_state then
164	[%log' error (Logger.create ())] "Ivar.fill bug is here!" ;	×
165	Ivar.fill x.final_state (`Success x.data)	×
166	\| Derivative x ->	×
167	if Ivar.is_full x.final_state then
168	[%log' error (Logger.create ())] "Ivar.fill bug is here!" ;	×
169	Ivar.fill x.final_state (`Success x.original)	×
170	\| Pure _ ->	×
171	failwith "cannot set consumed state of pure Cached.t"
172
173	let attach_finalizer t =
174	Gc.Expert.add_finalizer (Heap_block.create_exn t) (fun block ->	×
175	let t = Heap_block.value block in	×
176	if not (was_consumed t) then (	×
177	let cache = cache t in
178	Cache.remove cache `Unconsumed (original t) ;	×
179	Inputs.handle_unconsumed_cache_item ~logger:(Cache.logger cache)	×
180	~cache_exceptions:(Cache.cache_exceptions cache)	×
181	~cache_name:(Cache.name cache) ) ) ;	×
182	t	×
183
184	let create cache data final_state =
185	attach_finalizer (Base { data; cache; transformed = false; final_state })	×
186
187	let assert_not_consumed t msg =
188	let open Error in	×
189	if was_consumed t then
190	raise	×
191	(createf "%s: %s" msg	×
192	(Cache.element_to_string (cache t) (original t)) )	×
193
194	let assert_not_finalized t msg =
195	let open Error in	×
196	if was_finalized t then
197	raise	×
198	(createf "%s: %s" msg	×
199	(Cache.element_to_string (cache t) (original t)) )	×
200
201	let peek (type a b) (t : (a, b) t) : a =
202	assert_not_finalized t "cannot peek at finalized Cached.t" ;	×
203	value t	×
204
205	let mark_transformed : type a b. (a, b) t -> unit = function
206	\| Base x ->	×
207	x.transformed <- true
208	\| Derivative x ->	×
209	x.transformed <- true
210	\| Pure _ ->	×
211	failwith "cannot set transformed status for pure Cached.t"
212
213	let transform (type a b) (t : (a, b) t) ~(f : a -> 'c) : ('c, b) t =
214	assert_not_consumed t "cannot consume Cached.t twice" ;	×
215	mark_transformed t ;	×
216	attach_finalizer	×
217	(Derivative
218	{ original = original t	×
219	; mutant = f (value t)	×
220	; cache = cache t	×
221	; transformed = false
222	; final_state = final_state t	×
223	} )
224
225	let invalidate_with_failure (type a b) (t : (a, b) t) : a =
226	assert_not_finalized t "Cached item has already been finalized" ;	×
227	mark_failed t ;	×
228	Cache.remove (cache t) `Failure (original t) ;	×
229	value t	×
230
231	let invalidate_with_success (type a b) (t : (a, b) t) : a =
232	assert_not_finalized t "Cached item has already been finalized" ;	×
233	mark_success t ;	×
234	Cache.remove (cache t) `Consumed (original t) ;	×
235	value t	×
236
237	let sequence_deferred (type a b) (t : (a Deferred.t, b) t) :
238	(a, b) t Deferred.t =
239	let open Deferred.Let_syntax in	×
240	let%map x = peek t in	×
241	transform t ~f:(Fn.const x)	×
242
243	let sequence_result (type a b) (t : ((a, 'e) Result.t, b) t) :
244	((a, b) t, 'e) Result.t =
245	match peek t with	×
246	\| Ok x ->	×
247	Ok (transform t ~f:(Fn.const x))	×
248	\| Error err ->	×
249	[%log' error (Cache.logger (cache t))]	×
250	"Cached.sequence_result called on an already consumed Cached.t" ;
251	ignore (invalidate_with_failure t : (a, 'e) Result.t) ;	×
252	Error err
253	end
254
255	module Transmuter_cache :
256	Intf.Transmuter_cache.F
257	with module Cached := Cached
258	and module Cache := Cache = struct
259	module Make
260	(Transmuter : Intf.Transmuter.S)
261	(Registry : Intf.Registry.S with type element := Transmuter.Target.t)
262	(Name : Intf.Constant.S with type t := string) :
263	Intf.Transmuter_cache.S
264	with module Cached := Cached
265	and module Cache := Cache
266	and type source = Transmuter.Source.t
267	and type target = Transmuter.Target.t = struct
268	type source = Transmuter.Source.t
269
270	type target = Transmuter.Target.t
271
272	type t = Transmuter.Target.t Cache.t
273
274	let create ~logger =
275	Cache.create ~logger ~name:Name.t ~on_add:Registry.element_added	×
276	~on_remove:Registry.element_removed
277	~element_to_string:Transmuter.Target.to_string
278	(module Transmuter.Target)
279
280	let register_exn t x =
281	let target = Cache.register_exn t (Transmuter.transmute x) in	×
282	Cached.transform target ~f:(Fn.const x)	×
283
284	let final_state t x = Cache.final_state t (Transmuter.transmute x)	×
285
286	let mem t x = Cache.mem t (Transmuter.transmute x)	×
287	end
288	end
289	end
290
291	let%test_module "cache_lib test instance" =
292	( module struct
293	let dropped_cache_items = ref 0
294
295	include Make (struct
296	let handle_unconsumed_cache_item ~logger:_ ~cache_exceptions:_
297	~cache_name:_ =
298	incr dropped_cache_items	×
299	end)
300
301	let setup () = dropped_cache_items := 0	×
302
303	let with_item ~f =
304	Bytes.create 10 \|> Bytes.to_string	×
305	\|> String.map ~f:(fun _ -> Char.of_int_exn (Random.bits () land 0xff))	×
306	\|> f	×
307
308	let with_cache ~logger ~cache_exceptions ~f =
309	Cache.create ~name:"test" ~logger ~cache_exceptions ~on_add:ignore	×
310	~on_remove:(fun _ _ -> ())	×
311	~element_to_string:Fn.id
312	(module String)
313	\|> f	×
314
315	let%test_unit "cached objects do not trigger unconsumption hook when \
316	invalidated" =
317	setup () ;	×
318	let logger = Logger.null () in	×
319	with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->	×
320	with_item ~f:(fun data ->	×
321	let x = Cache.register_exn cache data in	×
322	ignore (Cached.invalidate_with_success x : string) ) ;	×
323	Gc.full_major () ;
324	assert (!dropped_cache_items = 0) )	×
325
326	let%test_unit "cached objects are garbage collected independently of caches"
327	=
328	setup () ;	×
329	let logger = Logger.null () in	×
330	with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->	×
331	with_item ~f:(fun data ->	×
332	ignore (Cache.register_exn cache data : (string, string) Cached.t) ) ;	×
333	Gc.full_major () ;
334	assert (!dropped_cache_items = 1) )	×
335
336	let%test_unit "cached objects are garbage collected independently of data" =
337	setup () ;	×
338	let logger = Logger.null () in	×
339	with_item ~f:(fun data ->	×
340	with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->	×
341	ignore (Cache.register_exn cache data : (string, string) Cached.t) ) ;	×
342	Gc.full_major () ;
343	assert (!dropped_cache_items = 1) )	×
344
345	let%test_unit "cached objects are not unexpectedly garbage collected" =
346	setup () ;	×
347	let logger = Logger.null () in	×
348	with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->	×
349	with_item ~f:(fun data ->	×
350	let cached = Cache.register_exn cache data in	×
351	Gc.full_major () ;	×
352	assert (!dropped_cache_items = 0) ;	×
353	ignore (Cached.invalidate_with_success cached : string) ) ) ;	×
354	Gc.full_major () ;
355	assert (!dropped_cache_items = 0)	×
356
357	let%test_unit "garbage collection of derived cached objects do not trigger \
358	unconsumption handler for parents" =
359	setup () ;	×
360	let logger = Logger.null () in	×
361	with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->	×
362	with_item ~f:(fun data ->	×
363	ignore	×
364	( Cache.register_exn cache data
365	\|> Cached.transform ~f:(Fn.const 5)	×
366	\|> Cached.transform ~f:(Fn.const ())	×
367	: (unit, string) Cached.t ) ) ;
368	Gc.full_major () ;
369	assert (!dropped_cache_items = 1) )	×
370
371	let%test_unit "properly invalidated derived cached objects do not trigger \
372	any unconsumption handler calls" =
373	setup () ;	×
374	let logger = Logger.null () in	×
375	with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->	×
376	with_item ~f:(fun data ->	×
377	Cache.register_exn cache data	×
378	\|> Cached.transform ~f:(Fn.const 5)	×
379	\|> Cached.transform ~f:(Fn.const ())	×
380	\|> Cached.invalidate_with_success ) ;	×
381	Gc.full_major () ;
382	assert (!dropped_cache_items = 0) )	×
383
384	let%test_unit "invalidate original cached object would also remove the \
385	derived cached object" =
386	setup () ;	×
387	let logger = Logger.null () in	×
388	with_cache ~logger ~cache_exceptions:false ~f:(fun cache ->	×
389	with_item ~f:(fun data ->	×
390	let src = Cache.register_exn cache data in	×
391	let _der =	×
392	src
393	\|> Cached.transform ~f:(Fn.const 5)	×
394	\|> Cached.transform ~f:(Fn.const ())	×
395	in
396	ignore (Cached.invalidate_with_success src : string) ) ;	×
397	Gc.full_major () ;
398	assert (!dropped_cache_items = 0) )	×
399
400	let%test_unit "deriving a cached object inhabits its parent's final_state" =
401	setup () ;	×
402	with_cache ~logger:(Logger.null ()) ~cache_exceptions:false	×
403	~f:(fun cache ->
404	with_item ~f:(fun data ->	×
405	let src = Cache.register_exn cache data in	×
406	let der = Cached.transform src ~f:(Fn.const 5) in	×
407	let src_final_state = Cached.final_state src in	×
408	let der_final_state = Cached.final_state der in	×
409	assert (Ivar.equal src_final_state der_final_state) ) )	×
410	end )	3✔

MinaProtocol / mina / 2817

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