From: Ketmar Dark Date: Mon, 11 Sep 2017 18:30:12 +0000 (+0300) Subject: simple allocation counter for classes X-Git-Url: http://deadsoftware.ru/gitweb?p=d2df-sdl.git;a=commitdiff_plain;h=31d174a428ef1235e1708b0738804b47e006cf5c simple allocation counter for classes --- diff --git a/src/engine/e_sound_fmod.inc b/src/engine/e_sound_fmod.inc index 430735c..6c9efa6 100644 --- 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 4bac230..4d2e93d 100644 --- 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 7f0afec..a3e333a 100644 --- 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 1cb2534..0c9da2d 100644 --- 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 = class(TObject) + generic TBodyGridBase = 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 d59c838..2ead3bb 100644 --- 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 96e86c9..e23d6c7 100644 --- 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 0580a47..f91ab19 100644 --- 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 9647d18..8629bc9 100644 --- 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 9c20c90..932e081 100644 --- 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 9e42436..b8d0ec6 100644 --- 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 af3b29f..f186958 100644 --- 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 3dfd736..155ebac 100644 --- 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 8616b7b..ec9bbf8 100644 --- 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 8cb99e6..4722be8 100644 --- 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 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 . + *) +{$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; // 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 96bf229..3f13946 100644 --- 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 4ac9db7..4afab5f 100644 --- 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; // 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 bac4e4a..eb56686 100644 --- 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;