simple allocation counter for classes

diff --git a/src/engine/e_sound_fmod.inc b/src/engine/e_sound_fmod.inc
index 430735c7c6ae56761d2fdd5713a0665f9eed31a7..6c9efa6e841e55ee44e9f3307335e2cae9911e64 100644 (file)
--- a/src/engine/e_sound_fmod.inc
+++ b/src/engine/e_sound_fmod.inc
@@ -19,6 +19,7 @@ uses
   fmod,
   fmodtypes,
   fmoderrors,
+  mempool,
   e_log,
   SysUtils;
 
@@ -30,7 +31,7 @@ type
     nRefs: Integer;
   end;
 
-  TBasicSound = class (TObject)
+  TBasicSound = class(TPoolObject)
   private
     FChannel: FMOD_CHANNEL;
 

diff --git a/src/engine/e_sound_sdl.inc b/src/engine/e_sound_sdl.inc
index 4bac2308a9e6020d3af28e07a703a446732e5f5a..4d2e93d25260243e34c6228fb59c4b40cb9ba652 100644 (file)
--- a/src/engine/e_sound_sdl.inc
+++ b/src/engine/e_sound_sdl.inc
@@ -18,6 +18,7 @@ interface
 uses
   sdl2,
   SDL2_mixer,
+  mempool,
   e_log,
   SysUtils;
 
@@ -30,7 +31,7 @@ type
     nRefs: Integer;
   end;
 
-  TBasicSound = class (TObject)
+  TBasicSound = class(TPoolObject)
   private
     FChanNum: Integer; // <0: no channel allocated
 

diff --git a/src/game/Doom2DF.dpr b/src/game/Doom2DF.dpr
index 7f0afecda37322d78a9b6cea05b136f8eb76db40..a3e333a32062f604de7d9ca45026614c5230446a 100644 (file)
--- a/src/game/Doom2DF.dpr
+++ b/src/game/Doom2DF.dpr
@@ -39,6 +39,7 @@ program Doom2DF;
 {$ENDIF}
 
 uses
+  mempool in '../shared/mempool.pas',
   conbuf in '../shared/conbuf.pas',
   math,
   GL,

diff --git a/src/game/g_grid.pas b/src/game/g_grid.pas
index 1cb2534f9d8fdaaef113598cb828b047c8d5e4d4..0c9da2dbd51d2e03d7e689026499a53812b4d43b 100644 (file)
--- a/src/game/g_grid.pas
+++ b/src/game/g_grid.pas
@@ -26,13 +26,16 @@ unit g_grid;
 
 interface
 
+uses
+  mempool;
+
 const
   GridTileSize = 32; // must be power of two!
 
 type
   TBodyProxyId = Integer;
 
-  generic TBodyGridBase<ITP> = class(TObject)
+  generic TBodyGridBase<ITP> = class(TPoolObject)
   public
     type TGridQueryCB = function (obj: ITP; tag: Integer): Boolean is nested; // return `true` to stop
     type TGridRayQueryCB = function (obj: ITP; tag: Integer; x, y, prevx, prevy: Integer): Boolean is nested; // return `true` to stop

diff --git a/src/game/g_gui.pas b/src/game/g_gui.pas
index d59c838557761d29290813f3c667d366ec248151..2ead3bbbb06a9e0bf0bd7c8cbae0b5eb2d626919 100644 (file)
--- a/src/game/g_gui.pas
+++ b/src/game/g_gui.pas
@@ -19,6 +19,7 @@ unit g_gui;
 interface
 
 uses
+  mempool,
   e_graphics, e_input, e_log, g_playermodel, g_basic, MAPDEF, wadreader;
 
 const
@@ -84,7 +85,7 @@ type
 
   TFontType = (FONT_TEXTURE, FONT_CHAR);
 
-  TFont = class(TObject)
+  TFont = class(TPoolObject)
   private
     ID: DWORD;
     FScale: Single;
@@ -108,7 +109,7 @@ type
   TOnChangeEvent = procedure(Sender: TGUIControl);
   TOnEnterEvent = procedure(Sender: TGUIControl);
 
-  TGUIControl = class
+  TGUIControl = class(TPoolObject)
   private
     FX, FY: Integer;
     FEnabled: Boolean;
@@ -133,7 +134,7 @@ type
     property RightAlign: Boolean read FRightAlign write FRightAlign; // for menu
   end;
 
-  TGUIWindow = class
+  TGUIWindow = class(TPoolObject)
   private
     FActiveControl: TGUIControl;
     FDefControl: string;
@@ -416,7 +417,7 @@ type
     property Font: TFont read FFont write FFont;
   end;
 
-  TGUIFileListBox = class (TGUIListBox)
+  TGUIFileListBox = class(TGUIListBox)
   private
     FBasePath: String;
     FPath: String;

diff --git a/src/game/g_holmes.pas b/src/game/g_holmes.pas
index 96e86c97a5f93a15cc525122a79fcc2a3ed111a7..e23d6c74722e265135164ee32d165f186f963d37 100644 (file)
--- a/src/game/g_holmes.pas
+++ b/src/game/g_holmes.pas
@@ -19,6 +19,7 @@ unit g_holmes;
 interface
 
 uses
+  mempool,
   e_log, e_input,
   g_textures, g_basic, e_graphics, g_phys, g_grid, g_player, g_monsters,
   g_window, g_map, g_triggers, g_items, g_game, g_panel, g_console, g_gfx,

diff --git a/src/game/g_holmes_ui.inc b/src/game/g_holmes_ui.inc
index 0580a475a60f68178a479bf0f942162173155026..f91ab1937f2ab50f496803255ebf6ebecbada50e 100644 (file)
--- a/src/game/g_holmes_ui.inc
+++ b/src/game/g_holmes_ui.inc
@@ -15,7 +15,7 @@
  *)
 // ////////////////////////////////////////////////////////////////////////// //
 type
-  THControl = class
+  THControl = class(TPoolObject)
   public
     type TActionCB = procedure (me: THControl; uinfo: Integer);
 

diff --git a/src/game/g_monsters.pas b/src/game/g_monsters.pas
index 9647d18eca57012ecd6a4773bd78db2054143f72..8629bc954ae6143ed88e380cd3bc76795289b448 100644 (file)
--- a/src/game/g_monsters.pas
+++ b/src/game/g_monsters.pas
@@ -21,6 +21,7 @@ unit g_monsters;
 interface
 
 uses
+  mempool,
   g_basic, e_graphics, g_phys, g_textures, g_grid,
   g_saveload, BinEditor, g_panel, xprofiler;
 
@@ -48,7 +49,7 @@ const
 }
 
 type
-  TMonster = Class (TObject)
+  TMonster = class(TPoolObject)
   private
     FMonsterType: Byte;
     FUID: Word;

diff --git a/src/game/g_player.pas b/src/game/g_player.pas
index 9c20c904f520d41a9855248c2a9822ee95e46138..932e081d6da0b56ef9dabac4c6e190b9ca2ceaa2 100644 (file)
--- a/src/game/g_player.pas
+++ b/src/game/g_player.pas
@@ -20,6 +20,7 @@ unit g_player;
 interface
 
 uses
+  mempool,
   e_graphics, g_playermodel, g_basic, g_textures,
   g_weapons, g_phys, g_sound, g_saveload, MAPDEF,
   BinEditor, g_panel;
@@ -133,7 +134,7 @@ type
     Time: Word;
   end;
 
-  TPlayer = class (TObject)
+  TPlayer = class(TPoolObject)
   private
     FIamBot:    Boolean;
     FUID:       Word;
@@ -415,7 +416,7 @@ type
     Value: String;
   end;
 
-  TBot = class (TPlayer)
+  TBot = class(TPlayer)
   private
     FSelectedWeapon:  Byte;
     FTargetUID:       Word;
@@ -484,7 +485,7 @@ type
     procedure positionChanged ();  inline; //WARNING! call this after entity position was changed, or coldet will not work right!
   end;
 
-  TCorpse = class (TObject)
+  TCorpse = class(TPoolObject)
   private
     FModelName:     String;
     FMess:          Boolean;

diff --git a/src/game/g_playermodel.pas b/src/game/g_playermodel.pas
index 9e42436ec5a4440f619ec289298c2cf20444f451..b8d0ec6c7ef4b74d3f1c54c6a7297af846029d88 100644 (file)
--- a/src/game/g_playermodel.pas
+++ b/src/game/g_playermodel.pas
@@ -20,6 +20,7 @@ unit g_playermodel;
 interface
 
 uses
+  mempool,
   MAPDEF, g_textures, g_basic, g_weapons, e_graphics, wadreader;
 
 const
@@ -81,7 +82,7 @@ type
                   Array [A_STAND..A_LAST] of
                   Array [D_LEFT..D_RIGHT] of Array of TDFPoint;
 
-  TPlayerModel = class (TObject)
+  TPlayerModel = class(TPoolObject)
   private
     FName:             String;
     FDirection:        TDirection;

diff --git a/src/game/g_textures.pas b/src/game/g_textures.pas
index af3b29ff8e464f1fe8467a2b804ea384bd8d0ba5..f18695861cd8007a217f07983c312d10c93af076 100644 (file)
--- a/src/game/g_textures.pas
+++ b/src/game/g_textures.pas
@@ -19,6 +19,7 @@ unit g_textures;
 interface
 
 uses
+  mempool,
   e_graphics, MAPDEF, BinEditor, ImagingTypes, Imaging, ImagingUtility;
 
 Type
@@ -35,7 +36,7 @@ Type
 
   TLevelTextureArray = Array of TLevelTexture;
 
-  TAnimation = class(TObject)
+  TAnimation = class(TPoolObject)
   private
     ID:            DWORD;
     FAlpha:        Byte;

diff --git a/src/shared/CONFIG.pas b/src/shared/CONFIG.pas
index 3dfd736f4a6e1f492090993a7e4a11c96d63053c..155ebacabbeee0357f7e6fbd21225d2541c014f8 100644 (file)
--- a/src/shared/CONFIG.pas
+++ b/src/shared/CONFIG.pas
@@ -24,6 +24,9 @@ CONFIG.PAS 
 
 interface
 
+uses
+  mempool;
+
 type
   TParam = record
    Param: ShortString;
@@ -31,7 +34,7 @@ type
    Section: Word;
   end;
 
-  TConfig = class(TObject)
+  TConfig = class(TPoolObject)
    private
     FParams: array of TParam;
     FSections: array of ShortString;

diff --git a/src/shared/exoma.pas b/src/shared/exoma.pas
index 8616b7ba21d138914aaf2f109b91c7669799f7ef..ec9bbf8b40d0d83f62e97ef3577ce54bf40ba535 100644 (file)
--- a/src/shared/exoma.pas
+++ b/src/shared/exoma.pas
@@ -19,7 +19,7 @@ unit exoma;
 interface
 
 uses
-  typinfo, SysUtils, Variants, hashtable, xparser;
+  typinfo, SysUtils, Variants, mempool, hashtable, xparser;
 
 
 // ////////////////////////////////////////////////////////////////////////// //
@@ -41,7 +41,7 @@ type
 
 // ////////////////////////////////////////////////////////////////////////// //
 type
-  TPropHash = class
+  TPropHash = class(TPoolObject)
   private
     mClass: TClass;
     mNames: THashStrInt;
@@ -59,7 +59,7 @@ type
 
 // ////////////////////////////////////////////////////////////////////////// //
 type
-  TExprConstList = class
+  TExprConstList = class(TPoolObject)
   public
     function valid (const cname: AnsiString): Boolean; virtual; abstract;
     function get (const cname: AnsiString; out v: Variant): Boolean; virtual; abstract;
@@ -68,7 +68,7 @@ type
 
 // ////////////////////////////////////////////////////////////////////////// //
 type
-  TExprScope = class
+  TExprScope = class(TPoolObject)
   public
     class procedure error (const amsg: AnsiString);
     class procedure errorfmt (const afmt: AnsiString; const args: array of const);
@@ -78,7 +78,7 @@ type
     procedure setField (obj: TObject; const afldname: AnsiString; var aval: Variant); virtual;
   end;
 
-  TExprBase = class
+  TExprBase = class(TPoolObject)
   public
     class function coerce2bool (var v0: Variant): Boolean;
     class function toInt (var v: Variant): LongInt;

diff --git a/src/shared/idpool.pas b/src/shared/idpool.pas
index 8cb99e6fca1775be4b4854fcbb4f9ddbb3cbed7a..4722be8838635794e913348909d334ba72befdcc 100644 (file)
--- a/src/shared/idpool.pas
+++ b/src/shared/idpool.pas
@@ -19,10 +19,14 @@ unit idpool;
 
 interface
 
+uses
+  mempool;
+
+
 // ////////////////////////////////////////////////////////////////////////// //
 type
   //TODO: implement getting n sequential ids
-  TIdPool = class(TObject)
+  TIdPool = class(TPoolObject)
   public
     const InvalidId = $ffffffff;
 

diff --git a/src/shared/mempool.pas b/src/shared/mempool.pas
new file mode 100644 (file)
index 0000000..73c48c1
--- /dev/null
+++ b/src/shared/mempool.pas
@@ -0,0 +1,184 @@
+(* Copyright (C)  DooM 2D:Forever Developers
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program.  If not, see <http://www.gnu.org/licenses/>.
+ *)
+{$INCLUDE a_modes.inc}
+{$DEFINE MEM_DISABLE_ACCOUNTING}
+unit mempool;
+
+interface
+
+uses
+  SysUtils;
+
+
+type
+  PMemPool = ^TMemPool;
+  TMemPool = record
+  private
+    mName: ShortString;
+    mObjSize: Integer; // not a limit, just a recommendation
+    mFirstPage: Pointer;
+    mLastPage: Pointer;
+    mAllocTotal: Integer;
+    mAllocCount: Integer;
+
+  public
+    constructor Create (const aname: AnsiString; aobjsize: Integer);
+
+    procedure setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
+    procedure release (); // release all pool memory
+
+    function alloc (len: Integer): Pointer; // throws on OOM
+    procedure free (ptr: Pointer); // currently it is noop
+
+  public
+    property name: ShortString read mName;
+    property allocCount: Integer read mAllocCount;
+    property allocTotal: Integer read mAllocTotal;
+  end;
+
+
+  TPoolObject = class
+    {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
+    public class function NewInstance (): TObject; override;
+    public procedure FreeInstance (); override;
+    {$ENDIF}
+  end;
+
+
+implementation
+
+uses
+  hashtable;
+
+type
+  THashPtrPtr = specialize THashBase<Pointer, PMemPool>; // key: TClass; value: PMemPool
+
+var
+  pools: THashPtrPtr = nil;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+function hashequ (constref a, b: Pointer): Boolean; begin result := (a = b); end;
+function hashhash (constref a: Pointer): LongWord; begin result := fnvHash(PByte(@a)^, sizeof(a)); end;
+
+
+function getPoolFor (c: TClass): PMemPool;
+begin
+  if (pools = nil) then pools := THashPtrPtr.Create(hashhash, hashequ);
+  if not pools.get(Pointer(c), result) then
+  begin
+    GetMem(result, sizeof(TMemPool));
+    result.Create(c.ClassName, c.InstanceSize);
+    pools.put(Pointer(c), result);
+  end;
+end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+constructor TMemPool.Create (const aname: AnsiString; aobjsize: Integer);
+begin
+  if (aobjsize < 1) then aobjsize := 16; // arbitrary number
+  mName := aname;
+  mObjSize := aobjsize;
+  mFirstPage := nil;
+  mLastPage := nil;
+  mAllocTotal := 0;
+  mAllocCount := 0;
+end;
+
+
+procedure TMemPool.setCapacity (acount: Integer); // ensure capacity for at least `acount` objects
+begin
+end;
+
+
+procedure TMemPool.release (); // release all pool memory
+begin
+end;
+
+
+function TMemPool.alloc (len: Integer): Pointer; // throws on OOM
+begin
+  if (len > 0) then mAllocTotal += len;
+  if (len < 1) then len := 1;
+  GetMem(result, len);
+  FillChar(PByte(result)^, len, 0);
+  Inc(mAllocCount);
+end;
+
+
+procedure TMemPool.free (ptr: Pointer); // currently it is noop
+begin
+  FreeMem(ptr);
+end;
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+{$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
+class function TPoolObject.NewInstance (): TObject;
+var
+  {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
+  pool: PMemPool;
+  {$ENDIF}
+  ptr: Pointer;
+begin
+  {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
+  pool := getPoolFor(self.ClassType);
+  ptr := pool.alloc(self.InstanceSize);
+  {$ELSE}
+  GetMem(ptr, self.InstanceSize);
+  FillChar(PByte(ptr)^, self.InstanceSize, 0); // hello, Wyoming Knott!
+  {$ENDIF}
+  result := TObject(ptr);
+  self.InitInstance(ptr);
+end;
+
+
+procedure TPoolObject.FreeInstance ();
+var
+  pool: PMemPool;
+begin
+  pool := getPoolFor(self.ClassType);
+  pool.free(Pointer(self));
+end;
+{$ENDIF}
+
+
+// ////////////////////////////////////////////////////////////////////////// //
+{$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
+procedure dumpPools ();
+var
+  fo: TextFile;
+  kv: THashPtrPtr.PEntry;
+begin
+  AssignFile(fo, 'zmemlog.txt');
+  Rewrite(fo);
+  for kv in pools.byKeyValue do
+  begin
+    writeln(fo, kv.value.name, ': count=', kv.value.allocCount, '; total=', kv.value.allocTotal);
+  end;
+  CloseFile(fo);
+end;
+{$ENDIF}
+
+
+initialization
+  //mpoolMap := TMemPool.Create('textmap', 64);
+finalization
+  {$IF DEFINED(D2F_DEBUG) and NOT DEFINED(MEM_DISABLE_ACCOUNTING)}
+  dumpPools();
+  {$ENDIF}
+end.

diff --git a/src/shared/wadreader.pas b/src/shared/wadreader.pas
index 96bf2293b01bff634f722032f9e225e7948019bd..3f13946bcb1dea1532c6805ad57af2ae4854449a 100644 (file)
--- a/src/shared/wadreader.pas
+++ b/src/shared/wadreader.pas
@@ -22,13 +22,13 @@ unit wadreader;
 interface
 
 uses
-  sfs, xstreams, Classes;
+  mempool, sfs, xstreams, Classes;
 
 
 type
   SArray = array of ShortString;
 
-  TWADFile = class
+  TWADFile = class(TPoolObject)
   private
     fFileName: AnsiString; // empty: not opened
     fIter: TSFSFileList;

diff --git a/src/shared/xdynrec.pas b/src/shared/xdynrec.pas
index 4ac9db7667f375a08daa5defa0c99ff99c5bc355..4afab5f2a2f5b31812bc36b9fbaaf5a53590bbc6 100644 (file)
--- a/src/shared/xdynrec.pas
+++ b/src/shared/xdynrec.pas
@@ -21,7 +21,7 @@ interface
 
 uses
   SysUtils, Variants, Classes,
-  xparser, xstreams, utils, hashtable;
+  xparser, xstreams, utils, hashtable, mempool;
 
 
 // ////////////////////////////////////////////////////////////////////////// //
@@ -54,7 +54,7 @@ type
   TDynEBSList = specialize TSimpleList<TDynEBS>;
 
   // this is base type for all scalars (and arrays)
-  TDynField = class
+  TDynField = class(TPoolObject)
   public
     type
       TType = (TBool, TChar, TByte, TUByte, TShort, TUShort, TInt, TUInt, TString, TPoint, TSize, TColor, TList, TTrigData);
@@ -238,7 +238,7 @@ type
 
 
   // record, either with actual values, or with type definitions
-  TDynRecord = class
+  TDynRecord = class(TPoolObject)
   private
     mOwner: TDynMapDef;
     mId: AnsiString;
@@ -375,7 +375,7 @@ type
 
 
   // bitset/enum definition
-  TDynEBS = class
+  TDynEBS = class(TPoolObject)
   private
     mOwner: TDynMapDef;
     mIsEnum: Boolean;
@@ -420,7 +420,7 @@ type
 
 
   // parsed "mapdef.txt"
-  TDynMapDef = class
+  TDynMapDef = class(TPoolObject)
   public
     recTypes: TDynRecList; // [0] is always header
     trigTypes: TDynRecList; // trigdata

diff --git a/src/shared/xparser.pas b/src/shared/xparser.pas
index bac4e4a8153feb04faf29362eb0fbfc1295766c1..eb56686ee1daa9c4c9aa83184e4cb8c5226fefad 100644 (file)
--- a/src/shared/xparser.pas
+++ b/src/shared/xparser.pas
@@ -19,12 +19,12 @@ unit xparser;
 interface
 
 uses
-  Classes;
+  Classes, mempool;
 
 
 // ////////////////////////////////////////////////////////////////////////// //
 type
-  TTextParser = class
+  TTextParser = class(TPoolObject)
   public
     const
       TTNone = -1;