forked from ocaml/ocaml
-
Notifications
You must be signed in to change notification settings - Fork 0
/
obj.ml
183 lines (151 loc) · 6.1 KB
/
obj.ml
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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Operations on internal representations of values *)
type t
type raw_data = nativeint
external repr : 'a -> t = "%identity"
external obj : t -> 'a = "%identity"
external magic : 'a -> 'b = "%identity"
external is_int : t -> bool = "%obj_is_int"
let [@inline always] is_block a = not (is_int a)
external tag : t -> int = "caml_obj_tag" [@@noalloc]
external size : t -> int = "%obj_size"
external reachable_words : t -> int = "caml_obj_reachable_words"
external field : t -> int -> t = "%obj_field"
external set_field : t -> int -> t -> unit = "%obj_set_field"
external floatarray_get : floatarray -> int -> float = "caml_floatarray_get"
external floatarray_set :
floatarray -> int -> float -> unit = "caml_floatarray_set"
let [@inline always] double_field x i = floatarray_get (obj x : floatarray) i
let [@inline always] set_double_field x i v =
floatarray_set (obj x : floatarray) i v
external raw_field : t -> int -> raw_data = "caml_obj_raw_field"
external set_raw_field : t -> int -> raw_data -> unit
= "caml_obj_set_raw_field"
external new_block : int -> int -> t = "caml_obj_block"
external dup : t -> t = "caml_obj_dup"
external add_offset : t -> Int32.t -> t = "caml_obj_add_offset"
external with_tag : int -> t -> t = "caml_obj_with_tag"
let first_non_constant_constructor_tag = 0
let last_non_constant_constructor_tag = 243
let forcing_tag = 244
let cont_tag = 245
let lazy_tag = 246
let closure_tag = 247
let object_tag = 248
let infix_tag = 249
let forward_tag = 250
let no_scan_tag = 251
let abstract_tag = 251
let string_tag = 252
let double_tag = 253
let double_array_tag = 254
let custom_tag = 255
let int_tag = 1000
let out_of_heap_tag = 1001
let unaligned_tag = 1002
module Closure = struct
type info = {
arity: int;
start_env: int;
}
let info_of_raw (info : nativeint) =
let open Nativeint in
let arity =
(* signed: negative for tupled functions *)
if Sys.word_size = 64 then
to_int (shift_right info 56)
else
to_int (shift_right info 24)
in
let start_env =
(* start_env is unsigned, but we know it can always fit an OCaml
integer so we use [to_int] instead of [unsigned_to_int]. *)
to_int (shift_right_logical (shift_left info 8) 9) in
{ arity; start_env }
(* note: we expect a closure, not an infix pointer *)
let info (obj : t) =
assert (tag obj = closure_tag);
info_of_raw (raw_field obj 1)
end
module Extension_constructor =
struct
type t = extension_constructor
let of_val x =
let x = repr x in
let slot =
if (is_block x) && (tag x) <> object_tag && (size x) >= 1 then field x 0
else x
in
let name =
if (is_block slot) && (tag slot) = object_tag then field slot 0
else invalid_arg "Obj.extension_constructor"
in
if (tag name) = string_tag then (obj slot : t)
else invalid_arg "Obj.extension_constructor"
let [@inline always] name (slot : t) =
(obj (field (repr slot) 0) : string)
let [@inline always] id (slot : t) =
(obj (field (repr slot) 1) : int)
end
module Ephemeron = struct
type obj_t = t
type t (** ephemeron *)
(** To change in sync with weak.h *)
let additional_values = 2
let max_ephe_length = Sys.max_array_length - additional_values
external create : int -> t = "caml_ephe_create"
let create l =
if not (0 <= l && l <= max_ephe_length) then
invalid_arg "Obj.Ephemeron.create";
create l
let length x = size(repr x) - additional_values
let raise_if_invalid_offset e o msg =
if not (0 <= o && o < length e) then
invalid_arg msg
external get_key: t -> int -> obj_t option = "caml_ephe_get_key"
let get_key e o =
raise_if_invalid_offset e o "Obj.Ephemeron.get_key";
get_key e o
external get_key_copy: t -> int -> obj_t option = "caml_ephe_get_key_copy"
let get_key_copy e o =
raise_if_invalid_offset e o "Obj.Ephemeron.get_key_copy";
get_key_copy e o
external set_key: t -> int -> obj_t -> unit = "caml_ephe_set_key"
let set_key e o x =
raise_if_invalid_offset e o "Obj.Ephemeron.set_key";
set_key e o x
external unset_key: t -> int -> unit = "caml_ephe_unset_key"
let unset_key e o =
raise_if_invalid_offset e o "Obj.Ephemeron.unset_key";
unset_key e o
external check_key: t -> int -> bool = "caml_ephe_check_key"
let check_key e o =
raise_if_invalid_offset e o "Obj.Ephemeron.check_key";
check_key e o
external blit_key : t -> int -> t -> int -> int -> unit
= "caml_ephe_blit_key"
let blit_key e1 o1 e2 o2 l =
if l < 0 || o1 < 0 || o1 > length e1 - l
|| o2 < 0 || o2 > length e2 - l
then invalid_arg "Obj.Ephemeron.blit_key"
else if l <> 0 then blit_key e1 o1 e2 o2 l
external get_data: t -> obj_t option = "caml_ephe_get_data"
external get_data_copy: t -> obj_t option = "caml_ephe_get_data_copy"
external set_data: t -> obj_t -> unit = "caml_ephe_set_data"
external unset_data: t -> unit = "caml_ephe_unset_data"
external check_data: t -> bool = "caml_ephe_check_data"
external blit_data : t -> t -> unit = "caml_ephe_blit_data"
end