(****************************************************************************
*                                                                           *
*                            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 3                                        *
* 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  $        *
*                                                                           *
*****************************************************************************)
{$w-,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_UnkPentium  = 7;            // Unknown Intel Pentium family processor

CpuTypes: array [0..7] of string[20] =
(
'Unknown',
'Intel 80386',
'Intel 80486',
'Intel Pentium(R)',
'Intel PentiumPro(R)',
'Intel PentiumII(R)',
'Intel PentiumIII(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;
         if model = 1 then
          cpu := CPU_PentiumPro
         else
          cpu := CPU_PentiumII;
        end;
     7: cpu := CPU_PentiumIII;
     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
        ((abs(3 * freq -total) > (3*TOLERANCE)) or
        ( abs(3 * freq2-total) > (3*TOLERANCE)) or
        ( abs(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.