[Ada] Place "at end" on body nodes

This patch fixes a bug where finalization code might refer to variables
outside their lifetime. The previous version moved declarations into the
Handled_Statement_Sequence (HSS), so that the "at end" handler of the
HSS could handle exceptions raised by those declarations. The
First_Real_Statement field was used to find the first statement after
the moved declarations. In addition, if the HSS already had exception
handlers, it was wrapped in another layer of block_statement. This
doesn't work if there are variable-sized objects allocated on the
(primary) stack, because the stack will be popped before the "at end" is
invoked.

In the new version, we allow "at end" on nodes such as
N_Subprogram_Body, in addition to HSS. We modify gigi so that such an
"at end" applies to the whole body (declarations and HSS) by extending
support for At_End_Proc mechanism to N_Block_Statement and N_*_Body
nodes. This also removes the support for First_Real_Statement. In
particular, an exception raised by the declarations will trigger the "at
end". We no longer move declarations into the HSS, we no longer have a
First_Real_Statement field, and we no longer do the wrapping mentioned
above.

This change requires various other changes, in cases where we depended
on the First_Real_Statement and the moving/wrapping mentioned above.

gcc/ada/

	* gen_il-fields.ads
	(First_Real_Statement): Remove this field.
	* gen_il-gen-gen_nodes.adb: Remove the First_Real_Statement field.
	Add the At_End_Proc field to nodes that have both Declarations and
	HSS.
	* sinfo.ads
	(At_End_Proc): Document new semantics.
	(First_Real_Statement): Remove comment.
	* exp_ch11.adb
	(Expand_N_Handled_Sequence_Of_Statements): Remove
	First_Real_Statement.
	* exp_ch7.adb
	(Build_Cleanup_Statements): Remove "Historical note"; it doesn't
	seem useful, and we have revision history.
	(Create_Finalizer): Insert the finalizer later, typically in the
	statement list, in some cases.
	(Build_Finalizer_Call): Attach the "at end" handler to the parent
	of the HSS node in most cases, so it applies to declarations.
	(Expand_Cleanup_Actions): Remove Wrap_HSS_In_Block and the call to
	it. Remove the code that moves declarations. Remove some redundant
	code.
	* exp_ch9.adb
	(Build_Protected_Entry): Copy the At_End_Proc.
	(Build_Protected_Subprogram_Body): Reverse the sense of Exc_Safe,
	to avoid double negatives. Remove "Historical note" as in
	exp_ch7.adb.
	(Build_Unprotected_Subprogram_Body): Copy the At_End_Proc from the
	protected version.
	(Expand_N_Conditional_Entry_Call): Use First (Statements(...))
	instead of First_Real_Statement(...).
	(Expand_N_Task_Body): Put the Abort_Undefer call at the beginning
	of the declarations, rather than in the HSS. Use First
	(Statements(...)) instead of First_Real_Statement(...). Copy the
	At_End_Proc.
	* inline.adb
	(Has_Initialized_Type): Return False if the declaration does not
	come from source.
	* libgnarl/s-tpoben.ads
	(Lock_Entries, Lock_Entries_With_Status): Document when these
	things raise Program_Error. It's not clear that
	Lock_Entries_With_Status ought to be raising exceptions, but at
	least it's documented now.
	* sem.ads: Minor comment fixes.
	* sem_ch6.adb
	(Analyze_Subprogram_Body_Helper): Use First (Statements(...))
	instead of First_Real_Statement(...).
	(Analyze_Null_Procedure): Minor comment fix.
	* sem_util.adb
	(Might_Raise): Return True for N_Raise_Expression. Adjust the part
	about exceptions generated by the back end to match the reality of
	what the back end generates.
	(Update_First_Real_Statement): Remove.
	* sem_util.ads: Remove First_Real_Statement from comment.
	* sinfo-utils.ads
	(First_Real_Statement): New function that always returns Empty.
	This should be removed once gnat-llvm and codepeer have been
	updated to not refer to First_Real_Statement.
	* sprint.adb
	(Sprint_At_End_Proc): Deal with printing At_End_Proc.
	* sem_prag.adb: Minor comment fixes.
	* gcc-interface/trans.cc (At_End_Proc_to_gnu): New function.
	(Subprogram_Body_to_gnu): Call it to handle an At_End_Proc.
	(Handled_Sequence_Of_Statements_to_gnu): Likewise. Remove the
	support for First_Real_Statement and clean up the rest.
	(Exception_Handler_to_gnu): Do not push binding levels.
	(Compilation_Unit_to_gnu): Adjust call to process_decls.
	(gnat_to_gnu) <N_Package_Specification>: Likewise. <N_Entry_Body>:
	Likewise. <N_Freeze_Entity>: Likewise. <N_Block_Statement>:
	Likewise and call At_End_Proc_to_gnu to handle an At_End_Proc.
	<N_Package_Body>: Likewise.
	(process_decls): Remove GNAT_END_LIST parameter and adjust
	recursive calls.

Co-authored-by: Eric Botcazou <ebotcazou@adacore.com>

1 files changed, 71 insertions, 85 deletions

diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index c1dd567..58412a0 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -234,7 +234,7 @@ static inline bool stmt_group_may_fallthru (void);
 static enum gimplify_status gnat_gimplify_stmt (tree *);
 static void elaborate_all_entities (Node_Id);
 static void process_freeze_entity (Node_Id);
-static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
+static void process_decls (List_Id, List_Id, bool, bool);
 static tree emit_check (tree, tree, int, Node_Id);
 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
@@ -3778,6 +3778,30 @@ build_return_expr (tree ret_obj, tree ret_val)
   return build1 (RETURN_EXPR, void_type_node, result_expr);
 }
 
+/* Subroutine of gnat_to_gnu to translate the At_End_Proc of GNAT_NODE, an
+   N_Block_Statement or N_Handled_Sequence_Of_Statements or N_*_Body node.
+
+   To invoked the GCC mechanism, we call add_cleanup and when we leave the
+   group, end_stmt_group will create the TRY_FINALLY_EXPR construct.  */
+
+static void
+At_End_Proc_to_gnu (Node_Id gnat_node)
+{
+  tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
+
+  /* When not optimizing, disable inlining of finalizers as this can
+     create a more complex CFG in the parent function.  */
+  if (!optimize || optimize_debug)
+    DECL_DECLARED_INLINE_P (proc_decl) = 0;
+
+  /* If there is no end label attached, we use the location of the At_End
+     procedure because Expand_Cleanup_Actions might reset the location of
+      the enclosing construct to that of an inner statement.  */
+  add_cleanup (build_call_n_expr (proc_decl, 0),
+	       Present (End_Label (gnat_node))
+	       ? End_Label (gnat_node) : At_End_Proc (gnat_node));
+}
+
 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Subprogram_Body.  */
 
 static void
@@ -3928,12 +3952,16 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
   gnat_pushlevel ();
 
   /* First translate the declarations of the subprogram.  */
-  process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+  process_decls (Declarations (gnat_node), Empty, true, true);
 
   /* Then generate the code of the subprogram itself.  A return statement will
      be present and any Out parameters will be handled there.  */
   add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
 
+  /* Process the At_End_Proc, if any.  */
+  if (Present (At_End_Proc (gnat_node)))
+    At_End_Proc_to_gnu (gnat_node);
+
   gnat_poplevel ();
   tree gnu_result = end_stmt_group ();
 
@@ -5305,76 +5333,39 @@ static tree
 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
 {
   /* If just annotating, ignore all EH and cleanups.  */
-  const bool gcc_eh
+  const bool eh
     = !type_annotate_only && Present (Exception_Handlers (gnat_node));
   const bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
-  const bool binding_for_block = (at_end || gcc_eh);
-  tree gnu_inner_block; /* The statement(s) for the block itself.  */
   tree gnu_result;
   Node_Id gnat_temp;
 
-  /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes.
-     To call the GCC mechanism, we call add_cleanup, and when we leave the
-     binding, end_stmt_group will create the TRY_FINALLY_EXPR construct.
+  /* The exception handling mechanism can handle both ZCX and SJLJ schemes, and
+     is exposed through the TRY_CATCH_EXPR construct that we build manually.
 
      ??? The region level calls down there have been specifically put in place
      for a ZCX context and currently the order in which things are emitted
      (region/handlers) is different from the SJLJ case.  Instead of putting
      other calls with different conditions at other places for the SJLJ case,
      it seems cleaner to reorder things for the SJLJ case and generalize the
-     condition to make it not ZCX specific.
+     condition to make it not ZCX specific.  */
 
-     If there are any exceptions or cleanup processing involved, we need an
-     outer statement group and binding level.  */
-  if (binding_for_block)
-    {
-      start_stmt_group ();
-      gnat_pushlevel ();
-    }
-
-  /* If we are to call a function when exiting this block, add a cleanup
-     to the binding level we made above.  Note that add_cleanup is FIFO
-     so we must register this cleanup after the EH cleanup just above.  */
-  if (at_end)
-    {
-      tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
-
-      /* When not optimizing, disable inlining of finalizers as this can
-	 create a more complex CFG in the parent function.  */
-      if (!optimize || optimize_debug)
-	DECL_DECLARED_INLINE_P (proc_decl) = 0;
-
-      /* If there is no end label attached, we use the location of the At_End
-	 procedure because Expand_Cleanup_Actions might reset the location of
-	 the enclosing construct to that of an inner statement.  */
-      add_cleanup (build_call_n_expr (proc_decl, 0),
-		   Present (End_Label (gnat_node))
-		   ? End_Label (gnat_node) : At_End_Proc (gnat_node));
-    }
-
-  /* Now build the tree for the declarations and statements inside this
-     block.  */
+  /* First build the tree for the statements inside the sequence.  */
   start_stmt_group ();
 
-  if (Present (First_Real_Statement (gnat_node)))
-    process_decls (Statements (gnat_node), Empty,
-		   First_Real_Statement (gnat_node), true, true);
-
-  /* Generate code for each statement in the block.  */
-  for (gnat_temp = (Present (First_Real_Statement (gnat_node))
-		    ? First_Real_Statement (gnat_node)
-		    : First (Statements (gnat_node)));
-       Present (gnat_temp); gnat_temp = Next (gnat_temp))
+  for (gnat_temp = First (Statements (gnat_node));
+       Present (gnat_temp);
+       gnat_temp = Next (gnat_temp))
     add_stmt (gnat_to_gnu (gnat_temp));
 
-  gnu_inner_block = end_stmt_group ();
+  gnu_result = end_stmt_group ();
 
-  if (gcc_eh)
+  /* Then process the exception handlers, if any.  */
+  if (eh)
     {
       tree gnu_handlers;
       location_t locus;
 
-      /* First make a block containing the handlers.  */
+      /* First make a group containing the handlers.  */
       start_stmt_group ();
       for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
 	   Present (gnat_temp);
@@ -5382,9 +5373,10 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
 	add_stmt (gnat_to_gnu (gnat_temp));
       gnu_handlers = end_stmt_group ();
 
-      /* Now make the TRY_CATCH_EXPR for the block.  */
-      gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
-			   gnu_inner_block, gnu_handlers);
+      /* Now make the TRY_CATCH_EXPR for the group.  */
+      gnu_result
+	= build2 (TRY_CATCH_EXPR, void_type_node, gnu_result, gnu_handlers);
+
       /* Set a location.  We need to find a unique location for the dispatching
 	 code, otherwise we can get coverage or debugging issues.  Try with
 	 the location of the end label.  */
@@ -5398,14 +5390,13 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
            coverage analysis tools.  */
 	set_expr_location_from_node (gnu_result, gnat_node, true);
     }
-  else
-    gnu_result = gnu_inner_block;
 
-  /* Now close our outer block, if we had to make one.  */
-  if (binding_for_block)
+  /* Process the At_End_Proc, if any.  */
+  if (at_end)
     {
+      start_stmt_group ();
       add_stmt (gnu_result);
-      gnat_poplevel ();
+      At_End_Proc_to_gnu (gnat_node);
       gnu_result = end_stmt_group ();
     }
 
@@ -5493,7 +5484,6 @@ Exception_Handler_to_gnu (Node_Id gnat_node)
     }
 
   start_stmt_group ();
-  gnat_pushlevel ();
 
   /* Expand a call to the begin_handler hook at the beginning of the
      handler, and arrange for a call to the end_handler hook to occur
@@ -5584,7 +5574,7 @@ Exception_Handler_to_gnu (Node_Id gnat_node)
   else
     {
       start_stmt_group ();
-      gnat_pushlevel ();
+
       /* CODE: void *EXPRP = __builtin_eh_handler (0); */
       tree prop_ptr
 	= create_var_decl (get_identifier ("EXPRP"), NULL_TREE,
@@ -5604,14 +5594,11 @@ Exception_Handler_to_gnu (Node_Id gnat_node)
       add_stmt_with_node (ecall, gnat_node);
 
       /* CODE: } */
-      gnat_poplevel ();
       tree eblk = end_stmt_group ();
       tree ehls = build2 (EH_ELSE_EXPR, void_type_node, call, eblk);
       add_cleanup (ehls, gnat_node);
     }
 
-  gnat_poplevel ();
-
   gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
 
   return
@@ -5677,7 +5664,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
        gnat_pragma = Next (gnat_pragma))
     if (Nkind (gnat_pragma) == N_Pragma)
       add_stmt (gnat_to_gnu (gnat_pragma));
-  process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
+  process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty,
 		 true, true);
 
   /* Process the unit itself.  */
@@ -7365,8 +7352,10 @@ gnat_to_gnu (Node_Id gnat_node)
 	{
 	  start_stmt_group ();
 	  gnat_pushlevel ();
-	  process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+	  process_decls (Declarations (gnat_node), Empty, true, true);
 	  add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
+	  if (Present (At_End_Proc (gnat_node)))
+	    At_End_Proc_to_gnu (gnat_node);
 	  gnat_poplevel ();
 	  gnu_result = end_stmt_group ();
 	}
@@ -7606,15 +7595,14 @@ gnat_to_gnu (Node_Id gnat_node)
       break;
 
     case N_Package_Specification:
-
       start_stmt_group ();
       process_decls (Visible_Declarations (gnat_node),
-		     Private_Declarations (gnat_node), Empty, true, true);
+		     Private_Declarations (gnat_node),
+		     true, true);
       gnu_result = end_stmt_group ();
       break;
 
     case N_Package_Body:
-
       /* If this is the body of a generic package - do nothing.  */
       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
 	{
@@ -7623,11 +7611,11 @@ gnat_to_gnu (Node_Id gnat_node)
 	}
 
       start_stmt_group ();
-      process_decls (Declarations (gnat_node), Empty, Empty, true, true);
-
+      process_decls (Declarations (gnat_node), Empty, true, true);
       if (Present (Handled_Statement_Sequence (gnat_node)))
 	add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
-
+      if (Present (At_End_Proc (gnat_node)))
+	At_End_Proc_to_gnu (gnat_node);
       gnu_result = end_stmt_group ();
       break;
 
@@ -7673,7 +7661,7 @@ gnat_to_gnu (Node_Id gnat_node)
     case N_Task_Body:
       /* These nodes should only be present when annotating types.  */
       gcc_assert (type_annotate_only);
-      process_decls (Declarations (gnat_node), Empty, Empty, true, true);
+      process_decls (Declarations (gnat_node), Empty, true, true);
       gnu_result = alloc_stmt_list ();
       break;
 
@@ -7975,7 +7963,7 @@ gnat_to_gnu (Node_Id gnat_node)
     case N_Freeze_Entity:
       start_stmt_group ();
       process_freeze_entity (gnat_node);
-      process_decls (Actions (gnat_node), Empty, Empty, true, true);
+      process_decls (Actions (gnat_node), Empty, true, true);
       gnu_result = end_stmt_group ();
       break;
 
@@ -9203,17 +9191,13 @@ process_freeze_entity (Node_Id gnat_node)
    we declare a function if there was no spec).  The second pass
    elaborates the bodies.
 
-   GNAT_END_LIST gives the element in the list past the end.  Normally,
-   this is Empty, but can be First_Real_Statement for a
-   Handled_Sequence_Of_Statements.
-
    We make a complete pass through both lists if PASS1P is true, then make
    the second pass over both lists if PASS2P is true.  The lists usually
    correspond to the public and private parts of a package.  */
 
 static void
 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
-	       Node_Id gnat_end_list, bool pass1p, bool pass2p)
+	       bool pass1p, bool pass2p)
 {
   List_Id gnat_decl_array[2];
   Node_Id gnat_decl;
@@ -9225,7 +9209,8 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
     for (i = 0; i <= 1; i++)
       if (Present (gnat_decl_array[i]))
 	for (gnat_decl = First (gnat_decl_array[i]);
-	     gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
+	     Present (gnat_decl);
+	     gnat_decl = Next (gnat_decl))
 	  {
 	    /* For package specs, we recurse inside the declarations,
 	       thus taking the two pass approach inside the boundary.  */
@@ -9234,14 +9219,14 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
 			   == N_Package_Specification)))
 	      process_decls (Visible_Declarations (Specification (gnat_decl)),
 			     Private_Declarations (Specification (gnat_decl)),
-			     Empty, true, false);
+			     true, false);
 
 	    /* Similarly for any declarations in the actions of a
 	       freeze node.  */
 	    else if (Nkind (gnat_decl) == N_Freeze_Entity)
 	      {
 		process_freeze_entity (gnat_decl);
-		process_decls (Actions (gnat_decl), Empty, Empty, true, false);
+		process_decls (Actions (gnat_decl), Empty, true, false);
 	      }
 
 	    /* Package bodies with freeze nodes get their elaboration deferred
@@ -9308,7 +9293,8 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
     for (i = 0; i <= 1; i++)
       if (Present (gnat_decl_array[i]))
 	for (gnat_decl = First (gnat_decl_array[i]);
-	     gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
+	     Present (gnat_decl);
+	     gnat_decl = Next (gnat_decl))
 	  {
 	    if (Nkind (gnat_decl) == N_Subprogram_Body
 		|| Nkind (gnat_decl) == N_Subprogram_Body_Stub
@@ -9321,10 +9307,10 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
 				== N_Package_Specification)))
 	      process_decls (Visible_Declarations (Specification (gnat_decl)),
 			     Private_Declarations (Specification (gnat_decl)),
-			     Empty, false, true);
+			     false, true);
 
 	    else if (Nkind (gnat_decl) == N_Freeze_Entity)
-	      process_decls (Actions (gnat_decl), Empty, Empty, false, true);
+	      process_decls (Actions (gnat_decl), Empty, false, true);
 
 	    else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
 	      add_stmt (gnat_to_gnu (gnat_decl));