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 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
  60
  61 implementation
  62
  63 uses
  64   hashtable;
  65
  66 type
  67   THashKeyPtr = class
  68   public
  69     class function hash (const k: Pointer): LongWord; inline;
  70     class function equ (const a, b: Pointer): Boolean; inline;
  71     class procedure freekey (k: Pointer); inline;
  72   end;
  73
  74   THashPtrPtr = specialize THashBase<Pointer, PMemPool, THashKeyPtr>; // key: TClass; value: PMemPool
  75
  76 var
  77   pools: THashPtrPtr = nil;
  78
  79
  80 // ////////////////////////////////////////////////////////////////////////// //
  81 class function THashKeyPtr.hash (const k: Pointer): LongWord; inline; begin result := fnvHash(PByte(@k)^, sizeof(k)); end;
  82 class function THashKeyPtr.equ (const a, b: Pointer): Boolean; inline; begin result := (a = b); end;
  83 class procedure THashKeyPtr.freekey (k: Pointer); inline; begin end;
  84
  85
  86 function getPoolFor (c: TClass): PMemPool;
  87 begin
  88   if (pools = nil) then pools := THashPtrPtr.Create();
  89   if not pools.get(Pointer(c), result) then
  90   begin
  91     GetMem(result, sizeof(TMemPool));
  92     result.Create(c.ClassName, c.InstanceSize);
  93     pools.put(Pointer(c), result);
  94   end;
  95 end;
  96
  97
  98 // ////////////////////////////////////////////////////////////////////////// //
  99 constructor TMemPool.Create (const aname: AnsiString; aobjsize: Integer);
 100 begin
 101   if (aobjsize < 1) then aobjsize := 16; // arbitrary number
 102   mName := aname;
 103   mObjSize := aobjsize;
 104   mFirstPage := nil;
 105   mLastPage := nil;
 106   mAllocTotal := 0;
 107   mAllocCount := 0;
 108 end;
 109
 110
 111 procedure TMemPool.setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
 112 begin
 113 end;
 114
 115
 116 procedure TMemPool.release (); // release all pool memory
 117 begin
 118 end;
 119
 120
 121 function TMemPool.alloc (len: Integer): Pointer; // throws on OOM
 122 begin
 123   if (len > 0) then mAllocTotal += len;
 124   if (len < 1) then len := 1;
 125   GetMem(result, len);
 126   FillChar(PByte(result)^, len, 0);
 127   Inc(mAllocCount);
 128 end;
 129
 130
 131 procedure TMemPool.free (ptr: Pointer); // currently it is noop
 132 begin
 133   FreeMem(ptr);
 134 end;
 135
 136
 137 // ////////////////////////////////////////////////////////////////////////// //
 138 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 139 class function TPoolObject.NewInstance (): TObject;
 140 var
 141   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 142   pool: PMemPool;
 143   {$ENDIF}
 144   ptr: Pointer;
 145 begin
 146   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 147   pool := getPoolFor(self.ClassType);
 148   ptr := pool.alloc(self.InstanceSize);
 149   {$ELSE}
 150   GetMem(ptr, self.InstanceSize);
 151   FillChar(PByte(ptr)^, self.InstanceSize, 0); // hello, Wyoming Knott!
 152   {$ENDIF}
 153   result := TObject(ptr);
 154   self.InitInstance(ptr);
 155 end;
 156
 157
 158 procedure TPoolObject.FreeInstance ();
 159 var
 160   pool: PMemPool;
 161 begin
 162   pool := getPoolFor(self.ClassType);
 163   pool.free(Pointer(self));
 164 end;
 165 {$ENDIF}
 166
 167
 168 // ////////////////////////////////////////////////////////////////////////// //
 169 {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 170 procedure dumpPools ();
 171 var
 172   fo: TextFile;
 173   kv: THashPtrPtr.PEntry;
 174 begin
 175   AssignFile(fo, 'zmemlog.txt');
 176   Rewrite(fo);
 177   for kv in pools.byKeyValue do
 178   begin
 179     writeln(fo, kv.value.name, ': count=', kv.value.allocCount, '; total=', kv.value.allocTotal);
 180   end;
 181   CloseFile(fo);
 182 end;
 183 {$ENDIF}
 184
 185
 186 initialization
 187   //mpoolMap := TMemPool.Create('textmap', 64);
 188 finalization
 189   {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
 190   dumpPools();
 191   {$ENDIF}
 192 end.