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

* extra info update so it can be always be set on/off

Browse Source
This commit is contained in:
peter 2001-04-11 12:34:50 +00:00
parent 3367fc1c61
commit 60ba93a688
1 changed files with 150 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

288
rtl/inc/heaptrc.pp
View File

@ -14,13 +14,6 @@
**********************************************************************} **********************************************************************}
unit heaptrc; unit heaptrc;
{ 0.99.12 had a bug that initialization/finalization only worked for
objfpc,delphi mode }
{$ifdef VER0_99_12}
{$mode objfpc}
{$endif}
interface interface
Procedure DumpHeap; Procedure DumpHeap;
@ -33,14 +26,15 @@ Procedure MarkHeap;
WARNING this needs extremely much memory (PM) } WARNING this needs extremely much memory (PM) }
type type
FillExtraInfoType = procedure(p : pointer); tFillExtraInfoProc = procedure(p : pointer);
tdisplayextrainfoProc = procedure (var ptext : text;p : pointer);
{ allows to add several longint value that can help { Allows to add info pre memory block, see ppheap.pas of the compiler
to debug : for example source }
see for instance ppheap.pas unit of the compiler source PM } procedure SetHeapExtraInfo( size : longint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
Procedure SetExtraInfo( size : longint;func : FillExtraInfoType); { Redirection of the output to a file }
Procedure SetHeapTraceOutput(const name : string); procedure SetHeapTraceOutput(const name : string);
const const
{ tracing level { tracing level
@ -57,11 +51,12 @@ const
is freed several times } is freed several times }
{$ifdef EXTRA} {$ifdef EXTRA}
keepreleased : boolean=true; keepreleased : boolean=true;
add_tail : boolean = true;
{$else EXTRA} {$else EXTRA}
keepreleased : boolean=false; keepreleased : boolean=false;
add_tail : boolean = false;
{$endif EXTRA} {$endif EXTRA}
{ add a small footprint at the end of memory blocks, this
can check for memory overwrites at the end of a block }
add_tail : boolean = true;
{ put crc in sig { put crc in sig
this allows to test for writing into that part } this allows to test for writing into that part }
usecrc : boolean = true; usecrc : boolean = true;
@ -73,35 +68,46 @@ type
plongint = ^longint; plongint = ^longint;
const const
{ allows to add custom info in heap_mem_info } { allows to add custom info in heap_mem_info, this is the size that will
be allocated for this information }
extra_info_size : longint = 0; extra_info_size : longint = 0;
exact_info_size : longint = 0; exact_info_size : longint = 0;
EntryMemUsed : longint = 0; EntryMemUsed : longint = 0;
{ function to fill this info up } { function to fill this info up }
fill_extra_info : FillExtraInfoType = nil; fill_extra_info_proc : TFillExtraInfoProc = nil;
display_extra_info_proc : TDisplayExtraInfoProc = nil;
error_in_heap : boolean = false; error_in_heap : boolean = false;
inside_trace_getmem : boolean = false; inside_trace_getmem : boolean = false;
type type
pheap_mem_info = ^theap_mem_info; pheap_extra_info = ^theap_extra_info;
theap_extra_info = record
fillproc : tfillextrainfoProc;
displayproc : tdisplayextrainfoProc;
data : record
end;
end;
{ warning the size of theap_mem_info { warning the size of theap_mem_info
must be a multiple of 8 must be a multiple of 8
because otherwise you will get because otherwise you will get
problems when releasing the usual memory part !! problems when releasing the usual memory part !!
sizeof(theap_mem_info = 16+tracesize*4 so sizeof(theap_mem_info = 16+tracesize*4 so
tracesize must be even !! PM } tracesize must be even !! PM }
pheap_mem_info = ^theap_mem_info;
theap_mem_info = record theap_mem_info = record
previous, previous,
next : pheap_mem_info; next : pheap_mem_info;
size : longint; size : longint;
sig : longint; sig : longword;
{$ifdef EXTRA} {$ifdef EXTRA}
release_sig : longint; release_sig : longword;
prev_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 exact_info_size : word;
end; extra_info_size : word;
extra_info : pheap_extra_info;
end; end;
var var
@ -126,19 +132,11 @@ var
*****************************************************************************} *****************************************************************************}
var var
{$ifdef Delphi}
Crc32Tbl : array[0..255] of longword; Crc32Tbl : array[0..255] of longword;
{$else Delphi}
Crc32Tbl : array[0..255] of longint;
{$endif Delphi}
procedure MakeCRC32Tbl; procedure MakeCRC32Tbl;
var var
{$ifdef Delphi}
crc : longword; crc : longword;
{$else Delphi}
crc : longint;
{$endif Delphi}
i,n : byte; i,n : byte;
begin begin
for i:=0 to 255 do for i:=0 to 255 do
@ -146,11 +144,7 @@ begin
crc:=i; crc:=i;
for n:=1 to 8 do for n:=1 to 8 do
if odd(crc) then if odd(crc) then
{$ifdef Delphi}
crc:=(crc shr 1) xor $edb88320 crc:=(crc shr 1) xor $edb88320
{$else Delphi}
crc:=longint(cardinal(crc shr 1) xor $edb88320)
{$endif Delphi}
else else
crc:=crc shr 1; crc:=crc shr 1;
Crc32Tbl[i]:=crc; Crc32Tbl[i]:=crc;
@ -158,13 +152,7 @@ begin
end; end;
{$ifopt R+} Function UpdateCrc32(InitCrc:longword;var InBuf;InLen:Longint):longword;
{$define Range_check_on}
{$endif opt R+}
{$R- needed here }
Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
var var
i : longint; i : longint;
p : pchar; p : pchar;
@ -173,25 +161,25 @@ begin
for i:=1 to InLen do for i:=1 to InLen do
begin begin
InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8); InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
inc(longint(p)); inc(p);
end; end;
UpdateCrc32:=InitCrc; UpdateCrc32:=InitCrc;
end; end;
Function calculate_sig(p : pheap_mem_info) : longint; Function calculate_sig(p : pheap_mem_info) : longword;
var var
crc : longint; crc : longword;
pl : plongint; pl : plongint;
begin begin
crc:=longint($ffffffff); crc:=longword($ffffffff);
crc:=UpdateCrc32(crc,p^.size,sizeof(longint)); crc:=UpdateCrc32(crc,p^.size,sizeof(longint));
crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint)); crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint));
if extra_info_size>0 then if p^.extra_info_size>0 then
crc:=UpdateCrc32(crc,p^.extra_info,exact_info_size); crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
if add_tail then if add_tail then
begin begin
{ Check also 4 bytes just after allocation !! } { Check also 4 bytes just after allocation !! }
pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info)+p^.size; pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
crc:=UpdateCrc32(crc,pl^,sizeof(longint)); crc:=UpdateCrc32(crc,pl^,sizeof(longint));
end; end;
calculate_sig:=crc; calculate_sig:=crc;
@ -200,32 +188,28 @@ end;
{$ifdef EXTRA} {$ifdef EXTRA}
Function calculate_release_sig(p : pheap_mem_info) : longint; Function calculate_release_sig(p : pheap_mem_info) : longint;
var var
crc : longint; crc : longword;
pl : plongint; pl : plongint;
begin begin
crc:=longint($ffffffff); crc:=$ffffffff;
crc:=UpdateCrc32(crc,p^.size,sizeof(longint)); crc:=UpdateCrc32(crc,p^.size,sizeof(longint));
crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint)); crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint));
if extra_info_size>0 then if p^.extra_info_size>0 then
crc:=UpdateCrc32(crc,p^.extra_info,exact_info_size); crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
{ Check the whole of the whole allocation } { Check the whole of the whole allocation }
pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info); pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info);
crc:=UpdateCrc32(crc,pl^,p^.size); crc:=UpdateCrc32(crc,pl^,p^.size);
{ Check also 4 bytes just after allocation !! } { Check also 4 bytes just after allocation !! }
if add_tail then if add_tail then
begin begin
{ Check also 4 bytes just after allocation !! } { Check also 4 bytes just after allocation !! }
pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info)+p^.size; pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
crc:=UpdateCrc32(crc,pl^,sizeof(longint)); crc:=UpdateCrc32(crc,pl^,sizeof(longint));
end; end;
calculate_release_sig:=crc; calculate_release_sig:=crc;
end; end;
{$endif EXTRA} {$endif EXTRA}
{$ifdef Range_check_on}
{$R+}
{$undef Range_check_on}
{$endif Range_check_on}
{***************************************************************************** {*****************************************************************************
Helpers Helpers
@ -239,14 +223,14 @@ begin
for i:=1 to tracesize do for i:=1 to tracesize do
if pp^.calls[i]<>0 then if pp^.calls[i]<>0 then
writeln(ptext,BackTraceStrFunc(pp^.calls[i])); writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
for i:=0 to (exact_info_size div 4)-1 do if assigned(pp^.extra_info^.displayproc) then
writeln(ptext,'info ',i,'=',plongint(pointer(@pp^.extra_info)+4*i)^); pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
end; end;
procedure call_free_stack(pp : pheap_mem_info;var ptext : text); procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
var var
i : longint; i : longint;
begin begin
writeln(ptext,'Call trace for block at 0x',hexstr(longint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size); writeln(ptext,'Call trace for block at 0x',hexstr(longint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size);
for i:=1 to tracesize div 2 do for i:=1 to tracesize div 2 do
@ -256,8 +240,8 @@ begin
for i:=(tracesize div 2)+1 to tracesize do for i:=(tracesize div 2)+1 to tracesize do
if pp^.calls[i]<>0 then if pp^.calls[i]<>0 then
writeln(ptext,BackTraceStrFunc(pp^.calls[i])); writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
for i:=0 to (exact_info_size div 4)-1 do for i:=0 to (pp^.exact_info_size div 4)-1 do
writeln(ptext,'info ',i,'=',plongint(pointer(@pp^.extra_info)+4*i)^); writeln(ptext,'info ',i,'=',plongint(pointer(pp^.extra_info)+4*i)^);
end; end;
@ -272,8 +256,7 @@ end;
procedure dump_error(p : pheap_mem_info;var ptext : text); procedure dump_error(p : pheap_mem_info;var ptext : text);
begin begin
Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8) Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
,' instead of ',hexstr(calculate_sig(p),8));
dump_stack(ptext,get_caller_frame(get_frame)); dump_stack(ptext,get_caller_frame(get_frame));
end; end;
@ -283,11 +266,10 @@ procedure dump_change_after(p : pheap_mem_info;var ptext : text);
i : longint; i : longint;
begin begin
Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8) Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8));
,' instead of ',hexstr(calculate_release_sig(p),8));
Writeln(ptext,'This memory was changed after call to freemem !'); Writeln(ptext,'This memory was changed after call to freemem !');
call_free_stack(p,ptext); call_free_stack(p,ptext);
pp:=pointer(p)+sizeof(theap_mem_info)+extra_info_size; pp:=pointer(p)+sizeof(theap_mem_info);
for i:=0 to p^.size-1 do for i:=0 to p^.size-1 do
if byte(pp[i])<>$F0 then if byte(pp[i])<>$F0 then
Writeln(ptext,'offset',i,':$',hexstr(i,8),'"',pp[i],'"'); Writeln(ptext,'offset',i,':$',hexstr(i,8),'"',pp[i],'"');
@ -301,8 +283,8 @@ begin
Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed'); Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
dump_stack(ptext,get_caller_frame(get_frame)); dump_stack(ptext,get_caller_frame(get_frame));
for i:=0 to (exact_info_size div 4)-1 do for i:=0 to (p^.exact_info_size div 4)-1 do
writeln(ptext,'info ',i,'=',plongint(@p^.extra_info+4*i)^); writeln(ptext,'info ',i,'=',plongint(p^.extra_info+4*i)^);
call_stack(p,ptext); call_stack(p,ptext);
end; end;
@ -317,9 +299,9 @@ begin
i:=0; i:=0;
while pp<>nil do while pp<>nil do
begin begin
if ((pp^.sig<>longint($DEADBEEF)) or usecrc) and if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) and ((pp^.sig<>calculate_sig(pp)) or not usecrc) and
(pp^.sig <> longint($AAAAAAAA)) then (pp^.sig <>$AAAAAAAA) then
begin begin
writeln(ptext^,'error in linked list of heap_mem_info'); writeln(ptext^,'error in linked list of heap_mem_info');
RunError(204); RunError(204);
@ -352,13 +334,31 @@ begin
inc(bp,sizeof(longint)); inc(bp,sizeof(longint));
p:=SysGetMem(bp); p:=SysGetMem(bp);
{ Create the info block } { Create the info block }
pheap_mem_info(p)^.sig:=longint($DEADBEEF); pheap_mem_info(p)^.sig:=$DEADBEEF;
pheap_mem_info(p)^.size:=size; pheap_mem_info(p)^.size:=size;
pheap_mem_info(p)^.extra_info_size:=extra_info_size;
pheap_mem_info(p)^.exact_info_size:=exact_info_size;
{
the end of the block contains:
<tail> 4 bytes
<extra_info> X bytes
}
pheap_mem_info(p)^.extra_info:=pointer(p)+bp-extra_info_size;
fillchar(pheap_mem_info(p)^.extra_info^,extra_info_size,0);
pheap_mem_info(p)^.extra_info^.fillproc:=fill_extra_info_proc;
pheap_mem_info(p)^.extra_info^.displayproc:=display_extra_info_proc;
if assigned(fill_extra_info_proc) then
begin
inside_trace_getmem:=true;
fill_extra_info_proc(@pheap_mem_info(p)^.extra_info^.data);
inside_trace_getmem:=false;
end;
if add_tail then if add_tail then
begin begin
pl:=pointer(p)+bp-sizeof(longint); pl:=pointer(p)+bp-extra_info_size-sizeof(longint);
pl^:=longint($DEADBEEF); pl^:=$DEADBEEF;
end; end;
{ retrieve backtrace info }
bp:=get_caller_frame(get_frame); bp:=get_caller_frame(get_frame);
for i:=1 to tracesize do for i:=1 to tracesize do
begin begin
@ -381,16 +381,10 @@ begin
because checkpointer can be called from within because checkpointer can be called from within
fill_extra_info PM } fill_extra_info PM }
inc(getmem_cnt); inc(getmem_cnt);
if assigned(fill_extra_info) then
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));
TraceGetmem:=p; TraceGetmem:=p;
end; end;
@ -406,23 +400,25 @@ var
{$ifdef EXTRA} {$ifdef EXTRA}
pp2 : pheap_mem_info; pp2 : pheap_mem_info;
{$endif} {$endif}
extra_size : longint;
begin begin
inc(freemem_size,size); inc(freemem_size,size);
inc(freemem8_size,((size+7) div 8)*8); inc(freemem8_size,((size+7) div 8)*8);
ppsize:= size + sizeof(theap_mem_info)+extra_info_size; dec(p,sizeof(theap_mem_info));
if add_tail then
ppsize:=ppsize+sizeof(longint);
dec(p,sizeof(theap_mem_info)+extra_info_size);
pp:=pheap_mem_info(p); pp:=pheap_mem_info(p);
extra_size:=pp^.extra_info_size;
ppsize:= size + sizeof(theap_mem_info)+pp^.extra_info_size;
if add_tail then
inc(ppsize,sizeof(longint));
if not quicktrace and not(is_in_getmem_list(pp)) then if not quicktrace and not(is_in_getmem_list(pp)) then
RunError(204); RunError(204);
if (pp^.sig=longint($AAAAAAAA)) and not usecrc 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^);
if haltonerror then halt(1); if haltonerror then halt(1);
end end
else if ((pp^.sig<>longint($DEADBEEF)) or usecrc) and else if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
begin begin
error_in_heap:=true; error_in_heap:=true;
@ -446,7 +442,7 @@ begin
exit; exit;
end; end;
{ now it is released !! } { now it is released !! }
pp^.sig:=longint($AAAAAAAA); pp^.sig:=$AAAAAAAA;
if not keepreleased then if not keepreleased then
begin begin
if pp^.next<>nil then if pp^.next<>nil then
@ -470,13 +466,11 @@ begin
{ this way we keep all info about all released memory !! } { this way we keep all info about all released memory !! }
if keepreleased then if keepreleased then
begin begin
{$ifndef EXTRA} i:=ppsize;
dec(ppsize,sizeof(theap_mem_info)+extra_info_size); inc(p,sizeof(theap_mem_info));
inc(p,sizeof(theap_mem_info)+extra_info_size); fillchar(p^,size,#240); { $F0 will lead to GFP if used as pointer ! }
{$else EXTRA} {$ifdef EXTRA}
inc(p,sizeof(theap_mem_info)+extra_info_size); { We want to check if the memory was changed after release !! }
fillchar(p^,size,#240); { $F0 will lead to GFP if used as pointer ! }
{ 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_last then if pp=heap_valid_last then
begin begin
@ -498,11 +492,12 @@ begin
else else
pp2:=pp2^.prev_valid; pp2:=pp2^.prev_valid;
end; end;
exit;
{$endif EXTRA} {$endif EXTRA}
end; exit;
i:=SysFreeMemSize(p,ppsize); end
dec(i,sizeof(theap_mem_info)+extra_info_size); else
i:=SysFreeMemSize(p,ppsize);
dec(i,sizeof(theap_mem_info)+extra_size);
if add_tail then if add_tail then
dec(i,sizeof(longint)); dec(i,sizeof(longint));
TraceFreeMemSize:=i; TraceFreeMemSize:=i;
@ -512,9 +507,12 @@ end;
function TraceMemSize(p:pointer):Longint; function TraceMemSize(p:pointer):Longint;
var var
l : longint; l : longint;
pp : pheap_mem_info;
begin begin
l:=SysMemSize(p-(sizeof(theap_mem_info)+extra_info_size)); dec(p,sizeof(theap_mem_info));
dec(l,sizeof(theap_mem_info)+extra_info_size); pp:=pheap_mem_info(p);
l:=SysMemSize(pp);
dec(l,sizeof(theap_mem_info)+pp^.extra_info_size);
if add_tail then if add_tail then
dec(l,sizeof(longint)); dec(l,sizeof(longint));
TraceMemSize:=l; TraceMemSize:=l;
@ -526,7 +524,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(p-sizeof(theap_mem_info));
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
@ -551,6 +549,10 @@ var
i,bp : longint; i,bp : longint;
pl : plongint; pl : plongint;
pp : pheap_mem_info; pp : pheap_mem_info;
oldextrasize,
oldexactsize : longint;
old_fill_extra_info_proc : tfillextrainfoproc;
old_display_extra_info_proc : tdisplayextrainfoproc;
begin begin
{ Free block? } { Free block? }
if size=0 then if size=0 then
@ -568,10 +570,10 @@ begin
exit; exit;
end; end;
{ Resize block } { Resize block }
dec(p,sizeof(theap_mem_info)+extra_info_size); dec(p,sizeof(theap_mem_info));
pp:=pheap_mem_info(p); pp:=pheap_mem_info(p);
{ test block } { test block }
if ((pp^.sig<>longint($DEADBEEF)) or usecrc) and if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
begin begin
error_in_heap:=true; error_in_heap:=true;
@ -583,15 +585,21 @@ begin
if haltonerror then halt(1); if haltonerror then halt(1);
exit; exit;
end; end;
{ save info }
oldextrasize:=pp^.extra_info_size;
oldexactsize:=pp^.exact_info_size;
old_fill_extra_info_proc:=pp^.extra_info^.fillproc;
old_display_extra_info_proc:=pp^.extra_info^.displayproc;
{ Do the real ReAllocMem, but alloc also for the info block } { Do the real ReAllocMem, but alloc also for the info block }
bp:=size+sizeof(theap_mem_info)+extra_info_size; bp:=size+sizeof(theap_mem_info)+pp^.extra_info_size;
if add_tail then if add_tail then
inc(bp,sizeof(longint)); inc(bp,sizeof(longint));
{ the internal ReAllocMem is not allowed to move any data } { Try to resize the block, if not possible we need to do a
getmem, move data, freemem }
if not SysTryResizeMem(p,bp) then if not SysTryResizeMem(p,bp) then
begin begin
{ restore p } { restore p }
inc(p,sizeof(theap_mem_info)+extra_info_size); inc(p,sizeof(theap_mem_info));
{ get a new block } { get a new block }
oldsize:=TraceMemSize(p); oldsize:=TraceMemSize(p);
newP := TraceGetMem(size); newP := TraceGetMem(size);
@ -612,21 +620,28 @@ begin
inc(getmem_size,size); inc(getmem_size,size);
inc(getmem8_size,((size+7) div 8)*8); inc(getmem8_size,((size+7) div 8)*8);
{ Create the info block } { Create the info block }
pp^.sig:=longint($DEADBEEF); pp^.sig:=$DEADBEEF;
pp^.size:=size; pp^.size:=size;
if add_tail then pp^.extra_info_size:=oldextrasize;
begin pp^.exact_info_size:=oldexactsize;
pl:=pointer(p)+bp-sizeof(longint);
pl^:=longint($DEADBEEF);
end;
bp:=get_caller_frame(get_frame); bp:=get_caller_frame(get_frame);
for i:=1 to tracesize do for i:=1 to tracesize do
begin begin
pp^.calls[i]:=get_caller_addr(bp); pp^.calls[i]:=get_caller_addr(bp);
bp:=get_caller_frame(bp); bp:=get_caller_frame(bp);
end; end;
if assigned(fill_extra_info) then { add the new extra_info and tail }
fill_extra_info(@pp^.extra_info); pp^.extra_info:=p+bp-pp^.extra_info_size;
fillchar(pp^.extra_info^,extra_info_size,0);
pp^.extra_info^.fillproc:=old_fill_extra_info_proc;
pp^.extra_info^.displayproc:=old_display_extra_info_proc;
if assigned(pp^.extra_info^.fillproc) then
pp^.extra_info^.fillproc(@pp^.extra_info^.data);
if add_tail then
begin
pl:=pointer(p)+bp-pp^.extra_info_size-sizeof(longint);
pl^:=$DEADBEEF;
end;
{ update the pointer } { update the pointer }
if usecrc then if usecrc then
pp^.sig:=calculate_sig(pp); pp^.sig:=calculate_sig(pp);
@ -727,10 +742,10 @@ begin
(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=longint($DEADBEEF)) and not usecrc) or if ((pp^.sig=$DEADBEEF) and not usecrc) or
((pp^.sig=calculate_sig(pp)) and usecrc) or ((pp^.sig=calculate_sig(pp)) and usecrc) or
{ special case of the fill_extra_info call } { special case of the fill_extra_info call }
((pp=heap_valid_last) and usecrc and (pp^.sig=longint($DEADBEEF)) ((pp=heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
and inside_trace_getmem) then and inside_trace_getmem) then
goto _exit goto _exit
else else
@ -758,7 +773,7 @@ begin
if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)) and if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)) and
(cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)+cardinal(pp^.size)) then (cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)+cardinal(pp^.size)) then
{ allocated block } { allocated block }
if ((pp^.sig=longint($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) then
goto _exit goto _exit
else else
@ -817,7 +832,7 @@ begin
Writeln(ptext^,'More memory blocks than expected'); Writeln(ptext^,'More memory blocks than expected');
exit; exit;
end; end;
if ((pp^.sig=longint($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) then
begin begin
{ this one was not released !! } { this one was not released !! }
@ -825,7 +840,7 @@ begin
call_stack(pp,ptext^); call_stack(pp,ptext^);
dec(i); dec(i);
end end
else if pp^.sig<>longint($AAAAAAAA) then else if pp^.sig<>$AAAAAAAA then
begin begin
dump_error(pp,ptext^); dump_error(pp,ptext^);
{$ifdef EXTRA} {$ifdef EXTRA}
@ -854,7 +869,7 @@ begin
pp:=heap_mem_root; pp:=heap_mem_root;
while pp<>nil do while pp<>nil do
begin begin
pp^.sig:=longint($AAAAAAAA); pp^.sig:=$AAAAAAAA;
pp:=pp^.previous; pp:=pp^.previous;
end; end;
end; end;
@ -958,22 +973,16 @@ begin
writeln(ptext^); writeln(ptext^);
end; end;
procedure SetExtraInfo( size : longint;func : fillextrainfotype); procedure SetHeapExtraInfo( size : longint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
begin
{ the total size must stay multiple of 8, also allocate 2 pointers for
the fill and display procvars }
exact_info_size:=size + sizeof(pointer)*2;
extra_info_size:=((exact_info_size+7) div 8)*8;
fill_extra_info_proc:=fillproc;
display_extra_info_proc:=displayproc;
end;
begin
if getmem_cnt>0 then
begin
writeln(ptext^,'Setting extra info is only possible at start !! ');
dumpheap;
end
else
begin
{ the total size must stay multiple of 8 !! }
exact_info_size:=size;
extra_info_size:=((size+7) div 8)*8;
fill_extra_info:=func;
end;
end;
Initialization Initialization
EntryMemUsed:=System.HeapSize-MemAvail; EntryMemUsed:=System.HeapSize-MemAvail;
@ -996,7 +1005,10 @@ finalization
end. end.
{ {
$Log$ $Log$
Revision 1.6 2000-12-16 15:57:17 jonas Revision 1.7 2001-04-11 12:34:50 peter
* extra info update so it can be always be set on/off
Revision 1.6 2000/12/16 15:57:17 jonas
* removed 64bit evaluations when range checking is on * removed 64bit evaluations when range checking is on
Revision 1.5 2000/12/07 17:19:47 jonas Revision 1.5 2000/12/07 17:19:47 jonas