public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r11-6209] [Ada] Remove discriminant checks processing in gigi
@ 2020-12-17 10:51 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2020-12-17 10:51 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:84be0369c8d3a6c94f46906d901d2c5426fb9174
commit r11-6209-g84be0369c8d3a6c94f46906d901d2c5426fb9174
Author: Arnaud Charlet <charlet@adacore.com>
Date: Tue Nov 17 03:39:04 2020 -0500
[Ada] Remove discriminant checks processing in gigi
gcc/ada/
* sem_ch4.adb (Analyze_Selected_Component): Request a compile
time error replacement in Apply_Compile_Time_Constraint_Error
in case of an invalid field.
* sem_ch3.adb (Create_Constrained_Components): Take advantage of
Gather_Components also in the case of a record extension and
also constrain records in the case of compile time known discriminant
values, as already done in gigi.
* sem_util.ads, sem_util.adb (Gather_Components): New parameter
Allow_Compile_Time to allow compile time known (but non static)
discriminant values, needed by Create_Constrained_Components,
and new parameter Include_Interface_Tag.
(Is_Dependent_Component_Of_Mutable_Object): Use Original_Node to
perform check on the original tree.
(Is_Object_Reference): Likewise. Only call Original_Node when
relevant via a new function Safe_Prefix.
(Is_Static_Discriminant_Component, In_Check_Node): New.
(Is_Actual_Out_Or_In_Out_Parameter): New.
* exp_ch4.adb (Expand_N_Selected_Component): Remove no longer needed
code preventing evaluating statically discriminants in more cases.
* exp_ch5.adb (Expand_N_Loop_Statement): Simplify expansion of loops
with an N_Raise_xxx_Error node to avoid confusing the code generator.
(Make_Component_List_Assign): Try to find a constrained type to
extract discriminant values from, so that the case statement
built gets an opportunity to be folded by
Expand_N_Case_Statement.
(Expand_Assign_Record): Update comments, code cleanups.
* sem_attr.adb (Analyze_Attribute): Perform most of the analysis
on the original prefix node to deal properly with a prefix rewritten
as a N_Raise_xxx_Error.
* sem_ch5.adb (Analyze_Loop_Parameter_Specification): Handle properly
a discrete subtype definition being rewritten as N_Raise_xxx_Error.
* sem_ch8.adb (Analyze_Object_Renaming): Handle N_Raise_xxx_Error
nodes as part of the expression being renamed.
* sem_eval.ads, sem_eval.adb (Fold, Eval_Selected_Component): New.
(Compile_Time_Known_Value, Expr_Value, Expr_Rep_Value): Evaluate
static discriminant component values.
* sem_res.adb (Resolve_Selected_Component): Call
Eval_Selected_Component.
Diff:
---
gcc/ada/exp_ch4.adb | 12 +-----
gcc/ada/exp_ch5.adb | 59 +++++++++++++++++---------
gcc/ada/sem_attr.adb | 25 ++++++++---
gcc/ada/sem_ch3.adb | 69 ++++++++++++++++--------------
gcc/ada/sem_ch4.adb | 2 +-
gcc/ada/sem_ch5.adb | 5 ++-
gcc/ada/sem_ch8.adb | 32 +++++++++++++-
gcc/ada/sem_eval.adb | 69 ++++++++++++++++++++++++++++++
gcc/ada/sem_eval.ads | 5 +++
gcc/ada/sem_res.adb | 46 +++++++++++---------
gcc/ada/sem_util.adb | 118 ++++++++++++++++++++++++++++++++++++++++++---------
gcc/ada/sem_util.ads | 32 +++++++++++---
12 files changed, 353 insertions(+), 121 deletions(-)
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index e376648a4a5..04bd1fe0dba 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -11162,7 +11162,7 @@ package body Exp_Ch4 is
-- because the selected component may be a reference to the
-- object being initialized, whose discriminant is not yet
-- set. This only happens in complex cases involving changes
- -- or representation.
+ -- of representation.
if Disc = Entity (Selector_Name (N))
and then (Is_Entity_Name (Dval)
@@ -11174,15 +11174,7 @@ package body Exp_Ch4 is
-- constrained by an outer discriminant, which cannot
-- be optimized away.
- if Denotes_Discriminant
- (Dval, Check_Concurrent => True)
- then
- exit Discr_Loop;
-
- elsif Nkind (Original_Node (Dval)) = N_Selected_Component
- and then
- Denotes_Discriminant
- (Selector_Name (Original_Node (Dval)), True)
+ if Denotes_Discriminant (Dval, Check_Concurrent => True)
then
exit Discr_Loop;
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 307acaae61a..4cae2ee8d3f 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -1623,14 +1623,27 @@ package body Exp_Ch5 is
CI : constant List_Id := Component_Items (CL);
VP : constant Node_Id := Variant_Part (CL);
- Alts : List_Id;
- DC : Node_Id;
- DCH : List_Id;
- Expr : Node_Id;
- Result : List_Id;
- V : Node_Id;
+ Constrained_Typ : Entity_Id;
+ Alts : List_Id;
+ DC : Node_Id;
+ DCH : List_Id;
+ Expr : Node_Id;
+ Result : List_Id;
+ V : Node_Id;
begin
+ -- Try to find a constrained type to extract discriminant values
+ -- from, so that the case statement built below gets an
+ -- opportunity to be folded by Expand_N_Case_Statement.
+
+ if U_U or else Is_Constrained (Etype (Rhs)) then
+ Constrained_Typ := Etype (Rhs);
+ elsif Is_Constrained (Etype (Expression (N))) then
+ Constrained_Typ := Etype (Expression (N));
+ else
+ Constrained_Typ := Empty;
+ end if;
+
Result := Make_Field_Assigns (CI);
if Present (VP) then
@@ -1652,17 +1665,12 @@ package body Exp_Ch5 is
Next_Non_Pragma (V);
end loop;
- -- If we have an Unchecked_Union, use the value of the inferred
- -- discriminant of the variant part expression as the switch
- -- for the case statement. The case statement may later be
- -- folded.
-
- if U_U then
+ if Present (Constrained_Typ) then
Expr :=
New_Copy (Get_Discriminant_Value (
Entity (Name (VP)),
- Etype (Rhs),
- Discriminant_Constraint (Etype (Rhs))));
+ Constrained_Typ,
+ Discriminant_Constraint (Constrained_Typ)));
else
Expr :=
Make_Selected_Component (Loc,
@@ -1786,9 +1794,10 @@ package body Exp_Ch5 is
-- Start of processing for Expand_Assign_Record
begin
- -- Note that we use the base types for this processing. This results
- -- in some extra work in the constrained case, but the change of
- -- representation case is so unusual that it is not worth the effort.
+ -- Note that we need to use the base types for this processing in
+ -- order to retrieve the Type_Definition. In the constrained case,
+ -- we filter out the non relevant fields in
+ -- Make_Component_List_Assign.
-- First copy the discriminants. This is done unconditionally. It
-- is required in the unconstrained left side case, and also in the
@@ -1824,7 +1833,7 @@ package body Exp_Ch5 is
CF := F;
end if;
- if Is_Unchecked_Union (Base_Type (R_Typ)) then
+ if Is_Unchecked_Union (R_Typ) then
-- Within an initialization procedure this is the
-- assignment to an unchecked union component, in which
@@ -1916,8 +1925,8 @@ package body Exp_Ch5 is
Insert_Actions (N,
Make_Component_List_Assign (Component_List (RDef), True));
else
- Insert_Actions
- (N, Make_Component_List_Assign (Component_List (RDef)));
+ Insert_Actions (N,
+ Make_Component_List_Assign (Component_List (RDef)));
end if;
Rewrite (N, Make_Null_Statement (Loc));
@@ -4681,6 +4690,16 @@ package body Exp_Ch5 is
New_Id : Entity_Id;
begin
+ -- If Discrete_Subtype_Definition has been rewritten as an
+ -- N_Raise_xxx_Error, rewrite the whole loop as a raise node to
+ -- avoid confusing the code generator down the line.
+
+ if Nkind (Discrete_Subtype_Definition (LPS)) in N_Raise_xxx_Error
+ then
+ Rewrite (N, Discrete_Subtype_Definition (LPS));
+ return;
+ end if;
+
if Present (Iterator_Filter (LPS)) then
pragma Assert (Ada_Version >= Ada_2020);
Set_Statements (N,
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 0bef709e9e6..e4537e45553 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -227,9 +227,11 @@ package body Sem_Attr is
procedure Analyze_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Aname : constant Name_Id := Attribute_Name (N);
- P : constant Node_Id := Prefix (N);
Exprs : constant List_Id := Expressions (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+ P_Old : constant Node_Id := Prefix (N);
+
+ P : Node_Id := P_Old;
E1 : Node_Id;
E2 : Node_Id;
@@ -1836,7 +1838,7 @@ package body Sem_Attr is
-- Case of an expression
- Resolve (P);
+ Resolve (P_Old);
if Is_Access_Type (P_Type) then
@@ -1852,12 +1854,12 @@ package body Sem_Attr is
Freeze_Before (N, Designated_Type (P_Type));
end if;
- Rewrite (P,
- Make_Explicit_Dereference (Sloc (P),
- Prefix => Relocate_Node (P)));
+ Rewrite (P_Old,
+ Make_Explicit_Dereference (Sloc (P_Old),
+ Prefix => Relocate_Node (P_Old)));
- Analyze_And_Resolve (P);
- P_Type := Etype (P);
+ Analyze_And_Resolve (P_Old);
+ P_Type := Etype (P_Old);
if P_Type = Any_Type then
raise Bad_Attribute;
@@ -3102,6 +3104,15 @@ package body Sem_Attr is
end if;
end if;
+ -- If the prefix was rewritten as a raise node, then rewrite N as a
+ -- raise node, to avoid creating inconsistent trees. We still need to
+ -- perform legality checks on the original tree.
+
+ if Nkind (P) in N_Raise_xxx_Error then
+ Rewrite (N, Relocate_Node (P));
+ P := Original_Node (P_Old);
+ end if;
+
-- Remaining processing depends on attribute
case Attr_Id is
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index a51dd54aff5..c01bce132c0 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -14619,11 +14619,13 @@ package body Sem_Ch3 is
Comp_List : constant Elist_Id := New_Elmt_List;
Parent_Type : constant Entity_Id := Etype (Typ);
Assoc_List : constant List_Id := New_List;
- Discr_Val : Elmt_Id;
- Errors : Boolean;
- New_C : Entity_Id;
- Old_C : Entity_Id;
- Is_Static : Boolean := True;
+
+ Discr_Val : Elmt_Id;
+ Errors : Boolean;
+ New_C : Entity_Id;
+ Old_C : Entity_Id;
+ Is_Static : Boolean := True;
+ Is_Compile_Time_Known : Boolean := True;
procedure Collect_Fixed_Components (Typ : Entity_Id);
-- Collect parent type components that do not appear in a variant part
@@ -14773,7 +14775,11 @@ package body Sem_Ch3 is
while Present (Discr_Val) loop
if not Is_OK_Static_Expression (Node (Discr_Val)) then
Is_Static := False;
- exit;
+
+ if not Compile_Time_Known_Value (Node (Discr_Val)) then
+ Is_Compile_Time_Known := False;
+ exit;
+ end if;
end if;
Next_Elmt (Discr_Val);
@@ -14871,19 +14877,18 @@ package body Sem_Ch3 is
end if;
end Add_Discriminants;
- if Is_Static
+ if Is_Compile_Time_Known
and then Is_Variant_Record (Typ)
then
Collect_Fixed_Components (Typ);
-
- Gather_Components (
- Typ,
- Component_List (Type_Definition (Parent (Typ))),
- Governed_By => Assoc_List,
- Into => Comp_List,
- Report_Errors => Errors);
- pragma Assert (not Errors
- or else Serious_Errors_Detected > 0);
+ Gather_Components
+ (Typ,
+ Component_List (Type_Definition (Parent (Typ))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors,
+ Allow_Compile_Time => True);
+ pragma Assert (not Errors or else Serious_Errors_Detected > 0);
Create_All_Components;
@@ -14891,7 +14896,7 @@ package body Sem_Ch3 is
-- with constraints, we retrieve the record definition of the parent
-- type to select the components of the proper variant.
- elsif Is_Static
+ elsif Is_Compile_Time_Known
and then Is_Tagged_Type (Typ)
and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
and then
@@ -14899,13 +14904,13 @@ package body Sem_Ch3 is
and then Is_Variant_Record (Parent_Type)
then
Collect_Fixed_Components (Typ);
-
Gather_Components
(Typ,
Component_List (Type_Definition (Parent (Parent_Type))),
- Governed_By => Assoc_List,
- Into => Comp_List,
- Report_Errors => Errors);
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors,
+ Allow_Compile_Time => True);
-- Note: previously there was a check at this point that no errors
-- were detected. As a consequence of AI05-220 there may be an error
@@ -14913,21 +14918,19 @@ package body Sem_Ch3 is
-- static constraint.
-- If the tagged derivation has a type extension, collect all the
- -- new components therein.
+ -- new relevant components therein via Gather_Components.
if Present (Record_Extension_Part (Type_Definition (Parent (Typ))))
then
- Old_C := First_Component (Typ);
- while Present (Old_C) loop
- if Original_Record_Component (Old_C) = Old_C
- and then Chars (Old_C) /= Name_uTag
- and then Chars (Old_C) /= Name_uParent
- then
- Append_Elmt (Old_C, Comp_List);
- end if;
-
- Next_Component (Old_C);
- end loop;
+ Gather_Components
+ (Typ,
+ Component_List
+ (Record_Extension_Part (Type_Definition (Parent (Typ)))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors,
+ Allow_Compile_Time => True,
+ Include_Interface_Tag => True);
end if;
Create_All_Components;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 01d70b00684..7a8c261ee4f 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -5455,7 +5455,7 @@ package body Sem_Ch4 is
Apply_Compile_Time_Constraint_Error
(N, "component not present in }??",
CE_Discriminant_Check_Failed,
- Ent => Prefix_Type, Rep => False);
+ Ent => Prefix_Type);
Set_Raises_Constraint_Error (N);
return;
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index d344ad16e3e..0b1db8510c4 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -3097,7 +3097,10 @@ package body Sem_Ch5 is
Check_Predicate_Use (Entity (Subtype_Mark (DS)));
end if;
- Make_Index (DS, N);
+ if Nkind (DS) not in N_Raise_xxx_Error then
+ Make_Index (DS, N);
+ end if;
+
Set_Ekind (Id, E_Loop_Parameter);
-- A quantified expression which appears in a pre- or post-condition may
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 8ec86fc9b1c..899464f961b 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -772,6 +772,31 @@ package body Sem_Ch8 is
-- Obtain the name of the object from node Nod which is being renamed by
-- the object renaming declaration N.
+ function Find_Raise_Node (N : Node_Id) return Traverse_Result;
+ -- Process one node in search for N_Raise_xxx_Error nodes.
+ -- Return Abandon if found, OK otherwise.
+
+ ---------------------
+ -- Find_Raise_Node --
+ ---------------------
+
+ function Find_Raise_Node (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) in N_Raise_xxx_Error then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Raise_Node;
+
+ ------------------------
+ -- No_Raise_xxx_Error --
+ ------------------------
+
+ function No_Raise_xxx_Error is new Traverse_Func (Find_Raise_Node);
+ -- Traverse tree to look for a N_Raise_xxx_Error node and returns
+ -- Abandon if so and OK if none found.
+
------------------------------
-- Check_Constrained_Object --
------------------------------
@@ -1454,9 +1479,12 @@ package body Sem_Ch8 is
then
Error_Msg_N ("incompatible types in renaming", Nam);
- -- AI12-0383: Names that denote values can be renamed
+ -- AI12-0383: Names that denote values can be renamed.
+ -- Ignore (accept) N_Raise_xxx_Error nodes in this context.
- elsif Ada_Version < Ada_2020 then
+ elsif Ada_Version < Ada_2020
+ and then No_Raise_xxx_Error (Nam) = OK
+ then
Error_Msg_N ("value in renaming requires -gnat2020", Nam);
end if;
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 1a832f767cd..8d47589df73 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -43,6 +43,7 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Elab; use Sem_Elab;
@@ -1855,6 +1856,12 @@ package body Sem_Eval is
N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null
then
return True;
+
+ -- Evaluate static discriminants, to eliminate dead paths and
+ -- redundant discriminant checks.
+
+ elsif Is_Static_Discriminant_Component (Op) then
+ return True;
end if;
end if;
@@ -3818,6 +3825,24 @@ package body Sem_Eval is
Warn_On_Known_Condition (N);
end Eval_Relational_Op;
+ -----------------------------
+ -- Eval_Selected_Component --
+ -----------------------------
+
+ procedure Eval_Selected_Component (N : Node_Id) is
+ begin
+ -- If an attribute reference or a LHS, nothing to do.
+ -- Also do not fold if N is an [in] out subprogram parameter.
+ -- Fold will perform the other relevant tests.
+
+ if Nkind (Parent (N)) /= N_Attribute_Reference
+ and then Is_LHS (N) = No
+ and then not Is_Actual_Out_Or_In_Out_Parameter (N)
+ then
+ Fold (N);
+ end if;
+ end Eval_Selected_Component;
+
----------------
-- Eval_Shift --
----------------
@@ -4487,6 +4512,15 @@ package body Sem_Eval is
elsif Kind = N_Unchecked_Type_Conversion then
return Expr_Rep_Value (Expression (N));
+ -- Static discriminant value
+
+ elsif Is_Static_Discriminant_Component (N) then
+ return Expr_Rep_Value
+ (Get_Discriminant_Value
+ (Entity (Selector_Name (N)),
+ Etype (Prefix (N)),
+ Discriminant_Constraint (Etype (Prefix (N)))));
+
else
raise Program_Error;
end if;
@@ -4574,6 +4608,15 @@ package body Sem_Eval is
elsif Kind = N_Unchecked_Type_Conversion then
Val := Expr_Value (Expression (N));
+ -- Static discriminant value
+
+ elsif Is_Static_Discriminant_Component (N) then
+ Val := Expr_Value
+ (Get_Discriminant_Value
+ (Entity (Selector_Name (N)),
+ Etype (Prefix (N)),
+ Discriminant_Constraint (Etype (Prefix (N)))));
+
else
raise Program_Error;
end if;
@@ -4801,6 +4844,32 @@ package body Sem_Eval is
end if;
end Flag_Non_Static_Expr;
+ ----------
+ -- Fold --
+ ----------
+
+ procedure Fold (N : Node_Id) is
+ Typ : constant Entity_Id := Etype (N);
+ begin
+ -- If not known at compile time or if already a literal, nothing to do
+
+ if Nkind (N) in N_Numeric_Or_String_Literal
+ or else not Compile_Time_Known_Value (N)
+ then
+ null;
+
+ elsif Is_Discrete_Type (Typ) then
+ Fold_Uint (N, Expr_Value (N), Static => Is_Static_Expression (N));
+
+ elsif Is_Real_Type (Typ) then
+ Fold_Ureal (N, Expr_Value_R (N), Static => Is_Static_Expression (N));
+
+ elsif Is_String_Type (Typ) then
+ Fold_Str
+ (N, Strval (Expr_Value_S (N)), Static => Is_Static_Expression (N));
+ end if;
+ end Fold;
+
----------------
-- Fold_Dummy --
----------------
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 76e4bdf5d65..972cee646d7 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -330,6 +330,7 @@ package Sem_Eval is
procedure Eval_Op_Not (N : Node_Id);
procedure Eval_Real_Literal (N : Node_Id);
procedure Eval_Relational_Op (N : Node_Id);
+ procedure Eval_Selected_Component (N : Node_Id);
procedure Eval_Shift (N : Node_Id);
procedure Eval_Short_Circuit (N : Node_Id);
procedure Eval_Slice (N : Node_Id);
@@ -387,6 +388,10 @@ package Sem_Eval is
-- The call has no effect if Raises_Constraint_Error (N) is True, since
-- there is no point in folding if we have an error.
+ procedure Fold (N : Node_Id);
+ -- Rewrite N with the relevant value if Compile_Time_Known_Value (N) is
+ -- True, otherwise a no-op.
+
function Is_In_Range
(N : Node_Id;
Typ : Entity_Id;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index bb4ddab6d85..4077ae1b256 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -10891,30 +10891,34 @@ package body Sem_Res is
Set_Etype (N, Base_Type (Typ));
end if;
- -- Note: No Eval processing is required, because the prefix is of a
- -- record type, or protected type, and neither can possibly be static.
+ -- Eval_Selected_Component may e.g. fold statically known discriminants.
- -- If the record type is atomic and the component is not, then this is
- -- worth a warning before Ada 2020, since we have a situation where the
- -- access to the component may cause extra read/writes of the atomic
- -- object, or partial word accesses, both of which may be unexpected.
+ Eval_Selected_Component (N);
- if Nkind (N) = N_Selected_Component
- and then Is_Atomic_Ref_With_Address (N)
- and then not Is_Atomic (Entity (S))
- and then not Is_Atomic (Etype (Entity (S)))
- and then Ada_Version < Ada_2020
- then
- Error_Msg_N
- ("??access to non-atomic component of atomic record",
- Prefix (N));
- Error_Msg_N
- ("\??may cause unexpected accesses to atomic object",
- Prefix (N));
- end if;
+ if Nkind (N) = N_Selected_Component then
- Resolve_Implicit_Dereference (Prefix (N));
- Analyze_Dimension (N);
+ -- If the record type is atomic and the component is not, then this
+ -- is worth a warning before Ada 2020, since we have a situation
+ -- where the access to the component may cause extra read/writes of
+ -- the atomic object, or partial word accesses, both of which may be
+ -- unexpected.
+
+ if Is_Atomic_Ref_With_Address (N)
+ and then not Is_Atomic (Entity (S))
+ and then not Is_Atomic (Etype (Entity (S)))
+ and then Ada_Version < Ada_2020
+ then
+ Error_Msg_N
+ ("??access to non-atomic component of atomic record",
+ Prefix (N));
+ Error_Msg_N
+ ("\??may cause unexpected accesses to atomic object",
+ Prefix (N));
+ end if;
+
+ Resolve_Implicit_Dereference (Prefix (N));
+ Analyze_Dimension (N);
+ end if;
end Resolve_Selected_Component;
-------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 90e746f746a..20ec9075a51 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -9896,11 +9896,13 @@ package body Sem_Util is
-----------------------
procedure Gather_Components
- (Typ : Entity_Id;
- Comp_List : Node_Id;
- Governed_By : List_Id;
- Into : Elist_Id;
- Report_Errors : out Boolean)
+ (Typ : Entity_Id;
+ Comp_List : Node_Id;
+ Governed_By : List_Id;
+ Into : Elist_Id;
+ Report_Errors : out Boolean;
+ Allow_Compile_Time : Boolean := False;
+ Include_Interface_Tag : Boolean := False)
is
Assoc : Node_Id;
Variant : Node_Id;
@@ -9932,15 +9934,20 @@ package body Sem_Util is
while Present (Comp_Item) loop
- -- Skip the tag of a tagged record, the interface tags, as well
- -- as all items that are not user components (anonymous types,
- -- rep clauses, Parent field, controller field).
+ -- Skip the tag of a tagged record, as well as all items that are not
+ -- user components (anonymous types, rep clauses, Parent field,
+ -- controller field).
if Nkind (Comp_Item) = N_Component_Declaration then
declare
Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
begin
- if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then
+ if not (Is_Tag (Comp)
+ and then not
+ (Include_Interface_Tag
+ and then Etype (Comp) = RTE (RE_Interface_Tag)))
+ and then Chars (Comp) /= Name_uParent
+ then
Append_Elmt (Comp, Into);
end if;
end;
@@ -10049,7 +10056,11 @@ package body Sem_Util is
end loop Find_Constraint;
Discrim_Value := Expression (Assoc);
- if Is_OK_Static_Expression (Discrim_Value) then
+
+ if Is_OK_Static_Expression (Discrim_Value)
+ or else (Allow_Compile_Time
+ and then Compile_Time_Known_Value (Discrim_Value))
+ then
Discrim_Value_Status := Static_Expr;
else
if Ada_Version >= Ada_2020 then
@@ -10228,7 +10239,8 @@ package body Sem_Util is
end if;
Gather_Components
- (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
+ (Typ, Component_List (Variant), Governed_By, Into,
+ Report_Errors, Allow_Compile_Time);
end if;
end Gather_Components;
@@ -13861,6 +13873,24 @@ package body Sem_Util is
and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
end In_Assertion_Expression_Pragma;
+ -------------------
+ -- In_Check_Node --
+ -------------------
+
+ function In_Check_Node (N : Node_Id) return Boolean is
+ Node : Node_Id := Parent (N);
+ begin
+ while Present (Node) loop
+ if Nkind (Node) in N_Raise_xxx_Error then
+ return True;
+ end if;
+
+ Node := Parent (Node);
+ end loop;
+
+ return False;
+ end In_Check_Node;
+
-------------------------------
-- In_Generic_Formal_Package --
-------------------------------
@@ -15210,6 +15240,19 @@ package body Sem_Util is
return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter;
end Is_Actual_In_Out_Parameter;
+ ---------------------------------------
+ -- Is_Actual_Out_Or_In_Out_Parameter --
+ ---------------------------------------
+
+ function Is_Actual_Out_Or_In_Out_Parameter (N : Node_Id) return Boolean is
+ Formal : Entity_Id;
+ Call : Node_Id;
+ begin
+ Find_Actual (N, Formal, Call);
+ return Present (Formal)
+ and then Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter;
+ end Is_Actual_Out_Or_In_Out_Parameter;
+
-------------------------
-- Is_Actual_Parameter --
-------------------------
@@ -16312,7 +16355,7 @@ package body Sem_Util is
P_Aliased : Boolean := False;
Comp : Entity_Id;
- Deref : Node_Id := Object;
+ Deref : Node_Id := Original_Node (Object);
-- Dereference node, in something like X.all.Y(2)
-- Start of processing for Is_Dependent_Component_Of_Mutable_Object
@@ -16323,11 +16366,9 @@ package body Sem_Util is
while Nkind (Deref) in
N_Indexed_Component | N_Selected_Component | N_Slice
loop
- Deref := Prefix (Deref);
+ Deref := Original_Node (Prefix (Deref));
end loop;
- Deref := Original_Node (Deref);
-
-- If the prefix is a qualified expression of a variable, then function
-- Is_Variable will return False for that because a qualified expression
-- denotes a constant view, so we need to get the name being qualified
@@ -16503,14 +16544,16 @@ package body Sem_Util is
elsif Nkind (Object) = N_Indexed_Component
or else Nkind (Object) = N_Slice
then
- return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
+ return Is_Dependent_Component_Of_Mutable_Object
+ (Original_Node (Prefix (Object)));
-- A type conversion that Is_Variable is a view conversion:
-- go back to the denoted object.
elsif Nkind (Object) = N_Type_Conversion then
return
- Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
+ Is_Dependent_Component_Of_Mutable_Object
+ (Original_Node (Expression (Object)));
end if;
end if;
@@ -18296,6 +18339,23 @@ package body Sem_Util is
-------------------------
function Is_Object_Reference (N : Node_Id) return Boolean is
+ function Safe_Prefix (N : Node_Id) return Node_Id;
+ -- Return Prefix (N) unless it has been rewritten as an
+ -- N_Raise_xxx_Error node, in which case return its original node.
+
+ -----------------
+ -- Safe_Prefix --
+ -----------------
+
+ function Safe_Prefix (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (Prefix (N)) in N_Raise_xxx_Error then
+ return Original_Node (Prefix (N));
+ else
+ return Prefix (N);
+ end if;
+ end Safe_Prefix;
+
begin
-- AI12-0068: Note that a current instance reference in a type or
-- subtype's aspect_specification is considered a value, not an object
@@ -18311,8 +18371,8 @@ package body Sem_Util is
| N_Slice
=>
return
- Is_Object_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N)));
+ Is_Object_Reference (Safe_Prefix (N))
+ or else Is_Access_Type (Etype (Safe_Prefix (N)));
-- In Ada 95, a function call is a constant object; a procedure
-- call is not.
@@ -18340,8 +18400,8 @@ package body Sem_Util is
return
Is_Object_Reference (Selector_Name (N))
and then
- (Is_Object_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N))));
+ (Is_Object_Reference (Safe_Prefix (N))
+ or else Is_Access_Type (Etype (Safe_Prefix (N))));
-- An explicit dereference denotes an object, except that a
-- conditional expression gets turned into an explicit dereference
@@ -19954,6 +20014,22 @@ package body Sem_Util is
or else Nkind (N) = N_Procedure_Call_Statement;
end Is_Statement;
+ --------------------------------------
+ -- Is_Static_Discriminant_Component --
+ --------------------------------------
+
+ function Is_Static_Discriminant_Component (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Selected_Component
+ and then not Is_In_Discriminant_Check (N)
+ and then Present (Etype (Prefix (N)))
+ and then Ekind (Etype (Prefix (N))) = E_Record_Subtype
+ and then Has_Static_Discriminants (Etype (Prefix (N)))
+ and then Present (Entity (Selector_Name (N)))
+ and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
+ and then not In_Check_Node (N);
+ end Is_Static_Discriminant_Component;
+
------------------------
-- Is_Static_Function --
------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 60ed0e8f941..65601800495 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1049,11 +1049,13 @@ package Sem_Util is
-- be installed on the scope stack to prevent spurious visibility errors.
procedure Gather_Components
- (Typ : Entity_Id;
- Comp_List : Node_Id;
- Governed_By : List_Id;
- Into : Elist_Id;
- Report_Errors : out Boolean);
+ (Typ : Entity_Id;
+ Comp_List : Node_Id;
+ Governed_By : List_Id;
+ Into : Elist_Id;
+ Report_Errors : out Boolean;
+ Allow_Compile_Time : Boolean := False;
+ Include_Interface_Tag : Boolean := False);
-- The purpose of this procedure is to gather the valid components in a
-- record type according to the values of its discriminants, in order to
-- validate the components of a record aggregate.
@@ -1076,6 +1078,12 @@ package Sem_Util is
-- Report_Errors is set to True if the values of the discriminants are
-- non-static.
--
+ -- Allow_Compile_Time if set to True, allows compile time known values in
+ -- Governed_By expressions in addition to static expressions.
+ --
+ -- Include_Interface_Tag if set to True, gather any interface tag
+ -- component, otherwise exclude them.
+ --
-- This procedure is also used when building a record subtype. If the
-- discriminant constraint of the subtype is static, the components of the
-- subtype are only those of the variants selected by the values of the
@@ -1542,6 +1550,9 @@ package Sem_Util is
-- Returns True if node N appears within a pragma that acts as an assertion
-- expression. See Sem_Prag for the list of qualifying pragmas.
+ function In_Check_Node (N : Node_Id) return Boolean;
+ -- Return True if N is part of a N_Raise_xxx_Error node
+
function In_Generic_Formal_Package (E : Entity_Id) return Boolean;
-- Returns True if entity E is inside a generic formal package
@@ -1696,6 +1707,10 @@ package Sem_Util is
function Is_Actual_Out_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter of out mode in a subprogram call
+ function Is_Actual_Out_Or_In_Out_Parameter (N : Node_Id) return Boolean;
+ -- Determines if N is an actual parameter of out or in out mode in a
+ -- subprogram call.
+
function Is_Actual_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter in a subprogram call
@@ -2236,6 +2251,13 @@ package Sem_Util is
-- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo).
-- Note that a label is *not* a statement, and will return False.
+ function Is_Static_Discriminant_Component (N : Node_Id) return Boolean;
+ -- Return True if N is guaranteed to a selected component containing a
+ -- statically known discriminant.
+ -- Note that this routine takes a conservative view and may return False
+ -- in some cases where N would match the criteria. In other words this
+ -- routine should be used to simplify or optimize the expanded code.
+
function Is_Static_Function (Subp : Entity_Id) return Boolean;
-- Determine whether subprogram Subp denotes a static function,
-- which is a function with the aspect Static with value True.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2020-12-17 10:51 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-12-17 10:51 [gcc r11-6209] [Ada] Remove discriminant checks processing in gigi Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).