FastMM4DataCollector.pas

unit FastMM4DataCollector;

{$I FastMM4Options.inc}
{$I FastMM4CompilerDefines.inc}

interface

{$IFNDEF UNICODE}
const
  CDefaultPromoteGen1_sec  = 1; // promote every second
  CDefaultPromoteGen1Count = 1; // promote allocations with Count > 1
  CGeneration1Size = 1024;
  CGeneration2Size = 256;
  CCollectedDataSize = CGeneration2Size;
  CMaxPointers = 11; // same as in FastMM4

type
  TPointers = record
    Pointers: array [1..CMaxPointers] of Pointer;
    Count   : integer;
  end;
  TDataInfo = record
    Data : TPointers;
    Count: integer;
  end;
  TCollectedData = array [1..CCollectedDataSize] of TDataInfo;
  TGenerationOverflowCount = record
    Generation1: integer;
    Generation2: integer;
  end;

  PDataInfo = ^TDataInfo;
  TGenerationPlaceholder = array [1..1] of TDataInfo;
  PGenerationPlaceholder = ^TGenerationPlaceholder;
  TGenerationInfo = record
    Data            : PGenerationPlaceholder;
    Size            : integer;
    Last            : integer;
    NextGeneration  : integer;
    PromoteEvery_sec: integer;
    PromoteCountOver: integer;
    OverflowCount   : integer;
    LastCheck_ms    : int64;
  end;
{$ENDIF UNICODE}

type
  {$IFNDEF UNICODE}
  TStaticCollector = object
  {$ELSE}
  TStaticCollector = record
  strict private const
    CDefaultPromoteGen1_sec  = 1; // promote every second
    CDefaultPromoteGen1Count = 1; // promote allocations with Count > 1
    CGeneration1Size = 1024;
    CGeneration2Size = 256;
    CCollectedDataSize = CGeneration2Size;
    CMaxPointers = 11; // same as in FastMM4
  public type
    TPointers = record
      Pointers: array [1..CMaxPointers] of Pointer;
      Count   : integer;
      class operator Equal(const a, b: TPointers): boolean;
    end;
    TDataInfo = record
      Data : TPointers;
      Count: integer;
    end;
    TCollectedData = array [1..CCollectedDataSize] of TDataInfo;
    TGenerationOverflowCount = record
      Generation1: integer;
      Generation2: integer;
    end;
  strict private type
    PDataInfo = ^TDataInfo;
    TGenerationPlaceholder = array [1..1] of TDataInfo;
    PGenerationPlaceholder = ^TGenerationPlaceholder;
    TGenerationInfo = record
      Data            : PGenerationPlaceholder;
      Size            : integer;
      Last            : integer;
      NextGeneration  : integer;
      PromoteEvery_sec: integer;
      PromoteCountOver: integer;
      OverflowCount   : integer;
      LastCheck_ms    : int64;
    end;
  var
  {$ENDIF UNICODE}
    FGeneration1   : array [1..CGeneration1Size] of TDataInfo;
    FGeneration2   : array [1..CGeneration2Size] of TDataInfo;
    FGenerationInfo: array [0..2] of TGenerationInfo; //gen0 is used for merging
    FLocked        : ByteBool;
    FPadding       : array [1..3] of byte;
    function GetGen1_PromoteCountOver: integer;
    function GetGen1_PromoteEvery_sec: integer;
    function GetOverflowCount: TGenerationOverflowCount;
    procedure Lock;
    function Now_ms: int64; {$IFDEF XE2AndUp}inline;{$ENDIF}
    procedure SetGen1_PromoteCountOver(const value: integer);
    procedure SetGen1_PromoteEvery_sec(const value: integer);
  private
    procedure AddToGeneration(generation: integer; const aData: TPointers;
      count: integer = 1);
    procedure CheckPromoteGeneration(generation: integer); {$IFDEF XE2AndUp}inline;{$ENDIF}
    function FindInGeneration(generation: integer; const aData: TPointers): integer; {$IFDEF XE2AndUp}inline;{$ENDIF}
    function FindInsertionPoint(generation, count: integer): integer; {$IFDEF XE2AndUp}inline;{$ENDIF}
    procedure FlushAllGenerations;
    function InsertIntoGeneration(generation: integer; const dataInfo: TDataInfo): boolean;
    procedure PromoteGeneration(oldGen, newGen: integer);
    procedure ResortGeneration(generation, idxData: integer);
  public
    procedure Initialize;
    procedure Add(const pointers: pointer; count: integer);
    procedure GetData(var data: TCollectedData; var count: integer);
    procedure Merge(var mergedData: TCollectedData; var mergedCount: integer;
      const newData: TCollectedData; newCount: integer);
    property Gen1_PromoteCountOver: integer read GetGen1_PromoteCountOver
      write SetGen1_PromoteCountOver;
    property OverflowCount: TGenerationOverflowCount read GetOverflowCount;
    property Gen1_PromoteEvery_sec: integer read GetGen1_PromoteEvery_sec write
      SetGen1_PromoteEvery_sec;
  end;
  PStaticCollector = ^TStaticCollector;

implementation

uses
  Windows; //used in Now_ms

{$RANGECHECKS OFF}

type
  PByteBool = ^ByteBool;

// Copied from FastMM4.pas
function LockCmpxchg8(CompareVal, NewVal: ByteBool; AAddress: PByteBool): ByteBool;
asm
{$if SizeOf(Pointer) = 4}
  {On entry:
    al = CompareVal,
    dl = NewVal,
    ecx = AAddress}
  {$ifndef LINUX}
  lock cmpxchg [ecx], dl
  {$else}
  {Workaround for Kylix compiler bug}
  db $F0, $0F, $B0, $11
  {$endif}
{$else}
  {On entry:
    cl = CompareVal
    dl = NewVal
    r8 = AAddress}
  .noframe
  mov rax, rcx
  lock cmpxchg [r8], dl
{$ifend}
end;

{ TStaticCollector.TPointers }
{$IFDEF UNICODE}
class operator TStaticCollector.TPointers.Equal(const a, b: TPointers): boolean;
var
  i: integer;
begin
  Result := a.Count = b.Count;
  if Result then
    begin
    for i := 1 to a.Count do
      begin
      if a.Pointers[i] <> b.Pointers[i] then
        begin
        result := False;
        Exit;
        end;
      end;
    end;
end;
{$ENDIF UNICODE}

{ TStaticCollector }

procedure TStaticCollector.Add(const pointers: pointer; count: integer);
var
  ptrData: TPointers;
begin
  Lock;
  ptrData.Count := CMaxPointers;
  if count < CMaxPointers then
    ptrData.Count := count;
  Move(pointers^, ptrData.Pointers[1], ptrData.Count * SizeOf(pointer));
  AddToGeneration(1, ptrData);
  FLocked := false;
end;

procedure TStaticCollector.AddToGeneration(generation: integer; const aData: TPointers;
  count: integer = 1);
var
  dataInfo: TDataInfo;
  idxData : integer;
begin
  CheckPromoteGeneration(generation);

  with FGenerationInfo[generation] do begin
    idxData := FindInGeneration(generation, aData);
    if idxData >= 1 then begin
      Data^[idxData].Count := Data^[idxData].Count + count;
      ResortGeneration(generation, idxData);
    end
    else begin
      dataInfo.Data := aData;
      dataInfo.Count := count;
      InsertIntoGeneration(generation, dataInfo);
    end;
  end;
end; { TStaticCollector.AddToGeneration }

procedure TStaticCollector.CheckPromoteGeneration(generation: integer);
begin
  with FGenerationInfo[generation] do begin
    if NextGeneration > 0 then begin
      if LastCheck_ms = 0 then
        LastCheck_ms := Now_ms
      else if ((Now_ms - LastCheck_ms) div 1000) >= PromoteEvery_sec then begin
        PromoteGeneration(generation, NextGeneration);
        LastCheck_ms := Now_ms;
      end;
    end;
  end;
end;

function TStaticCollector.FindInGeneration(generation: integer; const aData: TPointers): integer;
var
  i : integer;
  b : Boolean;
begin
  with FGenerationInfo[generation] do
    begin
    for Result := 1 to Last do
      begin
      b := Data^[Result].Data.Count = aData.Count;
      if b then
        begin
        for i := 1 to Data^[Result].Data.Count do
          begin
          if Data^[Result].Data.Pointers[i] <> aData.Pointers[i] then
            begin
            b := False;
            break;
            end;
          end;
        end;

      if b then
        Exit;
      end;
    end;
  Result := 0;
end;

function TStaticCollector.FindInsertionPoint(generation, count: integer): integer;
var
  insert: integer;
begin
  with FGenerationInfo[generation] do begin
    for insert := Last downto 1 do begin
      if Data^[insert].Count > count then
        begin
        result := insert+1;
        Exit;
        end;
    end;
    Result := 1;
  end;
end;

procedure TStaticCollector.FlushAllGenerations;
var
  generation: integer;
  nextGen   : integer;
begin
  generation := 1;
  while generation <> 0 do begin
    nextGen := FGenerationInfo[generation].NextGeneration;
    if nextGen > 0 then
      PromoteGeneration(generation, nextGen);
    generation := nextGen;
  end;
end;

procedure TStaticCollector.GetData(var data: TCollectedData; var count: integer);
begin
  Lock;
  FlushAllGenerations;
  Assert(Length(data) = Length(FGeneration2));
  count := FGenerationInfo[2].Last;
  Move(FGeneration2[1], data[1], count * SizeOf(data[1]));
  FLocked := false;
end;

function TStaticCollector.GetGen1_PromoteCountOver: integer;
begin
  Result := FGenerationInfo[1].PromoteCountOver;
end;

function TStaticCollector.GetGen1_PromoteEvery_sec: integer;
begin
  Result := FGenerationInfo[1].PromoteEvery_sec;
end;

function TStaticCollector.GetOverflowCount: TGenerationOverflowCount;
begin
  Result.Generation1 := FGenerationInfo[1].OverflowCount;
  Result.Generation2 := FGenerationInfo[2].OverflowCount;
end;

procedure TStaticCollector.Initialize;
begin
  Assert(SizeOf(TStaticCollector) mod SizeOf(pointer) = 0);
  with FGenerationInfo[1] do begin
    Data := PGenerationPlaceholder(@FGeneration1);
    Size := CGeneration1Size;
    Last := 0;
    NextGeneration := 2;
    PromoteEvery_sec := CDefaultPromoteGen1_sec;
    PromoteCountOver := CDefaultPromoteGen1Count;
    LastCheck_ms := 0;
  end;
  with FGenerationInfo[2] do begin
    Data := PGenerationPlaceholder(@FGeneration2);
    Size := CGeneration2Size;
    NextGeneration := 0;
  end;
end;

function TStaticCollector.InsertIntoGeneration(generation: integer; const dataInfo:
  TDataInfo): boolean;
var
  idx: integer;
begin
  // We already know that this element does not exist in the generation.

  Result := true;
  with FGenerationInfo[generation] do begin
    idx := FindInsertionPoint(generation, dataInfo.Count);
    if idx > Last then begin
      if Last = Size then begin
        Inc(OverflowCount);
        Result := false;
      end
      else begin
        Inc(Last);
        Data^[Last] := dataInfo;
      end;
    end
    else begin
      if Last < Size then begin
        Move(Data^[idx], Data^[idx+1], (Last-idx+1) * SizeOf(Data^[idx]));
        Inc(Last);
      end
      else begin
        if Last > idx then
          Move(Data^[idx], Data^[idx+1], (Last-idx) * SizeOf(Data^[idx]));
        Inc(OverflowCount);
      end;
      Data^[idx] := dataInfo;
    end;
  end;
end;

procedure TStaticCollector.Lock;
begin
{$ifndef AssumeMultiThreaded}
  if IsMultiThread then
{$endif}
  begin
    while LockCmpxchg8(False, True, @FLocked) <> False do
    begin
{$ifdef NeverSleepOnThreadContention}
  {$ifdef UseSwitchToThread}
      SwitchToThread;
  {$endif}
{$else}
      {Sleep(0) gives up the rest of the time slice to another thread that is
       ready to run and returns at once when there is none, which is why the
       retry sits between it and Sleep(1). Windows XP gave way only to a thread
       of equal priority; that changed with Windows Server 2003. Sleep(1) asks
       for a millisecond, and what it waits is decided by the system clock
       resolution and by scheduling, so it can be shorter than the millisecond
       asked for as well as longer. SwitchToThread, compiled in place of both
       when NeverSleepOnThreadContention and UseSwitchToThread are defined
       together above, yields only to a thread ready on the current processor:
       the operating system will not move execution to another processor, even
       an idle one.
       The three are compared in https://stackoverflow.com/a/44875696/6910868 }
      Sleep(0);
      if LockCmpxchg8(False, True, @FLocked) = False then
        Break;
      Sleep(1);
{$endif}
    end;
  end;
end;

procedure TStaticCollector.Merge(var mergedData: TCollectedData;
  var mergedCount: integer; const newData: TCollectedData; newCount: integer);
var
  iNew: integer;
begin
  // Merges two sorted arrays.

  FGenerationInfo[0].Data := PGenerationPlaceholder(@mergedData);
  FGenerationInfo[0].Last := mergedCount;
  FGenerationInfo[0].Size := CCollectedDataSize;
  FGenerationInfo[0].NextGeneration := 0;

  for iNew := 1 to newCount do
    AddToGeneration(0, newData[iNew].Data, newData[iNew].Count);

  mergedCount := FGenerationInfo[0].Last;
end;

function TStaticCollector.Now_ms: int64;
var
  st: TSystemTime;
begin
  // We cannot use SysUtils as that gets memory allocator called before FastMM is initialized.
  GetSystemTime(st);
  SystemTimeToFileTime(st, TFileTime(Result));
  Result := Result div 10000;
end;

procedure TStaticCollector.PromoteGeneration(oldGen, newGen: integer);
var
  canInsert : boolean;
  idxNew    : integer;
  idxOld    : integer;
  newGenData: PGenerationPlaceholder;
  pOldData  : PDataInfo;
begin
  canInsert := true;
  newGenData := FGenerationInfo[newGen].Data;
  with FGenerationInfo[oldGen] do begin
    for idxOld := 1 to Last do begin
      pOldData := @Data^[idxOld];
      if pOldData^.Count <= PromoteCountOver then
        break; //for idxOld
      idxNew := FindInGeneration(newGen, pOldData^.Data);
      if idxNew > 0 then begin
        newGenData^[idxNew].Count := newGenData^[idxNew].Count + pOldData^.Count;
        ResortGeneration(newGen, idxNew);
      end
      else if canInsert then
        canInsert := InsertIntoGeneration(newGen, pOldData^)
      else with FGenerationInfo[newGen] do
        Inc(OverflowCount);
    end; //for idxOld
    Last := 0;
  end;
end;

procedure TStaticCollector.ResortGeneration(generation, idxData: integer);
var
  dataInfo: TDataInfo;
  idx     : integer;
begin
  // Data^[idxData].Count was just updated, resort the generation.
  with FGenerationInfo[generation] do begin
    idx := FindInsertionPoint(generation, Data^[idxData].Count);
    if idx < idxData then begin
      dataInfo := Data^[idxData];
      Move(Data^[idx], Data^[idx+1], (idxData-idx) * SizeOf(Data^[idx]));
      Data^[idx] := dataInfo;
    end;
  end;
end;

procedure TStaticCollector.SetGen1_PromoteCountOver(const value: integer);
begin
  FGenerationInfo[1].PromoteCountOver := value;
end;

procedure TStaticCollector.SetGen1_PromoteEvery_sec(const value: integer);
begin
  FGenerationInfo[1].PromoteEvery_sec := value;
end;

end.