Branch data Line data Source code
1 : : #define BOUNDED_COMPARE_BOUND 4096
2 : : #define BOUNDED_HASH_BOUND 16384
3 : :
4 : : // comparable tag
5 : : #define cmptag(v) (isfixnum(v) ? TAG_NUM : tag(v))
6 : :
7 : 0 : static value_t eq_class(fl_context_t *fl_ctx, htable_t *table, value_t key)
8 : : {
9 : 0 : value_t c = (value_t)ptrhash_get(table, (void*)key);
10 [ # # ]: 0 : if (c == (value_t)HT_NOTFOUND)
11 : 0 : return fl_ctx->NIL;
12 [ # # ]: 0 : if (c == key)
13 : 0 : return c;
14 : 0 : return eq_class(fl_ctx, table, c);
15 : : }
16 : :
17 : 0 : static void eq_union(fl_context_t *fl_ctx, htable_t *table, value_t a,
18 : : value_t b, value_t c, value_t cb)
19 : : {
20 [ # # ]: 0 : value_t ca = (c==fl_ctx->NIL ? a : c);
21 [ # # ]: 0 : if (cb != fl_ctx->NIL)
22 : 0 : ptrhash_put(table, (void*)cb, (void*)ca);
23 : 0 : ptrhash_put(table, (void*)a, (void*)ca);
24 : 0 : ptrhash_put(table, (void*)b, (void*)ca);
25 : 0 : }
26 : :
27 : : static value_t bounded_compare(fl_context_t *fl_ctx, value_t a, value_t b, int bound, int eq);
28 : : static value_t cyc_compare(fl_context_t *fl_ctx, value_t a, value_t b, htable_t *table, int eq);
29 : :
30 : 0 : static value_t bounded_vector_compare(fl_context_t *fl_ctx, value_t a, value_t b, int bound, int eq)
31 : : {
32 : 0 : size_t la = vector_size(a);
33 : 0 : size_t lb = vector_size(b);
34 : : size_t m, i;
35 [ # # # # ]: 0 : if (eq && (la!=lb)) return fixnum(1);
36 : 0 : m = la < lb ? la : lb;
37 [ # # ]: 0 : for (i = 0; i < m; i++) {
38 : 0 : value_t d = bounded_compare(fl_ctx, vector_elt(a,i), vector_elt(b,i),
39 : : bound-1, eq);
40 [ # # # # ]: 0 : if (d==fl_ctx->NIL || numval(d)!=0) return d;
41 : : }
42 [ # # ]: 0 : if (la < lb) return fixnum(-1);
43 [ # # ]: 0 : if (la > lb) return fixnum(1);
44 : 0 : return fixnum(0);
45 : : }
46 : :
47 : : // strange comparisons are resolved arbitrarily but consistently.
48 : : // ordering: number < cprim < function < vector < cvalue < symbol < cons
49 : 298750000 : static value_t bounded_compare(fl_context_t *fl_ctx, value_t a, value_t b, int bound, int eq)
50 : : {
51 : : value_t d;
52 : :
53 : 298750000 : compare_top:
54 [ + + ]: 298750000 : if (a == b) return fixnum(0);
55 [ - + ]: 296114000 : if (bound <= 0)
56 : 0 : return fl_ctx->NIL;
57 : 296114000 : int taga = tag(a);
58 [ + + ]: 296114000 : int tagb = cmptag(b);
59 : : int c;
60 [ + + - + : 296114000 : switch (taga) {
+ + + - ]
61 : 1019900 : case TAG_NUM :
62 : : case TAG_NUM1:
63 [ + + ]: 1019900 : if (isfixnum(b)) {
64 [ + + ]: 332062 : return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
65 : : }
66 [ + + ]: 687838 : if (iscprim(b)) {
67 [ + - ]: 672382 : if (cp_class((cprim_t*)ptr(b)) == fl_ctx->wchartype)
68 : 672382 : return fixnum(1);
69 : 0 : return fixnum(numeric_compare(fl_ctx, a, b, eq, 1, NULL));
70 : : }
71 : 15456 : return fixnum(-1);
72 : 123711000 : case TAG_SYM:
73 [ + + ]: 123711000 : if (eq) return fixnum(1);
74 [ - + ]: 32 : if (tagb < TAG_SYM) return fixnum(1);
75 [ - + ]: 32 : if (tagb > TAG_SYM) return fixnum(-1);
76 : 32 : return fixnum(strcmp(symbol_name(fl_ctx, a), symbol_name(fl_ctx, b)));
77 : 0 : case TAG_VECTOR:
78 [ # # ]: 0 : if (isvector(b))
79 : 0 : return bounded_vector_compare(fl_ctx, a, b, bound, eq);
80 : 0 : break;
81 : 163072200 : case TAG_CPRIM:
82 [ + + ]: 163072200 : if (cp_class((cprim_t*)ptr(a)) == fl_ctx->wchartype) {
83 [ + + + + ]: 162874400 : if (!iscprim(b) || cp_class((cprim_t*)ptr(b)) != fl_ctx->wchartype)
84 : 13623820 : return fixnum(-1);
85 : : }
86 [ + + + + ]: 197802 : else if (iscprim(b) && cp_class((cprim_t*)ptr(b)) == fl_ctx->wchartype) {
87 : 89392 : return fixnum(1);
88 : : }
89 : 149359000 : c = numeric_compare(fl_ctx, a, b, eq, 1, NULL);
90 [ + + ]: 149359000 : if (c != 2)
91 : 149352400 : return fixnum(c);
92 : 6566 : break;
93 : 387214 : case TAG_CVALUE:
94 [ + + ]: 387214 : if (iscvalue(b)) {
95 [ + - + - ]: 235660 : if (cv_isPOD((cvalue_t*)ptr(a)) && cv_isPOD((cvalue_t*)ptr(b)))
96 : 235660 : return cvalue_compare(a, b);
97 : 0 : return fixnum(1);
98 : : }
99 : 151554 : break;
100 : 144686 : case TAG_FUNCTION:
101 [ - + ]: 144686 : if (tagb == TAG_FUNCTION) {
102 [ # # # # ]: 0 : if (uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS) {
103 : 0 : function_t *fa = (function_t*)ptr(a);
104 : 0 : function_t *fb = (function_t*)ptr(b);
105 : 0 : d = bounded_compare(fl_ctx, fa->bcode, fb->bcode, bound-1, eq);
106 [ # # # # ]: 0 : if (d==fl_ctx->NIL || numval(d) != 0) return d;
107 : 0 : d = bounded_compare(fl_ctx, fa->vals, fb->vals, bound-1, eq);
108 [ # # # # ]: 0 : if (d==fl_ctx->NIL || numval(d) != 0) return d;
109 : 0 : d = bounded_compare(fl_ctx, fa->env, fb->env, bound-1, eq);
110 [ # # # # ]: 0 : if (d==fl_ctx->NIL || numval(d) != 0) return d;
111 : 0 : return fixnum(0);
112 : : }
113 [ # # ]: 0 : return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
114 : : }
115 : 144686 : break;
116 : 7778200 : case TAG_CONS:
117 [ + + ]: 7778200 : if (tagb < TAG_CONS) return fixnum(1);
118 : 4380060 : d = bounded_compare(fl_ctx, car_(a), car_(b), bound-1, eq);
119 [ + - + + ]: 4380060 : if (d==fl_ctx->NIL || numval(d) != 0) return d;
120 : 1792522 : a = cdr_(a); b = cdr_(b);
121 : 1792522 : bound--;
122 : 1792522 : goto compare_top;
123 : : }
124 [ + + ]: 302806 : return (taga < tagb) ? fixnum(-1) : fixnum(1);
125 : : }
126 : :
127 : 0 : static value_t cyc_vector_compare(fl_context_t *fl_ctx, value_t a,
128 : : value_t b, htable_t *table, int eq)
129 : : {
130 : 0 : size_t la = vector_size(a);
131 : 0 : size_t lb = vector_size(b);
132 : : size_t m, i;
133 : : value_t d, xa, xb, ca, cb;
134 : :
135 : : // first try to prove them different with no recursion
136 [ # # # # ]: 0 : if (eq && (la!=lb)) return fixnum(1);
137 : 0 : m = la < lb ? la : lb;
138 [ # # ]: 0 : for (i = 0; i < m; i++) {
139 : 0 : xa = vector_elt(a,i);
140 : 0 : xb = vector_elt(b,i);
141 [ # # # # ]: 0 : if (leafp(xa) || leafp(xb)) {
142 : 0 : d = bounded_compare(fl_ctx, xa, xb, 1, eq);
143 [ # # # # ]: 0 : if (d!=fl_ctx->NIL && numval(d)!=0) return d;
144 : : }
145 [ # # ]: 0 : else if (tag(xa) < tag(xb)) {
146 : 0 : return fixnum(-1);
147 : : }
148 [ # # ]: 0 : else if (tag(xa) > tag(xb)) {
149 : 0 : return fixnum(1);
150 : : }
151 : : }
152 : :
153 : 0 : ca = eq_class(fl_ctx, table, a);
154 : 0 : cb = eq_class(fl_ctx, table, b);
155 [ # # # # ]: 0 : if (ca!=fl_ctx->NIL && ca==cb)
156 : 0 : return fixnum(0);
157 : :
158 : 0 : eq_union(fl_ctx, table, a, b, ca, cb);
159 : :
160 [ # # ]: 0 : for (i = 0; i < m; i++) {
161 : 0 : xa = vector_elt(a,i);
162 : 0 : xb = vector_elt(b,i);
163 [ # # # # ]: 0 : if (!leafp(xa) || tag(xa)==TAG_FUNCTION) {
164 : 0 : d = cyc_compare(fl_ctx, xa, xb, table, eq);
165 [ # # ]: 0 : if (numval(d)!=0)
166 : 0 : return d;
167 : : }
168 : : }
169 : :
170 [ # # ]: 0 : if (la < lb) return fixnum(-1);
171 [ # # ]: 0 : if (la > lb) return fixnum(1);
172 : 0 : return fixnum(0);
173 : : }
174 : :
175 : 0 : static value_t cyc_compare(fl_context_t *fl_ctx, value_t a, value_t b, htable_t *table, int eq)
176 : : {
177 : : value_t d, ca, cb;
178 : 0 : cyc_compare_top:
179 [ # # ]: 0 : if (a==b)
180 : 0 : return fixnum(0);
181 [ # # ]: 0 : if (iscons(a)) {
182 [ # # ]: 0 : if (iscons(b)) {
183 : 0 : value_t aa = car_(a); value_t da = cdr_(a);
184 : 0 : value_t ab = car_(b); value_t db = cdr_(b);
185 : 0 : int tagaa = tag(aa); int tagda = tag(da);
186 : 0 : int tagab = tag(ab); int tagdb = tag(db);
187 [ # # # # ]: 0 : if (leafp(aa) || leafp(ab)) {
188 : 0 : d = bounded_compare(fl_ctx, aa, ab, 1, eq);
189 [ # # # # ]: 0 : if (d!=fl_ctx->NIL && numval(d)!=0) return d;
190 : : }
191 [ # # ]: 0 : else if (tagaa < tagab)
192 : 0 : return fixnum(-1);
193 [ # # ]: 0 : else if (tagaa > tagab)
194 : 0 : return fixnum(1);
195 [ # # # # ]: 0 : if (leafp(da) || leafp(db)) {
196 : 0 : d = bounded_compare(fl_ctx, da, db, 1, eq);
197 [ # # # # ]: 0 : if (d!=fl_ctx->NIL && numval(d)!=0) return d;
198 : : }
199 [ # # ]: 0 : else if (tagda < tagdb)
200 : 0 : return fixnum(-1);
201 [ # # ]: 0 : else if (tagda > tagdb)
202 : 0 : return fixnum(1);
203 : :
204 : 0 : ca = eq_class(fl_ctx, table, a);
205 : 0 : cb = eq_class(fl_ctx, table, b);
206 [ # # # # ]: 0 : if (ca!=fl_ctx->NIL && ca==cb)
207 : 0 : return fixnum(0);
208 : :
209 : 0 : eq_union(fl_ctx, table, a, b, ca, cb);
210 : 0 : d = cyc_compare(fl_ctx, aa, ab, table, eq);
211 [ # # ]: 0 : if (numval(d)!=0) return d;
212 : 0 : a = da;
213 : 0 : b = db;
214 : 0 : goto cyc_compare_top;
215 : : }
216 : : else {
217 : 0 : return fixnum(1);
218 : : }
219 : : }
220 [ # # # # ]: 0 : else if (isvector(a) && isvector(b)) {
221 : 0 : return cyc_vector_compare(fl_ctx, a, b, table, eq);
222 : : }
223 [ # # # # : 0 : else if (isclosure(a) && isclosure(b)) {
# # # # ]
224 : 0 : function_t *fa = (function_t*)ptr(a);
225 : 0 : function_t *fb = (function_t*)ptr(b);
226 : 0 : d = bounded_compare(fl_ctx, fa->bcode, fb->bcode, 1, eq);
227 [ # # ]: 0 : if (numval(d) != 0) return d;
228 : :
229 : 0 : ca = eq_class(fl_ctx, table, a);
230 : 0 : cb = eq_class(fl_ctx, table, b);
231 [ # # # # ]: 0 : if (ca!=fl_ctx->NIL && ca==cb)
232 : 0 : return fixnum(0);
233 : :
234 : 0 : eq_union(fl_ctx, table, a, b, ca, cb);
235 : 0 : d = cyc_compare(fl_ctx, fa->vals, fb->vals, table, eq);
236 [ # # ]: 0 : if (numval(d) != 0) return d;
237 : 0 : a = fa->env;
238 : 0 : b = fb->env;
239 : 0 : goto cyc_compare_top;
240 : : }
241 : 0 : return bounded_compare(fl_ctx, a, b, 1, eq);
242 : : }
243 : :
244 : 30 : void comparehash_init(fl_context_t *fl_ctx)
245 : : {
246 : 30 : htable_new(&fl_ctx->equal_eq_hashtable, 512);
247 : 30 : }
248 : :
249 : : // 'eq' means unordered comparison is sufficient
250 : 292576000 : static value_t compare_(fl_context_t *fl_ctx, value_t a, value_t b, int eq)
251 : : {
252 : 292576000 : value_t guess = bounded_compare(fl_ctx, a, b, BOUNDED_COMPARE_BOUND, eq);
253 [ - + ]: 292576000 : if (guess == fl_ctx->NIL) {
254 : 0 : guess = cyc_compare(fl_ctx, a, b, &fl_ctx->equal_eq_hashtable, eq);
255 : 0 : htable_reset(&fl_ctx->equal_eq_hashtable, 512);
256 : : }
257 : 292576000 : return guess;
258 : : }
259 : :
260 : 530386 : value_t fl_compare(fl_context_t *fl_ctx, value_t a, value_t b)
261 : : {
262 : 530386 : return compare_(fl_ctx, a, b, 0);
263 : : }
264 : :
265 : 0 : value_t fl_equal(fl_context_t *fl_ctx, value_t a, value_t b)
266 : : {
267 [ # # ]: 0 : if (eq_comparable(a, b))
268 [ # # ]: 0 : return (a == b) ? fl_ctx->T : fl_ctx->F;
269 [ # # ]: 0 : return (numval(compare_(fl_ctx, a,b,1))==0 ? fl_ctx->T : fl_ctx->F);
270 : : }
271 : :
272 : : /*
273 : : optimizations:
274 : : - use hash updates instead of calling lookup then insert. i.e. get the
275 : : bp once and use it twice.
276 : : * preallocate hash table and call reset() instead of new/free
277 : : * less redundant tag checking, 3-bit tags
278 : : */
279 : :
280 : : #ifdef _P64
281 : : #define MIX(a, b) int64hash((int64_t)(a) ^ (int64_t)(b));
282 : : #define doublehash(a) int64hash(a)
283 : : #else
284 : : #define MIX(a, b) int64to32hash(((int64_t)(a))<<32 | ((int64_t)(b)))
285 : : #define doublehash(a) int64to32hash(a)
286 : : #endif
287 : :
288 : : // *oob: output argument, means we hit the limit specified by 'bound'
289 : 81541400 : static uintptr_t bounded_hash(fl_context_t *fl_ctx, value_t a, int bound, int *oob)
290 : : {
291 : 81541400 : *oob = 0;
292 : : union {
293 : : double d;
294 : : int64_t i64;
295 : : } u;
296 : : numerictype_t nt;
297 : : size_t i, len;
298 : : cvalue_t *cv;
299 : : cprim_t *cp;
300 : : void *data;
301 : 81541400 : uintptr_t h = 0;
302 : 81541400 : int oob2, tg = tag(a);
303 [ + + + + : 81541400 : switch(tg) {
+ - + - ]
304 : 8116720 : case TAG_NUM :
305 : : case TAG_NUM1:
306 : 8116720 : u.d = (double)numval(a);
307 : 8116720 : return doublehash(u.i64);
308 : 6358460 : case TAG_FUNCTION:
309 [ - + ]: 6358460 : if (uintval(a) > N_BUILTINS)
310 : 0 : return bounded_hash(fl_ctx, ((function_t*)ptr(a))->bcode, bound, oob);
311 : 6358460 : return inthash(a);
312 : 50348400 : case TAG_SYM:
313 : 50348400 : return ((symbol_t*)ptr(a))->hash;
314 : 10240260 : case TAG_CPRIM:
315 : 10240260 : cp = (cprim_t*)ptr(a);
316 : 10240260 : data = cp_data(cp);
317 [ + + ]: 10240260 : if (cp_class(cp) == fl_ctx->wchartype)
318 : 10228900 : return inthash(*(int32_t*)data);
319 : 11346 : nt = cp_numtype(cp);
320 : 11346 : u.d = conv_to_double(data, nt);
321 : 11346 : return doublehash(u.i64);
322 : 187956 : case TAG_CVALUE:
323 : 187956 : cv = (cvalue_t*)ptr(a);
324 : 187956 : data = cv_data(cv);
325 : 187956 : return memhash((char*)data, cv_len(cv));
326 : :
327 : 0 : case TAG_VECTOR:
328 [ # # ]: 0 : if (bound <= 0) {
329 : 0 : *oob = 1;
330 : 0 : return 1;
331 : : }
332 : 0 : len = vector_size(a);
333 [ # # ]: 0 : for(i=0; i < len; i++) {
334 : 0 : h = MIX(h, bounded_hash(fl_ctx, vector_elt(a,i), bound/2, &oob2)^1);
335 [ # # ]: 0 : if (oob2)
336 : 0 : bound/=2;
337 [ # # # # ]: 0 : *oob = *oob || oob2;
338 : : }
339 : 0 : return h;
340 : :
341 : 6498660 : case TAG_CONS:
342 : : do {
343 [ + + ]: 12788380 : if (bound <= 0) {
344 : 48 : *oob = 1;
345 : 48 : return h;
346 : : }
347 : 12788320 : h = MIX(h, bounded_hash(fl_ctx, car_(a), bound/2, &oob2));
348 : : // bounds balancing: try to share the bounds efficiently
349 : : // so we can hash better when a list is cdr-deep (a common case)
350 [ + + ]: 12788320 : if (oob2)
351 : 140 : bound/=2;
352 : : else
353 : 12788180 : bound--;
354 : : // recursive OOB propagation. otherwise this case is slow:
355 : : // (hash '#2=((#0=(#1=(#1#) . #0#)) . #2#))
356 [ + + + + ]: 12788320 : *oob = *oob || oob2;
357 : 12788320 : a = cdr_(a);
358 [ + + ]: 12788320 : } while (iscons(a));
359 : 6289660 : h = MIX(h, bounded_hash(fl_ctx, a, bound-1, &oob2)^2);
360 [ + + - + ]: 6289660 : *oob = *oob || oob2;
361 : 6289660 : return h;
362 : : }
363 : 0 : return 0;
364 : : }
365 : :
366 : 62526000 : int equal_lispvalue(fl_context_t *fl_ctx, value_t a, value_t b)
367 : : {
368 [ + + ]: 62526000 : if (eq_comparable(a, b))
369 : 48968800 : return (a==b);
370 : 13557160 : return (numval(compare_(fl_ctx, a, b, 1))==0);
371 : : }
372 : :
373 : 62463400 : uintptr_t hash_lispvalue(fl_context_t *fl_ctx, value_t a)
374 : : {
375 : 62463400 : int oob = 0;
376 : 62463400 : uintptr_t n = bounded_hash(fl_ctx, a, BOUNDED_HASH_BOUND, &oob);
377 : 62463400 : return n;
378 : : }
379 : :
380 : 0 : value_t fl_hash(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
381 : : {
382 : 0 : argcount(fl_ctx, "hash", nargs, 1);
383 : 0 : return fixnum(hash_lispvalue(fl_ctx, args[0]));
384 : : }
|
