This is a regression present on all active branches: the compiler may generate
elaboration code that wrongly raises a Constraint_Error for a multidimensional
array whose component type is controlled if the unit is compiled at -O3.
Tested on x86_64-suse-linux, applied on all active branches.
2019-01-27 Eric Botcazou <ebotca...@adacore.com>
* gcc-interface/decl.c (array_type_has_nonaliased_component): Return
the same value for every dimension of a multidimensional array type.
2019-01-27 Eric Botcazou <ebotca...@adacore.com>
* gnat.dg/opt75.adb: New test.
* gnat.dg/opt75_pkg.ad[sb]: New helper.
--
Eric Botcazou
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 268309)
+++ gcc-interface/decl.c (working copy)
@@ -6237,12 +6237,6 @@ same_discriminant_p (Entity_Id discr1, E
static bool
array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
{
- /* If the array type is not the innermost dimension of the GNAT type,
- then it has a non-aliased component. */
- if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
- return true;
-
/* If the array type has an aliased component in the front-end sense,
then it also has an aliased component in the back-end sense. */
if (Has_Aliased_Components (gnat_type))
@@ -6253,15 +6247,17 @@ array_type_has_nonaliased_component (tre
if (Is_Derived_Type (gnat_type))
{
tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
- int index;
if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
gnu_parent_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
- for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
- gnu_parent_type = TREE_TYPE (gnu_parent_type);
return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
}
+ /* For a multi-dimensional array type, find the component type. */
+ while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
+ gnu_type = TREE_TYPE (gnu_type);
+
/* Consider that an array of pointers has an aliased component, which is
sort of logical and helps with Taft Amendment types in LTO mode. */
if (POINTER_TYPE_P (TREE_TYPE (gnu_type)))
-- { dg-do run }
-- { dg-options "-O3" }
with Opt75_Pkg; use Opt75_Pkg;
procedure Opt75 is
begin
null;
end;
pragma Restrictions (No_Abort_Statements);
pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
with Ada.Finalization;
with System.Atomic_Counters;
package Opt75_Pkg is
type Rec is record
Counter : System.Atomic_Counters.Atomic_Counter;
end record;
type Rec_Ptr is access all Rec;
Empty_Rec : aliased Rec;
type T is new Ada.Finalization.Controlled with record
Ref : Rec_Ptr := Empty_Rec'Access;
end record;
overriding procedure Adjust (Object : in out T);
Empty : constant T := (Ada.Finalization.Controlled with Ref => Empty_Rec'Access);
type Arr is array (Integer range 1 .. 8, Integer range 1 .. 4) of T;
end Opt75_Pkg;
package body Opt75_Pkg is
overriding procedure Adjust (Object : in out T) is
begin
if Object.Ref /= Empty_Rec'Access then
System.Atomic_Counters.Increment (Object.Ref.Counter);
end if;
end;
A : constant Arr := (others => (others => Empty));
end Opt75_Pkg;