debug.pas

{$MODE OBJFPC} { -*- delphi -*- }
{$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];

procedure HexDump(var Data; const Size, SubSize: Cardinal);

{$IFNDEF OPT}
function SetHeapInfo(S: THeapInfo): THeapInfo;
function SetHeapInfoTruncated(S: AnsiString): THeapInfo; // only adds the end of the string
{$ENDIF}

implementation

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

procedure HexDump(var Data; const Size, SubSize: Cardinal);
var
   Index, LineIndex: Cardinal;
begin
   Index := 0;
   LineIndex := 0;
   while Index < Size do
   begin
      Write(IntToHex(PByte(Pointer(@Data) + Index)^, 2));
      Inc(Index);
      Inc(LineIndex);
      if ((LineIndex >= 80) or (Index mod SubSize = 0)) then
      begin
         Writeln();
         LineIndex := 0;
      end
      else
      if (LineIndex mod 8 = 0) then
      begin
         Write(' ');
      end;
   end;
end;

{$IFNDEF OPT}
var
   CurrentHeapInfo: THeapInfo = '';
   ReportAllocations: Boolean = False;

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

function SetHeapInfoTruncated(S: AnsiString): THeapInfo;
begin
   Result := CurrentHeapInfo;
   if (Length(S) > HeapInfoSize) then
      CurrentHeapInfo := Copy(S, Length(S)-HeapInfoSize+1, HeapInfoSize)
   else
      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 = 'lib/heaptrc.pp') or (SourceFile = 'lib/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)^); // http://bugs.freepascal.org/view.php?id=25916
      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');
{$ENDIF}
end.