paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-30 02:31:59 +01:00
Code Issues Packages Projects Releases Wiki Activity

* several extra_size_info fixes

Browse Source
This commit is contained in:
pierre 1999-11-09 22:32:23 +00:00
parent ec77ff77ee
commit bd7d22c00f
1 changed files with 64 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
rtl/inc/heaptrc.pp
View File

@ -78,6 +78,8 @@ const
{ function to fill this info up } { function to fill this info up }
fill_extra_info : FillExtraInfoType = nil; fill_extra_info : FillExtraInfoType = nil;
error_in_heap : boolean = false; error_in_heap : boolean = false;
inside_trace_getmem : boolean = false;
type type
pheap_mem_info = ^theap_mem_info; pheap_mem_info = ^theap_mem_info;
{ warning the size of theap_mem_info { warning the size of theap_mem_info
@ -93,7 +95,7 @@ type
sig : longint; sig : longint;
{$ifdef EXTRA} {$ifdef EXTRA}
release_sig : longint; release_sig : longint;
next_valid : pheap_mem_info; prev_valid : pheap_mem_info;
{$endif EXTRA} {$endif EXTRA}
calls : array [1..tracesize] of longint; calls : array [1..tracesize] of longint;
extra_info : record extra_info : record
@ -299,7 +301,7 @@ begin
end; end;
function is_in_getmem_list (p : pointer) : boolean; function is_in_getmem_list (p : pheap_mem_info) : boolean;
var var
i : longint; i : longint;
pp : pheap_mem_info; pp : pheap_mem_info;
@ -363,27 +365,32 @@ begin
pheap_mem_info(p)^.previous:=heap_mem_root; pheap_mem_info(p)^.previous:=heap_mem_root;
pheap_mem_info(p)^.next:=nil; pheap_mem_info(p)^.next:=nil;
{$ifdef EXTRA} {$ifdef EXTRA}
pheap_mem_info(p)^.next_valid:=nil; pheap_mem_info(p)^.prev_valid:=heap_valid_last;
if assigned(heap_valid_last) then
heap_valid_last^.next_valid:=pheap_mem_info(p);
heap_valid_last:=pheap_mem_info(p); heap_valid_last:=pheap_mem_info(p);
if not assigned(heap_valid_first) then if not assigned(heap_valid_first) then
heap_valid_first:=pheap_mem_info(p); heap_valid_first:=pheap_mem_info(p);
{$endif EXTRA} {$endif EXTRA}
heap_mem_root:=p; heap_mem_root:=p;
{ must be changed before fill_extra_info is called
because checkpointer can be called from within
fill_extra_info PM }
inc(getmem_cnt);
if assigned(fill_extra_info) then if assigned(fill_extra_info) then
fill_extra_info(@pheap_mem_info(p)^.extra_info); begin
inside_trace_getmem:=true;
fill_extra_info(@pheap_mem_info(p)^.extra_info);
inside_trace_getmem:=false;
end;
{ update the pointer } { update the pointer }
if usecrc then if usecrc then
pheap_mem_info(p)^.sig:=calculate_sig(pheap_mem_info(p)); pheap_mem_info(p)^.sig:=calculate_sig(pheap_mem_info(p));
inc(p,sizeof(theap_mem_info)+extra_info_size); inc(p,sizeof(theap_mem_info)+extra_info_size);
inc(getmem_cnt);
TraceGetmem:=p; TraceGetmem:=p;
end; end;
{***************************************************************************** {*****************************************************************************
TraceFreeMem TraceFreeMem
*****************************************************************************} *****************************************************************************}
function TraceFreeMemSize(var p:pointer;size:longint):longint; function TraceFreeMemSize(var p:pointer;size:longint):longint;
@ -401,9 +408,9 @@ begin
ppsize:=ppsize+sizeof(longint); ppsize:=ppsize+sizeof(longint);
dec(p,sizeof(theap_mem_info)+extra_info_size); dec(p,sizeof(theap_mem_info)+extra_info_size);
pp:=pheap_mem_info(p); pp:=pheap_mem_info(p);
if not quicktrace and not(is_in_getmem_list(p)) then if not quicktrace and not(is_in_getmem_list(pp)) then
RunError(204); RunError(204);
if pp^.sig=$AAAAAAAA then if (pp^.sig=$AAAAAAAA) and not usecrc then
begin begin
error_in_heap:=true; error_in_heap:=true;
dump_already_free(pp,ptext^); dump_already_free(pp,ptext^);
@ -465,25 +472,25 @@ begin
fillchar(p^,size,#240); { $F0 will lead to GFP if used as pointer ! } fillchar(p^,size,#240); { $F0 will lead to GFP if used as pointer ! }
{ We want to check if the memory was changed after release !! } { We want to check if the memory was changed after release !! }
pp^.release_sig:=calculate_release_sig(pp); pp^.release_sig:=calculate_release_sig(pp);
if pp=heap_valid_first then if pp=heap_valid_last then
begin begin
heap_valid_first:=pp^.next_valid; heap_valid_last:=pp^.prev_valid;
if pp=heap_valid_last then if pp=heap_valid_first then
heap_valid_last:=nil; heap_valid_first:=nil;
exit; exit;
end; end;
pp2:=heap_valid_first; pp2:=heap_valid_last;
while assigned(pp2) do while assigned(pp2) do
begin begin
if pp2^.next_valid=pp then if pp2^.prev_valid=pp then
begin begin
pp2^.next_valid:=pp^.next_valid; pp2^.prev_valid:=pp^.prev_valid;
if pp=heap_valid_last then if pp=heap_valid_first then
heap_valid_last:=pp2; heap_valid_first:=pp2;
exit; exit;
end end
else else
pp2:=pp2^.next_valid; pp2:=pp2^.prev_valid;
end; end;
exit; exit;
{$endif EXTRA} {$endif EXTRA}
@ -500,7 +507,7 @@ function TraceMemSize(p:pointer):Longint;
var var
l : longint; l : longint;
begin begin
l:=SysMemSize(p-sizeof(theap_mem_info)+extra_info_size); l:=SysMemSize(p-(sizeof(theap_mem_info)+extra_info_size));
dec(l,sizeof(theap_mem_info)+extra_info_size); dec(l,sizeof(theap_mem_info)+extra_info_size);
if add_tail then if add_tail then
dec(l,sizeof(longint)); dec(l,sizeof(longint));
@ -513,7 +520,7 @@ var
size : longint; size : longint;
pp : pheap_mem_info; pp : pheap_mem_info;
begin begin
pp:=pheap_mem_info(pointer(p)-sizeof(theap_mem_info)+extra_info_size); pp:=pheap_mem_info(pointer(p)-(sizeof(theap_mem_info)+extra_info_size));
size:=TraceMemSize(p); size:=TraceMemSize(p);
{ this can never happend normaly } { this can never happend normaly }
if pp^.size>size then if pp^.size>size then
@ -538,8 +545,11 @@ var
edata : cardinal; external name 'edata'; edata : cardinal; external name 'edata';
{$endif go32v2} {$endif go32v2}
{$S-}
var var
heap_at_init : pointer; heap_at_init : pointer;
StartUpHeapEnd : pointer;
procedure CheckPointer(p : pointer);[public, alias : 'FPC_CHECKPOINTER']; procedure CheckPointer(p : pointer);[public, alias : 'FPC_CHECKPOINTER'];
var var
@ -580,26 +590,44 @@ begin
{$endif go32v2} {$endif go32v2}
{ I don't know where the stack is in other OS !! } { I don't know where the stack is in other OS !! }
{$ifdef win32}
if (cardinal(p)>=$40000) and (p<=HeapOrg) then
goto _exit;
{ inside stack ? }
if (cardinal(startupheapend)<Win32StackTop) and (cardinal(p)>cardinal(startupheapend)) and
(cardinal(p)<Win32StackTop) then
goto _exit;
{$endif win32}
if p>=heapptr then if p>=heapptr then
runerror(216); runerror(216);
{ first try valid list faster } { first try valid list faster }
{$ifdef EXTRA} {$ifdef EXTRA}
pp:=heap_valid_first; pp:=heap_valid_last;
while pp<>nil do while pp<>nil do
begin begin
{ inside this valid block ! } { inside this valid block ! }
if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info)+extra_info_size) and { we can be changing the extrainfo !! }
if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info){+extra_info_size}) and
(cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then (cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then
begin begin
{ check allocated block } { check allocated block }
if ((pp^.sig=$DEADBEEF) and not usecrc) or if ((pp^.sig=$DEADBEEF) and not usecrc) or
((pp^.sig=calculate_sig(pp)) and usecrc) then ((pp^.sig=calculate_sig(pp)) and usecrc) or
goto _exit; { special case of the fill_extra_info call }
((pp=heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
and inside_trace_getmem) then
goto _exit
else
begin
writeln(ptext^,'corrupted heap_mem_info');
dump_error(pp,ptext^);
halt(1);
end;
end end
else else
pp:=pp^.next_valid; pp:=pp^.prev_valid;
inc(i); inc(i);
if i>getmem_cnt-freemem_cnt then if i>getmem_cnt-freemem_cnt then
begin begin
@ -851,6 +879,7 @@ begin
end; end;
Procedure SetHeapTraceOutput(const name : string); Procedure SetHeapTraceOutput(const name : string);
var i : longint;
begin begin
if ptext<>@stderr then if ptext<>@stderr then
begin begin
@ -864,6 +893,9 @@ begin
Rewrite(ownfile); Rewrite(ownfile);
{$I+} {$I+}
ptext:=@ownfile; ptext:=@ownfile;
for i:=0 to Paramcount do
write(ptext^,paramstr(i),' ');
writeln(ptext^);
end; end;
procedure SetExtraInfo( size : longint;func : fillextrainfotype); procedure SetExtraInfo( size : longint;func : fillextrainfotype);
@ -892,12 +924,16 @@ Initialization
Rewrite(error_file); Rewrite(error_file);
{$endif EXTRA} {$endif EXTRA}
Heap_at_init:=HeapPtr; Heap_at_init:=HeapPtr;
StartupHeapEnd:=HeapEnd;
finalization finalization
TraceExit; TraceExit;
end. end.
{ {
$Log$ $Log$
Revision 1.27 1999-11-06 14:35:38 peter Revision 1.28 1999-11-09 22:32:23 pierre
* several extra_size_info fixes
Revision 1.27 1999/11/06 14:35:38 peter
* truncated log * truncated log
Revision 1.26 1999/11/01 13:56:50 peter Revision 1.26 1999/11/01 13:56:50 peter