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

feat(codegen): expand typeinfo with totalsize, fieldcleanup, vtable

Browse source 
Step 11e foundation.  Class typeinfo data blocks now carry three new
l-slots after the existing { parent, impllist, name, methods } prefix:

  Slot 4 (offset 32): total instance size in bytes (vptr + fields)
  Slot 5 (offset 40): pointer to $_FieldCleanup_<T> for this class
  Slot 6 (offset 48): pointer to $vtable_<T> for this class

These are the inputs needed by the upcoming _ClassCreate(TInfo) RTL
helper to allocate, install the vtable, and arrange ARC field cleanup
on release — the runtime equivalent of the inline lowering
EmitConstructorCall produces for the static 'TFoo.Create' form.

TObject also gets a vtable stub ($vtable_TObject = { l $typeinfo_TObject,
l $TObject_Destroy, l $TObject_ToString }) and an empty no-op
$_FieldCleanup_TObject function so its typeinfo can name them.  Both
were previously unemitted because TObject is built-in, not a user
type declaration; the new typeinfo slots force them to be real
linker-visible symbols.

Tests pinning the old four-slot layout updated to assert on the
prefix rather than the full record:
  cp.test.publishedrtti — TestCodegen_TypeInfo_HasFourSlots,
                          TestCodegen_NoPublishedMethods_MethodsSlotZero,
                          TestCodegen_PublishedMethods_TableEmitted
  cp.test.typetests    — TestCodegen_TypeInfo_ParentPtr_IsZero_ForRoot,
                          TestCodegen_TypeInfo_ParentPtr_ForDerived
  cp.test.interfaces   — TestCodegen_Typeinfo_ClassHasImpllistField

All 1235 tests pass.  testbcl smoke driver still green.
This commit is contained in:
Graeme Geldenhuys 2026-05-06 00:57:20 +01:00
parent bee768f290
commit 58ff2a429c
4 changed files with 56 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -2900,21 +2900,32 @@ begin
end;
procedure TCodeGenQBE.EmitTypeInfoDefs(AProg: TProgram);
{ Emit one $typeinfo_T data item per class type.
Layout: { l parent, l impllist, l name, l methods }
{ Emit one $typeinfo_T data item per class type. Each typeinfo data
block has 7 l-slots, in order:
Slot 0 (offset 0): parent typeinfo pointer (0 = root)
Slot 1 (offset 8): impllist pointer (0 = no interfaces)
Slot 2 (offset 16): pointer to class name string literal
Slot 3 (offset 24): pointer to published-method table (0 = none)
Table layout: { l count, [l name, l addr] x count }.
TObject.MethodAddress walks vtable[0]→typeinfo→
slot 3, then climbs the parent chain.
Table holds count followed by (name, code) pairs.
TObject.MethodAddress walks vtable[0] -> typeinfo
-> slot 3, then climbs the parent chain.
Slot 4 (offset 32): total instance size in bytes (vptr + fields)
Slot 5 (offset 40): pointer to $_FieldCleanup_<T> for this class
Slot 6 (offset 48): pointer to $vtable_<T> for this class
Slots 4-6 are read by _ClassCreate(TInfo) to allocate, install the
vtable, and arrange for ARC field cleanup on release — the runtime
equivalent of the inline lowering EmitConstructorCall produces for
the static 'TFoo.Create' form.
TObject is the built-in root class; any user class with an explicit
class(TObject, IFoo) parent list resolves Parent to TObject's
TRecordTypeDesc, so we emit a typeinfo stub for TObject unconditionally
to satisfy the linker. Its parent slot is nil and its impllist slot
is nil because TObject implements no interfaces. }
is nil because TObject implements no interfaces. TObject also gets
a vtable stub and an empty field-cleanup function so its typeinfo
can name them. }
var
I, J, PubCount: Integer;
TD: TTypeDecl;
@ -2930,7 +2941,8 @@ var
MethLine: string;
begin
EmitLine('data $typeinfo_TObject = { l 0, l 0, l ' +
EmitClassNameRef('TObject') + ', l 0 }');
EmitClassNameRef('TObject') + ', l 0' +
', l 8, l $_FieldCleanup_TObject, l $vtable_TObject }');
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
begin
@ -2977,7 +2989,10 @@ begin
EmitLine('data $typeinfo_' + TD.Name +
' = { l ' + ParentStr + ', l ' + ImplStr +
', l ' + EmitClassNameRef(TD.Name) +
', l ' + MethStr + ' }');
', l ' + MethStr +
', l ' + IntToStr(RT.TotalSize) +
', l $_FieldCleanup_' + TD.Name +
', l $vtable_' + TD.Name + ' }');
end;
{ Generic instances — no published-method table emission yet (the
@ -2994,7 +3009,10 @@ begin
ParentStr := '0';
ImplStr := '0';
EmitLine('data $typeinfo_' + MName + ' = { l ' + ParentStr + ', l ' + ImplStr +
', l ' + EmitClassNameRef(GI.TypeName) + ', l 0 }');
', l ' + EmitClassNameRef(GI.TypeName) + ', l 0' +
', l ' + IntToStr(RT.TotalSize) +
', l $_FieldCleanup_' + MName +
', l $vtable_' + MName + ' }');
end;
EmitLine('');
@ -3002,7 +3020,9 @@ end;
procedure TCodeGenQBE.EmitVTableDefs(AProg: TProgram);
{ Vtable layout: slot 0 = $typeinfo_T pointer, slots 1..N = virtual method ptrs.
Dispatch uses (VTableSlot + 1) * 8 to skip the typeinfo slot. }
Dispatch uses (VTableSlot + 1) * 8 to skip the typeinfo slot.
TObject's vtable carries Destroy and ToString — referenced by every
user class through inheritance and by the typeinfo's vtable slot. }
var
I, S: Integer;
TD: TTypeDecl;
@ -3013,6 +3033,8 @@ var
Line: string;
MName: string;
begin
EmitLine('data $vtable_TObject = { l $typeinfo_TObject' +
', l $TObject_Destroy, l $TObject_ToString }');
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
@ -3202,7 +3224,9 @@ end;
procedure TCodeGenQBE.EmitFieldCleanupDefs(AProg: TProgram);
{ Emit a _FieldCleanup_<T> function for every declared class and every
generic class instantiation. The constructor lowering references these
functions by name; see the _ClassAlloc call in EmitExpr. }
functions by name; see the _ClassAlloc call in EmitExpr.
TObject also gets a no-op stub so the typeinfo's fieldcleanup slot
can name a real symbol — needed by _ClassCreate's runtime path. }
var
I: Integer;
TD: TTypeDecl;
@ -3210,6 +3234,11 @@ var
RT: TRecordTypeDesc;
GI: TGenericInstance;
begin
EmitLine('function $_FieldCleanup_TObject(l %self) {');
EmitLine('@start');
EmitLine(' ret');
EmitLine('}');
EmitLine('');
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);

5
compiler/src/test/pascal/cp.test.interfaces.pas
View file

@ -587,9 +587,10 @@ var
IR: string;
begin
IR := GenIR(SrcClassImplements);
{ Class with implements: parent, impllist, nameptr, methods. }
{ Class with implements: parent, impllist, nameptr, methods, then
totalsize/fieldcleanup/vtable (Step 11e). }
AssertTrue('TFoo typeinfo has impllist field',
Pos('$typeinfo_TFoo = { l $typeinfo_TObject, l $impllist_TFoo, l $__cn_TFoo + 12, l 0 }', IR) > 0);
Pos('$typeinfo_TFoo = { l $typeinfo_TObject, l $impllist_TFoo, l $__cn_TFoo + 12, l 0,', IR) > 0);
end;
procedure TInterfaceTests.TestCodegen_Impllist_Emitted;

12
compiler/src/test/pascal/cp.test.publishedrtti.pas
View file

@ -314,9 +314,13 @@ const
'begin end.';
var IR: string;
begin
{ Layout: parent, impllist, name, methods, totalsize, fieldcleanup, vtable.
The first four slots remain unchanged from Step 11b; the trailing
three were added in Step 11e to support runtime ClassCreate. }
IR := GenIR(Src);
AssertTrue('typeinfo emits four l-slots',
Pos('$typeinfo_TFoo = { l $typeinfo_TObject, l 0, l $__cn_TFoo + 12, l 0 }', IR) > 0);
AssertTrue('typeinfo emits seven l-slots, first four unchanged',
Pos('$typeinfo_TFoo = { l $typeinfo_TObject, l 0, l $__cn_TFoo + 12, l 0' +
', l 8, l $_FieldCleanup_TFoo, l $vtable_TFoo }', IR) > 0);
end;
procedure TPublishedRTTITests.TestCodegen_NoPublishedMethods_MethodsSlotZero;
@ -334,7 +338,7 @@ var IR: string;
begin
IR := GenIR(Src);
AssertTrue('typeinfo methods slot is 0 when no published methods',
Pos('$typeinfo_TFoo = { l $typeinfo_TObject, l 0, l $__cn_TFoo + 12, l 0 }', IR) > 0);
Pos('$typeinfo_TFoo = { l $typeinfo_TObject, l 0, l $__cn_TFoo + 12, l 0,', IR) > 0);
AssertEquals('no methods table emitted', 0, Pos('$methods_TFoo', IR));
end;
@ -354,7 +358,7 @@ begin
IR := GenIR(Src);
AssertTrue('methods table emitted', Pos('$methods_TFoo', IR) > 0);
AssertTrue('typeinfo points at methods table',
Pos(', l $methods_TFoo }', IR) > 0);
Pos(', l $methods_TFoo,', IR) > 0);
end;
procedure TPublishedRTTITests.TestCodegen_PublishedMethods_TableCount;

9
compiler/src/test/pascal/cp.test.typetests.pas
View file

@ -336,20 +336,21 @@ end;
procedure TTypeTestTests.TestCodegen_TypeInfo_ParentPtr_IsZero_ForRoot;
var IR: string;
begin
{ Root class (no parent): parent=0, impllist=0, nameptr=&ClassName, methods=0. }
{ Root class (no parent): parent=0, impllist=0, nameptr=&ClassName,
methods=0, then totalsize/fieldcleanup/vtable (Step 11e). }
IR := GenIR(SrcBase);
AssertTrue('root typeinfo has zero parent ptr',
Pos('$typeinfo_TAnimal = { l 0, l 0, l $__cn_TAnimal + 12, l 0 }', IR) > 0);
Pos('$typeinfo_TAnimal = { l 0, l 0, l $__cn_TAnimal + 12, l 0,', IR) > 0);
end;
procedure TTypeTestTests.TestCodegen_TypeInfo_ParentPtr_ForDerived;
var IR: string;
begin
{ Derived class typeinfo: parent=$typeinfo_TAnimal, impllist=0,
nameptr=&ClassName, methods=0. }
nameptr=&ClassName, methods=0, then size/cleanup/vtable. }
IR := GenIR(SrcInherit);
AssertTrue('derived typeinfo refs parent',
Pos('$typeinfo_TDog = { l $typeinfo_TAnimal, l 0, l $__cn_TDog + 12, l 0 }', IR) > 0);
Pos('$typeinfo_TDog = { l $typeinfo_TAnimal, l 0, l $__cn_TDog + 12, l 0,', IR) > 0);
end;
procedure TTypeTestTests.TestCodegen_Vtable_StartsWithTypeInfo;