paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 02:26:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ added $error if compiled with -pg

Browse Source 
+ all output to stderr
This commit is contained in:
pierre 1998-11-18 09:22:10 +00:00
parent 50ccd479d2
commit 16524901b4
1 changed files with 41 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
rtl/dos/go32v2/profile.pp
View File

@ -17,6 +17,11 @@
} }
{$S- do not use stackcheck here .. PM } {$S- do not use stackcheck here .. PM }
{$ifdef FPC_PROFILE}
{$error }
{$message you can not compile profile unit with profiling}
{$endif FPC_PROFILE}
Unit profile; Unit profile;
interface interface
@ -54,14 +59,11 @@ var
no lookup. } no lookup. }
procedure mcount; procedure mcount;
implementation implementation
uses uses
go32,dpmiexcp; go32,dpmiexcp;
{$ASMMODE ATT}
type type
plongint = ^longint; plongint = ^longint;
var var
@ -69,6 +71,27 @@ var
const const
cache : pMTABE = nil; cache : pMTABE = nil;
(*
{$ASMMODE DIRECT}
procedure sbrk_getmem(var p : pointer;size : longint);assembler;
asm
movl size,%eax
pushl %eax
call ___sbrk
addl $4,%esp
movl %eax,p
end;
this nice piece of code make serious problems !!! PM *)
procedure sbrk_getmem(var p : pointer;size : longint);
begin
system.getmem(p,size);
end;
{$ASMMODE ATT}
{ problem how to avoid mcount calling itself !! } { problem how to avoid mcount calling itself !! }
procedure mcount; [public, alias : 'MCOUNT']; procedure mcount; [public, alias : 'MCOUNT'];
{ {
@ -151,7 +174,9 @@ begin
end; end;
end; end;
{ lob off another page of memory and initialize the new table } { lob off another page of memory and initialize the new table }
getmem(m,sizeof(M_TAB)); { problem here : getmem is not reentrant yet !! PM }
{ lets hope that a direct call to sbrk correct this }
sbrk_getmem(m,sizeof(M_TAB));
fillchar(m^, sizeof(M_TAB),#0); fillchar(m^, sizeof(M_TAB),#0);
m^.prev := mtab; m^.prev := mtab;
mtab := m; mtab := m;
@ -206,7 +231,7 @@ begin
movl _RELOAD,%eax movl _RELOAD,%eax
movl %eax,___djgpp_timer_countdown movl %eax,___djgpp_timer_countdown
end; end;
mcount_tick(x); timer:=mcount_tick(x);
{ _raise(SIGPROF); } { _raise(SIGPROF); }
end; end;
@ -226,13 +251,13 @@ begin
set_pm_interrupt($8,old_timer); set_pm_interrupt($8,old_timer);
reload:=0; reload:=0;
exitproc:=oldexitproc; exitproc:=oldexitproc;
writeln('Writing profile output'); writeln(stderr,'Writing profile output');
writeln('histogram length = ',histlen); writeln(stderr,'histogram length = ',histlen);
writeln('Nb of double calls = ',doublecall); writeln(stderr,'Nb of double calls = ',doublecall);
if invalid_mcount_call>0 then if invalid_mcount_call>0 then
writeln('nb of invalid mcount : ',invalid_mcount_call,'/',mcount_nb) writeln(stderr,'nb of invalid mcount : ',invalid_mcount_call,'/',mcount_nb)
else else
writeln('nb of mcount : ',mcount_nb); writeln(stderr,'nb of mcount : ',mcount_nb);
assign(f,'gmon.out'); assign(f,'gmon.out');
rewrite(f,1); rewrite(f,1);
blockwrite(f, h, sizeof(header)); blockwrite(f, h, sizeof(header));
@ -247,7 +272,7 @@ begin
blockwrite(f, m^.calls[i],sizeof(MTABE)); blockwrite(f, m^.calls[i],sizeof(MTABE));
{$ifdef DEBUG} {$ifdef DEBUG}
if m^.calls[i].count>0 then if m^.calls[i].count>0 then
writeln(' 0x',hexstr(m^.calls[i]._to,8),' called from ',hexstr(m^.calls[i].from,8), writeln(stderr,' 0x',hexstr(m^.calls[i]._to,8),' called from ',hexstr(m^.calls[i].from,8),
' ',m^.calls[i].count,' times'); ' ',m^.calls[i].count,' times');
{$endif DEBUG} {$endif DEBUG}
end; end;
@ -330,7 +355,11 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.3 1998-11-17 09:43:22 pierre Revision 1.4 1998-11-18 09:22:10 pierre
+ added $error if compiled with -pg
+ all output to stderr
Revision 1.3 1998/11/17 09:43:22 pierre
+ No stack check + No stack check
Revision 1.2 1998/05/31 14:18:28 peter Revision 1.2 1998/05/31 14:18:28 peter