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   end;
  94
  95
  96 var
  97   framePool: TPoolMarkRelease; // temporary per-frame allocation pool
  98
  99
 100 implementation
 101
 102 uses
 103   SysUtils
 104 {$IFDEF USE_MEMPOOL}
 105   , hashtable
 106 {$ENDIF}
 107   ;
 108
 109
 110 // ////////////////////////////////////////////////////////////////////////// //
 111 constructor TPoolMarkRelease.Create (aInitSize: Integer);
 112 begin
 113   if (aInitSize > 0) then
 114   begin
 115     mSize := aInitSize;
 116     GetMem(mMemory, mSize);
 117   end
 118   else
 119   begin
 120     mMemory := nil;
 121     mSize := 0;
 122   end;
 123   mUsed := 0;
 124 end;
 125
 126
 127 // free all allocated memory
 128 procedure TPoolMarkRelease.kill ();
 129 begin
 130   if (mMemory <> nil) then FreeMem(mMemory);
 131   mMemory := nil;
 132   mSize := 0;
 133   mUsed := 0;
 134 end;
 135
 136
 137 // forget everything
 138 procedure TPoolMarkRelease.reset ();
 139 begin
 140   mUsed := 0;
 141 end;
 142
 143
 144 // mark current position
 145 function TPoolMarkRelease.mark (): PoolMark; inline;
 146 begin
 147   result := mUsed;
 148 end;
 149
 150
 151 // forget everything from the given mark
 152 procedure TPoolMarkRelease.release (amark: PoolMark); inline;
 153 begin
 154   if (amark < 0) or (amark > mUsed) then raise Exception.Create('MarkReleasePool is fucked (release)');
 155   mUsed := amark;
 156 end;
 157
 158
 159 // allocate some memory
 160 // WARNING! pool can realloc it's internal storage and invalidate all previous pointers!
 161 function TPoolMarkRelease.alloc (size: Integer): Pointer; inline;
 162 begin
 163   if (size < 0) then raise Exception.Create('MarkReleasePool: cannot allocate negative amount of bytes');
 164   if (size > 1024*1024) then raise Exception.Create('MarkReleasePool: why do you need to allocate more than 1MB?');
 165   // do we need to get more memory?
 166   if (mUsed+size > mSize) then
 167   begin
 168     if (mUsed+size > 1024*1024*64) then raise Exception.Create('MarkReleasePool: more than 64MB in MarkReleasePool is insanity!');
 169     while (mUsed+size > mSize) do
 170     begin
 171       // less than 256KB: 64KB steps
 172       if (mSize < 256*1024) then mSize += 64*1024
 173       // less than 1MB: 128KB steps
 174       else if (mSize < 1024*1024) then mSize += 128*1024
 175       // otherwise, 1MB steps
 176       else mSize += 1024*1024;
 177     end;
 178     ReallocMem(mMemory, mSize);
 179     if (mMemory = nil) then raise Exception.Create('MarkReleasePool: out of memory!');
 180   end;
 181   result := Pointer(PAnsiChar(mMemory)+mUsed);
 182   mUsed += size;
 183   assert(mUsed <= mSize);
 184 end;
 185
 186
 187 // get pointer for the given mark
 188 // WARNING! pointer can become invalid after next call to `alloc()`!
 189 function TPoolMarkRelease.getPtr (amark: PoolMark): Pointer; inline;
 190 begin
 191   if (amark < 0) or (amark > mUsed) then raise Exception.Create('MarkReleasePool is fucked (getPtr)');
 192   result := Pointer(PAnsiChar(mMemory)+amark);
 193 end;
 194
 195
 196 // ////////////////////////////////////////////////////////////////////////// //
 197 {$IFDEF USE_MEMPOOL}
 198 uses
 199   hashtable;
 200
 201 type
 202   THashKeyPtr = class
 203   public
 204     class function hash (const k: Pointer): LongWord; inline;
 205     class function equ (const a, b: Pointer): Boolean; inline;
 206     class procedure freekey (k: Pointer); inline;
 207   end;
 208
 209   THashPtrPtr = specialize THashBase<Pointer, PMemPool, THashKeyPtr>; // key: TClass; value: PMemPool
 210
 211 var
 212   pools: THashPtrPtr = nil;
 213
 214
 215 // ////////////////////////////////////////////////////////////////////////// //
 216 class function THashKeyPtr.hash (const k: Pointer): LongWord; inline; begin result := fnvHash(PByte(@k)^, sizeof(k)); end;
 217 class function THashKeyPtr.equ (const a, b: Pointer): Boolean; inline; begin result := (a = b); end;
 218 class procedure THashKeyPtr.freekey (k: Pointer); inline; begin end;
 219
 220
 221 function getPoolFor (c: TClass): PMemPool;
 222 begin
 223   if (pools = nil) then pools := THashPtrPtr.Create();
 224   if not pools.get(Pointer(c), result) then
 225   begin
 226     GetMem(result, sizeof(TMemPool));
 227     result.Create(c.ClassName, c.InstanceSize);
 228     pools.put(Pointer(c), result);
 229   end;
 230 end;
 231
 232
 233 // ////////////////////////////////////////////////////////////////////////// //
 234 constructor TMemPool.Create (const aname: AnsiString; aobjsize: Integer);
 235 begin
 236   if (aobjsize < 1) then aobjsize := 16; // arbitrary number
 237   mName := aname;
 238   mObjSize := aobjsize;
 239   mFirstPage := nil;
 240   mLastPage := nil;
 241   mAllocTotal := 0;
 242   mAllocCount := 0;
 243 end;
 244
 245
 246 procedure TMemPool.setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
 247 begin
 248 end;
 249
 250
 251 procedure TMemPool.release (); // release all pool memory
 252 begin
 253 end;
 254
 255
 256 function TMemPool.alloc (len: Integer): Pointer; // throws on OOM
 257 begin
 258   if (len > 0) then mAllocTotal += len;
 259   if (len < 1) then len := 1;
 260   GetMem(result, len);
 261   FillChar(PByte(result)^, len, 0);
 262   Inc(mAllocCount);
 263 end;
 264
 265
 266 procedure TMemPool.free (ptr: Pointer); // currently it is noop
 267 begin
 268   FreeMem(ptr);
 269 end;
 270
 271
 272 // ////////////////////////////////////////////////////////////////////////// //
 273 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 274 class function TPoolObject.NewInstance (): TObject;
 275 var
 276   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 277   pool: PMemPool;
 278   {$ENDIF}
 279   ptr: Pointer;
 280 begin
 281   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 282   pool := getPoolFor(self.ClassType);
 283   ptr := pool.alloc(self.InstanceSize);
 284   {$ELSE}
 285   GetMem(ptr, self.InstanceSize);
 286   FillChar(PByte(ptr)^, self.InstanceSize, 0); // hello, Wyoming Knott!
 287   {$ENDIF}
 288   result := TObject(ptr);
 289   self.InitInstance(ptr);
 290 end;
 291
 292
 293 procedure TPoolObject.FreeInstance ();
 294 var
 295   pool: PMemPool;
 296 begin
 297   pool := getPoolFor(self.ClassType);
 298   pool.free(Pointer(self));
 299 end;
 300 {$ENDIF}
 301
 302
 303 // ////////////////////////////////////////////////////////////////////////// //
 304 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 305 procedure dumpPools ();
 306 var
 307   fo: TextFile;
 308   kv: THashPtrPtr.PEntry;
 309 begin
 310   AssignFile(fo, 'zmemlog.txt');
 311   Rewrite(fo);
 312   for kv in pools.byKeyValue do
 313   begin
 314     writeln(fo, kv.value.name, ': count=', kv.value.allocCount, '; total=', kv.value.allocTotal);
 315   end;
 316   CloseFile(fo);
 317 end;
 318 {$ENDIF}
 319
 320
 321 initialization
 322   //mpoolMap := TMemPool.Create('textmap', 64);
 323   framePool := TPoolMarkRelease.Create(65536);
 324 finalization
 325   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 326   dumpPools();
 327   {$ENDIF}
 328 {$ENDIF} // USE_MEMPOOL
 329 end.