From 5a4bc7f7d1b2fb3dacf0cce40c794b92c0771bb1 Mon Sep 17 00:00:00 2001 From: Andrew Haines Date: Wed, 24 Jun 2026 15:24:17 -0400 Subject: [PATCH] fix(codegen): support calling a procedural-typed field through a receiver 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. --- .../pascal/blaise.codegen.native.x86_64.pas | 143 ++++++++++++++++++ .../src/main/pascal/blaise.codegen.qbe.pas | 68 +++++++-- compiler/src/main/pascal/uSemantic.pas | 13 +- compiler/src/test/pascal/cp.test.e2e.misc.pas | 121 +++++++++++++++ .../src/test/pascal/cp.test.proctypes.pas | 38 +++++ 5 files changed, 364 insertions(+), 19 deletions(-) diff --git a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas index ce61515..7190db2 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -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: + + movq , %rax ; addq $Offset, %rax ; %rax = field slot + movq 8(%rax), %rdi (of object only: Data -> first arg) + movq (%rax), %r10 ; code pointer + popq ; 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; + HK: TList; + 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.Create(); + HK := TList.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 diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index 1d4f56f..19a9134 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -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; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index e1b75e1..9a0215a 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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( diff --git a/compiler/src/test/pascal/cp.test.e2e.misc.pas b/compiler/src/test/pascal/cp.test.e2e.misc.pas index d16980f..afecbdb 100644 --- a/compiler/src/test/pascal/cp.test.e2e.misc.pas +++ b/compiler/src/test/pascal/cp.test.e2e.misc.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.proctypes.pas b/compiler/src/test/pascal/cp.test.proctypes.pas index 873f3a2..9e076b8 100644 --- a/compiler/src/test/pascal/cp.test.proctypes.pas +++ b/compiler/src/test/pascal/cp.test.proctypes.pas @@ -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);