Паскаль / do11 / tmtp390d / SOURCE / zentimer

(****************************************************************************
* *
* The Zen Timer Unit *
* *
* TMT Pascal Version *
* Copyright (C) 1997-2000 TMT Development Corporation *
* All rights reserved. *
* *
* Portions Copyright (C) 1991-1997 SciTech Software, Inc. *
* All rights reserved. *
* *
* *
* Filename: $Workfile: zentimer.pas $ *
* Version: $Revision: 2.8 $ *
* *
* Language: TMT Pascal Multi-target *
* Environment: IBM PC (MSDOS 32-bit protected mode, OS/2, Win32) *
* *
* Description: Source file of the Zen Timer library. Provides a number *
* of routines to accurately time segments of code. A long *
* period timer is provided to time code that takes up to *
* one hour to execute, with microsecond precision, and an *
* ultra long period timer for timing code that takes up to *
* 24 hours to execute (raytracing etc). *
* *
* We also provide a set of Pascal objects to manipulate *
* the Zen Timers. Note that you can only have one LZTimer *
* running at a time (you can have multiple ULZTimers however),*
* and that the total aggregate time of thr ULZTimer is about *
* 65,000 hours, which should suit most timing purposes. *
* *
* This unit also includes routines for querying the CPU *
* type, CPU speed and CPU features, and includes support for *
* high precision timing on Pentium based systems using the *
* Read Time Stamp Counter. Based on Intel sample code. *
* *
* $Date: 19 Jul 2000 $ $Author of TMT Pascal version : Vadim Bodrov $ *
* $Date: 01 Oct 1997 $ $Author of original C/C++ code: KendallB $ *
* *
*****************************************************************************)
{$r-,q-,i-,t-,x+,v-,a+,cc+,oa+}

unit ZenTimer;

interface

const
CPU_unknown = 0; // Unknown proccessor
CPU_i386 = 1; // Intel 80386 processor
CPU_i486 = 2; // Intel 80486 processor
CPU_Pentium = 3; // Intel Pentium(R) processor
CPU_PentiumPro = 4; // Intel PentiumPro(R) processor
CPU_PentiumII = 5; // Intel PentiumII(R) processor
CPU_PentiumIII = 6; // Intel PentiumIII(R) processor
CPU_Pentium4 = 7; // Intel PentiumIII(R) processor
CPU_UnkPentium = $FFFF; // Unknown Intel Pentium family processor

CpuTypes: array [0..8] of string[20] =
(
'Unknown',
'Intel 80386',
'Intel 80486',
'Intel Pentium(R)',
'Intel PentiumPro(R)',
'Intel PentiumII(R)',
'Intel PentiumIII(R)',
'Intel Pentium4(R)',
'Unknown Pentium'
);

(* Routines to obtain CPU information *)
function CPU_getProcessorType: DWord;
function CPU_isIntelClone: Boolean;
function CPU_haveMMX: Boolean;
function CPU_have3DNow: Boolean;
function CPU_haveRDTSC: Boolean;
function CPU_getProcessorSpeed: DWord;
function CPU_getCPUIDFeatures: DWord;

(* Routine to initialise the library. You may not call this procedure,
since it calls automaticaly at unit initialization. ZTimerInit
procedure listed here only for compatibility with original C/C++
ztimer library *)
procedure ZTimerInit;

(* Long period timing routines (times up to 1 hour) *)
procedure LZTimerOn;
function LZTimerLap: DWord;
procedure LZTimerOff;
function LZTimerCount: DWord;

(* New procedure added *)
procedure LZDelay(Value: DWord);

(* Ultra long period timing routines (times up to 65,000 hours) *)
procedure ULZTimerOn;
procedure ULZTimerOff;
function ULZTimerLap: DWord;
function ULZTimerCount: DWord;
function ULZReadTime: DWord;
function ULZElapsedTime(start, finish: DWord): DWord;
function ULZTimerResolution: Double;

(* New procedure added *)
procedure ULZDelay(Value: DWord);

////////////////////////////////////////////////////////////////////////////
// Long Period Zen Timer object. This can be used to time code that takes
// up to 1 hour to execute between calls to Start and Stop or lap. The
// aggregate count can be up to 2^32 - 1 microseconds (about 1 hour and
// 10 mins).
////////////////////////////////////////////////////////////////////////////
type LZTimer = object
private
_count: DWord;
_overflow: Boolean;
procedure ComputeTime;
public
procedure LZTimer;
procedure Start;
procedure Restart;
function Lap: DWord;
procedure Stop;
function Count: DWord;
procedure Reset;
function Overflow: Boolean;
function Resolution: Double;
procedure Delay(Value: DWord);
end;

////////////////////////////////////////////////////////////////////////////
// Ultra Long Period Zen Timer object. This can be used to time code that
// takes up 24 hours total to execute between calls to Start and Stop.
// The aggregate count can be up to 2^32 - 1 1/18ths of a second, which
// is about 65,000 hours! Should be enough for most applications.
/////////////////////////////////////////////////////////////////////////////
type ULZTimer = object
private
_count: DWord;
_start: DWord;
_finish: DWord;
public
procedure ULZTimer;
procedure Start;
procedure Restart;
function Lap: DWord;
procedure Stop;
function Count: DWord;
procedure Reset;
function Resolution: Double;
procedure Delay(Value: DWord);
end;

implementation

{$ifdef __WIN32__}
uses Windows;

type
CPU_LargeInteger = TLargeInteger;
{$endif}

{$ifdef __OS2__}
uses DOSCall;
{$endif}

{$ifndef __WIN32__}
type CPU_largeInteger = record
LowPart: DWord;
HighPart: DWord;
end;
{$endif}

const
Intel_id: string[12] = 'GenuineIntel';
TOLERANCE = 1;
MAXCLOCKS = 150;
ROUND_THRESHOLD = 6;
ITERATIONS = 16000;
MAX_TRIES = 20;
SAMPLINGS = 10;

CPU_mask = $7FFF;
CPU_IntelClone = $8000;
CPU_HaveMMX_ = $00800000;
CPU_HaveRDTSC_ = $00000010;

var
StartBIOSCount,EndBIOSCount: DWord := 0;
EndTimedCount: Word := 0;
CpuSpeed: LongInt := 0;
HaveRDTSC: Boolean := FALSE;
tmStart,tmEnd: CPU_largeInteger;
start,finish: DWord := 0;
ZTimerBIOS: DWord := 0;

{$ifdef __WIN32__}
var
CountFreq: CPU_LargeInteger;
havePerformanceCounter: Boolean;

function timeGetTime: DWORD; stdcall; external 'winmm.dll' name 'timeGetTime';
{$endif}

{$ifdef __OS2__}
var
CountFreq: CPU_LargeInteger;

function timeGetTime: DWORD;
begin
DosQuerySysInfo(qsv_Ms_Count,qsv_Ms_Count, Result, 4);
end;
{$endif}

////////////////////////////////////////////////////////////////////////////
// Determines if we have an i386 processor.
////////////////////////////////////////////////////////////////////////////
function CPU_check80386: Boolean;
asm
xor edx,edx // EDX = 0, not an 80386
mov bx, sp
and sp, not 3
pushfd // Push original EFLAGS
pop eax // Get original EFLAGS
mov ecx, eax // Save original EFLAGS
xor eax, 40000h // Flip AC bit in EFLAGS
push eax // Save new EFLAGS value on
// stack
popfd // Replace current EFLAGS value
pushfd // Get new EFLAGS
pop eax // Store new EFLAGS in EAX
xor eax, ecx // Can't toggle AC bit,
// processor=80386
jnz @@Done // Jump if not an 80386 processor
inc edx // We have an 80386

@@Done: push ecx
popfd
mov sp, bx
mov eax, edx
end;

////////////////////////////////////////////////////////////////////////////
// Determines if we have an i486 processor.
////////////////////////////////////////////////////////////////////////////
function CPU_check80486: Boolean;
asm
pushfd // Get original EFLAGS
pop eax
mov ecx, eax
xor eax, 200000h // Flip ID bit in EFLAGS
push eax // Save new EFLAGS value on stack
popfd // Replace current EFLAGS value
pushfd // Get new EFLAGS
pop eax // Store new EFLAGS in EAX
xor eax, ecx // Can not toggle ID bit,
jnz @@1 // Processor=80486
mov eax,1 // We dont have a Pentium
jmp @@Done
@@1: xor eax,eax // We have Pentium or later
@@Done:
end;

////////////////////////////////////////////////////////////////////////////
// Determines if we have support for the CPUID instruction.
////////////////////////////////////////////////////////////////////////////
function CPU_haveCPUID: Boolean; assembler;
asm
pushfd // Get original EFLAGS
pop eax
mov ecx, eax
xor eax, 200000h // Flip ID bit in EFLAGS
push eax // Save new EFLAGS value on stack
popfd // Replace current EFLAGS value
pushfd // Get new EFLAGS
pop eax // Store new EFLAGS in EAX
xor eax, ecx // Can not toggle ID bit,
jnz @@1 // Processor=80486
mov eax,0 // We dont have CPUID support
jmp @@Done
@@1: mov eax,1 // We have CPUID support
@@Done:
end;

////////////////////////////////////////////////////////////////////////////
// Determines the CPU type using the CPUID instruction.
////////////////////////////////////////////////////////////////////////////
function CPU_checkCPUID: DWord; assembler;
asm
xor eax, eax // Set up for CPUID instruction
cpuid // Get and save vendor ID
cmp eax, 1 // Make sure 1 is valid input for CPUID
jl @@Fail // We dont have the CPUID instruction
xor eax,eax // Assume Genuine Intel
cmp dword ptr [intel_id+1], ebx
jne @@NotGenuineIntel
cmp dword ptr [intel_id+5], edx
jne @@NotGenuineIntel
cmp dword ptr [intel_id+9], ecx
je @@HaveGenuineIntel
@@NotGenuineIntel:
mov eax,CPU_IntelClone // Set the clone flag
@@HaveGenuineIntel:
push eax
xor eax, eax
inc eax
cpuid // Get family/model/stepping/features
and eax, 0F00h
shr eax, 8 // Isolate family
and eax, 0Fh
pop ecx
or eax,ecx // Combine in the clone flag
jmp @@Done
@@Fail:
xor eax,eax
@@Done:
end;

////////////////////////////////////////////////////////////////////////////
// Determines the CPU type using the CPUID instruction.
////////////////////////////////////////////////////////////////////////////
function CPU_getCPUIDModel: DWord; assembler;
asm
xor eax, eax // Set up for CPUID instruction
cpuid // Get and save vendor ID
cmp eax, 1 // Make sure 1 is valid input for CPUID
jl @@Fail // We dont have the CPUID instruction
xor eax, eax
inc eax
cpuid // Get family/model/stepping/features
and eax, 0F0h
shr eax, 4 // Isolate model
jmp @@Done
@@Fail:
xor eax,eax
@@Done:
end;

////////////////////////////////////////////////////////////////////////////
// Determines the CPU type using the CPUID instruction.
////////////////////////////////////////////////////////////////////////////
function CPU_getCPUIDFeatures: DWord; assembler;
asm
xor eax, eax // Set up for CPUID instruction
cpuid // Get and save vendor ID
cmp eax, 1 // Make sure 1 is valid input for CPUID
jl @@Fail // We dont have the CPUID instruction
xor eax, eax
inc eax
cpuid // Get family/model/stepping/features
mov eax, edx
jmp @@Done
@@Fail: xor eax,eax
@@Done:
end;

////////////////////////////////////////////////////////////////////////////
// Checks if the i386 or i486 processor is a clone or genuine Intel.
////////////////////////////////////////////////////////////////////////////
function CPU_checkClone: DWord; assembler;
asm
mov ax,5555h // Check to make sure this is a 32-bit processor
xor dx,dx
mov cx,0002h
div cx // Perform Division
clc
jnz @@NoClone
jmp @@Clone
@@NoClone:
stc
@@Clone:
pushfd
pop eax // Get the flags
and eax,1
xor eax,1 // EAX=0 is probably Intel, EAX=1 is a Clone
end;
////////////////////////////////////////////////////////////////////////////
// Reads the time stamp counter and returns the low order 32-bits
////////////////////////////////////////////////////////////////////////////
function CPU_quickRDTSC: DWord; code;
asm
rdtsc
ret
end;

////////////////////////////////////////////////////////////////////////////
// Runs a loop of BSF instructions for the specified number of iterations
////////////////////////////////////////////////////////////////////////////
procedure CPU_runBSFLoop(interations: DWord); assembler;
asm
mov edx,[interations]
mov eax,80000000h
mov ebx,edx
ALIGN 4
@@loop: bsf ecx,eax
dec ebx
jnz @@loop
end;

////////////////////////////////////////////////////////////////////////////
// Reads the time stamp counter and returns the 64-bit result.
////////////////////////////////////////////////////////////////////////////
procedure CPU_readTimeStamp(var time: CPU_largeInteger); assembler;
asm
db 00Fh,031h
rdtsc
mov ecx,[time] // Access directly without stack frame
mov [ecx],eax
mov [ecx+4],edx
end;

////////////////////////////////////////////////////////////////////////////
// Computes the difference between two 64-bit numbers.
////////////////////////////////////////////////////////////////////////////
function CPU_diffTime64 (var t1,t2,t: CPU_largeInteger): DWord; assembler;
asm
mov ecx,[t2]
mov eax,[ecx] // EAX := t2.low
mov ecx,[t1]
sub eax,[ecx]
mov edx,eax // EDX := low difference
mov ecx,[t2]
mov eax,[ecx+4] // ECX := t2.high
mov ecx,[t1]
sbb eax,[ecx+4] // EAX := high difference
mov ebx,[t] // Store the result
mov [ebx],edx // Store low part
mov [ebx+4],eax // Store high part
mov eax,edx // Return low part
end;

////////////////////////////////////////////////////////////////////////////
// Computes the value in microseconds for the elapsed time with maximum
// precision. The formula we use is:
//
// us = (((diff * 0x100000) / freq) * 1000000) / 0x100000)
//
// The power of two multiple before the first divide allows us to scale the
// 64-bit difference using simple shifts, and then the divide brings the
// final result into the range to fit into a 32-bit integer.
////////////////////////////////////////////////////////////////////////////
function CPU_calcMicroSec (var Count: CPU_largeInteger; freq: DWord): DWord; assembler;
asm
mov ecx,[count]
mov eax,[ecx] // EAX := low part
mov edx,[ecx+4] // EDX := high part
shld edx,eax,20
shl eax,20 // diff * 0x100000
div dword ptr [freq] // (diff * 0x100000) / freq
mov ecx,1000000
xor edx,edx
mul ecx // ((diff * 0x100000) / freq) * 1000000)
shrd eax,edx,20 // ((diff * 0x100000) / freq) * 1000000) / 0x100000
end;

////////////////////////////////////////////////////////////////////////////
// Starts the Long period Zen timer counting.
////////////////////////////////////////////////////////////////////////////
procedure LZ_TimerOn; assembler;
asm
mov al,34h
out 43h,al
db 0EBh,00h,0EBh,00h,0EBh,00h
xor ax,ax
out 40h,al
db 0EBh,00h,0EBh,00h,0EBh,00h
out 40h,al
cli
mov edi,46Ch
mov eax,dword ptr [edi]
sti
mov dword ptr [StartBIOSCount],eax
mov al,34h
out 43h,al
db 0EBh,00h,0EBh,00h,0EBh,00h
xor ax,ax
out 40h,al
db 0EBh,00h,0EBh,00h,0EBh,00h
out 40h,al
end;

////////////////////////////////////////////////////////////////////////////
// Stops the long period Zen timer and saves count.
////////////////////////////////////////////////////////////////////////////
procedure LZ_TimerOff; assembler;
asm
xor al,al
out 43h,al
cli
mov edi,46Ch
mov eax,dword ptr [edi]
mov dword ptr [EndBIOSCount],eax
in al,40h
db 0EBh,00h,0EBh,00h,0EBh,00h
mov ah,al
in al,40h
xchg ah,al
neg ax
mov [EndTimedCount],ax
sti
end;

////////////////////////////////////////////////////////////////////////////
// Latches the current count and converts it to a microsecond timing value,
// but leaves the timer still running. We dont check for and overflow,
// where the time has gone over an hour in this routine, since we want it
// to execute as fast as possible.
////////////////////////////////////////////////////////////////////////////
function LZ_TimerLap: DWord; assembler;
asm
xor al,al
out 43h,al
cli
mov edi,46Ch
mov eax,dword ptr [edi]
mov dword ptr [EndBIOSCount],eax
in al,40h
db 0EBh,00h,0EBh,00h,0EBh,00h
mov ah,al
in al,40h
xchg ah,al
neg ax
mov [EndTimedCount],ax
sti
mov eax,dword ptr [EndBIOSCount]
cmp eax,dword ptr [StartBIOSCount]
jae @CalcBIOSTime
add dword ptr [EndBIOSCount],001800B0h
@CalcBIOSTime:
mov eax,[EndBIOSCount]
sub eax,[StartBIOSCount]
mov edx,54925
mul edx
mov ebx,eax
movzx eax,[EndTimedCount]
mov esi,8381
mul esi
mov esi,10000
div esi
add eax,ebx
end;

////////////////////////////////////////////////////////////////////////////
// Returns an unsigned long representing the net time in microseconds.
//
// If an hour has passed while timing, we return 0xFFFFFFFF as the count
// (which is not a possible count in itself).
////////////////////////////////////////////////////////////////////////////
function LZ_TimerCount: DWord; assembler;
asm
mov eax,dword ptr [EndBIOSCount]
cmp eax,dword ptr [StartBIOSCount]
jae @CheckForHour
add dword ptr [EndBIOSCount],001800B0h
@CheckForHour:
mov ax,word ptr [StartBIOSCount+2]
cmp ax,word ptr [EndBIOSCount+2]
je @CalcBIOSTime
inc ax
cmp ax,word ptr [EndBIOSCount+2]
jne @TestTooLong
mov ax,word ptr [EndBIOSCount]
cmp ax,word ptr [StartBIOSCount]
jb @CalcBIOSTime
@TestTooLong:
mov eax,0FFFFFFFFh
ret
@CalcBIOSTime:
mov eax,[EndBIOSCount]
sub eax,[StartBIOSCount]
mov edx,54925
mul edx
mov ebx,eax
movzx eax,[EndTimedCount]
mov esi,8381
mul esi
mov esi,10000
div esi
add eax,ebx
end;

function GetCPUType: DWORD;
var
cpu, model, clone: DWord;
begin
if CPU_haveCPUID then
begin
cpu := CPU_checkCPUID;
clone := (cpu and CPU_IntelClone);
case (cpu and CPU_mask) of
4: cpu := CPU_i486;
5: cpu := CPU_Pentium;
6: begin
model := CPU_getCPUIDModel;
case model of
1: cpu := CPU_PentiumPro
3,5,6: cpu := CPU_PentiumII;
7,8: cpu := CPU_PentiumIII;
9: cpu := CPU_Pentium4;
else
cpu := CPU_UnkPentium;
end;
end;
else
cpu := CPU_UnkPentium;
end;
end else
begin
clone := CPU_checkClone * CPU_IntelClone;
if CPU_check80386 then
cpu := CPU_i386
else if CPU_check80486 then
cpu := CPU_i486
else
cpu := CPU_Pentium;
end;
Result := cpu or clone;
end;

(****************************************************************************
DESCRIPTION:
Returns the type of processor in the system.

RETURNS:
Numerical identifier for the installed processor

REMARKS:
Returns the type of processor in the system. Note that if the CPU is an
unknown Pentium family processor that we don't have an enumeration for,
the return value will be greater than or equal to the value of CPU_UnkPentium
(depending on the value returned by the CPUID instruction).

SEE ALSO:
CPU_getProcessorSpeed, CPU_haveMMX
****************************************************************************)
function CPU_getProcessorType: DWord;
begin
Result := GetCPUType and $7FFF;
end;

(****************************************************************************
DESCRIPTION:
Returns TRUE if the processor is an Intel clone.
****************************************************************************)
function CPU_isIntelClone: Boolean;
begin
Result := (GetCPUType and CPU_IntelClone) <> 0;
end;

(****************************************************************************
DESCRIPTION:
Returns true if the processor supports Intel MMX extensions.

RETURNS:
True if MMX is available, false if not.

REMARKS:
This function determines if the processor supports the Intel MMX extended
instruction set. If the processor is not an Intel or Intel clone CPU, this
function will always return false.

SEE ALSO:
CPU_getProcessorType, CPU_getProcessorSpeed, CPU_have3DNow
****************************************************************************)
function CPU_haveMMX: Boolean;
begin
if CPU_haveCPUID then
Result:= (CPU_getCPUIDFeatures and CPU_HaveMMX_) <> 0
else
Result := FALSE;
end;

(****************************************************************************
DESCRIPTION:
Returns true if the processor supports AMD 3DNow! extensions.

RETURNS:
True if 3DNow is available, false if not.

REMARKS:
This function determines if the processor supports the Intel MMX extended
instruction set. If the processor is not an Intel or Intel clone CPU, this
function will always return false.

SEE ALSO:
CPU_getProcessorType, CPU_getProcessorSpeed, CPU_haveMMX
****************************************************************************)
function CPU_have3DNow: Boolean; code;
asm
call CPU_haveCPUID
and eax, 00000001h
jz @@NO_3DNOW
mov eax, 80000000h // query for extended functions
CPUID // get extended function limit
cmp eax, 80000000h // is 8000_0001h supported?
jbe @@NO_3DNOW // if not, 3DNow! tech. not supported
mov eax, 80000001h // setup extended function 1
CPUID // call the function
test edx, 80000000h // test bit 31
jz @@NO_3DNOW
xor eax, eax // 3DNow! technology supported
inc eax
ret
@@NO_3DNOW:
xor eax, eax
ret
end;

(****************************************************************************
DESCRIPTION:
Returns true if the processor supports the RDTSC instruction

RETURNS:
True if the RTSC instruction is available, false if not.

REMARKS:
This function determines if the processor supports the Intel RDTSC
instruction, for high precision timing. If the processor is not an Intel or
Intel clone CPU, this function will always return false.

SEE ALSO:
CPU_getProcessorType, CPU_isMMXAvailable
****************************************************************************)
function CPU_haveRDTSC: Boolean;
begin
if CPU_haveCPUID then
Result := (CPU_getCPUIDFeatures and CPU_HaveRDTSC_) <> 0
else
Result := FALSE;
end;

procedure ZTimerQuickInit;
begin
{$ifdef __DOS__}
ZTimerBIOS := $400;
{$endif}
end;

{$ifdef __WIN32__}
procedure GetCounterFrequency(var freq: CPU_largeInteger);
begin
if not QueryPerformanceFrequency(freq) then
begin
HavePerformanceCounter := FALSE;
freq.LowPart := 100000;
freq.HighPart := 0;
end else
havePerformanceCounter := TRUE;
end;

procedure GetCounter(var t: CPU_largeInteger);
begin
if havePerformanceCounter then
QueryPerformanceCounter(t)
else begin
t.LowPart := timeGetTime * 100;
t.HighPart := 0;
end;
end;
{$endif}

{$ifdef __OS2__}
procedure GetCounterFrequency(var freq: CPU_largeInteger);
begin
freq.LowPart := 100000;
freq.HighPart := 0;
end;

procedure GetCounter(var t: CPU_largeInteger);
begin
t.LowPart := timeGetTime * 100;
t.HighPart := 0;
end;
{$endif}

{$ifdef __DOS__}
procedure GetCounterFrequency(var freq: CPU_largeInteger);
begin
ZTimerQuickInit;
freq.LowPart := 100000;
freq.HighPart := 0;
end;

procedure GetCounter(var t: CPU_largeInteger);
begin
t.LowPart := ULZReadTime * 5500;
t.HighPart := 0;
end;
{$endif}

procedure LZ_Disable; code;
asm
cli
ret
end;

procedure LZ_Enable; code;
asm
sti
ret
end;

(****************************************************************************
REMARKS:
On processors supporting the Read Time Stamp opcode, compare elapsed
time on the High-Resolution Counter with elapsed cycles on the Time
Stamp Register.

The inner loop runs up to 20 times oruntil the average of the previous
three calculated frequencies is within 1 MHz of each of the individual
calculated frequencies. This resampling increases the accuracy of the
results since outside factors could affect this calculation.
****************************************************************************)
function GetRDTSCCpuSpeed: LongInt;
var
t0, t1,count_freq: CPU_largeInteger;
freq, freq2, freq3: DWord := 0;
total, tries, total_cycles, cycles,
stamp0, stamp1, total_ticks, ticks: DWord := 0;
{$ifdef __WIN32__}
var
iPriority: LongInt;
hThread: THandle;
{$endif}
begin
{$ifdef __WIN32__}
hThread := GetCurrentThread;
iPriority := GetThreadPriority(hThread);
if iPriority <> THREAD_PRIORITY_ERROR_RETURN then
SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);
{$endif}
GetCounterFrequency(Count_freq);
repeat
tries +:= 1; // Increment number of times sampled
freq3 := freq2; // Shift frequencies back
freq2 := freq;

(* Loop until 50 ticks have passed since last read of hi-res counter.
* This accounts for overhead later. *)

GetCounter (t0);
t1.LowPart := t0.LowPart;
t1.HighPart := t0.HighPart;
while ((t1.LowPart - t0.LowPart) < 50) do
begin
GetCounter (t1);
stamp0 := CPU_quickRDTSC;
end;

(* Loop until 1000 ticks have passed since last read of hi-res counter.
* This allows for elapsed time for sampling. *)

t0.LowPart := t1.LowPart;
t0.HighPart := t1.HighPart;
while ((t1.LowPart - t0.LowPart) < 1000) do
begin
GetCounter(t1);
stamp1 := CPU_quickRDTSC;
end;

(* Find the difference during the timing loop *)

cycles := stamp1 - stamp0;
ticks := t1.LowPart- t0.LowPart;

(* Note that some seemingly arbitrary mulitplies and divides are done
* below. This is to maintain a high level of precision without truncating
* the most significant data. According to what value ITERATIIONS is set
* to, these multiplies and divides might need to be shifted for optimal
* precision. *)

ticks := ticks * 100000;
ticks := ticks div (count_freq.LowPart div 10);
total_ticks +:= ticks;
total_cycles +:= cycles;
if ((ticks mod count_freq.LowPart) > (count_freq.LowPart div 2)) then
ticks +:=1; // Round up if necessary
freq := cycles div ticks; // Cycles / us = MHz
if ((cycles mod ticks) > (ticks div 2)) then
freq +:= 1; // Round up if necessary
total := (freq + freq2 + freq3); // Total last three frequency calculations
until ((tries < 3 ) or (tries < 20) and
(((3 * freq -total) > (3 * TOLERANCE)) or
( (3 * freq2-total) > (3 * TOLERANCE)) or
( (3 * freq3-total) > (3 * TOLERANCE))));
{$ifdef __WIN32__}
if iPriority <> THREAD_PRIORITY_ERROR_RETURN then
SetThreadPriority(hThread, iPriority);
{$endif}
Result := (total_cycles div total_ticks);
end;

(****************************************************************************
REMARKS:
If processor does not support time stamp reading, but is at least a 386 or
above, utilize method of timing a loop of BSF instructions which take a
known number of cycles to run on i386(tm), i486(tm), and Pentium(R)
processors.
****************************************************************************)
function GetBSFCpuSpeed(Cycles: DWord): DWord;
var
t0, t1, count_freq: CPU_largeInteger;
ticks, current, i: DWORD;
lowest: DWORD := High(DWORD) - 1;
{$ifdef __WIN32__}
var
iPriority: LongInt;
hThread: THandle;
{$endif}
begin
{$ifdef __WIN32__}
hThread := GetCurrentThread;
iPriority := GetThreadPriority(hThread);
if iPriority <> THREAD_PRIORITY_ERROR_RETURN then
SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);
{$endif}
{$ifdef __DOS__}
count_freq.LowPart := 100000;
count_freq.HighPart := 0;
ZTimerQuickInit;
LZTimerOn;
{$else}
GetCounterFrequency(Count_freq);
{$endif}
for i := 0 to SAMPLINGS do
begin
{$ifdef __DOS__}
t0.LowPart := LZTimerLap div 10;
{$else}
GetCounter(t0);
{$endif}
CPU_runBSFLoop(ITERATIONS);
{$ifdef __DOS__}
t1.LowPart := LZTimerLap div 10;
{$else}
GetCounter(t1);
{$endif}
current:= t1.LowPart - t0.LowPart;
if current < lowest then lowest := current;
end;
{$Ifdef __DOS__}
LZTimerOff;
{$endif}
{$ifdef __WIN32__}
if iPriority <> THREAD_PRIORITY_ERROR_RETURN then
SetThreadPriority(hThread, iPriority);
{$endif}
(* Compute frequency *)
ticks:= lowest;
ticks:= ticks * 100000;
ticks:= ticks div (count_freq.LowPart div 10);
if ((ticks mod count_freq.LowPart) > (count_freq.LowPart div 2)) then
ticks +:= 1;
if ticks = 0 then
Result := 0
else
Result := Cycles div ticks;
end;

(****************************************************************************
DESCRIPTION:
Returns the speed of the processor in Mhz.

RETURNS:
Processor speed in Mhz.

REMARKS:
This function returns the speed of the CPU in Mhz. Note that if the speed
cannot be determined, this function will return 0.

SEE ALSO:
CPU_getProcessorType, CPU_haveMMX
****************************************************************************)
function CPU_getProcessorSpeed: DWord;
var
cpuSpeed, i, tries, processor: DWord;
const
processor_cycles: array [0..6] of DWord =
(
0, 115 ,47, 43, 38, 38, 38
);

known_speeds: array [0..23] of DWord =
(
600, 550, 500, 450, 400, 375, 333, 300,
266, 233, 200, 166, 150, 133, 120, 100,
90, 75, 66, 60, 50, 33, 20, 0
);
begin
processor := CPU_getProcessorType and CPU_mask;
(* Try 3 times for insurance... *)
for tries := 1 to 3 do
begin
if CPU_haveRDTSC then
cpuSpeed := GetRDTSCCpuSpeed
else
cpuSpeed := GetBSFCpuSpeed(ITERATIONS * processor_cycles[processor]);
i := 0;
repeat
if (CpuSpeed >= (known_speeds[i]-2)) and (CpuSpeed <= (known_speeds[i]+2))
then begin
Result := known_speeds[i];
exit;
end;
i +:= 1;
until known_speeds[i] = 0;
end;
Result:=cpuSpeed;
end;

procedure ZTimerInit;
begin
if cpuSpeed = -1 then
begin
ZTimerQuickInit;
cpuSpeed := CPU_getProcessorSpeed * 1000000;
if CPU_getProcessorType > CPU_i486 then
haveRDTSC := (CPU_haveRDTSC) and (cpuSpeed > 0)
else
haveRDTSC := FALSE;
end;
{$ifdef __WIN32__}
havePerformanceCounter := QueryPerformanceFrequency (CountFreq);
{$endif}
end;

procedure LZTimerOn;
begin
if haveRDTSC then
begin
CPU_readTimeStamp (tmStart);
end
{$ifdef __WIN32__}
else
begin
if havePerformanceCounter then
QueryPerformanceCounter(tmStart)
else
tmStart.LowPart := timeGetTime;
end;
{$endif}
{$ifdef __OS2__}
else
tmStart.LowPart := timeGetTime;
{$endif}
{$ifdef __DOS__}
else
LZ_timerOn;
{$endif}
end;

function LZTimerLap: DWord;
var
tmLap,tmCount: CPU_largeInteger;
begin
if haveRDTSC then
begin
CPU_readTimeStamp(tmLap);
CPU_diffTime64(tmStart, tmLap, tmCount);
Result:=CPU_calcMicroSec(tmCount, cpuSpeed);
end
{$ifdef __WIN32__}
else begin
if havePerformanceCounter then
begin
QueryPerformanceCounter(tmLap);
CPU_diffTime64(tmStart, tmLap, tmCount);
Result := CPU_calcMicroSec(tmCount, countFreq.LowPart);
end else
begin
tmLap.LowPart := timeGetTime;
Result := (tmLap.LowPart - tmStart.LowPart) * 1000;
end;
end;
{$endif}
{$ifdef __OS2__}
else
begin
tmLap.LowPart := timeGetTime;
Result := (tmLap.LowPart - tmStart.LowPart) * 1000;
end;
{$endif}
{$ifdef __DOS__}
else
Result := LZ_timerLap
{$endif}
end;

procedure LZTimerOff;
begin
if haveRDTSC then
begin
CPU_readTimeStamp(tmEnd);
end
{$ifdef __WIN32__}
else
if havePerformanceCounter then
QueryPerformanceCounter(tmEnd)
else
tmEnd.LowPart := timeGetTime;
{$endif}
{$ifdef __OS2__}
else
tmEnd.LowPart := timeGetTime;
{$endif}
{$ifdef __DOS__}
else
LZ_timerOff;
{$endif}
end;

function LZTimerCount: DWord;
var
tmCount: CPU_largeInteger;
begin
if haveRDTSC then
begin
CPU_diffTime64(tmStart, tmEnd, tmCount);
Result:=CPU_calcMicroSec(tmCount, cpuSpeed);
end
{$ifdef __WIN32__}
else
if havePerformanceCounter then
begin
CPU_diffTime64(tmStart, tmEnd, tmCount);
Result := CPU_calcMicroSec(tmCount, countFreq.LowPart);
end else
Result := (tmEnd.LowPart - tmStart.LowPart) * 1000;
{$endif}
{$ifdef __OS2__}
else
Result := (tmEnd.LowPart - tmStart.LowPart) * 1000;
{$endif}
{$ifdef __DOS__}
else
Result := LZ_timerCount;
{$endif}
end;

procedure LZDelay(Value: DWord);
var
CurValue: DWord;
begin
CurValue := LZTimerLap + Value;
while LZTimerLap < CurValue do (* nothing *)
end;

function LZTimerResolution: Double;
begin
Result := 1E-6;
end;

procedure ULZTimerOn;
begin
{$ifdef __DOS__}
Start := ULZReadTime;
{$else}
Start := timeGetTime;
{$endif}
end;

procedure ULZTimerOff;
begin
{$ifdef __DOS__}
Finish := ULZReadTime;
{$else}
Finish := timeGetTime;
{$endif}
end;

function ULZTimerLap: DWord;
begin
{$ifdef __DOS__}
Result := ULZElapsedTime(Start, ULZReadTime);
{$else}
Result := timeGetTime - Start;
{$endif}
end;

function ULZTimerCount: DWord;
begin
{$ifdef __DOS__}
Result := ULZElapsedTime(Start, Finish);
{$else}
Result := Finish - Start;
{$endif}
end;

function ULZReadTime: DWord;
{$ifdef __DOS__}
var
ticks: DWord;
begin
LZ_Disable;
ticks := DWord(Pointer(ZTimerBIOS+$6C)^);
LZ_Enable;
Result := ticks;
end;
{$else}
begin
Result := timeGetTime;
end;
{$endif}

function ULZElapsedTime(start, finish: DWord): DWord;
begin
(* Check to see whether a midnight boundary has passed, and if so
* adjust the finish time to account for this. We cannot detect if
* more that one midnight boundary has passed, so if this happens
* we will be generating erronous results. *)
{$ifdef __DOS__}
if Finish < Start then Finish +:= 1573040; // Number of ticks in 24 hours
Result:= Finish - Start;
{$else}
Result := Finish - Start;
{$endif}
end;

function ULZTimerResolution: Double;
begin
{$ifdef __DOS__}
Result := 0.054925;
{$else}
Result := 0.001;
{$endif}
end;

procedure ULZDelay(Value: DWord);
var
CurValue: DWord;
begin
CurValue := ULZTimerLap + Value;
while ULZTimerLap < CurValue do (* nothing *)
end;

procedure LZTimer.ComputeTime;
var
newcount: DWord;
begin
if not _overflow then
begin
newcount := LZTimerCount;
if newcount = $FFFFFFFF then
_overflow := TRUE
else
_count +:= newcount;
end;
end;

procedure LZTimer.LZTimer;
begin
ZTimerInit;
Reset;
end;

procedure LZTimer.Start;
begin
_count := 0;
LZTimerOn;
end;

procedure LZTimer.Restart;
begin
Reset;
Start;
end;

procedure LZTimer.Stop;
begin
LZTimerOff;
ComputeTime;
end;

function LZTimer.Lap: DWord;
begin
Result := _count + LZTimerLap;
end;

function LZTimer.Count: DWord;
begin
Result := _count;
end;

procedure LZTimer.Reset;
begin
_count := 0;
_overflow := FALSE;
end;

function LZTimer.Overflow: Boolean;
begin
Result := _overflow;
end;

function LZTimer.Resolution: Double;
begin
Result := 1E-6;
end;

procedure LZTimer.Delay(Value: DWord);
begin
LZDelay(Value);
end;

procedure ULZTimer.ULZTimer;
begin
ZTimerInit;
_count := 0;
end;

procedure ULZTimer.Start;
begin
_start := ULZReadTime;
end;

procedure ULZTimer.Restart;
begin
Reset;
Start;
end;

function ULZTimer.Lap: DWord;
begin
Result:= ULZElapsedTime(_start,ULZReadTime);
end;

procedure ULZTimer.Stop;
begin
_finish := ULZReadTime;
_count +:= ULZElapsedTime(_start,_finish);
end;

function ULZTimer.Count: DWord;
begin
Result :=_count;
end;

procedure ULZTimer.Reset;
begin
_count := 0;
end;

function ULZTimer.Resolution: Double;
begin
{$ifdef __DOS__}
Result := 0.054925;
{$else}
Result := 0.001;
{$endif}
end;

procedure ULZTimer.Delay(Value: DWord);
begin
ULZDelay(Value);
end;

begin
CpuSpeed := -1;
FillChar(tmStart, SizeOf(tmStart), 0);
FillChar(tmEnd, SizeOf(tmEnd), 0);
ZTimerInit;
end.