topmanagers.pas

类似fastmm替换Delphi自带的内存管理器

{****************************************************************************************

TOPMEMORY v3.54 - HIGH PERFORMANCE DELPHI MEMORY MANAGER  (C) 2008 Ivo Tops, Topsoftware

  TopManagers contains;

  TSizeManager   = Manager for blocks of a specific size
  TThreadManager = ThreadMemory Manager with a list of SizeManagers
  TThreadManagerList = All ThreadManagers
  TPoolSM = SizeManager for Pool
  TPoolTM = ThreadManager for Pool

****************************************************************************************}
unit TopManagers;

{$B-}
interface

{$IFNDEF TOPDEBUG} // Debugging off unless you use the TOPDEBUG directive
{$D-,L-}
{$ENDIF}
{$X+}

{.DEFINE TOPDISABLEPOOL}

uses
  TopCS,
  TopBlocks,
  TopSortedList,
  TopPointerList,
  TopLocalObjects,
  TopLib_CopyMemory,
  Windows;

const
  cMaxManagers = 23;
  cSMIndexQBuf1 = 22;
  cSMIndexQBuf2 = 18;
  cMaxBlockLists = 8;


type
  TOSBlockList = class(TTopPointerList)
  private
    function Get(Index: Integer): TOSBlock; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    procedure Put(Index: Integer; const Value: TOSBlock); {$IF COMPILERVERSION>=18}inline; {$IFEND}
  public
    property Items[Index: Integer]: TOSBlock read Get write Put; default;
  end;

type
  TPoolSMBlock = packed record
    MinBlocks: Integer;
    FullPoolBlocks: Integer;
    List: TTopPointerList;
    Lock: _RTL_CRITICAL_SECTION;
  end;

type
  RQRec = record
    UseBuf: Boolean;
    QMem: Pointer;
    QBlock: TOSBlock;
  end;

const
  cSMIndexSizes: array[0..cMaxManagers] of Cardinal =
  (8, 16, 32, 48, 64, 96, 128, 192, 256, 384, 496, 768, 1008, 1456, 2176, 3120
    , 4368, 8176, 16368, 32752, 65520, 131040, 262080, 0);
  cSMIndexStart: array[0..cMaxManagers] of Byte =
  (64, 60, 56, 52, 48, 44, 40, 36, 32, 28, 24
    , 20, 16, 14, 12, 10, 8, 6, 4, 4, 2, 2, 1, 1);
const
  cSMSizeStop: array[-1..cMaxManagers] of Cardinal =
  (0, 5, 13, 25, 41, 57, 81, 113, 161, 225, 321, 441, 633
    , 889, 1233, 1817, 2649, 3745, 6273, 12273, 24561, 49137, 98281, 196561, MaxCard);
const
  cSMMaxAppBlocks: array[-1..cMaxManagers] of Byte =
  (255, 245, 235, 225, 215, 205, 195, 185, 175, 165, 155, 145, 135
    , 125, 115, 105, 95, 85, 75, 65, 55, 45, 25, 10, 1);


type
  TSizeManagerBase = class(TLocalObject)
  private
    FSMIndex: Byte;
    FAppBlockSize: Cardinal;
    FThreadManager: Pointer;
    FUniqueBlockmode: Boolean;
  protected
    procedure CollectLeaks(const ALeaks: TTopSortedList); virtual; abstract;
  public
    constructor Create(const SMIndex: Byte; const AppBlockSize: Cardinal; const AThreadManager: Pointer; const UniqueBlockMode: Boolean); reintroduce;
    //
    procedure Clear; virtual; abstract;
    //
    property AppBlockSize: Cardinal read FAppBlockSize;
    property SMIndex: Byte read FSMIndex;
    //
    property ThreadManager: Pointer read FThreadManager;

  end;

type
  TSizeManager = class(TSizeManagerBase)
  private
    FBlockToStart: Integer;
    FFullBlocks: Integer;
    FOSBlockList: TOSBlockList;
    FStartAt: Byte;
    QBuf: array[0..1] of RQRec;
    procedure FreeQbuf;
    function AddBlock(const SpecificSize: Cardinal = 0): Integer;
    procedure RemoveBlock(const Index: Integer);
  protected
    procedure CollectLeaks(const ALeaks: TTopSortedList); override;
  public
    constructor Create(const SMIndex: Byte; const AThreadManager: Pointer; const UniqueBlockMode: Boolean = False); reintroduce;
    destructor Destroy; override;
    //
    function SMGetMem(const Size: Cardinal; const AZeroMemory: Boolean = False): Pointer;
    procedure SMFreeMem(const Loc: Pointer; const Block: TOSBlock; const AQBuf: Boolean = True);
    function SMReAllocMem(const Size: Cardinal; const Block: TOSBlock): Pointer;
    function InQBuf(const APointer: Pointer): Boolean; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    //
    procedure Clear; override;
  end;

type
  TSizeManagerList = class(TTopPointerList)
  private
    function Get(Index: Integer): TSizeManagerBase; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    procedure Put(Index: Integer; const Value: TSizeManagerBase); {$IF COMPILERVERSION>=18}inline; {$IFEND}
  public
    property Items[Index: Integer]: TSizeManagerBase read Get write Put; default;
  end;

type
  TPoolSM = class(TSizeManagerBase)
  private
    FBlockList: array[0..cMaxBlockLists - 1] of TPoolSMBlock;
  protected
    procedure ProcessAppBlocksFreedFromOtherThread(const Block: TOSBlock);
    function FreeBlocks(const ListIndex: Byte; const Amount: Integer): Boolean;
    procedure CollectLeaks(const ALeaks: TTopSortedList); override;
  public
    constructor Create(const SMIndex: Byte; const AThreadManager: Pointer; const UniqueBlockMode: Boolean = False); reintroduce;
    destructor Destroy; override;
    // Poolblocks give and take
    procedure AddBlockToPool(const Block: TOSBlock);
    procedure AddBlocksToPool(const Blocks: TOSBlockList);
    function GetEmptyBlock(const StartAt: Byte; out Block: TOSBlock; const NewOwner: Pointer): Boolean; // Block with room, not totally empty
    //
    procedure SMFreeMem(const Loc: Pointer; const Block: TOSBlock);
    //
    procedure LockList(const PoolID: Byte); {$IF COMPILERVERSION>=18}inline; {$IFEND}
    procedure UnLockList(const PoolID: Byte); {$IF COMPILERVERSION>=18}inline; {$IFEND}
    // Maintenance
    procedure ManagePoolSize(const AFreeAll: Boolean = False);
    //
    procedure Clear; override;
  end;

type
  TThreadManager = class(TCSObject)
  private
    FSequenceID:Cardinal;
    FThreadHandle: THandle;
    // List voor SizeManagers
    FSManagerList: TSizeManagerList;
    // List voor gemarkeerde blokken
    FMarkedBlockList: TTopPointerList;
    FBlocksToFree: TTopSortedList;
    // Delphi?
    FDelphi: Boolean;
    procedure CreateList; virtual;
    procedure Destroylist;
    function GetSizeManager(const Size: Cardinal): TSizeManager; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    function GetSizeManagerByIndex(const Index: Byte): TSizeManager; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    function GetIsPoolManager: Boolean;
  public
    constructor Create(const ASequenceID:Cardinal); reintroduce;
    destructor Destroy; override;
    //
    procedure TMFreeMem(const P: Pointer; const OSBlock: TOSBlock); {$IF COMPILERVERSION>=18}inline; {$IFEND}
    function TMGetMem(const Size: Cardinal; const AZeroMemory: Boolean = False): Pointer; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    function TMReallocMem(const P: Pointer; const OSBlock: TOSBlock; const Size: Cardinal): Pointer;
    //
    procedure DataFreedByOtherThreadInBlock(const Block: TOSBlock); {$IF COMPILERVERSION>=18}inline; {$IFEND}
    procedure FreeDataInMarkedBlocks;
    function MarkedBlocksPresent: Boolean; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    //
    procedure Clear; // All Blocks To Pool
    //
    property IsPoolManager: Boolean read GetIsPoolManager;
    property ThreadHandle: THandle read FThreadHandle write FThreadHandle; // Thread using this manager
    property IsDelphiThread: Boolean read FDelphi write FDelphi;
    property SequenceID:Cardinal read FSequenceID;
  end;

type
  TPoolTM = class(TThreadManager)
  private
    procedure CreateList; override;
  protected
    procedure AddBlockToPool(const SMIndex: Byte; const OSBlock: TOSBlock);
    function GetBlockFromPool(const StartAt: Byte; const SMIndex: Byte; const NewOwner: TSizeManager; out OSBlock: TOSBlock): Boolean;
    //
    function GetSizeManager(const Size: Cardinal): TPoolSM; reintroduce; {$IF COMPILERVERSION>=18}inline; {$IFEND}
  public
    function GetSizeManagerByIndex(const Index: Byte): TPoolSM; reintroduce; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    //
    procedure ClearPool; // Free all empty blocks
  end;

type
  TTManagerEntry = packed record
    ThreadManager: TThreadManager;
    FreeList: Integer;
  end;
  TTManagerArray = array[0..MaxInt div (SizeOf(TTManagerEntry)) - 1] of TTManagerEntry;
  PTManagerArray = ^TTManagerArray;

type
  TThreadManagerList = class(TCSObject)
  private
    FFreeListStart: Integer;
    FFreeManagersList: TTopPointerList;
    FAllManagers: TTopPointerList;
    FNonDelphiManagersList: TTopPointerList;
    FLeakList: TTopSortedList;
    FGLobalPool: TPoolTM;
    //
    function AllThreadManagersUsed: Boolean; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    //
    procedure AddNonDelphiManagerToList(const AManager: TThreadManager);
    procedure RemoveNonDelphiManagerFromList(const AManager: TThreadManager);
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
    //
    procedure TMLReallocMem(const ThreadManager: TThreadManager; const OSBlock: TOSBlock; const P: Pointer; const NewSize: Cardinal; out ReAllocResult: Pointer);
    procedure FreeAppBlockFromOtherThread(const Block: TOSBlock; const Loc: Pointer);
    //
    procedure Clear; // Clean up / Move to pool as much as possible
    //
    function ReserveThreadManager(const ADelphiThread: Boolean): TThreadManager;
    procedure ReleaseThreadManager(const AManager: TThreadManager);
    //
    function RegisterMemoryLeak(P: Pointer): Boolean;
    function UnregisterMemoryLeak(P: Pointer): Boolean;
    procedure CollectLeaks(const ALeaks: TTopsortedList);
    procedure ReportLeaks;
    //
    procedure MarkAsDelphiThread(const AManager: TThreadManager);
    procedure DetectDeadThreads;
    //
    property GlobalPool: TPoolTM read FGlobalPool; // ThreadManager reserved for Pool Actions
  end;

const
  cGrowLen = 30;
var
  cBlockSizes: array[0..cMaxManagers - 1, 0..cGrowLen] of Word;

// windows api call definition
{$EXTERNALSYM OpenThread}
function OpenThread(dwDesiredAccess: DWord; bInheritHandle: Bool; dwThreadID: DWord): THandle; stdcall;
function OpenThread; external kernel32 Name 'OpenThread';

const
  THREAD_QUERY_INFORMATION: Dword = $0040;

implementation

uses
  TopReporting,
  TopInstall,
  TopLib_SSE2,
  Math,
  SysUtils;

function TSizeManagerList.Get(Index: Integer): TSizeManagerBase;
begin
  Result := inherited Get(Index);
end;

procedure TPoolSM.LockList(const PoolID: Byte);
begin
  EnterCriticalSection(FBlockList[PoolID].Lock);
end;

procedure TPoolSM.UnLockList(const PoolID: Byte);
begin
  LeaveCriticalSection(FBlockList[PoolID].Lock);
end;

function TThreadManager.GetSizeManagerByIndex(const Index: Byte): TSizeManager;
begin
  Result := TSizeManager(FSManagerList[Index]);
end;


function TThreadManager.GetIsPoolManager: Boolean;
begin
  Result := Self = TopMM.GlobalPool;
end;


procedure TSizeManagerList.Put(Index: Integer; const Value: TSizeManagerBase);
begin
  inherited Put(Index, Value);
end;

function TThreadManager.MarkedBlocksPresent: Boolean;
begin
  Result := FMarkedBlockList.Flag = True;
end;

function TPoolTM.GetSizeManager(const Size: Cardinal): TPoolSM;
begin
  Result := TPoolSM(inherited GetSizeManager(Size));
end;

function TThreadManagerList.AllThreadManagersUsed: Boolean;
begin
  Result := FFreeListStart = FFreeManagersList.Count;
end;

{ TOSBlockList }

function TOSBlockList.Get(Index: Integer): TOSBlock;
begin
  Result := inherited Get(Index);
end;

function TSizeManager.InQBuf(const APointer: Pointer): Boolean;
begin
  Result := (QBuf[0].QMem = APointer) or (QBuf[1].QMem = APointer);
end;


procedure TOSBlockList.Put(Index: Integer; const Value: TOSBlock);
begin
  inherited Put(Index, Value);
end;

function TPoolTM.GetSizeManagerByIndex(const Index: Byte): TPoolSM;
begin
  Result := TPoolSM(inherited GetSizeManagerByIndex(Index));
end;

procedure TThreadManager.TMFreeMem(const P: Pointer; const OSBlock: TOSBlock);
begin
  TSizeManager(OSBlock.Sizemanager).SMFreeMem(P, OSBlock);
end;

function TThreadManager.GetSizeManager(const Size: Cardinal): TSizeManager;
begin
  if Size <= cSMSizeStop[9] then
  begin
    if Size <= cSMSizeStop[5] then
    begin
      if Size <= cSMSizeStop[3] then
      begin
        if Size <= cSMSizeStop[1] then
        begin
          if Size <= cSMSizeStop[0] then
            Result := TSizeManager(FSManagerList[0])
          else
            Result := TSizeManager(FSManagerList[1]);
        end else
          if Size <= cSMSizeStop[2] then
            Result := TSizeManager(FSManagerList[2])
          else
            Result := TSizeManager(FSManagerList[3]);
      end else
        if Size <= cSMSizeStop[4] then
          Result := TSizeManager(FSManagerList[4])
        else
          Result := TSizeManager(FSManagerList[5]);
    end else
      if Size <= cSMSizeStop[7] then
      begin
        if Size <= cSMSizeStop[6] then
          Result := TSizeManager(FSManagerList[6])
        else
          Result := TSizeManager(FSManagerList[7]);
      end else
        if Size <= cSMSizeStop[8] then
          Result := TSizeManager(FSManagerList[8])
        else
          Result := TSizeManager(FSManagerList[9]);
  end else
    if Size <= cSMSizeStop[13] then
    begin
      if Size <= cSMSizeStop[11] then
      begin
        if Size <= cSMSizeStop[10] then
          Result := TSizeManager(FSManagerList[10])
        else
          Result := TSizeManager(FSManagerList[11]);
      end else
        if Size <= cSMSizeStop[12] then
          Result := TSizeManager(FSManagerList[12])