From a9cb4961eaa2aaf929384ea6dba1648eea053bfe Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Wed, 10 Jun 2026 10:23:05 +0100 Subject: [PATCH] feat(debug): extend leak tracking to strings and dynamic arrays MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- .../src/test/pascal/cp.test.e2e.leakcheck.pas | 59 ++++++++++++++++++- runtime/src/main/pascal/blaise_arc.pas | 53 ++++++++++++++--- 2 files changed, 100 insertions(+), 12 deletions(-) diff --git a/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas b/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas index 4b99fb7..1b3e6d0 100644 --- a/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas +++ b/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas @@ -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); diff --git a/runtime/src/main/pascal/blaise_arc.pas b/runtime/src/main/pascal/blaise_arc.pas index a375724..10b8dc7 100644 --- a/runtime/src/main/pascal/blaise_arc.pas +++ b/runtime/src/main/pascal/blaise_arc.pas @@ -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;