topmanagers.pas

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

  // Clear all SizeManagers of Excess Stuff
  // Start this loop random in each thread so we are not blocking each other when many threads finish simultaneously
  R := Random(cMaxManagers + 1);
  // All Managers from R to FSManagers
  for I := R to cMaxManagers do FSManagerList[I].Clear;
  // All Managers from  Zero to R - 1
  for I := 0 to R - 1 do FSManagerList[I].Clear;
  // All blocks have gone now, clear Marked Block list
  FMarkedBlockList.Clear;
end;

{ TThreadManagerList }

procedure TThreadManagerList.Clear;
var
  I: Integer;
begin
  // Clear all unused ThreadManagers (frees up some OS data and reclaims crossthread freed memory)
  Lock;
  try
    // Walk list for all UNUSED threadmanagers, others can only be cleared from their own context and will do so upon being released
    for I := FFreeListStart to FFreeManagersList.Count - 1 do
      TThreadManager(FFreeManagersList[I]).Clear;
  finally
    UnLock;
  end;
end;

procedure TThreadManagerList.CollectLeaks(const ALeaks: TTopsortedList);
var
  I, M: Integer;
  lPoolSM: TPoolSM;
  lSM: TSizeManager;
begin
  Lock;
  try
    GLobalPool.Lock;
    try
      // Collect all pointers in use at the moment in the Pool
      with GlobalPool do
      begin
        for I := 0 to cMaxManagers do
        begin
          lPoolSM := GetSizeManagerByIndex(I);
          lPoolSM.CollectLeaks(ALeaks);
        end;
      end;
      // Collect all pointers in use at the moment in the ThreadManagers
      for M := 0 to FAllManagers.Count - 1 do
      begin
        with TThreadManager(FAllManagers[M]) do
        begin
          for I := 0 to cMaxManagers do
          begin
            lSM := GetSizeManagerByIndex(I);
            lSM.CollectLeaks(ALeaks);
          end;
        end;
      end;
    finally
      GlobalPool.Unlock;
    end;
  finally
    UnLock;
  end;
end;

constructor TThreadManagerList.Create;
begin
  inherited Create;
  Randomize;
  FFreeManagersList := TTopPointerList.Create(False, True);
  FNonDelphiManagersList := TTopPointerList.Create(True);
  FLeakList := TTopSortedList.Create(True);
  FFreeListStart := 0;
  FGlobalPool := TPoolTM.Create(0);
  FAllManagers := TTopPointerList.Create(False);
end;

destructor TThreadManagerList.Destroy;
var
  I: Integer;
begin
  Lock;
  try
    // Destroy unused managers, others will be reported as leaks
    for I := FFreeManagersList.Count - 1 downto FFreeListStart do
      TThreadManager(FFreeManagersList[I]).Free;
    // List is freed
  finally
    UnLock;
  end;
  //
  FreeAndNil(FFreeManagersList);
  FreeAndNil(FGlobalPool);
  FreeAndNil(FLeakList);
  FreeAndNil(FNonDelphiManagersList);
  //
  inherited Destroy;
end;

procedure TThreadManagerList.DetectDeadThreads;
var
  I: Integer;
  T: TTopSortedList;
begin
  T := nil;
  try
    Lock;
    try
      // Walk the used managers and check deceased
      for I := 0 to FNonDelphiManagersList.Count - 1 do
      begin
        if not IsThreadAlive(TThreadManager(FNonDelphiManagersList[I]).ThreadHandle) then
        begin
          if not Assigned(T) then T := TTopSortedList.Create(False);
          T.Add(TThreadManager(FNonDelphiManagersList[I]));
        end;
      end;
    finally
      UnLock;
    end;
      // free the deceased ones
    if Assigned(T) then
      for I := 0 to T.Count - 1 do
        ReleaseThreadManager(TThreadManager(T[I].Index));
  finally
    FreeAndNil(T);
  end;
end;

constructor TThreadManager.Create(const ASequenceID:Cardinal);
begin
  inherited Create;
  CreateList;
  FSequenceID:=ASequenceID;
  FMarkedBlockList := TTopPointerList.Create(False, True);
  FBlocksToFree := TTopSortedList.Create(False, True);
  ThreadHandle := 0;
  FDelphi := False;
end;

procedure TThreadManagerList.ReleaseThreadManager(const AManager: TThreadManager);
{$IFDEF TOPDEBUG}
var I: Integer;
{$ENDIF}
begin
  if assigned(AManager) then
  begin
{$IFDEF TOPDEBUG}
    for I := FFreeListStart to FFreeManagersList.Count - 1 do
      if TThreadManager(FFreeManagersList[I]) = AManager then
        DebugError('ThreadManager returned twice?!');
{$ENDIF}
    // Move all remaining blocks To Pool
    AManager.Clear;
    // Add To ThreadManagerList FreeList
    Lock;
    try
      Dec(FFreeListStart);
      FFreeManagersList.Items[FFreeListStart] := AManager;
      if not AManager.IsDelphiThread then RemoveNonDelphiManagerFromList(AManager);
    finally
      UnLock;
    end;
  end;
end;

procedure TThreadManagerList.ReportLeaks;
var
  AllLeaks: TTopSortedList;

  procedure RemoveAndReportExpectedLeaks(AAllLeaks: TTopSortedList);
  var
    ExpectedFound, I: Integer;
  begin
    // remove all expected leaks
    ExpectedFound := 0;
    for I := 0 to FLeakList.Count - 1 do
      if AAllLeaks.Delete(FLeakList[I].Index) then
        Inc(ExpectedFound);
    // report number of expected leaks
    if ExpectedFound > 0 then
      ReportString(IntToStr(ExpectedFound) + ' of ' + IntToStr(FLeakList.Count) + ' registered memory leaks found.');
  end;

  function ReportThreads: Boolean; // result TRUE when 1 or more delphi threads still running
  var
    DelphiThreads, NotDelphiThreads: Integer;
  begin
    Result := False;
    // report threads not freed yet
    NotDelphiThreads := FNonDelphiManagersList.Count;
    DelphiThreads := FFreeListStart - 1 - NotDelphiThreads; // -2 because Main and Managerthread must be excluded.
    // report
    if DelphiThreads > 0 then
    begin
      Result := True;
      if DelphiThreads = 1 then
        ReportString('1 Delphi TThread (or descendant) has not finished before Application Exit.')
      else
        ReportString(IntToStr(DelphiThreads) + ' Delphi TThreads (or descendants) have not finished before Application Exit.');
    end;
    if NotDelphiThreads > 0 then
    begin
      if NotDelphiThreads = 1 then
        ReportString('1 Non Delphi Thread is still running at Application Exit (this does not have to be an error)')
      else
        ReportString(IntToStr(NotDelphiThreads) + ' Non Delphi Threads are still running at Application Exit (this does not have to be an error)');
    end;
  end;

begin
  // Do we need to report?
  if ReportMemoryLeaksOnShutdown and (ReportMemoryLeaksToLogFile or ReportMemoryLeaksToIDE) then
  try
    AllLeaks := TTopSortedList.Create(False, True); // for performance do not check for dupes in non sorted list
    try
      Lock;
      try
        // First report all threads that have not returned their memory
        // wait some extra time if there are still delphi threads running
        if ReportThreads then Sleep(250);
        //
        // Collect all leaks (list not yet sorted)
        CollectLeaks(AllLeaks);
        // Sort the list
        AllLeaks.Sorted := True;
        // Remove expected leaks
        RemoveAndReportExpectedLeaks(AllLeaks);
      finally
        UnLock;
      end;
      // Group and report the leaks
      OutputLeaks(AllLeaks);
    finally
      AllLeaks.Free;
    end;
  except
    // Eat Errors as this is not entirely threadsafe (although app should have stopped everything by now)
  end;
end;

function TThreadManagerList.ReserveThreadManager(const ADelphiThread: Boolean): TThreadManager;
begin
  Lock;
  try
    // Try to reserve an existing manager
    if not AllThreadManagersUsed then
      Result := TThreadManager(FFreeManagersList[FFreeListStart])
    else
    begin
      // Make new Manager;
      Result := TThreadManager.Create(FFreeManagersList.Count);
      FFreeManagersList.Add(Pointer(0)); // Create space for when it's returned
      FAllManagers.Add(Result);
    end;
    Inc(FFreeListStart);
    // Add to list if non delphi
    Result.IsDelphiThread := ADelphiThread;
    if not ADelphiThread then AddNonDelphiManagerToList(Result);
  finally
    UnLock;
  end;
end;

procedure TThreadManagerList.AddNonDelphiManagerToList(const AManager: TThreadManager);
begin
  // Make sure we have a lock when calling this routine
  FNonDelphiManagersList.Add(AManager);
  // Get ahandle on it so we can check if it's alive
  try
    AManager.ThreadHandle := OpenThread(THREAD_QUERY_INFORMATION, BOOL(False), GetCurrentThreadID);
  except
    AManager.ThreadHandle := 0;
  end;
end;

procedure TThreadManagerList.RemoveNonDelphiManagerFromList(const AManager: TThreadManager);
var
  Idx: Integer;
begin
  // Make sure we have a lock when calling this routine
  if FNonDelphiManagersList.Find(AManager, Idx) then
  begin
    try
      // close handle
      try
        if AManager.ThreadHandle <> 0 then CloseHandle(AManager.ThreadHandle);
      except
      // ignore errors
      end;
    finally
      FNonDelphiManagersList.DeleteByIndex(Idx);
    end;
  end;
end;


procedure TThreadManagerList.TMLReallocMem(const ThreadManager: TThreadManager; const OSBlock: TOSBlock; const P: Pointer; const NewSize: Cardinal; out ReAllocResult: Pointer);
var
  GetMemResult: Pointer;
  CopySize: Cardinal;
begin
  ReAllocResult := nil;
  // ReAlloc of existing block
  if TSizeManager(OSBlock.SizeManager).ThreadManager = ThreadManager then
  begin
    ReAllocResult := ThreadManager.TMReAllocMem(P, OSBlock, NewSize); // ReAllocResult nil is failure, Result False means block was not in this manager
  end else
  begin
    // copy data if block to small or new size is far below normal size for block
    if (OSBlock.AppBlockSize < NewSize + cAppBlockHeaderSize) or (NewSize < (OSBlock.AppBlockSize shr 2)) then
    begin
      // Claim new space in our own manager, copy data from other block and free in other Manager
      GetMemResult := ThreadManager.TMGetMem(NewSize);
      if GetMemResult <> nil then
      begin
        // Copy all content to new block (or as much as possible if block is smaller)
        // Determine copysize (old size minus alignment shift. can be calculated from pointers)
        CopySize := OSBlock.AppBlockSize - cAppBlockHeaderSize;
        if NewSize < CopySize then
          CopySize := NewSize;
        // MemoryCopy
        TopMoveMemory(Pointer(Cardinal(GetMemResult) + cAppBlockHeaderSize), Pointer(Cardinal(P) + cAppBlockHeaderSize), CopySize);
        // Set result pointer to newly allocated spot
        ReAllocResult := GetMemResult;
        // Free old data
        FreeAppBlockFromOtherThread(OSBlock, P);
      end else ReAllocResult := nil;
    end
    else
      ReAllocResult := P; // Reallocated size fits within already allocated block
  end;
end;

function TThreadManagerList.RegisterMemoryLeak(P: Pointer): Boolean;
begin
  Result := True;
  //
  Lock;
  try
    FLeakList.add(P);
  finally
    UnLock;
  end;
end;

function TThreadManagerList.UnregisterMemoryLeak(P: Pointer): Boolean;
begin
  Lock;
  try
    Result := FLeakList.Delete(P);
  finally
    UnLock;
  end;
end;

procedure TThreadManager.Destroylist;
var
  I: Integer;
begin
  // Free all SizeManagers
  for I := 0 to cMaxManagers do
    FSManagerList[I].Free;
  //
  FSManagerList.Free;
end;

procedure TPoolTM.AddBlockToPool(const SMIndex: Byte; const OSBlock: TOSBlock);
var
  PoolSizeManager: TPoolSM;
  lLockID: Byte;
begin
{$IFDEF TOPDEBUG}
  if (not OSBlock.IsEmpty) then
    DebugError('PM.ABTP');
{$ENDIF}
  // Use AppBlockSize of SizeManager as Block might have been shrunken in uniquemode. Still has to go to Correct SizeManager in pool
  PoolSizeManager := GetSizeManagerByIndex(SMIndex);
  //
  lLockID := OSBlock.PoolID;
  // Upper cap on fully empty blocks in pool
{  if OSBlock.IsEmpty and (PoolSizeManager.FBlockList[lLockID].List.Count - PoolSizeManager.FBlockList[lLockID].FullPoolBlocks > ((cMaxManagers - SMIndex) shl 3)) then
  begin
    OSBlock.Free;
    Exit;
  end;}
  //
  PoolSizeManager.LockList(lLockID);
  try
    PoolSizeManager.AddBlockToPool(OSBlock);
  finally
    PoolSizeManager.UnLockList(lLockID);
  end;
end;

function TPoolTM.GetBlockFromPool(const StartAt: Byte; const SMIndex: Byte; const NewOwner: TSizeManager; out OSBlock: TOSBlock): Boolean;
begin
  // Get Block from SizeManager that has blocks this size
  Result := GetSizeManagerByIndex(SMIndex).GetEmptyBlock(StartAt, OSBlock, NewOwner);
end;

procedure TPoolSM.AddBlockToPool(const Block: TOSBlock);
begin