DEADSOFTWARE

was this even necessary?
[d2df-sdl.git] / src / shared / mempool.pas
1 (* Copyright (C) Doom 2D: Forever Developers
2 *
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, version 3 of the License ONLY.
6 *
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * GNU General Public License for more details.
11 *
12 * You should have received a copy of the GNU General Public License
13 * along with this program. If not, see <http://www.gnu.org/licenses/>.
14 *)
15 {$INCLUDE a_modes.inc}
16 {$DEFINE MEM_DISABLE_ACCOUNTING}
17 unit mempool;
19 interface
21 {$IFDEF USE_MEMPOOL}
22 uses
23 SysUtils;
26 type
27 PMemPool = ^TMemPool;
28 TMemPool = record
29 private
30 mName: ShortString;
31 mObjSize: Integer; // not a limit, just a recommendation
32 mFirstPage: Pointer;
33 mLastPage: Pointer;
34 mAllocTotal: Integer;
35 mAllocCount: Integer;
37 public
38 constructor Create (const aname: AnsiString; aobjsize: Integer);
40 procedure setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
41 procedure release (); // release all pool memory
43 function alloc (len: Integer): Pointer; // throws on OOM
44 procedure free (ptr: Pointer); // currently it is noop
46 public
47 property name: ShortString read mName;
48 property allocCount: Integer read mAllocCount;
49 property allocTotal: Integer read mAllocTotal;
50 end;
53 TPoolObject = class
54 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
55 public class function NewInstance (): TObject; override;
56 public procedure FreeInstance (); override;
57 {$ENDIF}
58 end;
59 {$ENDIF}
61 (* Simple "mark/release" allocator *)
62 type
63 PoolMark = Integer;
65 PPoolMarkRelease = ^TPoolMarkRelease;
66 TPoolMarkRelease = record
67 private
68 mMemory: Pointer;
69 mSize: Integer;
70 mUsed: Integer;
72 public
73 constructor Create (aInitSize: Integer);
75 // free all allocated memory
76 procedure kill ();
78 // forget everything
79 procedure reset ();
81 // mark current position
82 function mark (): PoolMark; inline;
83 // forget everything from the given mark
84 procedure release (amark: PoolMark); inline;
86 // allocate some memory
87 // WARNING! pool can realloc it's internal storage and invalidate all previous pointers!
88 function alloc (size: Integer): Pointer; inline;
90 // get pointer for the given mark
91 // WARNING! pointer can become invalid after next call to `alloc()`!
92 function getPtr (amark: PoolMark): Pointer; inline;
93 function curPtr (): Pointer; inline;
94 end;
97 type
98 generic PoolIter<T> = record
99 public
100 type Ptr = ^T;
101 type MyType = specialize PoolIter<T>;
103 private
104 mPool: PPoolMarkRelease;
105 mMark: PoolMark;
106 mCount: Integer;
107 mCurrent: Integer;
108 mFinished: Boolean;
110 public
111 constructor Create (var apool: TPoolMarkRelease); // idiotic FPC doesn't support arg-less ctors for rectord
112 procedure finishIt (); inline; // sets count
114 procedure rewind (); inline;
115 function length (): Integer; inline;
116 procedure release (); inline; // reset pool
118 function moveNext (): Boolean; inline;
119 function getCurrent (): Ptr; inline;
120 function getEnumerator (): MyType; inline;
122 function first (): Ptr; inline;
124 public
125 property current: Ptr read getCurrent;
126 end;
129 var
130 framePool: TPoolMarkRelease; // temporary per-frame allocation pool
133 implementation
135 uses
136 SysUtils
137 {$IFDEF USE_MEMPOOL}
138 , hashtable
139 {$ENDIF}
143 // ////////////////////////////////////////////////////////////////////////// //
144 constructor TPoolMarkRelease.Create (aInitSize: Integer);
145 begin
146 if (aInitSize > 0) then
147 begin
148 mSize := aInitSize;
149 GetMem(mMemory, mSize);
150 end
151 else
152 begin
153 mMemory := nil;
154 mSize := 0;
155 end;
156 mUsed := 0;
157 end;
160 // free all allocated memory
161 procedure TPoolMarkRelease.kill ();
162 begin
163 if (mMemory <> nil) then FreeMem(mMemory);
164 mMemory := nil;
165 mSize := 0;
166 mUsed := 0;
167 end;
170 // forget everything
171 procedure TPoolMarkRelease.reset ();
172 begin
173 mUsed := 0;
174 end;
177 // mark current position
178 function TPoolMarkRelease.mark (): PoolMark; inline;
179 begin
180 result := mUsed;
181 end;
184 // forget everything from the given mark
185 procedure TPoolMarkRelease.release (amark: PoolMark); inline;
186 begin
187 if (amark < 0) or (amark > mUsed) then raise Exception.Create('MarkReleasePool is fucked (release)');
188 mUsed := amark;
189 end;
192 // allocate some memory
193 // WARNING! pool can realloc it's internal storage and invalidate all previous pointers!
194 function TPoolMarkRelease.alloc (size: Integer): Pointer; inline;
195 begin
196 if (size < 0) then raise Exception.Create('MarkReleasePool: cannot allocate negative amount of bytes');
197 if (size > 1024*1024) then raise Exception.Create('MarkReleasePool: why do you need to allocate more than 1MB?');
198 // do we need to get more memory?
199 if (mUsed+size > mSize) then
200 begin
201 if (mUsed+size > 1024*1024*64) then raise Exception.Create('MarkReleasePool: more than 64MB in MarkReleasePool is insanity!');
202 while (mUsed+size > mSize) do
203 begin
204 // less than 256KB: 64KB steps
205 if (mSize < 256*1024) then mSize += 64*1024
206 // less than 1MB: 128KB steps
207 else if (mSize < 1024*1024) then mSize += 128*1024
208 // otherwise, 1MB steps
209 else mSize += 1024*1024;
210 end;
211 ReallocMem(mMemory, mSize);
212 if (mMemory = nil) then raise Exception.Create('MarkReleasePool: out of memory!');
213 end;
214 result := Pointer(PAnsiChar(mMemory)+mUsed);
215 mUsed += size;
216 assert(mUsed <= mSize);
217 end;
220 // get pointer for the given mark
221 // WARNING! pointer can become invalid after next call to `alloc()`!
222 function TPoolMarkRelease.getPtr (amark: PoolMark): Pointer; inline;
223 begin
224 if (amark < 0) or (amark > mUsed) then raise Exception.Create('MarkReleasePool is fucked (getPtr)');
225 result := Pointer(PAnsiChar(mMemory)+amark);
226 end;
229 function TPoolMarkRelease.curPtr (): Pointer; inline;
230 begin
231 result := Pointer(PAnsiChar(mMemory)+mUsed);
232 end;
236 // ////////////////////////////////////////////////////////////////////////// //
237 constructor PoolIter.Create (var apool: TPoolMarkRelease);
238 begin
239 mPool := @apool;
240 mMark := mPool^.mark();
241 mCount := 0;
242 mCurrent := -1;
243 mFinished := false;
244 end;
247 procedure PoolIter.finishIt (); inline; // sets count
248 begin
249 if (mFinished) then raise Exception.Create('double fatality');
250 if (mPool = nil) then raise Exception.Create('void fatality');
251 mFinished := true;
252 mCount := Integer(PtrUInt(mPool^.curPtr)-PtrUInt(mPool^.getPtr(mMark))) div Integer(sizeof(T));
253 if (mCount < 0) then raise Exception.Create('wutafu?');
254 end;
257 procedure PoolIter.rewind (); inline;
258 begin
259 if (mPool = nil) then raise Exception.Create('void rewind');
260 mCurrent := -1;
261 end;
264 function PoolIter.length (): Integer; inline;
265 begin
266 //if (mCurrent+1 >= 0) and (mCurrent+1 < mCount) then result := mCount-(mCurrent+1) else result := 0;
267 result := mCount;
268 end;
271 procedure PoolIter.release (); inline; // reset pool
272 begin
273 if (mPool = nil) then raise Exception.Create('double release');
274 mPool^.release(mMark);
275 mPool := nil;
276 mCount := 0;
277 mCurrent := -1;
278 mFinished := false;
279 end;
282 function PoolIter.moveNext (): Boolean; inline;
283 begin
284 if (mPool = nil) then raise Exception.Create('void moveNext()');
285 if (not mFinished) then raise Exception.Create('moveNext() on unfinished');
286 Inc(mCurrent);
287 result := (mCurrent < mCount);
288 end;
291 function PoolIter.getCurrent (): Ptr; inline;
292 begin
293 if (mPool = nil) then raise Exception.Create('getCurrent() on nothing');
294 if (mCurrent < 0) or (mCurrent >= mCount) then raise Exception.Create('getCurrent() range error');
295 result := Ptr(mPool^.getPtr(mMark+mCurrent*Integer(sizeof(T))));
296 end;
299 function PoolIter.getEnumerator (): PoolIter; inline;
300 begin
301 result := self;
302 end;
305 function PoolIter.first (): Ptr; inline;
306 begin
307 if (mPool = nil) then raise Exception.Create('void moveNext()');
308 if (not mFinished) then raise Exception.Create('moveNext() on unfinished');
309 result := Ptr(mPool^.getPtr(mMark));
310 end;
313 // ////////////////////////////////////////////////////////////////////////// //
314 {$IFDEF USE_MEMPOOL}
315 uses
316 hashtable;
318 type
319 THashKeyPtr = class
320 public
321 class function hash (const k: Pointer): LongWord; inline;
322 class function equ (const a, b: Pointer): Boolean; inline;
323 class procedure freekey (k: Pointer); inline;
324 end;
326 THashPtrPtr = specialize THashBase<Pointer, PMemPool, THashKeyPtr>; // key: TClass; value: PMemPool
328 var
329 pools: THashPtrPtr = nil;
332 // ////////////////////////////////////////////////////////////////////////// //
333 class function THashKeyPtr.hash (const k: Pointer): LongWord; inline; begin result := fnvHash(PByte(@k)^, sizeof(k)); end;
334 class function THashKeyPtr.equ (const a, b: Pointer): Boolean; inline; begin result := (a = b); end;
335 class procedure THashKeyPtr.freekey (k: Pointer); inline; begin end;
338 function getPoolFor (c: TClass): PMemPool;
339 begin
340 if (pools = nil) then pools := THashPtrPtr.Create();
341 if not pools.get(Pointer(c), result) then
342 begin
343 GetMem(result, sizeof(TMemPool));
344 result.Create(c.ClassName, c.InstanceSize);
345 pools.put(Pointer(c), result);
346 end;
347 end;
350 // ////////////////////////////////////////////////////////////////////////// //
351 constructor TMemPool.Create (const aname: AnsiString; aobjsize: Integer);
352 begin
353 if (aobjsize < 1) then aobjsize := 16; // arbitrary number
354 mName := aname;
355 mObjSize := aobjsize;
356 mFirstPage := nil;
357 mLastPage := nil;
358 mAllocTotal := 0;
359 mAllocCount := 0;
360 end;
363 procedure TMemPool.setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
364 begin
365 end;
368 procedure TMemPool.release (); // release all pool memory
369 begin
370 end;
373 function TMemPool.alloc (len: Integer): Pointer; // throws on OOM
374 begin
375 if (len > 0) then mAllocTotal += len;
376 if (len < 1) then len := 1;
377 GetMem(result, len);
378 FillChar(PByte(result)^, len, 0);
379 Inc(mAllocCount);
380 end;
383 procedure TMemPool.free (ptr: Pointer); // currently it is noop
384 begin
385 FreeMem(ptr);
386 end;
389 // ////////////////////////////////////////////////////////////////////////// //
390 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
391 class function TPoolObject.NewInstance (): TObject;
392 var
393 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
394 pool: PMemPool;
395 {$ENDIF}
396 ptr: Pointer;
397 begin
398 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
399 pool := getPoolFor(self.ClassType);
400 ptr := pool.alloc(self.InstanceSize);
401 {$ELSE}
402 GetMem(ptr, self.InstanceSize);
403 FillChar(PByte(ptr)^, self.InstanceSize, 0); // hello, Wyoming Knott!
404 {$ENDIF}
405 result := TObject(ptr);
406 self.InitInstance(ptr);
407 end;
410 procedure TPoolObject.FreeInstance ();
411 var
412 pool: PMemPool;
413 begin
414 pool := getPoolFor(self.ClassType);
415 pool.free(Pointer(self));
416 end;
417 {$ENDIF}
420 // ////////////////////////////////////////////////////////////////////////// //
421 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
422 procedure dumpPools ();
423 var
424 fo: TextFile;
425 kv: THashPtrPtr.PEntry;
426 begin
427 AssignFile(fo, 'zmemlog.txt');
428 Rewrite(fo);
429 for kv in pools.byKeyValue do
430 begin
431 writeln(fo, kv.value.name, ': count=', kv.value.allocCount, '; total=', kv.value.allocTotal);
432 end;
433 CloseFile(fo);
434 end;
435 {$ENDIF}
438 initialization
439 //mpoolMap := TMemPool.Create('textmap', 64);
440 framePool := TPoolMarkRelease.Create(65536);
441 finalization
442 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
443 dumpPools();
444 {$ENDIF}
445 {$ENDIF} // USE_MEMPOOL
446 end.