>From 73582f931e77e506b64b311486b8804a03b8a87f Mon Sep 17 00:00:00 2001 From: Richard Wai Date: Wed, 9 Aug 2023 01:45:54 -0400 Subject: [PATCH 2/2] ada: fix designated type selection for the creation of finalize address bodies in the case of a constrained subtype of a unconstrained synchronized private extension. --- gcc/ada/exp_ch3.adb | 4 ++ gcc/ada/exp_ch7.adb | 26 ++++++++- gcc/testsuite/gnat.dg/sync_tag_finalize.adb | 60 +++++++++++++++++++++ 3 files changed, 88 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/sync_tag_finalize.adb diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 04c3ad8c631..bb015986200 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5000,6 +5000,10 @@ package body Exp_Ch3 is -- Do not create TSS routine Finalize_Address for concurrent class-wide -- types. Ignore C, C++, CIL and Java types since it is assumed that the -- non-Ada side will handle their destruction. + -- + -- Concurrent Ada types are functionally represented by an associated + -- "corresponding record type" (typenameV), which owns the actual TSS + -- finalize bodies for the type (and technically class-wide type). elsif Is_Concurrent_Type (Root) or else Is_C_Derivation (Root) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index aa16c707887..5b4381697c5 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -8512,7 +8512,8 @@ package body Exp_Ch7 is Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ))) then declare - Parent_Typ : Entity_Id; + Parent_Typ : Entity_Id; + Parent_Utyp : Entity_Id; begin -- Climb the parent type chain looking for a non-constrained type @@ -8533,7 +8534,28 @@ package body Exp_Ch7 is Parent_Typ := Underlying_Record_View (Parent_Typ); end if; - Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); + Parent_Utyp := Underlying_Type (Parent_Typ); + + -- Handle views created for a synchronized private extension with + -- known, non-defaulted discriminants. In that case, parent_typ + -- will be the private extension, as it is the first "non + -- -constrained" type in the parent chain. Unfortunately, the + -- underlying type, being a protected or task type, is not the + -- "real" type needing finalization. Rather, the "corresponding + -- record type" should be the designated type here. In fact, TSS + -- finalizer generation is specifically skipped for the nominal + -- class-wide type of (the full view of) a concurrent type (see + -- exp_ch7.Expand_Freeze_Class_Wide_Type). If we don't designate + -- the underlying record (Tprot_typeVC), we will end up trying to + -- dispatch to prot_typeVDF from an incorrectly designated + -- Tprot_typeC, which is, of course, not actually a member of + -- prot_typeV'Class, and thus incompatible. + + if Present (Corresponding_Record_Type (Parent_Utyp)) then + Parent_Utyp := Corresponding_Record_Type (Parent_Utyp); + end if; + + Desig_Typ := Class_Wide_Type (Parent_Utyp); end; -- General case diff --git a/gcc/testsuite/gnat.dg/sync_tag_finalize.adb b/gcc/testsuite/gnat.dg/sync_tag_finalize.adb new file mode 100644 index 00000000000..1e9df0edbaa --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync_tag_finalize.adb @@ -0,0 +1,60 @@ +-- In previous versions of GNAT there was a curious bug that caused +-- compilation to fail in the case of a synchronized private extension +-- with non-default discriminants, where the creation of a constrained object +-- (and thus subtype) caused the TSS deep finalize machinery of the internal +-- class-wide constratined subtype (TConstrainedC) to construct a malformed +-- TSS finalize address body. The issue was that the machinery climbs +-- the type parent chain looking for a "non-constrained" type to use as a +-- designated (class-wide) type for a dispatching call to a higher TSS DF +-- subprogram. When there is a discriminated synchronized private extension +-- with known, non-default discriminants (thus unconstrained/indefinite), +-- that search ends up at that private extension declaration. Since the +-- underlying type is actually a concurrent type, class-wide TSS finalizers +-- are not built for the type, but rather the corresponding record type. The +-- TSS machinery that selects the designated type was prevsiously unaware of +-- this caveat, and thus selected an incompatible designated type, leading to +-- failed compilation. +-- +-- TL;DR: When creating a constrained subtype of a synchronized private +-- extension with known non-defaulted disciminants, the class-wide TSS +-- address finalization body for the constrained subtype should dispatch to +-- the corresponding record (class-wide) type deep finalize subprogram. + +-- { dg-do compile } + +procedure Sync_Tag_Finalize is + + package Ifaces is + + type Test_Interface is synchronized interface; + + procedure Interface_Action (Test: in out Test_Interface) is abstract; + + end Ifaces; + + + package Implementation is + type Test_Implementation + (Constraint: Positive) is + synchronized new Ifaces.Test_Interface with private; + + private + protected type Test_Implementation + (Constraint: Positive) + is new Ifaces.Test_Interface with + + overriding procedure Interface_Action; + + end Test_Implementation; + end Implementation; + + package body Implementation is + protected body Test_Implementation is + procedure Interface_Action is null; + end; + end Implementation; + + Constrained: Implementation.Test_Implementation(2); +begin + null; +end; -- 2.40.1