development/compilers/freepascal/rtl/go32v2/profile.pp

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by Pierre Muller,
   5     member of the Free Pascal development team.
   6
   7     Profiling support for Go32V2
   8
   9     See the file COPYING.FPC, included in this distribution,
  10     for details about the copyright.
  11
  12     This program is distributed in the hope that it will be useful,
  13     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  15
  16  **********************************************************************
  17 }
  18
  19 {$S- do not use stackcheck here .. PM }
  20 {$ifdef FPC_PROFILE}
  21 {$error }
  22 {$message you can not compile profile unit with profiling}
  23 {$endif FPC_PROFILE}
  24
  25 Unit profile;
  26
  27 interface
  28
  29 type
  30   header = record
  31     low,high,nbytes : longint;
  32   end;
  33
  34 { entry of a GPROF type file }
  35   ppMTABE = ^pMTABE;
  36   pMTABE = ^MTABE;
  37   MTABE = record
  38     from,_to,count : longint;
  39   end;
  40
  41 { internal form - sizeof(MTAB) is 4096 for efficiency }
  42   PMTAB = ^M_TAB;
  43   M_TAB  = record
  44     calls : array [0..340] of MTABE;
  45     prev  : PMTAB;
  46   end;
  47
  48 const
  49   mcount_skip : longint = 1;
  50   mtab        : PMTAB = nil;
  51 var
  52   h           : header;
  53   histogram   : ^integer;
  54   histlen     : longint;
  55   oldexitproc : pointer;
  56
  57 { called by functions.  Use the pointer it provides to cache the last used
  58   MTABE, so that repeated calls to/from the same pair works quickly -
  59   no lookup. }
  60 procedure mcount;
  61
  62 implementation
  63
  64 {$asmmode ATT}
  65
  66 uses
  67   go32,dpmiexcp;
  68
  69 type
  70   plongint = ^longint;
  71 const
  72   cache : pMTABE = nil;
  73
  74 var
  75   djgpp_old_timer : tseginfo;external name '___djgpp_old_timer';
  76   start : longint;external name 'start';
  77   _etext : longint;external name '_etext';
  78   starttext : longint;
  79   endtext : longint;
  80
  81 procedure djgpp_timer_hdlr;external name '___djgpp_timer_hdlr';
  82
  83 procedure sbrk_getmem(var p : pointer;size : longint);
  84
  85   begin
  86      system.getmem(p,size);
  87   end;
  88
  89
  90 { problem how to avoid mcount calling itself !! }
  91 procedure mcount;  [public, alias : 'MCOUNT'];
  92 {
  93   ebp contains the frame of mcount (ebp) the frame of calling (to_)
  94   ((ebp)) the frame of from
  95 }
  96 var
  97    m : pmtab;
  98    i,to_,ebp,from,mtabi : longint;
  99 begin
 100    { optimisation !! }
 101    asm
 102       pushal
 103       movl 4(%ebp),%eax
 104       movl %eax,to_
 105       movl (%ebp),%eax
 106       movl 4(%eax),%eax
 107       movl %eax,from
 108    end;
 109    if endtext=0 then
 110      asm
 111         popal
 112         leave
 113         ret
 114      end;
 115    mcount_skip := 1;
 116    if (to_ > endtext) or (from > endtext) then
 117      runerror(255);
 118    if ((cache<>nil) and (cache^.from=from) and (cache^._to=to_)) then
 119      begin
 120      { cache paid off - works quickly }
 121        inc(cache^.count);
 122        mcount_skip:=0;
 123        asm
 124          popal
 125          leave
 126          ret
 127        end;
 128      end;
 129 { no cache hit - search all mtab tables for a match, or an empty slot }
 130   mtabi := -1;
 131   m:=mtab;
 132   while m<>nil do
 133     begin
 134        for i:=0 to 340 do
 135          begin
 136            if m^.calls[i].from=0 then
 137              begin
 138               { empty slot - end of table }
 139                 mtabi := i;
 140                 break;
 141              end;
 142            if ((m^.calls[i].from = from) and (m^.calls[i]._to = to_)) then
 143              begin
 144               { found a match - bump count and return }
 145                 inc(m^.calls[i].count);
 146                 cache:=@(m^.calls[i]);
 147                 mcount_skip:=0;
 148                 asm
 149                    popal
 150                    leave
 151                    ret
 152                 end;
 153              end;
 154         end;
 155       m:=m^.prev;
 156    end;
 157   if (mtabi<>-1) then
 158     begin
 159      { found an empty - fill it in }
 160        mtab^.calls[mtabi].from := from;
 161        mtab^.calls[mtabi]._to := to_;
 162        mtab^.calls[mtabi].count := 1;
 163        cache := @(mtab^.calls[mtabi]);
 164        mcount_skip := 0;
 165        asm
 166           popal
 167           leave
 168           ret
 169        end;
 170     end;
 171 { lob off another page of memory and initialize the new table }
 172   { problem here : getmem is not reentrant yet !!  PM }
 173   { lets hope that a direct call to sbrk correct this }
 174   sbrk_getmem(m,sizeof(M_TAB));
 175   fillchar(m^, sizeof(M_TAB),#0);
 176   m^.prev := mtab;
 177   mtab := m;
 178   m^.calls[0].from := from;
 179   m^.calls[0]._to := to_;
 180   m^.calls[0].count := 1;
 181   cache := @(m^.calls[0]);
 182   mcount_skip := 0;
 183   asm
 184      popal
 185      leave
 186      ret
 187   end;
 188 end;
 189
 190
 191 var
 192   new_timer,
 193   old_timer       : tseginfo;
 194   invalid_mcount_call,
 195   mcount_nb,
 196   doublecall,
 197   reload          : longint; {=0}
 198
 199 function mcount_tick(x : longint) : longint;
 200 var
 201   bin : longint;
 202 begin
 203    if mcount_skip=0 then
 204      begin
 205         bin := djgpp_exception_state^.__eip;
 206         if (djgpp_exception_state^.__cs=get_cs) and (bin >= starttext) and (bin <= endtext) then
 207           begin
 208              bin := (bin - starttext) div 16;
 209              inc(histogram[bin]);
 210           end
 211         else
 212           inc(invalid_mcount_call);
 213         inc(mcount_nb);
 214      end
 215    else
 216      inc(doublecall);
 217    mcount_tick:=0;
 218 end;
 219
 220
 221 var
 222   ___djgpp_timer_countdown:longint;external name '___djgpp_timer_countdown';
 223
 224 function timer(x : longint) : longint;
 225 begin
 226    if reload>0 then
 227     ___djgpp_timer_countdown:=RELOAD;
 228    timer:=mcount_tick(x);
 229    { _raise(SIGPROF); }
 230 end;
 231
 232
 233 procedure mcount_write;
 234 {
 235   this is called during program exit
 236 }
 237 var
 238   m : PMTAB;
 239   i : longint;
 240   f : file;
 241 begin
 242   mcount_skip:=1;
 243   signal(SIGTIMR,@SIG_IGN);
 244   signal(SIGPROF,@SIG_IGN);
 245   set_pm_interrupt($8,old_timer);
 246   reload:=0;
 247   exitproc:=oldexitproc;
 248   writeln(stderr,'Writing profile output');
 249   writeln(stderr,'histogram length = ',histlen);
 250   writeln(stderr,'Nb of double calls = ',doublecall);
 251   if invalid_mcount_call>0 then
 252     writeln(stderr,'nb of invalid mcount : ',invalid_mcount_call,'/',mcount_nb)
 253   else
 254     writeln(stderr,'nb of mcount : ',mcount_nb);
 255   assign(f,'gmon.out');
 256   rewrite(f,1);
 257   blockwrite(f, h, sizeof(header));
 258   blockwrite(f, histogram^, histlen);
 259   m:=mtab;
 260   while m<>nil do
 261     begin
 262        for i:=0 to 340 do
 263          begin
 264             if (m^.calls[i].from = 0) then
 265               break;
 266             blockwrite(f, m^.calls[i],sizeof(MTABE));
 267 {$ifdef DEBUG}
 268             if m^.calls[i].count>0 then
 269               writeln(stderr,'  0x',hexstr(m^.calls[i]._to,8),' called from ',hexstr(m^.calls[i].from,8),
 270                 ' ',m^.calls[i].count,' times');
 271 {$endif DEBUG}
 272          end;
 273        m:=m^.prev;
 274     end;
 275   close(f);
 276 end;
 277
 278
 279 procedure mcount_init;
 280 {
 281   this is called to initialize profiling before the program starts
 282 }
 283
 284   procedure set_old_timer_handler;
 285     begin
 286       djgpp_old_timer:=Old_Timer;
 287     end;
 288
 289 begin
 290   starttext:=longint(@start);
 291   endtext:=longint(@_etext);
 292   h.low := starttext;
 293   h.high := endtext;
 294   histlen := ((h.high-h.low) div 16) * 2; { must be even }
 295   h.nbytes := sizeof(header) + histlen;
 296   getmem(histogram,histlen);
 297   fillchar(histogram^, histlen,#0);
 298
 299   oldexitproc:=exitproc;
 300   exitproc:=@mcount_write;
 301
 302 { here, do whatever it takes to initialize the timer interrupt }
 303   signal(SIGPROF,@mcount_tick);
 304   signal(SIGTIMR,@timer);
 305
 306   get_pm_interrupt($8,old_timer);
 307   set_old_timer_handler;
 308 {$ifdef DEBUG}
 309   writeln(stderr,'ori pm int8  '+hexstr(old_timer.segment,4)+':'+hexstr(longint(old_timer.offset),8));
 310   flush(stderr);
 311 {$endif DEBUG}
 312   new_timer.segment:=get_cs;
 313   new_timer.offset:=@djgpp_timer_hdlr;
 314   reload:=3;
 315 {$ifdef DEBUG}
 316   writeln(stderr,'new pm int8  '+hexstr(new_timer.segment,4)+':'+hexstr(longint(new_timer.offset),8));
 317   flush(stderr);
 318 {$endif DEBUG}
 319   set_pm_interrupt($8,new_timer);
 320   reload:=1;
 321   ___djgpp_timer_countdown:=RELOAD;
 322   mcount_skip := 0;
 323 end;
 324
 325
 326 begin
 327   mcount_init;
 328 end.
 329 {
 330   $Log$
 331   Revision 1.1  2002/02/19 08:25:13  sasu
 332   Initial revision
 333
 334   Revision 1.1  2000/07/13 06:30:39  michael
 335   + Initial import
 336
 337   Revision 1.7  2000/03/28 10:06:19  pierre
 338    * fix for 885
 339
 340   Revision 1.6  2000/03/20 13:09:07  pierre
 341    * fix for bug 876
 342
 343   Revision 1.5  2000/02/09 16:59:29  peter
 344     * truncated log
 345
 346   Revision 1.4  2000/01/07 16:41:32  daniel
 347     * copyright 2000
 348
 349   Revision 1.3  2000/01/07 16:32:23  daniel
 350     * copyright 2000 added
 351
 352 }