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

feat(debug): extend leak tracking to strings and dynamic arrays

Browse source 
Track string and dynamic-array buffer leaks in --debug builds.
Strings are registered in _StringAddRef (on the 0→1 transition)
and removed in _StringRelease; likewise for _DynArrayAddRef/Release.
The leak report prints "string" or "dynarray" as the type tag
instead of a class name.

Sentinel-based type tags (GLTTagString=Pointer(2), GLTTagDynArray=
Pointer(3)) distinguish buffer entries from class entries in the
hash map.  The report reads the correct refcount header offset
for each type (12-byte string header, 8-byte dynarray header,
CLASS_HDR for classes).

LT_BUCKETS grows from 1024 to 4096 to accommodate the higher
entry count when strings/dynarrays are tracked.  Report wording
changes from "object(s) not released" to "leak(s) not released".

2768 tests pass (2 new e2e tests), FIXPOINT_OK.
This commit is contained in:
Graeme Geldenhuys 2026-06-10 10:23:05 +01:00
parent c1c9a0851e
commit a9cb4961ea
2 changed files with 100 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -33,6 +33,8 @@ type
procedure TestRelease_NoReport_WhenDebugOff;
procedure TestDebug_LeakReport_IncludesUnitAndLine;
procedure TestDebug_LeakReport_IncludesUnitAndLine_Native;
procedure TestDebug_StringLeak_Reported;
procedure TestDebug_StringClean_NoReport;
end;
implementation
@ -196,6 +198,32 @@ const
end.
''';
{ Leaked string: concatenation produces a heap-allocated string (non-immortal).
Extra AddRef prevents scope-exit release from freeing it. }
SrcStringLeak = '''
program P;
uses blaise_arc;
var
S: string;
begin
S := 'hel' + 'lo';
_StringAddRef(Pointer(S));
WriteLn('done')
end.
''';
{ Clean string usage: no leak expected — scope-exit ARC releases properly. }
SrcStringClean = '''
program P;
uses blaise_arc;
var
S: string;
begin
S := 'hello';
WriteLn(S)
end.
''';
{ ------------------------------------------------------------------ }
procedure TE2ELeakCheckTests.TestDebug_NoLeak_NoReport;
@ -246,7 +274,7 @@ begin
AssertTrue('compile+run', CompileAndRunWithRTLDebug(SrcOneLeak, Output, ExitCode, True));
AssertEquals('exit 0', 0, ExitCode);
AssertTrue('leak header present', Pos('Blaise leak report', Output) >= 0);
AssertTrue('count 1', Pos('1 object(s)', Output) >= 0);
AssertTrue('count 1', Pos('1 leak(s)', Output) >= 0);
AssertTrue('class name', Pos('TBox', Output) >= 0);
end;
@ -259,7 +287,7 @@ begin
AssertTrue('compile+run', CompileAndRunWithRTLDebug(SrcTwoLeaks, Output, ExitCode, True));
AssertEquals('exit 0', 0, ExitCode);
AssertTrue('leak header present', Pos('Blaise leak report', Output) >= 0);
AssertTrue('count 2', Pos('2 object(s)', Output) >= 0);
AssertTrue('count 2', Pos('2 leak(s)', Output) >= 0);
AssertTrue('TAlpha reported', Pos('TAlpha', Output) >= 0);
AssertTrue('TBeta reported', Pos('TBeta', Output) >= 0);
end;
@ -273,7 +301,7 @@ begin
AssertTrue('compile+run', CompileAndRunWithRTLDebug(SrcCycleLeak, Output, ExitCode, True));
AssertEquals('exit 0', 0, ExitCode);
AssertTrue('leak header present', Pos('Blaise leak report', Output) >= 0);
AssertTrue('count 2', Pos('2 object(s)', Output) >= 0);
AssertTrue('count 2', Pos('2 leak(s)', Output) >= 0);
AssertTrue('TNode reported', Pos('TNode', Output) >= 0);
end;
@ -319,6 +347,31 @@ begin
AssertTrue('at separator', Pos(' at ', Output) >= 0);
end;
procedure TE2ELeakCheckTests.TestDebug_StringLeak_Reported;
var
Output: string;
ExitCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run',
CompileAndRunWithRTLDebug(SrcStringLeak, Output, ExitCode, True));
AssertEquals('exit 0', 0, ExitCode);
AssertTrue('leak header', Pos('Blaise leak report', Output) >= 0);
AssertTrue('string tag', Pos('string', Output) >= 0);
end;
procedure TE2ELeakCheckTests.TestDebug_StringClean_NoReport;
var
Output: string;
ExitCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run',
CompileAndRunWithRTLDebug(SrcStringClean, Output, ExitCode, True));
AssertEquals('exit 0', 0, ExitCode);
AssertTrue('no leak report', Pos('Blaise leak report', Output) < 0);
end;
initialization
RegisterTest(TE2ELeakCheckTests);

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

@ -148,7 +148,7 @@ end;
}
const
LT_BUCKETS = 1024; { must be power of two }
LT_BUCKETS = 4096; { must be power of two; larger for string/dynarray tracking }
LT_BUCKET_SZ = 32; { 4 × 8-byte slots: key, classname, unitname, line }
var
@ -156,6 +156,8 @@ var
GLTTable: PChar; { raw bucket array, LT_BUCKETS * LT_BUCKET_SZ bytes }
GLTCount: Integer;
GLTTombstone: Pointer; { sentinel for deleted slots, set to Pointer(1) at init }
GLTTagString: Pointer; { sentinel classname tag for leaked strings, Pointer(2) }
GLTTagDynArray: Pointer; { sentinel classname tag for leaked dyn-arrays, Pointer(3) }
function LTHash(P: Pointer): Integer;
var
@ -300,7 +302,7 @@ begin
WriteNL();
WriteStr(' ', 2);
WriteInt(GLTCount);
WriteStr(' object(s) not released:', 24);
WriteStr(' leak(s) not released:', 22);
WriteNL();
for I := 0 to LT_BUCKETS - 1 do
begin
@ -314,9 +316,24 @@ begin
LineSlot := Pointer(Pointer(Slot) + 24);
Line := LineSlot^;
WriteStr(' - ', 4);
WriteStrSlot(ClassName);
RCSlot := Slot^ - CLASS_HDR;
RC := RCSlot^;
if ClassName = GLTTagString then
begin
WriteStr('string', 6);
RCSlot := Slot^ - HDR_SIZE;
RC := RCSlot^;
end
else if ClassName = GLTTagDynArray then
begin
WriteStr('dynarray', 8);
RCSlot := Slot^ - 8;
RC := RCSlot^;
end
else
begin
WriteStrSlot(ClassName);
RCSlot := Slot^ - CLASS_HDR;
RC := RCSlot^;
end;
WriteStr(' (rc=', 5);
WriteSignedInt(RC);
WriteStr(')', 1);
@ -352,6 +369,10 @@ begin
well above page 0, and address 1 is in the unmapped zero page). }
Sentinel := 1;
GLTTombstone := Pointer(Sentinel);
Sentinel := 2;
GLTTagString := Pointer(Sentinel);
Sentinel := 3;
GLTTagDynArray := Pointer(Sentinel);
TableSize := LT_BUCKETS * LT_BUCKET_SZ;
GLTTable := PChar(_BlaiseGetMem(TableSize));
if GLTTable = nil then begin GLTEnabled := False; Exit end;
@ -410,11 +431,14 @@ end;
procedure _StringAddRef(Ptr: Pointer);
var
RC: PInteger;
OldRC: Integer;
begin
if Ptr = nil then Exit;
RC := PInteger(Ptr - HDR_SIZE);
if RC^ = IMMORTAL then Exit;
_AtomicAddInt32(RC, 1);
OldRC := _AtomicAddInt32(RC, 1);
if (OldRC = 0) and GLTEnabled then
LTInsert(Ptr, GLTTagString, nil, 0);
end;
procedure _StringRelease(Ptr: Pointer);
@ -432,7 +456,11 @@ begin
CP := Base + 8;
_StringReleaseCheck(Ptr, RC^, LN^, CP^);
OldRC := _AtomicSubInt32(RC, 1);
if OldRC = 1 then _BlaiseFreeMem(Base);
if OldRC = 1 then
begin
if GLTEnabled then LTDelete(Ptr);
_BlaiseFreeMem(Base);
end;
end;
{ Dynamic-array buffer header is [refcount:4][length:4]; data pointer
@ -444,11 +472,14 @@ const
DA_HDR = 8;
var
RC: PInteger;
OldRC: Integer;
begin
if Ptr = nil then Exit;
RC := PInteger(Ptr - DA_HDR);
if RC^ = IMMORTAL then Exit;
_AtomicAddInt32(RC, 1);
OldRC := _AtomicAddInt32(RC, 1);
if (OldRC = 0) and GLTEnabled then
LTInsert(Ptr, GLTTagDynArray, nil, 0);
end;
procedure _DynArrayRelease(Ptr: Pointer);
@ -464,7 +495,11 @@ begin
RC := PInteger(Base);
if RC^ = IMMORTAL then Exit;
OldRC := _AtomicSubInt32(RC, 1);
if OldRC = 1 then _BlaiseFreeMem(Base);
if OldRC = 1 then
begin
if GLTEnabled then LTDelete(Ptr);
_BlaiseFreeMem(Base);
end;
end;
function _StringEquals(S1, S2: Pointer): Integer;