paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-18 00:19:15 +02:00
Code Issues Packages Projects Releases Wiki Activity

Big update for Generics.Collections to latest version (compilable with trunk and 3.0.4)

Browse Source 
git-svn-id: trunk@57795 -
This commit is contained in:
hnb 2018-05-06 17:10:46 +00:00
parent dd7422fede
commit 9b1a4ea081
9 changed files with 4201 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
components/sparta/generics/examples/TStack/TStackProject.lpr
View File

@ -8,7 +8,6 @@ program TStackProject;
uses
SysUtils,
Windows,
Generics.Collections;
type

2940
components/sparta/generics/source/generics.collections.pas
View File

File diff suppressed because it is too large Load Diff

36
components/sparta/generics/source/generics.defaults.pas
View File

@ -14,6 +14,14 @@
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Acknowledgment
Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring
many new types and major refactoring of entire library
Thanks to mORMot (http://synopse.info) project for the best implementations
of hashing functions like crc32c and xxHash32 :)
**********************************************************************}
unit Generics.Defaults;
@ -554,7 +562,7 @@ type
EqualityComparer_Method_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Method ; GetHashCode: @THashFactory.Method );
EqualityComparer_Variant_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Variant; GetHashCode: @THashFactory.Variant);
EqualityComparer_Pointer_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Pointer; GetHashCode: @THashFactory.Pointer);
{$WARNINGS ON}
{.$WARNINGS ON} // do not enable warnings ever in this unit, or you will get many warnings about uninitialized TEqualityComparerVMT fields
private class var
// IEqualityComparer VMT
FEqualityComparer_Int8_VMT : THashFactory.TEqualityComparerVMT;
@ -673,7 +681,7 @@ type
ExtendedEqualityComparer_Method_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Method ; GetHashCode: @THashFactory.Method ; GetHashList: @TExtendedHashFactory.Method );
ExtendedEqualityComparer_Variant_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Variant; GetHashCode: @THashFactory.Variant; GetHashList: @TExtendedHashFactory.Variant);
ExtendedEqualityComparer_Pointer_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Pointer; GetHashCode: @THashFactory.Pointer; GetHashList: @TExtendedHashFactory.Pointer);
{$WARNINGS ON}
{.$WARNINGS ON} // do not enable warnings ever in this unit, or you will get many warnings about uninitialized TEqualityComparerVMT fields
private class var
// IExtendedEqualityComparer VMT
FExtendedEqualityComparer_Int8_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT;
@ -857,6 +865,12 @@ type
class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override;
end;
TmORMotHashFactory = class(THashFactory)
public
class function GetHashService: THashServiceClass; override;
class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override;
end;
{ TAdler32HashFactory }
TAdler32HashFactory = class(THashFactory)
@ -922,7 +936,7 @@ type
class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); override;
end;
TDefaultHashFactory = TDelphiQuadrupleHashFactory;
TDefaultHashFactory = TmORMotHashFactory;
TDefaultGenericInterface = (giComparer, giEqualityComparer, giExtendedEqualityComparer);
@ -2782,6 +2796,18 @@ begin
Result := DelphiHashLittle(AKey, ASize, AInitVal);
end;
{ TmORMotHashFactory }
class function TmORMotHashFactory.GetHashService: THashServiceClass;
begin
Result := THashService<TmORMotHashFactory>;
end;
class function TmORMotHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32;
begin
Result := mORMotHasher(AInitVal, AKey, ASize);
end;
{ TAdler32HashFactory }
class function TAdler32HashFactory.GetHashService: THashServiceClass;
@ -2879,7 +2905,7 @@ begin
else
raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange);
end;
{$WARNINGS ON}
{.$WARNINGS ON} // do not enable warnings ever in this unit, or you will get many warnings about uninitialized TEqualityComparerVMT fields
end;
{ TDelphiQuadrupleHashFactory }
@ -3255,7 +3281,7 @@ begin
giEqualityComparer:
begin
if AFactory = nil then
AFactory := TDelphiHashFactory;
AFactory := TDefaultHashFactory;
Exit(
AFactory.GetHashService.LookupEqualityComparer(ATypeInfo, ASize));

674
components/sparta/generics/source/generics.hashes.pas
View File

@ -14,6 +14,14 @@
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Acknowledgment
Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring
many new types and major refactoring of entire library.
Thanks to mORMot (http://synopse.info) project for the best implementations
of hashing functions like crc32c and xxHash32 :)
**********************************************************************}
unit Generics.Hashes;
@ -64,6 +72,14 @@ function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
// https://code.google.com/p/hedgewars/source/browse/hedgewars/adler32.pas
function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;
type
THasher = function(crc: cardinal; buf: Pointer; len: cardinal): cardinal;
var
crc32c: THasher;
mORMotHasher: THasher;
implementation
@ -911,5 +927,663 @@ begin
Result := Int32(c);
end;
{$ifdef CPU64}
{$define PUREPASCAL}
{$ifdef CPUX64}
{$define CPUINTEL}
{$ASMMODE INTEL}
{$endif CPUX64}
{$else}
{$ifdef CPUX86}
{$ifndef FPC_PIC}
{$define CPUINTEL}
{$ASMMODE INTEL}
{$else}
{ Assembler code uses references to static
variables with are not PIC ready }
{$define PUREPASCAL}
{$endif}
{$else CPUX86}
{$define PUREPASCAL}
{$endif}
{$endif CPU64}
{$ifdef CPUARM} // circumvent FPC issue on ARM
function ToByte(value: cardinal): cardinal; inline;
begin
result := value and $ff;
end;
{$else}
type ToByte = byte;
{$endif}
{$ifdef CPUINTEL} // use optimized x86/x64 asm versions for xxHash32
{$ifdef CPUX86}
function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;
asm
xchg edx, ecx
push ebp
push edi
lea ebp, [ecx+edx]
push esi
push ebx
sub esp, 8
cmp edx, 15
mov ebx, eax
mov dword ptr [esp], edx
lea eax, [ebx+165667B1H]
jbe @2
lea eax, [ebp-10H]
lea edi, [ebx+24234428H]
lea esi, [ebx-7A143589H]
mov dword ptr [esp+4H], ebp
mov edx, eax
lea eax, [ebx+61C8864FH]
mov ebp, edx
@1: mov edx, dword ptr [ecx]
imul edx, edx, -2048144777
add edi, edx
rol edi, 13
imul edi, edi, -1640531535
mov edx, dword ptr [ecx+4]
imul edx, edx, -2048144777
add esi, edx
rol esi, 13
imul esi, esi, -1640531535
mov edx, dword ptr [ecx+8]
imul edx, edx, -2048144777
add ebx, edx
rol ebx, 13
imul ebx, ebx, -1640531535
mov edx, dword ptr [ecx+12]
lea ecx, [ecx+16]
imul edx, edx, -2048144777
add eax, edx
rol eax, 13
imul eax, eax, -1640531535
cmp ebp, ecx
jnc @1
rol edi, 1
rol esi, 7
rol ebx, 12
add esi, edi
mov ebp, dword ptr [esp+4H]
ror eax, 14
add ebx, esi
add eax, ebx
@2: lea esi, [ecx+4H]
add eax, dword ptr [esp]
cmp ebp, esi
jc @4
mov ebx, esi
nop
@3: imul edx, dword ptr [ebx-4H], -1028477379
add ebx, 4
add eax, edx
ror eax, 15
imul eax, eax, 668265263
cmp ebp, ebx
jnc @3
lea edx, [ebp-4H]
sub edx, ecx
mov ecx, edx
and ecx, 0FFFFFFFCH
add ecx, esi
@4: cmp ebp, ecx
jbe @6
@5: movzx edx, byte ptr [ecx]
add ecx, 1
imul edx, edx, 374761393
add eax, edx
rol eax, 11
imul eax, eax, -1640531535
cmp ebp, ecx
jnz @5
nop
@6: mov edx, eax
add esp, 8
shr edx, 15
xor eax, edx
imul eax, eax, -2048144777
pop ebx
pop esi
mov edx, eax
shr edx, 13
xor eax, edx
imul eax, eax, -1028477379
pop edi
pop ebp
mov edx, eax
shr edx, 16
xor eax, edx
end;
{$endif CPUX86}
{$ifdef CPUX64}
function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;
asm
{$ifndef WIN64} // crc=rdi P=rsi len=rdx
mov r8, rdi
mov rcx, rsi
{$else} // crc=r8 P=rcx len=rdx
mov r10, r8
mov r8, rcx
mov rcx, rdx
mov rdx, r10
push rsi // Win64 expects those registers to be preserved
push rdi
{$endif}
// P=r8 len=rcx crc=rdx
push rbx
lea r10, [rcx+rdx]
cmp rdx, 15
lea eax, [r8+165667B1H]
jbe @2
lea rsi, [r10-10H]
lea ebx, [r8+24234428H]
lea edi, [r8-7A143589H]
lea eax, [r8+61C8864FH]
@1: imul r9d, dword ptr [rcx], -2048144777
add rcx, 16
imul r11d, dword ptr [rcx-0CH], -2048144777
add ebx, r9d
lea r9d, [r11+rdi]
rol ebx, 13
rol r9d, 13
imul ebx, ebx, -1640531535
imul edi, r9d, -1640531535
imul r9d, dword ptr [rcx-8H], -2048144777
add r8d, r9d
imul r9d, dword ptr [rcx-4H], -2048144777
rol r8d, 13
imul r8d, r8d, -1640531535
add eax, r9d
rol eax, 13
imul eax, eax, -1640531535
cmp rsi, rcx
jnc @1
rol edi, 7
rol ebx, 1
rol r8d, 12
mov r9d, edi
ror eax, 14
add r9d, ebx
add r8d, r9d
add eax, r8d
@2: lea r9, [rcx+4H]
add eax, edx
cmp r10, r9
jc @4
mov r8, r9
@3: imul edx, dword ptr [r8-4H], -1028477379
add r8, 4
add eax, edx
ror eax, 15
imul eax, eax, 668265263
cmp r10, r8
jnc @3
lea rdx, [r10-4H]
sub rdx, rcx
mov rcx, rdx
and rcx, 0FFFFFFFFFFFFFFFCH
add rcx, r9
@4: cmp r10, rcx
jbe @6
@5: movzx edx, byte ptr [rcx]
add rcx, 1
imul edx, edx, 374761393
add eax, edx
rol eax, 11
imul eax, eax, -1640531535
cmp r10, rcx
jnz @5
@6: mov edx, eax
shr edx, 15
xor eax, edx
imul eax, eax, -2048144777
mov edx, eax
shr edx, 13
xor eax, edx
imul eax, eax, -1028477379
mov edx, eax
shr edx, 16
xor eax, edx
pop rbx
{$ifdef WIN64}
pop rdi
pop rsi
{$endif}
end;
{$endif CPUX64}
{$else not CPUINTEL}
const
PRIME32_1 = 2654435761;
PRIME32_2 = 2246822519;
PRIME32_3 = 3266489917;
PRIME32_4 = 668265263;
PRIME32_5 = 374761393;
// RolDWord is an intrinsic function under FPC :)
function Rol13(value: cardinal): cardinal; inline;
begin
result := RolDWord(value, 13);
end;
function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;
var c1, c2, c3, c4: cardinal;
PLimit, PEnd: PAnsiChar;
begin
PEnd := P + len;
if len >= 16 then begin
PLimit := PEnd - 16;
c3 := crc;
c2 := c3 + PRIME32_2;
c1 := c2 + PRIME32_1;
c4 := c3 - PRIME32_1;
repeat
c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^);
c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P+4)^);
c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P+8)^);
c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P+12)^);
inc(P, 16);
until not (P <= PLimit);
result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18);
end else
result := crc + PRIME32_5;
inc(result, len);
while P <= PEnd - 4 do begin
inc(result, PCardinal(P)^ * PRIME32_3);
result := RolDWord(result, 17) * PRIME32_4;
inc(P, 4);
end;
while P < PEnd do begin
inc(result, PByte(P)^ * PRIME32_5);
result := RolDWord(result, 11) * PRIME32_1;
inc(P);
end;
result := result xor (result shr 15);
result := result * PRIME32_2;
result := result xor (result shr 13);
result := result * PRIME32_3;
result := result xor (result shr 16);
end;
{$endif CPUINTEL}
{$ifdef CPUINTEL}
type
TRegisters = record
eax,ebx,ecx,edx: cardinal;
end;
{$ifdef CPU64}
procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); nostackframe; assembler;
asm
{$ifdef win64}
mov eax, ecx
mov r9, rdx
{$else}
mov eax, edi
mov r9, rsi
{$endif win64}
mov r10, rbx // preserve rbx
xor ebx, ebx
xor ecx, ecx
xor edx, edx
cpuid
mov TRegisters(r9).&eax, eax
mov TRegisters(r9).&ebx, ebx
mov TRegisters(r9).&ecx, ecx
mov TRegisters(r9).&edx, edx
mov rbx, r10
end;
function crc32csse42(crc: cardinal; buf: Pointer; len: cardinal): cardinal; nostackframe; assembler;
asm // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,rdx)
{$ifdef win64}
mov eax, ecx
{$else}
mov eax, edi
mov r8, rdx
mov rdx, rsi
{$endif win64}
not eax
test rdx, rdx
jz @0
test r8, r8
jz @0
@7: test dl, 7
jz @8 // align to 8 bytes boundary
crc32 eax, byte ptr[rdx]
inc rdx
dec r8
jz @0
test dl, 7
jnz @7
@8: mov rcx, r8
shr r8, 3
jz @2
@1:
crc32 rax, qword [rdx] // hash 8 bytes per loop
dec r8
lea rdx, [rdx + 8]
jnz @1
@2: and ecx, 7
jz @0
cmp ecx, 4
jb @4
crc32 eax, dword ptr[rdx]
sub ecx, 4
lea rdx, [rdx + 4]
jz @0
@4: crc32 eax, byte ptr[rdx]
dec ecx
jz @0
crc32 eax, byte ptr[rdx + 1]
dec ecx
jz @0
crc32 eax, byte ptr[rdx + 2]
@0: not eax
end;
{$endif CPU64}
{$ifdef CPUX86}
procedure GetCPUID(Param: Cardinal; var Registers: TRegisters);
asm
push esi
push edi
mov esi, edx
mov edi, eax
pushfd
pop eax
mov edx, eax
xor eax, $200000
push eax
popfd
pushfd
pop eax
xor eax, edx
jz @nocpuid
push ebx
mov eax, edi
xor ecx, ecx
cpuid
mov TRegisters(esi).&eax, eax
mov TRegisters(esi).&ebx, ebx
mov TRegisters(esi).&ecx, ecx
mov TRegisters(esi).&edx, edx
pop ebx
@nocpuid:
pop edi
pop esi
end;
function crc32csse42(crc: cardinal; buf: Pointer; len: cardinal): cardinal;
asm // eax=crc, edx=buf, ecx=len
not eax
test ecx, ecx
jz @0
test edx, edx
jz @0
@3: test edx, 3
jz @8 // align to 4 bytes boundary
crc32 eax, byte ptr[edx]
inc edx
dec ecx
jz @0
test edx, 3
jnz @3
@8: push ecx
shr ecx, 3
jz @2
@1:
crc32 eax, dword ptr[edx]
crc32 eax, dword ptr[edx + 4]
dec ecx
lea edx, [edx + 8]
jnz @1
@2: pop ecx
and ecx, 7
jz @0
cmp ecx, 4
jb @4
crc32 eax, dword ptr[edx]
sub ecx, 4
lea edx, [edx + 4]
jz @0
@4:
crc32 eax, byte ptr[edx]
dec ecx
jz @0
crc32 eax, byte ptr[edx + 1]
dec ecx
jz @0
crc32 eax, byte ptr[edx + 2]
@0: not eax
end;
{$endif CPUX86}
type
/// the potential features, retrieved from an Intel CPU
// - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits
TIntelCpuFeature =
( { in EDX }
cfFPU, cfVME, cfDE, cfPSE, cfTSC, cfMSR, cfPAE, cfMCE,
cfCX8, cfAPIC, cf_d10, cfSEP, cfMTRR, cfPGE, cfMCA, cfCMOV,
cfPAT, cfPSE36, cfPSN, cfCLFSH, cf_d20, cfDS, cfACPI, cfMMX,
cfFXSR, cfSSE, cfSSE2, cfSS, cfHTT, cfTM, cfIA64, cfPBE,
{ in ECX }
cfSSE3, cfCLMUL, cfDS64, cfMON, cfDSCPL, cfVMX, cfSMX, cfEST,
cfTM2, cfSSSE3, cfCID, cfSDBG, cfFMA, cfCX16, cfXTPR, cfPDCM,
cf_c16, cfPCID, cfDCA, cfSSE41, cfSSE42, cfX2A, cfMOVBE, cfPOPCNT,
cfTSC2, cfAESNI, cfXS, cfOSXS, cfAVX, cfF16C, cfRAND, cfHYP,
{ extended features in EBX, ECX }
cfFSGS, cf_b01, cfSGX, cfBMI1, cfHLE, cfAVX2, cf_b06, cfSMEP,
cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE,
cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT, cfCLFLUSH,
cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA, cfAVX512BW, cfAVX512VL,
cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE, cf_c05, cf_c06, cf_c07,
cf_c08, cf_c09, cf_c10, cf_c11, cf_c12, cf_c13, cfAVX512VPC, cf_c15,
cf_cc16, cf_c17, cf_c18, cf_c19, cf_c20, cf_c21, cfRDPID, cf_c23,
cf_c24, cf_c25, cf_c26, cf_c27, cf_c28, cf_c29, cfSGXLC, cf_c31,
cf_d0, cf_d1, cfAVX512NNI, cfAVX512MAS, cf_d4, cf_d5, cf_d6, cf_d7);
/// all features, as retrieved from an Intel CPU
TIntelCpuFeatures = set of TIntelCpuFeature;
var
/// the available CPU features, as recognized at program startup
CpuFeatures: TIntelCpuFeatures;
procedure TestIntelCpuFeatures;
var regs: TRegisters;
begin
regs.edx := 0;
regs.ecx := 0;
GetCPUID(1,regs);
PIntegerArray(@CpuFeatures)^[0] := regs.edx;
PIntegerArray(@CpuFeatures)^[1] := regs.ecx;
GetCPUID(7,regs);
PIntegerArray(@CpuFeatures)^[2] := regs.ebx;
PIntegerArray(@CpuFeatures)^[3] := regs.ecx;
PByte(@PIntegerArray(@CpuFeatures)^[4])^ := regs.edx;
// assert(sizeof(CpuFeatures)=4*4+1);
{$ifdef Darwin}
{$ifdef CPU64}
// SSE42 asm does not (yet) work on Darwin x64 ...
Exclude(CpuFeatures, cfSSE42);
{$endif}
{$endif}
end;
{$endif CPUINTEL}
var
crc32ctab: array[0..{$ifdef PUREPASCAL}3{$else}7{$endif},byte] of cardinal;
function crc32cfast(crc: cardinal; buf: Pointer; len: cardinal): cardinal;
{$ifdef PUREPASCAL}
begin
result := not crc;
if (buf<>nil) and (len>0) then begin
repeat
if PtrUInt(buf) and 3=0 then // align to 4 bytes boundary
break;
result := crc32ctab[0,ToByte(result xor cardinal(buf^))] xor (result shr 8);
dec(len);
inc(buf);
until len=0;
while len>=4 do begin
result := result xor PCardinal(buf)^;
inc(buf,4);
result := crc32ctab[3,ToByte(result)] xor
crc32ctab[2,ToByte(result shr 8)] xor
crc32ctab[1,ToByte(result shr 16)] xor
crc32ctab[0,result shr 24];
dec(len,4);
end;
while len>0 do begin
result := crc32ctab[0,ToByte(result xor cardinal(buf^))] xor (result shr 8);
dec(len);
inc(buf);
end;
end;
result := not result;
end;
{$else}
// adapted from fast Aleksandr Sharahov version
asm
test edx, edx
jz @ret
neg ecx
jz @ret
not eax
push ebx
@head: test dl, 3
jz @aligned
movzx ebx, byte[edx]
inc edx
xor bl, al
shr eax, 8
xor eax, dword ptr[ebx * 4 + crc32ctab]
inc ecx
jnz @head
pop ebx
not eax
ret
@ret: rep ret
@aligned:
sub edx, ecx
add ecx, 8
jg @bodydone
push esi
push edi
mov edi, edx
mov edx, eax
@bodyloop:
mov ebx, [edi + ecx - 4]
xor edx, [edi + ecx - 8]
movzx esi, bl
mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3]
movzx esi, bh
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2]
shr ebx, 16
movzx esi, bl
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1]
movzx esi, bh
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0]
movzx esi, dl
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 7]
movzx esi, dh
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 6]
shr edx, 16
movzx esi, dl
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 5]
movzx esi, dh
xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 4]
add ecx, 8
jg @done
mov ebx, [edi + ecx - 4]
xor eax, [edi + ecx - 8]
movzx esi, bl
mov edx, dword ptr[esi * 4 + crc32ctab + 1024 * 3]
movzx esi, bh
xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 2]
shr ebx, 16
movzx esi, bl
xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 1]
movzx esi, bh
xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 0]
movzx esi, al
xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 7]
movzx esi, ah
xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 6]
shr eax, 16
movzx esi, al
xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 5]
movzx esi, ah
xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 4]
add ecx, 8
jle @bodyloop
mov eax, edx
@done: mov edx, edi
pop edi
pop esi
@bodydone:
sub ecx, 8
jl @tail
pop ebx
not eax
ret
@tail: movzx ebx, byte[edx + ecx]
xor bl, al
shr eax, 8
xor eax, dword ptr[ebx * 4 + crc32ctab]
inc ecx
jnz @tail
pop ebx
not eax
end;
{$endif PUREPASCAL}
procedure InitializeCrc32ctab;
var
i, n: integer;
crc: cardinal;
begin
// initialize tables for crc32cfast() and SymmetricEncrypt/FillRandom
for i := 0 to 255 do begin
crc := i;
for n := 1 to 8 do
if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32()
crc := (crc shr 1) xor $82f63b78 else
crc := crc shr 1;
crc32ctab[0,i] := crc;
end;
for i := 0 to 255 do begin
crc := crc32ctab[0,i];
for n := 1 to high(crc32ctab) do begin
crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)];
crc32ctab[n,i] := crc;
end;
end;
end;
begin
{$ifdef CPUINTEL}
TestIntelCpuFeatures;
if cfSSE42 in CpuFeatures then
begin
crc32c := @crc32csse42;
mORMotHasher := @crc32csse42;
end
else
{$endif CPUINTEL}
begin
InitializeCrc32ctab;
crc32c := @crc32cfast;
mORMotHasher := @xxHash32;
end;
end.

2
components/sparta/generics/source/generics.helpers.pas
View File

@ -20,6 +20,8 @@ unit Generics.Helpers;
{$MODE DELPHI}{$H+}
{$MODESWITCH TYPEHELPERS}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
interface

27
components/sparta/generics/source/generics.memoryexpanders.pas
View File

@ -21,6 +21,8 @@ unit Generics.MemoryExpanders;
{$mode delphi}
{$MACRO ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{.$WARN 5024 OFF}
{.$WARN 4079 OFF}
@ -38,7 +40,7 @@ type
TLinearProbing = class(TProbeSequence)
public
class function Probe(I, {%H-}M, Hash: UInt32): UInt32; static; inline;
class function Probe(I, Hash: UInt32): UInt32; static; inline;
const MAX_LOAD_FACTOR = 1;
const DEFAULT_LOAD_FACTOR = 0.75;
@ -47,13 +49,8 @@ type
{ TQuadraticProbing }
TQuadraticProbing = class(TProbeSequence)
private
class constructor Create;
public
class var C1: UInt32;
class var C2: UInt32;
class function Probe(I, {%H-}M, Hash: UInt32): UInt32; static; inline;
class function Probe(I, Hash: UInt32): UInt32; static; inline;
const MAX_LOAD_FACTOR = 0.5;
const DEFAULT_LOAD_FACTOR = 0.5;
@ -63,7 +60,7 @@ type
TDoubleHashing = class(TProbeSequence)
public
class function Probe(I, {%H-}M, Hash1: UInt32; Hash2: UInt32 = 1): UInt32; static; inline;
class function Probe(I, Hash1: UInt32; Hash2: UInt32 = 1): UInt32; static; inline;
const MAX_LOAD_FACTOR = 1;
const DEFAULT_LOAD_FACTOR = 0.85;
@ -207,27 +204,21 @@ end;
{ TLinearProbing }
class function TLinearProbing.Probe(I, M, Hash: UInt32): UInt32;
class function TLinearProbing.Probe(I, Hash: UInt32): UInt32;
begin
Result := (Hash + I)
end;
{ TQuadraticProbing }
class constructor TQuadraticProbing.Create;
class function TQuadraticProbing.Probe(I, Hash: UInt32): UInt32;
begin
C1 := 1;
C2 := 1;
end;
class function TQuadraticProbing.Probe(I, M, Hash: UInt32): UInt32;
begin
Result := (Hash + C1 * I {%H-}+ C2 * Sqr(I));
Result := (Hash + Sqr(I));
end;
{ TDoubleHashingNoMod }
class function TDoubleHashing.Probe(I, M, Hash1: UInt32; Hash2: UInt32): UInt32;
class function TDoubleHashing.Probe(I, Hash1: UInt32; Hash2: UInt32): UInt32;
begin
Result := Hash1 + I * Hash2;
end;

3
components/sparta/generics/source/generics.strings.pas
View File

@ -24,7 +24,10 @@ interface
resourcestring
SArgumentOutOfRange = 'Argument out of range';
SArgumentNilNode = 'Node is nil';
SDuplicatesNotAllowed = 'Duplicates not allowed in dictionary';
SCollectionInconsistency = 'Collection inconsistency';
SCollectionDuplicate = 'Collection does not allow duplicates';
SDictionaryKeyDoesNotExist = 'Dictionary key does not exist';
SItemNotFound = 'Item not found';

498
components/sparta/generics/source/inc/generics.dictionaries.inc
View File

@ -16,6 +16,14 @@
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Acknowledgment
Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring
many new types and major refactoring of entire library
Thanks to mORMot (http://synopse.info) project for the best implementations
of hashing functions like crc32c and xxHash32 :)
**********************************************************************}
{ TPair<TKey,TValue> }
@ -29,7 +37,7 @@ end;
{ TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS> }
procedure TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.PairNotify(constref APair: TPair<TKey, TValue>;
procedure TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.PairNotify(constref APair: TDictionaryPair;
ACollectionNotification: TCollectionNotification);
begin
KeyNotify(APair.Key, ACollectionNotification);
@ -88,16 +96,35 @@ begin
Create(ACollection, TEqualityComparer<TKey>.Default(THashFactory));
end;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create(ACollection: TEnumerableWithPointers<TDictionaryPair>);
begin
Create(ACollection, TEqualityComparer<TKey>.Default(THashFactory));
end;
{$ENDIF}
constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>;
const AComparer: IEqualityComparer<TKey>); overload;
var
LItem: TPair<TKey, TValue>;
LItem: TDictionaryPair;
begin
Create(AComparer);
for LItem in ACollection do
Add(LItem);
end;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create(ACollection: TEnumerableWithPointers<TDictionaryPair>;
const AComparer: IEqualityComparer<TKey>); overload;
var
LItem: PDictionaryPair;
begin
Create(AComparer);
for LItem in ACollection.Ptr^ do
Add(LItem^);
end;
{$ENDIF}
destructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Destroy;
begin
Clear;
@ -143,27 +170,32 @@ begin
Result := GetCurrent;
end;
{ TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS> }
{ TDictionaryEnumerable<TDictionaryEnumerator, TDictionaryPointersEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS> }
constructor TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.Create(
function TDictionaryEnumerable<TDictionaryEnumerator, TDictionaryPointersEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.GetPtrEnumerator: TEnumerator<PT>;
begin
Result := TDictionaryPointersEnumerator.Create(FDictionary);
end;
constructor TDictionaryEnumerable<TDictionaryEnumerator, TDictionaryPointersEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.Create(
ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
begin
FDictionary := ADictionary;
end;
function TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.
function TDictionaryEnumerable<TDictionaryEnumerator, TDictionaryPointersEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.
DoGetEnumerator: TDictionaryEnumerator;
begin
Result := TDictionaryEnumerator(TDictionaryEnumerator.NewInstance);
TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>(Result).Create(FDictionary);
end;
function TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.GetCount: SizeInt;
function TDictionaryEnumerable<TDictionaryEnumerator, TDictionaryPointersEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.GetCount: SizeInt;
begin
Result := TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>(FDictionary).Count;
end;
function TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.ToArray: TArray<T>;
function TDictionaryEnumerable<TDictionaryEnumerator, TDictionaryPointersEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.ToArray: TArray<T>;
begin
Result := ToArrayImpl(FDictionary.Count);
end;
@ -193,6 +225,89 @@ begin
Result := True;
end;
{ TOpenAddressingPointersEnumerator<TItem, PDictionaryPair> }
function TOpenAddressingPointersEnumerator<TItem, PDictionaryPair>.DoMoveNext: boolean;
var
LLength: SizeInt;
begin
Inc(FIndex);
LLength := Length(FItems^);
if FIndex >= LLength then
Exit(False);
// maybe related to bug #24098
// compiler error for (TDictionary<DICTIONARY_CONSTRAINTS>(FDictionary).FItems[FIndex].Hash and UInt32.GetSignMask) = 0
while (FItems^[FIndex].Hash and UInt32.GetSignMask) = 0 do
begin
Inc(FIndex);
if FIndex = LLength then
Exit(False);
end;
Result := True;
end;
function TOpenAddressingPointersEnumerator<TItem, PDictionaryPair>.DoGetCurrent: PDictionaryPair;
begin
Result := GetCurrent;
end;
function TOpenAddressingPointersEnumerator<TItem, PDictionaryPair>.GetCurrent: PDictionaryPair;
begin
Result := @FItems^[FIndex].Pair;
end;
constructor TOpenAddressingPointersEnumerator<TItem, PDictionaryPair>.Create(var AItems);
begin
FIndex := -1;
FItems := @AItems;
end;
{ TOpenAddressingPointersCollection<TPointersEnumerator, TItem, PDictionaryPair> }
function TOpenAddressingPointersCollection<TPointersEnumerator, TItem, PDictionaryPair>.Items: PArray;
begin
Result := PArray(@((@Self)^));
end;
function TOpenAddressingPointersCollection<TPointersEnumerator, TItem, PDictionaryPair>.GetCount: SizeInt;
begin
Result := PSizeInt(PByte(@((@Self)^))-SizeOf(SizeInt))^;
end;
function TOpenAddressingPointersCollection<TPointersEnumerator, TItem, PDictionaryPair>.GetEnumerator: TPointersEnumerator;
begin
Result := TPointersEnumerator(TPointersEnumerator.NewInstance);
TPointersEnumerator(Result).Create(Items^);
end;
function TOpenAddressingPointersCollection<TPointersEnumerator, TItem, PDictionaryPair>.ToArray: TArray<PDictionaryPair>;
{begin
Result := ToArrayImpl(FList.Count);
end;}
var
i: SizeInt;
LEnumerator: TPointersEnumerator;
begin
SetLength(Result, GetCount);
try
LEnumerator := GetEnumerator;
i := 0;
while LEnumerator.MoveNext do
begin
Result[i] := LEnumerator.Current;
Inc(i);
end;
finally
LEnumerator.Free;
end;
end;
{ TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS> }
constructor TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACapacity: SizeInt;
@ -224,7 +339,7 @@ begin
Result := FindBucketIndex(FItems, AKey, LHash);
end;
function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.PrepareAddingItem: SizeInt;
procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.PrepareAddingItem;
begin
if RealItemsLength > FItemsThreshold then
Rehash(Length(FItems) shl 1)
@ -235,9 +350,6 @@ begin
end
else if FItemsLength = $40000001 then // High(TIndex) ... Error: Type mismatch
OutOfMemoryError;
Result := FItemsLength;
Inc(FItemsLength);
end;
procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.UpdateItemsThreshold(ASize: SizeInt);
@ -255,9 +367,17 @@ begin
AItem.Pair.Key := AKey;
AItem.Pair.Value := AValue;
// ! very important. FItemsLength must be increased after above code (because constref has meaning)
Inc(FItemsLength);
PairNotify(AItem.Pair, cnAdded);
end;
function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.GetPointers: PPointersCollection;
begin
Result := PPointersCollection(@FItems);
end;
procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Add(constref AKey: TKey; constref AValue: TValue);
begin
DoAdd(AKey, AValue);
@ -302,7 +422,7 @@ var
LIndex: SizeInt;
begin
LIndex := FindBucketIndex(AKey);
if LIndex < 0 then
if LIndex < 0 then
Exit;
DoRemove(LIndex, cnRemoved);
@ -313,7 +433,7 @@ var
LIndex: SizeInt;
begin
LIndex := FindBucketIndex(AKey);
if LIndex < 0 then
if LIndex < 0 then
Exit(Default(TPair<TKey, TValue>));
Result.Key := AKey;
@ -555,6 +675,13 @@ begin
Result := TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems[FIndex].Pair.Value;
end;
{ TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TPValueEnumerator }
function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TPValueEnumerator.GetCurrent: PValue;
begin
Result := @(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems[FIndex].Pair.Value);
end;
{ TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TKeyEnumerator }
function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TKeyEnumerator.GetCurrent: TKey;
@ -562,6 +689,13 @@ begin
Result := TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems[FIndex].Pair.Key;
end;
{ TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TPKeyEnumerator }
function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TPKeyEnumerator.GetCurrent: PKey;
begin
Result := @(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems[FIndex].Pair.Key);
end;
{ TOpenAddressingLP<DICTIONARY_CONSTRAINTS> }
procedure TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.NotifyIndexChange(AFrom, ATo: SizeInt);
@ -574,7 +708,7 @@ var
LItem: PItem;
LPair: TPair<TKey, TValue>;
LLengthMask: SizeInt;
i, m, LIndex, LGapIndex: SizeInt;
i, LIndex, LGapIndex: SizeInt;
LHash, LBucket: UInt32;
begin
LItem := @FItems[AIndex];
@ -583,12 +717,11 @@ begin
// try fill gap
LHash := LItem.Hash;
LItem.Hash := 0; // prevents an infinite searching loop
m := Length(FItems);
LLengthMask := m - 1;
LLengthMask := Length(FItems) - 1;
i := Succ(AIndex - (LHash and LLengthMask));
LGapIndex := AIndex;
repeat
LIndex := TProbeSequence.Probe(i, m, LHash) and LLengthMask;
LIndex := TProbeSequence.Probe(i, LHash) and LLengthMask;
LItem := @FItems[LIndex];
// Empty position
@ -650,7 +783,7 @@ begin
Inc(i);
Result := TProbeSequence.Probe(i, m, AHash) and LLengthMask;
Result := TProbeSequence.Probe(i, AHash) and LLengthMask;
until false;
end;
@ -743,7 +876,7 @@ begin
Inc(i);
Result := TProbeSequence.Probe(i, m, AHash) and LLengthMask;
Result := TProbeSequence.Probe(i, AHash) and LLengthMask;
until false;
end;
@ -783,11 +916,93 @@ begin
Inc(i);
Result := TProbeSequence.Probe(i, m, AHash) and LLengthMask;
Result := TProbeSequence.Probe(i, AHash) and LLengthMask;
until false;
end;
{ TOpenAddressingQP<OPEN_ADDRESSING_CONSTRAINTS> }
procedure TOpenAddressingQP<OPEN_ADDRESSING_CONSTRAINTS>.UpdateItemsThreshold(ASize: SizeInt);
begin
if ASize = $40000000 then
FItemsThreshold := $40000001
else
begin
FPrimaryNumberAsSizeApproximation := PrimaryNumbersJustLessThanPowerOfTwo[
MultiplyDeBruijnBitPosition[UInt32(((ASize and -ASize) * $077CB531)) shr 27]];
FItemsThreshold := Pred(Round(FPrimaryNumberAsSizeApproximation * FMaxLoadFactor));
end;
end;
function TOpenAddressingQP<OPEN_ADDRESSING_CONSTRAINTS>.FindBucketIndex(constref AItems: TArray<TItem>;
constref AKey: TKey; out AHash: UInt32): SizeInt;
var
LItem: {TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.}_TItem; // for workaround Lazarus bug #25613
i: SizeInt;
LHash: UInt32;
begin
LHash := FEqualityComparer.GetHashCode(AKey);
i := 0;
AHash := LHash or UInt32.GetSignMask;
if Length(AItems) = 0 then
Exit(-1);
for i := 0 to FPrimaryNumberAsSizeApproximation - 1 do
begin
Result := TProbeSequence.Probe(i, AHash) mod FPrimaryNumberAsSizeApproximation;
LItem := _TItem(AItems[Result]);
// Empty position
if LItem.Hash = 0 then
Exit(not Result); // insert!
// Same position?
if LItem.Hash = AHash then
if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then
Exit;
end;
Result := -1;
end;
function TOpenAddressingQP<OPEN_ADDRESSING_CONSTRAINTS>.FindBucketIndexOrTombstone(constref AItems: TArray<TItem>;
constref AKey: TKey; out AHash: UInt32): SizeInt;
var
LItem: {TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.}_TItem; // for workaround Lazarus bug #25613
i: SizeInt;
LHash: UInt32;
begin
LHash := FEqualityComparer.GetHashCode(AKey);
i := 0;
AHash := LHash or UInt32.GetSignMask;
if Length(AItems) = 0 then
Exit(-1);
for i := 0 to FPrimaryNumberAsSizeApproximation - 1 do
begin
Result := TProbeSequence.Probe(i, AHash) mod FPrimaryNumberAsSizeApproximation;
LItem := _TItem(AItems[Result]);
// Empty position or tombstone
if LItem.Hash and UInt32.GetSignMask = 0 then
Exit(not Result); // insert!
// Same position?
if LItem.Hash = AHash then
if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then
Exit;
end;
Result := -1;
end;
{ TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS> }
constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACapacity: SizeInt;
@ -804,6 +1019,13 @@ constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACollection: T
begin
end;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACollection: TEnumerableWithPointers<TDictionaryPair>;
const AComparer: IEqualityComparer<TKey>);
begin
end;
{$ENDIF}
constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACapacity: SizeInt);
begin
Create(ACapacity, TExtendedEqualityComparer<TKey>.Default(THashFactory));
@ -814,6 +1036,13 @@ begin
Create(ACollection, TExtendedEqualityComparer<TKey>.Default(THashFactory));
end;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACollection: TEnumerableWithPointers<TDictionaryPair>);
begin
Create(ACollection, TExtendedEqualityComparer<TKey>.Default(THashFactory));
end;
{$ENDIF}
constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACapacity: SizeInt;
const AComparer: IExtendedEqualityComparer<TKey>);
begin
@ -830,13 +1059,25 @@ end;
constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>;
const AComparer: IExtendedEqualityComparer<TKey>);
var
LItem: TPair<TKey, TValue>;
LItem: TDictionaryPair;
begin
Create(AComparer);
for LItem in ACollection do
Add(LItem);
end;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACollection: TEnumerableWithPointers<TDictionaryPair>;
const AComparer: IExtendedEqualityComparer<TKey>);
var
LItem: PDictionaryPair;
begin
Create(AComparer);
for LItem in ACollection.Ptr^ do
Add(LItem^);
end;
{$ENDIF}
procedure TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.UpdateItemsThreshold(ASize: SizeInt);
begin
inherited;
@ -885,7 +1126,7 @@ begin
Inc(i);
Result := TProbeSequence.Probe(i, m, AHash, LHash2) and LLengthMask;
Result := TProbeSequence.Probe(i, AHash, LHash2) and LLengthMask;
until false;
end;
@ -929,7 +1170,7 @@ begin
Inc(i);
Result := TProbeSequence.Probe(i, m, AHash, LHash2) and LLengthMask;
Result := TProbeSequence.Probe(i, AHash, LHash2) and LLengthMask;
until false;
end;
@ -992,6 +1233,126 @@ begin
Result := True;
end;
{ TDeamortizedDArrayPointersEnumerator<TCuckooCfg, TItemsArray, TItemsDArray, TQueueDictionary, PDictionaryPair> }
function TDeamortizedDArrayPointersEnumerator<TCuckooCfg, TItemsArray, TItemsDArray, TQueueDictionary, PDictionaryPair>.DoMoveNext: boolean;
var
LLength: SizeInt;
LArray: TItemsArray;
begin
Inc(FIndex);
if (FMainIndex = TCuckooCfg.D) then // queue
begin
LLength := Length(FQueue.FItems);
if FIndex >= LLength then
Exit(False);
while ((FQueue.FItems[FIndex].Hash)
and UInt32.GetSignMask) = 0 do
begin
Inc(FIndex);
if FIndex = LLength then
Exit(False);
end;
end
else // d-array
begin
LArray := FItems^[FMainIndex];
LLength := Length(LArray);
if FIndex >= LLength then
begin
Inc(FMainIndex);
FIndex := -1;
Exit(DoMoveNext);
end;
while (((LArray[FIndex]).Hash) and UInt32.GetSignMask) = 0 do
begin
Inc(FIndex);
if FIndex = LLength then
begin
Inc(FMainIndex);
FIndex := -1;
Exit(DoMoveNext);
end;
end;
end;
Result := True;
end;
function TDeamortizedDArrayPointersEnumerator<TCuckooCfg, TItemsArray, TItemsDArray, TQueueDictionary, PDictionaryPair>.DoGetCurrent: PDictionaryPair;
begin
Result := GetCurrent;
end;
function TDeamortizedDArrayPointersEnumerator<TCuckooCfg, TItemsArray, TItemsDArray, TQueueDictionary, PDictionaryPair>.GetCurrent: PDictionaryPair;
begin
if FMainIndex = TCuckooCfg.D then
Result := @(FQueue.FItems[FIndex].Pair.Value.Pair)
else
Result := @((FItems^[FMainIndex])[FIndex].Pair);
end;
constructor TDeamortizedDArrayPointersEnumerator<TCuckooCfg, TItemsArray, TItemsDArray, TQueueDictionary, PDictionaryPair>.Create(var AItems; AQueue: TQueueDictionary; ACount: SizeInt);
begin
FIndex := -1;
if ACount = 0 then
FMainIndex := TCuckooCfg.D
else
FMainIndex := 0;
FQueue := AQueue;
FItems := @AItems;
end;
{ TDeamortizedDArrayPointersCollection<TPointersEnumerator, TItem, TQueueDictionary, PDictionaryPair> }
function TDeamortizedDArrayPointersCollection<TPointersEnumerator, TItemsDArray, TQueueDictionary, PDictionaryPair>.Items: PArray;
begin
Result := PArray(@((@Self)^));
end;
function TDeamortizedDArrayPointersCollection<TPointersEnumerator, TItemsDArray, TQueueDictionary, PDictionaryPair>.GetCount: SizeInt;
begin
Result := SizeInt((@PByte(@((@Self)^))[-SizeOf(SizeInt)])^);
end;
function TDeamortizedDArrayPointersCollection<TPointersEnumerator, TItemsDArray, TQueueDictionary, PDictionaryPair>.GetQueue: TQueueDictionary;
begin
Result := TQueueDictionary((@PByte(@((@Self)^))[SizeOf(TItemsDArray)])^);
end;
function TDeamortizedDArrayPointersCollection<TPointersEnumerator, TItemsDArray, TQueueDictionary, PDictionaryPair>.GetEnumerator: TPointersEnumerator;
begin
Result := TPointersEnumerator(TPointersEnumerator.NewInstance);
TPointersEnumerator(Result).Create(Items^, GetQueue, GetCount);
end;
function TDeamortizedDArrayPointersCollection<TPointersEnumerator, TItemsDArray, TQueueDictionary, PDictionaryPair>.ToArray: TArray<PDictionaryPair>;
{begin
Result := ToArrayImpl(FList.Count);
end;}
var
i: SizeInt;
LEnumerator: TPointersEnumerator;
begin
SetLength(Result, GetCount);
try
LEnumerator := GetEnumerator;
i := 0;
while LEnumerator.MoveNext do
begin
Result[i] := LEnumerator.Current;
Inc(i);
end;
finally
LEnumerator.Free;
end;
end;
{ TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS> }
function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.Rehash(ASizePow2: SizeInt;
@ -1052,7 +1413,7 @@ end;
function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.Pop: Pointer;
var
AIndex, LGap: SizeInt;
AIndex: SizeInt;
//LResult: TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TItem; !!!bug #25917
begin
AIndex := FIdx.DoRemove(FIdx.Count - 1, cnExtracted);
@ -1092,6 +1453,13 @@ constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACollection:
begin
end;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACollection: TEnumerableWithPointers<TDictionaryPair>;
const AComparer: IEqualityComparer<TKey>);
begin
end;
{$ENDIF}
constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create;
begin
Create(0);
@ -1107,6 +1475,13 @@ begin
Create(ACollection, TExtendedEqualityComparer<TKey>.Default(THashFactory));
end;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACollection: TEnumerableWithPointers<TDictionaryPair>);
begin
Create(ACollection, TExtendedEqualityComparer<TKey>.Default(THashFactory));
end;
{$ENDIF}
constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACapacity: SizeInt;
const AComparer: IExtendedEqualityComparer<TKey>);
begin
@ -1136,13 +1511,25 @@ end;
constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>;
const AComparer: IExtendedEqualityComparer<TKey>);
var
LItem: TPair<TKey, TValue>;
LItem: TDictionaryPair;
begin
Create(AComparer);
for LItem in ACollection do
Add(LItem);
end;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACollection: TEnumerableWithPointers<TDictionaryPair>;
const AComparer: IExtendedEqualityComparer<TKey>);
var
LItem: PDictionaryPair;
begin
Create(AComparer);
for LItem in ACollection.Ptr^ do
Add(LItem^);
end;
{$ENDIF}
destructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Destroy;
begin
inherited;
@ -1164,6 +1551,11 @@ begin
Result := TValueCollection(FValues);
end;
function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetPointers: PPointersCollection;
begin
Result := PPointersCollection(@FItems);
end;
function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Lookup(constref AKey: TKey;
var AHashListOrIndex: PUInt32): SizeInt;
begin
@ -1229,7 +1621,7 @@ begin
Result := LR_NIL;
end;
function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.PrepareAddingItem: SizeInt;
procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.PrepareAddingItem;
var
i: SizeInt;
begin
@ -1243,9 +1635,6 @@ begin
end
else if FItemsLength = $40000001 then // High(TIndex) ... Error: Type mismatch
OutOfMemoryError;
Result := FItemsLength;
Inc(FItemsLength);
end;
procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.UpdateItemsThreshold(ASize: SizeInt);
@ -1267,7 +1656,7 @@ var
y: boolean = false;
b: UInt32;
LIndex: UInt32;
i, j, LLengthMask: SizeInt;
i, LLengthMask: SizeInt;
LTempItem: TItem;
LHashList: array[0..1] of UInt32;
LHashListParams: array[0..3] of UInt16 absolute LHashList;
@ -1330,10 +1719,11 @@ begin
FQueue.InsertIntoHead(@LNewItem);
end;
procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.DoAdd(constref AKey: TKey; constref AValue: TValue;
procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.DoAdd(const AKey: TKey; const AValue: TValue;
const AHashList: PUInt32);
begin
AddItem(FItems, AKey, AValue, AHashList);
Inc(FItemsLength);
KeyNotify(AKey, cnAdded);
ValueNotify(AValue, cnAdded);
end;
@ -1464,10 +1854,8 @@ end;
procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Rehash(ASizePow2: SizeInt);
var
LNewItems: TItemsDArray;
LHash: UInt32;
LIndex: SizeInt;
i, j: SizeInt;
LItem, LNewItem: PItem;
LItem: PItem;
LOldQueue: TQueueDictionary;
var
LHashList: array[0..1] of UInt32;
@ -1607,6 +1995,8 @@ end;
procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TrimExcess;
begin
SetCapacity(Succ(FItemsLength));
FQueue.TrimExcess;
FQueue.FIdx.TrimExcess;
end;
procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.SetItem(constref AValue: TValue;
@ -1630,7 +2020,6 @@ var
LHashList: array[0..TCuckooCfg.D] of UInt32;
LHashListOrIndex: PUint32;
LLookupResult: SizeInt;
LIndex: UInt32;
begin
LHashListOrIndex := @LHashList[0];
LLookupResult := Lookup(AKey, LHashListOrIndex);
@ -1666,16 +2055,17 @@ var
LHashList: array[0..TCuckooCfg.D] of UInt32;
LHashListOrIndex: PUint32;
LLookupResult: SizeInt;
LIndex: UInt32;
begin
LHashListOrIndex := @LHashList[0];
LLookupResult := Lookup(AKey, LHashListOrIndex);
if LLookupResult = LR_NIL then
begin
PrepareAddingItem;
DoAdd(AKey, AValue, LHashListOrIndex);
end
Add(AKey, AValue)
// more optimal version for AddOrSetValue has some bug : see Test_CuckooD2_Notification
//begin
// PrepareAddingItem;
// DoAdd(AKey, AValue, LHashListOrIndex);
//end
else
SetItem(AValue, LHashListOrIndex, LLookupResult);
end;
@ -1751,6 +2141,16 @@ begin
Result := TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FItems[FMainIndex][FIndex].Pair.Value;
end;
{ TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TPValueEnumerator }
function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TPValueEnumerator.GetCurrent: PValue;
begin
if FMainIndex = TCuckooCfg.D then
Result := @(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair.Value)
else
Result := @(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FItems[FMainIndex][FIndex].Pair.Value);
end;
{ TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TKeyEnumerator }
function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TKeyEnumerator.GetCurrent: TKey;
@ -1761,6 +2161,16 @@ begin
Result := TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FItems[FMainIndex][FIndex].Pair.Key;
end;
{ TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TPKeyEnumerator }
function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TPKeyEnumerator.GetCurrent: TKey;
begin
if FMainIndex = TCuckooCfg.D then
Result := @(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair.Key)
else
Result := @(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FItems[FMainIndex][FIndex].Pair.Key);
end;
{ TObjectDictionary<DICTIONARY_CONSTRAINTS> }
procedure TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.KeyNotify(
@ -1769,7 +2179,7 @@ begin
inherited;
if (doOwnsKeys in FOwnerships) and (ACollectionNotification = cnRemoved) then
TObject(AKey).Free;
TObject((@AKey)^).Free;
end;
procedure TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.ValueNotify(constref AValue: TValue;
@ -1778,7 +2188,7 @@ begin
inherited;
if (doOwnsValues in FOwnerships) and (ACollectionNotification = cnRemoved) then
TObject(AValue).Free;
TObject((@AValue)^).Free;
end;
constructor TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(
@ -1817,7 +2227,7 @@ begin
inherited;
if (doOwnsKeys in FOwnerships) and (ACollectionNotification = cnRemoved) then
TObject(AKey).Free;
TObject((@AKey)^).Free;
end;
procedure TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.ValueNotify(
@ -1826,7 +2236,7 @@ begin
inherited;
if (doOwnsValues in FOwnerships) and (ACollectionNotification = cnRemoved) then
TObject(AValue).Free;
TObject((@AValue)^).Free;
end;
constructor TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.Create(AOwnerships: TDictionaryOwnerships);

186
components/sparta/generics/source/inc/generics.dictionariesh.inc
View File

@ -16,6 +16,14 @@
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Acknowledgment
Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring
many new types and major refactoring of entire library
Thanks to mORMot (http://synopse.info) project for the best implementations
of hashing functions like crc32c and xxHash32 :)
**********************************************************************}
{$WARNINGS OFF}
@ -44,8 +52,7 @@ type
PKey = ^TKey;
PValue = ^TValue;
THashFactoryClass = THashFactory;
public
FItemsLength: SizeInt;
protected
FEqualityComparer: IEqualityComparer<TKey>;
FKeys: TEnumerable<TKey>;
FValues: TEnumerable<TValue>;
@ -63,8 +70,6 @@ type
property LoadFactor: single read GetLoadFactor;
property Capacity: SizeInt read GetCapacity write SetCapacity;
property Count: SizeInt read FItemsLength;
procedure Clear; virtual; abstract;
procedure Add(constref APair: TPair<TKey, TValue>); virtual; abstract;
strict private // bug #24283. workaround for this class because can't inherit from TEnumerable
@ -78,6 +83,10 @@ type
constructor Create(const AComparer: IEqualityComparer<TKey>); overload;
constructor Create(ACollection: TEnumerable<TDictionaryPair>); virtual; overload;
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); virtual; overload;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor Create(ACollection: TEnumerableWithPointers<TDictionaryPair>); virtual; overload;
constructor Create(ACollection: TEnumerableWithPointers<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); virtual; overload;
{$ENDIF}
destructor Destroy; override;
private
@ -88,11 +97,15 @@ type
procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); virtual;
procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); virtual;
procedure PairNotify(constref APair: TPair<TKey, TValue>; ACollectionNotification: TCollectionNotification); inline;
procedure PairNotify(constref APair: TDictionaryPair; ACollectionNotification: TCollectionNotification); inline;
procedure SetValue(var AValue: TValue; constref ANewValue: TValue);
public
property OnKeyNotify: TCollectionNotifyEvent<TKey> read FOnKeyNotify write FOnKeyNotify;
property OnValueNotify: TCollectionNotifyEvent<TValue> read FOnValueNotify write FOnValueNotify;
protected // FItemsLength must be declared at the end of TCustomDictionary
FItemsLength: SizeInt;
public
property Count: SizeInt read FItemsLength;
end;
{ TCustomDictionaryEnumerator }
@ -110,27 +123,52 @@ type
{ TDictionaryEnumerable }
TDictionaryEnumerable<TDictionaryEnumerator, // ... inherits from TCustomDictionaryEnumerator. workaround...
T, CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract(TEnumerable<T>)
TDictionaryEnumerable<TDictionaryEnumerator: TObject; TDictionaryPointersEnumerator, // ... inherits from TCustomDictionaryEnumerator. workaround...
T, CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract(TEnumerableWithPointers<T>)
private
FDictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>;
function GetCount: SizeInt;
protected
function GetPtrEnumerator: TEnumerator<PT>; override;
function DoGetEnumerator: TDictionaryEnumerator; override;
public
constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
function DoGetEnumerator: TDictionaryEnumerator; override;
function ToArray: TArray<T>; override; final;
property Count: SizeInt read GetCount;
end;
// more info : http://en.wikipedia.org/wiki/Open_addressing
{ TDictionaryEnumerable }
{ TOpenAddressingEnumerator }
TOpenAddressingEnumerator<T, OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>)
protected
function DoMoveNext: Boolean; override;
end;
TOpenAddressingPointersEnumerator<TItem, PDictionaryPair> = class abstract(TEnumerator<PDictionaryPair>)
private var
FItems: ^TArray<TItem>;
FIndex: SizeInt;
protected
function DoMoveNext: boolean; override;
function DoGetCurrent: PDictionaryPair; override;
function GetCurrent: PDictionaryPair; virtual;
public
constructor Create(var AItems);
end;
TOpenAddressingPointersCollection<TPointersEnumerator, TItem, PDictionaryPair> = record
private type
PArray = ^TArray<TItem>;
function Items: PArray; inline;
function GetCount: SizeInt; inline;
public
function GetEnumerator: TPointersEnumerator;
function ToArray: TArray<PDictionaryPair>;
property Count: SizeInt read GetCount;
end;
TOnGetMemoryLayoutKeyPosition = procedure(Sender: TObject; AKeyPos: UInt32) of object;
TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>)
@ -142,12 +180,16 @@ type
end;
TItemsArray = array of TItem;
private var
FItemsThreshold: SizeInt;
TPointersEnumerator = class(TOpenAddressingPointersEnumerator<TItem, PDictionaryPair>);
TPointersCollection = TOpenAddressingPointersCollection<TPointersEnumerator, TItem, PDictionaryPair>;
public type
PPointersCollection = ^TPointersCollection;
private var // FItems must be declared as first field
FItems: TItemsArray;
FItemsThreshold: SizeInt;
procedure Resize(ANewSize: SizeInt);
function PrepareAddingItem: SizeInt;
procedure PrepareAddingItem;
protected
function RealItemsLength: SizeInt; virtual;
function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; virtual;
@ -166,21 +208,32 @@ type
function GetCurrent: TValue; override;
end;
TPValueEnumerator = class(TOpenAddressingEnumerator<PValue, OPEN_ADDRESSING_CONSTRAINTS>)
protected
function GetCurrent: PValue; override;
end;
TKeyEnumerator = class(TOpenAddressingEnumerator<TKey, OPEN_ADDRESSING_CONSTRAINTS>)
protected
function GetCurrent: TKey; override;
end;
// Collections
TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>);
TPKeyEnumerator = class(TOpenAddressingEnumerator<PKey, OPEN_ADDRESSING_CONSTRAINTS>)
protected
function GetCurrent: PKey; override;
end;
TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>);
// Collections
TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TPValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>);
TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TPKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>);
// bug #24283 - workaround related to lack of DoGetEnumerator
function GetEnumerator: TPairEnumerator; reintroduce;
private
function GetKeys: TKeyCollection;
function GetValues: TValueCollection;
function GetPointers: PPointersCollection; inline;
private
function GetItem(const AKey: TKey): TValue; inline;
procedure SetItem(const AKey: TKey; const AValue: TValue); inline;
@ -217,6 +270,7 @@ type
property Items[Index: TKey]: TValue read GetItem write SetItem; default;
property Keys: TKeyCollection read GetKeys;
property Values: TValueCollection read GetValues;
property Ptr: PPointersCollection read GetPointers;
procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition);
end;
@ -267,6 +321,17 @@ type
out AHash: UInt32): SizeInt; override;
end;
TOpenAddressingQP<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingSH<OPEN_ADDRESSING_CONSTRAINTS>)
private
FPrimaryNumberAsSizeApproximation: SizeInt;
protected
procedure UpdateItemsThreshold(ASize: SizeInt); override;
function FindBucketIndex(constref AItems: TArray<TItem>;
constref AKey: TKey; out AHash: UInt32): SizeInt; override; overload;
function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>;
constref AKey: TKey; out AHash: UInt32): SizeInt; override;
end;
TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>)
private type // for workaround Lazarus bug #25613
_TItem = record
@ -285,12 +350,21 @@ type
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
constructor Create(const AComparer: IEqualityComparer<TKey>); reintroduce; overload;
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor Create(ACollection: TEnumerableWithPointers<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload;
{$ENDIF}
public // bug #26181 (redundancy of constructors)
constructor Create(ACapacity: SizeInt); override; overload;
constructor Create(ACollection: TEnumerable<TDictionaryPair>); override; overload;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor Create(ACollection: TEnumerableWithPointers<TDictionaryPair>); override; overload;
{$ENDIF}
constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
constructor Create(const AComparer: IExtendedEqualityComparer<TKey>); overload;
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor Create(ACollection: TEnumerableWithPointers<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
{$ENDIF}
end;
TDeamortizedDArrayCuckooMapEnumerator<T, CUCKOO_CONSTRAINTS> = class abstract(TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>)
@ -308,6 +382,32 @@ type
constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>);
end;
TDeamortizedDArrayPointersEnumerator<TCuckooCfg, TItemsArray, TItemsDArray, TQueueDictionary, PDictionaryPair> = class abstract(TEnumerator<PDictionaryPair>)
private var // FItems must be declared as first field and FQueue as second
FItems: ^TItemsDArray;
FQueue: TQueueDictionary;
FIndex: SizeInt;
FMainIndex: SizeInt;
protected
function DoMoveNext: boolean; override;
function DoGetCurrent: PDictionaryPair; override;
function GetCurrent: PDictionaryPair; virtual;
public
constructor Create(var AItems; AQueue: TQueueDictionary; ACount: SizeInt);
end;
TDeamortizedDArrayPointersCollection<TPointersEnumerator, TItemsDArray, TQueueDictionary, PDictionaryPair> = record
private type
PArray = ^TItemsDArray;
function Items: PArray; inline;
function GetCount: SizeInt; inline;
function GetQueue: TQueueDictionary; inline;
public
function GetEnumerator: TPointersEnumerator;
function ToArray: TArray<PDictionaryPair>;
property Count: SizeInt read GetCount;
end;
// more info :
// http://arxiv.org/abs/0903.0391
@ -323,7 +423,7 @@ type
end;
TValueForQueue = TItem;
TQueueDictionary = class(TOpenAddressingLP<TKey, TValueForQueue, TDelphiHashFactory, TLinearProbing>)
TQueueDictionary = class(TOpenAddressingLP<TKey, TValueForQueue, TDefaultHashFactory, TLinearProbing>)
private type // for workaround Lazarus bug #25613
_TItem = record
Hash: UInt32;
@ -344,27 +444,31 @@ type
end;
// cycle-detection mechanism class
TCDM = class(TOpenAddressingSH<TKey, TEmptyRecord, TDelphiHashFactory, TLinearProbing>);
TCDM = class(TOpenAddressingSH<TKey, TEmptyRecord, TDefaultHashFactory, TLinearProbing>);
TItemsArray = array of TItem;
TItemsDArray = array[0..Pred(TCuckooCfg.D)] of TItemsArray;
TPointersEnumerator = class(TDeamortizedDArrayPointersEnumerator<TCuckooCfg, TItemsArray, TItemsDArray, TQueueDictionary, PDictionaryPair>);
TPointersCollection = TDeamortizedDArrayPointersCollection<TPointersEnumerator, TItemsDArray, TQueueDictionary, PDictionaryPair>;
public type
PPointersCollection = ^TPointersCollection;
private var
FItems: TItemsDArray;
FQueue: TQueueDictionary; // probably can be optimized - hash TItem give information from TItem.Hash for cuckoo ...
// currently is kept in "TQueueDictionary = class(TOpenAddressingSH<TKey, TItem, ...>"
FCDM: TCDM; // cycle-detection mechanism
FItemsThreshold: SizeInt;
FItems: TItemsDArray;
// sadly there is bug #24848 for class var ...
{class} var
CUCKOO_SIGN, CUCKOO_INDEX_SIZE, CUCKOO_HASH_SIGN: UInt32;
// CUCKOO_MAX_ITEMS_LENGTH: <- to do : calc max length for items based on CUCKOO sign
// maybe some CDM bloom filter?
procedure UpdateItemsThreshold(ASize: SizeInt); override;
procedure Resize(ANewSize: SizeInt);
procedure Rehash(ASizePow2: SizeInt);
function PrepareAddingItem: SizeInt;
procedure PrepareAddingItem;
protected
procedure UpdateItemsThreshold(ASize: SizeInt); override;
function Lookup(constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; inline; overload;
function Lookup(constref AItems: TItemsDArray; constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; virtual; overload;
public
@ -380,28 +484,39 @@ type
function GetCurrent: TValue; override;
end;
TPValueEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<PValue, CUCKOO_CONSTRAINTS>)
protected
function GetCurrent: PValue; override;
end;
TKeyEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TKey, CUCKOO_CONSTRAINTS>)
protected
function GetCurrent: TKey; override;
end;
// Collections
TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>);
TPKeyEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<PKey, CUCKOO_CONSTRAINTS>)
protected
function GetCurrent: PKey; override;
end;
TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>);
// Collections
TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TPValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>);
TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TPKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>);
// bug #24283 - workaround related to lack of DoGetEnumerator
function GetEnumerator: TPairEnumerator; reintroduce;
private
function GetKeys: TKeyCollection;
function GetValues: TValueCollection;
function GetPointers: PPointersCollection; inline;
private
function GetItem(const AKey: TKey): TValue; inline;
procedure SetItem(const AKey: TKey; const AValue: TValue); overload; inline;
procedure SetItem(constref AValue: TValue; const AHashListOrIndex: PUInt32; ALookupResult: SizeInt); overload;
procedure AddItem(constref AItems: TItemsDArray; constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload;
procedure DoAdd(constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload; inline;
procedure DoAdd(const AKey: TKey; const AValue: TValue; const AHashList: PUInt32); overload; inline;
function DoRemove(const AHashListOrIndex: PUInt32; ALookupResult: SizeInt;
ACollectionNotification: TCollectionNotification): TValue;
@ -417,15 +532,24 @@ type
constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload;
constructor Create(const AComparer: IEqualityComparer<TKey>); reintroduce; overload;
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor Create(ACollection: TEnumerableWithPointers<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload;
{$ENDIF}
public
// TODO: function TryFlushQueue(ACount: SizeInt): SizeInt;
constructor Create; override; overload;
constructor Create(ACapacity: SizeInt); override; overload;
constructor Create(ACollection: TEnumerable<TDictionaryPair>); override; overload;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor Create(ACollection: TEnumerableWithPointers<TDictionaryPair>); override; overload;
{$ENDIF}
constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
constructor Create(const AComparer: IExtendedEqualityComparer<TKey>); overload;
constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers}
constructor Create(ACollection: TEnumerableWithPointers<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload;
{$ENDIF}
destructor Destroy; override;
procedure Add(constref APair: TPair<TKey, TValue>); override; overload;
@ -443,6 +567,7 @@ type
property Items[Index: TKey]: TValue read GetItem write SetItem; default;
property Keys: TKeyCollection read GetKeys;
property Values: TValueCollection read GetValues;
property Ptr: PPointersCollection read GetPointers;
property QueueCount: SizeInt read GetQueueCount;
procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition);
@ -486,17 +611,17 @@ type
// useful generics overloads
TOpenAddressingLP<TKey, TValue, THashFactory> = class(TOpenAddressingLP<TKey, TValue, THashFactory, TLinearProbing>);
TOpenAddressingLP<TKey, TValue> = class(TOpenAddressingLP<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
TOpenAddressingLP<TKey, TValue> = class(TOpenAddressingLP<TKey, TValue, TDefaultHashFactory, TLinearProbing>);
TObjectOpenAddressingLP<TKey, TValue, THashFactory> = class(TObjectOpenAddressingLP<TKey, TValue, THashFactory, TLinearProbing>);
TObjectOpenAddressingLP<TKey, TValue> = class(TObjectOpenAddressingLP<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
TObjectOpenAddressingLP<TKey, TValue> = class(TObjectOpenAddressingLP<TKey, TValue, TDefaultHashFactory, TLinearProbing>);
// Linear Probing with Tombstones (LPT)
TOpenAddressingLPT<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TLinearProbing>);
TOpenAddressingLPT<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, TLinearProbing>);
TOpenAddressingLPT<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDefaultHashFactory, TLinearProbing>);
TOpenAddressingQP<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TQuadraticProbing>);
TOpenAddressingQP<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, TQuadraticProbing>);
TOpenAddressingQP<TKey, TValue, THashFactory> = class(TOpenAddressingQP<TKey, TValue, THashFactory, TQuadraticProbing>);
TOpenAddressingQP<TKey, TValue> = class(TOpenAddressingQP<TKey, TValue, TDefaultHashFactory, TQuadraticProbing>);
TOpenAddressingDH<TKey, TValue, THashFactory> = class(TOpenAddressingDH<TKey, TValue, THashFactory, TDoubleHashing>);
TOpenAddressingDH<TKey, TValue> = class(TOpenAddressingDH<TKey, TValue, TDelphiDoubleHashFactory, TDoubleHashing>);
@ -528,6 +653,3 @@ type
THashMap<TKey, TValue> = class(TCuckooD4<TKey, TValue>);
TObjectHashMap<TKey, TValue> = class(TObjectCuckooD4<TKey, TValue>);
var
EmptyRecord: TEmptyRecord;