rtlvcloptimize.pas

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

  {Save ebx}
  push ebx
  {Get pointers to the 4th last bytes in the strings}
  lea edx, [edx + ecx - 4]
  lea ebx, [eax + ecx - 4]
  {Negate the loop counter}
  neg ecx
  {Compare the last four bytes. If the string length is less than four bytes
   then part of the length field is compared again - no harm done.}
  mov eax, [ebx]
  cmp eax, [edx]
  jne @LStrEqual_CompareDonePop
@LStrEqual_CompareLoop:
  {Next four bytes}
  add ecx, 4
  jns @LStrEqual_Match
  {Compare four bytes per iteration}
  mov eax, [ebx + ecx]
  cmp eax, [edx + ecx]
  je @LStrEqual_CompareLoop
@LStrEqual_CompareDonePop:
  pop ebx
@LStrEqual_CompareDoneNoPop:
  ret
@LStrEqual_Match:
  {Strings match - set the zero flag}
  xor eax, eax
  pop ebx
  ret
{ --- </LStrEqual> --- }
@FirstStringNil:
  {S1 is nil - compare lengths of the strings}
  cmp eax, [edx - 4]
end;

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

{------------------------------------------------------------------------------}
 (* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The assembly implementation of function _LStrEqual is subject to the
* Mozilla Public License Version 1.1 (the "License"); you may
* not use this file except in compliance with the License.
* You may obtain a copy of the License at http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Initial Developer of the Original Code is Pierre le Riche
*
* Portions created by the Initial Developer are Copyright (C) 2002-2007
* the Initial Developer. All Rights Reserved.
*
* Contributor(s): Pierre le Riche
*
* ***** END LICENSE BLOCK ***** *)
procedure _WStrEqual;
asm
  {On entry:
     eax = @S1[1]
     edx = @S2[1]
   On exit:
     Result in flags:
       ZF = 1 if S1 = S2, ZF = 0 otherwise
   Destroys:
     eax, edx, ecx
   Code size:
     68 bytes}
  {Do S1 and S2 point to the same string data?}
  cmp eax, edx
  je @CompareDoneNoPop
  {Is one of the two string pointers perhaps nil?}
  test eax, edx
  jz @PossibleNilString
@BothStringsNonNil:
  {Compare lengths}
  mov ecx, [eax - 4]
  cmp ecx, [edx - 4]
  jne @CompareDoneNoPop
  {Save ebx}
  push ebx
  {Get pointers to the 4th last bytes in the strings}
  lea edx, [edx + ecx - 4]
  lea ebx, [eax + ecx - 4]
  {Negate the loop counter}
  neg ecx
  {Compare the last four bytes. If the string length is less than four bytes
   then part of the length field is compared again - no harm done.}
  mov eax, [ebx]
  cmp eax, [edx]
  jne @CompareDonePop
@CompareLoop:
  {Next four bytes}
  add ecx, 4
  jns @Match
  {Compare four bytes per iteration}
  mov eax, [ebx + ecx]
  cmp eax, [edx + ecx]
  je @CompareLoop
@CompareDonePop:
  pop ebx
@CompareDoneNoPop:
  ret
@Match:
  {Strings match - set the zero flag}
  xor eax, eax
  pop ebx
  ret
@PossibleNilString:
  {There is a good probability that one of the strings are nil (but not both)}
  test eax, eax
  jz @FirstStringNil
  test edx, edx
  jnz @BothStringsNonNil
  {S2 is nil - compare lengths of the strings}
  cmp [eax - 4], edx
  ret
@FirstStringNil:
  {S1 is nil - compare lengths of the strings}
  cmp eax, [edx - 4]
end;

procedure ReplaceWStrCmpByWStrEqual(var ProcAddr: TLongCall);
type
  PInlineNilCmp = ^TInlineNilCmp;
  TInlineNilCmp = packed record
    TestEaxEax: Word;
    Nops: Word;
    Nop: Byte;
  end;

var
  OldProtect: Cardinal;
  ImportEntry: PImportEntry;
begin
  ImportEntry := Pointer(Integer(@ProcAddr.NextCmd) + ProcAddr.Offset);
  if (ImportEntry = @_WStrCmp_WStrEqual) or (ImportEntry = OrgWStrCmp)  then
  begin
    { Disabled because if there is .NET code in an IDE expert that calls an
      Win32 IDE function with a non-NULL zero length WideString will cause an
      access violation in the code that meight follow the inlined "if WS = '' then" }

    {if PWord(Cardinal(@ProcAddr) - 2)^ = $D233 then // xor edx,edx
    begin // => if WS = '' then ...
      if VirtualProtectEx(CurProcess, @ProcAddr, SizeOf(ProcAddr), PAGE_EXECUTE_READWRITE, OldProtect) then
      begin
        PInlineNilCmp(@ProcAddr).TestEaxEax := $C085; // test eax,eax
        PInlineNilCmp(@ProcAddr).Nops := $9090;
        PInlineNilCmp(@ProcAddr).Nop := $90;
        VirtualProtectEx(CurProcess, @ProcAddr, SizeOf(ProcAddr), OldProtect, @OldProtect);
      end;
    end
    else}
    if VirtualProtectEx(CurProcess, @ProcAddr.Offset, SizeOf(Integer), PAGE_EXECUTE_READWRITE, OldProtect) then
    begin
      ProcAddr.Offset := Integer(@_WStrEqual) - (Integer(@ProcAddr.NextCmd));
      VirtualProtectEx(CurProcess, @ProcAddr.Offset, SizeOf(Integer), OldProtect, @OldProtect);
    end;
  end
  else
  begin
    try
      { protect against non-Delphi conform import tables }
      if //not IsBadReadPtr(ImportEntry, SizeOf(TImportEntry)) and
         (ImportEntry.Jmp = $25FF) and ((ImportEntry.Magic = $C08B) or (ImportEntry.Magic = $25FF)) then
      begin
        { Disabled because if there is .NET code in an IDE expert that calls an
          Win32 IDE function with a non-NULL zero length WideString will cause an
          access violation in the code that meight follow the inlined "if WS = '' then" }

        {if PWord(Cardinal(@ProcAddr) - 2)^ = $D233 then // xor edx,edx
        begin // => if WS = '' then ...
          if VirtualProtectEx(CurProcess, @ProcAddr, SizeOf(ProcAddr), PAGE_EXECUTE_READWRITE, OldProtect) then
          begin
            PInlineNilCmp(@ProcAddr).TestEaxEax := $C085; // test eax,eax
            PInlineNilCmp(@ProcAddr).Nops := $9090;
            PInlineNilCmp(@ProcAddr).Nop := $90;
            VirtualProtectEx(CurProcess, @ProcAddr, SizeOf(ProcAddr), OldProtect, @OldProtect);
          end;
        end
        else}
        if VirtualProtectEx(CurProcess, @ProcAddr.Offset, SizeOf(Integer), PAGE_EXECUTE_READWRITE, OldProtect) then
        begin
          ProcAddr.Offset := Integer(@_WStrEqual) - (Integer(@ProcAddr.NextCmd));
          VirtualProtectEx(CurProcess, @ProcAddr.Offset, SizeOf(Integer), OldProtect, @OldProtect);
        end;
      end;
    except
    end;
  end;
end;

{------------------------------------------------------------------------------}
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The assembly implementation of function _LStrCmp is subject to the
* Mozilla Public License Version 1.1 (the "License"); you may
* not use this file except in compliance with the License.
* You may obtain a copy of the License at http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Initial Developer of the Original Code is Pierre le Riche
*
* Portions created by the Initial Developer are Copyright (C) 2002-2007
* the Initial Developer. All Rights Reserved.
*
* Contributor(s): Pierre le Riche,
*                 Andreas Hausladen (inline function replacing)
*
* ***** END LICENSE BLOCK ***** *)
procedure _WStrCmp_WStrEqual{left: WideString; right: WideString};
asm
  // Check if this call is a candidate for _WStrEqual

  mov ecx, [esp]         { read return address }
  mov cx, WORD PTR [ecx] { read opcode at the return address }

  {cmp cl, $75 // JNZ near
  je @LStrEqual
  jg @StartCompare
  cmp cl, $74 // JZ near
  je @LStrEqual}
  add cl, $8c
  sub cl, $02
  jb @WStrEqual

  { prefixed opcodes }
  {cmp cl, $0f
  jne @StartCompare}
  add cl, $67 //=$02-$8c-$0f
  jnz @StartCompare

  {cmp ch, $95 // SETNZ al
  je @LStrEqual
  jg @StartCompare
  cmp ch, $84 // JZ far
  je @LStrEqual
  jl @StartCompare
  cmp ch, $94 // SETZ al
  je @LStrEqual
  cmp ch, $85 // JNZ far
  je @LStrEqual}
  add ch, $7c
  sub ch, $02
  jb @WStrEqual
  add ch, $f2
  sub ch, $02
  jb @WStrEqual

@StartCompare:
  {On entry:
     eax = @S1[1]
     edx = @S2[1]
   On exit:
     Result in flags:
       CF = 1 if S1 < S2, CF = 0 otherwise
       ZF = 1 if S1 = S2, ZF = 0 otherwise
   Destroys:
     eax, edx, ecx
   Code size:
     88+41 bytes}
  {Do S1 and S2 point to the same string data?}
  cmp eax, edx
  je @DoneNoPop
  {Is one of the two string pointers perhaps nil?}
  test eax, edx
  jz @PossibleNilString

@BothStringsNonNil:
  {Compare the first character. (There has to be a trailing #0, so this
   comparison is safe). In "random" string compares this can save significant
   CPU time.}
  movzx ecx, word ptr [eax]
  sub cx, [edx]
  jne @DoneNoPop
  {Save ebx}
  push ebx
  {Set ebx = length(S1)}
  mov ebx, [eax - 4]
  {Set ebx = length(S1) - length(S2)}
  sub ebx, [edx - 4]
  {Save the length difference on the stack}
  push ebx
  {Set ecx = 0 if length(S1) <= length(S2), $ffffffff otherwise}
  adc ecx, -1
  {Set ecx = - min(length(S1), length(S2))}
  and ecx, ebx
  sub ecx, [eax - 4]
  {Adjust the pointers to be negative offset based}
  sub eax, ecx
  sub edx, ecx
@CompareLoop:
  {Compare four bytes per cycle. (The start of string data is at least DWord
   aligned, so this is safe.)}
  mov ebx, [eax + ecx]
  xor ebx, [edx + ecx]
  jnz @Mismatch
  {Next four bytes}
  add ecx, 4
  js @CompareLoop
  {All characters match up to the compare length}
@MatchUpToLength:
  {Restore the string length difference to eax}
  pop eax
  {Set the flags according to the length difference}
  add eax, eax
  {Restore ebx and return}
  pop ebx
@DoneNoPop:
  ret
@Mismatch:
  {Find the byte index that mismatched}
  bsf ebx, ebx
  shr ebx, 3
  {Is the mismatch beyond the compare length?}
  add ecx, ebx
  jns @MatchUpToLength
  {Compare the mismatched byte, setting the flags}
  mov ax, [eax + ecx]
  cmp ax, [edx + ecx]
  {Pop the length difference, restore ebx and return}
  pop ebx
  pop ebx
  ret
@PossibleNilString:
  {There is a good probability that one of the strings are nil (but not both)}
  test eax, eax
  jz @FirstStringNil
  test edx, edx
  jnz @BothStringsNonNil
  {S2 is nil - compare lengths of the strings}
  cmp [eax - 4], edx
  ret

@WStrEqual:
{$IFDEF STREQUAL_INJECTION}
  push eax
  push edx
  mov eax, [esp+8]    // get caller...
  sub eax, 5          // ... and the calling opcode
  cmp BYTE PTR [eax], $E8
  jne @@CallFunction
  call ReplaceWStrCmpByWStrEqual
@@CallFunction:
  pop edx
  pop eax
{$ENDIF STREQUAL_INJECTION}
  jmp _WStrEqual

@FirstStringNil:
  {S1 is nil - compare lengths of the strings}
  cmp eax, [edx - 4]
end;

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

function FastStrScan(Str: PChar; Chr: Char): PChar;
begin
  Result := Str;
  if Result <> nil then
  begin
    while Result^ <> #0 do
    begin
      if Result^ = Chr then
        Exit;
      Inc(Result);
    end;
    if Result^ = Chr then
      Exit;
  end;
  Result := nil;
end;

{ Less CALLs by inlining the functions. }
function FastAnsiCompareText(const S1, S2: string): Integer;
type
  PStrRec = ^StrRec;
  StrRec = packed record
    refCnt: Longint;
    length: Longint;
  end;

  function InternCompare(const S1, S2: string): Integer;
  var
    Len1, Len2: Integer;
  begin
    Len1 := PStrRec(Integer(S1) - SizeOf(StrRec)).length;
    Len2 := PStrRec(Integer(S2) - SizeOf(StrRec)).length;
    Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
      Pointer(S1), Len1, Pointer(S2), Len2) - 2;
  end;

{begin
  if S1 = '' then
  begin
    if S2 = '' then
      Result := 0
    else
      Result := -1;
  end
  else
  if S2 = '' then
    Result := 1
  else
    Result := InternCompare(S1, S2);
end;}
asm
  test eax,eax
  jnz @@TestS2

  test edx,edx
  jnz @@More

@@Equal:
  xor eax, eax
  ret

@@More:
  or eax,-$01
  ret

@@TestS2:
  test edx, edx
  jnz InternCompare

@@Less:
  mov eax, 1
  ret
end;

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

function FastSameStr(const S1, S2: string): Boolean;
asm
  call _LStrEqual
  setz al
end;

function FastWideSameStr(const S1, S2: WideString): Boolean;
asm
  call _WStrEqual
  setz al
end;

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

{ WARNING: Never set a breakpoint in this function }
function FastAnsiByteType(const S: string; Index: Integer): TMbcsByteType;
begin
  Result := mbSingleByte;
end;

{ WARNING: Never set a breakpoint in this function }
function FastAnsiStrByteType(Str: PChar; Index: Cardinal): TMbcsByteType;
begin
  Result := mbSingleByte;
end;

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

function GetLStrCmp: Pointer; asm mov eax, OFFSET System.@LStrCmp; end;
function GetWStrCmp: Pointer; asm mov eax, OFFSET System.@WStrCmp; end;
{$IFNDEF COMPILER9}
function GetLStrPos: Pointer; asm mov eax, OFFSET System.@LStrPos; end;
{$ENDIF ~COMPILER9}

{------------------------------------------------------------------------------}
{ List optimization                                                            }
{------------------------------------------------------------------------------}

// FillZeroes32 (from FastObj)
//
procedure FillZeroes32(nbDWords: Integer; p: Pointer);
// fill nbDWords DWORDs with zeroes starting at p, nbDWORDS assumed > 0
asm
   push  edi
   mov   ecx, eax
   mov   edi, edx
   xor   eax, eax
   rep   stosd
   pop   edi
end;

type