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