[Ada] Double finalization of limited controlled result

[Ada] Double finalization of limited controlled result

This patch disables a build-in-place optimization when a function returns a
limited controlled result because the optimization may violate the semantics of
finalizable types by performing illegal calls to Finalize.

In general, the optimization causes the result object of a build-in-place
function to be allocated at the caller site, with a pointer to the object
passed to the function. The function then simply initializes the caller-
allocated object.

This mode of operation however violates semantics of finalizable types when
the context of the call is allocation. The act of allocating the controlled
object at the caller site will place it on the associated access type's
finalization master. If the function fails the initialization of the object,
the malformed object will still be finalized when the finalization master
goes out of scope. This is dangerous, and must not happen.

------------
-- Source --
------------

--  pack.ads

with Ada.Finalization; use Ada.Finalization;

package Pack is
   type Lim_Ctrl is new Limited_Controlled with null record;
   procedure Finalize (Obj : in out Lim_Ctrl);

   type Lim_Ctrl_Ptr is access all Lim_Ctrl;

   function Make_Lim_Ctrl_Bad_Init return Lim_Ctrl;
   function Make_Lim_Ctrl_OK_Init return Lim_Ctrl;
end Pack;

--  pack.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Pack is
   procedure Finalize (Obj : in out Lim_Ctrl) is
   begin
      Put_Line ("     Finalize");
   end Finalize;

   function Make_Lim_Ctrl_Bad_Init return Lim_Ctrl is
   begin
      return Result : Lim_Ctrl := raise Program_Error do
         null;
      end return;
   end Make_Lim_Ctrl_Bad_Init;

   function Make_Lim_Ctrl_OK_Init return Lim_Ctrl is
   begin
      return Result : Lim_Ctrl do
         raise Program_Error;
      end return;
   end Make_Lim_Ctrl_OK_Init;
end Pack;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;
with Pack;        use Pack;

procedure Main is
begin
   begin
      Put_Line ("1) Heap-allocated bad init");

      declare
         Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl_Bad_Init);
      begin
         Put_Line ("1) ERROR: Heap-allocated bad init: exception not raised");
      end;

   exception
      when Program_Error =>
         Put_Line ("1) Heap-allocated bad init: Program_Error raised");
      when others =>
         Put_Line ("1) ERROR: Heap-allocatd bad init: unexpected exception");
   end;

   begin
      Put_Line ("2) Stack-allocated bad init");

      declare
         Obj : Lim_Ctrl := Make_Lim_Ctrl_Bad_Init;
      begin
         Put_Line ("2) ERROR: Stack-allocated bad init: exception not raised");
      end;

   exception
      when Program_Error =>
         Put_Line ("2) Stack-allocated bad init: Program_Error raised");
      when others =>
         Put_Line ("2) ERROR: Stack-allocated bad init: unexpected exception");
   end;

   begin
      Put_Line ("3) Heap-allocated OK init");

      declare
         Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl_OK_Init);
      begin
         Put_Line ("3) ERROR: Heap-allocated OK init: exception not raised");
      end;

   exception
      when Program_Error =>
         Put_Line ("3) Heap-allocated OK init: Program_Error raised");
      when others =>
         Put_Line ("3) ERROR: Heap-allocatd OK init: unexpected exception");
   end;

   begin
      Put_Line ("4) Stack-allocated OK init");

      declare
         Obj : Lim_Ctrl := Make_Lim_Ctrl_OK_Init;
      begin
         Put_Line ("4) ERROR: Stack-allocated OK init: exception not raised");
      end;

   exception
      when Program_Error =>
         Put_Line ("4) Stack-allocated OK init: Program_Error raised");
      when others =>
         Put_Line ("4) ERROR: Stack-allocated OK init: unexpected exception");
   end;
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q main.adb
$ ./main
1) Heap-allocated bad init
1) Heap-allocated bad init: Program_Error raised
2) Stack-allocated bad init
2) Stack-allocated bad init: Program_Error raised
3) Heap-allocated OK init
     Finalize
3) Heap-allocated OK init: Program_Error raised
4) Stack-allocated OK init
     Finalize
4) Stack-allocated OK init: Program_Error raised

2018-06-11  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_ch6.adb (Add_Unconstrained_Actuals_To_Build_In_Place_Call): Do
	not add any actuals when the size of the object is known, and the
	caller will allocate it.
	(Build_Heap_Allocator): Rename to Build_Heap_Or_Pool_Allocator to
	better illustrate its functionality. Update the comment on the
	generated code.  Generate a branch for the heap and pool cases where
	the object is not necessarity controlled.
	(Expand_N_Extended_Return_Statement): Expand the extended return
	statement into four branches depending the requested mode if the caller
	will not allocate the object on its side.
	(Make_Build_In_Place_Call_In_Allocator): Do not allocate a controlled
	object on the caller side because this will violate the semantics of
	finalizable types. Instead notify the function to allocate the object
	on the heap or a user-defined storage pool.
	(Needs_BIP_Alloc_Form): A build-in-place function needs to be notified
	which of the four modes to employ when returning a limited controlled
	result.
	* exp_util.adb (Build_Allocate_Deallocate_Proc): Remove a redundant
	guard which is already covered in Needs_Finalization.

From-SVN: r261427