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

fix(qbe): refcount dyn-array, interface, and nested-record fields in records

Browse source 
Records with value semantics may contain fields with reference semantics
(String, dynamic array, interface, nested managed record).  The QBE
backend's field walkers only covered the String and Class cases, so:

  * A record whose field is a dynamic array leaked the buffer on every
    copy and return-by-value — _DynArrayAddRef/_DynArrayRelease were not
    invoked from EmitRecordCopy or EmitRecordReleaseFields, and there
    was no scope-exit release for dyn-array locals.
  * A class with a record field whose own fields were managed (String,
    Class, dyn-array, interface, or a deeper record) leaked those
    sub-fields when the class was released — _FieldCleanup_<T> skipped
    record-typed fields entirely.
  * Interface fields inside records were never copied or released.

This commit:

  * Adds _DynArrayAddRef / _DynArrayRelease to blaise_arc.pas alongside
    the existing _StringAddRef/_StringRelease and _ClassAddRef/_ClassRelease.
    They walk the existing [refcount:4][length:4] dyn-array buffer header
    (layout defined by _DynArraySetLength in blaise_str.pas), are nil-safe
    and immortal-safe (rc = -1), and use _AtomicAddInt32 / _AtomicSubInt32
    (lock xadd) so the refcount stays sound under threading — matching the
    other ARC primitives.
  * Extends EmitRecordCopy, EmitRecordReleaseFields, and
    EmitFieldCleanupFn to handle tyDynArray, tyInterface, and nested
    tyRecord fields (the latter by recursing through the shared
    EmitRecordReleaseFields walker).
  * Routes tyDynArray field assignments through the existing IsArc
    path so a field write retains the new buffer and releases the old.
  * Adds tyDynArray to EmitArcCleanup + EmitExcPathArcCleanup so
    dyn-array locals balance their first-assignment retain at scope
    exit (and on exception paths).
  * Adds tyDynArray to EmitAssignment for variable-to-variable
    assignment so b := a between dyn-array vars is refcount-symmetric.

Adds two regression tests in cp.test.e2e.records.pas:

  * TestRun_Record_DynArrayField_ReturnByValue_NoLeak — 5000-iter
    return-by-value of a record with a dyn-array field; asserts the
    buffer contents survive (proves AddRef/Release pairing) and the
    program runs to completion.
  * TestRun_Class_RecordField_NestedClass_FullCleanup — class -> record
    -> class -> record -> class chain with each Create/Destroy bumping
    a global AliveCount; after 100 iterations AliveCount must be 0,
    proving _FieldCleanup recurses through nested record fields.

TestRunner: OK (2663 tests).  Self-bootstrap from a master-built stage-1
through stage-2/3/4 reaches a clean stage-3 == stage-4 IR fixpoint.
This commit is contained in:
Andrew Haines 2026-06-07 20:07:43 -04:00
parent 328493baf2
commit f74e5ccf43
4 changed files with 285 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -2161,6 +2161,8 @@ begin
RelFn := '$_ClassRelease'
else if IsIntf then
RelFn := '$_ClassRelease' { obj slot release; itab is static }
else if Decl.ResolvedType.Kind = tyDynArray then
RelFn := '$_DynArrayRelease'
else if Decl.ResolvedType.Kind = tyRecord then
begin
{ Record local: release each ARC-managed field at scope exit }
@ -2242,6 +2244,8 @@ begin
RelFn := '$_ClassRelease'
else if IsIntf then
RelFn := '$_ClassRelease'
else if Decl.ResolvedType.Kind = tyDynArray then
RelFn := '$_DynArrayRelease'
else if Decl.ResolvedType.Kind = tyRecord then
begin
{ Record local on exception path: release ARC fields }
@ -3968,6 +3972,25 @@ begin
else
EmitLine(Format(' storel %s, %s', [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)]));
end
else if (AAssign.ResolvedLhsType <> nil) and
(AAssign.ResolvedLhsType.Kind = tyDynArray) then
begin
{ Dynamic-array variable assignment: same ARC shape as string. The dyn-array
data pointer carries a refcount in its header, so b := a must retain the
new buffer and release the old before overwriting the slot. }
OldTemp := AllocTemp();
if not AAssign.IsGlobal and IsPromoted(AAssign.Name) then
EmitLine(Format(' %s =l copy %%_var_%s', [OldTemp, AAssign.Name]))
else
EmitLine(Format(' %s =l loadl %s', [OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal)]));
ValTemp := EmitExpr(AAssign.Expr);
EmitLine(Format(' call $_DynArrayAddRef(l %s)', [ValTemp]));
EmitLine(Format(' call $_DynArrayRelease(l %s)', [OldTemp]));
if not AAssign.IsGlobal and IsPromoted(AAssign.Name) then
EmitLine(Format(' %%_var_%s =l copy %s', [AAssign.Name, ValTemp]))
else
EmitLine(Format(' storel %s, %s', [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)]));
end
else if (AAssign.ResolvedLhsType <> nil) and
(AAssign.ResolvedLhsType.Kind = tyClass) and
(AAssign.Expr is TNilLiteral) then
@ -4527,6 +4550,36 @@ begin
EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp]));
EmitLine(Format(' storel %s, %s', [ValTemp, DstField]));
end
else if F.TypeDesc.Kind = tyDynArray then
begin
ValTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [ValTemp, SrcField]));
OldTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [OldTemp, DstField]));
EmitLine(Format(' call $_DynArrayAddRef(l %s)', [ValTemp]));
EmitLine(Format(' call $_DynArrayRelease(l %s)', [OldTemp]));
EmitLine(Format(' storel %s, %s', [ValTemp, DstField]));
end
else if F.TypeDesc.Kind = tyInterface then
begin
{ Interface field: 16-byte fat pointer (obj at +0, itab at +8). Only the
obj slot is refcounted; the itab slot is static rodata. }
ValTemp := AllocTemp(); { src obj }
EmitLine(Format(' %s =l loadl %s', [ValTemp, SrcField]));
OldTemp := AllocTemp(); { dst obj (to release) }
EmitLine(Format(' %s =l loadl %s', [OldTemp, DstField]));
EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp]));
EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp]));
EmitLine(Format(' storel %s, %s', [ValTemp, DstField]));
{ Copy itab slot (src+8 → dst+8). }
ValTemp := AllocTemp();
EmitLine(Format(' %s =l add %s, 8', [ValTemp, SrcField]));
OldTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [OldTemp, ValTemp]));
ValTemp := AllocTemp();
EmitLine(Format(' %s =l add %s, 8', [ValTemp, DstField]));
EmitLine(Format(' storel %s, %s', [OldTemp, ValTemp]));
end
else if F.TypeDesc.Kind = tyRecord then
{ Nested record field: recurse into sub-fields }
Self.EmitRecordCopy(TRecordTypeDesc(F.TypeDesc), DstField, SrcField)
@ -4700,7 +4753,24 @@ begin
begin
F := TFieldInfo(ARec.Fields.Items[I]);
if F.TypeDesc = nil then Continue;
if not (F.TypeDesc.IsString() or (F.TypeDesc.Kind = tyClass)) then Continue;
if F.TypeDesc.Kind = tyRecord then
begin
{ Nested record field: recurse so its managed sub-fields are released.
EmitRecordCopy already recurses on copy — without this, every nested
managed sub-field leaks one ref per copy. }
if F.Offset > 0 then
begin
FldAddr := AllocTemp();
EmitLine(Format(' %s =l add %s, %d', [FldAddr, AAddr, F.Offset]));
end
else
FldAddr := AAddr;
EmitRecordReleaseFields(TRecordTypeDesc(F.TypeDesc), FldAddr);
Continue;
end;
if not (F.TypeDesc.IsString() or (F.TypeDesc.Kind = tyClass)
or (F.TypeDesc.Kind = tyDynArray)
or (F.TypeDesc.Kind = tyInterface)) then Continue;
if F.Offset > 0 then
begin
FldAddr := AllocTemp();
@ -4712,7 +4782,12 @@ begin
EmitLine(Format(' %s =l loadl %s', [ValT, FldAddr]));
if F.TypeDesc.IsString() then
EmitLine(Format(' call $_StringRelease(l %s)', [ValT]))
else if F.TypeDesc.Kind = tyDynArray then
EmitLine(Format(' call $_DynArrayRelease(l %s)', [ValT]))
else
{ tyClass and tyInterface both release the obj slot via _ClassRelease.
For an interface field the itab slot lives at +8 and is static rodata,
so no extra release is needed. }
EmitLine(Format(' call $_ClassRelease(l %s)', [ValT]));
end;
end;
@ -4877,7 +4952,8 @@ begin
end;
IsStr := AAssign.FieldInfo.TypeDesc.IsString();
IsArc := IsStr or (AAssign.FieldInfo.TypeDesc.Kind = tyClass);
IsArc := IsStr or (AAssign.FieldInfo.TypeDesc.Kind = tyClass)
or (AAssign.FieldInfo.TypeDesc.Kind = tyDynArray);
if AAssign.FieldInfo.IsUnretained and (AAssign.FieldInfo.TypeDesc.Kind = tyClass) then
begin
{ Unretained class field: non-owning — store the pointer with no addref
@ -4904,6 +4980,11 @@ begin
EmitLine(Format(' call $_StringAddRef(l %s)', [ValTemp]));
EmitLine(Format(' call $_StringRelease(l %s)', [OldTemp]));
end
else if AAssign.FieldInfo.TypeDesc.Kind = tyDynArray then
begin
EmitLine(Format(' call $_DynArrayAddRef(l %s)', [ValTemp]));
EmitLine(Format(' call $_DynArrayRelease(l %s)', [OldTemp]));
end
else
begin
EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp]));
@ -6192,7 +6273,24 @@ begin
begin
F := TFieldInfo(ARec.Fields.Items[I]);
if F.TypeDesc = nil then Continue;
if not (F.TypeDesc.IsString() or (F.TypeDesc.Kind = tyClass)) then
{ Nested record field: delegate to the shared per-field walker so its
managed sub-fields (strings, classes, dyn-arrays, interfaces, deeper
records) are released too. }
if F.TypeDesc.Kind = tyRecord then
begin
if F.Offset > 0 then
begin
PtrT := AllocTemp();
EmitLine(Format(' %s =l add %%self, %d', [PtrT, F.Offset]));
end
else
PtrT := '%self';
EmitRecordReleaseFields(TRecordTypeDesc(F.TypeDesc), PtrT);
Continue;
end;
if not (F.TypeDesc.IsString() or (F.TypeDesc.Kind = tyClass)
or (F.TypeDesc.Kind = tyDynArray)
or (F.TypeDesc.Kind = tyInterface)) then
Continue;
{ Unretained class field: non-owning — nothing to release or clear. }
if F.IsUnretained and (F.TypeDesc.Kind = tyClass) then
@ -6215,7 +6313,11 @@ begin
EmitLine(Format(' %s =l loadl %s', [Temp, PtrT]));
if F.TypeDesc.IsString() then
EmitLine(Format(' call $_StringRelease(l %s)', [Temp]))
else if F.TypeDesc.Kind = tyDynArray then
EmitLine(Format(' call $_DynArrayRelease(l %s)', [Temp]))
else
{ tyClass and tyInterface both release the obj slot via _ClassRelease;
an interface's itab slot is static rodata so no release is needed. }
EmitLine(Format(' call $_ClassRelease(l %s)', [Temp]));
EmitLine(Format(' storel 0, %s', [PtrT]));
end;

143
compiler/src/test/pascal/cp.test.e2e.records.pas
View file

@ -36,6 +36,8 @@ type
procedure TestRun_Record_StmtMethodCall_Result;
procedure TestRun_Record_AddrOfImplicitSelf;
procedure TestRun_Record_PointerDerefFieldAccess;
procedure TestRun_Record_DynArrayField_ReturnByValue_NoLeak;
procedure TestRun_Class_RecordField_NestedClass_FullCleanup;
end;
implementation
@ -318,6 +320,125 @@ const
end.
''';
{ Regression: a record whose field is a dynamic array, returned by value
in a loop. Before the dyn-array ARC fix, every iteration leaked the
array buffer because EmitRecordCopy/EmitRecordReleaseFields did not
refcount tyDynArray fields. After the fix, the per-iter delta is one
AddRef + one Release on the buffer header — net zero — and the final
assertion of the buffer contents proves the data was not freed under
the function's feet. }
{ Regression: a class whose field is a record whose field is another class
whose field is another record whose field is a leaf class. Each Create
increments a global AliveCount; each Destroy decrements it. After the
outermost instance is released, AliveCount must be 0 — proving that
_FieldCleanup for a class with a record field recurses through that
record's class sub-fields all the way down.
Before the fix, _FieldCleanup_<T> skipped record-typed fields entirely,
so the chain leaked TMid and TLeaf instances every iteration. }
SrcClassRecordFieldNestedCleanup = '''
program P;
type
TLeaf = class
Tag: Integer;
constructor Create();
destructor Destroy(); override;
end;
TMidRec = record
Leaf: TLeaf;
Extra: Integer;
end;
TMid = class
Inner: TMidRec;
constructor Create();
destructor Destroy(); override;
end;
TOuterRec = record
Mid: TMid;
Note: Integer;
end;
TOuter = class
Wrap: TOuterRec;
constructor Create();
destructor Destroy(); override;
end;
var
AliveCount: Integer;
constructor TLeaf.Create();
begin
AliveCount := AliveCount + 1;
Self.Tag := 1
end;
destructor TLeaf.Destroy();
begin
AliveCount := AliveCount - 1
end;
constructor TMid.Create();
begin
AliveCount := AliveCount + 1;
Self.Inner.Leaf := TLeaf.Create();
Self.Inner.Extra := 7
end;
destructor TMid.Destroy();
begin
AliveCount := AliveCount - 1
end;
constructor TOuter.Create();
begin
AliveCount := AliveCount + 1;
Self.Wrap.Mid := TMid.Create();
Self.Wrap.Note := 99
end;
destructor TOuter.Destroy();
begin
AliveCount := AliveCount - 1
end;
procedure RunOnce();
var
O: TOuter;
begin
O := TOuter.Create();
if O.Wrap.Mid.Inner.Leaf.Tag <> 1 then
WriteLn('chain broken')
end;
var
i: Integer;
begin
AliveCount := 0;
for i := 0 to 99 do
RunOnce();
WriteLn(AliveCount)
end.
''';
SrcRecordDynArrayReturnByValueNoLeak = '''
program P;
type
TBuf = record
Arr: array of Integer;
end;
function MakeBuf: TBuf;
var
tmp: TBuf;
a: array of Integer;
begin
SetLength(a, 8);
a[0] := 1;
a[7] := 70;
tmp.Arr := a;
Result := tmp
end;
var
i: Integer;
r: TBuf;
begin
for i := 0 to 4999 do
r := MakeBuf();
WriteLn(r.Arr[0]);
WriteLn(r.Arr[7])
end.
''';
SrcRecordNestedFieldAssignMethodCall = '''
program P;
type
@ -464,6 +585,28 @@ begin
AssertRunsOnBoth(SrcRecordPointerDerefFieldAccess, '42' + LE + '99' + LE, 0);
end;
procedure TE2ERecordsTests.TestRun_Class_RecordField_NestedClass_FullCleanup;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run',
CompileAndRun(SrcClassRecordFieldNestedCleanup, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('all 3 layers fully released across 100 iterations',
'0' + LE, Output);
end;
procedure TE2ERecordsTests.TestRun_Record_DynArrayField_ReturnByValue_NoLeak;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run',
CompileAndRun(SrcRecordDynArrayReturnByValueNoLeak, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('first and last element survive 5000 iterations',
'1' + LE + '70' + LE, Output);
end;
initialization
RegisterTest(TE2ERecordsTests);

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

@ -42,6 +42,8 @@ type
procedure _StringAddRef(Ptr: Pointer);
procedure _StringRelease(Ptr: Pointer);
procedure _DynArrayAddRef(Ptr: Pointer);
procedure _DynArrayRelease(Ptr: Pointer);
function _StringEquals(S1, S2: Pointer): Integer;
function _StringConcat(S1, S2: Pointer): Pointer;
procedure TObject_Destroy(Self: Pointer);
@ -412,6 +414,38 @@ begin
if OldRC = 1 then _BlaiseFreeMem(Base);
end;
{ Dynamic-array buffer header is [refcount:4][length:4]; data pointer
points at element 0, so the refcount slot lives at Ptr - 8. Layout
is defined by _DynArraySetLength in blaise_str.pas. }
procedure _DynArrayAddRef(Ptr: Pointer);
const
DA_HDR = 8;
var
RC: PInteger;
begin
if Ptr = nil then Exit;
RC := PInteger(Ptr - DA_HDR);
if RC^ = IMMORTAL then Exit;
_AtomicAddInt32(RC, 1);
end;
procedure _DynArrayRelease(Ptr: Pointer);
const
DA_HDR = 8;
var
Base: Pointer;
RC: PInteger;
OldRC: Integer;
begin
if Ptr = nil then Exit;
Base := Ptr - DA_HDR;
RC := PInteger(Base);
if RC^ = IMMORTAL then Exit;
OldRC := _AtomicSubInt32(RC, 1);
if OldRC = 1 then _BlaiseFreeMem(Base);
end;
function _StringEquals(S1, S2: Pointer): Integer;
var
Len1, Len2: Integer;

4
runtime/src/main/pascal/blaise_str.pas
View file

@ -91,7 +91,9 @@ function _Utf8DecodeAt(S: Pointer; Idx: Integer): Int64;
Refcount = -1 marks immortal (statically-allocated).
_DynArraySetLength(OldPtr, NewLen, ElemSize) → new data pointer.
_DynArrayLength(Ptr) → length (0 for nil). }
_DynArrayLength(Ptr) → length (0 for nil).
Refcount helpers (_DynArrayAddRef / _DynArrayRelease) live in
blaise_arc.pas alongside the other ARC primitives. }
function _DynArraySetLength(Ptr: Pointer; NewLen, ElemSize: Integer): Pointer;
function _DynArrayLength(Ptr: Pointer): Integer;