From c1c9a0851ec35f659cd90f4e4a9f7e7d32279211 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Wed, 10 Jun 2026 10:11:52 +0100 Subject: [PATCH] feat(debug): add allocation-site info (unit:line) to leak tracker 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. --- .../pascal/blaise.codegen.native.backend.pas | 11 ++- .../src/main/pascal/blaise.codegen.native.pas | 3 + .../pascal/blaise.codegen.native.x86_64.pas | 34 +++++++ compiler/src/main/pascal/uCodeGenQBE.pas | 12 ++- compiler/src/test/pascal/cp.test.e2e.base.pas | 94 +++++++++++++++++++ .../src/test/pascal/cp.test.e2e.leakcheck.pas | 50 ++++++++++ runtime/src/main/pascal/blaise_arc.pas | 65 ++++++++----- 7 files changed, 242 insertions(+), 27 deletions(-) diff --git a/compiler/src/main/pascal/blaise.codegen.native.backend.pas b/compiler/src/main/pascal/blaise.codegen.native.backend.pas index 8c7f800..6fe785d 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.backend.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.backend.pas @@ -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); diff --git a/compiler/src/main/pascal/blaise.codegen.native.pas b/compiler/src/main/pascal/blaise.codegen.native.pas index 47316dc..7512023 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.pas @@ -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; diff --git a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas index e7891af..8a2ad90 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -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 diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index add407c..c3ecd5e 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -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); diff --git a/compiler/src/test/pascal/cp.test.e2e.base.pas b/compiler/src/test/pascal/cp.test.e2e.base.pas index 11311c4..0d0bd83 100644 --- a/compiler/src/test/pascal/cp.test.e2e.base.pas +++ b/compiler/src/test/pascal/cp.test.e2e.base.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas b/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas index 8285366..4b99fb7 100644 --- a/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas +++ b/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas @@ -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); diff --git a/runtime/src/main/pascal/blaise_arc.pas b/runtime/src/main/pascal/blaise_arc.pas index 2ba0335..a375724 100644 --- a/runtime/src/main/pascal/blaise_arc.pas +++ b/runtime/src/main/pascal/blaise_arc.pas @@ -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;