rtlvcloptimize.pas

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

    if (C <> DriveDelim) and (C <> PathDelim) then
      Result := Result + PathDelim;
    Result := Result + Name;
  end;
  Result := '';
end;

{------------------------------------------------------------------------------}
var
  GetFileAttributesExFunc: function(lpFileName: PChar; fInfoLevelId: TGetFileExInfoLevels;
    lpFileInformation: Pointer): BOOL; stdcall;
  {$WARNINGS OFF} // deprecated warning
  SysUtils_FileAge: function(const FileName: string): Integer = SysUtils.FileAge;
  {$IFDEF COMPILER10_UP}
  SysUtils_FileAgeNew: function(const FileName: string; out FileDateTime: TDateTime): Boolean = SysUtils.FileAge;
  {$ENDIF COMPILER10_UP}
  {$WARNINGS ON}

function FastFileAge(const FileName: string): Integer;
var
  FindData: TWin32FileAttributeData;
  LocalFileTime: TFileTime;
begin
  if GetFileAttributesExFunc(Pointer(Filename), GetFileExInfoStandard, @FindData) then
  begin
    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
    begin
      FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
      if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo) then
        Exit;
    end;
  end;
  Result := -1;
end;

function FastFileAgeNew(const FileName: string; out FileDateTime: TDateTime): Boolean;
var
  FindData: TWin32FindData;
  LSystemTime: TSystemTime;
  LocalFileTime: TFileTime;
begin
  Result := False;
  if GetFileAttributesExFunc(Pointer(Filename), GetFileExInfoStandard, @FindData) then
  begin
    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
    begin
      Result := True;
      FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
      FileTimeToSystemTime(LocalFileTime, LSystemTime);
      with LSystemTime do
        FileDateTime := EncodeDate(wYear, wMonth, wDay) +
          EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);
    end;
  end;
end;
{$ENDIF ~DELPHI2007}

{------------------------------------------------------------------------------}
{ System optimizations                                                         }
{------------------------------------------------------------------------------}

function GetCallDynaInstAddr: Pointer; asm mov eax, OFFSET System.@CallDynaInst; end;
function GetCallDynaClassAddr: Pointer; asm mov eax, OFFSET System.@CallDynaClass; end;
function GetFindDynaInstAddr: Pointer; asm mov eax, OFFSET System.@FindDynaInst; end;
function GetFindDynaClassAddr: Pointer; asm mov eax, OFFSET System.@FindDynaClass; end;

type
  IntPtr = Integer;
  {$IFDEF COMPILER5}
  PPointerArray = ^TPointerArray;
  TPointerArray = array[0..MaxInt div SizeOf(Pointer) - 1] of Pointer;
  {$ENDIF COMPILER5}

{$IFDEF COMPILER5}
const
  RaiseLastOSError: procedure = RaiseLastWin32Error;
{$ENDIF COMPILER5}

procedure SortDMT(IndexList: PWordArray; L, R: Integer; AddrList: PPointerArray);
var
  I, J: Integer;
  P, T: Word;
  TT: Pointer;
begin
  repeat
    I := L;
    J := R;
    P := IndexList[(L + R) shr 1];
    repeat
      while IndexList[I] < P do
        Inc(I);
      while IndexList[J] > P do
        Dec(J);
      if I <= J then
      begin
        if I <> J then
        begin
          T := IndexList[I];
          IndexList[I] := IndexList[J];
          IndexList[J] := T;
          TT := AddrList[I];
          AddrList[I] := AddrList[J];
          AddrList[J] := TT;
        end;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      SortDMT(IndexList, L, J, AddrList);
    L := I;
  until I >= R;
end;

type
  PDmt = ^TDmt;
  TDmt = packed record
    Count: Word;
    IndexList: array[0..0] of Word;
    {AddressList: array[0..0] of Pointer;}
  end;
  PPDmt = ^PDmt;

function InitDMTBinSearch(DmtP: PPDmt): PDmt;
{ called only once for each DMT }
var
  Size: Cardinal;
  Count: Integer;
  P: PWord;
  NewDmt: PDmt;
  NumWritten: Cardinal;
begin
  Count := DmtP^.Count;
  Size := 2 + Count * (SizeOf(Word) + SizeOf(Pointer));
  P := GlobalAllocPtr(GMEM_FIXED, 2 + Size + 4);
  if P <> nil then
  begin
    P^ := $FACE;
    NewDmt := Pointer(IntPtr(P) + SizeOf(Word));
    Move(DmtP^^, NewDmt^, Size);
    SortDMT(@NewDmt.IndexList, 0, Count - 1, Pointer(IntPtr(@NewDmt.IndexList) + Count * SizeOf(Word)));
    if not WriteProcessMemory(GetCurrentProcess, DmtP, @NewDmt, SizeOf(Pointer), NumWritten) then
      RaiseLastOSError;
  end
  else
  begin
    NewDmt := DmtP^;
    SortDMT(@NewDmt.IndexList, 0, Count - 1, Pointer(IntPtr(@NewDmt.IndexList) + Count * SizeOf(Word)));
  end;

  Result := NewDmt;
end;

function DMTBinSearch(Index: Word; IndexList: PWordArray; Count: Integer): Integer;
{$IFDEF PUREPASCAL}
var
  L, H: Integer;
begin
  L := 0;
  H := Count - 1;
  while L <= H do
  begin
    Result := (L + H) shr 1;
    if IndexList[Result] = Index then
      Exit
    else
    if IndexList[Result] < Index then
      L := Result + 1
    else
      H := Result - 1;
  end;
  Result := -1;
end;
{$ELSE}
asm
// begin
   push esi
   push edi
// L := 0;
   xor esi,esi
// H := Count - 1;
   mov edi,ecx
   dec edi
//  while L <= H do
   cmp edi,esi
   jl @@NotFound
@@Loop:
//  Result := (L + H) shr 1;
   lea ecx,[edi+esi]
   shr ecx,1
//  if IndexList[Result] = Index then
   cmp ax,[edx+ecx*2]
   jz @@Found
//  if IndexList[Result] < Index then
   cmp ax,[edx+ecx*2] // looks like this optimizes the CPU cache
   jbe @@Greater
//  L := Result + 1
   lea esi,[ecx+$01]
//  while L <= H do
   cmp edi,esi
   jnl @@Loop
   jmp @@NotFound
@@Greater:
//  H := Result - 1;
   mov edi,ecx
   dec edi
@@Next:
//  while L <= H do
   cmp edi,esi
   jnl @@Loop
@@NotFound:
//  Result := -1;
   or ecx,-$01
@@Found:
//  end;
   mov eax,ecx
   pop edi
   pop esi
end;
{$ENDIF PUREPASCAL}

function DMTSearch(Index: Integer; DmtP: PPDmt; Count: Integer): Pointer;
var
  Idx: Integer;
  Dmt: PDmt;
begin
  Dmt := DmtP^;
  if PWord(IntPtr(Dmt) - SizeOf(Word))^ <> $FACE then
    Dmt := InitDMTBinSearch(DmtP);
  Idx := DMTBinSearch(Index, @Dmt.IndexList, Count);

  if Idx <> -1 then
    Result := PPointerArray(IntPtr(@Dmt.IndexList) + (Count * SizeOf(Word)))^[Idx]
  else
    Result := nil;
end;

{$IFDEF COMPILER6_UP} { in SI, out ESI }
procedure GetDynaMethod;
{       function        GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer;       }
asm
        { ->    EAX     vmt of class            }
        {       SI      dynamic method index    }
        { <-    ESI pointer to routine  }
        {       ZF = 0 if found         }
        {       trashes: EAX, ECX               }

        PUSH    EDI
        PUSH    EBX
        PUSH    EDX
        XCHG    EAX,ESI
        AND     EAX,$0000FFFF
        MOV     EBX,EAX
        JMP     @@haveVMT
@@outerLoop:
        MOV     ESI,[ESI]
@@haveVMT:
        LEA     EDX,[ESI].vmtDynamicTable
        MOV     EDI,[EDX]
        TEST    EDI,EDI
        JE      @@parent

        MOVZX   ECX,word ptr [EDI]
        MOV     EAX,EBX
        CMP     ECX,1
        JE      @@SingleFind
@@1:
        CALL    DMTSearch
        OR      EAX,EAX
        JNZ     @@found
@@parent:
        MOV     ESI,[ESI].vmtParent
        TEST    ESI,ESI
        JNE     @@outerLoop
        JMP     @@exit

@@SingleFind:
        MOVZX   EDX,word ptr [EDI+2]
        CMP     EAX,EDX
        JNZ     @@parent
        MOV     EAX,[EDI+4]
        TEST    EAX,EAX

@@found:
        MOV     ESI,EAX

@@exit:
        POP     EDX
        POP     EBX
        POP     EDI
end;

procedure oldOptimGetDynaMethod;
{       function        GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer;       }
asm
        { ->    EAX     vmt of class            }
        {       SI      dynamic method index    }
        { <-    ESI pointer to routine  }
        {       ZF = 0 if found         }
        {       trashes: EAX, ECX               }

        PUSH    EDI
        PUSH    EBX
        PUSH    EDX
        XCHG    EAX,ESI
        AND     EAX,$0000FFFF
        JMP     @@haveVMT
@@outerLoop:
        MOV     ESI,[ESI]
@@haveVMT:
        MOV     EDI,[ESI].vmtDynamicTable
        TEST    EDI,EDI
        JE      @@parent
        MOVZX   ECX,word ptr [EDI]
        MOV     EBX,ECX
        ADD     EDI,2
@@Loop:
        MOVZX   EDX,WORD PTR [EDI]
        DEC     ECX
        ADD     EDI,2
        CMP     EAX,EDX
        JE      @@found
        OR      ECX,ECX
        JNZ     @@Loop

@@LeaveLoop:
        MOV     ECX,EBX
@@parent:
        MOV     ESI,[ESI].vmtParent
        TEST    ESI,ESI
        JNE     @@outerLoop
        JMP     @@exit

@@found:
        MOV     EAX,EBX
        ADD     EAX,EAX
        SUB     EAX,ECX         { this will always clear the Z-flag ! }
        MOV     ESI,[EDI+EAX*2-4]

@@exit:
        POP     EDX
        POP     EBX
        POP     EDI
end;
{$ELSE} // COMPILER5 { in BX, out EBX }
procedure GetDynaMethod;
{       function        GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer;       }
asm
        { ->    EAX     vmt of class            }
        {       SI      dynamic method index    }
        { <-    ESI pointer to routine  }
        {       ZF = 0 if found         }
        {       trashes: EAX, ECX               }

        PUSH    EDI
        PUSH    ESI
        PUSH    EDX
        XCHG    EAX,EBX
        AND     EAX,$0000FFFF
        JMP     @@haveVMT
@@outerLoop:
        MOV     EBX,[EBX]
@@haveVMT:
        MOV     EDI,[EBX].vmtDynamicTable
        TEST    EDI,EDI
        JE      @@parent
        MOVZX   ECX,word ptr [EDI]
        MOV     ESI,ECX
        ADD     EDI,2
@@Loop:
        MOVZX   EDX,WORD PTR [EDI]
        DEC     ECX
        ADD     EDI,2
        CMP     EAX,EDX
        JE      @@found
        OR      ECX,ECX
        JNZ     @@Loop

@@LeaveLoop:
        MOV     ECX,ESI
@@parent:
        MOV     EBX,[EBX].vmtParent
        TEST    EBX,EBX
        JNE     @@outerLoop
        JMP     @@exit

@@found:
        MOV     EAX,ESI
        ADD     EAX,EAX
        SUB     EAX,ECX         { this will always clear the Z-flag ! }
        MOV     EBX,[EDI+EAX*2-4]

@@exit:
        POP     EDX
        POP     ESI
        POP     EDI
end;
{$ENDIF COMPILER6_UP}

function GetAddrGetDynaMethod: Pointer;
var
  P: PByteArray;
begin
  P := GetActualAddr(GetCallDynaInstAddr);
  while P[0] <> $E9 do
  begin
    if (P[0] = $E8) and (P[2] = $FF) and (P[3] = $FF) and (P[4] = $FF) then
    begin
      Result := Pointer(Integer(@P[5]) + PInteger(@P[1])^);
      Exit;
    end;
    Inc(PByte(P));
  end;
  Result := nil;
end;

procedure ReplaceAsmCall(Start: Pointer; OrgProc, NewProc: Pointer);
var
  P: PByteArray;
  OldProtect: Cardinal;
begin
  P := GetActualAddr(Start);
  OrgProc := GetActualAddr(OrgProc);
  NewProc := GetActualAddr(NewProc);
  while (P[0] <> $C2) and (P[0] <> $E9) do
  begin
    if (P[0] = $E8) then
    begin
      if Pointer(Integer(@P[5]) + PInteger(@P[1])^) = OrgProc then
      begin
        VirtualProtect(@P[1], 4, PAGE_EXECUTE_READWRITE, OldProtect);
        PInteger(@P[1])^ := Integer(NewProc) - Integer(@P[5]);
        VirtualProtect(@P[1], 4, OldProtect, OldProtect);
        FlushInstructionCache(GetCurrentProcess, @P[1], 4);
        Exit;
      end;
    end;
    Inc(PByte(P));
  end;
end;

function GetSetEqAddr: Pointer; asm mov eax, OFFSET System.@SetEq; end;

procedure _SetEq;
asm
{       FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode;   }
{       EAX     =       left operand    }
{       EDX     =       right operand   }
{       CL      =       size of set     }

        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX
        MOV     EDI,EDX

        AND     ECX,0FFH
@@Loop:
        MOVZX   EAX,WORD PTR [ESI]
        MOVZX   EDX,WORD PTR [EDI]
        DEC     ECX
        JZ      @@ByteCheck
        ADD     EDI,2
        ADD     ESI,2
        CMP     EAX,EDX
        JNE     @@Leave
        DEC     ECX
        JNZ     @@Loop
@@Leave:

        POP     EDI
        POP     ESI
        RET

@@ByteCheck:
        CMP     AL,DL
        JNE     @@Leave
        OR      ECX,ECX

        POP     EDI
        POP     ESI
        RET
end;

var
  MainModuleFilename: array[0..MAX_PATH] of Char;

function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord;
const
  LOCALE_SABBREVLANGNAME = $00000003;   { abbreviated language nam