Update delphi-detours-library

Common/delphi-detours-library/CPUID.pas

@@ -0,0 +1,279 @@
+// **************************************************************************************************
+// CPUID for Delphi.
+// Unit CPUID
+// https://github.com/MahdiSafsafi/delphi-detours-library
+
+// 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 CPUID.pas.
+//
+// The Initial Developer of the Original Code is Mahdi Safsafi [SMP3].
+// Portions created by Mahdi Safsafi . are Copyright (C) 2013-2017 Mahdi Safsafi .
+// All Rights Reserved.
+//
+// **************************************************************************************************
+
+unit CPUID;
+{$IFDEF FPC}
+{$MODE DELPHI}
+{$ENDIF FPC}
+
+interface
+
+{$I Defs.inc}
+
+uses SysUtils;
+
+type
+  { Do not change registers order ! }
+  TCPUIDStruct = packed record
+    rEAX: UInt32; { EAX Register }
+    rEBX: UInt32; { EBX Register }
+    rEDX: UInt32; { EDX Register }
+    rECX: UInt32; { ECX Register }
+  end;
+
+  PCPUIDStruct = ^TCPUIDStruct;
+
+procedure CallCPUID(const ID: NativeUInt; var CPUIDStruct: TCPUIDStruct);
+function IsCPUIDSupported: Boolean;
+
+type
+  TCPUVendor = (vUnknown, vIntel, vAMD, vNextGen);
+  TCPUEncoding = set of (REX, VEX, EVEX);
+  TCPUInstructions = set of (iMultiNop);
+
+var
+  CPUVendor: TCPUVendor;
+  CPUEncoding: TCPUEncoding;
+  CPUInsts: TCPUInstructions;
+
+implementation
+
+var
+  CPUIDSupported: Boolean = False;
+
+function ___IsCPUIDSupported: Boolean;
+asm
+  {$IFDEF CPUX86}
+  PUSH ECX
+  PUSHFD
+  POP EAX { EAX = EFLAGS }
+  MOV ECX, EAX  { Save the original EFLAGS value . }
+  {
+  CPUID is supported only if we can modify
+  bit 21 of EFLAGS register !
+   }
+  XOR EAX, $200000
+  PUSH EAX
+  POPFD { Set the new EFLAGS value }
+  PUSHFD
+  POP EAX { Read EFLAGS }
+  {
+  Check if the 21 bit was modified !
+  If so ==> Return True .
+  else  ==> Return False.
+   }
+  XOR EAX, ECX
+  SHR EAX, 21
+  AND EAX, 1
+  PUSH ECX
+  POPFD  { Restore original EFLAGS value . }
+  POP ECX
+  {$ELSE !CPUX86}
+  PUSH RCX
+  MOV RCX,RCX
+  PUSHFQ
+  POP RAX
+  MOV RCX, RAX
+  XOR RAX, $200000
+  PUSH RAX
+  POPFQ
+  PUSHFQ
+  POP RAX
+  XOR RAX, RCX
+  SHR RAX, 21
+  AND RAX, 1
+  PUSH RCX
+  POPFQ
+  POP RCX
+  {$ENDIF CPUX86}
+end;
+
+procedure ___CallCPUID(const ID: NativeInt; var CPUIDStruct);
+asm
+  {
+  ALL REGISTERS (rDX,rCX,rBX) MUST BE SAVED BEFORE
+  EXECUTING CPUID INSTRUCTION !
+   }
+  {$IFDEF CPUX86}
+  PUSH EDI
+  PUSH ECX
+  PUSH EBX
+  MOV EDI,EDX
+  CPUID
+  {$IFNDEF FPC}
+  MOV EDI.TCPUIDStruct.rEAX,EAX
+  MOV EDI.TCPUIDStruct.rEBX,EBX
+  MOV EDI.TCPUIDStruct.rECX,ECX
+  MOV EDI.TCPUIDStruct.rEDX,EDX
+  {$ELSE FPC}
+  MOV [EDI].TCPUIDStruct.rEAX,EAX
+  MOV [EDI].TCPUIDStruct.rEBX,EBX
+  MOV [EDI].TCPUIDStruct.rECX,ECX
+  MOV [EDI].TCPUIDStruct.rEDX,EDX
+  {$ENDIF !FPC}
+  POP EBX
+  POP ECX
+  POP EDI
+  {$ELSE !CPUX86}
+  PUSH R9
+  PUSH RBX
+  PUSH RDX
+  MOV RAX,RCX
+  MOV R9,RDX
+  CPUID
+  MOV R9.TCPUIDStruct.rEAX,EAX
+  MOV R9.TCPUIDStruct.rEBX,EBX
+  MOV R9.TCPUIDStruct.rECX,ECX
+  MOV R9.TCPUIDStruct.rEDX,EDX
+  POP RDX
+  POP RBX
+  POP R9
+  {$ENDIF CPUX86}
+end;
+
+function ___IsAVXSupported: Boolean;
+asm
+  {
+  Checking for AVX support requires 3 steps:
+
+  1) Detect CPUID.1:ECX.OSXSAVE[bit 27] = 1
+  => XGETBV enabled for application use
+
+  2) Detect CPUID.1:ECX.AVX[bit 28] = 1
+  => AVX instructions supported.
+
+  3) Issue XGETBV and verify that XCR0[2:1] = �11b�
+  => XMM state and YMM state are enabled by OS.
+
+   }
+
+  { Steps : 1 and 2 }
+  {$IFDEF CPUX64}
+  MOV RAX, 1
+  PUSH RCX
+  PUSH RBX
+  PUSH RDX
+  {$ELSE !CPUX64}
+  MOV EAX, 1
+  PUSH ECX
+  PUSH EBX
+  PUSH EDX
+  {$ENDIF CPUX64}
+  CPUID
+  AND ECX, $018000000
+  CMP  ECX, $018000000
+  JNE  @@NOT_SUPPORTED
+  XOR  ECX,ECX
+  {
+  Delphi does not support XGETBV !
+  => We need to use the XGETBV opcodes !
+   }
+  DB $0F DB $01 DB $D0 // XGETBV
+  { Step :3 }
+  AND EAX, $06
+  CMP  EAX, $06
+  JNE @@NOT_SUPPORTED
+  MOV EAX, 1
+  JMP @@END
+@@NOT_SUPPORTED:
+  XOR EAX,EAX
+@@END:
+  {$IFDEF CPUX64}
+  POP RDX
+  POP RBX
+  POP RCX
+  {$ELSE !CPUX64}
+  POP EDX
+  POP EBX
+  POP ECX
+  {$ENDIF CPUX64}
+end;
+
+procedure CallCPUID(const ID: NativeUInt; var CPUIDStruct: TCPUIDStruct);
+begin
+  FillChar(CPUIDStruct, SizeOf(TCPUIDStruct), #0);
+  if not CPUIDSupported then
+    raise Exception.Create('CPUID instruction not supported.')
+  else
+    ___CallCPUID(ID, CPUIDStruct);
+end;
+
+function IsCPUIDSupported: Boolean;
+begin
+  Result := CPUIDSupported;
+end;
+
+type
+  TVendorName = array [0 .. 12] of AnsiChar;
+
+function GetVendorName: TVendorName;
+var
+  Info: PCPUIDStruct;
+  P: PByte;
+begin
+  Result := '';
+  if not IsCPUIDSupported then
+    Exit;
+  Info := GetMemory(SizeOf(TCPUIDStruct));
+  CallCPUID(0, Info^);
+  P := PByte(Info) + 4; // Skip EAX !
+  Move(P^, PByte(@Result[0])^, 12);
+  FreeMemory(Info);
+end;
+
+procedure __Init__;
+var
+  vn: TVendorName;
+  Info: TCPUIDStruct;
+  r: UInt32;
+begin
+  CPUVendor := vUnknown;
+{$IFDEF CPUX64}
+  CPUEncoding := [REX];
+{$ELSE !CPUX64}
+  CPUEncoding := [];
+{$ENDIF CPUX64}
+  CPUInsts := [];
+  if IsCPUIDSupported then
+  begin
+    vn := GetVendorName();
+    if vn = 'GenuineIntel' then
+      CPUVendor := vIntel
+    else if vn = 'AuthenticAMD' then
+      CPUVendor := vAMD
+    else if vn = 'NexGenDriven' then
+      CPUVendor := vNextGen;
+    CallCPUID(1, Info);
+    r := Info.rEAX and $F00;
+    case r of
+      $F00, $600: Include(CPUInsts, iMultiNop);
+    end;
+    if ___IsAVXSupported then
+      Include(CPUEncoding, VEX);
+  end;
+end;
+
+initialization
+
+CPUIDSupported := ___IsCPUIDSupported;
+__Init__;
+
+end.

Common/delphi-detours-library/DDetours.pas

@@ -2239,7 +2239,12 @@ function TIntercept.InstallHook(TargetProc, InterceptProc: PByte; const Options:
   begin
     P := GetRoot(TargetProc);
     PDscr := CreateNewDescriptor;
-    InsertDescriptor(P, PDscr);
+    try
+      InsertDescriptor(P, PDscr);
+    except
+      FreeMem(PDscr);
+      raise;
+    end;
   end;
   Result := AddHook(PDscr, InterceptProc);
 end;

Common/delphi-detours-library/Defs.inc

@@ -0,0 +1,48 @@
+{$DEFINE UseInline}
+{$DEFINE BuildThreadSafe}
+{$DEFINE UseGenerics}
+{$DEFINE UseMultiBytesNop}
+//Define HookInternalFuncs if you want to hook internal functions used by DDL core!
+{.$DEFINE HookInternalFuncs}
+//----------------------------------------------
+{$IFDEF FPC}
+  {$IFDEF CPU64}
+    {$IFNDEF CPUX64}
+      {$DEFINE CPUX64}
+    {$ENDIF !CPUX64}
+  {$ENDIF CPU64}
+  {$ASMMODE INTEL}
+{$ENDIF FPC}
+
+{$IFNDEF CPUX64}
+  {$IFNDEF CPUX86}
+    {$DEFINE CPUX86}
+  {$ENDIF !CPUX86}
+{$ENDIF !CPUX64}
+
+{$IFDEF DEBUG}
+{$R+} // Range check On
+{$ENDIF}
+
+{$IFNDEF FPC}
+  {$IF CompilerVersion >17}
+    {$DEFINE CanInline}
+  {$IFEND}
+  {$IF CompilerVersion >=21}
+    {$DEFINE GenericsExist }
+  {$IFEND}
+  {$IF CompilerVersion >=23}
+    {$DEFINE DXE2UP }
+  {$IFEND}  
+  {$IF CompilerVersion >=24}
+    {$DEFINE DXE3UP }
+  {$IFEND}    
+{$ENDIF !FPC}
+
+{$IF DEFINED(UseInline) and DEFINED(CanInline)}
+  {$DEFINE MustInline}
+{$IFEND}
+
+{$IF DEFINED(GenericsExist) and DEFINED(UseGenerics)}
+  {$DEFINE MustUseGenerics}
+{$IFEND}