Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

new ephemeron API, implemented on top of old ephemerons #10737

Merged
merged 7 commits into from
Nov 5, 2021
Merged

new ephemeron API, implemented on top of old ephemerons #10737

Show file tree
Hide file tree
Changes from 3 commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
348004d
new ephemeron API, implemented on top of old ephemerons
damiendoligez Oct 11, 2021
d535cc9
fix tests that use the old ephemeron API
damiendoligez Nov 2, 2021
1c2952c
add Changes entry
damiendoligez Nov 2, 2021
cd592f8
update .depend
damiendoligez Nov 2, 2021
d099279
ephemerons: port tests to the new API
damiendoligez Nov 3, 2021
c1f281d
ephemerons : fix test for flambda
damiendoligez Nov 3, 2021
5de50bd
fix "set_key/set_data" virtual bug; update Changes
damiendoligez Nov 4, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
4 changes: 4 additions & 0 deletions Changes
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -100,6 +100,10 @@ Working version
(Sébastien Hinderer, review by Damien Doligez, Gabriel Scherer, David
Allsopp, Nicolás Ojeda Bär, Vincent Laviron)

- #10737: add new ephemeron API for forward compatibility with Multicore
OCaml.
(Damien Doligez, review by ...)

### Other libraries:

- #10192: Add support for Unix domain sockets on Windows and use them
Expand Down
216 changes: 214 additions & 2 deletions stdlib/ephemeron.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,15 +13,77 @@
(* *)
(**************************************************************************)

[@@@ocaml.warning "-32"]

module type SeededS = sig
include Hashtbl.SeededS

type key
type !'a t
val create : ?random (*thwart tools/sync_stdlib_docs*) : bool -> int -> 'a t
val clear : 'a t -> unit
val reset : 'a t -> unit
val copy : 'a t -> 'a t
val add : 'a t -> key -> 'a -> unit
val remove : 'a t -> key -> unit
val find : 'a t -> key -> 'a
val find_opt : 'a t -> key -> 'a option
val find_all : 'a t -> key -> 'a list
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val length : 'a t -> int
val stats : 'a t -> Hashtbl.statistics
val to_seq : 'a t -> (key * 'a) Seq.t
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val to_seq_keys : _ t -> key Seq.t
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val to_seq_values : 'a t -> 'a Seq.t
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val add_seq : 'a t -> (key * 'a) Seq.t -> unit
val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
val of_seq : (key * 'a) Seq.t -> 'a t
val clean: 'a t -> unit
val stats_alive: 'a t -> Hashtbl.statistics
(** same as {!stats} but only count the alive bindings *)
end

module type S = sig
include Hashtbl.S

type key
type !'a t
val create : int -> 'a t
val clear : 'a t -> unit
val reset : 'a t -> unit
val copy : 'a t -> 'a t
val add : 'a t -> key -> 'a -> unit
val remove : 'a t -> key -> unit
val find : 'a t -> key -> 'a
val find_opt : 'a t -> key -> 'a option
val find_all : 'a t -> key -> 'a list
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val length : 'a t -> int
val stats : 'a t -> Hashtbl.statistics
val to_seq : 'a t -> (key * 'a) Seq.t
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val to_seq_keys : _ t -> key Seq.t
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val to_seq_values : 'a t -> 'a Seq.t
[@@alert old_ephemeron_api "This function won't be available in 5.0"]
val add_seq : 'a t -> (key * 'a) Seq.t -> unit
val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
val of_seq : (key * 'a) Seq.t -> 'a t
val clean: 'a t -> unit
val stats_alive: 'a t -> Hashtbl.statistics
(** same as {!stats} but only count the alive bindings *)
Expand Down Expand Up @@ -450,6 +512,18 @@ module K1 = struct
let check_data (t:('k,'d) t) : bool = ObjEph.check_data t
let blit_data (t1:(_,'d) t) (t2:(_,'d) t) : unit = ObjEph.blit_data t1 t2

let make key data =
let eph = create () in
set_key eph key;
set_data eph data;
eph
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It is safer in theory to write this as set_data eph data; set_key eph key, because if this is the last use of key and the GC runs between set_key and set_data then it can clear the ephemeron before the data is set, resulting in an ephemeron with a dead, cleared key and a strong reference to data. This strong reference will never be cleared.

I think in practice this situation will not occur, because there is no allocation between those two calls, the safepoints patch does not insert allocations at that point, and if this is inlined into a function that does contain allocations it seems relatively unlikely that the optimiser will choose to move an allocation between these calls. So it's probably fine as-is, but it would at least be more obviously fine the other way around.

(See here for further discussion on this issue. I think the new API proposed here is a big improvement, because it avoids this sort of trickiness)

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Doesn't cost much to fix, so I fixed it.


let query eph key =
match get_key eph with
| None -> None
| Some k when k == key -> get_data eph
| Some _ -> None

module MakeSeeded (H:Hashtbl.SeededHashedType) =
GenHashTable.MakeSeeded(struct
type 'a container = (H.t,'a) t
Expand Down Expand Up @@ -490,6 +564,37 @@ module K1 = struct
tbl
end

module Bucket = struct

type nonrec ('k, 'd) t = ('k, 'd) t list ref
let k1_make = make
let make () = ref []
let add b k d = b := k1_make k d :: !b

let test_key k e =
match get_key e with
| Some x when x == k -> true
| _ -> false

let remove b k =
let rec loop l acc =
match l with
| [] -> ()
| h :: t when test_key k h -> b := List.rev_append acc t
| h :: t -> loop t (h :: acc)
in
loop !b []

let find b k =
match List.find_opt (test_key k) !b with
| Some e -> get_data e
| None -> None

let length b = List.length !b
let clear b = b := []

end

end

module K2 = struct
Expand Down Expand Up @@ -530,6 +635,24 @@ module K2 = struct
let check_data (t:('k1,'k2,'d) t) : bool = ObjEph.check_data t
let blit_data (t1:(_,_,'d) t) (t2:(_,_,'d) t) : unit = ObjEph.blit_data t1 t2

let make key1 key2 data =
let eph = create () in
set_key1 eph key1;
set_key2 eph key2;
set_data eph data;
eph

let query eph key1 key2 =
match get_key1 eph with
| None -> None
| Some k when k == key1 ->
begin match get_key2 eph with
| None -> None
| Some k when k == key2 -> get_data eph
| Some _ -> None
end
| Some _ -> None

module MakeSeeded
(H1:Hashtbl.SeededHashedType)
(H2:Hashtbl.SeededHashedType) =
Expand Down Expand Up @@ -582,6 +705,37 @@ module K2 = struct
tbl
end

module Bucket = struct

type nonrec ('k1, 'k2, 'd) t = ('k1, 'k2, 'd) t list ref
let k2_make = make
let make () = ref []
let add b k1 k2 d = b := k2_make k1 k2 d :: !b

let test_keys k1 k2 e =
match get_key1 e, get_key2 e with
| Some x1, Some x2 when x1 == k1 && x2 == k2 -> true
| _ -> false

let remove b k1 k2 =
let rec loop l acc =
match l with
| [] -> ()
| h :: t when test_keys k1 k2 h -> b := List.rev_append acc t
| h :: t -> loop t (h :: acc)
in
loop !b []

let find b k1 k2 =
match List.find_opt (test_keys k1 k2) !b with
| Some e -> get_data e
| None -> None

let length b = List.length !b
let clear b = b := []

end

end

module Kn = struct
Expand All @@ -608,6 +762,26 @@ module Kn = struct
let check_data (t:('k,'d) t) : bool = ObjEph.check_data t
let blit_data (t1:(_,'d) t) (t2:(_,'d) t) : unit = ObjEph.blit_data t1 t2

let make keys data =
let l = Array.length keys in
let eph = create l in
for i = 0 to l - 1 do set_key eph i keys.(i) done;
set_data eph data;
eph

let query eph keys =
let l = length eph in
try
if l <> Array.length keys then raise Exit;
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Would raise_notrace be better for this and similar instances of raise?

for i = 0 to l - 1 do
match get_key eph i with
| None -> raise Exit
| Some k when k == keys.(i) -> ()
| Some _ -> raise Exit
done;
get_data eph
with Exit -> None

module MakeSeeded (H:Hashtbl.SeededHashedType) =
GenHashTable.MakeSeeded(struct
type 'a container = (H.t,'a) t
Expand Down Expand Up @@ -685,4 +859,42 @@ module Kn = struct
replace_seq tbl i;
tbl
end

module Bucket = struct

type nonrec ('k, 'd) t = ('k, 'd) t list ref
let kn_make = make
let make () = ref []
let add b k d = b := kn_make k d :: !b

let test_keys k e =
try
if length e <> Array.length k then raise Exit;
for i = 0 to Array.length k - 1 do
match get_key e i with
| Some x when x == k.(i) -> ()
| _ -> raise Exit
done;
true
with Exit -> false

let remove b k =
let rec loop l acc =
match l with
| [] -> ()
| h :: t when test_keys k h -> b := List.rev_append acc t
| h :: t -> loop t (h :: acc)
in
loop !b []

let find b k =
match List.find_opt (test_keys k) !b with
| Some e -> get_data e
| None -> None

let length b = List.length !b
let clear b = b := []

end

end