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

fix(codegen): re-assert owning-unit context before impl-section class emission

Browse source 
A class declared in a unit's implementation section (IsImplPrivate) referenced
as a metaclass value in that same unit's initialization block — e.g.
RegisterTest(TFoo) — could be emitted under a bare, unqualified, undefined
typeinfo symbol, linking to garbage and crashing at runtime.

Per-unit codegen sets the symbol-table viewing context (DefineOwningUnit) to the
unit being emitted, so TSymbolTable.Lookup's cross-unit-leak guard does not
suppress the unit's own impl-section types.  But earlier emit passes in EmitUnit
(method-body type resolution that walks the uses chain) leave DefineOwningUnit
pointing at a dependency unit.  By the time the class-data section and the
initialization block are emitted, a metaclass reference to an impl-section class
resolved to nil and ClassSymName/ClassUnitPrefix fell back to the bare class
name.  Only per-unit separate compilation exposed this; whole-program emit-ir
mode kept the context stable, so all fixpoints and the IR harness passed while
the linked binary held a garbage typeinfo pointer.

Re-assert DefineOwningUnit := AUnit.Name immediately before the class-data
section emission and before the initialization-block emission, in both the
native x86-64 and QBE backends.

Add Test{Native,QBE}ImplSectionMetaclassInInit_Runs to cp.test.e2e.sepcompile,
exercising an impl-section class assigned to a class-of global in the unit's own
init on both backends.
This commit is contained in:
Graeme Geldenhuys 2026-06-28 21:25:42 +01:00
parent 02de7b694a
commit 7979f23eb1
3 changed files with 194 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
compiler/src/main/pascal/blaise.codegen.native.x86_64.pas
View file

@ -17361,6 +17361,17 @@ begin
the native main footer; emitted but only init is invoked.) }
if (AUnit.InitStmts <> nil) and (AUnit.InitStmts.Count > 0) then
begin
{ Re-assert THIS unit as the viewing context. Earlier emit passes in this
procedure (method-body type resolution that walks the uses chain) can
leave DefineOwningUnit pointing at a dependency unit; if the init block
references one of THIS unit's own implementation-section (IsImplPrivate)
classes — e.g. a metaclass value passed to a registrar — TSymbolTable.Lookup
would otherwise suppress it as a cross-unit leak and ClassSymName would fall
back to a bare, unqualified, undefined typeinfo symbol (silent link-time
garbage). See the impl-section-class visibility guard in
TSymbolTable.Lookup. }
if FSymTable <> nil then
FSymTable.DefineOwningUnit := AUnit.Name;
FUnitInitNames.Add(NativeMangle(AUnit.Name));
Self.ClearFrame();
FExitLabel := '';
@ -17391,6 +17402,11 @@ begin
UnitSym := AUnit.SymbolTable
else
UnitSym := FSymTable;
{ Re-assert the viewing context (see the init-block note above): the class
section emits unit-qualified typeinfo/vtable/_FieldCleanup names via
ClassSymName, which must resolve THIS unit's own impl-section classes. }
if FSymTable <> nil then
FSymTable.DefineOwningUnit := AUnit.Name;
Self.EmitClassSection(AUnit.IntfBlock.TypeDecls, AUnit.GenericInstances,
UnitSym);
{ Impl-section classes' typeinfo / vtable / _FieldCleanup (generics already

15
compiler/src/main/pascal/blaise.codegen.qbe.pas
View file

@ -14447,6 +14447,11 @@ begin
All require FSymTable to look up resolved TRecordTypeDesc. }
if FSymTable <> nil then
begin
{ Re-assert the viewing context (see the init-block note below): method-body
emission above can leave DefineOwningUnit pointing at a dependency unit,
which would make ClassUnitPrefix emit this unit's own impl-section class
typeinfo/vtable symbols under bare, unqualified names. }
FSymTable.DefineOwningUnit := AUnit.Name;
{ Interface typeinfo blocks }
for I := 0 to AllTD.Count - 1 do
begin
@ -14731,6 +14736,16 @@ begin
{ Initialization section: emit as export function $<Unit>_init() }
if (AUnit.InitStmts <> nil) and (AUnit.InitStmts.Count > 0) then
begin
{ Re-assert THIS unit as the viewing context. Method-body emission above
(type resolution that walks the uses chain) can leave DefineOwningUnit
pointing at a dependency unit; if the init block references one of THIS
unit's own implementation-section (IsImplPrivate) classes — e.g. a
metaclass value passed to a registrar — TSymbolTable.Lookup would
otherwise suppress it as a cross-unit leak and ClassUnitPrefix would fall
back to a bare, unqualified, undefined typeinfo symbol (silent link-time
garbage). }
if FSymTable <> nil then
FSymTable.DefineOwningUnit := AUnit.Name;
FUnitInitNames.Add(AUnit.Name);
EmitLine('');
EmitLine('export function w $' + AUnit.Name + '_init() {');

163
compiler/src/test/pascal/cp.test.e2e.sepcompile.pas
View file

@ -57,6 +57,15 @@ type
alongside IntfBlock ones. }
procedure TestNativeImplSectionClass_Compiles;
procedure TestQBEImplSectionClass_Compiles;
{ Regression: an IMPLEMENTATION-section class referenced as a METACLASS value
(class-of / `TFoo` used as a value) in the unit's OWN initialization block.
Per-unit codegen left DefineOwningUnit pointing at a dependency unit by the
time the init block was emitted, so the impl-section class symbol was
suppressed by Lookup's cross-unit-leak guard and the metaclass ref mangled
to a bare, undefined typeinfo symbol -> link-time garbage -> SIGSEGV.
Both backends. }
procedure TestNativeImplSectionMetaclassInInit_Runs;
procedure TestQBEImplSectionMetaclassInInit_Runs;
{ Regression: a class declared in unit A's IMPLEMENTATION section must NOT
be visible to an unrelated unit B that never `uses` A — it previously
leaked through the flat global scope. }
@ -794,6 +803,160 @@ begin
AssertEquals('use_implclsq stdout', '7' + #10, Captured)
end;
procedure TSepCompileTests.TestNativeImplSectionMetaclassInInit_Runs;
{ The unit's INITIALIZATION block references an impl-section class as a metaclass
value (assigns the class to a `class of` global). Before the
DefineOwningUnit re-assertion fix, per-unit codegen emitted that metaclass ref
under a bare, undefined `typeinfo_<TFoo>` symbol, linking to garbage and
crashing at runtime. Native (default) path. }
const
UnitSrc =
'''
unit ImplMetaN;
interface
function MakeViaMeta: Integer;
implementation
type
TFoo = class
FX: Integer;
constructor Create;
function GetX: Integer;
end;
TFooClass = class of TFoo;
var
GCls: TFooClass;
constructor TFoo.Create;
begin FX := 42 end;
function TFoo.GetX: Integer;
begin Result := FX end;
function MakeViaMeta: Integer;
var F: TFoo;
begin
F := GCls.Create();
Result := F.GetX();
F.Free()
end;
initialization
GCls := TFoo;
end.
''';
ProgSrc =
'''
program UseImplMetaN;
uses ImplMetaN;
begin
WriteLn(MakeViaMeta())
end.
''';
var
UnitPas, ProgPas, ProgBin: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitPas := FScratch + '/ImplMetaN.pas';
ProgPas := FScratch + '/use_implmetan.pas';
ProgBin := FScratch + '/use_implmetan';
WriteFile(UnitPas, UnitSrc);
WriteFile(ProgPas, ProgSrc);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'native',
'--unit-path', FScratch], Captured);
AssertEquals('blaise(use_implmetan) exit code (out: ' + Captured + ')', 0, Rc);
AssertTrue('use_implmetan exists', FileExists(ProgBin));
Rc := RunBinary(ProgBin, Captured);
AssertEquals('use_implmetan exit code', 0, Rc);
AssertEquals('use_implmetan stdout', '42' + #10, Captured)
end;
procedure TSepCompileTests.TestQBEImplSectionMetaclassInInit_Runs;
{ Same as TestNativeImplSectionMetaclassInInit_Runs but forces the QBE backend. }
const
UnitSrc =
'''
unit ImplMetaQ;
interface
function MakeViaMeta: Integer;
implementation
type
TFoo = class
FX: Integer;
constructor Create;
function GetX: Integer;
end;
TFooClass = class of TFoo;
var
GCls: TFooClass;
constructor TFoo.Create;
begin FX := 42 end;
function TFoo.GetX: Integer;
begin Result := FX end;
function MakeViaMeta: Integer;
var F: TFoo;
begin
F := GCls.Create();
Result := F.GetX();
F.Free()
end;
initialization
GCls := TFoo;
end.
''';
ProgSrc =
'''
program UseImplMetaQ;
uses ImplMetaQ;
begin
WriteLn(MakeViaMeta())
end.
''';
var
UnitPas, ProgPas, ProgBin: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitPas := FScratch + '/ImplMetaQ.pas';
ProgPas := FScratch + '/use_implmetaq.pas';
ProgBin := FScratch + '/use_implmetaq';
WriteFile(UnitPas, UnitSrc);
WriteFile(ProgPas, ProgSrc);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'qbe',
'--unit-path', FScratch], Captured);
AssertEquals('blaise(use_implmetaq) exit code (out: ' + Captured + ')', 0, Rc);
AssertTrue('use_implmetaq exists', FileExists(ProgBin));
Rc := RunBinary(ProgBin, Captured);
AssertEquals('use_implmetaq exit code', 0, Rc);
AssertEquals('use_implmetaq stdout', '42' + #10, Captured)
end;
procedure TSepCompileTests.TestImplSectionClass_DoesNotLeakCrossUnit;
{ A class declared in unit A's IMPLEMENTATION section is private to A. A second
unit B that never `uses` A must NOT see it — referencing it must be a compile