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
|
--- hash_compat.c.orig 2024-02-06 20:29:47 UTC
+++ hash_compat.c
@@ -0,0 +1,165 @@
+/* The pre-OCaml 4.00 hash implementation */
+/* FIXME: This is included for backwards compatibility only and must be
+ * REMOVED when a new hash function included in a stable release has been
+ * available for a few years. The removal of this function will break
+ * Unison version compatibility. There must be plenty of time given
+ * for users to upgrade (most users don't compile themselves and are at
+ * mercy of whatever package repositories they use). */
+
+/* Code copied from OCaml sources */
+/**************************************************************************/
+/* */
+/* 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. */
+/* */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/custom.h>
+#include <caml/address_class.h>
+
+struct hash_state {
+ uintnat accu;
+ intnat univ_limit, univ_count;
+};
+
+static void hash_aux(struct hash_state*, value obj);
+
+CAMLprim value unsn_hash_univ_param(value count, value limit, value obj)
+{
+ struct hash_state h;
+ h.univ_limit = Long_val(limit);
+ h.univ_count = Long_val(count);
+ h.accu = 0;
+ hash_aux(&h, obj);
+ return Val_long(h.accu & 0x3FFFFFFF);
+ /* The & has two purposes: ensure that the return value is positive
+ and give the same result on 32 bit and 64 bit architectures. */
+}
+
+#define Alpha 65599
+#define Beta 19
+#define Combine(new) (h->accu = h->accu * Alpha + (new))
+#define Combine_small(new) (h->accu = h->accu * Beta + (new))
+
+static void hash_aux(struct hash_state* h, value obj)
+{
+ unsigned char * p;
+ mlsize_t i, j;
+ tag_t tag;
+
+ h->univ_limit--;
+ if (h->univ_count < 0 || h->univ_limit < 0) return;
+
+ again:
+ if (Is_long(obj)) {
+ h->univ_count--;
+ Combine(Long_val(obj));
+ return;
+ }
+ if (! Is_in_value_area(obj)) {
+ /* obj is a pointer outside the heap, to an object with
+ a priori unknown structure. Use its physical address as hash key. */
+ Combine((intnat) obj);
+ return;
+ }
+ /* Pointers into the heap are well-structured blocks. So are atoms.
+ We can inspect the block contents. */
+ /* The code needs reindenting later. Leaving as is to facilitate review. */
+ tag = Tag_val(obj);
+ switch (tag) {
+ case String_tag:
+ h->univ_count--;
+ i = caml_string_length(obj);
+ for (p = &Byte_u(obj, 0); i > 0; i--, p++)
+ Combine_small(*p);
+ break;
+ case Double_tag:
+ /* For doubles, we inspect their binary representation, LSB first.
+ The results are consistent among all platforms with IEEE floats. */
+ h->univ_count--;
+#ifdef ARCH_BIG_ENDIAN
+ for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
+ i > 0;
+ p--, i--)
+#else
+ for (p = &Byte_u(obj, 0), i = sizeof(double);
+ i > 0;
+ p++, i--)
+#endif
+ Combine_small(*p);
+ break;
+ case Double_array_tag:
+ h->univ_count--;
+ for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
+#ifdef ARCH_BIG_ENDIAN
+ for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
+ i > 0;
+ p--, i--)
+#else
+ for (p = &Byte_u(obj, j), i = sizeof(double);
+ i > 0;
+ p++, i--)
+#endif
+ Combine_small(*p);
+ }
+ break;
+ case Abstract_tag:
+ /* We don't know anything about the contents of the block.
+ Better do nothing. */
+ break;
+ case Infix_tag:
+ hash_aux(h, obj - Infix_offset_val(obj));
+ break;
+ case Forward_tag:
+ obj = Forward_val (obj);
+ goto again;
+ case Object_tag:
+ h->univ_count--;
+ Combine(Oid_val(obj));
+ break;
+ case Custom_tag:
+ /* If no hashing function provided, do nothing */
+ if (Custom_ops_val(obj)->hash != NULL) {
+ h->univ_count--;
+ Combine(Custom_ops_val(obj)->hash(obj));
+ }
+ break;
+#ifdef NO_NAKED_POINTERS
+ case Closure_tag:
+ h->univ_count--;
+ Combine_small(tag);
+ /* Recursively hash the environment fields */
+ i = Wosize_val(obj);
+ j = Start_env_closinfo(Closinfo_val(obj));
+ while (i > j) {
+ i--;
+ hash_aux(h, Field(obj, i));
+ }
+ /* Combine the code pointers, closure info fields, and infix headers */
+ while (i > 0) {
+ i--;
+ Combine(Field(obj, i));
+ h->univ_count--;
+ }
+ break;
+#endif
+ default:
+ h->univ_count--;
+ Combine_small(tag);
+ i = Wosize_val(obj);
+ while (i != 0) {
+ i--;
+ hash_aux(h, Field(obj, i));
+ }
+ break;
+ }
+}
|
