Source file 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
(**************************************************************************)
(*                                                                        *)
(*                                 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 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