rtl-generics: Fix critical issue (infinity loop) for quadratic probing. Table size must be a prime number.

git-svn-id: trunk@35608 -

packages/rtl-generics/src/inc/generics.dictionaries.inc

@@ -788,6 +788,58 @@ begin
   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>.FindBucketIndexOrTombstone(constref AItems: TArray<TItem>;
+  constref AKey: TKey; out AHash: UInt32): SizeInt;
+var
+  LItem: {TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.}_TItem; // for workaround Lazarus bug #25613
+  LLengthMask: SizeInt;
+  i, m: SizeInt;
+  LHash: UInt32;
+begin
+  m := Length(AItems);
+  LLengthMask := m - 1;
+
+  LHash := FEqualityComparer.GetHashCode(AKey);
+
+  i := 0;
+  AHash := LHash or UInt32.GetSignMask;
+
+  if m = 0 then
+    Exit(-1);
+
+  for i := 0 to FPrimaryNumberAsSizeApproximation - 1 do
+  begin
+    Result := TProbeSequence.Probe(i, m, 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;

packages/rtl-generics/src/inc/generics.dictionariesh.inc

@@ -267,6 +267,15 @@ 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 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
@@ -495,8 +504,8 @@ type
   TOpenAddressingLPT<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TLinearProbing>);
   TOpenAddressingLPT<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, 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, TDelphiHashFactory, TQuadraticProbing>);
 
   TOpenAddressingDH<TKey, TValue, THashFactory> = class(TOpenAddressingDH<TKey, TValue, THashFactory, TDoubleHashing>);
   TOpenAddressingDH<TKey, TValue> = class(TOpenAddressingDH<TKey, TValue, TDelphiDoubleHashFactory, TDoubleHashing>);