From b744498c3f6d4d30731c74ba376e15e71de9b610 Mon Sep 17 00:00:00 2001 From: Ketmar Dark Date: Mon, 21 Aug 2017 12:01:21 +0300 Subject: [PATCH] added robin hood hash table implementation --- src/game/Doom2DF.dpr | 1 + src/shared/a_modes.inc | 1 + src/shared/hashtable.pas | 418 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 420 insertions(+) create mode 100644 src/shared/hashtable.pas diff --git a/src/game/Doom2DF.dpr b/src/game/Doom2DF.dpr index 26fd58b..1341a79 100644 --- a/src/game/Doom2DF.dpr +++ b/src/game/Doom2DF.dpr @@ -99,6 +99,7 @@ uses {$ENDIF} xprofiler in '../shared/xprofiler.pas', binheap in '../shared/binheap.pas', + hashtable in '../shared/hashtable.pas', BinEditor in '../shared/BinEditor.pas', envvars in '../shared/envvars.pas', g_panel in 'g_panel.pas', diff --git a/src/shared/a_modes.inc b/src/shared/a_modes.inc index 9c5c74c..9d1da17 100644 --- a/src/shared/a_modes.inc +++ b/src/shared/a_modes.inc @@ -55,6 +55,7 @@ {$MMX-} // get lost, mmx {$IF DEFINED(D2F_DEBUG)} + {$RANGECHECKS ON} {$STACKFRAMES ON} {$ELSE} {$STACKFRAMES OFF} diff --git a/src/shared/hashtable.pas b/src/shared/hashtable.pas new file mode 100644 index 0000000..8b75d54 --- /dev/null +++ b/src/shared/hashtable.pas @@ -0,0 +1,418 @@ +(* Copyright (C) DooM 2D:Forever Developers + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE a_modes.inc} +{.$DEFINE RBHASH_DEBUG_RESIZE} +{.$DEFINE RBHASH_DEBUG_DELETE} +{$IF DEFINED(D2F_DEBUG)} + {$DEFINE RBHASH_SANITY_CHECKS} +{$ENDIF} +// hash table (robin hood) +unit hashtable; + +interface + + +type + // WARNING! don't put structures into hash, use ponters or ids! + generic THashBase = class(TObject) + private + const InitSize = {$IF DEFINED(D2F_DEBUG)}16{$ELSE}512{$ENDIF}; + const LoadFactorPrc = 90; // it is ok for robin hood hashes + + public + type THashFn = function (constref o: KeyT): LongWord; + type TEquFn = function (constref a, b: KeyT): Boolean; + + private + type + PEntry = ^TEntry; + TEntry = record + key: KeyT; + value: ValueT; + hash: LongWord; // key hash or 0 + nextFree: Integer; + end; + + private + hashfn: THashFn; + equfn: TEquFn; + mBuckets: array of PEntry; // entries, points to mEntries elements + mBucketsUsed: Integer; + mEntries: array of TEntry; + mEntriesUsed: Integer; + mFreeEntryHead: Integer; + + private + function allocEntry (): PEntry; + procedure releaseEntry (e: PEntry); + + function distToStIdx (idx: LongWord): LongWord; inline; + + procedure putEntryInternal (swpe: PEntry); + + public + constructor Create (ahashfn: THashFn; aequfn: TEquFn); + destructor Destroy (); override; + + procedure clear (); + + procedure rehash (); + + function get (constref akey: KeyT; out rval: ValueT): Boolean; // `true`: found + function put (constref akey: KeyT; constref aval: ValueT): Boolean; // `true`: replaced + function has (constref akey: KeyT): Boolean; // `true`: found + function del (constref akey: KeyT): Boolean; // `true`: deleted + + property count: Integer read mBucketsUsed; + end; + + +implementation + +uses + SysUtils; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor THashBase.Create (ahashfn: THashFn; aequfn: TEquFn); +begin + if not assigned(ahashfn) then raise Exception.Create('cannot create hash without hash function'); + if not assigned(aequfn) then raise Exception.Create('cannot create hash without equality function'); + + hashfn := ahashfn; + equfn := aequfn; + + clear(); +end; + + +destructor THashBase.Destroy (); +begin + mBuckets := nil; + mEntries := nil; + inherited; +end; + + +function THashBase.allocEntry (): PEntry; +begin + {$IFDEF RBHASH_SANITY_CHECKS} + if (mFreeEntryHead = -1) then raise Exception.Create('internal error in hash entry allocator (0)'); + if (mEntries[mFreeEntryHead].hash <> 0) then raise Exception.Create('internal error in hash entry allocator (1)'); + {$ENDIF} + result := @mEntries[mFreeEntryHead]; + mFreeEntryHead := result.nextFree; + Inc(mEntriesUsed); + result.nextFree := -1; +end; + + +procedure THashBase.releaseEntry (e: PEntry); +var + idx: LongWord; +begin + {$IFDEF RBHASH_SANITY_CHECKS} + if (mEntriesUsed = 0) then raise Exception.Create('internal error in hash entry allocator'); + if (e = nil) then raise Exception.Create('internal error in hash entry allocator (trying to release nil entry)'); + if (e.nextFree <> -1) or (e.hash = 0) then raise Exception.Create('internal error in hash entry allocator (trying to release unallocated entry)'); + {$ENDIF} + idx := LongWord((PtrUInt(e)-PtrUInt(@mEntries[0])) div sizeof(mEntries[0])); + {$IFDEF RBHASH_SANITY_CHECKS} + if (idx >= Length(mEntries)) then raise Exception.Create('internal error in hash entry allocator (invalid calculated index)'); + {$ENDIF} + e.hash := 0; + e.nextFree := mFreeEntryHead; + mFreeEntryHead := idx; + Dec(mEntriesUsed); +end; + + +function THashBase.distToStIdx (idx: LongWord): LongWord; inline; +var + stidx: LongWord; +begin + {$IFDEF RBHASH_SANITY_CHECKS} + assert(idx < Length(mBuckets)); + assert(mBuckets[idx] <> nil); + {$ENDIF} + stidx := mBuckets[idx].hash mod Length(mBuckets); + if (stidx <= idx) then result := idx-stidx else result := idx+(Length(mBuckets)-stidx); +end; + + +function THashBase.has (constref akey: KeyT): Boolean; +var + khash, idx: LongWord; + dist, pdist: LongWord; + blen: LongWord; +begin + result := false; + if (mBucketsUsed = 0) then exit; + + blen := Length(mBuckets); + khash := hashfn(akey); if (khash = 0) then khash := $29a; + idx := khash mod blen; + if (mBuckets[idx] = nil) then exit; + + for dist := 0 to blen-1 do + begin + if (mBuckets[idx] = nil) then break; + pdist := distToStIdx(idx); + if (dist > pdist) then break; + result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey); + if result then break; + idx := (idx+1) mod blen; + end; +end; + + +function THashBase.get (constref akey: KeyT; out rval: ValueT): Boolean; +var + khash, idx: LongWord; + dist, pdist: LongWord; + blen: LongWord; +begin + result := false; + if (mBucketsUsed = 0) then begin rval := Default(ValueT); exit; end; + + blen := Length(mBuckets); + khash := hashfn(akey); if (khash = 0) then khash := $29a; + idx := khash mod blen; + if (mBuckets[idx] = nil) then begin rval := Default(ValueT); exit; end; + + for dist := 0 to blen-1 do + begin + if (mBuckets[idx] = nil) then break; + pdist := distToStIdx(idx); + if (dist > pdist) then break; + result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey); + if result then + begin + rval := mBuckets[idx].value; + break; + end; + idx := (idx+1) mod blen; + end; + + if not result then rval := Default(ValueT); // just in case +end; + + +procedure THashBase.putEntryInternal (swpe: PEntry); +var + idx, dist, pcur, pdist: LongWord; + tmpe: PEntry; // current entry to swap (or nothing) + blen: LongWord; +begin + blen := Length(mBuckets); + idx := swpe.hash mod blen; + pcur := 0; + for dist := 0 to blen-1 do + begin + if (mBuckets[idx] = nil) then + begin + // put entry + mBuckets[idx] := swpe; + Inc(mBucketsUsed); + break; + end; + pdist := distToStIdx(idx); + if (pcur > pdist) then + begin + // swapping the current bucket with the one to insert + tmpe := mBuckets[idx]; + mBuckets[idx] := swpe; + swpe := tmpe; + pcur := pdist; + end; + idx := (idx+1) mod blen; + Inc(pcur); + end; +end; + + +function THashBase.put (constref akey: KeyT; constref aval: ValueT): Boolean; +var + khash, stidx, idx, dist, pdist: LongWord; + swpe: PEntry = nil; // current entry to swap (or nothing) + blen: LongWord; + newsz, eidx: Integer; +begin + result := false; + + blen := Length(mBuckets); + khash := hashfn(akey); if (khash = 0) then khash := $29a; + stidx := khash mod blen; + + // check if we already have this key + idx := stidx; + if (mBucketsUsed <> 0) and (mBuckets[idx] <> nil) then + begin + for dist := 0 to blen-1 do + begin + if (mBuckets[idx] = nil) then break; + pdist := distToStIdx(idx); + if (dist > pdist) then break; + result := (mBuckets[idx].hash = khash) and equfn(mBuckets[idx].key, akey); + if result then + begin + // replace element + //mBuckets[idx].key := akey; + mBuckets[idx].value := aval; + exit; + end; + idx := (idx+1) mod blen; + end; + end; + + // need to resize hash? + if (mBucketsUsed >= blen*LoadFactorPrc div 100) then + begin + newsz := Length(mBuckets); + if (Length(mEntries) <> newsz) then raise Exception.Create('internal error in hash table (resize)'); + if (newsz <= 1024*1024*512) then newsz *= 2 else newsz += 1024*1024; + {$IFDEF RBHASH_DEBUG_RESIZE} + writeln('resizing hash; used=', mBucketsUsed, '; total=', blen, '; maxload=', blen*LoadFactorPrc div 100, '; newsz=', newsz); + {$ENDIF} + SetLength(mBuckets, newsz); + // resize entries array + eidx := newsz; + SetLength(mEntries, newsz); + while (eidx < Length(mEntries)) do begin mEntries[eidx].hash := 0; Inc(eidx); end; + // mFreeEntryHead will be fixed in `rehash()` + // reinsert entries + rehash(); + end; + + // create new entry + swpe := allocEntry(); + swpe.key := akey; + swpe.value := aval; + swpe.hash := khash; + + putEntryInternal(swpe); +end; + + +// see http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/ +function THashBase.del (constref akey: KeyT): Boolean; +var + khash, stidx, idxcur, idxnext, pdist, dist: LongWord; + blen: LongWord; +begin + result := false; + if (mBucketsUsed = 0) then exit; + + blen := Length(mBuckets); + khash := hashfn(akey); if (khash = 0) then khash := $29a; + stidx := khash mod blen; + + // find key + if (mBuckets[stidx] = nil) then exit; // no key + + idxcur := stidx; + for dist := 0 to blen-1 do + begin + if (mBuckets[idxcur] = nil) then break; + pdist := distToStIdx(idxcur); + if (dist > pdist) then break; + result := (mBuckets[idxcur].hash = khash) and equfn(mBuckets[idxcur].key, akey); + if result then break; + idxcur := (idxcur+1) mod blen; + end; + + if not result then + begin + // key not found + {$IFDEF RBHASH_DEBUG_DELETE} + writeln('del: key ', akey, ': not found'); + {$ENDIF} + exit; + end; + + {$IFDEF RBHASH_DEBUG_DELETE} + writeln('del: key ', akey, ': found at ', idxcur, '(', stidx, '); ek=', mBuckets[idxcur].key, '; ev=', mBuckets[idxcur].value); + {$ENDIF} + releaseEntry(mBuckets[idxcur]); + + idxnext := (idxcur+1) mod blen; + for dist := 0 to blen-1 do + begin + {$IFDEF RBHASH_DEBUG_DELETE} + writeln(' dist=', dist, '; idxcur=', idxcur, '; idxnext=', idxnext, '; ce=', (mBuckets[idxcur] <> nil), '; ne=', (mBuckets[idxnext] <> nil)); + {$ENDIF} + if (mBuckets[idxnext] = nil) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln(' idxnext nil');{$ENDIF} mBuckets[idxcur] := nil; break; end; + pdist := distToStIdx(idxnext); + if (pdist = 0) then begin {$IFDEF RBHASH_DEBUG_DELETE}writeln(' pdist is zero');{$ENDIF} mBuckets[idxcur] := nil; break; end; + {$IFDEF RBHASH_DEBUG_DELETE}writeln(' pdist=', pdist);{$ENDIF} + mBuckets[idxcur] := mBuckets[idxnext]; + idxcur := (idxcur+1) mod blen; + idxnext := (idxnext+1) mod blen; + end; + + Dec(mBucketsUsed); +end; + + +procedure THashBase.clear (); +var + idx: Integer; +begin + SetLength(mBuckets, InitSize); + for idx := 0 to High(mBuckets) do mBuckets[idx] := nil; + + SetLength(mEntries, Length(mBuckets)); + for idx := 0 to High(mEntries) do + begin + mEntries[idx].hash := 0; + mEntries[idx].nextFree := idx+1; + end; + mEntries[High(mEntries)].nextFree := -1; + + mBucketsUsed := 0; + mEntriesUsed := 0; + mFreeEntryHead := 0; +end; + + +procedure THashBase.rehash (); +var + idx, lastfree: Integer; + e: PEntry; +begin + // clear buckets + for idx := 0 to High(mBuckets) do mBuckets[idx] := nil; + mBucketsUsed := 0; + // reinsert entries + mFreeEntryHead := -1; + lastfree := -1; + for idx := 0 to High(mEntries) do + begin + e := @mEntries[idx]; + if (e.hash <> 0) then + begin + putEntryInternal(e); + end + else + begin + if (lastfree <> -1) then mEntries[lastfree].nextFree := idx else mFreeEntryHead := idx; + lastfree := idx; + end; + end; +end; + + +end. -- 2.29.2