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

fix(codegen): return function-of-object via two-register aggregate ABI

Browse source 
A `function ... of object` return value is a 16-byte [Code, Data]
method pointer, ABI-identical to `record Code, Data: Pointer end`.  It
was returned as a scalar (only the Code half), so a method captured from
a call (`M := Obj.GetFn()`) and later invoked dropped the Data/Self half
— a call through M then dereferenced a null/garbage Self.

Route the return through the record-return ABI: a canonical 16-byte
[Code, Data] two-pointer record classifies as two integer eightbytes ->
rcInt2 (rax:rdx) on SysV, matching a direct record return.  Both the
QBE and native x86-64 backends are fixed.

The native side mirrors the QBE approach via a lazily-built canonical
`_BlaiseMethodPtr` record (distinct GNative* singletons so the two
backends' identically-named globals do not collide when both are linked
into the self-hosting compiler), wired through BuildFrame's return
classification (rcInt2, not sret), the epilogue (loads both halves into
rax:rdx), the Result-slot zero-init (both 16 bytes), and every call-site
capture: variable- and field-destination assignment of a
method-ptr-returning call, and the immediate-invoke path
(`Obj.GetFn()(args)`) which materialises the 16-byte block and dispatches
through it so Data lands in %rdi.

Tests: an IR-level assertion that the return uses the aggregate ABI, plus
e2e cases.  The new TestRun_MethodPtrReturn_ReadsSelf returns a method
that READS Self (an instance field) — unlike the X+Y case, which never
touches Self and so could not catch a dropped Data half — and asserts the
right value on every backend.
This commit is contained in:
Graeme Geldenhuys 2026-06-30 17:34:26 +01:00
parent c32bc73f2c
commit f6c1cee9fe
4 changed files with 444 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -813,6 +813,60 @@ const
SysVArgRegs16: array[0..5] of string =
('%di', '%si', '%dx', '%cx', '%r8w', '%r9w');
var
{ Process-wide singleton method-pointer return record + its shared Pointer
leaf type; built lazily by MethodPtrReturnRec and reused by every codegen
instance. A `function ... of object` value is a 16-byte [Code; Data]
aggregate that is ABI-identical to `record Code, Data: Pointer end` — two
integer eightbytes classify as rcInt2 (rax:rdx) on SysV. Never mutated
after creation; intentionally not freed (a single process-lifetime
constant), mirroring the QBE backend's GMethodPtrRec. The native names are
distinct (GNative*) so the two backend units do not collide on the emitted
global symbol when both are linked into the self-hosting compiler. }
GNativeMethodPtrRec: TRecordTypeDesc;
GNativeMethodPtrLeaf: TTypeDesc;
{ True for an 'of object' method-pointer type — a 16-byte [Code; Data]
aggregate returned by the same ABI as a two-pointer record. }
function IsMethodPtrType(AType: TTypeDesc): Boolean;
begin
Result := (AType <> nil) and (AType.Kind = tyProcedural)
and TProceduralTypeDesc(AType).IsMethodPtr;
end;
{ Lazily-built canonical 16-byte [Code; Data] record for method pointers.
Returning a canonical record descriptor lets the whole record-return path
(classify, prologue/epilogue, call-site capture) handle method-pointer
returns uniformly. Built once and cached in a unit-level singleton. }
function MethodPtrReturnRec(): TRecordTypeDesc;
begin
if GNativeMethodPtrRec = nil then
begin
GNativeMethodPtrLeaf := TTypeDesc.Create();
GNativeMethodPtrLeaf.Kind := tyPointer;
GNativeMethodPtrLeaf.Name := 'Pointer';
GNativeMethodPtrRec := TRecordTypeDesc.Create('_BlaiseMethodPtr', tyRecord);
GNativeMethodPtrRec.AddField('Code', GNativeMethodPtrLeaf);
GNativeMethodPtrRec.AddField('Data', GNativeMethodPtrLeaf);
end;
Result := GNativeMethodPtrRec;
end;
{ The record descriptor governing AType's by-aggregate return ABI: AType itself
for a real record, the canonical method-pointer record for an 'of object'
procedural type, else nil. Mirrors TCodeGenQBE.AggRetRec. }
function AggRetRec(AType: TTypeDesc): TRecordTypeDesc;
begin
if AType = nil then
Result := nil
else if AType.Kind = tyRecord then
Result := TRecordTypeDesc(AType)
else if IsMethodPtrType(AType) then
Result := MethodPtrReturnRec()
else
Result := nil;
end;
constructor TOALCallFrame.Create;
begin
inherited Create();
@ -4014,6 +4068,14 @@ begin
FRecRetClass := ClassifyRecordReturn(
TRecordTypeDesc(ADecl.ResolvedReturnType));
FSretFunc := FRecRetClass = rcSret;
end
else if IsMethodPtrType(ADecl.ResolvedReturnType) then
begin
{ A method pointer is a 16-byte [Code; Data] aggregate — two integer
eightbytes -> rcInt2 (rax:rdx) on SysV. Route it through the same
record-return machinery as a real two-pointer record. }
FRecRetClass := ClassifyRecordReturn(MethodPtrReturnRec());
FSretFunc := FRecRetClass = rcSret;
end;
end;
@ -8044,6 +8106,30 @@ begin
dispatch via callq *%r10. }
if AExpr is TIndirectFuncCallExpr then
begin
{ Method-pointer callee ('of object'): the callee yields a 16-byte
[Code; Data] block, not a bare function pointer. Materialise the callee
value into a stack buffer (it may itself be a method-ptr-returning call,
e.g. Obj.GetFn()(args)) and dispatch through EmitMethodPtrCall, which
loads Code into %r10 and Data (Self) into %rdi. }
if (TIndirectFuncCallExpr(AExpr).ResolvedProcType <> nil) and
TProceduralTypeDesc(
TIndirectFuncCallExpr(AExpr).ResolvedProcType).IsMethodPtr then
begin
{ Materialise the callee's 16-byte [Code; Data] block into a stack buffer
and carry its address in callee-saved %rbx — EmitMethodPtrCall reads its
operand AFTER pushing args (which moves %rsp), so a %rsp-relative operand
would drift; %rbx survives the arg push/pop. }
Self.Emit(#9'pushq %rbx');
Self.Emit(#9'subq $16, %rsp');
Self.EmitRecordCallSretAt(TIndirectFuncCallExpr(AExpr).CalleeExpr, '(%rsp)');
Self.Emit(#9'movq %rsp, %rbx');
Self.EmitMethodPtrCall('(%rbx)',
TProceduralTypeDesc(TIndirectFuncCallExpr(AExpr).ResolvedProcType),
TIndirectFuncCallExpr(AExpr).Args);
Self.Emit(#9'addq $16, %rsp');
Self.Emit(#9'popq %rbx');
Exit;
end;
Self.EmitExprToEax(TIndirectFuncCallExpr(AExpr).CalleeExpr);
Self.Emit(#9'pushq %rax');
for SetI := 0 to TIndirectFuncCallExpr(AExpr).Args.Count - 1 do
@ -11198,6 +11284,59 @@ begin
Self.Emit(#9'callq memcpy');
Exit;
end;
{ Method-ptr-returning call assignment: LHS is an 'of object' method pointer
and RHS is a function/method call returning one. A method pointer is a
16-byte [Code; Data] aggregate returned via the record-return ABI (rcInt2,
rax:rdx on SysV) — route it through the same sret helpers as a two-pointer
record so BOTH halves are captured into the 16-byte destination slot. }
if (Asgn.ResolvedLhsType <> nil) and
IsMethodPtrType(Asgn.ResolvedLhsType) and
(Asgn.Expr is TFuncCallExpr) and
(TFuncCallExpr(Asgn.Expr).ResolvedDecl <> nil) and
IsMethodPtrType(
TMethodDecl(TFuncCallExpr(Asgn.Expr).ResolvedDecl).ResolvedReturnType) then
begin
if FSretFunc and SameText(Asgn.Name, 'Result') then
Self.EmitFuncCallSret(TFuncCallExpr(Asgn.Expr),
Self.VarOperand('Result'), True)
else if Asgn.IsVarParam then
Self.EmitFuncCallSret(TFuncCallExpr(Asgn.Expr),
Self.VarOperand(Asgn.Name), True)
else if Self.IsLocal(Asgn.Name) then
Self.EmitFuncCallSret(TFuncCallExpr(Asgn.Expr),
Self.VarOperand(Asgn.Name), False)
else
begin
Self.AddGlobal(Asgn.Name, Asgn.ResolvedLhsType);
Self.EmitFuncCallSret(TFuncCallExpr(Asgn.Expr),
Asgn.Name + '(%rip)', False);
end;
Exit;
end;
if (Asgn.ResolvedLhsType <> nil) and
IsMethodPtrType(Asgn.ResolvedLhsType) and
(Asgn.Expr is TMethodCallExpr) and
(TMethodCallExpr(Asgn.Expr).ResolvedMethod <> nil) and
IsMethodPtrType(
TMethodDecl(TMethodCallExpr(Asgn.Expr).ResolvedMethod).ResolvedReturnType) then
begin
if FSretFunc and SameText(Asgn.Name, 'Result') then
Self.EmitMethodSretCall(TMethodCallExpr(Asgn.Expr),
Self.VarOperand('Result'), True)
else if Asgn.IsVarParam then
Self.EmitMethodSretCall(TMethodCallExpr(Asgn.Expr),
Self.VarOperand(Asgn.Name), True)
else if Self.IsLocal(Asgn.Name) then
Self.EmitMethodSretCall(TMethodCallExpr(Asgn.Expr),
Self.VarOperand(Asgn.Name), False)
else
begin
Self.AddGlobal(Asgn.Name, Asgn.ResolvedLhsType);
Self.EmitMethodSretCall(TMethodCallExpr(Asgn.Expr),
Asgn.Name + '(%rip)', False);
end;
Exit;
end;
{ sret assignment: LHS is a record (or jumbo set) variable; RHS is a
record/jumbo-set-returning call. Pass the destination buffer address as
the hidden first arg (%rdi). }
@ -12531,14 +12670,18 @@ begin
Self.Emit(#9'movq %rax, (%rcx)');
Exit;
end;
{ Field := MethodCall() where the method returns a record via sret.
Compute the field address into %rbx (callee-saved), release managed
fields of the old record, then call with %rbx as the sret destination. }
if (FA.FieldInfo.TypeDesc.Kind = tyRecord) and
{ Field := MethodCall() where the method returns a record (or method ptr)
via the aggregate-return ABI. Compute the field address into %rbx
(callee-saved), release managed fields of the old record (none for a
method ptr), then call with %rbx as the destination. A method-ptr field
is a 16-byte [Code; Data] slot captured via rcInt2 by EmitMethodSretCall. }
if ((FA.FieldInfo.TypeDesc.Kind = tyRecord) or
IsMethodPtrType(FA.FieldInfo.TypeDesc)) and
(FA.Expr is TMethodCallExpr) and
(TMethodCallExpr(FA.Expr).ResolvedMethod <> nil) and
(TMethodDecl(TMethodCallExpr(FA.Expr).ResolvedMethod).ResolvedReturnType <> nil) and
(TMethodDecl(TMethodCallExpr(FA.Expr).ResolvedMethod).ResolvedReturnType.Kind = tyRecord) then
((TMethodDecl(TMethodCallExpr(FA.Expr).ResolvedMethod).ResolvedReturnType.Kind = tyRecord) or
IsMethodPtrType(TMethodDecl(TMethodCallExpr(FA.Expr).ResolvedMethod).ResolvedReturnType)) then
begin
Self.Emit(#9'pushq %rbx');
if FA.ObjExpr <> nil then
@ -12573,17 +12716,20 @@ begin
end;
if FA.FieldInfo.Offset > 0 then
Self.Emit(Format(#9'addq $%d, %%rbx', [FA.FieldInfo.Offset]));
Self.EmitRecordFieldReleases(TRecordTypeDesc(FA.FieldInfo.TypeDesc), '%rbx');
if FA.FieldInfo.TypeDesc.Kind = tyRecord then
Self.EmitRecordFieldReleases(TRecordTypeDesc(FA.FieldInfo.TypeDesc), '%rbx');
Self.EmitMethodSretCall(TMethodCallExpr(FA.Expr), '(%rbx)', False);
Self.Emit(#9'popq %rbx');
Exit;
end;
{ Field := FuncCall() where the function returns a record via sret. }
if (FA.FieldInfo.TypeDesc.Kind = tyRecord) and
{ Field := FuncCall() where the function returns a record (or method ptr). }
if ((FA.FieldInfo.TypeDesc.Kind = tyRecord) or
IsMethodPtrType(FA.FieldInfo.TypeDesc)) and
(FA.Expr is TFuncCallExpr) and
(TFuncCallExpr(FA.Expr).ResolvedDecl <> nil) and
(TMethodDecl(TFuncCallExpr(FA.Expr).ResolvedDecl).ResolvedReturnType <> nil) and
(TMethodDecl(TFuncCallExpr(FA.Expr).ResolvedDecl).ResolvedReturnType.Kind = tyRecord) then
((TMethodDecl(TFuncCallExpr(FA.Expr).ResolvedDecl).ResolvedReturnType.Kind = tyRecord) or
IsMethodPtrType(TMethodDecl(TFuncCallExpr(FA.Expr).ResolvedDecl).ResolvedReturnType)) then
begin
Self.Emit(#9'pushq %rbx');
if FA.ObjExpr <> nil then
@ -12614,7 +12760,8 @@ begin
end;
if FA.FieldInfo.Offset > 0 then
Self.Emit(Format(#9'addq $%d, %%rbx', [FA.FieldInfo.Offset]));
Self.EmitRecordFieldReleases(TRecordTypeDesc(FA.FieldInfo.TypeDesc), '%rbx');
if FA.FieldInfo.TypeDesc.Kind = tyRecord then
Self.EmitRecordFieldReleases(TRecordTypeDesc(FA.FieldInfo.TypeDesc), '%rbx');
Self.EmitFuncCallSret(TFuncCallExpr(FA.Expr), '(%rbx)', False);
Self.Emit(#9'popq %rbx');
Exit;
@ -15078,6 +15225,7 @@ var
AllocSz: Integer;
CleanUp: Integer;
RC: TRecReturnClass;
RetRec: TRecordTypeDesc;
HD: TList<Integer>;
HK: TList<Integer>;
HTotal: Integer;
@ -15086,11 +15234,13 @@ var
IntIdx, XmmIdx, SlotOff: Integer;
ArgPushed: Integer;
begin
{ Check if the callee returns a small POD record via registers. }
{ Check if the callee returns a small POD record (or method pointer) via
registers. RetRec is the real record or the canonical method-ptr record. }
RC := rcSret;
if (ADecl <> nil) and (ADecl.ResolvedReturnType <> nil) and
(ADecl.ResolvedReturnType.Kind = tyRecord) then
RC := ClassifyRecordReturn(TRecordTypeDesc(ADecl.ResolvedReturnType));
RetRec := nil;
if ADecl <> nil then RetRec := AggRetRec(ADecl.ResolvedReturnType);
if RetRec <> nil then
RC := ClassifyRecordReturn(RetRec);
if RC <> rcSret then
begin
{ Reg-return: zero the dest buffer, call without hidden sret param,
@ -15101,12 +15251,10 @@ begin
Self.Emit(Format(#9'leaq %s, %%r10', [ASretAddr]));
Self.Emit(#9'movq %r10, %rdi');
Self.Emit(#9'xorl %esi, %esi');
Self.Emit(Format(#9'movq $%d, %%rdx',
[TRecordTypeDesc(ADecl.ResolvedReturnType).TotalSize()]));
Self.Emit(Format(#9'movq $%d, %%rdx', [RetRec.TotalSize()]));
Self.Emit(#9'callq memset');
Self.EmitCall(AFuncSym, ADecl, AArgs);
Self.EmitRecordRegReturnCapture(ASretAddr,
TRecordTypeDesc(ADecl.ResolvedReturnType), RC, ASretIsIndirect);
Self.EmitRecordRegReturnCapture(ASretAddr, RetRec, RC, ASretIsIndirect);
Exit;
end;
{ Save the destination address on the stack, below the hoist region:
@ -15382,6 +15530,7 @@ var
AllocSz: Integer;
CleanUp: Integer;
RC: TRecReturnClass;
RetRec: TRecordTypeDesc;
HD: TList<Integer>;
HK: TList<Integer>;
HTotal: Integer;
@ -15452,11 +15601,12 @@ begin
end;
{ Check for register-return: no hidden sret param, Self goes in %rdi,
args in %rsi onwards. }
args in %rsi onwards. RetRec is the real record or the canonical
method-ptr record (a method pointer is a 16-byte [Code; Data] rcInt2). }
RC := rcSret;
if (MD.ResolvedReturnType <> nil) and
(MD.ResolvedReturnType.Kind = tyRecord) then
RC := ClassifyRecordReturn(TRecordTypeDesc(MD.ResolvedReturnType));
RetRec := AggRetRec(MD.ResolvedReturnType);
if RetRec <> nil then
RC := ClassifyRecordReturn(RetRec);
if RC <> rcSret then
begin
if LSretIndirect then
@ -15465,8 +15615,7 @@ begin
Self.Emit(Format(#9'leaq %s, %%r10', [LSretAddr]));
Self.Emit(#9'movq %r10, %rdi');
Self.Emit(#9'xorl %esi, %esi');
Self.Emit(Format(#9'movq $%d, %%rdx',
[TRecordTypeDesc(MD.ResolvedReturnType).TotalSize()]));
Self.Emit(Format(#9'movq $%d, %%rdx', [RetRec.TotalSize()]));
Self.Emit(#9'callq memset');
Self.BeginCallArgs(MD.Params, ACall.Args);
for I := 0 to ACall.Args.Count - 1 do
@ -15517,8 +15666,7 @@ begin
else
Self.Emit(#9'callq ' + Sym);
Self.EndCallArgs();
Self.EmitRecordRegReturnCapture(LSretAddr,
TRecordTypeDesc(MD.ResolvedReturnType), RC, LSretIndirect);
Self.EmitRecordRegReturnCapture(LSretAddr, RetRec, RC, LSretIndirect);
Self.EmitMethodSretRecvCleanup(RecvBufBytes);
Exit;
end;
@ -16894,6 +17042,15 @@ begin
Self.Emit(#9'xorpd %xmm0, %xmm0');
Self.EmitStoreFloat(Self.VarOperand('Result'), ADecl.ResolvedReturnType);
end
else if IsMethodPtrType(ADecl.ResolvedReturnType) then
begin
{ Method-ptr Result is a 16-byte [Code; Data] slot — zero BOTH halves so
the Data (Self) half is defined even if the body never assigns it. }
Self.Emit(#9'xorl %eax, %eax');
Self.Emit(Format(#9'movq %%rax, %s', [Self.VarOperand('Result')]));
Self.Emit(Format(#9'leaq %s, %%rcx', [Self.VarOperand('Result')]));
Self.Emit(#9'movq %rax, 8(%rcx)');
end
else
begin
Self.Emit(#9'xorl %eax, %eax');
@ -17206,6 +17363,10 @@ begin
if (ADecl.ResolvedReturnType.Kind = tyRecord) and (FRecRetClass <> rcSret) then
Self.EmitRecordReturnEpilogue(
TRecordTypeDesc(ADecl.ResolvedReturnType), FRecRetClass)
else if IsMethodPtrType(ADecl.ResolvedReturnType) and (FRecRetClass <> rcSret) then
{ Method-ptr return: load both halves of the 16-byte Result slot into the
return registers (rax:rdx for rcInt2) via the canonical record. }
Self.EmitRecordReturnEpilogue(MethodPtrReturnRec(), FRecRetClass)
else if IsFloatFamily(ADecl.ResolvedReturnType) then
Self.EmitLoadFloat(Self.VarOperand('Result'), ADecl.ResolvedReturnType)
else

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

@ -427,6 +427,14 @@ type
ARetType: TRecordTypeDesc;
const ADestAddr: string);
function ClassifyRecordReturn(ARec: TRecordTypeDesc): TRecReturnClass;
{ Lazily-built canonical 16-byte [Code; Data] record for method pointers. }
function MethodPtrReturnRec(): TRecordTypeDesc;
{ The record descriptor governing AType's by-aggregate return ABI: AType
itself for a real record, the canonical method-pointer record for an
'of object' procedural type, else nil. }
function AggRetRec(AType: TTypeDesc): TRecordTypeDesc;
{ Record descriptor for an already-aggregate record-return call site. }
function SretRetRec(AType: TTypeDesc): TRecordTypeDesc;
function IsRecordManagedClean(ARec: TRecordTypeDesc): Boolean;
function IsRecordAllIntegerLeaves(ARec: TRecordTypeDesc): Boolean;
function IsRecordAllFloatLeaves(ARec: TRecordTypeDesc): Boolean;
@ -572,6 +580,14 @@ type
implementation
var
{ Process-wide singleton method-pointer return record + its shared Pointer
leaf type; built lazily by TCodeGenQBE.MethodPtrReturnRec and reused by
every codegen instance. Never mutated after creation; intentionally not
freed (a single process-lifetime constant). }
GMethodPtrRec: TRecordTypeDesc;
GMethodPtrLeaf: TTypeDesc;
{ -----------------------------------------------------------------------
TIRBuffer
----------------------------------------------------------------------- }
@ -5475,6 +5491,65 @@ begin
Result := RecretClassify(ARec, GTarget);
end;
{ True for an 'of object' method-pointer type — a 16-byte [Code; Data]
aggregate returned by the same ABI as a two-pointer record. }
function IsMethodPtrType(AType: TTypeDesc): Boolean;
begin
Result := (AType <> nil) and (AType.Kind = tyProcedural)
and TProceduralTypeDesc(AType).IsMethodPtr;
end;
{ A method pointer is a 16-byte aggregate [Code; Data] of two raw pointers —
ABI-identical to `record Code, Data: Pointer end`. Returning a canonical
record descriptor for it lets the whole record-return path (classify,
signature, prologue/epilogue, call site) handle method-pointer returns
uniformly: two integer eightbytes -> rcInt2 on SysV (rax:rdx), aggregate on
Win64. Built once and cached in a unit-level singleton (the descriptor is a
process-wide constant shared by every TCodeGenQBE instance; it is never
mutated after creation, and a deliberate process-lifetime leak avoids adding
ARC/teardown state to the codegen object). The two fields share one
untyped-Pointer leaf (referenced, not owned by the record). }
function TCodeGenQBE.MethodPtrReturnRec(): TRecordTypeDesc;
begin
if GMethodPtrRec = nil then
begin
GMethodPtrLeaf := TTypeDesc.Create();
GMethodPtrLeaf.Kind := tyPointer;
GMethodPtrLeaf.Name := 'Pointer';
GMethodPtrRec := TRecordTypeDesc.Create('_BlaiseMethodPtr', tyRecord);
GMethodPtrRec.AddField('Code', GMethodPtrLeaf);
GMethodPtrRec.AddField('Data', GMethodPtrLeaf);
end;
Result := GMethodPtrRec;
end;
function TCodeGenQBE.AggRetRec(AType: TTypeDesc): TRecordTypeDesc;
begin
if AType = nil then
Result := nil
else if AType.Kind = tyRecord then
Result := TRecordTypeDesc(AType)
else if (AType.Kind = tyProcedural) and
TProceduralTypeDesc(AType).IsMethodPtr then
Result := MethodPtrReturnRec()
else
Result := nil;
end;
{ Record descriptor for a record-return CALL SITE, where the return type is
already known to be aggregate (record, static array, jumbo set, or method
pointer). Substitutes the canonical method-pointer record for an 'of object'
type; otherwise reinterprets the type as a record descriptor exactly as the
call site did before — EmitRecordReturnCallSite re-checks the kind and routes
static-array/jumbo-set returns through their own sret branch. }
function TCodeGenQBE.SretRetRec(AType: TTypeDesc): TRecordTypeDesc;
begin
if IsMethodPtrType(AType) then
Result := MethodPtrReturnRec()
else
Result := TRecordTypeDesc(AType);
end;
procedure TCodeGenQBE.EmitRecordReturnSignature(var ASig: string;
AClass: TRecReturnClass);
begin
@ -5837,7 +5912,7 @@ begin
begin
FCallExpr := TFuncCallExpr(AExpr);
MDecl := TMethodDecl(FCallExpr.ResolvedDecl);
RetType := TRecordTypeDesc(MDecl.ResolvedReturnType);
RetType := SretRetRec(MDecl.ResolvedReturnType);
if FCallExpr.IsImplicitSelfMethod then
begin
SelfTemp := AllocTemp();
@ -5896,7 +5971,7 @@ begin
Exit;
end;
MDecl := TMethodDecl(MCallExpr.ResolvedMethod);
RetType := TRecordTypeDesc(MDecl.ResolvedReturnType);
RetType := SretRetRec(MDecl.ResolvedReturnType);
{ Static (class-level) record-returning function: TypeName.Make(args).
No Self — the visible args begin with the first user parameter. (A record
factory is the canonical case; the user opted records into requiring an
@ -5987,7 +6062,7 @@ begin
Exit;
end;
MDecl := TMethodDecl(FldAccess.ResolvedMethod);
RetType := TRecordTypeDesc(MDecl.ResolvedReturnType);
RetType := SretRetRec(MDecl.ResolvedReturnType);
if FldAccess.IsImplicitSelf then
begin
SelfTemp := AllocTemp();
@ -6031,7 +6106,7 @@ begin
parent's symbol, marshal Self + args, and let the callee write straight
into ASretAddr (the assignment's destination slot — no temp, no copy). }
MDecl := TMethodDecl(TInheritedCallExpr(AExpr).ResolvedMethod);
RetType := TRecordTypeDesc(MDecl.ResolvedReturnType);
RetType := SretRetRec(MDecl.ResolvedReturnType);
VisArgs := InheritedArgLine(MDecl, TInheritedCallExpr(AExpr).Args);
FuncName := '$' + MethodEmitName(MDecl, MDecl.OwnerTypeName,
TInheritedCallExpr(AExpr).Name);
@ -7719,6 +7794,7 @@ var
SavedExitLbl: string;
ValTemp: string;
RC: TRecReturnClass;
RetRec: TRecordTypeDesc;
begin
if AMethod.ResolvedQbeName <> '' then
FuncName := '$' + QBEMangle(AMethod.ResolvedQbeName)
@ -7726,12 +7802,18 @@ begin
FuncName := '$' + QBEMangle(ATypeName + '_' + AMethod.Name);
IsFunc := AMethod.ResolvedReturnType <> nil;
{ RetRec drives the by-aggregate return ABI for both real records and
method pointers (the latter via a synthetic two-pointer record). }
if IsFunc then RetRec := AggRetRec(AMethod.ResolvedReturnType)
else RetRec := nil;
RC := rcSret;
if IsFunc and (AMethod.ResolvedReturnType.Kind = tyRecord) then
RC := Self.ClassifyRecordReturn(TRecordTypeDesc(AMethod.ResolvedReturnType));
if RetRec <> nil then
RC := Self.ClassifyRecordReturn(RetRec);
{ A STATIC (class-level) method takes no implicit Self. Its signature starts
empty (or with just the sret pointer for aggregate returns). }
empty (or with just the sret pointer for aggregate returns). RetRec drives
the by-aggregate return for both real records and method pointers (synthetic
two-pointer record), so gate on RetRec rather than Kind = tyRecord. }
if AMethod.IsStatic then
begin
Sig := '';
@ -7739,7 +7821,7 @@ begin
((AMethod.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo())) then
Sig := 'l %_par__sret'
else if IsFunc and (AMethod.ResolvedReturnType.Kind = tyRecord) then
else if RetRec <> nil then
{ Sig is '' here, so EmitRecordReturnSignature yields just the sret ptr. }
EmitRecordReturnSignature(Sig, RC);
end
@ -7750,7 +7832,7 @@ begin
((AMethod.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo())) then
Sig := 'l %_par__sret, l %_par_Self'
else if IsFunc and (AMethod.ResolvedReturnType.Kind = tyRecord) then
else if RetRec <> nil then
EmitRecordReturnSignature(Sig, RC);
end;
for I := 0 to AMethod.Params.Count - 1 do
@ -7786,10 +7868,9 @@ begin
((AMethod.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo()) then
EmitLine(Format('%sfunction %s(%s) {', [ExportPrefix(), FuncName, Sig]))
else if AMethod.ResolvedReturnType.Kind = tyRecord then
else if RetRec <> nil then
begin
RetDeclType := EmitRecordReturnDeclType(
TRecordTypeDesc(AMethod.ResolvedReturnType), RC);
RetDeclType := EmitRecordReturnDeclType(RetRec, RC);
if RetDeclType = '' then
EmitLine(Format('%sfunction %s(%s) {', [ExportPrefix(), FuncName, Sig]))
else
@ -7849,8 +7930,8 @@ begin
{ For function methods, allocate/alias a zero-initialised Result slot }
if IsFunc then
begin
if AMethod.ResolvedReturnType.Kind = tyRecord then
EmitRecordReturnPrologue(TRecordTypeDesc(AMethod.ResolvedReturnType), RC)
if RetRec <> nil then
EmitRecordReturnPrologue(RetRec, RC)
else if AMethod.ResolvedReturnType.Kind = tyStaticArray then
begin
EmitLine(' %_var_Result =l copy %_par__sret');
@ -7938,8 +8019,8 @@ begin
if IsFunc then
begin
if AMethod.ResolvedReturnType.Kind = tyRecord then
EmitRecordReturnEpilogue(TRecordTypeDesc(AMethod.ResolvedReturnType), RC)
if RetRec <> nil then
EmitRecordReturnEpilogue(RetRec, RC)
else if (AMethod.ResolvedReturnType.Kind in [tyInterface, tyStaticArray]) or
((AMethod.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo()) then
@ -8719,6 +8800,7 @@ var
CapName: string;
NestedFuncName: string;
RC: TRecReturnClass;
RetRec: TRecordTypeDesc;
begin
if ADecl.IsExternal then Exit; { no body to emit for external declarations }
if ADecl.Body = nil then Exit; { forward declaration — impl appears elsewhere }
@ -8749,9 +8831,13 @@ begin
else
FuncName := '$' + QBEMangle(ADecl.Name);
IsFunc := ADecl.ResolvedReturnType <> nil;
{ RetRec drives the by-aggregate return ABI for both real records and
method pointers (the latter via a synthetic two-pointer record). }
if IsFunc then RetRec := AggRetRec(ADecl.ResolvedReturnType)
else RetRec := nil;
RC := rcSret;
if IsFunc and (ADecl.ResolvedReturnType.Kind = tyRecord) then
RC := Self.ClassifyRecordReturn(TRecordTypeDesc(ADecl.ResolvedReturnType));
if RetRec <> nil then
RC := Self.ClassifyRecordReturn(RetRec);
if AExported or FExportAll or FOpdfMode then Prefix := 'export ' else Prefix := '';
{ Captured outer-scope variables are prepended as implicit pointer params.
@ -8798,11 +8884,10 @@ begin
else Sig := 'l %_par__sret';
EmitLine(Format('%sfunction %s(%s) {', [Prefix, FuncName, Sig]));
end
else if ADecl.ResolvedReturnType.Kind = tyRecord then
else if RetRec <> nil then
begin
EmitRecordReturnSignature(Sig, RC);
RetDeclType := EmitRecordReturnDeclType(
TRecordTypeDesc(ADecl.ResolvedReturnType), RC);
RetDeclType := EmitRecordReturnDeclType(RetRec, RC);
if RetDeclType = '' then
EmitLine(Format('%sfunction %s(%s) {', [Prefix, FuncName, Sig]))
else
@ -8945,8 +9030,8 @@ begin
if IsFunc then
begin
if ADecl.ResolvedReturnType.Kind = tyRecord then
EmitRecordReturnPrologue(TRecordTypeDesc(ADecl.ResolvedReturnType), RC)
if RetRec <> nil then
EmitRecordReturnPrologue(RetRec, RC)
else if ADecl.ResolvedReturnType.Kind = tyStaticArray then
begin
EmitLine(' %_var_Result =l copy %_par__sret');
@ -9043,8 +9128,8 @@ begin
if IsFunc then
begin
if ADecl.ResolvedReturnType.Kind = tyRecord then
EmitRecordReturnEpilogue(TRecordTypeDesc(ADecl.ResolvedReturnType), RC)
if RetRec <> nil then
EmitRecordReturnEpilogue(RetRec, RC)
else if (ADecl.ResolvedReturnType.Kind in [tyInterface, tyStaticArray]) or
((ADecl.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(ADecl.ResolvedReturnType).IsJumbo()) then
@ -11187,6 +11272,16 @@ begin
EmitRecordCallSret(AExpr, SretBuf);
Exit(SretBuf);
end;
{ Method-pointer return — a 16-byte [Code; Data] aggregate routed
through the record-return ABI; the buffer address is the result. }
if IsMethodPtrType(MDecl.ResolvedReturnType) then
begin
SretBuf := AllocTemp();
EmitLine(Format(' %s =l alloc8 16', [SretBuf]));
EmitLine(Format(' call $memset(l %s, w 0, l 16)', [SretBuf]));
EmitRecordCallSret(AExpr, SretBuf);
Exit(SretBuf);
end;
{ sret: jumbo-set-returning function — caller allocates a zero-init
bitmap buffer and passes its address as the hidden first parameter. }
if (MDecl.ResolvedReturnType.Kind = tySet) and
@ -11704,6 +11799,16 @@ begin
EmitRecordCallSret(AExpr, SretBuf);
Exit(SretBuf);
end;
{ Method-pointer return — a 16-byte [Code; Data] aggregate routed
through the record-return ABI; the buffer address is the result. }
if IsMethodPtrType(MDecl.ResolvedReturnType) then
begin
SretBuf := AllocTemp();
EmitLine(Format(' %s =l alloc8 16', [SretBuf]));
EmitLine(Format(' call $memset(l %s, w 0, l 16)', [SretBuf]));
EmitRecordCallSret(AExpr, SretBuf);
Exit(SretBuf);
end;
{ sret: jumbo-set-returning method }
if (MDecl.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(MDecl.ResolvedReturnType).IsJumbo() then

89
compiler/src/test/pascal/cp.test.e2e.misc.pas
View file

@ -54,6 +54,8 @@ type
not the statically-resolved declared-type method. }
procedure TestRun_MethodPtrVirtualCapture_Var;
procedure TestRun_MethodPtrVirtualCapture_Field;
procedure TestRun_MethodPtrReturn;
procedure TestRun_MethodPtrReturn_ReadsSelf;
{ Unqualified call to a procedural-typed field via implicit Self (FFn(...)
with no 'Self.' prefix), as an expression and as a statement. }
procedure TestRun_ImplicitSelfProcField_Expr;
@ -534,6 +536,78 @@ const
end.
''';
{ A method returning a 'function ... of object' value. The return is a
16-byte (Code, Data) aggregate; it must travel back by the two-register/
sret record-return ABI rather than a scalar that drops the Data half.
Op(3, 4) invokes the captured method pointer and must print 7. }
SrcMethodPtrReturn = '''
program Prg;
type TBinOp = function(X, Y: Integer): Integer of object;
type
TCalc = class
function Add(X, Y: Integer): Integer;
function GetOp: TBinOp;
end;
function TCalc.Add(X, Y: Integer): Integer;
begin Result := X + Y end;
function TCalc.GetOp: TBinOp;
begin Result := @Self.Add end;
var C: TCalc; Op: TBinOp;
begin
C := TCalc.Create();
Op := C.GetOp();
WriteLn(Op(3, 4));
C.Free()
end.
''';
{ Method pointer whose RETURNED method READS an instance field (Self.Base).
A method ptr is a 16-byte [Code; Data] aggregate; if a backend returns only
the Code half the Data (Self) pointer is lost and the invoked method
dereferences garbage — which it only observes when it actually uses Self.
SrcMethodPtrReturn's Add(X,Y)=X+Y never touches Self, so it cannot catch
that defect; this one does, on every backend. Also exercises a field
destination (Self.FStored), a free-function method-ptr return, and an
immediate invoke of the returned pointer (C.GetFn()(9)). }
SrcMethodPtrReturnSelf = '''
program Prg;
type TFn = function(X: Integer): Integer of object;
type
TCalc = class
Base: Integer;
FStored: TFn;
function AddBase(X: Integer): Integer;
function GetFn: TFn;
procedure StoreFn;
function CallStored(X: Integer): Integer;
end;
function TCalc.AddBase(X: Integer): Integer;
begin Result := Self.Base + X end;
function TCalc.GetFn: TFn;
begin Result := @Self.AddBase end;
procedure TCalc.StoreFn;
begin Self.FStored := Self.GetFn() end;
function TCalc.CallStored(X: Integer): Integer;
begin Result := Self.FStored(X) end;
var GC: TCalc;
function GetGlobalFn: TFn;
begin Result := @GC.AddBase end;
var C: TCalc; F: TFn;
begin
C := TCalc.Create();
C.Base := 100;
F := C.GetFn();
WriteLn(F(7));
C.StoreFn();
WriteLn(C.CallStored(5));
GC := C;
F := GetGlobalFn();
WriteLn(F(3));
WriteLn(C.GetFn()(9));
C.Free()
end.
''';
{ Unqualified (implicit-Self) call to a procedural-typed field, as an
expression — FFn(...) with no 'Self.' prefix. }
SrcImplicitProcFieldExpr = '''
@ -939,6 +1013,21 @@ begin
AssertRunsOnAll(SrcMethodPtrVirtualCaptureField, 'dog' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrReturn;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrReturn, '7' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrReturn_ReadsSelf;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ 107, 105, 103, 109 — each line proves the Data (Self) half of the returned
16-byte method pointer survived: AddBase reads Self.Base (100). }
AssertRunsOnAll(SrcMethodPtrReturnSelf,
'107' + LE + '105' + LE + '103' + LE + '109' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ImplicitSelfProcField_Expr;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;

38
compiler/src/test/pascal/cp.test.proctypes_ofobject.pas
View file

@ -56,6 +56,7 @@ type
procedure TestCodegen_MethodPtrField_DirectCall_LoadsCodeAndData;
procedure TestCodegen_MethodPtrVirtualCapture_LoadsFromVTable;
procedure TestCodegen_MethodPtrReturn_UsesAggregateABI;
{ End-to-end }
procedure TestE2E_MethodPtr_NoArgs;
@ -726,6 +727,43 @@ begin
StrPos('storel $TAnimal_Speak', IR) >= 0);
end;
procedure TProcTypesOfObjectTests.TestCodegen_MethodPtrReturn_UsesAggregateABI;
const
Src =
'''
program P;
type TBinOp = function(X, Y: Integer): Integer of object;
type
TCalc = class(TObject)
function Add(X, Y: Integer): Integer;
function GetOp: TBinOp;
end;
function TCalc.Add(X, Y: Integer): Integer;
begin Result := X + Y end;
function TCalc.GetOp: TBinOp;
begin Result := @Self.Add end;
var C: TCalc; Op: TBinOp;
begin
C := TCalc.Create();
Op := C.GetOp();
WriteLn(Op(3, 4));
C.Free()
end.
''';
var IR: string;
begin
IR := GenIR(Src);
{ A 'function ... of object' is a 16-byte (Code, Data) aggregate. The
return must go through the two-register/sret record-return ABI, not a
scalar 'l' that drops the Data half. The fix routes it through a
synthetic two-pointer record, so the callee's Result slot is 16 bytes
and the function is declared with the aggregate return type. }
AssertTrue('method-ptr-returning function allocates a 16-byte Result slot',
StrPos('%_var_Result =l alloc8 16', IR) >= 0);
AssertTrue('method-ptr return is routed through the aggregate return ABI',
StrPos('_ffi__BlaiseMethodPtr', IR) >= 0);
end;
procedure TProcTypesOfObjectTests.TestE2E_MethodPtrField_DirectCall_StmtForm;
const
Src =