This extends the exception made for attribute references in the code
generating range checks to the simple expressions containing a single
attribute reference, thus avoiding to create a temporary whose type is
Universal_Integer when the attribute returns Universal_Integer, which is
the common case. This also prevents Remove_Side_Effects from creating a
similar temporary for an attribute reference whose prefix is not a name.
The reason is that Universal_Integer must be a type as large as the
largest supported integer type and, therefore, can be much larger than
what is really needed here.
No functional changes.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-03 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* checks.adb (Is_Single_Attribute_Reference): New predicate.
(Generate_Range_Check): Do not force the evaluation if the
node is a single attribute reference.
* exp_util.adb (Side_Effect_Free_Attribute): New predicate.
(Side_Effect_Free) <N_Attribute_Reference>: Call it.
(Remove_Side_Effects): Remove the side effects of the prefix
for an attribute reference whose prefix is not a name.--- gcc/ada/checks.adb
+++ gcc/ada/checks.adb
@@ -6875,6 +6875,10 @@ package body Checks is
-- given Suppress argument. Then check the converted value against the
-- range of the target subtype.
+ function Is_Single_Attribute_Reference (N : Node_Id) return Boolean;
+ -- Return True if N is an expression that contains a single attribute
+ -- reference, possibly as operand among only integer literal operands.
+
-----------------------------
-- Convert_And_Check_Range --
-----------------------------
@@ -6934,6 +6938,31 @@ package body Checks is
Set_Etype (N, Target_Base_Type);
end Convert_And_Check_Range;
+ -------------------------------------
+ -- Is_Single_Attribute_Reference --
+ -------------------------------------
+
+ function Is_Single_Attribute_Reference (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Attribute_Reference then
+ return True;
+
+ elsif Nkind (N) in N_Binary_Op then
+ if Nkind (Right_Opnd (N)) = N_Integer_Literal then
+ return Is_Single_Attribute_Reference (Left_Opnd (N));
+
+ elsif Nkind (Left_Opnd (N)) = N_Integer_Literal then
+ return Is_Single_Attribute_Reference (Right_Opnd (N));
+
+ else
+ return False;
+ end if;
+
+ else
+ return False;
+ end if;
+ end Is_Single_Attribute_Reference;
+
-- Start of processing for Generate_Range_Check
begin
@@ -6982,9 +7011,10 @@ package body Checks is
-- We skip the evaluation of attribute references because, after these
-- runtime checks are generated, the expander may need to rewrite this
-- node (for example, see Attribute_Max_Size_In_Storage_Elements in
- -- Expand_N_Attribute_Reference).
+ -- Expand_N_Attribute_Reference) and, in many cases, their return type
+ -- is universal integer, which is a very large type for a temporary.
- if Nkind (N) /= N_Attribute_Reference
+ if not Is_Single_Attribute_Reference (N)
and then (not Is_Entity_Name (N)
or else Treat_As_Volatile (Entity (N)))
then
--- gcc/ada/exp_util.adb
+++ gcc/ada/exp_util.adb
@@ -224,6 +224,10 @@ package body Exp_Util is
-- level, and False otherwise. Nested_Constructs is True when any nested
-- packages declared in L must be processed, and False otherwise.
+ function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean;
+ -- Return True if the evaluation of the given attribute is considered
+ -- side-effect free, independently of its prefix and expressions.
+
-------------------------------------
-- Activate_Atomic_Synchronization --
-------------------------------------
@@ -11306,6 +11310,21 @@ package body Exp_Util is
Scope_Suppress.Suppress := (others => True);
+ -- If this is a side-effect free attribute reference whose expressions
+ -- are also side-effect free and whose prefix is not a name, remove the
+ -- side effects of the prefix. A copy of the prefix is required in this
+ -- case and it is better not to make an additional one for the attribute
+ -- itself, because the return type of many of them is universal integer,
+ -- which is a very large type for a temporary.
+
+ if Nkind (Exp) = N_Attribute_Reference
+ and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
+ and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
+ and then not Is_Name_Reference (Prefix (Exp))
+ then
+ Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
+ goto Leave;
+
-- If this is an elementary or a small not-by-reference record type, and
-- we need to capture the value, just make a constant; this is cheap and
-- objects of both kinds of types can be bit aligned, so it might not be
@@ -11316,12 +11335,12 @@ package body Exp_Util is
-- anyway, see below). Also do it if we have a volatile reference and
-- Name_Req is not set (see comments for Side_Effect_Free).
- if (Is_Elementary_Type (Exp_Type)
- or else (Is_Record_Type (Exp_Type)
- and then Known_Static_RM_Size (Exp_Type)
- and then RM_Size (Exp_Type) <= 64
- and then not Has_Discriminants (Exp_Type)
- and then not Is_By_Reference_Type (Exp_Type)))
+ elsif (Is_Elementary_Type (Exp_Type)
+ or else (Is_Record_Type (Exp_Type)
+ and then Known_Static_RM_Size (Exp_Type)
+ and then RM_Size (Exp_Type) <= 64
+ and then not Has_Discriminants (Exp_Type)
+ and then not Is_By_Reference_Type (Exp_Type)))
and then (Variable_Ref
or else (not Is_Name_Reference (Exp)
and then Nkind (Exp) /= N_Type_Conversion)
@@ -13173,58 +13192,18 @@ package body Exp_Util is
case Nkind (N) is
- -- An attribute reference is side effect free if its expressions
- -- are side effect free and its prefix is side effect free or
- -- is an entity reference.
-
- -- Is this right? what about x'first where x is a variable???
+ -- An attribute reference is side-effect free if its expressions
+ -- are side-effect free and its prefix is side-effect free or is
+ -- an entity reference.
when N_Attribute_Reference =>
- Attribute_Reference : declare
-
- function Side_Effect_Free_Attribute
- (Attribute_Name : Name_Id) return Boolean;
- -- Returns True if evaluation of the given attribute is
- -- considered side-effect free (independent of prefix and
- -- arguments).
-
- --------------------------------
- -- Side_Effect_Free_Attribute --
- --------------------------------
-
- function Side_Effect_Free_Attribute
- (Attribute_Name : Name_Id) return Boolean
- is
- begin
- case Attribute_Name is
- when Name_Input =>
- return False;
-
- when Name_Image
- | Name_Img
- | Name_Wide_Image
- | Name_Wide_Wide_Image
- =>
- -- CodePeer doesn't want to see replicated copies of
- -- 'Image calls.
-
- return not CodePeer_Mode;
-
- when others =>
- return True;
- end case;
- end Side_Effect_Free_Attribute;
-
- -- Start of processing for Attribute_Reference
-
- begin
- return
- Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
- and then Side_Effect_Free_Attribute (Attribute_Name (N))
- and then (Is_Entity_Name (Prefix (N))
- or else Side_Effect_Free
- (Prefix (N), Name_Req, Variable_Ref));
- end Attribute_Reference;
+ return Side_Effect_Free_Attribute (Attribute_Name (N))
+ and then
+ Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
+ and then
+ (Is_Entity_Name (Prefix (N))
+ or else
+ Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref));
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
@@ -13383,6 +13362,30 @@ package body Exp_Util is
end if;
end Side_Effect_Free;
+ --------------------------------
+ -- Side_Effect_Free_Attribute --
+ --------------------------------
+
+ function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean is
+ begin
+ case Name is
+ when Name_Input =>
+ return False;
+
+ when Name_Image
+ | Name_Img
+ | Name_Wide_Image
+ | Name_Wide_Wide_Image
+ =>
+ -- CodePeer doesn't want to see replicated copies of 'Image calls
+
+ return not CodePeer_Mode;
+
+ when others =>
+ return True;
+ end case;
+ end Side_Effect_Free_Attribute;
+
----------------------------------
-- Silly_Boolean_Array_Not_Test --
----------------------------------
