频道分类

Delphi uCPUUsage 单元

作者:admin 来源: 日期:2020/1/20 1:37:04 人气: 标签:

 

CPU and RAM usage information *.pas for Delphi x32/x64

 

unit uCPUInfo;

(*

   lightweight unit for access to CPU and RAM usage information

   R. Cherepanov, 06.2019

   X64 support

*)

 

interface

uses

  SysUtils,

  Winapi.PsAPI,

  Winapi.Windows;

 

type

  TRegisters=record

    case Integer of

      0:(EAX,EBX,ECX,EDX:LongWord);

      1:(Str1,Str2,Str3,Str4:array[0..3] of AnsiChar );

      2:(Str:array[0..15] of AnsiChar );

  end;

 

  T_CPU_Info= record

    logical_cores: integer;

    physical_cores: integer;

    L1CacheSize: Int64;

    L2CacheSize: Int64;

    L3CacheSize: Int64;

    RAMSize    : Int64;

  end;

 

 

  procedure GetCPUID(Param:Cardinal; var Registers:TRegisters); register;

  function IsCPUID_Available:Boolean; register;

  function GetExtendeCPUInfo: AnsiString;

  function GetCPUInfo: T_CPU_Info;

  function GetCPUName: AnsiString;

  function GetCPUUsage: real;

 

function GetProcessMem: Integer;

 

implementation

 

  function NtQuerySystemInformation (

    SystemInformationClass : DWORD;  // information type flag

    SystemInformation : Pointer;     // buffer

    SystemInformationLength : DWORD; // fuffer size

    var ReturnLength : DWORD         // count of bytes to be returned or needed

  ) : DWORD; stdcall; external 'ntdll.dll';

 

var

  nOldIdleTime : int64 = 0;

  nOldSystemTime : int64 = 0;

  nNewCPUTime : double = 0;

  pmc: PPROCESS_MEMORY_COUNTERS;

 

  function IsCPUID_Available:Boolean; register;

{$IFDEF CPUX64}

    asm  // x64 version

      // FLAGS register in x64 has 64bits, i.e. QWORD,

      // PUSHFQ/POPFQ instead of PUSHFD/POPFD for DWORD in x32.

 

      .noframe

      PUSHFQ

      POP    RAX

      MOV    RBX, RAX

      XOR    EAX, $200000;

      PUSH   RAX

      POPFQ

      PUSHFQ

      POP    RAX

      XOR    EAX, EDX

      SETNZ  AL

    end;

{$ELSE}

    asm   // x32 version

      PUSHFD

      POP    EAX

      MOV    EDX, EAX

      XOR    EAX, $200000;

      PUSH   EAX

      POPFD

      PUSHFD

      POP    EAX

      XOR    EAX, EDX

      SETNZ  AL

    end;

{$ENDIF}

 

  procedure GetCPUID(Param:Cardinal; var Registers:TRegisters); register;

{$IFDEF CPUX64}

    asm  // X64 version

      .noframe

    PUSH   RBX

    PUSH   RDI

    MOV    RDI, Registers

    MOV    EAX, Param

    XOR    EBX, EBX

    XOR    ECX, ECX

    XOR    EDX, EDX

    CPUID

    MOV    TRegisters(EDI).&EAX, EAX

    MOV    TRegisters(EDI).&EBX, EBX

    MOV    TRegisters(EDI).&ECX, ECX

    MOV    TRegisters(EDI).&EDX, EDX

    POP    RDI

    POP    RBX

    end;

{$ELSE}

  asm      // x32 version

    PUSH    EBX

    PUSH    EDI

    MOV    EDI, Registers

    XOR    EBX, EBX

    XOR    ECX, ECX

    XOR    EDX, EDX

    CPUID

    MOV    TRegisters(EDI).&EAX, EAX

    MOV    TRegisters(EDI).&EBX, EBX

    MOV    TRegisters(EDI).&ECX, ECX

    MOV    TRegisters(EDI).&EDX, EDX

    POP    EDI

    POP    EBX

  end;

{$ENDIF}

 

function GetCPUInfo: T_CPU_Info;

var

    sysinfo : _SYSTEM_INFO;

    Buffer : PSYSTEM_LOGICAL_PROCESSOR_INFORMATION_EX;

    current_info :  PSYSTEM_LOGICAL_PROCESSOR_INFORMATION_EX;

    ByteCount : WinApi.Windows.DWORD;

    RelationshipType: LOGICAL_PROCESSOR_RELATIONSHIP;

    offset : integer;

    res: boolean;

    statex: MEMORYSTATUSEX;

 

begin

 

  statex.dwLength := sizeof(statex);

  GlobalMemoryStatusEx(statex);

  Result.RAMSize := statex.ullTotalPhys;

 

  Result.logical_cores  := 0;

  Result.physical_cores := 0;

  Result.L1CacheSize := 0;

  Result.L2CacheSize := 0;

  Result.L3CacheSize := 0;

 

//  RelationshipType := RelationProcessorCore;

//  RelationshipType := RelationNumaNode;

//  RelationshipType := RelationCache;

//  RelationshipType := RelationProcessorPackage;

//  RelationshipType := RelationGroup;

  RelationshipType := RelationAll;

 

  res := GetLogicalProcessorInformationEx(

    RelationshipType,

    nil,

    @ByteCount

  );

 

  GetMem(Buffer, ByteCount);

 

  res := GetLogicalProcessorInformationEx(

    RelationshipType,

    @(Buffer^),

    @ByteCount

  );

 

  offset := 0;

 

  while (offset < ByteCount) do

  begin

    current_info := PSYSTEM_LOGICAL_PROCESSOR_INFORMATION_EX( UInt64(buffer) + offset);

    offset := offset + current_info^.size;

 

    if Current_info.Relationship = RelationProcessorCore

    then

      inc(Result.physical_cores);

 

    if current_info.Relationship = RelationCache then

    begin

      case current_info.Cache.Level of

      1: Result.L1CacheSize := Result.L1CacheSize + current_info.Cache.CacheSize;

      2: Result.L2CacheSize := Result.L2CacheSize + current_info.Cache.CacheSize;

      3: Result.L3CacheSize := Result.L3CacheSize + current_info.Cache.CacheSize;

      end; // of CASE

    end;

 

  end;

 

  GetSystemInfo(sysinfo);

  Result.logical_cores :=  sysinfo.dwNumberOfProcessors;

 

end;

 

function GetCPUName: AnsiString;

var

  Registers:TRegisters;

  _EAX: LongWord;

  FamilyID, ExtFamilyID, ModelID, ExtModelID, ProcType, Stepping: LongWord;

begin

  Result:='';

 

  if not IsCPUID_Available then begin

    Result := 'CPUID not supported';

    Exit;

  end;

 

  // get general CPU info

  GetCPUID( $00000000,Registers );

 

  // Its fantastic! general info stored at mixed order:  EBX:EDX:ECX

  Result := Result + Registers.Str2+Registers.Str4+Registers.Str3 + ': ';

 

  // Get extended info string

  for _EAX := $80000002 to $80000004 do

  begin

    GetCPUID( _EAX ,Registers);

    Result := Result + Registers.Str;

  end;

end;

 

function GetExtendeCPUInfo: AnsiString;

var

  Registers:TRegisters;

  MaxEAX,_EAX: LongWord;

  FamilyID, ExtFamilyID, ModelID, ExtModelID, ProcType, Stepping: LongWord;

begin

  // get Family, Model and Stepping of CPU

  Result:='';

  if not IsCPUID_Available then begin

    Result := 'CPUID not supported';

    Exit;

  end;

 

  // steppings are stored at $00000001 "offset"

  GetCPUID($00000001,Registers);

 

  Stepping    := (Registers.EAX shr 0 ) and  $0F;

  ModelID     := (Registers.EAX shr 4 ) and  $0F;

  FamilyID    := (Registers.EAX shr 8 ) and  $0F;

  ProcType    := (Registers.EAX shr 12) and  $03;

  ExtModelID  := (Registers.EAX shr 16) and $0F;

  ExtFamilyID := (Registers.EAX shr 20) and $FF;

 

  Result := Result + Format('Family %x(%x), Model %x(%x), ID %x, Stepping %x',

                            [FamilyID, ExtFamilyID, ModelID, ExtModelID,

                             ProcType, Stepping]  )

end;

 

function GetCPUUsage: real;

type

  SYSTEM_BASIC_INFORMATION = {$IFDEF WIN32}packed {$ENDIF} record

    AlwaysZero : ULONG;

    uKeMaximumIncrement : ULONG;

    uPageSize : ULONG;

    uMmNumberOfPhysicalPages : ULONG;

    uMmLowestPhysicalPage : ULONG;

    uMmHighestPhysicalPage : ULONG;

    uAllocationGranularity : ULONG;

    pLowestUserAddress : POINTER;

    pMmHighestUserAddress : POINTER;

    uKeActiveProcessors : POINTER;

    bKeNumberProcessors : byte;

    Filler : array [0..2] of byte;

  end;

 

  SYSTEM_TIME_INFORMATION = {$IFDEF WIN32}packed {$ENDIF} record

    nKeBootTime : int64;

    nKeSystemTime : int64;

    nExpTimeZoneBias : int64;

    uCurrentTimeZoneId : ULONG;

    dwReserved : DWORD;

  end;

 

  SYSTEM_PERFORMANCE_INFORMATION = {$IFDEF WIN32}packed {$ENDIF} record

    nIdleTime : int64;

    dwSpare : array [0..75] of DWORD;

  end;

 

const

  SystemBasicInformation = 0;

  SystemTimeOfDayInformation = 3;

  SystemPerformanceInformation = 2;

var

  SBI : SYSTEM_BASIC_INFORMATION;

  STI : SYSTEM_TIME_INFORMATION;

  SPI : SYSTEM_PERFORMANCE_INFORMATION;

  ERROR_CODE: cardinal;

  dummy : DWORD;

begin

  result := -1.0;

 

  ERROR_CODE :=  NTQuerySystemInformation (SystemBasicInformation,

                              @SBI,

                              SizeOf (SYSTEM_BASIC_INFORMATION),

                              dummy);

  if ERROR_CODE <> NO_ERROR then exit;

 

  ERROR_CODE := NTQuerySystemInformation (SystemTimeOfDayInformation,

                                @STI,

                                SizeOf (SYSTEM_TIME_INFORMATION),

                                dummy);

 

  if ERROR_CODE <> NO_ERROR then exit;

 

  ERROR_CODE := NTQuerySystemInformation (SystemPerformanceInformation,

                                @SPI,

                                SizeOf (SYSTEM_PERFORMANCE_INFORMATION),

                                dummy);

 

  if ERROR_CODE <> NO_ERROR then exit;

 

  if (nOldIdleTime <> 0) then

  begin

    nNewCPUTime :=  1.0 -

       (SPI.nIdleTime - nOldIdleTime) /

        ( (STI.nKeSystemTime - nOldSystemTime) * SBI.bKeNumberProcessors ) ;

 

    if (nNewCPUTime <> nOldIdleTime) then

      result := nNewCPUTIME;

    if result < 0.0 then result := 0.0;

 

  end;

 

  nOldIdleTime := SPI.nIdleTime;

  nOldSystemTime := STI.nKeSystemTime;

end;

 

function GetProcessMem: Integer;

var cb: cardinal;

    ProcHandle : THandle;

    i: integer;

    CurrUsage: double;

begin

 

///  add  Winapi.PsAPI to "uses" list

///  pmc: PPROCESS_MEMORY_COUNTERS; declared as global var

///

///  add to initialization code

///  *******

///  cb := SizeOf(_PROCESS_MEMORY_COUNTERS);

///  GetMem(pmc, cb);

///  pmc^.cb := cb;

///  ****

 

  cb := SizeOf(_PROCESS_MEMORY_COUNTERS);

  if pmc = nil then begin

    GetMem(pmc, cb);

    pmc^.cb := cb;

  end;

 

  ProcHandle := GetCurrentProcess();

 

  if GetProcessMemoryInfo( ProcHandle, pmc, cb) then

    result := pmc^.WorkingSetSize

  else

    Result := -1;

end;

 

end.