From a4d178b52c4eda52132d0bdc8cd6af775437dc93 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Sat, 27 Jun 2026 21:52:23 +0100 Subject: [PATCH] fix(codegen): itab dispatch of a record-returning method (both backends) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit An interface (itab-dispatched) method returning a RECORD was broken on both backends, both when the result was assigned and when discarded in statement position, for memory-class (sret) and register-class records alike. The itab dispatch had no record-return ABI: it emitted a scalar call, so for a memory-class return the first argument register doubled as the sret pointer (the callee received a garbage argument and wrote the record over caller memory — "_StringRelease corrupted header"), and a register-class return was dereferenced as a pointer. Assignment was equally broken because IsRecordCall / IsNativeRecordCall keyed off ResolvedMethod, which is nil for itab dispatch. QBE: * IsRecordCall recognises an itab record call (ResolvedClassType = interface + ResolvedType in [record, static-array]) for both the args form (TMethodCallExpr) and the zero-arg form (TFieldAccessExpr.IsInterfaceCall). * EmitIntfSretDispatch builds the visible args (Self, method args) and delegates to EmitRecordReturnCallSite, which applies the correct ABI from ClassifyRecordReturn (sret pointer vs register capture) — instead of always passing an sret buffer. * The discarded-statement path (EmitMethodCall) gained a record/static-array branch: a throwaway zeroed buffer, the classified call, then EmitRecordReleaseFields on the buffer. Native: * IsNativeRecordCall recognises the itab record case. * New EmitIntfRecordSretDispatch performs itab dispatch with the full record-return ABI: an sret buffer in %rdi for a memory-class record, or EmitRecordRegReturnCapture (a new helper covering rcInt1/rcInt2/rcSSE1/ rcSSE2/rcIntSSE/rcSSEInt) storing the register result into the destination. Wired into EmitRecordCallSretAt, both record-assignment branches (implicit-Self field and plain local/var/global), and the discarded-statement path. E2E regressions (both backends, via AssertRunsOnAll): TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsSretRecord and _ReturnsRegisterRecord — each exercises an assigned and a discarded call. --- .../pascal/blaise.codegen.native.x86_64.pas | 337 +++++++++++++++++- .../src/main/pascal/blaise.codegen.qbe.pas | 69 +++- .../test/pascal/cp.test.e2e.interfaces.pas | 79 ++++ 3 files changed, 476 insertions(+), 9 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 b23ed31..a162e79 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -547,6 +547,15 @@ type EmitIntfSretCall: the 16-byte buffer is left at (%rsp); the caller loads the slots and pops it (addq $16, %rsp). } procedure EmitIntfSretMethodCall(ACall: TMethodCallExpr); + { Interface-method call (itab dispatch) RETURNING a RECORD: dispatch through + the itab and write the record result into the caller-supplied ADest, + honouring the full record-return ABI (hidden sret pointer for a + memory-class record; register capture for a register-class one). Mirrors + the QBE EmitIntfSretDispatch helper. ADestIsIndirect: ADest holds a + pointer to the destination buffer (var/out / Result), not the buffer. } + procedure EmitIntfRecordSretDispatch(ACall: TMethodCallExpr; + const ADest: string; + ADestIsIndirect: Boolean); { Class-receiver method call RETURNING an interface (Obj.Make() where Obj is class-typed): sret hidden first arg (%rdi), receiver in %rsi, static or vtable dispatch from the receiver's class. Same caller contract as @@ -4550,6 +4559,18 @@ end; function TX86_64Backend.IsNativeRecordCall(AExpr: TASTExpr): Boolean; begin Result := False; + { Interface (itab) dispatch has no ResolvedMethod — classify by the call's + resolved return type instead, so a record-returning itab call routes + through the sret/record-return path (EmitIntfRecordSretDispatch) like a + direct record method call. Mirrors the QBE IsRecordCall interface case. } + if (AExpr is TMethodCallExpr) and + (TMethodCallExpr(AExpr).ResolvedClassType <> nil) and + (TMethodCallExpr(AExpr).ResolvedClassType.Kind = tyInterface) then + begin + Result := (TMethodCallExpr(AExpr).ResolvedType <> nil) and + (TMethodCallExpr(AExpr).ResolvedType.Kind = tyRecord); + Exit; + end; if (AExpr is TMethodCallExpr) and (TMethodCallExpr(AExpr).ResolvedMethod <> nil) and (TMethodDecl(TMethodCallExpr(AExpr).ResolvedMethod).ResolvedReturnType <> nil) and @@ -4616,7 +4637,13 @@ end; procedure TX86_64Backend.EmitRecordCallSretAt(AExpr: TASTExpr; const ADest: string); begin - if AExpr is TMethodCallExpr then + if (AExpr is TMethodCallExpr) and + (TMethodCallExpr(AExpr).ResolvedClassType <> nil) and + (TMethodCallExpr(AExpr).ResolvedClassType.Kind = tyInterface) then + { Interface (itab) record-returning dispatch — EmitMethodSretCall raises on + a nil ResolvedMethod, so route through the itab record-return helper. } + Self.EmitIntfRecordSretDispatch(TMethodCallExpr(AExpr), ADest, False) + else if AExpr is TMethodCallExpr then Self.EmitMethodSretCall(TMethodCallExpr(AExpr), ADest, False) else if AExpr is TInheritedCallExpr then Self.EmitInheritedRecordSret( @@ -9061,6 +9088,7 @@ var IsSretDiscard: Boolean; SretBufSize: Integer; SretRT: TRecordTypeDesc; + SretShim: TMethodCallExpr; begin { Metaclass-var constructor dispatch in statement position: C.Create(args) where C is a 'class of' variable and the result is discarded. Only the @@ -9139,6 +9167,57 @@ begin Exit; end; + { Discarded interface (itab) method call returning a RECORD: the callee + follows the record-return ABI (sret pointer for a memory-class record, + register return for a register-class one). The plain EmitInterfaceCall + path below treats the return as a scalar / fat pointer and hands the callee + no sret buffer, so an sret record is written over caller memory. Allocate + a zeroed throwaway buffer, dispatch into it, then release its managed + fields. Mirrors the QBE EmitMethodCall record-discard branch. } + if (ACall.ResolvedClassType <> nil) and + (ACall.ResolvedClassType.Kind = tyInterface) and + (ACall.ResolvedReturnTypeDesc <> nil) and + (ACall.ResolvedReturnTypeDesc.Kind = tyRecord) then + begin + SretRT := TRecordTypeDesc(ACall.ResolvedReturnTypeDesc); + SretBufSize := (SretRT.TotalSize() + 15) and (-16); + Self.Emit(#9'pushq %rbx'); + Self.Emit(Format(#9'subq $%d, %%rsp', [SretBufSize])); + Self.Emit(#9'movq %rsp, %rbx'); + { Zero the buffer so EmitRecordFieldReleases sees nil managed fields if the + callee leaves any unset. } + Self.Emit(#9'movq %rbx, %rdi'); + Self.Emit(#9'xorl %esi, %esi'); + Self.Emit(Format(#9'movq $%d, %%rdx', [SretRT.TotalSize()])); + Self.Emit(#9'callq memset'); + { EmitIntfRecordSretDispatch takes the expression form; build a transient + TMethodCallExpr view of this statement node (the relevant fields are the + same). Args are borrowed and detached before Free. } + SretShim := TMethodCallExpr.Create(); + try + SretShim.ObjectName := ACall.ObjectName; + SretShim.Name := ACall.Name; + SretShim.Args := ACall.Args; + SretShim.ObjExpr := ACall.ObjExpr; + SretShim.ResolvedClassType := ACall.ResolvedClassType; + SretShim.ResolvedType := ACall.ResolvedReturnTypeDesc; + SretShim.IsGlobal := ACall.IsGlobal; + SretShim.IsVarParam := ACall.IsVarParam; + Self.EmitIntfRecordSretDispatch(SretShim, '(%rbx)', False); + finally + SretShim.Args := nil; { borrowed — do not free } + SretShim.ObjExpr := nil; { borrowed — do not free } + SretShim.Free(); + end; + { The dispatch may clobber %rbx during arg evaluation; %rsp is balanced and + still points at the buffer, so re-derive the buffer address. } + Self.Emit(#9'movq %rsp, %rbx'); + Self.EmitRecordFieldReleases(SretRT, '%rbx'); + Self.Emit(Format(#9'addq $%d, %%rsp', [SretBufSize])); + Self.Emit(#9'popq %rbx'); + Exit; + end; + { Interface method dispatch (statement position): route through the itab. Pass ObjExpr so receivers that are interface-typed fields (H.S.Note()) load obj/itab from the field's fat pointer instead of bogus _obj/_itab @@ -10791,6 +10870,24 @@ begin Self.Emit(#9'movq %rax, (%r15)'); Self.Emit(#9'popq %r15'); end + else if (Asgn.ResolvedLhsType.Kind = tyRecord) and + (Asgn.Expr is TMethodCallExpr) and + (TMethodCallExpr(Asgn.Expr).ResolvedClassType <> nil) and + (TMethodCallExpr(Asgn.Expr).ResolvedClassType.Kind = tyInterface) and + (TMethodCallExpr(Asgn.Expr).ResolvedType <> nil) and + (TMethodCallExpr(Asgn.Expr).ResolvedType.Kind = tyRecord) then + begin + { Interface (itab) record-returning dispatch into an implicit-Self + field — EmitRecordCallSretAt routes the itab case to the record- + return helper. } + Self.Emit(#9'pushq %rbx'); + Self.Emit(Format(#9'movq %s, %%rbx', [Self.VarOperand('Self')])); + if ISFld.Offset > 0 then + Self.Emit(Format(#9'addq $%d, %%rbx', [ISFld.Offset])); + Self.EmitRecordFieldReleases(TRecordTypeDesc(Asgn.ResolvedLhsType), '%rbx'); + Self.EmitIntfRecordSretDispatch(TMethodCallExpr(Asgn.Expr), '(%rbx)', False); + Self.Emit(#9'popq %rbx'); + end else if (Asgn.ResolvedLhsType.Kind = tyRecord) and (Asgn.Expr is TMethodCallExpr) and (TMethodCallExpr(Asgn.Expr).ResolvedMethod <> nil) and @@ -10976,6 +11073,41 @@ begin end; Exit; end; + { sret assignment: interface (itab) method call returning a record. The + itab call has no ResolvedMethod, so it is classified by ResolvedClassType + = interface + ResolvedType = record. EmitIntfRecordSretDispatch writes + the record straight into the destination, honouring the record-return ABI + (hidden sret pointer for a memory-class record; register capture for a + register-class one). Mirrors the QBE EmitIntfSretDispatch path. } + if (Asgn.ResolvedLhsType <> nil) and + (Asgn.ResolvedLhsType.Kind = tyRecord) and + (Asgn.Expr is TMethodCallExpr) and + (TMethodCallExpr(Asgn.Expr).ResolvedClassType <> nil) and + (TMethodCallExpr(Asgn.Expr).ResolvedClassType.Kind = tyInterface) and + (TMethodCallExpr(Asgn.Expr).ResolvedType <> nil) and + (TMethodCallExpr(Asgn.Expr).ResolvedType.Kind = tyRecord) then + begin + { Release the destination's prior managed fields before overwriting it, + then dispatch. The dispatch writes the constructed record (which owns + its managed fields +1) over the dest, so ownership transfers cleanly. } + Self.Emit(#9'pushq %rbx'); + if FSretFunc and SameText(Asgn.Name, 'Result') then + Self.Emit(Format(#9'movq %s, %%rbx', [Self.VarOperand('Result')])) + else if Asgn.IsVarParam then + Self.Emit(Format(#9'movq %s, %%rbx', [Self.VarOperand(Asgn.Name)])) + else if Self.IsLocal(Asgn.Name) then + Self.Emit(Format(#9'leaq %s, %%rbx', [Self.VarOperand(Asgn.Name)])) + else + begin + Self.AddGlobal(Asgn.Name, Asgn.ResolvedLhsType); + if Asgn.IsThreadVar then Self.MarkThreadVar(Asgn.Name); + Self.EmitLeaqGlobal(Asgn.Name, '%rbx'); + end; + Self.EmitRecordFieldReleases(TRecordTypeDesc(Asgn.ResolvedLhsType), '%rbx'); + Self.EmitIntfRecordSretDispatch(TMethodCallExpr(Asgn.Expr), '(%rbx)', False); + Self.Emit(#9'popq %rbx'); + Exit; + end; { sret assignment: method call returning a record (or jumbo set). %rdi = sret ptr, %rsi = Self, %rdx.. = user args. } if (Asgn.ResolvedLhsType <> nil) and @@ -15756,6 +15888,209 @@ begin HK.Free(); end; +procedure TX86_64Backend.EmitIntfRecordSretDispatch(ACall: TMethodCallExpr; + const ADest: string; ADestIsIndirect: Boolean); +var + I, SlotOff, ArgN, Slots: Integer; + Arg: TASTExpr; + IntfD: TInterfaceTypeDesc; + HD: TList; + HK: TList; + HTotal, Pushed: Integer; + VFlags: string; + IE: TIdentExpr; + OverflowBytes, ABase: Integer; + RC: TRecReturnClass; + RetRec: TRecordTypeDesc; +begin + IntfD := TInterfaceTypeDesc(ACall.ResolvedClassType); + RetRec := TRecordTypeDesc(ACall.ResolvedType); + RC := ClassifyRecordReturn(RetRec); + ArgN := 0; + if ACall.Args <> nil then ArgN := ACall.Args.Count; + + { Resolve the destination to an ABSOLUTE pointer FIRST, in callee-saved %r14, + before any %rsp movement (arg pushes / overflow spill) can drift a + %rsp-relative ADest. } + Self.Emit(#9'pushq %r14'); + if ADestIsIndirect then + Self.Emit(Format(#9'movq %s, %%r14', [ADest])) + else + Self.Emit(Format(#9'leaq %s, %%r14', [ADest])); + + { Same unknown-signature hoist as EmitIntfSretMethodCall; the region sits + BELOW any sret buffer space we reserve. } + HD := TList.Create(); + HK := TList.Create(); + VFlags := IntfD.MethodParamVarFlagsStr(IntfD.MethodIndex(ACall.Name)); + HTotal := Self.EmitArgHoist(nil, nil, False, VFlags, ACall.Args, HD, HK); + Pushed := 0; + { Push args left-to-right; interface args push obj then itab (2 slots). } + for I := 0 to ArgN - 1 do + begin + Arg := TASTExpr(ACall.Args.Items[I]); + if HK.Get(I) >= akRecCall then + begin + Self.Emit(Format(#9'movq %d(%%rsp), %%rax', [HTotal - HD.Get(I) + Pushed])); + Self.Emit(#9'pushq %rax'); + end + else if Self.VarFlagAt(VFlags, I) then + begin + Self.EmitVarArgAddrToRax(Arg); + Self.Emit(#9'pushq %rax'); + end + else if (Arg.ResolvedType <> nil) and (Arg.ResolvedType.Kind = tyInterface) then + begin + if Arg is TIdentExpr then + begin + if TIdentExpr(Arg).IsImplicitSelf and + (TIdentExpr(Arg).ImplicitFieldInfo <> nil) then + begin + Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand('Self')])); + if TFieldInfo(TIdentExpr(Arg).ImplicitFieldInfo).Offset > 0 then + Self.Emit(Format(#9'addq $%d, %%rax', + [TFieldInfo(TIdentExpr(Arg).ImplicitFieldInfo).Offset])); + Self.Emit(#9'movq (%rax), %rcx'); + Self.Emit(#9'movq 8(%rax), %rdx'); + Self.Emit(#9'pushq %rcx'); + Self.Emit(#9'pushq %rdx'); + end + else + begin + Self.Emit(Format(#9'movq %s, %%rax', + [Self.IntfObjOperand(TIdentExpr(Arg).Name, TIdentExpr(Arg).IsGlobal)])); + Self.Emit(Format(#9'movq %s, %%rcx', + [Self.IntfItabOperand(TIdentExpr(Arg).Name, TIdentExpr(Arg).IsGlobal)])); + Self.Emit(#9'pushq %rax'); + Self.Emit(#9'pushq %rcx'); + end; + end + else if Arg is TFieldAccessExpr then + begin + Self.EmitInterfaceFieldAddr(TFieldAccessExpr(Arg), '%rax'); + Self.Emit(#9'movq (%rax), %rcx'); + Self.Emit(#9'movq 8(%rax), %rdx'); + Self.Emit(#9'pushq %rcx'); + Self.Emit(#9'pushq %rdx'); + end + else + raise ENativeCodeGenError.Create( + 'native backend: unsupported interface arg expression in sret interface record dispatch'); + end + else + begin + Self.EmitExprToEax(Arg); + Self.Emit(#9'pushq %rax'); + end; + if (HK.Get(I) < akRecCall) and (not Self.VarFlagAt(VFlags, I)) and + (Arg.ResolvedType <> nil) and + (Arg.ResolvedType.Kind = tyInterface) then + Pushed := Pushed + 16 + else + Pushed := Pushed + 8; + end; + { Resolve the receiver: obj into %r10, itab into %rax. } + if (ACall.ObjExpr <> nil) and (ACall.ObjExpr is TFieldAccessExpr) then + begin + Self.EmitInterfaceFieldAddr(TFieldAccessExpr(ACall.ObjExpr), '%r10'); + Self.Emit(#9'movq 8(%r10), %rax'); + Self.Emit(#9'movq (%r10), %r10'); + end + else if (ACall.ObjExpr <> nil) and (ACall.ObjExpr is TIdentExpr) and + TIdentExpr(ACall.ObjExpr).IsImplicitSelf and + (TIdentExpr(ACall.ObjExpr).ImplicitFieldInfo <> nil) then + begin + IE := TIdentExpr(ACall.ObjExpr); + Self.Emit(Format(#9'movq %s, %%r10', [Self.VarOperand('Self')])); + if TFieldInfo(IE.ImplicitFieldInfo).Offset > 0 then + Self.Emit(Format(#9'addq $%d, %%r10', + [TFieldInfo(IE.ImplicitFieldInfo).Offset])); + Self.Emit(#9'movq 8(%r10), %rax'); + Self.Emit(#9'movq (%r10), %r10'); + end + else if (ACall.ObjExpr <> nil) and (ACall.ObjExpr is TIdentExpr) then + begin + IE := TIdentExpr(ACall.ObjExpr); + Self.Emit(Format(#9'movq %s, %%r10', + [Self.IntfObjOperand(IE.Name, IE.IsGlobal)])); + Self.Emit(Format(#9'movq %s, %%rax', + [Self.IntfItabOperand(IE.Name, IE.IsGlobal)])); + end + else if ACall.ObjExpr <> nil then + raise ENativeCodeGenError.Create( + 'native backend: unsupported receiver expression in sret interface record dispatch') + else if ACall.IsVarParam then + begin + Self.Emit(Format(#9'movq %s, %%r10', [Self.VarOperand(ACall.ObjectName)])); + Self.Emit(#9'movq 8(%r10), %rax'); + Self.Emit(#9'movq (%r10), %r10'); + end + else + begin + Self.Emit(Format(#9'movq %s, %%r10', + [Self.IntfObjOperand(ACall.ObjectName, ACall.IsGlobal)])); + Self.Emit(Format(#9'movq %s, %%rax', + [Self.IntfItabOperand(ACall.ObjectName, ACall.IsGlobal)])); + end; + SlotOff := IntfD.MethodIndex(ACall.Name) * 8; + if SlotOff = 0 then + Self.Emit(#9'movq (%rax), %r11') + else + Self.Emit(Format(#9'movq %d(%%rax), %%r11', [SlotOff])); + + { Count the arg SLOTS (var positions one slot; interface args two). } + Slots := 0; + for I := 0 to ArgN - 1 do + begin + Arg := TASTExpr(ACall.Args.Items[I]); + if (not Self.VarFlagAt(VFlags, I)) and (Arg.ResolvedType <> nil) and + (Arg.ResolvedType.Kind = tyInterface) then + Inc(Slots, 2) + else + Inc(Slots); + end; + + if RC = rcSret then + begin + { Memory-class record: hidden sret pointer in %rdi, receiver obj in %rsi, + visible args from %rdx (base index 2). The dest buffer is %r14. } + Self.Emit(#9'movq %r14, %rdi'); + Self.Emit(#9'xorl %esi, %esi'); + Self.Emit(Format(#9'movq $%d, %%rdx', [RetRec.TotalSize()])); + Self.Emit(#9'pushq %r10'); { preserve receiver obj across memset } + Self.Emit(#9'pushq %r11'); { preserve fptr across memset } + Self.Emit(#9'callq memset'); + Self.Emit(#9'popq %r11'); + Self.Emit(#9'popq %r10'); + ABase := 2; + OverflowBytes := Self.EmitSretRegArgs(Slots, ABase); + Self.Emit(#9'movq %r10, %rsi'); + Self.Emit(#9'movq %r14, %rdi'); + Self.Emit(#9'callq *%r11'); + if OverflowBytes > 0 then + Self.Emit(Format(#9'addq $%d, %%rsp', [OverflowBytes])); + Self.EmitHoistEpilogue(ACall.Args, HD, HK, HTotal, 0, True); + end + else + begin + { Register-class record: NO hidden sret arg. Receiver obj in %rdi, + visible args from %rsi (base index 1). Capture the register return + into the dest buffer (%r14). } + ABase := 1; + OverflowBytes := Self.EmitSretRegArgs(Slots, ABase); + Self.Emit(#9'movq %r10, %rdi'); + Self.Emit(#9'callq *%r11'); + if OverflowBytes > 0 then + Self.Emit(Format(#9'addq $%d, %%rsp', [OverflowBytes])); + { %r14 still holds the dest pointer (callee-saved across the call). } + Self.EmitRecordRegReturnCapture('%r14', RetRec, RC, True); + Self.EmitHoistEpilogue(ACall.Args, HD, HK, HTotal, 0, True); + end; + HD.Free(); + HK.Free(); + Self.Emit(#9'popq %r14'); +end; + procedure TX86_64Backend.EmitClassIntfSretMethodCall(ACall: TMethodCallExpr); var I: Integer; diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index df527bb..885d982 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -5077,15 +5077,34 @@ begin end else if AExpr is TMethodCallExpr then begin - if TMethodCallExpr(AExpr).ResolvedMethod = nil then Exit; - MDecl := TMethodDecl(TMethodCallExpr(AExpr).ResolvedMethod); - Result := (MDecl.ResolvedReturnType <> nil) and - (MDecl.ResolvedReturnType.Kind in [tyRecord, tyStaticArray]); + { Interface (itab) dispatch has no ResolvedMethod — classify by the call's + resolved return type instead, so a record-returning itab call routes + through the sret/record-return path (EmitIntfSretDispatch) like a direct + record method call. } + if (TMethodCallExpr(AExpr).ResolvedClassType <> nil) and + (TMethodCallExpr(AExpr).ResolvedClassType.Kind = tyInterface) then + Result := (TMethodCallExpr(AExpr).ResolvedType <> nil) and + (TMethodCallExpr(AExpr).ResolvedType.Kind in [tyRecord, tyStaticArray]) + else + begin + if TMethodCallExpr(AExpr).ResolvedMethod = nil then Exit; + MDecl := TMethodDecl(TMethodCallExpr(AExpr).ResolvedMethod); + Result := (MDecl.ResolvedReturnType <> nil) and + (MDecl.ResolvedReturnType.Kind in [tyRecord, tyStaticArray]); + end; end else if AExpr is TFieldAccessExpr then begin FldA := TFieldAccessExpr(AExpr); if not FldA.IsMethodCall then Exit; + { Zero-arg interface (itab) dispatch (G.GetThing): no ResolvedMethod — + classify by the resolved return type, as for the args form above. } + if FldA.IsInterfaceCall then + begin + Result := (FldA.ResolvedType <> nil) and + (FldA.ResolvedType.Kind in [tyRecord, tyStaticArray]); + Exit; + end; if FldA.ResolvedMethod = nil then Exit; MDecl := TMethodDecl(FldA.ResolvedMethod); Result := (MDecl.ResolvedReturnType <> nil) and @@ -5563,9 +5582,11 @@ var ArgLine: string; SlotOff: Integer; PMark: Integer; + RetType: TRecordTypeDesc; begin PMark := PendingReleaseMark(); AArgs := nil; + RetType := TRecordTypeDesc(TASTExpr(ACall).ResolvedType); if ACall is TMethodCallExpr then begin MCall := TMethodCallExpr(ACall); @@ -5610,11 +5631,15 @@ begin EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff])); EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp])); end; - { Callee signature is (sret, Self, args...) — the same shape every - interface-returning method body declares (`l %_par__sret, l %_par_Self`). } - ArgLine := Format('l %s, l %s', [ASretAddr, SelfTemp]) + + { The visible arguments are (Self, method-args...). The RECORD-RETURN ABI + (sret vs register-class) is decided by EmitRecordReturnCallSite from the + return type's classification — exactly as for a direct record-returning + call. Passing an sret pointer unconditionally (the old behaviour) is only + correct for memory-class records; a register-class record return then + mismatched the callee ABI, shifting Self/args and corrupting memory. } + ArgLine := Format('l %s', [SelfTemp]) + IntfDispatchArgFragment(IntfDesc, IntfDesc.MethodIndex(MethName), AArgs); - EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine])); + EmitRecordReturnCallSite(FPtrTemp, ArgLine, RetType, ASretAddr); FlushPendingReleases(PMark); end; @@ -6506,6 +6531,7 @@ var ItabName: string; SretTemp: string; PMark: Integer; + RetTypeRec: TRecordTypeDesc; begin PMark := PendingReleaseMark(); @@ -6671,6 +6697,33 @@ begin EmitLine(Format(' %s =l loadl %s', [ArgTemp, SretTemp])); EmitLine(Format(' call $_ClassRelease(l %s)', [ArgTemp])); end + else if (ACall.ResolvedReturnTypeDesc <> nil) and + (ACall.ResolvedReturnTypeDesc.Kind in [tyRecord, tyStaticArray]) then + begin + { Discarded RECORD/static-array return through itab dispatch: the callee + follows the record-return ABI (sret pointer for a memory-class record, + register return for a register-class one). A plain scalar call here + (the old fall-through) handed the callee no sret buffer and mis-typed + the return, so for an sret record the first ARG register doubled as the + sret pointer — the callee received a garbage argument and wrote the + record over caller memory. Route through EmitRecordReturnCallSite with + a throwaway destination so the correct ABI is used, then release the + throwaway's managed fields. } + RetTypeRec := TRecordTypeDesc(ACall.ResolvedReturnTypeDesc); + SretTemp := AllocTemp(); + if ACall.ResolvedReturnTypeDesc.Kind = tyStaticArray then + EmitLine(Format(' %s =l alloc8 %d', + [SretTemp, ACall.ResolvedReturnTypeDesc.RawSize()])) + else if RetTypeRec.MaxAlign() >= 8 then + EmitLine(Format(' %s =l alloc8 %d', [SretTemp, RetTypeRec.TotalSize()])) + else + EmitLine(Format(' %s =l alloc4 %d', [SretTemp, RetTypeRec.TotalSize()])); + EmitLine(Format(' call $memset(l %s, w 0, l %d)', + [SretTemp, ACall.ResolvedReturnTypeDesc.RawSize()])); + EmitRecordReturnCallSite(FPtrTemp, ArgLine, RetTypeRec, SretTemp); + if ACall.ResolvedReturnTypeDesc.Kind = tyRecord then + EmitRecordReleaseFields(RetTypeRec, SretTemp); + end else EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine])); FlushPendingReleases(PMark); diff --git a/compiler/src/test/pascal/cp.test.e2e.interfaces.pas b/compiler/src/test/pascal/cp.test.e2e.interfaces.pas index 8422505..b090e28 100644 --- a/compiler/src/test/pascal/cp.test.e2e.interfaces.pas +++ b/compiler/src/test/pascal/cp.test.e2e.interfaces.pas @@ -49,6 +49,14 @@ type procedure TestRun_InheritedInterface_DescendantToVar; procedure TestRun_InheritedInterface_OverrideAndInheritedMethod; procedure TestRun_InheritedInterface_NonVirtualMethod; + { An itab-dispatched method returning a RECORD. Two ABI shapes: + a memory-class record (has a managed field -> sret) and a register-class + record (all-scalar, returned in registers). Both must work when the + result is ASSIGNED and when DISCARDED in statement position — the + discarded statement and the assignment used to mis-handle the + record-return ABI and corrupt memory (bug #5). } + procedure TestRun_InterfaceMethod_ReturnsSretRecord; + procedure TestRun_InterfaceMethod_ReturnsRegisterRecord; end; implementation @@ -406,6 +414,77 @@ begin AssertRunsOnAll(Src, 'hello' + LE + 'hello' + LE, 0); end; +procedure TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsSretRecord; +const + { TRect has a managed (string) field, so ClassifyRecordReturn => sret. } + Src = ''' + program P; + type + TRect = record Name: string; N: Integer; end; + IShape = interface + function MakeRect(AN: Integer): TRect; + end; + TShape = class(IShape) + function MakeRect(AN: Integer): TRect; + end; + function TShape.MakeRect(AN: Integer): TRect; + begin + Result.Name := 'r'; + Result.N := AN; + WriteLn('callee ', AN) + end; + var + M: IShape; + R: TRect; + begin + M := TShape.Create(); + R := M.MakeRect(5); { assigned sret record return } + WriteLn('assigned ', R.N); + M.MakeRect(7) { discarded sret record return } + end. + '''; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertRunsOnAll(Src, + 'callee 5' + LE + 'assigned 5' + LE + 'callee 7' + LE, 0); +end; + +procedure TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsRegisterRecord; +const + { TPt is all-scalar, so ClassifyRecordReturn => a register-class return + (no sret buffer); the itab dispatch must capture the register result. } + Src = ''' + program P; + type + TPt = record X, Y: Integer; end; + IShape = interface + function MakePt(AN: Integer): TPt; + end; + TShape = class(IShape) + function MakePt(AN: Integer): TPt; + end; + function TShape.MakePt(AN: Integer): TPt; + begin + Result.X := AN; + Result.Y := AN * 2; + WriteLn('callee ', AN) + end; + var + M: IShape; + R: TPt; + begin + M := TShape.Create(); + R := M.MakePt(5); { assigned register-class record return } + WriteLn('assigned ', R.X, ' ', R.Y); + M.MakePt(9) { discarded register-class record return } + end. + '''; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertRunsOnAll(Src, + 'callee 5' + LE + 'assigned 5 10' + LE + 'callee 9' + LE, 0); +end; + initialization RegisterTest(TE2EInterfaceTests);