gigi.h (build_atomic_load): Adjust prototype.

	* gcc-interface/gigi.h (build_atomic_load): Adjust prototype.
	(build_atomic_store): Likewise.
	(build_load_modify_store): Declare.
	(VECTOR_TYPE_P): Delete.
	* gcc-interface/decl.c (gnat_to_gnu_entity): Replace Is_Atomic with
	Is_Atomic_Or_VFA throughout.
	<E_Array_Type>: Build a variant of the XUA type instead of forcing
	TYPE_VOLATILE on it.
	<E_Array_Subtype>: Use the main variant of the base type.
	Do not force TYPE_VOLATILE on the type being built.
	<E_Record_Type>: Likewise.
	<E_Array_Subtype>: Likewise.
	<E_Subprogram_Type>: Rename local variable.
	Add Atomic qualifier in conjunction with Volatile on types if needed.
	Force BLKmode for by-ref types only at the end of the processing.
	Change qualifiers only after changing the mode of the type.  Set
	TYPE_UNIVERSAL_ALIASING_P on the type directly.
	(check_ok_for_atomic_type): Issue specific error message for VFA.
	(gnat_to_gnu_component_type): Replace Is_Atomic with
	Is_Atomic_Or_VFA throughout.
	* gcc-interface/misc.c (gnat_get_alias_set): Test
	TYPE_UNIVERSAL_ALIASING_P on the type directly.
	* gcc-interface/trans.c (lvalue_required_p): Replace Is_Atomic with
	Is_Atomic_Or_VFA throughout.  Add missing guard.
	(node_is_atomic): New predicate.
	(node_has_volatile_full_access): Likewise.
	(gnat_strip_type_conversion): New function.
	(outer_atomic_access_required_p): New predicate.
	(atomic_sync_required_p): Rename into...
	(atomic_access_required_p): ...this.  Add SYNC parameter, scan the
	parent node first and then look for the atomic setting.  Add support
	for Volatile_Full_Access.
	(Call_to_gnu): Add atomic_access and outer_atomic_access parameters
	and adjusts calls to above functions.  Use load-modify-store sequence
	for updates of In/Out and Out parameters if required, as well as for
	moving the result to the target if required.  Add couple of missing
	guards.
	(gnat_to_gnu): Adjust calls to above functions.
	<N_Object_Renaming_Declaration>: If the renamed object has side-effects
	evaluate only its address.
	<N_Assignment_Statement>: Adjust call to Call_to_gnu.  Use load-modify
	store sequence if required.
	<N_Function_Call>: Adjust call to Call_to_gnu.
	(extract_values): Adjust comment.
	* gcc-interface/utils2.c (build_atomic_load): Add SYNC parameter and
	use relaxed memory model if it is not set.
	(build_atomic_store): Likewise.
	(call_is_atomic_load): New predicate.
	(build_load_modify_store): New function.
	(build_binary_op) <MODIFY_EXPR>: Accept SAVE_EXPR on the LHS.
	(gnat_stabilize_reference) <CALL_EXPR>: Deal with atomic loads.

From-SVN: r223652

1 files changed, 216 insertions, 70 deletions

diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 03f3e30..3c957a6 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -896,7 +896,7 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
 	 the actual assignment might end up being done component-wise.  */
       return (!constant
 	      ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
-		 && Is_Atomic (Defining_Entity (gnat_parent)))
+		 && Is_Atomic_Or_VFA (Defining_Entity (gnat_parent)))
 	      /* We don't use a constructor if this is a class-wide object
 		 because the effective type of the object is the equivalent
 		 type of the class-wide subtype and it smashes most of the
@@ -910,7 +910,8 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
       return (!constant
 	      || Name (gnat_parent) == gnat_node
 	      || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
-		  && Is_Atomic (Entity (Name (gnat_parent)))));
+		  && Is_Entity_Name (Name (gnat_parent))
+		  && Is_Atomic_Or_VFA (Entity (Name (gnat_parent)))));
 
     case N_Unchecked_Type_Conversion:
 	if (!constant)
@@ -3886,57 +3887,171 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
     rest_of_subprog_body_compilation (gnu_subprog_decl);
 }
 
-/* Return true if GNAT_NODE requires atomic synchronization.  */
+/* Return true if GNAT_NODE references an Atomic entity.  */
 
 static bool
-atomic_sync_required_p (Node_Id gnat_node)
+node_is_atomic (Node_Id gnat_node)
 {
-  const Node_Id gnat_parent = Parent (gnat_node);
-  Node_Kind kind;
-  unsigned char attr_id;
+  Entity_Id gnat_entity;
 
-  /* First, scan the node to find the Atomic_Sync_Required flag.  */
-  kind = Nkind (gnat_node);
-  if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
+  switch (Nkind (gnat_node))
     {
-      gnat_node = Expression (gnat_node);
-      kind = Nkind (gnat_node);
+    case N_Identifier:
+    case N_Expanded_Name:
+      gnat_entity = Entity (gnat_node);
+      if (Ekind (gnat_entity) != E_Variable)
+	break;
+      return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
+
+    case N_Selected_Component:
+      gnat_entity = Entity (Selector_Name (gnat_node));
+      return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
+
+    case N_Indexed_Component:
+      if (Has_Atomic_Components (Etype (Prefix (gnat_node))))
+	return true;
+
+      /* ... fall through ... */
+
+    case N_Explicit_Dereference:
+      return Is_Atomic (Etype (gnat_node));
+
+    default:
+      break;
     }
 
-  switch (kind)
+  return false;
+}
+
+/* Return true if GNAT_NODE references a Volatile_Full_Access entity.  */
+
+static bool
+node_has_volatile_full_access (Node_Id gnat_node)
+{
+  Entity_Id gnat_entity;
+
+  switch (Nkind (gnat_node))
     {
-    case N_Expanded_Name:
-    case N_Explicit_Dereference:
     case N_Identifier:
-    case N_Indexed_Component:
+    case N_Expanded_Name:
+      gnat_entity = Entity (gnat_node);
+      if (Ekind (gnat_entity) != E_Variable)
+	break;
+      return Is_Volatile_Full_Access (gnat_entity)
+	     || Is_Volatile_Full_Access (Etype (gnat_entity));
+
     case N_Selected_Component:
-      if (!Atomic_Sync_Required (gnat_node))
-	return false;
-      break;
+      gnat_entity = Entity (Selector_Name (gnat_node));
+      return Is_Volatile_Full_Access (gnat_entity)
+	     || Is_Volatile_Full_Access (Etype (gnat_entity));
+
+    case N_Indexed_Component:
+    case N_Explicit_Dereference:
+      return Is_Volatile_Full_Access (Etype (gnat_node));
 
     default:
-      return false;
+      break;
     }
 
-  /* Then, scan the parent to find out cases where the flag is irrelevant.  */
-  kind = Nkind (gnat_parent);
-  switch (kind)
+  return false;
+}
+
+/* Strip any type conversion on GNAT_NODE and return the result.  */
+
+static Node_Id
+gnat_strip_type_conversion (Node_Id gnat_node)
+{
+  Node_Kind kind = Nkind (gnat_node);
+
+  if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
+    gnat_node = Expression (gnat_node);
+
+  return gnat_node;
+}
+
+/* Return true if GNAT_NODE requires outer atomic access, i.e. atomic access
+   of an object of which GNAT_NODE is a component.  */
+
+static bool
+outer_atomic_access_required_p (Node_Id gnat_node)
+{
+  gnat_node = gnat_strip_type_conversion (gnat_node);
+
+  while (Nkind (gnat_node) == N_Indexed_Component
+	 || Nkind (gnat_node) == N_Selected_Component
+	 || Nkind (gnat_node) == N_Slice)
+    {
+      gnat_node = gnat_strip_type_conversion (Prefix (gnat_node));
+      if (node_has_volatile_full_access (gnat_node))
+	return true;
+    }
+
+  return false;
+}
+
+/* Return true if GNAT_NODE requires atomic access and set SYNC according to
+   the associated synchronization setting.  */
+
+static bool
+atomic_access_required_p (Node_Id gnat_node, bool *sync)
+{
+  const Node_Id gnat_parent = Parent (gnat_node);
+  unsigned char attr_id;
+  bool as_a_whole = true;
+
+  /* First, scan the parent to find out cases where the flag is irrelevant.  */
+  switch (Nkind (gnat_parent))
     {
     case N_Attribute_Reference:
       attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
       /* Do not mess up machine code insertions.  */
       if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
 	return false;
+
+      /* Nothing to do if we are the prefix of an attribute, since we do not
+	 want an atomic access for things like 'Size.  */
+
+      /* ... fall through ... */
+
+    case N_Reference:
+      /* The N_Reference node is like an attribute.  */
+      if (Prefix (gnat_parent) == gnat_node)
+	return false;
+      break;
+
+    case N_Indexed_Component:
+    case N_Selected_Component:
+    case N_Slice:
+      /* If we are the prefix, then the access is only partial.  */
+      if (Prefix (gnat_parent) == gnat_node)
+	as_a_whole = false;
       break;
 
     case N_Object_Renaming_Declaration:
-      /* Do not generate a function call as a renamed object.  */
+      /* Nothing to do for the identifier in an object renaming declaration,
+         the renaming itself does not need atomic access.  */
       return false;
 
     default:
       break;
     }
 
+  /* Then, scan the node to find the atomic object.  */
+  gnat_node = gnat_strip_type_conversion (gnat_node);
+
+  /* For Atomic itself, only reads and updates of the object as a whole require
+     atomic access (RM C.6 (15)).  But for Volatile_Full_Access, all reads and
+     updates require atomic access.  */
+  if (!(as_a_whole && node_is_atomic (gnat_node))
+      && !node_has_volatile_full_access (gnat_node))
+    return false;
+
+  /* If an outer atomic access will also be required, it cancels this one.  */
+  if (outer_atomic_access_required_p (gnat_node))
+    return false;
+
+  *sync = Atomic_Sync_Required (gnat_node);
+
   return true;
 }
 
@@ -3975,12 +4090,14 @@ create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
    GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
    If GNU_TARGET is non-null, this must be a function call on the RHS of a
    N_Assignment_Statement and the result is to be placed into that object.
-   If, in addition, ATOMIC_SYNC is true, then the assignment to GNU_TARGET
-   requires atomic synchronization.  */
+   If OUTER_ATOMIC_ACCESS is true, then the assignment to GNU_TARGET must be a
+   load-modify-store sequence.  Otherwise, if ATOMIC_ACCESS is true, then the
+   assignment to GNU_TARGET must be atomic.  If, in addition, ATOMIC_SYNC is
+   true, then the assignment to GNU_TARGET requires atomic synchronization.  */
 
 static tree
 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
-	     bool atomic_sync)
+	     bool outer_atomic_access, bool atomic_access, bool atomic_sync)
 {
   const bool function_call = (Nkind (gnat_node) == N_Function_Call);
   const bool returning_value = (function_call && !gnu_target);
@@ -4004,6 +4121,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
   bool pushed_binding_level = false;
   Entity_Id gnat_formal;
   Node_Id gnat_actual;
+  bool sync;
 
   gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
 
@@ -4248,13 +4366,13 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
       /* Start from the real object and build the actual.  */
       gnu_actual = gnu_name;
 
-      /* If this is an atomic access of an In or In Out parameter for which
-	 synchronization is required, build the atomic load.  */
+      /* If atomic access is required for an In or In Out actual parameter,
+	 build the atomic load.  */
       if (is_true_formal_parm
 	  && !is_by_ref_formal_parm
 	  && Ekind (gnat_formal) != E_Out_Parameter
-	  && atomic_sync_required_p (gnat_actual))
-	gnu_actual = build_atomic_load (gnu_actual);
+	  && atomic_access_required_p (gnat_actual, &sync))
+	gnu_actual = build_atomic_load (gnu_actual, sync);
 
       /* If this was a procedure call, we may not have removed any padding.
 	 So do it here for the part we will use as an input, if any.  */
@@ -4537,12 +4655,24 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 		  gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
 	      }
 
-	    if (atomic_sync_required_p (gnat_actual))
-	      gnu_result = build_atomic_store (gnu_actual, gnu_result);
+	    /* If an outer atomic access is required for an actual parameter,
+	       build the load-modify-store sequence.  */
+	    if (outer_atomic_access_required_p (gnat_actual))
+	      gnu_result
+		= build_load_modify_store (gnu_actual, gnu_result, gnat_node);
+
+	    /* Or else, if simple atomic access is required, build the atomic
+	       store.  */
+	    else if (atomic_access_required_p (gnat_actual, &sync))
+	      gnu_result = build_atomic_store (gnu_actual, gnu_result, sync);
+
+	    /* Otherwise build a regular assignment.  */
 	    else
 	      gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
 					    gnu_actual, gnu_result);
-	    set_expr_location_from_node (gnu_result, gnat_node);
+
+	    if (EXPR_P (gnu_result))
+	      set_expr_location_from_node (gnu_result, gnat_node);
 	    append_to_statement_list (gnu_result, &gnu_stmt_list);
 	    gnu_cico_list = TREE_CHAIN (gnu_cico_list);
 	    gnu_name_list = TREE_CHAIN (gnu_name_list);
@@ -4593,12 +4723,18 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	  else
 	    op_code = MODIFY_EXPR;
 
-	  if (atomic_sync)
-	    gnu_call = build_atomic_store (gnu_target, gnu_call);
+	  /* Use the required method to move the result to the target.  */
+	  if (outer_atomic_access)
+	    gnu_call
+	      = build_load_modify_store (gnu_target, gnu_call, gnat_node);
+	  else if (atomic_access)
+	    gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
 	  else
 	    gnu_call
 	      = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
-	  set_expr_location_from_node (gnu_call, gnat_parent);
+
+	  if (EXPR_P (gnu_call))
+	    set_expr_location_from_node (gnu_call, gnat_parent);
 	  append_to_statement_list (gnu_call, &gnu_stmt_list);
 	}
       else
@@ -5394,6 +5530,7 @@ gnat_to_gnu (Node_Id gnat_node)
   tree gnu_result_type = void_type_node;
   tree gnu_expr, gnu_lhs, gnu_rhs;
   Node_Id gnat_temp;
+  bool sync;
 
   /* Save node number for error message and set location information.  */
   error_gnat_node = gnat_node;
@@ -5456,11 +5593,10 @@ gnat_to_gnu (Node_Id gnat_node)
     case N_Defining_Identifier:
       gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
 
-      /* If this is an atomic access on the RHS for which synchronization is
-	 required, build the atomic load.  */
-      if (atomic_sync_required_p (gnat_node)
+      /* If atomic access is required on the RHS, build the atomic load.  */
+      if (atomic_access_required_p (gnat_node, &sync)
 	  && !present_in_lhs_or_actual_p (gnat_node))
-	gnu_result = build_atomic_load (gnu_result);
+	gnu_result = build_atomic_load (gnu_result, sync);
       break;
 
     case N_Integer_Literal:
@@ -5694,9 +5830,7 @@ gnat_to_gnu (Node_Id gnat_node)
 
       /* Don't do anything if this renaming is handled by the front end or if
 	 we are just annotating types and this object has a composite or task
-	 type, don't elaborate it.  We return the result in case it contains
-	 any SAVE_EXPRs that need to be evaluated here, but this cannot occur
-	 at the global level (see Renaming, case 2 in gnat_to_gnu_entity).  */
+	 type, don't elaborate it.  */
       if (!Is_Renaming_Of_Object (gnat_temp)
 	  && ! (type_annotate_only
 		&& (Is_Array_Type (Etype (gnat_temp))
@@ -5706,8 +5840,10 @@ gnat_to_gnu (Node_Id gnat_node)
 	  tree gnu_temp
 	    = gnat_to_gnu_entity (gnat_temp,
 				  gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
-	  if (!global_bindings_p ())
-	    gnu_result = gnu_temp;
+	  /* We need to make sure that the side-effects of the renamed object
+	     are evaluated at this point, so we evaluate its address.  */
+	  if (TREE_SIDE_EFFECTS (gnu_temp))
+	    gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
 	}
       break;
 
@@ -5721,8 +5857,8 @@ gnat_to_gnu (Node_Id gnat_node)
 	  tree gnu_temp
 	    = gnat_to_gnu_entity (gnat_temp,
 				  gnat_to_gnu (Renamed_Entity (gnat_temp)), 1);
-	  if (!global_bindings_p ())
-	    gnu_result = gnu_temp;
+	  if (TREE_SIDE_EFFECTS (gnu_temp))
+	    gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
 	}
       break;
 
@@ -5749,11 +5885,10 @@ gnat_to_gnu (Node_Id gnat_node)
       gnu_result_type = get_unpadded_type (Etype (gnat_node));
       gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
 
-      /* If this is an atomic access on the RHS for which synchronization is
-	 required, build the atomic load.  */
-      if (atomic_sync_required_p (gnat_node)
+      /* If atomic access is required on the RHS, build the atomic load.  */
+      if (atomic_access_required_p (gnat_node, &sync)
 	  && !present_in_lhs_or_actual_p (gnat_node))
-	gnu_result = build_atomic_load (gnu_result);
+	gnu_result = build_atomic_load (gnu_result, sync);
       break;
 
     case N_Indexed_Component:
@@ -5842,11 +5977,10 @@ gnat_to_gnu (Node_Id gnat_node)
 
 	gnu_result_type = get_unpadded_type (Etype (gnat_node));
 
-	/* If this is an atomic access on the RHS for which synchronization is
-	   required, build the atomic load.  */
-	if (atomic_sync_required_p (gnat_node)
+	/* If atomic access is required on the RHS, build the atomic load.  */
+	if (atomic_access_required_p (gnat_node, &sync)
 	    && !present_in_lhs_or_actual_p (gnat_node))
-	  gnu_result = build_atomic_load (gnu_result);
+	  gnu_result = build_atomic_load (gnu_result, sync);
       }
       break;
 
@@ -5985,11 +6119,10 @@ gnat_to_gnu (Node_Id gnat_node)
 
 	gnu_result_type = get_unpadded_type (Etype (gnat_node));
 
-	/* If this is an atomic access on the RHS for which synchronization is
-	   required, build the atomic load.  */
-	if (atomic_sync_required_p (gnat_node)
+	/* If atomic access is required on the RHS, build the atomic load.  */
+	if (atomic_access_required_p (gnat_node, &sync)
 	    && !present_in_lhs_or_actual_p (gnat_node))
-	  gnu_result = build_atomic_load (gnu_result);
+	  gnu_result = build_atomic_load (gnu_result, sync);
       }
       break;
 
@@ -6492,9 +6625,16 @@ gnat_to_gnu (Node_Id gnat_node)
 	gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
 				       N_Raise_Storage_Error);
       else if (Nkind (Expression (gnat_node)) == N_Function_Call)
-	gnu_result
-	  = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
-			 atomic_sync_required_p (Name (gnat_node)));
+	{
+	  bool outer_atomic_access
+	    = outer_atomic_access_required_p (Name (gnat_node));
+	  bool atomic_access
+	    = !outer_atomic_access
+	      && atomic_access_required_p (Name (gnat_node), &sync);
+	  gnu_result
+	    = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
+			   outer_atomic_access, atomic_access, sync);
+	}
       else
 	{
 	  const Node_Id gnat_expr = Expression (gnat_node);
@@ -6526,9 +6666,14 @@ gnat_to_gnu (Node_Id gnat_node)
 	    gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
 					gnat_node);
 
-	  /* If atomic synchronization is required, build an atomic store.  */
-	  if (atomic_sync_required_p (Name (gnat_node)))
-	    gnu_result = build_atomic_store (gnu_lhs, gnu_rhs);
+	  /* If an outer atomic access is required on the LHS, build the load-
+	     modify-store sequence.  */
+	  if (outer_atomic_access_required_p (Name (gnat_node)))
+	    gnu_result = build_load_modify_store (gnu_lhs, gnu_rhs, gnat_node);
+
+	  /* Or else, if atomic access is required, build the atomic store.  */
+	  else if (atomic_access_required_p (Name (gnat_node), &sync))
+	    gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, sync);
 
 	  /* Or else, use memset when the conditions are met.  */
 	  else if (use_memset_p)
@@ -6829,7 +6974,8 @@ gnat_to_gnu (Node_Id gnat_node)
 
     case N_Function_Call:
     case N_Procedure_Call_Statement:
-      gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE, false);
+      gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
+				false, false, false);
       break;
 
     /************************/
@@ -9174,9 +9320,9 @@ pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
 }
 
 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
-   some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting
-   of the associations that are from RECORD_TYPE.  If we see an internal
-   record, make a recursive call to fill it in as well.  */
+   some of which are from RECORD_TYPE.  Return a CONSTRUCTOR consisting of the
+   associations that are from RECORD_TYPE.  If we see an internal record, make
+   a recursive call to fill it in as well.  */
 
 static tree
 extract_values (tree values, tree record_type)