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

fix(codegen): support calling a procedural-typed field through a receiver

Browse source 
Calling a function-pointer class field via its receiver (Self.FFn(args))
was broken in three independent ways:

  * Semantic analysis gave the call expression a nil result type, so
    using it as a value (Result := Self.FFn(S)) failed with "Expression
    has no value type in assignment".  The three procedural-field call
    branches now carry the field signature's return type.

  * The QBE backend passed var/out arguments by value instead of by
    reference, so a callee writing through an out parameter corrupted
    memory and crashed; the expression form also hardcoded the call's
    result width to l rather than the signature's return type.

  * The native x86-64 backend had no support for procedural-field calls
    at all -- both the statement and expression forms raised "has no
    ResolvedMethod".  EmitProcFieldCall lowers the dispatch by pushing
    the arguments first, then loading the (call-free) receiver and the
    field's code pointer, mirroring the interface-dispatch shape.

Covered by an IR-level test (indirect dispatch, not a direct call) and
end-to-end tests that run on both backends: value return, statement
call, out parameter, and multiple value arguments.
This commit is contained in:
Andrew Haines 2026-06-24 15:24:17 -04:00 committed by Graeme Geldenhuys
parent 0396ed7b1c
commit 5a4bc7f7d1
5 changed files with 364 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -504,6 +504,19 @@ type
procedure EmitCallIndirect(const APtrOperand: string;
AProcType: TProceduralTypeDesc;
AArgs: TObjectList);
{ Call a procedural-typed CLASS FIELD through a receiver
(Self.FFn(args)). The function pointer lives at [instance + Offset],
which is not a %rbp/%rip-relative operand, so this cannot reuse
EmitCallIndirect/EmitMethodPtrCall. Mirrors the interface-dispatch
shape instead: push args, then load the (call-free) receiver and the
field's code pointer. AResultType nil = statement call (no result
narrowing). Receiver shapes: a named var/global via AObjectName, a
var/out param (AIsVarParam), or a call-free AObjExpr (an identifier or
field access). }
procedure EmitProcFieldCall(AObjExpr: TASTExpr; const AObjectName: string;
AIsVarParam: Boolean; AFieldInfo: TFieldInfo;
AProcType: TProceduralTypeDesc;
AArgs: TObjectList; AResultType: TTypeDesc);
{ Evaluate an integer expression; result left in %rax (64-bit-extended). }
procedure EmitExprToEax(AExpr: TASTExpr);
procedure EmitByteRhsToEax(AExpr: TASTExpr);
@ -8105,6 +8118,17 @@ begin
Exit;
end;
{ Procedural-typed field call used as an expression: Result := Self.FFn(S).
Dispatch through the (Code, Data) pair stored in the field; the result is
left in %rax. }
if ACall.IsProcFieldCall then
begin
Self.EmitProcFieldCall(ACall.ObjExpr, ACall.ObjectName, ACall.IsVarParam,
ACall.ProcFieldInfo, TProceduralTypeDesc(ACall.ResolvedProcType),
ACall.Args, ACall.ResolvedType);
Exit;
end;
MD := TMethodDecl(ACall.ResolvedMethod);
if MD = nil then
raise ENativeCodeGenError.Create(
@ -9088,6 +9112,16 @@ begin
Exit;
end;
{ Procedural-typed field call as a statement: Self.FFn(args). Dispatch
through the (Code, Data) pair stored in the field; no result is wanted. }
if ACall.IsProcFieldCall then
begin
Self.EmitProcFieldCall(ACall.ObjExpr, ACall.ObjectName, ACall.IsVarParam,
ACall.ProcFieldInfo, TProceduralTypeDesc(ACall.ResolvedProcType),
ACall.Args, nil);
Exit;
end;
MD := TMethodDecl(ACall.ResolvedMethod);
if MD = nil then
raise ENativeCodeGenError.Create(
@ -14213,6 +14247,115 @@ begin
HK.Free();
end;
{ Call a procedural-typed class field through a receiver — emits:
<push each arg>
movq <receiver>, %rax ; addq $Offset, %rax ; %rax = field slot
movq 8(%rax), %rdi (of object only: Data -> first arg)
movq (%rax), %r10 ; code pointer
popq <arg regs> ; callq *%r10 }
procedure TX86_64Backend.EmitProcFieldCall(AObjExpr: TASTExpr;
const AObjectName: string; AIsVarParam: Boolean; AFieldInfo: TFieldInfo;
AProcType: TProceduralTypeDesc; AArgs: TObjectList; AResultType: TTypeDesc);
var
I: Integer;
Arg: TASTExpr;
IsVar: Boolean;
IsMeth: Boolean;
Slots: Integer;
HD: TList<Integer>;
HK: TList<Integer>;
HTotal: Integer;
begin
IsMeth := (AProcType <> nil) and AProcType.IsMethodPtr;
{ A method pointer consumes %rdi for the captured Data (Self), leaving five
argument registers; a plain function pointer leaves all six. Anything
larger would need the stack-overflow argument strategy — fail loudly
rather than emit a silently wrong call. }
if IsMeth then Slots := AArgs.Count + 1 else Slots := AArgs.Count;
if Slots > 6 then
raise ENativeCodeGenError.Create(
'native backend: procedural-field call with >6 argument slots is not supported');
HD := TList<Integer>.Create();
HK := TList<Integer>.Create();
try
HTotal := Self.EmitArgHoist(nil, AProcType.Params, True, '', AArgs, HD, HK);
{ Evaluate args left-to-right and push them. var/out positions push the
argument's address; record-call/string args are reloaded from the hoist
region. }
for I := 0 to AArgs.Count - 1 do
begin
Arg := TASTExpr(AArgs.Items[I]);
IsVar := (I < AProcType.Params.Count) and
TProcParamInfo(AProcType.Params.Items[I]).IsVarParam;
if HK.Get(I) >= akRecCall then
begin
Self.Emit(Format(#9'movq %d(%%rsp), %%rax',
[HTotal - HD.Get(I) + I * 8]));
Self.Emit(#9'pushq %rax');
end
else if IsVar then
begin
Self.EmitVarArgAddrToRax(Arg);
Self.Emit(#9'pushq %rax');
end
else
begin
Self.EmitExprToEax(Arg);
Self.Emit(#9'pushq %rax');
end;
end;
{ Load the receiver instance pointer into %rax. This must be call-free so
it cannot clobber the already-pushed arguments. }
if AObjExpr <> nil then
begin
if (AObjExpr is TIdentExpr) or (AObjExpr is TFieldAccessExpr) then
Self.EmitExprToEax(AObjExpr)
else
raise ENativeCodeGenError.Create(
'native backend: unsupported receiver expression in procedural-field call');
end
else if AIsVarParam then
begin
Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand(AObjectName)]));
Self.Emit(#9'movq (%rax), %rax');
end
else
Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand(AObjectName)]));
{ %rax now holds the instance pointer; advance to the field slot (the code
pointer for a plain function pointer, or the 16-byte (Code, Data) block
for a method pointer). }
if AFieldInfo.Offset > 0 then
Self.Emit(Format(#9'addq $%d, %%rax', [AFieldInfo.Offset]));
if IsMeth then
begin
Self.Emit(#9'movq 8(%rax), %rdi'); { Data (Self) -> first argument }
Self.Emit(#9'movq (%rax), %r10'); { Code pointer }
for I := AArgs.Count - 1 downto 0 do
Self.Emit(#9'popq ' + SysVArg64(I + 1));
end
else
begin
Self.Emit(#9'movq (%rax), %r10'); { Code pointer }
for I := AArgs.Count - 1 downto 0 do
Self.Emit(#9'popq ' + SysVArg64(I));
end;
Self.Emit(#9'callq *%r10');
Self.EmitHoistEpilogue(AArgs, HD, HK, HTotal, 0, True);
finally
HD.Free();
HK.Free();
end;
{ Normalise the (32-bit-ABI) return value to the field signature's return
width. Statement calls pass nil and need no result. }
if AResultType <> nil then
Self.EmitNarrowToType(AResultType);
end;
procedure TX86_64Backend.EmitLocalRecordBase(const AName, AReg: string);
begin
if FSretFunc and SameText(AName, 'Result') then

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

@ -6618,11 +6618,21 @@ begin
for I := 0 to ACall.Args.Count - 1 do
begin
if ArgLine <> '' then ArgLine := ArgLine + ', ';
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
QType := QbeTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc);
ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QType);
ArgLine := ArgLine + Format('%s %s',
[QbeParamTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc), ArgTemp]);
{ var/out parameters are passed by reference — emit the argument's
l-value address, not its value. }
if TProcParamInfo(PT.Params.Items[I]).IsVarParam then
begin
ArgTemp := EmitLValueAddr(TASTExpr(ACall.Args.Items[I]));
ArgLine := ArgLine + Format('l %s', [ArgTemp]);
end
else
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
QType := QbeTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc);
ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QType);
ArgLine := ArgLine + Format('%s %s',
[QbeParamTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc), ArgTemp]);
end;
end;
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
if ExprOwnsRef(ACall.ObjExpr) then
@ -6811,11 +6821,21 @@ begin
for I := 0 to ACall.Args.Count - 1 do
begin
if ArgLine <> '' then ArgLine := ArgLine + ', ';
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
QType := QbeTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc);
ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QType);
ArgLine := ArgLine + Format('%s %s',
[QbeParamTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc), ArgTemp]);
{ var/out parameters are passed by reference — emit the argument's
l-value address, not its value. }
if TProcParamInfo(PT.Params.Items[I]).IsVarParam then
begin
ArgTemp := EmitLValueAddr(TASTExpr(ACall.Args.Items[I]));
ArgLine := ArgLine + Format('l %s', [ArgTemp]);
end
else
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
QType := QbeTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc);
ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QType);
ArgLine := ArgLine + Format('%s %s',
[QbeParamTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc), ArgTemp]);
end;
end;
EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
Exit;
@ -10770,14 +10790,30 @@ begin
for I := 0 to MCallExpr.Args.Count - 1 do
begin
if ArgLine <> '' then ArgLine := ArgLine + ', ';
ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I]));
QType := QbeTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc);
ArgTemp := CoerceArg(ArgTemp, TASTExpr(MCallExpr.Args.Items[I]), QType);
ArgLine := ArgLine + Format('%s %s',
[QbeParamTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc), ArgTemp]);
{ var/out parameters are passed by reference — emit the argument's
l-value address, not its value (otherwise the callee writes through
a garbage pointer). }
if TProcParamInfo(PT.Params.Items[I]).IsVarParam then
begin
ArgTemp := EmitLValueAddr(TASTExpr(MCallExpr.Args.Items[I]));
ArgLine := ArgLine + Format('l %s', [ArgTemp]);
end
else
begin
ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I]));
QType := QbeTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc);
ArgTemp := CoerceArg(ArgTemp, TASTExpr(MCallExpr.Args.Items[I]), QType);
ArgLine := ArgLine + Format('%s %s',
[QbeParamTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc), ArgTemp]);
end;
end;
{ Result width follows the field signature's return type. }
if PT.ReturnType <> nil then
QType := QbeTypeOf(PT.ReturnType)
else
QType := 'l';
T := AllocTemp();
EmitLine(Format(' %s =l call %s(%s)', [T, FPtrTemp, ArgLine]));
EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FPtrTemp, ArgLine]));
Exit(T);
end;

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

@ -10017,7 +10017,10 @@ begin
AExpr.ResolvedProcType := FldInfo.TypeDesc;
AExpr.ResolvedClassType := RT;
AExpr.ResolvedMethod := nil;
AExpr.ResolvedType := nil;
{ Calling a function-pointer field yields the field signature's return
type — not nil — so the call can be used as an expression. }
AExpr.ResolvedType := TProceduralTypeDesc(FldInfo.TypeDesc).ReturnType;
Result := AExpr.ResolvedType;
Exit;
end;
SemanticError(
@ -10113,7 +10116,9 @@ begin
AExpr.ResolvedProcType := FldInfo.TypeDesc;
AExpr.ResolvedClassType := RT;
AExpr.ResolvedMethod := nil;
AExpr.ResolvedType := nil;
{ Function-pointer field call yields the signature's return type. }
AExpr.ResolvedType := TProceduralTypeDesc(FldInfo.TypeDesc).ReturnType;
Result := AExpr.ResolvedType;
Exit;
end;
SemanticError(
@ -10345,7 +10350,9 @@ begin
(ObjSym.Kind = skVarParameter) or
((ObjSym.Kind = skParameter) and (ObjSym.TypeDesc <> nil) and
(ObjSym.TypeDesc.Kind in [tyRecord, tyStaticArray]));
AExpr.ResolvedType := nil;
{ Function-pointer field call yields the signature's return type. }
AExpr.ResolvedType := TProceduralTypeDesc(FldInfo.TypeDesc).ReturnType;
Result := AExpr.ResolvedType;
Exit;
end;
SemanticError(

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

@ -42,6 +42,11 @@ type
{ Procedural types }
procedure TestRun_ProcType_CallViaVariable;
procedure TestRun_ProcType_OfObject_Dispatch;
{ Procedural-typed class field called through a receiver (Self.FFn(...)). }
procedure TestRun_ProcFieldCall_ReturnValue;
procedure TestRun_ProcFieldCall_Statement;
procedure TestRun_ProcFieldCall_OutParam;
procedure TestRun_ProcFieldCall_MultiArg;
{ Default parameters }
procedure TestRun_DefaultParam_OmitLast;
@ -329,6 +334,98 @@ const
end.
''';
{ Function-pointer class field called through a receiver, as an expression. }
SrcProcFieldReturn = '''
program Prg;
type
TFn = function(const S: string): Integer;
TBox = class
FFn: TFn;
function Run(const S: string): Integer;
end;
function Len2(const S: string): Integer;
begin Result := Length(S) end;
function TBox.Run(const S: string): Integer;
begin Result := Self.FFn(S) end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Len2;
WriteLn(IntToStr(B.Run('hello')));
B.Free()
end.
''';
{ Function-pointer class field called as a statement. }
SrcProcFieldStmt = '''
program Prg;
type
TFn = procedure(const S: string);
TBox = class
FFn: TFn;
procedure Run;
end;
procedure Hi(const S: string);
begin WriteLn(S) end;
procedure TBox.Run;
begin Self.FFn('hi') end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Hi;
B.Run();
B.Free()
end.
''';
{ Function-pointer class field with an out parameter — the argument must be
passed by reference so the callee writes back into the caller's variable. }
SrcProcFieldOut = '''
program Prg;
type
TFn = function(const S: string; out V: string): Boolean;
TBox = class
FFn: TFn;
function Run(const S: string): string;
end;
function Echo(const S: string; out V: string): Boolean;
begin V := S; Result := True end;
function TBox.Run(const S: string): string;
var V: string;
begin
if Self.FFn(S, V) then Result := V else Result := '?'
end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Echo;
WriteLn(B.Run('hi'));
B.Free()
end.
''';
{ Function-pointer class field with several value arguments. }
SrcProcFieldMultiArg = '''
program Prg;
type
TFn = function(A, B, C: Integer): Integer;
TBox = class
FFn: TFn;
function Run(X: Integer): Integer;
end;
function Sum3(A, B, C: Integer): Integer;
begin Result := A + B + C end;
function TBox.Run(X: Integer): Integer;
begin Result := Self.FFn(X, X + 1, X + 2) end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Sum3;
WriteLn(IntToStr(B.Run(10)));
B.Free()
end.
''';
SrcDefaultParam = '''
program Prg;
function Add(A: Integer; B: Integer = 10): Integer;
@ -646,6 +743,30 @@ begin
AssertEquals('55', '55' + LE, Output);
end;
procedure TE2EMiscTests.TestRun_ProcFieldCall_ReturnValue;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcFieldReturn, '5' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ProcFieldCall_Statement;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcFieldStmt, 'hi' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ProcFieldCall_OutParam;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcFieldOut, 'hi' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ProcFieldCall_MultiArg;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcFieldMultiArg, '33' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_DefaultParam_OmitLast;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;

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

@ -47,6 +47,10 @@ type
procedure TestCodegen_ProceduralVar_AllocatedAsPointer;
procedure TestCodegen_AddrOfFunc_EmitsFunctionLabel;
procedure TestCodegen_IndirectCall_UsesTempNotName;
{ A procedural-typed class field called through a receiver as an
expression (Result := Self.FFn(S)) must type to the field's return
type and dispatch through the loaded pointer, not a direct call. }
procedure TestCodegen_ProcFieldCallExpr_IndirectNotDirect;
end;
implementation
@ -548,6 +552,40 @@ begin
IRContains(IR, 'call $MyFn('));
end;
procedure TProcTypesTests.TestCodegen_ProcFieldCallExpr_IndirectNotDirect;
var
IR: string;
begin
{ Regression: this used to fail semantic analysis ("Expression has no value
type in assignment") because a procedural-field call used as an expression
was given a nil result type. It must now compile and dispatch indirectly. }
IR := GenIR(
'''
program Test;
type
TFn = function(const S: string): Integer;
TBox = class
FFn: TFn;
function Run(const S: string): Integer;
end;
function TBox.Run(const S: string): Integer;
begin
Result := Self.FFn(S)
end;
var
B: TBox;
begin
end.
'''
);
{ The only call in the program is the indirect dispatch through the field —
it must go through a temp (call %tmp(...)), never a direct named call. }
AssertTrue('Procedural-field call must dispatch through a temp',
IRContains(IR, 'call %'));
AssertFalse('Procedural-field call must not be a direct call to $FFn',
IRContains(IR, 'call $FFn('));
end;
initialization
RegisterTest(TProcTypesTests);