This ensures that the compiler fully implements the C.6(19) clause of
the Ada Reference Manual and gives a warning when the clause does change
the passing mechanism of the affected parameter.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-12-11 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* fe.h (Is_Atomic_Object): Declare.
(Is_Volatile_Object): Likewise.
* gcc-interface/trans.c (atomic_or_volatile_copy_required_p):
New.
(Call_to_gnu): Generate a copy for an actual parameter passed by
reference if the conditions set forth by RM C.6(19) are met and
specificially deal with an atomic actual parameter.
gcc/testsuite/
* gnat.dg/atomic11.adb, gnat.dg/atomic11_pkg1.ads,
gnat.dg/atomic11_pkg2.ads: New testcase.--- gcc/ada/fe.h
+++ gcc/ada/fe.h
@@ -281,13 +281,17 @@ extern Boolean Is_OK_Static_Subtype (Entity_Id);
#define Defining_Entity sem_util__defining_entity
#define First_Actual sem_util__first_actual
#define Next_Actual sem_util__next_actual
+#define Is_Atomic_Object sem_util__is_atomic_object
#define Is_Variable_Size_Record sem_util__is_variable_size_record
+#define Is_Volatile_Object sem_util__is_volatile_object
#define Requires_Transient_Scope sem_util__requires_transient_scope
extern Entity_Id Defining_Entity (Node_Id);
extern Node_Id First_Actual (Node_Id);
extern Node_Id Next_Actual (Node_Id);
+extern Boolean Is_Atomic_Object (Node_Id);
extern Boolean Is_Variable_Size_Record (Entity_Id Id);
+extern Boolean Is_Volatile_Object (Node_Id);
extern Boolean Requires_Transient_Scope (Entity_Id);
/* sinfo: */
--- gcc/ada/gcc-interface/trans.c
+++ gcc/ada/gcc-interface/trans.c
@@ -4936,6 +4936,35 @@ create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
return gnu_temp;
}
+/* Return whether ACTUAL parameter corresponding to FORMAL_TYPE must be passed
+ by copy in a call as per RM C.6(19). Note that we use the same predicates
+ as in the front-end for RM C.6(12) because it's purely a legality issue. */
+
+static bool
+atomic_or_volatile_copy_required_p (Node_Id actual, Entity_Id formal_type)
+{
+ /* We should not have a scalar type here because such a type is passed
+ by copy. But the Interlocked routines in System.Aux_DEC force some
+ of the their scalar parameters to be passed by reference so we need
+ to preserve that if we do not want to break the interface. */
+ if (Is_Scalar_Type (formal_type))
+ return false;
+
+ if (Is_Atomic_Object (actual) && !Is_Atomic (formal_type))
+ {
+ post_error ("?atomic actual passed by copy (RM C.6(19))", actual);
+ return true;
+ }
+
+ if (Is_Volatile_Object (actual) && !Is_Volatile (formal_type))
+ {
+ post_error ("?volatile actual passed by copy (RM C.6(19))", actual);
+ return true;
+ }
+
+ return false;
+}
+
/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
@@ -5150,13 +5179,18 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
= build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
}
- /* If we are passing a non-addressable parameter by reference, pass the
- address of a copy. In the In Out or Out case, set up to copy back
- out after the call. */
+ /* If we are passing a non-addressable actual parameter by reference,
+ pass the address of a copy and, in the In Out or Out case, set up
+ to copy back after the call. We also need to do that if the actual
+ parameter is atomic or volatile but the formal parameter is not. */
if (is_by_ref_formal_parm
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
- && !addressable_p (gnu_name, gnu_name_type))
+ && (!addressable_p (gnu_name, gnu_name_type)
+ || (Comes_From_Source (gnat_node)
+ && atomic_or_volatile_copy_required_p (gnat_actual,
+ gnat_formal_type))))
{
+ const bool atomic_p = atomic_access_required_p (gnat_actual, &sync);
tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
/* Do not issue warnings for CONSTRUCTORs since this is not a copy
@@ -5236,6 +5270,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
}
/* Create an explicit temporary holding the copy. */
+ if (atomic_p)
+ gnu_name = build_atomic_load (gnu_name, sync);
gnu_temp
= create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
@@ -5256,8 +5292,13 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
(TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
gnu_orig = TREE_OPERAND (gnu_orig, 2);
- gnu_stmt
- = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
+ if (atomic_p)
+ gnu_stmt
+ = build_atomic_store (gnu_orig, gnu_temp, sync);
+ else
+ gnu_stmt
+ = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
+ gnu_temp);
set_expr_location_from_node (gnu_stmt, gnat_node);
append_to_statement_list (gnu_stmt, &gnu_after_list);
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/atomic11.adb
@@ -0,0 +1,19 @@
+-- { dg-do compile }
+
+with Atomic11_Pkg1; use Atomic11_Pkg1;
+
+procedure Atomic11 is
+
+ R1 : Rec1;
+ pragma Atomic (R1);
+
+ R2 : Rec2;
+ pragma Volatile (R2);
+
+begin
+ R1.I := 0;
+ Proc1 (R1); -- { dg-warning "atomic actual passed by copy" }
+ R2.A(1) := 0;
+ Proc1 (R1); -- { dg-warning "atomic actual passed by copy" }
+ Proc2 (R2); -- { dg-warning "volatile actual passed by copy" }
+end;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/atomic11_pkg1.ads
@@ -0,0 +1,20 @@
+with Atomic11_Pkg2;
+
+package Atomic11_Pkg1 is
+
+ type Rec1 is record
+ I : Integer;
+ end record;
+
+ procedure Proc1 (R : Rec1);
+ pragma Import (C, Proc1);
+
+ type Arr is array (Positive range <>) of Integer;
+
+ type Rec2 is record
+ A : Arr (1 .. Atomic11_Pkg2.Max);
+ end record;
+
+ procedure Proc2 (R : Rec2);
+
+end Atomic11_Pkg1;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/atomic11_pkg2.ads
@@ -0,0 +1,5 @@
+package Atomic11_Pkg2 is
+
+ function Max return Positive;
+
+end Atomic11_Pkg2;
