trans.c (call_to_gnu): Return an expression with a COMPOUND_EXPR including the call instead of...

2007-04-06  Olivier Hainque  <hainque@adacore.com>
	    Eric Botcazou <botcazou@adacore.com>

	* trans.c (call_to_gnu) <TYPE_RETURNS_BY_TARGET_PTR_P>: Return an
	expression with a COMPOUND_EXPR including the call instead of emitting
	the call directly here.
	(gnat_to_gnu) <N_Slice>: Do not return a non-constant low bound if the
	high bound is constant and the slice is empty.  Tidy.
	(tree_transform, case N_Op_Not): Handle properly the case where the
	operation applies to a private type whose full view is a modular type.
	(Case_Statement_To_gnu): If an alternative is an E_Constant with an
	Address_Clause, use the associated Expression as the GNAT tree
	representing the choice value to ensure the corresponding GCC tree is
	of the proper kind.
	(maybe_stabilize_reference): Stabilize COMPOUND_EXPRs as a whole
	instead of just the operands, as the base GCC stabilize_reference does.
	<CALL_EXPR>: New case. Directly stabilize the call if an lvalue is not
	requested; otherwise fail.
	(addressable_p) <COMPONENT_REF>: Do not test DECL_NONADDRESSABLE_P.

From-SVN: r123608

gcc/ada/trans.c

@@ -288,7 +288,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
 /* Perform initializations for this module.  */
 
 void
-gnat_init_stmt_group ()
+gnat_init_stmt_group (void)
 {
   /* Initialize ourselves.  */
   init_code_table ();
@@ -1172,8 +1172,7 @@ Case_Statement_to_gnu (Node_Id gnat_node)
 	    case N_Identifier:
 	    case N_Expanded_Name:
 	      /* This represents either a subtype range or a static value of
-		 some kind; Ekind says which.  If a static value, fall through
-		 to the next case.  */
+		 some kind; Ekind says which.  */
 	      if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
 		{
 		  tree gnu_type = get_unpadded_type (Entity (gnat_choice));
@@ -1182,6 +1181,29 @@ Case_Statement_to_gnu (Node_Id gnat_node)
 		  gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
 		  break;
 		}
+	      /* Static values are handled by the next case to which we'll
+		 fallthrough.  If this is a constant with an address clause
+		 attached, we need to get to the initialization expression
+		 first, as the GCC tree for the entity might happen to be an
+		 INDIRECT_REF otherwise.  */
+	      else if (Ekind (Entity (gnat_choice)) == E_Constant
+		       && Present (Address_Clause (Entity (gnat_choice))))
+		{
+		  /* We might have a deferred constant with an address clause
+		     on either the incomplete or the full view.  While the
+		     Address_Clause is always attached to the visible entity,
+		     as tested above, the static value is the Expression
+		     attached to the the declaration of the entity or of its
+		     full view if any.  */
+
+		  Entity_Id gnat_constant = Entity (gnat_choice);
+
+		  if (Present (Full_View (gnat_constant)))
+		    gnat_constant = Full_View (gnat_constant);
+
+		  gnat_choice
+		    = Expression (Declaration_Node (gnat_constant));
+		}
 
 	      /* ... fall through ... */
 
@@ -1996,14 +2018,43 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
 				      gnu_subprog_addr,
 				      nreverse (gnu_actual_list));
 
-  /* If we return by passing a target, we emit the call and return the target
-     as our result.  */
+  /* If we return by passing a target, the result is the target after the
+     call.  We must not emit the call directly here because this might be
+     evaluated as part of an expression with conditions to control whether
+     the call should be emitted or not.  */
   if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
     {
-      add_stmt_with_node (gnu_subprog_call, gnat_node);
-      *gnu_result_type_p
+      /* Conceptually, what we need is a COMPOUND_EXPR with the call followed
+	 by the target object converted to the proper type.  Doing so would
+	 potentially be very inefficient, however, as this expresssion might
+	 end up wrapped into an outer SAVE_EXPR later on, which would incur a
+	 pointless temporary copy of the whole object.
+
+	 What we do instead is build a COMPOUND_EXPR returning the address of
+	 the target, and then dereference.  Wrapping the COMPOUND_EXPR into a
+	 SAVE_EXPR later on then only incurs a pointer copy.  */
+
+      tree gnu_result_type
 	= TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
-      return unchecked_convert (*gnu_result_type_p, gnu_target, false);
+
+      /* Build and return
+	 (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target]  */
+
+      tree gnu_target_address
+	= build_unary_op (ADDR_EXPR, NULL_TREE, gnu_target);
+
+      gnu_result
+	= build2 (COMPOUND_EXPR, TREE_TYPE (gnu_target_address),
+		  gnu_subprog_call, gnu_target_address);
+
+      gnu_result
+	= unchecked_convert (gnu_result_type,
+			     build_unary_op (INDIRECT_REF, NULL_TREE,
+					     gnu_result),
+			     false);
+
+      *gnu_result_type_p = gnu_result_type;
+      return gnu_result;
     }
 
   /* If it is a function call, the result is the call expression unless
@@ -3032,65 +3083,73 @@ gnat_to_gnu (Node_Id gnat_node)
 
     case N_Slice:
       {
-        tree gnu_type;
-        Node_Id gnat_range_node = Discrete_Range (gnat_node);
+	tree gnu_type;
+	Node_Id gnat_range_node = Discrete_Range (gnat_node);
 
-        gnu_result = gnat_to_gnu (Prefix (gnat_node));
-        gnu_result_type = get_unpadded_type (Etype (gnat_node));
+	gnu_result = gnat_to_gnu (Prefix (gnat_node));
+	gnu_result_type = get_unpadded_type (Etype (gnat_node));
 
 	/* Do any implicit dereferences of the prefix and do any needed
 	   range check.  */
-        gnu_result = maybe_implicit_deref (gnu_result);
-        gnu_result = maybe_unconstrained_array (gnu_result);
-        gnu_type = TREE_TYPE (gnu_result);
-        if (Do_Range_Check (gnat_range_node))
-          {
-            /* Get the bounds of the slice. */
+	gnu_result = maybe_implicit_deref (gnu_result);
+	gnu_result = maybe_unconstrained_array (gnu_result);
+	gnu_type = TREE_TYPE (gnu_result);
+	if (Do_Range_Check (gnat_range_node))
+	  {
+	    /* Get the bounds of the slice.  */
 	    tree gnu_index_type
 	      = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
-            tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
-            tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
-            tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
-
-            /* Check to see that the minimum slice value is in range */
-            gnu_expr_l
-	      = emit_index_check
-		(gnu_result, gnu_min_expr,
-		 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
-		 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
-
-            /* Check to see that the maximum slice value is in range */
-            gnu_expr_h
-	      = emit_index_check
-		(gnu_result, gnu_max_expr,
-		 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
-		 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
-
-            /* Derive a good type to convert everything too */
-            gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
-
-            /* Build a compound expression that does the range checks */
-            gnu_expr
-              = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
-                                 convert (gnu_expr_type, gnu_expr_h),
-                                 convert (gnu_expr_type, gnu_expr_l));
-
-            /* Build a conditional expression that returns the range checks
-               expression if the slice range is not null (max >= min) or
-               returns the min if the slice range is null */
-            gnu_expr
-              = fold_build3 (COND_EXPR, gnu_expr_type,
-			     build_binary_op (GE_EXPR, gnu_expr_type,
-					      convert (gnu_expr_type,
-						       gnu_max_expr),
-					      convert (gnu_expr_type,
-						       gnu_min_expr)),
-			     gnu_expr, gnu_min_expr);
-          }
-        else
-          gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
+	    tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
+	    tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
+	    /* Get the permitted bounds.  */
+	    tree gnu_base_index_type
+	      = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
+	    tree gnu_base_min_expr = TYPE_MIN_VALUE (gnu_base_index_type);
+	    tree gnu_base_max_expr = TYPE_MAX_VALUE (gnu_base_index_type);
+	    tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
+
+	    /* Check to see that the minimum slice value is in range.  */
+	    gnu_expr_l = emit_index_check (gnu_result,
+					   gnu_min_expr,
+					   gnu_base_min_expr,
+					   gnu_base_max_expr);
+
+	    /* Check to see that the maximum slice value is in range.  */
+	    gnu_expr_h = emit_index_check (gnu_result,
+					   gnu_max_expr,
+					   gnu_base_min_expr,
+					   gnu_base_max_expr);
+
+	    /* Derive a good type to convert everything to.  */
+	    gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
+
+	    /* Build a compound expression that does the range checks and
+	       returns the low bound.  */
+	    gnu_expr = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
+					convert (gnu_expr_type, gnu_expr_h),
+					convert (gnu_expr_type, gnu_expr_l));
+
+	   /* Build a conditional expression that does the range check and
+	      returns the low bound if the slice is not empty (max >= min),
+	      and returns the naked low bound otherwise (max < min), unless
+	      it is non-constant and the high bound is; this prevents VRP
+	      from inferring bogus ranges on the unlikely path.  */
+	    gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
+				    build_binary_op (GE_EXPR, gnu_expr_type,
+						     convert (gnu_expr_type,
+							      gnu_max_expr),
+						     convert (gnu_expr_type,
+							      gnu_min_expr)),
+				    gnu_expr,
+				    TREE_CODE (gnu_min_expr) != INTEGER_CST
+				    && TREE_CODE (gnu_max_expr) == INTEGER_CST
+				    ? gnu_max_expr : gnu_min_expr);
+	  }
+	else
+	  /* Simply return the naked low bound.  */
+	  gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
 
-        gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
+	gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
 				      gnu_result, gnu_expr);
       }
       break;
@@ -3487,7 +3546,9 @@ gnat_to_gnu (Node_Id gnat_node)
       /* This case can apply to a boolean or a modular type.
 	 Fall through for a boolean operand since GNU_CODES is set
 	 up to handle this.  */
-      if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
+      if (Is_Modular_Integer_Type (Etype (gnat_node))
+	  || (Ekind (Etype (gnat_node)) == E_Private_Type
+	      && Is_Modular_Integer_Type (Full_View (Etype (gnat_node)))))
 	{
 	  gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
 	  gnu_result_type = get_unpadded_type (Etype (gnat_node));
@@ -4473,7 +4534,7 @@ insert_code_for (Node_Id gnat_node)
 /* Start a new statement group chained to the previous group.  */
 
 static void
-start_stmt_group ()
+start_stmt_group (void)
 {
   struct stmt_group *group = stmt_group_free_list;
 
@@ -4633,7 +4694,7 @@ set_block_for_group (tree gnu_block)
    BLOCK or cleanups were set.  */
 
 static tree
-end_stmt_group ()
+end_stmt_group (void)
 {
   struct stmt_group *group = current_stmt_group;
   tree gnu_retval = group->stmt_list;
@@ -5633,12 +5694,12 @@ addressable_p (tree gnu_expr)
     case COMPONENT_REF:
       return (!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
 	      && (!STRICT_ALIGNMENT
-	          /* If the field was marked as "semantically" addressable
-		     in create_field_decl, we are guaranteed that it can
-		     be directly addressed.  */
-		  || !DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr, 1))
-		  /* Otherwise it can nevertheless be directly addressed
-		     if it has been sufficiently aligned in the record.  */
+		  /* Even with DECL_BIT_FIELD cleared, we have to ensure that
+		     the field is sufficiently aligned, in case it is subject
+		     to a pragma Component_Alignment.  But we don't need to
+		     check the alignment of the containing record, as it is
+		     guaranteed to be not smaller than that of its most
+		     aligned field that is not a bit-field.  */
 		  || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
 		       >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))
 	      && addressable_p (TREE_OPERAND (gnu_expr, 0)));
@@ -6004,8 +6065,8 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
 
     case ADDR_EXPR:
       /*  A standalone ADDR_EXPR is never an lvalue, and this one can't
-	  be nested inside an outer INDIRECT_REF, since INDIREC_REF goes
-	  straight to stabilize_1.  */
+	  be nested inside an outer INDIRECT_REF, since INDIRECT_REF goes
+	  straight to gnat_stabilize_reference_1.  */
       if (lvalues_only)
 	goto failure;
 
@@ -6057,11 +6118,17 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
       break;
 
     case COMPOUND_EXPR:
-      result = build2 (COMPOUND_EXPR, type,
-		       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
-						   force),
-		       maybe_stabilize_reference (TREE_OPERAND (ref, 1), force,
-						  lvalues_only, success));
+      result = gnat_stabilize_reference_1 (ref, force);
+      break;
+
+    case CALL_EXPR:
+      if (lvalues_only)
+	goto failure;
+
+      /* This generates better code than the scheme in protect_multiple_eval
+	 because large objects will be returned via invisible reference in
+	 most ABIs so the temporary will directly be filled by the callee.  */
+      result = gnat_stabilize_reference_1 (ref, force);
       break;
 
     case ERROR_MARK: