topblocks.pas

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

  begin
    // Free OSMemory in block
    if FVirtual then
      TopVirtualMemFree(RealOSBlockPointer)
    else
      TopLocalMemFree(RealOSBlockPointer);
    //
    FOSBlockPointerUnAligned := nil;
    FOSBlockPointer := nil;
  end;
end;

constructor TOSBlock.Create(const SMIndex: Byte; const SizeManager: Pointer; const AppBlocks, AppBlockSize: Cardinal; const Uniquemode: Boolean);
begin
  inherited Create;
  // Check input
{$IFDEF TOPDEBUG}
  if not (AppBlockSize > 0) then
    DebugError('AppBlockSize must be above zero');
  if not (SizeManager <> nil) then
    DebugError('SizeManager must not be nil');
{$ENDIF}
  //
  FSMIndex := SMIndex;
  FVirtual := False;
  FSizeManager := SizeManager;
  FOSBlockPointer := nil;
  FAppBlockSize := AppBlockSize;
  FPoolListID := Random(cMaxBlockLists);
  //
  FUniqueMode := Uniquemode;
  //
  if FUniqueMode then
    FAppBlocks := 1
  else
    FAppBlocks := AppBlocks;
  //
  FOSBlockSize := FAppBlocksize * FAppBlocks;
  // List for crossthread stuff
  FFreedByOtherThreadBlocks := 0;
  FFreedByOtherThreadListCapacity := 0;
  FFreedByOtherThreadList := nil;
  //
  FAppBlockList := TopLocalMemAlloc((FAppBlocks) * (SizeOf(Byte)));
  // List with Free blocks
  FFreeListStart := 0;
  TopMoveMemory(@FAppBlockList[0], @cFastIndexArray[0], FAppBlocks * SizeOf(Byte)); //for I := FFreeListStart to FAppBlocks - 1 do  FAPPBlockList[I] := I;
  // Allocate data needed
  AllocOSBlock;
end;

destructor TOSBlock.Destroy;
begin
  FreeOSBlock;
  //
  TopLocalMemFree(FAppBlockList);
  //
  if FFreedByOtherThreadList <> nil then TopLocalMemFree(FFreedByOtherThreadList);
  //
  inherited Destroy;
end;

procedure TOSBlock.CheckCapacity;
var
  FixByteMax: Integer;
begin
  // Allocate extra capacity if needed
  if FFreedByOtherThreadBlocks > FFreedByOtherThreadListCapacity then
  begin
    // We have a Byte Maximum that the generic routine does not take into account. It might allocate > 255
    FixByteMax := FFreedByOtherThreadListCapacity;
    // Enlarge data area
    FFreedByOtherThreadList := FixCapacity(Pointer(FFreedByOtherThreadList), FixByteMax, SizeOf(Byte));
    // Store new maximum capacity. Excess will not be used
    if FixByteMax >= cMaxAppBlocks then
      FFreedByOtherThreadListCapacity := cMaxAppBlocks
    else
      FFreedByOtherThreadListCapacity := FixByteMax;
  end;
end;

procedure TOSBlock.OBFreeMem(const Loc: Pointer);
begin
  // Add AppBlock to Freelist
  AddAppblockToFreeList((Cardinal(Loc) - Cardinal(FOSBlockPointer)) div Cardinal(FAppBlockSize));
  FIsAlreadyZero := False;
end;

function TOSBlock.OBGetMem(const Size: Cardinal; out Loc: Pointer): Boolean;
var
  SizeChanged: Boolean;
  OldSize: Cardinal;
begin
{$IFDEF TOPDEBUG}
  if Size > FAppBlockSize - cAppBlockHeaderSize then
    DebugError('TBL.SFA');
{$ENDIF}
  Loc := nil;
  SizeChanged := False;
  //
  // Check if there are still free appblocks available
  Result := not IsFull;
  // Indien er een blok vrij is dan pakken we dat
  if Result then
  begin
    if not IsAllocated then
    begin
      // Alloc mem
      // check if size has to be changed (if this is uniqueblockmode)
      if (Size <> FAppblocksize - cAppBlockHeaderSize) and (FUniqueMode) then
      begin
        FOSBlockSize := Max(Size, Size + cAppBlockHeaderSize);
        FAppBlockSize := Max(Size, Size + cAppBlockHeaderSize);
      end;
      AllocOSBlock;
    end
    else
    begin
      // we are allocated
      // check if size has to be changed (if this is uniqueblockmode)
      if (Size > FAppblocksize - cAppBlockHeaderSize) and (FUniqueMode) then
      begin
        OldSize := FOSBlockSize - cAppBlockHeaderSize;
        FAppBlockSize := Max(Size, Size + cAppBlockHeaderSize);
        if not ReAllocOSBlock(OldSize, Size) then
        begin
          // ReAlloc failed, new pointer will be nill, existing data is still present
          FAppBlockSize := OldSize;
          Result := False;
          Exit;
        end;
        SizeChanged := True;
      end;
    end;
    // Pointer to first free appblock within osblock and then move the listpointer to the next free block
    if IsAllocated then
    begin
      if SizeChanged then
      begin
        Loc := FOSBlockPointer;
        FFreeListStart := 1; // Fixed for Full Uniqueblocks
      end
      else
      begin
        Loc := Pointer(Cardinal(FOSBlockPointer) + Cardinal(FAppBlockList[FFreeListStart] * (FAppBlockSize)));
        Inc(FFreeListStart);
      end;
    end else
      Result := False; // alloc failed (unique mode)
  end;
{$IFDEF TOPDEBUG}
  if not ((Loc = nil) or (Cardinal(Loc) >= Cardinal(FOSBlockPointer))) then
    DebugError('Error #1 getting memory');
  if not ((Loc = nil) or (Cardinal(Loc) <= Cardinal(FOSBlockPointer) + Cardinal(OSBlockSize - FAppblocksize))) then
    DebugError('Error #2 getting memory');
{$ENDIF}
end;

function TOSBlock.ReAllocOSBlock(const OldSize, NewSize: Cardinal): Boolean;
var
  OldPointer, OldPointerUnAligned: Pointer;
  AlignDiff: Integer;
  CopySize: Cardinal;
begin
  Result := True;
  //
  OldPointer := FOSBlockPointer;
  OldPointerUnAligned := FOSBlockPointerUnAligned;
  FOSBlockSize := NewSize;
  if FVirtual then
  begin
    FOSBlockPointerUnAligned := TopVirtualMemReAlloc(RealOSBlockPointer, OldSize + Alignment - 1 + cBlockHeaderSize, FOSBlockSize + Alignment - 1 + cBlockHeaderSize);
    if assigned(FOSBlockPointerUnAligned) then FOSBlockPointerUnAligned := Pointer(Cardinal(FOSBlockPointerUnAligned) + cBlockHeaderSize);
  end
  else
  begin
    FOSBlockPointerUnAligned := TopLocalMemReAlloc(RealOSBlockPointer, FOSBlockSize + Alignment - 1 + cBlockHeaderSize, OldSize + Alignment - 1 + cBlockHeaderSize);
    if assigned(FOSBlockPointerUnAligned) then FOSBlockPointerUnAligned := Pointer(Cardinal(FOSBlockPointerUnAligned) + cBlockHeaderSize);
  end;
  // On failure return to old situation
  if FOSBlockPointerUnAligned = nil then
  begin
    Result := False;
    FOSBlockSize := OldSize;
    FOSBlockPointerUnAligned := OldPointerUnAligned; // Old memory stays if realloc failed
  end else // Inform PLL of new Situation
  begin
    FOSBlockPointer := Pointer(Cardinal(FOSBlockPointerUnAligned) + Alignment - ((Cardinal(FOSBlockPointerUnAligned) + cAppBlockHeaderSize - 1) mod Alignment) - 1);
    // Check if re-allocated memory has different alignment. If so, bad luck and we have to move the data
    AlignDiff := Integer(Cardinal(OldPointer) - Cardinal(OldPointerUnAligned)) - Integer((Cardinal(FOSBlockPointer) - Cardinal(FOSBlockPointerUnAligned)));
    if AlignDiff <> 0 then
    begin
      CopySize := OldSize;
      if NewSize < OldSize then CopySize := NewSize;
      if AlignDiff > 0 then
        TopMoveMemory(FOSBlockPointer, Pointer(Cardinal(FOSBlockPointer) + Cardinal(AlignDiff)), CopySize)
      else
        TopMoveMemory(FOSBlockPointer, Pointer(Cardinal(FOSBlockPointer) - Cardinal(-AlignDiff)), CopySize);
    end;
  end;
  // Info PLL
  if IsAllocated then SetBlockPointer;
end;


procedure TOSBlock.SetBlockPointer;
begin
  Cardinal(Pointer(Cardinal(FOSBlockPointer) - cBlockHeaderSize)^) := Cardinal(Self);
end;

function TOSBlock.AddFreedByOtherThreadListBlock(const Loc: Pointer): Boolean;
begin
  // We do not know whether the block is used and cannot peek because the thread is running
  // Only error we detect is if too many blocks have been freed
  Result := FFreedByOtherThreadBlocks < cMaxAppBlocks;
  if Result then // Add to list to be freed later by the thread
  begin
    Inc(FFreedByOtherThreadBlocks);
    CheckCapacity;
    FFreedByOtherThreadList[FFreedByOtherThreadBlocks - 1] := Cardinal(Cardinal(Loc) - Cardinal(FOSBlockPointer)) div (FAppBlockSize);
  end;
end;

procedure TOSBlock.AddPointersOfAllAppBlocksInUse(const AList: TTopsortedList);
var
  I: Integer;
  BlockList: PByteArray;
  PoolSM: TPoolSM;
begin
  // We do not have a list of Used Blocks, Only of Free Blocks. Do some looping to make it
  BlockList := TopLocalMemZeroAlloc((FAppBlocks) * (SizeOf(Byte)));
  try
    // Blocks ready to be issued are free
    for I := FreeListStart to FAppBlocks - 1 do
      BlockList[FAppBlockList[I]] := 1; // Mark as Free;
    // Blocks in the ToBeFreed List are Officialy Free. Lock and Look at them
    if FFreedByOtherThreadBlocks > 0 then
    begin
      // Make sure block is not shifting between owners
      PoolSM := TopMM.GlobalPool.GetSizeManagerByIndex(SMIndex);
      PoolSM.LockList(PoolID);
      try
        for I := 0 to FFreedByOtherThreadBlocks - 1 do
          BlockList[FFreedByOtherThreadList[I]] := 1; // Mark as Free;
      finally
        PoolSM.UnLockList(PoolID);
      end;
    end;
    // report the leaks
    for I := 0 to FAppBlocks - 1 do
      if BlockList[I] = 0 then // Check if not in the QBuf
        if not (TSizeManager(SizeManager).InQBuf(Pointer(Cardinal(Cardinal(FOSBlockPointer) + Cardinal(I) * FAppBlockSize)))) then
         AList.Add(Cardinal(Cardinal(FOSBlockPointer) + Cardinal(I) * FAppBlockSize+cAppBlockHeaderSize), Pointer(FAppBlockSize));
  finally
    TopLocalMemFree(BlockList);
  end;
end;

function TOSBlock.OBResize(const Size: Cardinal; out Loc: Pointer): Boolean;
var OldSize: Cardinal;
begin
{$IFDEF TOPDEBUG}
  if (not FUniqueMode) or (not IsFull) then
    DebugError('Resize only possible for unique mode already allocated blocks');
{$ENDIF}
  //
  OldSize := FOSBlockSize;
  FAppBlockSize := Size;
  //
  Result := ReAllocOSBlock(OldSize, Size);
  if not Result then
  begin
    // ReAlloc failed, existing data is still present
    FAppBlockSize := OldSize;
    Result := False;
  end;
  //
  Loc := FOSBlockPointer;
end;


initialization
  DetermineBlocksizes;

end.