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

codegen: store vtable in constructor calls with arguments

Browse source 
TMethodCallExpr.IsConstructorCall (TypeName.Create with args) was missing
the storel $vtable_X instruction after _ClassAlloc.  The TFieldAccessExpr
path (no-arg Create) already had it.  The missing store left vtable pointer
as zero, causing _IsInstance to crash with null vtable dereference during
type analysis of TTypeDesc subclasses.

Also adds virtual Destroy to TTypeDesc in the hand source so TTypeDesc and
its subclasses (TRecordTypeDesc, TEnumTypeDesc, TInterfaceTypeDesc) get
vtable slots, making HasVTable return true and field offsets correct.

Regression tests added for both the no-arg and with-arg constructor vtable
store paths.
This commit is contained in:
Graeme Geldenhuys 2026-04-25 00:01:12 +01:00
parent 50c746996b
commit f6ac68f537
3 changed files with 68 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -3069,6 +3069,9 @@ begin
SelfTemp := AllocTemp;
EmitLine(Format(' %s =l call $_ClassAlloc(l %d, l $_FieldCleanup_%s)',
[SelfTemp, RT.TotalSize, RT.Name]));
if RT.HasVTable then
EmitLine(Format(' storel $vtable_%s, %s',
[QBEMangle(RT.Name), SelfTemp]));
EmitLine(Format(' call $_ClassAddRef(l %s)', [SelfTemp]));
{ If there's a user-defined Create method, call it }
if MCallExpr.ResolvedMethod <> nil then

50
compiler/src/test/pascal/cp.test.classes.pas
View file

@ -83,6 +83,12 @@ type
procedure TestCodegen_ClassFieldAssign_InsertsAddRefRelease;
procedure TestCodegen_FieldCleanup_EmittedPerClass;
procedure TestCodegen_FieldCleanup_ReleasesClassField;
{ ------------------------------------------------------------------ }
{ vtable initialisation }
{ ------------------------------------------------------------------ }
procedure TestCodegen_Constructor_NoArgs_StoresVTable;
procedure TestCodegen_Constructor_WithArgs_StoresVTable;
end;
implementation
@ -795,6 +801,50 @@ begin
Pos('call $_ClassRelease', OuterBody) > 0);
end;
procedure TClassTests.TestCodegen_Constructor_NoArgs_StoresVTable;
var IR: string;
begin
{ TFoo.Create (no args) — goes through TFieldAccessExpr.IsConstructorCall.
A class with a virtual method must get its vtable pointer stored at
offset 0 immediately after _ClassAlloc. }
IR := GenIR(
'program P;' + LineEnding +
'type' + LineEnding +
' TFoo = class' + LineEnding +
' procedure Done; virtual;' + LineEnding +
' end;' + LineEnding +
'procedure TFoo.Done; begin end;' + LineEnding +
'var F: TFoo;' + LineEnding +
'begin' + LineEnding +
' F := TFoo.Create' + LineEnding +
'end.');
AssertTrue('no-arg ctor stores vtable', Pos('storel $vtable_TFoo', IR) > 0);
end;
procedure TClassTests.TestCodegen_Constructor_WithArgs_StoresVTable;
var IR: string;
begin
{ TFoo.Create(N) (args) — goes through TMethodCallExpr.IsConstructorCall.
The vtable pointer must still be stored at offset 0 even when a
user-defined Create method is called with arguments. }
IR := GenIR(
'program P;' + LineEnding +
'type' + LineEnding +
' TFoo = class' + LineEnding +
' FN: Integer;' + LineEnding +
' procedure Create(N: Integer);' + LineEnding +
' procedure Done; virtual;' + LineEnding +
' end;' + LineEnding +
'procedure TFoo.Create(N: Integer);' + LineEnding +
'begin FN := N end;' + LineEnding +
'procedure TFoo.Done; begin end;' + LineEnding +
'var F: TFoo;' + LineEnding +
'begin' + LineEnding +
' F := TFoo.Create(42)' + LineEnding +
'end.');
AssertTrue('with-arg ctor stores vtable', Pos('storel $vtable_TFoo', IR) > 0);
end;
initialization
RegisterTest(TClassTests);

23
tests/blaise-compiler.pas
View file

@ -1605,10 +1605,12 @@ type
function IsString: Boolean;
function IsOrdinal: Boolean;
function IsRecord: Boolean;
function ByteSize: Integer;
function AllocAlign: Integer;
procedure Destroy; virtual;
end;
@ -1623,10 +1625,10 @@ type
TEnumTypeDesc = class(TTypeDesc)
Members: TStringList;
Members: TStringList;
procedure Create(const AName: string);
procedure Destroy;
function OrdinalOf(const AMember: string): Integer;
procedure Destroy; override;
function OrdinalOf(const AMember: string): Integer;
end;
@ -1670,7 +1672,7 @@ type
FHasDestroyMethod: Boolean;
procedure Create(const AName: string; AKind: TTypeKind);
procedure Destroy;
procedure Destroy; override;
procedure AddField(const AName: string; AType: TTypeDesc);
function FindField(const AName: string): TFieldInfo;
function TotalSize: Integer;
@ -1708,7 +1710,7 @@ type
FParent: TInterfaceTypeDesc;
procedure Create(const AName: string);
procedure Destroy;
procedure Destroy; override;
procedure AddMethod(const AName: string;
const AReturnTypeName: string);
function HasMethod(const AName: string): Boolean;
@ -1893,7 +1895,7 @@ function TTypeDesc.AllocAlign: Integer;
begin
case Kind of
tyInteger, tyUInt32, tyEnum: Result := 4;
tyByte, tyBoolean: Result := 4;
tyByte, tyBoolean: Result := 4;
tyInt64, tyString: Result := 8;
tyRecord: Result := TRecordTypeDesc(Self).MaxAlign;
else
@ -1901,6 +1903,9 @@ begin
end;
end;
procedure TTypeDesc.Destroy;
begin
end;
@ -11547,6 +11552,8 @@ begin
begin
SelfTemp := AllocTemp;
EmitLine(Format(' %s =l call $_ClassAlloc(l %d, l $_FieldCleanup_%s)', SelfTemp, RT.TotalSize, RT.Name));
if RT.HasVTable then
EmitLine(Format(' storel $vtable_%s, %s', QBEMangle(RT.Name), SelfTemp));
EmitLine(Format(' call $_ClassAddRef(l %s)', SelfTemp));
if MCallExpr.ResolvedMethod <> nil then