Compiler Explorer

Source code

unit app;
{$mode objfpc}
{$h+}
{$modeswitch advancedrecords}
{$optimization on}

interface
implementation

uses
  SysUtils, DateUtils,
  Generics.Hashes,
  Generics.Collections,
  ghashmap,
  Contnrs,
  TypInfo, RTTI;

type
  generic TDefaultHasher<TKey> = class
    class function GetDataPointer(const AKey: TKey): Pointer; static; inline;
    class function GetDataSize(const AKey: TKey): SizeInt; static; inline;
    class function GetKeyHash(const AKey: TKey): UInt32; static; inline;
    class constructor Create;
  end;

generic TPerfectHashBase<TKey, TValue, THasher> = class
  strict private type
    PValue = ^TValue;
    THashPair = packed record
      Key: TKey;
      Value: TValue;
      Hash: UInt32;
      class operator :=(const KeyValueArr: array of RTTI.TValue): THashPair;
    end;
  strict private
    Mask: UInt32;
    HashTable: array of THashPair;
  public
    function GetValue(const AKey: TKey): PValue;
    procedure Generate(const Arr: array of THashPair);
  end;
  generic TPerfectHash<TKey, TValue> = class(specialize TPerfectHashBase<TKey, TValue, specialize TDefaultHasher<TKey>>);

{ TDefaultHasher }

class constructor TDefaultHasher.Create;
var
  Key: TKey;
begin
  {$PUSH}{$ASSERTIONS ON}
  Assert((GetDataPointer(Key)=nil) and (GetDataSize(Key)=0), 'This key type (TKey) is not supported, implement a custom hashing function');
  {$POP}
end;

class function TDefaultHasher.GetDataPointer(const AKey: TKey): Pointer;
type
  TDynByteArray = array of Byte;
  PDynByteArray = ^TDynByteArray;
begin
  case GetTypeKind(TKey) of
    tkAString:  Result:=@PAnsiString(@AKey)^[1];
    tkLString:  Result:=@PAnsiString(@AKey)^[1];
    tkWString:  Result:=@PWideString(@AKey)^[1];
    tkUString:  Result:=@PUnicodeString(@AKey)^[1];
    tkSString:  Result:=@PShortString(@AKey)^[1];
    tkDynArray: Result:=@PDynByteArray(@AKey)^[1];
    tkSet, tkInt64, tkQWord, tkInteger, tkChar, tkBool,
    tkWChar, tkEnumeration, tkFloat, tkArray, tkRecord, tkPointer:
      Result:=@AKey;
  else
    Result:=nil;
  end;
end;

class function TDefaultHasher.GetDataSize(const AKey: TKey): SizeInt;
begin
  case GetTypeKind(TKey) of
    tkAString:  Result:=Length(PAnsiString(@AKey)^) * SizeOf(PAnsiString(nil)^[1]);
    tkLString:  Result:=Length(PAnsiString(@AKey)^) * SizeOf(PAnsiString(nil)^[1]);
    tkWString:  Result:=Length(PWideString(@AKey)^) * SizeOf(PWideString(nil)^[1]);
    tkUString:  Result:=Length(PUnicodeString(@AKey)^) * SizeOf(PUnicodeString(nil)^[1]);
    tkSString:  Result:=Length(PShortString(@AKey)^) * SizeOf(PShortString(nil)^[1]);
    tkDynArray: Result:=DynArraySize(PPointer(@AKey)^) * GetTypeData(TypeInfo(TKey))^.elSize;
    tkSet, tkInt64, tkQWord, tkInteger, tkChar, tkBool,
    tkWChar, tkEnumeration, tkFloat, tkArray, tkRecord, tkPointer:
      Result:=SizeOf(TKey);
  else
    Result:=0;
  end;
end;

class function TDefaultHasher.GetKeyHash(const AKey: TKey): UInt32;
var
  LDataPtr: Pointer;
  LDataSize: SizeInt;
begin
  LDataPtr:=GetDataPointer(AKey);
  LDataSize:=GetDataSize(AKey);
  Result:=mORMotHasher(0, LDataPtr, LDataSize);
end;

{ TPerfectHashBase.THashPair }

class operator TPerfectHashBase.THashPair.:=(const KeyValueArr: array of RTTI.TValue): THashPair;
begin
  // In general, it would be good to add a check for the key type,
  // to ensure it falls within the acceptable range of values
  // For now, I will leave it without checks

Result.Key   := KeyValueArr[0].specialize AsType<TKey>;
  Result.Value := KeyValueArr[1].specialize AsType<TValue>;
  Result.Hash  := THasher.GetKeyHash(Result.Key) or (1 shl 31);
end;

{ TPerfectHashBase }

procedure TPerfectHashBase.Generate(const Arr: array of THashPair);
var
  i, Count: SizeInt;
  Index: UInt32;
  IndexCollision, HashCollision: Boolean;

function ToPowerOf2(num: UInt32): UInt32;
  begin
    Result:=1 shl (ShortInt(BsrDWord(num-1))+1);
  end;

begin
  Count := ToPowerOf2(Length(Arr));
  Mask := Count - 1;
  if Mask = 0 then Mask := 1;

repeat
    SetLength(HashTable, Count);
    FillChar(HashTable[0], Length(HashTable)*SizeOf(HashTable[0]), 0);

for i:=Low(Arr) to High(Arr) do
    begin
      Index := Arr[i].Hash and Mask;

repeat
        HashCollision := HashTable[Index].Hash = Arr[i].Hash;
        if HashCollision then
          Index := (Index+1) and Mask
        else
          Break;
      until False;

IndexCollision := HashTable[Index].Hash <> 0;
      if IndexCollision then
      begin
        Count := Count*2;
        Mask  := Count-1;
        Break;
      end;
      HashTable[Index] := Arr[i];
    end;
  until not IndexCollision;
end;

function TPerfectHashBase.GetValue(const AKey: TKey): PValue;
var
  Index, LHash: UInt32;
begin
  LHash := THasher.GetKeyHash(AKey) or (1 shl 31);
  Index := LHash and Mask;
  repeat
    with HashTable[Index] do
    begin
      if ((Hash and (1 shl 31)) = 0) then Exit(nil);

// if the data size is small (up to the size of the register? x2?),
      // it is easier to compare the data directly rather than hashes?
      if (Hash = LHash) and (Key = AKey) then Exit(@Value);
    end;
    Index:=(Index+1) and Mask;
  until False;
end;

type
  TPerfHash = specialize TPerfectHash<string, string>;

TDict = specialize TDictionary<string, string>;

THMHash = class
    class function Hash(const Data: String; n: SizeInt): UInt32; static; inline;
  end;

TGHashMap = ghashmap.specialize THashmap<string, string, THMHash>;

class function THMHash.Hash(const Data: String; n: SizeInt): UInt32;
begin
  Result:=mORMotHasher(0, @Data[1], Length(Data)) and (n-1);
end;

const
  N = 16*1024*1024;

var
  PerfHash: TPerfHash;
  Dict: TDict;
  GHM: TGHashMap;
  ContnrsSHT: Contnrs.TFPStringHashTable;
  i: UInt32;
  t: TDateTime;
  s: string;
  StrArr: array of string = ('type','path','lines','line_number','submatches','start','end','elapsed','human','matched_lines','matches','searches','searches_with_match');

begin
  s:='abfcmbk';
  WriteLn(IntToHex(mORMotHasher(0, @s[1], Length(s))));
  s:='baabaaa';
  WriteLn(IntToHex(mORMotHasher(0, @s[1], Length(s))));

PerfHash:=TPerfHash.Create;
  PerfHash.Generate([
    ['abfcmbk',    'abfcmbk'],
    ['baabaaa',    'baabaaa']
  ]);
  WriteLn(PerfHash.GetValue('abfcmbk')^);
  WriteLn(PerfHash.GetValue('baabaaa')^);

Dict:=TDict.Create;
  for s in StrArr do
    Dict.Add(s, s);

GHM:=TGHashMap.Create;
  for s in StrArr do
    GHM.insert(s, s);

ContnrsSHT:=Contnrs.TFPStringHashTable.Create;
  for s in StrArr do
    ContnrsSHT.Add(s, s);

PerfHash:=TPerfHash.Create;
  PerfHash.Generate([
    ['type',    'type'],
    ['path',    'path'],
    ['lines',    'lines'],
    ['line_number',    'line_number'],
    ['submatches',    'submatches'],
    ['start',    'start'],
    ['end',    'end'],
    ['elapsed',    'elapsed'],
    ['human',    'human'],
    ['matched_lines',    'matched_lines'],
    ['matches',    'matches'],
    ['searches',    'searches'],
    ['searches_with_match',     'searches_with_match']
  ]);

t:=Now;
  for i:=0 to N do
    Dict.TryGetValue('matched_lines', s);
  WriteLn('Dict: ', MilliSecondsBetween(Now, t), 'ms');

t:=Now;
  for i:=0 to N do
    GHM.GetValue('matched_lines', s);
  WriteLn('GHM: ', MilliSecondsBetween(Now, t), 'ms');

t:=Now;
  for i:=0 to N do
    s:=ContnrsSHT.Items['matched_lines'];
  WriteLn('ContnrsSHT: ', MilliSecondsBetween(Now, t), 'ms');

t:=Now;
  for i:=0 to N do
    s:=PerfHash.GetValue('matched_lines')^;
  WriteLn('PerfHash: ', MilliSecondsBetween(Now, t), 'ms');

//ReadLn;
end.