fpc/rtl/inc/heaptrc.pp

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by the Free Pascal development team.

    Heap tracer

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{$checkpointer off}
unit heaptrc;
interface

{$inline on}

{$ifdef FPC_HEAPTRC_EXTRA}
  {$define EXTRA}
  {$inline off}
{$endif FPC_HEAPTRC_EXTRA}
{$ifndef DISABLE_SYSTEMINLINE}
  {$define SYSTEMINLINE}
{$endif}


{$TYPEDADDRESS on}

{$if defined(win32) or defined(wince)}
  {$define windows}
{$endif}

{$Q-}
{$R-}

Procedure DumpHeap;
Procedure DumpHeap(SkipIfNoLeaks : Boolean);

{ define EXTRA to add more
  tests :
   - keep all memory after release and
   check by CRC value if not changed after release
   WARNING this needs extremely much memory (PM) }

type
   tFillExtraInfoProc = procedure(p : pointer);
   tdisplayextrainfoProc = procedure (var ptext : text;p : pointer);

{ Allows to add info pre memory block, see ppheap.pas of the compiler
  for example source }
procedure SetHeapExtraInfo(size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);

{ Redirection of the output to a file }
procedure SetHeapTraceOutput(const name : string);overload;
procedure SetHeapTraceOutput(var ATextOutput : Text);overload;

procedure CheckPointer(p : pointer);

const
  { tracing level
    splitted in two if memory is released !! }
{$ifdef EXTRA}
  tracesize = 32;
{$else EXTRA}
  tracesize = 16;
{$endif EXTRA}
  { install heaptrc memorymanager }
  useheaptrace : boolean=true;
  { less checking }
  quicktrace : boolean=true;
  { calls halt() on error by default !! }
  HaltOnError : boolean = true;
  { Halt on exit if any memory was not freed }
  HaltOnNotReleased : boolean = false;

  { set this to true if you suspect that memory
    is freed several times }
{$ifdef EXTRA}
  keepreleased : boolean=true;
{$else EXTRA}
  keepreleased : boolean=false;
{$endif EXTRA}
  { add a small footprint at the end of memory blocks, this
    can check for memory overwrites at the end of a block }
  add_tail : boolean = true;
  tail_size : longint = sizeof(ptruint);

  { put crc in sig
    this allows to test for writing into that part }
  usecrc : boolean = true;

  printleakedblock: boolean = false;
  printfaultyblock: boolean = false;
  maxprintedblocklength: integer = 128;

  GlobalSkipIfNoLeaks : Boolean = False;

implementation

const
  { allows to add custom info in heap_mem_info, this is the size that will
    be allocated for this information }
  extra_info_size : ptruint = 0;
  exact_info_size : ptruint = 0;
  { function to fill this info up }
  fill_extra_info_proc : TFillExtraInfoProc = nil;
  display_extra_info_proc : TDisplayExtraInfoProc = nil;
  { indicates where the output will be redirected }
  { only set using environment variables          }
  outputstr : shortstring = '';
  ReleaseSig = $AAAAAAAA;
  AllocateSig = $DEADBEEF;
  CheckSig = $12345678;

type
  pheap_extra_info = ^theap_extra_info;
  theap_extra_info = record
    check       : cardinal;  { used to check if the procvar is still valid }
    fillproc    : tfillextrainfoProc;
    displayproc : tdisplayextrainfoProc;
    data : record
           end;
  end;

  ppheap_mem_info = ^pheap_mem_info;
  pheap_mem_info = ^theap_mem_info;

  { warning the size of theap_mem_info
    must be a multiple of 8
    because otherwise you will get
    problems when releasing the usual memory part !!
    sizeof(theap_mem_info = 16+tracesize*4 so
    tracesize must be even !! PM }
  theap_mem_info = record
    previous,
    next     : pheap_mem_info;
    todolist : ppheap_mem_info;
    todonext : pheap_mem_info;
    size     : ptruint;
    sig      : longword;
{$ifdef EXTRA}
    release_sig : longword;
    prev_valid  : pheap_mem_info;
{$endif EXTRA}
    calls    : array [1..tracesize] of codepointer;
    exact_info_size : word;
    extra_info_size : word;
    extra_info      : pheap_extra_info;
  end;

  pheap_info = ^theap_info;
  theap_info = record
{$ifdef EXTRA}
    heap_valid_first,
    heap_valid_last : pheap_mem_info;
{$endif EXTRA}
    heap_mem_root : pheap_mem_info;
    heap_free_todo : pheap_mem_info;
    getmem_cnt,
    freemem_cnt   : ptruint;
    getmem_size,
    freemem_size,
    EntryMemUsed : ptruint;
    error_in_heap : boolean;
    inside_trace_getmem : boolean;
  end;

var
  useownfile, useowntextoutput : boolean;
  ownfile : text;
{$ifdef EXTRA}
  error_file : text;
{$endif EXTRA}
  main_orig_todolist: ppheap_mem_info;
  main_relo_todolist: ppheap_mem_info;
  orphaned_info: theap_info;
  todo_lock: trtlcriticalsection;
  textoutput : ^text;
{$ifdef FPC_HAS_FEATURE_THREADING}
threadvar
{$else}
var
{$endif}
  heap_info: theap_info;

function GetOutput : PText;
begin
  if useownfile then
    GetOutput:=@ownfile
  else
    GetOutput:=textoutput;
end;

procedure CloseOwnFile;
begin
  if not useownfile then
    exit;
  useownfile:=false;
  close(ownfile);
end;

{*****************************************************************************
                                   Crc 32
*****************************************************************************}

var
  Crc32Tbl : array[0..255] of longword;
const
  Crc32Seed = $ffffffff;
  Crc32Pattern = $edb88320;

procedure MakeCRC32Tbl;
var
  crc : longword;
  i,n : byte;
begin
  for i:=0 to 255 do
   begin
     crc:=i;
     for n:=1 to 8 do
      if odd(crc) then
       crc:=(crc shr 1) xor longword(CRC32Pattern)
      else
       crc:=crc shr 1;
     Crc32Tbl[i]:=crc;
   end;
end;


Function UpdateCrc32(InitCrc:longword;var InBuf;InLen:ptruint):longword;
var
  i : ptruint;
  p : pbyte;
begin
  p:=@InBuf;
  for i:=1 to InLen do
   begin
     InitCrc:=Crc32Tbl[byte(InitCrc) xor p^] xor (InitCrc shr 8);
     inc(p);
   end;
  UpdateCrc32:=InitCrc;
end;

Function calculate_sig(p : pheap_mem_info) : longword;
var
   crc : longword;
   pl : pptruint;
begin
   crc:=longword(CRC32Seed);
   crc:=UpdateCrc32(crc,p^.size,sizeof(ptruint));
   crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(codepointer));
   if p^.extra_info_size>0 then
     crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
   if add_tail then
     begin
        { Check also 4 bytes just after allocation !! }
        pl:=pointer(p)+sizeof(theap_mem_info)+p^.size;
        crc:=UpdateCrc32(crc,pl^,tail_size);
     end;
   calculate_sig:=crc;
end;

{$ifdef EXTRA}
Function calculate_release_sig(p : pheap_mem_info) : longword;
var
   crc : longword;
   pl : pptruint;
begin
   crc:=longword(CRC32Seed);
   crc:=UpdateCrc32(crc,p^.size,sizeof(ptruint));
   crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(codepointer));
   if p^.extra_info_size>0 then
     crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
   { Check the whole of the whole allocation }
   pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info);
   crc:=UpdateCrc32(crc,pl^,p^.size);
   { Check also 4 bytes just after allocation !! }
   if add_tail then
     begin
        { Check also 4 bytes just after allocation !! }
        pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
        crc:=UpdateCrc32(crc,pl^,tail_size);
     end;
   calculate_release_sig:=crc;
end;
{$endif EXTRA}


{*****************************************************************************
                                Helpers
*****************************************************************************}

function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
  size: ptruint; release_todo_lock: boolean): ptruint; forward;
function TraceFreeMem(p: pointer): ptruint; forward;

procedure printhex(p : pointer; const size : PtrUInt; var ptext : text);
var s: PtrUInt;
 i: Integer;
begin
  s := size;
  if s > maxprintedblocklength then
    s := maxprintedblocklength;

  for i:=0 to s-1 do
    write(ptext, hexstr(pbyte(p + i)^,2));

  if size > maxprintedblocklength then
    write(ptext,'..');
  writeln(ptext,' - ');

  for i:=0 to s-1 do
    if pansichar(p + sizeof(theap_mem_info) + i)^ < ' ' then
      write(ptext, ' ')
    else
      write(ptext, pansichar(p + i)^);

  if size > maxprintedblocklength then
    write(ptext,'..');
  writeln(ptext);
end;

procedure call_stack(pp : pheap_mem_info;var ptext : text);
var
  i  : ptruint;
begin
  writeln(ptext,'Call trace for block $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size);
  if printleakedblock then
    begin
      write(ptext, 'Block content: ');
      printhex(pointer(pp) + sizeof(theap_mem_info), pp^.size, ptext);
    end;

  for i:=1 to tracesize do
   if pp^.calls[i]<>nil then
     writeln(ptext,BackTraceStrFunc(pp^.calls[i]));

  { the check is done to be sure that the procvar is not overwritten }
  if assigned(pp^.extra_info) and
     (pp^.extra_info^.check=cardinal(CheckSig)) and
     assigned(pp^.extra_info^.displayproc) then
   pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
end;


procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
var
  i  : ptruint;
begin
  writeln(ptext,'Call trace for block at $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size);
  for i:=1 to tracesize div 2 do
   if pp^.calls[i]<>nil then
     writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
  writeln(ptext,' was released at ');
  for i:=(tracesize div 2)+1 to tracesize do
   if pp^.calls[i]<>nil then
     writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
  { the check is done to be sure that the procvar is not overwritten }
  if assigned(pp^.extra_info) and
     (pp^.extra_info^.check=cardinal(CheckSig)) and
     assigned(pp^.extra_info^.displayproc) then
   pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
end;


procedure dump_already_free(p : pheap_mem_info;var ptext : text);
begin
  Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
  call_free_stack(p,ptext);
  Writeln(ptext,'freed again at');
  dump_stack(ptext,1);
end;

procedure dump_error(p : pheap_mem_info;var ptext : text);
begin
  Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid',LineEnding,
                'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
  if printfaultyblock then
    begin
      write(ptext, 'Block content: ');
      printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext);
    end;
  dump_stack(ptext,1);
end;

function released_modified(p : pheap_mem_info;var ptext : text) : boolean;
 var pl : pdword;
     pb : pbyte;
     i : longint;
begin
  released_modified:=false;
  { Check tail_size bytes just after allocation !! }
  pl:=pointer(p)+sizeof(theap_mem_info)+p^.size;
  pb:=pointer(p)+sizeof(theap_mem_info);
  for i:=0 to p^.size-1 do
    if pb[i]<>$F0 then
      begin
        Writeln(ptext,'offset',i,':$',hexstr(i,2*sizeof(pointer)),'"',hexstr(pb[i],2),'"');
        released_modified:=true;
      end;
  for i:=1 to (tail_size div sizeof(dword)) do
    begin
      if unaligned(pl^) <> AllocateSig then
        begin
          released_modified:=true;
          writeln(ptext,'Tail modified after release at pos ',i*sizeof(ptruint));
          printhex(pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size,tail_size,ptext);
          break;
        end;
      inc(pointer(pl),sizeof(dword));
    end;
  if released_modified then
    begin
      dump_already_free(p,ptext);
      if @stderr<>@ptext then
        dump_already_free(p,stderr);
    end;
end;

{$ifdef EXTRA}
procedure dump_change_after(p : pheap_mem_info;var ptext : text);
 var pp : pansichar;
     i : ptruint;
begin
  Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid',LineEnding,
                'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8),LineEnding,
                'This memory was changed after call to freemem !');
  call_free_stack(p,ptext);
  pp:=pointer(p)+sizeof(theap_mem_info);
  for i:=0 to p^.size-1 do
    if byte(pp[i])<>$F0 then
      Writeln(ptext,'offset',i,':$',hexstr(i,2*sizeof(pointer)),'"',pp[i],'"');
end;
{$endif EXTRA}

procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
begin
  Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid',LineEnding,
                'Wrong size : ',p^.size,' allocated ',size,' freed');
  dump_stack(ptext,1);
  { the check is done to be sure that the procvar is not overwritten }
  if assigned(p^.extra_info) and
     (p^.extra_info^.check=cardinal(CheckSig)) and
     assigned(p^.extra_info^.displayproc) then
   p^.extra_info^.displayproc(ptext,@p^.extra_info^.data);
  call_stack(p,ptext);
end;

function is_in_getmem_list (loc_info: pheap_info; p : pheap_mem_info) : boolean;
var
  i  : ptruint;
  pp : pheap_mem_info;
begin
  is_in_getmem_list:=false;
  pp:=loc_info^.heap_mem_root;
  i:=0;
  while pp<>nil do
   begin
     if (i>=loc_info^.getmem_cnt-loc_info^.freemem_cnt) or
        (usecrc or (pp^.sig<>longword(AllocateSig))) and
        (not usecrc or (pp^.sig<>calculate_sig(pp))) and
        (pp^.sig <>longword(ReleaseSig)) then
      begin
        writeln(GetOutput^,'error in linked list of heap_mem_info');
        RunError(204);
      end;
     if pp=p then
      is_in_getmem_list:=true;
     pp:=pp^.previous;
     inc(i);
   end;
end;

procedure finish_heap_free_todo_list(loc_info: pheap_info);
var
  bp: pointer;
  pp: pheap_mem_info;
  list: ppheap_mem_info;
begin
  list := @loc_info^.heap_free_todo;
  repeat
    pp := list^;
    list^ := list^^.todonext;
    bp := pointer(pp)+sizeof(theap_mem_info);
    InternalFreeMemSize(loc_info,bp,pp,pp^.size,false);
  until list^ = nil;
end;

procedure try_finish_heap_free_todo_list(loc_info: pheap_info);
begin
  if loc_info^.heap_free_todo <> nil then
  begin
{$ifdef FPC_HAS_FEATURE_THREADING}
    entercriticalsection(todo_lock);
{$endif}
    finish_heap_free_todo_list(loc_info);
{$ifdef FPC_HAS_FEATURE_THREADING}
    leavecriticalsection(todo_lock);
{$endif}
  end;
end;


{*****************************************************************************
                               TraceGetMem
*****************************************************************************}

Function TraceGetMem(size:ptruint):pointer;
var
  i, allocsize : ptruint;
  pl : pdword;
  p  : pointer;
  pp : pheap_mem_info;
  loc_info: pheap_info;
begin
  loc_info := @heap_info;
  try_finish_heap_free_todo_list(loc_info);
{ Do the real GetMem, but alloc also for the info block }
{$ifdef cpuarm}
  allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+extra_info_size;
{$else cpuarm}
  allocsize:=size+sizeof(theap_mem_info)+extra_info_size;
{$endif cpuarm}
  if add_tail then
    inc(allocsize,tail_size);
  { if ReturnNilIfGrowHeapFails is true
    SysGetMem can return nil }
  p:=SysGetMem(allocsize);
  if (p=nil) then
    begin
      TraceGetMem:=nil;
      exit;
    end;
  pp:=pheap_mem_info(p);
  inc(p,sizeof(theap_mem_info));
  { Update getmem_size only after successful call to SysGetMem }
  inc(loc_info^.getmem_size,size);
{ Create the info block }
  pp^.sig:=longword(AllocateSig);
  pp^.todolist:=@loc_info^.heap_free_todo;
  pp^.todonext:=nil;
  pp^.size:=size;
  pp^.extra_info_size:=extra_info_size;
  pp^.exact_info_size:=exact_info_size;
  fillchar(pp^.calls[1],sizeof(pp^.calls),#0);
  {
    the end of the block contains:
    <tail>   4 bytes
    <extra_info>   X bytes
  }
  if extra_info_size>0 then
   begin
     pp^.extra_info:=pointer(pp)+allocsize-extra_info_size;
     fillchar(pp^.extra_info^,extra_info_size,0);
     pp^.extra_info^.check:=cardinal(CheckSig);
     pp^.extra_info^.fillproc:=fill_extra_info_proc;
     pp^.extra_info^.displayproc:=display_extra_info_proc;
     if assigned(fill_extra_info_proc) then
      begin
        loc_info^.inside_trace_getmem:=true;
        fill_extra_info_proc(@pp^.extra_info^.data);
        loc_info^.inside_trace_getmem:=false;
      end;
   end
  else
   pp^.extra_info:=nil;
  if add_tail then
    begin
      { Calculate position from start because of arm
        specific alignment }
      pl:=pointer(pp)+sizeof(theap_mem_info)+pp^.size;
      for i:=1 to tail_size div sizeof(dword) do
        begin
          unaligned(pl^):=dword(AllocateSig);
          inc(pointer(pl),sizeof(dword));
        end;
    end;
  { clear the memory }
  fillchar(p^,size,#255);
  { retrieve backtrace info }
  CaptureBacktrace(1,tracesize,@pp^.calls[1]);

  { insert in the linked list }
  if loc_info^.heap_mem_root<>nil then
   loc_info^.heap_mem_root^.next:=pp;
  pp^.previous:=loc_info^.heap_mem_root;
  pp^.next:=nil;
{$ifdef EXTRA}
  pp^.prev_valid:=loc_info^.heap_valid_last;
  loc_info^.heap_valid_last:=pp;
  if not assigned(loc_info^.heap_valid_first) then
    loc_info^.heap_valid_first:=pp;
{$endif EXTRA}
  loc_info^.heap_mem_root:=pp;
  { must be changed before fill_extra_info is called
    because checkpointer can be called from within
    fill_extra_info PM }
  inc(loc_info^.getmem_cnt);
  { update the signature }
  if usecrc then
    pp^.sig:=calculate_sig(pp);
  TraceGetmem:=p;
end;


{*****************************************************************************
                                TraceFreeMem
*****************************************************************************}

function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info;
  size, ppsize: ptruint): boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifdef EXTRA}
var
  pp2 : pheap_mem_info;
{$endif}
begin
  inc(loc_info^.freemem_size,size);
  if not quicktrace then
    begin
      if not(is_in_getmem_list(loc_info, pp)) then
       RunError(204);
    end;
  if (pp^.sig=longword(ReleaseSig)) then
    begin
       loc_info^.error_in_heap:=true;
       dump_already_free(pp,GetOutput^);
       if haltonerror then halt(1);
    end
  else if ((pp^.sig<>longword(AllocateSig)) or usecrc) and
        ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
    begin
       loc_info^.error_in_heap:=true;
       dump_error(pp,GetOutput^);
{$ifdef EXTRA}
       dump_error(pp,error_file);
{$endif EXTRA}
       { don't release anything in this case !! }
       if haltonerror then halt(1);
       exit;
    end
  else if pp^.size<>size then
    begin
       loc_info^.error_in_heap:=true;
       dump_wrong_size(pp,size,GetOutput^);
{$ifdef EXTRA}
       dump_wrong_size(pp,size,error_file);
{$endif EXTRA}
       if haltonerror then halt(1);
       { don't release anything in this case !! }
       exit;
    end;
  { now it is released !! }
  pp^.sig:=longword(ReleaseSig);
  if not keepreleased then
    begin
       if pp^.next<>nil then
         pp^.next^.previous:=pp^.previous;
       if pp^.previous<>nil then
         pp^.previous^.next:=pp^.next;
       if pp=loc_info^.heap_mem_root then
         loc_info^.heap_mem_root:=loc_info^.heap_mem_root^.previous;
    end
  else
    CaptureBacktrace(1,(tracesize div 2)-1,@pp^.calls[(tracesize div 2)+1]);

  inc(loc_info^.freemem_cnt);
  { clear the memory, $F0 will lead to GFP if used as pointer ! }
  fillchar((pointer(pp)+sizeof(theap_mem_info))^,size,#240);
  { this way we keep all info about all released memory !! }
  if keepreleased then
    begin
{$ifdef EXTRA}
       { We want to check if the memory was changed after release !! }
       pp^.release_sig:=calculate_release_sig(pp);
       if pp=loc_info^.heap_valid_last then
         begin
            loc_info^.heap_valid_last:=pp^.prev_valid;
            if pp=loc_info^.heap_valid_first then
              loc_info^.heap_valid_first:=nil;
            exit(false);
         end;
       pp2:=loc_info^.heap_valid_last;
       while assigned(pp2) do
         begin
            if pp2^.prev_valid=pp then
              begin
                 pp2^.prev_valid:=pp^.prev_valid;
                 if pp=loc_info^.heap_valid_first then
                   loc_info^.heap_valid_first:=pp2;
                 exit(false);
              end
            else
              pp2:=pp2^.prev_valid;
         end;
{$endif EXTRA}
       exit(false);
    end;
  CheckFreeMemSize:=true;
end;

function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
  size: ptruint; release_todo_lock: boolean): ptruint;
var
  i,ppsize : ptruint;
  extra_size: ptruint;
  release_mem: boolean;
begin
  { save old values }
  extra_size:=pp^.extra_info_size;
  ppsize:= size+sizeof(theap_mem_info)+pp^.extra_info_size;
  if add_tail then
    inc(ppsize,tail_size);
  { do various checking }
  release_mem := CheckFreeMemSize(loc_info, pp, size, ppsize);
{$ifdef FPC_HAS_FEATURE_THREADING}
  if release_todo_lock then
    leavecriticalsection(todo_lock);
{$endif}
  if release_mem then
  begin
    { release the normal memory at least }
    i:=SysFreeMemSize(pp,ppsize);
    { return the correct size }
    dec(i,sizeof(theap_mem_info)+extra_size);
    if add_tail then
      dec(i,tail_size);
{$ifdef EXTRA}
    if (i<size) then
      dump_wrong_size(pp,size,error_file)
    else
{$endif EXTRA}
      InternalFreeMemSize:=size;
  end else
    InternalFreeMemSize:=size;
end;

function TraceFreeMemSize(p:pointer;size:ptruint):ptruint;
var
  loc_info: pheap_info;
  pp: pheap_mem_info;
  release_lock: boolean;
begin
  if p=nil then
    begin
      TraceFreeMemSize:=0;
      exit;
    end;
  loc_info:=@heap_info;
  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
  release_lock:=false;
  if @loc_info^.heap_free_todo <> pp^.todolist then
  begin
    if pp^.todolist = main_orig_todolist then
      pp^.todolist := main_relo_todolist;
{$ifdef FPC_HAS_FEATURE_THREADING}
    entercriticalsection(todo_lock);
{$endif}
    release_lock:=true;
    if pp^.todolist = @orphaned_info.heap_free_todo then
    begin
      loc_info := @orphaned_info;
    end else
    if pp^.todolist <> @loc_info^.heap_free_todo then
    begin
      { allocated in different heap, push to that todolist }
      pp^.todonext := pp^.todolist^;
      pp^.todolist^ := pp;
      TraceFreeMemSize := pp^.size;
{$ifdef FPC_HAS_FEATURE_THREADING}
      leavecriticalsection(todo_lock);
{$endif}
      exit;
    end;
  end;
  TraceFreeMemSize:=InternalFreeMemSize(loc_info,p,pp,size,release_lock);
end;


function TraceMemSize(p:pointer):ptruint;
var
  pp : pheap_mem_info;
begin
  if not assigned(p) then
    exit(0);
  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
  TraceMemSize:=pp^.size;
end;


function TraceFreeMem(p:pointer):ptruint;
var
  l  : ptruint;
  pp : pheap_mem_info;
begin
  if p=nil then
    begin
      TraceFreeMem:=0;
      exit;
    end;
  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
  l:=SysMemSize(pp);
  dec(l,sizeof(theap_mem_info)+pp^.extra_info_size);
  if add_tail then
   dec(l,tail_size);
  { this can never happend normaly }
  if pp^.size>l then
   begin
     dump_wrong_size(pp,l,GetOutput^);
{$ifdef EXTRA}
     dump_wrong_size(pp,l,error_file);
{$endif EXTRA}
   end;
  TraceFreeMem:=TraceFreeMemSize(p,pp^.size);
end;


{*****************************************************************************
                                ReAllocMem
*****************************************************************************}

function TraceReAllocMem(var p:pointer;size:ptruint):Pointer;
var
  newP: pointer;
  i, allocsize,
  movesize  : ptruint;
  pl : pdword;
  pp,prevpp{$ifdef EXTRA},ppv{$endif} : pheap_mem_info;
  oldsize,
  oldextrasize,
  oldexactsize : ptruint;
  old_fill_extra_info_proc : tfillextrainfoproc;
  old_display_extra_info_proc : tdisplayextrainfoproc;
  loc_info: pheap_info;
begin
{ Free block? }
  if size=0 then
   begin
     if p<>nil then
      TraceFreeMem(p);
     p:=nil;
     TraceReallocMem:=P;
     exit;
   end;
{ Allocate a new block? }
  if p=nil then
   begin
     p:=TraceGetMem(size);
     TraceReallocMem:=P;
     exit;
   end;
{ Resize block }
  loc_info:=@heap_info;
  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
  { test block }
  if ((pp^.sig<>longword(AllocateSig)) or usecrc) and
     ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
   begin
     loc_info^.error_in_heap:=true;
     dump_error(pp,GetOutput^);
{$ifdef EXTRA}
     dump_error(pp,error_file);
{$endif EXTRA}
     { don't release anything in this case !! }
     if haltonerror then halt(1);
     exit;
   end;
  { save info }
  oldsize:=pp^.size;
  oldextrasize:=pp^.extra_info_size;
  oldexactsize:=pp^.exact_info_size;
  if pp^.extra_info_size>0 then
   begin
     old_fill_extra_info_proc:=pp^.extra_info^.fillproc;
     old_display_extra_info_proc:=pp^.extra_info^.displayproc;
   end;
  { Do the real ReAllocMem, but alloc also for the info block }
{$ifdef cpuarm}
  allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+pp^.extra_info_size;
{$else cpuarm}
  allocsize:=size+sizeof(theap_mem_info)+pp^.extra_info_size;
{$endif cpuarm}
  if add_tail then
   inc(allocsize,tail_size);
  { Try to resize the block, if not possible we need to do a
    getmem, move data, freemem }
  if pp^.todolist<>@loc_info^.heap_free_todo then
   begin
     { get a new block }
     newP := TraceGetMem(size);
     { move the data }
     if newP <> nil then
      begin
        movesize:=TraceMemSize(p);
        {if the old size is larger than the new size,
         move only the new size}
        if movesize>size then
          movesize:=size;
        move(p^,newP^,movesize);
      end;
     { release p }
     traceFreeMem(p);
     { return the new pointer }
     p:=newp;
     traceReAllocMem := newp;
     exit;
   end
  else
   begin
     prevpp:=pp;
     if (SysReallocMem(pp,allocsize)<>prevpp) then
       begin
         { We need to update the previous/next chains }
         if assigned(pp^.previous) then
           pp^.previous^.next:=pp;
         if assigned(pp^.next) then
           pp^.next^.previous:=pp;
         if prevpp=loc_info^.heap_mem_root then
           loc_info^.heap_mem_root:=pp;
{$ifdef EXTRA}
         { remove prevpp from prev_valid chain }
         ppv:=loc_info^.heap_valid_last;
         if (ppv=prevpp) then
           loc_info^.heap_valid_last:=pp^.prev_valid
         else
           begin
             while assigned(ppv) do
               begin
                 if (ppv^.prev_valid=prevpp) then
                   begin
                     ppv^.prev_valid:=pp^.prev_valid;
                     if prevpp=loc_info^.heap_valid_first then
                       loc_info^.heap_valid_first:=ppv;
                     ppv:=nil;
                   end
                 else
                   ppv:=ppv^.prev_valid;
               end;
           end;
         { Reinsert new value in last position }
         pp^.prev_valid:=loc_info^.heap_valid_last;
         loc_info^.heap_valid_last:=pp;
         if not assigned(loc_info^.heap_valid_first) then
           loc_info^.heap_valid_first:=pp;
{$endif EXTRA}
       end;
   end;
{ Recreate the info block }
  pp^.sig:=longword(AllocateSig);
  pp^.size:=size;
  pp^.extra_info_size:=oldextrasize;
  pp^.exact_info_size:=oldexactsize;
  { add the new extra_info and tail }
  if pp^.extra_info_size>0 then
   begin
     pp^.extra_info:=pointer(pp)+allocsize-pp^.extra_info_size;
     fillchar(pp^.extra_info^,extra_info_size,0);
     pp^.extra_info^.check:=cardinal(CheckSig);
     pp^.extra_info^.fillproc:=old_fill_extra_info_proc;
     pp^.extra_info^.displayproc:=old_display_extra_info_proc;
     if assigned(pp^.extra_info^.fillproc) then
      pp^.extra_info^.fillproc(@pp^.extra_info^.data);
   end
  else
   pp^.extra_info:=nil;
  if add_tail then
    begin
      { Calculate position from start because of arm
        specific alignment }
      pl:=pointer(pp)+sizeof(theap_mem_info)+pp^.size;
      for i:=1 to tail_size div sizeof(dword) do
        begin
          unaligned(pl^):=dword(AllocateSig);
          inc(pointer(pl),sizeof(dword));
        end;
   end;
  { adjust like a freemem and then a getmem, so you get correct
    results in the summary display }
  inc(loc_info^.freemem_size,oldsize);
  inc(loc_info^.getmem_size,size);
  { generate new backtrace }
  CaptureBacktrace(1,tracesize,@pp^.calls[1]);
  { regenerate signature }
  if usecrc then
    pp^.sig:=calculate_sig(pp);
  { return the pointer }
  p:=pointer(pp)+sizeof(theap_mem_info);
  TraceReAllocmem:=p;
end;



{*****************************************************************************
                              Check pointer
*****************************************************************************}

{$ifndef Unix}
  {$S-}
{$endif}

{$ifdef go32v2}
var
   __stklen : longword;external name '__stklen';
   __stkbottom : longword;external name '__stkbottom';
   ebss : longword; external name 'end';
{$endif go32v2}

{$ifdef linux}
var
   etext: ptruint; external name '_etext';
   edata : ptruint; external name '_edata';
   eend : ptruint; external name '_end';
{$endif}

{$ifdef freebsd}
var
   text_start: ptruint; external name '__executable_start';
   etext: ptruint; external name '_etext';
   eend : ptruint; external name '_end';
{$endif}

{$ifdef os2}
(* Currently still EMX based - possibly to be changed in the future. *)
var
   etext: ptruint; external name '_etext';
   edata : ptruint; external name '_edata';
   eend : ptruint; external name '_end';
{$endif}

{$ifdef windows}
var
   sdata : ptruint; external name '__data_start__';
   edata : ptruint; external name '__data_end__';
   sbss : ptruint; external name '__bss_start__';
   ebss : ptruint; external name '__bss_end__';
   TLSKey : PDWord; external name '_FPC_TlsKey';
   TLSSize : DWord; external name '_FPC_TlsSize';

function TlsGetValue(dwTlsIndex : DWord) : pointer;
  {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'TlsGetValue';
{$endif}

{$ifdef BEOS}
const
  B_ERROR = -1;

type
  area_id   = Longint;

function area_for(addr : Pointer) : area_id;
            cdecl; external 'root' name 'area_for';
{$endif BEOS}

procedure CheckPointer(p : pointer); [public, alias : 'FPC_CHECKPOINTER'];
var
  i  : ptruint;
  pp : pheap_mem_info;
  loc_info: pheap_info;
{$ifdef go32v2}
  get_ebp,stack_top : longword;
  bss_end : longword;
{$endif go32v2}
{$ifdef windows}
  datap : pointer;
{$endif windows}
begin
  if p=nil then
    runerror(204);

  i:=0;
  loc_info:=@heap_info;

{$ifdef go32v2}
  if ptruint(p)<$1000 then
    runerror(216);
  asm
     movl %ebp,get_ebp
     leal ebss,%eax
     movl %eax,bss_end
  end;
  stack_top:=__stkbottom+__stklen;
  { allow all between start of code and end of bss }
  if ptruint(p)<=bss_end then
    exit;
  { stack can be above heap !! }

  if (ptruint(p)>=get_ebp) and (ptruint(p)<=stack_top) then
    exit;
{$endif go32v2}

  { I don't know where the stack is in other OS !! }
{$ifdef windows}
  { inside stack ? }
  if (ptruint(p)>ptruint(get_frame)) and
     (p<StackTop) then
    exit;
  { inside data, rdata ... bss }
  if (ptruint(p)>=ptruint(@sdata)) and (ptruint(p)<ptruint(@ebss)) then
    exit;
  { is program multi-threaded and p inside Threadvar range? }
  if TlsKey^<>-1 then
    begin
      datap:=TlsGetValue(tlskey^);
      if ((ptruint(p)>=ptruint(datap)) and
          (ptruint(p)<ptruint(datap)+TlsSize)) then
        exit;
    end;
{$endif windows}

{$IFDEF OS2}
  { inside stack ? }
  if (PtrUInt (P) > PtrUInt (Get_Frame)) and
     (PtrUInt (P) < PtrUInt (StackTop)) then
    exit;
  { inside data or bss ? }
  if (PtrUInt (P) >= PtrUInt (@etext)) and (PtrUInt (P) < PtrUInt (@eend)) then
    exit;
{$ENDIF OS2}

{$ifdef linux}
  { inside stack ? }
  if (ptruint(p)>ptruint(get_frame)) and
     (ptruint(p)<ptruint(StackTop)) then
    exit;
  { inside data or bss ? }
  if (ptruint(p)>=ptruint(@etext)) and (ptruint(p)<ptruint(@eend)) then
    exit;
{$endif linux}

{$ifdef freebsd}
  { inside stack ? }
  if (ptruint(p)>ptruint(get_frame)) and
     (ptruint(p)<ptruint(StackTop)) then
    exit;
  { inside data or bss ? }
  if (ptruint(p)>=ptruint(@text_start)) and (ptruint(p)<ptruint(@eend)) then
    exit;
{$endif linux}
{$ifdef morphos}
  { inside stack ? }
  if (ptruint(p)<ptruint(StackTop)) and (ptruint(p)>ptruint(StackBottom)) then
    exit;
  { inside data or bss ? }
  {$WARNING data and bss checking missing }
{$endif morphos}

  {$ifdef darwin}
  {$warning No checkpointer support yet for Darwin}
  exit;
  {$endif}

{$ifdef BEOS}
  // if we find the address in a known area in our current process,
  // then it is a valid one
  if area_for(p) <> B_ERROR then
    exit;
{$endif BEOS}

  { first try valid list faster }

{$ifdef EXTRA}
  pp:=loc_info^.heap_valid_last;
  while pp<>nil do
   begin
     { inside this valid block ! }
     { we can be changing the extrainfo !! }
     if (ptruint(p)>=ptruint(pp)+sizeof(theap_mem_info){+extra_info_size}) and
        (ptruint(p)<=ptruint(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then
       begin
          { check allocated block }
          if ((pp^.sig=longword(AllocateSig)) and not usecrc) or
             ((pp^.sig=calculate_sig(pp)) and usecrc) or
          { special case of the fill_extra_info call }
             ((pp=loc_info^.heap_valid_last) and usecrc and (pp^.sig=longword(AllocateSig))
              and loc_info^.inside_trace_getmem) then
            exit
          else
            begin
              writeln(GetOutput^,'corrupted heap_mem_info');
              dump_error(pp,GetOutput^);
              halt(1);
            end;
       end
     else
       pp:=pp^.prev_valid;
     inc(i);
     if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then
      begin
         writeln(GetOutput^,'error in linked list of heap_mem_info');
         halt(1);
      end;
   end;
  i:=0;
{$endif EXTRA}
  pp:=loc_info^.heap_mem_root;
  while pp<>nil do
   begin
     { inside this block ! }
     if (ptruint(p)>=ptruint(pp)+sizeof(theap_mem_info)+ptruint(extra_info_size)) and
        (ptruint(p)<=ptruint(pp)+sizeof(theap_mem_info)+ptruint(extra_info_size)+ptruint(pp^.size)) then
        { allocated block }
       if ((pp^.sig=longword(AllocateSig)) and not usecrc) or
          ((pp^.sig=calculate_sig(pp)) and usecrc) then
          exit
       else
         begin
            writeln(GetOutput^,'pointer $',hexstr(p),' points into invalid memory block');
            dump_error(pp,GetOutput^);
            runerror(204);
         end;
     pp:=pp^.previous;
     inc(i);
     if i>loc_info^.getmem_cnt then
      begin
         writeln(GetOutput^,'error in linked list of heap_mem_info');
         halt(1);
      end;
   end;
  writeln(GetOutput^,'pointer $',hexstr(p),' does not point to valid memory block');
  dump_stack(GetOutput^,1);
  runerror(204);
end;

{*****************************************************************************
                              Dump Heap
*****************************************************************************}

procedure dumpheap;

begin
  DumpHeap(GlobalSkipIfNoLeaks);
end;

const
{$ifdef BSD}   // dlopen is in libc on FreeBSD.
  LibDL = 'c';
{$else}
  {$ifdef HAIKU}
    LibDL = 'root';
  {$else}
    LibDL = 'dl';
  {$endif}
{$endif}

{$if defined(linux)}
    { if libc is not linked explicitly, FPC might chose the wrong startup code, as
      libdl depends on libc on linux, this does not hurt }
    {$linklib c}
{$endif}

{$if defined(LINUX) or defined(BSD)}
type
  Pdl_info = ^dl_info;
  dl_info = record
    dli_fname      : Pansichar;
    dli_fbase      : pointer;
    dli_sname      : Pansichar;
    dli_saddr      : pointer;
  end;

// *BSD isn't flagged for "weak"  support in 3.2.2
{$if defined(BSD) and (FPC_FULLVERSION<30300)}
  function _dladdr(Lib:pointer; info: Pdl_info): Longint; cdecl; external LibDL name 'dladdr';
{$else}
  function _dladdr(Lib:pointer; info: Pdl_info): Longint; cdecl; weakexternal LibDL name 'dladdr';
{$endif}
{$elseif defined(MSWINDOWS)}
  function _GetModuleFileNameA(hModule:HModule;lpFilename:PAnsiChar;nSize:cardinal):cardinal;stdcall; external 'kernel32' name 'GetModuleFileNameA';
{$endif}

function GetModuleName:string;
{$ifdef MSWINDOWS}
var
  sz:cardinal;
  buf:array[0..8191] of ansichar;
{$endif}
{$if defined(LINUX) or defined(BSD)}
var
  res:integer;
  dli:dl_info;
{$endif}
begin
  GetModuleName:='';
{$if defined(LINUX) or defined(BSD)}
  if assigned(@_dladdr) then
    begin
      res:=_dladdr(@ParamStr,@dli); { get any non-eliminated address in SO space }
      if res<=0 then
        exit;
      if Assigned(dli.dli_fname) then
        GetModuleName:=PAnsiChar(dli.dli_fname);
    end
  else
    GetModuleName:=ParamStr(0);
{$elseif defined(MSWINDOWS)}
  sz:=_GetModuleFileNameA(hInstance,PAnsiChar(@buf),sizeof(buf));
  if sz>0 then
    setstring(GetModuleName,PAnsiChar(@buf),sz)
{$else}
  GetModuleName:=ParamStr(0);
{$endif}
end;

procedure dumpheap(SkipIfNoLeaks : Boolean);
var
  pp : pheap_mem_info;
  i : ptrint;
  ExpectedHeapFree : ptruint;
  status : TFPCHeapStatus;
  ptext : ^text;
  loc_info: pheap_info;
begin
  loc_info:=@heap_info;
  ptext:=GetOutput;
  pp:=loc_info^.heap_mem_root;
  if ((loc_info^.getmem_size-loc_info^.freemem_size)=0) and SkipIfNoLeaks then
    exit;
  status:=SysGetFPCHeapStatus;
  Write(ptext^,
    'Heap dump by heaptrc unit of "'+GetModuleName()+'"',LineEnding,
    loc_info^.getmem_cnt, ' memory blocks allocated : ',loc_info^.getmem_size,LineEnding,
    loc_info^.freemem_cnt,' memory blocks freed     : ',loc_info^.freemem_size,LineEnding,
    loc_info^.getmem_cnt-loc_info^.freemem_cnt,' unfreed memory blocks : ',loc_info^.getmem_size-loc_info^.freemem_size,LineEnding,
    'True heap size : ',status.CurrHeapSize);
  if loc_info^.EntryMemUsed > 0 then
    Write(ptext^,' (',loc_info^.EntryMemUsed,' used in System startup)');
  Writeln(ptext^,LineEnding,
    'True free heap : ',status.CurrHeapFree);
  ExpectedHeapFree:=status.CurrHeapSize
    -(loc_info^.getmem_size-loc_info^.freemem_size)
    -(loc_info^.getmem_cnt-loc_info^.freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)
    -loc_info^.EntryMemUsed;
  If ExpectedHeapFree<>status.CurrHeapFree then
    Writeln(ptext^,'Should be : ',ExpectedHeapFree);
  i:=loc_info^.getmem_cnt-loc_info^.freemem_cnt;
  while pp<>nil do
   begin
     if i<0 then
       begin
          Writeln(ptext^,'Error in heap memory list',LineEnding,
                         'More memory blocks than expected');
          exit;
       end;
     if ((pp^.sig=longword(AllocateSig)) and not usecrc) or
        ((pp^.sig=calculate_sig(pp)) and usecrc) then
       begin
          { this one was not released !! }
          if exitcode<>203 then
            call_stack(pp,ptext^);
          dec(i);
       end
     else if pp^.sig<>longword(ReleaseSig) then
       begin
          dump_error(pp,ptext^);
          if @stderr<>ptext then
            dump_error(pp,stderr);
{$ifdef EXTRA}
          dump_error(pp,error_file);
{$endif EXTRA}
          loc_info^.error_in_heap:=true;
       end
{$ifdef EXTRA}
     else if pp^.release_sig<>calculate_release_sig(pp) then
       begin
          dump_change_after(pp,ptext^);
          dump_change_after(pp,error_file);
          loc_info^.error_in_heap:=true;
       end
{$else not EXTRA}
     else
       begin
         if released_modified(pp,ptext^) then
           exitcode:=203;
       end;
{$endif EXTRA}
       ;
     pp:=pp^.previous;
   end;
  if HaltOnNotReleased and (loc_info^.getmem_cnt<>loc_info^.freemem_cnt) then
    exitcode:=203;
end;


{*****************************************************************************
                                AllocMem
*****************************************************************************}

function TraceAllocMem(size:ptruint):Pointer;
begin
  TraceAllocMem := TraceGetMem(size);
  if Assigned(TraceAllocMem) then
    FillChar(TraceAllocMem^, TraceMemSize(TraceAllocMem), 0);
end;


{*****************************************************************************
                            No specific tracing calls
*****************************************************************************}

procedure TraceInitThread;
var
  loc_info: pheap_info;
begin
  loc_info := @heap_info;
  FillChar(loc_info^,sizeof(loc_info^),0);
  loc_info^.EntryMemUsed := SysGetFPCHeapStatus.CurrHeapUsed;
end;

procedure TraceRelocateHeap;
begin
  main_relo_todolist := @heap_info.heap_free_todo;
{$ifdef FPC_HAS_FEATURE_THREADING}
  initcriticalsection(todo_lock);
{$endif}
end;

procedure move_heap_info(src_info, dst_info: pheap_info);
var
  heap_mem: pheap_mem_info;
begin
  if src_info^.heap_free_todo <> nil then
    finish_heap_free_todo_list(src_info);
  if dst_info^.heap_free_todo <> nil then
    finish_heap_free_todo_list(dst_info);
  heap_mem := src_info^.heap_mem_root;
  if heap_mem <> nil then
  begin
    repeat
      heap_mem^.todolist := @dst_info^.heap_free_todo;
      if heap_mem^.previous = nil then break;
      heap_mem := heap_mem^.previous;
    until false;
    heap_mem^.previous := dst_info^.heap_mem_root;
    if dst_info^.heap_mem_root <> nil then
      dst_info^.heap_mem_root^.next := heap_mem;
    dst_info^.heap_mem_root := src_info^.heap_mem_root;
  end;
  inc(dst_info^.getmem_cnt, src_info^.getmem_cnt);
  inc(dst_info^.getmem_size, src_info^.getmem_size);
  inc(dst_info^.freemem_cnt, src_info^.freemem_cnt);
  inc(dst_info^.freemem_size, src_info^.freemem_size);
  dst_info^.error_in_heap := dst_info^.error_in_heap or src_info^.error_in_heap;
{$ifdef EXTRA}
  if assigned(dst_info^.heap_valid_first) then
    dst_info^.heap_valid_first^.prev_valid := src_info^.heap_valid_last
  else
    dst_info^.heap_valid_last := src_info^.heap_valid_last;
  dst_info^.heap_valid_first := src_info^.heap_valid_first;
{$endif}
end;

procedure TraceExitThread;
var
  loc_info: pheap_info;
begin
  loc_info := @heap_info;
{$ifdef FPC_HAS_FEATURE_THREADING}
  entercriticalsection(todo_lock);
{$endif}
  move_heap_info(loc_info, @orphaned_info);
{$ifdef FPC_HAS_FEATURE_THREADING}
  leavecriticalsection(todo_lock);
{$endif}
end;

function TraceGetHeapStatus:THeapStatus;
begin
  TraceGetHeapStatus:=SysGetHeapStatus;
end;

function TraceGetFPCHeapStatus:TFPCHeapStatus;
begin
    TraceGetFPCHeapStatus:=SysGetFPCHeapStatus;
end;


{*****************************************************************************
                             Program Hooks
*****************************************************************************}

Procedure SetHeapTraceOutput(const name : string);
var i : ptruint;
begin
   CloseOwnFile;
   assign(ownfile,name);
{$I-}
   append(ownfile);
   if IOResult<>0 then
     begin
       Rewrite(ownfile);
       if IOResult<>0 then
         begin
           Writeln(textoutput^,'[heaptrc] Unable to open "',name,'", writing output to stderr instead.');
           useownfile:=false;
           exit;
         end;
     end;
{$I+}
   useownfile:=true;
   for i:=0 to Paramcount do
     write(ownfile,paramstr(i),' ');
   writeln(ownfile);
end;

procedure SetHeapTraceOutput(var ATextOutput : Text);
Begin
  useowntextoutput := True;
  textoutput := @ATextOutput;
end;

procedure SetHeapExtraInfo( size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
begin
  { the total size must stay multiple of 8, also allocate 2 pointers for
    the fill and display procvars }
  exact_info_size:=size + sizeof(theap_extra_info);
  extra_info_size:=(exact_info_size+7) and not 7;
  fill_extra_info_proc:=fillproc;
  display_extra_info_proc:=displayproc;
end;


{*****************************************************************************
                           Install MemoryManager
*****************************************************************************}

const
  TraceManager:TMemoryManager=(
    NeedLock : true;
    Getmem  : @TraceGetMem;
    Freemem : @TraceFreeMem;
    FreememSize : @TraceFreeMemSize;
    AllocMem : @TraceAllocMem;
    ReAllocMem : @TraceReAllocMem;
    MemSize : @TraceMemSize;
    InitThread: @TraceInitThread;
    DoneThread: @TraceExitThread;
    RelocateHeap: @TraceRelocateHeap;
    GetHeapStatus : @TraceGetHeapStatus;
    GetFPCHeapStatus : @TraceGetFPCHeapStatus;
  );

var
  PrevMemoryManager : TMemoryManager;

procedure TraceInit;
begin
  textoutput := @stderr;
  useowntextoutput := false;
  MakeCRC32Tbl;
  main_orig_todolist := @heap_info.heap_free_todo;
  main_relo_todolist := nil;
  TraceInitThread;
  GetMemoryManager(PrevMemoryManager);
  SetMemoryManager(TraceManager);
  useownfile:=false;
  if outputstr <> '' then
     SetHeapTraceOutput(outputstr);
{$ifdef EXTRA}
{$i-}
  Assign(error_file,'heap.err');
  Rewrite(error_file);
{$i+}
  if IOResult<>0 then
    begin
      writeln('[heaptrc] Unable to create heap.err extra log file, writing output to screen.');
      Assign(error_file,'');
      Rewrite(error_file);
    end;
{$endif EXTRA}
  { if multithreading was initialized before heaptrc gets initialized (this is currently
    the case for windows dlls), then RelocateHeap gets never called and the lock
    must be initialized already here,

    however, IsMultithread is not set in this case on windows,
    it is set only if a new thread is started
  }
{$IfNDef WINDOWS}
  if IsMultithread then
{$EndIf WINDOWS}
    TraceRelocateHeap;
end;

procedure TraceExit;
begin
  { no dump if error
    because this gives long long listings }
  { clear inoutres, in case the program that quit didn't }
  ioresult;
  if (exitcode<>0) and (erroraddr<>nil) then
    begin
       Writeln(GetOutput^,'No heap dump by heaptrc unit',LineEnding,
                          'Exitcode = ',exitcode);
       CloseOwnFile;
       exit;
    end;
  { Disable heaptrc memory manager to avoid problems }
  SetMemoryManager(PrevMemoryManager);
  move_heap_info(@orphaned_info, @heap_info);
  dumpheap;
  if heap_info.error_in_heap and (exitcode=0) then
    exitcode:=203;
{$ifdef FPC_HAS_FEATURE_THREADING}
  if main_relo_todolist <> nil then
    donecriticalsection(todo_lock);
{$endif}
{$ifdef EXTRA}
  Close(error_file);
{$endif EXTRA}
  CloseOwnFile;
  if useowntextoutput then
  begin
    useowntextoutput := false;
    close(textoutput^);
  end;
end;

{$if defined(win32) or defined(win64)}
   function GetEnvironmentStrings : pansichar; stdcall;
     external 'kernel32' name 'GetEnvironmentStringsA';
   function FreeEnvironmentStrings(p : pansichar) : longbool; stdcall;
     external 'kernel32' name 'FreeEnvironmentStringsA';
Function  GetEnv(envvar: ansistring): ansistring;
var
   s : ansistring;
   i : ptruint;
   hp,p : pansichar;
begin
   getenv:='';
   p:=GetEnvironmentStrings;
   hp:=p;
   while hp^<>#0 do
     begin
        s:=strpas(hp);
        i:=pos('=',s);
        if upcase(copy(s,1,i-1))=upcase(envvar) then
          begin
             getenv:=copy(s,i+1,length(s)-i);
             break;
          end;
        { next string entry}
        hp:=hp+strlen(hp)+1;
     end;
   FreeEnvironmentStrings(p);
end;
{$elseif defined(wince) or defined(sinclairql)}
Function GetEnv(P:string):PAnsichar;
begin
  { WinCE does not have environment strings.
    Add some way to specify heaptrc options? }
  GetEnv:=nil;
end;
{$elseif defined(msdos) or defined(msxdos)}
   type
     PFarChar=^AnsiChar;far;
     PPFarChar=^PFarChar;
   var
     envp: PPFarChar;external name '__fpc_envp';
Function GetEnv(P:ansistring):ansistring;
var
  ep    : ppfarchar;
  pc    : pfarchar;
  i     : smallint;
  found : boolean;
Begin
  getenv:='';
  p:=p+'=';            {Else HOST will also find HOSTNAME, etc}
  ep:=envp;
  found:=false;
  if ep<>nil then
    begin
      while (not found) and (ep^<>nil) do
        begin
          found:=true;
          for i:=1 to length(p) do
            if p[i]<>ep^[i-1] then
              begin
                found:=false;
                break;
              end;
          if not found then
            inc(ep);
        end;
    end;
  if found then
    begin
      pc:=ep^+length(p);
      while pc^<>#0 do
        begin
          getenv:=getenv+pc^;
          Inc(pc);
        end;
    end;
end;
{$else}
Function GetEnv(P:ansistring):Pansichar;
{
  Searches the environment for a string with name p and
  returns a pansichar to it's value.
  A pansichar is used to accomodate for strings of length > 255
}
var
  ep    : ppansichar;
  i     : ptruint;
  found : boolean;
Begin
  p:=p+'=';            {Else HOST will also find HOSTNAME, etc}
  ep:=envp;
  found:=false;
  if ep<>nil then
   begin
     while (not found) and (ep^<>nil) do
      begin
        found:=true;
        for i:=1 to length(p) do
         if p[i]<>ep^[i-1] then
          begin
            found:=false;
            break;
          end;
        if not found then
         inc(ep);
      end;
   end;
  if found then
   getenv:=ep^+length(p)
  else
   getenv:=nil;
end;
{$endif}

procedure LoadEnvironment;
var
  i,j : ptruint;
  s,s2   : ansistring;
  err : word;
begin
  s:=Getenv('HEAPTRC');
  if pos('keepreleased',s)>0 then
   keepreleased:=true;
  if pos('disabled',s)>0 then
   useheaptrace:=false;
  if pos('nohalt',s)>0 then
   haltonerror:=false;
  if pos('haltonnotreleased',s)>0 then
   HaltOnNotReleased :=true;
  if pos('skipifnoleaks',s)>0 then
   GlobalSkipIfNoLeaks :=true;
  if pos('tail_size=',s)>0 then
    begin
      i:=pos('tail_size=',s)+length('tail_size=');
      s2:='';
      while (i<=length(s)) and (s[i] in ['0'..'9']) do
        begin
          s2:=s2+s[i];
          inc(i);
        end;
      val(s2,tail_size,err);
      if err=0 then
        tail_size:=((tail_size + sizeof(ptruint)-1) div sizeof(ptruint)) * sizeof(ptruint)
      else
        tail_size:=sizeof(ptruint);
      add_tail:=(tail_size > 0);
    end;
  i:=pos('log=',s);
  if i>0 then
   begin
     outputstr:=copy(s,i+4,255);
     j:=pos(' ',outputstr);
     if j=0 then
      j:=length(outputstr)+1;
     delete(outputstr,j,255);
   end;
end;


Initialization
  LoadEnvironment;
  { heaptrc can be disabled from the environment }
  if useheaptrace then
   TraceInit;
finalization
  if useheaptrace then
   TraceExit;
end.