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

fix(codegen): interface-dispatch ABI — record args, var/out params, call receivers, discarded returns

Browse source 
Four itab-dispatch ABI gaps reported from Andrew Haines'
unify_backend_interface branch, fixed on both backends:

- Record by const/value through interface dispatch (QBE) passed the
  record as 'w <addr>' — truncating to the low 8 bytes and shifting
  every later argument.  Dispatch sites now use the same :_ffi_<Name>
  aggregate ABI as direct calls.  (Native already passed the address.)
- var/out parameters through interface dispatch loaded the VALUE
  instead of passing the slot address.  Root causes: a 1-based loop
  over the 0-based var-flag string in MethodParamIsVar (parameter 0's
  flag was never seen), the QBE statement path ignoring var flags, and
  the native push loops never emitting addresses.  Strings and
  dynarrays covered.
- TFuncCallExpr receivers (GetDriver(x).Info()) previously raised
  fail-loud.  The receiver call is sret-evaluated into a temporary fat
  pair; the owned +1 obj is released right after the consuming call
  (QBE: pending-release list flushed by every call emitter; native:
  pair kept above the hoist region, released preserving result regs).
- Discarded interface-returning itab calls in statement position
  clobbered memory through the register the callee expects to hold the
  sret buffer (QBE: missing buffer; native: receiver passed where the
  buffer belongs, shifting Self).  Statement calls now get a throwaway
  sret buffer and release the returned obj.  Semantic records the itab
  return type on TMethodCallStmt (bif-coverage clean).

e2e tests run on both backends (cp.test.e2e.imap); IR tests pin the
aggregate ABI, slot-address passing, and the discard-sret+release
sequence (cp.test.interfaces).
This commit is contained in:
Graeme Geldenhuys 2026-06-12 13:27:00 +01:00
parent c20ddd549d
commit f0f888f2c5
7 changed files with 684 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -271,9 +271,11 @@ type
AIsVarParam: Boolean;
AIntf: TInterfaceTypeDesc;
const AMethName: string; AArgs: TObjectList;
AObjExpr: TASTExpr = nil);
AObjExpr: TASTExpr = nil;
ADiscardIntfRet: Boolean = False);
procedure EmitInterfaceFieldCall(AFld: TFieldInfo; AIntf: TInterfaceTypeDesc;
const AMethName: string; AArgs: TObjectList);
const AMethName: string; AArgs: TObjectList;
ADiscardIntfRet: Boolean = False);
{ Emit typeinfo / itab / impllist blocks for interfaces and the classes
that implement them. Mirrors the QBE backend's EmitInterfaceDefs. }
procedure EmitInterfaceDefs(ATypeDecls: TObjectList;
@ -1831,12 +1833,34 @@ var
HK: TList<Integer>;
HTotal, Pushed: Integer;
VFlags: string;
RecvOnStack: Boolean;
DiscSz: Integer;
begin
{ x86_64: pointers are 8 bytes (this backend's invariant, like the rest of the
file). i386/arm64 backends will be separate TNativeBackend subclasses. }
Ps := 8;
ArgN := 0;
if AArgs <> nil then ArgN := AArgs.Count;
RecvOnStack := False;
if (AObjExpr <> nil) and (AObjExpr is TFuncCallExpr) then
begin
{ Function-call receiver (GetDriver().Info()): evaluate it FIRST via the
sret convention — it is a call and would clobber pushed args. The
owned (+1) fat pair stays at (%rsp) until after the dispatch, then the
obj is released. }
Self.EmitIntfSretCall(TFuncCallExpr(AObjExpr));
RecvOnStack := True;
end;
DiscSz := 0;
if ADiscardIntfRet then
begin
{ Throwaway sret buffer for a DISCARDED interface return: without it the
callee would write its 16-byte fat-pointer return through %rdi. }
Self.Emit(#9'subq $16, %rsp');
Self.Emit(#9'movq $0, (%rsp)');
Self.Emit(#9'movq $0, 8(%rsp)');
DiscSz := 16;
end;
{ Hoist record-call args and (shape-classified) string args — the
implementing method's const-ness is invisible at an interface call site,
so every string-typed value argument is protected by shape. The var
@ -1858,6 +1882,13 @@ 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
{ var/out position: pass the slot ADDRESS — same rule as direct
calls; covers managed types (string, dynarray) the callee rebinds. }
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
@ -1901,8 +1932,10 @@ begin
Self.EmitExprToEax(Arg);
Self.Emit(#9'pushq %rax');
end;
{ Track bytes pushed so far — hoisted-value reloads are %rsp-relative. }
if (HK.Get(I) < akRecCall) and (Arg.ResolvedType <> nil) and
{ Track bytes pushed so far — hoisted-value reloads are %rsp-relative.
var positions always occupy one slot, even for interface-typed args. }
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
@ -1914,7 +1947,13 @@ begin
The receiver shapes that need EmitExprToEax (FA.Base) are not yet reachable
here — args are already on the stack, so only the call-free shapes (class
access, local/global record, var-param) are safe; reject the rest loudly. }
if (AObjExpr <> nil) and (AObjExpr is TFieldAccessExpr) then
if RecvOnStack then
begin
{ Receiver fat pair sits above the discard buffer + hoist region + args. }
Self.Emit(Format(#9'movq %d(%%rsp), %%r10', [Pushed + HTotal + DiscSz]));
Self.Emit(Format(#9'movq %d(%%rsp), %%rax', [Pushed + HTotal + DiscSz + 8]));
end
else if (AObjExpr <> nil) and (AObjExpr is TFieldAccessExpr) then
begin
Self.EmitInterfaceFieldAddr(TFieldAccessExpr(AObjExpr), '%r10');
Self.Emit(#9'movq 8(%r10), %rax'); { itab }
@ -1939,21 +1978,57 @@ begin
else
Self.Emit(Format(#9'movq %d(%%rax), %%r11', [SlotOff]));
{ Pop args into %rsi/%rdx/... (shift by 1 for %rdi = Self).
Count slots: interface args occupy 2 slots each. }
Count slots: interface args occupy 2 slots each, except at var
positions (one address slot). }
SlotOff := 0;
for I := 0 to ArgN - 1 do
begin
Arg := TASTExpr(AArgs.Items[I]);
if (Arg.ResolvedType <> nil) and (Arg.ResolvedType.Kind = tyInterface) then
if (not Self.VarFlagAt(VFlags, I)) and (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 + 1]);
Self.Emit(#9'movq %r10, %rdi');
if ADiscardIntfRet then
begin
{ sret convention: %rdi = buffer, %rsi = Self, visible args from %rdx. }
for I := SlotOff - 1 downto 0 do
Self.Emit(#9'popq ' + SysVArgRegs64[I + 2]);
Self.Emit(Format(#9'leaq %d(%%rsp), %%rdi', [HTotal]));
Self.Emit(#9'movq %r10, %rsi');
end
else
begin
for I := SlotOff - 1 downto 0 do
Self.Emit(#9'popq ' + SysVArgRegs64[I + 1]);
Self.Emit(#9'movq %r10, %rdi');
end;
Self.Emit(#9'callq *%r11');
Self.EmitHoistEpilogue(AArgs, HD, HK, HTotal, 0, True);
if ADiscardIntfRet then
begin
{ Discarded owned return: release the obj half; statement position, so
no live result registers to preserve. }
Self.Emit(#9'movq (%rsp), %rdi');
Self.Emit(#9'callq _ClassRelease');
Self.Emit(#9'addq $16, %rsp');
end;
if RecvOnStack then
begin
{ Release the owned receiver pair; preserve the dispatch result regs
(this path also serves expression position). }
Self.Emit(#9'subq $24, %rsp');
Self.Emit(#9'movq %rax, 0(%rsp)');
Self.Emit(#9'movq %rdx, 8(%rsp)');
Self.Emit(#9'movsd %xmm0, 16(%rsp)');
Self.Emit(#9'movq 24(%rsp), %rdi');
Self.Emit(#9'callq _ClassRelease');
Self.Emit(#9'movq 0(%rsp), %rax');
Self.Emit(#9'movq 8(%rsp), %rdx');
Self.Emit(#9'movsd 16(%rsp), %xmm0');
Self.Emit(#9'addq $40, %rsp');
end;
HD.Free();
HK.Free();
end;
@ -1972,6 +2047,14 @@ var
begin
ArgN := 0;
if AArgs <> nil then ArgN := AArgs.Count;
if ADiscardIntfRet then
begin
{ Throwaway sret buffer for a DISCARDED interface return: without it the
callee would write its 16-byte fat-pointer return through %rdi. }
Self.Emit(#9'subq $16, %rsp');
Self.Emit(#9'movq $0, (%rsp)');
Self.Emit(#9'movq $0, 8(%rsp)');
end;
{ Same unknown-signature hoist as EmitInterfaceCall. }
HD := TList<Integer>.Create();
HK := TList<Integer>.Create();
@ -1988,6 +2071,13 @@ 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
{ var/out position: pass the slot ADDRESS — same rule as direct
calls; covers managed types (string, dynarray) the callee rebinds. }
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
@ -2031,8 +2121,10 @@ begin
Self.EmitExprToEax(Arg);
Self.Emit(#9'pushq %rax');
end;
{ Track bytes pushed so far — hoisted-value reloads are %rsp-relative. }
if (HK.Get(I) < akRecCall) and (Arg.ResolvedType <> nil) and
{ Track bytes pushed so far — hoisted-value reloads are %rsp-relative.
var positions always occupy one slot, even for interface-typed args. }
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
@ -2050,21 +2142,40 @@ begin
Self.Emit(#9'movq (%rax), %r11')
else
Self.Emit(Format(#9'movq %d(%%rax), %%r11', [SlotOff]));
{ Count total slots then pop in reverse. }
{ Count total slots then pop in reverse; var positions take one slot. }
SlotOff := 0;
for I := 0 to ArgN - 1 do
begin
Arg := TASTExpr(AArgs.Items[I]);
if (Arg.ResolvedType <> nil) and (Arg.ResolvedType.Kind = tyInterface) then
if (not Self.VarFlagAt(VFlags, I)) and (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 + 1]);
Self.Emit(#9'movq %r10, %rdi');
if ADiscardIntfRet then
begin
{ sret convention: %rdi = buffer, %rsi = Self, visible args from %rdx. }
for I := SlotOff - 1 downto 0 do
Self.Emit(#9'popq ' + SysVArgRegs64[I + 2]);
Self.Emit(Format(#9'leaq %d(%%rsp), %%rdi', [HTotal]));
Self.Emit(#9'movq %r10, %rsi');
end
else
begin
for I := SlotOff - 1 downto 0 do
Self.Emit(#9'popq ' + SysVArgRegs64[I + 1]);
Self.Emit(#9'movq %r10, %rdi');
end;
Self.Emit(#9'callq *%r11');
Self.EmitHoistEpilogue(AArgs, HD, HK, HTotal, 0, True);
if ADiscardIntfRet then
begin
{ Discarded owned return: release the obj half (statement position). }
Self.Emit(#9'movq (%rsp), %rdi');
Self.Emit(#9'callq _ClassRelease');
Self.Emit(#9'addq $16, %rsp');
end;
HD.Free();
HK.Free();
end;
@ -6916,11 +7027,15 @@ begin
begin
if ACall.IsImplicitSelf and (ACall.ImplicitBaseInfo <> nil) then
Self.EmitInterfaceFieldCall(ACall.ImplicitBaseInfo,
TInterfaceTypeDesc(ACall.ResolvedClassType), ACall.Name, ACall.Args)
TInterfaceTypeDesc(ACall.ResolvedClassType), ACall.Name, ACall.Args,
(ACall.ResolvedReturnTypeDesc <> nil) and
(ACall.ResolvedReturnTypeDesc.Kind = tyInterface))
else
Self.EmitInterfaceCall(ACall.ObjectName, ACall.IsGlobal, ACall.IsVarParam,
TInterfaceTypeDesc(ACall.ResolvedClassType), ACall.Name, ACall.Args,
ACall.ObjExpr);
ACall.ObjExpr,
(ACall.ResolvedReturnTypeDesc <> nil) and
(ACall.ResolvedReturnTypeDesc.Kind = tyInterface));
Exit;
end;
@ -12072,6 +12187,13 @@ begin
[16 + HTotal - HD.Get(I) + Pushed]));
Self.Emit(#9'pushq %rax');
end
else if Self.VarFlagAt(VFlags, I) then
begin
{ var/out position: pass the slot ADDRESS — same rule as direct
calls; covers managed types (string, dynarray) the callee rebinds. }
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
@ -12115,7 +12237,8 @@ begin
Self.EmitExprToEax(Arg);
Self.Emit(#9'pushq %rax');
end;
if (HK.Get(I) < akRecCall) and (Arg.ResolvedType <> nil) and
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
@ -12170,12 +12293,14 @@ begin
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. }
{ Pop args shifted by 2: %rdi = sret buffer, %rsi = receiver obj.
var positions take one slot. }
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
if (not Self.VarFlagAt(VFlags, I)) and (Arg.ResolvedType <> nil) and
(Arg.ResolvedType.Kind = tyInterface) then
Inc(SlotOff, 2)
else
Inc(SlotOff);

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

@ -127,6 +127,14 @@ type
leave the linear entry-prelude region of a function — see SeenArcStore. }
FArcSlotWritten: TStringList;
{ Obj temps of owned (+1) interface pairs materialised by
EmitInterfaceExprPair for call-shaped sources (a function or itab call
returning an interface used as receiver or argument). The dispatch
site that consumed the pair captures a mark before evaluating its
receiver/args and flushes the releases right after its call
instruction — the object must stay alive across the call. }
FPendingObjReleases: TStringList;
{ Record types referenced by a record-by-value FFI (cdecl external) call
parameter. Each entry is a record name; Objects[] holds the
TRecordTypeDesc. At end of Generate/GenerateUnit/AppendUnit/
@ -349,6 +357,19 @@ type
ACall is a TMethodCallExpr (args form) or a TFieldAccessExpr with
IsInterfaceCall set (zero-arg form). }
procedure EmitIntfSretDispatch(ACall: TASTExpr; const ASretAddr: string);
{ Build the visible-argument fragment (', t %a, ...') for an itab
dispatch site. No TMethodParam list exists there — only the var-param
flags recorded on the interface descriptor and each argument's
resolved type — so: var/out positions pass the slot address, interface
args pass both fat-pointer slots, records use the aggregate FFI type,
and scalars use their natural QBE type. }
function IntfDispatchArgFragment(AIntfDesc: TInterfaceTypeDesc;
AMethIdx: Integer; AArgs: TObjectList): string;
{ Deferred releases for owned interface pairs produced while building a
call (see FPendingObjReleases). Capture the mark before evaluating
receiver/args, flush right after the call instruction. }
function PendingReleaseMark(): Integer;
procedure FlushPendingReleases(AMark: Integer);
procedure EmitRecordReturnCallSite(const AFuncName, AVisibleArgs: string;
ARetType: TRecordTypeDesc;
const ADestAddr: string);
@ -569,6 +590,8 @@ begin
FPromotedTypes := TStringList.Create();
FArcSlotWritten := TStringList.Create();
FArcSlotWritten.CaseSensitive := True;
FPendingObjReleases := TStringList.Create();
FPendingObjReleases.CaseSensitive := True;
FFFIRecordTypes := TStringList.Create();
FFFIRecordTypes.CaseSensitive := True;
FFFIRecordTypes.Sorted := True;
@ -599,6 +622,7 @@ begin
FConstArgUnsafe.Free();
FPromotedTypes.Free();
FArcSlotWritten.Free();
FPendingObjReleases.Free();
FFFIRecordTypes.Free();
FFFIRecordEmitted.Free();
FCapturedVars.Free();
@ -5076,6 +5100,60 @@ begin
end;
end;
function TCodeGenQBE.PendingReleaseMark(): Integer;
begin
Result := FPendingObjReleases.Count;
end;
procedure TCodeGenQBE.FlushPendingReleases(AMark: Integer);
begin
while FPendingObjReleases.Count > AMark do
begin
EmitLine(Format(' call $_ClassRelease(l %s)',
[FPendingObjReleases.Strings[FPendingObjReleases.Count - 1]]));
FPendingObjReleases.Delete(FPendingObjReleases.Count - 1);
end;
end;
function TCodeGenQBE.IntfDispatchArgFragment(AIntfDesc: TInterfaceTypeDesc;
AMethIdx: Integer; AArgs: TObjectList): string;
var
I: Integer;
Arg: TASTExpr;
ArgTemp: string;
begin
Result := '';
if AArgs = nil then Exit;
for I := 0 to AArgs.Count - 1 do
begin
Arg := TASTExpr(AArgs.Items[I]);
if AIntfDesc.MethodParamIsVar(AMethIdx, I) then
{ var/out params pass the slot address — same rule as direct calls;
covers managed types (string, dynarray) whose slot the callee
rebinds. }
Result := Result + Format(', l %s', [EmitLValueAddr(Arg)])
else if (Arg.ResolvedType <> nil) and
(Arg.ResolvedType.Kind = tyInterface) then
{ Interface args are two-slot fat pointers; the callee declares
obj + itab params. }
Result := Result + InterfaceArgFragment(Arg)
else if Arg.ResolvedType <> nil then
begin
ArgTemp := EmitExpr(Arg);
{ QbeParamTypeOf gives records the same :_ffi_<Name> aggregate ABI
the implementing method declares; scalars get their natural type
(w/l/s/d) instead of an unconditional w. }
Result := Result + Format(', %s %s',
[QbeParamTypeOf(Arg.ResolvedType), ArgTemp]);
end
else
begin
ArgTemp := EmitExpr(Arg);
Result := Result + Format(', w %s', [ArgTemp]);
end;
end;
end;
procedure TCodeGenQBE.EmitIntfSretDispatch(ACall: TASTExpr;
const ASretAddr: string);
var
@ -5090,8 +5168,9 @@ var
ArgTemp: string;
ArgLine: string;
SlotOff: Integer;
I: Integer;
PMark: Integer;
begin
PMark := PendingReleaseMark();
AArgs := nil;
if ACall is TMethodCallExpr then
begin
@ -5139,27 +5218,10 @@ begin
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;
ArgLine := Format('l %s, l %s', [ASretAddr, SelfTemp]) +
IntfDispatchArgFragment(IntfDesc, IntfDesc.MethodIndex(MethName), AArgs);
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
FlushPendingReleases(PMark);
end;
procedure TCodeGenQBE.EmitRecordCallSret(AExpr: TASTExpr;
@ -5177,7 +5239,9 @@ var
FuncName: string;
Ptr: string;
RetType: TRecordTypeDesc;
PMark: Integer;
begin
PMark := PendingReleaseMark();
if AExpr is TFuncCallExpr then
begin
FCallExpr := TFuncCallExpr(AExpr);
@ -5225,6 +5289,7 @@ begin
end;
end;
EmitRecordReturnCallSite(FuncName, VisArgs, RetType, ASretAddr);
FlushPendingReleases(PMark);
end
else if AExpr is TMethodCallExpr then
begin
@ -5275,6 +5340,7 @@ begin
end;
end;
EmitRecordReturnCallSite(FuncName, VisArgs, RetType, ASretAddr);
FlushPendingReleases(PMark);
end
else if AExpr is TFieldAccessExpr then
begin
@ -5322,6 +5388,7 @@ begin
FuncName := '$' + MethodEmitName(MDecl, MDecl.OwnerTypeName, FldAccess.FieldName);
VisArgs := Format('l %s', [SelfTemp]);
EmitRecordReturnCallSite(FuncName, VisArgs, RetType, ASretAddr);
FlushPendingReleases(PMark);
end;
end;
@ -5880,7 +5947,10 @@ var
SlotAddr: string;
DataTemp: string;
ItabName: string;
SretTemp: string;
PMark: Integer;
begin
PMark := PendingReleaseMark();
{ Interface method dispatch: load obj + itab, index by method slot }
if (ACall.ResolvedClassType <> nil) and
(ACall.ResolvedClassType.Kind = tyInterface) then
@ -5930,22 +6000,27 @@ begin
EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff]));
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
end;
{ Emit args: no concrete param info at interface-dispatch site, so use
the resolved type of each argument expression to pick the QBE type.
Pointer-typed args (var params written as TAddrOfExpr or already resolved
as pointer/class) use 'l'; all other scalar args use 'w'. }
ArgLine := Format('l %s', [SelfTemp]);
for I := 0 to ACall.Args.Count - 1 do
ArgLine := Format('l %s', [SelfTemp]) +
IntfDispatchArgFragment(IntfDesc, IntfDesc.MethodIndex(ACall.Name),
ACall.Args);
if (ACall.ResolvedReturnTypeDesc <> nil) and
(ACall.ResolvedReturnTypeDesc.Kind = tyInterface) then
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
if (TASTExpr(ACall.Args.Items[I]).ResolvedType <> nil) and
(TASTExpr(ACall.Args.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;
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
{ Discarded interface return: the callee still writes its fat pointer
through a hidden first sret arg — without a buffer it would write
through whatever the first register holds. Give it a throwaway
buffer and release the returned (owned +1) obj. }
SretTemp := AllocTemp();
EmitLine(Format(' %s =l alloc8 16', [SretTemp]));
EmitLine(Format(' call $memset(l %s, w 0, l 16)', [SretTemp]));
EmitLine(Format(' call %s(l %s, %s)', [FPtrTemp, SretTemp, ArgLine]));
ArgTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [ArgTemp, SretTemp]));
EmitLine(Format(' call $_ClassRelease(l %s)', [ArgTemp]));
end
else
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
FlushPendingReleases(PMark);
Exit;
end;
@ -6057,6 +6132,7 @@ begin
EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff]));
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
FlushPendingReleases(PMark);
EmitOwnedArgReleases(ACall.Args, ArgTemps, MDecl.Params);
ReleaseConstStringArgs(ACall.Args, ArgTemps, MDecl.Params);
ArgTemps.Free();
@ -6071,6 +6147,7 @@ begin
else
FuncName := '$' + MethodEmitName(MDecl, RT.Name, ACall.Name);
EmitLine(Format(' call %s(%s)', [FuncName, ArgLine]));
FlushPendingReleases(PMark);
EmitOwnedArgReleases(ACall.Args, ArgTemps, MDecl.Params);
ReleaseConstStringArgs(ACall.Args, ArgTemps, MDecl.Params);
ArgTemps.Free();
@ -6266,6 +6343,7 @@ begin
FuncName := '$' + MethodEmitName(MDecl, RT.Name, ACall.Name);
EmitLine(Format(' call %s(%s)', [FuncName, ArgLine]));
end;
FlushPendingReleases(PMark);
EmitOwnedArgReleases(ACall.Args, ArgTemps, MDecl.Params);
ReleaseConstStringArgs(ACall.Args, ArgTemps, MDecl.Params);
finally
@ -6351,10 +6429,12 @@ var
Par: TMethodParam;
QType: string;
I: Integer;
PMark: Integer;
begin
{ TObject inherited calls are no-ops — no method body exists }
if ACall.ResolvedMethod = nil then Exit;
PMark := PendingReleaseMark();
MDecl := TMethodDecl(ACall.ResolvedMethod);
{ Load Self from the current method's local slot }
@ -6411,6 +6491,7 @@ begin
else
EmitLine(Format(' call $%s(%s)',
[MethodEmitName(MDecl, MDecl.OwnerTypeName, ACall.Name), ArgLine]));
FlushPendingReleases(PMark);
end;
procedure TCodeGenQBE.EmitParamAllocs(AMethod: TMethodDecl;
@ -7703,7 +7784,9 @@ var
SetQT: string;
SetLoad: string;
SetStore: string;
PMark: Integer;
begin
PMark := PendingReleaseMark();
{ Indirect call through a procedural-typed variable: load the function
pointer from the variable and call through it. For 'of object' types
the variable's slot is a 16-byte (Code, Data) block; load both halves
@ -7821,6 +7904,7 @@ begin
end;
EmitLine(Format(' call $%s(%s)',
[MethodEmitName(MDecl, MDecl.OwnerTypeName, ACall.Name), ArgLine]));
FlushPendingReleases(PMark);
ReleaseConstStringArgs(ACall.Args, ArgTemps, MDecl.Params);
Exit;
finally
@ -7917,6 +8001,7 @@ begin
EmitLine(Format(' call $%s(%s)', [QBEMangle(MDecl.ResolvedQbeName), ArgLine]))
else
EmitLine(Format(' call $%s(%s)', [QBEMangle(ACall.Name), ArgLine]));
FlushPendingReleases(PMark);
EmitOwnedArgReleases(ACall.Args, ArgTemps, MDecl.Params);
ReleaseConstStringArgs(ACall.Args, ArgTemps, MDecl.Params);
finally
@ -8431,7 +8516,9 @@ var
SlotAddr: string;
DataTemp: string;
SQT: string;
PMark: Integer;
begin
PMark := PendingReleaseMark();
if AExpr is TFuncCallExpr then
begin
{ Standalone function call expression }
@ -9648,6 +9735,7 @@ begin
end;
T := AllocTemp();
EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FuncName, ArgLine]));
FlushPendingReleases(PMark);
ReleaseConstStringArgs(FC.Args, ArgTemps, MDecl.Params);
Exit(MaybeNormalizeExtReturn(T, MDecl));
finally
@ -9719,6 +9807,7 @@ begin
end;
T := AllocTemp();
EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FuncName, ArgLine]));
FlushPendingReleases(PMark);
EmitOwnedArgReleases(FC.Args, ArgTemps, MDecl.Params);
ReleaseConstStringArgs(FC.Args, ArgTemps, MDecl.Params);
Result := MaybeNormalizeExtReturn(T, MDecl);
@ -9791,6 +9880,7 @@ begin
if (MCallExpr.ResolvedClassType <> nil) and
(MCallExpr.ResolvedClassType.Kind = tyInterface) then
begin
PMark := PendingReleaseMark();
IntfDesc := TInterfaceTypeDesc(MCallExpr.ResolvedClassType);
if MCallExpr.ObjExpr <> nil then
{ Receiver is an expression (record/class field, as-cast, implicit
@ -9816,28 +9906,16 @@ begin
EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff]));
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
end;
{ Evaluate arguments: use var-param flags stored on the interface desc }
ArgLine := Format('l %s', [SelfTemp]);
for I := 0 to MCallExpr.Args.Count - 1 do
begin
if IntfDesc.MethodParamIsVar(IntfDesc.MethodIndex(MCallExpr.Name), I) then
ArgLine := ArgLine + Format(', l %s',
[EmitLValueAddr(TASTExpr(MCallExpr.Args.Items[I]))])
else
begin
ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I]));
if (TASTExpr(MCallExpr.Args.Items[I]).ResolvedType <> nil) and
(TASTExpr(MCallExpr.Args.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;
{ Evaluate arguments: var-param flags + resolved arg types decide the
ABI — same rules as every other itab dispatch site. }
ArgLine := Format('l %s', [SelfTemp]) +
IntfDispatchArgFragment(IntfDesc,
IntfDesc.MethodIndex(MCallExpr.Name), MCallExpr.Args);
QType := QbeTypeOf(MCallExpr.ResolvedType);
if QType = '' then QType := 'w';
T := AllocTemp();
EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FPtrTemp, ArgLine]));
FlushPendingReleases(PMark);
Exit(T);
end;
@ -9870,6 +9948,7 @@ begin
if MCallExpr.ResolvedMethod <> nil then
begin
MDecl := TMethodDecl(MCallExpr.ResolvedMethod);
PMark := PendingReleaseMark();
ArgLine := Format('l %s', [SelfTemp]);
ArgTemps := TStringList.Create();
try
@ -9920,6 +9999,7 @@ begin
else
FuncName := '$' + MethodEmitName(MDecl, RT.Name, MCallExpr.Name);
EmitLine(Format(' call %s(%s)', [FuncName, ArgLine]));
FlushPendingReleases(PMark);
EmitOwnedArgReleases(MCallExpr.Args, ArgTemps, MDecl.Params);
ReleaseConstStringArgs(MCallExpr.Args, ArgTemps, MDecl.Params);
finally
@ -10057,6 +10137,7 @@ begin
end;
{ Build argument string }
PMark := PendingReleaseMark();
ArgLine := Format('l %s', [SelfTemp]);
ArgTemps := TStringList.Create();
for I := 0 to MCallExpr.Args.Count - 1 do
@ -10105,6 +10186,7 @@ begin
end
else
EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FuncName, ArgLine]));
FlushPendingReleases(PMark);
EmitOwnedArgReleases(MCallExpr.Args, ArgTemps, MDecl.Params);
ReleaseConstStringArgs(MCallExpr.Args, ArgTemps, MDecl.Params);
ArgTemps.Free();
@ -11850,6 +11932,27 @@ begin
AObjTemp := ObjT;
AItabTemp := ItabT;
end
else if IsInterfaceCall(AExpr) then
begin
{ Interface-returning CALL as the pair source (function-call receiver:
GetDriver().Info(), or a chained itab call). Must be checked before
the stored-field branch — a zero-arg itab call is field-access shaped.
Evaluate via the sret convention into a fresh 16-byte buffer and load
the pair. The callee AddRef'd into the buffer, so the pair is owned
(+1) — defer the obj release to the consuming dispatch site (after
its call instruction). }
ObjT := AllocTemp();
EmitLine(Format(' %s =l alloc8 16', [ObjT]));
EmitLine(Format(' call $memset(l %s, w 0, l 16)', [ObjT]));
EmitRecordCallSret(AExpr, ObjT);
AObjTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [AObjTemp, ObjT]));
ItabT := AllocTemp();
EmitLine(Format(' %s =l add %s, 8', [ItabT, ObjT]));
AItabTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [AItabTemp, ItabT]));
FPendingObjReleases.Add(AObjTemp);
end
else if AExpr is TFieldAccessExpr then
begin
{ Interface stored in a record/class field: the fat pointer is contiguous

5
compiler/src/main/pascal/uAST.pas
View file

@ -474,6 +474,11 @@ type
{ Set by uSemantic: }
[Unretained] ResolvedClassType: TTypeDesc; { not owned }
[Unretained] ResolvedMethod: TObject; { TMethodDecl — not owned; avoids forward ref }
{ Set by uSemantic for itab dispatch only: the method's resolved return
type. A discarded interface/record-returning call in statement
position still needs the sret calling convention — codegen reads this
to allocate a throwaway buffer. }
[Unretained] ResolvedReturnTypeDesc: TTypeDesc; { not owned; nil for procedures }
IsImplicitSelf: Boolean; { ObjectName is a field of Self }
[Unretained] ImplicitBaseInfo: TFieldInfo; { not owned — the field of Self }
IsGlobal: Boolean; { set by uSemantic — ObjectName is a program-level global }

22
compiler/src/main/pascal/uSemantic.pas
View file

@ -202,6 +202,11 @@ type
{ Re-type set-literal args to their `set of` param type post-overload. }
procedure RetypeSetLiteralArgs(AArgs: TObjectList; AMDecl: TMethodDecl);
procedure AnalyseMethodCall(ACall: TMethodCallStmt);
{ Resolve the return type of an interface method for a statement-position
itab dispatch; nil for procedures. Codegen uses this to give discarded
sret-convention returns a throwaway buffer. }
function ResolveIntfMethodReturn(AIntf: TInterfaceTypeDesc;
const AMethName: string): TTypeDesc;
procedure AnalyseInheritedCall(ACall: TInheritedCallStmt);
procedure AnalyseCaseStmt(AStmt: TCaseStmt);
function AnalyseMethodCallExpr(AExpr: TMethodCallExpr): TTypeDesc;
@ -5494,6 +5499,17 @@ begin
AnalyseCaseStmt(TCaseStmt(AStmt));
end;
function TSemanticAnalyser.ResolveIntfMethodReturn(AIntf: TInterfaceTypeDesc;
const AMethName: string): TTypeDesc;
var
RetName: string;
begin
Result := nil;
RetName := AIntf.MethodReturnTypeName(AIntf.MethodIndex(AMethName));
if RetName <> '' then
Result := FindTypeOrInstantiate(RetName);
end;
procedure TSemanticAnalyser.AnalyseMethodCall(ACall: TMethodCallStmt);
var
ObjSym: TSymbol;
@ -5528,6 +5544,8 @@ begin
AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
ACall.ResolvedClassType := ObjType;
ACall.ResolvedMethod := nil;
ACall.ResolvedReturnTypeDesc :=
ResolveIntfMethodReturn(TInterfaceTypeDesc(ObjType), ACall.Name);
Exit;
end;
RT := TRecordTypeDesc(ObjType);
@ -5591,6 +5609,8 @@ begin
AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
ACall.ResolvedClassType := ACall.ImplicitBaseInfo.TypeDesc;
ACall.ResolvedMethod := nil;
ACall.ResolvedReturnTypeDesc := ResolveIntfMethodReturn(
TInterfaceTypeDesc(ACall.ImplicitBaseInfo.TypeDesc), ACall.Name);
Exit;
end;
RT := TRecordTypeDesc(ACall.ImplicitBaseInfo.TypeDesc);
@ -5652,6 +5672,8 @@ begin
ACall.ResolvedMethod := nil; { nil = interface dispatch, not class dispatch }
ACall.IsGlobal := ObjSym.IsGlobal;
ACall.IsVarParam := (ObjSym.Kind = skVarParameter);
ACall.ResolvedReturnTypeDesc := ResolveIntfMethodReturn(
TInterfaceTypeDesc(ObjSym.TypeDesc), ACall.Name);
Exit;
end;

8
compiler/src/main/pascal/uSymbolTable.pas
View file

@ -1071,10 +1071,12 @@ begin
if (AMethodIndex < 0) or (AMethodIndex >= FParamIsVar.Count) then Exit;
Flags := FParamIsVar.Strings[AMethodIndex];
if Flags = '' then Exit;
{ Walk through comma-separated '0'/'1' flags to find AParamIndex }
{ Walk through comma-separated '0'/'1' flags to find AParamIndex.
Blaise strings are 0-based — starting at index 1 skipped the first
parameter's flag entirely (var/out at position 0 was never seen). }
CurPar := 0;
Idx := 1;
while Idx <= Length(Flags) do
Idx := 0;
while Idx < Length(Flags) do
begin
if Flags[Idx] = ',' then
CurPar := CurPar + 1

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

@ -33,6 +33,11 @@ type
procedure TestRun_StaticArrayOfInterface_FatPointer;
procedure TestRun_InterfaceResult_NilCompare_Registry;
procedure TestRun_IntfMethodReturningIntf_ToLocal;
procedure TestRun_IntfDispatch_ConstRecordArg;
procedure TestRun_IntfDispatch_OutStringArg;
procedure TestRun_IntfDispatch_VarDynArrayArg;
procedure TestRun_FuncCallReceiver_IntfDispatch;
procedure TestRun_DiscardedIntfReturn_StatementPosition;
end;
implementation
@ -630,6 +635,202 @@ begin
'42' + LineEnding + '21' + LineEnding, 0);
end;
const
{ Record passed by const through itab dispatch: the callee must see the
full record (per the direct-call aggregate ABI), and the parameter
AFTER the record must arrive un-shifted. }
SrcIntfConstRecordArg =
'''
program P;
type
TOpts = record
A: Integer;
B: Integer;
C: Integer;
end;
ICfg = interface
procedure Configure(const Opts: TOpts; X: Integer);
end;
TCfg = class(ICfg)
procedure Configure(const Opts: TOpts; X: Integer);
begin
WriteLn(Opts.A);
WriteLn(Opts.B);
WriteLn(Opts.C);
WriteLn(X)
end;
end;
var
C: ICfg;
O: TOpts;
begin
O.A := 11; O.B := 22; O.C := 33;
C := TCfg.Create();
C.Configure(O, 77)
end.
''';
{ out-string param through itab dispatch: the caller must pass the SLOT
ADDRESS (var-param rule), not the loaded string value. }
SrcIntfOutStringArg =
'''
program P;
type
IName = interface
procedure GetName(out AName: string);
end;
TNamed = class(IName)
procedure GetName(out AName: string);
begin
AName := 'blaise'
end;
end;
var
N: IName;
S: string;
begin
S := 'old';
N := TNamed.Create();
N.GetName(S);
WriteLn(S)
end.
''';
{ var dynarray param through itab dispatch: same slot-address rule as
strings — the callee reassigns the caller's array. }
SrcIntfVarDynArrayArg =
'''
program P;
type
TIntArr = array of Integer;
ISink = interface
procedure Fill(var A: TIntArr);
end;
TSink = class(ISink)
procedure Fill(var A: TIntArr);
begin
SetLength(A, 2);
A[0] := 5;
A[1] := 9
end;
end;
var
K: ISink;
Arr: TIntArr;
begin
K := TSink.Create();
K.Fill(Arr);
WriteLn(Length(Arr));
WriteLn(Arr[0]);
WriteLn(Arr[1])
end.
''';
{ TFuncCallExpr receiver: the interface-returning CALL itself is the
receiver of an itab dispatch — both in expression position
(WriteLn(GetInfo().Val())) and statement position (GetInfo().Note()). }
SrcFuncCallReceiver =
'''
program P;
type
IInfo = interface
function Val(): Integer;
procedure Note();
end;
TInfo = class(IInfo)
function Val(): Integer;
begin
Result := 5
end;
procedure Note();
begin
WriteLn('note')
end;
end;
function GetInfo(): IInfo;
begin
Result := TInfo.Create()
end;
begin
WriteLn(GetInfo().Val());
GetInfo().Note()
end.
''';
{ Interface-returning itab call DISCARDED in statement position: must not
clobber the receiver (the callee writes a 16-byte fat pointer through
the hidden sret arg) and the receiver must stay usable afterwards. }
SrcDiscardedIntfReturnStmt =
'''
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;
var
D: IDriver;
W: IWidget;
begin
D := TDrv.Create();
D.MakeWidget(5);
W := D.MakeWidget(7);
WriteLn(W.Tag())
end.
''';
procedure TE2EIMapTests.TestRun_IntfDispatch_ConstRecordArg;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertRunsOnAll(SrcIntfConstRecordArg,
'11' + LineEnding + '22' + LineEnding + '33' + LineEnding +
'77' + LineEnding, 0);
end;
procedure TE2EIMapTests.TestRun_IntfDispatch_OutStringArg;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertRunsOnAll(SrcIntfOutStringArg, 'blaise' + LineEnding, 0);
end;
procedure TE2EIMapTests.TestRun_IntfDispatch_VarDynArrayArg;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertRunsOnAll(SrcIntfVarDynArrayArg,
'2' + LineEnding + '5' + LineEnding + '9' + LineEnding, 0);
end;
procedure TE2EIMapTests.TestRun_FuncCallReceiver_IntfDispatch;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertRunsOnAll(SrcFuncCallReceiver,
'5' + LineEnding + 'note' + LineEnding, 0);
end;
procedure TE2EIMapTests.TestRun_DiscardedIntfReturn_StatementPosition;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertRunsOnAll(SrcDiscardedIntfReturnStmt, '7' + LineEnding, 0);
end;
initialization
RegisterTest(TE2EIMapTests);

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

@ -123,6 +123,13 @@ type
procedure TestCodegen_InterfaceResult_NilCompare_UsesObjSlot;
procedure TestCodegen_InterfaceLocal_NilCompare_UsesObjSlot;
procedure TestCodegen_IntfMethodReturningIntf_AssignsToSplitSlots;
{ ------------------------------------------------------------------ }
{ Regression — itab-dispatch argument ABI; discarded sret returns }
{ ------------------------------------------------------------------ }
procedure TestCodegen_IntfDispatch_RecordArg_PassesAggregate;
procedure TestCodegen_IntfDispatch_OutString_PassesSlotAddr;
procedure TestCodegen_DiscardedIntfReturnStmt_GetsSretAndRelease;
end;
implementation
@ -1627,6 +1634,146 @@ begin
Pos(', %_var_W' + #10, IR) > 0);
end;
{ ------------------------------------------------------------------ }
{ Regression — itab-dispatch argument ABI; discarded sret returns }
{ ------------------------------------------------------------------ }
const
{ Record by const through itab dispatch — must use the same aggregate
param type (:_ffi_TOpts) as a direct call, not a single w/l scalar. }
SrcIntfDispatchRecordArg =
'''
program P;
type
TOpts = record
A: Integer;
B: Integer;
C: Integer;
end;
ICfg = interface
procedure Configure(const Opts: TOpts; X: Integer);
end;
TCfg = class(TObject, ICfg)
procedure Configure(const Opts: TOpts; X: Integer);
end;
procedure TCfg.Configure(const Opts: TOpts; X: Integer);
begin
WriteLn(X)
end;
var
C: ICfg;
O: TOpts;
begin
C := TCfg.Create();
C.Configure(O, 77)
end.
''';
{ out-string through itab dispatch — must pass the slot ADDRESS
(var-param rule), not the loaded value. }
SrcIntfDispatchOutString =
'''
program P;
type
IName = interface
procedure GetName(out AName: string);
end;
TNamed = class(TObject, IName)
procedure GetName(out AName: string);
end;
procedure TNamed.GetName(out AName: string);
begin
AName := 'x'
end;
procedure Run();
var
N: IName;
S: string;
begin
N := TNamed.Create();
N.GetName(S)
end;
begin
Run()
end.
''';
{ Interface-returning itab call discarded in statement position — the
call must receive a throwaway sret buffer as hidden first arg and the
returned obj must be released. }
SrcDiscardedIntfReturnStmt =
'''
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;
var
D: IDriver;
begin
D := TDrv.Create();
D.MakeWidget(5)
end.
''';
procedure TInterfaceTests.TestCodegen_IntfDispatch_RecordArg_PassesAggregate;
var
IR: string;
CallPos: Integer;
CallLine: string;
begin
IR := GenIR(SrcIntfDispatchRecordArg);
{ The dispatch site is the only INDIRECT call ('call %fptr(...)'); the
callee signature also mentions :_ffi_TOpts, so scope the check to the
indirect call line. }
CallPos := Pos('call %', IR);
AssertTrue('indirect dispatch call present', CallPos > 0);
CallLine := Copy(IR, CallPos, Pos(')', Copy(IR, CallPos, MaxInt)) + 1);
AssertTrue('record arg uses the aggregate FFI type at the dispatch site: '
+ CallLine, Pos(':_ffi_TOpts ', CallLine) > 0);
end;
procedure TInterfaceTests.TestCodegen_IntfDispatch_OutString_PassesSlotAddr;
var
IR: string;
begin
IR := GenIR(SrcIntfDispatchOutString);
AssertTrue('out-string arg passes the slot address',
Pos(', l %_var_S', IR) > 0);
end;
procedure TInterfaceTests.TestCodegen_DiscardedIntfReturnStmt_GetsSretAndRelease;
var
IR: string;
CallPos: Integer;
begin
IR := GenIR(SrcDiscardedIntfReturnStmt);
{ The dispatch call must carry a hidden sret buffer; the buffer alloc and
a release of the returned obj must both be present in main. }
CallPos := Pos('alloc8 16', IR);
AssertTrue('throwaway sret buffer allocated for the discarded call',
CallPos > 0);
AssertTrue('returned obj released after the discarded call',
Pos('call $_ClassRelease', Copy(IR, CallPos, MaxInt)) > 0);
end;
initialization
RegisterTest(TInterfaceTests);