{$MODE OBJFPC} { -*- text -*- }
{$INCLUDE settings.inc}
{$IFNDEF DEBUG} {$FATAL This unit should only be included in debug mode.} {$ENDIF}
unit debug;

interface

const
   HeapInfoSize = 16;

type
   PHeapInfo = ^THeapInfo;
   THeapInfo = String[HeapInfoSize];

function GetStackTrace(): AnsiString;
function SetHeapInfo(S: THeapInfo): THeapInfo;

implementation

{$WARNINGS OFF} // otherwise it warns that we should use -gl instead of "uses lineinfo", but we want visibility into the unit...
uses
   heaptrc, lineinfo;
{$WARNINGS ON}

function GetStackTrace(): AnsiString;
// the following is a verbatim copy from http://wiki.freepascal.org/Logging_exceptions
var
  I: Longint;
  prevbp: Pointer;
  CallerFrame,
  CallerAddress,
  bp: Pointer;
  Report: string;
const
  MaxDepth = 20;
begin
  Report := '';
  bp := get_frame;
  // This trick skip SendCallstack item
  // bp:= get_caller_frame(get_frame);
  try
    prevbp := bp - 1;
    I := 0;
    while bp > prevbp do begin
       CallerAddress := get_caller_addr(bp);
       CallerFrame := get_caller_frame(bp);
       if (CallerAddress = nil) then
         Break;
       Report := Report + BackTraceStrFunc(CallerAddress) + LineEnding;
       Inc(I);
       if (I >= MaxDepth) or (CallerFrame = nil) then
         Break;
       prevbp := bp;
       bp := CallerFrame;
     end;
   except
     { prevent endless dump if an exception occured }
   end;
   // end of copy from http://wiki.freepascal.org/Logging_exceptions
   Result := Report;
end;

var
   CurrentHeapInfo: THeapInfo = '';
   ReportAllocations: Boolean = False;

function SetHeapInfo(S: THeapInfo): THeapInfo;
begin
   Result := CurrentHeapInfo;
   CurrentHeapInfo := S;
end;

procedure HeapInfoFiller(P: Pointer);
var
   FunctionName, SourceFile: ShortString;
   LineNumber: Longint;
   Frame: Pointer;
begin
   if (ReportAllocations) then
   begin
      ReportAllocations := False;
      FunctionName := '';
      SourceFile := '';
      LineNumber := 0;
      Frame := Get_Frame;
      while (Assigned(Frame) and
             {$HINTS OFF} GetLineInfo(PtrUInt(Get_Caller_Addr(Frame)), {$HINTS ON} FunctionName, SourceFile, LineNumber) and 
             ((SourceFile = '') or (SourceFile = 'infrastructure/heaptrc.pp') or (SourceFile = 'infrastructure/debug.pas'))) do
         Frame := Get_Caller_Frame(Frame);
      if (SourceFile <> '') then
      begin
         if (FunctionName <> '') then
            Writeln('Allocating memory for ', FunctionName, '() in ', SourceFile, ' line ', LineNumber, '; ', CurrentHeapInfo)
         else
            Writeln('Allocating memory for ', SourceFile, ' line ', LineNumber, '; ', CurrentHeapInfo);
      end;
      ReportAllocations := True;
   end;
   Assert(Assigned(P));
   PHeapInfo(P)^ := CurrentHeapInfo;
end;

procedure HeapInfoDisplayer(var PText: Text; P: Pointer);
begin
   if (PHeapInfo(P)^ <> '') then
   begin
      Writeln(PText, 'Debug log: ', PHeapInfo(P)^);
      Writeln(PText);
   end;
end;

initialization
   Assert(SizeOf(THeapInfo) = HeapInfoSize+1);
   SetHeapInfo('initialization');
   SetHeapExtraInfo(SizeOf(THeapInfo), @HeapInfoFiller, @HeapInfoDisplayer);
   //QuickTrace := False; { ridiculously slow }
   //ReportAllocations := True; { ridiculously verbose }
   //KeepReleased := True;
finalization
   SetHeapInfo('finalisation');
end.