1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
(************************************************************************)
(* * The Coq Proof Assistant / The Coq Development Team *)
(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *)
(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
(* Type-safe implementation by whitequark *)
(* An extensible variant has an internal representation equivalent
to the following:
type constr = {
name: string,
id: int
}
type value = (*Object_tag*) constr * v1 * v2...
and the code generated by the compiler looks like:
(* type X += Y *)
let constr_Y = alloc { "Y", %caml_fresh_oo_id () }
(* match x with Y -> a | _ -> b *)
if x.0 == constr_Y then a else b
and the polymorphic comparison function works like:
let equal = fun (c1, ...) (c2, ...) ->
c1.id == c2.id
In every new extension constructor, the name field is a constant
string and the id field is filled with an unique[1] value returned
by %caml_fresh_oo_id. Moreover, every value of an extensible variant
type is allocated as a new block.
[1]: On 64-bit systems. On 32-bit systems, calling %caml_fresh_oo_id
2**30 times will result in a wraparound. Note that this does
not affect soundness because constructors are compared by
physical equality during matching. See OCaml PR7809 for code
demonstrating this.
An extensible variant can be marshalled and unmarshalled, and
is guaranteed to not be equal to itself after unmarshalling,
since the id field is filled with another unique value.
Note that the explanation above is purely informative and we
do not depend on the exact representation of extensible variants,
only on the fact that no two constructor representations ever
alias. In particular, if the definition of constr is replaced with:
type constr = int
(where the value is truly unique for every created constructor),
correctness is preserved.
*)
type 'a typ = ..
(* Erases the contained type so that the key can be put in a hash table. *)
type boxkey = Box : 'a typ -> boxkey [@@unboxed]
(* Carry the type we just erased with the actual key. *)
type 'a key = 'a typ * boxkey
module EHashtbl = Ephemeron.K1.Make(struct
type t = boxkey
let equal = (==)
let hash = Hashtbl.hash
end)
type value = { get : 'k. 'k typ -> 'k } [@@unboxed]
let values : value EHashtbl.t =
EHashtbl.create 1001
let create : type v. v -> v key =
fun value ->
let module M = struct
type _ typ += Typ : v typ
let get : type k. k typ -> k =
fun typ ->
match typ with
| Typ -> value
| _ -> assert false
let boxkey = Box Typ
let key = Typ, boxkey
let value = { get }
end in
EHashtbl.add values M.boxkey M.value;
M.key
(* Avoid raising Not_found *)
exception InvalidKey
let get (typ, boxkey) =
try (EHashtbl.find values boxkey).get typ
with Not_found -> raise InvalidKey
let default (typ, boxkey) default =
try (EHashtbl.find values boxkey).get typ
with Not_found -> default
let iter_opt (typ, boxkey) f =
try f ((EHashtbl.find values boxkey).get typ)
with Not_found -> ()
let clean () = EHashtbl.clean values