From f6c1cee9fec81b0580eafbf4f9344d189b779ca1 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Tue, 30 Jun 2026 17:34:26 +0100 Subject: [PATCH] fix(codegen): return function-of-object via two-register aggregate ABI MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- .../pascal/blaise.codegen.native.x86_64.pas | 213 +++++++++++++++--- .../src/main/pascal/blaise.codegen.qbe.pas | 155 +++++++++++-- compiler/src/test/pascal/cp.test.e2e.misc.pas | 89 ++++++++ .../pascal/cp.test.proctypes_ofobject.pas | 38 ++++ 4 files changed, 444 insertions(+), 51 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 fd542c2..3713937 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -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; HK: TList; 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; HK: TList; 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 diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index 75ead5b..c5a1fd8 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -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 diff --git a/compiler/src/test/pascal/cp.test.e2e.misc.pas b/compiler/src/test/pascal/cp.test.e2e.misc.pas index 417868c..eab1509 100644 --- a/compiler/src/test/pascal/cp.test.e2e.misc.pas +++ b/compiler/src/test/pascal/cp.test.e2e.misc.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas b/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas index e4559b2..da1f3a3 100644 --- a/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas +++ b/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas @@ -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 =