aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/Makefile.rtl1
-rw-r--r--gcc/ada/debug.adb7
-rw-r--r--gcc/ada/exp_ch4.adb5
-rw-r--r--gcc/ada/exp_ch6.adb91
-rw-r--r--gcc/ada/exp_util.adb7
-rw-r--r--gcc/ada/fe.h16
-rw-r--r--gcc/ada/gcc-interface/ada-builtin-types.def3
-rw-r--r--gcc/ada/gcc-interface/ada-builtins.def3
-rw-r--r--gcc/ada/gcc-interface/ada-tree.h5
-rw-r--r--gcc/ada/gcc-interface/decl.cc6
-rw-r--r--gcc/ada/gcc-interface/trans.cc8
-rw-r--r--gcc/ada/gcc-interface/utils2.cc41
-rw-r--r--gcc/ada/gnat1drv.adb7
-rw-r--r--gcc/ada/libgnat/s-retsta.ads57
-rw-r--r--gcc/ada/opt.ads12
-rw-r--r--gcc/ada/rtsfind.ads8
-rw-r--r--gcc/ada/sem_util.adb192
-rw-r--r--gcc/ada/sem_util.ads29
18 files changed, 334 insertions, 164 deletions
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 7b84ee5..ed3d334 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 8a0ba021..a03c88d 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 aa29156..14e9b0e 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 9ddbd8c..e95c6c5 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 32c1ff7..31a2d5c 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 33b48e6..4be9d94 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 f00845b..000d429 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 dcdc4d9..8ba89a8 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 0ec81bc..ca718f4 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 e6f2df8..c096b0d 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 57a9dee..b8a0d5d 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 76622da..ae81a0d 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 79d5847..cd70a14 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 0000000..8340341
--- /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 9ea153a..2ce24ee 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 8c831f0..280e2bd 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 762fe48..c306e27 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 b6c70ca..f9903b8 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
generated by cgit v1.1 at 2025-02-24 19:32:45 +0000