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

fix(arc): propagate IsUnretained/IsWeak flags during field inheritance

Browse source 
When a child class inherits fields from its parent, the field loop in
both AnalyseTypeDecls and InstantiateGeneric copied Name and TypeDesc
but dropped IsUnretained and IsWeak flags.  This caused _FieldCleanup
in child classes to emit _ClassRelease calls for inherited [Unretained]
fields, releasing references the child does not own — a use-after-free
when the shared reference (e.g. a symbol-table type cache) is still
live elsewhere.

Fix both inheritance sites to copy the flags after AddField.  Add a
regression test that asserts TChild's _FieldCleanup contains exactly
one _ClassRelease (for the owned field) and not two.
This commit is contained in:
Graeme Geldenhuys 2026-06-10 01:44:15 +01:00
parent b7e82d6ffb
commit d00323e0b2
2 changed files with 48 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
compiler/src/main/pascal/uSemantic.pas
View file

@ -1917,6 +1917,7 @@ var
IntfDesc: TInterfaceTypeDesc;
ParentSym: TSymbol;
ParentRT: TRecordTypeDesc;
FldInfo: TFieldInfo;
begin
Result := nil;
@ -2061,9 +2062,12 @@ begin
RT.Parent := ParentRT;
RT.CopyVTableFrom(ParentRT);
for K := 0 to ParentRT.Fields.Count - 1 do
RT.AddField(
TFieldInfo(ParentRT.Fields.Items[K]).Name,
TFieldInfo(ParentRT.Fields.Items[K]).TypeDesc);
begin
FldInfo := TFieldInfo(ParentRT.Fields.Items[K]);
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
RT.FindField(FldInfo.Name).IsUnretained := FldInfo.IsUnretained;
RT.FindField(FldInfo.Name).IsWeak := FldInfo.IsWeak;
end;
end;
end
else if not SameText(ATypeName, 'TObject') then
@ -3416,6 +3420,8 @@ begin
begin
FldInfo := TFieldInfo(ParentRT.Fields.Items[K]);
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
RT.FindField(FldInfo.Name).IsUnretained := FldInfo.IsUnretained;
RT.FindField(FldInfo.Name).IsWeak := FldInfo.IsWeak;
end;
end;
end;

39
compiler/src/test/pascal/cp.test.weakref.pas
View file

@ -78,6 +78,7 @@ type
procedure TestCodegen_UnretainedField_NoWeakAssign;
procedure TestCodegen_UnretainedField_CleanupDoesNotRelease;
procedure TestCodegen_UnretainedField_ReleasesOwnedRHS;
procedure TestCodegen_UnretainedField_InheritedCleanupDoesNotRelease;
end;
implementation
@ -649,6 +650,44 @@ begin
Pos('_ClassRelease', Body) > 0);
end;
procedure TWeakRefTests.TestCodegen_UnretainedField_InheritedCleanupDoesNotRelease;
var
IR, Cleanup: string;
P0, P1: Integer;
begin
IR := GenIR(
'''
program P;
type
TTarget = class end;
TBase = class
[Unretained] FRef: TTarget;
end;
TChild = class(TBase)
FOwned: TTarget;
end;
var C: TChild;
begin
C := TChild.Create()
end.
''');
P0 := Pos('function $_FieldCleanup_TChild', IR);
AssertTrue('_FieldCleanup_TChild present', P0 > 0);
Cleanup := Copy(IR, P0, 400);
P1 := Pos('}', Cleanup);
if P1 > 0 then Cleanup := Copy(Cleanup, 0, P1);
{ FOwned is a regular class field and must be released. }
AssertTrue('owned field is released',
Pos('_ClassRelease', Cleanup) > 0);
{ But there must be exactly ONE _ClassRelease — the inherited
[Unretained] FRef must NOT be released. Two releases would mean
the unretained flag was lost during inheritance. }
P0 := Pos('_ClassRelease', Cleanup);
P1 := Pos('_ClassRelease', Copy(Cleanup, P0 + 13, Length(Cleanup)));
AssertTrue('inherited [Unretained] field must not be released (only one release)',
P1 < 0);
end;
initialization
RegisterTest(TWeakRefTests);