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

fix(codegen): store @Obj.Method into a class field on the native backend

Browse source 
Assigning a method pointer (procedure/function of object) captured with
@Obj.Method into a class field -- B.FEvt := @S.Handle -- raised
"@Obj.Method must be used in assignment context" on the native x86-64
backend.  The simple-variable destination was already handled, but a
field destination fell through to evaluating @Obj.Method as a general
expression, which has no standalone lowering.

The field-assignment path now special-cases a method-pointer field whose
right-hand side is @Obj.Method: it computes the field's containing-object
base per receiver shape (as the interface-field store already does), then
stores the code pointer at offset 0 and the captured object pointer at
offset 8 of the field's 16-byte slot.

This also makes the of-object arm of procedural-field call dispatch
reachable on the native backend (a field must be populated before it can
be called).  Covered end-to-end on both backends: capture @Obj.Method
into a field, then dispatch through it.
This commit is contained in:
Andrew Haines 2026-06-24 15:34:03 -04:00 committed by Graeme Geldenhuys
parent 5a4bc7f7d1
commit aa33103659
2 changed files with 114 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -11987,6 +11987,82 @@ begin
FA.FieldInfo.TypeDesc);
Exit;
end;
{ Method-pointer (of object) field assignment from @Obj.Method: store the
[CodePtr, ObjPtr] pair into the field's 16-byte slot. Mirrors the
simple-variable case in EmitAssignment; the only difference is that the
destination is a field, so its containing-object base is computed per
receiver shape (exactly as the interface-field store above does). }
if (FA.FieldInfo.TypeDesc.Kind = tyProcedural) and
TProceduralTypeDesc(FA.FieldInfo.TypeDesc).IsMethodPtr and
(FA.Expr is TAddrOfExpr) and
(TAddrOfExpr(FA.Expr).Expr is TFieldAccessExpr) and
(TFieldAccessExpr(TAddrOfExpr(FA.Expr).Expr).ResolvedType <> nil) and
(TFieldAccessExpr(TAddrOfExpr(FA.Expr).Expr).ResolvedType.Kind = tyProcedural) and
TProceduralTypeDesc(TFieldAccessExpr(TAddrOfExpr(FA.Expr).Expr).ResolvedType).IsMethodPtr then
begin
FAE := TFieldAccessExpr(TAddrOfExpr(FA.Expr).Expr);
MD := TMethodDecl(FAE.ResolvedMethod);
{ Destination field's containing-object base → %rcx, per receiver shape. }
if FA.ObjExpr <> nil then
begin
Self.EmitExprToEax(FA.ObjExpr);
Self.Emit(#9'movq %rax, %rcx');
end
else if FSretFunc and (FA.RecordName = 'Result') then
Self.Emit(Format(#9'movq %s, %%rcx', [Self.VarOperand('Result')]))
else if FA.IsImplicitSelf then
begin
Self.Emit(Format(#9'movq %s, %%rcx', [Self.VarOperand('Self')]));
if (FA.ImplicitBaseInfo <> nil) and (FA.ImplicitBaseInfo.Offset > 0) then
Self.Emit(Format(#9'addq $%d, %%rcx', [FA.ImplicitBaseInfo.Offset]));
if FA.IsClassAccess then
Self.Emit(#9'movq (%rcx), %rcx');
end
else if FA.IsClassAccess then
begin
if Self.IsLocal(FA.RecordName) then
Self.Emit(Format(#9'movq %s, %%rcx', [Self.VarOperand(FA.RecordName)]))
else
Self.Emit(Format(#9'movq %s(%%rip), %%rcx', [FA.RecordName]));
if FA.IsVarParam then
{ var-param class: slot -> caller var -> instance }
Self.Emit(#9'movq (%rcx), %rcx');
end
else if FA.IsVarParam then
begin
if Self.IsLocal(FA.RecordName) then
Self.Emit(Format(#9'movq %s, %%rcx', [Self.VarOperand(FA.RecordName)]))
else
Self.Emit(Format(#9'movq %s(%%rip), %%rcx', [FA.RecordName]));
end
else if Self.IsLocal(FA.RecordName) then
Self.EmitLocalRecordBase(FA.RecordName, '%rcx')
else
Self.Emit(Format(#9'leaq %s(%%rip), %%rcx', [FA.RecordName]));
if FA.FieldInfo.Offset > 0 then
Self.Emit(Format(#9'addq $%d, %%rcx', [FA.FieldInfo.Offset]));
{ Store the code pointer at offset 0. }
Self.Emit(Format(#9'leaq %s(%%rip), %%rax',
[MethodEmitNameNative(MD, MD.OwnerTypeName, FAE.FieldName)]));
Self.Emit(#9'movq %rax, (%rcx)');
{ Store the captured object pointer at offset 8. }
if FAE.Base <> nil then
begin
Self.Emit(#9'pushq %rcx');
Self.EmitExprToEax(FAE.Base);
Self.Emit(#9'popq %rcx');
Self.Emit(#9'movq %rax, 8(%rcx)');
end
else
begin
if Self.IsLocal(FAE.RecordName) then
Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand(FAE.RecordName)]))
else
Self.Emit(Format(#9'movq %s(%%rip), %%rax', [FAE.RecordName]));
Self.Emit(#9'movq %rax, 8(%rcx)');
end;
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. }

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

@ -47,6 +47,9 @@ type
procedure TestRun_ProcFieldCall_Statement;
procedure TestRun_ProcFieldCall_OutParam;
procedure TestRun_ProcFieldCall_MultiArg;
{ Method-pointer (of object) field: assign @Obj.Method into a field, then
dispatch through it — exercises the 16-byte (Code, Data) field store. }
procedure TestRun_MethodPtrField_AssignAndCall;
{ Default parameters }
procedure TestRun_DefaultParam_OmitLast;
@ -426,6 +429,35 @@ const
end.
''';
{ Method-pointer (of object) class field: capture @Obj.Method into a field
and call through it. The capture stores a 16-byte (Code, Data) pair. }
SrcMethodPtrField = '''
program Prg;
type
TEvt = procedure(const S: string) of object;
TSrc = class
Tag: string;
procedure Handle(const S: string);
end;
TBox = class
FEvt: TEvt;
procedure Fire(const S: string);
end;
procedure TSrc.Handle(const S: string);
begin WriteLn(Self.Tag, ':', S) end;
procedure TBox.Fire(const S: string);
begin Self.FEvt(S) end;
var B: TBox; S: TSrc;
begin
S := TSrc.Create(); S.Tag := 'T';
B := TBox.Create();
B.FEvt := @S.Handle;
B.Fire('hello');
B.Free();
S.Free()
end.
''';
SrcDefaultParam = '''
program Prg;
function Add(A: Integer; B: Integer = 10): Integer;
@ -767,6 +799,12 @@ begin
AssertRunsOnAll(SrcProcFieldMultiArg, '33' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrField_AssignAndCall;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrField, 'T:hello' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_DefaultParam_OmitLast;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;