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