topmanagers.pas

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

  // Caller must have size manager locked
  // Block should not be listed as having blocks freed by other thread in current threadmanager
  // Set Pool as New Owner for Block;
  Block.SizeManager := self;
  // Add block to end of list
  FBlockList[Block.PoolID].List.Add(Block);
  // Full block and flag setting
  if Block.IsFull then Inc(FBlockList[Block.PoolID].FullPoolBlocks) else FBlockList[Block.PoolID].List.Flag := True;
end;

function TPoolSM.GetEmptyBlock(const StartAt: Byte; out Block: TOSBlock; const NewOwner: Pointer): Boolean;
var
  X, C: Byte;
  I: Integer;
begin
  // Caller must have pool size manager locked
{$IFDEF TOPDEBUG}
  if (not TThreadManager(FThreadManager).IsPoolManager) then
    DebugError('SM.GEB');
{$ENDIF}
  Result := False;
  // Start op een random positie om zoveel mogelijk niet in elkaars weg te zitten
  X := StartAt;
  C := 0;
  repeat
    if FBlockList[X].List.Flag = True then
    begin
      LockList(X);
      try
        for I := FBlockList[X].List.Count - 1 downto 0 do
          if not TOSBlock(FBlockList[X].List[I]).IsFull then
          begin
            // Niet vol blok gevonden
            Result := True;
            Block := TOSBlock(FBlockList[X].List[I]);
            Block.SizeManager := NewOwner;
            // verwijder uit pool
            FBlockList[X].List.DeleteByIndex(I);
            // Flag setting
            if FBlockList[X].List.Count = FBlockList[X].FullPoolBlocks then FBlockList[X].List.Flag := False;
            // MinMax
            if (FBlockList[X].List.Count - FBlockList[X].FullPoolBlocks) < (FBlockList[X].MinBlocks) then FBlockList[X].MinBlocks := FBlockList[X].List.Count - FBlockList[X].FullPoolBlocks;
            // Ready
            Break;
          end;
      finally
        UnLockList(X);
      end;
    end;
    //
    if not Result then
    begin
      Inc(X);
      if X = cMaxBlockLists then X := 0;
      Inc(C);
    end;
    //
  until (Result = True) or (C = cMaxBlockLists);
end;

procedure TPoolSM.AddBlocksToPool(const Blocks: TOSBlockList);
var
  I: Integer;
begin
  // Should be already locked by caller
{$IFDEF TOPDEBUG}
  if (not TThreadManager(FThreadManager).IsPoolManager) then DebugError('SM.ABSTP');
{$ENDIF}
  // Walk all blocks and add to pool.
  for I := 0 to Blocks.Count - 1 do
  begin
    LockList(Blocks[I].PoolID);
    try
      // Free data in there already marked to be freed from other threads
      if Blocks[I].FreedByOtherThreadBlocks > 0 then ProcessAppBlocksFreedFromOtherThread(Blocks[I]);
      // Move to pool
      AddBlockToPool(Blocks[I]);
    finally
      UnLockList(Blocks[I].PoolID);
    end;
  end;
end;

function TSizeManager.SMReAllocMem(const Size: Cardinal; const Block: TOSBlock): Pointer;
begin
{$IFDEF TOPDEBUG}
  if not Block.UniqueMode then
    DebugError('SM.BNU');
{$ENDIF}
  // ReAlloc data in a Unique mode block
  // If not succeeded we report a nil pointer for the result
  if not Block.OBResize(Size, Result) then Result := nil;
end;

procedure TThreadManager.DataFreedByOtherThreadInBlock(const Block: TOSBlock);
begin
  // Caller must have TM locked
  FMarkedBlockList.Add(Block);
  FMarkedBlockList.Flag := True;
end;

procedure TThreadManager.FreeDataInMarkedBlocks;
var
  Loc: Pointer;
  I: Integer;

  procedure FreeBlockData(const Block: TOSBlock);
  var
    BlocksToDo, J: Integer;
  begin
    BlocksToDo := Block.FreedByOtherThreadBlocks;
    // Set to zero right now because block might be destroyed at end, we won't know
    Block.FreedByOtherThreadBlocks := 0;
    // Andere thread heeft misschien geheugen als vrij aangemerkt. Hier verwerken we dit netjes
    // zoals we ook normale blokken verwerken bij vrijgave.
    for J := BlocksToDo - 1 downto 0 do
    begin
      Loc := Pointer(Cardinal(Block.OSBlockPointer) + Cardinal(Block.FreedByOtherThreadList[J] * Block.AppBlockSize));
        // Zorg dat de laatste niet gedaan wordt (pool niet gelocked, anders deadlock)
      if (J = 0) and (Block.FreeListStart = 1) then
        FBlocksToFree.Add(Loc, Block)
      else
        TSizeManager(Block.SizeManager).SMFreeMem(Loc, Block);
    end;
  end;

begin
  FBlocksToFree.Clear;
  FMarkedBlockList.Flag := False;
  //
  Lock;
  try
    for I := FMarkedBlockList.Count - 1 downto 0 do
    begin
      FreeBlockData(TOSBlock(FMarkedBlockList[I]));
      FMarkedBlockList.DeleteByIndex(I);
    end;
  finally
    UnLock;
  end;
  // Free last appblocks (will move to pool) outside Threadlock (deadlock if within)
  for I := 0 to FBlocksToFree.Count - 1 do
    TSizeManager(TOSBlock(FBlocksToFree[I].Obj).SizeManager).SMFreeMem(Pointer(FBlocksToFree[I].Index), TOSBlock(FBlocksToFree[I].Obj));
end;


procedure TPoolTM.ClearPool;
var
  I: Integer;
begin
  for I := cMaxManagers downto 0 do TPoolSM(FSManagerList[I]).ManagePoolSize(True);
end;

procedure TPoolTM.CreateList;
begin
  FSManagerList := TSizeManagerList.Create(False, True, cMaxManagers + 1);
  FSManagerList[0] := TPoolSM.Create(0, self);
  FSManagerList[1] := TPoolSM.Create(1, self);
  FSManagerList[2] := TPoolSM.Create(2, self);
  FSManagerList[3] := TPoolSM.Create(3, self);
  FSManagerList[4] := TPoolSM.Create(4, self);
  FSManagerList[5] := TPoolSM.Create(5, self);
  FSManagerList[6] := TPoolSM.Create(6, self);
  FSManagerList[7] := TPoolSM.Create(7, self);
  FSManagerList[8] := TPoolSM.Create(8, self);
  FSManagerList[9] := TPoolSM.Create(9, self);
  FSManagerList[10] := TPoolSM.Create(10, self);
  FSManagerList[11] := TPoolSM.Create(11, self);
  FSManagerList[12] := TPoolSM.Create(12, self);
  FSManagerList[13] := TPoolSM.Create(13, self);
  FSManagerList[14] := TPoolSM.Create(14, self);
  FSManagerList[15] := TPoolSM.Create(15, self);
  FSManagerList[16] := TPoolSM.Create(16, self);
  FSManagerList[17] := TPoolSM.Create(17, self);
  FSManagerList[18] := TPoolSM.Create(18, self);
  FSManagerList[19] := TPoolSM.Create(19, self);
  FSManagerList[20] := TPoolSM.Create(20, self);
  FSManagerList[21] := TPoolSM.Create(21, self);
  FSManagerList[22] := TPoolSM.Create(22, self);
  // Large block handler
  FSManagerList[cMaxManagers] := TPoolSM.Create(cMaxManagers, self, True);
end;

constructor TPoolSM.Create(const SMIndex: Byte; const AThreadManager: Pointer; const UniqueBlockMode: Boolean);
var
  I: Integer;
begin
  inherited Create(SMIndex, cSMIndexSizes[SMIndex], AThreadManager, UniqueBlockMode);
  //
  for I := 0 to cMaxBlockLists - 1 do
  begin
    FillChar(FBlockList[I], SizeOf(TPoolSMBlock), 0);
    FBlockList[I].List := TTopPointerList.Create(False, True); // for performance do not check for dupes in non sorted list
    //InitializeCriticalSectionAndSpinCount(FBlockList[I].Lock, 500);
    InitializeCriticalSection(FBlockList[I].Lock);
  end;
end;

constructor TSizeManagerBase.Create(const SMIndex: Byte; const AppBlockSize: Cardinal; const AThreadManager: Pointer; const UniqueBlockMode: Boolean);
begin
  inherited Create;
  FSMIndex := SMIndex;
  FAppBlockSize := AppBlockSize;
  FThreadManager := AThreadManager;
  FUniqueBlockMode := UniqueBlockMode;
end;

procedure TThreadManagerList.FreeAppBlockFromOtherThread(const Block: TOSBlock; const Loc: Pointer);
var
  TM: TThreadManager;
  PoolSM: TPoolSM;
begin
  // Make sure block is not shifting between owners
  PoolSM := TopMM.GlobalPool.GetSizeManagerByIndex(Block.SMIndex);
  PoolSM.LockList(Block.PoolID);
  try
    TM := TThreadManager(TSizeManagerBase(Block.SizeManager).FThreadManager);
    // Free directly if in Pool
    if not TM.IsPoolManager then
    begin
      TM.Lock;
      try
        Block.AddFreedByOtherThreadListBlock(Loc);
        // Also Add Block to ThreadMarkedBlockList if this was the first block added
        if Block.FreedByOtherThreadBlocks = 1 then TThreadManager(TSizeManager(Block.SizeManager).ThreadManager).DataFreedByOtherThreadInBlock(Block);
      finally
        TM.UnLock;
      end;
    end
    else
      PoolSM.SMFreeMem(Loc, Block);
  finally
    PoolSM.UnLockList(Block.PoolID);
  end;
end;

procedure TThreadManagerList.MarkAsDelphiThread(const AManager: TThreadManager);
begin
  Lock;
  try
    RemoveNonDelphiManagerFromList(AManager); // Is Delphi, so Remove
    AManager.IsDelphiThread := True;
  finally
    UnLock;
  end;
end;


//procedure TThreadManagerList.PreAllocThreadManagers;
//var
//  I: Integer;
//begin
//  Lock;
//  try
//    for I := 0 to NumberOfProcessors - 1 do FFreeManagersList.Add(TThreadManager.Create); // Create space for when it's returned
//    FFreeListStart := FFreeListStart + Integer(NumberOfProcessors);
//  finally
//    UnLock;
//  end;
//end;

destructor TPoolSM.Destroy;
var
  I, J: Integer;
begin
  for I := 0 to cMaxBlockLists - 1 do
  begin
    LockList(I);
    try
      for J := 0 to FBlockList[I].List.Count - 1 do
        TOSBlock(FBlockList[I].List[J]).Free;
    finally
      UnLockList(I);
    end;
    DeleteCriticalSection(FBlockList[I].Lock);
    FBlockList[I].List.Free;
  end;
  //
  inherited;
end;


function TPoolSM.FreeBlocks(const ListIndex: Byte; const Amount: Integer): Boolean; // Result True = Has FreeBlocks left
var
  J, BlocksFreed: Integer;
  Block: TOSBlock;
begin
  // Caller should have pool locked
  // Free [Amount] empty blocks
  BlocksFreed := 0;
  //
  for J := FBlockList[ListIndex].List.Count - 1 downto 0 do
  begin
    if BlocksFreed < Amount then
    begin
      Block := TOSBlock(FBlockList[ListIndex].List[J]);
      if Block.IsEmpty then
      begin
        // verwijder uit pool and delete
        FBlockList[ListIndex].List.DeleteByIndex(J);
        Block.Free;
        Inc(BlocksFreed);
      end;
    end else Break; // Freed enough blocks
  end;
  //
  Result := FBlockList[ListIndex].FullPoolBlocks < FBlockList[ListIndex].List.Count;
end;

procedure TPoolSM.ManagePoolSize(const AFreeAll: Boolean);
var
  I: Integer;
begin
  for I := 0 to cMaxBlockLists - 1 do
  begin
    // only lock and work if necessary
    if FBlockList[I].List.Flag then
    begin
      LockList(I);
      try
        // Free minimum amount continually present during last interval
        if AFreeAll then FBlockList[I].MinBlocks := MaxInt;
        //
        FBlockList[I].List.Flag := FreeBlocks(I, FBlockList[I].MinBlocks);
        // reset
        FBlockList[I].MinBlocks := FBlockList[I].List.Count;
      finally
        UnLockList(I);
      end;
    end;
  end;
end;

procedure TPoolSM.ProcessAppBlocksFreedFromOtherThread(const Block: TOSBlock);
var
  I: Integer;
begin
  // Walk blocks
  for I := Block.FreedByOtherThreadBlocks - 1 downto 0 do Block.AddAppblockToFreeList(Block.FreedByOtherThreadList[I]);
  //
  Block.FreedByOtherThreadBlocks := 0;
end;

procedure TPoolSM.Clear;
var I: Integer;
begin
  for I := 0 to cMaxBlockLists - 1 do
  begin
    LockList(I);
    try
      // Free all empty blocks
      FBlockList[I].List.Flag := FreeBlocks(I, MaxInt);
    finally
      UnLockList(I);
    end;
  end;
end;


procedure TPoolSM.CollectLeaks(const ALeaks: TTopSortedList);
var
  I, X: Integer;
begin
  for X := 0 to cMaxBlockLists - 1 do
  begin
    LockList(X);
    try
      for I := 0 to FBlockList[X].List.Count - 1 do
      begin
        with TOSBlock(FBlockList[X].List[I]) do
        begin
          if not IsEmpty then AddPointersOfAllAppBlocksInUse(ALeaks);
        end;
      end;
    finally
      UnLockList(X);
    end;
  end;
end;

procedure TPoolSM.SMFreeMem(const Loc: Pointer; const Block: TOSBlock);
begin
  Block.OBFreeMem(Loc);
  // no longer full, then record stat and set Flag to free block present
  if Block.FreeListStart = Block.AppBlocks - 1 then
  begin
    Dec(FBlockList[Block.PoolID].FullPoolBlocks);
    FBlockList[Block.PoolID].List.Flag := True;
  end;
end;

{procedure InitSizes;
var
  I: Integer;
begin
  cSMSizeStop[-1] := 0;
  for I := 0 to cMaxManagers - 1 do cSMSizeStop[I] := cSMIndexSizes[I] - (cSMIndexSizes[I] shr 2) - cAppBlockHeaderSize;
  cSMSizeStop[cMaxManagers] := MaxCard;
end;}


end.