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 0cca0ac..fd542c2 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -2107,6 +2107,18 @@ begin begin TD := TTypeDecl(ATypeDecls.Items[I]); if not (TD.Def is TClassTypeDef) then Continue; + { Re-assert the viewing context before EVERY FindType. Resolving a prior + class in this loop (its parent/field/method types via ClassSymName -> + Lookup -> the uses-chain walk) can leave FSymTable.DefineOwningUnit + pointing at a dependency unit. If it has drifted, FindType for one of THIS + unit's own implementation-section (IsImplPrivate) classes is suppressed by + Lookup's cross-unit-leak guard and returns nil — so the class is skipped + and its typeinfo / vtable / _FieldCleanup are NEVER emitted, leaving a + dangling reference the linker binds to garbage (an out-of-range metaclass + crash, e.g. via RegisterTest). Pin DOU to the unit being emitted so an + owned impl-private class always resolves. } + if (ASymTable <> nil) and (FCurrentUnitName <> '') then + ASymTable.DefineOwningUnit := FCurrentUnitName; TDesc := ASymTable.FindType(TD.Name); if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue; RT := TRecordTypeDesc(TDesc); @@ -11126,11 +11138,8 @@ begin Self.Emit(Format(#9'leaq %s, %%rcx', [Self.VarOperand(Asgn.Name)])) else Self.Emit(Format(#9'leaq %s(%%rip), %%rcx', [Asgn.Name])); - { Store 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 object pointer at offset 8 } + { Store object pointer at offset 8 first — a virtual method reads its + code pointer from THIS instance's vtable. } if FAE.Base <> nil then begin Self.Emit(#9'pushq %rcx'); @@ -11143,6 +11152,21 @@ begin Self.EmitVarBaseToReg(FAE.RecordName, False, '%rax'); Self.Emit(#9'movq %rax, 8(%rcx)'); end; + { Store code pointer at offset 0. A virtual/override method must be + resolved through the instance's vtable so @Obj.M captures the dynamic + type's override — matching a direct Obj.M() call — instead of freezing + the static address. Slot 0 of the vtable is typeinfo, so method N is + at offset (N+1)*8 (mirrors the dispatch in the call path). } + if MD.VTableSlot >= 0 then + begin + Self.Emit(#9'movq 8(%rcx), %rax'); { obj = data slot } + Self.Emit(#9'movq (%rax), %rax'); { vptr = obj[0] } + Self.Emit(Format(#9'movq %d(%%rax), %%rax', [(MD.VTableSlot + 1) * 8])); + end + else + Self.Emit(Format(#9'leaq %s(%%rip), %%rax', + [MethodEmitNameNative(MD, MD.OwnerTypeName, FAE.FieldName)])); + Self.Emit(#9'movq %rax, (%rcx)'); Exit; end; { Method-pointer (of-object) assignment from a TMethod/TAddProc cast: @@ -12476,11 +12500,8 @@ begin else Self.EmitVarBaseToReg(FA.RecordName, True, '%rcx'); 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. } + { Store the captured object pointer at offset 8 first — a virtual method + reads its code pointer from THIS instance's vtable. } if FAE.Base <> nil then begin Self.Emit(#9'pushq %rcx'); @@ -12493,6 +12514,21 @@ begin Self.EmitVarBaseToReg(FAE.RecordName, False, '%rax'); Self.Emit(#9'movq %rax, 8(%rcx)'); end; + { Store the code pointer at offset 0. A virtual/override method must be + resolved through the instance's vtable so @Obj.M captures the dynamic + type's override — matching a direct Obj.M() call — instead of freezing + the static address. Slot 0 of the vtable is typeinfo, so method N is + at offset (N+1)*8. } + if MD.VTableSlot >= 0 then + begin + Self.Emit(#9'movq 8(%rcx), %rax'); { obj = data slot } + Self.Emit(#9'movq (%rax), %rax'); { vptr = obj[0] } + Self.Emit(Format(#9'movq %d(%%rax), %%rax', [(MD.VTableSlot + 1) * 8])); + end + else + Self.Emit(Format(#9'leaq %s(%%rip), %%rax', + [MethodEmitNameNative(MD, MD.OwnerTypeName, FAE.FieldName)])); + Self.Emit(#9'movq %rax, (%rcx)'); Exit; end; { Field := MethodCall() where the method returns a record via sret. diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index 819849a..75ead5b 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -15062,6 +15062,9 @@ var Adj: string; Offset: string; ElemPtr: string; + VTblTemp: string; + SlotPtr: string; + FPtrTemp: string; begin if AExpr.Expr is TStringSubscriptExpr then begin @@ -15230,7 +15233,8 @@ begin { @Obj.MethodName — method-pointer construction. The semantic pass set IsMethodPtr on the TFieldAccessExpr's ResolvedType when it detected this pattern. Allocate a 16-byte block [code_ptr, data_ptr] on the stack, - store the static method address and the object pointer, return the block. } + store the code pointer (vtable-resolved for a virtual/override method, + the static label otherwise) and the object pointer, return the block. } if (AExpr.Expr is TFieldAccessExpr) and (TFieldAccessExpr(AExpr.Expr).ResolvedType <> nil) and (TFieldAccessExpr(AExpr.Expr).ResolvedType.Kind = tyProcedural) and @@ -15242,10 +15246,8 @@ begin EmitLine(Format(' %s =l alloc8 16', [MBlock])); DataSlot := AllocTemp(); EmitLine(Format(' %s =l add %s, 8', [DataSlot, MBlock])); - { Store code pointer at offset 0 } - EmitLine(Format(' storel $%s, %s', - [MethodEmitName(MD, MD.OwnerTypeName, FldExpr.FieldName), MBlock])); - { Load and store the object pointer at offset 8. + { Compute the object (data) pointer first — a virtual method reads its + code pointer from THIS instance's vtable. Simple form: @VarName.Method — FldExpr.Base is nil; load via RecordName. Chained form: @Expr.Method — FldExpr.Base is set; use EmitInstancePtr. } if FldExpr.Base <> nil then @@ -15255,6 +15257,26 @@ begin ObjPtr := AllocTemp(); EmitLine(Format(' %s =l loadl %s', [ObjPtr, VarRef(FldExpr.RecordName, FldExpr.IsGlobal)])); end; + { Store the code pointer at offset 0. A virtual/override method must be + resolved through the instance's vtable so @Obj.M captures the dynamic + type's override — matching a direct Obj.M() call — instead of freezing + the static address of the declared type. Slot 0 of the vtable is + typeinfo, so method N is at offset (N+1)*8 (mirrors EmitMethodCall). } + if MD.VTableSlot >= 0 then + begin + VTblTemp := AllocTemp(); + EmitLine(Format(' %s =l loadl %s', [VTblTemp, ObjPtr])); + SlotPtr := AllocTemp(); + EmitLine(Format(' %s =l add %s, %d', + [SlotPtr, VTblTemp, (MD.VTableSlot + 1) * 8])); + FPtrTemp := AllocTemp(); + EmitLine(Format(' %s =l loadl %s', [FPtrTemp, SlotPtr])); + EmitLine(Format(' storel %s, %s', [FPtrTemp, MBlock])); + end + else + EmitLine(Format(' storel $%s, %s', + [MethodEmitName(MD, MD.OwnerTypeName, FldExpr.FieldName), MBlock])); + { Store the object pointer at offset 8. } EmitLine(Format(' storel %s, %s', [ObjPtr, DataSlot])); Exit(MBlock); end; diff --git a/compiler/src/test/pascal/cp.test.e2e.misc.pas b/compiler/src/test/pascal/cp.test.e2e.misc.pas index 7098a11..417868c 100644 --- a/compiler/src/test/pascal/cp.test.e2e.misc.pas +++ b/compiler/src/test/pascal/cp.test.e2e.misc.pas @@ -50,6 +50,10 @@ type { 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; + { Capturing @Obj.VirtualMethod must bind the receiver's dynamic override, + not the statically-resolved declared-type method. } + procedure TestRun_MethodPtrVirtualCapture_Var; + procedure TestRun_MethodPtrVirtualCapture_Field; { Unqualified call to a procedural-typed field via implicit Self (FFn(...) with no 'Self.' prefix), as an expression and as a statement. } procedure TestRun_ImplicitSelfProcField_Expr; @@ -473,6 +477,63 @@ const end. '''; + { Method-pointer capture of a VIRTUAL method through a base-typed variable: + A is declared TAnimal but holds a TDog, so @A.Speak must capture TDog's + override (print 'dog'), resolving the Code half through A's vtable rather + than freezing the declared type's TAnimal.Speak. } + SrcMethodPtrVirtualCaptureVar = ''' + program Prg; + type + TSpeak = procedure of object; + TAnimal = class + procedure Speak; virtual; + end; + TDog = class(TAnimal) + procedure Speak; override; + end; + procedure TAnimal.Speak; + begin WriteLn('animal') end; + procedure TDog.Speak; + begin WriteLn('dog') end; + var A: TAnimal; M: TSpeak; + begin + A := TDog.Create(); + M := @A.Speak; + M(); + A.Free() + end. + '''; + + { Same dynamic-dispatch capture, but stored into a class FIELD rather than a + local variable — exercises the field-destination assignment path. } + SrcMethodPtrVirtualCaptureField = ''' + program Prg; + type + TSpeak = procedure of object; + TAnimal = class + procedure Speak; virtual; + end; + TDog = class(TAnimal) + procedure Speak; override; + end; + TBox = class + M: TSpeak; + end; + procedure TAnimal.Speak; + begin WriteLn('animal') end; + procedure TDog.Speak; + begin WriteLn('dog') end; + var A: TAnimal; B: TBox; + begin + A := TDog.Create(); + B := TBox.Create(); + B.M := @A.Speak; + B.M(); + B.Free(); + A.Free() + end. + '''; + { Unqualified (implicit-Self) call to a procedural-typed field, as an expression — FFn(...) with no 'Self.' prefix. } SrcImplicitProcFieldExpr = ''' @@ -866,6 +927,18 @@ begin AssertRunsOnAll(SrcMethodPtrField, 'T:hello' + LE, 0); end; +procedure TE2EMiscTests.TestRun_MethodPtrVirtualCapture_Var; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertRunsOnAll(SrcMethodPtrVirtualCaptureVar, 'dog' + LE, 0); +end; + +procedure TE2EMiscTests.TestRun_MethodPtrVirtualCapture_Field; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertRunsOnAll(SrcMethodPtrVirtualCaptureField, 'dog' + LE, 0); +end; + procedure TE2EMiscTests.TestRun_ImplicitSelfProcField_Expr; begin if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; diff --git a/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas b/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas index 1de1edc..e4559b2 100644 --- a/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas +++ b/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas @@ -55,6 +55,7 @@ type procedure TestCodegen_MethodPtrField_RecordTotalSizeIncludes16; procedure TestCodegen_MethodPtrField_DirectCall_LoadsCodeAndData; + procedure TestCodegen_MethodPtrVirtualCapture_LoadsFromVTable; { End-to-end } procedure TestE2E_MethodPtr_NoArgs; @@ -688,6 +689,43 @@ begin StrPos('$THolder_Handler', IR) >= 0); end; +procedure TProcTypesOfObjectTests.TestCodegen_MethodPtrVirtualCapture_LoadsFromVTable; +const + Src = + ''' + program P; + type + TSpeak = procedure of object; + TAnimal = class(TObject) + procedure Speak; virtual; + end; + TDog = class(TAnimal) + procedure Speak; override; + end; + procedure TAnimal.Speak; + begin WriteLn('animal') end; + procedure TDog.Speak; + begin WriteLn('dog') end; + var A: TAnimal; M: TSpeak; + begin + A := TDog.Create(); + M := @A.Speak; + M(); + A.Free() + end. + '''; +var IR: string; +begin + IR := GenIR(Src); + { Capturing @A.Speak where Speak is virtual must read the Code half from + the receiver's vtable, not freeze the statically-resolved declared-type + address. The buggy codegen stored the static label '$TAnimal_Speak' + into the (Code, Data) block; the fix loads the slot through the instance + vptr, so that static store must be absent. } + AssertFalse('virtual capture must not store the static method address', + StrPos('storel $TAnimal_Speak', IR) >= 0); +end; + procedure TProcTypesOfObjectTests.TestE2E_MethodPtrField_DirectCall_StmtForm; const Src =