This patch improves the performance of the frontend machinery which
detects dangerous order dependencies caused by out-mode parameters
of Ada 2012 functions (AI05-0144).
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-05-25 Javier Miranda <mira...@adacore.com>
* einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): This attribute
is now present in subprograms, generic subprograms, entries and
entry families.
* sem_ch6.adb (Set_Formal_Mode): Set As_Out_Or_In_Out_Parameter
on entries, entry families, subprograms and generic subprograms.
* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration):
Minor code reorganization to ensure that the Ekind attribute
of the subprogram entity is set before its formals are
processed. Required to allow the use of the attribute
Has_Out_Or_In_Out_Parameter on the subprogram entity.
* sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate):
Perform the check on writable actuals only if the value of some
component of the aggregate involves calling a function with
out-mode parameters.
(Resolve_Record_Aggregate): Propagate the Check_Actuals flag to the
internally built aggregate.
* sem_ch3.adb (Build_Derived_Record_Type, Record_Type_Declaration):
Perform the check on writable actuals only if the initialization of
some component involves calling a function with out-mode parameters.
* sem_ch4.adb (Analyze_Arithmetic_Op, Analyze_Comparison_Op,
Analyze_Equality_Op, Analyze_Logical_Op, Analyze_Membership_Op,
Analyze_Range): Check writable actuals only if the
subtrees have a call to a function with out-mode parameters
(Analyze_Call.Check_Writable_Actuals): New subprogram. If the call
has out or in-out parameters then mark its outermost enclosing
construct as a node on which the writable actuals check must
be performed.
(Analyze_Call): Check if the flag must be set and if the outermost
enclosing construct.
* sem_util.adb (Check_Function_Writable_Actuals): Code cleanup
and reorganization. We skip processing aggregate discriminants
since their precise analysis involves two phases traversal.
* sem_res.adb (Resolve_Actuals, Resolve_Arithmetic_Op,
Resolve_Logical_Op, Resolve_Membership_Op): Remove call to
check_writable_actuals.
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 223476)
+++ sem_aggr.adb (working copy)
@@ -1161,7 +1161,9 @@
Set_Analyzed (N);
end if;
- Check_Function_Writable_Actuals (N);
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Resolve_Aggregate;
-----------------------------
@@ -2904,7 +2906,9 @@
Error_Msg_N ("no unique type for this aggregate", A);
end if;
- Check_Function_Writable_Actuals (N);
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Resolve_Extension_Aggregate;
------------------------------
@@ -4677,6 +4681,7 @@
Set_Expressions (New_Aggregate, No_List);
Set_Etype (New_Aggregate, Etype (N));
Set_Component_Associations (New_Aggregate, New_Assoc_List);
+ Set_Check_Actuals (New_Aggregate, Check_Actuals (N));
Rewrite (N, New_Aggregate);
end Step_8;
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 223573)
+++ sem_ch3.adb (working copy)
@@ -8953,7 +8953,9 @@
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
end if;
- Check_Function_Writable_Actuals (N);
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Build_Derived_Record_Type;
------------------------
@@ -21116,7 +21118,9 @@
Derive_Progenitor_Subprograms (T, T);
end if;
- Check_Function_Writable_Actuals (N);
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Record_Type_Declaration;
----------------------------
Index: einfo.adb
===================================================================
--- einfo.adb (revision 223561)
+++ einfo.adb (working copy)
@@ -1611,7 +1611,9 @@
function Has_Out_Or_In_Out_Parameter (Id : E) return B is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
+ pragma Assert
+ (Ekind_In (Id, E_Entry, E_Entry_Family)
+ or else Is_Subprogram_Or_Generic_Subprogram (Id));
return Flag110 (Id);
end Has_Out_Or_In_Out_Parameter;
@@ -4505,7 +4507,9 @@
procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
+ pragma Assert
+ (Ekind_In (Id, E_Entry, E_Entry_Family)
+ or else Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Flag110 (Id, V);
end Set_Has_Out_Or_In_Out_Parameter;
Index: einfo.ads
===================================================================
--- einfo.ads (revision 223573)
+++ einfo.ads (working copy)
@@ -1756,8 +1756,9 @@
-- Object_Size clauses for a given entity.
-- Has_Out_Or_In_Out_Parameter (Flag110)
--- Present in function and generic function entities. Set if the function
--- has at least one OUT or IN OUT parameter (allowed only in Ada 2012).
+-- Present in subprograms, generic subprograms, entries and entry
+-- families. Set if they have at least one OUT or IN OUT parameter
+-- (allowed for functions only in Ada 2012).
-- Has_Per_Object_Constraint (Flag154)
-- Defined in E_Component entities. Set if the subtype of the component
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb (revision 223573)
+++ sem_ch12.adb (working copy)
@@ -3366,13 +3366,17 @@
Formals := Parameter_Specifications (Spec);
+ if Nkind (Spec) = N_Function_Specification then
+ Set_Ekind (Id, E_Generic_Function);
+ else
+ Set_Ekind (Id, E_Generic_Procedure);
+ end if;
+
if Present (Formals) then
Process_Formals (Formals, Spec);
end if;
if Nkind (Spec) = N_Function_Specification then
- Set_Ekind (Id, E_Generic_Function);
-
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
Result_Type := Access_Definition (Spec, Result_Definition (Spec));
Set_Etype (Id, Result_Type);
@@ -3420,7 +3424,6 @@
end if;
else
- Set_Ekind (Id, E_Generic_Procedure);
Set_Etype (Id, Standard_Void_Type);
end if;
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 223561)
+++ sem_util.adb (working copy)
@@ -2119,11 +2119,37 @@
then
return Skip;
+ -- For now we skip aggregate discriminants since they require
+ -- performing the analysis in two phases to identify conflicts:
+ -- first one analyzing discriminants and second one analyzing
+ -- the rest of components (since at runtime discriminants are
+ -- evaluated prior to components): too much computation cost
+ -- to identify a corner case???
+
+ elsif Nkind (Parent (N)) = N_Component_Association
+ and then Nkind_In (Parent (Parent (N)),
+ N_Aggregate,
+ N_Extension_Aggregate)
+ then
+ declare
+ Choice : constant Node_Id := First (Choices (Parent (N)));
+ begin
+ if Ekind (Entity (N)) = E_Discriminant then
+ return Skip;
+
+ elsif Expression (Parent (N)) = N
+ and then Nkind (Choice) = N_Identifier
+ and then Ekind (Entity (Choice)) = E_Discriminant
+ then
+ return Skip;
+ end if;
+ end;
+
-- Analyze if N is a writable actual of a function
elsif Nkind (Parent (N)) = N_Function_Call then
declare
- Call : constant Node_Id := Parent (N);
+ Call : constant Node_Id := Parent (N);
Actual : Node_Id;
Formal : Node_Id;
@@ -2136,32 +2162,59 @@
return Abandon;
end if;
- Formal := First_Formal (Id);
- Actual := First_Actual (Call);
- while Present (Actual) and then Present (Formal) loop
- if Actual = N then
- if Ekind_In (Formal, E_Out_Parameter,
- E_In_Out_Parameter)
- then
- Is_Writable_Actual := True;
+ if Ekind_In (Id, E_Function, E_Generic_Function)
+ and then Has_Out_Or_In_Out_Parameter (Id)
+ then
+ Formal := First_Formal (Id);
+ Actual := First_Actual (Call);
+ while Present (Actual) and then Present (Formal) loop
+ if Actual = N then
+ if Ekind_In (Formal, E_Out_Parameter,
+ E_In_Out_Parameter)
+ then
+ Is_Writable_Actual := True;
+ end if;
+
+ exit;
end if;
- exit;
- end if;
-
- Next_Formal (Formal);
- Next_Actual (Actual);
- end loop;
+ Next_Formal (Formal);
+ Next_Actual (Actual);
+ end loop;
+ end if;
end;
end if;
if Is_Writable_Actual then
if Contains (Writable_Actuals_List, N) then
- Error_Msg_NE
- ("value may be affected by call to& "
- & "because order of evaluation is arbitrary", N, Id);
- Error_Node := N;
- return Abandon;
+
+ -- Report the error on the second occurrence of the
+ -- identifier. We cannot assume that N is the second
+ -- occurrence since traverse_func walks through Field2
+ -- last (see comment in the body of traverse_func).
+
+ declare
+ Elmt : Elmt_Id := First_Elmt (Writable_Actuals_List);
+
+ begin
+ while Present (Elmt)
+ and then Entity (Node (Elmt)) /= Entity (N)
+ loop
+ Next_Elmt (Elmt);
+ end loop;
+
+ if Sloc (N) > Sloc (Node (Elmt)) then
+ Error_Node := N;
+ else
+ Error_Node := Node (Elmt);
+ end if;
+
+ Error_Msg_NE
+ ("value may be affected by call to& "
+ & "because order of evaluation is arbitrary",
+ Error_Node, Id);
+ return Abandon;
+ end;
end if;
Append_New_Elmt (N, To => Writable_Actuals_List);
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 223569)
+++ sem_res.adb (working copy)
@@ -3566,7 +3566,6 @@
begin
Check_Argument_Order;
- Check_Function_Writable_Actuals (N);
if Is_Overloadable (Nam)
and then Is_Inherited_Operation (Nam)
@@ -5508,7 +5507,6 @@
Check_Unset_Reference (L);
Check_Unset_Reference (R);
- Check_Function_Writable_Actuals (N);
end Resolve_Arithmetic_Op;
------------------
@@ -8600,8 +8598,6 @@
end if;
end;
end if;
-
- Check_Function_Writable_Actuals (N);
end Resolve_Logical_Op;
---------------------------
@@ -8793,7 +8789,6 @@
<<SM_Exit>>
Eval_Membership_Op (N);
- Check_Function_Writable_Actuals (N);
end Resolve_Membership_Op;
------------------
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 223570)
+++ sem_ch4.adb (working copy)
@@ -830,6 +830,10 @@
end if;
Operator_Check (N);
+
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Analyze_Arithmetic_Op;
------------------
@@ -862,6 +866,11 @@
-- Check that parameter and named associations are not mixed. This is
-- a restriction in SPARK mode.
+ procedure Check_Writable_Actuals (N : Node_Id);
+ -- If the call has out or in-out parameters then mark its outermost
+ -- enclosing construct as a node on which the writable actuals check
+ -- must be performed.
+
function Name_Denotes_Function return Boolean;
-- If the type of the name is an access to subprogram, this may be the
-- type of a name, or the return type of the function being called. If
@@ -902,6 +911,140 @@
end loop;
end Check_Mixed_Parameter_And_Named_Associations;
+ ----------------------------
+ -- Check_Writable_Actuals --
+ ----------------------------
+
+ -- The identification of conflicts in calls to functions with writable
+ -- actuals is performed in the analysis phase of the frontend to ensure
+ -- that it reports exactly the same errors compiling with and without
+ -- expansion enabled. It is performed in two stages:
+
+ -- 1) When a call to a function with out-mode parameters is found
+ -- we climb to the outermost enclosing construct which can be
+ -- evaluated in arbitrary order and we mark it with the flag
+ -- Check_Actuals.
+
+ -- 2) When the analysis of the marked node is complete then we
+ -- traverse its decorated subtree searching for conflicts
+ -- (see function Sem_Util.Check_Function_Writable_Actuals).
+
+ -- The unique exception to this general rule are aggregates, since
+ -- their analysis is performed by the frontend in the resolution
+ -- phase. For aggregates we do not climb to its enclosing construct:
+ -- we restrict the analysis to the subexpressions initializing the
+ -- aggregate components.
+
+ -- This implies that the analysis of expressions containing aggregates
+ -- is not complete since there may be conflicts on writable actuals
+ -- involving subexpressions of the enclosing logical or arithmetic
+ -- expressions. However, we cannot wait and perform the analysis when
+ -- the whole subtree is resolved since the subtrees may be transformed
+ -- thus adding extra complexity and computation cost to identify and
+ -- report exactly the same errors compiling with and without expansion
+ -- enabled.
+
+ procedure Check_Writable_Actuals (N : Node_Id) is
+
+ function Is_Arbitrary_Evaluation_Order_Construct
+ (N : Node_Id) return Boolean;
+ -- Return True if N is an Ada construct which may evaluate in
+ -- arbitrary order. This function does not cover all the language
+ -- constructs which can be evaluated in arbitrary order but the
+ -- subset needed for AI05-0144.
+
+ ---------------------------------------------
+ -- Is_Arbitrary_Evaluation_Order_Construct --
+ ---------------------------------------------
+
+ function Is_Arbitrary_Evaluation_Order_Construct
+ (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Aggregate
+ or else Nkind (N) = N_Assignment_Statement
+ or else Nkind (N) = N_Full_Type_Declaration
+ or else Nkind (N) = N_Entry_Call_Statement
+ or else Nkind (N) = N_Extension_Aggregate
+ or else Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Object_Declaration
+ or else Nkind (N) = N_Pragma
+ or else Nkind (N) = N_Range
+ or else Nkind (N) = N_Slice
+
+ or else Nkind (N) in N_Array_Type_Definition
+ or else Nkind (N) in N_Membership_Test
+ or else Nkind (N) in N_Op
+ or else Nkind (N) in N_Subprogram_Call;
+ end Is_Arbitrary_Evaluation_Order_Construct;
+
+ -- Start of processing for Check_Writable_Actuals
+
+ begin
+ if Comes_From_Source (N)
+ and then Present (Get_Subprogram_Entity (N))
+ and then Has_Out_Or_In_Out_Parameter (Get_Subprogram_Entity (N))
+ then
+ -- For procedures and entries there is no need to climb since
+ -- we only need to check if the actuals of this call invoke
+ -- functions whose out-mode parameters overlap.
+
+ if Nkind (N) /= N_Function_Call then
+ Set_Check_Actuals (N);
+
+ -- For calls to functions we climb to the outermost enclosing
+ -- construct where the out-mode actuals of this function may
+ -- introduce conflicts.
+
+ else
+ declare
+ Outermost : Node_Id;
+ P : Node_Id := N;
+
+ begin
+ while Present (P) loop
+
+ -- For object declarations we can climb to such node from
+ -- its object definition branch or from its initializing
+ -- expression. We prefer to mark the child node as the
+ -- outermost construct to avoid adding further complexity
+ -- to the routine which will take care later of
+ -- performing the writable actuals check.
+
+ if Is_Arbitrary_Evaluation_Order_Construct (P)
+ and then Nkind (P) /= N_Assignment_Statement
+ and then Nkind (P) /= N_Object_Declaration
+ then
+ Outermost := P;
+ end if;
+
+ -- Avoid climbing more than needed!
+
+ exit when Nkind (P) = N_Aggregate
+ or else Nkind (P) = N_Assignment_Statement
+ or else Nkind (P) = N_Entry_Call_Statement
+ or else Nkind (P) = N_Extended_Return_Statement
+ or else Nkind (P) = N_Extension_Aggregate
+ or else Nkind (P) = N_Full_Type_Declaration
+ or else Nkind (P) = N_Object_Declaration
+ or else Nkind (P) = N_Object_Renaming_Declaration
+ or else Nkind (P) = N_Package_Specification
+ or else Nkind (P) = N_Pragma
+ or else Nkind (P) = N_Procedure_Call_Statement
+ or else Nkind (P) = N_Simple_Return_Statement
+ or else (Nkind (P) = N_Range
+ and then not
+ Nkind_In (Parent (P), N_In, N_Not_In))
+ or else Nkind (P) in N_Has_Condition;
+
+ P := Parent (P);
+ end loop;
+
+ Set_Check_Actuals (Outermost);
+ end;
+ end if;
+ end if;
+ end Check_Writable_Actuals;
+
---------------------------
-- Name_Denotes_Function --
---------------------------
@@ -1257,6 +1400,21 @@
End_Interp_List;
end if;
+
+ if Ada_Version >= Ada_2012 then
+
+ -- Check if the call contains a function with writable actuals
+
+ Check_Writable_Actuals (N);
+
+ -- If found and the outermost construct which can be evaluated in
+ -- arbitrary order is precisely this call then check all its
+ -- actuals.
+
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
+ end if;
end Analyze_Call;
-----------------------------
@@ -1474,6 +1632,10 @@
end if;
Operator_Check (N);
+
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Analyze_Comparison_Op;
---------------------------
@@ -1721,6 +1883,10 @@
end if;
Operator_Check (N);
+
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Analyze_Equality_Op;
----------------------------------
@@ -2544,6 +2710,10 @@
end if;
Operator_Check (N);
+
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Analyze_Logical_Op;
---------------------------
@@ -2699,6 +2869,11 @@
if No (R) and then Ada_Version >= Ada_2012 then
Analyze_Set_Membership;
+
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
+
return;
end if;
@@ -2770,6 +2945,10 @@
then
Error_Msg_N ("membership test not applicable to cpp-class types", N);
end if;
+
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Analyze_Membership_Op;
-----------------
@@ -3849,7 +4028,9 @@
Check_Universal_Expression (H);
end if;
- Check_Function_Writable_Actuals (N);
+ if Check_Actuals (N) then
+ Check_Function_Writable_Actuals (N);
+ end if;
end Analyze_Range;
-----------------------
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 223573)
+++ sem_ch6.adb (working copy)
@@ -10539,6 +10539,7 @@
procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
Spec : constant Node_Id := Parent (Formal_Id);
+ Id : constant Entity_Id := Scope (Formal_Id);
begin
-- Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
@@ -10546,8 +10547,14 @@
-- point of the call.
if Out_Present (Spec) then
- if Ekind_In (Scope (Formal_Id), E_Function, E_Generic_Function) then
+ if Ekind_In (Id, E_Entry, E_Entry_Family)
+ or else Is_Subprogram_Or_Generic_Subprogram (Id)
+ then
+ Set_Has_Out_Or_In_Out_Parameter (Id, True);
+ end if;
+ if Ekind_In (Id, E_Function, E_Generic_Function) then
+
-- [IN] OUT parameters allowed for functions in Ada 2012
if Ada_Version >= Ada_2012 then
@@ -10564,8 +10571,6 @@
Set_Ekind (Formal_Id, E_Out_Parameter);
end if;
- Set_Has_Out_Or_In_Out_Parameter (Scope (Formal_Id), True);
-
-- But not in earlier versions of Ada
else
