src/shared/hashtable.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE a_modes.inc}
  17 {.$DEFINE RBHASH_DEBUG_RESIZE}
  18 {.$DEFINE RBHASH_DEBUG_INSERT}
  19 {.$DEFINE RBHASH_DEBUG_DELETE}
  20 {.$DEFINE RBHASH_DEBUG_COMPACT}
  21 {$IF DEFINED(D2F_DEBUG)}
  22   {$DEFINE RBHASH_SANITY_CHECKS}
  23 {$ENDIF}
  24 // hash table (robin hood)
  25 unit hashtable;
  26
  27 interface
  28
  29
  30 type
  31   // WARNING! don't put structures into hash, use ponters or ids!
  32   generic THashBase<KeyT, ValueT> = class(TObject)
  33   private
  34     const InitSize = {$IF DEFINED(D2F_DEBUG)}16{$ELSE}512{$ENDIF}; // *MUST* be power of two
  35     const LoadFactorPrc = 90; // it is ok for robin hood hashes
  36
  37   public
  38     type THashFn = function (constref o: KeyT): LongWord;
  39     type TEquFn = function (constref a, b: KeyT): Boolean;
  40     type TIteratorFn = function (constref k: KeyT; constref v: ValueT): Boolean is nested; // return `true` to stop
  41
  42   private
  43     type
  44       PEntry = ^TEntry;
  45       TEntry = record
  46         key: KeyT;
  47         value: ValueT;
  48         hash: LongWord; // key hash or 0
  49         nextFree: PEntry; // next free entry
  50       end;
  51
  52   private
  53     hashfn: THashFn;
  54     equfn: TEquFn;
  55     mBuckets: array of PEntry; // entries, points to mEntries elements
  56     mBucketsUsed: Integer;
  57     mEntries: array of TEntry;
  58     {$IFDEF RBHASH_SANITY_CHECKS}
  59     mEntriesUsed: Integer;
  60     {$ENDIF}
  61     mFreeEntryHead: PEntry;
  62     mFirstEntry, mLastEntry: Integer;
  63     mSeed: LongWord;
  64
  65   private
  66     function allocEntry (): PEntry;
  67     procedure releaseEntry (e: PEntry);
  68
  69     //function distToStIdx (idx: LongWord): LongWord; inline;
  70
  71     procedure putEntryInternal (swpe: PEntry);
  72
  73     function getCapacity (): Integer; inline;
  74
  75   public
  76     constructor Create (ahashfn: THashFn; aequfn: TEquFn);
  77     destructor Destroy (); override;
  78
  79     procedure clear ();
  80
  81     procedure rehash ();
  82     procedure compact (); // call this instead of `rehash()` after alot of deletions
  83
  84     function get (constref akey: KeyT; out rval: ValueT): Boolean; // `true`: found
  85     function put (constref akey: KeyT; constref aval: ValueT): Boolean; // `true`: replaced
  86     function has (constref akey: KeyT): Boolean; // `true`: found
  87     function del (constref akey: KeyT): Boolean; // `true`: deleted
  88
  89     //WARNING! don't modify table in iterator (queries are ok, though)
  90     function forEach (it: TIteratorFn): Boolean;
  91
  92     property count: Integer read mBucketsUsed;
  93     property capacity: Integer read getCapacity;
  94   end;
  95
  96
  97 type
  98   TJoaatHasher = record
  99   private
 100     seed: LongWord; // initial seed value; MUST BE FIRST
 101     hash: LongWord; // current value
 102
 103   public
 104     constructor Create (aseed: LongWord);
 105
 106     procedure reset (); inline; overload;
 107     procedure reset (aseed: LongWord); inline; overload;
 108
 109     procedure put (const buf; len: LongWord);
 110
 111     // current hash value
 112     // you can continue putting data, as this is not destructive
 113     function value: LongWord; inline;
 114   end;
 115
 116
 117 type
 118   THashIntInt = specialize THashBase<Integer, Integer>;
 119
 120 function hashNewIntInt (): THashIntInt;
 121
 122
 123 function u32Hash (a: LongWord): LongWord; inline;
 124 function fnvHash (const buf; len: LongWord): LongWord;
 125 function joaatHash (const buf; len: LongWord): LongWord;
 126
 127 function nextPOT (x: LongWord): LongWord; inline;
 128
 129
 130 implementation
 131
 132 uses
 133   SysUtils;
 134
 135
 136 // ////////////////////////////////////////////////////////////////////////// //
 137 {$PUSH}
 138 {$RANGECHECKS OFF}
 139 function nextPOT (x: LongWord): LongWord; inline;
 140 begin
 141   result := x;
 142   result := result or (result shr 1);
 143   result := result or (result shr 2);
 144   result := result or (result shr 4);
 145   result := result or (result shr 8);
 146   result := result or (result shr 16);
 147   // already pot?
 148   if (x <> 0) and ((x and (x-1)) = 0) then result := result and (not (result shr 1)) else result += 1;
 149 end;
 150 {$POP}
 151
 152
 153 // ////////////////////////////////////////////////////////////////////////// //
 154 function hiiequ (constref a, b: Integer): Boolean; begin result := (a = b); end;
 155
 156 {$PUSH}
 157 {$RANGECHECKS OFF}
 158 function hiihash (constref k: Integer): LongWord;
 159 begin
 160   result := k;
 161   result -= (result shl 6);
 162   result := result xor (result shr 17);
 163   result -= (result shl 9);
 164   result := result xor (result shl 4);
 165   result -= (result shl 3);
 166   result := result xor (result shl 10);
 167   result := result xor (result shr 15);
 168 end;
 169 {$POP}
 170
 171
 172 function hashNewIntInt (): THashIntInt;
 173 begin
 174   result := THashIntInt.Create(hiihash, hiiequ);
 175 end;
 176
 177
 178 // ////////////////////////////////////////////////////////////////////////// //
 179 {$PUSH}
 180 {$RANGECHECKS OFF}
 181 constructor TJoaatHasher.Create (aseed: LongWord);
 182 begin
 183   reset(aseed);
 184 end;
 185
 186
 187 procedure TJoaatHasher.reset (); inline; overload;
 188 begin
 189   hash := seed;
 190 end;
 191
 192
 193 procedure TJoaatHasher.reset (aseed: LongWord); inline; overload;
 194 begin
 195   seed := aseed;
 196   hash := aseed;
 197 end;
 198
 199
 200 procedure TJoaatHasher.put (const buf; len: LongWord);
 201 var
 202   bytes: PByte;
 203   h: LongWord;
 204 begin
 205   if (len < 1) then exit;
 206   bytes := PByte(@buf);
 207   h := hash;
 208   while (len > 0) do
 209   begin
 210     h += bytes^;
 211     h += (h shl 10);
 212     h := h xor (h shr 6);
 213     Dec(len);
 214     Inc(bytes);
 215   end;
 216   hash := h;
 217 end;
 218
 219
 220 function TJoaatHasher.value: LongWord; inline;
 221 begin
 222   result := hash;
 223   result += (result shl 3);
 224   result := result xor (result shr 11);
 225   result += (result shl 15);
 226 end;
 227 {$POP}
 228
 229
 230 function joaatHash (const buf; len: LongWord): LongWord;
 231 var
 232   h: TJoaatHasher;
 233 begin
 234   h := TJoaatHasher.Create(0);
 235   h.put(buf, len);
 236   result := h.value;
 237 end;
 238
 239
 240 // ////////////////////////////////////////////////////////////////////////// //
 241 {$PUSH}
 242 {$RANGECHECKS OFF}
 243 // fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/
 244 function fnvHash (const buf; len: LongWord): LongWord;
 245 var
 246   b: PByte;
 247 begin
 248   b := @buf;
 249   result := 2166136261; // fnv offset basis
 250   while (len > 0) do
 251   begin
 252     result := result xor b^;
 253     result := result*16777619; // 32-bit fnv prime
 254     Inc(b);
 255     Dec(len);
 256   end;
 257 end;
 258 {$POP}
 259
 260
 261 {$PUSH}
 262 {$RANGECHECKS OFF}
 263 function u32Hash (a: LongWord): LongWord; inline;
 264 begin
 265   result := a;
 266   result -= (result shl 6);
 267   result := result xor (result shr 17);
 268   result -= (result shl 9);
 269   result := result xor (result shl 4);
 270   result -= (result shl 3);
 271   result := result xor (result shl 10);
 272   result := result xor (result shr 15);
 273 end;
 274 {$POP}
 275
 276
 277 // ////////////////////////////////////////////////////////////////////////// //
 278 constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn);
 279 begin
 280   if not assigned(ahashfn) then raise Exception.Create('cannot create hash without hash function');
 281   if not assigned(aequfn) then raise Exception.Create('cannot create hash without equality function');
 282
 283   hashfn := ahashfn;
 284   equfn := aequfn;
 285   mSeed := u32Hash($29a);
 286
 287   clear();
 288 end;
 289
 290
 291 destructor THashBase.Destroy ();
 292 begin
 293   mBuckets := nil;
 294   mEntries := nil;
 295   inherited;
 296 end;
 297
 298
 299 procedure THashBase.clear ();
 300 var
 301   idx: Integer;
 302 begin
 303   SetLength(mBuckets, InitSize);
 304   for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 305
 306   SetLength(mEntries, Length(mBuckets));
 307   for idx := 0 to High(mEntries)-1 do
 308   begin
 309     mEntries[idx].hash := 0;
 310     mEntries[idx].nextFree := @mEntries[idx+1]; //idx+1;
 311   end;
 312   mEntries[High(mEntries)].hash := 0;
 313   mEntries[High(mEntries)].nextFree := nil;
 314
 315   mBucketsUsed := 0;
 316   {$IFDEF RBHASH_SANITY_CHECKS}
 317   mEntriesUsed := 0;
 318   {$ENDIF}
 319   mFreeEntryHead := @mEntries[0];
 320   mFirstEntry := -1;
 321   mLastEntry := -1;
 322 end;
 323
 324
 325 function THashBase.getCapacity (): Integer; inline; begin result := Length(mBuckets); end;
 326
 327
 328 function THashBase.allocEntry (): PEntry;
 329 var
 330   idx: Integer;
 331 begin
 332   {$IFDEF RBHASH_SANITY_CHECKS}
 333   if (mFreeEntryHead = nil) then raise Exception.Create('internal error in hash entry allocator (0)');
 334   if (mFreeEntryHead.hash <> 0) then raise Exception.Create('internal error in hash entry allocator (1)');
 335   {$ENDIF}
 336   result := mFreeEntryHead;
 337   mFreeEntryHead := result.nextFree;
 338   {$IFDEF RBHASH_SANITY_CHECKS}
 339   Inc(mEntriesUsed);
 340   {$ENDIF}
 341   result.nextFree := nil; // just in case
 342   // fix mFirstEntry and mLastEntry
 343   idx := Integer((PtrUInt(result)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
 344   {$IFDEF RBHASH_SANITY_CHECKS}
 345   if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
 346   if (result <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
 347   {$ENDIF}
 348   if (mFirstEntry < 0) or (idx < mFirstEntry) then mFirstEntry := idx;
 349   if (idx > mLastEntry) then mLastEntry := idx;
 350 end;
 351
 352
 353 procedure THashBase.releaseEntry (e: PEntry);
 354 var
 355   cidx, idx: Integer;
 356 begin
 357   {$IFDEF RBHASH_SANITY_CHECKS}
 358   if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator');
 359   if (mEntriesUsed <> mBucketsUsed) then raise Exception.Create('internal error in hash entry allocator (entry/bucket count mismatch)');
 360   if (e = nil) then raise Exception.Create('internal error in hash entry allocator (trying to release nil entry)');
 361   if (e.hash = 0) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)');
 362   {$ENDIF}
 363   idx := Integer((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0]));
 364   {$IFDEF RBHASH_SANITY_CHECKS}
 365   if (idx < 0) or (idx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid entry address)');
 366   if (e <> @mEntries[idx]) then raise Exception.Create('internal error in hash entry allocator (wtf?!)');
 367   {$ENDIF}
 368   e.hash := 0;
 369   e.nextFree := mFreeEntryHead;
 370   mFreeEntryHead := e; //idx;
 371   {$IFDEF RBHASH_SANITY_CHECKS}
 372   Dec(mEntriesUsed);
 373   {$ENDIF}
 374   // fix mFirstEntry and mLastEntry
 375   {$IFDEF RBHASH_SANITY_CHECKS}
 376   if (mFirstEntry < 0) or (mLastEntry < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 0)');
 377   {$ENDIF}
 378   if (mFirstEntry = mLastEntry) then
 379   begin
 380     {$IFDEF RBHASH_SANITY_CHECKS}
 381     if (mEntriesUsed <> 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 1)');
 382     {$ENDIF}
 383     mFirstEntry := -1;
 384     mLastEntry := -1;
 385   end
 386   else
 387   begin
 388     {$IFDEF RBHASH_SANITY_CHECKS}
 389     if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 2)');
 390     {$ENDIF}
 391     // fix first entry index
 392     if (idx = mFirstEntry) then
 393     begin
 394       cidx := idx+1;
 395       while (mEntries[cidx].hash = 0) do Inc(cidx);
 396       {$IFDEF RBHASH_SANITY_CHECKS}
 397       if (cidx > High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
 398       {$ENDIF}
 399       mFirstEntry := cidx;
 400     end;
 401     // fix last entry index
 402     if (idx = mLastEntry) then
 403     begin
 404       cidx := idx-1;
 405       while (mEntries[cidx].hash = 0) do Dec(cidx);
 406       {$IFDEF RBHASH_SANITY_CHECKS}
 407       if (cidx < 0) then raise Exception.Create('internal error in hash entry allocator (invalid first/last range; 3)');
 408       {$ENDIF}
 409       mLastEntry := cidx;
 410     end;
 411   end;
 412 end;
 413
 414
 415 (*
 416 function THashBase.distToStIdx (idx: LongWord): LongWord; inline;
 417 begin
 418   {$IFDEF RBHASH_SANITY_CHECKS}
 419   assert(idx < Length(mBuckets));
 420   assert(mBuckets[idx] <> nil);
 421   {$ENDIF}
 422   result := mBuckets[idx].hash and High(mBuckets);
 423   if (result <= idx) then result := idx-result else result := idx+(Length(mBuckets)-result);
 424 end;
 425 *)
 426
 427
 428 function THashBase.has (constref akey: KeyT): Boolean;
 429 var
 430   khash, idx: LongWord;
 431   dist, pdist: LongWord;
 432   bhigh: LongWord;
 433 begin
 434   result := false;
 435   if (mBucketsUsed = 0) then exit;
 436
 437   bhigh := High(mBuckets);
 438   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 439   idx := khash and bhigh;
 440   if (mBuckets[idx] = nil) then exit;
 441
 442   for dist := 0 to bhigh do
 443   begin
 444     if (mBuckets[idx] = nil) then break;
 445     //pdist := distToStIdx(idx);
 446     pdist := mBuckets[idx].hash and bhigh;
 447     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 448     //
 449     if (dist > pdist) then break;
 450     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 451     if result then break;
 452     idx := (idx+1) and bhigh;
 453   end;
 454 end;
 455
 456
 457 function THashBase.get (constref akey: KeyT; out rval: ValueT): Boolean;
 458 var
 459   khash, idx: LongWord;
 460   dist, pdist: LongWord;
 461   bhigh: LongWord;
 462 begin
 463   result := false;
 464   if (mBucketsUsed = 0) then begin rval := Default(ValueT); exit; end;
 465
 466   bhigh := High(mBuckets);
 467   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 468   idx := khash and bhigh;
 469   if (mBuckets[idx] = nil) then begin rval := Default(ValueT); exit; end;
 470
 471   for dist := 0 to bhigh do
 472   begin
 473     if (mBuckets[idx] = nil) then break;
 474     //pdist := distToStIdx(idx);
 475     pdist := mBuckets[idx].hash and bhigh;
 476     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 477     //
 478     if (dist > pdist) then break;
 479     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 480     if result then
 481     begin
 482       rval := mBuckets[idx].value;
 483       break;
 484     end;
 485     idx := (idx+1) and bhigh;
 486   end;
 487
 488   if not result then rval := Default(ValueT); // just in case
 489 end;
 490
 491
 492 procedure THashBase.putEntryInternal (swpe: PEntry);
 493 var
 494   idx, dist, pcur, pdist: LongWord;
 495   tmpe: PEntry; // current entry to swap (or nothing)
 496   bhigh: LongWord;
 497 begin
 498   bhigh := High(mBuckets);
 499   idx := swpe.hash and bhigh;
 500   {$IFDEF RBHASH_DEBUG_INSERT}writeln('inserting key ', swpe.key, '; value=', swpe.value, '; wantidx=', idx, '; bhigh=', bhigh);{$ENDIF}
 501   pcur := 0;
 502   for dist := 0 to bhigh do
 503   begin
 504     if (mBuckets[idx] = nil) then
 505     begin
 506       // put entry
 507       {$IFDEF RBHASH_DEBUG_INSERT}writeln('  inserted to ', idx);{$ENDIF}
 508       mBuckets[idx] := swpe;
 509       Inc(mBucketsUsed);
 510       break;
 511     end;
 512     //pdist := distToStIdx(idx);
 513     pdist := mBuckets[idx].hash and bhigh;
 514     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 515     //
 516     if (pcur > pdist) then
 517     begin
 518       // swapping the current bucket with the one to insert
 519       tmpe := mBuckets[idx];
 520       mBuckets[idx] := swpe;
 521       swpe := tmpe;
 522       pcur := pdist;
 523     end;
 524     idx := (idx+1) and bhigh;
 525     Inc(pcur);
 526   end;
 527 end;
 528
 529
 530 function THashBase.put (constref akey: KeyT; constref aval: ValueT): Boolean;
 531 var
 532   khash, idx, dist, pdist: LongWord;
 533   swpe: PEntry = nil; // current entry to swap (or nothing)
 534   bhigh: LongWord;
 535   newsz, eidx: Integer;
 536 begin
 537   result := false;
 538
 539   bhigh := High(mBuckets);
 540   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 541   idx := khash and bhigh;
 542
 543   // check if we already have this key
 544   if (mBucketsUsed <> 0) and (mBuckets[idx] <> nil) then
 545   begin
 546     for dist := 0 to bhigh do
 547     begin
 548       if (mBuckets[idx] = nil) then break;
 549       //pdist := distToStIdx(idx);
 550       pdist := mBuckets[idx].hash and bhigh;
 551       if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 552       //
 553       if (dist > pdist) then break;
 554       result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 555       if result then
 556       begin
 557         // replace element
 558         //mBuckets[idx].key := akey;
 559         mBuckets[idx].value := aval;
 560         exit;
 561       end;
 562       idx := (idx+1) and bhigh;
 563     end;
 564   end;
 565
 566   // need to resize hash?
 567   if (mBucketsUsed >= (bhigh+1)*LoadFactorPrc div 100) then
 568   begin
 569     newsz := Length(mBuckets);
 570     if (Length(mEntries) <> newsz) then raise Exception.Create('internal error in hash table (resize)');
 571     if (newsz <= 1024*1024*1024) then newsz *= 2 else raise Exception.Create('hash table too big');
 572     {$IFDEF RBHASH_DEBUG_RESIZE}
 573     writeln('resizing hash; used=', mBucketsUsed, '; total=', (bhigh+1), '; maxload=', (bhigh+1)*LoadFactorPrc div 100, '; newsz=', newsz);
 574     {$ENDIF}
 575     SetLength(mBuckets, newsz);
 576     // resize entries array
 577     eidx := Length(mEntries);
 578     SetLength(mEntries, newsz);
 579     while (eidx < Length(mEntries)) do begin mEntries[eidx].hash := 0; Inc(eidx); end;
 580     // mFreeEntryHead will be fixed in `rehash()`
 581     // reinsert entries
 582     rehash();
 583     // as seed was changed, recalc hash
 584     khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 585   end;
 586
 587   // create new entry
 588   swpe := allocEntry();
 589   swpe.key := akey;
 590   swpe.value := aval;
 591   swpe.hash := khash;
 592
 593   putEntryInternal(swpe);
 594 end;
 595
 596
 597 // see http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
 598 function THashBase.del (constref akey: KeyT): Boolean;
 599 var
 600   khash, idx, idxnext, pdist, dist: LongWord;
 601   bhigh: LongWord;
 602 begin
 603   result := false;
 604   if (mBucketsUsed = 0) then exit;
 605
 606   bhigh := High(mBuckets);
 607   khash := hashfn(akey) xor mSeed; if (khash = 0) then khash := $29a;
 608   idx := khash and bhigh;
 609
 610   // find key
 611   if (mBuckets[idx] = nil) then exit; // no key
 612   for dist := 0 to bhigh do
 613   begin
 614     if (mBuckets[idx] = nil) then break;
 615     //pdist := distToStIdx(idxcur);
 616     pdist := mBuckets[idx].hash and bhigh;
 617     if (pdist <= idx) then pdist := idx-pdist else pdist := idx+((bhigh+1)-pdist);
 618     //
 619     if (dist > pdist) then break;
 620     result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey);
 621     if result then break;
 622     idx := (idx+1) and bhigh;
 623   end;
 624
 625   if not result then
 626   begin
 627     // key not found
 628     {$IFDEF RBHASH_DEBUG_DELETE}
 629     writeln('del: key ', akey, ': not found');
 630     {$ENDIF}
 631     exit;
 632   end;
 633
 634   {$IFDEF RBHASH_DEBUG_DELETE}
 635   writeln('del: key ', akey, ': found at ', idx, '; ek=', mBuckets[idx].key, '; ev=', mBuckets[idx].value);
 636   {$ENDIF}
 637   releaseEntry(mBuckets[idx]);
 638
 639   idxnext := (idx+1) and bhigh;
 640   for dist := 0 to bhigh do
 641   begin
 642     {$IFDEF RBHASH_DEBUG_DELETE}
 643     writeln(' dist=', dist, '; idx=', idx, '; idxnext=', idxnext, '; ce=', (mBuckets[idx] <> nil), '; ne=', (mBuckets[idxnext] <> nil));
 644     {$ENDIF}
 645     if (mBuckets[idxnext] = nil) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  idxnext nil');{$ENDIF} mBuckets[idx] := nil; break; end;
 646     //pdist := distToStIdx(idxnext);
 647     pdist := mBuckets[idxnext].hash and bhigh;
 648     if (pdist <= idxnext) then pdist := idxnext-pdist else pdist := idxnext+((bhigh+1)-pdist);
 649     //
 650     if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist is zero');{$ENDIF} mBuckets[idx] := nil; break; end;
 651     {$IFDEF RBHASH_DEBUG_DELETE}writeln('  pdist=', pdist);{$ENDIF}
 652     mBuckets[idx] := mBuckets[idxnext];
 653     idx := (idx+1) and bhigh;
 654     idxnext := (idxnext+1) and bhigh;
 655   end;
 656
 657   Dec(mBucketsUsed);
 658 end;
 659
 660
 661 procedure THashBase.rehash ();
 662 var
 663   idx: Integer;
 664   lastfree: PEntry;
 665   e: PEntry = nil; // shut up, fpc!
 666   {$IFDEF RBHASH_SANITY_CHECKS}
 667   cnt: Integer = 0;
 668   {$ENDIF}
 669 begin
 670   // change seed, to minimize pathological cases
 671   if (mSeed = 0) then mSeed := $29a;
 672   mSeed := u32Hash(mSeed);
 673   // clear buckets
 674   for idx := 0 to High(mBuckets) do mBuckets[idx] := nil;
 675   mBucketsUsed := 0;
 676   // reinsert entries
 677   mFreeEntryHead := nil;
 678   lastfree := nil;
 679   for idx := 0 to High(mEntries) do
 680   begin
 681     e := @mEntries[idx];
 682     if (e.hash <> 0) then
 683     begin
 684       {$IFDEF RBHASH_SANITY_CHECKS}
 685       if (e.nextFree <> nil) then raise Exception.Create('internal error in rehash: inconsistent');
 686       if (cnt = 0) and (idx <> mFirstEntry) then raise Exception.Create('internal error in rehash: inconsistent (1)');
 687       Inc(cnt);
 688       if (cnt = mBucketsUsed) and (idx <> mLastEntry) then raise Exception.Create('internal error in rehash: inconsistent (2)');
 689       {$ENDIF}
 690       e.hash := hashfn(e.key) xor mSeed; if (e.hash = 0) then e.hash := $29a;
 691       putEntryInternal(e);
 692     end
 693     else
 694     begin
 695       if (lastfree <> nil) then lastfree.nextFree := e else mFreeEntryHead := e;
 696       lastfree := e;
 697     end;
 698   end;
 699   if (lastfree <> nil) then e.nextFree := nil;
 700   {$IFDEF RBHASH_SANITY_CHECKS}
 701   if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 0)');
 702   if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table resize (invalid first/last range; 1)');
 703   {$ENDIF}
 704 end;
 705
 706
 707 procedure THashBase.compact ();
 708 var
 709   newsz, didx, f: Integer;
 710   {$IFDEF RBHASH_SANITY_CHECKS}
 711   cnt: Integer;
 712   {$ENDIF}
 713 begin
 714   newsz := nextPOT(LongWord(mBucketsUsed));
 715   if (newsz >= 1024*1024*1024) then exit;
 716   if (newsz*2 >= Length(mBuckets)) then exit;
 717   if (newsz*2 < 128) then exit;
 718   {$IFDEF RBHASH_DEBUG_COMPACT}writeln('compacting; used=', mBucketsUsed, '; oldsizePOT=', newsz, '; newsize=', newsz*2);{$ENDIF}
 719   newsz *= 2;
 720   // move all entries to top
 721   if (mFirstEntry >= 0) then
 722   begin
 723     {$IFDEF RBHASH_SANITY_CHECKS}
 724     if (mBucketsUsed < 1) then raise Exception.Create('internal error in hash table (invalid bucket count; 0)');
 725     {$ENDIF}
 726     didx := 0;
 727     while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
 728     f := didx+1;
 729     // copy entries
 730     while true do
 731     begin
 732       if (mEntries[f].hash <> 0) then
 733       begin
 734         {$IFDEF RBHASH_SANITY_CHECKS}
 735         if (didx >= f) then raise Exception.Create('internal error in hash: inconsistent');
 736         {$ENDIF}
 737         mEntries[didx] := mEntries[f];
 738         mEntries[f].hash := 0;
 739         Inc(didx);
 740         if (f = mLastEntry) then break;
 741         while (didx < Length(mEntries)) do if (mEntries[didx].hash <> 0) then Inc(didx) else break;
 742       end;
 743       Inc(f);
 744     end;
 745     {$IFDEF RBHASH_SANITY_CHECKS}
 746     if (didx <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 1)');
 747     {$ENDIF}
 748     mFirstEntry := 0;
 749     mLastEntry := mBucketsUsed-1;
 750     {$IFDEF RBHASH_SANITY_CHECKS}
 751     cnt := 0;
 752     for f := mFirstEntry to mLastEntry do
 753     begin
 754       if (mEntries[f].hash = 0) then raise Exception.Create('internal error in hash table (invalid first/last range; 2)');
 755       Inc(cnt);
 756     end;
 757     if (cnt <> mBucketsUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 3)');
 758     if (cnt <> mEntriesUsed) then raise Exception.Create('internal error in hash table (invalid first/last range; 4)');
 759     for f := mLastEntry+1 to High(mEntries) do
 760     begin
 761       if (mEntries[f].hash <> 0) then raise Exception.Create('internal error in hash table (invalid first/last range; 5)');
 762     end;
 763     {$ENDIF}
 764   end
 765   else
 766   begin
 767     {$IFDEF RBHASH_SANITY_CHECKS}
 768     if (mBucketsUsed <> 0) then raise Exception.Create('internal error in hash table (invalid bucket count; 1)');
 769     {$ENDIF}
 770   end;
 771   // shrink
 772   SetLength(mBuckets, newsz);
 773   SetLength(mEntries, newsz);
 774   // mFreeEntryHead will be fixed in `rehash()`
 775   // reinsert entries
 776   rehash();
 777 end;
 778
 779
 780 function THashBase.forEach (it: TIteratorFn): Boolean;
 781 var
 782   i: Integer;
 783 begin
 784   result := false;
 785   if not assigned(it) then exit;
 786   i := mFirstEntry;
 787   if (i < 0) then exit;
 788   while (i <= mLastEntry) do
 789   begin
 790     if (mEntries[i].hash <> 0) then
 791     begin
 792       result := it(mEntries[i].key, mEntries[i].value);
 793       if result then exit;
 794     end;
 795     Inc(i);
 796   end;
 797 end;
 798
 799
 800 end.