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

fix: green the test suite — array-const link collisions and TComponent ARC

Browse source 
Three fixes that were causing six e2e failures:

Local array consts collided at link time. Function/block/unit-level
`const X: array[...] = (...)` were emitted as `export data $X` with no
mangling. The RTL's own `Days` const (rtl.platform.posix.pas) then
clashed with any user program declaring a `Days` const
(`multiple definition of 'Days'`). Local array consts now use a mangled,
file-local label (`__bac_N_Name`): the mangled name is set in semantic
(AnalyseArrayConstDecls -> ResolvedQbeName / ConstArrayQbe), carried to
the bare-ident read path via TIdentExpr.ConstArraySymbol, and emitted as
non-exported `data` so two separately-compiled objects cannot clash.
Class/record consts keep their exported, type-qualified label.

TComponent fought ARC and crashed. The destructor force-Freed children
it held only as raw pointers, while a caller's variable still referenced
them — a use-after-free at scope exit, surfacing as infinite
Destroy->RemoveComponent->ClassRelease recursion. Ownership is now honest
with ARC: FOwner is [Unretained]; AddComponent takes a strong ref via
_ClassAddRef; Destroy releases the owner's hold rather than Freeing, so a
child the caller still holds survives and an unheld child is destroyed;
RemoveComponent only unlinks the slot (the dying child's ref already
reached zero).

Deflaked TestRun_Thread_Terminate_Flag. The worker could finish via its
`I > 1000` break before the main thread's Terminate landed, racing the
printed flag between 0 and 1. The loop now exits only via the terminate
flag (with a high safety cap), so FTerminated is deterministically True.

Unit tests in cp.test.constants.pas updated to assert the mangled,
non-exported label.
This commit is contained in:
Graeme Geldenhuys 2026-06-03 01:49:00 +01:00
parent 576f60d807
commit 6711a6cfdd
7 changed files with 103 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
compiler/src/main/pascal/uAST.pas
View file

@ -86,6 +86,9 @@ type
IsMetaclassRef: Boolean; { set by uSemantic — bare class type identifier used as
metaclass value (typeinfo ptr); codegen emits
$typeinfo_<Name> instead of loading a variable. }
ConstArraySymbol: string; { set by uSemantic — non-empty when this ident resolves
to an array const; the mangled QBE data-label codegen
must reference instead of $Name. }
end;
TFieldAccessExpr = class(TASTExpr)
@ -790,6 +793,11 @@ type
declared set type or the set type inferred from the members' enum. }
IsSet: Boolean;
SetElements: TStringList; { non-nil when IsSet; member ident names }
{ Canonical QBE data-label for an array const, set by uSemantic. Mangled
to a unique symbol so identically-named consts in different scopes (and
RTL-internal consts) do not collide at link time. Empty for non-array
consts. }
ResolvedQbeName: string;
destructor Destroy; override;
end;

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

@ -1874,6 +1874,8 @@ begin
if (CD.ArrayElements = nil) or (CD.ArrayElements.Count = 0) then Exit;
if APrefix <> '' then
Label_ := APrefix + '_' + CD.Name
else if CD.ResolvedQbeName <> '' then
Label_ := CD.ResolvedQbeName
else
Label_ := CD.Name;
IsStrArray := SameText(CD.ArrayElemType, 'string');
@ -1897,7 +1899,16 @@ begin
else
Parts := Parts + Format('w %s', [ElemVal]);
end;
EmitLine(Format('export data $%s = { %s }', [Label_, Parts]));
{ Class/record consts keep an exported, type-qualified label (referenced as
TFoo.Const across the compilation). Block-local and program/unit array
consts use a mangled, file-local label: the mangled name is only unique
within one compilation, so it must NOT be exported — otherwise two
separately-compiled objects (e.g. the RTL and a user program) that each
mint '__bac_1_X' would collide at link time. }
if APrefix <> '' then
EmitLine(Format('export data $%s = { %s }', [Label_, Parts]))
else
EmitLine(Format('data $%s = { %s }', [Label_, Parts]));
end;
procedure TCodeGenQBE.EmitClassConstData(AClassDef: TClassTypeDef; const AClassName: string);
@ -9049,6 +9060,12 @@ begin
else
EmitLine(Format(' %s =w loadw %s', [T, Ptr]));
end
else if TIdentExpr(AExpr).ConstArraySymbol <> '' then
begin
{ Array const referenced bare — its storage is a mangled global data
label (not $Name, which would collide with RTL/other-scope symbols). }
Exit('$' + TIdentExpr(AExpr).ConstArraySymbol);
end
else if (AExpr.ResolvedType <> nil) and
(AExpr.ResolvedType.Kind in [tyRecord, tyStaticArray]) then
begin

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

@ -39,6 +39,7 @@ type
FCurrentClass: TRecordTypeDesc; { class being analysed (set in AnalyseMethodDecl) }
FCurrentLocalBlock: TBlock; { block currently being stmt-analysed; for-in injects synthetic TVarDecl here }
FForInCounter: Integer; { counter for generating unique __forin_N variable names }
FArrayConstCounter: Integer; { counter for generating unique array-const data labels }
FCurrentUnitName: string; { name of the unit/program currently being analysed }
FCurrentEnclosingDecl: TMethodDecl; { the innermost standalone proc/func currently being analysed;
nil at program level. Used to set EnclosingDecl on nested procs. }
@ -70,6 +71,11 @@ type
CD.IntVal and register the const symbol with its tySet type. }
procedure AnalyseSetConstDecl(ACD: TConstDecl);
procedure AnalyseArrayConstDecls(ABlock: TBlock);
{ Mint a unique, link-safe QBE data-label for an array const. The source
name is kept for lookups; this mangled label is what codegen emits and
references so identically-named consts in different scopes (and consts
inside the RTL) never collide at link time. }
function NewArrayConstLabel(const AName: string): string;
function FoldConstBitOpExpr(ATokens: TStringList;
ALine, ACol: Integer): Int64;
procedure AnalyseTypeDecls(ABlock: TBlock);
@ -2293,6 +2299,12 @@ begin
end;
end;
function TSemanticAnalyser.NewArrayConstLabel(const AName: string): string;
begin
Inc(FArrayConstCounter);
Result := Format('__bac_%d_%s', [FArrayConstCounter, AName]);
end;
procedure TSemanticAnalyser.AnalyseArrayConstDecls(ABlock: TBlock);
{ Second-pass constant analysis for array-typed constants.
Called after AnalyseTypeDecls so that enum index types are in scope. }
@ -2358,8 +2370,11 @@ begin
(J < CD.ArrayElements.Count) then
CD.ArrayElements.Put(J, IntToStr(FoldConstBitOpExpr(
TStringList(CD.ArrayElementParts.Items[J]), CD.Line, CD.Col)));
if CD.ResolvedQbeName = '' then
CD.ResolvedQbeName := Self.NewArrayConstLabel(CD.Name);
Sym := TSymbol.Create(CD.Name, skConstant, ArrTD);
Sym.IsGlobal := True;
Sym.ConstArrayQbe := CD.ResolvedQbeName;
Sym.ConstArray := TStringList.Create;
for J := 0 to CD.ArrayElements.Count - 1 do
Sym.ConstArray.Add(CD.ArrayElements[J]);
@ -7078,6 +7093,10 @@ begin
TIdentExpr(AExpr).ConstValue := Sym.ConstValue;
TIdentExpr(AExpr).ConstString := Sym.ConstString;
end;
{ Array const referenced bare: codegen must use the mangled data-label,
not $Name, to avoid link collisions. }
if (Sym.ConstArray <> nil) and (Sym.ConstArrayQbe <> '') then
TIdentExpr(AExpr).ConstArraySymbol := Sym.ConstArrayQbe;
{ Bare class type identifier used as a value: metaclass reference.
The result type is 'class of TFoo'; codegen emits the typeinfo
address. Compatibility with untyped Pointer (so 'Pointer(EError)'

2
compiler/src/main/pascal/uSymbolTable.pas
View file

@ -325,6 +325,8 @@ type
ConstValue: Int64; { valid when Kind = skConstant; integer/bool/enum value }
ConstString: string; { valid when Kind = skConstant and type is tyString }
ConstArray: TStringList; { owned; non-nil for array-typed const; raw element values }
ConstArrayQbe: string; { canonical QBE data-label for an array const; mangled
to avoid collisions across scopes and with the RTL }
IsWeak: Boolean; { true for variables declared [Weak]; codegen
keys off this to emit _WeakAssign instead
of the strong addref/release pattern. }

31
compiler/src/test/pascal/cp.test.constants.pas
View file

@ -997,10 +997,17 @@ begin
end.
''');
AssertTrue('IR non-empty', IR <> '');
AssertTrue('$Days data item emitted',
Pos('data $Days =', IR) >= 0);
AssertTrue('Days[M] reference present',
Pos('add $Days', IR) >= 0);
{ Local array consts get a mangled, file-local data label ('__bac_N_Days')
so they never collide with same-named consts elsewhere or with the RTL.
The label must NOT be exported. }
AssertTrue('mangled Days data item emitted',
Pos('data $__bac_', IR) >= 0);
AssertTrue('Days label suffix present',
Pos('_Days =', IR) >= 0);
AssertTrue('Days array const not exported',
Pos('export data $__bac_', IR) < 0);
AssertTrue('Days[M] reference uses mangled label',
Pos('add $__bac_', IR) >= 0);
end;
procedure TConstTests.TestArrayConst_LocalInProcedure_EmitsDataItem;
@ -1019,8 +1026,12 @@ begin
end.
''');
AssertTrue('IR non-empty', IR <> '');
AssertTrue('$Tbl data item emitted',
Pos('data $Tbl =', IR) >= 0);
AssertTrue('mangled Tbl data item emitted',
Pos('data $__bac_', IR) >= 0);
AssertTrue('Tbl label suffix present',
Pos('_Tbl =', IR) >= 0);
AssertTrue('Tbl array const not exported',
Pos('export data $__bac_', IR) < 0);
end;
procedure TConstTests.TestArrayConst_LocalInMethod_EmitsDataItem;
@ -1048,8 +1059,12 @@ begin
end.
''');
AssertTrue('IR non-empty', IR <> '');
AssertTrue('$Vals data item emitted',
Pos('data $Vals =', IR) >= 0);
AssertTrue('mangled Vals data item emitted',
Pos('data $__bac_', IR) >= 0);
AssertTrue('Vals label suffix present',
Pos('_Vals =', IR) >= 0);
AssertTrue('Vals array const not exported',
Pos('export data $__bac_', IR) < 0);
end;
procedure TConstTests.TestTypedConst_IntegerCast_NegativeSurvives;

7
compiler/src/test/pascal/cp.test.e2e.threading.pas
View file

@ -103,11 +103,16 @@ const
procedure TLoopThread.Execute;
var I: Integer;
begin
{ Spin until terminated. The loop must exit *only* via the terminate
flag so FTerminated is guaranteed True when read — an early-break
escape would let the worker finish before the main thread's Terminate
landed, making the printed flag race between 0 and 1. The large cap is
only a safety net so a missed Terminate cannot hang the test forever. }
I := 0;
while not Self.FTerminated do
begin
I := I + 1;
if I > 1000 then
if I > 2000000000 then
break
end;
WriteLn(Self.FTerminated)

33
stdlib/src/main/pascal/classes.pas
View file

@ -47,7 +47,12 @@ type
TComponent = class
private
FName: string;
FOwner: TComponent;
{ Non-owning back-reference: the owner keeps its children alive (via the
raw FChildren array), not the other way round. A strong ARC ref here
would form an owner<->child cycle and, worse, make the child's field
cleanup release the owner mid-destruction — re-entering the owner's
Destroy and crashing. }
[Unretained] FOwner: TComponent;
FChildren: ^Pointer;
FChildCap: Integer;
FChildCnt: Integer;
@ -195,7 +200,13 @@ begin
Self.GrowChildren;
Slot := Self.FChildren + Self.FChildCnt * SizeOf(Pointer);
Slot^ := Pointer(AComp);
Self.FChildCnt := Self.FChildCnt + 1
Self.FChildCnt := Self.FChildCnt + 1;
{ The owner holds a strong reference to each child: that is what keeps the
child alive for as long as the owner lives and lets the owner free its
children on destruction. The matching release happens in RemoveComponent
and Destroy. FChildren is a raw pointer array, so the ref must be taken
manually here. }
_ClassAddRef(Pointer(AComp))
end;
procedure TComponent.RemoveComponent(AComp: TComponent);
@ -252,19 +263,29 @@ var
Slot: ^Pointer;
Child: TComponent;
begin
{ Free children in reverse order }
{ Release the owner's strong reference to each child in reverse order.
Detaching FOwner first means the child's own Destroy (if this release
takes it to zero) skips the RemoveComponent call-back into this object,
which is already being torn down. Releasing — rather than Free — is what
keeps a child alive that the caller still holds a reference to: the owner
only drops its hold, it does not force destruction. }
while Self.FChildCnt > 0 do
begin
Slot := Self.FChildren + (Self.FChildCnt - 1) * SizeOf(Pointer);
Child := TComponent(Slot^);
Slot^ := nil;
Self.FChildCnt := Self.FChildCnt - 1;
Child.FOwner := nil;
Child.Free
if Child <> nil then
begin
Child.FOwner := nil;
_ClassRelease(Pointer(Child))
end
end;
FreeMem(Self.FChildren);
Self.FChildren := nil;
{ Unregister from owner }
{ Detach from owner so its array does not keep a dangling pointer. This
object's strong ref held by the owner is the one that just reached zero,
so RemoveComponent must only unlink the slot — it must not release again. }
if Self.FOwner <> nil then
Self.FOwner.RemoveComponent(Self)
end;