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

feat(native): TObject.InheritsFrom and default ToString builtins

Browse source 
The native backend raised "TMethodCallExpr has no ResolvedMethod" for the two
TObject built-in methods that the semantic pass flags rather than resolving to a
declared method:

* InheritsFrom(C): load the receiver's typeinfo (vtable[0] for a class instance),
  evaluate the class-of argument to a typeinfo pointer, and call
  _InheritsFrom(self_ti, arg_ti) → Boolean.
* ToString: virtual dispatch through vtable slot 2 (offset 16: typeinfo, Destroy,
  ToString), returning the string in %rax — the default returns the class name.

A small EmitMethodReceiverToRax helper loads the instance pointer (expression,
named local/global, or implicit Self). The 7 InheritsFrom tests and the default
ToString test in cp.test.e2e.classes2 are converted to AssertRunsOnAll, pinning
both builtins on QBE and native.

All three fixpoints green; 3481 tests pass.
This commit is contained in:
Graeme Geldenhuys 2026-06-18 07:50:43 +01:00
parent 161d8e4102
commit 92e09e517f
2 changed files with 66 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -586,6 +586,8 @@ type
Most params = 1 slot; interface params = 2 slots (obj + itab); open-array
params = 2 slots (ptr + high). Used by pop loops so they count slots, not
logical argument positions. }
{ Load a class method call's receiver instance pointer into %rax. }
procedure EmitMethodReceiverToRax(ACall: TMethodCallExpr);
function CountArgSlots(AParams: TObjectList): Integer;
{ Bounds-checked System V integer-arg-register accessor (raises if > 5). }
function SysVArg64(AIndex: Integer): string;
@ -7552,6 +7554,39 @@ begin
Exit;
end;
{ Built-in TObject.InheritsFrom(C): _InheritsFrom(self_typeinfo, arg_typeinfo)
→ Boolean in %eax. A class-instance receiver carries its typeinfo at
vtable[0] = *( *obj ); the argument is a class-of value that EmitExprToEax
lowers to a typeinfo pointer (mirrors the QBE path). }
if ACall.IsBuiltinInheritsFrom then
begin
Self.EmitMethodReceiverToRax(ACall); { instance ptr -> %rax }
if (ACall.ResolvedClassType <> nil) and
(ACall.ResolvedClassType.Kind = tyClass) then
begin
Self.Emit(#9'movq (%rax), %rax'); { vtable }
Self.Emit(#9'movq (%rax), %rax'); { typeinfo = vtable[0] }
end;
Self.Emit(#9'pushq %rax'); { save self typeinfo }
Self.EmitExprToEax(TASTExpr(ACall.Args.Items[0])); { arg typeinfo -> %rax }
Self.Emit(#9'movq %rax, %rsi');
Self.Emit(#9'popq %rdi'); { self typeinfo }
Self.Emit(#9'callq _InheritsFrom');
Exit;
end;
{ Built-in TObject.ToString: virtual dispatch through vtable slot 2 (offset 16:
[0]=typeinfo, [8]=Destroy, [16]=ToString). Returns a string in %rax. }
if ACall.IsBuiltinToString then
begin
Self.EmitMethodReceiverToRax(ACall); { instance ptr -> %rax }
Self.Emit(#9'movq %rax, %rdi'); { Self }
Self.Emit(#9'movq (%rdi), %rax'); { vtable }
Self.Emit(#9'movq 16(%rax), %rax'); { vtable[2] = ToString }
Self.Emit(#9'callq *%rax');
Exit;
end;
MD := TMethodDecl(ACall.ResolvedMethod);
if MD = nil then
raise ENativeCodeGenError.Create(
@ -7958,6 +7993,30 @@ begin
Result := SysVArgRegs64[AIndex];
end;
{ Load the receiver object pointer of a class method call into %rax. Covers an
expression receiver, a named local/global instance, and implicit Self. Used by
the TObject builtins (InheritsFrom, ToString) which only need the instance
pointer, not the record/var-param address handling of the full call path. }
procedure TX86_64Backend.EmitMethodReceiverToRax(ACall: TMethodCallExpr);
begin
if ACall.ObjExpr <> nil then
Self.EmitExprToEax(ACall.ObjExpr)
else if ACall.ObjectName <> '' then
begin
if ACall.IsVarParam then
begin
Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand(ACall.ObjectName)]));
Self.Emit(#9'movq (%rax), %rax');
end
else if Self.IsLocal(ACall.ObjectName) then
Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand(ACall.ObjectName)]))
else
Self.Emit(Format(#9'movq %s(%%rip), %%rax', [ACall.ObjectName]));
end
else
Self.Emit(Format(#9'movq %s, %%rax', [Self.VarOperand('Self')]));
end;
function TX86_64Backend.CountArgSlots(AParams: TObjectList): Integer;
var
I: Integer;

36
compiler/src/test/pascal/cp.test.e2e.classes2.pas
View file

@ -1009,13 +1009,9 @@ begin
end;
procedure TE2EClasses2Tests.TestRun_ToString_DefaultReturnsClassName;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcToStringDefault, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('default ToString returns class name',
'TFoo' + LE + 'TBar' + LE, Output);
AssertRunsOnAll(SrcToStringDefault, 'TFoo' + LE + 'TBar' + LE, 0);
end;
procedure TE2EClasses2Tests.TestRun_ToString_OverrideDispatchedVirtually;
@ -1039,57 +1035,39 @@ begin
end;
procedure TE2EClasses2Tests.TestRun_InheritsFrom_SameClass_ReturnsTrue;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcInheritsFromBase, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('same class returns true', 'yes' + LE, Output);
AssertRunsOnAll(SrcInheritsFromBase, 'yes' + LE, 0);
end;
procedure TE2EClasses2Tests.TestRun_InheritsFrom_Parent_ReturnsTrue;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcInheritsFromParent, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('child inherits from parent', 'yes' + LE, Output);
AssertRunsOnAll(SrcInheritsFromParent, 'yes' + LE, 0);
end;
procedure TE2EClasses2Tests.TestRun_InheritsFrom_GrandParent_ReturnsTrue;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcInheritsFromGrandParent, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('grandchild inherits from base', 'yes' + LE, Output);
AssertRunsOnAll(SrcInheritsFromGrandParent, 'yes' + LE, 0);
end;
procedure TE2EClasses2Tests.TestRun_InheritsFrom_Unrelated_ReturnsFalse;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcInheritsFromUnrelated, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('unrelated class returns false', 'no' + LE, Output);
AssertRunsOnAll(SrcInheritsFromUnrelated, 'no' + LE, 0);
end;
procedure TE2EClasses2Tests.TestRun_InheritsFrom_Reverse_ReturnsFalse;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcInheritsFromReverse, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('parent does not inherit from child', 'no' + LE, Output);
AssertRunsOnAll(SrcInheritsFromReverse, 'no' + LE, 0);
end;
procedure TE2EClasses2Tests.TestRun_InheritsFrom_ClassType_Works;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcInheritsFromClassType, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('ClassType.InheritsFrom works', 'yes' + LE, Output);
AssertRunsOnAll(SrcInheritsFromClassType, 'yes' + LE, 0);
end;
procedure TE2EClasses2Tests.TestRun_Is_CorrectSubclass_True;