public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-638] [Ada] Get rid of secondary stack for controlled components
@ 2022-05-19 14:06 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-19 14:06 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:c697f593f47490b1d3b061ae76ba728bfa2ff372
commit r13-638-gc697f593f47490b1d3b061ae76ba728bfa2ff372
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Sun Apr 10 00:47:48 2022 +0200
[Ada] Get rid of secondary stack for controlled components
This eliminates the use of the secondary stack to return composite types
with controlled components from functions, by exposing the return slot of
these functions through the support interface of memory pools, much like
for the secondary stack itself. This is piggybacked on the support of a
specific intrinsic function by the code generator, and can be disabled if
this support is not available, as well with the -gnatd_r debug switch.
The change also streamlines a bit the implementation by consistently using
the Needs_Finalization predicate, or its derivatives, in various places.
gcc/ada/
* Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-retsta.
* debug.adb (d_r): Document usage.
* exp_ch4.adb (Expand_N_Allocato): Deal with the return stack pool.
* exp_ch6.adb (Expand_Simple_Function_Return): Replace calls to
Requires_Transient_Scope with Returns_On_Secondary_Stack. Deal
with types that need finalization returned on the primary stack,
use CW_Or_Needs_Finalization for those returned on the secondary.
* exp_util.adb (Build_Allocate_Deallocate_Proc): Return early
for the return stack pool.
(Remove_Side_Effects): Call CW_Or_Needs_Finalization.
* fe.h (Requires_Transient_Scope): Delete.
(Returns_On_Secondary_Stack): Declare.
* gnat1drv.adb (Adjust_Global_Switches): Set Back_End_Return_Slot
to False when generating C code or if -gnatd_r is specified.
* opt.ads (Back_End_Return_Slot): New boolean variable.
* rtsfind.ads (RTU_Id): Add System_Return_Stack.
(RE_Id): Add RE_RS_Allocate and RE_RS_Pool.
(RE_Unit_Table): Add entries for RE_RS_Allocate and RE_RS_Pool.
* sem_util.ads (CW_Or_Has_Controlled_Part): Delete.
(CW_Or_Needs_Finalization): Declare.
(Requires_Transient_Scope): Adjust description.
(Returns_On_Secondary_Stack): Declare.
* sem_util.adb (Compute_Returns_By_Ref): Set Returns_By_Ref on types
which need finalization if they are returned on the secondary stack.
(CW_Or_Has_Controlled_Part): Rename to...
(CW_Or_Needs_Finalization): ...this.
(Requires_Transient_Scope): Move bulk of implementation to...
(Returns_On_Secondary_Stack): ...here. Return true for types which
need finalization only if the back-end return slot is not supported.
* libgnat/s-retsta.ads: New file.
* gcc-interface/ada-builtin-types.def (BT_FN_PTR_SSIZE): Define.
* gcc-interface/ada-builtins.def (return_slot): Likewise.
* gcc-interface/ada-tree.h (BUILT_IN_RETURN_SLOT): Likewise.
* gcc-interface/decl.cc (gnat_to_gnu_subprog_type): Replace call to
Requires_Transient_Scope with Returns_On_Secondary_Stack.
* gcc-interface/trans.cc (gnat_to_gnu) <N_Simple_Return_Statement>:
In the return by invisible reference, skip the copy if the source
is the same as the destination.
* gcc-interface/utils2.cc (build_call_alloc_dealloc_proc): Deal with
the return stack pool.
Diff:
---
gcc/ada/Makefile.rtl | 1 +
gcc/ada/debug.adb | 7 +-
gcc/ada/exp_ch4.adb | 5 +-
gcc/ada/exp_ch6.adb | 91 +++++++++++--
gcc/ada/exp_util.adb | 7 +-
gcc/ada/fe.h | 16 +--
gcc/ada/gcc-interface/ada-builtin-types.def | 3 +-
gcc/ada/gcc-interface/ada-builtins.def | 3 +-
gcc/ada/gcc-interface/ada-tree.h | 5 +-
gcc/ada/gcc-interface/decl.cc | 6 +-
gcc/ada/gcc-interface/trans.cc | 8 ++
gcc/ada/gcc-interface/utils2.cc | 41 +++++-
gcc/ada/gnat1drv.adb | 7 +
gcc/ada/libgnat/s-retsta.ads | 57 +++++++++
gcc/ada/opt.ads | 12 +-
gcc/ada/rtsfind.ads | 8 ++
gcc/ada/sem_util.adb | 192 ++++++++++++----------------
gcc/ada/sem_util.ads | 29 +++--
18 files changed, 334 insertions(+), 164 deletions(-)
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 7b84ee5bd37..ed3d33408d8 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -739,6 +739,7 @@ GNATRTL_NONTASKING_OBJS= \
s-regpat$(objext) \
s-resfil$(objext) \
s-restri$(objext) \
+ s-retsta$(objext) \
s-rident$(objext) \
s-rpc$(objext) \
s-scaval$(objext) \
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 8a0ba0213bb..a03c88d97f9 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -156,7 +156,7 @@ package body Debug is
-- d_o
-- d_p Ignore assertion pragmas for elaboration
-- d_q
- -- d_r
+ -- d_r Disable the use of the return slot in functions
-- d_s Stop elaboration checks on synchronous suspension
-- d_t In LLVM-based CCG, dump LLVM IR after transformations are done
-- d_u In LLVM-based CCG, dump flows
@@ -993,6 +993,11 @@ package body Debug is
-- semantics of invariants and postconditions in both the static and
-- dynamic elaboration models.
+ -- d_r The compiler does not make use of the return slot in the expansion
+ -- of functions returning a by-reference type. If this use is required
+ -- for these functions to return on the primary stack, then they are
+ -- changed to return on the secondary stack instead.
+
-- d_s The compiler stops the examination of a task body once it reaches
-- a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True
-- or Ada.Synchronous_Barriers.Wait_For_Release.
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index aa291569f3b..14e9b0e508e 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -4537,7 +4537,10 @@ package body Exp_Ch4 is
if Present (Pool) then
Set_Storage_Pool (N, Pool);
- if Is_RTE (Pool, RE_SS_Pool) then
+ if Is_RTE (Pool, RE_RS_Pool) then
+ Set_Procedure_To_Call (N, RTE (RE_RS_Allocate));
+
+ elsif Is_RTE (Pool, RE_SS_Pool) then
Check_Restriction (No_Secondary_Stack, N);
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 9ddbd8c20c3..e95c6c5b5a7 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -7325,10 +7325,9 @@ package body Exp_Ch6 is
-- A return statement from an ignored Ghost function does not use the
-- secondary stack (or any other one).
- elsif not Requires_Transient_Scope (R_Type)
+ elsif not Returns_On_Secondary_Stack (R_Type)
or else Is_Ignored_Ghost_Entity (Scope_Id)
then
-
-- Mutable records with variable-length components are not returned
-- on the sec-stack, so we need to make sure that the back end will
-- only copy back the size of the actual value, and not the maximum
@@ -7341,6 +7340,7 @@ package body Exp_Ch6 is
Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exp_Typ));
Decl : Node_Id;
Ent : Entity_Id;
+
begin
if not Exp_Is_Function_Call
and then Has_Discriminants (Ubt)
@@ -7355,6 +7355,72 @@ package body Exp_Ch6 is
end if;
end;
+ -- For types which need finalization, do the allocation on the return
+ -- stack manually in order to call Adjust at the right time:
+
+ -- type Ann is access R_Type;
+ -- for Ann'Storage_pool use rs_pool;
+ -- Rnn : Ann := new Exp_Typ'(Exp);
+ -- return Rnn.all;
+
+ -- but optimize the case where the result is a function call that
+ -- also needs finalization. In this case the result is already on
+ -- the return stack and no further processing is required.
+
+ if Present (Utyp)
+ and then Needs_Finalization (Utyp)
+ and then not (Nkind (Exp) = N_Function_Call
+ and then Needs_Finalization (Exp_Typ))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
+ Alloc_Node : Node_Id;
+ Temp : Entity_Id;
+
+ begin
+ Mutate_Ekind (Acc_Typ, E_Access_Type);
+
+ Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_RS_Pool));
+
+ -- This is an allocator for the return stack, and it's fine
+ -- to have Comes_From_Source set False on it, as gigi knows not
+ -- to flag it as a violation of No_Implicit_Heap_Allocations.
+
+ Alloc_Node :=
+ Make_Allocator (Loc,
+ Expression =>
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Occurrence_Of (Exp_Typ, Loc),
+ Expression => Relocate_Node (Exp)));
+
+ -- We do not want discriminant checks on the declaration,
+ -- given that it gets its value from the allocator.
+
+ Set_No_Initialization (Alloc_Node);
+
+ Temp := Make_Temporary (Loc, 'R', Alloc_Node);
+
+ Insert_Actions (Exp, New_List (
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Acc_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication => Subtype_Ind)),
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
+ Expression => Alloc_Node)));
+
+ Rewrite (Exp,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc)));
+
+ Analyze_And_Resolve (Exp, R_Type);
+ end;
+ end if;
+
-- Here if secondary stack is used
else
@@ -7372,8 +7438,8 @@ package body Exp_Ch6 is
-- wrong in the case of a controlled type, where gigi does not know
-- how to do a copy.)
- pragma Assert (Requires_Transient_Scope (R_Type));
- if Exp_Is_Function_Call and then Requires_Transient_Scope (Exp_Typ)
+ if Exp_Is_Function_Call
+ and then Returns_On_Secondary_Stack (Exp_Typ)
then
Set_By_Ref (N);
@@ -7393,19 +7459,20 @@ package body Exp_Ch6 is
Analyze_And_Resolve (Exp, R_Type);
- -- For controlled types, do the allocation on the secondary stack
- -- manually in order to call adjust at the right time:
+ -- For types which both need finalization and are returned on the
+ -- secondary stack, do the allocation on secondary stack manually
+ -- in order to call Adjust at the right time:
- -- type Anon1 is access R_Type;
- -- for Anon1'Storage_pool use ss_pool;
- -- Anon2 : anon1 := new R_Type'(expr);
- -- return Anon2.all;
+ -- type Ann is access R_Type;
+ -- for Ann'Storage_pool use ss_pool;
+ -- Rnn : Ann := new Exp_Typ'(Exp);
+ -- return Rnn.all;
- -- We do the same for classwide types that are not potentially
+ -- And we do the same for class-wide types that are not potentially
-- controlled (by the virtue of restriction No_Finalization) because
-- gigi is not able to properly allocate class-wide types.
- elsif CW_Or_Has_Controlled_Part (Utyp) then
+ elsif CW_Or_Needs_Finalization (Utyp) then
declare
Loc : constant Source_Ptr := Sloc (N);
Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 32c1ff7b7fd..31a2d5c3165 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -897,6 +897,11 @@ package body Exp_Util is
if No (Pool_Id) then
return;
+ -- Do not process allocations from the return stack
+
+ elsif Is_RTE (Pool_Id, RE_RS_Pool) then
+ return;
+
-- Do not process allocations on / deallocations from the secondary
-- stack, except for access types used to implement indirect temps.
@@ -12108,7 +12113,7 @@ package body Exp_Util is
elsif Nkind (Exp) = N_Unchecked_Type_Conversion
and then not Safe_Unchecked_Type_Conversion (Exp)
then
- if CW_Or_Has_Controlled_Part (Exp_Type) then
+ if CW_Or_Needs_Finalization (Exp_Type) then
-- Use a renaming to capture the expression, rather than create
-- a controlled temporary.
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index 33b48e6f3e5..4be9d94685e 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -298,14 +298,14 @@ extern Boolean Compile_Time_Known_Value (Node_Id);
#define Is_Expression_Function sem_util__is_expression_function
#define Is_Variable_Size_Record sem_util__is_variable_size_record
#define Next_Actual sem_util__next_actual
-#define Requires_Transient_Scope sem_util__requires_transient_scope
-
-extern Entity_Id Defining_Entity (Node_Id);
-extern Node_Id First_Actual (Node_Id);
-extern Boolean Is_Expression_Function (Entity_Id);
-extern Boolean Is_Variable_Size_Record (Entity_Id);
-extern Node_Id Next_Actual (Node_Id);
-extern Boolean Requires_Transient_Scope (Entity_Id);
+#define Returns_On_Secondary_Stack sem_util__returns_on_secondary_stack
+
+extern Entity_Id Defining_Entity (Node_Id);
+extern Node_Id First_Actual (Node_Id);
+extern Boolean Is_Expression_Function (Entity_Id);
+extern Boolean Is_Variable_Size_Record (Entity_Id);
+extern Node_Id Next_Actual (Node_Id);
+extern Boolean Returns_On_Secondary_Stack (Entity_Id);
/* sinfo: */
diff --git a/gcc/ada/gcc-interface/ada-builtin-types.def b/gcc/ada/gcc-interface/ada-builtin-types.def
index f00845b5f56..000d4290429 100644
--- a/gcc/ada/gcc-interface/ada-builtin-types.def
+++ b/gcc/ada/gcc-interface/ada-builtin-types.def
@@ -1,7 +1,7 @@
/* This file contains the type definitions for the builtins exclusively
used in the GNU Ada compiler.
- Copyright (C) 2019 Free Software Foundation, Inc.
+ Copyright (C) 2019-2022 Free Software Foundation, Inc.
This file is part of GCC.
@@ -22,4 +22,5 @@ along with GCC; see the file COPYING3. If not see
/* See builtin-types.def for details. */
DEF_FUNCTION_TYPE_1 (BT_FN_BOOL_BOOL, BT_BOOL, BT_BOOL)
+DEF_FUNCTION_TYPE_1 (BT_FN_PTR_SSIZE, BT_PTR, BT_SSIZE)
DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_BOOL_BOOL, BT_BOOL, BT_BOOL, BT_BOOL)
diff --git a/gcc/ada/gcc-interface/ada-builtins.def b/gcc/ada/gcc-interface/ada-builtins.def
index dcdc4d91891..8ba89a80e70 100644
--- a/gcc/ada/gcc-interface/ada-builtins.def
+++ b/gcc/ada/gcc-interface/ada-builtins.def
@@ -1,7 +1,7 @@
/* This file contains the definitions for the builtins exclusively used
in the GNU Ada compiler.
- Copyright (C) 2019 Free Software Foundation, Inc.
+ Copyright (C) 2019-2022 Free Software Foundation, Inc.
This file is part of GCC.
@@ -28,3 +28,4 @@ along with GCC; see the file COPYING3. If not see
DEF_ADA_BUILTIN (BUILT_IN_EXPECT, "expect", BT_FN_BOOL_BOOL_BOOL, ATTR_CONST_NOTHROW_LEAF_LIST)
DEF_ADA_BUILTIN (BUILT_IN_LIKELY, "likely", BT_FN_BOOL_BOOL, ATTR_CONST_NOTHROW_LEAF_LIST)
DEF_ADA_BUILTIN (BUILT_IN_UNLIKELY, "unlikely", BT_FN_BOOL_BOOL, ATTR_CONST_NOTHROW_LEAF_LIST)
+DEF_ADA_BUILTIN (BUILT_IN_RETURN_SLOT, "return_slot", BT_FN_PTR_SSIZE, ATTR_CONST_NOTHROW_LEAF_LIST)
diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index 0ec81bc541c..ca718f48c79 100644
--- a/gcc/ada/gcc-interface/ada-tree.h
+++ b/gcc/ada/gcc-interface/ada-tree.h
@@ -577,5 +577,6 @@ do { \
/* Small kludge to be able to define Ada built-in functions locally.
We overload them on top of the C++ coroutines builtin functions. */
-#define BUILT_IN_LIKELY BUILT_IN_CORO_PROMISE
-#define BUILT_IN_UNLIKELY BUILT_IN_CORO_RESUME
+#define BUILT_IN_LIKELY BUILT_IN_CORO_PROMISE
+#define BUILT_IN_UNLIKELY BUILT_IN_CORO_RESUME
+#define BUILT_IN_RETURN_SLOT BUILT_IN_CORO_DESTROY
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index e6f2df8f1ab..c096b0d08d3 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -5838,10 +5838,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
return_unconstrained_p = true;
}
- /* Likewise, if the return type requires a transient scope, the return
- value will also be allocated on the secondary stack so the actual
- return type is the reference type. */
- else if (Requires_Transient_Scope (gnat_return_type))
+ /* This is for the other types returned on the secondary stack. */
+ else if (Returns_On_Secondary_Stack (gnat_return_type))
{
gnu_return_type = build_reference_type (gnu_return_type);
return_unconstrained_p = true;
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 57a9dee0acc..b8a0d5d5d30 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -7456,6 +7456,14 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_ret_obj);
gnu_result = build2 (INIT_EXPR, void_type_node,
gnu_ret_deref, gnu_ret_val);
+ /* Avoid a useless copy with __builtin_return_slot. */
+ if (TREE_CODE (gnu_ret_val) == INDIRECT_REF)
+ gnu_result
+ = build3 (COND_EXPR, void_type_node,
+ fold_build2 (NE_EXPR, boolean_type_node,
+ TREE_OPERAND (gnu_ret_val, 0),
+ gnu_ret_obj),
+ gnu_result, NULL_TREE);
add_stmt_with_node (gnu_result, gnat_node);
gnu_ret_val = NULL_TREE;
}
diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
index 76622da8081..ae81a0d42a4 100644
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -2141,9 +2141,9 @@ build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
tree gnu_proc = gnat_to_gnu (gnat_proc);
tree gnu_call;
- /* A storage pool's underlying type is a record type (for both predefined
- storage pools and GNAT simple storage pools). The secondary stack uses
- the same mechanism, but its pool object (SS_Pool) is an integer. */
+ /* A storage pool's underlying type is a record type for both predefined
+ storage pools and GNAT simple storage pools. The return and secondary
+ stacks use the same mechanism, but their pool object is an integer. */
if (Is_Record_Type (Underlying_Type (Etype (gnat_pool))))
{
/* The size is the third parameter; the alignment is the
@@ -2170,7 +2170,6 @@ build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
gnu_size, gnu_align);
}
- /* Secondary stack case. */
else
{
/* The size is the second parameter. */
@@ -2180,10 +2179,42 @@ build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
gnu_size = convert (gnu_size_type, gnu_size);
+ if (DECL_BUILT_IN_CLASS (gnu_proc) == BUILT_IN_FRONTEND
+ && DECL_FE_FUNCTION_CODE (gnu_proc) == BUILT_IN_RETURN_SLOT)
+ {
+ /* This must be an allocation of the return stack in a function that
+ returns by invisible reference. */
+ gcc_assert (!gnu_obj);
+ gcc_assert (current_function_decl
+ && TREE_ADDRESSABLE (TREE_TYPE (current_function_decl)));
+ tree gnu_ret_size;
+
+ gnu_call = DECL_RESULT (current_function_decl);
+
+ /* The allocation has alreay been done by the caller so we check that
+ we are not going to overflow the return slot. */
+ if (TYPE_CI_CO_LIST (TREE_TYPE (current_function_decl)))
+ gnu_ret_size
+ = TYPE_SIZE_UNIT
+ (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (TREE_TYPE (gnu_call)))));
+ else
+ gnu_ret_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (gnu_call)));
+
+ gnu_call
+ = fold_build3 (COND_EXPR, TREE_TYPE (gnu_call),
+ fold_build2 (LE_EXPR, boolean_type_node,
+ fold_convert (sizetype, gnu_size),
+ gnu_ret_size),
+ gnu_call,
+ build_call_raise (PE_Explicit_Raise, Empty,
+ N_Raise_Program_Error));
+ }
+
/* The first arg is the address of the object, for a deallocator,
then the size. */
- if (gnu_obj)
+ else if (gnu_obj)
gnu_call = build_call_n_expr (gnu_proc, 2, gnu_obj, gnu_size);
+
else
gnu_call = build_call_n_expr (gnu_proc, 1, gnu_size);
}
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 79d58477f53..cd70a141e30 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -186,6 +186,7 @@ procedure Gnat1drv is
Building_Static_Dispatch_Tables := False;
Minimize_Expression_With_Actions := True;
Expand_Nonbinary_Modular_Ops := True;
+ Back_End_Return_Slot := False;
-- Set operating mode to Generate_Code to benefit from full front-end
-- expansion (e.g. generics).
@@ -726,6 +727,12 @@ procedure Gnat1drv is
Back_End_Handles_Limited_Types := False;
end if;
+ -- Return slot support is disabled if -gnatd_r is specified
+
+ if Debug_Flag_Underscore_R then
+ Back_End_Return_Slot := False;
+ end if;
+
-- If the inlining level has not been set by the user, compute it from
-- the optimization level: 1 at -O1/-O2 (and -Os), 2 at -O3 and above.
diff --git a/gcc/ada/libgnat/s-retsta.ads b/gcc/ada/libgnat/s-retsta.ads
new file mode 100644
index 00000000000..83403411052
--- /dev/null
+++ b/gcc/ada/libgnat/s-retsta.ads
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . R E T U R N _ S T A C K --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2022, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This small package provides direct access to the return stack of the code
+-- generator for functions returning a by-reference type. This return stack
+-- is the portion of the primary stack that has been allocated by callers of
+-- the functions and onto which the functions put the result before returning.
+
+with System.Storage_Elements;
+
+package System.Return_Stack is
+ pragma Preelaborate;
+
+ package SSE renames System.Storage_Elements;
+
+ procedure RS_Allocate
+ (Addr : out Address;
+ Storage_Size : SSE.Storage_Count);
+ pragma Import (Intrinsic, RS_Allocate, "__builtin_return_slot");
+ -- Allocate enough space on the return stack of the invoking task to
+ -- accommodate a return of size Storage_Size. Return the address of the
+ -- first byte of the allocation in Addr.
+
+private
+ RS_Pool : Integer;
+ -- Unused entity that is just present to ease the sharing of the pool
+ -- mechanism for specific allocation/deallocation in the compiler.
+
+end System.Return_Stack;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 9ea153aa07d..2ce24eec332 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -202,7 +202,7 @@ package Opt is
-- values.
Back_End_Handles_Limited_Types : Boolean;
- -- This flag is set true if the back end can properly handle limited or
+ -- This flag is set True if the back end can properly handle limited or
-- other by reference types, and avoid copies. If this flag is False, then
-- the front end does special expansion for if/case expressions to make
-- sure that no copy occurs. If the flag is True, then the expansion for
@@ -214,12 +214,20 @@ package Opt is
Back_End_Inlining : Boolean := False;
-- GNAT
-- Set True to activate inlining by back-end expansion. This is the normal
- -- default mode for gcc targets, so it is True on such targets unless the
+ -- default mode for GCC targets, so it is True on such targets unless the
-- switches -gnatN or -gnatd.z are used. See circuitry in gnat1drv for the
-- exact conditions for setting this switch.
-- WARNING: There is a matching C declaration of this variable in fe.h
+ Back_End_Return_Slot : Boolean := True;
+ -- GNAT
+ -- This flag is set True if the return slot of the back end for functions
+ -- returning a by-reference type can be accessed by means of an intrinsic
+ -- function callable in the body of these functions. This is the normal
+ -- default mode for GCC targets, so it is True on such targets unless the
+ -- switch -gnatd_r is used.
+
Bind_Alternate_Main_Name : Boolean := False;
-- GNATBIND
-- True if main should be called Alternate_Main_Name.all.
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 8c831f05841..280e2bda84e 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -428,6 +428,7 @@ package Rtsfind is
System_Put_Images,
System_Put_Task_Images,
System_Relative_Delays,
+ System_Return_Stack,
System_RPC,
System_Scalar_Values,
System_Secondary_Stack,
@@ -1843,6 +1844,9 @@ package Rtsfind is
RO_RD_Delay_For, -- System.Relative_Delays
+ RE_RS_Allocate, -- System.Return_Stack
+ RE_RS_Pool, -- System.Return_Stack
+
RE_IS_Is1, -- System.Scalar_Values
RE_IS_Is2, -- System.Scalar_Values
RE_IS_Is4, -- System.Scalar_Values
@@ -3535,6 +3539,9 @@ package Rtsfind is
RO_RD_Delay_For => System_Relative_Delays,
+ RE_RS_Allocate => System_Return_Stack,
+ RE_RS_Pool => System_Return_Stack,
+
RE_Do_Apc => System_RPC,
RE_Do_Rpc => System_RPC,
RE_Params_Stream_Type => System_RPC,
@@ -4021,6 +4028,7 @@ package Rtsfind is
System_Fat_LLF => True,
System_Fat_SFlt => True,
System_Machine_Code => True,
+ System_Return_Stack => True,
System_Secondary_Stack => True,
System_Storage_Elements => True,
System_Task_Info => True,
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 762fe48d1c9..c306e2779a4 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6808,13 +6808,18 @@ package body Sem_Util is
procedure Compute_Returns_By_Ref (Func : Entity_Id) is
Typ : constant Entity_Id := Etype (Func);
- Utyp : constant Entity_Id := Underlying_Type (Typ);
begin
if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Func);
- elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
+ -- For class-wide types and types which both need finalization and are
+ -- returned on the secondary stack, the secondary stack allocation is
+ -- done by the front end, see Expand_Simple_Function_Return.
+
+ elsif Returns_On_Secondary_Stack (Typ)
+ and then CW_Or_Needs_Finalization (Underlying_Type (Typ))
+ then
Set_Returns_By_Ref (Func);
end if;
end Compute_Returns_By_Ref;
@@ -7294,14 +7299,14 @@ package body Sem_Util is
end if;
end Current_Subprogram;
- -------------------------------
- -- CW_Or_Has_Controlled_Part --
- -------------------------------
+ ------------------------------
+ -- CW_Or_Needs_Finalization --
+ ------------------------------
- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
+ function CW_Or_Needs_Finalization (Typ : Entity_Id) return Boolean is
begin
- return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
- end CW_Or_Has_Controlled_Part;
+ return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ);
+ end CW_Or_Needs_Finalization;
-------------------------------
-- Deepest_Type_Access_Level --
@@ -27301,11 +27306,61 @@ package body Sem_Util is
-- Requires_Transient_Scope --
------------------------------
- -- A transient scope is required when variable-sized temporaries are
- -- allocated on the secondary stack, or when finalization actions must be
- -- generated before the next instruction.
+ function Requires_Transient_Scope (Typ : Entity_Id) return Boolean is
+ begin
+ return Returns_On_Secondary_Stack (Typ) or else Needs_Finalization (Typ);
+ end Requires_Transient_Scope;
+
+ --------------------------
+ -- Reset_Analyzed_Flags --
+ --------------------------
+
+ procedure Reset_Analyzed_Flags (N : Node_Id) is
+ function Clear_Analyzed (N : Node_Id) return Traverse_Result;
+ -- Function used to reset Analyzed flags in tree. Note that we do
+ -- not reset Analyzed flags in entities, since there is no need to
+ -- reanalyze entities, and indeed, it is wrong to do so, since it
+ -- can result in generating auxiliary stuff more than once.
+
+ --------------------
+ -- Clear_Analyzed --
+ --------------------
+
+ function Clear_Analyzed (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) not in N_Entity then
+ Set_Analyzed (N, False);
+ end if;
+
+ return OK;
+ end Clear_Analyzed;
+
+ procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
+
+ -- Start of processing for Reset_Analyzed_Flags
+
+ begin
+ Reset_Analyzed (N);
+ end Reset_Analyzed_Flags;
+
+ ------------------------
+ -- Restore_SPARK_Mode --
+ ------------------------
+
+ procedure Restore_SPARK_Mode
+ (Mode : SPARK_Mode_Type;
+ Prag : Node_Id)
+ is
+ begin
+ SPARK_Mode := Mode;
+ SPARK_Mode_Pragma := Prag;
+ end Restore_SPARK_Mode;
+
+ ---------------------------------
+ -- Returns_On_Secondary_Stack --
+ ---------------------------------
- function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
+ function Returns_On_Secondary_Stack (Id : Entity_Id) return Boolean is
pragma Assert (if Present (Id) then Ekind (Id) in E_Void | Type_Kind);
function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
@@ -27318,11 +27373,6 @@ package body Sem_Util is
-- could be nested inside some other record that is constrained by
-- nondiscriminants). That is, the recursive calls are too conservative.
- procedure Ensure_Minimum_Decoration (Typ : Entity_Id);
- -- If Typ is not frozen then add to Typ the minimum decoration required
- -- by Requires_Transient_Scope to reliably provide its functionality;
- -- otherwise no action is performed.
-
function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
-- Returns True if Typ is a nonlimited record with defaulted
-- discriminants whose max size makes it unsuitable for allocating on
@@ -27378,46 +27428,6 @@ package body Sem_Util is
return True;
end Caller_Known_Size_Record;
- -------------------------------
- -- Ensure_Minimum_Decoration --
- -------------------------------
-
- procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is
- Comp : Entity_Id;
- begin
- -- Do not set Has_Controlled_Component on a class-wide equivalent
- -- type. See Make_CW_Equivalent_Type.
-
- if not Is_Frozen (Typ)
- and then Is_Base_Type (Typ)
- and then (Is_Record_Type (Typ)
- or else Is_Concurrent_Type (Typ)
- or else Is_Incomplete_Or_Private_Type (Typ))
- and then not Is_Class_Wide_Equivalent_Type (Typ)
- then
- Comp := First_Component (Typ);
- while Present (Comp) loop
- if Has_Controlled_Component (Etype (Comp))
- or else
- (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Etype (Comp)))
- or else
- (Is_Protected_Type (Etype (Comp))
- and then
- Present (Corresponding_Record_Type (Etype (Comp)))
- and then
- Has_Controlled_Component
- (Corresponding_Record_Type (Etype (Comp))))
- then
- Set_Has_Controlled_Component (Typ);
- exit;
- end if;
-
- Next_Component (Comp);
- end loop;
- end if;
- end Ensure_Minimum_Decoration;
-
------------------------------
-- Large_Max_Size_Mutable --
------------------------------
@@ -27502,7 +27512,7 @@ package body Sem_Util is
Typ : constant Entity_Id := Underlying_Type (Id);
- -- Start of processing for Requires_Transient_Scope
+ -- Start of processing for Returns_On_Secondary_Stack
begin
-- This is a private type which is not completed yet. This can only
@@ -27513,8 +27523,6 @@ package body Sem_Util is
return False;
end if;
- Ensure_Minimum_Decoration (Id);
-
-- Do not expand transient scope for non-existent procedure return or
-- string literal types.
@@ -27529,20 +27537,23 @@ package body Sem_Util is
elsif Ekind (Typ) = E_Record_Subtype
and then Present (Cloned_Subtype (Typ))
then
- return Requires_Transient_Scope (Cloned_Subtype (Typ));
+ return Returns_On_Secondary_Stack (Cloned_Subtype (Typ));
-- Functions returning specific tagged types may dispatch on result, so
-- their returned value is allocated on the secondary stack, even in the
-- definite case. We must treat nondispatching functions the same way,
-- because access-to-function types can point at both, so the calling
- -- conventions must be compatible. Is_Tagged_Type includes controlled
- -- types and class-wide types. Controlled type temporaries need
- -- finalization.
+ -- conventions must be compatible.
+
+ elsif Is_Tagged_Type (Typ) then
+ return True;
- -- ???It's not clear why we need to return noncontrolled types with
- -- controlled components on the secondary stack.
+ -- If the return slot of the back end cannot be accessed, then there
+ -- is no way to call Adjust at the right time for the return object if
+ -- the type needs finalization, so the return object must be allocated
+ -- on the secondary stack.
- elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
+ elsif not Back_End_Return_Slot and then Needs_Finalization (Typ) then
return True;
-- Untagged definite subtypes are known size. This includes all
@@ -27571,52 +27582,7 @@ package body Sem_Util is
pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
return True;
end if;
- end Requires_Transient_Scope;
-
- --------------------------
- -- Reset_Analyzed_Flags --
- --------------------------
-
- procedure Reset_Analyzed_Flags (N : Node_Id) is
- function Clear_Analyzed (N : Node_Id) return Traverse_Result;
- -- Function used to reset Analyzed flags in tree. Note that we do
- -- not reset Analyzed flags in entities, since there is no need to
- -- reanalyze entities, and indeed, it is wrong to do so, since it
- -- can result in generating auxiliary stuff more than once.
-
- --------------------
- -- Clear_Analyzed --
- --------------------
-
- function Clear_Analyzed (N : Node_Id) return Traverse_Result is
- begin
- if Nkind (N) not in N_Entity then
- Set_Analyzed (N, False);
- end if;
-
- return OK;
- end Clear_Analyzed;
-
- procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
-
- -- Start of processing for Reset_Analyzed_Flags
-
- begin
- Reset_Analyzed (N);
- end Reset_Analyzed_Flags;
-
- ------------------------
- -- Restore_SPARK_Mode --
- ------------------------
-
- procedure Restore_SPARK_Mode
- (Mode : SPARK_Mode_Type;
- Prag : Node_Id)
- is
- begin
- SPARK_Mode := Mode;
- SPARK_Mode_Pragma := Prag;
- end Restore_SPARK_Mode;
+ end Returns_On_Secondary_Stack;
--------------------------------
-- Returns_Unconstrained_Type --
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index b6c70ca2300..f9903b8ebdd 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -672,11 +672,10 @@ package Sem_Util is
-- Current_Scope is returned. The returned value is Empty if this is called
-- from a library package which is not within any subprogram.
- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean;
- -- True if T is a class-wide type, or if it has controlled parts ("part"
- -- means T or any of its subcomponents). Same as Needs_Finalization, except
- -- when pragma Restrictions (No_Finalization) applies, in which case we
- -- know that class-wide objects do not contain controlled parts.
+ function CW_Or_Needs_Finalization (Typ : Entity_Id) return Boolean;
+ -- True if Typ is a class-wide type or requires finalization actions. Same
+ -- as Needs_Finalization except with pragma Restrictions (No_Finalization),
+ -- in which case we know that class-wide objects do not need finalization.
function Deepest_Type_Access_Level
(Typ : Entity_Id;
@@ -3048,14 +3047,12 @@ package Sem_Util is
-- This is used as a defense mechanism against ill-formed trees caused by
-- previous errors (particularly in -gnatq mode).
- function Requires_Transient_Scope (Id : Entity_Id) return Boolean;
- -- Id is a type entity. The result is True when temporaries of this type
- -- need to be wrapped in a transient scope to be reclaimed properly when a
- -- secondary stack is in use. Examples of types requiring such wrapping are
- -- controlled types and variable-sized types including unconstrained
- -- arrays.
-
- -- WARNING: There is a matching C declaration of this subprogram in fe.h
+ function Requires_Transient_Scope (Typ : Entity_Id) return Boolean;
+ -- Return true if temporaries of Typ need to be wrapped in a transient
+ -- scope, either because they are allocated on the secondary stack or
+ -- finalization actions must be generated before the next instruction.
+ -- Examples of types requiring such wrapping are variable-sized types,
+ -- including unconstrained arrays, and controlled types.
procedure Reset_Analyzed_Flags (N : Node_Id);
-- Reset the Analyzed flags in all nodes of the tree whose root is N
@@ -3064,6 +3061,12 @@ package Sem_Util is
-- Set the current SPARK_Mode to Mode and SPARK_Mode_Pragma to Prag. This
-- routine must be used in tandem with Set_SPARK_Mode.
+ function Returns_On_Secondary_Stack (Id : Entity_Id) return Boolean;
+ -- Return true if functions whose result type is Id must return on the
+ -- secondary stack, i.e. allocate the return object on this stack.
+
+ -- WARNING: There is a matching C declaration of this subprogram in fe.h
+
function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean;
-- Return true if Subp is a function that returns an unconstrained type
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-19 14:06 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-19 14:06 [gcc r13-638] [Ada] Get rid of secondary stack for controlled components Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).