Re: [PATCH 2/2 v2] Ada: Finalization of constrained subtypes of unconstrained synchronized private extensions

Re: [PATCH 2/2 v2] Ada: Finalization of constrained subtypes of unconstrained synchronized private extensions

[Gary Dismukes]

Hi Richard,

I hope you're doing well.

I'm just following up on the patch (second version) that you sent us
recently for the problem you ran into with the generation of the
address finalization routine for synchronized private extensions.

Thanks very much for finding this fix and submitting your patch.
Your patch looks good, and we'll look into applying that to the
compiler, though no guarantees about when it will be added.  

Best regards,
  Gary Dismukes

Re: [PATCH 2/2 v2] Ada: Finalization of constrained subtypes of unconstrained synchronized private extensions

[Gary Dismukes]

Richard,

As a follow-on to my earlier message, additional testing has uncovered an issue
with your patch.  When run against a compiler built with assertions enabled,
the test of "Present (Corresponding_Record_Type (Parent_Utyp))" can fail.
An additional guard is needed prior to that test, as follows:

            if Ekind (Parent_Utyp) in Concurrent_Kind
              and then Present (Corresponding_Record_Type (Parent_Utyp))
            then
               Parent_Utyp := Corresponding_Record_Type (Parent_Utyp);
            end if;

-- Gary

Re: [PATCH 2/2 v3] Ada: Finalization of constrained subtypes of unconstrained synchronized private extensions

[Arnaud Charlet]

> Thanks for finding that! I have made the recommended change and attached the revised patch, which is also rebased on trunk.
> 
> Additionally, I have added the “Signed-off-by” tag for legal compliance to the patch, as well as the change log entry as follows:

Thank you, patch is therefore now OK.

Re: [PATCH 2/2 v3] Ada: Finalization of constrained subtypes of unconstrained synchronized private extensions

[Richard Wai]

Thanks for that!

Richard

> On Sep 18, 2023, at 09:43, Arnaud Charlet <charlet@adacore.com> wrote:
> 
>> Thanks for finding that! I have made the recommended change and attached the revised patch, which is also rebased on trunk.
>> 
>> Additionally, I have added the “Signed-off-by” tag for legal compliance to the patch, as well as the change log entry as follows:
> 
> Thank you, patch is therefore now OK.

[COMMITTED] ada: TSS finalize address subprogram generation for constrained...

[Marc Poulhiès]

From: Richard Wai <richard@annexi-strayline.com>

...subtypes of unconstrained synchronized private extensions should take
care to designate the corresponding record of the underlying concurrent
type.

When generating TSS finalize address subprograms for class-wide types of
constrained root types, it follows the parent chain looking for the
first "non-constrained" type. It is possible that such a type is a
private extension with the “synchronized” keyword, in which case the
underlying type is a concurrent type. When that happens, the designated
type of the finalize address subprogram should be the corresponding
record’s class-wide-type.

gcc/ada/ChangeLog:
	* exp_ch3.adb (Expand_Freeze_Class_Wide_Type): Expanded comments
	explaining why TSS Finalize_Address is not generated for
	concurrent class-wide types.
	* exp_ch7.adb (Make_Finalize_Address_Stmts): Handle cases where the
	underlying non-constrained parent type is a concurrent type, and
	adjust the designated type to be the corresponding record’s
	class-wide type.

gcc/testsuite/ChangeLog:

	* gnat.dg/sync_tag_finalize.adb: New test.

Signed-off-by: Richard Wai <richard@annexi-strayline.com>
---
 gcc/ada/exp_ch3.adb                         |  4 ++
 gcc/ada/exp_ch7.adb                         | 28 +++++++++-
 gcc/testsuite/gnat.dg/sync_tag_finalize.adb | 60 +++++++++++++++++++++
 3 files changed, 90 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..4ea5e6ede64 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,30 @@ 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 Ekind (Parent_Utyp) in Concurrent_Kind
+              and then 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..6dffd4a102c
--- /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.0

[PATCH 1/2] Ada: Synchronized private extensions are always limited

[Richard Wai]

[-- Attachment #1.1: Type: text/plain, Size: 3732 bytes --]

GNAT currently considers a synchronized private extension that derives from
an interface to be limited only when said interface is a concurrent
interface. However it is of course legal for a synchronized private
extension to derive from a limited interface. In this case GNAT fails to
correctly determine that the private extension is limited.

 

This causes two separate problems that makes discriminated types in such a
case impossible:

1.	GNAT inappropriately rejects compilation, claiming default
discriminants on such a private extension are illegal.
2.	GNAT fails to generate the expected discriminals for the
unconstrained discriminanted case, leading to the corresponding
discriminants of the "corresponding record" of the underlying concurrent
type to have no identifiers, and thus compilation fails.

 

Fairly simple fix. If "synchronized" appears in the private extension
declaration, it is limited. This is explicit in the RM as well (7.3(6/2)).

 

Fixing this bug uncovered of a related bug wrt. TSS address finalizer
generation for constrained subtypes of synchronized private extensions with
no default discriminants. That patch is to follow separately.

 

Patch file is attached.

 

--  Begin change log entry --

 

ada: Private extensions with the keyword "synchronized" are always limited.

 

GNAT was relying on synchronized private type extensions deriving from a
concurrent interface to determine its limitedness. This does not cover the
case where such an extension derives a limited interface. RM-7.6(6/2) makes
is clear that "synchronized" in a private extension implies the derived type
is limited. GNAT should explicitly check for the presence of "synchronized"
in a private extension declaration, and it should have the same effect as
the presence of "limited".

 

gcc/ada/

                * sem_ch3.adb (Build_Derived_Record_Type): Treat presence of
keyword "synchronized" the same as "limited" when determining if a private
extension is limited.

 

-- End change log entry --

 

This patch was bootstrapped on x86_64-*-freebsd13.2. Two new test cases were
added. Note that 4 gnat test cases fail currently on master and are
unrelated to this patch.

 

Check-ada output of this patch:

                                === acats tests ===

Running chapter a ...

Running chapter c2 ...

Running chapter c3 ...

Running chapter c4 ...

Running chapter c5 ...

Running chapter c6 ...

Running chapter c7 ...

Running chapter c8 ...

Running chapter c9 ...

Running chapter ca ...

Running chapter cb ...

Running chapter cc ...

Running chapter cd ...

Running chapter ce ...

Running chapter cxa ...

Running chapter cxb ...

Running chapter cxf ...

Running chapter cxg ...

Running chapter cxh ...

Running chapter cz ...

Running chapter d ...

Running chapter e ...

Running chapter l ...

                                === acats Summary ===

# of expected passes                       2328

# of unexpected failures 0

 

Native configuration is x86_64-unknown-freebsd13.2

 

                                === gnat tests ===

 

Schedule of variations:

    unix

 

Running target unix

FAIL: gnat.dg/specs/alignment2.ads  (test for warnings, line 14)

FAIL: gnat.dg/specs/alignment2.ads  (test for warnings, line 20)

FAIL: gnat.dg/specs/alignment2.ads  (test for warnings, line 38)

FAIL: gnat.dg/specs/alignment2.ads  (test for warnings, line 42)

 

                                === gnat Summary ===

 

# of expected passes                       3402

# of unexpected failures                4

# of expected failures                      23

# of unsupported tests                   10

gnatmake version 14.0.0 20230809 (experimental)

 

 

Richard Wai

ANNEXI-STRAYLINE


[-- Attachment #2: ada-synchronized-private-types-are-limited.patch --]
[-- Type: application/octet-stream, Size: 5895 bytes --]

From f87d0da43296b87cd242380a4077a167e5ea1291 Mon Sep 17 00:00:00 2001
From: Richard Wai <richard@annexi-strayline.com>
Date: Wed, 9 Aug 2023 01:54:48 -0400
Subject: [PATCH 1/2] ada: Consider that any synchronized private extension is
 always a limited type, even if it inherits from a non-concurrent interface.
 Add two regression tests for two separate problems that arose

---
 gcc/ada/sem_ch3.adb                           | 12 +++--
 .../gnat.dg/sync_tag_discriminals.adb         | 51 +++++++++++++++++++
 gcc/testsuite/gnat.dg/sync_tag_limited.adb    | 50 ++++++++++++++++++
 3 files changed, 110 insertions(+), 3 deletions(-)
 create mode 100644 gcc/testsuite/gnat.dg/sync_tag_discriminals.adb
 create mode 100644 gcc/testsuite/gnat.dg/sync_tag_limited.adb

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 042ace01724..48731a7bf04 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9494,9 +9494,15 @@ package body Sem_Ch3 is
 
       --  AI-419: Limitedness is not inherited from an interface parent, so to
       --  be limited in that case the type must be explicitly declared as
-      --  limited. However, task and protected interfaces are always limited.
-
-      if Limited_Present (Type_Def) then
+      --  limited, or synchronized. While task and protected interfaces are
+      --  always limited, a synchronized private extension might not inherit
+      --  from such interfaces, and so we also need to recognize the
+      --  explicit limitedness implied by a synchronized private extension
+      --  the does not derive from a synchronized interface (see RM-7.3(6/2)).
+
+      if Limited_Present (Type_Def)
+        or else Synchronized_Present (Type_Def)
+      then
          Set_Is_Limited_Record (Derived_Type);
 
       elsif Is_Limited_Record (Parent_Type)
diff --git a/gcc/testsuite/gnat.dg/sync_tag_discriminals.adb b/gcc/testsuite/gnat.dg/sync_tag_discriminals.adb
new file mode 100644
index 00000000000..b105acf6e98
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/sync_tag_discriminals.adb
@@ -0,0 +1,51 @@
+-- This test is related to sync_tag_limited in that previous versions of GNAT
+-- failed to consider a synchronized private extension as limited if it was
+-- not derrived from a synchronized interface (i.e. a limited interface). Since
+-- such a private type would not be considered limited, GNAT would fail to
+-- correctly build the expected discriminals later needed by the creation of
+-- the concurrent type's "corresponding record type", leading to a compilation
+-- error where the discriminants of the corresponding record type had no
+-- identifiers.
+--
+-- This test is in addition to sync_tag_limited because the sync_tag_limited
+-- would fail for "legality" reasons (default discriminants not allowed for
+-- a non-limited taged type). It is also an opportunity to ensure that non-
+-- defaulted discriminated synchronized private extensions work as expected.
+
+--  { dg-do compile }
+
+procedure Sync_Tag_Discriminals is
+   
+   package Ifaces is
+      
+      type Test_Interface is limited 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;
+   
+begin
+   null;
+end Sync_Tag_Discriminals;
diff --git a/gcc/testsuite/gnat.dg/sync_tag_limited.adb b/gcc/testsuite/gnat.dg/sync_tag_limited.adb
new file mode 100644
index 00000000000..608f10662a3
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/sync_tag_limited.adb
@@ -0,0 +1,50 @@
+--  Synchronized tagged types created by a private extension with the keyword
+--  'synchronized' shall be seen as an (immutably) limited tagged type, and
+--  should therefore accept default disciminant spectifications.
+--  This was a bug in earlier versions of GNAT, whereby GNAT erroneously
+--  relied on a parent synchronized interface to determine limitedness
+--  of a synchronized private extension. The problem being that a synchronized
+--  private extension can derive a non-synchronized interface (specifically a
+--  limited interface), Yet the RM makes it clear (7.3(6/2)) that such
+--  synchronized private extensions are always limited.
+--
+--  Ergo: Default discriminants are of course legal on any synchronized private
+--  extension.
+
+--  { dg-do compile }
+
+procedure Sync_Tag_Limited is
+   
+   package Ifaces is
+      
+      type Test_Interface is limited interface;
+      
+      procedure Interface_Action (Test: in out Test_Interface) is abstract;
+      
+   end Ifaces;
+   
+   
+   package Implementation is
+      type Test_Implementation
+        (Constraint: Positive := 1) is
+        synchronized new Ifaces.Test_Interface with private;
+      
+   private
+      protected type Test_Implementation
+        (Constraint: Positive := 1)
+      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;
+   
+begin
+   null;
+end Sync_Tag_Limited;
-- 
2.40.1

[PATCH 2/2 v2] Ada: Finalization of constrained subtypes of unconstrained synchronized private extensions

[Richard Wai]

[-- Attachment #1.1: Type: text/plain, Size: 4442 bytes --]

Somehow an error worked its way into the original diff (the diff itself),
making the previous patch fail to apply.

 

Fixed version attached.

 

Richard Wai

ANNEXI-STRAYLINE

 

From: Richard Wai <richard@annexi-strayline.com> 
Sent: Thursday, August 10, 2023 1:27 AM
To: 'gcc-patches@gcc.gnu.org' <gcc-patches@gcc.gnu.org>
Cc: 'Eric Botcazou' <ebotcazou@adacore.com>; 'Arnaud Charlet'
<charlet@adacore.com>; 'Stephen Baird' <baird@adacore.com>
Subject: [PATCH 2/2] Ada: Finalization of constrained subtypes of
unconstrained synchronized private extensions

 

When generating TSS address finalization bodies for a tagged class-wide
subtype, GNAT climbs the parent chain looking for the first
"non-constrained" type. That type's underlying type's class-wide type is
used as a "designated" type for a dispatching TSS deep finalize call to the
designated class-wide type. In the case of a constrained subtype of an
unconstrained synchronized private extension, this ends up designating the
underlying type of that private extension. This means it targets the
class-wide type of the actual underlying concurrent type rather than the
corresponding record. Ultimately it ends up generating a call to the
corresponding record's deep finalizer, but with incompatible types
(concurrent_type'Class -> concurrent_typeV'Class). This causes compilation
to fail.

 

This patch adds extra logic to exp_ch7(Make_Finalize_Address_Stmts) to
identify such cases and ensure that the designated type is the corresponding
record type's class-wide type in that situation.

 

Patch file is attached.

 

--  Begin change log entry -

 

ada: TSS finalize address subprogram generation for constrained subtypes of
unconstrained synchronized private extensions should take care to designate
the corresponding record of the underlying concurrent type.

 

When generating TSS finalize address subprograms for class-wide types of
constrained root types, it follows the parent chain looking for the first
"non-constrained" type. It is possible that such a type is a private
extension with the "synchronized" keyword, in which case the underlying type
is a concurrent type. When that happens, the designated type of the finalize
address subprogram should be the corresponding record's class-wide-type.

 

Gcc/ada/

                * exp_ch3(Expand_Freeze_Class_Wide_Type): Expanded comments
explaining why TSS Finalize_Address is not generated for concurrent
class-wide types.

                * exp_ch7(Make_Finalize_Address_Stmts): Handle cases where
the underlying non-constrained parent type is a concurrent type, and adjust
the designated type to be the corresponding record's class-wide type.

 

--  End change log entry -

 

This patch was bootstrapped on x86_64-*-freebsd13.2. One new test cases was
added. Note that 4 gnat test cases fail currently on master and are
unrelated to this patch.

 

Check-ada output of this patch:

 

                                === acats tests ===

Running chapter a ...

Running chapter c2 ...

Running chapter c3 ...

Running chapter c4 ...

Running chapter c5 ...

Running chapter c6 ...

Running chapter c7 ...

Running chapter c8 ...

Running chapter c9 ...

Running chapter ca ...

Running chapter cb ...

Running chapter cc ...

Running chapter cd ...

Running chapter ce ...

Running chapter cxa ...

Running chapter cxb ...

Running chapter cxf ...

Running chapter cxg ...

Running chapter cxh ...

Running chapter cz ...

Running chapter d ...

Running chapter e ...

Running chapter l ...

                                === acats Summary ===

# of expected passes                       2328

# of unexpected failures                 0

 

Native configuration is x86_64-unknown-freebsd13.2

 

                                === gnat tests ===

 

Schedule of variations:

    unix

 

Running target unix

FAIL: gnat.dg/specs/alignment2.ads  (test for warnings, line 14)

FAIL: gnat.dg/specs/alignment2.ads  (test for warnings, line 20)

FAIL: gnat.dg/specs/alignment2.ads  (test for warnings, line 38)

FAIL: gnat.dg/specs/alignment2.ads  (test for warnings, line 42)

 

                                === gnat Summary ===

 

# of expected passes                       3401

# of unexpected failures                 4

# of expected failures                      23

# of unsupported tests                   10

gnatmake version 14.0.0 20230809 (experimental)

 

 

Richard Wai

ANNEXI-STRAYLINE


[-- Attachment #2: ada-tss-constrained-subtype-of-private-synchronized-extention-v2.patch --]
[-- Type: application/octet-stream, Size: 6289 bytes --]

From 73582f931e77e506b64b311486b8804a03b8a87f Mon Sep 17 00:00:00 2001
From: Richard Wai <richard@annexi-strayline.com>
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