From 6d46af93dee5f53f1dae7637190eb2fe3f3a0e6a Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Mon, 22 Jun 2026 18:05:32 +0100 Subject: [PATCH] =?UTF-8?q?fix(codegen):=20native=20HasClassAttribute=20?= =?UTF-8?q?=E2=80=94=20emit=20the=20call=20and=20the=20attribute=20RTTI?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit HasClassAttribute(AClass, AAttrClass) was unreliable on the native backend: - The call was never emitted. The builtin had no native lowering, so it fell through to a generic path that left the first metaclass's typeinfo address in %rax and read its low byte as the Boolean result — a layout-dependent false positive (a plain class reported as having an attribute). - Even with the call, the attribute table was missing: native typeinfo hardcoded slot 7 (attrs) to nil, so a [Threaded]-marked class reported False. Fixes (blaise.codegen.native.x86_64.pas): - Add a native lowering for the HasClassAttribute builtin (gated on FC.IsBuiltinHasClassAttr): evaluate both metaclass args to typeinfo pointers in %rdi/%rsi, call _HasClassAttribute, normalise %al to 0/1. Mirrors the QBE backend. - Emit the class attribute RTTI table (count + one typeinfo pointer per attribute) as attrs_ and reference it from typeinfo slot 7, nil when the class has no attributes. Mirrors the QBE backend's attrs_. This is what blaise.testing's runner uses to decide [Threaded] subprocess dispatch; the false positive forked non-threaded suites and crashed them. e2e test in cp.test.e2e.gaps (AssertRTLRunsOnAll, both backends): a plain TTestCase reports False, a [Threaded] one reports True. Full suite OK (3739); all four fixpoints pass on both build paths. --- .../pascal/blaise.codegen.native.x86_64.pas | 39 ++++++++++++++++++- compiler/src/test/pascal/cp.test.e2e.gaps.pas | 26 +++++++++++++ .../src/main/pascal/blaise.testing.pas | 0 .../pascal/blaise.testing.runner.text.pas | 0 4 files changed, 64 insertions(+), 1 deletion(-) rename {compiler => stdlib}/src/main/pascal/blaise.testing.pas (100%) rename {compiler => stdlib}/src/main/pascal/blaise.testing.runner.text.pas (100%) 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 46348d8..fc70347 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -1925,6 +1925,7 @@ var ParentStr: string; ImplStr: string; MethStr: string; + AttrsStr: string; PubCount: Integer; Line: string; EmitSys: Boolean; @@ -2060,6 +2061,24 @@ begin else MethStr := '0'; + { Class attribute RTTI table at typeinfo slot 7: a count word followed by + one typeinfo pointer per attribute. Referenced by _HasClassAttribute. + Emitted before the typeinfo so the symbol is defined when slot 7 + references it; nil when the class carries no attributes. Mirrors the + QBE backend's attrs_. } + if RT.ClassAttributeCount() > 0 then + begin + Self.Emit('.balign 8'); + Self.Emit('attrs_' + CSym + ':'); + Self.Emit(Format(#9'.quad %d', [RT.ClassAttributeCount()])); + for J := 0 to RT.ClassAttributeCount() - 1 do + Self.Emit(#9'.quad typeinfo_' + + Self.ClassSymName(RT.ClassAttributeAt(J))); + AttrsStr := 'attrs_' + CSym; + end + else + AttrsStr := '0'; + Self.Emit('.balign 8'); Self.Emit('.globl typeinfo_' + CSym); Self.Emit('typeinfo_' + CSym + ':'); @@ -2070,7 +2089,7 @@ begin Self.Emit(Format(#9'.quad %d', [RT.TotalSize()])); Self.Emit(#9'.quad _FieldCleanup_' + CSym); Self.Emit(#9'.quad vtable_' + CSym); - Self.Emit(#9'.quad 0'); { attrs } + Self.Emit(#9'.quad ' + AttrsStr); { attrs } end; { Typeinfo blocks for generic class instances. } @@ -5332,6 +5351,24 @@ begin { Result = method code pointer in %rax. } Exit; end; + { HasClassAttribute(AClass, AAttrClass): Boolean — query attribute RTTI. + Both args are metaclass expressions that lower to typeinfo pointers. + Pass them in %rdi/%rsi and call the runtime helper (result in %al). + Without this the native backend never emitted the call — the result + was the low byte of the first metaclass's typeinfo address, a layout- + dependent false positive. } + if FC.IsBuiltinHasClassAttr and (FC.Args.Count = 2) then + begin + Self.EmitExprToEax(TASTExpr(FC.Args.Items[0])); { ti_class -> %rax } + Self.Emit(#9'pushq %rax'); + Self.EmitExprToEax(TASTExpr(FC.Args.Items[1])); { ti_attr -> %rax } + Self.Emit(#9'movq %rax, %rsi'); + Self.Emit(#9'popq %rdi'); + Self.Emit(#9'callq _HasClassAttribute'); + { Result Boolean in %al; normalise to a clean 0/1 in %rax. } + Self.Emit(#9'movzbq %al, %rax'); + Exit; + end; { SizeOf(expr) → integer literal = byte size of the resolved type. } if SameText(FC.Name, 'SizeOf') and (FC.Args.Count = 1) then begin diff --git a/compiler/src/test/pascal/cp.test.e2e.gaps.pas b/compiler/src/test/pascal/cp.test.e2e.gaps.pas index ede5a19..948bc6b 100644 --- a/compiler/src/test/pascal/cp.test.e2e.gaps.pas +++ b/compiler/src/test/pascal/cp.test.e2e.gaps.pas @@ -58,6 +58,12 @@ type { Published RTTI + MethodAddress } procedure TestRun_PublishedRTTI_MethodAddress; + { HasClassAttribute attribute RTTI query: a plain class reports False, a + [Threaded]-marked class reports True. Regression: the native backend + emitted no call (result = low byte of the metaclass address, a false + positive) and emitted no attribute table in typeinfo. } + procedure TestRun_HasClassAttribute_PlainAndMarked; + { Named-type alias array const (GitHub #113) } procedure TestRun_NamedArrayAlias_IntConst; @@ -646,6 +652,26 @@ begin AssertRunsOnAll(Src, 'found' + Chr(10), 0); end; +procedure TE2EGapTests.TestRun_HasClassAttribute_PlainAndMarked; +const Src = ''' + program T; + uses blaise.testing; + type + TPlain = class(TTestCase) published procedure M; end; + [Threaded] + TMarked = class(TTestCase) published procedure M; end; + procedure TPlain.M; begin end; + procedure TMarked.M; begin end; + begin + WriteLn(HasClassAttribute(TPlain, ThreadedAttribute)); + WriteLn(HasClassAttribute(TMarked, ThreadedAttribute)) + end. + '''; +begin + { Uses blaise.testing (stdlib), so the RTL+stdlib search-path helper. } + AssertRTLRunsOnAll(Src, 'False' + Chr(10) + 'True' + Chr(10), 0); +end; + { ---- Multi-arg WriteLn ---- } procedure TE2EGapTests.TestRun_StaticArrayReturn_12Bytes; diff --git a/compiler/src/main/pascal/blaise.testing.pas b/stdlib/src/main/pascal/blaise.testing.pas similarity index 100% rename from compiler/src/main/pascal/blaise.testing.pas rename to stdlib/src/main/pascal/blaise.testing.pas diff --git a/compiler/src/main/pascal/blaise.testing.runner.text.pas b/stdlib/src/main/pascal/blaise.testing.runner.text.pas similarity index 100% rename from compiler/src/main/pascal/blaise.testing.runner.text.pas rename to stdlib/src/main/pascal/blaise.testing.runner.text.pas