home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast.iso / pcmag / vol6n20.zip / PROFIL.ZIP / PROFILE.PRF < prev    next >
Text File  |  1987-01-11  |  9KB  |  262 lines
  1. const
  2.   NumBins = 4096 ;
  3.   Old_Int8 : record           {This MUST be a typed constant}
  4.                offset,
  5.                segment : integer ;
  6.              end = ( offset : 0 ; segment : 0 ) ;
  7.   DS_Save : integer = 0 ;     {Use this to save Turbo's data segment}
  8.                               {This MUST be a typed constant}
  9.   CountSeg      : integer = 0 ;
  10.   CountOfs      : integer = 0 ;
  11.   BlockSize     : integer = 0 ;
  12.   BinSize       : integer = 0 ;
  13.   Active        : boolean = false ;
  14.   NotBusy       : boolean = true ;
  15.   NoOverflow    : boolean = true ;
  16.   IntCount      : integer = 0 ;
  17.   NumInts       : integer = 0 ;
  18.  
  19.  
  20. { The procedure Profile keeps track of program execution.  It is hooked into }
  21. { the hardware clock tick interrupt, so that whenever a clock tick occurs it }
  22. { is executed.  The rest of the procedures take care of installing and       }
  23. { removing Profile.                                                          }
  24.  
  25. procedure Profile ;
  26. var
  27.   BinNo,
  28.   ProgSeg,
  29.   ProgOfs,
  30.   Count     : integer ;
  31. begin
  32.   Inline(
  33.     $50                    {        push ax                    ; save registers}
  34.     /$53                   {        push bx}
  35.     /$51                   {        push cx}
  36.     /$52                   {        push dx}
  37.     /$56                   {        push si}
  38.     /$57                   {        push di}
  39.     /$1E                   {        push ds}
  40.     /$06                   {        push es}
  41.     /$2E/$8E/$1E/>DS_SAVE  {cs:     mov ds, [>DS_Save]         ; get original data segment}
  42.     );
  43.  
  44.   IntCount := succ( IntCount ) ;
  45.   if IntCount = NumInts then
  46.   begin                      { call the old interrupt handler every IntCount interrupts }
  47.     IntCount := 0 ;
  48.     Inline(
  49.       $9C                    {        pushf                      ; simulate interrupt}
  50.       /$2E/$FF/$1E/>OLD_INT8 {cs:     call far [>Old_Int8]       ; chain to old int 8 routine}
  51.     );
  52.   end
  53.   else
  54.     InLine(
  55.       $B0/$20                {        mov al, $20                ; tell interrupt controller}
  56.       /$E6/$20               {        out $20, al                ; we're ready to handle clock interrupts}
  57.     );
  58.  
  59.   if (NotBusy and Active and NoOverflow) then
  60.   begin
  61.     NotBusy := false ;       {        make sure Profile doesn't get called again while it's executing }
  62.     Inline(
  63.       $FB                    {        sti                        ; enable interrupts}
  64.       /$8B/$46/$04           {        mov ax, [bp+$04]           ; get value for ProgSeg}
  65.       /$89/$86/>PROGSEG      {        mov [bp+>ProgSeg], ax      ; store it}
  66.       /$8B/$46/$02           {        mov ax, [bp+$02]           ; get value for ProgOfs}
  67.       /$89/$86/>PROGOFS      {        mov [bp+>ProgOfs], ax      ; store it}
  68.     );
  69.  
  70.     if ProgSeg = CountSeg then        { see if we're in the code area being profiled }
  71.     begin
  72.       if ((ProgOfs + $8000) >= (CountOfs + $8000)) then  { unsigned compare }
  73.       begin
  74.         ProgOfs := ProgOfs - CountOfs ;
  75.         if ((ProgOfs + $8000) < (BlockSize + $8000)) then
  76.         begin
  77.           BinNo := ProgOfs div BinSize ;
  78.           Count := Bin^[BinNo] ;
  79.           if Count < MaxInt then
  80.              Bin^[BinNo] := succ(Count)  { count it }
  81.           else
  82.              NoOverflow := false ;       { or shut off profiler if data array is full }
  83.         end;
  84.       end;
  85.     end;
  86.  
  87.     Inline(
  88.       $FA                    {       cli                         ; disable interrupts}
  89.     );
  90.     NotBusy := true ;
  91.   end;
  92.   Inline(
  93.     $07                    {       pop es                      ; restore registers}
  94.     /$1F                   {       pop ds}
  95.     /$5F                   {       pop di}
  96.     /$5E                   {       pop si}
  97.     /$5A                   {       pop dx}
  98.     /$59                   {       pop cx}
  99.     /$5B                   {       pop bx}
  100.     /$58                   {       pop ax}
  101.     /$8B/$E5               {       mov sp, bp                  ; clean up stack }
  102.     /$5D                   {       pop bp}
  103.     /$CF                   {       iret}
  104.   );
  105. end; { procedure Profile  }
  106.  
  107.  
  108. { Save the address of the old hardware clock tick interrupt handler }
  109. procedure Save_Old_Timer;
  110. begin
  111.   with Regs do
  112.   begin
  113.     AH := $35;
  114.     AL := 8;
  115.     MsDos(Regs);
  116.     Old_Int8.segment := ES;
  117.     Old_Int8.offset := BX;
  118.   end;
  119. end;
  120.  
  121. { Install Profile as the new hardware clock tick interrupt handler }
  122. procedure Install_New_Timer;
  123. begin
  124.   with Regs do
  125.   begin
  126.     AH := $25;
  127.     AL := 8;
  128.     DS := CSeg;
  129.     DX := Ofs(Profile);
  130.     MsDos(Regs);
  131.   end;
  132. end;
  133.  
  134. procedure Restore_Old_Timer;
  135. begin
  136.   with Regs do
  137.   begin
  138.     AH := $25;
  139.     AL := 8;
  140.     DS := Old_Int8.segment;
  141.     DX := Old_Int8.offset;
  142.     MsDos(Regs);
  143.   end;
  144. end;
  145.  
  146.  
  147. { Set the speedup factor.  Ordinarily, the hardware clock tick interrupt     }
  148. { occurs 18.2 times per second.  This procedure speeds it up so that it      }
  149. { NumInts*18.2 times per second.                                             }
  150. { This causes Profile to be executed NumInts*18.2 times each second. Profile }
  151. { itself chains to the old hardware clock tick interrupt handler once for    }
  152. { every NumInts calls, thus maintaining the original system timing.          }
  153.  
  154. procedure SetSpeed ;
  155. var
  156.   Cnt : integer ;
  157. begin
  158.   if NumInts = 1 then Cnt := 0
  159.   else Cnt := trunc(65536./NumInts) ;
  160.   Inline(
  161.     $FA                    {       cli               ; disable interrupts}
  162.     /$B0/$36               {       mov al, $36       ; timer 0, mode 3, send lsb then msb}
  163.     /$E6/$43               {       out $43, al       ; write mode control word}
  164.     /$8B/$9E/>CNT          {       mov bx,[bp+>Cnt]  ; get new countdown value}
  165.     /$88/$D8               {       mov al, bl        ; copy lsb of new value}
  166.     /$E6/$40               {       out $40, al       ; send lsb}
  167.     /$88/$F8               {       mov al, bh        ; copy msb of new value}
  168.     /$E6/$40               {       out $40, al       ; send msb}
  169.     /$FB                   {       sti               ; enable interrupts}
  170.   );
  171. end; { procedure SetSpeed  }
  172.  
  173. { Copy the program's environment into local storage and add the string  }
  174. { "PRFDATA=Seg:Ofs", with Seg and Ofs as decimal numbers.  These numbers}
  175. { give the location of the data areas which must be filled in by the    }
  176. { program to be executed.  They tell the profiler what region of memory }
  177. { to watch.                                                             }
  178.  
  179. procedure SetEnvStr( Segment, Offset : integer );
  180. var
  181.   TempStr : string[5] ;
  182.   Text    : string[20] ;
  183. begin
  184.   str( Segment:1, TempStr ) ;
  185.   Text := 'PRFDATA=' + TempStr + ':' ;
  186.   str( Offset:1, TempStr ) ;
  187.   Text := Text + TempStr;
  188.   AddEnvStr( Text );
  189. end; { procedure SetEnvStr( Segm, Offs : integer ) }
  190.  
  191.  
  192. { Install the Profile procedure as the clock tick interrupt handler, taking   }
  193. { care of all the bookkeeping necessary and initializing parameters.          }
  194. procedure Install_Int ;
  195. begin
  196.   New( Bin ) ;
  197.   FillChar( Bin^[0], 8192, chr(0) ) ;
  198.   NotBusy := true ;
  199.   Active := true ;
  200.   NoOverflow := true ;
  201.   SetEnvStr( CSeg, Ofs( CountSeg ) ) ;
  202.   DS_Save := DSeg ;
  203.   IntCount := 0 ;
  204.   Save_Old_Timer ;
  205.   Install_New_Timer ;
  206.   SetSpeed ;
  207. end; { procedure Install_Int }
  208.  
  209. { Remove the profiler from the clock tick interrupt, restore the old vector, }
  210. { and restore the old clock frequency.                                       }
  211. procedure Remove_Int ;
  212. begin
  213.   Restore_Old_Timer ;
  214.   NumInts := 1 ;
  215.   SetSpeed ;   { set speedup factor to 1 to restore original timing }
  216. end; { procedure Remove_Int  }
  217.  
  218.  
  219. { If there were no parameters given on the command line, prompt for the       }
  220. { command string to be profiled.  Otherwise, pass the command line on.        }
  221.  
  222. Procedure GetString( var Command : string255 ) ;
  223. var
  224.   I : integer;
  225. begin
  226.   if ParamCount = 0 then
  227.   begin
  228.     FastWrite( 'Command String (<CR> to exit):', 5, 1, TextAttr ) ;
  229.     GotoXY( 32, 5 ) ;
  230.     ReadLn( Command ) ;
  231.     HideCursor ;
  232.     if Command = '' then
  233.     begin
  234.       Clrscr;
  235.       Halt;
  236.     end;
  237.   end
  238.   else
  239.   begin
  240.     Command := '' ;
  241.     for I := 1 to ParamCount do
  242.         Command := Command + ParamStr(I) + ' ' ;
  243.     Command[0] := pred(Command[0]) ;
  244.   end;
  245. end; { procedure GetString( var Command : string255 ) }
  246.  
  247. { Initialize the program }
  248. procedure Init_Profiler ;
  249. begin
  250.   GetString( Command ) ;
  251.   FastWrite( 'Speedup factor (1-75):', 6, 1, TextAttr ) ;
  252.   GotoXY( 24, 6 ) ;
  253.   ReadLn( NumInts ) ;
  254.   HideCursor ;
  255.   if NumInts < 1 then NumInts := 1 ;
  256.   if NumInts > 75 then NumInts := 75 ;
  257.   Install_Int ;
  258. end; { procedure Init_Profiler  }
  259.  
  260.  
  261.  
  262.