rtlvcloptimize.pas

Delphi RTL-VCL optimization addon. I ve used, really good job.

  PMetaClass = ^TMetaClass;
  TMetaClass = record
    ClassType: TClass;
  end;

  TFastList = class(TObject)
  public
    FList: PPointerList;
    FCount: Integer;
    FCapacity: Integer;

    function Get(Index: Integer): Pointer;
    function IndexOf(Item: Pointer): Integer;
    procedure SetCount(NewCount: Integer);
    procedure Put(Index: Integer; Item: Pointer);
    procedure Insert(Index: Integer; Item: Pointer);
    procedure Delete(Index: Integer);
    function Last: Pointer;
    procedure Exchange(Index1, Index2: Integer);
    procedure Sort(Compare: TListSortCompare);
  end;

  {$IFDEF COMPILER7_UP}
  TMyStrings = class(TStrings)
  public
    {$IFDEF NOLEADBYTES_HOOK}
    procedure SetDelimitedText(const Value: string);
    {$ENDIF NOLEADBYTES_HOOK}
    function GetDelimitedText: string;
  end;
  {$ENDIF COMPILER7_UP}

  TFastStringList = class(TStrings)
  private
    FList: PStringItemList;
    FCount: Integer;
  public
    procedure ExchangeItems(Index1, Index2: Integer);
    procedure QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
    procedure CustomSort(Compare: TStringListSortCompare); virtual;
  end;

  TOpenList = class(TList);
  TOpenStringList = class(TStringList);
  TOpenObjectList = class(TObjectList);


{------------------------------------------------------------------------------}
function TFastList.Get(Index: Integer): Pointer;
{$IFNDEF COMPILER7}
begin
  if Cardinal(Index) < Cardinal(FCount) then
    Result := FList^[Index]
  else
  begin
    TList(Self).Error(@SListIndexError, Index);
    Result := nil;
  end;
end;
{$ELSE} // stupid Delphi 7 Update - Compiler optimization
asm
  cmp edx, [eax+$08]
  jnb @@Error
  mov eax, [eax+$04]
  mov eax, [eax+edx*4]
  ret
@@Error:
  push eax
  call GetListIndexErrorRs
  mov ecx, eax
  pop eax

  mov eax, [eax]
  xchg edx, ecx
  call TList.Error
  //xor eax, eax
  ret
end;
{$ENDIF}

{.$DEFINE PUREPASCAL}
{------------------------------------------------------------------------------}
function TFastList.IndexOf(Item: Pointer): Integer;
{$IFDEF COMPILER10_UP}
var
  LList: PPointerArray;
  LCount: Integer;
begin
  LCount := FCount;
  LList := PPointerArray(FList);
  for Result := 0 to LCount - 1 do // new optimizer doesn't use [esp] for Result
    if LList[Result] = Item then
      Exit;
  Result := -1;
end;
{$ELSE}
// inlined
asm
  // Result := InternIndexOf(PPointerArray(FList), Item, FCount);
  mov ecx, [eax+$08]
  mov eax, [eax+$04]

  push esi
  //for Result := 0 to Count - 1 do
  dec ecx
  test ecx, ecx
  jl @@LeaveNotFound
  inc ecx
  xor esi, esi
@@Next:
  //  if List[Result] = Item then
  cmp edx, [eax+esi*4]
  jz @@Leave
  //    Exit;
  inc esi
  //for Result := 0 to Count - 1 do
  dec ecx
  jnz @@Next
  // Result := -1;
@@LeaveNotFound:
  or esi, -$01
@@Leave:
  mov eax, esi
  pop esi
//  ret
end;
{$ENDIF COMPILER10_UP}

{------------------------------------------------------------------------------}

procedure TFastList.SetCount(NewCount: Integer); // based on FastObj code
var
  i: Integer;
  LCount: Integer;
begin
  LCount := FCount;
  if NewCount <> LCount then // VCL often calls List.Clear on empty lists in DoAlign
  begin
    if Cardinal(NewCount) <= Cardinal(MaxListSize) then
    begin
      if NewCount > FCapacity then
      begin
        TList(Self).Capacity := NewCount;
        FillZeroes32(NewCount - LCount, @FList^[LCount]);
      end
      else
      begin
        if NewCount > FCount then
          FillZeroes32(NewCount - LCount, @FList^[LCount])
        else
        if PMetaClass(Self).ClassType <> TList then
          for i := LCount - 1 downto NewCount do
            Delete(i);
      end;
      FCount := NewCount;
    end
    else
      TList(Self).Error(@SListCountError, newCount);
  end;
end;

{------------------------------------------------------------------------------}
procedure TFastList.Put(Index: Integer; Item: Pointer);
var
  Temp, LItem: Pointer;
  LList: PPointerList;
begin
  LItem := Item; // take Item(ecx) from [esp] into esi
  if Cardinal(Index) < Cardinal(FCount) then
  begin
    if PMetaClass(Self).ClassType = TList then
    begin
      LList := FList;
      if LItem <> LList^[Index] then
        LList^[Index] := LItem
    end
    else
    begin
      LList := FList;
      if LItem <> LList^[Index] then
      begin
        Temp := LList^[Index];
        LList^[Index] := LItem;
        if Temp <> nil then
          TOpenList(Self).Notify(Temp, lnDeleted);
        if Item <> nil then
          TOpenList(Self).Notify(LItem, lnAdded);
      end
    end;
  end
  else
    TList(Self).Error(@SListIndexError, Index);
end;

{------------------------------------------------------------------------------}
procedure TFastList.Insert(Index: Integer; Item: Pointer);
var
  Diff: Integer;
  LList: PPointerList;
begin
  if Cardinal(Index) <= Cardinal(FCount) then
  begin
    if FCount = FCapacity then
      TOpenList(Self).Grow;
    Diff := FCount - Index;
    if Diff > 0 then
    begin
      LList := FList;
      Move(LList^[Index], LList^[Index + 1], Diff * SizeOf(Pointer));
    end;
    FList^[Index] := Item;
    Inc(FCount);
    if (Item <> nil) and (PMetaClass(Self).ClassType <> TList) then
      TOpenList(Self).Notify(Item, lnAdded);
  end
  else
    TList(Self).Error(@SListIndexError, Index);
end;

{------------------------------------------------------------------------------}
procedure TFastList.Delete(Index: Integer);
var
  Temp: Pointer;
  Diff: Integer;
  LList: PPointerList;
  Item: Pointer;
begin
  if Cardinal(Index) < Cardinal(FCount) then
  begin
    LList := FList;
    Temp := LList^[Index];
    Dec(FCount);
    Diff := FCount - Index;
    if Diff > 0 then
      Move(LList^[Index + 1], LList^[Index], Diff * SizeOf(Pointer));
    Item := Temp; // why can't the compiler detect itself that some CPU registers are free 
    if (Item <> nil) and (PMetaClass(Self).ClassType <> TList) then
      TOpenList(Self).Notify(Item, lnDeleted);
  end
  else
    TList(Self).Error(@SListIndexError, Index);
end;

{------------------------------------------------------------------------------}
function TFastList.Last: Pointer;
{$IFNDEF COMPILER7}
var
  LCount: Integer;
begin
  LCount := FCount;
  if LCount > 0 then
    Result := FList^[LCount - 1]
  else
  begin
    TList(Self).Error(@SListIndexError, 0);
    Result := nil;
  end;
end;
{$ELSE} // stupid Delphi 7 Update - Compiler optimization
asm
  mov edx, [eax+$08]
  test edx, edx
  jle @@Error
  mov ecx, [eax+$04]
  mov eax, [ecx+edx*4-$04]
  ret

@@Error:
  push eax
  call GetListIndexErrorRs
  mov edx, eax
  pop eax

  mov eax, [eax]
  xor ecx, ecx
  call TList.Error
  //xor eax, eax
  ret
end;
{$ENDIF}

{------------------------------------------------------------------------------}
procedure TFastList.Exchange(Index1, Index2: Integer);
var
  Item: Pointer;
  LCount: Cardinal;
  LList: PPOinterList;
begin
  LCount := Cardinal(FCount);
  if Cardinal(Index1) < LCount then
  begin
    if Cardinal(Index2) < LCount then
    begin
      LList := FList;
      Item := LList^[Index1];
      LList^[Index1] := LList^[Index2];
      LList^[Index2] := Item;
    end
    else
      TList(Self).Error(@SListIndexError, Index2);
  end
  else
    TList(Self).Error(@SListIndexError, Index1);
end;

{------------------------------------------------------------------------------}
procedure QuickSort(SortList: PPointerList; L, R: Integer; SCompare: TListSortCompare);
var
  I, J: Integer;
  P, T: Pointer;
begin
  repeat
    I := L;
    J := R;
    P := SortList^[(L + R) shr 1];
    repeat
      while SCompare(SortList^[I], P) < 0 do
        Inc(I);
      while SCompare(SortList^[J], P) > 0 do
        Dec(J);
      if I <= J then
      begin
        if I <> J then
        begin
          T := SortList^[I];
          SortList^[I] := SortList^[J];
          SortList^[J] := T;
        end;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      QuickSort(SortList, L, J, SCompare);
    L := I;
  until I >= R;
end;

procedure TFastList.Sort(Compare: TListSortCompare);
var
  LCount: Integer;
begin
  LCount := FCount;
  if (FList <> nil) and (LCount > 1) then
    QuickSort(FList, 0, LCount - 1, Compare);
end;

{------------------------------------------------------------------------------}

{ WARNING: Never set a breakpoint in this function }
procedure TObjectList_Notify(List: TObjectList; Ptr: Pointer; Action: TListNotification);
begin
  if Action = lnDeleted then  // swap the two IFs for less memory accesses
    if List.OwnsObjects then
      if Ptr <> nil then
        TObject(Ptr).Destroy;
      //TObject(Ptr).Free;   can't be injected due to relative CALL, Destroy uses the VMT
  //inherited Notify(Ptr, Action); does nothing, so don't call it
end;

procedure TObjectList_NotifyEND;
begin
end;

{------------------------------------------------------------------------------}

procedure TFastStringList.ExchangeItems(Index1, Index2: Integer);
var
  Temp: Integer;
  Item1, Item2: PStringItem;
  List: PStringItemList;
begin
  List := FList; // remove one (object) memory access
  Item1 := @List^[Index1];
  Item2 := @List^[Index2];
  Temp := Integer(Item1^.FString);
  Integer(Item1^.FString) := Integer(Item2^.FString);
  Integer(Item2^.FString) := Temp;
  Temp := Integer(Item1^.FObject);
  Integer(Item1^.FObject) := Integer(Item2^.FObject);
  Integer(Item2^.FObject) := Temp;
end;

procedure TFastStringList.QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
var
  I, J, P: Integer;
begin
  repeat
    I := L;
    J := R;
    P := (L + R) shr 1;
    repeat
      while SCompare(TStringList(Self), I, P) < 0 do
        Inc(I);
      while SCompare(TStringList(Self), J, P) > 0 do
        Dec(J);
      if I <= J then
      begin
        if I <> J then
          ExchangeItems(I, J);
        if P = I then
          P := J
        else if P = J then
          P := I;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      QuickSort(L, J, SCompare);
    L := I;
  until I >= R;
end;

procedure TFastStringList.CustomSort(Compare: TStringListSortCompare);
begin
  with TOpenStringList(Self) do
  begin
    if not Sorted and (FCount > 1) then
    begin
      Changing;
      QuickSort(0, FCount - 1, Compare);
      Changed;
    end;
  end;
end;

{-------------------------------------------------------------------}

{$IFDEF COMPILER7_UP}

{$IFDEF NOLEADBYTES_HOOK}
{ Requires: LeadBytes = [] }
procedure TMyStrings.SetDelimitedText(const Value: string);
var
  P, P1: PChar;
  S: string;
  LStrictDelimiter: Boolean;
  LDelimiter: Char;
  QuoteCh: Char;
begin
  {$IFDEF COMPILER10_UP}
  LStrictDelimiter := StrictDelimiter;
  {$ELSE}
  LStrictDelimiter := False;
  {$ENDIF COMPILER10_UP}
  LDelimiter := Delimiter;
  QuoteCh := QuoteChar;

  BeginUpdate;
  try
    Clear;
    P := PChar(Value);
    if not LStrictDelimiter then
      while P^ in [#1..' '] do
        Inc(P);
    while P^ <> #0 do
    begin
      if P^ = QuoteCh then
        S := AnsiExtractQuotedStr(P, QuoteCh)
      else
      begin
        P1 := P;
        while ((not LStrictDelimiter and (P^ > ' ')) or
              (LStrictDelimiter and (P^ <> #0))) and (P^ <> LDelimiter) do
          Inc(P);
        SetString(S, P1, P - P1);
      end;
      Add(S);
      if not LStrictDelimiter then
        while P^ in [#1..' '] do
          Inc(P);

      if P^ = LDelimiter then
      begin
        P1 := P;
        if P1[1] = #0 then
          Add('');
        repeat
          Inc(P);
        until not (not LStrictDelimiter and (P^ in [#1..' ']));
      end;
    end;
  finally
    EndUpdate;
  end;
end;
{$ENDIF NOLEADBYTES_HOOK}

function TMyStrings.GetDelimitedText: string;
var
  S: string;