WebSVN – decoder – /trunk/VCL_DEC/CPU.pas

{Copyright: Hagen Reddmann HaReddmann at T-Online dot de
Author: Hagen Reddmann
Remarks: Public Domain, this Copyright must be included
known Problems: none
Version: 5.1, Delphi Encryption Compendium
Delphi 2-7, BCB 3-4, designed and testet under D3-7
Description: CPU Detection, single Unit
Remarks:
- codesizes 503 (CPUType)
1003 (CPUType, CPUSpeed)
5035 (CPUType, CPUSpeed, CPUVendor) bytes
- datasize (BSS) 142 bytes
- datasize (DATA) 100 bytes if CPUVendor is used
minimal 645 bytes in EXE
}
unit CPU;
interface
type
{CPU Detection}
TCPUData = packed record
Typ: Byte;
Family: Byte;
Model: Byte;
Stepping: Byte;
Signature: Cardinal; // encoded Typ/Family/Model/Stepping
Features_EDX: Cardinal; // Features
Features_EBX: Cardinal;
Features_ECX: Cardinal;
FeaturesEx_EDX: Cardinal; // extended Features AMD/Cyrix
FeaturesEx_EBX: Cardinal;
FeaturesEx_ECX: Cardinal;
Vendor: array[0..12] of Char; // inculdes trailing #0
VendorEx: array[0..64] of Char; // " "
CPUID3: array[0..4] of Cardinal;
VendorID: Cardinal;
TLB_EAX: Cardinal; // Cache and TLB Infos, see Intel Docus
TLB_EDX: Cardinal;
TLB_EBX: Cardinal;
TLB_ECX: Cardinal;
end;
const
// CPU Family codes
cf386 = 3;
cf486 = 4;
cfPentium = 5;
cfPentiumPro = 6;
// CPU Types
ctOEM = 0;
ctOverdrive = 1;
ctDual = 2;
// Vendor codes
cvIntel = $506E7F40; // CRC('GenuineIntel'); Intel
cvAMD = $454D5A47; // CRC('AuthenticAMD'); AMD
cvCyrix = $7E7D554F; // CRC('CyrixInstead'); Cyrix
cvUMC = $20434D55; // CRC('UMC UMC UMC '); UMC
cvNexGen = $5B597D42; // CRC('NexGenDriven'); NexGen
cvCentaur = $4F706543; // CRC('CentaurHauls'); Centaur/IDT
cvRise = $65736952; // CRC('RiseRiseRise'); Rise Technology
cvTransmeta = $17337363; // CRC('GenuineTMx86'); Transmeta
// CPU Features
ffFPU = $00000001; // Floating Point Unit on Chip
ffVME = $00000002; // Virtual 8086 Mode Enhancements
ffDE = $00000004; // Debugging Extensions
ffPSE = $00000008; // Page Size Extensions
ffTSC = $00000010; // Time Stamp Counter, supports RDTSC Instruction
ffMSR = $00000020; // Model Specific Registers, supports RDMSR Instruction
ffPAE = $00000040; // Physical Address Extension
ffMCE = $00000080; // Machine Check Exception
ffCX8 = $00000100; // CMPXCHG Instruction supported
ffAPIC = $00000200; // Advanced Programmable Interrupt Controller
// ffRes1 = $00000400;
ffSEP = $00000800; // Fast System Call, SYSENTER and SYSEXIT Instruction
ffMTRR = $00001000; // Memory Type Range Registers
ffPGE = $00002000; // Global Flag Processor supported
ffMCA = $00004000; // Machine Check Architecture
ffCMOV = $00008000; // CMOV/FCOMI Instructions supported
ffFGPAT = $00010000; // Page Attribute Table, CMOVcc supported
ffPSE36 = $00020000; // PSE-3636-bit Page Size Extension
ffPN = $00040000; // PNProcessor Number, supports the 96-bit PN feature
ffCLFSH = $00080000; // CLFLUSH intsturction supported
// ffRes2 = $00100000;
ffDS = $00200000; // Debug Store supported
ffACPI = $00400000; // Thermal Monitor and Software Controlled Clock Features
ffMMX = $00800000; // MMX instruction set
ffFXSR = $01000000; // Fast FP/MMX Technology/Streaming SIMD Extensions
ffSSE = $02000000; // Streaming SIMD Extensions Instruction set
ffSSE2 = $04000000; // Streaming SIMD Extensions Instruction set 2
ffSS = $08000000; // Self-Snoop supported
ffHTT = $10000000; // Hyper-Threading Technology
ffTM = $20000000; // Thermal control circuit TCC supported
ffIA64 = $40000000; // IA-64 architecture
// ffRes5 = $80000000;
function CPUType: Integer; {any cfXXXX Value}
function CPUData: TCPUData;
function CPUVendor: String;
function CPUSpeedRaw(Delay: Cardinal): Comp;
function CPUSpeed: Cardinal;
function PerfCounter: Comp;
function PerfFreq: Comp;
function RDTSC: Int64;
implementation
uses Windows, SysUtils;
resourcestring
sCPU_Unknown = '%s P%d Model %d';
sCPU_Dual = ' (Dual Processor)';
sCPU_Model = ' Model ';
sCPU_Compatible = ' (compatible)';
var
FCPU: TCPUData;
function QPC(var C: Comp): Bool; stdcall; external 'kernel32.dll' name 'QueryPerformanceCounter';
function QPF(var F: Comp): Bool; stdcall; external 'kernel32.dll' name 'QueryPerformanceFrequency';
function PerfCounter: Comp;
begin
if not QPC(Result) then Result := GetTickCount
end;
function PerfFreq: Comp;
begin
if not QPF(Result) then Result := 1000
end;
function RDTSC: Int64;
asm
DW 0310Fh
end;
{CPU Routines}
function CPUType: Integer;
begin
Result := FCPU.Family;
end;
function CPUSpeedRaw(Delay: Cardinal): Comp;
var
C: Comp;
D: Double;
begin
Result := 0;
if FCPU.Features_EDX and ffTSC <> 0 then
try // except Block needed, RDTSC can be a privilege Instruction !! but should never
if Delay <= 0 then Delay := 10;
D := PerfCounter; // API QueryPerformanceCounter() based on a virtual 1.19318 MHz CPU
asm
PUSHAD
DW 0310Fh // RDTSC, read Time Stamp Counter into C
MOV C.DWord[0],EAX // RDTSC is an CPU Clock based value
MOV C.DWord[4],EDX // incremented on ONE CPU Clock.
POPAD
end;
Inc(Delay, GetTickCount);
while GetTickCount < Delay do ;
asm
PUSHAD
DW 0310Fh // C := RDTSC - C
SUB EAX,C.DWord[0]
SBB EDX,C.DWord[4]
ADD EAX,5000 // subtract ~Cycles of follow API call
ADC EDX,0
MOV C.DWord[0],EAX
MOV C.DWord[4],EDX
POPAD
end;
D := PerfCounter - D;
Result := C * PerfFreq / D;
except
end;
end;
function CPUSpeed: Cardinal;
// returns corrected speed
{$J+}
const
FSpeed: Cardinal = 0;
{$J-}
FS1: array[0..47] of Word = (
0, 25, 33, 60, 66, 75, 82, 90,
100, 110, 116, 120, 133, 150, 166, 180,
188, 200, 225, 233, 266, 300, 333, 350,
366, 400, 415, 433, 450, 466, 500, 533,
550, 600, 650, 667, 700, 733, 750, 800,
833, 850, 866, 900, 933, 950, 966, 1000);
FS2: array[0..5] of Byte = (
0, 33, 50, 66, 100, 133);
var
I,S: Integer;
begin
if FSpeed = 0 then
begin
S := Round(CPUSpeedRaw(10) / 1000000);
for I := Low(FS1) +1 to High(FS1) -1 do
if (S = FS1[I]) or
((S >= FS1[I] - (FS1[I] - FS1[I -1]) div 2) and
(S < FS1[I] + (FS1[I +1] - FS1[I]) div 2)) then
begin
FSpeed := FS1[I];
Break;
end;
if FSpeed = 0 then
begin
FSpeed := S;
S := S mod 100;
Dec(FSpeed, S);
for I := Low(FS2) +1 to High(FS2) -1 do
if (S = FS2[I]) or
((S >= FS2[I] - (FS2[I] - FS2[I -1]) div 2) and
(S < FS2[I] + (FS2[I +1] - FS2[I]) div 2)) then
begin
Inc(FSpeed, FS2[I]);
Break;
end;
end;
end;
Result := FSpeed;
end;
function CPUData: TCPUData;
begin
Result := FCPU;
end;
{check is CPUID Instruction present}
function CPUID_Found: LongBool; assembler;
asm
PUSHFD
PUSHFD
POP EAX
MOV EDX,EAX
XOR EAX,0040000h
PUSH EAX
POPFD
PUSHFD
POP EAX
XOR EAX,EDX
JZ @@1
PUSHFD
POP EAX
MOV EDX,EAX
XOR EAX,0200000h
PUSH EAX
POPFD
PUSHFD
POP EAX
XOR EAX,EDX
@@1: POPFD
end;
{initialize the CPU Datastruct}
procedure GetCPU;
function CRC(const Value): Cardinal; assembler;
asm
MOV EDX,EAX
MOV EAX,[EDX + 0]
XOR EAX,[EDX + 4]
XOR EAX,[EDX + 8]
end;
var
ID: Word;
begin
FillChar(FCPU, SizeOf(FCPU), 0);
if CPUID_Found then
asm
PUSH EDI
PUSH EBX
MOV EDI,OFFSET FCPU
LEA EDI,[EDI].TCPUData.Vendor
XOR EAX,EAX
DW 0A20Fh // CPUID
MOV [EDI + 0],EBX
MOV [EDI + 4],EDX
MOV [EDI + 8],ECX
MOV EDI,OFFSET FCPU
CMP EAX,2
JL @@1
MOV EAX,2
DW 0A20Fh
MOV [EDI].TCPUData.TLB_EAX,EAX
MOV [EDI].TCPUData.TLB_EDX,EDX
MOV [EDI].TCPUData.TLB_EBX,EBX
MOV [EDI].TCPUData.TLB_ECX,ECX
@@1: MOV EAX,1
XOR EBX,EBX
XOR ECX,ECX
DW 0A20Fh
MOV [EDI].TCPUData.Signature,EAX
MOV DWord Ptr [EDI].TCPUData.CPUID3[0],EAX
MOV [EDI].TCPUData.Features_EDX,EDX
MOV [EDI].TCPUData.Features_EBX,EBX
MOV [EDI].TCPUData.Features_ECX,ECX
MOV EDX,EAX
AND EAX,0Fh
MOV [EDI].TCPUData.Stepping,AL
SHR EDX,4
MOV EAX,EDX
AND EAX,0Fh
MOV [EDI].TCPUData.Model,AL
SHR EDX,4
MOV EAX,EDX
AND EAX,0Fh
MOV [EDI].TCPUData.Family,AL
SHR EDX,4
AND EDX,0Fh
MOV [EDI].TCPUData.Typ,DL
MOV EAX,080000000h
XOR EDX,EDX
XOR EAX,EAX
DW 0A20Fh
TEST EAX,EAX
JLE @@3
AND EDX,EDX
JZ @@3
PUSH EAX
MOV EAX,080000001h
DW 0A20Fh
MOV [EDI].TCPUData.FeaturesEx_EDX,EDX
MOV [EDI].TCPUData.FeaturesEx_EBX,EBX
MOV [EDI].TCPUData.FeaturesEx_ECX,ECX
POP EAX
CMP EAX,1
JBE @@3
PUSH ESI
PUSH EDI
XOR ESI,ESI
LEA EDI,[EDI].TCPUData.VendorEx
@@2: LEA EAX,[080000002h + ESI]
XOR EDX,EDX
XOR EBX,EBX
XOR ECX,ECX
DW 0A20Fh
MOV [EDI + 0],EAX
MOV [EDI + 4],EBX
MOV [EDI + 8],ECX
MOV [EDI + 12],EDX
INC ESI
ADD EDI,16
AND ESI,3
JNZ @@2
POP EDI
POP ESI
@@3: XOR EDX,EDX
XOR ECX,ECX
XOR EBX,EBX
MOV EAX,3
DW 0A20Fh
MOV DWord Ptr [EDI].TCPUData.CPUID3[ 4],EDX
MOV DWord Ptr [EDI].TCPUData.CPUID3[ 8],ECX
MOV DWord Ptr [EDI].TCPUData.CPUID3[12],EBX
MOV DWord Ptr [EDI].TCPUData.CPUID3[16],EAX
POP EBX
POP EDI
end else
try
FCPU.Family := cf386;
asm
XADD EAX,EAX
BSWAP EAX
PUSH EDI
MOV EDI,OFFSET FCPU
MOV [EDI].TCPUData.Family,cf486
MOV EAX,CR0
AND EAX,not 010h
MOV CR0,EAX
MOV EAX,CR0
AND EAX, 010h
JZ @@1
INC [EDI].TCPUData.Model
OR ID,1
FNINIT
FNSTSW ID
CMP ID[0],0
JNE @@1
FNSTCW ID
MOV AX,ID
AND AX,013Fh
CMP AX,003Fh
JNE @@1
INC [EDI].TCPUData.Model
@@1: POP EDI
end;
except
end;
FCPU.VendorID := CRC(FCPU.Vendor);
end;
function CPUVendor: String;
function L2Cache: Cardinal;
begin // find L2 Cache definition
Result := FCPU.TLB_EDX;
while (Result and $40 = 0) and (Result <> 0) do Result := Result shr 8;
Result := Result and $FF;
end;
label
Unknown, Skip;
var
Compatible: Boolean;
begin
Compatible := False;
with FCPU do
begin
case VendorID of
// Intel ----------------------------
cvIntel:
begin
Result := 'Intel ';
// use goto's, yes, not realy good coding style, but I want a compact solution
goto Skip;
Unknown:
Compatible := True;
Skip:
case Family of
cf386: Result := Result + '386';
cf486:
case Model of
// on the way a small remark:
// we use here concacted stringconstant,
// compiler save optimated only once on different version into code,
// and so we reduce the codesize.
0: Result := Result + '486' + 'DX' + '25/30';
1: Result := Result + '486' + 'DX' + '50';
2: Result := Result + '486' + 'SX';
3: Result := Result + '486' + 'DX' + '2';
4: Result := Result + '486' + 'SL';
5: Result := Result + '486' + 'SX' + '2';
7: Result := Result + '486' + 'DX' + '2' + ' WB enhanced';
8: Result := Result + '486' + 'DX' + '4';
9: Result := Result + '486' + 'DX' + '4' + ' WB enhanced';
else
Result := Result + '486' + sCPU_Model + IntToStr(Model);
end;
cfPentium:
case Model of
0: Result := Result + 'Pentium' + ' P5' + ' A-step';
1: Result := Result + 'Pentium' + ' P5';
2: Result := Result + 'Pentium' + ' P5' + '4C';
3: Result := Result + 'Pentium' + ' P5' + '4T' + ' ' + 'overdrive';
4: Result := Result + 'Pentium' + ' P5' + '5C';
7: Result := Result + 'Pentium' + ' P5' + '4C';
8: Result := Result + 'Pentium' + ' P5' + '5C' + ' (0.25 µm)';
else
Result := Result + 'Pentium' + sCPU_Model + IntToStr(Model);
end;
cfPentiumPro:
case Model of
0: Result := Result + 'Pentium' + ' Pro (P6)' + ' A-step';
1: Result := Result + 'Pentium' + ' Pro (P6)';
3: Result := Result + 'Pentium' + ' II' + ' (0.28 µm)';
5: begin
Result := Result + 'Pentium' + ' II' + ' (0.25 µm)';
case L2Cache of
0: Result := Result + ' Celeron';
$44,$45: Result := Result + ' Xenon';
end;
end;
6: Result := Result + 'Pentium' + ' II' + ' L2 Cache';
7,8: begin
Result := Result + 'Pentium';
case Features_EBX and $FF of
1: Result := Result + ' Celeron';
3: Result := Result + ' III' + ' Xenon';
8: Result := Result + ' IV'; // ? I don't known realy
else
begin
Result := Result + ' III';
if L2Cache in [$44,$45] then Result := Result + ' Xenon';
end;
end;
if Model = 7 then Result := Result + ' (0.25 µm)'
else Result := Result + ' (0.18 µm)';
end;
10: Result := Result + 'Pentium' + ' III' + ' Xenon';
else
Result := Result + 'Pentium' + ' II' + sCPU_Model + IntToStr(Model);
end;
else
Result := Format(sCPU_Unknown, [Vendor, Family, Model]);;
end;
end;
// AMD ----------------------------
cvAMD:
begin
Result := 'AMD ';
case Family of
cf486:
case Model of
14: Result := Result + '586';
15: Result := Result + '586' + ' WB enhanced';
else
goto Unknown;
end;
cfPentium:
case Model of
0: Result := Result + 'K5' + ' SSA5' + ' (PR75, PR90, PR100)';
1: Result := Result + 'K5' + ' 5k86' + ' (PR120, PR133)';
2: Result := Result + 'K5' + ' 5k86' + ' (PR166)';
3: Result := Result + 'K5' + ' 5k86' + ' (PR200)';
6: Result := Result + 'K6' + ' (0.30 µm)';
7: Result := Result + 'K6' + ' (0.25 µm)';
8: Result := Result + 'K6' + ' II';
9: Result := Result + 'K6' + ' III';
13: Result := Result + 'K6' + ' II+ or III+';
else
goto Unknown;
end;
cfPentiumPro:
case Model of
1: Result := Result + 'K7' + ' Athlon' + ' (0.25 µm)';
2: Result := Result + 'K7' + ' Athlon' + ' (0.18 µm)';
3,4: Result := Result + 'K7' + ' Athlon';
else
goto Unknown;
end;
else
goto Unknown;
end;
end;
// Cyrix ----------------------------
cvCyrix:
begin
Result := 'Cyrix ';
case Family of
cf486:
case Model of
4: Result := Result + '586' + ' Media GX';
9: Result := Result + '586'
else
goto Unknown;
end;
cfPentium:
case Model of
2: Result := Result + 'M1' + ' 6x86';
4: Result := Result + 'GXm';
else
goto Unknown;
end;
cfPentiumPro:
case Model of
0: Result := Result + 'M2' + ' 6x86' + 'MX';
5: Result := Result + 'M2' + ' VIA III';
else
goto Unknown;
end;
else
goto Unknown;
end;
end;
// UMC ----------------------------
cvUMC:
begin
Result := 'UMC ';
if Family = cf486 then
case Model of
1: Result := Result + 'U5D';
2: Result := Result + 'U5S';
else
goto Unknown;
end
else goto Unknown;
end;
// NexGen ----------------------------
cvNexGen:
begin
Result := 'NexGen ';
if (Family = cfPentium) and (Model = 0) then Result := Result + '586'
else goto Unknown;
end;
// Centaur/IDT ----------------------------
cvCentaur:
begin
Result := 'Centaur/IDT ';
if Family = cfPentium then
case Model of
4: Result := Result + 'C6';
8: Result := Result + 'C2';
9: Result := Result + 'C3';
else
goto Unknown;
end
else goto Unknown;
end;
// Rise Technology ----------------------------
cvRise:
begin
Result := 'Rise Technology ';
if Family = cfPentium then
case Model of
0: Result := Result + 'mP6' + ' (0.25 µm)';
2: Result := Result + 'mP6' + ' (0.18 µm)';
else
goto Unknown;
end
else goto Unknown;
end;
else
goto Unknown;
end;
if (Features_EDX and ffMMX <> 0) and (Pos('MMX', Result) = 0) then
Result := Result + ' ' + 'MMX';
if (Typ = ctOverdrive) and (Pos('overdrive', Result) = 0) then
Result := Result + ' ' + 'overdrive';
if (Typ = ctDual) and (Pos(sCPU_Dual, Result) = 0) then
Result := Result + sCPU_Dual;
if Compatible then
Result := Result + sCPU_Compatible;
if VendorEx[0] <> #0 then
Result := Result + ' "' + Trim(StrPas(VendorEx)) + '"';
end;
end;
initialization
GetCPU;
end.

Subversion Repositories decoder

decoder/trunk/VCL_DEC/CPU.pas – Rev 2