From f74e5ccf43a7a02aa4c5f9ec3b22e7468067e599 Mon Sep 17 00:00:00 2001 From: Andrew Haines Date: Sun, 7 Jun 2026 20:07:43 -0400 Subject: [PATCH] fix(qbe): refcount dyn-array, interface, and nested-record fields in records MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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_ 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. --- compiler/src/main/pascal/uCodeGenQBE.pas | 108 ++++++++++++- .../src/test/pascal/cp.test.e2e.records.pas | 143 ++++++++++++++++++ runtime/src/main/pascal/blaise_arc.pas | 34 +++++ runtime/src/main/pascal/blaise_str.pas | 4 +- 4 files changed, 285 insertions(+), 4 deletions(-) diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 986168a..cba452d 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.e2e.records.pas b/compiler/src/test/pascal/cp.test.e2e.records.pas index ac7c53a..1ddd8df 100644 --- a/compiler/src/test/pascal/cp.test.e2e.records.pas +++ b/compiler/src/test/pascal/cp.test.e2e.records.pas @@ -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_ 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); diff --git a/runtime/src/main/pascal/blaise_arc.pas b/runtime/src/main/pascal/blaise_arc.pas index baf048c..2ba0335 100644 --- a/runtime/src/main/pascal/blaise_arc.pas +++ b/runtime/src/main/pascal/blaise_arc.pas @@ -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; diff --git a/runtime/src/main/pascal/blaise_str.pas b/runtime/src/main/pascal/blaise_str.pas index 872b5ee..0fc3295 100644 --- a/runtime/src/main/pascal/blaise_str.pas +++ b/runtime/src/main/pascal/blaise_str.pas @@ -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;