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