fix(codegen): interface-typed static var store via static methods

A static var of interface type round-tripped through static methods
(THolder.SetIt(X: IThing) / THolder.GetIt: IThing) was miscompiled on
both backends. The 2-slot fat-pointer global slot itself was correct;
the bugs were in the static-CALL path.

QBE: a static method whose first parameter is interface-typed emitted
'call $T_M(, l obj, l itab)'. The interface argument fragment carries a
leading ', ' (it is normally appended after Self or a preceding arg), and
the static-call argument loop did not strip it, so the first argument
began with a comma and QBE rejected it as an invalid class specifier.
Strip the leading ', ' in that branch, matching the existing
EmitMethodCall var-arg/interface precedent.

Native: a static method returning an interface routed through
EmitClassIntfSretMethodCall (ResolvedClassType is the owning class, a
class type), which loaded the bare type name as a global Self and emitted
an undefined reference to the class symbol at external-cc link time (the
internal/driver linker masked it). Add an IsStaticCall branch that emits
the plain free-function interface-sret ABI with no receiver, mirroring
the non-Self arm of EmitIntfSretCall.

Tests: TestIR_StaticCall_InterfaceArg_NoLeadingComma asserts the QBE call
has no leading comma; TestRun_StaticVar_InterfaceStore compiles and runs
the SetIt/GetIt round-trip on both backends.
This commit is contained in:
Graeme Geldenhuys 2026-06-29 01:01:25 +01:00
parent ceb566ed0f
commit e950814a34
4 changed files with 165 additions and 2 deletions

View file

@ -16276,6 +16276,62 @@ begin
'native backend: class sret interface call has no ResolvedMethod (' +
ACall.Name + ')');
Sym := MethodEmitNameNative(MD, MD.OwnerTypeName, ACall.Name);
{ Static method returning an interface (TypeName.GetIt: IFoo): there is NO
receiver, so the call follows the plain free-function interface-sret ABI
sret buffer in %rdi, user args from %rsi (base 1), and a direct callq to the
mangled static symbol. Without this branch the code below would treat the
bare TypeName (ACall.ObjectName) as a global Self and emit a load of an
undefined `TypeName` symbol. Mirrors the non-Self `else` arm of
EmitIntfSretCall. }
if ACall.IsStaticCall then
begin
Sym := MethodEmitNameNative(MD,
TRecordTypeDesc(ACall.ResolvedClassType).Name, ACall.Name);
UserSlots := Self.CountArgSlots(MD.Params);
HD := TList<Integer>.Create();
HK := TList<Integer>.Create();
HTotal := Self.EmitArgHoist(MD.Params, nil, True, '', ACall.Args, HD, HK);
Self.Emit(#9'subq $16, %rsp');
Self.Emit(#9'movq $0, (%rsp)');
Self.Emit(#9'movq $0, 8(%rsp)');
Pushed := 0;
for I := 0 to ACall.Args.Count - 1 do
begin
Par := TMethodParam(MD.Params.Items[I]);
Arg := TASTExpr(ACall.Args.Items[I]);
if HK.Get(I) >= akRecCall then
begin
Self.Emit(Format(#9'movq %d(%%rsp), %%rax',
[16 + HTotal - HD.Get(I) + Pushed]));
Self.Emit(#9'pushq %rax');
Pushed := Pushed + 8;
end
else
begin
Self.EmitMethodArgPush(Par, Arg);
if Par.IsOpenArray or
((Par.ResolvedType <> nil) and (Par.ResolvedType.Kind = tyInterface)) then
Pushed := Pushed + 16
else
Pushed := Pushed + 8;
end;
end;
{ Base 1: %rdi = sret buffer, user args from %rsi; no Self register. }
OverflowBytes := Self.EmitSretRegArgs(UserSlots, 1);
Self.Emit(#9'movq %rsp, %rdi');
if OverflowBytes > 0 then
Self.Emit(Format(#9'addq $%d, %%rdi', [OverflowBytes]));
Self.Emit(#9'callq ' + Sym);
if OverflowBytes > 0 then
Self.Emit(Format(#9'addq $%d, %%rsp', [OverflowBytes]));
Self.EmitHoistEpilogue(ACall.Args, HD, HK, HTotal, 16, False);
Self.EmitSretBufferSlideDown(HTotal);
HD.Free();
HK.Free();
Exit;
end;
UserSlots := Self.CountArgSlots(MD.Params);
{ %rdi = sret buffer, %rsi = Self leave four integer arg registers; further
slots spill to the stack via EmitSretRegArgs (ABase = 2). }

View file

@ -6855,8 +6855,14 @@ begin
else if (Par.ResolvedType <> nil) and (Par.ResolvedType.Kind = tyInterface) then
begin
ArgTemps.Add('');
ArgLine := ArgLine +
InterfaceArgFragment(TASTExpr(ACall.Args.Items[I]), Par.ResolvedType);
{ InterfaceArgFragment returns a leading-comma pair ', l obj, l itab'
(designed to be appended directly after a preceding arg). This
loop already inserts the ', ' separator at the top (line ~6843),
so strip the fragment's own leading ', ' to avoid a double comma
and to avoid a leading comma when the interface is the FIRST arg of
a static call (which QBE rejects as "invalid class specifier"). }
ArgLine := ArgLine + Copy(InterfaceArgFragment(
TASTExpr(ACall.Args.Items[I]), Par.ResolvedType), 2, MaxInt);
end
else
begin

View file

@ -31,6 +31,7 @@ type
procedure TestRun_StaticVar_QualifiedRead;
procedure TestRun_StaticVar_QualifiedWrite_Scalar;
procedure TestRun_StaticVar_QualifiedWrite_ClassARC;
procedure TestRun_StaticVar_InterfaceStore;
procedure TestRun_StaticProperty_QualifiedRead;
procedure TestRun_Singleton_LazyGetInstance;
procedure TestRun_StaticConst_OnClass;
@ -169,6 +170,58 @@ begin
AssertRunsOnAll(Src, '99' + LineEnding + 'released' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticVar_InterfaceStore;
{ Interface-typed static var: the bare store inside a static method
(FCache := X) must write BOTH slots of the 2-slot fat pointer (obj + itab)
with correct ARC, and the bare read (Result := FCache) must reconstruct it.
Regression for the static-call interface-arg leading-comma bug that made
THolder.SetIt(T) emit an invalid QBE call and segfault native. }
const Src =
'''
program P;
type
IThing = interface
procedure Speak;
end;
TThing = class(IThing)
public
Tag: Integer;
procedure Speak;
end;
THolder = class
public static var
FCache: IThing;
static procedure SetIt(X: IThing);
static function GetIt: IThing;
end;
procedure TThing.Speak;
begin
WriteLn('thing ', Tag);
end;
static procedure THolder.SetIt(X: IThing);
begin
FCache := X;
end;
static function THolder.GetIt: IThing;
begin
Result := FCache;
end;
var
T: TThing;
Got: IThing;
begin
T := TThing.Create();
T.Tag := 7;
THolder.SetIt(T);
Got := THolder.GetIt();
Got.Speak();
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, 'thing 7' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticProperty_QualifiedRead;
const Src =
'''

View file

@ -587,6 +587,7 @@ type
procedure TestIR_StaticVar_QualifiedRead_LoadsGlobal;
procedure TestIR_StaticProperty_QualifiedRead_CallsGetter;
procedure TestIR_ClassStaticVar_ReleasedAtExit;
procedure TestIR_StaticCall_InterfaceArg_NoLeadingComma;
end;
function TStaticMembersSemTests.AnalyseSrc(const ASrc: string): TProgram;
@ -993,6 +994,53 @@ begin
(Pos('@main_exit', IR) >= 0) and (Pos('loadl $TFoo_FInst', IR) >= 0));
end;
procedure TStaticMembersSemTests.TestIR_StaticCall_InterfaceArg_NoLeadingComma;
{ A static method whose FIRST parameter is interface-typed must be CALLED with
a well-formed argument list: 'call $T_M(l obj, l itab)'. The interface arg
fragment carries a leading ', ' (it is normally appended after Self/a prior
arg); in a static call it is the first arg, so the codegen must strip that
comma otherwise QBE rejects 'call $T_M(, l obj, l itab)' as an invalid
class specifier. }
const
Src =
'''
program P;
type
IThing = interface
procedure Speak;
end;
TThing = class(IThing)
public
procedure Speak;
end;
THolder = class
public
static procedure SetIt(X: IThing);
end;
procedure TThing.Speak;
begin
end;
static procedure THolder.SetIt(X: IThing);
begin
end;
var T: TThing;
begin
T := TThing.Create();
THolder.SetIt(T);
end.
''';
var IR: string; CallPos: Integer;
begin
IR := GenIR(Src);
CallPos := Pos('call $THolder_SetIt(', IR);
AssertTrue('static interface-arg call emitted', CallPos >= 0);
{ The call must not begin its argument list with a comma. }
AssertFalse('no leading comma in static interface-arg call',
Pos('call $THolder_SetIt(,', IR) >= 0);
AssertTrue('call passes obj+itab pair',
Pos('call $THolder_SetIt(l ', IR) >= 0);
end;
initialization
RegisterTest(TStaticMembersParseTests);
RegisterTest(TStaticMembersSemTests);