fix(codegen): itab dispatch of a record-returning method (both backends)

An interface (itab-dispatched) method returning a RECORD was broken on both
backends, both when the result was assigned and when discarded in statement
position, for memory-class (sret) and register-class records alike.  The itab
dispatch had no record-return ABI: it emitted a scalar call, so for a
memory-class return the first argument register doubled as the sret pointer
(the callee received a garbage argument and wrote the record over caller
memory — "_StringRelease corrupted header"), and a register-class return was
dereferenced as a pointer.  Assignment was equally broken because
IsRecordCall / IsNativeRecordCall keyed off ResolvedMethod, which is nil for
itab dispatch.

QBE:
* IsRecordCall recognises an itab record call (ResolvedClassType = interface +
  ResolvedType in [record, static-array]) for both the args form
  (TMethodCallExpr) and the zero-arg form (TFieldAccessExpr.IsInterfaceCall).
* EmitIntfSretDispatch builds the visible args (Self, method args) and delegates
  to EmitRecordReturnCallSite, which applies the correct ABI from
  ClassifyRecordReturn (sret pointer vs register capture) — instead of always
  passing an sret buffer.
* The discarded-statement path (EmitMethodCall) gained a record/static-array
  branch: a throwaway zeroed buffer, the classified call, then
  EmitRecordReleaseFields on the buffer.

Native:
* IsNativeRecordCall recognises the itab record case.
* New EmitIntfRecordSretDispatch performs itab dispatch with the full
  record-return ABI: an sret buffer in %rdi for a memory-class record, or
  EmitRecordRegReturnCapture (a new helper covering rcInt1/rcInt2/rcSSE1/
  rcSSE2/rcIntSSE/rcSSEInt) storing the register result into the destination.
  Wired into EmitRecordCallSretAt, both record-assignment branches (implicit-Self
  field and plain local/var/global), and the discarded-statement path.

E2E regressions (both backends, via AssertRunsOnAll):
TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsSretRecord and
_ReturnsRegisterRecord — each exercises an assigned and a discarded call.
This commit is contained in:
Graeme Geldenhuys 2026-06-27 21:52:23 +01:00
parent 4bd52cd96a
commit a4d178b52c
3 changed files with 476 additions and 9 deletions

View file

@ -547,6 +547,15 @@ type
EmitIntfSretCall: the 16-byte buffer is left at (%rsp); the caller loads
the slots and pops it (addq $16, %rsp). }
procedure EmitIntfSretMethodCall(ACall: TMethodCallExpr);
{ Interface-method call (itab dispatch) RETURNING a RECORD: dispatch through
the itab and write the record result into the caller-supplied ADest,
honouring the full record-return ABI (hidden sret pointer for a
memory-class record; register capture for a register-class one). Mirrors
the QBE EmitIntfSretDispatch helper. ADestIsIndirect: ADest holds a
pointer to the destination buffer (var/out / Result), not the buffer. }
procedure EmitIntfRecordSretDispatch(ACall: TMethodCallExpr;
const ADest: string;
ADestIsIndirect: Boolean);
{ Class-receiver method call RETURNING an interface (Obj.Make() where Obj
is class-typed): sret hidden first arg (%rdi), receiver in %rsi, static
or vtable dispatch from the receiver's class. Same caller contract as
@ -4550,6 +4559,18 @@ end;
function TX86_64Backend.IsNativeRecordCall(AExpr: TASTExpr): Boolean;
begin
Result := False;
{ Interface (itab) dispatch has no ResolvedMethod — classify by the call's
resolved return type instead, so a record-returning itab call routes
through the sret/record-return path (EmitIntfRecordSretDispatch) like a
direct record method call. Mirrors the QBE IsRecordCall interface case. }
if (AExpr is TMethodCallExpr) and
(TMethodCallExpr(AExpr).ResolvedClassType <> nil) and
(TMethodCallExpr(AExpr).ResolvedClassType.Kind = tyInterface) then
begin
Result := (TMethodCallExpr(AExpr).ResolvedType <> nil) and
(TMethodCallExpr(AExpr).ResolvedType.Kind = tyRecord);
Exit;
end;
if (AExpr is TMethodCallExpr) and
(TMethodCallExpr(AExpr).ResolvedMethod <> nil) and
(TMethodDecl(TMethodCallExpr(AExpr).ResolvedMethod).ResolvedReturnType <> nil) and
@ -4616,7 +4637,13 @@ end;
procedure TX86_64Backend.EmitRecordCallSretAt(AExpr: TASTExpr; const ADest: string);
begin
if AExpr is TMethodCallExpr then
if (AExpr is TMethodCallExpr) and
(TMethodCallExpr(AExpr).ResolvedClassType <> nil) and
(TMethodCallExpr(AExpr).ResolvedClassType.Kind = tyInterface) then
{ Interface (itab) record-returning dispatch — EmitMethodSretCall raises on
a nil ResolvedMethod, so route through the itab record-return helper. }
Self.EmitIntfRecordSretDispatch(TMethodCallExpr(AExpr), ADest, False)
else if AExpr is TMethodCallExpr then
Self.EmitMethodSretCall(TMethodCallExpr(AExpr), ADest, False)
else if AExpr is TInheritedCallExpr then
Self.EmitInheritedRecordSret(
@ -9061,6 +9088,7 @@ var
IsSretDiscard: Boolean;
SretBufSize: Integer;
SretRT: TRecordTypeDesc;
SretShim: TMethodCallExpr;
begin
{ Metaclass-var constructor dispatch in statement position: C.Create(args)
where C is a 'class of' variable and the result is discarded. Only the
@ -9139,6 +9167,57 @@ begin
Exit;
end;
{ Discarded interface (itab) method call returning a RECORD: the callee
follows the record-return ABI (sret pointer for a memory-class record,
register return for a register-class one). The plain EmitInterfaceCall
path below treats the return as a scalar / fat pointer and hands the callee
no sret buffer, so an sret record is written over caller memory. Allocate
a zeroed throwaway buffer, dispatch into it, then release its managed
fields. Mirrors the QBE EmitMethodCall record-discard branch. }
if (ACall.ResolvedClassType <> nil) and
(ACall.ResolvedClassType.Kind = tyInterface) and
(ACall.ResolvedReturnTypeDesc <> nil) and
(ACall.ResolvedReturnTypeDesc.Kind = tyRecord) then
begin
SretRT := TRecordTypeDesc(ACall.ResolvedReturnTypeDesc);
SretBufSize := (SretRT.TotalSize() + 15) and (-16);
Self.Emit(#9'pushq %rbx');
Self.Emit(Format(#9'subq $%d, %%rsp', [SretBufSize]));
Self.Emit(#9'movq %rsp, %rbx');
{ Zero the buffer so EmitRecordFieldReleases sees nil managed fields if the
callee leaves any unset. }
Self.Emit(#9'movq %rbx, %rdi');
Self.Emit(#9'xorl %esi, %esi');
Self.Emit(Format(#9'movq $%d, %%rdx', [SretRT.TotalSize()]));
Self.Emit(#9'callq memset');
{ EmitIntfRecordSretDispatch takes the expression form; build a transient
TMethodCallExpr view of this statement node (the relevant fields are the
same). Args are borrowed and detached before Free. }
SretShim := TMethodCallExpr.Create();
try
SretShim.ObjectName := ACall.ObjectName;
SretShim.Name := ACall.Name;
SretShim.Args := ACall.Args;
SretShim.ObjExpr := ACall.ObjExpr;
SretShim.ResolvedClassType := ACall.ResolvedClassType;
SretShim.ResolvedType := ACall.ResolvedReturnTypeDesc;
SretShim.IsGlobal := ACall.IsGlobal;
SretShim.IsVarParam := ACall.IsVarParam;
Self.EmitIntfRecordSretDispatch(SretShim, '(%rbx)', False);
finally
SretShim.Args := nil; { borrowed — do not free }
SretShim.ObjExpr := nil; { borrowed — do not free }
SretShim.Free();
end;
{ The dispatch may clobber %rbx during arg evaluation; %rsp is balanced and
still points at the buffer, so re-derive the buffer address. }
Self.Emit(#9'movq %rsp, %rbx');
Self.EmitRecordFieldReleases(SretRT, '%rbx');
Self.Emit(Format(#9'addq $%d, %%rsp', [SretBufSize]));
Self.Emit(#9'popq %rbx');
Exit;
end;
{ Interface method dispatch (statement position): route through the itab.
Pass ObjExpr so receivers that are interface-typed fields (H.S.Note())
load obj/itab from the field's fat pointer instead of bogus _obj/_itab
@ -10791,6 +10870,24 @@ begin
Self.Emit(#9'movq %rax, (%r15)');
Self.Emit(#9'popq %r15');
end
else if (Asgn.ResolvedLhsType.Kind = tyRecord) and
(Asgn.Expr is TMethodCallExpr) and
(TMethodCallExpr(Asgn.Expr).ResolvedClassType <> nil) and
(TMethodCallExpr(Asgn.Expr).ResolvedClassType.Kind = tyInterface) and
(TMethodCallExpr(Asgn.Expr).ResolvedType <> nil) and
(TMethodCallExpr(Asgn.Expr).ResolvedType.Kind = tyRecord) then
begin
{ Interface (itab) record-returning dispatch into an implicit-Self
field — EmitRecordCallSretAt routes the itab case to the record-
return helper. }
Self.Emit(#9'pushq %rbx');
Self.Emit(Format(#9'movq %s, %%rbx', [Self.VarOperand('Self')]));
if ISFld.Offset > 0 then
Self.Emit(Format(#9'addq $%d, %%rbx', [ISFld.Offset]));
Self.EmitRecordFieldReleases(TRecordTypeDesc(Asgn.ResolvedLhsType), '%rbx');
Self.EmitIntfRecordSretDispatch(TMethodCallExpr(Asgn.Expr), '(%rbx)', False);
Self.Emit(#9'popq %rbx');
end
else if (Asgn.ResolvedLhsType.Kind = tyRecord) and
(Asgn.Expr is TMethodCallExpr) and
(TMethodCallExpr(Asgn.Expr).ResolvedMethod <> nil) and
@ -10976,6 +11073,41 @@ begin
end;
Exit;
end;
{ sret assignment: interface (itab) method call returning a record. The
itab call has no ResolvedMethod, so it is classified by ResolvedClassType
= interface + ResolvedType = record. EmitIntfRecordSretDispatch writes
the record straight into the destination, honouring the record-return ABI
(hidden sret pointer for a memory-class record; register capture for a
register-class one). Mirrors the QBE EmitIntfSretDispatch path. }
if (Asgn.ResolvedLhsType <> nil) and
(Asgn.ResolvedLhsType.Kind = tyRecord) and
(Asgn.Expr is TMethodCallExpr) and
(TMethodCallExpr(Asgn.Expr).ResolvedClassType <> nil) and
(TMethodCallExpr(Asgn.Expr).ResolvedClassType.Kind = tyInterface) and
(TMethodCallExpr(Asgn.Expr).ResolvedType <> nil) and
(TMethodCallExpr(Asgn.Expr).ResolvedType.Kind = tyRecord) then
begin
{ Release the destination's prior managed fields before overwriting it,
then dispatch. The dispatch writes the constructed record (which owns
its managed fields +1) over the dest, so ownership transfers cleanly. }
Self.Emit(#9'pushq %rbx');
if FSretFunc and SameText(Asgn.Name, 'Result') then
Self.Emit(Format(#9'movq %s, %%rbx', [Self.VarOperand('Result')]))
else if Asgn.IsVarParam then
Self.Emit(Format(#9'movq %s, %%rbx', [Self.VarOperand(Asgn.Name)]))
else if Self.IsLocal(Asgn.Name) then
Self.Emit(Format(#9'leaq %s, %%rbx', [Self.VarOperand(Asgn.Name)]))
else
begin
Self.AddGlobal(Asgn.Name, Asgn.ResolvedLhsType);
if Asgn.IsThreadVar then Self.MarkThreadVar(Asgn.Name);
Self.EmitLeaqGlobal(Asgn.Name, '%rbx');
end;
Self.EmitRecordFieldReleases(TRecordTypeDesc(Asgn.ResolvedLhsType), '%rbx');
Self.EmitIntfRecordSretDispatch(TMethodCallExpr(Asgn.Expr), '(%rbx)', False);
Self.Emit(#9'popq %rbx');
Exit;
end;
{ sret assignment: method call returning a record (or jumbo set).
%rdi = sret ptr, %rsi = Self, %rdx.. = user args. }
if (Asgn.ResolvedLhsType <> nil) and
@ -15756,6 +15888,209 @@ begin
HK.Free();
end;
procedure TX86_64Backend.EmitIntfRecordSretDispatch(ACall: TMethodCallExpr;
const ADest: string; ADestIsIndirect: Boolean);
var
I, SlotOff, ArgN, Slots: Integer;
Arg: TASTExpr;
IntfD: TInterfaceTypeDesc;
HD: TList<Integer>;
HK: TList<Integer>;
HTotal, Pushed: Integer;
VFlags: string;
IE: TIdentExpr;
OverflowBytes, ABase: Integer;
RC: TRecReturnClass;
RetRec: TRecordTypeDesc;
begin
IntfD := TInterfaceTypeDesc(ACall.ResolvedClassType);
RetRec := TRecordTypeDesc(ACall.ResolvedType);
RC := ClassifyRecordReturn(RetRec);
ArgN := 0;
if ACall.Args <> nil then ArgN := ACall.Args.Count;
{ Resolve the destination to an ABSOLUTE pointer FIRST, in callee-saved %r14,
before any %rsp movement (arg pushes / overflow spill) can drift a
%rsp-relative ADest. }
Self.Emit(#9'pushq %r14');
if ADestIsIndirect then
Self.Emit(Format(#9'movq %s, %%r14', [ADest]))
else
Self.Emit(Format(#9'leaq %s, %%r14', [ADest]));
{ Same unknown-signature hoist as EmitIntfSretMethodCall; the region sits
BELOW any sret buffer space we reserve. }
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);
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
Self.Emit(Format(#9'movq %d(%%rsp), %%rax', [HTotal - HD.Get(I) + Pushed]));
Self.Emit(#9'pushq %rax');
end
else if Self.VarFlagAt(VFlags, I) then
begin
Self.EmitVarArgAddrToRax(Arg);
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 record dispatch');
end
else
begin
Self.EmitExprToEax(Arg);
Self.Emit(#9'pushq %rax');
end;
if (HK.Get(I) < akRecCall) and (not Self.VarFlagAt(VFlags, I)) 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
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 record 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]));
{ Count the arg SLOTS (var positions one slot; interface args two). }
Slots := 0;
for I := 0 to ArgN - 1 do
begin
Arg := TASTExpr(ACall.Args.Items[I]);
if (not Self.VarFlagAt(VFlags, I)) and (Arg.ResolvedType <> nil) and
(Arg.ResolvedType.Kind = tyInterface) then
Inc(Slots, 2)
else
Inc(Slots);
end;
if RC = rcSret then
begin
{ Memory-class record: hidden sret pointer in %rdi, receiver obj in %rsi,
visible args from %rdx (base index 2). The dest buffer is %r14. }
Self.Emit(#9'movq %r14, %rdi');
Self.Emit(#9'xorl %esi, %esi');
Self.Emit(Format(#9'movq $%d, %%rdx', [RetRec.TotalSize()]));
Self.Emit(#9'pushq %r10'); { preserve receiver obj across memset }
Self.Emit(#9'pushq %r11'); { preserve fptr across memset }
Self.Emit(#9'callq memset');
Self.Emit(#9'popq %r11');
Self.Emit(#9'popq %r10');
ABase := 2;
OverflowBytes := Self.EmitSretRegArgs(Slots, ABase);
Self.Emit(#9'movq %r10, %rsi');
Self.Emit(#9'movq %r14, %rdi');
Self.Emit(#9'callq *%r11');
if OverflowBytes > 0 then
Self.Emit(Format(#9'addq $%d, %%rsp', [OverflowBytes]));
Self.EmitHoistEpilogue(ACall.Args, HD, HK, HTotal, 0, True);
end
else
begin
{ Register-class record: NO hidden sret arg. Receiver obj in %rdi,
visible args from %rsi (base index 1). Capture the register return
into the dest buffer (%r14). }
ABase := 1;
OverflowBytes := Self.EmitSretRegArgs(Slots, ABase);
Self.Emit(#9'movq %r10, %rdi');
Self.Emit(#9'callq *%r11');
if OverflowBytes > 0 then
Self.Emit(Format(#9'addq $%d, %%rsp', [OverflowBytes]));
{ %r14 still holds the dest pointer (callee-saved across the call). }
Self.EmitRecordRegReturnCapture('%r14', RetRec, RC, True);
Self.EmitHoistEpilogue(ACall.Args, HD, HK, HTotal, 0, True);
end;
HD.Free();
HK.Free();
Self.Emit(#9'popq %r14');
end;
procedure TX86_64Backend.EmitClassIntfSretMethodCall(ACall: TMethodCallExpr);
var
I: Integer;

View file

@ -5077,15 +5077,34 @@ begin
end
else if AExpr is TMethodCallExpr then
begin
if TMethodCallExpr(AExpr).ResolvedMethod = nil then Exit;
MDecl := TMethodDecl(TMethodCallExpr(AExpr).ResolvedMethod);
Result := (MDecl.ResolvedReturnType <> nil) and
(MDecl.ResolvedReturnType.Kind in [tyRecord, tyStaticArray]);
{ Interface (itab) dispatch has no ResolvedMethod — classify by the call's
resolved return type instead, so a record-returning itab call routes
through the sret/record-return path (EmitIntfSretDispatch) like a direct
record method call. }
if (TMethodCallExpr(AExpr).ResolvedClassType <> nil) and
(TMethodCallExpr(AExpr).ResolvedClassType.Kind = tyInterface) then
Result := (TMethodCallExpr(AExpr).ResolvedType <> nil) and
(TMethodCallExpr(AExpr).ResolvedType.Kind in [tyRecord, tyStaticArray])
else
begin
if TMethodCallExpr(AExpr).ResolvedMethod = nil then Exit;
MDecl := TMethodDecl(TMethodCallExpr(AExpr).ResolvedMethod);
Result := (MDecl.ResolvedReturnType <> nil) and
(MDecl.ResolvedReturnType.Kind in [tyRecord, tyStaticArray]);
end;
end
else if AExpr is TFieldAccessExpr then
begin
FldA := TFieldAccessExpr(AExpr);
if not FldA.IsMethodCall then Exit;
{ Zero-arg interface (itab) dispatch (G.GetThing): no ResolvedMethod —
classify by the resolved return type, as for the args form above. }
if FldA.IsInterfaceCall then
begin
Result := (FldA.ResolvedType <> nil) and
(FldA.ResolvedType.Kind in [tyRecord, tyStaticArray]);
Exit;
end;
if FldA.ResolvedMethod = nil then Exit;
MDecl := TMethodDecl(FldA.ResolvedMethod);
Result := (MDecl.ResolvedReturnType <> nil) and
@ -5563,9 +5582,11 @@ var
ArgLine: string;
SlotOff: Integer;
PMark: Integer;
RetType: TRecordTypeDesc;
begin
PMark := PendingReleaseMark();
AArgs := nil;
RetType := TRecordTypeDesc(TASTExpr(ACall).ResolvedType);
if ACall is TMethodCallExpr then
begin
MCall := TMethodCallExpr(ACall);
@ -5610,11 +5631,15 @@ begin
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]) +
{ The visible arguments are (Self, method-args...). The RECORD-RETURN ABI
(sret vs register-class) is decided by EmitRecordReturnCallSite from the
return type's classification — exactly as for a direct record-returning
call. Passing an sret pointer unconditionally (the old behaviour) is only
correct for memory-class records; a register-class record return then
mismatched the callee ABI, shifting Self/args and corrupting memory. }
ArgLine := Format('l %s', [SelfTemp]) +
IntfDispatchArgFragment(IntfDesc, IntfDesc.MethodIndex(MethName), AArgs);
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
EmitRecordReturnCallSite(FPtrTemp, ArgLine, RetType, ASretAddr);
FlushPendingReleases(PMark);
end;
@ -6506,6 +6531,7 @@ var
ItabName: string;
SretTemp: string;
PMark: Integer;
RetTypeRec: TRecordTypeDesc;
begin
PMark := PendingReleaseMark();
@ -6671,6 +6697,33 @@ begin
EmitLine(Format(' %s =l loadl %s', [ArgTemp, SretTemp]));
EmitLine(Format(' call $_ClassRelease(l %s)', [ArgTemp]));
end
else if (ACall.ResolvedReturnTypeDesc <> nil) and
(ACall.ResolvedReturnTypeDesc.Kind in [tyRecord, tyStaticArray]) then
begin
{ Discarded RECORD/static-array return through itab dispatch: the callee
follows the record-return ABI (sret pointer for a memory-class record,
register return for a register-class one). A plain scalar call here
(the old fall-through) handed the callee no sret buffer and mis-typed
the return, so for an sret record the first ARG register doubled as the
sret pointer — the callee received a garbage argument and wrote the
record over caller memory. Route through EmitRecordReturnCallSite with
a throwaway destination so the correct ABI is used, then release the
throwaway's managed fields. }
RetTypeRec := TRecordTypeDesc(ACall.ResolvedReturnTypeDesc);
SretTemp := AllocTemp();
if ACall.ResolvedReturnTypeDesc.Kind = tyStaticArray then
EmitLine(Format(' %s =l alloc8 %d',
[SretTemp, ACall.ResolvedReturnTypeDesc.RawSize()]))
else if RetTypeRec.MaxAlign() >= 8 then
EmitLine(Format(' %s =l alloc8 %d', [SretTemp, RetTypeRec.TotalSize()]))
else
EmitLine(Format(' %s =l alloc4 %d', [SretTemp, RetTypeRec.TotalSize()]));
EmitLine(Format(' call $memset(l %s, w 0, l %d)',
[SretTemp, ACall.ResolvedReturnTypeDesc.RawSize()]));
EmitRecordReturnCallSite(FPtrTemp, ArgLine, RetTypeRec, SretTemp);
if ACall.ResolvedReturnTypeDesc.Kind = tyRecord then
EmitRecordReleaseFields(RetTypeRec, SretTemp);
end
else
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
FlushPendingReleases(PMark);

View file

@ -49,6 +49,14 @@ type
procedure TestRun_InheritedInterface_DescendantToVar;
procedure TestRun_InheritedInterface_OverrideAndInheritedMethod;
procedure TestRun_InheritedInterface_NonVirtualMethod;
{ An itab-dispatched method returning a RECORD. Two ABI shapes:
a memory-class record (has a managed field -> sret) and a register-class
record (all-scalar, returned in registers). Both must work when the
result is ASSIGNED and when DISCARDED in statement position — the
discarded statement and the assignment used to mis-handle the
record-return ABI and corrupt memory (bug #5). }
procedure TestRun_InterfaceMethod_ReturnsSretRecord;
procedure TestRun_InterfaceMethod_ReturnsRegisterRecord;
end;
implementation
@ -406,6 +414,77 @@ begin
AssertRunsOnAll(Src, 'hello' + LE + 'hello' + LE, 0);
end;
procedure TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsSretRecord;
const
{ TRect has a managed (string) field, so ClassifyRecordReturn => sret. }
Src = '''
program P;
type
TRect = record Name: string; N: Integer; end;
IShape = interface
function MakeRect(AN: Integer): TRect;
end;
TShape = class(IShape)
function MakeRect(AN: Integer): TRect;
end;
function TShape.MakeRect(AN: Integer): TRect;
begin
Result.Name := 'r';
Result.N := AN;
WriteLn('callee ', AN)
end;
var
M: IShape;
R: TRect;
begin
M := TShape.Create();
R := M.MakeRect(5); { assigned sret record return }
WriteLn('assigned ', R.N);
M.MakeRect(7) { discarded sret record return }
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src,
'callee 5' + LE + 'assigned 5' + LE + 'callee 7' + LE, 0);
end;
procedure TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsRegisterRecord;
const
{ TPt is all-scalar, so ClassifyRecordReturn => a register-class return
(no sret buffer); the itab dispatch must capture the register result. }
Src = '''
program P;
type
TPt = record X, Y: Integer; end;
IShape = interface
function MakePt(AN: Integer): TPt;
end;
TShape = class(IShape)
function MakePt(AN: Integer): TPt;
end;
function TShape.MakePt(AN: Integer): TPt;
begin
Result.X := AN;
Result.Y := AN * 2;
WriteLn('callee ', AN)
end;
var
M: IShape;
R: TPt;
begin
M := TShape.Create();
R := M.MakePt(5); { assigned register-class record return }
WriteLn('assigned ', R.X, ' ', R.Y);
M.MakePt(9) { discarded register-class record return }
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src,
'callee 5' + LE + 'assigned 5 10' + LE + 'callee 9' + LE, 0);
end;
initialization
RegisterTest(TE2EInterfaceTests);