administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

feat(debug): add allocation-site info (unit:line) to leak tracker

Browse source 
Extend _LeakTrackerRegister from 2 to 4 args (UserPtr, ClassName,
UnitName, Line) so the --debug leak report prints where each leaked
object was allocated.  Both QBE and native backends now emit the
extra unit-name string literal and AST line number at every
_ClassAlloc site.  Leak report output changes from:
  - TBox (rc=1)
to:
  - TBox (rc=1) at LeakSite:14

Runtime: bucket size grows from 16 to 32 bytes; LTInsert stores
unit-name ptr + line; _LeakTrackerReport prints the " at unit:line"
suffix.

Native backend: plumb FDebugMode from TCodeGenNative through
TNativeBackend; emit _LeakTrackerEnable in $main; emit
_LeakTrackerRegister at both constructor-call paths.

QBE backend: add FCurrentUnitName, set in Generate/GenerateUnit/
AppendUnit/AppendProgram; extend both _LeakTrackerRegister call
sites with EmitStrLit(FCurrentUnitName) + node.Line.

2766 tests pass (2 new e2e tests), FIXPOINT_OK.
This commit is contained in:
Graeme Geldenhuys 2026-06-10 10:11:52 +01:00
parent 924964089c
commit c1c9a0851e
7 changed files with 242 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
compiler/src/main/pascal/blaise.codegen.native.backend.pas
View file

@ -40,8 +40,9 @@ type
TNativeBackend = class
protected
FTarget: TTargetDesc;
FSymTable: TSymbolTable; { not owned }
FTarget: TTargetDesc;
FSymTable: TSymbolTable; { not owned }
FDebugMode: Boolean;
{ Assembly text is built append-only and read once at the end, so a
TStringBuilder (single growable buffer, no per-line heap string and no
O(N^2) final concat) is the right structure — the same approach the QBE
@ -73,6 +74,7 @@ type
function GetOutput: string;
procedure SetSymbolTable(ASymTable: TSymbolTable);
procedure SetDebugMode(AEnabled: Boolean);
{ Lower a whole program to assembly text and return it. }
function GenerateProgram(AProg: TProgram): string;
@ -103,6 +105,11 @@ begin
FSymTable := ASymTable;
end;
procedure TNativeBackend.SetDebugMode(AEnabled: Boolean);
begin
FDebugMode := AEnabled;
end;
procedure TNativeBackend.Emit(const ALine: string);
begin
FAsm.AppendLine(ALine);

3
compiler/src/main/pascal/blaise.codegen.native.pas
View file

@ -137,6 +137,7 @@ procedure TCodeGenNative.Generate(AProg: TProgram);
begin
Self.EnsureBackend();
FBackend.SetSymbolTable(FSymTable);
FBackend.SetDebugMode(FDebugMode);
FOutput := FBackend.GenerateProgram(AProg);
end;
@ -152,6 +153,7 @@ procedure TCodeGenNative.AppendUnit(AUnit: TUnit);
begin
Self.EnsureBackend();
FBackend.SetSymbolTable(FSymTable);
FBackend.SetDebugMode(FDebugMode);
FBackend.AppendUnit(AUnit);
FOutput := FBackend.GetOutput();
end;
@ -160,6 +162,7 @@ procedure TCodeGenNative.AppendProgram(AProg: TProgram);
begin
Self.EnsureBackend();
FBackend.SetSymbolTable(FSymTable);
FBackend.SetDebugMode(FDebugMode);
FBackend.AppendProgram(AProg);
FOutput := FBackend.GetOutput();
end;

34
compiler/src/main/pascal/blaise.codegen.native.x86_64.pas
View file

@ -5402,6 +5402,21 @@ begin
[Self.ClassSymName(FAE.ResolvedType.Name)]));
Self.Emit(#9'movq %rcx, (%rax)');
end;
if FDebugMode then
begin
Self.Emit(#9'pushq %rbx');
Self.Emit(#9'movq %rax, %rbx');
Self.Emit(#9'movq %rbx, %rdi');
Self.Emit(Format(#9'movq typeinfo_%s+16(%%rip), %%rsi',
[Self.ClassSymName(FAE.ResolvedType.Name)]));
SetI := FStrLits.IndexOf(FCurrentUnitName);
if SetI < 0 then SetI := FStrLits.Add(FCurrentUnitName);
Self.Emit(Format(#9'leaq __s%d+12(%%rip), %%rdx', [SetI]));
Self.Emit(Format(#9'movq $%d, %%rcx', [FAE.Line]));
Self.Emit(#9'callq _LeakTrackerRegister');
Self.Emit(#9'movq %rbx, %rax');
Self.Emit(#9'popq %rbx');
end;
{ Call user-defined zero-arg Create body if present. }
if FAE.ResolvedMethod <> nil then
begin
@ -5506,6 +5521,7 @@ end;
procedure TX86_64Backend.EmitMethodCallExpr(ACall: TMethodCallExpr);
var
I: Integer;
SetI: Integer;
MD: TMethodDecl;
Sym: string;
Arg: TASTExpr;
@ -5547,6 +5563,21 @@ begin
Self.Emit(Format(#9'leaq vtable_%s(%%rip), %%rcx', [Self.ClassSymName(RT.Name)]));
Self.Emit(#9'movq %rcx, (%rax)');
end;
if FDebugMode then
begin
Self.Emit(#9'pushq %rbx');
Self.Emit(#9'movq %rax, %rbx');
Self.Emit(#9'movq %rbx, %rdi');
Self.Emit(Format(#9'movq typeinfo_%s+16(%%rip), %%rsi',
[Self.ClassSymName(RT.Name)]));
SetI := FStrLits.IndexOf(FCurrentUnitName);
if SetI < 0 then SetI := FStrLits.Add(FCurrentUnitName);
Self.Emit(Format(#9'leaq __s%d+12(%%rip), %%rdx', [SetI]));
Self.Emit(Format(#9'movq $%d, %%rcx', [ACall.Line]));
Self.Emit(#9'callq _LeakTrackerRegister');
Self.Emit(#9'movq %rbx, %rax');
Self.Emit(#9'popq %rbx');
end;
MD := TMethodDecl(ACall.ResolvedMethod);
if MD <> nil then
begin
@ -10422,6 +10453,7 @@ var
VD: TVarDecl;
Decl: TMethodDecl;
begin
FCurrentUnitName := AProg.Name;
{ Register declared program-level variables as global slots. }
for I := 0 to AProg.Block.Decls.Count - 1 do
begin
@ -10491,6 +10523,8 @@ begin
{ Call initialization sections of imported units in order. }
for I := 0 to FUnitInitNames.Count - 1 do
Self.Emit(#9'callq ' + FUnitInitNames.Strings[I] + '_init');
if FDebugMode then
Self.Emit(#9'callq _LeakTrackerEnable');
{ Program body. }
FExitLabel := Self.NewLabel('main_exit');
for I := 0 to AProg.Block.Stmts.Count - 1 do

12
compiler/src/main/pascal/uCodeGenQBE.pas
View file

@ -85,6 +85,7 @@ type
its own next iteration. }
FThreadVarNames: TStringList; { global names declared as threadvar }
FUnitInitNames: TStringList; { unit names that have initialization sections }
FCurrentUnitName: string; { name of the unit/program being emitted }
{ mem2reg: parallel lists tracking which locals are promoted SSA temps.
FPromotedLocals[i] = var name; FPromotedTypes[i] = QBE type ('w','l','d','s').
Cleared at the start of each function by EmitVarAllocs. }
@ -9168,7 +9169,8 @@ begin
[L, ClassSymName(QBEMangle(RT.Name))]));
R := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [R, L]));
EmitLine(Format(' call $_LeakTrackerRegister(l %s, l %s)', [SelfTemp, R]));
EmitLine(Format(' call $_LeakTrackerRegister(l %s, l %s, l %s, l %d)',
[SelfTemp, R, Self.EmitStrLit(FCurrentUnitName), MCallExpr.Line]));
end;
{ If there's a user-defined Create method, call it }
if MCallExpr.ResolvedMethod <> nil then
@ -9961,13 +9963,13 @@ begin
[ClassSymName(QBEMangle(FldAccess.ResolvedType.Name)), T]));
if FDebugMode then
begin
{ Load classname ptr from typeinfo[2] (offset +16) and register with leak tracker }
L := AllocTemp();
EmitLine(Format(' %s =l add $typeinfo_%s, 16',
[L, ClassSymName(QBEMangle(FldAccess.ResolvedType.Name))]));
R := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [R, L]));
EmitLine(Format(' call $_LeakTrackerRegister(l %s, l %s)', [T, R]));
EmitLine(Format(' call $_LeakTrackerRegister(l %s, l %s, l %s, l %d)',
[T, R, Self.EmitStrLit(FCurrentUnitName), FldAccess.Line]));
end;
{ Call user-defined Create body if one exists }
if FldAccess.ResolvedMethod <> nil then
@ -11324,6 +11326,7 @@ begin
FStrLitsEmitted := 0;
FTempCount := 0;
FLabelCount := 0;
FCurrentUnitName := AProg.Name;
CollectThreadVarNames(AProg.Block);
@ -11381,6 +11384,7 @@ begin
FStrLitsEmitted := 0;
FTempCount := 0;
FLabelCount := 0;
FCurrentUnitName := AUnit.Name;
CollectThreadVarNames(AUnit.IntfBlock);
CollectThreadVarNames(AUnit.ImplBlock);
@ -11537,6 +11541,7 @@ begin
Counter resets are safe: QBE temps and block labels are function-scoped. }
FTempCount := 0;
FLabelCount := 0;
FCurrentUnitName := AUnit.Name;
CollectThreadVarNames(AUnit.IntfBlock);
CollectThreadVarNames(AUnit.ImplBlock);
@ -11994,6 +11999,7 @@ begin
{ No clears — accumulates after AppendUnit calls. }
FTempCount := 0;
FLabelCount := 0;
FCurrentUnitName := AProg.Name;
CollectThreadVarNames(AProg.Block);

94
compiler/src/test/pascal/cp.test.e2e.base.pas
View file

@ -90,6 +90,11 @@ type
out AStdout: string;
out AExitCode: Integer;
ADebugMode: Boolean): Boolean;
function CompileAndRunWithRTLDebugOn(ABackend: TBackend;
const ASrc: string;
out AStdout: string;
out AExitCode: Integer;
ADebugMode: Boolean): Boolean;
{ Compile a program that USES a user unit written to the scratch dir, so
the unit (not the program) is the compilation unit. Exercises the
multi-unit codegen path. AUnitName is the unit identifier; AUnitSrc and
@ -503,6 +508,95 @@ begin
Result := True
end;
function TE2ETestCase.CompileAndRunWithRTLDebugOn(ABackend: TBackend;
const ASrc: string;
out AStdout: string;
out AExitCode: Integer;
ADebugMode: Boolean): Boolean;
var
Lexer: TLexer;
Parser: TParser;
Prog: TProgram;
Semantic: TSemanticAnalyser;
QCG: TCodeGenQBE;
NCG: TCodeGenNative;
CG: ICodeGen;
Loader: TUnitLoader;
Units: TObjectList;
SearchPaths: TStringList;
Emitted: string;
IRFile: string;
AsmFile: string;
BinFile: string;
ToolOut: string;
Rc: Integer;
I: Integer;
begin
Result := False;
Inc(FCounter);
IRFile := FScratch + '/t' + IntToStr(FCounter) + '.ssa';
AsmFile := FScratch + '/t' + IntToStr(FCounter) + '.s';
BinFile := FScratch + '/t' + IntToStr(FCounter);
Lexer := nil; Parser := nil; Prog := nil; Semantic := nil;
QCG := nil; CG := nil; Loader := nil; Units := nil; SearchPaths := nil;
try
Lexer := TLexer.Create(ASrc);
Parser := TParser.Create(Lexer);
Prog := Parser.Parse();
Semantic := TSemanticAnalyser.Create();
SearchPaths := TStringList.Create();
SearchPaths.Add(FRTLUnitPath);
SearchPaths.Add(FStdlibUnitPath);
Loader := TUnitLoader.Create(SearchPaths);
Units := Loader.LoadAll(Prog.UsedUnits);
for I := 0 to Units.Count - 1 do
Semantic.AnalyseUnitForExport(TUnit(Units.Items[I]));
Semantic.Analyse(Prog);
if ABackend = beNative then
begin
NCG := TCodeGenNative.Create();
NCG.SetTarget(HostTarget());
CG := NCG;
CG.SetDebugMode(ADebugMode);
CG.SetSymbolTable(Prog.SymbolTable);
for I := 0 to Units.Count - 1 do
CG.AppendUnit(TUnit(Units.Items[I]));
CG.AppendProgram(Prog);
Emitted := CG.GetOutput()
end
else
begin
QCG := TCodeGenQBE.Create();
QCG.SetDebugMode(ADebugMode);
QCG.SetSymbolTable(Prog.SymbolTable);
for I := 0 to Units.Count - 1 do
QCG.AppendUnit(TUnit(Units.Items[I]));
QCG.AppendProgram(Prog);
Emitted := QCG.GetOutput()
end
finally
QCG.Free(); Semantic.Free();
Units.Free(); Loader.Free(); SearchPaths.Free();
Prog.Free(); Parser.Free(); Lexer.Free()
end;
if ABackend = beNative then
begin
WriteFile(AsmFile, Emitted)
end
else
begin
WriteFile(IRFile, Emitted);
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end
end;
Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True
end;
function TE2ETestCase.CompileAndRunWithUnit(const AUnitName, AUnitSrc, ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean;

50
compiler/src/test/pascal/cp.test.e2e.leakcheck.pas
View file

@ -31,6 +31,8 @@ type
procedure TestDebug_MultipleLeaks_AllReported;
procedure TestDebug_CycleRetained_Reported;
procedure TestRelease_NoReport_WhenDebugOff;
procedure TestDebug_LeakReport_IncludesUnitAndLine;
procedure TestDebug_LeakReport_IncludesUnitAndLine_Native;
end;
implementation
@ -176,6 +178,24 @@ const
end.
''';
{ Leak with allocation-site info: the report must include the unit name and
line number where the leaking TBox.Create() call was made. }
SrcLeakWithSite = '''
program LeakSite;
uses blaise_arc;
type
TBox = class
Value: Integer;
end;
var
B: TBox;
begin
B := TBox.Create();
_ClassAddRef(Pointer(B));
WriteLn('done')
end.
''';
{ ------------------------------------------------------------------ }
procedure TE2ELeakCheckTests.TestDebug_NoLeak_NoReport;
@ -269,6 +289,36 @@ begin
AssertTrue('no leak report', Pos('Blaise leak report', Output) < 0);
end;
procedure TE2ELeakCheckTests.TestDebug_LeakReport_IncludesUnitAndLine;
var
Output: string;
ExitCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run',
CompileAndRunWithRTLDebugOn(beQBE, SrcLeakWithSite, Output, ExitCode, True));
AssertEquals('exit 0', 0, ExitCode);
AssertTrue('leak header', Pos('Blaise leak report', Output) >= 0);
AssertTrue('class name', Pos('TBox', Output) >= 0);
AssertTrue('unit name in report', Pos('LeakSite', Output) >= 0);
AssertTrue('at separator', Pos(' at ', Output) >= 0);
end;
procedure TE2ELeakCheckTests.TestDebug_LeakReport_IncludesUnitAndLine_Native;
var
Output: string;
ExitCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run',
CompileAndRunWithRTLDebugOn(beNative, SrcLeakWithSite, Output, ExitCode, True));
AssertEquals('exit 0', 0, ExitCode);
AssertTrue('leak header', Pos('Blaise leak report', Output) >= 0);
AssertTrue('class name', Pos('TBox', Output) >= 0);
AssertTrue('unit name in report', Pos('LeakSite', Output) >= 0);
AssertTrue('at separator', Pos(' at ', Output) >= 0);
end;
initialization
RegisterTest(TE2ELeakCheckTests);

65
runtime/src/main/pascal/blaise_arc.pas
View file

@ -59,7 +59,8 @@ function _HasClassAttribute(AClassTI, AAttrTI: Pointer): Boolean;
procedure _StringReleaseCheck(DataPtr: Pointer; RefCount, Length, Capacity: Integer);
procedure _AbstractMethodError;
procedure _LeakTrackerEnable;
procedure _LeakTrackerRegister(UserPtr: Pointer; ClassName: Pointer);
procedure _LeakTrackerRegister(UserPtr: Pointer; ClassName: Pointer;
UnitName: Pointer; Line: Int64);
procedure _libc_atexit(Fn: Pointer); external name 'atexit';
implementation
@ -148,7 +149,7 @@ end;
const
LT_BUCKETS = 1024; { must be power of two }
LT_BUCKET_SZ = 16; { 2 × 8-byte pointers }
LT_BUCKET_SZ = 32; { 4 × 8-byte slots: key, classname, unitname, line }
var
GLTEnabled: Boolean;
@ -166,10 +167,11 @@ begin
Result := Integer(V and (LT_BUCKETS - 1));
end;
procedure LTInsert(Key, Value: Pointer);
procedure LTInsert(Key, ClassName, UnitName: Pointer; Line: Int64);
var
Idx, Step: Integer;
Slot: ^Pointer;
LineSlot: ^Int64;
begin
Idx := LTHash(Key);
Step := 0;
@ -180,7 +182,11 @@ begin
begin
Slot^ := Key;
Slot := Pointer(Pointer(Slot) + 8);
Slot^ := Value;
Slot^ := ClassName;
Slot := Pointer(Pointer(Slot) + 8);
Slot^ := UnitName;
LineSlot := Pointer(Pointer(Slot) + 8);
LineSlot^ := Line;
Inc(GLTCount);
Exit;
end;
@ -261,14 +267,30 @@ begin
WriteInt(V);
end;
procedure WriteStrSlot(DataPtr: Pointer);
var
LenSlot: ^Integer;
Len: Integer;
begin
if DataPtr = nil then begin WriteStr('(unknown)', 9); Exit end;
LenSlot := DataPtr - 8;
Len := LenSlot^;
if (Len > 0) and (Len < 256) then
WriteStr(DataPtr, Len)
else
WriteStr('(unknown)', 9);
end;
procedure _LeakTrackerReport;
var
I: Integer;
Slot: ^Pointer;
NamePtr: ^Pointer;
ClassName: Pointer;
LenSlot: ^Integer;
NameLen: Integer;
UnitSlot: ^Pointer;
UnitName: Pointer;
LineSlot: ^Int64;
Line: Int64;
RCSlot: ^Integer;
RC: Integer;
begin
@ -287,36 +309,35 @@ begin
begin
NamePtr := Pointer(Pointer(Slot) + 8);
ClassName := NamePtr^;
UnitSlot := Pointer(Pointer(Slot) + 16);
UnitName := UnitSlot^;
LineSlot := Pointer(Pointer(Slot) + 24);
Line := LineSlot^;
WriteStr(' - ', 4);
if ClassName <> nil then
begin
LenSlot := ClassName - 8; { string header: Length at data_ptr-8 }
NameLen := LenSlot^;
if (NameLen > 0) and (NameLen < 256) then
WriteStr(ClassName, NameLen)
else
WriteStr('(unknown)', 9);
end
else
WriteStr('(unknown)', 9);
{ Refcount lives in the class header at UserPtr - CLASS_HDR. A leaked
object with rc>1 indicates an over-retain (double-AddRef); rc=1
indicates a reference that was never released. }
WriteStrSlot(ClassName);
RCSlot := Slot^ - CLASS_HDR;
RC := RCSlot^;
WriteStr(' (rc=', 5);
WriteSignedInt(RC);
WriteStr(')', 1);
if UnitName <> nil then
begin
WriteStr(' at ', 4);
WriteStrSlot(UnitName);
WriteStr(':', 1);
WriteInt(Integer(Line));
end;
WriteNL();
end;
end;
end;
procedure _LeakTrackerRegister(UserPtr: Pointer; ClassName: Pointer);
procedure _LeakTrackerRegister(UserPtr: Pointer; ClassName: Pointer;
UnitName: Pointer; Line: Int64);
begin
if not GLTEnabled then Exit;
if UserPtr = nil then Exit;
LTInsert(UserPtr, ClassName);
LTInsert(UserPtr, ClassName, UnitName, Line);
end;
procedure _LeakTrackerEnable;