rtlvcloptimize.pas

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

{-----------------------------------------------------------------------------
The contents of this file are 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/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: RtlVclOptimize.pas, released on 2007-05-08

The Initial Developer of the Original Code is Andreas Hausladen
Portions created by Andreas Hausladen are Copyright (C) 2006, 2007 Andreas Hausladen.
All Rights Reserved.

Contributor(s): -

Version 2.7 (2007-10-01)

Known Issues:
-----------------------------------------------------------------------------}
{$A+,B-,C+,D-,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W+,X+,Y+,Z1}

unit RtlVclOptimize;

{.$DEFINE WMPAINT_HOOK}
  { If WMPAINT_HOOK is defined the TWinControl.WMPaint message handler for
    Delphi 6, 7, 2005 and 2006 is overwritten by a version that takes less
    time and which is also used in the Delphi 2007 VCL by default. }

{.$DEFINE STREQUAL_INJECTION}
  { If STREQUAL_INJECTION is defined the _LStrCmp/_WStrCmp call is replaced
    by a call to _LStrEqual/_WStrEqual when the next opcode is a
    JZ/JNZ/SETZ/SETNZ. So every "if Str1 = Str2 then" and "if Str <> Str2 then"
    will call _LStrEqual/_WStrEqual directly on the next iteration. }

{.$DEFINE NOLEADBYTES_HOOK}
  { If NOLEADBYTES_HOOK is defined and SysLocal.LeadBytes is [], some ANSI
    functions are replaced by faster functions that ignore the LeadBytes. }

{.$DEFINE RTLDEBUG}
  { If RTLDEBUG is defined the unit is compiled with debug information. }

interface

{$IFDEF CONDITIONALEXPRESSIONS}
 {$DEFINE COMPILER6_UP}
 {$IF RtlVersion >= 15.0}
  {$DEFINE COMPILER7_UP}
 {$IFEND}
 {$IF RtlVersion >= 17.0}
  {$DEFINE COMPILER9_UP}
  {$IF RtlVersion = 17.0}
   {$DEFINE COMPILER9}
  {$IFEND}
 {$IFEND}
 {$IF RtlVersion >= 18.0}
  {$DEFINE COMPILER10_UP}
 {$IFEND}
 {$IF CompilerVersion >= 18.5}
  {$DEFINE DELPHI2007_UP}
 {$IFEND}
{$ELSE} // Delphi 5 or below
 {$IFDEF VER130}
  {$DEFINE COMPILER5}
  {$DEFINE COMPILER5_UP}
 {$ELSE}
  This_compiler_version_is_not_supported
 {$ENDIF}
{$ENDIF}

{$IFDEF COMPILER7_UP}
 {$WARN UNSAFE_TYPE OFF}
 {$WARN UNSAFE_CODE OFF}
 {$WARN UNSAFE_CAST OFF}
{$ENDIF COMPILER7_UP}

{$IFDEF RTLDEBUG}
 {$D+}
{$ENDIF RTLDEBUG}

implementation

uses
  Windows, Messages, SysUtils, Classes, Contnrs, TypInfo,
  {$IFDEF COMPILER6_UP} RtlConsts {$ELSE} Consts {$ENDIF},
  Controls;

{$IFDEF NOLEADBYTES_HOOK}
var
  NoLeadBytes: Boolean;
{$ENDIF NOLEADBYTES_HOOK}

const
  CurProcess = Cardinal(-1); // GetCurrentProcess returns EAX = DWORD(-1)

{------------------------------------------------------------------------------}
{ Memory manipulation functions                                                }
{------------------------------------------------------------------------------}
type
  TInjectRec = packed record
    Jump: Byte;
    Offset: Integer;
  end;

  PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
  TAbsoluteIndirectJmp = packed record
    OpCode: Word;   //$FF25
    Addr: ^Pointer;
  end;

  PWin9xDebugThunk = ^TWin9xDebugThunk;
  TWin9xDebugThunk = packed record
    PUSH: Byte;    // $68
    Addr: Pointer;
    JMP: Byte;     // $E9
    Offset: Integer;
  end;

  TLongCall = packed record
    Call: Byte;
    Offset: Integer;
    NextCmd: record end;
  end;

  PPointer = ^Pointer;

  PImportEntry = ^TImportEntry;
  TImportEntry = packed record
    Jmp: Word;
    Destination: PPointer;
    Magic: Word;
  end;

function IsWin9xDebugThunk(Addr: Pointer): Boolean;
begin
  Result := (Addr <> nil) and (PWin9xDebugThunk(Addr).PUSH = $68) and
                              (PWin9xDebugThunk(Addr).JMP = $E9);
end;

function GetActualAddr(Proc: Pointer): Pointer;
begin
  if Proc <> nil then
  begin
    if (SysUtils.Win32Platform <> VER_PLATFORM_WIN32_NT) and IsWin9xDebugThunk(Proc) then
      Proc := PWin9xDebugThunk(Proc).Addr;
    if (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
      Result := PAbsoluteIndirectJmp(Proc).Addr^
    else
      Result := Proc;
  end
  else
    Result := nil;
end;

procedure CodeRedirect(Proc: Pointer; NewProc: Pointer);
var
  OldProtect: Cardinal;
begin
  if Proc = nil then
    Exit;
  Proc := GetActualAddr(Proc);
  if VirtualProtectEx(GetCurrentProcess, Proc, SizeOf(TInjectRec), PAGE_EXECUTE_READWRITE, OldProtect) then
  begin
    TInjectRec(Proc^).Jump := $E9;
    TInjectRec(Proc^).Offset := Integer(NewProc) - (Integer(Proc) + SizeOf(TInjectRec));
    VirtualProtectEx(GetCurrentProcess, Proc, SizeOf(TInjectRec), OldProtect, @OldProtect);
  end;
end;

function InjectCode(DestProc, SourceProc: Pointer; Size: Cardinal): Boolean;
var
  n: Cardinal;
begin
  DestProc := GetActualAddr(DestProc);
  Result := (DestProc <> nil) and (SourceProc <> nil) and
            WriteProcessMemory(GetCurrentProcess, DestProc, SourceProc, Size, n) and (n = Size);
end;

function GetDynamicMethod(AClass: TClass; Index: Integer): Pointer;
asm
  CALL System.@FindDynaClass
end;
{------------------------------------------------------------------------------}

{------------------------------------------------------------------------------}
{ Long/Wide-String optimization                                                }
{------------------------------------------------------------------------------}
var
  OrgLStrCmp: Pointer;
  OrgWStrCmp: Pointer;

procedure _LStrCmp_LStrEqual{left: AnsiString; right: AnsiString}; forward;
procedure _WStrCmp_WStrEqual{left: WideString; right: WideString}; forward;

{------------------------------------------------------------------------------}
 (* ***** 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 _LStrEqual;
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 ReplaceLStrCmpByLStrEqual(var ProcAddr: TLongCall);
var
  OldProtect: Cardinal;
  ImportEntry: PImportEntry;
begin
  ImportEntry := Pointer(Integer(@ProcAddr.NextCmd) + ProcAddr.Offset);
  if (ImportEntry = @_LStrCmp_LStrEqual) or (ImportEntry = OrgLStrCmp) then
  begin
    if VirtualProtectEx(CurProcess, @ProcAddr.Offset, SizeOf(Integer), PAGE_EXECUTE_READWRITE, OldProtect) then
    begin
      ProcAddr.Offset := Integer(@_LStrEqual) - (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
        if VirtualProtectEx(CurProcess, @ProcAddr.Offset, SizeOf(Integer), PAGE_EXECUTE_READWRITE, OldProtect) then
        begin
          ProcAddr.Offset := Integer(@_LStrEqual) - (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 _LStrCmp_LStrEqual{left: AnsiString; right: AnsiString};
asm
  {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:
  // can _LStrEqual be used
  mov ecx, [esp] // read return address
  mov cx, WORD PTR [ecx] // read first byte 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 @LStrEqual

  // prefix 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 @LStrEqual
  add ch, $f2
  sub ch, $02
  jb @LStrEqual

@StartCompare:
  {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, byte ptr [eax]
  sub cl, [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 al, [eax + ecx]
  cmp al, [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
{ --- <LStrEqual> --- }
@LStrEqual:
{$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 ReplaceLStrCmpByLStrEqual
@@CallFunction:
  pop edx
  pop eax
{$ENDIF STREQUAL_INJECTION}
  {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:
     xx bytes}

  {Compare lengths}
  mov ecx, [eax - 4]
  cmp ecx, [edx - 4]
  jne @LStrEqual_CompareDoneNoPop