[gcc r13-840] [Ada] Avoid creating a finalization wrapper block for functions

[gcc r13-840] [Ada] Avoid creating a finalization wrapper block for functions

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:6a91be29578fa466376cd482d3abed5eb20685b4

commit r13-840-g6a91be29578fa466376cd482d3abed5eb20685b4
Author: Bob Duff <duff@adacore.com>
Date:   Tue Apr 26 07:16:20 2022 -0400

    [Ada] Avoid creating a finalization wrapper block for functions
    
    This patch fixes a bug whereby if a function body has local objects that
    are finalizable, and has a return statement that requires generation of
    transient finalizable temps, and there are dynamic-sized objects
    requiring pushing/popping the (primary) stack at run time, and the
    function body has exception handlers, then incorrect code is
    generated. In particular, the transient objects are finalized after they
    have been deallocated. This can cause seg faults, corrupted heap, and
    the like.
    
    Note that if there are no dynamic-sized objects, then the bug does
    not occur, because the back end allocates objects of compile-time-known
    size based on where they are referenced, rather than which local
    block they are declared in.
    
    This patch relies on the fact that an At_End handler and regular
    exception handlers CAN coexist in the same handled statement sequence,
    which was not true some years ago.
    
    gcc/ada/
    
            * exp_ch7.adb (Wrap_HSS_In_Block): Do not create a new block in
            the case of function bodies. We include all subprogram bodies,
            because it's harmless for procedures. We cannot easily avoid
            creating this block in ALL cases, because some transformations
            of (e.g.) task bodies end up moving some code such that the
            wrong exception handlers apply to that code.
            (Build_Finalizer_Call): Remove code for creating a new block.
            This was unreachable code, given that Wrap_HSS_In_Block has
            already done that, but with the above change to
            Wrap_HSS_In_Block, this code becomes reachable, and triggers
            essentially the same bug.
            * exp_ch7.ads: Adjust comment.

Diff:
---
 gcc/ada/exp_ch7.adb | 80 +++++++++++++++++++----------------------------------
 gcc/ada/exp_ch7.ads |  4 +--
 2 files changed, 30 insertions(+), 54 deletions(-)

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index bb6712d823d..d611d0e52d4 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -341,8 +341,8 @@ package body Exp_Ch7 is
    --  Build_Finalizer.
 
    procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
-   --  N is a construct which contains a handled sequence of statements, Fin_Id
-   --  is the entity of a finalizer. Create an At_End handler which covers the
+   --  N is a construct that contains a handled sequence of statements, Fin_Id
+   --  is the entity of a finalizer. Create an At_End handler that covers the
    --  statements of N and calls Fin_Id. If the handled statement sequence has
    --  an exception handler, the statements will be wrapped in a block to avoid
    --  unwanted interaction with the new At_End handler.
@@ -3722,7 +3722,7 @@ package body Exp_Ch7 is
       --  which belongs to a protected type.
 
       Loc : constant Source_Ptr := Sloc (N);
-      HSS : Node_Id;
+      HSS : Node_Id := Handled_Statement_Sequence (N);
 
    begin
       --  Do not perform this expansion in SPARK mode because we do not create
@@ -3732,13 +3732,8 @@ package body Exp_Ch7 is
          return;
       end if;
 
-      --  The At_End handler should have been assimilated by the finalizer
-
-      HSS := Handled_Statement_Sequence (N);
-      pragma Assert (No (At_End_Proc (HSS)));
-
       --  If the construct to be cleaned up is a protected subprogram body, the
-      --  finalizer call needs to be associated with the block which wraps the
+      --  finalizer call needs to be associated with the block that wraps the
       --  unprotected version of the subprogram. The following illustrates this
       --  scenario:
 
@@ -3760,27 +3755,9 @@ package body Exp_Ch7 is
 
       if Is_Prot_Body then
          HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
-
-      --  An At_End handler and regular exception handlers cannot coexist in
-      --  the same statement sequence. Wrap the original statements in a block.
-
-      elsif Present (Exception_Handlers (HSS)) then
-         declare
-            End_Lab : constant Node_Id := End_Label (HSS);
-            Block   : Node_Id;
-
-         begin
-            Block :=
-              Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
-
-            Set_Handled_Statement_Sequence (N,
-              Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
-
-            HSS := Handled_Statement_Sequence (N);
-            Set_End_Label (HSS, End_Lab);
-         end;
       end if;
 
+      pragma Assert (No (At_End_Proc (HSS)));
       Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
 
       --  Attach reference to finalizer to tree, for LLVM use
@@ -5568,10 +5545,10 @@ package body Exp_Ch7 is
    procedure Expand_Cleanup_Actions (N : Node_Id) is
       pragma Assert
         (Nkind (N) in N_Block_Statement
-                    | N_Entry_Body
-                    | N_Extended_Return_Statement
                     | N_Subprogram_Body
-                    | N_Task_Body);
+                    | N_Task_Body
+                    | N_Entry_Body
+                    | N_Extended_Return_Statement);
 
       Scop : constant Entity_Id := Current_Scope;
 
@@ -5639,18 +5616,14 @@ package body Exp_Ch7 is
       -----------------------
 
       procedure Wrap_HSS_In_Block is
-         Block    : Node_Id;
-         Block_Id : Entity_Id;
-         End_Lab  : Node_Id;
-
-      begin
-         --  Preserve end label to provide proper cross-reference information
-
-         End_Lab := End_Label (HSS);
-         Block :=
+         Block : constant Node_Id :=
            Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
+         Block_Id : constant Entity_Id :=
+           New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
+         End_Lab : constant Node_Id := End_Label (HSS);
+         --  Preserve end label to provide proper cross-reference information
 
-         Block_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
+      begin
          Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc));
          Set_Etype (Block_Id, Standard_Void_Type);
          Set_Block_Node (Block_Id, Identifier (Block));
@@ -5660,14 +5633,11 @@ package body Exp_Ch7 is
 
          Set_Is_Finalization_Wrapper (Block);
 
-         Set_Handled_Statement_Sequence (N,
-           Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
-         HSS := Handled_Statement_Sequence (N);
-
+         HSS := Make_Handled_Sequence_Of_Statements (Loc,
+           Statements => New_List (Block),
+           End_Label => End_Lab);
          Set_First_Real_Statement (HSS, Block);
-         Set_End_Label (HSS, End_Lab);
-
-         --  Comment needed here, see RH for 1.306 ???
+         Set_Handled_Statement_Sequence (N, HSS);
 
          if Nkind (N) = N_Subprogram_Body then
             Set_Has_Nested_Block_With_Handler (Scop);
@@ -5789,11 +5759,17 @@ package body Exp_Ch7 is
             Set_Uses_Sec_Stack (Scop, False);
          end if;
 
-         --  If exception handlers are present, wrap the sequence of statements
-         --  in a block since it is not possible to have exception handlers and
-         --  an At_End handler in the same construct.
+         --  If exception handlers are present in a non-subprogram
+         --  construct, wrap the sequence of statements in a block.
+         --  Otherwise, code can be moved so that the wrong handlers
+         --  apply. It is important not to do this for function bodies,
+         --  because otherwise transient finalizable objects created
+         --  by a return statement get finalized too late. It is harmless
+         --  not to do this for procedures.
 
-         if Present (Exception_Handlers (HSS)) then
+         if Present (Exception_Handlers (HSS))
+           and then Nkind (N) /= N_Subprogram_Body
+         then
             Wrap_HSS_In_Block;
 
          --  Ensure that the First_Real_Statement field is set
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 3dbac21d6a5..1f1ab167685 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -255,8 +255,8 @@ package Exp_Ch7 is
    procedure Expand_Cleanup_Actions (N : Node_Id);
    --  Expand the necessary stuff into a scope to enable finalization of local
    --  objects and deallocation of transient data when exiting the scope. N is
-   --  a "scope node" that is to say one of the following: N_Block_Statement,
-   --  N_Subprogram_Body, N_Task_Body, N_Entry_Body.
+   --  one of N_Block_Statement, N_Subprogram_Body, N_Task_Body, N_Entry_Body,
+   --  or N_Extended_Return_Statement.
 
    procedure Establish_Transient_Scope
      (N                : Node_Id;