Category : Files from Magazines
Archive   : VOL6N20.ZIP
Filename : PROFILE.PRF

const
NumBins = 4096 ;
Old_Int8 : record {This MUST be a typed constant}
offset,
segment : integer ;
end = ( offset : 0 ; segment : 0 ) ;
DS_Save : integer = 0 ; {Use this to save Turbo's data segment}
{This MUST be a typed constant}
CountSeg : integer = 0 ;
CountOfs : integer = 0 ;
BlockSize : integer = 0 ;
BinSize : integer = 0 ;
Active : boolean = false ;
NotBusy : boolean = true ;
NoOverflow : boolean = true ;
IntCount : integer = 0 ;
NumInts : integer = 0 ;


{ The procedure Profile keeps track of program execution. It is hooked into }
{ the hardware clock tick interrupt, so that whenever a clock tick occurs it }
{ is executed. The rest of the procedures take care of installing and }
{ removing Profile. }

procedure Profile ;
var
BinNo,
ProgSeg,
ProgOfs,
Count : integer ;
begin
Inline(
$50 { push ax ; save registers}
/$53 { push bx}
/$51 { push cx}
/$52 { push dx}
/$56 { push si}
/$57 { push di}
/$1E { push ds}
/$06 { push es}
/$2E/$8E/$1E/>DS_SAVE {cs: mov ds, [>DS_Save] ; get original data segment}
);

IntCount := succ( IntCount ) ;
if IntCount = NumInts then
begin { call the old interrupt handler every IntCount interrupts }
IntCount := 0 ;
Inline(
$9C { pushf ; simulate interrupt}
/$2E/$FF/$1E/>OLD_INT8 {cs: call far [>Old_Int8] ; chain to old int 8 routine}
);
end
else
InLine(
$B0/$20 { mov al, $20 ; tell interrupt controller}
/$E6/$20 { out $20, al ; we're ready to handle clock interrupts}
);

if (NotBusy and Active and NoOverflow) then
begin
NotBusy := false ; { make sure Profile doesn't get called again while it's executing }
Inline(
$FB { sti ; enable interrupts}
/$8B/$46/$04 { mov ax, [bp+$04] ; get value for ProgSeg}
/$89/$86/>PROGSEG { mov [bp+>ProgSeg], ax ; store it}
/$8B/$46/$02 { mov ax, [bp+$02] ; get value for ProgOfs}
/$89/$86/>PROGOFS { mov [bp+>ProgOfs], ax ; store it}
);

if ProgSeg = CountSeg then { see if we're in the code area being profiled }
begin
if ((ProgOfs + $8000) >= (CountOfs + $8000)) then { unsigned compare }
begin
ProgOfs := ProgOfs - CountOfs ;
if ((ProgOfs + $8000) < (BlockSize + $8000)) then
begin
BinNo := ProgOfs div BinSize ;
Count := Bin^[BinNo] ;
if Count < MaxInt then
Bin^[BinNo] := succ(Count) { count it }
else
NoOverflow := false ; { or shut off profiler if data array is full }
end;
end;
end;

Inline(
$FA { cli ; disable interrupts}
);
NotBusy := true ;
end;
Inline(
$07 { pop es ; restore registers}
/$1F { pop ds}
/$5F { pop di}
/$5E { pop si}
/$5A { pop dx}
/$59 { pop cx}
/$5B { pop bx}
/$58 { pop ax}
/$8B/$E5 { mov sp, bp ; clean up stack }
/$5D { pop bp}
/$CF { iret}
);
end; { procedure Profile }


{ Save the address of the old hardware clock tick interrupt handler }
procedure Save_Old_Timer;
begin
with Regs do
begin
AH := $35;
AL := 8;
MsDos(Regs);
Old_Int8.segment := ES;
Old_Int8.offset := BX;
end;
end;

{ Install Profile as the new hardware clock tick interrupt handler }
procedure Install_New_Timer;
begin
with Regs do
begin
AH := $25;
AL := 8;
DS := CSeg;
DX := Ofs(Profile);
MsDos(Regs);
end;
end;

procedure Restore_Old_Timer;
begin
with Regs do
begin
AH := $25;
AL := 8;
DS := Old_Int8.segment;
DX := Old_Int8.offset;
MsDos(Regs);
end;
end;


{ Set the speedup factor. Ordinarily, the hardware clock tick interrupt }
{ occurs 18.2 times per second. This procedure speeds it up so that it }
{ NumInts*18.2 times per second. }
{ This causes Profile to be executed NumInts*18.2 times each second. Profile }
{ itself chains to the old hardware clock tick interrupt handler once for }
{ every NumInts calls, thus maintaining the original system timing. }

procedure SetSpeed ;
var
Cnt : integer ;
begin
if NumInts = 1 then Cnt := 0
else Cnt := trunc(65536./NumInts) ;
Inline(
$FA { cli ; disable interrupts}
/$B0/$36 { mov al, $36 ; timer 0, mode 3, send lsb then msb}
/$E6/$43 { out $43, al ; write mode control word}
/$8B/$9E/>CNT { mov bx,[bp+>Cnt] ; get new countdown value}
/$88/$D8 { mov al, bl ; copy lsb of new value}
/$E6/$40 { out $40, al ; send lsb}
/$88/$F8 { mov al, bh ; copy msb of new value}
/$E6/$40 { out $40, al ; send msb}
/$FB { sti ; enable interrupts}
);
end; { procedure SetSpeed }

{ Copy the program's environment into local storage and add the string }
{ "PRFDATA=Seg:Ofs", with Seg and Ofs as decimal numbers. These numbers}
{ give the location of the data areas which must be filled in by the }
{ program to be executed. They tell the profiler what region of memory }
{ to watch. }

procedure SetEnvStr( Segment, Offset : integer );
var
TempStr : string[5] ;
Text : string[20] ;
begin
str( Segment:1, TempStr ) ;
Text := 'PRFDATA=' + TempStr + ':' ;
str( Offset:1, TempStr ) ;
Text := Text + TempStr;
AddEnvStr( Text );
end; { procedure SetEnvStr( Segm, Offs : integer ) }


{ Install the Profile procedure as the clock tick interrupt handler, taking }
{ care of all the bookkeeping necessary and initializing parameters. }
procedure Install_Int ;
begin
New( Bin ) ;
FillChar( Bin^[0], 8192, chr(0) ) ;
NotBusy := true ;
Active := true ;
NoOverflow := true ;
SetEnvStr( CSeg, Ofs( CountSeg ) ) ;
DS_Save := DSeg ;
IntCount := 0 ;
Save_Old_Timer ;
Install_New_Timer ;
SetSpeed ;
end; { procedure Install_Int }

{ Remove the profiler from the clock tick interrupt, restore the old vector, }
{ and restore the old clock frequency. }
procedure Remove_Int ;
begin
Restore_Old_Timer ;
NumInts := 1 ;
SetSpeed ; { set speedup factor to 1 to restore original timing }
end; { procedure Remove_Int }


{ If there were no parameters given on the command line, prompt for the }
{ command string to be profiled. Otherwise, pass the command line on. }

Procedure GetString( var Command : string255 ) ;
var
I : integer;
begin
if ParamCount = 0 then
begin
FastWrite( 'Command String ( to exit):', 5, 1, TextAttr ) ;
GotoXY( 32, 5 ) ;
ReadLn( Command ) ;
HideCursor ;
if Command = '' then
begin
Clrscr;
Halt;
end;
end
else
begin
Command := '' ;
for I := 1 to ParamCount do
Command := Command + ParamStr(I) + ' ' ;
Command[0] := pred(Command[0]) ;
end;
end; { procedure GetString( var Command : string255 ) }

{ Initialize the program }
procedure Init_Profiler ;
begin
GetString( Command ) ;
FastWrite( 'Speedup factor (1-75):', 6, 1, TextAttr ) ;
GotoXY( 24, 6 ) ;
ReadLn( NumInts ) ;
HideCursor ;
if NumInts < 1 then NumInts := 1 ;
if NumInts > 75 then NumInts := 75 ;
Install_Int ;
end; { procedure Init_Profiler }