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

fix(codegen): interface nil-compare and interface-method sret returns

Browse source 
Two interface-dispatch bugs surfaced by Andrew Haines'
unify_backend_interface branch, fixed on both backends:

1. Interface value reads through a bare identifier (nil compares,
   most visibly 'if Result = nil' inside an interface-returning
   function) loaded a non-existent single slot.  Interface idents now
   load the obj half of the fat pointer: locals via the _obj slot,
   globals via the Name_obj label, Result via the sret buffer
   pointer.  QBE additionally treats tyInterface as a pointer kind in
   comparisons (ceql/cnel).  The native backend previously compared
   the sret buffer ADDRESS against nil — always false, silently.

2. V := Intf.Method(...) where Method returns an interface emitted a
   single-slot store against the split-slot local (invalid QBE IR /
   wrong native code).  Itab-dispatched calls returning interfaces now
   route through the sret convention like plain function calls: QBE
   grows EmitIntfSretDispatch; native grows EmitIntfSretMethodCall,
   wired into every interface-assignment LHS shape.  Ownership follows
   the existing convention (callee AddRefs into the sret buffer, the
   caller takes the owned +1 pair).

Also fixes a latent bug found while testing: assigning an
interface-typed Result to a global stored the sret buffer pointer as
the obj half (native PushIntfIdentPair now dereferences correctly).

Still open, fail-loud (recorded in bugs.txt): TFuncCallExpr receivers
of interface calls, and discarded interface-returning itab calls in
statement position on the QBE path.

IR tests in cp.test.interfaces; e2e tests in cp.test.e2e.imap run the
registry-pattern acceptance program on both backends.
This commit is contained in:
Graeme Geldenhuys 2026-06-12 12:50:19 +01:00
parent 81c5804ae4
commit c20ddd549d
4 changed files with 713 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -251,6 +251,12 @@ type
globals are two separate .data labels, AName + '_obj'/'_itab'. }
function IntfObjOperand(const AName: string; AIsGlobal: Boolean): string;
function IntfItabOperand(const AName: string; AIsGlobal: Boolean): string;
{ Push the (itab, obj) pair of a named interface ident source — itab
first so obj ends on top; leaves obj in %rax for the ARC retain that
follows. Handles the sret interface Result, whose slot holds a
POINTER to the caller's 16-byte buffer rather than the fat pointer
itself (IntfObjOperand alone would push that pointer as the obj). }
procedure PushIntfIdentPair(AIdent: TIdentExpr);
{ Lower one interface method call (TFieldAccessExpr.IsInterfaceCall or a
TMethodCallExpr/Stmt whose ResolvedClassType is tyInterface): load obj +
itab, index the itab by method slot, call the loaded pointer with obj as
@ -398,6 +404,12 @@ type
buffer (obj+itab) is left on the stack; caller is responsible for loading
the slots and cleaning up (addq $16, %rsp). }
procedure EmitIntfSretCall(ACall: TFuncCallExpr);
{ Interface-method call (itab dispatch) RETURNING an interface: the callee
writes the fat pointer through a hidden sret first arg (%rdi), with the
receiver obj as the second arg (%rsi). Same caller contract as
EmitIntfSretCall: the 16-byte buffer is left at (%rsp); the caller loads
the slots and pops it (addq $16, %rsp). }
procedure EmitIntfSretMethodCall(ACall: TMethodCallExpr);
{ Indirect call: load a bare function pointer from APtrOperand (an AT&T
memory operand, e.g. "-8(%rbp)"), set up args as for EmitCall, then
dispatch via callq *%r10. AProcType supplies the param list for
@ -2265,12 +2277,7 @@ begin
end
else if (AAsgn.Expr.ResolvedType.Kind = tyInterface) and (AAsgn.Expr is TIdentExpr) then
begin
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfItabOperand(TIdentExpr(AAsgn.Expr).Name, TIdentExpr(AAsgn.Expr).IsGlobal)]));
Self.Emit(#9'pushq %rax');
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfObjOperand(TIdentExpr(AAsgn.Expr).Name, TIdentExpr(AAsgn.Expr).IsGlobal)]));
Self.Emit(#9'pushq %rax');
Self.PushIntfIdentPair(TIdentExpr(AAsgn.Expr));
Self.Emit(#9'movq %rax, %rdi');
Self.Emit(#9'callq _ClassAddRef');
Self.Emit(#9'movq (%r15), %rdi');
@ -2310,6 +2317,21 @@ begin
Self.Emit(#9'movq %rax, 8(%r15)');
Self.Emit(#9'addq $16, %rsp');
end
else if (AAsgn.Expr is TMethodCallExpr) and
(TMethodCallExpr(AAsgn.Expr).ResolvedClassType <> nil) and
(TMethodCallExpr(AAsgn.Expr).ResolvedClassType.Kind = tyInterface) then
begin
{ Interface-method call (itab dispatch) returning an interface — the
callee hands back an OWNED +1 fat pointer in the sret buffer. }
Self.EmitIntfSretMethodCall(TMethodCallExpr(AAsgn.Expr));
Self.Emit(#9'movq (%r15), %rdi');
Self.Emit(#9'callq _ClassRelease');
Self.Emit(#9'movq (%rsp), %rax');
Self.Emit(#9'movq %rax, (%r15)');
Self.Emit(#9'movq 8(%rsp), %rax');
Self.Emit(#9'movq %rax, 8(%r15)');
Self.Emit(#9'addq $16, %rsp');
end
else
raise ENativeCodeGenError.Create(
'native backend: unsupported interface-field assignment RHS');
@ -2354,12 +2376,7 @@ begin
end
else if (AAsgn.Expr.ResolvedType.Kind = tyInterface) and (AAsgn.Expr is TIdentExpr) then
begin
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfItabOperand(TIdentExpr(AAsgn.Expr).Name, TIdentExpr(AAsgn.Expr).IsGlobal)]));
Self.Emit(#9'pushq %rax');
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfObjOperand(TIdentExpr(AAsgn.Expr).Name, TIdentExpr(AAsgn.Expr).IsGlobal)]));
Self.Emit(#9'pushq %rax');
Self.PushIntfIdentPair(TIdentExpr(AAsgn.Expr));
Self.Emit(#9'movq %rax, %rdi');
Self.Emit(#9'callq _ClassAddRef');
Self.Emit(#9'movq (%r15), %rdi');
@ -2369,6 +2386,35 @@ begin
Self.Emit(#9'popq %rax');
Self.Emit(#9'movq %rax, 8(%r15)');
end
else if (AAsgn.Expr is TFuncCallExpr) and
(TFuncCallExpr(AAsgn.Expr).ResolvedDecl <> nil) and
(TMethodDecl(TFuncCallExpr(AAsgn.Expr).ResolvedDecl).ResolvedReturnType <> nil) and
(TMethodDecl(TFuncCallExpr(AAsgn.Expr).ResolvedDecl).ResolvedReturnType.Kind = tyInterface) then
begin
Self.EmitIntfSretCall(TFuncCallExpr(AAsgn.Expr));
Self.Emit(#9'movq (%r15), %rdi');
Self.Emit(#9'callq _ClassRelease');
Self.Emit(#9'movq (%rsp), %rax');
Self.Emit(#9'movq %rax, (%r15)');
Self.Emit(#9'movq 8(%rsp), %rax');
Self.Emit(#9'movq %rax, 8(%r15)');
Self.Emit(#9'addq $16, %rsp');
end
else if (AAsgn.Expr is TMethodCallExpr) and
(TMethodCallExpr(AAsgn.Expr).ResolvedClassType <> nil) and
(TMethodCallExpr(AAsgn.Expr).ResolvedClassType.Kind = tyInterface) then
begin
{ Interface-method call (itab dispatch) returning an interface — the
callee hands back an OWNED +1 fat pointer in the sret buffer. }
Self.EmitIntfSretMethodCall(TMethodCallExpr(AAsgn.Expr));
Self.Emit(#9'movq (%r15), %rdi');
Self.Emit(#9'callq _ClassRelease');
Self.Emit(#9'movq (%rsp), %rax');
Self.Emit(#9'movq %rax, (%r15)');
Self.Emit(#9'movq 8(%rsp), %rax');
Self.Emit(#9'movq %rax, 8(%r15)');
Self.Emit(#9'addq $16, %rsp');
end
else
raise ENativeCodeGenError.Create(
'native backend: unsupported sret interface Result assignment RHS');
@ -2473,12 +2519,7 @@ begin
else
begin
{ Load src obj+itab; addref new obj; release old obj; store both. }
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfItabOperand(TIdentExpr(AAsgn.Expr).Name, TIdentExpr(AAsgn.Expr).IsGlobal)]));
Self.Emit(#9'pushq %rax'); { itab }
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfObjOperand(TIdentExpr(AAsgn.Expr).Name, TIdentExpr(AAsgn.Expr).IsGlobal)]));
Self.Emit(#9'pushq %rax'); { obj; stack now (obj, itab) }
Self.PushIntfIdentPair(TIdentExpr(AAsgn.Expr));
Self.Emit(#9'movq %rax, %rdi');
Self.Emit(#9'callq _ClassAddRef');
Self.Emit(Format(#9'movq %s, %%rdi', [ObjOp])); { old obj }
@ -2538,6 +2579,24 @@ begin
Exit;
end;
{ F := SomeIntf.Method(args) where Method (itab dispatch) returns an
interface — same sret protocol; the callee hands back an OWNED +1 fat
pointer, so release the old obj and store without an extra AddRef. }
if (AAsgn.Expr is TMethodCallExpr) and
(TMethodCallExpr(AAsgn.Expr).ResolvedClassType <> nil) and
(TMethodCallExpr(AAsgn.Expr).ResolvedClassType.Kind = tyInterface) then
begin
Self.EmitIntfSretMethodCall(TMethodCallExpr(AAsgn.Expr));
Self.Emit(Format(#9'movq %s, %%rdi', [ObjOp])); { old obj }
Self.Emit(#9'callq _ClassRelease');
Self.Emit(#9'movq (%rsp), %rax');
Self.Emit(Format(#9'movq %%rax, %s', [ObjOp]));
Self.Emit(#9'movq 8(%rsp), %rax');
Self.Emit(Format(#9'movq %%rax, %s', [ItabOp]));
Self.Emit(#9'addq $16, %rsp');
Exit;
end;
raise ENativeCodeGenError.Create(
'native backend: unsupported interface-field assignment RHS');
end;
@ -2606,14 +2665,7 @@ begin
Self.Emit(#9'pushq %rcx');
end
else
begin
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfItabOperand(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal)]));
Self.Emit(#9'pushq %rax');
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfObjOperand(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal)]));
Self.Emit(#9'pushq %rax');
end;
Self.PushIntfIdentPair(TIdentExpr(AExpr));
end
else if AExpr is TFieldAccessExpr then
begin
@ -2829,6 +2881,29 @@ begin
Result := AName + '_itab(%rip)';
end;
procedure TX86_64Backend.PushIntfIdentPair(AIdent: TIdentExpr);
begin
if FSretFunc and SameText(AIdent.Name, 'Result') then
begin
{ sret interface Result: the slot holds the caller-buffer address —
dereference for obj (+0) and itab (+8). }
Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand('Result')]));
Self.Emit(#9'movq 8(%rax), %rcx');
Self.Emit(#9'pushq %rcx');
Self.Emit(#9'movq (%rax), %rax');
Self.Emit(#9'pushq %rax');
end
else
begin
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfItabOperand(AIdent.Name, AIdent.IsGlobal)]));
Self.Emit(#9'pushq %rax');
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfObjOperand(AIdent.Name, AIdent.IsGlobal)]));
Self.Emit(#9'pushq %rax');
end;
end;
{ Load an integer-family value from memory into %rax, extended to the full
64-bit register according to AType's width and signedness. Narrower-than-
32-bit loads use a sign/zero-extending move; 32-bit signed widens with
@ -4223,6 +4298,24 @@ begin
[Self.VarOperand('_cap_' + TIdentExpr(AExpr).Name)]));
Self.EmitLoadVar('(%rcx)', Self.IntExprType(AExpr));
end
else if (TIdentExpr(AExpr).ResolvedType <> nil) and
(TIdentExpr(AExpr).ResolvedType.Kind = tyInterface) then
begin
{ Interface ident used as a single value (nil/identity compare): load
the obj half of the fat pointer. An sret Result slot holds a POINTER
to the caller's 16-byte buffer — dereference it; locals keep obj at
the slot base and globals use the _obj data label (a bare global
symbol load would reference a label that does not exist). }
if FSretFunc and SameText(TIdentExpr(AExpr).Name, 'Result') then
begin
Self.Emit(Format(#9'movq %s, %%rcx', [Self.VarOperand('Result')]));
Self.Emit(#9'movq (%rcx), %rax');
end
else
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfObjOperand(TIdentExpr(AExpr).Name,
TIdentExpr(AExpr).IsGlobal)]));
end
else
Self.EmitLoadVar(Self.VarOperand(TIdentExpr(AExpr).Name),
Self.IntExprType(AExpr));
@ -11942,6 +12035,171 @@ begin
HK.Free();
end;
procedure TX86_64Backend.EmitIntfSretMethodCall(ACall: TMethodCallExpr);
var
I, SlotOff, ArgN: Integer;
Arg: TASTExpr;
IntfD: TInterfaceTypeDesc;
HD: TList<Integer>;
HK: TList<Integer>;
HTotal, Pushed: Integer;
VFlags: string;
IE: TIdentExpr;
begin
IntfD := TInterfaceTypeDesc(ACall.ResolvedClassType);
ArgN := 0;
if ACall.Args <> nil then ArgN := ACall.Args.Count;
{ Same unknown-signature hoist as EmitInterfaceCall; the region sits BELOW
the sret buffer (see EmitIntfSretCall for the layout rationale). }
HD := TList<Integer>.Create();
HK := TList<Integer>.Create();
VFlags := IntfD.MethodParamVarFlagsStr(IntfD.MethodIndex(ACall.Name));
HTotal := Self.EmitArgHoist(nil, nil, False, VFlags, ACall.Args, HD, HK);
{ Allocate and zero the 16-byte sret buffer. }
Self.Emit(#9'subq $16, %rsp');
Self.Emit(#9'movq $0, (%rsp)');
Self.Emit(#9'movq $0, 8(%rsp)');
Pushed := 0;
{ Push args left-to-right; interface args push obj then itab (2 slots). }
for I := 0 to ArgN - 1 do
begin
Arg := TASTExpr(ACall.Args.Items[I]);
if HK.Get(I) >= akRecCall then
begin
{ Hoisted record-call or string argument — reload the saved value
(+16 for the sret buffer between %rsp and the hoist region). }
Self.Emit(Format(#9'movq %d(%%rsp), %%rax',
[16 + HTotal - HD.Get(I) + Pushed]));
Self.Emit(#9'pushq %rax');
end
else if (Arg.ResolvedType <> nil) and (Arg.ResolvedType.Kind = tyInterface) then
begin
if Arg is TIdentExpr then
begin
if TIdentExpr(Arg).IsImplicitSelf and
(TIdentExpr(Arg).ImplicitFieldInfo <> nil) then
begin
Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand('Self')]));
if TFieldInfo(TIdentExpr(Arg).ImplicitFieldInfo).Offset > 0 then
Self.Emit(Format(#9'addq $%d, %%rax',
[TFieldInfo(TIdentExpr(Arg).ImplicitFieldInfo).Offset]));
Self.Emit(#9'movq (%rax), %rcx');
Self.Emit(#9'movq 8(%rax), %rdx');
Self.Emit(#9'pushq %rcx');
Self.Emit(#9'pushq %rdx');
end
else
begin
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfObjOperand(TIdentExpr(Arg).Name, TIdentExpr(Arg).IsGlobal)]));
Self.Emit(Format(#9'movq %s, %%rcx',
[Self.IntfItabOperand(TIdentExpr(Arg).Name, TIdentExpr(Arg).IsGlobal)]));
Self.Emit(#9'pushq %rax');
Self.Emit(#9'pushq %rcx');
end;
end
else if Arg is TFieldAccessExpr then
begin
Self.EmitInterfaceFieldAddr(TFieldAccessExpr(Arg), '%rax');
Self.Emit(#9'movq (%rax), %rcx');
Self.Emit(#9'movq 8(%rax), %rdx');
Self.Emit(#9'pushq %rcx');
Self.Emit(#9'pushq %rdx');
end
else
raise ENativeCodeGenError.Create(
'native backend: unsupported interface arg expression in sret interface dispatch');
end
else
begin
Self.EmitExprToEax(Arg);
Self.Emit(#9'pushq %rax');
end;
if (HK.Get(I) < akRecCall) and (Arg.ResolvedType <> nil) and
(Arg.ResolvedType.Kind = tyInterface) then
Pushed := Pushed + 16
else
Pushed := Pushed + 8;
end;
{ Resolve the receiver: obj into %r10, itab into %rax. }
if (ACall.ObjExpr <> nil) and (ACall.ObjExpr is TFieldAccessExpr) then
begin
Self.EmitInterfaceFieldAddr(TFieldAccessExpr(ACall.ObjExpr), '%r10');
Self.Emit(#9'movq 8(%r10), %rax');
Self.Emit(#9'movq (%r10), %r10');
end
else if (ACall.ObjExpr <> nil) and (ACall.ObjExpr is TIdentExpr) and
TIdentExpr(ACall.ObjExpr).IsImplicitSelf and
(TIdentExpr(ACall.ObjExpr).ImplicitFieldInfo <> nil) then
begin
{ Interface field of Self as receiver: fat pointer at Self + offset. }
IE := TIdentExpr(ACall.ObjExpr);
Self.Emit(Format(#9'movq %s, %%r10', [Self.VarOperand('Self')]));
if TFieldInfo(IE.ImplicitFieldInfo).Offset > 0 then
Self.Emit(Format(#9'addq $%d, %%r10',
[TFieldInfo(IE.ImplicitFieldInfo).Offset]));
Self.Emit(#9'movq 8(%r10), %rax');
Self.Emit(#9'movq (%r10), %r10');
end
else if (ACall.ObjExpr <> nil) and (ACall.ObjExpr is TIdentExpr) then
begin
IE := TIdentExpr(ACall.ObjExpr);
Self.Emit(Format(#9'movq %s, %%r10',
[Self.IntfObjOperand(IE.Name, IE.IsGlobal)]));
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfItabOperand(IE.Name, IE.IsGlobal)]));
end
else if ACall.ObjExpr <> nil then
raise ENativeCodeGenError.Create(
'native backend: unsupported receiver expression in sret interface dispatch')
else if ACall.IsVarParam then
begin
Self.Emit(Format(#9'movq %s, %%r10', [Self.VarOperand(ACall.ObjectName)]));
Self.Emit(#9'movq 8(%r10), %rax');
Self.Emit(#9'movq (%r10), %r10');
end
else
begin
Self.Emit(Format(#9'movq %s, %%r10',
[Self.IntfObjOperand(ACall.ObjectName, ACall.IsGlobal)]));
Self.Emit(Format(#9'movq %s, %%rax',
[Self.IntfItabOperand(ACall.ObjectName, ACall.IsGlobal)]));
end;
SlotOff := IntfD.MethodIndex(ACall.Name) * 8;
if SlotOff = 0 then
Self.Emit(#9'movq (%rax), %r11')
else
Self.Emit(Format(#9'movq %d(%%rax), %%r11', [SlotOff]));
{ Pop args shifted by 2: %rdi = sret buffer, %rsi = receiver obj. }
SlotOff := 0;
for I := 0 to ArgN - 1 do
begin
Arg := TASTExpr(ACall.Args.Items[I]);
if (Arg.ResolvedType <> nil) and (Arg.ResolvedType.Kind = tyInterface) then
Inc(SlotOff, 2)
else
Inc(SlotOff);
end;
for I := SlotOff - 1 downto 0 do
Self.Emit(#9'popq ' + SysVArgRegs64[I + 2]);
Self.Emit(#9'movq %r10, %rsi');
Self.Emit(#9'movq %rsp, %rdi');
Self.Emit(#9'callq *%r11');
{ Post-call: release hoisted values, then slide the buffer down over the
hoist region so the caller's `fat pointer at (%rsp)` contract holds. }
Self.EmitHoistEpilogue(ACall.Args, HD, HK, HTotal, 16, False);
if HTotal > 0 then
begin
Self.Emit(#9'movq (%rsp), %rax');
Self.Emit(#9'movq 8(%rsp), %rcx');
Self.Emit(Format(#9'addq $%d, %%rsp', [16 + HTotal]));
Self.Emit(#9'pushq %rcx');
Self.Emit(#9'pushq %rax');
end;
HD.Free();
HK.Free();
end;
{ Emit a method-pointer (of-object) call through a TMethod block.
APtrOperand is the AT&T memory operand for the 16-byte Code+Data block.
Load Code into %r10, Data into %rdi, push/pop other args, then callq *%r10. }

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

@ -344,6 +344,11 @@ type
the result there instead of returning it. Handles TFuncCallExpr,
TMethodCallExpr, and TFieldAccessExpr.IsMethodCall. }
procedure EmitRecordCallSret(AExpr: TASTExpr; const ASretAddr: string);
{ Interface-dispatched (itab) call whose return type is an interface:
the callee writes the fat pointer through a hidden first sret arg.
ACall is a TMethodCallExpr (args form) or a TFieldAccessExpr with
IsInterfaceCall set (zero-arg form). }
procedure EmitIntfSretDispatch(ACall: TASTExpr; const ASretAddr: string);
procedure EmitRecordReturnCallSite(const AFuncName, AVisibleArgs: string;
ARetType: TRecordTypeDesc;
const ADestAddr: string);
@ -3830,6 +3835,42 @@ begin
Exit;
end;
{ Interface := call returning an interface — the callee writes the fat
pointer (obj+itab) into a caller-supplied 16-byte sret buffer. Load both
slots from the buffer and store into the LHS split slots with ARC. This
must run BEFORE the interface-to-interface branch below: a zero-arg
interface-method call is a TFieldAccessExpr, which that branch would
otherwise mistake for a plain field read. }
if (AAssign.ResolvedLhsType <> nil) and
(AAssign.ResolvedLhsType.Kind = tyInterface) and
IsInterfaceCall(AAssign.Expr) then
begin
SretBuf := AllocTemp();
EmitLine(Format(' %s =l alloc8 16', [SretBuf]));
EmitLine(Format(' call $memset(l %s, w 0, l 16)', [SretBuf]));
EmitRecordCallSret(AAssign.Expr, SretBuf);
ObjTemp := AllocTemp();
ItabTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [ObjTemp, SretBuf]));
ValTemp := AllocTemp();
EmitLine(Format(' %s =l add %s, 8', [ValTemp, SretBuf]));
EmitLine(Format(' %s =l loadl %s', [ItabTemp, ValTemp]));
ObjAddr := IntfObjAddr(AAssign.Name, AAssign.IsGlobal, AAssign.IsVarParam);
ItabAddr := IntfItabAddr(AAssign.Name, AAssign.IsGlobal, AAssign.IsVarParam);
if AAssign.IsWeakLhs then
EmitLine(Format(' call $_WeakAssign(l %s, l %s)', [ObjAddr, ObjTemp]))
else
begin
{ The callee returns an OWNED +1 fat pointer — no caller AddRef. }
OldTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [OldTemp, ObjAddr]));
EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp]));
EmitLine(Format(' storel %s, %s', [ObjTemp, ObjAddr]));
end;
EmitLine(Format(' storel %s, %s', [ItabTemp, ItabAddr]));
Exit;
end;
{ Interface-to-interface direct assignment: F := G where both sides are
interface-typed. Copy obj and itab from G's fat pointer to F's; for
strong F, retain the backing object and release F's prior obj ref;
@ -3894,38 +3935,6 @@ begin
Exit;
end;
{ Interface := FuncReturningInterface() — the callee writes the fat pointer
(obj+itab) into a caller-supplied 16-byte sret buffer. Load both slots
from the buffer and store into the LHS split slots with ARC. }
if (AAssign.ResolvedLhsType <> nil) and
(AAssign.ResolvedLhsType.Kind = tyInterface) and
IsInterfaceCall(AAssign.Expr) then
begin
SretBuf := AllocTemp();
EmitLine(Format(' %s =l alloc8 16', [SretBuf]));
EmitLine(Format(' call $memset(l %s, w 0, l 16)', [SretBuf]));
EmitRecordCallSret(AAssign.Expr, SretBuf);
ObjTemp := AllocTemp();
ItabTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [ObjTemp, SretBuf]));
ValTemp := AllocTemp();
EmitLine(Format(' %s =l add %s, 8', [ValTemp, SretBuf]));
EmitLine(Format(' %s =l loadl %s', [ItabTemp, ValTemp]));
ObjAddr := IntfObjAddr(AAssign.Name, AAssign.IsGlobal, AAssign.IsVarParam);
ItabAddr := IntfItabAddr(AAssign.Name, AAssign.IsGlobal, AAssign.IsVarParam);
if AAssign.IsWeakLhs then
EmitLine(Format(' call $_WeakAssign(l %s, l %s)', [ObjAddr, ObjTemp]))
else
begin
OldTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [OldTemp, ObjAddr]));
EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp]));
EmitLine(Format(' storel %s, %s', [ObjTemp, ObjAddr]));
end;
EmitLine(Format(' storel %s, %s', [ItabTemp, ItabAddr]));
Exit;
end;
if AAssign.IsVarParam then
begin
PtrTemp := AllocTemp();
@ -4607,6 +4616,16 @@ begin
end
else if AExpr is TMethodCallExpr then
begin
{ Interface dispatch: ResolvedMethod is nil by design (the target is
resolved through the itab); the call's own resolved type carries the
interface method's return type. }
if (TMethodCallExpr(AExpr).ResolvedClassType <> nil) and
(TMethodCallExpr(AExpr).ResolvedClassType.Kind = tyInterface) then
begin
Result := (AExpr.ResolvedType <> nil) and
(AExpr.ResolvedType.Kind = tyInterface);
Exit;
end;
if TMethodCallExpr(AExpr).ResolvedMethod = nil then Exit;
MDecl := TMethodDecl(TMethodCallExpr(AExpr).ResolvedMethod);
Result := (MDecl.ResolvedReturnType <> nil) and
@ -4615,6 +4634,14 @@ begin
else if AExpr is TFieldAccessExpr then
begin
FldA := TFieldAccessExpr(AExpr);
{ Zero-arg interface method call through itab dispatch — same rule as
the TMethodCallExpr interface-dispatch case above. }
if FldA.IsInterfaceCall then
begin
Result := (AExpr.ResolvedType <> nil) and
(AExpr.ResolvedType.Kind = tyInterface);
Exit;
end;
if not FldA.IsMethodCall then Exit;
if FldA.ResolvedMethod = nil then Exit;
MDecl := TMethodDecl(FldA.ResolvedMethod);
@ -5049,6 +5076,92 @@ begin
end;
end;
procedure TCodeGenQBE.EmitIntfSretDispatch(ACall: TASTExpr;
const ASretAddr: string);
var
IntfDesc: TInterfaceTypeDesc;
MethName: string;
AArgs: TObjectList;
MCall: TMethodCallExpr;
FldA: TFieldAccessExpr;
SelfTemp: string;
VTblTemp: string;
FPtrTemp: string;
ArgTemp: string;
ArgLine: string;
SlotOff: Integer;
I: Integer;
begin
AArgs := nil;
if ACall is TMethodCallExpr then
begin
MCall := TMethodCallExpr(ACall);
IntfDesc := TInterfaceTypeDesc(MCall.ResolvedClassType);
MethName := MCall.Name;
AArgs := MCall.Args;
if MCall.ObjExpr <> nil then
{ Receiver is an expression (record/class field, implicit-Self field,
as-cast) — resolve its fat pointer rather than split slots. }
EmitInterfaceExprPair(MCall.ObjExpr, SelfTemp, VTblTemp)
else
begin
SelfTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s',
[SelfTemp, IntfObjAddr(MCall.ObjectName, MCall.IsGlobal, MCall.IsVarParam)]));
VTblTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s',
[VTblTemp, IntfItabAddr(MCall.ObjectName, MCall.IsGlobal, MCall.IsVarParam)]));
end;
end
else
begin
{ Zero-arg interface method call: F := G.GetThing — receiver is the
named interface local/global/var-param G. }
FldA := TFieldAccessExpr(ACall);
IntfDesc := TInterfaceTypeDesc(FldA.ResolvedClassType);
MethName := FldA.FieldName;
SelfTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s',
[SelfTemp, IntfObjAddr(FldA.RecordName, FldA.IsGlobal, FldA.IsVarParam)]));
VTblTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s',
[VTblTemp, IntfItabAddr(FldA.RecordName, FldA.IsGlobal, FldA.IsVarParam)]));
end;
SlotOff := IntfDesc.MethodIndex(MethName) * 8;
FPtrTemp := AllocTemp();
if SlotOff = 0 then
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, VTblTemp]))
else
begin
ArgTemp := AllocTemp();
EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff]));
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
end;
{ Callee signature is (sret, Self, args...) — the same shape every
interface-returning method body declares (`l %_par__sret, l %_par_Self`). }
ArgLine := Format('l %s, l %s', [ASretAddr, SelfTemp]);
if AArgs <> nil then
begin
for I := 0 to AArgs.Count - 1 do
begin
if IntfDesc.MethodParamIsVar(IntfDesc.MethodIndex(MethName), I) then
ArgLine := ArgLine + Format(', l %s',
[EmitLValueAddr(TASTExpr(AArgs.Items[I]))])
else
begin
ArgTemp := EmitExpr(TASTExpr(AArgs.Items[I]));
if (TASTExpr(AArgs.Items[I]).ResolvedType <> nil) and
(TASTExpr(AArgs.Items[I]).ResolvedType.Kind in
[tyPointer, tyClass, tyInterface, tyPChar, tyString]) then
ArgLine := ArgLine + Format(', l %s', [ArgTemp])
else
ArgLine := ArgLine + Format(', w %s', [ArgTemp]);
end;
end;
end;
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
end;
procedure TCodeGenQBE.EmitRecordCallSret(AExpr: TASTExpr;
const ASretAddr: string);
var
@ -5116,6 +5229,14 @@ begin
else if AExpr is TMethodCallExpr then
begin
MCallExpr := TMethodCallExpr(AExpr);
if (MCallExpr.ResolvedClassType <> nil) and
(MCallExpr.ResolvedClassType.Kind = tyInterface) then
begin
{ Interface-method call through itab dispatch — ResolvedMethod is nil,
so the direct-call path below cannot be used. }
EmitIntfSretDispatch(MCallExpr, ASretAddr);
Exit;
end;
MDecl := TMethodDecl(MCallExpr.ResolvedMethod);
RetType := TRecordTypeDesc(MDecl.ResolvedReturnType);
if MCallExpr.ObjExpr <> nil then
@ -5158,6 +5279,12 @@ begin
else if AExpr is TFieldAccessExpr then
begin
FldAccess := TFieldAccessExpr(AExpr);
if FldAccess.IsInterfaceCall then
begin
{ Zero-arg interface method call through itab dispatch. }
EmitIntfSretDispatch(FldAccess, ASretAddr);
Exit;
end;
MDecl := TMethodDecl(FldAccess.ResolvedMethod);
RetType := TRecordTypeDesc(MDecl.ResolvedReturnType);
if FldAccess.IsImplicitSelf then
@ -11022,6 +11149,17 @@ begin
{ Aggregate variable — return its storage address directly (no load). }
Exit(VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal));
end
else if (AExpr.ResolvedType <> nil) and
(AExpr.ResolvedType.Kind = tyInterface) then
begin
{ Interface ident used as a single value (nil/identity compare): the
fat pointer lives in split _obj/_itab slots — there is no single
%_var_Name slot. Load the obj half; this also covers an interface
Result, whose _obj slot holds the sret-buffer address. }
EmitLine(Format(' %s =l loadl %s',
[T, IntfObjAddr(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal,
False)]));
end
else if not TIdentExpr(AExpr).IsGlobal and
IsPromoted(TIdentExpr(AExpr).Name) then
begin
@ -11224,9 +11362,9 @@ begin
pointer-shaped (class/nil/pointer/metaclass). Identity check only;
ordering ops on pointers are not supported. }
if ((BinExpr.Left.ResolvedType <> nil) and
(BinExpr.Left.ResolvedType.Kind in [tyClass, tyNil, tyPointer, tyMetaClass])) or
(BinExpr.Left.ResolvedType.Kind in [tyClass, tyNil, tyPointer, tyMetaClass, tyInterface])) or
((BinExpr.Right.ResolvedType <> nil) and
(BinExpr.Right.ResolvedType.Kind in [tyClass, tyNil, tyPointer, tyMetaClass])) then
(BinExpr.Right.ResolvedType.Kind in [tyClass, tyNil, tyPointer, tyMetaClass, tyInterface])) then
begin
case BinExpr.Op of
boEQ: Op := 'ceql';

111
compiler/src/test/pascal/cp.test.e2e.imap.pas
View file

@ -31,6 +31,8 @@ type
procedure TestRun_IMap_SwapImplementation_SameCallSite;
procedure TestRun_IMap_GenericDictInUnit_LinksAndRuns;
procedure TestRun_StaticArrayOfInterface_FatPointer;
procedure TestRun_InterfaceResult_NilCompare_Registry;
procedure TestRun_IntfMethodReturningIntf_ToLocal;
end;
implementation
@ -519,6 +521,115 @@ begin
Pos('11' + #10 + '22' + #10 + '22' + #10 + '11' + #10 + '11', Output) >= 0);
end;
const
{ Registry pattern: function returning an interface with `if Result = nil`
inside. The interface Result lives in the caller's sret buffer (split
obj/itab) — the nil compare must read the obj half, not a single slot. }
SrcIntfResultNilCompare =
'''
program P;
type
IDriver = interface
function GetVal: Integer;
end;
TDrv = class(IDriver)
function GetVal: Integer;
begin
Result := 7
end;
end;
var
GCache: IDriver;
function GetDriver(): IDriver;
begin
Result := GCache;
if Result = nil then
begin
WriteLn('miss');
Result := TDrv.Create();
GCache := Result
end
end;
var
D: IDriver;
begin
D := GetDriver();
WriteLn(D.GetVal());
D := GetDriver();
WriteLn(D.GetVal())
end.
''';
{ Interface-method call (itab dispatch) returning an interface, assigned to
a LOCAL interface var — both with a local interface receiver and with an
implicit-Self interface-field receiver. }
SrcIntfMethodReturningIntf =
'''
program P;
type
IWidget = interface
function Tag: Integer;
end;
IDriver = interface
function MakeWidget(N: Integer): IWidget;
end;
TWidget = class(IWidget)
FTag: Integer;
function Tag: Integer;
begin
Result := Self.FTag
end;
end;
TDrv = class(IDriver)
function MakeWidget(N: Integer): IWidget;
var W: TWidget;
begin
W := TWidget.Create();
W.FTag := N;
Result := W
end;
end;
TWorker = class
FDriver: IDriver;
function Run: Integer;
var W: IWidget;
begin
W := FDriver.MakeWidget(21);
Result := W.Tag()
end;
end;
procedure Go();
var
D: IDriver;
W: IWidget;
K: TWorker;
begin
D := TDrv.Create();
W := D.MakeWidget(42);
WriteLn(W.Tag());
K := TWorker.Create();
K.FDriver := D;
WriteLn(K.Run())
end;
begin
Go()
end.
''';
procedure TE2EIMapTests.TestRun_InterfaceResult_NilCompare_Registry;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertRunsOnAll(SrcIntfResultNilCompare,
'miss' + LineEnding + '7' + LineEnding + '7' + LineEnding, 0);
end;
procedure TE2EIMapTests.TestRun_IntfMethodReturningIntf_ToLocal;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertRunsOnAll(SrcIntfMethodReturningIntf,
'42' + LineEnding + '21' + LineEnding, 0);
end;
initialization
RegisterTest(TE2EIMapTests);

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

@ -115,6 +115,14 @@ type
procedure TestSemantic_InterfaceProperty_InheritedFromParent_OK;
procedure TestCodegen_InterfacePropertyRead_DispatchesGetter;
procedure TestCodegen_InterfacePropertyWrite_DispatchesSetter;
{ ------------------------------------------------------------------ }
{ Regression — interface idents as values; interface-returning }
{ interface-method calls }
{ ------------------------------------------------------------------ }
procedure TestCodegen_InterfaceResult_NilCompare_UsesObjSlot;
procedure TestCodegen_InterfaceLocal_NilCompare_UsesObjSlot;
procedure TestCodegen_IntfMethodReturningIntf_AssignsToSplitSlots;
end;
implementation
@ -1481,6 +1489,144 @@ begin
Pos('call %', IR) > 0);
end;
{ ------------------------------------------------------------------ }
{ Regression — interface idents as values; interface-returning }
{ interface-method calls }
{ ------------------------------------------------------------------ }
const
{ Function whose RETURN TYPE is an interface, with `if Result = nil` in the
body. An interface Result has no single %_var_Result slot — only the
split %_var_Result_obj / %_var_Result_itab pair pointing into the sret
buffer — so the nil compare must load the obj half. }
SrcInterfaceResultNilCompare =
'''
program P;
type
IDriver = interface
function GetVal(): Integer;
end;
TDrv = class(TObject, IDriver)
function GetVal(): Integer;
end;
function TDrv.GetVal(): Integer;
begin
Result := 7
end;
function GetDriver(): IDriver;
begin
Result := nil;
if Result = nil then
Result := TDrv.Create()
end;
begin
end.
''';
{ Plain interface LOCAL compared against nil — same obj-half rule. }
SrcInterfaceLocalNilCompare =
'''
program P;
type
IDriver = interface
function GetVal(): Integer;
end;
TDrv = class(TObject, IDriver)
function GetVal(): Integer;
end;
function TDrv.GetVal(): Integer;
begin
Result := 7
end;
procedure Run();
var
D: IDriver;
begin
D := nil;
if D = nil then
D := TDrv.Create()
end;
begin
Run()
end.
''';
{ Interface-method call (itab dispatch) RETURNING an interface, assigned to
a LOCAL interface var. The callee writes the fat pointer through a hidden
sret arg; the caller must store obj/itab into the split slots — never a
single `storel %t, %_var_W`. }
SrcIntfMethodCallReturnsInterface =
'''
program P;
type
IWidget = interface
function Tag(): Integer;
end;
IDriver = interface
function MakeWidget(N: Integer): IWidget;
end;
TWidget = class(TObject, IWidget)
function Tag(): Integer;
end;
TDrv = class(TObject, IDriver)
function MakeWidget(N: Integer): IWidget;
end;
function TWidget.Tag(): Integer;
begin
Result := 1
end;
function TDrv.MakeWidget(N: Integer): IWidget;
begin
Result := TWidget.Create()
end;
procedure Run();
var
D: IDriver;
W: IWidget;
begin
D := TDrv.Create();
W := D.MakeWidget(3)
end;
begin
Run()
end.
''';
procedure TInterfaceTests.TestCodegen_InterfaceResult_NilCompare_UsesObjSlot;
var
IR: string;
begin
IR := GenIR(SrcInterfaceResultNilCompare);
AssertTrue('nil compare loads the obj half of Result',
Pos('loadl %_var_Result_obj', IR) > 0);
AssertFalse('must not load a non-existent single %_var_Result slot',
Pos('loadl %_var_Result' + #10, IR) > 0);
end;
procedure TInterfaceTests.TestCodegen_InterfaceLocal_NilCompare_UsesObjSlot;
var
IR: string;
begin
IR := GenIR(SrcInterfaceLocalNilCompare);
AssertTrue('nil compare loads the obj half of the local',
Pos('loadl %_var_D_obj', IR) > 0);
AssertFalse('must not load a non-existent single %_var_D slot',
Pos('loadl %_var_D' + #10, IR) > 0);
end;
procedure TInterfaceTests.TestCodegen_IntfMethodReturningIntf_AssignsToSplitSlots;
var
IR: string;
begin
IR := GenIR(SrcIntfMethodCallReturnsInterface);
AssertTrue('obj half stored into the split obj slot',
Pos(', %_var_W_obj', IR) > 0);
AssertTrue('itab half stored into the split itab slot',
Pos(', %_var_W_itab', IR) > 0);
AssertFalse('must not store into a non-existent single %_var_W slot',
Pos(', %_var_W' + #10, IR) > 0);
end;
initialization
RegisterTest(TInterfaceTests);