[Ada] Complete implementation of RM C.6(19) clause

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.

2018-12-11  Eric Botcazou  <ebotcazou@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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@266993 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8e2f54c0c5fd0a9d01d34ecdc802811ab9a657b2..8c5d2a9b11e4624995ac94a779692563fb5726eb 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2018-12-11  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * 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.
+
 2018-12-11  Piotr Trojanek  <trojanek@adacore.com>
 
        * sem_util.adb (Is_Subprogram_Stub_Without_Prior_Declaration):

diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index c85d69c5825e8af349138bd565de52c1edc45436..cbd3ee2558763b04e8edfbf60b857fe3b31369da 100644 (file)
--- a/gcc/ada/fe.h
+++ b/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: */

diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 5caba9947297e79959ab9155a85bffd570c70dcf..c2553d83ec82b2522bb9e50f31fb3fc8c4f56309 100644 (file)
--- a/gcc/ada/gcc-interface/trans.c
+++ b/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);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index daae085b1a96e771fb01200d2351e4d38c124564..8591d318f56cabb2c84f6b70f9c6de6cac6355e8 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-12-11  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gnat.dg/atomic11.adb, gnat.dg/atomic11_pkg1.ads,
+       gnat.dg/atomic11_pkg2.ads: New testcase.
+
 2018-12-11  Ed Schonberg  <schonberg@adacore.com>
 
        * gnat.dg/aspect1.adb, gnat.dg/aspect1_horizontal.adb,

diff --git a/gcc/testsuite/gnat.dg/atomic11.adb b/gcc/testsuite/gnat.dg/atomic11.adb
new file mode 100644 (file)
index 0000000..18a3191
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/atomic11_pkg1.ads b/gcc/testsuite/gnat.dg/atomic11_pkg1.ads
new file mode 100644 (file)
index 0000000..574fd63
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/atomic11_pkg2.ads b/gcc/testsuite/gnat.dg/atomic11_pkg2.ads
new file mode 100644 (file)
index 0000000..681bcab
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/atomic11_pkg2.ads
@@ -0,0 +1,5 @@
+package Atomic11_Pkg2 is
+
+  function Max return Positive;
+
+end Atomic11_Pkg2;