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;