Originally the expansion of attribute Validate_Scalars was only using
Validated_View, but it was generating unnecessary unchecked conversions
between array types that prevented validity checks from being optimized
at compilation time.
To prevent those conversions some of the calls to Validated_View were
replaced with calls to Get_Fullest_View, which behaves as an identity
function for non-packed arrays (and unchecked conversions between the
views of a type are trivially eliminated).
This patch restores uses of Validated_View, makes it behave as an
identity function on arrays and explains this behaviour in a comment.
A similar issue occurs for scalar (sub)types, which must be validated
without switching to their base types that would lack range constraints.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_attr.adb (Build_Array_VS_Func): Restore uses of
Validated_View.
(Build_Record_VS_Func): Likewise.
(Expand_N_Attribute_Reference): Likewise.
* sem_util.adb (Validated_View): Behave as an identity function
for arrays and scalars.diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -248,7 +248,7 @@ package body Exp_Attr is
is
Loc : constant Source_Ptr := Sloc (Attr);
Comp_Typ : constant Entity_Id :=
- Get_Fullest_View (Component_Type (Array_Typ));
+ Validated_View (Component_Type (Array_Typ));
function Validate_Component
(Obj_Id : Entity_Id;
@@ -535,7 +535,7 @@ package body Exp_Attr is
is
Field_Id : constant Entity_Id := Defining_Entity (Field);
Field_Nam : constant Name_Id := Chars (Field_Id);
- Field_Typ : constant Entity_Id := Get_Fullest_View (Etype (Field_Id));
+ Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
Attr_Nam : Name_Id;
begin
@@ -7396,7 +7396,7 @@ package body Exp_Attr is
-------------------
when Attribute_Valid_Scalars => Valid_Scalars : declare
- Val_Typ : constant Entity_Id := Get_Fullest_View (Ptyp);
+ Val_Typ : constant Entity_Id := Validated_View (Ptyp);
Expr : Node_Id;
begin
@@ -7460,7 +7460,7 @@ package body Exp_Attr is
(Build_Record_VS_Func
(Attr => N,
Formal_Typ => Ptyp,
- Rec_Typ => Validated_View (Ptyp)),
+ Rec_Typ => Val_Typ),
Loc),
Parameter_Associations => New_List (Pref));
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -29473,34 +29473,53 @@ package body Sem_Util is
function Validated_View (Typ : Entity_Id) return Entity_Id is
begin
+ -- Scalar types can be always validated. In fast, switiching to the base
+ -- type would drop the range constraints and force validation to use a
+ -- larger type than necessary.
+
+ if Is_Scalar_Type (Typ) then
+ return Typ;
+
+ -- Array types can be validated even when they are derived, because
+ -- validation only requires their bounds and component types to be
+ -- accessible. In fact, switching to the parent type would pollute
+ -- expansion of attribute Valid_Scalars with unnecessary conversion
+ -- that might not be eliminated by the frontend.
+
+ elsif Is_Array_Type (Typ) then
+ return Typ;
+
+ -- For other types, in particular for record subtypes, we switch to the
+ -- base type.
+
+ elsif not Is_Base_Type (Typ) then
+ return Validated_View (Base_Type (Typ));
+
-- Obtain the full view of the input type by stripping away concurrency,
-- derivations, and privacy.
- if Is_Base_Type (Typ) then
- if Is_Concurrent_Type (Typ) then
- if Present (Corresponding_Record_Type (Typ)) then
- return Corresponding_Record_Type (Typ);
- else
- return Typ;
- end if;
+ elsif Is_Concurrent_Type (Typ) then
+ if Present (Corresponding_Record_Type (Typ)) then
+ return Corresponding_Record_Type (Typ);
+ else
+ return Typ;
+ end if;
- elsif Is_Derived_Type (Typ) then
- return Validated_View (Etype (Typ));
+ elsif Is_Derived_Type (Typ) then
+ return Validated_View (Etype (Typ));
- elsif Is_Private_Type (Typ) then
- if Present (Underlying_Full_View (Typ)) then
- return Validated_View (Underlying_Full_View (Typ));
+ elsif Is_Private_Type (Typ) then
+ if Present (Underlying_Full_View (Typ)) then
+ return Validated_View (Underlying_Full_View (Typ));
- elsif Present (Full_View (Typ)) then
- return Validated_View (Full_View (Typ));
- else
- return Typ;
- end if;
+ elsif Present (Full_View (Typ)) then
+ return Validated_View (Full_View (Typ));
+ else
+ return Typ;
end if;
- return Typ;
else
- return Validated_View (Base_Type (Typ));
+ return Typ;
end if;
end Validated_View;
