├── .travis.yml ├── tests ├── hamt_tests.lpi └── hamt_tests.pas ├── README.md ├── hamt.sets.pas ├── hamt.maps.pas └── hamt.internals.pas /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | sudo: required 3 | dist: bionic 4 | 5 | os: 6 | - linux 7 | 8 | env: 9 | matrix: 10 | - FPC_VER=3.0.4 11 | 12 | install: 13 | - if [[ $FPC_VER = 3.0.4 ]]; then wget http://mirrors.iwi.me/lazarus/releases/Lazarus%20Linux%20amd64%20DEB/Lazarus%201.8.4/fpc_3.0.4-3_amd64.deb; sudo dpkg --force-overwrite -i *.deb; fi 14 | - git clone https://github.com/benibela/bbutils.git bbutils 15 | 16 | script: 17 | - fpc -Fubbutils tests/hamt_tests.pas 18 | - tests/hamt_tests 19 | - rm hamt*.o hamt*.ppu 20 | - fpc -O2 -Fubbutils tests/hamt_tests.pas 21 | - tests/hamt_tests 22 | - rm hamt*.o hamt*.ppu 23 | - fpc -O3 -Fubbutils tests/hamt_tests.pas 24 | - tests/hamt_tests 25 | - rm hamt*.o hamt*.ppu 26 | - fpc -O4 -Fubbutils tests/hamt_tests.pas 27 | - tests/hamt_tests 28 | - rm hamt*.o hamt*.ppu 29 | - fpc -CoRt -Fubbutils tests/hamt_tests.pas 30 | - tests/hamt_tests 31 | - rm hamt*.o hamt*.ppu 32 | - fpc -CoRt -O4 -Fubbutils tests/hamt_tests.pas 33 | - tests/hamt_tests 34 | 35 | notifications: 36 | email: 37 | on_success: false 38 | on_failure: change 39 | -------------------------------------------------------------------------------- /tests/hamt_tests.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | <UseAppBundle Value="False"/> 16 | <ResourceType Value="res"/> 17 | </General> 18 | <BuildModes Count="1"> 19 | <Item1 Name="default" Default="True"/> 20 | </BuildModes> 21 | <PublishOptions> 22 | <Version Value="2"/> 23 | </PublishOptions> 24 | <RunParams> 25 | <FormatVersion Value="2"/> 26 | <Modes Count="1"> 27 | <Mode0 Name="default"/> 28 | </Modes> 29 | </RunParams> 30 | <Units Count="4"> 31 | <Unit0> 32 | <Filename Value="hamt_tests.pas"/> 33 | <IsPartOfProject Value="True"/> 34 | </Unit0> 35 | <Unit1> 36 | <Filename Value="..\hamt.internals.pas"/> 37 | <IsPartOfProject Value="True"/> 38 | </Unit1> 39 | <Unit2> 40 | <Filename Value="..\hamt.maps.pas"/> 41 | <IsPartOfProject Value="True"/> 42 | </Unit2> 43 | <Unit3> 44 | <Filename Value="..\hamt.sets.pas"/> 45 | <IsPartOfProject Value="True"/> 46 | </Unit3> 47 | </Units> 48 | </ProjectOptions> 49 | <CompilerOptions> 50 | <Version Value="11"/> 51 | <PathDelim Value="\"/> 52 | <SearchPaths> 53 | <IncludeFiles Value="$(ProjOutDir)"/> 54 | <OtherUnitFiles Value="\home\benito\hg\components\pascal\data\;\home\benito\hg\programs\contests\euler\;\home\benito\hg\components\pascal\internet\;\home\benito\hg\components\lazarus\dialogs\;\home\benito\hg\components\pascal\system\;.."/> 55 | <SrcPath Value="\home\benito\hg\components\pascal\import\synapse\"/> 56 | </SearchPaths> 57 | <Parsing> 58 | <SyntaxOptions> 59 | <IncludeAssertionCode Value="True"/> 60 | </SyntaxOptions> 61 | </Parsing> 62 | <CodeGeneration> 63 | <SmartLinkUnit Value="True"/> 64 | <Checks> 65 | <IOChecks Value="True"/> 66 | <RangeChecks Value="True"/> 67 | <OverflowChecks Value="True"/> 68 | </Checks> 69 | <Optimizations> 70 | <OptimizationLevel Value="4"/> 71 | </Optimizations> 72 | </CodeGeneration> 73 | <Linking> 74 | <Debugging> 75 | <UseHeaptrc Value="True"/> 76 | <TrashVariables Value="True"/> 77 | </Debugging> 78 | <LinkSmart Value="True"/> 79 | </Linking> 80 | </CompilerOptions> 81 | <Debugging> 82 | <Exceptions Count="4"> 83 | <Item1> 84 | <Name Value="EAbort"/> 85 | </Item1> 86 | <Item2> 87 | <Name Value="ECodetoolError"/> 88 | </Item2> 89 | <Item3> 90 | <Name Value="EFOpenError"/> 91 | </Item3> 92 | <Item4> 93 | <Name Value="RunError(203)"/> 94 | </Item4> 95 | </Exceptions> 96 | </Debugging> 97 | </CONFIG> 98 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Hash Array Mapped Trie (HAMT) 2 | ============ 3 | 4 | A HAMT is a hashmap/set stored as trie, which provides update and lookup performance similarly to a normal hashmap/set, but needs no rehashing and also allows one to copy the entire map/set in constant time. This implementation uses a 32 bit hash and trie nodes with 32 children, so 5 bits of the hash are consumed to choose the next child. When there are no hash collisions, this HAMT can store 2^32 items with a maximal tree depth of (log_32 2^32) = 6, i.e., you need 6 memory accesses to find any key/value which is practically O(1). Although when there are hash collisions, they are put in an array. 5 | 6 | Each HAMT node carries a reference counter, since FreePascal has no garbage collector. If the reference count is 1, the node can mutate, otherwise it is immutable with a copy-on-write semantic like strings. The counter is updated atomically, so the map could be shared across threads. This might lead to a large number of memory writes when a path of a full tree is copied (6 levels of up 32 children), but still less than copying a full hash table. 7 | 8 | Everything is implemented using generics, so it can be used with all types. 9 | 10 | Examples 11 | ------------ 12 | 13 | Mutable Map: 14 | 15 | ```pascal 16 | type TMutableMapStringString = specialize TMutableMap<string, string, THAMTTypeInfo>; 17 | var map: TMutableMapStringString; 18 | p: TMutableMapStringString.PPair; 19 | begin 20 | map := TMutableMapStringString.create; 21 | map.Insert('hello', 'world'); 22 | map.insert('foo', 'bar'); 23 | map['abc'] := 'def'; 24 | 25 | writeln(map['hello']); // world 26 | writeln(map.get('foo')); // bar 27 | writeln(map.get('abc', 'default')); // def 28 | 29 | //enumerate all 30 | for p in map do 31 | writeln(p^.key, ': ', p^.value); 32 | 33 | map.free; 34 | end. 35 | ``` 36 | 37 | Immutable Map: 38 | 39 | 40 | ```pascal 41 | type TImmutableMapStringString = specialize TImmutableMap<string, string, THAMTTypeInfo>; 42 | var map, map2, map3: TImmutableMapStringString; 43 | p: TImmutableMapStringString.PPair; 44 | begin 45 | map := TImmutableMapStringString.create; 46 | map2 := map.Insert('hello', 'world'); 47 | map3 := map2.insert('foo', 'bar'); 48 | 49 | writeln(map.get('hello', 'default')); // default 50 | writeln(map.get('foo', 'default')); // default 51 | 52 | writeln(map2.get('hello')); // world 53 | writeln(map2.get('foo', 'default')); // default 54 | 55 | writeln(map3['hello']); // world 56 | writeln(map3['foo']); // bar 57 | 58 | //enumerate all 59 | for p in map3 do 60 | writeln(p^.key, ': ', p^.value); 61 | 62 | map.free; 63 | map2.free; 64 | map3.free; 65 | end. 66 | ``` 67 | 68 | Mutable Set: 69 | ```pascal 70 | type TMutableSetString = specialize TMutableSet<string, THAMTTypeInfo>; 71 | var stringSet: TMutableSetString; 72 | p: TMutableSetString.PItem; 73 | begin 74 | stringSet := TMutableSetString.create; 75 | stringSet.Insert('hello'); 76 | stringSet.insert('foo'); 77 | 78 | writeln(stringSet['hello']); // true 79 | writeln(stringSet.contains('foo')); // true 80 | writeln(stringSet.contains('abc')); // false 81 | 82 | //enumerate all 83 | for p in stringSet do 84 | writeln(p^); 85 | 86 | stringSet.free; 87 | end. 88 | ``` 89 | 90 | 91 | Immutable Set: 92 | 93 | ```pascal 94 | type TImmutableSetString = specialize TImmutableSet<string, THAMTTypeInfo>; 95 | var set1, set2, set3: TImmutableSetString; 96 | p: TImmutableSetString.PItem; 97 | begin 98 | set1 := TImmutableSetString.create; 99 | set2 := set1.Insert('hello'); 100 | set3 := set2.insert('foo'); 101 | 102 | writeln(set1.contains('hello')); // false 103 | writeln(set1['foo']); // false 104 | 105 | writeln(set2.contains('hello')); // true 106 | writeln(set2['foo']); // false 107 | 108 | writeln(set3.contains('hello')); // true 109 | writeln(set3['foo']); // true 110 | 111 | //enumerate all 112 | for p in set3 do 113 | writeln(p^); 114 | 115 | set1.free; 116 | set2.free; 117 | set3.free; 118 | end. 119 | ``` 120 | 121 | 122 | Documentation 123 | -------- 124 | 125 | Manual: 126 | 127 | 128 | * [Maps](https://www.benibela.de/documentation/hamt/hamt.maps.html) 129 | 130 | * [Sets](https://www.benibela.de/documentation/hamt/hamt.sets.html) 131 | 132 | * [HAMT](https://www.benibela.de/documentation/hamt/hamt.internals.html) 133 | 134 | Installation 135 | --------- 136 | This library requires no installation, there are no dependencies besides the FreePascal compiler. Just copy the `hamt.*` files in the unit search path of FreePascal. Then you can use the maps with `uses hamt.maps` and the sets with `uses hamt.sets`. 137 | 138 | However, beware that the last stable release of FreePascal, 3.0.4, cannot compile the complex generics used here. You need to have at least FreePascal 3.1.1, preferably 3.3.1 with revision r39690. 139 | 140 | To run the tests cases in `tests/hamt_tests.pas`, you also need to have [bbutils](https://www.benibela.de/sources_en.html#bbutils) in the search path. 141 | 142 | 143 | 144 | References 145 | ------- 146 | [Ideal Hash Trees](https://infoscience.epfl.ch/record/64398/files/idealhashtrees.pdf) 147 | 148 | [Efficient Immutable Collections](https://michael.steindorfer.name/publications/phd-thesis-efficient-immutable-collections.pdf) 149 | 150 | -------------------------------------------------------------------------------- /hamt.sets.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2018 Benito van der Zander (BeniBela) 3 | benito@benibela.de 4 | www.benibela.de 5 | 6 | This file is distributed under under the same license as Lazarus and the LCL itself: 7 | 8 | This file is distributed under the Library GNU General Public License 9 | with the following modification: 10 | 11 | As a special exception, the copyright holders of this library give you 12 | permission to link this library with independent modules to produce an 13 | executable, regardless of the license terms of these independent modules, 14 | and to copy and distribute the resulting executable under terms of your choice, 15 | provided that you also meet, for each linked independent module, the terms 16 | and conditions of the license of that module. An independent module is a 17 | module which is not derived from or based on this library. If you modify this 18 | library, you may extend this exception to your version of the library, but 19 | you are not obligated to do so. If you do not wish to do so, delete this 20 | exception statement from your version. 21 | 22 | } 23 | {** 24 | @abstract(Mutable and immutable persistent sets as hash array mapped trie (HAMT)) 25 | 26 | Public generic classes: 27 | 28 | * TReadOnlySet 29 | 30 | * TMutableSet 31 | 32 | * TImmutableSet 33 | 34 | Public specialized classes: 35 | 36 | * TMutableSetString 37 | 38 | * TImmutableSetString 39 | 40 | 41 | } 42 | unit hamt.sets; 43 | 44 | {$mode objfpc}{$H+}{$ModeSwitch autoderef}{$ModeSwitch advancedrecords} 45 | 46 | interface 47 | 48 | uses 49 | sysutils, hamt.internals; 50 | 51 | type 52 | THAMTTypeInfo = hamt.internals.THAMTTypeInfo; 53 | 54 | //** @abstract(Generic read-only set) 55 | //** 56 | //** The data in this set can be read, but there are no public methods to modify it. 57 | generic TReadOnlySet<TItem, TInfo> = class(specialize TReadOnlyCustomSet<TItem, TInfo>) 58 | type PItem = ^TItem; 59 | protected 60 | function forceInclude(const item: TItem; allowOverride: boolean): boolean; inline; 61 | function forceExclude(const item: TItem): boolean; inline; 62 | public 63 | //** Returns if the set contains a certain item 64 | function contains(const item: TItem): boolean; inline; 65 | //** Default parameter, so you can test if the set contains an item @code(set[key]) 66 | property items[item: TItem]: Boolean read contains; default; 67 | end; 68 | 69 | 70 | 71 | {** @abstract(Generic mutable set) 72 | 73 | Data in this set can be read (see ancestor TReadOnlySet) and modified. 74 | 75 | Example: 76 | 77 | @longcode(# 78 | type TMutableSetString = specialize TMutableSet<string, THAMTTypeInfo>; 79 | var stringSet: TMutableSetString; 80 | p: TMutableSetString.PItem; 81 | begin 82 | stringSet := TMutableSetString.create; 83 | stringSet.Insert('hello'); 84 | stringSet.insert('foo'); 85 | 86 | writeln(stringSet['hello']); // true 87 | writeln(stringSet.contains('foo')); // true 88 | writeln(stringSet.contains('abc')); // false 89 | 90 | //enumerate all 91 | for p in stringSet do 92 | writeln(p^); 93 | 94 | stringSet.free; 95 | end. 96 | #) 97 | } 98 | generic TMutableSet<TItem, TInfo> = class(specialize TReadOnlySet<TItem, TInfo>) 99 | private 100 | procedure toggleItem(item: TItem; AValue: Boolean); 101 | public 102 | //** Creates an empty set 103 | constructor Create; 104 | //** Creates a set equal to other. No data is copied, till either set is modified (copy-on-write). 105 | constructor Create(other: specialize TReadOnlyCustomSet<TItem, TInfo>); 106 | //** Inserts an item, if the set does not contain the item or allowOverride is true. 107 | //** @returns If the set did not contain item. 108 | function include(const item: TItem; allowOverride: boolean = true): boolean; inline; 109 | //** Removes an item, 110 | //** @returns If the set did contain item. 111 | function exclude(const item: TItem): boolean; inline; 112 | //** Inserts an item, or raises an exception if the set already contains the item 113 | procedure insert(const item: TItem); inline; 114 | //** Removes an item, or raises an exception if the set did not contain the item 115 | procedure remove(const item: TItem); inline; 116 | //** Removes everything from the set; 117 | procedure clear; 118 | //** Creates a new set equal to self. No data is copied, till either set is modified (copy-on-write). 119 | function clone: TMutableSet; 120 | //** Default parameter, so you can test and update the set with @code(set[key]) 121 | property items[item: TItem]: Boolean read contains write toggleItem; default; 122 | end; 123 | 124 | {** @abstract(Generic immutable set) 125 | 126 | Data in this set can be read (see ancestor TReadOnlySet) and modified by creating new sets. 127 | 128 | Example: @longcode(# 129 | type TImmutableSetString = specialize TImmutableSet<string, THAMTTypeInfo>; 130 | var set1, set2, set3: TImmutableSetString; 131 | p: TImmutableSetString.PItem; 132 | begin 133 | set1 := TImmutableSetString.create; 134 | set2 := set1.Insert('hello'); 135 | set3 := set2.insert('foo'); 136 | 137 | writeln(set1.contains('hello')); // false 138 | writeln(set1['foo']); // false 139 | 140 | writeln(set2.contains('hello')); // true 141 | writeln(set2['foo']); // false 142 | 143 | writeln(set3.contains('hello')); // true 144 | writeln(set3['foo']); // true 145 | 146 | //enumerate all 147 | for p in set3 do 148 | writeln(p^); 149 | 150 | set1.free; 151 | set2.free; 152 | set3.free; 153 | end. 154 | #) 155 | } 156 | generic TImmutableSet<TItem, TInfo> = class(specialize TReadOnlySet<TItem, TInfo>) 157 | public 158 | //** Creates an empty set 159 | constructor Create; 160 | //** Creates a set equal to other. No data is copied, till either set is modified (copy-on-write). 161 | constructor Create(other: specialize TReadOnlyCustomSet<TItem, TInfo>); 162 | 163 | //** Creates a new set containing item @code(item). If the set does not contain item or allowOverride is true, item is inserted, otherwise the value is unchanged. 164 | //** @returns The new set 165 | function include(const item: TItem; allowOverride: boolean = true): TImmutableSet; inline; 166 | //** Removes an item 167 | //** @returns The new set without item 168 | function exclude(const item: TItem): TImmutableSet; inline; 169 | //** Inserts an item, or raises an exception if the set already contains the item 170 | //** @returns The new set 171 | function insert(const item: TItem): TImmutableSet; inline; 172 | //** Creates a new set without item, or raises an exception if the set did not contain item 173 | //** @returns The new set without item 174 | function remove(const item: TItem): TImmutableSet; inline; 175 | 176 | //** Creates a new set equal to self. No data is copied, till either set is modified (copy-on-write). 177 | function clone: TImmutableSet; 178 | end; 179 | 180 | //** @abstract(A TMutableSet containing strings.) 181 | //** The set handles reference counting and freeing of the strings. 182 | TMutableSetString = specialize TMutableSet<string, THAMTTypeInfo>; 183 | //** @abstract(A TImmutableSet containing strings.) 184 | //** The set handles reference counting and freeing of the strings. 185 | TImmutableSetString = specialize TImmutableSet<string, THAMTTypeInfo>; 186 | 187 | 188 | implementation 189 | 190 | 191 | function TReadOnlySet.forceInclude(const item: TItem; allowOverride: boolean): boolean; 192 | begin 193 | result := THAMTNode.include(@froot, item, allowOverride); 194 | if Result then Inc(fcount); 195 | end; 196 | 197 | function TReadOnlySet.forceExclude(const item: TItem): boolean; 198 | begin 199 | result := THAMTNode.exclude(@froot, item); 200 | if result then dec(fcount); 201 | end; 202 | 203 | 204 | function TReadOnlySet.contains(const item: TItem): boolean; 205 | begin 206 | result := froot.find(item) <> nil; 207 | end; 208 | 209 | {function TReadOnlySet.get(const key: TKey; const def: TValue): TValue; 210 | var 211 | pair: PPair; 212 | begin 213 | pair := find(key); 214 | if pair = nil then result := def 215 | else result := pair.value; 216 | end; 217 | 218 | function TReadOnlySet.get(const key: TKey): TValue; 219 | var 220 | pair: PPair; 221 | begin 222 | pair := find(key); 223 | if pair = nil then raiseMissingKey(key); 224 | result := pair.value; 225 | end; } 226 | 227 | procedure TMutableSet.toggleItem(item: TItem; AValue: Boolean); 228 | begin 229 | if AValue then include(item, true) 230 | else exclude(item); 231 | end; 232 | 233 | constructor TMutableSet.Create; 234 | begin 235 | froot := THAMTNode.allocateEmpty; 236 | fcount := 0; 237 | end; 238 | 239 | constructor TMutableSet.Create(other: specialize TReadOnlyCustomSet<TItem, TInfo>); 240 | begin 241 | fcount := other.fcount; 242 | froot := other.froot; 243 | InterLockedIncrement(froot.refCount); 244 | end; 245 | 246 | function TMutableSet.include(const item: TItem; allowOverride: boolean): boolean; 247 | begin 248 | result := forceInclude(item, allowOverride); 249 | end; 250 | 251 | function TMutableSet.exclude(const item: TItem): boolean; 252 | begin 253 | result := forceExclude(item); 254 | end; 255 | 256 | procedure TMutableSet.insert(const item: TItem); 257 | begin 258 | if not forceInclude(item, false) then raiseItemError(rsDuplicateItem, item); 259 | end; 260 | 261 | procedure TMutableSet.remove(const item: TItem); 262 | begin 263 | if not forceExclude(item) then raiseItemError(rsMissingItem, item); 264 | end; 265 | 266 | procedure TMutableSet.clear; 267 | begin 268 | THAMTNode.decrementRefCount(froot); 269 | froot := THAMTNode.allocateEmpty; 270 | fcount := 0; 271 | end; 272 | 273 | 274 | function TMutableSet.clone: TMutableSet; 275 | begin 276 | result := TMutableSet.Create(self); 277 | end; 278 | 279 | 280 | 281 | 282 | constructor TImmutableSet.Create; 283 | begin 284 | froot := THAMTNode.allocateEmpty; 285 | fcount := 0; 286 | end; 287 | 288 | constructor TImmutableSet.Create(other: specialize TReadOnlyCustomSet<TItem, TInfo>); 289 | begin 290 | fcount := other.fcount; 291 | froot := other.froot; 292 | InterLockedIncrement(froot.refCount); 293 | end; 294 | 295 | function TImmutableSet.include(const item: TItem; allowOverride: boolean): TImmutableSet; 296 | begin 297 | result := TImmutableSet.Create(self); 298 | result.forceInclude(item, allowOverride); 299 | end; 300 | 301 | function TImmutableSet.exclude(const item: TItem): TImmutableSet; 302 | begin 303 | result := TImmutableSet.Create(self); 304 | result.forceExclude(item); 305 | end; 306 | 307 | function TImmutableSet.insert(const item: TItem): TImmutableSet; 308 | begin 309 | result := TImmutableSet.Create(self); 310 | if not result.forceInclude(item, false) then begin 311 | result.free; 312 | raiseItemError(rsDuplicateItem, item); 313 | end; 314 | end; 315 | 316 | function TImmutableSet.remove(const item: TItem): TImmutableSet; 317 | begin 318 | result := TImmutableSet.Create(self); 319 | if not result.forceExclude(item) then begin 320 | result.free; 321 | raiseItemError(rsMissingItem, item); 322 | end; 323 | end; 324 | 325 | function TImmutableSet.clone: TImmutableSet; 326 | begin 327 | result := TImmutableSet.Create(self); 328 | end; 329 | 330 | 331 | end. 332 | 333 | -------------------------------------------------------------------------------- /hamt.maps.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2018 Benito van der Zander (BeniBela) 3 | benito@benibela.de 4 | www.benibela.de 5 | 6 | This file is distributed under under the same license as Lazarus and the LCL itself: 7 | 8 | This file is distributed under the Library GNU General Public License 9 | with the following modification: 10 | 11 | As a special exception, the copyright holders of this library give you 12 | permission to link this library with independent modules to produce an 13 | executable, regardless of the license terms of these independent modules, 14 | and to copy and distribute the resulting executable under terms of your choice, 15 | provided that you also meet, for each linked independent module, the terms 16 | and conditions of the license of that module. An independent module is a 17 | module which is not derived from or based on this library. If you modify this 18 | library, you may extend this exception to your version of the library, but 19 | you are not obligated to do so. If you do not wish to do so, delete this 20 | exception statement from your version. 21 | 22 | } 23 | {** 24 | @abstract(Mutable and immutable persistent maps as hash array mapped trie (HAMT)) 25 | 26 | Public generic classes: 27 | 28 | * TReadOnlyMap 29 | 30 | * TMutableMap 31 | 32 | * TImmutableMap 33 | 34 | Public specialized classes: 35 | 36 | * TMutableMapStringString 37 | 38 | * TMutableMapStringObject 39 | 40 | * TImmutableMapStringString 41 | 42 | * TImmutableMapStringObject 43 | 44 | } 45 | unit hamt.maps; 46 | 47 | {$mode objfpc}{$H+}{$ModeSwitch autoderef}{$ModeSwitch advancedrecords} 48 | 49 | interface 50 | 51 | uses 52 | sysutils, hamt.internals; 53 | 54 | type 55 | THAMTTypeInfo = hamt.internals.THAMTTypeInfo; 56 | 57 | generic THAMTPairInfo<TKey, TValue, TInfo> = record 58 | type 59 | TPair = packed record 60 | key: TKey; 61 | value: TValue; 62 | end; 63 | TValueSizeEquivalent = packed array[1..sizeof(TValue)] of byte; 64 | 65 | class function hash(const p: TPair): THAMTHash; static; inline; 66 | class function equal(const p, q: TPair): boolean; static; inline; 67 | 68 | class procedure addRef(var p: TPair); static; inline; 69 | class procedure release(var p: TPair); static; inline; 70 | 71 | class procedure assignEqual(var p: TPair; const q: TPair); static; inline; 72 | 73 | class function toString(const p: TPair): string; static; inline; 74 | end; 75 | 76 | //** @abstract(Generic read-only map) 77 | //** 78 | //** The data in this map can be read, but there are no public methods to modify it. 79 | generic TReadOnlyMap<TKey, TValue, TInfo> = class(specialize TReadOnlyCustomSet<specialize THAMTPairInfo<TKey, TValue, TInfo>.TPair, specialize THAMTPairInfo<TKey, TValue, TInfo>>) 80 | type 81 | PKey = ^TKey; 82 | PValue = ^TValue; 83 | TKeySizeEquivalent = packed array[1..sizeof(TKey)] of byte; 84 | TValueSizeEquivalent = packed array[1..sizeof(TValue)] of byte; 85 | PPair = THAMTNode.PItem; 86 | private 87 | function forceInclude(const key: TKey; const value: TValue; allowOverride: boolean): boolean; inline; 88 | function forceExclude(const key: TKey): boolean; inline; 89 | protected 90 | function find(const key: TKey): PPair; inline; 91 | class procedure raiseKeyError(const message: string; const key: TKey); static; 92 | public 93 | //** Creates an empty map 94 | constructor Create; 95 | //** Creates a map equal to other. No data is copied, till either map is modified (copy-on-write). 96 | constructor Create(other: specialize TReadOnlyCustomSet<THAMTNode.TItem, THAMTNode.TInfo>); 97 | //** Returns if the map contains a certain key 98 | function contains(const key:TKey): boolean; inline; 99 | //** Returns the value for a certain key, or default value def if the map does not contain the key 100 | function get(const key: TKey; const def: TValue): TValue; inline; 101 | //** Returns the value for a certain key, or default(TValue) if the map does not contain the key 102 | function getOrDefault(const key: TKey): TValue; inline; 103 | //** Returns the value for a certain key, or raises an exception if the map does not contain the key 104 | function get(const key: TKey): TValue; inline; 105 | //** Default parameter, so you can read elements with @code(map[key]) 106 | property items[key: TKey]: TValue read get; default; 107 | end; 108 | 109 | 110 | 111 | {** @abstract(Generic mutable map) 112 | 113 | Data in this map can be read (see ancestor TReadOnlyMap) and modified. 114 | 115 | Example: 116 | 117 | @longcode(# 118 | type TMutableMapStringString = specialize TMutableMap<string, string, THAMTTypeInfo>; 119 | var map: TMutableMapStringString; 120 | p: TMutableMapStringString.PPair; 121 | begin 122 | map := TMutableMapStringString.create; 123 | map.Insert('hello', 'world'); 124 | map.insert('foo', 'bar'); 125 | map['abc'] := 'def'; 126 | 127 | writeln(map['hello']); // world 128 | writeln(map.get('foo')); // bar 129 | writeln(map.get('abc', 'default')); // def 130 | 131 | //enumerate all 132 | for p in map do 133 | writeln(p^.key, ': ', p^.value); 134 | 135 | map.free; 136 | end. 137 | #) 138 | } 139 | generic TMutableMap<TKey, TValue, TInfo> = class(specialize TReadOnlyMap<TKey, TValue, TInfo>) 140 | protected 141 | procedure includeItem(const key: TKey; const value: TValue); inline; 142 | function getRef(const key: TKey): PValue; 143 | public 144 | //** Inserts a (key, value) pair, if allowOverride is true or key did not exist 145 | //** @returns If the map did not contain key 146 | function include(const key: TKey; const value: TValue; allowOverride: boolean = true): boolean; inline; 147 | //** Removes a (key, value) pair 148 | //** @returns If the map did contain key 149 | function exclude(const key: TKey): boolean; inline; 150 | //** Inserts a (key, value) pair, or raises an exception if the map did not contain key 151 | procedure insert(const key: TKey; const value: TValue); inline; 152 | //** Removes key (and the associated value), or raises an exception if the map did not contain key 153 | procedure remove(const key:TKey); inline; 154 | //** Removes everything from the map; 155 | procedure clear; 156 | //** Creates a new map equal to self. No data is copied, till either map is modified (copy-on-write). 157 | function clone: TMutableMap; 158 | //** Default parameter, so you can read or write elements with @code(map[key]) 159 | property items[key: TKey]: TValue read get write includeItem; default; 160 | //** Pointer to value 161 | property mutable[key: TKey]: PValue read getRef; 162 | end; 163 | 164 | {** @abstract(Generic immutable map) 165 | 166 | Data in this map can be read (see ancestor TReadOnlyMap) and modified by creating new maps. 167 | 168 | Example: @longcode(# 169 | type TImmutableMapStringString = specialize TImmutableMap<string, string, THAMTTypeInfo>; 170 | var map, map2, map3: TImmutableMapStringString; 171 | p: TImmutableMapStringString.PPair; 172 | begin 173 | map := TImmutableMapStringString.create; 174 | map2 := map.Insert('hello', 'world'); 175 | map3 := map2.insert('foo', 'bar'); 176 | 177 | writeln(map.get('hello', 'default')); // default 178 | writeln(map.get('foo', 'default')); // default 179 | 180 | writeln(map2.get('hello')); // world 181 | writeln(map2.get('foo', 'default')); // default 182 | 183 | writeln(map3['hello']); // world 184 | writeln(map3['foo']); // bar 185 | 186 | //enumerate all 187 | for p in map3 do 188 | writeln(p^.key, ': ', p^.value); 189 | 190 | map.free; 191 | map2.free; 192 | map3.free; 193 | end. 194 | #) 195 | } 196 | generic TImmutableMap<TKey, TValue, TInfo> = class(specialize TReadOnlyMap<TKey, TValue, TInfo>) 197 | public 198 | //** Creates a new map containing (key, value). If the map does not contain key or allowOverride is true, the value associated with the key is @code(value), otherwise the value is unchanged. 199 | //** @returns The new map 200 | function include(const key: TKey; const value: TValue; allowOverride: boolean = true): TImmutableMap; inline; overload; 201 | //** Creates a new map without key and its associated value 202 | //** @returns The new map 203 | function exclude(const key: TKey): TImmutableMap; inline; 204 | //** Creates a new map containing (key, value), or raises an exception if the map already contained key 205 | //** @returns The new map 206 | function insert(const key: TKey; const value: TValue): TImmutableMap; inline; 207 | //** Creates a new map without key and its associated value, or raises an exception if the map did not contain key 208 | //** @returns The new map 209 | function remove(const key:TKey): TImmutableMap; inline; 210 | //** Creates a new map equal to self. No data is copied, till either map is modified (copy-on-write). 211 | function clone: TImmutableMap; 212 | end; 213 | 214 | //** @abstract(A TMutableMap mapping string keys to string values.) 215 | //** The map handles reference counting and freeing of the strings. 216 | TMutableMapStringString = specialize TMutableMap<string, string, THAMTTypeInfo>; 217 | //** @abstract(A TMutableMap mapping string keys to TObject values.) 218 | //** The map handles reference counting and freeing of the string keys, but the objects are neither changed nor freed. 219 | TMutableMapStringObject = specialize TMutableMap<string, TObject, THAMTTypeInfo>; 220 | //** @abstract(A TImmutableMap mapping string keys to string values.) 221 | //** The map handles reference counting and freeing of the strings. 222 | TImmutableMapStringString = specialize TImmutableMap<string, string, THAMTTypeInfo>; 223 | //** @abstract(A TImmutableMap mapping string keys to TObject values.) 224 | //** The map handles reference counting and freeing of the string keys, but the objects are neither changed nor freed. 225 | TImmutableMapStringObject = specialize TImmutableMap<string, TObject, THAMTTypeInfo>; 226 | 227 | 228 | implementation 229 | 230 | 231 | class function THAMTPairInfo.hash(const p: TPair): THAMTHash; 232 | begin 233 | result := TInfo.hash(p.key); 234 | end; 235 | 236 | class function THAMTPairInfo.equal(const p, q: TPair): boolean; 237 | begin 238 | result := TInfo.equal(p.key, q.key); 239 | end; 240 | 241 | class procedure THAMTPairInfo.addRef(var p: TPair); 242 | begin 243 | with p do begin 244 | TInfo.addRef(key); 245 | TInfo.addRef(value); 246 | end; 247 | end; 248 | 249 | class procedure THAMTPairInfo.release(var p: TPair); 250 | begin 251 | with p do begin 252 | TInfo.release(key); 253 | TInfo.release(value); 254 | end; 255 | end; 256 | 257 | class procedure THAMTPairInfo.assignEqual(var p: TPair; const q: TPair); 258 | begin 259 | TInfo.release(p.value); 260 | TValueSizeEquivalent(p.value) := TValueSizeEquivalent(q.value); 261 | TInfo.addRef(p.value); 262 | end; 263 | 264 | class function THAMTPairInfo.toString(const p: TPair): string; 265 | begin 266 | result := TInfo.toString(p.key); 267 | end; 268 | 269 | constructor TReadOnlyMap.Create; 270 | begin 271 | froot := THAMTNode.allocateEmpty; 272 | fcount := 0; 273 | end; 274 | 275 | constructor TReadOnlyMap.Create(other: specialize TReadOnlyCustomSet<THAMTNode.TItem, THAMTNode.TInfo>); 276 | begin 277 | fcount := other.fcount; 278 | froot := other.froot; 279 | InterLockedIncrement(froot.refCount); 280 | end; 281 | 282 | function TReadOnlyMap.forceInclude(const key: TKey; const value: TValue; allowOverride: boolean): boolean; 283 | var tempPair: packed array[1..sizeof(TKey)+sizeof(TValue)] of byte; 284 | begin 285 | TKeySizeEquivalent(PPair(@tempPair).key) := TKeySizeEquivalent(key); 286 | TValueSizeEquivalent(PPair(@tempPair).value) := TValueSizeEquivalent(value); 287 | result := THAMTNode.include(@froot, PPair(@tempPair)^, allowOverride); 288 | if result then inc(fcount); 289 | end; 290 | 291 | function TReadOnlyMap.forceExclude(const key: TKey): boolean; 292 | begin 293 | result := THAMTNode.exclude(@froot, PPair(@key)^ ); //this cast should work, because key is the first element of TPair 294 | if result then dec(fcount); 295 | end; 296 | 297 | 298 | function TReadOnlyMap.find(const key: TKey): PPair; 299 | begin 300 | result := froot.find( PPair(@key)^ ); //this cast should work, because key is the first element of TPair 301 | end; 302 | 303 | class procedure TReadOnlyMap.raiseKeyError(const message: string; const key: TKey); 304 | var s: string; 305 | begin 306 | s := TInfo.toString(key); 307 | raise EHAMTException.Create(Format(message, [s]) ); 308 | end; 309 | 310 | function TReadOnlyMap.contains(const key: TKey): boolean; 311 | begin 312 | result := find(key) <> nil; 313 | end; 314 | 315 | function TReadOnlyMap.get(const key: TKey; const def: TValue): TValue; 316 | var 317 | pair: PPair; 318 | begin 319 | pair := find(key); 320 | if pair = nil then result := def 321 | else result := pair.value; 322 | end; 323 | 324 | function TReadOnlyMap.getOrDefault(const key: TKey): TValue; 325 | var 326 | pair: PPair; 327 | begin 328 | pair := find(key); 329 | if pair = nil then result := default(TValue) 330 | else result := pair.value; 331 | end; 332 | 333 | function TReadOnlyMap.get(const key: TKey): TValue; 334 | var 335 | pair: PPair; 336 | begin 337 | pair := find(key); 338 | if pair = nil then 339 | raiseKeyError(rsMissingKey, key); 340 | result := pair.value; 341 | end; 342 | 343 | 344 | 345 | procedure TMutableMap.includeItem(const key: TKey; const value: TValue); 346 | begin 347 | forceInclude(key, value, true); 348 | end; 349 | 350 | function TMutableMap.getRef(const key: TKey): PValue; 351 | var 352 | pair: PPair; 353 | begin 354 | pair := THAMTNode.findAndUnique(@froot, PPair(@key)^ ); //this cast should work, because key is the first element of TPair 355 | if pair = nil then 356 | raiseKeyError(rsMissingKey, key); 357 | result := @pair.value; 358 | end; 359 | 360 | function TMutableMap.include(const key: TKey; const value: TValue; allowOverride: boolean): boolean; 361 | begin 362 | result := forceInclude(key, value, allowOverride); 363 | end; 364 | function TMutableMap.exclude(const key: TKey): boolean; 365 | begin 366 | result := forceExclude(key); 367 | end; 368 | procedure TMutableMap.insert(const key: TKey; const value: TValue); 369 | begin 370 | if not forceInclude(key, value, false) then raiseKeyError(rsDuplicateKey, key); 371 | end; 372 | procedure TMutableMap.remove(const key:TKey); 373 | begin 374 | if not forceExclude(key) then raiseKeyError(rsMissingKey, key); 375 | end; 376 | 377 | procedure TMutableMap.clear; 378 | begin 379 | THAMTNode.decrementRefCount(froot); 380 | froot := THAMTNode.allocateEmpty; 381 | fcount := 0; 382 | end; 383 | 384 | 385 | function TMutableMap.clone: TMutableMap; 386 | begin 387 | result := TMutableMap.Create(self); 388 | end; 389 | 390 | 391 | function TImmutableMap.include(const key: TKey; const value: TValue; allowOverride: boolean): TImmutableMap; inline; 392 | begin 393 | result := TImmutableMap.Create(self); 394 | result.forceInclude(key, value, allowOverride) 395 | end; 396 | function TImmutableMap.exclude(const key: TKey): TImmutableMap; inline; 397 | begin 398 | result := TImmutableMap.Create(self); 399 | result.forceExclude(key); 400 | end; 401 | function TImmutableMap.insert(const key: TKey; const value: TValue): TImmutableMap; inline; 402 | begin 403 | result := TImmutableMap.Create(self); 404 | if not result.forceInclude(key, value, false) then begin 405 | result.free; 406 | raiseKeyError(rsDuplicateKey, key); 407 | end; 408 | end; 409 | function TImmutableMap.remove(const key:TKey): TImmutableMap; inline; 410 | begin 411 | result := TImmutableMap.Create(self); 412 | if not result.forceExclude(key) then begin 413 | result.free; 414 | raiseKeyError(rsMissingKey, key); 415 | end; 416 | end; 417 | 418 | 419 | function TImmutableMap.clone: TImmutableMap; 420 | begin 421 | result := TImmutableMap.Create(self); 422 | end; 423 | 424 | 425 | end. 426 | 427 | -------------------------------------------------------------------------------- /tests/hamt_tests.pas: -------------------------------------------------------------------------------- 1 | program hamt_tests; 2 | 3 | {$mode objfpc}{$H+}{$ModeSwitch typehelpers} 4 | 5 | uses 6 | {$IFDEF UNIX} 7 | cthreads, 8 | {$ENDIF} 9 | Classes, hamt.internals, commontestutils, sysutils, bbutils, contnrs, hamt.maps, hamt.sets 10 | { you can add units after this }; 11 | 12 | 13 | type THAMTTestTypeInfo = object(THAMTTypeInfo) 14 | class function hash(const s: string): THAMTHash; 15 | end; 16 | 17 | type TMutableMap_Test = class(specialize TMutableMap<string, string, THAMTTestTypeInfo>) 18 | procedure testInsert(const k, v: string; override: boolean = false); 19 | procedure testGet(const k, v: string); 20 | procedure testRemove(const k: string; notthere: boolean = false); 21 | procedure testEnumeration(expectedCount: integer); 22 | end; 23 | const MISSING = 'MISSING'; 24 | 25 | type TTestThread = class(TThread) 26 | id: string; 27 | map: TMutableMapStringString; 28 | constructor Create(aid: string; amap: TMutableMapStringString); 29 | procedure Execute; override; 30 | end; 31 | 32 | 33 | {$PUSH} 34 | {$RangeChecks OFF} 35 | {$OverflowChecks OFF} 36 | class function THAMTTestTypeInfo.hash(const s: string): THAMTHash; 37 | var 38 | p, last: PByte; 39 | begin 40 | if s = '' then exit(1); 41 | p := pbyte(pointer(s)); 42 | last := p + length(s); 43 | result := 0; 44 | 45 | //testing cases 46 | if p^ = ord('_') then begin 47 | inc(p); 48 | while p < last do begin 49 | result := (result shl BITS_PER_LEVEL) or THAMTHash((p^ - ord('0')) * 10 + (((p+1)^ - ord('0') ))); 50 | inc(p, 3); 51 | end; 52 | exit; 53 | end; 54 | if p^ = ord('$') then exit(StrToInt(s)); 55 | case s of 56 | 'test', 'collision+1', 'collision+2', 'collision+3': exit(hash('collision')); 57 | end; 58 | 59 | //actual hash 60 | while p < last do begin 61 | result := result + p^; 62 | result := result + (result shl 10); 63 | result := result xor (result shr 6); 64 | inc(p); 65 | end; 66 | 67 | 68 | result := result + (result shl 3); 69 | result := result xor (result shr 11); 70 | result := result + (result shl 15); 71 | end; 72 | {$POP} 73 | 74 | 75 | procedure TMutableMap_Test.testInsert(const k, v: string; override: boolean); 76 | var c: integer; 77 | begin 78 | c := count; 79 | test(include(k, v) xor override, 'insert failed (override marker?)'); 80 | test(contains(k), 'insert failed: ' + k); 81 | test(get(k, 'xx'), v); 82 | if not override then inc(c); 83 | test(count, c); 84 | test((c = 0) = isEmpty); 85 | end; 86 | 87 | procedure TMutableMap_Test.testGet(const k, v: string); 88 | begin 89 | test(get(k, MISSING), v, 'get ' + k); 90 | end; 91 | 92 | procedure TMutableMap_Test.testRemove(const k: string; notthere: boolean); 93 | var c: integer; 94 | begin 95 | c := count; 96 | if notthere then 97 | test(exclude(k) <> notthere, 'remove failed: ' + k) 98 | else remove(k); 99 | // test( <> notthere, 'remove failed: ' + k); 100 | test(get(k, MISSING), MISSING); 101 | if not notthere then dec(c); 102 | test(count, c); 103 | end; 104 | 105 | procedure TMutableMap_Test.testEnumeration(expectedCount: integer); 106 | var 107 | pair: TMutableMap_Test.PPair; 108 | visitedKeys: TFPStringHashTable; 109 | acount: integer; 110 | begin 111 | acount := 0; 112 | visitedKeys := TFPStringHashTable.Create; 113 | for pair in self do begin 114 | test(visitedKeys.Find(pair^.key) = nil, 'duplicated key'); 115 | inc(acount); 116 | test(get(pair^.key, MISSING), pair^.value); 117 | visitedKeys.Add(pair^.key, pair^.value); 118 | end; 119 | test(acount, expectedCount); 120 | visitedKeys.Free; 121 | end; 122 | 123 | function testInsert(m: TImmutableMapStringString; const k, v: string; override: boolean = false): TImmutableMapStringString; 124 | var c: integer; 125 | begin 126 | c := m.count; 127 | if override then result := m.include(k, v) 128 | else result := m.insert(k, v); 129 | // test( xor override, 'insert failed (override marker?)'); 130 | test(result.contains(k), 'insert failed: ' + k); 131 | test(result.get(k, 'xx'), v); 132 | test(result[k], v); 133 | test(m.count, c); 134 | if not override then 135 | inc(c); 136 | test(result.count, c); 137 | end; 138 | 139 | procedure testEnumeration(m: TImmutableMapStringString; expectedCount: integer); 140 | var 141 | pair: TMutableMap_Test.PPair; 142 | visitedKeys: TFPStringHashTable; 143 | acount: integer; 144 | begin 145 | acount := 0; 146 | visitedKeys := TFPStringHashTable.Create; 147 | for pair in m do begin 148 | test(visitedKeys.Find(pair^.key) = nil, 'duplicated key'); 149 | inc(acount); 150 | test(m.get(pair^.key, MISSING), pair^.value); 151 | visitedKeys.Add(pair^.key, pair^.value); 152 | end; 153 | test(acount, expectedCount); 154 | visitedKeys.Free; 155 | end; 156 | 157 | constructor TTestThread.Create(aid: string; amap: TMutableMapStringString); 158 | begin 159 | id := aid; 160 | map := amap; 161 | inherited Create(false); 162 | end; 163 | 164 | var runningThreads: integer; 165 | procedure TTestThread.Execute; 166 | var 167 | i: Integer; 168 | begin 169 | for i := 1 to 50000 do 170 | map.insert(id + IntToStr(i), IntToStr(i) + id); 171 | for i := 1 to 50000 do 172 | test(map.get(id + IntToStr(i)), IntToStr(i) + id); 173 | for i := 1 to 50000 do 174 | test(map.get(IntToStr(i)), 'init' + IntToStr(i)); 175 | for i := 1 to 50000 do 176 | map.remove(IntToStr(i)); 177 | for i := 1 to 50000 do 178 | test(map.get(id + IntToStr(i)), IntToStr(i) + id); 179 | for i := 1 to 50000 do 180 | test(map.contains(IntToStr(i)) = false); 181 | 182 | map.free; 183 | InterLockedDecrement(runningThreads); 184 | end; 185 | 186 | procedure setTestsMutable; 187 | var stringSet: TMutableSetString; 188 | p: TMutableSetString.PItem; 189 | begin 190 | stringSet := TMutableSetString.create; 191 | stringSet.Insert('hello'); 192 | stringSet.insert('foo'); 193 | 194 | test(stringSet['hello']); 195 | test(stringSet.contains('foo')); 196 | test(not stringSet.contains('abc')); 197 | 198 | stringSet.include('foo'); 199 | stringSet.include('foobar'); 200 | test(stringSet.contains('foo')); 201 | test(stringSet.contains('foobar')); 202 | 203 | stringSet.remove('foo'); 204 | stringSet.remove('foobar'); 205 | //stringSet.remove('foobar'); 206 | stringSet.exclude('foo'); 207 | stringSet.exclude('foobar'); 208 | stringSet.exclude('foobar'); 209 | 210 | test(not stringSet.contains('foo')); 211 | test(not stringSet.contains('foobar')); 212 | 213 | stringSet['foo'] := true; 214 | test(stringSet.contains('foo')); 215 | stringSet['foo'] := false; 216 | test(not stringSet.contains('foo')); 217 | stringSet['foo'] := true; 218 | test(stringSet.contains('foo')); 219 | 220 | 221 | //enumerate all 222 | for p in stringSet do 223 | test((p^ = 'hello') or (p^ = 'foo')); 224 | 225 | stringSet.free; 226 | end; 227 | 228 | procedure setTestsImmutable; 229 | var set1, set2, set3, set4, set5: TImmutableSetString; 230 | p: TImmutableSetString.PItem; 231 | begin 232 | set1 := TImmutableSetString.create; 233 | set2 := set1.Insert('hello'); 234 | set3 := set2.insert('foo'); 235 | 236 | test(not set1.contains('hello')); 237 | test(not set1['foo']); 238 | 239 | test(set2.contains('hello')); 240 | test(not set2['foo']); 241 | 242 | test(set3.contains('hello')); 243 | test(set3['foo']); 244 | 245 | set4 := set3.remove('hello'); 246 | set5 := set4.exclude('hello'); 247 | 248 | test(not set4.contains('hello')); 249 | test(set4['foo']); 250 | 251 | test(not set5.contains('hello')); 252 | test(set5['foo']); 253 | 254 | //enumerate all 255 | for p in set3 do 256 | test((p^ = 'hello') or (p^ = 'foo')); 257 | 258 | set1.free; 259 | set2.free; 260 | set3.free; 261 | set4.free; 262 | set5.free; 263 | end; 264 | 265 | var 266 | hamt, hamt2: TMutableMap_Test; 267 | imap, imap2, imap3, imap4: TImmutableMapStringString; 268 | mss: TMutableMapStringString; 269 | i: Integer; 270 | threads: array[1..8] of TThread; 271 | begin 272 | hamt := TMutableMap_Test.create; 273 | hamt.testInsert('hello', 'world'); 274 | test(not hamt.contains('xyz')); 275 | hamt.testInsert('foo', 'bar'); 276 | 277 | hamt.testGet('hello', 'world'); 278 | hamt.testGet('foo', 'bar'); 279 | 280 | hamt.testInsert('hello', 'override', true); 281 | 282 | hamt.testGet('foo', 'bar'); 283 | 284 | hamt.testEnumeration(2); 285 | hamt.remove('hello'); 286 | hamt['abc'] := 'def'; 287 | hamt.testGet('abc', 'def'); 288 | hamt.free; 289 | 290 | Assert(THAMTTestTypeInfo.hash('test') = THAMTTestTypeInfo.hash('collision')); 291 | Assert(THAMTTestTypeInfo.hash('_00') = 0); 292 | Assert(THAMTTestTypeInfo.hash('_01_02') = 2 or 32); 293 | Assert(THAMTTestTypeInfo.hash('$123') = $123); 294 | 295 | //test collisions 296 | hamt := TMutableMap_Test.create; 297 | hamt.testInsert('test', 'A'); 298 | hamt.testInsert('collision', 'B'); 299 | hamt.testInsert('collision+1', 'C'); 300 | hamt.testInsert('collision+2', 'D'); 301 | 302 | hamt.testGet('test', 'A'); 303 | hamt.testGet('collision', 'B'); 304 | hamt.testGet('collision+1', 'C'); 305 | hamt.testGet('collision+2', 'D'); 306 | hamt.testEnumeration(4); 307 | hamt.testRemove('test'); 308 | hamt.testRemove('test', true); 309 | hamt.testRemove('test!', true); 310 | hamt.free; 311 | 312 | 313 | 314 | hamt := TMutableMap_Test.create; 315 | hamt.testInsert('_00_01_02', 'x1'); 316 | hamt.testInsert('_00_01_02', 'x2', true); 317 | hamt.testInsert('_00_02_03', 'x3'); 318 | 319 | hamt.testGet('_00_01_02', 'x2'); 320 | hamt.testGet('_00_02_03', 'x3'); 321 | hamt.testEnumeration(2); 322 | hamt.testRemove('_01_02-03', true); 323 | hamt.free; 324 | 325 | hamt := TMutableMap_Test.create; 326 | hamt.testInsert('_00_01_02', 'x1'); 327 | hamt.testInsert('_00_01-02', 'x1b'); 328 | hamt.testInsert('_00_01-03', 'y'); 329 | hamt.testGet('_00_01_02', 'x1'); 330 | hamt.testGet('_00_01-02', 'x1b'); 331 | hamt.testGet('_00_01-03', 'y'); 332 | hamt.testEnumeration(3); 333 | hamt.testRemove('_01_01-02', true); 334 | hamt.testRemove('_01_02-02', true); 335 | hamt.free; 336 | 337 | //test prefix collisions 338 | hamt := TMutableMap_Test.create; 339 | hamt.testInsert('_02_01_00', 'x1'); 340 | hamt.testInsert('_02_01_00', 'x2', true); 341 | hamt.testInsert('_03_02_00', 'x3'); 342 | 343 | hamt.testGet('_02_01_00', 'x2'); 344 | hamt.testGet('_03_02_00', 'x3'); 345 | hamt.testEnumeration(2); 346 | hamt.free; 347 | 348 | hamt := TMutableMap_Test.create; 349 | hamt.testInsert('_02_01_00', 'x1'); 350 | hamt.testInsert('_02x01_00', 'x2'); 351 | hamt.testInsert('_03_02_00', 'x3'); 352 | 353 | hamt.testGet('_02_01_00', 'x1'); 354 | hamt.testGet('_02x01_00', 'x2'); 355 | hamt.testGet('_03_02_00', 'x3'); 356 | hamt.testEnumeration(3); 357 | hamt.free; 358 | 359 | //test some keys 360 | hamt := TMutableMap_Test.create; 361 | hamt.testInsert('$0', '0x0'); 362 | hamt.testInsert('$1', '0x1'); 363 | hamt.testInsert('$2', '0x2'); 364 | hamt.testInsert('$3', '0x3'); 365 | hamt.testInsert('$FFFFFFFF', '0xFFFFFFFF'); 366 | hamt.testInsert('$FFFFFFFE', '0xFFFFFFFE'); 367 | hamt.testInsert('$EFFFFFFF', '0xEFFFFFFF'); 368 | hamt.testInsert('$EFFFFFFE', '0xEFFFFFFE'); 369 | hamt.testInsert('$7FFFFFFE', '0x7FFFFFFE'); 370 | hamt.testInsert('$7FFFFFFF', '0x7FFFFFFF'); 371 | hamt.testInsert('$FFFFFFF0', '0xFFFFFFF0'); 372 | hamt.testInsert('$FFFFFFF1', '0xFFFFFFF1'); 373 | hamt.testInsert('$FFFFFFF2', '0xFFFFFFF2'); 374 | hamt.testInsert('$FFFFFFF3', '0xFFFFFFF3'); 375 | hamt.testInsert('$eFFFFFF0', '0xeFFFFFF0'); 376 | hamt.testInsert('$eFFFFFF1', '0xeFFFFFF1'); 377 | hamt.testInsert('$eFFFFFF2', '0xeFFFFFF2'); 378 | hamt.testInsert('$eFFFFFF3', '0xeFFFFFF3'); 379 | hamt.testInsert('$eFFFFFF7', '0xeFFFFFF7'); 380 | hamt.testInsert('$eFFFFFF8', '0xeFFFFFF8'); 381 | hamt.testEnumeration(20); 382 | hamt.free; 383 | 384 | 385 | //test snapshots 386 | hamt := TMutableMap_Test.create; 387 | hamt.testInsert('hello', 'world'); 388 | hamt.testInsert('foo', 'bar'); 389 | hamt2 := TMutableMap_Test(hamt.clone); 390 | hamt.testInsert('hello', 'override', true); 391 | 392 | hamt.testGet('hello', 'override'); 393 | hamt.testGet('foo', 'bar'); 394 | 395 | hamt2.testGet('hello', 'world'); 396 | hamt2.testGet('foo', 'bar'); 397 | hamt.testEnumeration(2); 398 | hamt2.testEnumeration(2); 399 | hamt.free; 400 | hamt2.Free; 401 | 402 | 403 | hamt := TMutableMap_Test.create; 404 | hamt.testInsert('hello', 'world'); 405 | hamt.testInsert('foo', 'bar'); 406 | hamt2 := TMutableMap_Test(hamt.clone); 407 | hamt.testInsert('new', 'N'); 408 | 409 | hamt.testGet('hello', 'world'); 410 | hamt.testGet('foo', 'bar'); 411 | hamt.testGet('new', 'N'); 412 | 413 | hamt2.testGet('hello', 'world'); 414 | hamt2.testGet('foo', 'bar'); 415 | hamt2.testGet('new', MISSING); 416 | hamt.testEnumeration(3); 417 | hamt2.testEnumeration(2); 418 | hamt.testRemove('new'); 419 | hamt2.testRemove('hello'); 420 | hamt.testEnumeration(2); 421 | hamt2.testEnumeration(1); 422 | hamt.free; 423 | hamt2.free; 424 | 425 | 426 | hamt := TMutableMap_Test.create; 427 | hamt.testInsert('_02_01_00', 'x1'); 428 | hamt.testInsert('_02_01_00', 'x2', true); 429 | hamt2 := TMutableMap_Test(hamt.clone); 430 | hamt.testInsert('_03_02_00', 'x3'); 431 | 432 | hamt.testGet('_02_01_00', 'x2'); 433 | hamt.testGet('_03_02_00', 'x3'); 434 | hamt2.testGet('_02_01_00', 'x2'); 435 | hamt2.testGet('_03_02_00', MISSING); 436 | 437 | hamt.testInsert('_03_03_00', 'x4'); 438 | hamt2.free; 439 | hamt2 := TMutableMap_Test(hamt.clone); 440 | hamt.testInsert('_03_03_00', 'x5', true); 441 | 442 | hamt.testGet('_02_01_00', 'x2'); 443 | hamt.testGet('_03_02_00', 'x3'); 444 | hamt.testGet('_03_03_00', 'x5'); 445 | hamt2.testGet('_02_01_00', 'x2'); 446 | hamt2.testGet('_03_02_00', 'x3'); 447 | hamt2.testGet('_03_03_00', 'x4'); 448 | 449 | hamt.testEnumeration(3); 450 | hamt2.testEnumeration(3); 451 | hamt.free; 452 | hamt2.free; 453 | 454 | 455 | 456 | hamt := TMutableMap_Test.create; 457 | hamt.testInsert('_02_01_00', 'x1'); 458 | hamt.testInsert('_02-01_00', 'x2'); 459 | hamt2 := TMutableMap_Test(hamt.clone); 460 | hamt.testInsert('_03_02_00', 'x3'); 461 | 462 | hamt.testGet('_02_01_00', 'x1'); 463 | hamt.testGet('_02-01_00', 'x2'); 464 | hamt.testGet('_03_02_00', 'x3'); 465 | hamt2.testGet('_02_01_00', 'x1'); 466 | hamt2.testGet('_02-01_00', 'x2'); 467 | hamt2.testGet('_03_02_00', MISSING); 468 | hamt.testEnumeration(3); 469 | hamt2.testEnumeration(2); 470 | hamt.testRemove('_02_01_00'); 471 | hamt.testEnumeration(2); 472 | hamt2.testEnumeration(2); 473 | hamt.testRemove('_02-01_00'); 474 | hamt.testEnumeration(1); 475 | hamt2.testEnumeration(2); 476 | hamt.free; 477 | hamt2.free; 478 | 479 | 480 | 481 | hamt := TMutableMap_Test.create; 482 | hamt.testInsert('_02_01_00', 'x1'); 483 | hamt.testInsert('_02-01_00', 'x2'); 484 | hamt2 := TMutableMap_Test(hamt.clone); 485 | hamt.testInsert('_02x01_00', 'x3'); 486 | 487 | hamt.testGet('_02_01_00', 'x1'); 488 | hamt.testGet('_02-01_00', 'x2'); 489 | hamt.testGet('_02x01_00', 'x3'); 490 | hamt2.testGet('_02_01_00', 'x1'); 491 | hamt2.testGet('_02-01_00', 'x2'); 492 | hamt2.testGet('_02x01_00', MISSING); 493 | hamt.testEnumeration(3); 494 | hamt2.testEnumeration(2); 495 | hamt.remove('_02_01_00'); 496 | hamt.remove('_02-01_00'); 497 | hamt.insert('_31_31_00', 'xy'); 498 | hamt.remove('_02x01_00'); 499 | hamt.remove('_31_31_00'); 500 | hamt.free; 501 | hamt2.free; 502 | 503 | 504 | hamt := TMutableMap_Test.create; 505 | hamt.testInsert('_02_01_00', 'x1'); 506 | hamt.testInsert('_02-01_00', 'x2'); 507 | hamt2 := TMutableMap_Test(hamt.clone); 508 | hamt.testInsert('_02-01_00', 'x3', true); 509 | 510 | hamt.testGet('_02_01_00', 'x1'); 511 | hamt.testGet('_02-01_00', 'x3'); 512 | hamt2.testGet('_02_01_00', 'x1'); 513 | hamt2.testGet('_02-01_00', 'x2'); 514 | hamt.testEnumeration(2); 515 | hamt2.testEnumeration(2); 516 | 517 | hamt.testRemove('_02_01_00'); 518 | hamt.testRemove('_02-01_00'); 519 | hamt2.testRemove('_02-01_00'); 520 | hamt.testEnumeration(0); 521 | hamt2.testEnumeration(1); 522 | 523 | hamt.free; 524 | hamt2.free; 525 | 526 | 527 | //more remove tests 528 | hamt := TMutableMap_Test.create; 529 | hamt.testInsert('_02_00_31', 'x1'); 530 | hamt.testInsert('_03-00_31', 'x2'); 531 | hamt2 := TMutableMap_Test(hamt.clone); 532 | hamt.testRemove('_03_00_31', true); 533 | hamt.testRemove('_03-00_31'); 534 | hamt2.testEnumeration(2); 535 | hamt.testRemove('_02_00_31'); 536 | hamt.testEnumeration(0); 537 | hamt2.testEnumeration(2); 538 | hamt.free; 539 | hamt2.free; 540 | 541 | hamt := TMutableMap_Test.create; 542 | hamt.testInsert('_00_00_00', 'x1'); 543 | hamt.testInsert('_31-31_31', 'x2'); 544 | hamt.testInsert('_30-31_31', 'x3'); 545 | hamt.testEnumeration(3); 546 | hamt.testRemove('_31-31_31'); 547 | hamt.testEnumeration(2); 548 | hamt.testRemove('_30-31_31'); 549 | hamt.testEnumeration(1); 550 | hamt.free; 551 | 552 | hamt := TMutableMap_Test.create; 553 | hamt.testInsert('_31-31_31', 'x1'); 554 | hamt.testInsert('_31x31_31', 'x2'); 555 | hamt.testInsert('_00x00_01', 'x3'); 556 | hamt.testRemove('_31-31_31'); //makes _31x31_31 into an array 557 | hamt2 := TMutableMap_Test(hamt.clone); 558 | hamt.testRemove('_31x31_31'); 559 | hamt.free; 560 | hamt2.free; 561 | 562 | //immutable interface 563 | imap := TImmutableMapStringString.Create; 564 | imap2 := testInsert(imap, 'a', 'x'); 565 | imap3 := testInsert(imap, 'b', 'y'); 566 | testEnumeration(imap2, 1); 567 | testEnumeration(imap3, 1); 568 | imap4 := testInsert(imap3, 'b', 'z', true); 569 | testEnumeration(imap4, 1); 570 | imap4.free; 571 | imap4 := testInsert(imap2, 'c', 'z'); 572 | testEnumeration(imap4, 2); 573 | imap4.free; 574 | imap4 := imap2.remove('a'); 575 | testEnumeration(imap4, 0); 576 | imap4.free; 577 | imap.Free; 578 | imap2.Free; 579 | imap3.Free; 580 | 581 | //mutable pointer 582 | hamt := TMutableMap_Test.create; 583 | hamt.testInsert('a', 'b'); 584 | hamt2 := TMutableMap_Test(hamt.clone); 585 | hamt.mutable['a']^ := 'c'; 586 | hamt.testGet('a', 'c'); 587 | hamt2.testGet('a', 'b'); 588 | hamt.free; 589 | hamt2.free; 590 | 591 | hamt := TMutableMap_Test.create; 592 | hamt.testInsert('_00_00_00', 'x1'); 593 | hamt.testInsert('_00_00_01', 'x2'); 594 | hamt.testInsert('_00_00_02', 'x3'); 595 | hamt2 := TMutableMap_Test(hamt.clone); 596 | hamt.mutable['_00_00_00']^ := 'u'; 597 | hamt.mutable['_00_00_01']^ := 'v'; 598 | hamt.mutable['_00_00_02']^ := 'w'; 599 | hamt.testGet('_00_00_00', 'u'); 600 | hamt.testGet('_00_00_01', 'v'); 601 | hamt.testGet('_00_00_02', 'w'); 602 | hamt2.testGet('_00_00_00', 'x1'); 603 | hamt2.testGet('_00_00_01', 'x2'); 604 | hamt2.testGet('_00_00_02', 'x3'); 605 | hamt.free; 606 | hamt2.free; 607 | 608 | //sets 609 | setTestsMutable; 610 | setTestsImmutable; 611 | 612 | mss := TMutableMapStringString.Create(); 613 | for i := 1 to 50000 do 614 | mss.insert(IntToStr(i), 'init' + IntToStr(i)); 615 | runningThreads := 8; 616 | for i := 1 to 8 do 617 | threads[i] := TTestThread.Create('_'+IntToStr(i)+'_', mss.clone); 618 | mss.free; 619 | 620 | while runningThreads > 0 do sleep(100); 621 | for i := 1 to 8 do threads[i].free; 622 | 623 | writeln('ok'); 624 | end. 625 | 626 | -------------------------------------------------------------------------------- /hamt.internals.pas: -------------------------------------------------------------------------------- 1 | { 2 | Copyright (C) 2018 Benito van der Zander (BeniBela) 3 | benito@benibela.de 4 | www.benibela.de 5 | 6 | This file is distributed under under the same license as Lazarus and the LCL itself: 7 | 8 | This file is distributed under the Library GNU General Public License 9 | with the following modification: 10 | 11 | As a special exception, the copyright holders of this library give you 12 | permission to link this library with independent modules to produce an 13 | executable, regardless of the license terms of these independent modules, 14 | and to copy and distribute the resulting executable under terms of your choice, 15 | provided that you also meet, for each linked independent module, the terms 16 | and conditions of the license of that module. An independent module is a 17 | module which is not derived from or based on this library. If you modify this 18 | library, you may extend this exception to your version of the library, but 19 | you are not obligated to do so. If you do not wish to do so, delete this 20 | exception statement from your version. 21 | 22 | } 23 | {** 24 | @abstract(Low-level HAMT) 25 | 26 | 27 | } 28 | unit hamt.internals; 29 | 30 | {$mode objfpc}{$H+}{$ModeSwitch autoderef}{$ModeSwitch advancedrecords} 31 | 32 | interface 33 | 34 | uses sysutils; 35 | type 36 | ppointer = ^pointer; 37 | 38 | THAMTHash = Cardinal; 39 | THAMTBitmap = record 40 | function countBeforeIndex(index: THAMTHash): DWord; inline; 41 | case boolean of 42 | false: (bits: bitpacked array[0..31] of boolean); 43 | true: (all: THAMTHash); 44 | end; 45 | { 4 cases bitmapIsSinglePointer bitmapIsValue pointer tag 46 | - next hamt node (pointer) true false 0 47 | - list (pointer to multiple keys + values) true false 1 48 | - empty false false - 49 | - one pair (key + value) false true - 50 | } 51 | THAMTTaggedPointer = packed record 52 | raw: pointer; 53 | function unpack(out isArray: boolean): pointer; inline; 54 | procedure setToArray(p: pointer); inline; 55 | end; 56 | const 57 | BITS_PER_LEVEL = 5; 58 | LEVEL_HIGH = ( sizeof(THAMTHash) * 8 ) div BITS_PER_LEVEL; 59 | type 60 | EHAMTException = class(Exception); 61 | generic THAMTItemHelper<T> = record //can't be specialized in the THAMTNode interface https://bugs.freepascal.org/view.php?id=34232 62 | type 63 | TSizeEquivalent = packed array[1..sizeof(T)] of byte; 64 | PSizeEquivalent = ^TSizeEquivalent; 65 | end; 66 | //** @abstract(Low-level HAMT from which further collections are built) 67 | //** Each node has a reference counter and stores up to 32 pointers or items. @br 68 | //** The HAMT node is either mutable (if reference counter is 1) or immutable with copy-on-write (if reference counter is >= 2) like strings. @br 69 | //** Using the nodes directly would be more efficient than using the map classes, since you have one less memory access without the class instance. 70 | generic THAMTNode<TItem, TInfo> = packed object 71 | const 72 | HAMTArrayEnd = -1; 73 | type 74 | PItem = ^TItem; 75 | {Invariants: 76 | - THAMTArray is not empty, count > 0 77 | - All keys in one THAMTArray have the same hash 78 | } 79 | PHAMTArray = ^THAMTArray; 80 | THAMTArrayIndex = integer; 81 | THAMTArray = packed object 82 | refCount: Integer; 83 | count: THAMTArrayIndex; 84 | firstItem: array[0..0] of TItem; 85 | class function size(aCount: THAMTArrayIndex): SizeInt; static; inline; 86 | class function allocate(acount: THAMTArrayIndex): PHAMTArray; static; //not initialized besides counts 87 | class procedure decrementRefCount(a: PHAMTArray); static; 88 | procedure incrementChildrenRefCount; 89 | function indexOf(const item: TItem): THAMTArrayIndex; 90 | function find(const item: TItem): PItem; 91 | function get(i: THAMTArrayIndex): PItem; inline; 92 | property items[i: THAMTArrayIndex]: PItem read get; default; 93 | //todo: this can easily be extended to a multi map, by having multiple pairs with the same key 94 | end; 95 | PHAMTNode = ^THAMTNode; 96 | PPHAMTNode = ^PHAMTNode; 97 | THAMTEnumerator = object 98 | protected 99 | level: integer; 100 | stack: array[0..LEVEL_HIGH] of PHAMTNode; 101 | offsets: array[0..LEVEL_HIGH] of integer; 102 | fcurrent, lastItem: PItem; 103 | function pushNode(node: PHAMTNode): boolean; 104 | public 105 | procedure initialize(node: PHAMTNode); 106 | property current: PItem read fcurrent; 107 | function MoveNext: boolean; 108 | end; 109 | 110 | protected 111 | refCount: Integer; 112 | pointerCount, itemCount: word; 113 | bitmapIsSinglePointer: THAMTBitmap; 114 | bitmapIsValue: THAMTBitmap; 115 | pointers: array[0..63] of THAMTTaggedPointer; 116 | function getPointerOffset(index: THAMTHash): DWord; inline; 117 | //function getPointer(index: THAMTHash): pointer; inline; 118 | function getItemOffset(index: THAMTHash): DWord; inline; 119 | function getItemFromOffset(offset: DWord): PItem; inline; 120 | function getItemAddr(index: THAMTHash): PItem; inline; 121 | function getNodeFromOffset(offset: DWord): PHAMTNode; inline; 122 | class procedure hashShift(var hash: THAMTHash; out index: THAMTHash); static; inline; 123 | class function size(apointerCount, aitemCount: SizeInt): SizeInt; static; inline; 124 | class function allocate(apointerCount, aitemCount: SizeInt): PHAMTNode; static; //memory not initialized besides counts 125 | procedure incrementChildrenRefCount; 126 | public 127 | class procedure decrementRefCount(node: PHAMTNode); static; 128 | class procedure decrementRefCountButKeepChildren(node: PHAMTNode); static; 129 | class function allocateEmpty(): PHAMTNode; static; //memory initialized 130 | public 131 | //trigger copy-on-write so the node becomes mutable 132 | class function uniqueNode(ppnode: PPHAMTNode): PHAMTNode; static; 133 | { 134 | //insert override allowed = true 135 | result = true inserted, no override 136 | result = false inserted, override 137 | //insert override forbidden = false 138 | result = true inserted, (no override) 139 | result = false not inserted 140 | } 141 | class function include(ppnode: PPHAMTNode; const item: TItem; allowOverride: boolean): Boolean; static; 142 | class function exclude(ppnode: PPHAMTNode; const item: TItem): Boolean; static; 143 | function find(const item: TItem): PItem; 144 | class function findAndUnique(ppnode: PPHAMTNode; const item: TItem): PItem; static; 145 | function contains(const item: TItem): boolean; 146 | end; 147 | 148 | 149 | //** @abstract(Default hash function and reference counting for strings/objects) 150 | //** The HAMT requires a hash function (hash) and equality test (equal) to compare keys. @br 151 | //** Memory management requires methods for reference counting (addRef, release) . Reference counting is mandatory as the HAMT might make arbitrary many copies of everything. assignEqual is called to assign one item to an equal, but not identical item. @br 152 | //** You can derive an object of THAMTTypeInfo to change some methods, e.g., the hashing. 153 | THAMTTypeInfo = object 154 | class function hash(const s: string): THAMTHash; static; inline; 155 | class function equal(const s, t: string): boolean; static; inline; 156 | 157 | class procedure addRef(var k: string); inline; static; 158 | class procedure release(var k: string); inline; static; 159 | class function toString(const k: string): string; static; inline; 160 | class procedure assignEqual(var a: string; const b: string); inline; static; 161 | 162 | class procedure addRef(var k: IUnknown); static; inline; 163 | class procedure release(var k: IUnknown); static; inline; 164 | class procedure assignEqual(var a: IUnknown; const b: IUnknown); inline; static; 165 | 166 | //no reference counting for objects 167 | class procedure addRef(var {%H-}k: TObject); static; inline; 168 | class procedure release(var {%H-}k: TObject); static; inline; 169 | class function toString(const k: TObject): string; inline; 170 | class procedure assignEqual(var a: TObject; const b: TObject); inline; static; 171 | 172 | class procedure addRef(var {%H-}k: pointer); static; inline; 173 | class procedure release(var {%H-}k: pointer); static; inline; 174 | class function toString(const k: pointer): string; inline; 175 | class procedure assignEqual(var a: pointer; const b: pointer); inline; static; 176 | end; 177 | 178 | //** @abstract(Generic low-level read-only set) 179 | //** 180 | //** Data in this set can be read, but there are no methods to modify it. 181 | generic TReadOnlyCustomSet<TItem, TInfo> = class 182 | type 183 | THAMTNode = specialize THAMTNode<TItem, TInfo>; 184 | PHAMTNode = ^THAMTNode; 185 | protected 186 | fcount: SizeUInt; 187 | froot: PHAMTNode; 188 | class procedure raiseItemError(const message: string; const item: TItem); 189 | public 190 | //** Returns if the set is empty 191 | function isEmpty: boolean; inline; 192 | //** Enumerates all items in an unspecified order @br 193 | //** Example: @longcode(# 194 | //** var p: TReadOnlyCustomSet.PItem; 195 | //** for p in customSet do 196 | //** .. 197 | //** #) 198 | //** 199 | //**The pointer let's you modify the item, but you must not modify it. 200 | function getEnumerator: THAMTNode.THAMTEnumerator; 201 | destructor Destroy; override; 202 | //** Number of items in the set 203 | property count: SizeUInt read fcount; 204 | end; 205 | 206 | 207 | 208 | 209 | function alignedGetMem(s: PtrUInt): pointer; inline; 210 | 211 | {$ifdef FPC} //hide this from pasdoc, since it cannot parse external 212 | //need this in interface, otherwise THAMTTypeInfo.addRef/release is not inlined 213 | Procedure fpc_AnsiStr_Incr_Ref (S : Pointer); [external name 'FPC_ANSISTR_INCR_REF']; 214 | Procedure fpc_ansistr_decr_ref (Var S : Pointer); [external name 'FPC_ANSISTR_DECR_REF']; 215 | {$endif} 216 | 217 | resourcestring 218 | rsMissingItem = 'Missing item: %s'; 219 | rsDuplicateItem = 'Duplicate item: %s'; 220 | rsMissingKey = 'Missing key: %s'; 221 | rsDuplicateKey = 'Duplicate key: %s'; 222 | 223 | implementation 224 | 225 | 226 | 227 | function THAMTNode.THAMTEnumerator.pushNode(node: PHAMTNode): boolean; 228 | begin 229 | inc(level); 230 | stack[level] := node; 231 | offsets[level] := -1; 232 | result := node.itemCount > 0; 233 | if result then begin 234 | fcurrent := node.getItemFromOffset(0); 235 | lastItem := current + node.itemCount - 1; 236 | end; 237 | end; 238 | 239 | procedure THAMTNode.THAMTEnumerator.initialize(node: PHAMTNode); 240 | begin 241 | level:=-1; 242 | if pushNode(node) then dec(fcurrent) 243 | else begin 244 | fcurrent := nil; 245 | lastItem := nil; 246 | end; 247 | end; 248 | 249 | function THAMTNode.THAMTEnumerator.MoveNext: boolean; 250 | var 251 | node: PHAMTNode; 252 | p: Pointer; 253 | isArray: boolean; 254 | begin 255 | result := current < lastItem; 256 | if result then begin 257 | inc(fcurrent); 258 | exit; 259 | end; 260 | 261 | while level >= 0 do begin 262 | node := stack[level]; 263 | inc(offsets[level]); 264 | if offsets[level] < node.pointerCount then begin 265 | p := node.pointers[offsets[level]].unpack(isArray); 266 | if isArray then begin 267 | fcurrent := @PHAMTArray(p).firstItem[0]; 268 | lastItem := fcurrent + PHAMTArray(p).count - 1; 269 | assert(fcurrent <= lastItem); 270 | exit(true); 271 | end; 272 | result := pushNode(PHAMTNode(p)); 273 | if result then exit; 274 | end else dec(level); 275 | end; 276 | 277 | result := false; 278 | end; 279 | 280 | 281 | class function THAMTTypeInfo.hash(const s: string): THAMTHash; 282 | begin 283 | result := objpas.hash(s); 284 | end; 285 | 286 | class function THAMTTypeInfo.equal(const s,t:string): boolean; 287 | begin 288 | result := s = t; 289 | end; 290 | 291 | 292 | class procedure THAMTTypeInfo.addRef(var k: string); 293 | begin 294 | fpc_ansistr_incr_ref(pointer(k)); 295 | end; 296 | 297 | class procedure THAMTTypeInfo.release(var k: string); 298 | begin 299 | fpc_ansistr_decr_ref(pointer(k)); 300 | end; 301 | 302 | 303 | class function THAMTTypeInfo.toString(const k: string): string; 304 | begin 305 | result := k 306 | end; 307 | 308 | class procedure THAMTTypeInfo.assignEqual(var a: string; const b: string); 309 | begin 310 | a := b; 311 | end; 312 | 313 | class procedure THAMTTypeInfo.addRef(var k: IUnknown); 314 | begin 315 | k._AddRef; 316 | end; 317 | 318 | class procedure THAMTTypeInfo.release(var k: IUnknown); 319 | begin 320 | k._Release; 321 | end; 322 | 323 | class procedure THAMTTypeInfo.assignEqual(var a: IUnknown; const b: IUnknown); 324 | begin 325 | a := b; 326 | end; 327 | 328 | class procedure THAMTTypeInfo.addRef(var k: TObject); 329 | begin 330 | //empty 331 | end; 332 | 333 | class procedure THAMTTypeInfo.release(var k: TObject); 334 | begin 335 | //empty 336 | end; 337 | 338 | 339 | class function THAMTTypeInfo.toString(const k: TObject): string; 340 | begin 341 | result := k.ToString; 342 | end; 343 | 344 | class procedure THAMTTypeInfo.assignEqual(var a: TObject; const b: TObject); 345 | begin 346 | a := b; 347 | end; 348 | 349 | class procedure THAMTTypeInfo.addRef(var k: pointer); 350 | begin 351 | //empty 352 | end; 353 | 354 | class procedure THAMTTypeInfo.release(var k: pointer); 355 | begin 356 | //empty 357 | end; 358 | 359 | class function THAMTTypeInfo.toString(const k: pointer): string; 360 | begin 361 | result := IntToHex(PtrUInt(k), sizeof(k)*2); 362 | end; 363 | 364 | class procedure THAMTTypeInfo.assignEqual(var a: pointer; const b: pointer); 365 | begin 366 | a := b 367 | end; 368 | 369 | class procedure THAMTNode.hashShift(var hash: THAMTHash; out index: THAMTHash); inline; 370 | begin 371 | index := hash and %11111; 372 | hash := hash shr BITS_PER_LEVEL; 373 | end; 374 | 375 | function THAMTBitmap.countBeforeIndex(index: THAMTHash): DWord; inline; 376 | var 377 | mask: THAMTHash; 378 | begin 379 | mask := THAMTHash((THAMTHash(1) shl index) - 1); 380 | result := PopCnt(all and mask); 381 | end; 382 | 383 | 384 | 385 | class function THAMTNode.THAMTArray.size(aCount: THAMTArrayIndex): SizeInt; 386 | begin 387 | result := sizeof(integer) + sizeof(THAMTArrayIndex) + sizeof(TItem) * acount 388 | end; 389 | 390 | class function THAMTNode.THAMTArray.allocate(acount: THAMTArrayIndex): PHAMTArray; 391 | begin 392 | result := alignedGetMem(size(acount)) ; 393 | result.refCount := 1; 394 | result.count := acount; 395 | end; 396 | 397 | class procedure THAMTNode.THAMTArray.decrementRefCount(a: PHAMTArray); 398 | var 399 | p, e: PItem; 400 | begin 401 | with a^ do begin 402 | if InterLockedDecrement(refCount) = 0 then begin 403 | p := @firstItem[0]; //use p[i] rather than pairs[i], because pairs[i] is not inlined 404 | e := p + count; 405 | while p < e do begin 406 | TInfo.release(p^); 407 | inc(p); 408 | end; 409 | Freemem(a); 410 | end; 411 | end; 412 | end; 413 | 414 | procedure THAMTNode.THAMTArray.incrementChildrenRefCount; 415 | var 416 | p, e: PItem; 417 | begin 418 | p := @firstItem[0]; 419 | e := p + count; 420 | while p < e do begin 421 | TInfo.addRef(p^); 422 | inc(p); 423 | end; 424 | end; 425 | 426 | function THAMTNode.THAMTArray.indexOf(const item: TItem): THAMTArrayIndex; 427 | var 428 | p: PItem; 429 | i: THAMTArrayIndex; 430 | begin 431 | p := @firstItem[0]; 432 | i := 0; 433 | while i < count do begin 434 | if TInfo.equal(p[i], item) then 435 | exit(i); 436 | inc(i); 437 | end; 438 | result := HAMTArrayEnd; 439 | end; 440 | 441 | function THAMTNode.THAMTArray.find(const item: TItem): PItem; 442 | var 443 | p, e: PItem; 444 | begin 445 | p := @firstItem[0]; 446 | e := p + count; 447 | while p < e do begin 448 | if TInfo.equal(p^, item) then 449 | exit(p); 450 | inc(p); 451 | end; 452 | result := nil; 453 | end; 454 | 455 | function THAMTNode.THAMTArray.get(i: THAMTArrayIndex): PItem; 456 | begin 457 | result := @firstItem[0]; 458 | inc(result, i); 459 | end; 460 | 461 | {$push} 462 | {$WARN 4055 off : Conversion between ordinals and pointers is not portable} 463 | function alignedGetMem(s: PtrUInt): pointer; inline; 464 | begin 465 | result := GetMem(s); 466 | while PtrUInt(result) and 1 = 1 do begin 467 | Freemem(result); 468 | result := GetMem(s); 469 | end; 470 | end; 471 | 472 | 473 | 474 | function THAMTTaggedPointer.unpack(out isArray: boolean): pointer; inline; 475 | var 476 | tag: PtrUInt; 477 | begin 478 | tag := PtrUInt(raw) and 1; 479 | isArray := tag <> 0; 480 | result := pointer(PtrUInt(raw) and not tag); 481 | end; 482 | 483 | procedure THAMTTaggedPointer.setToArray(p: pointer); 484 | begin 485 | raw := pointer(PtrUInt(p) or 1); 486 | end; 487 | {$pop} 488 | 489 | 490 | function THAMTNode.getPointerOffset(index: THAMTHash): DWord; 491 | begin 492 | result := bitmapIsSinglePointer.countBeforeIndex(index); 493 | end; 494 | 495 | function THAMTNode.getItemOffset(index: THAMTHash): DWord; 496 | begin 497 | result := bitmapIsValue.countBeforeIndex(index); 498 | end; 499 | 500 | function THAMTNode.getItemFromOffset(offset: DWord): PItem; 501 | begin 502 | result := PItem(@pointers[pointerCount]) + offset; 503 | end; 504 | 505 | function THAMTNode.getItemAddr(index: THAMTHash): PItem; 506 | begin 507 | result := getItemFromOffset(getItemOffset(index)); 508 | end; 509 | 510 | function THAMTNode.getNodeFromOffset(offset: DWord): PHAMTNode; 511 | begin 512 | result := PHAMTNode(pointers[offset].raw); 513 | end; 514 | 515 | 516 | procedure THAMTNode.incrementChildrenRefCount; 517 | var 518 | isArray: boolean; 519 | pointerRaw: Pointer; 520 | pairs: PItem; 521 | i: SizeInt; 522 | begin 523 | for i := 0 to SizeInt(pointerCount) - 1 do begin 524 | pointerRaw := pointers[i].unpack(isArray); 525 | if isArray then InterLockedIncrement(PHAMTArray(pointerRaw).refCount) 526 | else InterLockedIncrement(PHAMTNode(pointerRaw).refCount) 527 | end; 528 | pairs := PItem(@pointers[pointerCount]); 529 | for i := 0 to itemCount - 1 do 530 | TInfo.addRef(pairs[i]); 531 | end; 532 | 533 | 534 | class procedure THAMTNode.decrementRefCount(node: PHAMTNode); 535 | var 536 | isArray: boolean; 537 | pointerRaw: Pointer; 538 | pairs: PItem; 539 | i: SizeInt; 540 | begin 541 | with node^ do begin 542 | if InterLockedDecrement(refCount) = 0 then begin 543 | for i := 0 to pointerCount - 1 do begin 544 | pointerRaw := pointers[i].unpack(isArray); 545 | if isArray then THAMTArray.decrementRefCount(PHAMTArray(pointerRaw)) 546 | else decrementRefCount(PHAMTNode(pointerRaw)) 547 | end; 548 | pairs := PItem(@pointers[pointerCount]); 549 | for i := 0 to itemCount - 1 do 550 | TInfo.release(pairs[i]); 551 | Freemem(node); 552 | end; 553 | end; 554 | end; 555 | 556 | class procedure THAMTNode.decrementRefCountButKeepChildren(node: PHAMTNode); 557 | begin 558 | if node.refCount <= 1 then Freemem(node) 559 | else begin 560 | node.incrementChildrenRefCount; 561 | decrementRefCount(node); 562 | end; 563 | end; 564 | 565 | class function THAMTNode.size(apointerCount, aitemCount: SizeInt): SizeInt; 566 | begin 567 | size := SizeOf(THAMTNode.refCount) + SizeOf(THAMTNode.pointerCount) + SizeOf(THAMTNode.itemCount) + SizeOf(THAMTNode.bitmapIsSinglePointer) + SizeOf(THAMTNode.bitmapIsValue) 568 | + SizeOf(Pointer) * apointerCount 569 | + SizeOf(TItem) * aitemCount; 570 | end; 571 | 572 | class function THAMTNode.allocate(apointerCount, aitemCount: SizeInt): PHAMTNode; 573 | var 574 | s: SizeInt; 575 | begin 576 | s := size(apointerCount, aitemCount); 577 | result := alignedGetMem(s); 578 | result^.refCount := 1; 579 | result^.pointerCount := apointerCount; 580 | result^.itemCount := aitemCount; 581 | end; 582 | 583 | class function THAMTNode.allocateEmpty(): PHAMTNode; 584 | const 585 | s: SizeUInt = SizeOf(THAMTNode.refCount) + SizeOf(THAMTNode.pointerCount) + SizeOf(THAMTNode.itemCount) + SizeOf(THAMTNode.bitmapIsSinglePointer) + SizeOf(THAMTNode.bitmapIsValue); 586 | begin 587 | result := alignedGetMem(s); 588 | result^.refCount := 1; 589 | result^.pointerCount := 0; 590 | result^.itemCount := 0; 591 | result^.bitmapIsSinglePointer.all := 0; 592 | result^.bitmapIsValue.all := 0; 593 | end; 594 | 595 | class function THAMTNode.uniqueNode(ppnode: PPHAMTNode): PHAMTNode; 596 | var 597 | s: SizeInt; 598 | begin 599 | result := ppnode^; 600 | if result.refCount > 1 then begin 601 | { [ refcount = 2 ] => [ refcount = 1 ] [ refcount = 1 ] 602 | [ refcount = 1 ] [ refcount = 1 ] [ refcount = 2 ] [ refcount = 2 ] 603 | } 604 | result.incrementChildrenRefCount; 605 | 606 | s := size(result.pointerCount, result.itemCount); 607 | ppnode^ := alignedGetMem(s); //new node 608 | move(result^, ppnode^^, s); 609 | decrementRefCount(result); //result is still the old node 610 | ppnode^^.refCount := 1; 611 | result := ppnode^; 612 | end; 613 | end; 614 | 615 | 616 | class function THAMTNode.include(ppnode: PPHAMTNode; const item: TItem; allowOverride: boolean): Boolean; 617 | var itemHelper: specialize THAMTItemHelper<TItem>; 618 | 619 | var itemIndex: THAMTArrayIndex; 620 | function cloneArrayAppend(hamtArrayx: pointer; append: boolean): pointer; 621 | var HAMTArray: PHAMTArray; 622 | oldItem: PItem; 623 | begin 624 | HAMTArray := PHAMTArray(hamtArrayx); 625 | if append then begin 626 | result := THAMTArray.allocate(hamtArray.count + 1); 627 | oldItem := PHAMTArray(result)^[hamtArray.count]; 628 | itemHelper.PSizeEquivalent(oldItem)^ := itemHelper.PSizeEquivalent(@item)^; 629 | TInfo.addRef(oldItem^); 630 | end else begin 631 | result := THAMTArray.allocate(hamtArray.count); 632 | end; 633 | move(hamtArray^[0]^, PHAMTArray(result)^[0]^, hamtArray.count * sizeof(TItem)); 634 | if hamtArray.refCount > 1 then begin 635 | hamtArray.incrementChildrenRefCount(); 636 | THAMTArray.decrementRefCount(hamtArray); 637 | end else 638 | Freemem(hamtArray); 639 | end; 640 | 641 | var 642 | i: SizeInt; 643 | h, index, h2: THAMTHash; 644 | offset: DWord; 645 | procedure moveItemsDown(itemsIsArray: boolean; items: pointer); 646 | var node : PHAMTNode; 647 | dataOffset: SizeInt; 648 | oldItem: PItem; 649 | index2: THAMTHash; 650 | begin 651 | ppnode := @ppnode^.pointers[offset].raw; 652 | while i <= LEVEL_HIGH do begin 653 | hashShift(h, index); 654 | hashShift(h2, index2); 655 | if index = index2 then begin 656 | //go to next level 657 | node := THAMTNode.allocate(1, 0); 658 | node.bitmapIsSinglePointer.all := THAMTHash(1) shl index; 659 | node.bitmapIsValue.all := 0; 660 | ppnode^ := node; 661 | ppnode := @node.pointers[0].raw; 662 | end else begin 663 | //create node of old items and new item 664 | if itemsIsArray then begin 665 | node := THAMTNode.allocate(1, 1); 666 | node.bitmapIsSinglePointer.all := THAMTHash(1) shl index2; 667 | node.bitmapIsValue.all := THAMTHash(1) shl index; 668 | node.pointers[0].setToArray(items); 669 | dataOffset := 0; 670 | end else begin 671 | node := THAMTNode.allocate(0, 2); 672 | node.bitmapIsSinglePointer.all := 0; 673 | node.bitmapIsValue.all := (THAMTHash(1) shl index) or (THAMTHash(1) shl index2); 674 | if index < index2 then dataOffset := 0 else dataOffset := 1; 675 | oldItem := node.getItemFromOffset(1 - dataOffset); 676 | itemHelper.PSizeEquivalent(oldItem)^ := itemHelper.PSizeEquivalent(items)^; 677 | end; 678 | oldItem := node.getItemFromOffset(dataOffset); 679 | itemHelper.PSizeEquivalent(oldItem)^ := itemHelper.TSizeEquivalent(item); 680 | TInfo.addRef(oldItem^); 681 | ppnode^ := node; 682 | exit; 683 | end; 684 | end; 685 | assert(false); 686 | end; 687 | 688 | var 689 | node: PHAMTNode; 690 | itemOffset: DWord; 691 | oldItem: PItem; 692 | pointerIsArray: boolean; 693 | rawPointer: Pointer; 694 | hamtArray: PHAMTArray; 695 | begin 696 | result := true; 697 | node := ppnode^; 698 | h := TInfo.hash(item); 699 | for i := 0 to LEVEL_HIGH do begin 700 | hashShift(h, index); 701 | 702 | if node.bitmapIsSinglePointer.bits[index] then begin 703 | node := UniqueNode(ppnode); 704 | offset := node.getPointerOffset(index); 705 | rawPointer := node.pointers[offset].unpack(pointerIsArray); 706 | if pointerIsArray then begin 707 | hamtArray := PHAMTArray(rawPointer); 708 | h2 := TInfo.hash(hamtArray^[0]^) shr (BITS_PER_LEVEL * i + BITS_PER_LEVEL); 709 | if h <> h2 then begin 710 | //child at index is an array where the keys have a different hash 711 | //=> move array to a lower level on which the array hash and new key hash end up at a different index 712 | moveitemsDown(true, hamtArray); 713 | end else begin 714 | //array and new key have same hash => insert into array 715 | {Cases: 716 | key already in array refCount = 1 => override value 717 | key already in array refCount > 1 => clone array, override value in new array 718 | key not in array refCount = 1 => resize array: move values from old to new array (do not change ref counts) 719 | key not in array refCount > 1 => create larger array, copy values from old to new 720 | 721 | } 722 | itemIndex := hamtArray.indexOf(item); 723 | if (itemIndex <> HAMTArrayEnd) then begin 724 | result := false; 725 | if not allowOverride then exit; 726 | end; 727 | if (itemIndex = HAMTArrayEnd) or (hamtArray.refCount > 1) then begin 728 | hamtArray := cloneArrayAppend(hamtArray, itemIndex = HAMTArrayEnd); 729 | node.pointers[offset].setToArray(hamtArray); 730 | end; 731 | if itemIndex <> HAMTArrayEnd then 732 | TInfo.assignEqual(hamtArray^[itemIndex]^, item); 733 | end; 734 | exit; 735 | end else begin 736 | //go to next level 737 | ppnode := @ppnode^.pointers[offset].raw; 738 | node := ppnode^; 739 | end; 740 | end else if node.bitmapIsValue.bits[index] then begin 741 | itemOffset := node.getItemOffset(index); 742 | oldItem := node.getItemFromOffset(itemOffset); 743 | if not tinfo.equal(oldItem^, item) then begin 744 | //change item to array pointer 745 | offset := node.getPointerOffset(index); 746 | ppnode^ := allocate(node.pointerCount + 1, node.itemCount - 1); 747 | // [ ..head.. ..pointerPrefix.. ..pointerSuffix.. ..itemPrefix.. old item ..itemSuffix.. ] 748 | // -> [ ..head.. ..pointerPrefix.. ..newPointer ..pointerSuffix.. ..itemPrefix.. ..itemSuffix.. ] 749 | move(node.bitmapIsSinglePointer, ppnode^.bitmapIsSinglePointer, sizeof(THAMTBitmap) + sizeof(THAMTBitmap) + sizeof(Pointer) * offset); //head, pointer prefix 750 | move(node.pointers[offset], ppnode^.pointers[offset + 1], sizeof(pointer) * SizeUInt(node.pointerCount - offset) + sizeof(Titem) * itemOffset); //..pointerSuffix.. ..itemPrefix.. 751 | move(node.getItemFromOffset(itemOffset + 1)^ , ppnode^.getItemFromOffset(itemOffset)^, (node.itemCount - itemOffset - 1) * sizeof(Titem) ); //..itemSuffix.. 752 | ppnode^.bitmapIsSinglePointer.bits[index] := true; 753 | ppnode^.bitmapIsValue.bits[index] := False; 754 | result := true; 755 | if i < LEVEL_HIGH then begin 756 | h2 := TInfo.hash(oldItem^) shr (BITS_PER_LEVEL * i + BITS_PER_LEVEL); 757 | if h <> h2 then begin 758 | moveitemsDown(false, oldItem); 759 | result := false; 760 | end; 761 | end; 762 | if result then begin 763 | hamtArray := THAMTArray.allocate(2); 764 | itemHelper.PSizeEquivalent(hamtArray^[0])^ := itemHelper.PSizeEquivalent(oldItem)^; 765 | itemHelper.PSizeEquivalent(hamtArray^[1])^ := itemHelper.TSizeEquivalent(item); 766 | TInfo.addRef(hamtArray^[1]^); 767 | ppnode^.pointers[offset].setToArray(hamtArray); 768 | end else result := true; 769 | decrementRefCountButKeepChildren(node); 770 | end else begin 771 | result := false; 772 | if not allowOverride then exit; 773 | node := UniqueNode(ppnode); 774 | TInfo.assignEqual(node.getItemFromOffset(itemOffset)^, item); 775 | end; 776 | exit; 777 | end else begin 778 | //copy node and add key+value item 779 | offset := node.getItemOffset(index); 780 | ppnode^ := allocate(node.pointerCount, node.itemCount + 1); 781 | oldItem := ppnode^.getItemFromOffset(offset); 782 | itemHelper.PSizeEquivalent(oldItem)^ := itemHelper.TSizeEquivalent(item); 783 | TInfo.addRef(oldItem^); 784 | move(node.bitmapIsSinglePointer, ppnode^.bitmapIsSinglePointer, 2*sizeof(THAMTBitmap) + sizeof(Pointer) * SizeUInt(node.pointerCount) + sizeof(Titem) * offset); 785 | move( node.getItemFromOffset(offset)^ , (oldItem + 1)^ , (node.itemCount - offset) * sizeof(Titem) ); 786 | decrementRefCountButKeepChildren(node); 787 | ppnode^.bitmapIsValue.bits[index] := true; 788 | exit; 789 | end; 790 | end; 791 | end; 792 | 793 | class function THAMTNode.exclude(ppnode: PPHAMTNode; const item: TItem): Boolean; 794 | var 795 | initialPPNode: PPHAMTNode; 796 | indices: array[0..LEVEL_HIGH] of THAMTHash; 797 | offsets: array[0..LEVEL_HIGH] of SizeInt; //offsets[i] := ... getPointerOffset(indices[i]) 798 | nodes: array[0..LEVEL_HIGH] of PHAMTNode; //nodes[0] := ppnode^; nodes[i] := nodes[i-1].pointers[offsets[i-1]].raw 799 | 800 | //make sure nodes[0]..nodes[tillLevel] have ref count 0 801 | function uniqueAncestorNodes(tillLevel: SizeInt): pointer; 802 | var 803 | i, offset: SizeInt; 804 | begin 805 | result := uniqueNode(initialPPNode); 806 | for i := 0 to tillLevel - 1 do begin 807 | offset := offsets[i]; 808 | PHAMTNode(result).pointers[offset].raw := uniqueNode(@PHAMTNode(result).pointers[offset].raw); 809 | result := PHAMTNode(result).pointers[offset].raw; 810 | end; 811 | end; 812 | //delete nodes[level].pointers[offset[level]] and all ancestors that only have one pointer to their child 813 | procedure deletePointerFromNode(level: integer); 814 | var 815 | deleteOffset: Integer; 816 | node, newNode, parentNode: PHAMTNode; 817 | isArray: boolean; 818 | p: Pointer; 819 | begin 820 | while (level >= 0) and (nodes[level].itemCount = 0) and (nodes[level].pointerCount <= 1) do 821 | dec(level ); 822 | 823 | if level < 0 then begin 824 | THAMTNode.decrementRefCount(initialPPNode^); 825 | initialPPNode^ := THAMTNode.allocateEmpty; 826 | exit; 827 | end; 828 | 829 | if level > 0 then begin 830 | parentNode := uniqueAncestorNodes(level - 1); 831 | node := parentNode.getNodeFromOffset(offsets[level - 1]); 832 | end else begin 833 | parentNode := nil; 834 | node := initialPPNode^; 835 | end; 836 | newNode := allocate(node.pointerCount - 1, node.itemCount); 837 | deleteOffset := offsets[level]; 838 | // [ ..head.. ..pointerPrefix pointer pointerSuffix.. ..items.. ] 839 | // -> [ ..head.. ..pointerPrefix pointerSuffix.... ] 840 | move(node.bitmapIsSinglePointer, newNode.bitmapIsSinglePointer, 2*sizeof(THAMTBitmap) + sizeof(Pointer) * deleteOffset); 841 | move(node.pointers[deleteOffset + 1] , newNode.pointers[deleteOffset], (node.pointerCount - deleteOffset - 1) * sizeof(pointer) + node.itemCount * sizeof(Titem) ); 842 | newNode.bitmapIsSinglePointer.bits[indices[level]] := False; 843 | p := node.pointers[deleteOffset].unpack(isArray); 844 | decrementRefCountButKeepChildren(node); 845 | if not isArray then THAMTNode.decrementRefCount(p) //need to decrement RC again in case decrementRefCountButKeepChildren incremented it 846 | else THAMTArray.decrementRefCount(p); 847 | if level > 0 then 848 | parentNode.pointers[offsets[level - 1]].raw := newNode 849 | else 850 | initialPPNode^ := newNode; 851 | end; 852 | 853 | var 854 | hamtArray, newHamtArray: PHAMTArray; 855 | itemIndex: THAMTArrayIndex; 856 | i: Integer; 857 | node: PHAMTNode; 858 | h, index: THAMTHash; 859 | offset, itemOffset: DWord; 860 | rawPointer: Pointer; 861 | pointerIsArray: boolean; 862 | oldItem: PItem; 863 | begin 864 | result := true; 865 | initialPPNode := ppnode; 866 | node := ppnode^; 867 | h := TInfo.hash(item); 868 | //writeln('remove: ', key, ' ', h); 869 | for i := 0 to LEVEL_HIGH do begin 870 | hashShift(h, index); 871 | 872 | if node.bitmapIsSinglePointer.bits[index] then begin 873 | offset := node.getPointerOffset(index); 874 | rawPointer := node.pointers[offset].unpack(pointerIsArray); 875 | nodes[i] := node; 876 | offsets[i] := offset; 877 | indices[i] := index; 878 | if pointerIsArray then begin 879 | //remove from array 880 | hamtArray := PHAMTArray(rawPointer); 881 | itemIndex := hamtArray.indexOf(item); 882 | if itemIndex = HAMTArrayEnd then 883 | exit(false); 884 | if hamtArray.count = 1 then begin 885 | deletePointerFromNode(i); 886 | exit; 887 | end; 888 | //todo: optimize special case hamtArray.count = 2 by converting array to in-node value 889 | node := uniqueAncestorNodes(i); 890 | newHamtArray := THAMTArray.allocate(hamtArray.count - 1); 891 | move(hamtArray^[0]^, newHamtArray^[0]^, sizeof(Titem) * itemIndex ); 892 | move(hamtArray^[itemIndex + 1]^, newHamtArray^[itemIndex]^, sizeof(Titem) * ( hamtArray.count - itemIndex - 1 ) ); 893 | if hamtArray.refCount > 1 then begin 894 | newHamtArray.incrementChildrenRefCount; 895 | THAMTArray.decrementRefCount(hamtArray); 896 | end else begin 897 | TInfo.release(hamtArray^[itemIndex]^); 898 | Freemem(hamtArray); 899 | end; 900 | node.pointers[offset].setToArray(newHamtArray); 901 | exit; 902 | end else begin 903 | //go to next level 904 | ppnode := @ppnode^.pointers[offset].raw; 905 | node := ppnode^; 906 | end; 907 | end else if node.bitmapIsValue.bits[index] then begin 908 | itemOffset := node.getItemOffset(index); 909 | oldItem := node.getItemFromOffset(itemOffset); 910 | if not TInfo.equal(oldItem^, item) then begin 911 | //nothing to remove 912 | result := false; 913 | end else begin 914 | if (node.pointerCount = 0) and (node.itemCount = 1) then begin 915 | deletePointerFromNode(i - 1); 916 | exit; 917 | end; 918 | if i > 0 then 919 | ppnode := @PHAMTNode(uniqueAncestorNodes(i - 1)).pointers[offset].raw; 920 | //remove item 921 | // 922 | ppnode^ := allocate(node.pointerCount, node.itemCount - 1); 923 | // [ ..head.. ..pointers.. ..itemPrefix.. old item ..itemSuffix.. ] 924 | // -> [ ..head.. ..pointers.... ..itemPrefix.. ..itemSuffix.. ] 925 | move(node.bitmapIsSinglePointer, ppnode^.bitmapIsSinglePointer, 2*sizeof(THAMTBitmap) + sizeof(Pointer) * SizeUInt(node.pointerCount) + sizeof(Titem) * itemOffset); 926 | move(node.getItemFromOffset(itemOffset + 1)^ , ppnode^.getItemFromOffset(itemOffset)^, (node.itemCount - itemOffset - 1) * sizeof(Titem) ); //..itemSuffix.. 927 | if node.refCount > 1 then begin 928 | ppnode^.incrementChildrenRefCount; 929 | THAMTNode.decrementRefCount(node); 930 | end else begin 931 | TInfo.release(node^.getItemFromOffset(itemOffset)^); 932 | Freemem(node); 933 | end; 934 | ppnode^.bitmapIsValue.bits[index] := False; 935 | end; 936 | exit; 937 | end else begin 938 | //nothing to remove 939 | exit(false); 940 | end; 941 | end; 942 | end; 943 | 944 | function THAMTNode.find(const item: TItem): PItem; 945 | var 946 | node: PHAMTNode; 947 | i: Integer; 948 | h, index: THAMTHash; 949 | rawPointer: Pointer; 950 | pointerIsArray: boolean; 951 | offset: THAMTHash; 952 | begin 953 | node := @self; 954 | h := TInfo.hash(item); 955 | for i := 0 to LEVEL_HIGH do begin 956 | hashShift(h, index); 957 | if node.bitmapIsSinglePointer.bits[index] then begin 958 | offset := node.getPointerOffset(index); 959 | rawPointer := node.pointers[offset].unpack(pointerIsArray); 960 | if pointerIsArray then 961 | exit(PHAMTArray(rawPointer).find(item)) 962 | else 963 | node := PHAMTNode(rawPointer) 964 | end else if node.bitmapIsValue.bits[index] then begin 965 | result := node.getItemAddr(index); 966 | if not TInfo.equal(result^, item) then result := nil; 967 | exit; 968 | end else 969 | exit(nil); 970 | end; 971 | result := nil; 972 | end; 973 | 974 | class function THAMTNode.findAndUnique(ppnode: PPHAMTNode; const item: TItem): PItem; static; 975 | var 976 | node: PHAMTNode; 977 | i: Integer; 978 | h, index: THAMTHash; 979 | rawPointer: Pointer; 980 | pointerIsArray: boolean; 981 | offset: THAMTHash; 982 | begin 983 | node := uniqueNode(ppnode); 984 | h := TInfo.hash(item); 985 | for i := 0 to LEVEL_HIGH do begin 986 | hashShift(h, index); 987 | if node.bitmapIsSinglePointer.bits[index] then begin 988 | offset := node.getPointerOffset(index); 989 | rawPointer := node.pointers[offset].unpack(pointerIsArray); 990 | if pointerIsArray then 991 | exit(PHAMTArray(rawPointer).find(item)) 992 | else 993 | node := uniqueNode( PPHAMTNode(@node.pointers[offset].raw) ); 994 | end else if node.bitmapIsValue.bits[index] then begin 995 | result := node.getItemAddr(index); 996 | if not TInfo.equal(result^, item) then result := nil; 997 | exit; 998 | end else 999 | exit(nil); 1000 | end; 1001 | result := nil; 1002 | end; 1003 | 1004 | function THAMTNode.contains(const item: TItem): boolean; 1005 | begin 1006 | result := find(item) <> nil; 1007 | end; 1008 | 1009 | 1010 | 1011 | 1012 | class procedure TReadOnlyCustomSet.raiseItemError(const message: string; const item: TItem); 1013 | var s: string; 1014 | begin 1015 | s := TInfo.toString(item); 1016 | raise EHAMTException.Create(Format(message, [s]) ); 1017 | end; 1018 | 1019 | function TReadOnlyCustomSet.isEmpty: boolean; 1020 | begin 1021 | result := count = 0; 1022 | end; 1023 | 1024 | function TReadOnlyCustomSet.getEnumerator: THAMTNode.THAMTEnumerator; 1025 | begin 1026 | result.initialize(froot); 1027 | end; 1028 | 1029 | destructor TReadOnlyCustomSet.Destroy; 1030 | begin 1031 | THAMTNode.decrementRefCount(froot); 1032 | inherited; 1033 | end; 1034 | 1035 | 1036 | 1037 | 1038 | 1039 | end. 1040 | 1041 | 1042 | --------------------------------------------------------------------------------