1
{ This unit is an extended heaptrc unit.
9
{ define EXTRA to add more
11
- keep all memory after release and
12
check by CRC value if not changed after release
13
WARNING this needs extremely much memory (PM) }
17
{$inline off}// inline off for stack traces
19
// additions for codetools
20
{$DEFINE MC_Interface}
27
{$if defined(win32) or defined(wince)}
33
{ define EXTRA to add more
35
- keep all memory after release and
36
check by CRC value if not changed after release
37
WARNING this needs extremely much memory (PM) }
40
tFillExtraInfoProc = procedure(p : pointer);
41
tdisplayextrainfoProc = procedure (var ptext : text;p : pointer);
43
{ Allows to add info pre memory block, see ppheap.pas of the compiler
45
procedure SetHeapExtraInfo(size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
47
{ Redirection of the output to a file }
48
procedure SetHeapTraceOutput(const name : string);
52
splitted in two if memory is released !! }
58
{ install heaptrc memorymanager }
59
useheaptrace : boolean=true;
61
quicktrace : boolean=false;
62
{ calls halt() on error by default !! }
63
HaltOnError : boolean = true;
64
{ Halt on exit if any memory was not freed }
65
HaltOnNotReleased : boolean = false;
67
{ set this to true if you suspect that memory
68
is freed several times }
70
keepreleased : boolean=true;
72
keepreleased : boolean=false;
74
{ add a small footprint at the end of memory blocks, this
75
can check for memory overwrites at the end of a block }
76
add_tail : boolean = true;
78
this allows to test for writing into that part }
79
usecrc : boolean = true;
84
// additions for codetools
85
{$DEFINE MC_ImplementationStart}
87
{$UNDEF MC_ImplementationStart}
90
{ allows to add custom info in heap_mem_info, this is the size that will
91
be allocated for this information }
92
extra_info_size : ptruint = 0;
93
exact_info_size : ptruint = 0;
94
EntryMemUsed : ptruint = 0;
95
{ function to fill this info up }
96
fill_extra_info_proc : TFillExtraInfoProc = nil;
97
display_extra_info_proc : TDisplayExtraInfoProc = nil;
98
{ indicates where the output will be redirected }
99
{ only set using environment variables }
100
outputstr : shortstring = '';
103
pheap_extra_info = ^theap_extra_info;
104
theap_extra_info = record
105
check : cardinal; { used to check if the procvar is still valid }
106
fillproc : tfillextrainfoProc;
107
displayproc : tdisplayextrainfoProc;
112
ppheap_mem_info = ^pheap_mem_info;
113
pheap_mem_info = ^theap_mem_info;
115
{ warning the size of theap_mem_info
116
must be a multiple of 8
117
because otherwise you will get
118
problems when releasing the usual memory part !!
119
sizeof(theap_mem_info = 16+tracesize*4 so
120
tracesize must be even !! PM }
121
theap_mem_info = record
123
next : pheap_mem_info;
124
todolist : ppheap_mem_info;
125
todonext : pheap_mem_info;
129
release_sig : longword;
130
prev_valid : pheap_mem_info;
132
calls : array [1..tracesize] of pointer;
133
exact_info_size : word;
134
extra_info_size : word;
135
extra_info : pheap_extra_info;
138
pheap_info = ^theap_info;
142
heap_valid_last : pheap_mem_info;
144
heap_mem_root : pheap_mem_info;
145
heap_free_todo : pheap_mem_info;
147
freemem_cnt : ptruint;
149
freemem_size : ptruint;
151
freemem8_size : ptruint;
152
error_in_heap : boolean;
153
inside_trace_getmem : boolean;
157
useownfile : boolean;
162
main_orig_todolist: ppheap_mem_info;
163
main_relo_todolist: ppheap_mem_info;
164
orphaned_info: theap_info;
165
todo_lock: trtlcriticalsection;
167
heap_info: theap_info;
169
{*****************************************************************************
171
*****************************************************************************}
174
Crc32Tbl : array[0..255] of longword;
176
procedure MakeCRC32Tbl;
186
crc:=(crc shr 1) xor $edb88320
194
Function UpdateCrc32(InitCrc:longword;var InBuf;InLen:ptruint):longword;
202
InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
205
UpdateCrc32:=InitCrc;
208
Function calculate_sig(p : pheap_mem_info) : longword;
213
crc:=cardinal($ffffffff);
214
crc:=UpdateCrc32(crc,p^.size,sizeof(ptruint));
215
crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(ptruint));
216
if p^.extra_info_size>0 then
217
crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
220
{ Check also 4 bytes just after allocation !! }
221
pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
222
crc:=UpdateCrc32(crc,pl^,sizeof(ptruint));
228
Function calculate_release_sig(p : pheap_mem_info) : longword;
234
crc:=UpdateCrc32(crc,p^.size,sizeof(ptruint));
235
crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(ptruint));
236
if p^.extra_info_size>0 then
237
crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
238
{ Check the whole of the whole allocation }
239
pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info);
240
crc:=UpdateCrc32(crc,pl^,p^.size);
241
{ Check also 4 bytes just after allocation !! }
244
{ Check also 4 bytes just after allocation !! }
245
pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
246
crc:=UpdateCrc32(crc,pl^,sizeof(ptruint));
248
calculate_release_sig:=crc;
253
{*****************************************************************************
255
*****************************************************************************}
257
function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
258
size: ptruint; release_todo_lock: boolean): ptruint; forward;
259
function TraceFreeMem(p: pointer): ptruint; forward;
261
procedure call_stack(pp : pheap_mem_info;var ptext : text);
265
writeln(ptext,'Call trace for block $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size);
266
for i:=1 to tracesize do
267
if pp^.calls[i]<>nil then
268
writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
269
{ the check is done to be sure that the procvar is not overwritten }
270
if assigned(pp^.extra_info) and
271
(pp^.extra_info^.check=$12345678) and
272
assigned(pp^.extra_info^.displayproc) then
273
pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
277
procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
281
writeln(ptext,'Call trace for block at $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size);
282
for i:=1 to tracesize div 2 do
283
if pp^.calls[i]<>nil then
284
writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
285
writeln(ptext,' was released at ');
286
for i:=(tracesize div 2)+1 to tracesize do
287
if pp^.calls[i]<>nil then
288
writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
289
{ the check is done to be sure that the procvar is not overwritten }
290
if assigned(pp^.extra_info) and
291
(pp^.extra_info^.check=$12345678) and
292
assigned(pp^.extra_info^.displayproc) then
293
pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
297
procedure dump_already_free(p : pheap_mem_info;var ptext : text);
299
Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
300
call_free_stack(p,ptext);
301
Writeln(ptext,'freed again at');
302
dump_stack(ptext,get_caller_frame(get_frame));
305
procedure dump_error(p : pheap_mem_info;var ptext : text);
307
Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
308
Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
309
dump_stack(ptext,get_caller_frame(get_frame));
313
procedure dump_change_after(p : pheap_mem_info;var ptext : text);
317
Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
318
Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8));
319
Writeln(ptext,'This memory was changed after call to freemem !');
320
call_free_stack(p,ptext);
321
pp:=pointer(p)+sizeof(theap_mem_info);
322
for i:=0 to p^.size-1 do
323
if byte(pp[i])<>$F0 then
324
Writeln(ptext,'offset',i,':$',hexstr(i,2*sizeof(pointer)),'"',pp[i],'"');
328
procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
330
Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
331
Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
332
dump_stack(ptext,get_caller_frame(get_frame));
333
{ the check is done to be sure that the procvar is not overwritten }
334
if assigned(p^.extra_info) and
335
(p^.extra_info^.check=$12345678) and
336
assigned(p^.extra_info^.displayproc) then
337
p^.extra_info^.displayproc(ptext,@p^.extra_info^.data);
341
function is_in_getmem_list (loc_info: pheap_info; p : pheap_mem_info) : boolean;
346
is_in_getmem_list:=false;
347
pp:=loc_info^.heap_mem_root;
351
if ((pp^.sig<>$DEADBEEF) or usecrc) and
352
((pp^.sig<>calculate_sig(pp)) or not usecrc) and
353
(pp^.sig <>$AAAAAAAA) then
356
writeln(ownfile,'error in linked list of heap_mem_info')
358
writeln(stderr,'error in linked list of heap_mem_info');
362
is_in_getmem_list:=true;
365
if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then begin
367
writeln(ownfile,'error in linked list of heap_mem_info')
369
writeln(stderr,'error in linked list of heap_mem_info');
375
procedure finish_heap_free_todo_list(loc_info: pheap_info);
379
list: ppheap_mem_info;
381
list := @loc_info^.heap_free_todo;
384
list^ := list^^.todonext;
385
bp := pointer(pp)+sizeof(theap_mem_info);
386
InternalFreeMemSize(loc_info,bp,pp,pp^.size,false);
390
procedure try_finish_heap_free_todo_list(loc_info: pheap_info);
392
if loc_info^.heap_free_todo <> nil then
394
entercriticalsection(todo_lock);
395
finish_heap_free_todo_list(loc_info);
396
leavecriticalsection(todo_lock);
401
{*****************************************************************************
403
*****************************************************************************}
405
Function TraceGetMem(size:ptruint):pointer;
407
allocsize,i : ptruint;
413
loc_info: pheap_info;
415
loc_info := @heap_info;
416
try_finish_heap_free_todo_list(loc_info);
417
inc(loc_info^.getmem_size,size);
418
inc(loc_info^.getmem8_size,(size+7) and not 7);
419
{ Do the real GetMem, but alloc also for the info block }
421
allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+extra_info_size;
423
allocsize:=size+sizeof(theap_mem_info)+extra_info_size;
426
inc(allocsize,sizeof(ptruint));
427
{ if ReturnNilIfGrowHeapFails is true
428
SysGetMem can return nil }
429
p:=SysGetMem(allocsize);
435
pp:=pheap_mem_info(p);
436
inc(p,sizeof(theap_mem_info));
437
{ Create the info block }
439
pp^.todolist:=@loc_info^.heap_free_todo;
442
pp^.extra_info_size:=extra_info_size;
443
pp^.exact_info_size:=exact_info_size;
445
the end of the block contains:
449
if extra_info_size>0 then
451
pp^.extra_info:=pointer(pp)+allocsize-extra_info_size;
452
fillchar(pp^.extra_info^,extra_info_size,0);
453
pp^.extra_info^.check:=$12345678;
454
pp^.extra_info^.fillproc:=fill_extra_info_proc;
455
pp^.extra_info^.displayproc:=display_extra_info_proc;
456
if assigned(fill_extra_info_proc) then
458
loc_info^.inside_trace_getmem:=true;
459
fill_extra_info_proc(@pp^.extra_info^.data);
460
loc_info^.inside_trace_getmem:=false;
467
pl:=pointer(pp)+allocsize-pp^.extra_info_size-sizeof(ptruint);
468
{$ifdef FPC_SUPPORTS_UNALIGNED}
469
unaligned(pl^):=$DEADBEEF;
470
{$else FPC_SUPPORTS_UNALIGNED}
472
{$endif FPC_SUPPORTS_UNALIGNED}
475
fillchar(p^,size,#255);
476
{ retrieve backtrace info }
477
bp:=get_caller_frame(get_frame);
478
for i:=1 to tracesize do
480
pp^.calls[i]:=get_caller_addr(bp);
482
bp:=get_caller_frame(bp);
483
if (bp<oldbp) or (bp>(StackBottom + StackLength)) then
486
{ insert in the linked list }
487
if loc_info^.heap_mem_root<>nil then
488
loc_info^.heap_mem_root^.next:=pp;
489
pp^.previous:=loc_info^.heap_mem_root;
492
pp^.prev_valid:=loc_info^.heap_valid_last;
493
loc_info^.heap_valid_last:=pp;
494
if not assigned(loc_info^.heap_valid_first) then
495
loc_info^.heap_valid_first:=pp;
497
loc_info^.heap_mem_root:=pp;
498
{ must be changed before fill_extra_info is called
499
because checkpointer can be called from within
501
inc(loc_info^.getmem_cnt);
502
{ update the signature }
504
pp^.sig:=calculate_sig(pp);
509
{*****************************************************************************
511
*****************************************************************************}
513
function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info;
514
size, ppsize: ptruint): boolean;
520
pp2 : pheap_mem_info;
527
inc(loc_info^.freemem_size,size);
528
inc(loc_info^.freemem8_size,(size+7) and not 7);
529
if not quicktrace then
531
if not(is_in_getmem_list(loc_info, pp)) then
534
if (pp^.sig=$AAAAAAAA) and not usecrc then
536
loc_info^.error_in_heap:=true;
537
dump_already_free(pp,ptext^);
538
if haltonerror then halt(1);
540
else if ((pp^.sig<>$DEADBEEF) or usecrc) and
541
((pp^.sig<>calculate_sig(pp)) or not usecrc) then
543
loc_info^.error_in_heap:=true;
544
dump_error(pp,ptext^);
546
dump_error(pp,error_file);
548
{ don't release anything in this case !! }
549
if haltonerror then halt(1);
552
else if pp^.size<>size then
554
loc_info^.error_in_heap:=true;
555
dump_wrong_size(pp,size,ptext^);
557
dump_wrong_size(pp,size,error_file);
559
if haltonerror then halt(1);
560
{ don't release anything in this case !! }
563
{ now it is released !! }
565
if not keepreleased then
567
if pp^.next<>nil then
568
pp^.next^.previous:=pp^.previous;
569
if pp^.previous<>nil then
570
pp^.previous^.next:=pp^.next;
571
if pp=loc_info^.heap_mem_root then
572
loc_info^.heap_mem_root:=loc_info^.heap_mem_root^.previous;
576
bp:=get_caller_frame(get_frame);
577
for i:=(tracesize div 2)+1 to tracesize do
579
if bp<>nil then begin
580
pp^.calls[i]:=get_caller_addr(bp);
581
bp:=get_caller_frame(bp);
587
inc(loc_info^.freemem_cnt);
588
{ clear the memory, $F0 will lead to GFP if used as pointer ! }
589
fillchar((pointer(pp)+sizeof(theap_mem_info))^,size,#240);
590
{ this way we keep all info about all released memory !! }
594
{ We want to check if the memory was changed after release !! }
595
pp^.release_sig:=calculate_release_sig(pp);
596
if pp=loc_info^.heap_valid_last then
598
loc_info^.heap_valid_last:=pp^.prev_valid;
599
if pp=loc_info^.heap_valid_first then
600
loc_info^.heap_valid_first:=nil;
603
pp2:=loc_info^.heap_valid_last;
604
while assigned(pp2) do
606
if pp2^.prev_valid=pp then
608
pp2^.prev_valid:=pp^.prev_valid;
609
if pp=loc_info^.heap_valid_first then
610
loc_info^.heap_valid_first:=pp2;
614
pp2:=pp2^.prev_valid;
619
CheckFreeMemSize:=true;
622
function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
623
size: ptruint; release_todo_lock: boolean): ptruint;
627
release_mem: boolean;
630
extra_size:=pp^.extra_info_size;
631
ppsize:= size+sizeof(theap_mem_info)+pp^.extra_info_size;
633
inc(ppsize,sizeof(ptruint));
634
{ do various checking }
635
release_mem := CheckFreeMemSize(loc_info, pp, size, ppsize);
636
if release_todo_lock then
637
leavecriticalsection(todo_lock);
640
{ release the normal memory at least }
641
i:=SysFreeMemSize(pp,ppsize);
642
{ return the correct size }
643
dec(i,sizeof(theap_mem_info)+extra_size);
645
dec(i,sizeof(ptruint));
646
InternalFreeMemSize:=i;
648
InternalFreeMemSize:=size;
651
function TraceFreeMemSize(p:pointer;size:ptruint):ptruint;
653
loc_info: pheap_info;
655
release_lock: boolean;
662
loc_info:=@heap_info;
663
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
665
if @loc_info^.heap_free_todo <> pp^.todolist then
667
if pp^.todolist = main_orig_todolist then
668
pp^.todolist := main_relo_todolist;
669
entercriticalsection(todo_lock);
671
if pp^.todolist = @orphaned_info.heap_free_todo then
673
loc_info := @orphaned_info;
675
if pp^.todolist <> @loc_info^.heap_free_todo then
677
{ allocated in different heap, push to that todolist }
678
pp^.todonext := pp^.todolist^;
680
TraceFreeMemSize := pp^.size;
681
leavecriticalsection(todo_lock);
685
TraceFreeMemSize:=InternalFreeMemSize(loc_info,p,pp,size,release_lock);
689
function TraceMemSize(p:pointer):ptruint;
693
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
694
TraceMemSize:=pp^.size;
698
function TraceFreeMem(p:pointer):ptruint;
708
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
710
dec(l,sizeof(theap_mem_info)+pp^.extra_info_size);
712
dec(l,sizeof(ptruint));
713
{ this can never happend normaly }
717
dump_wrong_size(pp,l,ownfile)
719
dump_wrong_size(pp,l,stderr);
722
dump_wrong_size(pp,l,error_file);
725
TraceFreeMem:=TraceFreeMemSize(p,pp^.size);
729
{*****************************************************************************
731
*****************************************************************************}
733
function TraceReAllocMem(var p:pointer;size:ptruint):Pointer;
745
oldexactsize : ptruint;
746
old_fill_extra_info_proc : tfillextrainfoproc;
747
old_display_extra_info_proc : tdisplayextrainfoproc;
748
loc_info: pheap_info;
759
{ Allocate a new block? }
762
p:=TraceGetMem(size);
767
loc_info:=@heap_info;
768
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
770
if ((pp^.sig<>$DEADBEEF) or usecrc) and
771
((pp^.sig<>calculate_sig(pp)) or not usecrc) then
773
loc_info^.error_in_heap:=true;
775
dump_error(pp,ownfile)
777
dump_error(pp,stderr);
779
dump_error(pp,error_file);
781
{ don't release anything in this case !! }
782
if haltonerror then halt(1);
787
oldextrasize:=pp^.extra_info_size;
788
oldexactsize:=pp^.exact_info_size;
789
if pp^.extra_info_size>0 then
791
old_fill_extra_info_proc:=pp^.extra_info^.fillproc;
792
old_display_extra_info_proc:=pp^.extra_info^.displayproc;
794
{ Do the real ReAllocMem, but alloc also for the info block }
796
allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+pp^.extra_info_size;
798
allocsize:=size+sizeof(theap_mem_info)+pp^.extra_info_size;
801
inc(allocsize,sizeof(ptruint));
802
{ Try to resize the block, if not possible we need to do a
803
getmem, move data, freemem }
804
if not SysTryResizeMem(pp,allocsize) then
807
newP := TraceGetMem(size);
811
movesize:=TraceMemSize(p);
812
{if the old size is larger than the new size,
813
move only the new size}
814
if movesize>size then
816
move(p^,newP^,movesize);
820
{ return the new pointer }
822
traceReAllocMem := newp;
825
{ Recreate the info block }
828
pp^.extra_info_size:=oldextrasize;
829
pp^.exact_info_size:=oldexactsize;
830
{ add the new extra_info and tail }
831
if pp^.extra_info_size>0 then
833
pp^.extra_info:=pointer(pp)+allocsize-pp^.extra_info_size;
834
fillchar(pp^.extra_info^,extra_info_size,0);
835
pp^.extra_info^.check:=$12345678;
836
pp^.extra_info^.fillproc:=old_fill_extra_info_proc;
837
pp^.extra_info^.displayproc:=old_display_extra_info_proc;
838
if assigned(pp^.extra_info^.fillproc) then
839
pp^.extra_info^.fillproc(@pp^.extra_info^.data);
845
pl:=pointer(pp)+allocsize-pp^.extra_info_size-sizeof(ptruint);
846
{$ifdef FPC_SUPPORTS_UNALIGNED}
847
unaligned(pl^):=$DEADBEEF;
848
{$else FPC_SUPPORTS_UNALIGNED}
850
{$endif FPC_SUPPORTS_UNALIGNED}
852
{ adjust like a freemem and then a getmem, so you get correct
853
results in the summary display }
854
inc(loc_info^.freemem_size,oldsize);
855
inc(loc_info^.freemem8_size,(oldsize+7) and not 7);
856
inc(loc_info^.getmem_size,size);
857
inc(loc_info^.getmem8_size,(size+7) and not 7);
858
{ generate new backtrace }
859
bp:=get_caller_frame(get_frame);
860
for i:=1 to tracesize do
862
pp^.calls[i]:=get_caller_addr(bp);
864
bp:=get_caller_frame(bp);
865
if (bp<oldbp) or (bp>(StackBottom + StackLength)) then
868
{ regenerate signature }
870
pp^.sig:=calculate_sig(pp);
871
{ return the pointer }
872
p:=pointer(pp)+sizeof(theap_mem_info);
878
{*****************************************************************************
880
*****************************************************************************}
888
__stklen : longword;external name '__stklen';
889
__stkbottom : longword;external name '__stkbottom';
890
edata : longword; external name 'edata';
895
etext: ptruint; external name '_etext';
896
eend : ptruint; external name '_end';
900
(* Currently still EMX based - possibly to be changed in the future. *)
902
etext: ptruint; external name '_etext';
903
edata : ptruint; external name '_edata';
904
eend : ptruint; external name '_end';
909
sdata : ptruint; external name '__data_start__';
910
edata : ptruint; external name '__data_end__';
911
sbss : ptruint; external name '__bss_start__';
912
ebss : ptruint; external name '__bss_end__';
916
procedure CheckPointer(p : pointer); [public, alias : 'FPC_CHECKPOINTER'];
920
loc_info: pheap_info;
922
get_ebp,stack_top : longword;
936
loc_info:=@heap_info;
943
if ptruint(p)<$1000 then
950
stack_top:=__stkbottom+__stklen;
951
{ allow all between start of code and end of data }
952
if ptruint(p)<=data_end then
954
{ stack can be above heap !! }
956
if (ptruint(p)>=get_ebp) and (ptruint(p)<=stack_top) then
960
{ I don't know where the stack is in other OS !! }
963
if (ptruint(p)>ptruint(get_frame)) and
967
if (ptruint(p)>=ptruint(@sdata)) and (ptruint(p)<ptruint(@edata)) then
971
if (ptruint(p)>=ptruint(@sbss)) and (ptruint(p)<ptruint(@ebss)) then
977
if (PtrUInt (P) > PtrUInt (Get_Frame)) and
978
(PtrUInt (P) < PtrUInt (StackTop)) then
980
{ inside data or bss ? }
981
if (PtrUInt (P) >= PtrUInt (@etext)) and (PtrUInt (P) < PtrUInt (@eend)) then
987
if (ptruint(p)>ptruint(get_frame)) and
988
(ptruint(p)<$c0000000) then //todo: 64bit!
990
{ inside data or bss ? }
991
if (ptruint(p)>=ptruint(@etext)) and (ptruint(p)<ptruint(@eend)) then
997
stack_top:=ptruint(StackBottom)+StackLength;
998
if (ptruint(p)<stack_top) and (ptruint(p)>ptruint(StackBottom)) then
1000
{ inside data or bss ? }
1001
{$WARNING data and bss checking missing }
1005
{$warning No checkpointer support yet for Darwin}
1009
{ first try valid list faster }
1012
pp:=loc_info^.heap_valid_last;
1015
{ inside this valid block ! }
1016
{ we can be changing the extrainfo !! }
1017
if (ptruint(p)>=ptruint(pp)+sizeof(theap_mem_info){+extra_info_size}) and
1018
(ptruint(p)<=ptruint(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then
1020
{ check allocated block }
1021
if ((pp^.sig=$DEADBEEF) and not usecrc) or
1022
((pp^.sig=calculate_sig(pp)) and usecrc) or
1023
{ special case of the fill_extra_info call }
1024
((pp=loc_info^.heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
1025
and loc_info^.inside_trace_getmem) then
1029
writeln(ptext^,'corrupted heap_mem_info');
1030
dump_error(pp,ptext^);
1037
if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then
1039
writeln(ptext^,'error in linked list of heap_mem_info');
1045
pp:=loc_info^.heap_mem_root;
1048
{ inside this block ! }
1049
if (ptruint(p)>=ptruint(pp)+sizeof(theap_mem_info)+ptruint(extra_info_size)) and
1050
(ptruint(p)<=ptruint(pp)+sizeof(theap_mem_info)+ptruint(extra_info_size)+ptruint(pp^.size)) then
1052
if ((pp^.sig=$DEADBEEF) and not usecrc) or
1053
((pp^.sig=calculate_sig(pp)) and usecrc) then
1057
writeln(ptext^,'pointer $',hexstr(p),' points into invalid memory block');
1058
dump_error(pp,ptext^);
1063
if i>loc_info^.getmem_cnt then
1065
writeln(ptext^,'error in linked list of heap_mem_info');
1069
writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block');
1070
dump_error(p,ptext^);
1075
{*****************************************************************************
1077
*****************************************************************************}
1081
pp : pheap_mem_info;
1083
ExpectedHeapFree : ptruint;
1084
status : TFPCHeapStatus;
1086
loc_info: pheap_info;
1088
loc_info:=@heap_info;
1093
pp:=loc_info^.heap_mem_root;
1094
Writeln(ptext^,'Heap dump by heaptrc unit');
1095
Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ',
1096
loc_info^.getmem_size,'/',loc_info^.getmem8_size);
1097
Writeln(ptext^,loc_info^.freemem_cnt,' memory blocks freed : ',
1098
loc_info^.freemem_size,'/',loc_info^.freemem8_size);
1099
Writeln(ptext^,loc_info^.getmem_cnt-loc_info^.freemem_cnt,
1100
' unfreed memory blocks : ',loc_info^.getmem_size-loc_info^.freemem_size);
1101
status:=SysGetFPCHeapStatus;
1102
Write(ptext^,'True heap size : ',status.CurrHeapSize);
1103
if EntryMemUsed > 0 then
1104
Writeln(ptext^,' (',EntryMemUsed,' used in System startup)')
1107
Writeln(ptext^,'True free heap : ',status.CurrHeapFree);
1108
ExpectedHeapFree:=status.CurrHeapSize
1109
-(loc_info^.getmem8_size-loc_info^.freemem8_size)
1110
-(loc_info^.getmem_cnt-loc_info^.freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)
1112
If ExpectedHeapFree<>status.CurrHeapFree then
1113
Writeln(ptext^,'Should be : ',ExpectedHeapFree);
1114
i:=loc_info^.getmem_cnt-loc_info^.freemem_cnt;
1119
Writeln(ptext^,'Error in heap memory list');
1120
Writeln(ptext^,'More memory blocks than expected');
1123
if ((pp^.sig=$DEADBEEF) and not usecrc) or
1124
((pp^.sig=calculate_sig(pp)) and usecrc) then
1126
{ this one was not released !! }
1127
if exitcode<>203 then
1128
call_stack(pp,ptext^);
1131
else if pp^.sig<>$AAAAAAAA then
1133
dump_error(pp,ptext^);
1135
dump_error(pp,error_file);
1137
loc_info^.error_in_heap:=true;
1140
else if pp^.release_sig<>calculate_release_sig(pp) then
1142
dump_change_after(pp,ptext^);
1143
dump_change_after(pp,error_file);
1144
loc_info^.error_in_heap:=true;
1150
if HaltOnNotReleased and (loc_info^.getmem_cnt<>loc_info^.freemem_cnt) then
1155
{*****************************************************************************
1157
*****************************************************************************}
1159
function TraceAllocMem(size:ptruint):Pointer;
1161
TraceAllocMem:=SysAllocMem(size);
1165
{*****************************************************************************
1166
No specific tracing calls
1167
*****************************************************************************}
1169
procedure TraceInitThread;
1171
loc_info: pheap_info;
1173
loc_info := @heap_info;
1175
loc_info^.heap_valid_first := nil;
1176
loc_info^.heap_valid_last := nil;
1178
loc_info^.heap_mem_root := nil;
1179
loc_info^.getmem_cnt := 0;
1180
loc_info^.freemem_cnt := 0;
1181
loc_info^.getmem_size := 0;
1182
loc_info^.freemem_size := 0;
1183
loc_info^.getmem8_size := 0;
1184
loc_info^.freemem8_size := 0;
1185
loc_info^.error_in_heap := false;
1186
loc_info^.inside_trace_getmem := false;
1187
EntryMemUsed := SysGetFPCHeapStatus.CurrHeapUsed;
1190
procedure TraceRelocateHeap;
1192
main_relo_todolist := @heap_info.heap_free_todo;
1193
initcriticalsection(todo_lock);
1196
procedure move_heap_info(src_info, dst_info: pheap_info);
1198
heap_mem: pheap_mem_info;
1200
if src_info^.heap_free_todo <> nil then
1201
finish_heap_free_todo_list(src_info);
1202
if dst_info^.heap_free_todo <> nil then
1203
finish_heap_free_todo_list(dst_info);
1204
heap_mem := src_info^.heap_mem_root;
1205
if heap_mem <> nil then
1208
heap_mem^.todolist := @dst_info^.heap_free_todo;
1209
if heap_mem^.previous = nil then break;
1210
heap_mem := heap_mem^.previous;
1212
heap_mem^.previous := dst_info^.heap_mem_root;
1213
if dst_info^.heap_mem_root <> nil then
1214
dst_info^.heap_mem_root^.next := heap_mem;
1215
dst_info^.heap_mem_root := src_info^.heap_mem_root;
1217
inc(dst_info^.getmem_cnt, src_info^.getmem_cnt);
1218
inc(dst_info^.getmem_size, src_info^.getmem_size);
1219
inc(dst_info^.getmem8_size, src_info^.getmem8_size);
1220
inc(dst_info^.freemem_cnt, src_info^.freemem_cnt);
1221
inc(dst_info^.freemem_size, src_info^.freemem_size);
1222
inc(dst_info^.freemem8_size, src_info^.freemem8_size);
1223
dst_info^.error_in_heap := dst_info^.error_in_heap or src_info^.error_in_heap;
1225
if assigned(dst_info^.heap_valid_first) then
1226
dst_info^.heap_valid_first^.prev_valid := src_info^.heap_valid_last
1228
dst_info^.heap_valid_last := src_info^.heap_valid_last;
1229
dst_info^.heap_valid_first := src_info^.heap_valid_first;
1233
procedure TraceExitThread;
1235
loc_info: pheap_info;
1237
loc_info := @heap_info;
1238
entercriticalsection(todo_lock);
1239
move_heap_info(loc_info, @orphaned_info);
1240
leavecriticalsection(todo_lock);
1243
function TraceGetHeapStatus:THeapStatus;
1245
TraceGetHeapStatus:=SysGetHeapStatus;
1248
function TraceGetFPCHeapStatus:TFPCHeapStatus;
1250
TraceGetFPCHeapStatus:=SysGetFPCHeapStatus;
1254
{*****************************************************************************
1256
*****************************************************************************}
1258
Procedure SetHeapTraceOutput(const name : string);
1266
assign(ownfile,name);
1273
for i:=0 to Paramcount do
1274
write(ownfile,ParamStr(i),' ');
1278
procedure SetHeapExtraInfo( size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
1280
{ the total size must stay multiple of 8, also allocate 2 pointers for
1281
the fill and display procvars }
1282
exact_info_size:=size + sizeof(theap_extra_info);
1283
extra_info_size:=(exact_info_size+7) and not 7;
1284
fill_extra_info_proc:=fillproc;
1285
display_extra_info_proc:=displayproc;
1289
{*****************************************************************************
1290
Install MemoryManager
1291
*****************************************************************************}
1294
TraceManager:TMemoryManager=(
1296
Getmem : @TraceGetMem;
1297
Freemem : @TraceFreeMem;
1298
FreememSize : @TraceFreeMemSize;
1299
AllocMem : @TraceAllocMem;
1300
ReAllocMem : @TraceReAllocMem;
1301
MemSize : @TraceMemSize;
1302
InitThread: @TraceInitThread;
1303
DoneThread: @TraceExitThread;
1304
RelocateHeap: @TraceRelocateHeap;
1305
GetHeapStatus : @TraceGetHeapStatus;
1306
GetFPCHeapStatus : @TraceGetFPCHeapStatus;
1309
procedure TraceInit;
1312
main_orig_todolist := @heap_info.heap_free_todo;
1313
main_relo_todolist := nil;
1315
SetMemoryManager(TraceManager);
1317
if outputstr <> '' then
1318
SetHeapTraceOutput(outputstr);
1320
Assign(error_file,'heap.err');
1321
Rewrite(error_file);
1325
procedure TraceExit;
1328
because this gives long long listings }
1329
{ clear inoutres, in case the program that quit didn't }
1331
if (exitcode<>0) and (erroraddr<>nil) then
1335
Writeln(ownfile,'No heap dump by heaptrc unit');
1336
Writeln(ownfile,'Exitcode = ',exitcode);
1340
Writeln(stderr,'No heap dump by heaptrc unit');
1341
Writeln(stderr,'Exitcode = ',exitcode);
1350
move_heap_info(@orphaned_info, @heap_info);
1352
if heap_info.error_in_heap and (exitcode=0) then
1354
if main_relo_todolist <> nil then
1355
donecriticalsection(todo_lock);
1366
{$if defined(win32) or defined(win64)}
1367
function GetEnvironmentStrings : pchar; stdcall;
1368
external 'kernel32' name 'GetEnvironmentStringsA';
1369
function FreeEnvironmentStrings(p : pchar) : longbool; stdcall;
1370
external 'kernel32' name 'FreeEnvironmentStringsA';
1371
Function GetEnv(envvar: string): string;
1378
p:=GetEnvironmentStrings;
1384
if upcase(copy(s,1,i-1))=upcase(envvar) then
1386
getenv:=copy(s,i+1,length(s)-i);
1389
{ next string entry}
1390
hp:=hp+strlen(hp)+1;
1392
FreeEnvironmentStrings(p);
1394
{$else defined(win32) or defined(win64)}
1397
Function GetEnv(P:string):Pchar;
1399
{ WinCE does not have environment strings.
1400
Add some way to specify heaptrc options? }
1405
Function GetEnv(P:string):Pchar;
1407
Searches the environment for a string with name p and
1408
returns a pchar to it's value.
1409
A pchar is used to accomodate for strings of length > 255
1416
p:=p+'='; {Else HOST will also find HOSTNAME, etc}
1421
while (not found) and (ep^<>nil) do
1424
for i:=1 to length(p) do
1425
if p[i]<>ep^[i-1] then
1435
getenv:=ep^+length(p)
1442
procedure LoadEnvironment;
1447
s:=Getenv('HEAPTRC');
1448
if pos('keepreleased',s)>0 then
1450
if pos('disabled',s)>0 then
1451
useheaptrace:=false;
1452
if pos('nohalt',s)>0 then
1454
if pos('haltonnotreleased',s)>0 then
1455
HaltOnNotReleased :=true;
1459
outputstr:=copy(s,i+4,255);
1460
j:=pos(' ',outputstr);
1462
j:=length(outputstr)+1;
1463
delete(outputstr,j,255);
1467
// additions for codetools
1468
{$DEFINE MC_ImplementationEnd}
1469
{$i memcheck_laz.inc}
1470
{$UNDEF MC_ImplementationEnd}
1474
{ heaptrc can be disabled from the environment }
1475
if useheaptrace then
1477
CheckHeapWrtMemCnt('memcheck.pas Initialization');
1479
if useheaptrace then
added
removed
.pc/spell_errors.diff/components/codetools/memcheck.pas
