development/compilers/freepascal/rtl/inc/heaptrc.pp

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by the Free Pascal development team.
   5
   6     Heap tracer
   7
   8     See the file COPYING.FPC, included in this distribution,
   9     for details about the copyright.
  10
  11     This program is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15  **********************************************************************}
  16 unit heaptrc;
  17
  18 { 0.99.12 had a bug that initialization/finalization only worked for
  19   objfpc,delphi mode }
  20 {$ifdef VER0_99_12}
  21   {$mode objfpc}
  22 {$endif}
  23
  24 interface
  25
  26 Procedure DumpHeap;
  27 Procedure MarkHeap;
  28
  29 { define EXTRA to add more
  30   tests :
  31    - keep all memory after release and
  32    check by CRC value if not changed after release
  33    WARNING this needs extremely much memory (PM) }
  34
  35 type
  36     FillExtraInfoType = procedure(p : pointer);
  37
  38     { allows to add several longint value that can help
  39       to debug :
  40       see for instance ppheap.pas unit of the compiler source PM }
  41
  42 Procedure SetExtraInfo( size : longint;func : FillExtraInfoType);
  43 Procedure SetHeapTraceOutput(const name : string);
  44
  45 const
  46   { tracing level
  47     splitted in two if memory is released !! }
  48 {$ifdef EXTRA}
  49   tracesize = 16;
  50 {$else EXTRA}
  51   tracesize = 8;
  52 {$endif EXTRA}
  53   quicktrace : boolean=true;
  54   { calls halt() on error by default !! }
  55   HaltOnError : boolean = true;
  56   { set this to true if you suspect that memory
  57     is freed several times }
  58 {$ifdef EXTRA}
  59   keepreleased : boolean=true;
  60   add_tail : boolean = true;
  61 {$else EXTRA}
  62   keepreleased : boolean=false;
  63   add_tail : boolean = false;
  64 {$endif EXTRA}
  65   { put crc in sig
  66     this allows to test for writing into that part }
  67   usecrc : boolean = true;
  68
  69
  70 implementation
  71
  72 type
  73    plongint = ^longint;
  74
  75 const
  76   { allows to add custom info in heap_mem_info }
  77   extra_info_size : longint = 0;
  78   exact_info_size : longint = 0;
  79   EntryMemUsed    : longint = 0;
  80   { function to fill this info up }
  81   fill_extra_info : FillExtraInfoType = nil;
  82   error_in_heap : boolean = false;
  83   inside_trace_getmem : boolean = false;
  84
  85 type
  86   pheap_mem_info = ^theap_mem_info;
  87   { warning the size of theap_mem_info
  88     must be a multiple of 8
  89     because otherwise you will get
  90     problems when releasing the usual memory part !!
  91     sizeof(theap_mem_info = 16+tracesize*4 so
  92     tracesize must be even !! PM }
  93   theap_mem_info = record
  94     previous,
  95     next     : pheap_mem_info;
  96     size     : longint;
  97     sig      : longint;
  98 {$ifdef EXTRA}
  99     release_sig : longint;
 100     prev_valid  : pheap_mem_info;
 101 {$endif EXTRA}
 102     calls    : array [1..tracesize] of longint;
 103     extra_info : record
 104                  end;
 105   end;
 106
 107 var
 108   ptext : ^text;
 109   ownfile : text;
 110 {$ifdef EXTRA}
 111   error_file : text;
 112   heap_valid_first,
 113   heap_valid_last : pheap_mem_info;
 114 {$endif EXTRA}
 115   heap_mem_root : pheap_mem_info;
 116   getmem_cnt,
 117   freemem_cnt   : longint;
 118   getmem_size,
 119   freemem_size   : longint;
 120   getmem8_size,
 121   freemem8_size   : longint;
 122
 123
 124 {*****************************************************************************
 125                                    Crc 32
 126 *****************************************************************************}
 127
 128 var
 129 {$ifdef Delphi}
 130   Crc32Tbl : array[0..255] of longword;
 131 {$else Delphi}
 132   Crc32Tbl : array[0..255] of longint;
 133 {$endif Delphi}
 134
 135 procedure MakeCRC32Tbl;
 136 var
 137 {$ifdef Delphi}
 138   crc : longword;
 139 {$else Delphi}
 140   crc : longint;
 141 {$endif Delphi}
 142   i,n : byte;
 143 begin
 144   for i:=0 to 255 do
 145    begin
 146      crc:=i;
 147      for n:=1 to 8 do
 148       if odd(crc) then
 149        crc:=(crc shr 1) xor $edb88320
 150       else
 151        crc:=crc shr 1;
 152      Crc32Tbl[i]:=crc;
 153    end;
 154 end;
 155
 156
 157 {$ifopt R+}
 158 {$define Range_check_on}
 159 {$endif opt R+}
 160
 161 {$R- needed here }
 162
 163 Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
 164 var
 165   i : longint;
 166   p : pchar;
 167 begin
 168   p:=@InBuf;
 169   for i:=1 to InLen do
 170    begin
 171      InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
 172      inc(longint(p));
 173    end;
 174   UpdateCrc32:=InitCrc;
 175 end;
 176
 177 Function calculate_sig(p : pheap_mem_info) : longint;
 178 var
 179    crc : longint;
 180    pl : plongint;
 181 begin
 182    crc:=$ffffffff;
 183    crc:=UpdateCrc32(crc,p^.size,sizeof(longint));
 184    crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint));
 185    if extra_info_size>0 then
 186      crc:=UpdateCrc32(crc,p^.extra_info,exact_info_size);
 187    if add_tail then
 188      begin
 189         { Check also 4 bytes just after allocation !! }
 190         pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info)+p^.size;
 191         crc:=UpdateCrc32(crc,pl^,sizeof(longint));
 192      end;
 193    calculate_sig:=crc;
 194 end;
 195
 196 {$ifdef EXTRA}
 197 Function calculate_release_sig(p : pheap_mem_info) : longint;
 198 var
 199    crc : longint;
 200    pl : plongint;
 201 begin
 202    crc:=$ffffffff;
 203    crc:=UpdateCrc32(crc,p^.size,sizeof(longint));
 204    crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint));
 205    if extra_info_size>0 then
 206      crc:=UpdateCrc32(crc,p^.extra_info,exact_info_size);
 207    { Check the whole of the whole allocation }
 208    pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info);
 209    crc:=UpdateCrc32(crc,pl^,p^.size);
 210    { Check also 4 bytes just after allocation !! }
 211    if add_tail then
 212      begin
 213         { Check also 4 bytes just after allocation !! }
 214         pl:=pointer(p)+extra_info_size+sizeof(theap_mem_info)+p^.size;
 215         crc:=UpdateCrc32(crc,pl^,sizeof(longint));
 216      end;
 217    calculate_release_sig:=crc;
 218 end;
 219 {$endif EXTRA}
 220
 221 {$ifdef Range_check_on}
 222 {$R+}
 223 {$undef Range_check_on}
 224 {$endif Range_check_on}
 225
 226 {*****************************************************************************
 227                                 Helpers
 228 *****************************************************************************}
 229
 230 procedure call_stack(pp : pheap_mem_info;var ptext : text);
 231 var
 232   i  : longint;
 233 begin
 234   writeln(ptext,'Call trace for block 0x',hexstr(longint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size);
 235   for i:=1 to tracesize do
 236    if pp^.calls[i]<>0 then
 237      writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
 238   for i:=0 to (exact_info_size div 4)-1 do
 239     writeln(ptext,'info ',i,'=',plongint(pointer(@pp^.extra_info)+4*i)^);
 240 end;
 241
 242 procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
 243 var
 244   i  : longint;
 245
 246 begin
 247   writeln(ptext,'Call trace for block at 0x',hexstr(longint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size);
 248   for i:=1 to tracesize div 2 do
 249    if pp^.calls[i]<>0 then
 250      writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
 251   writeln(ptext,' was released at ');
 252   for i:=(tracesize div 2)+1 to tracesize do
 253    if pp^.calls[i]<>0 then
 254      writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
 255   for i:=0 to (exact_info_size div 4)-1 do
 256     writeln(ptext,'info ',i,'=',plongint(pointer(@pp^.extra_info)+4*i)^);
 257 end;
 258
 259
 260 procedure dump_already_free(p : pheap_mem_info;var ptext : text);
 261 begin
 262   Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' released');
 263   call_free_stack(p,ptext);
 264   Writeln(ptext,'freed again at');
 265   dump_stack(ptext,get_caller_frame(get_frame));
 266 end;
 267
 268 procedure dump_error(p : pheap_mem_info;var ptext : text);
 269 begin
 270   Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
 271   Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8)
 272     ,' instead of ',hexstr(calculate_sig(p),8));
 273   dump_stack(ptext,get_caller_frame(get_frame));
 274 end;
 275
 276 {$ifdef EXTRA}
 277 procedure dump_change_after(p : pheap_mem_info;var ptext : text);
 278  var pp : pchar;
 279      i : longint;
 280 begin
 281   Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
 282   Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8)
 283     ,' instead of ',hexstr(calculate_release_sig(p),8));
 284   Writeln(ptext,'This memory was changed after call to freemem !');
 285   call_free_stack(p,ptext);
 286   pp:=pointer(p)+sizeof(theap_mem_info)+extra_info_size;
 287   for i:=0 to p^.size-1 do
 288     if byte(pp[i])<>$F0 then
 289       Writeln(ptext,'offset',i,':$',hexstr(i,8),'"',pp[i],'"');
 290 end;
 291 {$endif EXTRA}
 292
 293 procedure dump_wrong_size(p : pheap_mem_info;size : longint;var ptext : text);
 294 var
 295   i : longint;
 296 begin
 297   Writeln(ptext,'Marked memory at 0x',HexStr(longint(pointer(p)+sizeof(theap_mem_info)),8),' invalid');
 298   Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
 299   dump_stack(ptext,get_caller_frame(get_frame));
 300   for i:=0 to (exact_info_size div 4)-1 do
 301     writeln(ptext,'info ',i,'=',plongint(@p^.extra_info+4*i)^);
 302   call_stack(p,ptext);
 303 end;
 304
 305
 306 function is_in_getmem_list (p : pheap_mem_info) : boolean;
 307 var
 308   i  : longint;
 309   pp : pheap_mem_info;
 310 begin
 311   is_in_getmem_list:=false;
 312   pp:=heap_mem_root;
 313   i:=0;
 314   while pp<>nil do
 315    begin
 316      if ((pp^.sig<>$DEADBEEF) or usecrc) and
 317         ((pp^.sig<>calculate_sig(pp)) or not usecrc) and
 318         (pp^.sig <> $AAAAAAAA) then
 319       begin
 320         writeln(ptext^,'error in linked list of heap_mem_info');
 321         RunError(204);
 322       end;
 323      if pp=p then
 324       is_in_getmem_list:=true;
 325      pp:=pp^.previous;
 326      inc(i);
 327      if i>getmem_cnt-freemem_cnt then
 328       writeln(ptext^,'error in linked list of heap_mem_info');
 329    end;
 330 end;
 331
 332
 333 {*****************************************************************************
 334                                TraceGetMem
 335 *****************************************************************************}
 336
 337 Function TraceGetMem(size:longint):pointer;
 338 var
 339   i,bp : longint;
 340   pl : plongint;
 341   p : pointer;
 342 begin
 343   inc(getmem_size,size);
 344   inc(getmem8_size,((size+7) div 8)*8);
 345 { Do the real GetMem, but alloc also for the info block }
 346   bp:=size+sizeof(theap_mem_info)+extra_info_size;
 347   if add_tail then
 348     inc(bp,sizeof(longint));
 349   p:=SysGetMem(bp);
 350 { Create the info block }
 351   pheap_mem_info(p)^.sig:=$DEADBEEF;
 352   pheap_mem_info(p)^.size:=size;
 353   if add_tail then
 354     begin
 355       pl:=pointer(p)+bp-sizeof(longint);
 356       pl^:=$DEADBEEF;
 357     end;
 358   bp:=get_caller_frame(get_frame);
 359   for i:=1 to tracesize do
 360    begin
 361      pheap_mem_info(p)^.calls[i]:=get_caller_addr(bp);
 362      bp:=get_caller_frame(bp);
 363    end;
 364   { insert in the linked list }
 365   if heap_mem_root<>nil then
 366    heap_mem_root^.next:=pheap_mem_info(p);
 367   pheap_mem_info(p)^.previous:=heap_mem_root;
 368   pheap_mem_info(p)^.next:=nil;
 369 {$ifdef EXTRA}
 370   pheap_mem_info(p)^.prev_valid:=heap_valid_last;
 371   heap_valid_last:=pheap_mem_info(p);
 372   if not assigned(heap_valid_first) then
 373     heap_valid_first:=pheap_mem_info(p);
 374 {$endif EXTRA}
 375   heap_mem_root:=p;
 376   { must be changed before fill_extra_info is called
 377     because checkpointer can be called from within
 378     fill_extra_info PM }
 379   inc(getmem_cnt);
 380   if assigned(fill_extra_info) then
 381     begin
 382       inside_trace_getmem:=true;
 383       fill_extra_info(@pheap_mem_info(p)^.extra_info);
 384       inside_trace_getmem:=false;
 385     end;
 386 { update the pointer }
 387   if usecrc then
 388     pheap_mem_info(p)^.sig:=calculate_sig(pheap_mem_info(p));
 389   inc(p,sizeof(theap_mem_info)+extra_info_size);
 390   TraceGetmem:=p;
 391 end;
 392
 393
 394 {*****************************************************************************
 395                                 TraceFreeMem
 396 *****************************************************************************}
 397
 398 function TraceFreeMemSize(var p:pointer;size:longint):longint;
 399 var
 400   i,bp, ppsize : longint;
 401   pp : pheap_mem_info;
 402 {$ifdef EXTRA}
 403   pp2 : pheap_mem_info;
 404 {$endif}
 405 begin
 406   inc(freemem_size,size);
 407   inc(freemem8_size,((size+7) div 8)*8);
 408   ppsize:= size + sizeof(theap_mem_info)+extra_info_size;
 409   if add_tail then
 410     ppsize:=ppsize+sizeof(longint);
 411   dec(p,sizeof(theap_mem_info)+extra_info_size);
 412   pp:=pheap_mem_info(p);
 413   if not quicktrace and not(is_in_getmem_list(pp)) then
 414     RunError(204);
 415   if (pp^.sig=$AAAAAAAA) and not usecrc then
 416     begin
 417        error_in_heap:=true;
 418        dump_already_free(pp,ptext^);
 419        if haltonerror then halt(1);
 420     end
 421   else if ((pp^.sig<>$DEADBEEF) or usecrc) and
 422         ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
 423     begin
 424        error_in_heap:=true;
 425        dump_error(pp,ptext^);
 426 {$ifdef EXTRA}
 427        dump_error(pp,error_file);
 428 {$endif EXTRA}
 429        { don't release anything in this case !! }
 430        if haltonerror then halt(1);
 431        exit;
 432     end
 433   else if pp^.size<>size then
 434     begin
 435        error_in_heap:=true;
 436        dump_wrong_size(pp,size,ptext^);
 437 {$ifdef EXTRA}
 438        dump_wrong_size(pp,size,error_file);
 439 {$endif EXTRA}
 440        if haltonerror then halt(1);
 441        { don't release anything in this case !! }
 442        exit;
 443     end;
 444   { now it is released !! }
 445   pp^.sig:=$AAAAAAAA;
 446   if not keepreleased then
 447     begin
 448        if pp^.next<>nil then
 449          pp^.next^.previous:=pp^.previous;
 450        if pp^.previous<>nil then
 451          pp^.previous^.next:=pp^.next;
 452        if pp=heap_mem_root then
 453          heap_mem_root:=heap_mem_root^.previous;
 454     end
 455   else
 456     begin
 457        bp:=get_caller_frame(get_frame);
 458        for i:=(tracesize div 2)+1 to tracesize do
 459         begin
 460           pp^.calls[i]:=get_caller_addr(bp);
 461           bp:=get_caller_frame(bp);
 462         end;
 463     end;
 464   inc(freemem_cnt);
 465   { release the normal memory at least !! }
 466   { this way we keep all info about all released memory !! }
 467   if keepreleased then
 468     begin
 469 {$ifndef EXTRA}
 470        dec(ppsize,sizeof(theap_mem_info)+extra_info_size);
 471        inc(p,sizeof(theap_mem_info)+extra_info_size);
 472 {$else EXTRA}
 473       inc(p,sizeof(theap_mem_info)+extra_info_size);
 474       fillchar(p^,size,#240); { $F0 will lead to GFP if used as pointer ! }
 475       { We want to check if the memory was changed after release !! }
 476        pp^.release_sig:=calculate_release_sig(pp);
 477        if pp=heap_valid_last then
 478          begin
 479             heap_valid_last:=pp^.prev_valid;
 480             if pp=heap_valid_first then
 481               heap_valid_first:=nil;
 482             exit;
 483          end;
 484        pp2:=heap_valid_last;
 485        while assigned(pp2) do
 486          begin
 487             if pp2^.prev_valid=pp then
 488               begin
 489                  pp2^.prev_valid:=pp^.prev_valid;
 490                  if pp=heap_valid_first then
 491                    heap_valid_first:=pp2;
 492                  exit;
 493               end
 494             else
 495               pp2:=pp2^.prev_valid;
 496          end;
 497        exit;
 498 {$endif EXTRA}
 499     end;
 500   i:=SysFreeMemSize(p,ppsize);
 501   dec(i,sizeof(theap_mem_info)+extra_info_size);
 502   if add_tail then
 503    dec(i,sizeof(longint));
 504   TraceFreeMemSize:=i;
 505 end;
 506
 507
 508 function TraceMemSize(p:pointer):Longint;
 509 var
 510   l : longint;
 511 begin
 512   l:=SysMemSize(p-(sizeof(theap_mem_info)+extra_info_size));
 513   dec(l,sizeof(theap_mem_info)+extra_info_size);
 514   if add_tail then
 515    dec(l,sizeof(longint));
 516   TraceMemSize:=l;
 517 end;
 518
 519
 520 function TraceFreeMem(var p:pointer):longint;
 521 var
 522   size : longint;
 523   pp : pheap_mem_info;
 524 begin
 525   pp:=pheap_mem_info(pointer(p)-(sizeof(theap_mem_info)+extra_info_size));
 526   size:=TraceMemSize(p);
 527   { this can never happend normaly }
 528   if pp^.size>size then
 529    begin
 530      dump_wrong_size(pp,size,ptext^);
 531 {$ifdef EXTRA}
 532      dump_wrong_size(pp,size,error_file);
 533 {$endif EXTRA}
 534    end;
 535   TraceFreeMem:=TraceFreeMemSize(p,pp^.size);
 536 end;
 537
 538
 539 {*****************************************************************************
 540                                 ReAllocMem
 541 *****************************************************************************}
 542
 543 function TraceReAllocMem(var p:pointer;size:longint):Pointer;
 544 var
 545   newP: pointer;
 546   oldsize,
 547   i,bp : longint;
 548   pl : plongint;
 549   pp : pheap_mem_info;
 550 begin
 551 { Free block? }
 552   if size=0 then
 553    begin
 554      if p<>nil then
 555       TraceFreeMem(p);
 556      TraceReallocMem:=P;
 557      exit;
 558    end;
 559 { Allocate a new block? }
 560   if p=nil then
 561    begin
 562      p:=TraceGetMem(size);
 563      TraceReallocMem:=P;
 564      exit;
 565    end;
 566 { Resize block }
 567   dec(p,sizeof(theap_mem_info)+extra_info_size);
 568   pp:=pheap_mem_info(p);
 569   { test block }
 570   if ((pp^.sig<>$DEADBEEF) or usecrc) and
 571      ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
 572    begin
 573      error_in_heap:=true;
 574      dump_error(pp,ptext^);
 575 {$ifdef EXTRA}
 576      dump_error(pp,error_file);
 577 {$endif EXTRA}
 578      { don't release anything in this case !! }
 579      if haltonerror then halt(1);
 580      exit;
 581    end;
 582   { Do the real ReAllocMem, but alloc also for the info block }
 583   bp:=size+sizeof(theap_mem_info)+extra_info_size;
 584   if add_tail then
 585    inc(bp,sizeof(longint));
 586   { the internal ReAllocMem is not allowed to move any data }
 587   if not SysTryResizeMem(p,bp) then
 588    begin
 589      { restore p }
 590      inc(p,sizeof(theap_mem_info)+extra_info_size);
 591      { get a new block }
 592      oldsize:=TraceMemSize(p);
 593      newP := TraceGetMem(size);
 594      { move the data }
 595      if newP <> nil then
 596        move(p^,newP^,oldsize);
 597      { release p }
 598      traceFreeMem(p);
 599      p := newP;
 600      traceReAllocMem := p;
 601      exit;
 602    end;
 603   pp:=pheap_mem_info(p);
 604 { adjust like a freemem and then a getmem, so you get correct
 605   results in the summary display }
 606   inc(freemem_size,pp^.size);
 607   inc(freemem8_size,((pp^.size+7) div 8)*8);
 608   inc(getmem_size,size);
 609   inc(getmem8_size,((size+7) div 8)*8);
 610 { Create the info block }
 611   pp^.sig:=$DEADBEEF;
 612   pp^.size:=size;
 613   if add_tail then
 614     begin
 615       pl:=pointer(p)+bp-sizeof(longint);
 616       pl^:=$DEADBEEF;
 617     end;
 618   bp:=get_caller_frame(get_frame);
 619   for i:=1 to tracesize do
 620    begin
 621      pp^.calls[i]:=get_caller_addr(bp);
 622      bp:=get_caller_frame(bp);
 623    end;
 624   if assigned(fill_extra_info) then
 625     fill_extra_info(@pp^.extra_info);
 626 { update the pointer }
 627   if usecrc then
 628     pp^.sig:=calculate_sig(pp);
 629   inc(p,sizeof(theap_mem_info)+extra_info_size);
 630   TraceReAllocmem:=p;
 631 end;
 632
 633
 634
 635 {*****************************************************************************
 636                               Check pointer
 637 *****************************************************************************}
 638
 639 {$ifndef linux}
 640   {$S-}
 641 {$endif}
 642
 643 {$ifdef go32v2}
 644 var
 645    __stklen : cardinal;external name '__stklen';
 646    __stkbottom : cardinal;external name '__stkbottom';
 647    edata : cardinal; external name 'edata';
 648    heap_at_init : pointer;
 649 {$endif go32v2}
 650
 651 {$ifdef win32}
 652 var
 653    StartUpHeapEnd : pointer;
 654    { I found no symbol for start of text section :(
 655      so we usee the _mainCRTStartup which should be
 656      in wprt0.ow or wdllprt0.ow PM }
 657    text_begin : cardinal;external name '_mainCRTStartup';
 658    data_end : cardinal;external name '__data_end__';
 659 {$endif}
 660
 661 procedure CheckPointer(p : pointer);[public, alias : 'FPC_CHECKPOINTER'];
 662 var
 663   i  : longint;
 664   pp : pheap_mem_info;
 665   get_ebp,stack_top : cardinal;
 666   data_end : cardinal;
 667 label
 668   _exit;
 669 begin
 670   asm
 671      pushal
 672   end;
 673   if p=nil then
 674     goto _exit;
 675
 676   i:=0;
 677
 678 {$ifdef go32v2}
 679   if cardinal(p)<$1000 then
 680     runerror(216);
 681   asm
 682      movl %ebp,get_ebp
 683      leal edata,%eax
 684      movl %eax,data_end
 685   end;
 686   stack_top:=__stkbottom+__stklen;
 687   { allow all between start of code and end of data }
 688   if cardinal(p)<=data_end then
 689     goto _exit;
 690   { .bss section }
 691   if cardinal(p)<=cardinal(heap_at_init) then
 692     goto _exit;
 693   { stack can be above heap !! }
 694
 695   if (cardinal(p)>=get_ebp) and (cardinal(p)<=stack_top) then
 696     goto _exit;
 697 {$endif go32v2}
 698
 699   { I don't know where the stack is in other OS !! }
 700 {$ifdef win32}
 701   if (cardinal(p)>=$40000) and (p<=HeapOrg) then
 702     goto _exit;
 703   { inside stack ? }
 704   asm
 705      movl %ebp,get_ebp
 706   end;
 707   if (cardinal(p)>get_ebp) and
 708      (cardinal(p)<Win32StackTop) then
 709     goto _exit;
 710 {$endif win32}
 711
 712   if p>=heapptr then
 713     runerror(216);
 714   { first try valid list faster }
 715
 716 {$ifdef EXTRA}
 717   pp:=heap_valid_last;
 718   while pp<>nil do
 719    begin
 720      { inside this valid block ! }
 721      { we can be changing the extrainfo !! }
 722      if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info){+extra_info_size}) and
 723         (cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then
 724        begin
 725           { check allocated block }
 726           if ((pp^.sig=$DEADBEEF) and not usecrc) or
 727              ((pp^.sig=calculate_sig(pp)) and usecrc) or
 728           { special case of the fill_extra_info call }
 729              ((pp=heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
 730               and inside_trace_getmem) then
 731             goto _exit
 732           else
 733             begin
 734               writeln(ptext^,'corrupted heap_mem_info');
 735               dump_error(pp,ptext^);
 736               halt(1);
 737             end;
 738        end
 739      else
 740        pp:=pp^.prev_valid;
 741      inc(i);
 742      if i>getmem_cnt-freemem_cnt then
 743       begin
 744          writeln(ptext^,'error in linked list of heap_mem_info');
 745          halt(1);
 746       end;
 747    end;
 748   i:=0;
 749 {$endif EXTRA}
 750   pp:=heap_mem_root;
 751   while pp<>nil do
 752    begin
 753      { inside this block ! }
 754      if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)) and
 755         (cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)+cardinal(pp^.size)) then
 756         { allocated block }
 757        if ((pp^.sig=$DEADBEEF) and not usecrc) or
 758           ((pp^.sig=calculate_sig(pp)) and usecrc) then
 759           goto _exit
 760        else
 761          begin
 762             writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block');
 763             dump_error(pp,ptext^);
 764             runerror(204);
 765          end;
 766      pp:=pp^.previous;
 767      inc(i);
 768      if i>getmem_cnt then
 769       begin
 770          writeln(ptext^,'error in linked list of heap_mem_info');
 771          halt(1);
 772       end;
 773    end;
 774   writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block');
 775   runerror(204);
 776 _exit:
 777   asm
 778      popal
 779   end;
 780 end;
 781
 782 {*****************************************************************************
 783                               Dump Heap
 784 *****************************************************************************}
 785
 786 procedure dumpheap;
 787 var
 788   pp : pheap_mem_info;
 789   i : longint;
 790   ExpectedMemAvail : longint;
 791 begin
 792   pp:=heap_mem_root;
 793   Writeln(ptext^,'Heap dump by heaptrc unit');
 794   Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size);
 795   Writeln(ptext^,freemem_cnt,' memory blocks freed     : ',freemem_size,'/',freemem8_size);
 796   Writeln(ptext^,getmem_cnt-freemem_cnt,' unfreed memory blocks : ',getmem_size-freemem_size);
 797   Write(ptext^,'True heap size : ',system.HeapSize);
 798   if EntryMemUsed > 0 then
 799     Writeln(ptext^,' (',EntryMemUsed,' used in System startup)')
 800   else
 801     Writeln(ptext^);
 802   Writeln(ptext^,'True free heap : ',MemAvail);
 803   ExpectedMemAvail:=system.HeapSize-(getmem8_size-freemem8_size)-
 804     (getmem_cnt-freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)-EntryMemUsed;
 805   If ExpectedMemAvail<>MemAvail then
 806     Writeln(ptext^,'Should be : ',ExpectedMemAvail);
 807   i:=getmem_cnt-freemem_cnt;
 808   while pp<>nil do
 809    begin
 810      if i<0 then
 811        begin
 812           Writeln(ptext^,'Error in heap memory list');
 813           Writeln(ptext^,'More memory blocks than expected');
 814           exit;
 815        end;
 816      if ((pp^.sig=$DEADBEEF) and not usecrc) or
 817         ((pp^.sig=calculate_sig(pp)) and usecrc) then
 818        begin
 819           { this one was not released !! }
 820           if exitcode<>203 then
 821             call_stack(pp,ptext^);
 822           dec(i);
 823        end
 824      else if pp^.sig<>$AAAAAAAA then
 825        begin
 826           dump_error(pp,ptext^);
 827 {$ifdef EXTRA}
 828           dump_error(pp,error_file);
 829 {$endif EXTRA}
 830           error_in_heap:=true;
 831        end
 832 {$ifdef EXTRA}
 833      else if pp^.release_sig<>calculate_release_sig(pp) then
 834        begin
 835           dump_change_after(pp,ptext^);
 836           dump_change_after(pp,error_file);
 837           error_in_heap:=true;
 838        end
 839 {$endif EXTRA}
 840        ;
 841      pp:=pp^.previous;
 842    end;
 843 end;
 844
 845
 846 procedure markheap;
 847 var
 848   pp : pheap_mem_info;
 849 begin
 850   pp:=heap_mem_root;
 851   while pp<>nil do
 852    begin
 853      pp^.sig:=$AAAAAAAA;
 854      pp:=pp^.previous;
 855    end;
 856 end;
 857
 858
 859 {*****************************************************************************
 860                                 AllocMem
 861 *****************************************************************************}
 862
 863 function TraceAllocMem(size:longint):Pointer;
 864 begin
 865   TraceAllocMem:=SysAllocMem(size);
 866 end;
 867
 868
 869 {*****************************************************************************
 870                             No specific tracing calls
 871 *****************************************************************************}
 872
 873 function TraceMemAvail:longint;
 874 begin
 875   TraceMemAvail:=SysMemAvail;
 876 end;
 877
 878 function TraceMaxAvail:longint;
 879 begin
 880   TraceMaxAvail:=SysMaxAvail;
 881 end;
 882
 883 function TraceHeapSize:longint;
 884 begin
 885   TraceHeapSize:=SysHeapSize;
 886 end;
 887
 888
 889 {*****************************************************************************
 890                            Install MemoryManager
 891 *****************************************************************************}
 892
 893 const
 894   TraceManager:TMemoryManager=(
 895     Getmem  : TraceGetMem;
 896     Freemem : TraceFreeMem;
 897     FreememSize : TraceFreeMemSize;
 898     AllocMem : TraceAllocMem;
 899     ReAllocMem : TraceReAllocMem;
 900     MemSize : TraceMemSize;
 901     MemAvail : TraceMemAvail;
 902     MaxAvail : TraceMaxAvail;
 903     HeapSize : TraceHeapsize;
 904   );
 905
 906 procedure TraceExit;
 907 begin
 908   { no dump if error
 909     because this gives long long listings }
 910   { clear inoutres, in case the program that quit didn't }
 911   ioresult;
 912   if (exitcode<>0) and (erroraddr<>nil) then
 913     begin
 914        Writeln(ptext^,'No heap dump by heaptrc unit');
 915        Writeln(ptext^,'Exitcode = ',exitcode);
 916        if ptext<>@stderr then
 917          begin
 918             ptext:=@stderr;
 919             close(ownfile);
 920          end;
 921        exit;
 922     end;
 923   if not error_in_heap then
 924     Dumpheap;
 925   if error_in_heap and (exitcode=0) then
 926     exitcode:=203;
 927 {$ifdef EXTRA}
 928   Close(error_file);
 929 {$endif EXTRA}
 930    if ptext<>@stderr then
 931      begin
 932         ptext:=@stderr;
 933         close(ownfile);
 934      end;
 935 end;
 936
 937 Procedure SetHeapTraceOutput(const name : string);
 938 var i : longint;
 939 begin
 940    if ptext<>@stderr then
 941      begin
 942         ptext:=@stderr;
 943         close(ownfile);
 944      end;
 945    assign(ownfile,name);
 946 {$I-}
 947    append(ownfile);
 948    if IOResult<>0 then
 949      Rewrite(ownfile);
 950 {$I+}
 951    ptext:=@ownfile;
 952    for i:=0 to Paramcount do
 953      write(ptext^,paramstr(i),' ');
 954    writeln(ptext^);
 955 end;
 956
 957 procedure SetExtraInfo( size : longint;func : fillextrainfotype);
 958
 959   begin
 960      if getmem_cnt>0 then
 961        begin
 962          writeln(ptext^,'Setting extra info is only possible at start !! ');
 963          dumpheap;
 964        end
 965      else
 966        begin
 967           { the total size must stay multiple of 8 !! }
 968           exact_info_size:=size;
 969           extra_info_size:=((size+7) div 8)*8;
 970           fill_extra_info:=func;
 971        end;
 972   end;
 973
 974 Initialization
 975   EntryMemUsed:=System.HeapSize-MemAvail;
 976   MakeCRC32Tbl;
 977   SetMemoryManager(TraceManager);
 978   ptext:=@stderr;
 979 {$ifdef EXTRA}
 980   Assign(error_file,'heap.err');
 981   Rewrite(error_file);
 982 {$endif EXTRA}
 983   { checkpointer init }
 984 {$ifdef go32v2}
 985   Heap_at_init:=HeapPtr;
 986 {$endif}
 987 {$ifdef win32}
 988   StartupHeapEnd:=HeapEnd;
 989 {$endif}
 990 finalization
 991   TraceExit;
 992 end.
 993 {
 994   $Log$
 995   Revision 1.1  2002/02/19 08:25:23  sasu
 996   Initial revision
 997
 998   Revision 1.1.2.2  2000/12/15 13:02:30  jonas
 999     * added some typecasts so some expressiosn aren't evaluated anymore in
1000       64bit when rangechecking is on
1001
1002   Revision 1.1.2.1  2000/08/24 08:59:35  jonas
1003     * clear inoutres in traceexit before writing anything (to avoid an RTE
1004       when writing the heaptrc output when a program didn't handle ioresult)
1005
1006   Revision 1.1  2000/07/13 06:30:47  michael
1007   + Initial import
1008
1009   Revision 1.43  2000/05/18 17:03:27  peter
1010     * fixed reallocmem with double removing from heap_mem_root list
1011     * fixed reallocmem getmem/freemem count, now both are increased and
1012       the _size8 counts are also increased
1013
1014   Revision 1.42  2000/04/27 15:35:50  pierre
1015    * fix for bug report 929
1016
1017   Revision 1.41  2000/02/10 13:59:35  peter
1018     * fixed bug with reallocmem to use the wrong size when copying the
1019       data to the new allocated pointer
1020
1021   Revision 1.40  2000/02/09 16:59:30  peter
1022     * truncated log
1023
1024   Revision 1.39  2000/02/07 10:42:44  peter
1025     * use backtracestrfunc()
1026
1027   Revision 1.38  2000/02/02 11:13:15  peter
1028     * fixed tracereallocmem which supplied the wrong size for tryresize
1029
1030   Revision 1.37  2000/01/31 23:41:30  peter
1031     * reallocmem fixed for freemem() call when size=0
1032
1033   Revision 1.36  2000/01/20 14:25:51  jonas
1034     * finally fixed tracereallocmem completely
1035
1036   Revision 1.35  2000/01/20 13:17:11  jonas
1037     * another problme with realloc fixed (one left)
1038
1039   Revision 1.34  2000/01/20 12:35:35  jonas
1040     * fixed problem with reallocmem and heaptrc
1041
1042   Revision 1.33  2000/01/07 16:41:34  daniel
1043     * copyright 2000
1044
1045   Revision 1.32  2000/01/07 16:32:24  daniel
1046     * copyright 2000 added
1047
1048   Revision 1.31  2000/01/05 13:56:55  jonas
1049     * fixed traceReallocMem with nil pointer (simply calls traceGetMem now in
1050       such a case)
1051
1052   Revision 1.30  2000/01/03 19:37:52  peter
1053     * fixed reallocmem with p=nil
1054
1055   Revision 1.29  1999/11/14 21:35:04  peter
1056     * removed warnings
1057
1058   Revision 1.28  1999/11/09 22:32:23  pierre
1059    * several extra_size_info fixes
1060
1061   Revision 1.27  1999/11/06 14:35:38  peter
1062     * truncated log
1063
1064   Revision 1.26  1999/11/01 13:56:50  peter
1065     * freemem,reallocmem now get var argument
1066
1067   Revision 1.25  1999/10/30 17:39:05  peter
1068     * memorymanager expanded with allocmem/reallocmem
1069
1070   Revision 1.24  1999/09/17 17:14:12  peter
1071     + new heap manager supporting delphi freemem(pointer)
1072
1073   Revision 1.23  1999/09/10 17:13:41  peter
1074     * fixed missing var
1075
1076   Revision 1.22  1999/09/08 16:14:41  peter
1077     * pointer fixes
1078
1079   Revision 1.21  1999/08/18 12:03:16  peter
1080     * objfpc mode for 0.99.12
1081
1082   Revision 1.20  1999/08/17 14:56:03  michael
1083   Removed the mode for objpas
1084
1085 }