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   TPoolMarkRelease = record
  67   private
  68     mMemory: Pointer;
  69     mSize: Integer;
  70     mUsed: Integer;
  71
  72   public
  73     constructor Create (aInitSize: Integer);
  74
  75     // free all allocated memory
  76     procedure kill ();
  77
  78     // forget everything
  79     procedure reset ();
  80
  81     // mark current position
  82     function mark (): PoolMark; inline;
  83     // forget everything from the given mark
  84     procedure release (amark: PoolMark); inline;
  85
  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;
  89
  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;
  95
  96
  97 type
  98   generic PoolIter<T> = record
  99   public
 100     type Ptr = ^T;
 101     type MyType = specialize PoolIter<T>;
 102
 103   private
 104     mMark: PoolMark;
 105     mCount: Integer;
 106     mCurrent: Integer;
 107     mFinished: Boolean;
 108
 109   public
 110     constructor Create (dummy: Boolean); // idiotic FPC doesn't support arg-less ctors for rectord
 111     procedure startIt (); inline; // automatically called by ctor; does NO checks!
 112     procedure finishIt (); inline; // sets count
 113
 114     procedure rewind (); inline;
 115     function length (): Integer; inline;
 116     procedure release (); inline; // reset pool
 117
 118     function moveNext (): Boolean; inline;
 119     function getCurrent (): Ptr; inline;
 120     function getEnumerator (): MyType; inline;
 121
 122     function first (): Ptr; inline;
 123
 124   public
 125     property current: Ptr read getCurrent;
 126   end;
 127
 128
 129 var
 130   framePool: TPoolMarkRelease; // temporary per-frame allocation pool
 131
 132
 133 implementation
 134
 135 uses
 136   SysUtils
 137 {$IFDEF USE_MEMPOOL}
 138   , hashtable
 139 {$ENDIF}
 140   ;
 141
 142
 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;
 158
 159
 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;
 168
 169
 170 // forget everything
 171 procedure TPoolMarkRelease.reset ();
 172 begin
 173   mUsed := 0;
 174 end;
 175
 176
 177 // mark current position
 178 function TPoolMarkRelease.mark (): PoolMark; inline;
 179 begin
 180   result := mUsed;
 181 end;
 182
 183
 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;
 190
 191
 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;
 218
 219
 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;
 227
 228
 229 function TPoolMarkRelease.curPtr (): Pointer; inline;
 230 begin
 231   result := Pointer(PAnsiChar(mMemory)+mUsed);
 232 end;
 233
 234
 235
 236 // ////////////////////////////////////////////////////////////////////////// //
 237 constructor PoolIter.Create (dummy: Boolean);
 238 begin
 239   startIt();
 240 end;
 241
 242
 243 procedure PoolIter.startIt (); inline; // automatically called by ctor; does NO checks!
 244 begin
 245   mMark := framePool.mark();
 246   mCount := 0;
 247   mCurrent := -1;
 248   mFinished := false;
 249 end;
 250
 251
 252 procedure PoolIter.finishIt (); inline; // sets count
 253 begin
 254   if (mFinished) then raise Exception.Create('double fatality');
 255   if (mMark = -1) then raise Exception.Create('void fatality');
 256   mFinished := true;
 257   mCount := Integer(PtrUInt(framePool.curPtr)-PtrUInt(framePool.getPtr(mMark))) div Integer(sizeof(T));
 258   if (mCount < 0) then raise Exception.Create('wutafu?');
 259 end;
 260
 261
 262 procedure PoolIter.rewind (); inline;
 263 begin
 264   if (mMark = -1) then raise Exception.Create('void rewind');
 265   mCurrent := -1;
 266 end;
 267
 268
 269 function PoolIter.length (): Integer; inline;
 270 begin
 271   //if (mCurrent+1 >= 0) and (mCurrent+1 < mCount) then result := mCount-(mCurrent+1) else result := 0;
 272   result := mCount;
 273 end;
 274
 275
 276 procedure PoolIter.release (); inline; // reset pool
 277 begin
 278   if (mMark = -1) then raise Exception.Create('double release');
 279   framePool.release(mMark);
 280   mMark := -1;
 281   mCount := 0;
 282   mCurrent := -1;
 283   mFinished := false;
 284 end;
 285
 286
 287 function PoolIter.moveNext (): Boolean; inline;
 288 begin
 289   if (mMark = -1) then raise Exception.Create('void moveNext()');
 290   if (not mFinished) then raise Exception.Create('moveNext() on unfinished');
 291   Inc(mCurrent);
 292   result := (mCurrent < mCount);
 293 end;
 294
 295
 296 function PoolIter.getCurrent (): Ptr; inline;
 297 begin
 298   if (mCurrent < 0) or (mCurrent >= mCount) then raise Exception.Create('getCurrent() range error');
 299   result := Ptr(framePool.getPtr(mMark+mCurrent*Integer(sizeof(T))));
 300 end;
 301
 302
 303 function PoolIter.getEnumerator (): PoolIter; inline;
 304 begin
 305   result := self;
 306 end;
 307
 308
 309 function PoolIter.first (): Ptr; inline;
 310 begin
 311   if (mMark = -1) then raise Exception.Create('void moveNext()');
 312   if (not mFinished) then raise Exception.Create('moveNext() on unfinished');
 313   result := Ptr(framePool.getPtr(mMark));
 314 end;
 315
 316
 317 // ////////////////////////////////////////////////////////////////////////// //
 318 {$IFDEF USE_MEMPOOL}
 319 uses
 320   hashtable;
 321
 322 type
 323   THashKeyPtr = class
 324   public
 325     class function hash (const k: Pointer): LongWord; inline;
 326     class function equ (const a, b: Pointer): Boolean; inline;
 327     class procedure freekey (k: Pointer); inline;
 328   end;
 329
 330   THashPtrPtr = specialize THashBase<Pointer, PMemPool, THashKeyPtr>; // key: TClass; value: PMemPool
 331
 332 var
 333   pools: THashPtrPtr = nil;
 334
 335
 336 // ////////////////////////////////////////////////////////////////////////// //
 337 class function THashKeyPtr.hash (const k: Pointer): LongWord; inline; begin result := fnvHash(PByte(@k)^, sizeof(k)); end;
 338 class function THashKeyPtr.equ (const a, b: Pointer): Boolean; inline; begin result := (a = b); end;
 339 class procedure THashKeyPtr.freekey (k: Pointer); inline; begin end;
 340
 341
 342 function getPoolFor (c: TClass): PMemPool;
 343 begin
 344   if (pools = nil) then pools := THashPtrPtr.Create();
 345   if not pools.get(Pointer(c), result) then
 346   begin
 347     GetMem(result, sizeof(TMemPool));
 348     result.Create(c.ClassName, c.InstanceSize);
 349     pools.put(Pointer(c), result);
 350   end;
 351 end;
 352
 353
 354 // ////////////////////////////////////////////////////////////////////////// //
 355 constructor TMemPool.Create (const aname: AnsiString; aobjsize: Integer);
 356 begin
 357   if (aobjsize < 1) then aobjsize := 16; // arbitrary number
 358   mName := aname;
 359   mObjSize := aobjsize;
 360   mFirstPage := nil;
 361   mLastPage := nil;
 362   mAllocTotal := 0;
 363   mAllocCount := 0;
 364 end;
 365
 366
 367 procedure TMemPool.setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
 368 begin
 369 end;
 370
 371
 372 procedure TMemPool.release (); // release all pool memory
 373 begin
 374 end;
 375
 376
 377 function TMemPool.alloc (len: Integer): Pointer; // throws on OOM
 378 begin
 379   if (len > 0) then mAllocTotal += len;
 380   if (len < 1) then len := 1;
 381   GetMem(result, len);
 382   FillChar(PByte(result)^, len, 0);
 383   Inc(mAllocCount);
 384 end;
 385
 386
 387 procedure TMemPool.free (ptr: Pointer); // currently it is noop
 388 begin
 389   FreeMem(ptr);
 390 end;
 391
 392
 393 // ////////////////////////////////////////////////////////////////////////// //
 394 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 395 class function TPoolObject.NewInstance (): TObject;
 396 var
 397   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 398   pool: PMemPool;
 399   {$ENDIF}
 400   ptr: Pointer;
 401 begin
 402   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 403   pool := getPoolFor(self.ClassType);
 404   ptr := pool.alloc(self.InstanceSize);
 405   {$ELSE}
 406   GetMem(ptr, self.InstanceSize);
 407   FillChar(PByte(ptr)^, self.InstanceSize, 0); // hello, Wyoming Knott!
 408   {$ENDIF}
 409   result := TObject(ptr);
 410   self.InitInstance(ptr);
 411 end;
 412
 413
 414 procedure TPoolObject.FreeInstance ();
 415 var
 416   pool: PMemPool;
 417 begin
 418   pool := getPoolFor(self.ClassType);
 419   pool.free(Pointer(self));
 420 end;
 421 {$ENDIF}
 422
 423
 424 // ////////////////////////////////////////////////////////////////////////// //
 425 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 426 procedure dumpPools ();
 427 var
 428   fo: TextFile;
 429   kv: THashPtrPtr.PEntry;
 430 begin
 431   AssignFile(fo, 'zmemlog.txt');
 432   Rewrite(fo);
 433   for kv in pools.byKeyValue do
 434   begin
 435     writeln(fo, kv.value.name, ': count=', kv.value.allocCount, '; total=', kv.value.allocTotal);
 436   end;
 437   CloseFile(fo);
 438 end;
 439 {$ENDIF}
 440
 441
 442 initialization
 443   //mpoolMap := TMemPool.Create('textmap', 64);
 444   framePool := TPoolMarkRelease.Create(65536);
 445 finalization
 446   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 447   dumpPools();
 448   {$ENDIF}
 449 {$ENDIF} // USE_MEMPOOL
 450 end.