From 3799f1516a26593963eb0637b9bc0d9ebf189f2c Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Wed, 10 Jun 2026 19:41:38 +0100 Subject: [PATCH] perf(stdlib): hash lookup for TDictionary, TOrderedDictionary and TSet The generic keyed containers used documented linear key scans. They now build the same lazy open-addressing index as TStringList: threshold 16, kept at <= 50% load, maintained on Add, invalidated by Remove/Clear/ Destroy (storage stays insertion-ordered, so TOrderedDictionary indexed access is unchanged). Hashing an arbitrary key type works through monomorphisation: the generic bodies call GCHashOf(Key), which resolves per instantiation against new overloads (string hashes its bytes FNV-1a, matching the content semantics of '=' on strings; Integer/Int64/Pointer use a multiplicative mix). Instantiating a keyed container with a type that has no GCHashOf overload is a compile-time error; the threshold const lives in the interface because generic bodies are analysed at their instantiation site. Neutral on the compiler self-compile (its dictionaries are small); this is stdlib quality for user programs. Contract pinned by 7 new in-process tests (cp.test.maphash.pas) written against the linear implementation first. --- compiler/src/test/pascal/TestRunner.pas | 1 + compiler/src/test/pascal/cp.test.maphash.pas | 193 +++++++++ .../src/main/pascal/generics.collections.pas | 382 ++++++++++++++++-- 3 files changed, 544 insertions(+), 32 deletions(-) create mode 100644 compiler/src/test/pascal/cp.test.maphash.pas diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index d9abfdc..e340e28 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -66,6 +66,7 @@ uses cp.test.stringops, cp.test.collections, cp.test.stringlistfind, + cp.test.maphash, cp.test.caseenum, cp.test.sets, cp.test.selfhosting, diff --git a/compiler/src/test/pascal/cp.test.maphash.pas b/compiler/src/test/pascal/cp.test.maphash.pas new file mode 100644 index 0000000..09f40ba --- /dev/null +++ b/compiler/src/test/pascal/cp.test.maphash.pas @@ -0,0 +1,193 @@ +{ + Blaise - An Object Pascal Compiler + Copyright (c) 2026 Graeme Geldenhuys + SPDX-License-Identifier: Apache-2.0 WITH Swift-exception + Licensed under the Apache License v2.0 with Runtime Library Exception. + See LICENSE file in the project root for full license terms. +} + +unit cp.test.maphash; + +{ In-process behaviour tests for TDictionary/TOrderedDictionary/TSet at + sizes that engage an accelerated (hashed) key lookup. These pin the + contract before the linear FindKey scan is replaced: + + - string keys match by CONTENT, including keys rebuilt at lookup time + (different buffers, equal bytes), + - Add on an existing key overwrites in place (no duplicate entry), + - Remove compacts and subsequent lookups stay correct, + - TOrderedDictionary preserves insertion order under indexed access, + - TSet Include/Exclude/Contains stay consistent at scale. + + They run against the same generics the compiler itself uses. } + +interface + +uses + Classes, SysUtils, blaise.testing, Generics.Collections; + +type + TMapHashTests = class(TTestCase) + published + procedure TestDict_StringKeys_ContentEquality_Large; + procedure TestDict_AddExistingKey_Overwrites; + procedure TestDict_Remove_ThenLookups; + procedure TestDict_IntegerKeys_Large; + procedure TestOrderedDict_PreservesInsertionOrder; + procedure TestOrderedDict_Remove_KeepsOrder; + procedure TestSet_IncludeExcludeContains_Large; + end; + +implementation + +procedure TMapHashTests.TestDict_StringKeys_ContentEquality_Large; +var + D: TDictionary; + I, V: Integer; +begin + D := TDictionary.Create(); + try + for I := 0 to 199 do + D.Add('key_' + IntToStr(I), I * 10); + AssertEquals('count', 200, D.Count); + { Lookup keys are freshly concatenated — different buffers, same bytes. } + AssertTrue('hit 0', D.TryGetValue('key_' + IntToStr(0), V)); + AssertEquals('val 0', 0, V); + AssertTrue('hit 157', D.TryGetValue('key_' + IntToStr(157), V)); + AssertEquals('val 157', 1570, V); + AssertTrue('miss', not D.TryGetValue('key_200', V)); + AssertTrue('contains', D.ContainsKey('key_42')); + AssertTrue('not contains', not D.ContainsKey('KEY_42')); + finally + D.Free(); + end; +end; + +procedure TMapHashTests.TestDict_AddExistingKey_Overwrites; +var + D: TDictionary; + I, V: Integer; +begin + D := TDictionary.Create(); + try + for I := 0 to 49 do + D.Add('k' + IntToStr(I), I); + D.Add('k25', 9999); + AssertEquals('count unchanged', 50, D.Count); + AssertTrue('still found', D.TryGetValue('k25', V)); + AssertEquals('overwritten', 9999, V); + finally + D.Free(); + end; +end; + +procedure TMapHashTests.TestDict_Remove_ThenLookups; +var + D: TDictionary; + I, V: Integer; +begin + D := TDictionary.Create(); + try + for I := 0 to 99 do + D.Add('k' + IntToStr(I), I); + D.Remove('k10'); + D.Remove('k99'); + AssertEquals('count', 98, D.Count); + AssertTrue('removed gone', not D.ContainsKey('k10')); + AssertTrue('removed gone 2', not D.ContainsKey('k99')); + AssertTrue('survivor', D.TryGetValue('k11', V)); + AssertEquals('survivor val', 11, V); + AssertTrue('survivor low', D.ContainsKey('k0')); + { Re-add a removed key. } + D.Add('k10', 1010); + AssertTrue('re-added', D.TryGetValue('k10', V)); + AssertEquals('re-added val', 1010, V); + finally + D.Free(); + end; +end; + +procedure TMapHashTests.TestDict_IntegerKeys_Large; +var + D: TDictionary; + I, V: Integer; +begin + D := TDictionary.Create(); + try + for I := 0 to 199 do + D.Add(I * 7, I); + AssertTrue('hit', D.TryGetValue(7 * 123, V)); + AssertEquals('val', 123, V); + AssertTrue('miss', not D.TryGetValue(5, V)); + finally + D.Free(); + end; +end; + +procedure TMapHashTests.TestOrderedDict_PreservesInsertionOrder; +var + D: TOrderedDictionary; + I, V: Integer; +begin + D := TOrderedDictionary.Create(); + try + for I := 0 to 99 do + D.Add('k' + IntToStr(I), I); + for I := 0 to 99 do + begin + AssertEquals('key order ' + IntToStr(I), 'k' + IntToStr(I), D.Keys[I]); + AssertEquals('value order ' + IntToStr(I), I, D.Values[I]); + end; + AssertTrue('lookup', D.TryGetValue('k73', V)); + AssertEquals('lookup val', 73, V); + finally + D.Free(); + end; +end; + +procedure TMapHashTests.TestOrderedDict_Remove_KeepsOrder; +var + D: TOrderedDictionary; + V: Integer; + I: Integer; +begin + D := TOrderedDictionary.Create(); + try + for I := 0 to 49 do + D.Add('k' + IntToStr(I), I); + D.Remove('k0'); + AssertEquals('count', 49, D.Count); + AssertEquals('new first key', 'k1', D.Keys[0]); + AssertTrue('lookup after remove', D.TryGetValue('k30', V)); + AssertEquals('val after remove', 30, V); + finally + D.Free(); + end; +end; + +procedure TMapHashTests.TestSet_IncludeExcludeContains_Large; +var + S: TSet; + I: Integer; +begin + S := TSet.Create(); + try + for I := 0 to 199 do + S.Include(I * 3); + AssertEquals('count', 200, S.Count); + S.Include(33); { 33 = 3*11 already present — no duplicate } + AssertEquals('no dup', 200, S.Count); + AssertTrue('contains', S.Contains(597)); + AssertTrue('not contains', not S.Contains(598)); + S.Exclude(597); + AssertTrue('excluded', not S.Contains(597)); + AssertEquals('count after exclude', 199, S.Count); + finally + S.Free(); + end; +end; + +initialization + RegisterTest(TMapHashTests); + +end. diff --git a/stdlib/src/main/pascal/generics.collections.pas b/stdlib/src/main/pascal/generics.collections.pas index b222016..d25dc3f 100644 --- a/stdlib/src/main/pascal/generics.collections.pas +++ b/stdlib/src/main/pascal/generics.collections.pas @@ -77,15 +77,20 @@ type property Count: Integer read FCount; end; - { Generic unordered set backed by a dynamic array with linear-scan membership. - Include adds an element only if not already present; Exclude removes it. - Contains tests membership. Suitable for small-to-medium sets where the - element type supports '=' equality. } + { Generic unordered set backed by a dynamic array. Membership tests use a + lazy hash index once the set is large enough (see GCHashOf); small sets + keep the linear scan. Include adds an element only if not already + present; Exclude removes it. } TSet = class - FData: ^T; - FCount: Integer; - FCapacity: Integer; + FData: ^T; + FCount: Integer; + FCapacity: Integer; + FHashSlots: ^Integer; + FHashCap: Integer; procedure Grow; + procedure HashInvalidate; + procedure HashInsertIdx(AIdx: Integer); + procedure HashRebuild; function IndexOf(Value: T): Integer; procedure Include(Value: T); procedure Exclude(Value: T); @@ -104,16 +109,23 @@ type function GetCount: Integer; end; - { Generic dictionary: linear-scan key table backed by two parallel arrays. - Key equality uses the '=' operator on the monomorphized type, so integer, - boolean and pointer key types work out of the box. String keys require - content-aware equality which is deferred. } + { Generic dictionary backed by two parallel arrays (insertion-ordered + storage). Key lookup uses a lazy open-addressing hash index once the + dictionary is large enough; small dictionaries keep the linear scan. + Key equality uses the '=' operator on the monomorphized type (content + equality for string keys); hashing dispatches through the GCHashOf + overloads, so a key type needs a matching GCHashOf to instantiate. } TDictionary = class(IMap) - FKeys: ^K; - FValues: ^V; - FCount: Integer; - FCapacity: Integer; + FKeys: ^K; + FValues: ^V; + FCount: Integer; + FCapacity: Integer; + FHashSlots: ^Integer; + FHashCap: Integer; procedure Grow; + procedure HashInvalidate; + procedure HashInsertIdx(AIdx: Integer); + procedure HashRebuild; function FindKey(Key: K): Integer; procedure Add(Key: K; Value: V); function TryGetValue(Key: K; var Value: V): Boolean; @@ -130,11 +142,16 @@ type where insertion order matters (e.g. preserving configuration file order, deterministic output). } TOrderedDictionary = class(IMap) - FKeys: ^K; - FValues: ^V; - FCount: Integer; - FCapacity: Integer; + FKeys: ^K; + FValues: ^V; + FCount: Integer; + FCapacity: Integer; + FHashSlots: ^Integer; + FHashCap: Integer; procedure Grow; + procedure HashInvalidate; + procedure HashInsertIdx(AIdx: Integer); + procedure HashRebuild; function FindKey(Key: K): Integer; procedure Add(Key: K; Value: V); function TryGetValue(Key: K; var Value: V): Boolean; @@ -149,8 +166,64 @@ type property Values[Index: Integer]: V read GetValue; end; +{ Key hashing for the generic containers. Monomorphisation resolves + GCHashOf(Key) against these overloads per instantiation, so each key type + gets a content-appropriate hash: strings hash their bytes (matching the + content semantics of '=' on strings), integers and pointers mix their + value. Instantiating a keyed container with a type that has no matching + overload is a compile-time error — add an overload here for new key types. } +function GCHashOf(AValue: string): Integer; overload; +function GCHashOf(AValue: Integer): Integer; overload; +function GCHashOf(AValue: Int64): Integer; overload; +function GCHashOf(AValue: Pointer): Integer; overload; +function GCHashOf(AValue: Boolean): Integer; overload; + +const + { Below this size a linear scan beats building a hash table. Interface + visibility because generic bodies are analysed at their instantiation + site. } + GCHashThreshold = 16; + implementation +{ ------------------------------------------------------------------ } +{ GCHashOf — key hashing overloads } +{ ------------------------------------------------------------------ } + +function GCHashOf(AValue: string): Integer; overload; +var + I: Integer; +begin + { FNV-1a over the bytes; case-sensitive to match '=' on strings. } + Result := -2128831035; { FNV offset basis 2166136261 as signed 32-bit } + for I := 0 to Length(AValue) - 1 do + Result := (Result xor Ord(AValue[I])) * 16777619; +end; + +function GCHashOf(AValue: Integer): Integer; overload; +begin + { Knuth multiplicative mix (2654435761 as signed 32-bit). } + Result := AValue * -1640531527; +end; + +function GCHashOf(AValue: Int64): Integer; overload; +begin + Result := Integer(AValue xor (AValue shr 32)) * -1640531527; +end; + +function GCHashOf(AValue: Pointer): Integer; overload; +begin + Result := GCHashOf(Int64(AValue)); +end; + +function GCHashOf(AValue: Boolean): Integer; overload; +begin + if AValue then + Result := 1 + else + Result := 0; +end; + { ------------------------------------------------------------------ } { TList } { ------------------------------------------------------------------ } @@ -429,11 +502,81 @@ begin Self.FCapacity := NewCap end; +procedure TSet.HashInvalidate; +begin + if Self.FHashSlots <> nil then + begin + FreeMem(Self.FHashSlots); + Self.FHashSlots := nil; + end; + Self.FHashCap := 0; +end; + +procedure TSet.HashInsertIdx(AIdx: Integer); +var + Slot: Integer; + SlotP: ^Integer; + EPtr: ^T; +begin + EPtr := Self.FData + AIdx * SizeOf(T); + Slot := GCHashOf(EPtr^) and (Self.FHashCap - 1); + while True do + begin + SlotP := Self.FHashSlots + Slot * SizeOf(Integer); + if SlotP^ = -1 then + begin + SlotP^ := AIdx; + Exit; + end; + Slot := (Slot + 1) and (Self.FHashCap - 1); + end; +end; + +procedure TSet.HashRebuild; +var + Cap: Integer; + I: Integer; + P: ^Integer; +begin + Cap := 16; + while Cap < Self.FCount * 2 do + Cap := Cap * 2; + if Self.FHashSlots <> nil then + FreeMem(Self.FHashSlots); + Self.FHashSlots := GetMem(Cap * SizeOf(Integer)); + Self.FHashCap := Cap; + for I := 0 to Cap - 1 do + begin + P := Self.FHashSlots + I * SizeOf(Integer); + P^ := -1; + end; + for I := 0 to Self.FCount - 1 do + Self.HashInsertIdx(I); +end; + function TSet.IndexOf(Value: T): Integer; var - I: Integer; - Ptr: ^T; + I: Integer; + Ptr: ^T; + Slot: Integer; + SlotP: ^Integer; begin + if Self.FCount >= GCHashThreshold then + begin + if Self.FHashCap = 0 then + Self.HashRebuild(); + Slot := GCHashOf(Value) and (Self.FHashCap - 1); + while True do + begin + SlotP := Self.FHashSlots + Slot * SizeOf(Integer); + if SlotP^ = -1 then + Exit(-1); + Ptr := Self.FData + SlotP^ * SizeOf(T); + if Ptr^ = Value then + Exit(SlotP^); + Slot := (Slot + 1) and (Self.FHashCap - 1); + end; + end; Result := -1; I := 0; while I < Self.FCount do @@ -458,7 +601,14 @@ begin Self.Grow(); Dest := Self.FData + Self.FCount * SizeOf(T); Dest^ := Value; - Self.FCount := Self.FCount + 1 + Self.FCount := Self.FCount + 1; + if Self.FHashCap > 0 then + begin + if Self.FCount * 2 > Self.FHashCap then + Self.HashInvalidate() + else + Self.HashInsertIdx(Self.FCount - 1); + end; end; procedure TSet.Exclude(Value: T); @@ -479,7 +629,9 @@ begin Dst^ := Src^; I := I + 1 end; - Self.FCount := Self.FCount - 1 + Self.FCount := Self.FCount - 1; + { Indexes shifted — rebuild lazily on the next lookup. } + Self.HashInvalidate() end; function TSet.Contains(Value: T): Boolean; @@ -489,11 +641,13 @@ end; procedure TSet.Clear; begin - Self.FCount := 0 + Self.FCount := 0; + Self.HashInvalidate() end; procedure TSet.Destroy; begin + Self.HashInvalidate(); FreeMem(Self.FData); Self.FData := nil; Self.FCount := 0; @@ -521,11 +675,83 @@ begin Self.FCapacity := NewCap end; +procedure TDictionary.HashInvalidate; +begin + if Self.FHashSlots <> nil then + begin + FreeMem(Self.FHashSlots); + Self.FHashSlots := nil; + end; + Self.FHashCap := 0; +end; + +procedure TDictionary.HashInsertIdx(AIdx: Integer); +var + Slot: Integer; + SlotP: ^Integer; + KPtr: ^K; +begin + KPtr := Self.FKeys + AIdx * SizeOf(K); + Slot := GCHashOf(KPtr^) and (Self.FHashCap - 1); + while True do + begin + SlotP := Self.FHashSlots + Slot * SizeOf(Integer); + if SlotP^ = -1 then + begin + SlotP^ := AIdx; + Exit; + end; + Slot := (Slot + 1) and (Self.FHashCap - 1); + end; +end; + +{ Keys are unique, so occupancy equals FCount; rebuilt at <= 50% load so + an empty slot terminates every probe chain. } +procedure TDictionary.HashRebuild; +var + Cap: Integer; + I: Integer; + P: ^Integer; +begin + Cap := 16; + while Cap < Self.FCount * 2 do + Cap := Cap * 2; + if Self.FHashSlots <> nil then + FreeMem(Self.FHashSlots); + Self.FHashSlots := GetMem(Cap * SizeOf(Integer)); + Self.FHashCap := Cap; + for I := 0 to Cap - 1 do + begin + P := Self.FHashSlots + I * SizeOf(Integer); + P^ := -1; + end; + for I := 0 to Self.FCount - 1 do + Self.HashInsertIdx(I); +end; + function TDictionary.FindKey(Key: K): Integer; var - I: Integer; - Ptr: ^K; + I: Integer; + Ptr: ^K; + Slot: Integer; + SlotP: ^Integer; begin + if Self.FCount >= GCHashThreshold then + begin + if Self.FHashCap = 0 then + Self.HashRebuild(); + Slot := GCHashOf(Key) and (Self.FHashCap - 1); + while True do + begin + SlotP := Self.FHashSlots + Slot * SizeOf(Integer); + if SlotP^ = -1 then + Exit(-1); + Ptr := Self.FKeys + SlotP^ * SizeOf(K); + if Ptr^ = Key then + Exit(SlotP^); + Slot := (Slot + 1) and (Self.FHashCap - 1); + end; + end; Result := -1; I := 0; while I < Self.FCount do @@ -562,7 +788,16 @@ begin VPtr := Self.FValues + Self.FCount * SizeOf(V); KPtr^ := Key; VPtr^ := Value; - Self.FCount := Self.FCount + 1 + Self.FCount := Self.FCount + 1; + { Keep the hash live across appends; past 50% load drop it and let the + next lookup rebuild at double size. } + if Self.FHashCap > 0 then + begin + if Self.FCount * 2 > Self.FHashCap then + Self.HashInvalidate() + else + Self.HashInsertIdx(Self.FCount - 1); + end; end end; @@ -611,7 +846,9 @@ begin VDst^ := VSrc^; I := I + 1 end; - Self.FCount := Self.FCount - 1 + Self.FCount := Self.FCount - 1; + { Indexes shifted — rebuild lazily on the next lookup. } + Self.HashInvalidate() end end; @@ -622,6 +859,7 @@ end; procedure TDictionary.Destroy; begin + Self.HashInvalidate(); FreeMem(Self.FKeys); FreeMem(Self.FValues); Self.FKeys := nil; @@ -651,11 +889,81 @@ begin Self.FCapacity := NewCap end; +procedure TOrderedDictionary.HashInvalidate; +begin + if Self.FHashSlots <> nil then + begin + FreeMem(Self.FHashSlots); + Self.FHashSlots := nil; + end; + Self.FHashCap := 0; +end; + +procedure TOrderedDictionary.HashInsertIdx(AIdx: Integer); +var + Slot: Integer; + SlotP: ^Integer; + KPtr: ^K; +begin + KPtr := Self.FKeys + AIdx * SizeOf(K); + Slot := GCHashOf(KPtr^) and (Self.FHashCap - 1); + while True do + begin + SlotP := Self.FHashSlots + Slot * SizeOf(Integer); + if SlotP^ = -1 then + begin + SlotP^ := AIdx; + Exit; + end; + Slot := (Slot + 1) and (Self.FHashCap - 1); + end; +end; + +procedure TOrderedDictionary.HashRebuild; +var + Cap: Integer; + I: Integer; + P: ^Integer; +begin + Cap := 16; + while Cap < Self.FCount * 2 do + Cap := Cap * 2; + if Self.FHashSlots <> nil then + FreeMem(Self.FHashSlots); + Self.FHashSlots := GetMem(Cap * SizeOf(Integer)); + Self.FHashCap := Cap; + for I := 0 to Cap - 1 do + begin + P := Self.FHashSlots + I * SizeOf(Integer); + P^ := -1; + end; + for I := 0 to Self.FCount - 1 do + Self.HashInsertIdx(I); +end; + function TOrderedDictionary.FindKey(Key: K): Integer; var - I: Integer; - Ptr: ^K; + I: Integer; + Ptr: ^K; + Slot: Integer; + SlotP: ^Integer; begin + if Self.FCount >= GCHashThreshold then + begin + if Self.FHashCap = 0 then + Self.HashRebuild(); + Slot := GCHashOf(Key) and (Self.FHashCap - 1); + while True do + begin + SlotP := Self.FHashSlots + Slot * SizeOf(Integer); + if SlotP^ = -1 then + Exit(-1); + Ptr := Self.FKeys + SlotP^ * SizeOf(K); + if Ptr^ = Key then + Exit(SlotP^); + Slot := (Slot + 1) and (Self.FHashCap - 1); + end; + end; Result := -1; I := 0; while I < Self.FCount do @@ -690,7 +998,14 @@ begin VPtr := Self.FValues + Self.FCount * SizeOf(V); KPtr^ := Key; VPtr^ := Value; - Self.FCount := Self.FCount + 1 + Self.FCount := Self.FCount + 1; + if Self.FHashCap > 0 then + begin + if Self.FCount * 2 > Self.FHashCap then + Self.HashInvalidate() + else + Self.HashInsertIdx(Self.FCount - 1); + end; end end; @@ -738,7 +1053,9 @@ begin VDst^ := VSrc^; I := I + 1 end; - Self.FCount := Self.FCount - 1 + Self.FCount := Self.FCount - 1; + { Indexes shifted — rebuild lazily on the next lookup. } + Self.HashInvalidate() end end; @@ -765,6 +1082,7 @@ end; procedure TOrderedDictionary.Destroy; begin + Self.HashInvalidate(); FreeMem(Self.FKeys); FreeMem(Self.FValues); Self.FKeys := nil;