[COMMITTED 26/31] ada: Fix strict aliasing violation in parameter passing

["Marc Poulhiès" <poulhies@adacore.com>]

From: Eric Botcazou <ebotcazou@adacore.com>

This fixes a long-standing (implicit) violation of the strict aliasing rules
that occurs when the result of a call to an instance of Unchecked_Conversion
is directly passed as an actual parameter in a call to a subprogram and the
passing mechanism is by reference.  In this case, the reference passed to
the subprogram may be to a type that has nothing to do with the type of the
underlying object, which is the definition of such a violation.

This implements the following two-pronged approach: first, the problematic
cases are detected and a reference to a temporary is passed instead of the
direct reference to the underlying object; second, the implementation of
pragma Universal_Aliasing is enhanced so that it is propagated from the
component type of an array type to the array type itself, or else can be
applied to the array type directly, and may therefore be used to prevent
the violation from occurring in the first place, when the array type is
involved in the Unchecked_Conversion.

gcc/ada/

	* gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Array_Type>: Set
	TYPE_TYPELESS_STORAGE on the array types if Universal_Aliasing is
	set on the type or its component type.
	<E_Array_Subtype>: Likewise.
	For other aggregate types, set TYPE_TYPELESS_STORAGE in this case.
	(set_typeless_storage_on_aggregate_type): New function.
	(set_universal_aliasing_on_type): Likewise.
	* gcc-interface/trans.cc (Call_to_gnu): Add const to local variable.
	Adjust comment.  Pass GNAT_NAME in the call to addressable_p and add
	a bypass for atomic types in case it returns false.
	(addressable_p): Add GNAT_EXPR third parameter with default value
	and add a default value to the existing second parameter.
	<VIEW_CONVERT_EXPR:>: Return false if the expression comes from a
	function call and if the alias sets of source and target types are
	both distinct from zero and each other.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/gcc-interface/decl.cc  | 40 ++++++++++++++++++++++-
 gcc/ada/gcc-interface/trans.cc | 60 ++++++++++++++++++++++++----------
 2 files changed, 82 insertions(+), 18 deletions(-)

diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 0987d534e69..ab54d2ccf13 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -205,6 +205,8 @@ static Entity_Id Gigi_Cloned_Subtype (Entity_Id);
 static tree gnu_ext_name_for_subprog (Entity_Id, tree);
 static void set_nonaliased_component_on_array_type (tree);
 static void set_reverse_storage_order_on_array_type (tree);
+static void set_typeless_storage_on_aggregate_type (tree);
+static void set_universal_aliasing_on_type (tree);
 static bool same_discriminant_p (Entity_Id, Entity_Id);
 static bool array_type_has_nonaliased_component (tree, Entity_Id);
 static bool compile_time_known_address_p (Node_Id);
@@ -2385,6 +2387,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 	      set_reverse_storage_order_on_array_type (tem);
 	    if (array_type_has_nonaliased_component (tem, gnat_entity))
 	      set_nonaliased_component_on_array_type (tem);
+	    if (Universal_Aliasing (gnat_entity)
+	        || Universal_Aliasing (Component_Type (gnat_entity)))
+	      set_typeless_storage_on_aggregate_type (tem);
 	  }
 
 	/* If this is a packed type implemented specially, then process the
@@ -2790,6 +2795,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 		set_reverse_storage_order_on_array_type (gnu_type);
 	      if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
 		set_nonaliased_component_on_array_type (gnu_type);
+	      if (Universal_Aliasing (gnat_entity)
+		  || Universal_Aliasing (Component_Type (gnat_entity)))
+		set_typeless_storage_on_aggregate_type (gnu_type);
 
 	      /* Clear the TREE_OVERFLOW flag, if any, for null arrays.  */
 	      if (gnu_null_ranges[index])
@@ -4757,7 +4765,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 
 	  /* Record whether a pragma Universal_Aliasing was specified.  */
 	  if (Universal_Aliasing (gnat_entity) && !TYPE_IS_DUMMY_P (gnu_type))
-	    TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1;
+	    {
+	      /* Set TYPE_TYPELESS_STORAGE if this is an aggregate type and
+		 TYPE_UNIVERSAL_ALIASING_P otherwise, since the former is not
+		 available in the latter case  Both will effectively put alias
+		 set 0 on the type, but the former is more robust because it
+		 will be streamed in LTO mode.  */
+	      if (AGGREGATE_TYPE_P (gnu_type))
+		set_typeless_storage_on_aggregate_type (gnu_type);
+	      else
+		set_universal_aliasing_on_type (gnu_type);
+	    }
 
 	  /* If it is passed by reference, force BLKmode to ensure that
 	     objects of this type will always be put in memory.  */
@@ -6641,6 +6659,26 @@ set_reverse_storage_order_on_array_type (tree type)
     TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type)) = 1;
 }
 
+/* Set TYPE_TYPELESS_STORAGE on an aggregate type.  */
+
+static void
+set_typeless_storage_on_aggregate_type (tree type)
+{
+  TYPE_TYPELESS_STORAGE (type) = 1;
+  if (TYPE_CANONICAL (type))
+    TYPE_TYPELESS_STORAGE (TYPE_CANONICAL (type)) = 1;
+}
+
+/* Set TYPE_UNIVERSAL_ALIASING_P on a type.  */
+
+static void
+set_universal_aliasing_on_type (tree type)
+{
+  TYPE_UNIVERSAL_ALIASING_P (type) = 1;
+  if (TYPE_CANONICAL (type))
+    TYPE_UNIVERSAL_ALIASING_P (TYPE_CANONICAL (type)) = 1;
+}
+
 /* Return true if DISCR1 and DISCR2 represent the same discriminant.  */
 
 static bool
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 6f761766559..a6b86ec8b51 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -254,7 +254,8 @@ static tree emit_check (tree, tree, int, Node_Id);
 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
 static tree convert_with_check (Entity_Id, tree, bool, bool, Node_Id);
-static bool addressable_p (tree, tree);
+static bool addressable_p (tree gnu_expr, tree gnu_type = NULL_TREE,
+			   Node_Id gnat_expr = Empty);
 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 static tree pos_to_constructor (Node_Id, tree);
 static void validate_unchecked_conversion (Node_Id);
@@ -4845,7 +4846,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
        gnat_formal = Next_Formal_With_Extras (gnat_formal),
        gnat_actual = Next_Actual (gnat_actual))
     {
-      Entity_Id gnat_formal_type = Etype (gnat_formal);
+      const Entity_Id gnat_formal_type = Etype (gnat_formal);
       tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
       tree gnu_formal = present_gnu_tree (gnat_formal)
 			? get_gnu_tree (gnat_formal) : NULL_TREE;
@@ -4861,10 +4862,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	 because we need the real object in this case, either to pass its
 	 address if it's passed by reference or as target of the back copy
 	 done after the call if it uses the copy-in/copy-out mechanism.
-	 We do it in the In case too, except for an unchecked conversion
-	 to an elementary type or a constrained composite type because it
-	 alone can cause the actual to be misaligned and the addressability
-	 test is applied to the real object.  */
+	 We do it in the In case too, except for a formal passed by reference
+	 and an actual which is an unchecked conversion to an elementary type
+	 or constrained composite type because it itself can cause the actual
+	 to be misaligned or the strict aliasing rules to be violated and the
+	 addressability test needs to be applied to the real object.  */
       const bool suppress_type_conversion
 	= ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
 	    && (!in_param
@@ -4894,7 +4896,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	 out after the call.  */
       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, gnat_name))
 	{
 	  tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
 
@@ -4903,6 +4905,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	  if (TREE_CODE (remove_conversions (gnu_name, true)) == CONSTRUCTOR)
 	    ;
 
+	  /* Likewise for an atomic type, which is defined to be by-reference
+	     if it is not by-copy but actually behaves more like a scalar.  */
+	  else if (TYPE_ATOMIC (gnu_formal_type))
+	    ;
+
 	  /* If the formal is passed by reference, a copy is not allowed.  */
 	  else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type)
 		   || Is_Aliased (gnat_formal))
@@ -10061,7 +10068,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
    unless it is an expression involving computation or if it involves a
    reference to a bitfield or to an object not sufficiently aligned for
    its type.  If GNU_TYPE is non-null, return true only if GNU_EXPR can
-   be directly addressed as an object of this type.
+   be directly addressed as an object of this type.  GNAT_EXPR is the
+   GNAT expression that has been translated into GNU_EXPR.
 
    *** Notes on addressability issues in the Ada compiler ***
 
@@ -10118,7 +10126,7 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
    generated to connect everything together.  */
 
 static bool
-addressable_p (tree gnu_expr, tree gnu_type)
+addressable_p (tree gnu_expr, tree gnu_type, Node_Id gnat_expr)
 {
   /* For an integral type, the size of the actual type of the object may not
      be greater than that of the expected type, otherwise an indirect access
@@ -10184,8 +10192,8 @@ addressable_p (tree gnu_expr, tree gnu_type)
     case COND_EXPR:
       /* We accept &COND_EXPR as soon as both operands are addressable and
 	 expect the outcome to be the address of the selected operand.  */
-      return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
-	      && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
+      return (addressable_p (TREE_OPERAND (gnu_expr, 1))
+	      && addressable_p (TREE_OPERAND (gnu_expr, 2)));
 
     case COMPONENT_REF:
       return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
@@ -10200,22 +10208,40 @@ addressable_p (tree gnu_expr, tree gnu_type)
 		       >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
 	       /* The field of a padding record is always addressable.  */
 	       || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
-	      && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
+	      && addressable_p (TREE_OPERAND (gnu_expr, 0)));
 
     case ARRAY_REF:  case ARRAY_RANGE_REF:
     case REALPART_EXPR:  case IMAGPART_EXPR:
     case NOP_EXPR:
-      return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
+      return addressable_p (TREE_OPERAND (gnu_expr, 0));
 
     case CONVERT_EXPR:
       return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
-	      && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
+	      && addressable_p (TREE_OPERAND (gnu_expr, 0)));
 
     case VIEW_CONVERT_EXPR:
       {
-	/* This is addressable if we can avoid a copy.  */
-	tree type = TREE_TYPE (gnu_expr);
 	tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
+	tree type = TREE_TYPE (gnu_expr);
+	alias_set_type inner_set, set;
+
+	/* Taking the address of a VIEW_CONVERT_EXPR of an expression violates
+	   strict aliasing rules if the source and target types are unrelated.
+	   This would happen in an Ada program that itself does *not* contain
+	   such a violation, through type punning done by means of an instance
+	   of Unchecked_Conversion.  Detect this case and force a temporary to
+	   prevent the violation from occurring, which is always allowed by
+	   the semantics of function calls in Ada, unless the source type or
+	   the target type have alias set 0, i.e. may alias anything.  */
+	if (Present (gnat_expr)
+	    && Nkind (gnat_expr) == N_Unchecked_Type_Conversion
+	    && Nkind (Original_Node (gnat_expr)) == N_Function_Call
+	    && (inner_set = get_alias_set (inner_type)) != 0
+	    && (set = get_alias_set (type)) != 0
+	    && inner_set != set)
+	  return false;
+
+	/* Otherwise this is addressable if we can avoid a copy.  */
 	return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
 		  && (!STRICT_ALIGNMENT
 		      || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
@@ -10227,7 +10253,7 @@ addressable_p (tree gnu_expr, tree gnu_type)
 			 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
 			 || TYPE_ALIGN_OK (type)
 			 || TYPE_ALIGN_OK (inner_type))))
-		&& addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
+		&& addressable_p (TREE_OPERAND (gnu_expr, 0)));
       }
 
     default:
-- 
2.43.2