topblocks.pas

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

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

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

  TopBlocks wrap OSMemory blocks

****************************************************************************************}
unit TopBlocks;

interface

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

{$DEFINE TOPALIGN}

uses
  Math,
  TopLocalObjects,
  TopSortedList,
  TopLib_CopyMemory;

const
  cMaxAppBlocks = 255;
  cBlockHeaderSize = 4;
  cAppBlockHeaderSize = 2;
  cMaxAlignment = 16;
  MaxCard = $FFFFFFFF;

const cFastIndexArray: array[0..cMaxAppBlocks - 1] of byte = (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254);


type
  TByteArray = array[0..MaxInt div (SizeOf(Byte)) - 1] of Byte;
  PByteArray = ^TByteArray;

type
  TBoolArray = array[0..MaxInt div (SizeOf(Boolean)) - 1] of Boolean;
  PBoolArray = ^TBoolArray;

type
  TOSBlock = class(TLocalObject)
  private
    FOSBlockSize: Cardinal;
    FAppBlockSize: Cardinal;
    FOSBlockPointer: Pointer;
    FOSBlockPointerUnAligned: Pointer;
    FFreeListStart: Byte;
    FSizeManager: Pointer;
    FSMIndex: Byte;
    FPoolListID: Byte;
    FAppBlockList: PByteArray;
    FAppBlocks: Byte;
    FVirtual: Boolean;
    FUniqueMode: Boolean;
    FIsAlreadyZero: Boolean;
    FFreedByOtherThreadList: PByteArray;
    FFreedByOtherThreadBlocks: Byte;
    FFreedByOtherThreadListCapacity: Byte;
    procedure SetBlockPointer; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    function Alignment: Cardinal; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    procedure AllocOSBlock;
    function ReAllocOSBlock(const OldSize, NewSize: Cardinal): Boolean;
    function RealOSBlockPointer: Pointer; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    procedure CheckCapacity;
  public
    constructor Create(const SMIndex: Byte; const SizeManager: Pointer; const AppBlocks, AppBlockSize: Cardinal; const Uniquemode: Boolean); reintroduce;
    destructor Destroy; override;
    // For Reporting
    procedure AddPointersOfAllAppBlocksInUse(const AList: TTopsortedList);
    procedure AddAppblockToFreeList(const AppBlock: Cardinal);
    function AddFreedByOtherThreadListBlock(const Loc: Pointer): Boolean;
    //
    procedure FreeOSBlock;
    //
    function OBGetMem(const Size: Cardinal; out Loc: Pointer): Boolean;
    procedure OBFreeMem(const Loc: Pointer); {$IF COMPILERVERSION>=18}inline; {$IFEND}
    function OBResize(const Size: Cardinal; out Loc: Pointer): Boolean; // Resize already allocated data
    //
    property OSBlockPointer: Pointer read FOSBlockPointer;
    property OSBlockSize: Cardinal read FOSBlockSize;
    property AppBlockSize: Cardinal read FAppBlockSize;
    property FreeListStart: Byte read FFreeListStart;
    property AppBlocks: Byte read FAppBlocks;
    //
    // List that contains appblocks freed from other threads and have to be released from our own context
    property FreedByOtherThreadList: PByteArray read FFreedByOtherThreadList;
    property FreedByOtherThreadBlocks: Byte read FFreedByOtherThreadBlocks write FFreedByOtherThreadBlocks;
    //
    property SizeManager: Pointer read FSizeManager write FSizeManager;
    property UniqueMode: Boolean read FUniqueMode;
    property SMIndex: Byte read FSMIndex;
    property PoolID: Byte read FPoolListID;
    //
    function IsEmpty: Boolean; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    function IsFull: Boolean; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    function IsAllocated: Boolean; {$IF COMPILERVERSION>=18}inline; {$IFEND}
    property IsAlreadyZero: Boolean read FIsAlreadyZero write FIsAlreadyZero; // Is the data we have zero'd?
  end;

implementation

uses
  TopManagers,
  TopLib_SSE2,
  Windows,
  TopInstall;

procedure DetermineBlocksizes;
var
  I, J, K: Integer;
  lAppBlockSize, lNewSize: Cardinal;
  lStartCount: Byte;
  lNewCount, lBest: Byte;
  lBestWaste, lWaste: Cardinal;
  lParts: Double;
begin
  for I := 0 to cMaxManagers - 1 do
  begin
    lAppBlockSize := cSMIndexSizes[I];
    lStartCount := cSMIndexStart[I];
    lParts := (cSMMaxAppBlocks[I] - lStartCount) div (cGrowLen - (cMaxManagers - I));
    cBlockSizes[I, 0] := lStartCount;
    for J := 1 to cGrowlen do
    begin
      lNewCount := Min(cSMMaxAppBlocks[I], Round(lParts * J + lStartCount));
      lNewSize := lNewCount * lAppBlockSize + cBlockHeaderSize + cMaxAlignment;
      if lNewSize >= cVirtualAbove then
      begin
        lBestWaste := MaxCard;
        lBest := lNewCount;
        for K := cBlockSizes[I, J - 1] to Min(cSMMaxAppBlocks[I], lNewCount + Trunc(lParts + 1)) do
        begin
          lNewSize := Cardinal(K) * lAppBlockSize + cBlockHeaderSize + cMaxAlignment;
          lWaste := lNewSize - ((lNewSize div cWinAllocSize) * cWinAllocSize);
          if lWaste <= lBestWaste then
          begin
            lBestWaste := lWaste;
            lBest := K;
          end;
        end;
        lNewCount := lBest;
      end;
      cBlockSizes[I, J] := lNewCount;
    end;
  end;
end;


function TOSBlock.IsEmpty: Boolean;
begin
  Result := FFreeListStart = 0;
end;

function TOSBlock.IsFull: Boolean;
begin
  Result := FFreeListStart = FAppBlocks;
end;


procedure TOSBlock.AddAppblockToFreeList(const AppBlock: Cardinal);
{$IFDEF TOPDEBUG}
var
  J: Integer;
begin
  if not (FFreeListStart > 0) then
    DebugError('TBL.AAF');
  if not (IsAllocated) then
    DebugError('Block has no OS data allocated so we should not be here trying to free it');
  if not (FFreeListStart > 0) then
    DebugError('All Data in this OS block is already free, application is probably doing double free of same pointer');
{$ELSE}
begin
{$ENDIF}
{$IFDEF TOPDEBUG}
  if not (AppBlock < FAppblocks) then
    DebugError('Pointer to free does not lie in correct range');
  for J := fFreeListStart to FAppblocks - 1 do
    if FAppBlockList[J] = AppBlock then
      DebugError('Memory passed to be freed was already freed!'); //<<- Error in application that uses TopMemory
  // Zero Memory in Debugmode
  FillChar(Pointer(Cardinal(FOSBlockPointer) + Cardinal(AppBlock) * Cardinal(FAppBlockSize))^, FAppBlockSize, 0);
{$ENDIF}
  Dec(FFreeListStart);
  FAppBlockList[FFreeListStart] := AppBlock;
end;

function TOSBlock.Alignment: Cardinal;
begin
{$IFDEF TOPALIGN}
  if FAppBlockSize > cMaxAlignment - 1 then
    Result := cMaxAlignment else
    if FAppBlockSize > 7 then
      Result := 8 else
      if FAppBlockSize > 3 then
        Result := 4
      else
        Result := 1;
{$ELSE}
  Result := 1;
{$ENDIF}
end;

function TOSBlock.RealOSBlockPointer: Pointer;
begin
  if Assigned(FOSBlockPointerUnAligned) then
    Result := Pointer(Cardinal(FOSBlockPointerUnAligned) - cBlockHeaderSize)
  else
    Result := nil;
end;

function TOSBlock.IsAllocated: Boolean;
begin
  Result := FOSBlockPointer <> nil;
end;

procedure TOSBlock.AllocOSBlock;
var
  I: Integer;
  lMark: Cardinal;
begin
{$IFDEF TOPDEBUG}
  if not (FOSBlockPointer = nil) then DebugError('TBL.ALC');
{$ENDIF}
  // Above certain size we use VirtualMemAlloc, smaller sizes use WinHeapManager
  FVirtual := FOSBlockSize > cVirtualAbove;
  // Allocate
  if FOSBlockSize < MaxCard - cBlockHeaderSize - Alignment then
  begin
    for I := 0 to 1 do
    begin
      if FVirtual then
      begin
        FOSBlockPointerUnAligned := TopVirtualMemAlloc(FOSBlockSize + Alignment - 1 + cBlockHeaderSize);
        if assigned(FOSBlockPointerUnAligned) then
        begin
          FOSBlockPointerUnAligned := Pointer(Cardinal(FOSBlockPointerUnAligned) + cBlockHeaderSize);
          FIsAlreadyZero := True; // Virtual Alloc delivers zero'd data
        end;
      end
      else
      begin
        FOSBlockPointerUnAligned := TopLocalMemAlloc(FOSBlockSize + Alignment - 1 + cBlockHeaderSize);
        if assigned(FOSBlockPointerUnAligned) then
        begin
          FOSBlockPointerUnAligned := Pointer(Cardinal(FOSBlockPointerUnAligned) + cBlockHeaderSize);
          FIsAlreadyZero := False;
        end;
      end;
      // If Alloc Fails we clear the pool and try again
      if not assigned(FOSBlockPointerUnAligned) then TopMM.GlobalPool.ClearPool else Break;
    end;
  end else FOSBlockPointerUnAligned := nil;
  //
  if FOSBlockPointerUnAligned <> nil then
  begin
    FOSBlockPointer := Pointer(Cardinal(FOSBlockPointerUnAligned) + Alignment - ((Cardinal(FOSBlockPointerUnAligned) + cAppBlockHeaderSize - 1) mod Alignment) - 1);
    SetBlockPointer;
  end
  else
    FOSBlockPointer := nil;
    // NIL result in Pointer on alloc will be raised as an exception by Delphi later
    //
  if FOSBlockPointer <> nil then
  begin
    // Mark our blockheaders
    lMark := Cardinal(FOSBlockPointer);
    for I := 0 to FAppBlocks - 1 do
    begin
      Byte(Pointer(lMark)^) := Byte(SMIndex);
      Byte(Pointer(lMark + 1)^) := Byte(I);
      lMark := lMark + FAppBlockSize;
    end;
  end;
end;

procedure TOSBlock.FreeOSBlock;
begin
{$IFDEF TOPDEBUG}
  // Normally the Block is empty when this routine is called. If not we are probably closing down and
  // this is a memory leak in the program that uses TopMM and should be fixed there.
  if not (IsEmpty) then
    DebugError('Attempt to free OS block with allocated data in it'); // <<-- Memory not yet freed by application that uses TopMemory!
{$ENDIF}
  // Release memory to OS
  if (IsAllocated) then