From 0a5bc441509b72896f86b749e2e26c11b65167da Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Sat, 6 Jun 2026 10:33:43 +0100 Subject: [PATCH] fix(arc): release old value when assigning nil to a class variable MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Assigning nil to a class-typed variable (O := nil) did not call _ClassRelease on the old value in either backend. The nil literal has ResolvedType.Kind = tyNil which bypassed the tyClass ARC branch in EmitAssignment, falling through to the generic scalar store that performs no reference counting. QBE backend: added a class-nil branch in EmitAssignment that loads the old value, calls _ClassRelease, and stores zero. Handles strong, weak, and promoted-local cases. Native backend: added the same class-nil assignment branch, plus two further fixes: - EmitExprToEax now handles TNilLiteral (emits xorq %rax, %rax) - EmitFieldCleanupFn now emits the destructor call and ARC field releases instead of being an empty stub, bringing it to parity with the QBE backend's FieldCleanup emission. Updated leak-check tests whose leak scenarios relied on the broken nil-assignment behaviour — they now use _ClassAddRef to create genuine unbalanced reference leaks. Updated test count in README (2293 -> 2606). --- README.adoc | 2 +- .../pascal/blaise.codegen.native.x86_64.pas | 85 ++++++++++++++++++- compiler/src/main/pascal/uCodeGenQBE.pas | 21 +++++ compiler/src/test/pascal/cp.test.classes.pas | 25 ++++++ compiler/src/test/pascal/cp.test.e2e.arc.pas | 31 +++++++ .../src/test/pascal/cp.test.e2e.leakcheck.pas | 17 ++-- .../src/test/pascal/cp.test.e2e.native.pas | 26 ++++++ 7 files changed, 192 insertions(+), 15 deletions(-) diff --git a/README.adoc b/README.adoc index 0078412..5ae8ea6 100644 --- a/README.adoc +++ b/README.adoc @@ -38,7 +38,7 @@ https://github.com/graemeg/opdebugger[OPDF] debug format support. == 🚀 Project Status * **Self-Hosting:** Yes. Blaise bootstraps and recompiles itself with byte-for-byte fixpoint. FPC is no longer required — the entire toolchain runs on Blaise alone. -* **Testing:** 2293 tests and growing (Test-Driven Development from day one). The test suite itself compiles under Blaise. +* **Testing:** 2606 tests and growing (Test-Driven Development from day one). The test suite itself compiles under Blaise. * **Backends:** Currently utilising a QBE backend, with an LLVM backend in active development. diff --git a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas index d23c77f..7ed9b3e 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -117,10 +117,8 @@ type { Emit an immortal class-name string blob in the data section and return the label+12 expression that points to the character data. } function EmitClassNameString(const AClassName: string): string; - { Emit the body of one $_FieldCleanup_ function. For classes with - no managed fields this is just a ret; with ARC string/class fields it - would call release helpers (deferred — today all user classes have only - integer fields). } + { Emit the body of one $_FieldCleanup_ function. Calls the + destructor (if any), releases ARC-managed fields, then returns. } procedure EmitFieldCleanupFn(const AMangledName: string; ART: TRecordTypeDesc); { Emit all class method definitions (OwnerTypeName <> ''). } @@ -710,12 +708,68 @@ end; procedure TX86_64Backend.EmitFieldCleanupFn(const AMangledName: string; ART: TRecordTypeDesc); +var + Walk: TRecordTypeDesc; + I: Integer; + F: TFieldInfo; + DestroyName: string; begin Self.Emit('.text'); Self.Emit('.globl _FieldCleanup_' + AMangledName); Self.Emit('_FieldCleanup_' + AMangledName + ':'); Self.Emit(#9'pushq %rbp'); Self.Emit(#9'movq %rsp, %rbp'); + Self.Emit(#9'pushq %rbx'); + Self.Emit(#9'movq %rdi, %rbx'); + if ART <> nil then + begin + Walk := ART; + while Walk <> nil do + begin + if Walk.HasDestroyMethod then + begin + if Walk.DestroyResolvedQbeName <> '' then + DestroyName := NativeMangle(Walk.DestroyResolvedQbeName) + else + DestroyName := NativeMangle(Walk.Name) + '_Destroy'; + Self.Emit(#9'movq %rbx, %rdi'); + Self.Emit(#9'callq ' + DestroyName); + Break; + end; + Walk := Walk.Parent; + end; + for I := 0 to ART.Fields.Count - 1 do + begin + F := TFieldInfo(ART.Fields.Items[I]); + if F.TypeDesc = nil then Continue; + if not (F.TypeDesc.IsString or (F.TypeDesc.Kind = tyClass)) then + Continue; + if F.IsUnretained and (F.TypeDesc.Kind = tyClass) then + Continue; + if F.IsWeak then + begin + if F.Offset > 0 then + Self.Emit(Format(#9'leaq %d(%%rbx), %%rdi', [F.Offset])) + else + Self.Emit(#9'movq %rbx, %rdi'); + Self.Emit(#9'callq _WeakClear'); + Continue; + end; + if F.Offset > 0 then + Self.Emit(Format(#9'movq %d(%%rbx), %%rdi', [F.Offset])) + else + Self.Emit(#9'movq (%rbx), %rdi'); + if F.TypeDesc.IsString then + Self.Emit(#9'callq _StringRelease') + else + Self.Emit(#9'callq _ClassRelease'); + if F.Offset > 0 then + Self.Emit(Format(#9'movq $0, %d(%%rbx)', [F.Offset])) + else + Self.Emit(#9'movq $0, (%rbx)'); + end; + end; + Self.Emit(#9'popq %rbx'); Self.Emit(#9'movq %rbp, %rsp'); Self.Emit(#9'popq %rbp'); Self.Emit(#9'ret'); @@ -2003,6 +2057,12 @@ var Unsigned: Boolean; AOE: TAddrOfExpr; begin + if AExpr is TNilLiteral then + begin + Self.Emit(#9'xorq %rax, %rax'); + Exit; + end; + if AExpr is TIntLiteral then begin { movabsq carries the full 64-bit immediate (32-bit movq sign-extends a @@ -3926,6 +3986,23 @@ begin begin Self.EmitInterfaceAssign(Asgn); end + else if (Asgn.ResolvedLhsType <> nil) and + (Asgn.ResolvedLhsType.Kind = tyClass) and + (Asgn.Expr is TNilLiteral) then + begin + if Self.IsLocal(Asgn.Name) then + Self.Emit(Format(#9'movq %s, %%rdi', [Self.VarOperand(Asgn.Name)])) + else + Self.Emit(Format(#9'movq %s(%%rip), %%rdi', [Asgn.Name])); + Self.Emit(#9'callq _ClassRelease'); + if Self.IsLocal(Asgn.Name) then + Self.Emit(Format(#9'movq $0, %s', [Self.VarOperand(Asgn.Name)])) + else + begin + Self.AddGlobal(Asgn.Name, Asgn.ResolvedLhsType); + Self.Emit(Format(#9'movq $0, %s(%%rip)', [Asgn.Name])); + end; + end else if (Asgn.ResolvedLhsType <> nil) and (Asgn.ResolvedLhsType.Kind = tyClass) then begin diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index fcdcb29..f4f44f0 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -3852,6 +3852,27 @@ begin 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 + begin + if AAssign.IsWeakLhs then + EmitLine(Format(' call $_WeakClear(l %s)', + [VarRef(AAssign.Name, AAssign.IsGlobal)])) + else + begin + 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)])); + EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); + if not AAssign.IsGlobal and IsPromoted(AAssign.Name) then + EmitLine(Format(' %%_var_%s =l copy 0', [AAssign.Name])) + else + EmitLine(Format(' storel 0, %s', [VarRef(AAssign.Name, AAssign.IsGlobal)])); + end; + end else if AAssign.IsWeakLhs and (AAssign.Expr.ResolvedType.Kind = tyClass) then begin { Weak class-typed assignment: bypass the strong refcount entirely. diff --git a/compiler/src/test/pascal/cp.test.classes.pas b/compiler/src/test/pascal/cp.test.classes.pas index 17dd61d..b824252 100644 --- a/compiler/src/test/pascal/cp.test.classes.pas +++ b/compiler/src/test/pascal/cp.test.classes.pas @@ -81,6 +81,7 @@ type { ARC on class variables and fields } { ------------------------------------------------------------------ } procedure TestCodegen_ClassVarAssign_InsertsAddRefRelease; + procedure TestCodegen_ClassVarAssignNil_EmitsRelease; procedure TestCodegen_ClassVarScopeExit_EmitsRelease; procedure TestCodegen_ClassFieldAssign_InsertsAddRefRelease; procedure TestCodegen_FieldCleanup_EmittedPerClass; @@ -882,6 +883,30 @@ begin Pos('call $_ClassRelease', IR) > 0); end; +procedure TClassTests.TestCodegen_ClassVarAssignNil_EmitsRelease; +const + Src = ''' + program P; + type TFoo = class end; + var F: TFoo; + begin + F := TFoo.Create; + F := nil + end. + '''; +var + IR: string; + P1, P2, P3: Integer; +begin + IR := GenIR(Src); + P1 := Pos('call $_ClassRelease', IR); + AssertTrue('1st _ClassRelease (Create assignment)', P1 > 0); + P2 := Pos('call $_ClassRelease', Copy(IR, P1 + 20, MaxInt)); + AssertTrue('2nd _ClassRelease (F := nil must release old value)', P2 > 0); + P3 := Pos('call $_ClassRelease', Copy(IR, P1 + 20 + P2 + 20, MaxInt)); + AssertTrue('3rd _ClassRelease (scope-exit cleanup)', P3 > 0); +end; + procedure TClassTests.TestCodegen_ClassVarScopeExit_EmitsRelease; var IR: string; begin diff --git a/compiler/src/test/pascal/cp.test.e2e.arc.pas b/compiler/src/test/pascal/cp.test.e2e.arc.pas index 843c534..34882b7 100644 --- a/compiler/src/test/pascal/cp.test.e2e.arc.pas +++ b/compiler/src/test/pascal/cp.test.e2e.arc.pas @@ -46,6 +46,7 @@ type dispatching the assignment ARC on the RHS (Pointer) type instead of the LHS (class) slot type. } procedure TestRun_PtrRvalueToClassLocal_PreservesLifetime; + procedure TestRun_ClassVarAssignNil_Destroys; end; implementation @@ -525,6 +526,36 @@ begin '0' + LE + '1' + LE, Output); end; +const + SrcClassAssignNil = ''' + program P; + type + TThing = class + destructor Destroy; override; + end; + destructor TThing.Destroy; + begin + WriteLn('destroyed'); + inherited Destroy + end; + var O: TThing; + begin + O := TThing.Create; + O := nil; + WriteLn('done') + end. + '''; + +procedure TE2EArcTests.TestRun_ClassVarAssignNil_Destroys; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL(SrcClassAssignNil, Output, RCode)); + AssertEquals('exit 0', 0, RCode); + AssertEquals('O := nil triggers destroy', + 'destroyed' + LE + 'done' + LE, Output); +end; + initialization RegisterTest(TE2EArcTests); diff --git a/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas b/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas index 09834de..c9ed2fa 100644 --- a/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas +++ b/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas @@ -120,14 +120,12 @@ const end; var B: TBox; - P: Pointer; begin B := TBox.Create; B.Value := 7; - P := Pointer(B); - B := nil; - { P holds the only reference but is an unmanaged Pointer — ARC never - releases it, so TBox leaks. } + _ClassAddRef(Pointer(B)); + { Artificial extra addref: rc=2. Scope-exit releases B (rc=1), + but the unbalanced addref keeps the object alive — leak. } WriteLn('done') end. '''; @@ -146,14 +144,13 @@ const var A: TAlpha; B: TBeta; - PA, PB: Pointer; begin A := TAlpha.Create; B := TBeta.Create; - PA := Pointer(A); - PB := Pointer(B); - A := nil; - B := nil; + _ClassAddRef(Pointer(A)); + _ClassAddRef(Pointer(B)); + { Artificial extra addref on each: scope-exit releases both + (rc 2->1) but the unbalanced addref keeps them alive. } WriteLn('done') end. '''; diff --git a/compiler/src/test/pascal/cp.test.e2e.native.pas b/compiler/src/test/pascal/cp.test.e2e.native.pas index ac6f6e3..b31752f 100644 --- a/compiler/src/test/pascal/cp.test.e2e.native.pas +++ b/compiler/src/test/pascal/cp.test.e2e.native.pas @@ -173,6 +173,7 @@ type { ARC on class fields } procedure TestRun_Native_ArcClassField_StoreAndRead; procedure TestRun_Native_ArcStringField_StoreAndRead; + procedure TestRun_Native_ArcClassAssignNil_Destroys; { ARC value param retain/release } procedure TestRun_Native_ArcValueParam_String; @@ -2466,6 +2467,25 @@ const end. '''; + SrcArcClassAssignNil = ''' + program P; + type + TThing = class + destructor Destroy; override; + end; + destructor TThing.Destroy; + begin + WriteLn('destroyed'); + inherited Destroy + end; + var O: TThing; + begin + O := TThing.Create; + O := nil; + WriteLn('done') + end. + '''; + SrcArcValueParamString = ''' program P; procedure PrintIt(S: string); @@ -2846,6 +2866,12 @@ begin AssertRunsOnBoth(SrcArcStringField, 'hello' + LE, 0); end; +procedure TE2ENativeTests.TestRun_Native_ArcClassAssignNil_Destroys; +begin + if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end; + AssertRunsOnBoth(SrcArcClassAssignNil, 'destroyed' + LE + 'done' + LE, 0); +end; + procedure TE2ENativeTests.TestRun_Native_ArcValueParam_String; begin if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;