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
|
/**************************************************************************/
/* */
/* OCaml */
/* */
/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */
/* */
/* Copyright 2000 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. */
/* */
/**************************************************************************/
#define CAML_INTERNALS
#include <string.h>
#include "caml/alloc.h"
#include "caml/custom.h"
#include "caml/fail.h"
#include "caml/memory.h"
#include "caml/mlvalues.h"
#include "caml/signals.h"
/* [size] is a number of bytes */
CAMLexport value caml_alloc_custom(struct custom_operations * ops,
uintnat size,
mlsize_t mem,
mlsize_t max)
{
mlsize_t wosize;
CAMLparam0();
CAMLlocal1(result);
wosize = 1 + (size + sizeof(value) - 1) / sizeof(value);
if (wosize <= Max_young_wosize) {
result = caml_alloc_small(wosize, Custom_tag);
Custom_ops_val(result) = ops;
if (ops->finalize != NULL || mem != 0) {
/* Remember that the block needs processing after minor GC. */
add_to_custom_table (&caml_custom_table, result, mem, max);
/* Keep track of extra resources held by custom block in
minor heap. */
if (mem != 0) {
if (max == 0) max = 1;
caml_extra_heap_resources_minor += (double) mem / (double) max;
if (caml_extra_heap_resources_minor > 1.0) {
caml_request_minor_gc ();
caml_gc_dispatch ();
}
}
}
} else {
result = caml_alloc_shr(wosize, Custom_tag);
Custom_ops_val(result) = ops;
caml_adjust_gc_speed(mem, max);
result = caml_check_urgent_gc(result);
}
CAMLreturn(result);
}
struct custom_operations_list {
struct custom_operations * ops;
struct custom_operations_list * next;
};
static struct custom_operations_list * custom_ops_table = NULL;
CAMLexport void caml_register_custom_operations(struct custom_operations * ops)
{
struct custom_operations_list * l =
caml_stat_alloc(sizeof(struct custom_operations_list));
CAMLassert(ops->identifier != NULL);
CAMLassert(ops->deserialize != NULL);
l->ops = ops;
l->next = custom_ops_table;
custom_ops_table = l;
}
struct custom_operations * caml_find_custom_operations(char * ident)
{
struct custom_operations_list * l;
for (l = custom_ops_table; l != NULL; l = l->next)
if (strcmp(l->ops->identifier, ident) == 0) return l->ops;
return NULL;
}
static struct custom_operations_list * custom_ops_final_table = NULL;
struct custom_operations * caml_final_custom_operations(final_fun fn)
{
struct custom_operations_list * l;
struct custom_operations * ops;
for (l = custom_ops_final_table; l != NULL; l = l->next)
if (l->ops->finalize == fn) return l->ops;
ops = caml_stat_alloc(sizeof(struct custom_operations));
ops->identifier = "_final";
ops->finalize = fn;
ops->compare = custom_compare_default;
ops->hash = custom_hash_default;
ops->serialize = custom_serialize_default;
ops->deserialize = custom_deserialize_default;
ops->compare_ext = custom_compare_ext_default;
l = caml_stat_alloc(sizeof(struct custom_operations_list));
l->ops = ops;
l->next = custom_ops_final_table;
custom_ops_final_table = l;
return ops;
}
extern struct custom_operations caml_int32_ops,
caml_nativeint_ops,
caml_int64_ops,
caml_ba_ops;
void caml_init_custom_operations(void)
{
caml_register_custom_operations(&caml_int32_ops);
caml_register_custom_operations(&caml_nativeint_ops);
caml_register_custom_operations(&caml_int64_ops);
caml_register_custom_operations(&caml_ba_ops);
}
|
