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;
  18
  19 interface
  20
  21 {$IFDEF USE_MEMPOOL}
  22 uses
  23   SysUtils;
  24
  25
  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;
  36
  37   public
  38     constructor Create (const aname: AnsiString; aobjsize: Integer);
  39
  40     procedure setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
  41     procedure release (); // release all pool memory
  42
  43     function alloc (len: Integer): Pointer; // throws on OOM
  44     procedure free (ptr: Pointer); // currently it is noop
  45
  46   public
  47     property name: ShortString read mName;
  48     property allocCount: Integer read mAllocCount;
  49     property allocTotal: Integer read mAllocTotal;
  50   end;
  51
  52
  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}
  60
  61 (* Simple "mark/release" allocator *)
  62 type
  63   PoolMark = Integer;
  64
  65   PPoolMarkRelease = ^TPoolMarkRelease;
  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     mPool: PPoolMarkRelease;
 105     mMark: PoolMark;
 106     mCount: Integer;
 107     mCurrent: Integer;
 108     mFinished: Boolean;
 109
 110   public
 111     constructor Create (var apool: TPoolMarkRelease); // idiotic FPC doesn't support arg-less ctors for rectord
 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 (var apool: TPoolMarkRelease);
 238 begin
 239   mPool := @apool;
 240   mMark := mPool^.mark();
 241   mCount := 0;
 242   mCurrent := -1;
 243   mFinished := false;
 244 end;
 245
 246
 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;
 255
 256
 257 procedure PoolIter.rewind (); inline;
 258 begin
 259   if (mPool = nil) then raise Exception.Create('void rewind');
 260   mCurrent := -1;
 261 end;
 262
 263
 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;
 269
 270
 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;
 280
 281
 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;
 289
 290
 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;
 297
 298
 299 function PoolIter.getEnumerator (): PoolIter; inline;
 300 begin
 301   result := self;
 302 end;
 303
 304
 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;
 311
 312
 313 // ////////////////////////////////////////////////////////////////////////// //
 314 {$IFDEF USE_MEMPOOL}
 315 uses
 316   hashtable;
 317
 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;
 325
 326   THashPtrPtr = specialize THashBase<Pointer, PMemPool, THashKeyPtr>; // key: TClass; value: PMemPool
 327
 328 var
 329   pools: THashPtrPtr = nil;
 330
 331
 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;
 336
 337
 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;
 348
 349
 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;
 361
 362
 363 procedure TMemPool.setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
 364 begin
 365 end;
 366
 367
 368 procedure TMemPool.release (); // release all pool memory
 369 begin
 370 end;
 371
 372
 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;
 381
 382
 383 procedure TMemPool.free (ptr: Pointer); // currently it is noop
 384 begin
 385   FreeMem(ptr);
 386 end;
 387
 388
 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;
 408
 409
 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}
 418
 419
 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}
 436
 437
 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.