[Ada] Get rid of secondary stack for most calls returning tagged types

This eliminates the use of the secondary stack to return specific tagged
types from functions in calls that are not dispatching on result, which
comprises returning controlled types, by introducing thunks whose only
purpose is to move the result from the primary to the secondary stack
for primitive functions that are controlling on result, and referencing
them in the dispatch table in lieu of the primitive functions.

The implementation reuses the existing machinery of interface thunks and
thus creates another kind of thunks, secondary stack thunks, which only
perform a call to the primitive function and return the result.

gcc/ada/

	* einfo.ads (Has_Controlling_Result): Document new usage.
	(Is_Thunk): Document secondary stack thunks.
	(Returns_By_Ref): Adjust.
	* exp_ch6.adb (Caller_Known_Size): Return true for tagged types.
	(Expand_N_Extended_Return_Statement): Do not call Set_By_Ref.
	(Expand_Simple_Function_Return): For a BIP return with an Alloc_Form
	parameter, mark the node as returning on the secondary stack.
	Replace call to Is_Limited_Interface with Is_Limited_View.  Deal wit
	secondary stack thunks.  Do not call Set_By_Ref.  Optimize the case
	of a call to a function whose type also needs finalization.
	(Needs_BIP_Task_Actuals): Replace Thunk_Entity with Thunk_Target.
	(Needs_BIP_Finalization_Master): Cosmetic fixes.
	(Needs_BIP_Alloc_Form): Check No_Secondary_Stack restriction and
	return true for tagged types.
	* exp_ch7.adb (Transient Scope Management): Update description.
	* exp_disp.adb (Expand_Dispatching_Call): Always set Returns_By_Ref
	on designated type if the call is dispatching on result.  Tidy up.
	(Expand_Interface_Thunk): Change type of Thunk_Code from Node_Id to
	List_Id.  Change type of local variables from Node_Id to Entity_Id.
	Propagate Aliased_Present flag to create the formals and explicitly
	set Has_Controlling_Result to False.  Build a secondary stack thunk
	if necessary in the function case.
	(Expand_Secondary_Stack_Thunk): New function.
	(Make_Secondary_DT): Build secondary stack thunks if necessary.
	(Make_DT): Likewise.
	(Register_Predefined_Primitive): Likewise.
	(Register_Primitive): Likewise.
	* exp_util.ads (Is_Secondary_Stack_Thunk): Declare.
	(Thunk_Target): Likewise.
	* exp_util.adb (Is_Secondary_Stack_Thunk): New function.
	(Thunk_Target): Likewise.
	* fe.h (Is_Secondary_Stack_Thunk): Declare.
	(Thunk_Target): Likewise.
	* gen_il-fields.ads (Opt_Field_Enum): Remove By_Ref.
	* gen_il-gen-gen_nodes.adb (N_Simple_Return_Statement): Likewise.
	(N_Extended_Return_Statement): Likewise.
	* sem_ch6.adb (Analyze_Subprogram_Specification): Skip check for
	abstract return type in the thunk case.
	(Create_Extra_Formals): Replace Thunk_Entity with Thunk_Target.
	* sem_disp.adb (Check_Controlling_Formals): Skip in the thunk case.
	* sem_util.adb: Add use and with clauses for Exp_Ch6.
	(Compute_Returns_By_Ref): Do not process procedures and only set
	the flag for direct return by reference.
	(Needs_Secondary_Stack): Do not return true for specific tagged
	types and adjust comments accordingly.
	* sinfo.ads (By_Ref): Delete.
	(N_Simple_Return_Statement): Remove By_Ref.
	(N_Extended_Return_Statement): Likewise.
	* gcc-interface/ada-tree.h (TYPE_RETURN_UNCONSTRAINED_P): Delete.
	* gcc-interface/decl.cc (gnat_to_gnu_subprog_type): Do not use it.
	Return by direct reference if the return type needs the secondary
	stack as well as for secondary stack thunks.
	* gcc-interface/gigi.h (fntype_same_flags_p): Remove parameter.
	* gcc-interface/misc.cc (gnat_type_hash_eq): Adjust to above change.
	* gcc-interface/trans.cc (finalize_nrv): Replace test on
	TYPE_RETURN_UNCONSTRAINED_P with TYPE_RETURN_BY_DIRECT_REF_P.
	(Subprogram_Body_to_gnu): Do not call maybe_make_gnu_thunk for
	secondary stack thunks.
	(Call_to_gnu): Do not test TYPE_RETURN_UNCONSTRAINED_P.
	(gnat_to_gnu) <N_Simple_Return_Statement>: In the return by direct
	reference case, test for the presence of Storage_Pool on the node
	to build an allocator.
	(maybe_make_gnu_thunk): Deal with Thunk_Entity and Thunk_Target.
	* gcc-interface/utils.cc (fntype_same_flags_p): Remove parameter.

6 files changed, 66 insertions, 93 deletions

diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index ec52024..6d9639d 100644
--- a/gcc/ada/gcc-interface/ada-tree.h
+++ b/gcc/ada/gcc-interface/ada-tree.h
@@ -97,11 +97,6 @@ do {							 \
    an Ada array other than the first.  */
 #define TYPE_MULTI_ARRAY_P(NODE) TYPE_LANG_FLAG_1 (ARRAY_TYPE_CHECK (NODE))
 
-/* For FUNCTION_TYPE and METHOD_TYPE, nonzero if function returns an
-   unconstrained array or record type.  */
-#define TYPE_RETURN_UNCONSTRAINED_P(NODE) \
-  TYPE_LANG_FLAG_1 (FUNC_OR_METHOD_CHECK (NODE))
-
 /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this denotes
    a justified modular type (will only be true for RECORD_TYPE).  */
 #define TYPE_JUSTIFIED_MODULAR_P(NODE) \
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 318c3be..bbbb343 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -5807,7 +5807,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
   bool pure_flag = Is_Pure (gnat_subprog);
   bool return_by_direct_ref_p = false;
   bool return_by_invisi_ref_p = false;
-  bool return_unconstrained_p = false;
   bool incomplete_profile_p = false;
   int num;
 
@@ -5822,7 +5821,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 	   && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type)))
     {
       gnu_return_type = TREE_TYPE (gnu_type);
-      return_unconstrained_p = TYPE_RETURN_UNCONSTRAINED_P (gnu_type);
       return_by_direct_ref_p = TYPE_RETURN_BY_DIRECT_REF_P (gnu_type);
       return_by_invisi_ref_p = TREE_ADDRESSABLE (gnu_type);
     }
@@ -5838,38 +5836,16 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
       else
 	gnu_return_type = gnat_to_gnu_profile_type (gnat_return_type);
 
-      /* If this function returns by reference, make the actual return type
-	 the reference type and make a note of that.  */
-      if (Returns_By_Ref (gnat_subprog))
+      /* If this function returns by reference or on the secondary stack, make
+	 the actual return type the reference type and make a note of that.  */
+      if (Returns_By_Ref (gnat_subprog)
+	  || Needs_Secondary_Stack (gnat_return_type)
+	  || Is_Secondary_Stack_Thunk (gnat_subprog))
 	{
 	  gnu_return_type = build_reference_type (gnu_return_type);
 	  return_by_direct_ref_p = true;
 	}
 
-      /* If the return type is an unconstrained array type, the return value
-	 will be allocated on the secondary stack so the actual return type
-	 is the fat pointer type.  */
-      else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
-	{
-	  gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
-	  return_unconstrained_p = true;
-	}
-
-      /* This is the same unconstrained array case, but for a dummy type.  */
-      else if (TYPE_REFERENCE_TO (gnu_return_type)
-	       && TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_return_type)))
-	{
-	  gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
-	  return_unconstrained_p = true;
-	}
-
-      /* This is for the other types returned on the secondary stack.  */
-      else if (Needs_Secondary_Stack (gnat_return_type))
-	{
-	  gnu_return_type = build_reference_type (gnu_return_type);
-	  return_unconstrained_p = true;
-	}
-
       /* If the Mechanism is By_Reference, ensure this function uses the
 	 target's by-invisible-reference mechanism, which may not be the
 	 same as above (e.g. it might be passing an extra parameter).  */
@@ -5949,8 +5925,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 	}
 
       if (kind == E_Function)
-	Set_Mechanism (gnat_subprog, return_unconstrained_p
-				     || return_by_direct_ref_p
+	Set_Mechanism (gnat_subprog, return_by_direct_ref_p
 				     || return_by_invisi_ref_p
 				     ? By_Reference : By_Copy);
     }
@@ -5962,7 +5937,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
      Similarly, if the function returns an unconstrained type, then the
      function will allocate the return value on the secondary stack and
      thus calls to it cannot be CSE'ed, lest the stack be reclaimed.  */
-  if (VOID_TYPE_P (gnu_return_type) || return_unconstrained_p)
+  if (VOID_TYPE_P (gnu_return_type) || return_by_direct_ref_p)
     pure_flag = false;
 
   /* Loop over the parameters and get their associated GCC tree.  While doing
@@ -6250,7 +6225,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 	gnu_type = make_node (method_p ? METHOD_TYPE : FUNCTION_TYPE);
       TREE_TYPE (gnu_type) = gnu_return_type;
       TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
-      TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
       TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
       TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
     }
@@ -6267,7 +6241,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 		= TYPE_MAIN_VARIANT (gnu_basetype);
 	    }
 	  TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
-	  TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
 	  TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
 	  TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
 	  TYPE_CANONICAL (gnu_type) = gnu_type;
@@ -6289,13 +6262,11 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 	  /* GNU_TYPE may be shared since GCC hashes types.  Unshare it if it
 	     has a different TYPE_CI_CO_LIST or flags.  */
 	  if (!fntype_same_flags_p (gnu_type, gnu_cico_list,
-				    return_unconstrained_p,
 				    return_by_direct_ref_p,
 				    return_by_invisi_ref_p))
 	    {
 	      gnu_type = copy_type (gnu_type);
 	      TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
-	      TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
 	      TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
 	      TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
 	    }
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index bd559d1..6d70c30 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -547,7 +547,7 @@ extern int gnat_types_compatible_p (tree t1, tree t2);
 extern bool gnat_useless_type_conversion (tree expr);
 
 /* Return true if T, a {FUNCTION,METHOD}_TYPE, has the specified flags.  */
-extern bool fntype_same_flags_p (const_tree, tree, bool, bool, bool);
+extern bool fntype_same_flags_p (const_tree, tree, bool, bool);
 
 /* Create an expression whose value is that of EXPR,
    converted to type TYPE.  The TREE_TYPE of the value
diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc
index 2caa83f..7824ebf 100644
--- a/gcc/ada/gcc-interface/misc.cc
+++ b/gcc/ada/gcc-interface/misc.cc
@@ -684,7 +684,6 @@ gnat_type_hash_eq (const_tree t1, const_tree t2)
 {
   gcc_assert (FUNC_OR_METHOD_TYPE_P (t1) && TREE_CODE (t1) == TREE_CODE (t2));
   return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
-			      TYPE_RETURN_UNCONSTRAINED_P (t2),
 			      TYPE_RETURN_BY_DIRECT_REF_P (t2),
 			      TREE_ADDRESSABLE (t2));
 }
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index e80200e..8097a89 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -3725,7 +3725,7 @@ finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret
   data.result = DECL_RESULT (fndecl);
   data.gnat_ret = gnat_ret;
   data.visited = new hash_set<tree>;
-  if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
+  if (TYPE_RETURN_BY_DIRECT_REF_P (TREE_TYPE (fndecl)))
     func = finalize_nrv_unc_r;
   else
     func = finalize_nrv_r;
@@ -3902,6 +3902,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
 
   /* Try to create a bona-fide thunk and hand it over to the middle-end.  */
   if (Is_Thunk (gnat_subprog)
+      && !Is_Secondary_Stack_Thunk (gnat_subprog)
       && maybe_make_gnu_thunk (gnat_subprog, gnu_subprog))
     return;
 
@@ -5252,10 +5253,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	  gnu_result_type = TREE_TYPE (gnu_call);
 	}
 
-      /* If the function returns an unconstrained array or by direct reference,
-	 we have to dereference the pointer.  */
-      if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
-	  || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
+      /* If the function returns by direct reference, we have to dereference
+	 the pointer.  */
+      if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
 	gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
 
       if (gnu_target)
@@ -7439,52 +7439,58 @@ gnat_to_gnu (Node_Id gnat_node)
 	      gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
 
 	    /* If the function returns by direct reference, return a pointer
-	       to the return value.  */
-	    if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
-		|| By_Ref (gnat_node))
-	      gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
-
-	    /* Otherwise, if it returns an unconstrained array, we have to
-	       allocate a new version of the result and return it.  */
-	    else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
+	       to the return value, possibly after allocating it.  */
+	    if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
 	      {
-		gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
-
-		/* And find out whether this is a candidate for Named Return
-		   Value.  If so, record it.  */
-		if (optimize
-		    && !optimize_debug
-		    && !TYPE_CI_CO_LIST (gnu_subprog_type))
+		if (Present (Storage_Pool (gnat_node)))
 		  {
-		    tree ret_val = gnu_ret_val;
-
-		    /* Strip useless conversions around the return value.  */
-		    if (gnat_useless_type_conversion (ret_val))
-		      ret_val = TREE_OPERAND (ret_val, 0);
-
-		    /* Strip unpadding around the return value.  */
-		    if (TREE_CODE (ret_val) == COMPONENT_REF
-			&& TYPE_IS_PADDING_P
-			   (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
-		      ret_val = TREE_OPERAND (ret_val, 0);
-
-		    /* Now apply the test to the return value.  */
-		    if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
+		    gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
+
+		    /* And find out whether it is a candidate for Named Return
+		       Value.  If so, record it.  Note that we disable this NRV
+		       optimization when we're preserving the control flow as
+		       it entails hoisting the allocation done below.  */
+		    if (optimize
+			&& !optimize_debug
+			&& !TYPE_CI_CO_LIST (gnu_subprog_type))
 		      {
-			if (!f_named_ret_val)
-			  f_named_ret_val = BITMAP_GGC_ALLOC ();
-			bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
-			if (!f_gnat_ret)
-			  f_gnat_ret = gnat_node;
+			tree ret_val = gnu_ret_val;
+
+			/* Strip conversions around the return value.  */
+			if (gnat_useless_type_conversion (ret_val))
+			  ret_val = TREE_OPERAND (ret_val, 0);
+
+			/* Strip unpadding around the return value.  */
+			if (TREE_CODE (ret_val) == COMPONENT_REF
+			    && TYPE_IS_PADDING_P
+			      (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
+			  ret_val = TREE_OPERAND (ret_val, 0);
+
+			/* Now apply the test to the return value.  */
+			if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
+			  {
+			    if (!f_named_ret_val)
+			      f_named_ret_val = BITMAP_GGC_ALLOC ();
+			    bitmap_set_bit (f_named_ret_val,
+					    DECL_UID (ret_val));
+			    if (!f_gnat_ret)
+			      f_gnat_ret = gnat_node;
+			  }
 		      }
+
+		    gnu_ret_val
+		      = build_allocator (TREE_TYPE (gnu_ret_val),
+					 gnu_ret_val,
+					 TREE_TYPE (gnu_ret_obj),
+					 Procedure_To_Call (gnat_node),
+					 Storage_Pool (gnat_node),
+					 gnat_node,
+					 false);
 		  }
 
-		gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
-					       gnu_ret_val,
-					       TREE_TYPE (gnu_ret_obj),
-					       Procedure_To_Call (gnat_node),
-					       Storage_Pool (gnat_node),
-					       gnat_node, false);
+		else
+		  gnu_ret_val
+		    = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
 	      }
 
 	    /* Otherwise, if it returns by invisible reference, dereference
@@ -10670,7 +10676,8 @@ make_covariant_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
 static bool
 maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
 {
-  const Entity_Id gnat_target = Thunk_Entity (gnat_thunk);
+  /* We use the Thunk_Target to compute the properties of the thunk.  */
+  const Entity_Id gnat_target = Thunk_Target (gnat_thunk);
 
   /* Check that the first formal of the target is the only controlling one.  */
   Entity_Id gnat_formal = First_Formal (gnat_target);
@@ -10738,7 +10745,9 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
       indirect_offset = (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
     }
 
-  tree gnu_target = gnat_to_gnu_entity (gnat_target, NULL_TREE, false);
+  /* But we generate a call to the Thunk_Entity in the thunk.  */
+  tree gnu_target
+    = gnat_to_gnu_entity (Thunk_Entity (gnat_thunk), NULL_TREE, false);
 
   /* If the target is local, then thunk and target must have the same context
      because cgraph_node::expand_thunk can only forward the static chain.  */
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index c583aca..3aa810b 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -3841,11 +3841,10 @@ gnat_useless_type_conversion (tree expr)
 /* Return true if T, a {FUNCTION,METHOD}_TYPE, has the specified flags.  */
 
 bool
-fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p,
-		     bool return_by_direct_ref_p, bool return_by_invisi_ref_p)
+fntype_same_flags_p (const_tree t, tree cico_list, bool return_by_direct_ref_p,
+		     bool return_by_invisi_ref_p)
 {
   return TYPE_CI_CO_LIST (t) == cico_list
-	 && TYPE_RETURN_UNCONSTRAINED_P (t) == return_unconstrained_p
 	 && TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p
 	 && TREE_ADDRESSABLE (t) == return_by_invisi_ref_p;
 }