1{ 2 This file is part of the Free Pascal run time library. 3 Copyright (c) 1999-2000 by the Free Pascal development team. 4 5 Heap tracer 6 7 See the file COPYING.FPC, included in this distribution, 8 for details about the copyright. 9 10 This program is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 14 **********************************************************************} 15 16{$checkpointer off} 17 18unit heaptrc; 19interface 20 21{$inline on} 22 23{$ifdef FPC_HEAPTRC_EXTRA} 24 {$define EXTRA} 25 {$inline off} 26{$endif FPC_HEAPTRC_EXTRA} 27 28{$TYPEDADDRESS on} 29 30{$if defined(win32) or defined(wince)} 31 {$define windows} 32{$endif} 33 34 35Procedure DumpHeap; 36Procedure DumpHeap(SkipIfNoLeaks : Boolean); 37 38{ define EXTRA to add more 39 tests : 40 - keep all memory after release and 41 check by CRC value if not changed after release 42 WARNING this needs extremely much memory (PM) } 43 44type 45 tFillExtraInfoProc = procedure(p : pointer); 46 tdisplayextrainfoProc = procedure (var ptext : text;p : pointer); 47 48{ Allows to add info pre memory block, see ppheap.pas of the compiler 49 for example source } 50procedure SetHeapExtraInfo(size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc); 51 52{ Redirection of the output to a file } 53procedure SetHeapTraceOutput(const name : string);overload; 54procedure SetHeapTraceOutput(var ATextOutput : Text);overload; 55 56procedure CheckPointer(p : pointer); 57 58const 59 { tracing level 60 splitted in two if memory is released !! } 61{$ifdef EXTRA} 62 tracesize = 32; 63{$else EXTRA} 64 tracesize = 16; 65{$endif EXTRA} 66 { install heaptrc memorymanager } 67 useheaptrace : boolean=true; 68 { less checking } 69 quicktrace : boolean=true; 70 { calls halt() on error by default !! } 71 HaltOnError : boolean = true; 72 { Halt on exit if any memory was not freed } 73 HaltOnNotReleased : boolean = false; 74 75 { set this to true if you suspect that memory 76 is freed several times } 77{$ifdef EXTRA} 78 keepreleased : boolean=true; 79{$else EXTRA} 80 keepreleased : boolean=false; 81{$endif EXTRA} 82 { add a small footprint at the end of memory blocks, this 83 can check for memory overwrites at the end of a block } 84 add_tail : boolean = true; 85 tail_size : longint = sizeof(ptruint); 86 87 { put crc in sig 88 this allows to test for writing into that part } 89 usecrc : boolean = true; 90 91 printleakedblock: boolean = false; 92 printfaultyblock: boolean = false; 93 maxprintedblocklength: integer = 128; 94 95 GlobalSkipIfNoLeaks : Boolean = False; 96 97implementation 98 99const 100 { allows to add custom info in heap_mem_info, this is the size that will 101 be allocated for this information } 102 extra_info_size : ptruint = 0; 103 exact_info_size : ptruint = 0; 104 EntryMemUsed : ptruint = 0; 105 { function to fill this info up } 106 fill_extra_info_proc : TFillExtraInfoProc = nil; 107 display_extra_info_proc : TDisplayExtraInfoProc = nil; 108 { indicates where the output will be redirected } 109 { only set using environment variables } 110 outputstr : shortstring = ''; 111 ReleaseSig = $AAAAAAAA; 112 AllocateSig = $DEADBEEF; 113 CheckSig = $12345678; 114 115type 116 pheap_extra_info = ^theap_extra_info; 117 theap_extra_info = record 118 check : cardinal; { used to check if the procvar is still valid } 119 fillproc : tfillextrainfoProc; 120 displayproc : tdisplayextrainfoProc; 121 data : record 122 end; 123 end; 124 125 ppheap_mem_info = ^pheap_mem_info; 126 pheap_mem_info = ^theap_mem_info; 127 128 { warning the size of theap_mem_info 129 must be a multiple of 8 130 because otherwise you will get 131 problems when releasing the usual memory part !! 132 sizeof(theap_mem_info = 16+tracesize*4 so 133 tracesize must be even !! PM } 134 theap_mem_info = record 135 previous, 136 next : pheap_mem_info; 137 todolist : ppheap_mem_info; 138 todonext : pheap_mem_info; 139 size : ptruint; 140 sig : longword; 141{$ifdef EXTRA} 142 release_sig : longword; 143 prev_valid : pheap_mem_info; 144{$endif EXTRA} 145 calls : array [1..tracesize] of codepointer; 146 exact_info_size : word; 147 extra_info_size : word; 148 extra_info : pheap_extra_info; 149 end; 150 151 pheap_info = ^theap_info; 152 theap_info = record 153{$ifdef EXTRA} 154 heap_valid_first, 155 heap_valid_last : pheap_mem_info; 156{$endif EXTRA} 157 heap_mem_root : pheap_mem_info; 158 heap_free_todo : pheap_mem_info; 159 getmem_cnt, 160 freemem_cnt : ptruint; 161 getmem_size, 162 freemem_size : ptruint; 163 getmem8_size, 164 freemem8_size : ptruint; 165 error_in_heap : boolean; 166 inside_trace_getmem : boolean; 167 end; 168 169var 170 useownfile, useowntextoutput : boolean; 171 ownfile : text; 172{$ifdef EXTRA} 173 error_file : text; 174{$endif EXTRA} 175 main_orig_todolist: ppheap_mem_info; 176 main_relo_todolist: ppheap_mem_info; 177 orphaned_info: theap_info; 178 todo_lock: trtlcriticalsection; 179 textoutput : ^text; 180{$ifdef FPC_HAS_FEATURE_THREADING} 181threadvar 182{$else} 183var 184{$endif} 185 heap_info: theap_info; 186 187{***************************************************************************** 188 Crc 32 189*****************************************************************************} 190 191var 192 Crc32Tbl : array[0..255] of longword; 193const 194 Crc32Seed = $ffffffff; 195 Crc32Pattern = $edb88320; 196 197procedure MakeCRC32Tbl; 198var 199 crc : longword; 200 i,n : byte; 201begin 202 for i:=0 to 255 do 203 begin 204 crc:=i; 205 for n:=1 to 8 do 206 if odd(crc) then 207 crc:=(crc shr 1) xor longword(CRC32Pattern) 208 else 209 crc:=crc shr 1; 210 Crc32Tbl[i]:=crc; 211 end; 212end; 213 214 215Function UpdateCrc32(InitCrc:longword;var InBuf;InLen:ptruint):longword; 216var 217 i : ptruint; 218 p : pchar; 219begin 220 p:=@InBuf; 221 for i:=1 to InLen do 222 begin 223 InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8); 224 inc(p); 225 end; 226 UpdateCrc32:=InitCrc; 227end; 228 229Function calculate_sig(p : pheap_mem_info) : longword; 230var 231 crc : longword; 232 pl : pptruint; 233begin 234 crc:=longword(CRC32Seed); 235 crc:=UpdateCrc32(crc,p^.size,sizeof(ptruint)); 236 crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(codepointer)); 237 if p^.extra_info_size>0 then 238 crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size); 239 if add_tail then 240 begin 241 { Check also 4 bytes just after allocation !! } 242 pl:=pointer(p)+sizeof(theap_mem_info)+p^.size; 243 crc:=UpdateCrc32(crc,pl^,tail_size); 244 end; 245 calculate_sig:=crc; 246end; 247 248{$ifdef EXTRA} 249Function calculate_release_sig(p : pheap_mem_info) : longword; 250var 251 crc : longword; 252 pl : pptruint; 253begin 254 crc:=longword(CRC32Seed); 255 crc:=UpdateCrc32(crc,p^.size,sizeof(ptruint)); 256 crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(codepointer)); 257 if p^.extra_info_size>0 then 258 crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size); 259 { Check the whole of the whole allocation } 260 pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info); 261 crc:=UpdateCrc32(crc,pl^,p^.size); 262 { Check also 4 bytes just after allocation !! } 263 if add_tail then 264 begin 265 { Check also 4 bytes just after allocation !! } 266 pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size; 267 crc:=UpdateCrc32(crc,pl^,tail_size); 268 end; 269 calculate_release_sig:=crc; 270end; 271{$endif EXTRA} 272 273 274{***************************************************************************** 275 Helpers 276*****************************************************************************} 277 278function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info; 279 size: ptruint; release_todo_lock: boolean): ptruint; forward; 280function TraceFreeMem(p: pointer): ptruint; forward; 281 282procedure printhex(p : pointer; const size : PtrUInt; var ptext : text); 283var s: PtrUInt; 284 i: Integer; 285begin 286 s := size; 287 if s > maxprintedblocklength then 288 s := maxprintedblocklength; 289 290 for i:=0 to s-1 do 291 write(ptext, hexstr(pbyte(p + i)^,2)); 292 293 if size > maxprintedblocklength then 294 writeln(ptext,'.. - ') 295 else 296 writeln(ptext, ' - '); 297 298 for i:=0 to s-1 do 299 if pchar(p + sizeof(theap_mem_info) + i)^ < ' ' then 300 write(ptext, ' ') 301 else 302 write(ptext, pchar(p + i)^); 303 304 if size > maxprintedblocklength then 305 writeln(ptext,'..') 306 else 307 writeln(ptext); 308end; 309 310procedure call_stack(pp : pheap_mem_info;var ptext : text); 311var 312 i : ptruint; 313begin 314 writeln(ptext,'Call trace for block $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size); 315 if printleakedblock then 316 begin 317 write(ptext, 'Block content: '); 318 printhex(pointer(pp) + sizeof(theap_mem_info), pp^.size, ptext); 319 end; 320 321 for i:=1 to tracesize do 322 if pp^.calls[i]<>nil then 323 writeln(ptext,BackTraceStrFunc(pp^.calls[i])); 324 325 { the check is done to be sure that the procvar is not overwritten } 326 if assigned(pp^.extra_info) and 327 (pp^.extra_info^.check=cardinal(CheckSig)) and 328 assigned(pp^.extra_info^.displayproc) then 329 pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data); 330end; 331 332 333procedure call_free_stack(pp : pheap_mem_info;var ptext : text); 334var 335 i : ptruint; 336begin 337 writeln(ptext,'Call trace for block at $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size); 338 for i:=1 to tracesize div 2 do 339 if pp^.calls[i]<>nil then 340 writeln(ptext,BackTraceStrFunc(pp^.calls[i])); 341 writeln(ptext,' was released at '); 342 for i:=(tracesize div 2)+1 to tracesize do 343 if pp^.calls[i]<>nil then 344 writeln(ptext,BackTraceStrFunc(pp^.calls[i])); 345 { the check is done to be sure that the procvar is not overwritten } 346 if assigned(pp^.extra_info) and 347 (pp^.extra_info^.check=cardinal(CheckSig)) and 348 assigned(pp^.extra_info^.displayproc) then 349 pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data); 350end; 351 352 353procedure dump_already_free(p : pheap_mem_info;var ptext : text); 354begin 355 Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released'); 356 call_free_stack(p,ptext); 357 Writeln(ptext,'freed again at'); 358 dump_stack(ptext,1); 359end; 360 361procedure dump_error(p : pheap_mem_info;var ptext : text); 362begin 363 Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid'); 364 Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8)); 365 if printfaultyblock then 366 begin 367 write(ptext, 'Block content: '); 368 printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext); 369 end; 370 dump_stack(ptext,1); 371end; 372 373function released_modified(p : pheap_mem_info;var ptext : text) : boolean; 374 var pl : pdword; 375 pb : pbyte; 376 i : longint; 377begin 378 released_modified:=false; 379 { Check tail_size bytes just after allocation !! } 380 pl:=pointer(p)+sizeof(theap_mem_info)+p^.size; 381 pb:=pointer(p)+sizeof(theap_mem_info); 382 for i:=0 to p^.size-1 do 383 if pb[i]<>$F0 then 384 begin 385 Writeln(ptext,'offset',i,':$',hexstr(i,2*sizeof(pointer)),'"',hexstr(pb[i],2),'"'); 386 released_modified:=true; 387 end; 388 for i:=1 to (tail_size div sizeof(dword)) do 389 begin 390 if unaligned(pl^) <> AllocateSig then 391 begin 392 released_modified:=true; 393 writeln(ptext,'Tail modified after release at pos ',i*sizeof(ptruint)); 394 printhex(pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size,tail_size,ptext); 395 break; 396 end; 397 inc(pointer(pl),sizeof(dword)); 398 end; 399 if released_modified then 400 begin 401 dump_already_free(p,ptext); 402 if @stderr<>@ptext then 403 dump_already_free(p,stderr); 404 end; 405end; 406 407{$ifdef EXTRA} 408procedure dump_change_after(p : pheap_mem_info;var ptext : text); 409 var pp : pchar; 410 i : ptruint; 411begin 412 Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid'); 413 Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8)); 414 Writeln(ptext,'This memory was changed after call to freemem !'); 415 call_free_stack(p,ptext); 416 pp:=pointer(p)+sizeof(theap_mem_info); 417 for i:=0 to p^.size-1 do 418 if byte(pp[i])<>$F0 then 419 Writeln(ptext,'offset',i,':$',hexstr(i,2*sizeof(pointer)),'"',pp[i],'"'); 420end; 421{$endif EXTRA} 422 423procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text); 424begin 425 Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid'); 426 Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed'); 427 dump_stack(ptext,1); 428 { the check is done to be sure that the procvar is not overwritten } 429 if assigned(p^.extra_info) and 430 (p^.extra_info^.check=cardinal(CheckSig)) and 431 assigned(p^.extra_info^.displayproc) then 432 p^.extra_info^.displayproc(ptext,@p^.extra_info^.data); 433 call_stack(p,ptext); 434end; 435 436function is_in_getmem_list (loc_info: pheap_info; p : pheap_mem_info) : boolean; 437var 438 i : ptruint; 439 pp : pheap_mem_info; 440begin 441 is_in_getmem_list:=false; 442 pp:=loc_info^.heap_mem_root; 443 i:=0; 444 while pp<>nil do 445 begin 446 if ((pp^.sig<>longword(AllocateSig)) or usecrc) and 447 ((pp^.sig<>calculate_sig(pp)) or not usecrc) and 448 (pp^.sig <>longword(ReleaseSig)) then 449 begin 450 if useownfile then 451 writeln(ownfile,'error in linked list of heap_mem_info') 452 else 453 writeln(textoutput^,'error in linked list of heap_mem_info'); 454 RunError(204); 455 end; 456 if pp=p then 457 is_in_getmem_list:=true; 458 pp:=pp^.previous; 459 inc(i); 460 if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then 461 if useownfile then 462 writeln(ownfile,'error in linked list of heap_mem_info') 463 else 464 writeln(textoutput^,'error in linked list of heap_mem_info'); 465 end; 466end; 467 468procedure finish_heap_free_todo_list(loc_info: pheap_info); 469var 470 bp: pointer; 471 pp: pheap_mem_info; 472 list: ppheap_mem_info; 473begin 474 list := @loc_info^.heap_free_todo; 475 repeat 476 pp := list^; 477 list^ := list^^.todonext; 478 bp := pointer(pp)+sizeof(theap_mem_info); 479 InternalFreeMemSize(loc_info,bp,pp,pp^.size,false); 480 until list^ = nil; 481end; 482 483procedure try_finish_heap_free_todo_list(loc_info: pheap_info); 484begin 485 if loc_info^.heap_free_todo <> nil then 486 begin 487{$ifdef FPC_HAS_FEATURE_THREADING} 488 entercriticalsection(todo_lock); 489{$endif} 490 finish_heap_free_todo_list(loc_info); 491{$ifdef FPC_HAS_FEATURE_THREADING} 492 leavecriticalsection(todo_lock); 493{$endif} 494 end; 495end; 496 497 498{***************************************************************************** 499 TraceGetMem 500*****************************************************************************} 501 502Function TraceGetMem(size:ptruint):pointer; 503var 504 i, allocsize : ptruint; 505 pl : pdword; 506 p : pointer; 507 pp : pheap_mem_info; 508 loc_info: pheap_info; 509begin 510 loc_info := @heap_info; 511 try_finish_heap_free_todo_list(loc_info); 512 inc(loc_info^.getmem_size,size); 513 inc(loc_info^.getmem8_size,(size+7) and not 7); 514{ Do the real GetMem, but alloc also for the info block } 515{$ifdef cpuarm} 516 allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+extra_info_size; 517{$else cpuarm} 518 allocsize:=size+sizeof(theap_mem_info)+extra_info_size; 519{$endif cpuarm} 520 if add_tail then 521 inc(allocsize,tail_size); 522 { if ReturnNilIfGrowHeapFails is true 523 SysGetMem can return nil } 524 p:=SysGetMem(allocsize); 525 if (p=nil) then 526 begin 527 TraceGetMem:=nil; 528 exit; 529 end; 530 pp:=pheap_mem_info(p); 531 inc(p,sizeof(theap_mem_info)); 532{ Create the info block } 533 pp^.sig:=longword(AllocateSig); 534 pp^.todolist:=@loc_info^.heap_free_todo; 535 pp^.todonext:=nil; 536 pp^.size:=size; 537 pp^.extra_info_size:=extra_info_size; 538 pp^.exact_info_size:=exact_info_size; 539 { 540 the end of the block contains: 541 <tail> 4 bytes 542 <extra_info> X bytes 543 } 544 if extra_info_size>0 then 545 begin 546 pp^.extra_info:=pointer(pp)+allocsize-extra_info_size; 547 fillchar(pp^.extra_info^,extra_info_size,0); 548 pp^.extra_info^.check:=cardinal(CheckSig); 549 pp^.extra_info^.fillproc:=fill_extra_info_proc; 550 pp^.extra_info^.displayproc:=display_extra_info_proc; 551 if assigned(fill_extra_info_proc) then 552 begin 553 loc_info^.inside_trace_getmem:=true; 554 fill_extra_info_proc(@pp^.extra_info^.data); 555 loc_info^.inside_trace_getmem:=false; 556 end; 557 end 558 else 559 pp^.extra_info:=nil; 560 if add_tail then 561 begin 562 pl:=pointer(pp)+allocsize-pp^.extra_info_size-tail_size; 563 for i:=1 to tail_size div sizeof(dword) do 564 begin 565 unaligned(pl^):=dword(AllocateSig); 566 inc(pointer(pl),sizeof(dword)); 567 end; 568 end; 569 { clear the memory } 570 fillchar(p^,size,#255); 571 { retrieve backtrace info } 572 CaptureBacktrace(1,tracesize,@pp^.calls[1]); 573 574 { insert in the linked list } 575 if loc_info^.heap_mem_root<>nil then 576 loc_info^.heap_mem_root^.next:=pp; 577 pp^.previous:=loc_info^.heap_mem_root; 578 pp^.next:=nil; 579{$ifdef EXTRA} 580 pp^.prev_valid:=loc_info^.heap_valid_last; 581 loc_info^.heap_valid_last:=pp; 582 if not assigned(loc_info^.heap_valid_first) then 583 loc_info^.heap_valid_first:=pp; 584{$endif EXTRA} 585 loc_info^.heap_mem_root:=pp; 586 { must be changed before fill_extra_info is called 587 because checkpointer can be called from within 588 fill_extra_info PM } 589 inc(loc_info^.getmem_cnt); 590 { update the signature } 591 if usecrc then 592 pp^.sig:=calculate_sig(pp); 593 TraceGetmem:=p; 594end; 595 596 597{***************************************************************************** 598 TraceFreeMem 599*****************************************************************************} 600 601function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info; 602 size, ppsize: ptruint): boolean; inline; 603var 604 ptext : ^text; 605{$ifdef EXTRA} 606 pp2 : pheap_mem_info; 607{$endif} 608begin 609 if useownfile then 610 ptext:=@ownfile 611 else 612 ptext:=textoutput; 613 inc(loc_info^.freemem_size,size); 614 inc(loc_info^.freemem8_size,(size+7) and not 7); 615 if not quicktrace then 616 begin 617 if not(is_in_getmem_list(loc_info, pp)) then 618 RunError(204); 619 end; 620 if (pp^.sig=longword(ReleaseSig)) then 621 begin 622 loc_info^.error_in_heap:=true; 623 dump_already_free(pp,ptext^); 624 if haltonerror then halt(1); 625 end 626 else if ((pp^.sig<>longword(AllocateSig)) or usecrc) and 627 ((pp^.sig<>calculate_sig(pp)) or not usecrc) then 628 begin 629 loc_info^.error_in_heap:=true; 630 dump_error(pp,ptext^); 631{$ifdef EXTRA} 632 dump_error(pp,error_file); 633{$endif EXTRA} 634 { don't release anything in this case !! } 635 if haltonerror then halt(1); 636 exit; 637 end 638 else if pp^.size<>size then 639 begin 640 loc_info^.error_in_heap:=true; 641 dump_wrong_size(pp,size,ptext^); 642{$ifdef EXTRA} 643 dump_wrong_size(pp,size,error_file); 644{$endif EXTRA} 645 if haltonerror then halt(1); 646 { don't release anything in this case !! } 647 exit; 648 end; 649 { now it is released !! } 650 pp^.sig:=longword(ReleaseSig); 651 if not keepreleased then 652 begin 653 if pp^.next<>nil then 654 pp^.next^.previous:=pp^.previous; 655 if pp^.previous<>nil then 656 pp^.previous^.next:=pp^.next; 657 if pp=loc_info^.heap_mem_root then 658 loc_info^.heap_mem_root:=loc_info^.heap_mem_root^.previous; 659 end 660 else 661 CaptureBacktrace(1,(tracesize div 2)-1,@pp^.calls[(tracesize div 2)+1]); 662 663 inc(loc_info^.freemem_cnt); 664 { clear the memory, $F0 will lead to GFP if used as pointer ! } 665 fillchar((pointer(pp)+sizeof(theap_mem_info))^,size,#240); 666 { this way we keep all info about all released memory !! } 667 if keepreleased then 668 begin 669{$ifdef EXTRA} 670 { We want to check if the memory was changed after release !! } 671 pp^.release_sig:=calculate_release_sig(pp); 672 if pp=loc_info^.heap_valid_last then 673 begin 674 loc_info^.heap_valid_last:=pp^.prev_valid; 675 if pp=loc_info^.heap_valid_first then 676 loc_info^.heap_valid_first:=nil; 677 exit(false); 678 end; 679 pp2:=loc_info^.heap_valid_last; 680 while assigned(pp2) do 681 begin 682 if pp2^.prev_valid=pp then 683 begin 684 pp2^.prev_valid:=pp^.prev_valid; 685 if pp=loc_info^.heap_valid_first then 686 loc_info^.heap_valid_first:=pp2; 687 exit(false); 688 end 689 else 690 pp2:=pp2^.prev_valid; 691 end; 692{$endif EXTRA} 693 exit(false); 694 end; 695 CheckFreeMemSize:=true; 696end; 697 698function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info; 699 size: ptruint; release_todo_lock: boolean): ptruint; 700var 701 i,ppsize : ptruint; 702 extra_size: ptruint; 703 release_mem: boolean; 704begin 705 { save old values } 706 extra_size:=pp^.extra_info_size; 707 ppsize:= size+sizeof(theap_mem_info)+pp^.extra_info_size; 708 if add_tail then 709 inc(ppsize,tail_size); 710 { do various checking } 711 release_mem := CheckFreeMemSize(loc_info, pp, size, ppsize); 712{$ifdef FPC_HAS_FEATURE_THREADING} 713 if release_todo_lock then 714 leavecriticalsection(todo_lock); 715{$endif} 716 if release_mem then 717 begin 718 { release the normal memory at least } 719 i:=SysFreeMemSize(pp,ppsize); 720 { return the correct size } 721 dec(i,sizeof(theap_mem_info)+extra_size); 722 if add_tail then 723 dec(i,tail_size); 724 InternalFreeMemSize:=i; 725 end else 726 InternalFreeMemSize:=size; 727end; 728 729function TraceFreeMemSize(p:pointer;size:ptruint):ptruint; 730var 731 loc_info: pheap_info; 732 pp: pheap_mem_info; 733 release_lock: boolean; 734begin 735 if p=nil then 736 begin 737 TraceFreeMemSize:=0; 738 exit; 739 end; 740 loc_info:=@heap_info; 741 pp:=pheap_mem_info(p-sizeof(theap_mem_info)); 742 release_lock:=false; 743 if @loc_info^.heap_free_todo <> pp^.todolist then 744 begin 745 if pp^.todolist = main_orig_todolist then 746 pp^.todolist := main_relo_todolist; 747{$ifdef FPC_HAS_FEATURE_THREADING} 748 entercriticalsection(todo_lock); 749{$endif} 750 release_lock:=true; 751 if pp^.todolist = @orphaned_info.heap_free_todo then 752 begin 753 loc_info := @orphaned_info; 754 end else 755 if pp^.todolist <> @loc_info^.heap_free_todo then 756 begin 757 { allocated in different heap, push to that todolist } 758 pp^.todonext := pp^.todolist^; 759 pp^.todolist^ := pp; 760 TraceFreeMemSize := pp^.size; 761{$ifdef FPC_HAS_FEATURE_THREADING} 762 leavecriticalsection(todo_lock); 763{$endif} 764 exit; 765 end; 766 end; 767 TraceFreeMemSize:=InternalFreeMemSize(loc_info,p,pp,size,release_lock); 768end; 769 770 771function TraceMemSize(p:pointer):ptruint; 772var 773 pp : pheap_mem_info; 774begin 775 pp:=pheap_mem_info(p-sizeof(theap_mem_info)); 776 TraceMemSize:=pp^.size; 777end; 778 779 780function TraceFreeMem(p:pointer):ptruint; 781var 782 l : ptruint; 783 pp : pheap_mem_info; 784begin 785 if p=nil then 786 begin 787 TraceFreeMem:=0; 788 exit; 789 end; 790 pp:=pheap_mem_info(p-sizeof(theap_mem_info)); 791 l:=SysMemSize(pp); 792 dec(l,sizeof(theap_mem_info)+pp^.extra_info_size); 793 if add_tail then 794 dec(l,tail_size); 795 { this can never happend normaly } 796 if pp^.size>l then 797 begin 798 if useownfile then 799 dump_wrong_size(pp,l,ownfile) 800 else 801 dump_wrong_size(pp,l,textoutput^); 802 803{$ifdef EXTRA} 804 dump_wrong_size(pp,l,error_file); 805{$endif EXTRA} 806 end; 807 TraceFreeMem:=TraceFreeMemSize(p,pp^.size); 808end; 809 810 811{***************************************************************************** 812 ReAllocMem 813*****************************************************************************} 814 815function TraceReAllocMem(var p:pointer;size:ptruint):Pointer; 816var 817 newP: pointer; 818 i, allocsize, 819 movesize : ptruint; 820 pl : pdword; 821 pp : pheap_mem_info; 822 oldsize, 823 oldextrasize, 824 oldexactsize : ptruint; 825 old_fill_extra_info_proc : tfillextrainfoproc; 826 old_display_extra_info_proc : tdisplayextrainfoproc; 827 loc_info: pheap_info; 828begin 829{ Free block? } 830 if size=0 then 831 begin 832 if p<>nil then 833 TraceFreeMem(p); 834 p:=nil; 835 TraceReallocMem:=P; 836 exit; 837 end; 838{ Allocate a new block? } 839 if p=nil then 840 begin 841 p:=TraceGetMem(size); 842 TraceReallocMem:=P; 843 exit; 844 end; 845{ Resize block } 846 loc_info:=@heap_info; 847 pp:=pheap_mem_info(p-sizeof(theap_mem_info)); 848 { test block } 849 if ((pp^.sig<>longword(AllocateSig)) or usecrc) and 850 ((pp^.sig<>calculate_sig(pp)) or not usecrc) then 851 begin 852 loc_info^.error_in_heap:=true; 853 if useownfile then 854 dump_error(pp,ownfile) 855 else 856 dump_error(pp,textoutput^); 857{$ifdef EXTRA} 858 dump_error(pp,error_file); 859{$endif EXTRA} 860 { don't release anything in this case !! } 861 if haltonerror then halt(1); 862 exit; 863 end; 864 { save info } 865 oldsize:=pp^.size; 866 oldextrasize:=pp^.extra_info_size; 867 oldexactsize:=pp^.exact_info_size; 868 if pp^.extra_info_size>0 then 869 begin 870 old_fill_extra_info_proc:=pp^.extra_info^.fillproc; 871 old_display_extra_info_proc:=pp^.extra_info^.displayproc; 872 end; 873 { Do the real ReAllocMem, but alloc also for the info block } 874{$ifdef cpuarm} 875 allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+pp^.extra_info_size; 876{$else cpuarm} 877 allocsize:=size+sizeof(theap_mem_info)+pp^.extra_info_size; 878{$endif cpuarm} 879 if add_tail then 880 inc(allocsize,tail_size); 881 { Try to resize the block, if not possible we need to do a 882 getmem, move data, freemem } 883 if not SysTryResizeMem(pp,allocsize) then 884 begin 885 { get a new block } 886 newP := TraceGetMem(size); 887 { move the data } 888 if newP <> nil then 889 begin 890 movesize:=TraceMemSize(p); 891 {if the old size is larger than the new size, 892 move only the new size} 893 if movesize>size then 894 movesize:=size; 895 move(p^,newP^,movesize); 896 end; 897 { release p } 898 traceFreeMem(p); 899 { return the new pointer } 900 p:=newp; 901 traceReAllocMem := newp; 902 exit; 903 end; 904{ Recreate the info block } 905 pp^.sig:=longword(AllocateSig); 906 pp^.size:=size; 907 pp^.extra_info_size:=oldextrasize; 908 pp^.exact_info_size:=oldexactsize; 909 { add the new extra_info and tail } 910 if pp^.extra_info_size>0 then 911 begin 912 pp^.extra_info:=pointer(pp)+allocsize-pp^.extra_info_size; 913 fillchar(pp^.extra_info^,extra_info_size,0); 914 pp^.extra_info^.check:=cardinal(CheckSig); 915 pp^.extra_info^.fillproc:=old_fill_extra_info_proc; 916 pp^.extra_info^.displayproc:=old_display_extra_info_proc; 917 if assigned(pp^.extra_info^.fillproc) then 918 pp^.extra_info^.fillproc(@pp^.extra_info^.data); 919 end 920 else 921 pp^.extra_info:=nil; 922 if add_tail then 923 begin 924 pl:=pointer(pp)+allocsize-pp^.extra_info_size-tail_size; 925 for i:=1 to tail_size div sizeof(dword) do 926 begin 927 unaligned(pl^):=dword(AllocateSig); 928 inc(pointer(pl),sizeof(dword)); 929 end; 930 end; 931 { adjust like a freemem and then a getmem, so you get correct 932 results in the summary display } 933 inc(loc_info^.freemem_size,oldsize); 934 inc(loc_info^.freemem8_size,(oldsize+7) and not 7); 935 inc(loc_info^.getmem_size,size); 936 inc(loc_info^.getmem8_size,(size+7) and not 7); 937 { generate new backtrace } 938 CaptureBacktrace(1,tracesize,@pp^.calls[1]); 939 { regenerate signature } 940 if usecrc then 941 pp^.sig:=calculate_sig(pp); 942 { return the pointer } 943 p:=pointer(pp)+sizeof(theap_mem_info); 944 TraceReAllocmem:=p; 945end; 946 947 948 949{***************************************************************************** 950 Check pointer 951*****************************************************************************} 952 953{$ifndef Unix} 954 {$S-} 955{$endif} 956 957{$ifdef go32v2} 958var 959 __stklen : longword;external name '__stklen'; 960 __stkbottom : longword;external name '__stkbottom'; 961 ebss : longword; external name 'end'; 962{$endif go32v2} 963 964{$ifdef linux} 965var 966 etext: ptruint; external name '_etext'; 967 edata : ptruint; external name '_edata'; 968 eend : ptruint; external name '_end'; 969{$endif} 970 971{$ifdef freebsd} 972var 973 text_start: ptruint; external name '__executable_start'; 974 etext: ptruint; external name '_etext'; 975 eend : ptruint; external name '_end'; 976{$endif} 977 978{$ifdef os2} 979(* Currently still EMX based - possibly to be changed in the future. *) 980var 981 etext: ptruint; external name '_etext'; 982 edata : ptruint; external name '_edata'; 983 eend : ptruint; external name '_end'; 984{$endif} 985 986{$ifdef windows} 987var 988 sdata : ptruint; external name '__data_start__'; 989 edata : ptruint; external name '__data_end__'; 990 sbss : ptruint; external name '__bss_start__'; 991 ebss : ptruint; external name '__bss_end__'; 992 TLSKey : PDWord; external name '_FPC_TlsKey'; 993 TLSSize : DWord; external name '_FPC_TlsSize'; 994 995function TlsGetValue(dwTlsIndex : DWord) : pointer; 996 {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'TlsGetValue'; 997{$endif} 998 999{$ifdef BEOS} 1000const 1001 B_ERROR = -1; 1002 1003type 1004 area_id = Longint; 1005 1006function area_for(addr : Pointer) : area_id; 1007 cdecl; external 'root' name 'area_for'; 1008{$endif BEOS} 1009 1010procedure CheckPointer(p : pointer); [public, alias : 'FPC_CHECKPOINTER']; 1011var 1012 i : ptruint; 1013 pp : pheap_mem_info; 1014 loc_info: pheap_info; 1015{$ifdef go32v2} 1016 get_ebp,stack_top : longword; 1017 bss_end : longword; 1018{$endif go32v2} 1019{$ifdef windows} 1020 datap : pointer; 1021{$endif windows} 1022 ptext : ^text; 1023begin 1024 if p=nil then 1025 runerror(204); 1026 1027 i:=0; 1028 loc_info:=@heap_info; 1029 if useownfile then 1030 ptext:=@ownfile 1031 else 1032 ptext:=textoutput; 1033 1034{$ifdef go32v2} 1035 if ptruint(p)<$1000 then 1036 runerror(216); 1037 asm 1038 movl %ebp,get_ebp 1039 leal ebss,%eax 1040 movl %eax,bss_end 1041 end; 1042 stack_top:=__stkbottom+__stklen; 1043 { allow all between start of code and end of bss } 1044 if ptruint(p)<=bss_end then 1045 exit; 1046 { stack can be above heap !! } 1047 1048 if (ptruint(p)>=get_ebp) and (ptruint(p)<=stack_top) then 1049 exit; 1050{$endif go32v2} 1051 1052 { I don't know where the stack is in other OS !! } 1053{$ifdef windows} 1054 { inside stack ? } 1055 if (ptruint(p)>ptruint(get_frame)) and 1056 (p<StackTop) then 1057 exit; 1058 { inside data, rdata ... bss } 1059 if (ptruint(p)>=ptruint(@sdata)) and (ptruint(p)<ptruint(@ebss)) then 1060 exit; 1061 { is program multi-threaded and p inside Threadvar range? } 1062 if TlsKey^<>-1 then 1063 begin 1064 datap:=TlsGetValue(tlskey^); 1065 if ((ptruint(p)>=ptruint(datap)) and 1066 (ptruint(p)<ptruint(datap)+TlsSize)) then 1067 exit; 1068 end; 1069{$endif windows} 1070 1071{$IFDEF OS2} 1072 { inside stack ? } 1073 if (PtrUInt (P) > PtrUInt (Get_Frame)) and 1074 (PtrUInt (P) < PtrUInt (StackTop)) then 1075 exit; 1076 { inside data or bss ? } 1077 if (PtrUInt (P) >= PtrUInt (@etext)) and (PtrUInt (P) < PtrUInt (@eend)) then 1078 exit; 1079{$ENDIF OS2} 1080 1081{$ifdef linux} 1082 { inside stack ? } 1083 if (ptruint(p)>ptruint(get_frame)) and 1084 (ptruint(p)<ptruint(StackTop)) then 1085 exit; 1086 { inside data or bss ? } 1087 if (ptruint(p)>=ptruint(@etext)) and (ptruint(p)<ptruint(@eend)) then 1088 exit; 1089{$endif linux} 1090 1091{$ifdef freebsd} 1092 { inside stack ? } 1093 if (ptruint(p)>ptruint(get_frame)) and 1094 (ptruint(p)<ptruint(StackTop)) then 1095 exit; 1096 { inside data or bss ? } 1097 if (ptruint(p)>=ptruint(@text_start)) and (ptruint(p)<ptruint(@eend)) then 1098 exit; 1099{$endif linux} 1100{$ifdef morphos} 1101 { inside stack ? } 1102 if (ptruint(p)<ptruint(StackTop)) and (ptruint(p)>ptruint(StackBottom)) then 1103 exit; 1104 { inside data or bss ? } 1105 {$WARNING data and bss checking missing } 1106{$endif morphos} 1107 1108 {$ifdef darwin} 1109 {$warning No checkpointer support yet for Darwin} 1110 exit; 1111 {$endif} 1112 1113{$ifdef BEOS} 1114 // if we find the address in a known area in our current process, 1115 // then it is a valid one 1116 if area_for(p) <> B_ERROR then 1117 exit; 1118{$endif BEOS} 1119 1120 { first try valid list faster } 1121 1122{$ifdef EXTRA} 1123 pp:=loc_info^.heap_valid_last; 1124 while pp<>nil do 1125 begin 1126 { inside this valid block ! } 1127 { we can be changing the extrainfo !! } 1128 if (ptruint(p)>=ptruint(pp)+sizeof(theap_mem_info){+extra_info_size}) and 1129 (ptruint(p)<=ptruint(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then 1130 begin 1131 { check allocated block } 1132 if ((pp^.sig=longword(AllocateSig)) and not usecrc) or 1133 ((pp^.sig=calculate_sig(pp)) and usecrc) or 1134 { special case of the fill_extra_info call } 1135 ((pp=loc_info^.heap_valid_last) and usecrc and (pp^.sig=longword(AllocateSig)) 1136 and loc_info^.inside_trace_getmem) then 1137 exit 1138 else 1139 begin 1140 writeln(ptext^,'corrupted heap_mem_info'); 1141 dump_error(pp,ptext^); 1142 halt(1); 1143 end; 1144 end 1145 else 1146 pp:=pp^.prev_valid; 1147 inc(i); 1148 if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then 1149 begin 1150 writeln(ptext^,'error in linked list of heap_mem_info'); 1151 halt(1); 1152 end; 1153 end; 1154 i:=0; 1155{$endif EXTRA} 1156 pp:=loc_info^.heap_mem_root; 1157 while pp<>nil do 1158 begin 1159 { inside this block ! } 1160 if (ptruint(p)>=ptruint(pp)+sizeof(theap_mem_info)+ptruint(extra_info_size)) and 1161 (ptruint(p)<=ptruint(pp)+sizeof(theap_mem_info)+ptruint(extra_info_size)+ptruint(pp^.size)) then 1162 { allocated block } 1163 if ((pp^.sig=longword(AllocateSig)) and not usecrc) or 1164 ((pp^.sig=calculate_sig(pp)) and usecrc) then 1165 exit 1166 else 1167 begin 1168 writeln(ptext^,'pointer $',hexstr(p),' points into invalid memory block'); 1169 dump_error(pp,ptext^); 1170 runerror(204); 1171 end; 1172 pp:=pp^.previous; 1173 inc(i); 1174 if i>loc_info^.getmem_cnt then 1175 begin 1176 writeln(ptext^,'error in linked list of heap_mem_info'); 1177 halt(1); 1178 end; 1179 end; 1180 writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block'); 1181 dump_stack(ptext^,1); 1182 runerror(204); 1183end; 1184 1185{***************************************************************************** 1186 Dump Heap 1187*****************************************************************************} 1188 1189procedure dumpheap; 1190 1191begin 1192 DumpHeap(GlobalSkipIfNoLeaks); 1193end; 1194 1195procedure dumpheap(SkipIfNoLeaks : Boolean); 1196var 1197 pp : pheap_mem_info; 1198 i : ptrint; 1199 ExpectedHeapFree : ptruint; 1200 status : TFPCHeapStatus; 1201 ptext : ^text; 1202 loc_info: pheap_info; 1203begin 1204 loc_info:=@heap_info; 1205 if useownfile then 1206 ptext:=@ownfile 1207 else 1208 ptext:=textoutput; 1209 pp:=loc_info^.heap_mem_root; 1210 if ((loc_info^.getmem_size-loc_info^.freemem_size)=0) and SkipIfNoLeaks then 1211 exit; 1212 Writeln(ptext^,'Heap dump by heaptrc unit of '+ParamStr(0)); 1213 Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ', 1214 loc_info^.getmem_size,'/',loc_info^.getmem8_size); 1215 Writeln(ptext^,loc_info^.freemem_cnt,' memory blocks freed : ', 1216 loc_info^.freemem_size,'/',loc_info^.freemem8_size); 1217 Writeln(ptext^,loc_info^.getmem_cnt-loc_info^.freemem_cnt, 1218 ' unfreed memory blocks : ',loc_info^.getmem_size-loc_info^.freemem_size); 1219 status:=SysGetFPCHeapStatus; 1220 Write(ptext^,'True heap size : ',status.CurrHeapSize); 1221 if EntryMemUsed > 0 then 1222 Writeln(ptext^,' (',EntryMemUsed,' used in System startup)') 1223 else 1224 Writeln(ptext^); 1225 Writeln(ptext^,'True free heap : ',status.CurrHeapFree); 1226 ExpectedHeapFree:=status.CurrHeapSize 1227 -(loc_info^.getmem8_size-loc_info^.freemem8_size) 1228 -(loc_info^.getmem_cnt-loc_info^.freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size) 1229 -EntryMemUsed; 1230 If ExpectedHeapFree<>status.CurrHeapFree then 1231 Writeln(ptext^,'Should be : ',ExpectedHeapFree); 1232 i:=loc_info^.getmem_cnt-loc_info^.freemem_cnt; 1233 while pp<>nil do 1234 begin 1235 if i<0 then 1236 begin 1237 Writeln(ptext^,'Error in heap memory list'); 1238 Writeln(ptext^,'More memory blocks than expected'); 1239 exit; 1240 end; 1241 if ((pp^.sig=longword(AllocateSig)) and not usecrc) or 1242 ((pp^.sig=calculate_sig(pp)) and usecrc) then 1243 begin 1244 { this one was not released !! } 1245 if exitcode<>203 then 1246 call_stack(pp,ptext^); 1247 dec(i); 1248 end 1249 else if pp^.sig<>longword(ReleaseSig) then 1250 begin 1251 dump_error(pp,ptext^); 1252 if @stderr<>ptext then 1253 dump_error(pp,stderr); 1254{$ifdef EXTRA} 1255 dump_error(pp,error_file); 1256{$endif EXTRA} 1257 loc_info^.error_in_heap:=true; 1258 end 1259{$ifdef EXTRA} 1260 else if pp^.release_sig<>calculate_release_sig(pp) then 1261 begin 1262 dump_change_after(pp,ptext^); 1263 dump_change_after(pp,error_file); 1264 loc_info^.error_in_heap:=true; 1265 end 1266{$else not EXTRA} 1267 else 1268 begin 1269 if released_modified(pp,ptext^) then 1270 exitcode:=203; 1271 end; 1272{$endif EXTRA} 1273 ; 1274 pp:=pp^.previous; 1275 end; 1276 if HaltOnNotReleased and (loc_info^.getmem_cnt<>loc_info^.freemem_cnt) then 1277 exitcode:=203; 1278end; 1279 1280 1281{***************************************************************************** 1282 AllocMem 1283*****************************************************************************} 1284 1285function TraceAllocMem(size:ptruint):Pointer; 1286begin 1287 TraceAllocMem := TraceGetMem(size); 1288 if Assigned(TraceAllocMem) then 1289 FillChar(TraceAllocMem^, TraceMemSize(TraceAllocMem), 0); 1290end; 1291 1292 1293{***************************************************************************** 1294 No specific tracing calls 1295*****************************************************************************} 1296 1297procedure TraceInitThread; 1298var 1299 loc_info: pheap_info; 1300begin 1301 loc_info := @heap_info; 1302{$ifdef EXTRA} 1303 loc_info^.heap_valid_first := nil; 1304 loc_info^.heap_valid_last := nil; 1305{$endif} 1306 loc_info^.heap_mem_root := nil; 1307 loc_info^.getmem_cnt := 0; 1308 loc_info^.freemem_cnt := 0; 1309 loc_info^.getmem_size := 0; 1310 loc_info^.freemem_size := 0; 1311 loc_info^.getmem8_size := 0; 1312 loc_info^.freemem8_size := 0; 1313 loc_info^.error_in_heap := false; 1314 loc_info^.inside_trace_getmem := false; 1315 EntryMemUsed := SysGetFPCHeapStatus.CurrHeapUsed; 1316end; 1317 1318procedure TraceRelocateHeap; 1319begin 1320 main_relo_todolist := @heap_info.heap_free_todo; 1321{$ifdef FPC_HAS_FEATURE_THREADING} 1322 initcriticalsection(todo_lock); 1323{$endif} 1324end; 1325 1326procedure move_heap_info(src_info, dst_info: pheap_info); 1327var 1328 heap_mem: pheap_mem_info; 1329begin 1330 if src_info^.heap_free_todo <> nil then 1331 finish_heap_free_todo_list(src_info); 1332 if dst_info^.heap_free_todo <> nil then 1333 finish_heap_free_todo_list(dst_info); 1334 heap_mem := src_info^.heap_mem_root; 1335 if heap_mem <> nil then 1336 begin 1337 repeat 1338 heap_mem^.todolist := @dst_info^.heap_free_todo; 1339 if heap_mem^.previous = nil then break; 1340 heap_mem := heap_mem^.previous; 1341 until false; 1342 heap_mem^.previous := dst_info^.heap_mem_root; 1343 if dst_info^.heap_mem_root <> nil then 1344 dst_info^.heap_mem_root^.next := heap_mem; 1345 dst_info^.heap_mem_root := src_info^.heap_mem_root; 1346 end; 1347 inc(dst_info^.getmem_cnt, src_info^.getmem_cnt); 1348 inc(dst_info^.getmem_size, src_info^.getmem_size); 1349 inc(dst_info^.getmem8_size, src_info^.getmem8_size); 1350 inc(dst_info^.freemem_cnt, src_info^.freemem_cnt); 1351 inc(dst_info^.freemem_size, src_info^.freemem_size); 1352 inc(dst_info^.freemem8_size, src_info^.freemem8_size); 1353 dst_info^.error_in_heap := dst_info^.error_in_heap or src_info^.error_in_heap; 1354{$ifdef EXTRA} 1355 if assigned(dst_info^.heap_valid_first) then 1356 dst_info^.heap_valid_first^.prev_valid := src_info^.heap_valid_last 1357 else 1358 dst_info^.heap_valid_last := src_info^.heap_valid_last; 1359 dst_info^.heap_valid_first := src_info^.heap_valid_first; 1360{$endif} 1361end; 1362 1363procedure TraceExitThread; 1364var 1365 loc_info: pheap_info; 1366begin 1367 loc_info := @heap_info; 1368{$ifdef FPC_HAS_FEATURE_THREADING} 1369 entercriticalsection(todo_lock); 1370{$endif} 1371 move_heap_info(loc_info, @orphaned_info); 1372{$ifdef FPC_HAS_FEATURE_THREADING} 1373 leavecriticalsection(todo_lock); 1374{$endif} 1375end; 1376 1377function TraceGetHeapStatus:THeapStatus; 1378begin 1379 TraceGetHeapStatus:=SysGetHeapStatus; 1380end; 1381 1382function TraceGetFPCHeapStatus:TFPCHeapStatus; 1383begin 1384 TraceGetFPCHeapStatus:=SysGetFPCHeapStatus; 1385end; 1386 1387 1388{***************************************************************************** 1389 Program Hooks 1390*****************************************************************************} 1391 1392Procedure SetHeapTraceOutput(const name : string); 1393var i : ptruint; 1394begin 1395 if useownfile then 1396 begin 1397 useownfile:=false; 1398 close(ownfile); 1399 end; 1400 assign(ownfile,name); 1401{$I-} 1402 append(ownfile); 1403 if IOResult<>0 then 1404 begin 1405 Rewrite(ownfile); 1406 if IOResult<>0 then 1407 begin 1408 Writeln(textoutput^,'[heaptrc] Unable to open "',name,'", writing output to stderr instead.'); 1409 useownfile:=false; 1410 exit; 1411 end; 1412 end; 1413{$I+} 1414 useownfile:=true; 1415 for i:=0 to Paramcount do 1416 write(ownfile,paramstr(i),' '); 1417 writeln(ownfile); 1418end; 1419 1420procedure SetHeapTraceOutput(var ATextOutput : Text); 1421Begin 1422 useowntextoutput := True; 1423 textoutput := @ATextOutput; 1424end; 1425 1426procedure SetHeapExtraInfo( size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc); 1427begin 1428 { the total size must stay multiple of 8, also allocate 2 pointers for 1429 the fill and display procvars } 1430 exact_info_size:=size + sizeof(theap_extra_info); 1431 extra_info_size:=(exact_info_size+7) and not 7; 1432 fill_extra_info_proc:=fillproc; 1433 display_extra_info_proc:=displayproc; 1434end; 1435 1436 1437{***************************************************************************** 1438 Install MemoryManager 1439*****************************************************************************} 1440 1441const 1442 TraceManager:TMemoryManager=( 1443 NeedLock : true; 1444 Getmem : @TraceGetMem; 1445 Freemem : @TraceFreeMem; 1446 FreememSize : @TraceFreeMemSize; 1447 AllocMem : @TraceAllocMem; 1448 ReAllocMem : @TraceReAllocMem; 1449 MemSize : @TraceMemSize; 1450 InitThread: @TraceInitThread; 1451 DoneThread: @TraceExitThread; 1452 RelocateHeap: @TraceRelocateHeap; 1453 GetHeapStatus : @TraceGetHeapStatus; 1454 GetFPCHeapStatus : @TraceGetFPCHeapStatus; 1455 ); 1456 1457var 1458 PrevMemoryManager : TMemoryManager; 1459 1460procedure TraceInit; 1461begin 1462 textoutput := @stderr; 1463 useowntextoutput := false; 1464 MakeCRC32Tbl; 1465 main_orig_todolist := @heap_info.heap_free_todo; 1466 main_relo_todolist := nil; 1467 TraceInitThread; 1468 GetMemoryManager(PrevMemoryManager); 1469 SetMemoryManager(TraceManager); 1470 useownfile:=false; 1471 if outputstr <> '' then 1472 SetHeapTraceOutput(outputstr); 1473{$ifdef EXTRA} 1474{$i-} 1475 Assign(error_file,'heap.err'); 1476 Rewrite(error_file); 1477{$i+} 1478 if IOResult<>0 then 1479 begin 1480 writeln('[heaptrc] Unable to create heap.err extra log file, writing output to screen.'); 1481 Assign(error_file,''); 1482 Rewrite(error_file); 1483 end; 1484{$endif EXTRA} 1485 { if multithreading was initialized before heaptrc gets initialized (this is currently 1486 the case for windows dlls), then RelocateHeap gets never called and the lock 1487 must be initialized already here, 1488 1489 however, IsMultithread is not set in this case on windows, 1490 it is set only if a new thread is started 1491 } 1492{$IfNDef WINDOWS} 1493 if IsMultithread then 1494{$EndIf WINDOWS} 1495 TraceRelocateHeap; 1496end; 1497 1498procedure TraceExit; 1499begin 1500 { no dump if error 1501 because this gives long long listings } 1502 { clear inoutres, in case the program that quit didn't } 1503 ioresult; 1504 if (exitcode<>0) and (erroraddr<>nil) then 1505 begin 1506 if useownfile then 1507 begin 1508 Writeln(ownfile,'No heap dump by heaptrc unit'); 1509 Writeln(ownfile,'Exitcode = ',exitcode); 1510 end 1511 else 1512 begin 1513 Writeln(textoutput^,'No heap dump by heaptrc unit'); 1514 Writeln(textoutput^,'Exitcode = ',exitcode); 1515 end; 1516 if useownfile then 1517 begin 1518 useownfile:=false; 1519 close(ownfile); 1520 end; 1521 exit; 1522 end; 1523 { Disable heaptrc memory manager to avoid problems } 1524 SetMemoryManager(PrevMemoryManager); 1525 move_heap_info(@orphaned_info, @heap_info); 1526 dumpheap; 1527 if heap_info.error_in_heap and (exitcode=0) then 1528 exitcode:=203; 1529{$ifdef FPC_HAS_FEATURE_THREADING} 1530 if main_relo_todolist <> nil then 1531 donecriticalsection(todo_lock); 1532{$endif} 1533{$ifdef EXTRA} 1534 Close(error_file); 1535{$endif EXTRA} 1536 if useownfile then 1537 begin 1538 useownfile:=false; 1539 close(ownfile); 1540 end; 1541 if useowntextoutput then 1542 begin 1543 useowntextoutput := false; 1544 close(textoutput^); 1545 end; 1546end; 1547 1548{$if defined(win32) or defined(win64)} 1549 function GetEnvironmentStrings : pchar; stdcall; 1550 external 'kernel32' name 'GetEnvironmentStringsA'; 1551 function FreeEnvironmentStrings(p : pchar) : longbool; stdcall; 1552 external 'kernel32' name 'FreeEnvironmentStringsA'; 1553Function GetEnv(envvar: string): string; 1554var 1555 s : string; 1556 i : ptruint; 1557 hp,p : pchar; 1558begin 1559 getenv:=''; 1560 p:=GetEnvironmentStrings; 1561 hp:=p; 1562 while hp^<>#0 do 1563 begin 1564 s:=strpas(hp); 1565 i:=pos('=',s); 1566 if upcase(copy(s,1,i-1))=upcase(envvar) then 1567 begin 1568 getenv:=copy(s,i+1,length(s)-i); 1569 break; 1570 end; 1571 { next string entry} 1572 hp:=hp+strlen(hp)+1; 1573 end; 1574 FreeEnvironmentStrings(p); 1575end; 1576{$elseif defined(wince)} 1577Function GetEnv(P:string):Pchar; 1578begin 1579 { WinCE does not have environment strings. 1580 Add some way to specify heaptrc options? } 1581 GetEnv:=nil; 1582end; 1583{$elseif defined(msdos)} 1584 type 1585 PFarChar=^Char;far; 1586 PPFarChar=^PFarChar; 1587 var 1588 envp: PPFarChar;external name '__fpc_envp'; 1589Function GetEnv(P:string):string; 1590var 1591 ep : ppfarchar; 1592 pc : pfarchar; 1593 i : smallint; 1594 found : boolean; 1595Begin 1596 getenv:=''; 1597 p:=p+'='; {Else HOST will also find HOSTNAME, etc} 1598 ep:=envp; 1599 found:=false; 1600 if ep<>nil then 1601 begin 1602 while (not found) and (ep^<>nil) do 1603 begin 1604 found:=true; 1605 for i:=1 to length(p) do 1606 if p[i]<>ep^[i-1] then 1607 begin 1608 found:=false; 1609 break; 1610 end; 1611 if not found then 1612 inc(ep); 1613 end; 1614 end; 1615 if found then 1616 begin 1617 pc:=ep^+length(p); 1618 while pc^<>#0 do 1619 begin 1620 getenv:=getenv+pc^; 1621 Inc(pc); 1622 end; 1623 end; 1624end; 1625{$else} 1626Function GetEnv(P:string):Pchar; 1627{ 1628 Searches the environment for a string with name p and 1629 returns a pchar to it's value. 1630 A pchar is used to accomodate for strings of length > 255 1631} 1632var 1633 ep : ppchar; 1634 i : ptruint; 1635 found : boolean; 1636Begin 1637 p:=p+'='; {Else HOST will also find HOSTNAME, etc} 1638 ep:=envp; 1639 found:=false; 1640 if ep<>nil then 1641 begin 1642 while (not found) and (ep^<>nil) do 1643 begin 1644 found:=true; 1645 for i:=1 to length(p) do 1646 if p[i]<>ep^[i-1] then 1647 begin 1648 found:=false; 1649 break; 1650 end; 1651 if not found then 1652 inc(ep); 1653 end; 1654 end; 1655 if found then 1656 getenv:=ep^+length(p) 1657 else 1658 getenv:=nil; 1659end; 1660{$endif} 1661 1662procedure LoadEnvironment; 1663var 1664 i,j : ptruint; 1665 s,s2 : string; 1666 err : word; 1667begin 1668 s:=Getenv('HEAPTRC'); 1669 if pos('keepreleased',s)>0 then 1670 keepreleased:=true; 1671 if pos('disabled',s)>0 then 1672 useheaptrace:=false; 1673 if pos('nohalt',s)>0 then 1674 haltonerror:=false; 1675 if pos('haltonnotreleased',s)>0 then 1676 HaltOnNotReleased :=true; 1677 if pos('skipifnoleaks',s)>0 then 1678 GlobalSkipIfNoLeaks :=true; 1679 if pos('tail_size=',s)>0 then 1680 begin 1681 i:=pos('tail_size=',s)+length('tail_size='); 1682 s2:=''; 1683 while (i<=length(s)) and (s[i] in ['0'..'9']) do 1684 begin 1685 s2:=s2+s[i]; 1686 inc(i); 1687 end; 1688 val(s2,tail_size,err); 1689 if err=0 then 1690 tail_size:=((tail_size + sizeof(ptruint)-1) div sizeof(ptruint)) * sizeof(ptruint) 1691 else 1692 tail_size:=sizeof(ptruint); 1693 add_tail:=(tail_size > 0); 1694 end; 1695 i:=pos('log=',s); 1696 if i>0 then 1697 begin 1698 outputstr:=copy(s,i+4,255); 1699 j:=pos(' ',outputstr); 1700 if j=0 then 1701 j:=length(outputstr)+1; 1702 delete(outputstr,j,255); 1703 end; 1704end; 1705 1706 1707Initialization 1708 LoadEnvironment; 1709 { heaptrc can be disabled from the environment } 1710 if useheaptrace then 1711 TraceInit; 1712finalization 1713 if useheaptrace then 1714 TraceExit; 1715end. 1716