Tecistel/Tecsitel_FactuGES2
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
fa7e7dd3e0
Tecsitel_FactuGES2/Source/Servidor/Utiles/MidasSpeedFix.pas

421 lines
14 KiB
ObjectPascal
Raw Blame History

{$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}
{**************************************************************************************************}
{ }
{ MidasSpeedFix unit - Unoffical speed fix for Midas (Delphi/C++Builder 6 to 2009) }
{ Version 1.0 (2009-01-21) }
{ }
{ 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/ }
{ }
{ 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 Original Code is MidasSpeedFix.pas. }
{ }
{ The Initial Developer of the Original Code is Andreas Hausladen (Andreas.Hausladen@gmx.de). }
{ Portions created by Andreas Hausladen are Copyright (C) 2009 Andreas Hausladen. }
{ All Rights Reserved. }
{ }
{**************************************************************************************************}
{ History:
2009-01-21:
Initial implementation
How to use:
Add the MidasSpeedFix.pas unit to your Delphi or C++ Project (ProjectManager: Add Unit)
}
unit MidasSpeedFix;
interface
{$IFDEF CONDITIONALEXPRESSIONS}
{$IF CompilerVersion >= 15.0}
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CODE OFF}
{$WARN UNSAFE_CAST OFF}
{$IFEND}
{$ENDIF}
implementation
uses
Windows, SysUtils, DSIntf;
{------------------------------------------------------------------------------}
function MidasMalloc(Size: LongWord): Pointer; stdcall;
begin
GetMem(Result, Size);
end;
procedure MidasFree(P: Pointer); stdcall;
begin
FreeMem(P);
end;
function MidasCalloc(Count, ElementSize: LongWord): Pointer; stdcall;
begin
Result := AllocMem(Count * ElementSize);
end;
function MidasRealloc(P: Pointer; OldSize, NewSize: LongWord): Pointer; stdcall;
begin
ReallocMem(P, NewSize);
Result := P;
if (Result <> nil) and (OldSize < NewSize) then
FillChar(Pointer(PAnsiChar(Result) + OldSize)^, NewSize - OldSize, 0);
end;
{------------------------------------------------------------------------------}
{$UNDEF REQUIRE_NEW_MEMORY_MANAGER}
{$IFDEF CONDITIONALEXPRESSIONS}
{$IF CompilerVersion < 18.0} // Delphi 2006 was the first shipped with FastMM
{$DEFINE REQUIRE_NEW_MEMORY_MANAGER}
{$IFEND}
{$ELSE}
{$DEFINE REQUIRE_NEW_MEMORY_MANAGER}
{$ENDIF CONDITIONALEXPRESSIONS}
type
TJumpOfs = Integer;
PPointer = ^Pointer;
type
PXRedirCode = ^TXRedirCode;
TXRedirCode = packed record
Jump: Byte;
Offset: TJumpOfs;
end;
{ Hooking }
procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
n: DWORD;
Code: TXRedirCode;
begin
Assert(Proc <> nil);
if ReadProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n) then
begin
Code.Jump := $E9;
Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
WriteProcessMemory(GetCurrentProcess, Proc, @Code, SizeOf(Code), n);
end;
end;
procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
n: Cardinal;
begin
if (BackupCode.Jump <> 0) and (Proc <> nil) then
begin
WriteProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n);
BackupCode.Jump := 0;
end;
end;
function FindMethodPtr(Start: THandle; const Bytes: array of Smallint): Pointer;
var
P, Address, BytePtr: PAnsiChar;
MemInfo: TMemoryBasicInformation;
I: Cardinal;
FirstByte: Byte;
StartOffset, Index: Integer;
BytesLen: Integer;
Found: Boolean;
AllocBase: Pointer;
begin
Result := nil;
BytesLen := Length(Bytes);
if (Start <> 0) and (BytesLen >= 8) then
begin
StartOffset := 0;
while (StartOffset < BytesLen) and (Bytes[StartOffset] = -1) do
Inc(StartOffset);
if StartOffset = BytesLen then
Exit;
FirstByte := Byte(Bytes[StartOffset]);
try
Address := PAnsiChar(Start);
if not VirtualQuery(Address, MemInfo, SizeOf(MemInfo)) = SizeOf(MemInfo) then
Exit;
AllocBase := MemInfo.AllocationBase;
while (VirtualQuery(Address, MemInfo, SizeOf(MemInfo)) = SizeOf(MemInfo)) and
(MemInfo.AllocationBase = AllocBase) do
begin
if MemInfo.Protect and $000000F0 <> 0 then // PAGE_EXECUTE | ...
begin
P := Address;
for I := 0 to MemInfo.RegionSize - 1 do
begin
if Byte(P[0]) = FirstByte then
begin
BytePtr := P + 1;
Found := True;
for Index := StartOffset + 1 to BytesLen - 1 do
begin
if (Bytes[Index] <> -1) and (Byte(Bytes[Index]) <> Byte(BytePtr^)) then
begin
Found := False;
Break;
end;
Inc(BytePtr);
end;
if Found then
begin
Result := P;
Exit;
end;
end;
Inc(P);
end;
end;
Inc(Address, MemInfo.RegionSize);
end;
except
on E: EAccessViolation do
;
on E: EPrivilege do
;
end;
end;
end;
{------------------------------------------------------------------------------}
const
MidasMallocBytes: array[0..15] of SmallInt = (
$55, // push ebp
$8B, $EC, // mov ebp,esp
$FF, $75, $08, // push dword ptr [ebp+$08]
$E8, -1, -1, -1, -1, // call _malloc
$59, // pop ecx
$5D, // pop ebp
$C2, $04, $00 // ret $0004
);
MidasFreeBytes: array[0..20] of SmallInt = (
$55, // push ebp
$8B, $EC, // mov ebp,esp
$8B, $45, $08, // mov eax,[ebp+$08]
$85, $C0, // test eax,eax
$74, $07, // jz +$07
$50, // push eax
$E8, -1, -1, -1, -1, // call _free
$59, // pop ecx
$5D, // pop ebp
$C2, $04, $00 // ret $0004
);
MidasMallocBytesGlobal: array[0..56] of SmallInt = (
$55, // push ebp
$8B, $EC, // mov ebp,esp
$53, // push ebx
$56, // push esi
$57, // push edi
$33, $DB, // xor ebx, ebx
$66, $BE, $02, $00, // mov si, $0002
$FF, $75, $08, // push dword ptr [ebp+$08]
$0F, $BF, $C6, // movsx eax,si
$50, // push eax
$E8, -1, -1, -1, -1, // call GlobalAlloc
$8B, $F8, // mov edi,eax
$85, $C0, // test eax,eax
$74, $12, // jz +$12
$57, // push edi
$E8, -1, -1, -1, -1, // call GlobalLock
$8B, $D8, // mov ebx,eax
$85, $C0, // test eax,eax
$75, $06, // jnz +$06
$57, // push edi
$E8, -1, -1, -1, -1, // call GlobalFree
$8B, $C3, // mov eax,ebx
$5F, // pop edi
$5E, // pop esi
$5B, // pop ebx
$5D, // pop ebp
$C2, $04, $00 // ret $0004
);
MidasFreeBytesGlobal: array[0..39] of SmallInt = (
$55, // push ebp
$8B, $EC, // mov ebp,esp
$53, // push ebx
$8B, $45, $08, // mov eax,[ebp+$08]
$85, $C0, // test eax,eax
$74, $18, // jz +$18
$50, // push eax
$E8, -1, -1, -1, -1, // call GlobalHandle
$8B, $D8, // mov ebx,eax
$85, $DB, // test ebx,ebx
$74, $0C, // jz +$0c
$53, // puch ebx
$E8, -1, -1, -1, -1, // call GlobalUnlock
$53, // push ebx
$E8, -1, -1, -1, -1, // call GlobalFree
$5B, // pop ebx
$5D, // pop ebp
$C2, $04, $00 // ret $0004
);
MidasCallocBytes: array[0..43] of SmallInt = (
$55, // push ebp
$8B, $EC, // mov ebp,esp
$53, // push ebx
$56, // push esi
$8B, $75, $08, // mov esi,[ebp+$08]
$0F, $AF, $75, $0C, // imul esi,[ebp+$0c]
$56, // push esi
$E8, -1, -1, -1, -1, // call $004d2097 MidasMalloc
$8B, $D8, // mov ebx,eax
$85, $DB, // test ebx,ebx
$74, $0C, // jz +$0c
$56, // push esi
$6A, $00, // push $00
$53, // push ebx
$E8, -1, -1, -1, -1, // call _memset
$83, $C4, $0C, // add esp,$0c
$8B, $C3, // mov eax,ebx
$5E, // pop esi
$5B, // pop ebx
$5D, // pop ebp
$C2, $08, $00 // ret $0008
);
MidasReallocBytes: array[0..54] of SmallInt = (
$55, // push ebp
$8B, $EC, // mov ebp,esp
$53, // push ebx
$56, // push esi
$8B, $75, $08, // mov esi,[ebp+$08]
$FF, $75, $10, // push dword ptr [ebp+$10]
$6A, $01, // push $01
$E8, -1, -1, -1, -1, // call $004d20a7 MidasCalloc
$8B, $D8, // mov ebx,eax
$85, $DB, // test ebx,ebx
$74, $17, // jz +$17
$85, $F6, // test esi,esi
$74, $13, // jz +$13
$FF, $75, $0C, // push dword ptr [ebp+$0c]
$56, // push esi
$53, // push ebx
$E8, -1, -1, -1, -1, // call _memmove
$83, $C4, $0C, // add esp,$0c
$56, // push esi
$E8, -1, -1, -1, -1, // call $004d20d3 MidasFree
$8B, $C3, // mov eax,ebx
$5E, // pop esi
$5B, // pop ebx
$5D, // pop ebp
$C2, $0C, $00 // ret $000c
);
var
Org_MidasMalloc: Pointer;
Org_MidasFree: Pointer;
Org_MidasCalloc: Pointer;
Org_MidasRealloc: Pointer;
MidasMallocHook: TXRedirCode;
MidasFreeHook: TXRedirCode;
MidasCallocHook: TXRedirCode;
MidasReallocHook: TXRedirCode;
{$IFDEF REQUIRE_NEW_MEMORY_MANAGER}
function RequireNewerMemoryManager: Boolean;
var
MemMan: TMemoryManager;
begin
GetMemoryManager(MemMan);
if @MemMan.GetMem = @SysGetMem then
begin
MessageBox(0, 'You must install an alternative memory manager like FastMM4. FastMM4 must run in RELEASE mode to see an improved performance.',
'Delphi - Midas Speed Fix', MB_OK or MB_ICONERROR);
Result := False;
end
else
Result := True;
end;
{$ENDIF REQUIRE_NEW_MEMORY_MANAGER}
procedure Init;
var
DSBase: IDSBase;
IsCRTLMemMan: Boolean;
begin
{$IFDEF REQUIRE_NEW_MEMORY_MANAGER}
if not RequireNewerMemoryManager then
Exit;
{$ENDIF REQUIRE_NEW_MEMORY_MANAGER}
IsCRTLMemMan := True; // C RTL memory manager
Org_MidasMalloc := FindMethodPtr(HInstance, MidasMallocBytes);
if Org_MidasMalloc = nil then
begin
Org_MidasMalloc := FindMethodPtr(HInstance, MidasMallocBytesGlobal);
if Org_MidasMalloc <> nil then
IsCRTLMemMan := False;
end;
if Org_MidasMalloc = nil then
begin
CreateDbClientObject(CLSID_DSBase, IDSBase, DSBase); // load midas.dll
DSBase := nil; // release alloctated midas memory
Org_MidasMalloc := FindMethodPtr(GetModuleHandle('midas.dll'), MidasMallocBytes);
if Org_MidasMalloc = nil then
begin
Org_MidasMalloc := FindMethodPtr(HInstance, MidasMallocBytesGlobal);
if Org_MidasMalloc <> nil then
IsCRTLMemMan := False;
end;
end;
if Org_MidasMalloc = nil then
begin
OutputDebugString('Midas speed fix could not be installed.');
Exit;
end;
Assert(Org_MidasMalloc <> nil);
if IsCRTLMemMan then
Org_MidasFree := FindMethodPtr(HINST(Org_MidasMalloc), MidasFreeBytes)
else
Org_MidasFree := FindMethodPtr(HINST(Org_MidasMalloc), MidasFreeBytesGlobal);
Org_MidasCalloc := FindMethodPtr(HINST(Org_MidasMalloc), MidasCallocBytes);
Org_MidasRealloc := FindMethodPtr(HINST(Org_MidasMalloc), MidasReallocBytes);
Assert(Org_MidasFree <> nil);
Assert(Org_MidasCalloc <> nil);
Assert(Org_MidasRealloc <> nil);
HookProc(Org_MidasMalloc, @MidasMalloc, MidasMallocHook);
HookProc(Org_MidasFree, @MidasFree, MidasFreeHook);
HookProc(Org_MidasCalloc, @MidasCalloc, MidasCallocHook);
HookProc(Org_MidasRealloc, @MidasRealloc, MidasReallocHook);
end;
procedure Fini;
begin
UnhookProc(Org_MidasMalloc, MidasMallocHook);
UnhookProc(Org_MidasFree, MidasFreeHook);
UnhookProc(Org_MidasCalloc, MidasCallocHook);
UnhookProc(Org_MidasRealloc, MidasReallocHook);
end;
initialization
Init;
finalization
Fini;
end.
Reference in New Issue View Git Blame Copy Permalink