1 {
2 This file is part of the Free Pascal/NewPascal run time library.
3 Copyright (c) 2014 by Maciej Izak (hnb)
4 member of the NewPascal development team (http://newpascal.org)
5
6 Copyright(c) 2004-2018 DaThoX
7
8 It contains the generics collections library
9
10 See the file COPYING.FPC, included in this distribution,
11 for details about the copyright.
12
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
16
17 Acknowledgment
18
19 Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring
20 many new types and major refactoring of entire library.
21
22 Thanks to mORMot (http://synopse.info) project for the best implementations
23 of hashing functions like crc32c and xxHash32 :)
24
25 **********************************************************************}
26
27 unit Generics.Hashes;
28
29 {$MODE DELPHI}{$H+}
30 {$POINTERMATH ON}
31 {$MACRO ON}
32 {$COPERATORS ON}
33 {$OVERFLOWCHECKS OFF}
34 {$RANGECHECKS OFF}
35
36 interface
37
38 uses
39 Classes, SysUtils;
40
41 { Warning: the following set of macro code
42 that decides to use assembler or normal code
43 needs to stay after the _INTERFACE keyword
44 because FPC_PIC macro is only set after this keyword,
45 as it can be modified before by the global $PIC preprocessor directive.
46 Pierre Muller 2018/07/04 }
47
48 {$ifdef FPC_PIC}
49 {$define DISABLE_X86_CPUINTEL}
50 {$endif FPC_PIC}
51
52 {$if defined(OPENBSD) or defined(EMX) or defined(OS2)}
53 { These targets have old GNU assemblers that }
54 { do not support all instructions used in assembler code below }
55 {$define DISABLE_X86_CPUINTEL}
56 {$endif}
57
58 {$ifdef CPU64}
59 {$define PUREPASCAL}
60 {$ifdef CPUX64}
61 {$define CPUINTEL}
62 {$ASMMODE INTEL}
63 {$endif CPUX64}
64 {$else}
65 {$ifdef CPUX86}
66 {$ifndef DISABLE_X86_CPUINTEL}
67 {$define CPUINTEL}
68 {$ASMMODE INTEL}
69 {$else}
70 { Assembler code uses references to static
71 variables with are not PIC ready }
72 {$define PUREPASCAL}
73 {$endif}
74 {$else CPUX86}
75 {$define PUREPASCAL}
76 {$endif}
77 {$endif CPU64}
78
79 // Original version of Bob Jenkins Hash
80 // http://burtleburtle.net/bob/c/lookup3.c
HashWordnull81 function HashWord(
82 AKey: PLongWord; //* the key, an array of uint32_t values */
83 ALength: SizeInt; //* the length of the key, in uint32_ts */
84 AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */
85 procedure HashWord2 (
86 AKey: PLongWord; //* the key, an array of uint32_t values */
87 ALength: SizeInt; //* the length of the key, in uint32_ts */
88 var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */
89 var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */
90
HashLittlenull91 function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32;
92 procedure HashLittle2(
93 AKey: Pointer; //* the key to hash */
94 ALength: SizeInt; //* length of the key */
95 var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */
96 var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */
97
DelphiHashLittlenull98 function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32;
99 procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32);
100
fromnull101 // hash function from fstl
102 function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
103
104 // some other hashes
105 // http://stackoverflow.com/questions/14409466/simple-hash-functions
106 // http://www.partow.net/programming/hashfunctions/
107 // http://en.wikipedia.org/wiki/List_of_hash_functions
108 // http://www.cse.yorku.ca/~oz/hash.html
109
110 // https://code.google.com/p/hedgewars/source/browse/hedgewars/adler32.pas
Adler32null111 function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
sdbmnull112 function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
xxHash32null113 function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;{$IFNDEF CPUINTEL}inline;{$ENDIF}
114 // pure pascal implementation of xxHash32
xxHash32Pascalnull115 function xxHash32Pascal(crc: cardinal; P: Pointer; len: integer): cardinal;
116
117 type
rcnull118 THasher = function(crc: cardinal; buf: Pointer; len: cardinal): cardinal;
119
120 var
121 crc32c: THasher;
122 mORMotHasher: THasher;
123
124 implementation
125
SimpleChecksumHashnull126 function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
127 var
128 i: Integer;
129 ABuffer: PUInt8 absolute AKey;
130 begin
131 Result := 0;
132 for i := 0 to ALength - 1 do
133 Inc(Result,ABuffer[i]);
134 end;
135
Adler32null136 function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
137 const
138 MOD_ADLER = 65521;
139 var
140 ABuffer: PUInt8 absolute AKey;
141 a: UInt32 = 1;
142 b: UInt32 = 0;
143 n: Integer;
144 begin
145 for n := 0 to ALength -1 do
146 begin
147 a := (a + ABuffer[n]) mod MOD_ADLER;
148 b := (b + a) mod MOD_ADLER;
149 end;
150 Result := (b shl 16) or a;
151 end;
152
sdbmnull153 function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
154 var
155 c: PUInt8 absolute AKey;
156 i: Integer;
157 begin
158 Result := 0;
159 c := AKey;
160 for i := 0 to ALength - 1 do
161 begin
162 Result := c^ + (Result shl 6) + (Result shl 16) {%H-}- Result;
163 Inc(c);
164 end;
165 end;
166
167 { BobJenkinsHash }
168
169 {$define mix_abc :=
170 a -= c; a := a xor (((c)shl(4)) or ((c)shr(32-(4)))); c += b;
171 b -= a; b := b xor (((a)shl(6)) or ((a)shr(32-(6)))); a += c;
172 c -= b; c := c xor (((b)shl(8)) or ((b)shr(32-(8)))); b += a;
173 a -= c; a := a xor (((c)shl(16)) or ((c)shr(32-(16)))); c += b;
174 b -= a; b := b xor (((a)shl(19)) or ((a)shr(32-(19)))); a += c;
175 c -= b; c := c xor (((b)shl(4)) or ((b)shr(32-(4)))); b += a
176 }
177
178 {$define final_abc :=
179 c := c xor b; c -= (((b)shl(14)) or ((b)shr(32-(14))));
180 a := a xor c; a -= (((c)shl(11)) or ((c)shr(32-(11))));
181 b := b xor a; b -= (((a)shl(25)) or ((a)shr(32-(25))));
182 c := c xor b; c -= (((b)shl(16)) or ((b)shr(32-(16))));
183 a := a xor c; a -= (((c)shl(4)) or ((c)shr(32-(4))));
184 b := b xor a; b -= (((a)shl(14)) or ((a)shr(32-(14))));
185 c := c xor b; c -= (((b)shl(24)) or ((b)shr(32-(24))))
186 }
187
HashWordnull188 function HashWord(
189 AKey: PLongWord; //* the key, an array of uint32_t values */
190 ALength: SizeInt; //* the length of the key, in uint32_ts */
191 AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */
192 var
193 a,b,c: UInt32;
194 label
195 Case0, Case1, Case2, Case3;
196 begin
197 //* Set up the internal state */
198 a := $DEADBEEF + (UInt32(ALength) shl 2) + AInitVal;
199 b := a;
200 c := b;
201
202 //*------------------------------------------------- handle most of the key */
203 while ALength > 3 do
204 begin
205 a += AKey[0];
206 b += AKey[1];
207 c += AKey[2];
208 mix_abc;
209 ALength -= 3;
210 AKey += 3;
211 end;
212
213 //*------------------------------------------- handle the last 3 uint32_t's */
214 case ALength of //* all the case statements fall through */
215 3: goto Case3;
216 2: goto Case2;
217 1: goto Case1;
218 0: goto Case0;
219 end;
220 Case3: c+=AKey[2];
221 Case2: b+=AKey[1];
222 Case1: a+=AKey[0];
223 final_abc;
224 Case0: //* case 0: nothing left to add */
225 //*------------------------------------------------------ report the result */
226 Result := c;
227 end;
228
229 procedure HashWord2 (
230 AKey: PLongWord; //* the key, an array of uint32_t values */
231 ALength: SizeInt; //* the length of the key, in uint32_ts */
232 var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */
233 var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */
234 var
235 a,b,c: UInt32;
236 label
237 Case0, Case1, Case2, Case3;
238 begin
239 //* Set up the internal state */
240 a := $deadbeef + (UInt32(ALength shl 2)) + APrimaryHashAndInitVal;
241 b := a;
242 c := b;
243 c += ASecondaryHashAndInitVal;
244
245 //*------------------------------------------------- handle most of the key */
246 while ALength > 3 do
247 begin
248 a += AKey[0];
249 b += AKey[1];
250 c += AKey[2];
251 mix_abc;
252 ALength -= 3;
253 AKey += 3;
254 end;
255
256 //*------------------------------------------- handle the last 3 uint32_t's */
257 case ALength of //* all the case statements fall through */
258 3: goto Case3;
259 2: goto Case2;
260 1: goto Case1;
261 0: goto Case0;
262 end;
263 Case3: c+=AKey[2];
264 Case2: b+=AKey[1];
265 Case1: a+=AKey[0];
266 final_abc;
267 Case0: //* case 0: nothing left to add */
268 //*------------------------------------------------------ report the result */
269 APrimaryHashAndInitVal := c;
270 ASecondaryHashAndInitVal := b;
271 end;
272
HashLittlenull273 function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32;
274 var
275 a, b, c: UInt32;
276 u: record case byte of
277 0: (ptr: Pointer);
278 1: (i: PtrUint);
279 end absolute AKey;
280
281 k32: ^UInt32 absolute AKey;
282 k16: ^UInt16 absolute AKey;
283 k8: ^UInt8 absolute AKey;
284
285 label _10, _8, _6, _4, _2;
286 label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
287
288 begin
289 a := $DEADBEEF + UInt32(ALength) + AInitVal;
290 b := a;
291 c := b;
292
293 {$IFDEF ENDIAN_LITTLE}
294 if (u.i and $3) = 0 then
295 begin
296 while (ALength > 12) do
297 begin
298 a += k32[0];
299 b += k32[1];
300 c += k32[2];
301 mix_abc;
302 ALength -= 12;
303 k32 += 3;
304 end;
305
306 case ALength of
307 12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
308 11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
309 10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
310 9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
311 8 : begin b += k32[1]; a += k32[0]; end;
312 7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
313 6 : begin b += k32[1] and $ffff; a += k32[0]; end;
314 5 : begin b += k32[1] and $ff; a += k32[0]; end;
315 4 : begin a += k32[0]; end;
316 3 : begin a += k32[0] and $ffffff; end;
317 2 : begin a += k32[0] and $ffff; end;
318 1 : begin a += k32[0] and $ff; end;
319 0 : Exit(c); // zero length strings require no mixing
320 end
321 end
322 else
323 if (u.i and $1) = 0 then
324 begin
325 while (ALength > 12) do
326 begin
327 a += k16[0] + (UInt32(k16[1]) shl 16);
328 b += k16[2] + (UInt32(k16[3]) shl 16);
329 c += k16[4] + (UInt32(k16[5]) shl 16);
330 mix_abc;
331 ALength -= 12;
332 k16 += 6;
333 end;
334
335 case ALength of
336 12:
337 begin
338 c+=k16[4]+((UInt32(k16[5])) shl 16);
339 b+=k16[2]+((UInt32(k16[3])) shl 16);
340 a+=k16[0]+((UInt32(k16[1])) shl 16);
341 end;
342 11:
343 begin
344 c+=(UInt32(k8[10])) shl 16; //* fall through */
345 goto _10;
346 end;
347 10:
348 begin _10:
349 c+=k16[4];
350 b+=k16[2]+((UInt32(k16[3])) shl 16);
351 a+=k16[0]+((UInt32(k16[1])) shl 16);
352 end;
353 9 :
354 begin
355 c+=k8[8]; //* fall through */
356 goto _8;
357 end;
358 8 :
359 begin _8:
360 b+=k16[2]+((UInt32(k16[3])) shl 16);
361 a+=k16[0]+((UInt32(k16[1])) shl 16);
362 end;
363 7 :
364 begin
365 b+=(UInt32(k8[6])) shl 16; //* fall through */
366 goto _6;
367 end;
368 6 :
369 begin _6:
370 b+=k16[2];
371 a+=k16[0]+((UInt32(k16[1])) shl 16);
372 end;
373 5 :
374 begin
375 b+=k8[4]; //* fall through */
376 goto _4;
377 end;
378 4 :
379 begin _4:
380 a+=k16[0]+((UInt32(k16[1])) shl 16);
381 end;
382 3 :
383 begin
384 a+=(UInt32(k8[2])) shl 16; //* fall through */
385 goto _2;
386 end;
387 2 :
388 begin _2:
389 a+=k16[0];
390 end;
391 1 :
392 begin
393 a+=k8[0];
394 end;
395 0 : Exit(c); //* zero length requires no mixing */
396 end;
397 end
398 else
399 {$ENDIF}
400 begin
401 while ALength > 12 do
402 begin
403 a += k8[0];
404 a += (UInt32(k8[1])) shl 8;
405 a += (UInt32(k8[2])) shl 16;
406 a += (UInt32(k8[3])) shl 24;
407 b += k8[4];
408 b += (UInt32(k8[5])) shl 8;
409 b += (UInt32(k8[6])) shl 16;
410 b += (UInt32(k8[7])) shl 24;
411 c += k8[8];
412 c += (UInt32(k8[9])) shl 8;
413 c += (UInt32(k8[10])) shl 16;
414 c += (UInt32(k8[11])) shl 24;
415 mix_abc;
416 ALength -= 12;
417 k8 += 12;
418 end;
419
420 case ALength of
421 12: goto Case12;
422 11: goto Case11;
423 10: goto Case10;
424 9 : goto Case9;
425 8 : goto Case8;
426 7 : goto Case7;
427 6 : goto Case6;
428 5 : goto Case5;
429 4 : goto Case4;
430 3 : goto Case3;
431 2 : goto Case2;
432 1 : goto Case1;
433 0 : Exit(c);
434 end;
435
436 Case12: c+=(UInt32(k8[11])) shl 24;
437 Case11: c+=(UInt32(k8[10])) shl 16;
438 Case10: c+=(UInt32(k8[9])) shl 8;
439 Case9: c+=k8[8];
440 Case8: b+=(UInt32(k8[7])) shl 24;
441 Case7: b+=(UInt32(k8[6])) shl 16;
442 Case6: b+=(UInt32(k8[5])) shl 8;
443 Case5: b+=k8[4];
444 Case4: a+=(UInt32(k8[3])) shl 24;
445 Case3: a+=(UInt32(k8[2])) shl 16;
446 Case2: a+=(UInt32(k8[1])) shl 8;
447 Case1: a+=k8[0];
448 end;
449
450 final_abc;
451 Result := c;
452 end;
453
454 (*
455 * hashlittle2: return 2 32-bit hash values
456 *
457 * This is identical to hashlittle(), except it returns two 32-bit hash
458 * values instead of just one. This is good enough for hash table
459 * lookup with 2^^64 buckets, or if you want a second hash if you're not
460 * happy with the first, or if you want a probably-unique 64-bit ID for
461 * the key. *pc is better mixed than *pb, so use *pc first. If you want
462 * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)".
463 *)
464 procedure HashLittle2(
465 AKey: Pointer; //* the key to hash */
466 ALength: SizeInt; //* length of the key */
467 var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */
468 var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */
469 var
470 a,b,c: UInt32;
471 u: record case byte of
472 0: (ptr: Pointer);
473 1: (i: PtrUint);
474 end absolute AKey;
475
476 k32: ^UInt32 absolute AKey;
477 k16: ^UInt16 absolute AKey;
478 k8: ^UInt8 absolute AKey;
479
480 label _10, _8, _6, _4, _2;
481 label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
482
483 begin
484 //* Set up the internal state */
485 a := $DEADBEEF + UInt32(ALength) + APrimaryHashAndInitVal;
486 b := a;
487 c := b;
488 c += ASecondaryHashAndInitVal;
489
490 {$IFDEF ENDIAN_LITTLE}
491 if (u.i and $3) = 0 then
492 begin
493 while (ALength > 12) do
494 begin
495 a += k32[0];
496 b += k32[1];
497 c += k32[2];
498 mix_abc;
499 ALength -= 12;
500 k32 += 3;
501 end;
502
503 case ALength of
504 12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
505 11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
506 10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
507 9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
508 8 : begin b += k32[1]; a += k32[0]; end;
509 7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
510 6 : begin b += k32[1] and $ffff; a += k32[0]; end;
511 5 : begin b += k32[1] and $ff; a += k32[0]; end;
512 4 : begin a += k32[0]; end;
513 3 : begin a += k32[0] and $ffffff; end;
514 2 : begin a += k32[0] and $ffff; end;
515 1 : begin a += k32[0] and $ff; end;
516 0 :
517 begin
518 APrimaryHashAndInitVal := c;
519 ASecondaryHashAndInitVal := b;
520 Exit; // zero length strings require no mixing
521 end;
522 end
523 end
524 else
525 if (u.i and $1) = 0 then
526 begin
527 while (ALength > 12) do
528 begin
529 a += k16[0] + (UInt32(k16[1]) shl 16);
530 b += k16[2] + (UInt32(k16[3]) shl 16);
531 c += k16[4] + (UInt32(k16[5]) shl 16);
532 mix_abc;
533 ALength -= 12;
534 k16 += 6;
535 end;
536
537 case ALength of
538 12:
539 begin
540 c+=k16[4]+((UInt32(k16[5])) shl 16);
541 b+=k16[2]+((UInt32(k16[3])) shl 16);
542 a+=k16[0]+((UInt32(k16[1])) shl 16);
543 end;
544 11:
545 begin
546 c+=(UInt32(k8[10])) shl 16; //* fall through */
547 goto _10;
548 end;
549 10:
550 begin _10:
551 c+=k16[4];
552 b+=k16[2]+((UInt32(k16[3])) shl 16);
553 a+=k16[0]+((UInt32(k16[1])) shl 16);
554 end;
555 9 :
556 begin
557 c+=k8[8]; //* fall through */
558 goto _8;
559 end;
560 8 :
561 begin _8:
562 b+=k16[2]+((UInt32(k16[3])) shl 16);
563 a+=k16[0]+((UInt32(k16[1])) shl 16);
564 end;
565 7 :
566 begin
567 b+=(UInt32(k8[6])) shl 16; //* fall through */
568 goto _6;
569 end;
570 6 :
571 begin _6:
572 b+=k16[2];
573 a+=k16[0]+((UInt32(k16[1])) shl 16);
574 end;
575 5 :
576 begin
577 b+=k8[4]; //* fall through */
578 goto _4;
579 end;
580 4 :
581 begin _4:
582 a+=k16[0]+((UInt32(k16[1])) shl 16);
583 end;
584 3 :
585 begin
586 a+=(UInt32(k8[2])) shl 16; //* fall through */
587 goto _2;
588 end;
589 2 :
590 begin _2:
591 a+=k16[0];
592 end;
593 1 :
594 begin
595 a+=k8[0];
596 end;
597 0 :
598 begin
599 APrimaryHashAndInitVal := c;
600 ASecondaryHashAndInitVal := b;
601 Exit; // zero length strings require no mixing
602 end;
603 end;
604 end
605 else
606 {$ENDIF}
607 begin
608 while ALength > 12 do
609 begin
610 a += k8[0];
611 a += (UInt32(k8[1])) shl 8;
612 a += (UInt32(k8[2])) shl 16;
613 a += (UInt32(k8[3])) shl 24;
614 b += k8[4];
615 b += (UInt32(k8[5])) shl 8;
616 b += (UInt32(k8[6])) shl 16;
617 b += (UInt32(k8[7])) shl 24;
618 c += k8[8];
619 c += (UInt32(k8[9])) shl 8;
620 c += (UInt32(k8[10])) shl 16;
621 c += (UInt32(k8[11])) shl 24;
622 mix_abc;
623 ALength -= 12;
624 k8 += 12;
625 end;
626
627 case ALength of
628 12: goto Case12;
629 11: goto Case11;
630 10: goto Case10;
631 9 : goto Case9;
632 8 : goto Case8;
633 7 : goto Case7;
634 6 : goto Case6;
635 5 : goto Case5;
636 4 : goto Case4;
637 3 : goto Case3;
638 2 : goto Case2;
639 1 : goto Case1;
640 0 :
641 begin
642 APrimaryHashAndInitVal := c;
643 ASecondaryHashAndInitVal := b;
644 Exit; // zero length strings require no mixing
645 end;
646 end;
647
648 Case12: c+=(UInt32(k8[11])) shl 24;
649 Case11: c+=(UInt32(k8[10])) shl 16;
650 Case10: c+=(UInt32(k8[9])) shl 8;
651 Case9: c+=k8[8];
652 Case8: b+=(UInt32(k8[7])) shl 24;
653 Case7: b+=(UInt32(k8[6])) shl 16;
654 Case6: b+=(UInt32(k8[5])) shl 8;
655 Case5: b+=k8[4];
656 Case4: a+=(UInt32(k8[3])) shl 24;
657 Case3: a+=(UInt32(k8[2])) shl 16;
658 Case2: a+=(UInt32(k8[1])) shl 8;
659 Case1: a+=k8[0];
660 end;
661
662 final_abc;
663 APrimaryHashAndInitVal := c;
664 ASecondaryHashAndInitVal := b;
665 end;
666
667 procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32);
668 var
669 a,b,c: UInt32;
670 u: record case byte of
671 0: (ptr: Pointer);
672 1: (i: PtrUint);
673 end absolute AKey;
674
675 k32: ^UInt32 absolute AKey;
676 k16: ^UInt16 absolute AKey;
677 k8: ^UInt8 absolute AKey;
678
679 label _10, _8, _6, _4, _2;
680 label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
681
682 begin
683 //* Set up the internal state */
684 a := $DEADBEEF + UInt32(ALength shl 2) + APrimaryHashAndInitVal; // delphi version bug? original version don't have "shl 2"
685 b := a;
686 c := b;
687 c += ASecondaryHashAndInitVal;
688
689 {$IFDEF ENDIAN_LITTLE}
690 if (u.i and $3) = 0 then
691 begin
692 while (ALength > 12) do
693 begin
694 a += k32[0];
695 b += k32[1];
696 c += k32[2];
697 mix_abc;
698 ALength -= 12;
699 k32 += 3;
700 end;
701
702 case ALength of
703 12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
704 11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
705 10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
706 9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
707 8 : begin b += k32[1]; a += k32[0]; end;
708 7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
709 6 : begin b += k32[1] and $ffff; a += k32[0]; end;
710 5 : begin b += k32[1] and $ff; a += k32[0]; end;
711 4 : begin a += k32[0]; end;
712 3 : begin a += k32[0] and $ffffff; end;
713 2 : begin a += k32[0] and $ffff; end;
714 1 : begin a += k32[0] and $ff; end;
715 0 :
716 begin
717 APrimaryHashAndInitVal := c;
718 ASecondaryHashAndInitVal := b;
719 Exit; // zero length strings require no mixing
720 end;
721 end
722 end
723 else
724 if (u.i and $1) = 0 then
725 begin
726 while (ALength > 12) do
727 begin
728 a += k16[0] + (UInt32(k16[1]) shl 16);
729 b += k16[2] + (UInt32(k16[3]) shl 16);
730 c += k16[4] + (UInt32(k16[5]) shl 16);
731 mix_abc;
732 ALength -= 12;
733 k16 += 6;
734 end;
735
736 case ALength of
737 12:
738 begin
739 c+=k16[4]+((UInt32(k16[5])) shl 16);
740 b+=k16[2]+((UInt32(k16[3])) shl 16);
741 a+=k16[0]+((UInt32(k16[1])) shl 16);
742 end;
743 11:
744 begin
745 c+=(UInt32(k8[10])) shl 16; //* fall through */
746 goto _10;
747 end;
748 10:
749 begin _10:
750 c+=k16[4];
751 b+=k16[2]+((UInt32(k16[3])) shl 16);
752 a+=k16[0]+((UInt32(k16[1])) shl 16);
753 end;
754 9 :
755 begin
756 c+=k8[8]; //* fall through */
757 goto _8;
758 end;
759 8 :
760 begin _8:
761 b+=k16[2]+((UInt32(k16[3])) shl 16);
762 a+=k16[0]+((UInt32(k16[1])) shl 16);
763 end;
764 7 :
765 begin
766 b+=(UInt32(k8[6])) shl 16; //* fall through */
767 goto _6;
768 end;
769 6 :
770 begin _6:
771 b+=k16[2];
772 a+=k16[0]+((UInt32(k16[1])) shl 16);
773 end;
774 5 :
775 begin
776 b+=k8[4]; //* fall through */
777 goto _4;
778 end;
779 4 :
780 begin _4:
781 a+=k16[0]+((UInt32(k16[1])) shl 16);
782 end;
783 3 :
784 begin
785 a+=(UInt32(k8[2])) shl 16; //* fall through */
786 goto _2;
787 end;
788 2 :
789 begin _2:
790 a+=k16[0];
791 end;
792 1 :
793 begin
794 a+=k8[0];
795 end;
796 0 :
797 begin
798 APrimaryHashAndInitVal := c;
799 ASecondaryHashAndInitVal := b;
800 Exit; // zero length strings require no mixing
801 end;
802 end;
803 end
804 else
805 {$ENDIF}
806 begin
807 while ALength > 12 do
808 begin
809 a += k8[0];
810 a += (UInt32(k8[1])) shl 8;
811 a += (UInt32(k8[2])) shl 16;
812 a += (UInt32(k8[3])) shl 24;
813 b += k8[4];
814 b += (UInt32(k8[5])) shl 8;
815 b += (UInt32(k8[6])) shl 16;
816 b += (UInt32(k8[7])) shl 24;
817 c += k8[8];
818 c += (UInt32(k8[9])) shl 8;
819 c += (UInt32(k8[10])) shl 16;
820 c += (UInt32(k8[11])) shl 24;
821 mix_abc;
822 ALength -= 12;
823 k8 += 12;
824 end;
825
826 case ALength of
827 12: goto Case12;
828 11: goto Case11;
829 10: goto Case10;
830 9 : goto Case9;
831 8 : goto Case8;
832 7 : goto Case7;
833 6 : goto Case6;
834 5 : goto Case5;
835 4 : goto Case4;
836 3 : goto Case3;
837 2 : goto Case2;
838 1 : goto Case1;
839 0 :
840 begin
841 APrimaryHashAndInitVal := c;
842 ASecondaryHashAndInitVal := b;
843 Exit; // zero length strings require no mixing
844 end;
845 end;
846
847 Case12: c+=(UInt32(k8[11])) shl 24;
848 Case11: c+=(UInt32(k8[10])) shl 16;
849 Case10: c+=(UInt32(k8[9])) shl 8;
850 Case9: c+=k8[8];
851 Case8: b+=(UInt32(k8[7])) shl 24;
852 Case7: b+=(UInt32(k8[6])) shl 16;
853 Case6: b+=(UInt32(k8[5])) shl 8;
854 Case5: b+=k8[4];
855 Case4: a+=(UInt32(k8[3])) shl 24;
856 Case3: a+=(UInt32(k8[2])) shl 16;
857 Case2: a+=(UInt32(k8[1])) shl 8;
858 Case1: a+=k8[0];
859 end;
860
861 final_abc;
862 APrimaryHashAndInitVal := c;
863 ASecondaryHashAndInitVal := b;
864 end;
865
866 function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32;
867 var
868 a, b, c: UInt32;
869 u: record case byte of
870 0: (ptr: Pointer);
871 1: (i: PtrUint);
872 end absolute AKey;
873
874 k32: ^UInt32 absolute AKey;
875 //k16: ^UInt16 absolute AKey;
876 k8: ^UInt8 absolute AKey;
877
878 label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
879
880 begin
881 a := $DEADBEEF + UInt32(ALength shl 2) + AInitVal; // delphi version bug? original version don't have "shl 2"
882 b := a;
883 c := b;
884
885 {.$IFDEF ENDIAN_LITTLE} // Delphi version don't care
886 if (u.i and $3) = 0 then
887 begin
888 while (ALength > 12) do
889 begin
890 a += k32[0];
891 b += k32[1];
892 c += k32[2];
893 mix_abc;
894 ALength -= 12;
895 k32 += 3;
896 end;
897
898 case ALength of
899 12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
900 11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
901 10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
902 9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
903 8 : begin b += k32[1]; a += k32[0]; end;
904 7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
905 6 : begin b += k32[1] and $ffff; a += k32[0]; end;
906 5 : begin b += k32[1] and $ff; a += k32[0]; end;
907 4 : begin a += k32[0]; end;
908 3 : begin a += k32[0] and $ffffff; end;
909 2 : begin a += k32[0] and $ffff; end;
910 1 : begin a += k32[0] and $ff; end;
911 0 : Exit(c); // zero length strings require no mixing
912 end
913 end
914 else
915 {.$ENDIF}
916 begin
917 while ALength > 12 do
918 begin
919 a += k8[0];
920 a += (UInt32(k8[1])) shl 8;
921 a += (UInt32(k8[2])) shl 16;
922 a += (UInt32(k8[3])) shl 24;
923 b += k8[4];
924 b += (UInt32(k8[5])) shl 8;
925 b += (UInt32(k8[6])) shl 16;
926 b += (UInt32(k8[7])) shl 24;
927 c += k8[8];
928 c += (UInt32(k8[9])) shl 8;
929 c += (UInt32(k8[10])) shl 16;
930 c += (UInt32(k8[11])) shl 24;
931 mix_abc;
932 ALength -= 12;
933 k8 += 12;
934 end;
935
936 case ALength of
937 12: goto Case12;
938 11: goto Case11;
939 10: goto Case10;
940 9 : goto Case9;
941 8 : goto Case8;
942 7 : goto Case7;
943 6 : goto Case6;
944 5 : goto Case5;
945 4 : goto Case4;
946 3 : goto Case3;
947 2 : goto Case2;
948 1 : goto Case1;
949 0 : Exit(c);
950 end;
951
952 Case12: c+=(UInt32(k8[11])) shl 24;
953 Case11: c+=(UInt32(k8[10])) shl 16;
954 Case10: c+=(UInt32(k8[9])) shl 8;
955 Case9: c+=k8[8];
956 Case8: b+=(UInt32(k8[7])) shl 24;
957 Case7: b+=(UInt32(k8[6])) shl 16;
958 Case6: b+=(UInt32(k8[5])) shl 8;
959 Case5: b+=k8[4];
960 Case4: a+=(UInt32(k8[3])) shl 24;
961 Case3: a+=(UInt32(k8[2])) shl 16;
962 Case2: a+=(UInt32(k8[1])) shl 8;
963 Case1: a+=k8[0];
964 end;
965
966 final_abc;
967 Result := Int32(c);
968 end;
969
970 {$ifdef CPUARM} // circumvent FPC issue on ARM
971 function ToByte(value: cardinal): cardinal; inline;
972 begin
973 result := value and $ff;
974 end;
975 {$else}
976 type ToByte = byte;
977 {$endif}
978
979 {$ifdef CPUINTEL} // use optimized x86/x64 asm versions for xxHash32
980
981 {$ifdef CPUX86}
982 function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;
983 asm
984 xchg edx, ecx
985 push ebp
986 push edi
987 lea ebp, [ecx+edx]
988 push esi
989 push ebx
990 sub esp, 8
991 cmp edx, 15
992 mov ebx, eax
993 mov dword ptr [esp], edx
994 lea eax, [ebx+165667B1H]
995 jbe @2
996 lea eax, [ebp-10H]
997 lea edi, [ebx+24234428H]
998 lea esi, [ebx-7A143589H]
999 mov dword ptr [esp+4H], ebp
1000 mov edx, eax
1001 lea eax, [ebx+61C8864FH]
1002 mov ebp, edx
1003 @1: mov edx, dword ptr [ecx]
1004 imul edx, edx, -2048144777
1005 add edi, edx
1006 rol edi, 13
1007 imul edi, edi, -1640531535
1008 mov edx, dword ptr [ecx+4]
1009 imul edx, edx, -2048144777
1010 add esi, edx
1011 rol esi, 13
1012 imul esi, esi, -1640531535
1013 mov edx, dword ptr [ecx+8]
1014 imul edx, edx, -2048144777
1015 add ebx, edx
1016 rol ebx, 13
1017 imul ebx, ebx, -1640531535
1018 mov edx, dword ptr [ecx+12]
1019 lea ecx, [ecx+16]
1020 imul edx, edx, -2048144777
1021 add eax, edx
1022 rol eax, 13
1023 imul eax, eax, -1640531535
1024 cmp ebp, ecx
1025 jnc @1
1026 rol edi, 1
1027 rol esi, 7
1028 rol ebx, 12
1029 add esi, edi
1030 mov ebp, dword ptr [esp+4H]
1031 ror eax, 14
1032 add ebx, esi
1033 add eax, ebx
1034 @2: lea esi, [ecx+4H]
1035 add eax, dword ptr [esp]
1036 cmp ebp, esi
1037 jc @4
1038 mov ebx, esi
1039 nop
1040 @3: imul edx, dword ptr [ebx-4H], -1028477379
1041 add ebx, 4
1042 add eax, edx
1043 ror eax, 15
1044 imul eax, eax, 668265263
1045 cmp ebp, ebx
1046 jnc @3
1047 lea edx, [ebp-4H]
1048 sub edx, ecx
1049 mov ecx, edx
1050 and ecx, 0FFFFFFFCH
1051 add ecx, esi
1052 @4: cmp ebp, ecx
1053 jbe @6
1054 @5: movzx edx, byte ptr [ecx]
1055 add ecx, 1
1056 imul edx, edx, 374761393
1057 add eax, edx
1058 rol eax, 11
1059 imul eax, eax, -1640531535
1060 cmp ebp, ecx
1061 jnz @5
1062 nop
1063 @6: mov edx, eax
1064 add esp, 8
1065 shr edx, 15
1066 xor eax, edx
1067 imul eax, eax, -2048144777
1068 pop ebx
1069 pop esi
1070 mov edx, eax
1071 shr edx, 13
1072 xor eax, edx
1073 imul eax, eax, -1028477379
1074 pop edi
1075 pop ebp
1076 mov edx, eax
1077 shr edx, 16
1078 xor eax, edx
1079 end;
1080 {$endif CPUX86}
1081
1082 {$ifdef CPUX64}
1083 function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;
1084 asm
1085 {$ifndef WIN64} // crc=rdi P=rsi len=rdx
1086 mov r8, rdi
1087 mov rcx, rsi
1088 {$else} // crc=r8 P=rcx len=rdx
1089 mov r10, r8
1090 mov r8, rcx
1091 mov rcx, rdx
1092 mov rdx, r10
1093 push rsi // Win64 expects those registers to be preserved
1094 push rdi
1095 {$endif}
1096 // P=r8 len=rcx crc=rdx
1097 push rbx
1098 lea r10, [rcx+rdx]
1099 cmp rdx, 15
1100 lea eax, [r8+165667B1H]
1101 jbe @2
1102 lea rsi, [r10-10H]
1103 lea ebx, [r8+24234428H]
1104 lea edi, [r8-7A143589H]
1105 lea eax, [r8+61C8864FH]
1106 @1: imul r9d, dword ptr [rcx], -2048144777
1107 add rcx, 16
1108 imul r11d, dword ptr [rcx-0CH], -2048144777
1109 add ebx, r9d
1110 lea r9d, [r11+rdi]
1111 rol ebx, 13
1112 rol r9d, 13
1113 imul ebx, ebx, -1640531535
1114 imul edi, r9d, -1640531535
1115 imul r9d, dword ptr [rcx-8H], -2048144777
1116 add r8d, r9d
1117 imul r9d, dword ptr [rcx-4H], -2048144777
1118 rol r8d, 13
1119 imul r8d, r8d, -1640531535
1120 add eax, r9d
1121 rol eax, 13
1122 imul eax, eax, -1640531535
1123 cmp rsi, rcx
1124 jnc @1
1125 rol edi, 7
1126 rol ebx, 1
1127 rol r8d, 12
1128 mov r9d, edi
1129 ror eax, 14
1130 add r9d, ebx
1131 add r8d, r9d
1132 add eax, r8d
1133 @2: lea r9, [rcx+4H]
1134 add eax, edx
1135 cmp r10, r9
1136 jc @4
1137 mov r8, r9
1138 @3: imul edx, dword ptr [r8-4H], -1028477379
1139 add r8, 4
1140 add eax, edx
1141 ror eax, 15
1142 imul eax, eax, 668265263
1143 cmp r10, r8
1144 jnc @3
1145 lea rdx, [r10-4H]
1146 sub rdx, rcx
1147 mov rcx, rdx
1148 and rcx, 0FFFFFFFFFFFFFFFCH
1149 add rcx, r9
1150 @4: cmp r10, rcx
1151 jbe @6
1152 @5: movzx edx, byte ptr [rcx]
1153 add rcx, 1
1154 imul edx, edx, 374761393
1155 add eax, edx
1156 rol eax, 11
1157 imul eax, eax, -1640531535
1158 cmp r10, rcx
1159 jnz @5
1160 @6: mov edx, eax
1161 shr edx, 15
1162 xor eax, edx
1163 imul eax, eax, -2048144777
1164 mov edx, eax
1165 shr edx, 13
1166 xor eax, edx
1167 imul eax, eax, -1028477379
1168 mov edx, eax
1169 shr edx, 16
1170 xor eax, edx
1171 pop rbx
1172 {$ifdef WIN64}
1173 pop rdi
1174 pop rsi
1175 {$endif}
1176 end;
1177 {$endif CPUX64}
1178 {$else not CPUINTEL}
1179 function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;
1180 begin
1181 result := xxHash32Pascal(crc, P, len);
1182 end;
1183 {$endif CPUINTEL}
1184
1185 const
1186 PRIME32_1 = 2654435761;
1187 PRIME32_2 = 2246822519;
1188 PRIME32_3 = 3266489917;
1189 PRIME32_4 = 668265263;
1190 PRIME32_5 = 374761393;
1191
1192 // RolDWord is an intrinsic function under FPC :)
1193 function Rol13(value: cardinal): cardinal; inline;
1194 begin
1195 result := RolDWord(value, 13);
1196 end;
1197
1198 function xxHash32Pascal(crc: cardinal; P: Pointer; len: integer): cardinal;
1199 var c1, c2, c3, c4: cardinal;
1200 PLimit, PEnd: PAnsiChar;
1201 begin
1202 PEnd := P + len;
1203 if len >= 16 then begin
1204 PLimit := PEnd - 16;
1205 c3 := crc;
1206 c2 := c3 + PRIME32_2;
1207 c1 := c2 + PRIME32_1;
1208 c4 := c3 - PRIME32_1;
1209 repeat
1210 c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^);
1211 c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P+4)^);
1212 c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P+8)^);
1213 c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P+12)^);
1214 inc(P, 16);
1215 until not (P <= PLimit);
1216 result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18);
1217 end else
1218 result := crc + PRIME32_5;
1219 inc(result, len);
1220 { Use "P + 4 <= PEnd" instead of "P <= PEnd - 4" to avoid crashes in case P = nil.
1221 When P = nil,
1222 then "PtrUInt(PEnd - 4)" is 4294967292,
1223 so the condition "P <= PEnd - 4" would be satisfied,
1224 and the code would try to access PCardinal(nil)^ causing a SEGFAULT. }
1225 while P + 4 <= PEnd do begin
1226 inc(result, PCardinal(P)^ * PRIME32_3);
1227 result := RolDWord(result, 17) * PRIME32_4;
1228 inc(P, 4);
1229 end;
1230 while P < PEnd do begin
1231 inc(result, PByte(P)^ * PRIME32_5);
1232 result := RolDWord(result, 11) * PRIME32_1;
1233 inc(P);
1234 end;
1235 result := result xor (result shr 15);
1236 result := result * PRIME32_2;
1237 result := result xor (result shr 13);
1238 result := result * PRIME32_3;
1239 result := result xor (result shr 16);
1240 end;
1241
1242 {$ifdef CPUINTEL}
1243
1244 type
1245 TRegisters = record
1246 eax,ebx,ecx,edx: cardinal;
1247 end;
1248
1249 {$ifdef CPU64}
1250 procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); nostackframe; assembler;
1251 asm
1252 {$ifdef win64}
1253 mov eax, ecx
1254 mov r9, rdx
1255 {$else}
1256 mov eax, edi
1257 mov r9, rsi
1258 {$endif win64}
1259 mov r10, rbx // preserve rbx
1260 xor ebx, ebx
1261 xor ecx, ecx
1262 xor edx, edx
1263 cpuid
1264 mov TRegisters(r9).&eax, eax
1265 mov TRegisters(r9).&ebx, ebx
1266 mov TRegisters(r9).&ecx, ecx
1267 mov TRegisters(r9).&edx, edx
1268 mov rbx, r10
1269 end;
1270
1271 function crc32csse42(crc: cardinal; buf: Pointer; len: cardinal): cardinal; nostackframe; assembler;
1272 asm // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,rdx)
1273 {$ifdef win64}
1274 mov eax, ecx
1275 {$else}
1276 mov eax, edi
1277 mov r8, rdx
1278 mov rdx, rsi
1279 {$endif win64}
1280 not eax
1281 test rdx, rdx
1282 jz @0
1283 test r8, r8
1284 jz @0
1285 @7: test dl, 7
1286 jz @8 // align to 8 bytes boundary
1287 crc32 eax, byte ptr[rdx]
1288 inc rdx
1289 dec r8
1290 jz @0
1291 test dl, 7
1292 jnz @7
1293 @8: mov rcx, r8
1294 shr r8, 3
1295 jz @2
1296 @1:
1297 crc32 rax, qword [rdx] // hash 8 bytes per loop
1298 dec r8
1299 lea rdx, [rdx + 8]
1300 jnz @1
1301 @2: and ecx, 7
1302 jz @0
1303 cmp ecx, 4
1304 jb @4
1305 crc32 eax, dword ptr[rdx]
1306 sub ecx, 4
1307 lea rdx, [rdx + 4]
1308 jz @0
1309 @4: crc32 eax, byte ptr[rdx]
1310 dec ecx
1311 jz @0
1312 crc32 eax, byte ptr[rdx + 1]
1313 dec ecx
1314 jz @0
1315 crc32 eax, byte ptr[rdx + 2]
1316 @0: not eax
1317 end;
1318 {$endif CPU64}
1319
1320 {$ifdef CPUX86}
1321 procedure GetCPUID(Param: Cardinal; var Registers: TRegisters);
1322 asm
1323 push esi
1324 push edi
1325 mov esi, edx
1326 mov edi, eax
1327 pushfd
1328 pop eax
1329 mov edx, eax
1330 xor eax, $200000
1331 push eax
1332 popfd
1333 pushfd
1334 pop eax
1335 xor eax, edx
1336 jz @nocpuid
1337 push ebx
1338 mov eax, edi
1339 xor ecx, ecx
1340 cpuid
1341 mov TRegisters(esi).&eax, eax
1342 mov TRegisters(esi).&ebx, ebx
1343 mov TRegisters(esi).&ecx, ecx
1344 mov TRegisters(esi).&edx, edx
1345 pop ebx
1346 @nocpuid:
1347 pop edi
1348 pop esi
1349 end;
1350
1351 function crc32csse42(crc: cardinal; buf: Pointer; len: cardinal): cardinal;
1352 asm // eax=crc, edx=buf, ecx=len
1353 not eax
1354 test ecx, ecx
1355 jz @0
1356 test edx, edx
1357 jz @0
1358 @3: test edx, 3
1359 jz @8 // align to 4 bytes boundary
1360 crc32 eax, byte ptr[edx]
1361 inc edx
1362 dec ecx
1363 jz @0
1364 test edx, 3
1365 jnz @3
1366 @8: push ecx
1367 shr ecx, 3
1368 jz @2
1369 @1:
1370 crc32 eax, dword ptr[edx]
1371 crc32 eax, dword ptr[edx + 4]
1372 dec ecx
1373 lea edx, [edx + 8]
1374 jnz @1
1375 @2: pop ecx
1376 and ecx, 7
1377 jz @0
1378 cmp ecx, 4
1379 jb @4
1380 crc32 eax, dword ptr[edx]
1381 sub ecx, 4
1382 lea edx, [edx + 4]
1383 jz @0
1384 @4:
1385 crc32 eax, byte ptr[edx]
1386 dec ecx
1387 jz @0
1388 crc32 eax, byte ptr[edx + 1]
1389 dec ecx
1390 jz @0
1391 crc32 eax, byte ptr[edx + 2]
1392 @0: not eax
1393 end;
1394 {$endif CPUX86}
1395
1396 type
1397 /// the potential features, retrieved from an Intel CPU
1398 // - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits
1399 TIntelCpuFeature =
1400 ( { in EDX }
1401 cfFPU, cfVME, cfDE, cfPSE, cfTSC, cfMSR, cfPAE, cfMCE,
1402 cfCX8, cfAPIC, cf_d10, cfSEP, cfMTRR, cfPGE, cfMCA, cfCMOV,
1403 cfPAT, cfPSE36, cfPSN, cfCLFSH, cf_d20, cfDS, cfACPI, cfMMX,
1404 cfFXSR, cfSSE, cfSSE2, cfSS, cfHTT, cfTM, cfIA64, cfPBE,
1405 { in ECX }
1406 cfSSE3, cfCLMUL, cfDS64, cfMON, cfDSCPL, cfVMX, cfSMX, cfEST,
1407 cfTM2, cfSSSE3, cfCID, cfSDBG, cfFMA, cfCX16, cfXTPR, cfPDCM,
1408 cf_c16, cfPCID, cfDCA, cfSSE41, cfSSE42, cfX2A, cfMOVBE, cfPOPCNT,
1409 cfTSC2, cfAESNI, cfXS, cfOSXS, cfAVX, cfF16C, cfRAND, cfHYP,
1410 { extended features in EBX, ECX }
1411 cfFSGS, cf_b01, cfSGX, cfBMI1, cfHLE, cfAVX2, cf_b06, cfSMEP,
1412 cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE,
1413 cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT, cfCLFLUSH,
1414 cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA, cfAVX512BW, cfAVX512VL,
1415 cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE, cf_c05, cf_c06, cf_c07,
1416 cf_c08, cf_c09, cf_c10, cf_c11, cf_c12, cf_c13, cfAVX512VPC, cf_c15,
1417 cf_cc16, cf_c17, cf_c18, cf_c19, cf_c20, cf_c21, cfRDPID, cf_c23,
1418 cf_c24, cf_c25, cf_c26, cf_c27, cf_c28, cf_c29, cfSGXLC, cf_c31,
1419 cf_d0, cf_d1, cfAVX512NNI, cfAVX512MAS, cf_d4, cf_d5, cf_d6, cf_d7);
1420
1421 /// all features, as retrieved from an Intel CPU
1422 TIntelCpuFeatures = set of TIntelCpuFeature;
1423
1424 var
1425 /// the available CPU features, as recognized at program startup
1426 CpuFeatures: TIntelCpuFeatures;
1427
1428 procedure TestIntelCpuFeatures;
1429 var regs: TRegisters;
1430 begin
1431 regs.edx := 0;
1432 regs.ecx := 0;
1433 GetCPUID(1,regs);
1434 PIntegerArray(@CpuFeatures)^[0] := regs.edx;
1435 PIntegerArray(@CpuFeatures)^[1] := regs.ecx;
1436 GetCPUID(7,regs);
1437 PIntegerArray(@CpuFeatures)^[2] := regs.ebx;
1438 PIntegerArray(@CpuFeatures)^[3] := regs.ecx;
1439 PByte(@PIntegerArray(@CpuFeatures)^[4])^ := regs.edx;
1440 // assert(sizeof(CpuFeatures)=4*4+1);
1441 {$ifdef Darwin}
1442 {$ifdef CPU64}
1443 // SSE42 asm does not (yet) work on Darwin x64 ...
1444 Exclude(CpuFeatures, cfSSE42);
1445 {$endif}
1446 {$endif}
1447 end;
1448 {$endif CPUINTEL}
1449
1450 var
1451 crc32ctab: array[0..{$ifdef PUREPASCAL}3{$else}7{$endif},byte] of cardinal;
1452
1453 function crc32cfast(crc: cardinal; buf: Pointer; len: cardinal): cardinal;
1454 {$ifdef PUREPASCAL}
1455 begin
1456 result := not crc;
1457 if (buf<>nil) and (len>0) then begin
1458 repeat
1459 if PtrUInt(buf) and 3=0 then // align to 4 bytes boundary
1460 break;
1461 result := crc32ctab[0,ToByte(result xor cardinal(buf^))] xor (result shr 8);
1462 dec(len);
1463 inc(buf);
1464 until len=0;
1465 while len>=4 do begin
1466 result := result xor PCardinal(buf)^;
1467 inc(buf,4);
1468 result := crc32ctab[3,ToByte(result)] xor
1469 crc32ctab[2,ToByte(result shr 8)] xor
1470 crc32ctab[1,ToByte(result shr 16)] xor
1471 crc32ctab[0,result shr 24];
1472 dec(len,4);
1473 end;
1474 while len>0 do begin
1475 result := crc32ctab[0,ToByte(result xor cardinal(buf^))] xor (result shr 8);
1476 dec(len);
1477 inc(buf);
1478 end;
1479 end;
1480 result := not result;
1481 end;
1482 {$else}
1483 // adapted from fast Aleksandr Sharahov version
1484 asm
1485 test edx, edx
1486 jz @ret
1487 neg ecx
1488 jz @ret
1489 not eax
1490 push ebx
1491 @head: test dl, 3
1492 jz @aligned
1493 movzx ebx, byte[edx]
1494 inc edx
1495 xor bl, al
1496 shr eax, 8
1497 xor eax, dword ptr[ebx * 4 + crc32ctab]
1498 inc ecx
1499 jnz @head
1500 pop ebx
1501 not eax
1502 ret
1503 @ret: rep ret
1504 @aligned:
1505 sub edx, ecx
1506 add ecx, 8
1507 jg @bodydone
1508 push esi
1509 push edi
1510 mov edi, edx
1511 mov edx, eax
1512 @bodyloop:
1513 mov ebx, [edi + ecx - 4]
1514 xor edx, [edi + ecx - 8]
1515 movzx esi, bl
1516 mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3]
1517 movzx esi, bh
1518 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2]
1519 shr ebx, 16
1520 movzx esi, bl
1521 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1]
1522 movzx esi, bh
1523 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0]
1524 movzx esi, dl
1525 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 7]
1526 movzx esi, dh
1527 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 6]
1528 shr edx, 16
1529 movzx esi, dl
1530 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 5]
1531 movzx esi, dh
1532 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 4]
1533 add ecx, 8
1534 jg @done
1535 mov ebx, [edi + ecx - 4]
1536 xor eax, [edi + ecx - 8]
1537 movzx esi, bl
1538 mov edx, dword ptr[esi * 4 + crc32ctab + 1024 * 3]
1539 movzx esi, bh
1540 xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 2]
1541 shr ebx, 16
1542 movzx esi, bl
1543 xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 1]
1544 movzx esi, bh
1545 xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 0]
1546 movzx esi, al
1547 xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 7]
1548 movzx esi, ah
1549 xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 6]
1550 shr eax, 16
1551 movzx esi, al
1552 xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 5]
1553 movzx esi, ah
1554 xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 4]
1555 add ecx, 8
1556 jle @bodyloop
1557 mov eax, edx
1558 @done: mov edx, edi
1559 pop edi
1560 pop esi
1561 @bodydone:
1562 sub ecx, 8
1563 jl @tail
1564 pop ebx
1565 not eax
1566 ret
1567 @tail: movzx ebx, byte[edx + ecx]
1568 xor bl, al
1569 shr eax, 8
1570 xor eax, dword ptr[ebx * 4 + crc32ctab]
1571 inc ecx
1572 jnz @tail
1573 pop ebx
1574 not eax
1575 end;
1576 {$endif PUREPASCAL}
1577
1578 procedure InitializeCrc32ctab;
1579 var
1580 i, n: integer;
1581 crc: cardinal;
1582 begin
1583 // initialize tables for crc32cfast() and SymmetricEncrypt/FillRandom
1584 for i := 0 to 255 do begin
1585 crc := i;
1586 for n := 1 to 8 do
1587 if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32()
1588 crc := (crc shr 1) xor $82f63b78 else
1589 crc := crc shr 1;
1590 crc32ctab[0,i] := crc;
1591 end;
1592 for i := 0 to 255 do begin
1593 crc := crc32ctab[0,i];
1594 for n := 1 to high(crc32ctab) do begin
1595 crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)];
1596 crc32ctab[n,i] := crc;
1597 end;
1598 end;
1599 end;
1600
1601 begin
1602 {$ifdef CPUINTEL}
1603 TestIntelCpuFeatures;
1604 if cfSSE42 in CpuFeatures then
1605 begin
1606 crc32c := @crc32csse42;
1607 mORMotHasher := @crc32csse42;
1608 end
1609 else
1610 {$endif CPUINTEL}
1611 begin
1612 InitializeCrc32ctab;
1613 crc32c := @crc32cfast;
1614 mORMotHasher := @{$IFDEF CPUINTEL}xxHash32{$ELSE}xxHash32Pascal{$ENDIF};
1615 end;
1616 end.
1617
1618