blob: 32049d72b3af977678ba50e19fd55726bf3a3e61 (
plain)
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
|
(**************************************************************************)
(* *)
(* 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
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"
external set_tag : t -> int -> unit = "caml_obj_set_tag"
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 new_block : int -> int -> t = "caml_obj_block"
external dup : t -> t = "caml_obj_dup"
external truncate : t -> int -> unit = "caml_obj_truncate"
external add_offset : t -> Int32.t -> t = "caml_obj_add_offset"
external with_tag : int -> t -> t = "caml_obj_with_tag"
let marshal (obj : t) =
Marshal.to_bytes obj []
let unmarshal str pos =
(Marshal.from_bytes str pos, pos + Marshal.total_size str pos)
let first_non_constant_constructor_tag = 0
let last_non_constant_constructor_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 final_tag = custom_tag
let int_tag = 1000
let out_of_heap_tag = 1001
let unaligned_tag = 1002
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
let extension_constructor = Extension_constructor.of_val
let extension_name = Extension_constructor.name
let extension_id = Extension_constructor.id
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
|
