topmanagers.pas

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

        else
          Result := TSizeManager(FSManagerList[13]);
    end else if Size <= cSMSizeStop[17] then
    begin
      if Size <= cSMSizeStop[15] then
      begin
        if Size <= cSMSizeStop[14] then
          Result := TSizeManager(FSManagerList[14])
        else
          Result := TSizeManager(FSManagerList[15]);
      end else
        if Size <= cSMSizeStop[16] then
          Result := TSizeManager(FSManagerList[16])
        else
          Result := TSizeManager(FSManagerList[17]);
    end else
      if Size <= cSMSizeStop[21] then
      begin
        if Size <= cSMSizeStop[19] then
        begin
          if Size <= cSMSizeStop[18] then
            Result := TSizeManager(FSManagerList[18])
          else
            Result := TSizeManager(FSManagerList[19]);
        end else
          if Size <= cSMSizeStop[20] then
            Result := TSizeManager(FSManagerList[20])
          else
            Result := TSizeManager(FSManagerList[21]);
      end else
        if Size <= cSMSizeStop[22] then
          Result := TSizeManager(FSManagerList[22])
        else
          result := TSizeManager(FSManagerList[cMaxManagers]);
end;


function TThreadManager.TMGetMem(const Size: Cardinal; const AZeroMemory: Boolean): Pointer;
begin
  // Check for CrossThread DeAllocations
  if MarkedBlocksPresent then FreeDataInMarkedBlocks;
{$IFDEF TOPDEBUG}
  if IsPoolManager then DebugError('GetMem from Pool is not allowed');
{$ENDIF}
  //
  Result := GetSizeManager(Size).SMGetMem(Size, AZeroMemory);
end;

function TSizeManager.AddBlock(const SpecificSize: Cardinal): Integer;
var
  OSBlock: TOSBlock;
  AppBlockSizeWanted: Integer;
  AppBlocksWanted: Integer;
begin
  // Check size for uniquemode
  if SpecificSize = 0 then
  begin
    AppBlockSizeWanted := FAppBlockSize;
    AppBlocksWanted := cBlockSizes[FSMIndex, Min(FOSBlockList.Count, cGrowLen)]; // every new block larger then the one before
  end
  else
  begin
    AppBlockSizeWanted := SpecificSize;
    AppBlocksWanted := 1;
  end;
  // Try to get block from pool
{$IFNDEF TOPDISABLEPOOL}
  if not TopMM.GlobalPool.GetBlockFromPool(FStartAt, FSMIndex, Self, OSBlock) then
{$ENDIF}
    OSBlock := TOSBlock.Create(FSMIndex, self, APPBlocksWanted, AppBlockSizeWanted, FUniqueBlockmode);
{$IFDEF TOPDEBUG}
  if OSBlock.SMindex <> FSMIndex then
    DebugError('New block has non-matching SizeManager Index');
  if OSBlock.UniqueMode <> FUniqueBlockmode then
    DebugError('New block has non-matching Uniquemode');
{$ENDIF}
  // Add Block to list
  Result := FOSBlockList.Add(OSBlock);
end;


procedure TSizeManager.Clear;
var
  PoolSizeManager: TPoolSM;
begin
  if FOSBlockList.Count > 0 then
  begin
    FreeQBuf;
    //
    // Move all OSBlocks to Pool or free them if pool is filled
    //
    // Get PoolSizeManager for blocks
    PoolSizeManager := TopMM.GlobalPool.GetSizeManagerByIndex(FSMIndex);
    //
{$IFDEF TOPDEBUG}
    if PoolSizeManager.Appblocksize <> FAppblocksize then DebugError('SM.WRPLM');
{$ENDIF}
    // Move the blocks
    PoolSizeManager.AddBlocksToPool(FOSBlockList);
    // Clear the list
    FBlockToStart := 0;
    FFullBlocks := 0;
    FOSBlockList.Clear;
  end;
end;

procedure TSizeManager.CollectLeaks(const ALeaks: TTopSortedList);
var
  I: Integer;
begin
  for I := 0 to FOSBlockList.Count - 1 do
  begin
    with TOSBlock(FOSBlockList[I]) do
    begin
      if not IsEmpty then AddPointersOfAllAppBlocksInUse(ALeaks);
    end;
  end;
end;

constructor TSizeManager.Create(const SMIndex: Byte; const AThreadManager: Pointer; const UniqueBlockMode: Boolean);
begin
  inherited Create(SMIndex, cSMIndexSizes[SMIndex], AThreadManager, UniqueBlockMode);
  FBlockToStart := 0;
  FFullBlocks := 0;
  FOSBlockList := TOSBlockList.Create(True, True); // for performance do not check dupes
  FStartAt := Byte(Random(cMaxBlockLists));
  QBuf[0].QMem := nil;
  QBuf[1].QMem := nil;
  QBuf[0].UseBuf := SMIndex < cSMIndexQBuf1;
  QBuf[1].UseBuf := SMIndex < cSMIndexQBuf2;
end;

procedure TSizeManager.FreeQbuf;
begin
  if assigned(QBuf[0].QMem) then begin SMFreeMem(QBuf[0].QMem, QBuf[0].QBlock, False); QBuf[0].QMem := nil; end;
  if assigned(QBuf[1].QMem) then begin SMFreeMem(QBuf[1].QMem, QBuf[1].QBlock, False); QBuf[1].QMem := nil; end;
end;


destructor TSizeManager.Destroy;
var
  I: Integer;
begin
  FreeQbuf;
  //
  for I := 0 to FOSBlockList.Count - 1 do FOSBlockList[I].Free;
  //
  FOSBlockList.Free;
  //
  inherited Destroy;
end;

procedure TSizeManager.RemoveBlock(const Index: Integer);
begin
{$IFDEF TOPDEBUG}
  if not (FOSBlockList.Count > 0) then
    DebugError('SizeManager has no blocks, invalid removal attempt');
{$ENDIF}
  if FOSBlockList[Index].IsFull then Dec(FFullBlocks);
  // Remove block from local list
  FOSBlockList.DeleteByIndex(Index);
  // Make sure currentblockpointer is still valid
  if (FBlockToStart >= Index) and (FBlockToStart > 0) then Dec(FBlockToStart);
end;

procedure TSizeManager.SMFreeMem(const Loc: Pointer; const Block: TOSBlock; const AQBuf: Boolean);
var
  I: Integer;
begin
{$IFDEF TOPDEBUG}
  if block = nil then DebugError('Invalid block passed to SMFreemem procedure');
{$ENDIF}
  if (not FUniqueBlockmode) then
  begin
//    if AQBuf and (Block.FreeListStart < 3) then // Do not QBuf if we can free the block
//    begin
//      I := 0;
//      if (Assigned(QBuf[0].QMem) and (QBuf[0].QBlock = Block)) then Inc(I);
//      if (Assigned(QBuf[1].QMem) and (QBuf[1].QBlock = Block)) then Inc(I);
//      if (I + 1) = Block.FreeListStart then
//      begin
//        I := 1; // Do not QBuf, free items and then the entire block
//        FreeQbuf;
//      end else I := 0;
//    end else I := 0;
    //
    if AQBuf then
    begin
      if QBuf[0].UseBuf and (not (Assigned(QBuf[0].QMem))) then
      begin
        QBuf[0].QMem := Loc;
        QBuf[0].QBlock := Block;
        Exit;
      end else if QBuf[1].UseBuf and (not (Assigned(QBuf[1].QMem))) then
      begin
        QBuf[1].QMem := Loc;
        QBuf[1].QBlock := Block;
        Exit;
      end;
    end;
  end;
  // Correct fullblockcounter
  if Block.isFull then Dec(FFullBlocks);
  // free the memory
  Block.OBFreeMem(Loc);
  // Indien blok nu leeg misschien OS memory vrijgeven of block naar Pool
  if Block.IsEmpty then
  begin
{$IFDEF TOPDEBUG}
    if not (FFullBlocks <= FOSBlockList.Count) then DebugError('FullBlocks counter is invalid #1');
    if not (FFullBlocks >= 0) then DebugError('FullBlocks counter is invalid #2');
{$ENDIF}
    // In Uniqueblockmode geven we alles terug aan OS (blokken zijn te groot om niet aan OS terug te geven) en houden we de tosblocks zelf
    if (FUniqueBlockmode) then
    begin
      Block.FreeOSBlock;
      if FOSBlockList[FBlockToStart].IsFull then FOSBlockList.Find(Block, FBlockToStart); // Move ptr to empty data if pointing to full block}
    end
    else
    begin // If not uniqueblock we move to pool.
      if FOSBlockList.Find(Block, I) then
      begin
        RemoveBlock(I);
{$IFDEF TOPDISABLEPOOL}
        Block.Free; //  free it (not using the pool)
{$ELSE}
        TopMM.FGlobalPool.AddBlockToPool(FSMIndex, Block); // Locking of pool is done inside this procedure
{$ENDIF}
      end;
    end;
  end
  else // block has free space now, move ptr if current block is full
    if FOSBlockList[FBlockToStart].IsFull then FOSBlockList.Find(Block, FBlockToStart); // Move ptr to empty data if pointing to full block
end;

function TSizeManager.SMGetMem(const Size: Cardinal; const AZeroMemory: Boolean): Pointer;
begin
  Result := nil;
  //
  if (not FUniqueBlockmode) then
  begin
    if (Assigned(QBuf[0].QMem)) then
    begin
      Result := QBuf[0].QMem;
      QBuf[0].QMem := nil;
    end else if (Assigned(QBuf[1].QMem)) then
    begin
      Result := QBuf[1].QMem;
      QBuf[1].QMem := nil;
    end;
  end;
  //
  if Assigned(Result) then
  begin
    if AZeroMemory then TopFillMemory(Pointer(Cardinal(Result) + cAppBlockHeaderSize), Size, 0);
    Exit;
  end;
  // Check if there are blocks with data available and if so find one
  if (FFullBlocks < FOSBlockList.Count) then
  begin
    // Try to get memory from one of the OSBlocks
    repeat
      // Try to allocate
      if not FOSBlockList[FBlockToStart].OBGetMem(Size, Result) then
      begin
        // check for special case where alloc is too large in unique mode
        // and must have failed because of lack of memory
        if FUniqueBlockmode and (not FOSBlockList[FBlockToStart].IsFull) then Exit;
        // If not successfull try next block
        Inc(FBlockToStart);
        if FBlockToStart = FOSBlockList.Count then FBlockToStart := 0;
      end
      else
      begin
        // Statcounters
        if FOSBlockList[FBlockToStart].IsFull then Inc(FFullBlocks);
      end;
    until (Result <> nil);
  end;
  //
  if Result = nil then
  begin
    // Allocate new OS Block for Size
    if FUniqueBlockmode then
      FBlockToStart := AddBlock(Size + cAppBlockHeaderSize + (Size shr 4)) // OverAlloc 6.5%
    else
      FBlockToStart := AddBlock;
    // Get space from fresh new block
    FOSBlockList[FBlockToStart].OBGetMem(Size, Result);
    // Statcounters
    if FOSBlockList[FBlockToStart].IsFull then
      Inc(FFullBlocks);
  end;
  //
  if AZeroMemory and (Result <> nil) and (not FOSBlockList[FBlockToStart].IsAlreadyZero) then TopFillMemory(Pointer(Cardinal(Result) + cAppBlockHeaderSize), Size, 0);
end;


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

destructor TThreadManager.Destroy;
begin
  DestroyList;
  //
  FMarkedBlockList.Free;
  FBlocksToFree.Free;
  //
  inherited Destroy;
end;

function TThreadManager.TMReallocMem(const P: Pointer; const OSBlock: TOSBlock; const Size: Cardinal): Pointer;
var
  OldSize: Cardinal;
begin
  // Check for CrossThread DeAllocations
  if MarkedBlocksPresent then FreeDataInMarkedBlocks;
{$IFDEF TOPDEBUG}
  if IsPoolManager then
    DebugError('ReAlloc should never be called inside a pool manager block');
  if not ((P <> nil) and (Size > 0)) then
    DebugError('Incorrect Re-Alloc parameters passed');
{$ENDIF}
    // only if realloc is larger then excess space a true realloc is needed.
  OLDSize := OSBlock.AppBlockSize;
  if Oldsize < Max(Size, Size + cAppBlockHeaderSize) then
  begin
    // In Uniquemode we now do a OS-ReAlloc as all Blockdata is for this allocation
    if OSBlock.UniqueMode then
    begin
      Result := TSizeManager(OSBlock.SizeManager).SMReAllocMem(Size + cAppBlockHeaderSize + (Size shr 4), OSBlock); // OverAlloc 6.5%
    end
    else
    begin // We have to move to a new block as this block is of wrong size for new alloc
      Result := TMGetMem(Size);
      if Result <> nil then
      begin
        // MemoryCopy
        TopMoveMemory(Pointer(Cardinal(Result) + cAppBlockHeaderSize), Pointer(Cardinal(P) + cAppBlockHeaderSize), OldSize - cAppBlockHeaderSize);
        TMFreeMem(P, OSBlock);
      end;
    end;
  end
  else
  begin
    if Oldsize > Max(Size, Size + cAppBlockHeaderSize) then begin
       //  In Uniquemode we now shrink the OSBlock if >50% is returned (we try in place, so no memory move)
      if OSBlock.UniqueMode then begin
        if (OldSize shr 1) > Size then
          Result := TSizeManager(OSBlock.SizeManager).SMReAllocMem(Size + cAppBlockHeaderSize, OSBlock) // No OverAlloc on shrinks
        else
          Result := P;
      end else begin
         // If new alloc is significantly smaller as original (<50%) we move the data to a smaller block (moving memory is a very expensive operation)
        if (OSBlock.AppBlockSize shr 1) >= Size then
        begin
          // Allocate new area
          Result := TMGetMem(Size);
          if Result <> nil then
          begin
            TopMoveMemory(Pointer(Cardinal(Result) + cAppBlockHeaderSize), Pointer(Cardinal(P) + cAppBlockHeaderSize), Size);
            TMFreeMem(P, OSBlock);
          end;
        end else
          Result := P;
      end;
    end else
      Result := P;
  end;
end;

procedure TThreadManager.Clear;
var
  I: Integer;
  R: Integer;
begin
  // Only call this from the context of the thread that has been given this manager
  //