From 92e09e517f45bf0fe2c16d7d884f47c9989989c6 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 18 Jun 2026 07:50:43 +0100 Subject: [PATCH] feat(native): TObject.InheritsFrom and default ToString builtins MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- .../pascal/blaise.codegen.native.x86_64.pas | 59 +++++++++++++++++++ .../src/test/pascal/cp.test.e2e.classes2.pas | 36 +++-------- 2 files changed, 66 insertions(+), 29 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 a4a795e..052e052 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.e2e.classes2.pas b/compiler/src/test/pascal/cp.test.e2e.classes2.pas index 3827282..ff82009 100644 --- a/compiler/src/test/pascal/cp.test.e2e.classes2.pas +++ b/compiler/src/test/pascal/cp.test.e2e.classes2.pas @@ -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;