[gcc r12-1179] Fix miscompilation of predicate on bit-packed array types

[gcc r12-1179] Fix miscompilation of predicate on bit-packed array types

[Eric Botcazou]

https://gcc.gnu.org/g:1eff5289b273041c9d71a4829c2600d283186ab6

commit r12-1179-g1eff5289b273041c9d71a4829c2600d283186ab6
Author: Eric Botcazou <ebotcazou@adacore.com>
Date:   Thu Jun 3 13:29:32 2021 +0200

    Fix miscompilation of predicate on bit-packed array types
    
    This is a regression present on the mainline and 11 branch in the form of a
    miscompilation by the new mod/ref IPA pass of code that passes constrained
    bit-packed array objets in a call to a subprograms taking unconstrained
    bit-packed array parameters, which occurs for predicate on bit-packed array
    types for example.
    
    gcc/ada/
            * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: Add PAT
            local constant and use it throughout.  If it is set, use a ref-all
            pointer type for the pointer-to-array field of the fat pointer type.
            <E_Array_Subtype>: Add PAT local constant and use it throughout.
    gcc/testsuite/
            * gnat.dg/bit_packed_array6.adb: New test.
            * gnat.dg/bit_packed_array6_pkg.ads: New helper.

Diff:
---
 gcc/ada/gcc-interface/decl.c                    | 37 +++++++++++++++----------
 gcc/testsuite/gnat.dg/bit_packed_array6.adb     | 10 +++++++
 gcc/testsuite/gnat.dg/bit_packed_array6_pkg.ads | 13 +++++++++
 3 files changed, 45 insertions(+), 15 deletions(-)

diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index bc7046accb5..6fc94dda83b 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -2100,6 +2100,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 
     case E_Array_Type:
       {
+	const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity);
 	const bool convention_fortran_p
 	  = (Convention (gnat_entity) == Convention_Fortran);
 	const int ndim = Number_Dimensions (gnat_entity);
@@ -2203,16 +2204,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 	  }
 
 	/* If the GNAT encodings are used, give the fat pointer type a name.
-	   If this is a packed array, tell the debugger how to interpret the
-	   underlying bits by fetching that of the implementation type.  But
-	   in any case, mark it as artificial so the debugger can skip it.  */
+	   If this is a packed type implemented specially, tell the debugger
+	   how to interpret the underlying bits by fetching the name of the
+	   implementation type.  But, in any case, mark it as artificial so
+	   the debugger can skip it.  */
 	const Entity_Id gnat_name
-	  = (Present (Packed_Array_Impl_Type (gnat_entity))
-	     && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
-	    ? Packed_Array_Impl_Type (gnat_entity)
+	  = Present (PAT) && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL
+	    ? PAT
 	    : gnat_entity;
 	tree xup_name
-	  = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+	  = gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL
 	    ? create_concat_name (gnat_name, "XUP")
 	    : gnu_entity_name;
 	create_type_decl (xup_name, gnu_fat_type, true, debug_info_p,
@@ -2347,9 +2348,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 
 	/* If this is a packed type implemented specially, then process the
 	   implementation type so it is elaborated in the proper scope.  */
-	if (Present (Packed_Array_Impl_Type (gnat_entity)))
-	  gnat_to_gnu_entity (Packed_Array_Impl_Type (gnat_entity), NULL_TREE,
-			      false);
+	if (Present (PAT))
+	  gnat_to_gnu_entity (PAT, NULL_TREE, false);
 
 	/* Otherwise, if an alignment is specified, use it if valid and, if
 	   the alignment was requested with an explicit clause, state so.  */
@@ -2374,8 +2374,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 	  tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE);
 
 	/* Adjust the type of the pointer-to-array field of the fat pointer
-	   and record the aliasing relationships if necessary.  */
-	TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
+	   and record the aliasing relationships if necessary.  If this is
+	   a packed type implemented specially, then use a ref-all pointer
+	   type since the implementation type may vary between constrained
+	   subtypes and unconstrained base type.  */
+	if (Present (PAT))
+	  TREE_TYPE (TYPE_FIELDS (gnu_fat_type))
+	    = build_pointer_type_for_mode (tem, ptr_mode, true);
+	else
+	  TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
 	if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
 	  record_component_aliases (gnu_fat_type);
 
@@ -2439,6 +2446,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 	;
       else
 	{
+	  const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity);
 	  Entity_Id gnat_index, gnat_base_index;
 	  const bool convention_fortran_p
 	    = (Convention (gnat_entity) == Convention_Fortran);
@@ -2844,7 +2852,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 
 	  /* If this is a packed type implemented specially, then replace our
 	     type with the implementation type.  */
-	  if (Present (Packed_Array_Impl_Type (gnat_entity)))
+	  if (Present (PAT))
 	    {
 	      /* First finish the type we had been making so that we output
 		 debugging information for it.  */
@@ -2869,8 +2877,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 		 this type again.  */
 	      save_gnu_tree (gnat_entity, gnu_tmp_decl, false);
 
-	      gnu_type
-		= gnat_to_gnu_type (Packed_Array_Impl_Type (gnat_entity));
+	      gnu_type = gnat_to_gnu_type (PAT);
 	      save_gnu_tree (gnat_entity, NULL_TREE, false);
 
 	      /* Set the ___XP suffix for GNAT encodings.  */
diff --git a/gcc/testsuite/gnat.dg/bit_packed_array6.adb b/gcc/testsuite/gnat.dg/bit_packed_array6.adb
new file mode 100644
index 00000000000..84f7a4ba4a1
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/bit_packed_array6.adb
@@ -0,0 +1,10 @@
+-- { dg-do run }
+-- { dg-options "-O2 -gnata -gnatVa" }
+
+with Bit_Packed_Array6_Pkg; use Bit_Packed_Array6_Pkg;
+
+procedure Bit_Packed_Array6 is
+  B : constant Boolean := Everywhere (K_Configuration);
+begin
+  null;
+end;
diff --git a/gcc/testsuite/gnat.dg/bit_packed_array6_pkg.ads b/gcc/testsuite/gnat.dg/bit_packed_array6_pkg.ads
new file mode 100644
index 00000000000..4eb1516a472
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/bit_packed_array6_pkg.ads
@@ -0,0 +1,13 @@
+package Bit_Packed_Array6_Pkg is
+
+   type Project_Kind is
+     (K_Configuration, K_Abstract,
+      K_Standard, K_Library, K_Aggregate, K_Aggregate_Library);
+
+   type Projects_Kind is array (Project_Kind) of Boolean
+     with Pack,
+          Dynamic_Predicate => Projects_Kind /= (Project_Kind => False);
+
+   Everywhere : constant Projects_Kind := (others => True);
+
+end Bit_Packed_Array6_Pkg;