OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Double finalization of limited controlled result

Browse Source 
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
This commit is contained in:
Hristian Kirtchev 2018-06-11 09:19:30 +00:00 committed by Pierre-Marie de Rodat
parent 557b744a6e
commit 7d1d3a5464
3 changed files with 336 additions and 270 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/ada/ChangeLog
View File

@ -1,3 +1,25 @@
2018-06-11 Hristian Kirtchev <kirtchev@adacore.com>
* 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.
2018-06-11 Olivier Hainque <hainque@adacore.com>
* libgnat/s-excmac*.ads: Factorize Unwind_Action definitions ...

576
gcc/ada/exp_ch6.adb
View File

@ -336,22 +336,18 @@ package body Exp_Ch6 is
Alloc_Form_Exp : Node_Id := Empty;
Pool_Actual : Node_Id := Make_Null (No_Location))
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Loc : constant Source_Ptr := Sloc (Function_Call);
Alloc_Form_Actual : Node_Id;
Alloc_Form_Formal : Node_Id;
Pool_Formal : Node_Id;
begin
-- The allocation form generally doesn't need to be passed in the case
-- of a constrained result subtype, since normally the caller performs
-- the allocation in that case. However this formal is still needed in
-- the case where the function has a tagged result, because generally
-- such functions can be called in a dispatching context and such calls
-- must be handled like calls to class-wide functions.
-- Nothing to do when the size of the object is known, and the caller is
-- in charge of allocating it, and the callee doesn't unconditionally
-- require an allocation form (such as due to having a tagged result).
if Is_Constrained (Underlying_Type (Etype (Function_Id)))
and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
then
if not Needs_BIP_Alloc_Form (Function_Id) then
return;
end if;
@ -382,8 +378,8 @@ package body Exp_Ch6 is
Add_Extra_Actual_To_Call
(Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
-- Pass the Storage_Pool parameter. This parameter is omitted on
-- ZFP as those targets do not support pools.
-- Pass the Storage_Pool parameter. This parameter is omitted on ZFP as
-- those targets do not support pools.
if RTE_Available (RE_Root_Storage_Pool_Ptr) then
Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool);
@ -4488,38 +4484,46 @@ package body Exp_Ch6 is
-- That is, we need to have a reified return object if there are statements
-- (which might refer to it) or if we're doing build-in-place (so we can
-- set its address to the final resting place or if there is no expression
-- (in which case default initial values might need to be set).
-- (in which case default initial values might need to be set)).
procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
function Build_Heap_Allocator
function Build_Heap_Or_Pool_Allocator
(Temp_Id : Entity_Id;
Temp_Typ : Entity_Id;
Func_Id : Entity_Id;
Ret_Typ : Entity_Id;
Alloc_Expr : Node_Id) return Node_Id;
-- Create the statements necessary to allocate a return object on the
-- caller's master. The master is available through implicit parameter
-- BIPfinalizationmaster.
-- heap or user-defined storage pool. The object may need finalization
-- actions depending on the return type.
--
-- if BIPfinalizationmaster /= null then
-- declare
-- type Ptr_Typ is access Ret_Typ;
-- for Ptr_Typ'Storage_Pool use
-- Base_Pool (BIPfinalizationmaster.all).all;
-- Local : Ptr_Typ;
-- * Controlled case
--
-- if BIPfinalizationmaster = null then
-- Temp_Id := <Alloc_Expr>;
-- else
-- declare
-- type Ptr_Typ is access Ret_Typ;
-- for Ptr_Typ'Storage_Pool use
-- Base_Pool (BIPfinalizationmaster.all).all;
-- Local : Ptr_Typ;
--
-- begin
-- procedure Allocate (...) is
-- begin
-- System.Storage_Pools.Subpools.Allocate_Any (...);
-- end Allocate;
-- procedure Allocate (...) is
-- begin
-- System.Storage_Pools.Subpools.Allocate_Any (...);
-- end Allocate;
--
-- Local := <Alloc_Expr>;
-- Temp_Id := Temp_Typ (Local);
-- end;
-- end if;
-- Local := <Alloc_Expr>;
-- Temp_Id := Temp_Typ (Local);
-- end;
-- end if;
--
-- * Non-controlled case
--
-- Temp_Id := <Alloc_Expr>;
--
-- Temp_Id is the temporary which is used to reference the internally
-- created object in all allocation forms. Temp_Typ is the type of the
@ -4536,11 +4540,11 @@ package body Exp_Ch6 is
-- Func_Id is the entity of the function where the extended return
-- statement appears.
--------------------------
-- Build_Heap_Allocator --
--------------------------
----------------------------------
-- Build_Heap_Or_Pool_Allocator --
----------------------------------
function Build_Heap_Allocator
function Build_Heap_Or_Pool_Allocator
(Temp_Id : Entity_Id;
Temp_Typ : Entity_Id;
Func_Id : Entity_Id;
@ -4550,7 +4554,7 @@ package body Exp_Ch6 is
begin
pragma Assert (Is_Build_In_Place_Function (Func_Id));
-- Processing for build-in-place object allocation.
-- Processing for objects that require finalization actions
if Needs_Finalization (Ret_Typ) then
declare
@ -4558,6 +4562,7 @@ package body Exp_Ch6 is
Fin_Mas_Id : constant Entity_Id :=
Build_In_Place_Formal
(Func_Id, BIP_Finalization_Master);
Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr);
Stmts : constant List_Id := New_List;
Desig_Typ : Entity_Id;
Local_Id : Entity_Id;
@ -4619,7 +4624,7 @@ package body Exp_Ch6 is
-- Perform minor decoration in order to set the master and the
-- storage pool attributes.
Set_Ekind (Ptr_Typ, E_Access_Type);
Set_Ekind (Ptr_Typ, E_Access_Type);
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
@ -4658,7 +4663,9 @@ package body Exp_Ch6 is
-- to a Finalize_Storage_Only allocation.
-- Generate:
-- if BIPfinalizationmaster /= null then
-- if BIPfinalizationmaster = null then
-- Temp_Id := <Orig_Expr>;
-- else
-- declare
-- <Decls>
-- begin
@ -4669,11 +4676,16 @@ package body Exp_Ch6 is
return
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Temp_Id, Loc),
Expression => Orig_Expr)),
Else_Statements => New_List (
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
@ -4690,7 +4702,7 @@ package body Exp_Ch6 is
Name => New_Occurrence_Of (Temp_Id, Loc),
Expression => Alloc_Expr);
end if;
end Build_Heap_Allocator;
end Build_Heap_Or_Pool_Allocator;
---------------------------
-- Move_Activation_Chain --
@ -5037,11 +5049,9 @@ package body Exp_Ch6 is
-- determine the form of allocation needed, initialization
-- is done with each part of the if statement that handles
-- the different forms of allocation (this is true for
-- unconstrained and tagged result subtypes).
-- unconstrained, tagged, and controlled result subtypes).
if Is_Constrained (Ret_Typ)
and then not Is_Tagged_Type (Underlying_Type (Ret_Typ))
then
if not Needs_BIP_Alloc_Form (Func_Id) then
Insert_After (Ret_Obj_Decl, Init_Assignment);
end if;
end if;
@ -5057,16 +5067,14 @@ package body Exp_Ch6 is
-- a storage pool. We generate an if statement to test the
-- implicit allocation formal and initialize a local access
-- value appropriately, creating allocators in the secondary
-- stack and global heap cases. The special formal also exists
-- stack and global heap cases. The special formal also exists
-- and must be tested when the function has a tagged result,
-- even when the result subtype is constrained, because in
-- general such functions can be called in dispatching contexts
-- and must be handled similarly to functions with a class-wide
-- result.
if not Is_Constrained (Ret_Typ)
or else Is_Tagged_Type (Underlying_Type (Ret_Typ))
then
if Needs_BIP_Alloc_Form (Func_Id) then
Obj_Alloc_Formal :=
Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
@ -5331,7 +5339,7 @@ package body Exp_Ch6 is
(Global_Heap)))),
Then_Statements => New_List (
Build_Heap_Allocator
Build_Heap_Or_Pool_Allocator
(Temp_Id => Alloc_Obj_Id,
Temp_Typ => Ref_Type,
Func_Id => Func_Id,
@ -5355,7 +5363,7 @@ package body Exp_Ch6 is
Then_Statements => New_List (
Pool_Decl,
Build_Heap_Allocator
Build_Heap_Or_Pool_Allocator
(Temp_Id => Alloc_Obj_Id,
Temp_Typ => Ref_Type,
Func_Id => Func_Id,
@ -7256,204 +7264,6 @@ package body Exp_Ch6 is
end if;
end Expand_Simple_Function_Return;
--------------------------------------------
-- Has_Unconstrained_Access_Discriminants --
--------------------------------------------
function Has_Unconstrained_Access_Discriminants
(Subtyp : Entity_Id) return Boolean
is
Discr : Entity_Id;
begin
if Has_Discriminants (Subtyp)
and then not Is_Constrained (Subtyp)
then
Discr := First_Discriminant (Subtyp);
while Present (Discr) loop
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
return True;
end if;
Next_Discriminant (Discr);
end loop;
end if;
return False;
end Has_Unconstrained_Access_Discriminants;
-----------------------------------
-- Is_Build_In_Place_Result_Type --
-----------------------------------
function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
begin
if not Expander_Active then
return False;
end if;
-- In Ada 2005 all functions with an inherently limited return type
-- must be handled using a build-in-place profile, including the case
-- of a function with a limited interface result, where the function
-- may return objects of nonlimited descendants.
if Is_Limited_View (Typ) then
return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
else
if Debug_Flag_Dot_9 then
return False;
end if;
if Has_Interfaces (Typ) then
return False;
end if;
declare
T : Entity_Id := Typ;
begin
-- For T'Class, return True if it's True for T. This is necessary
-- because a class-wide function might say "return F (...)", where
-- F returns the corresponding specific type. We need a loop in
-- case T is a subtype of a class-wide type.
while Is_Class_Wide_Type (T) loop
T := Etype (T);
end loop;
-- If this is a generic formal type in an instance, return True if
-- it's True for the generic actual type.
if Nkind (Parent (T)) = N_Subtype_Declaration
and then Present (Generic_Parent_Type (Parent (T)))
then
T := Entity (Subtype_Indication (Parent (T)));
if Present (Full_View (T)) then
T := Full_View (T);
end if;
end if;
if Present (Underlying_Type (T)) then
T := Underlying_Type (T);
end if;
declare
Result : Boolean;
-- So we can stop here in the debugger
begin
-- ???For now, enable build-in-place for a very narrow set of
-- controlled types. Change "if True" to "if False" to
-- experiment with more controlled types. Eventually, we might
-- like to enable build-in-place for all tagged types, all
-- types that need finalization, and all caller-unknown-size
-- types.
if True then
Result := Is_Controlled (T)
and then Present (Enclosing_Subprogram (T))
and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
else
Result := Is_Controlled (T);
end if;
return Result;
end;
end;
end if;
end Is_Build_In_Place_Result_Type;
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
begin
-- This function is called from Expand_Subtype_From_Expr during
-- semantic analysis, even when expansion is off. In those cases
-- the build_in_place expansion will not take place.
if not Expander_Active then
return False;
end if;
-- For now we test whether E denotes a function or access-to-function
-- type whose result subtype is inherently limited. Later this test
-- may be revised to allow composite nonlimited types. Functions with
-- a foreign convention or whose result type has a foreign convention
-- never qualify.
if Ekind_In (E, E_Function, E_Generic_Function)
or else (Ekind (E) = E_Subprogram_Type
and then Etype (E) /= Standard_Void_Type)
then
-- Note: If the function has a foreign convention, it cannot build
-- its result in place, so you're on your own. On the other hand,
-- if only the return type has a foreign convention, its layout is
-- intended to be compatible with the other language, but the build-
-- in place machinery can ensure that the object is not copied.
return Is_Build_In_Place_Result_Type (Etype (E))
and then not Has_Foreign_Convention (E)
and then not Debug_Flag_Dot_L;
else
return False;
end if;
end Is_Build_In_Place_Function;
-------------------------------------
-- Is_Build_In_Place_Function_Call --
-------------------------------------
function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
Exp_Node : constant Node_Id := Unqual_Conv (N);
Function_Id : Entity_Id;
begin
-- Return False if the expander is currently inactive, since awareness
-- of build-in-place treatment is only relevant during expansion. Note
-- that Is_Build_In_Place_Function, which is called as part of this
-- function, is also conditioned this way, but we need to check here as
-- well to avoid blowing up on processing protected calls when expansion
-- is disabled (such as with -gnatc) since those would trip over the
-- raise of Program_Error below.
-- In SPARK mode, build-in-place calls are not expanded, so that we
-- may end up with a call that is neither resolved to an entity, nor
-- an indirect call.
if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then
return False;
end if;
if Is_Entity_Name (Name (Exp_Node)) then
Function_Id := Entity (Name (Exp_Node));
-- In the case of an explicitly dereferenced call, use the subprogram
-- type generated for the dereference.
elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
Function_Id := Etype (Name (Exp_Node));
-- This may be a call to a protected function.
elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
else
raise Program_Error;
end if;
declare
Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
-- So we can stop here in the debugger
begin
return Result;
end;
end Is_Build_In_Place_Function_Call;
-----------------------
-- Freeze_Subprogram --
-----------------------
@ -7646,6 +7456,32 @@ package body Exp_Ch6 is
end if;
end Freeze_Subprogram;
--------------------------------------------
-- Has_Unconstrained_Access_Discriminants --
--------------------------------------------
function Has_Unconstrained_Access_Discriminants
(Subtyp : Entity_Id) return Boolean
is
Discr : Entity_Id;
begin
if Has_Discriminants (Subtyp)
and then not Is_Constrained (Subtyp)
then
Discr := First_Discriminant (Subtyp);
while Present (Discr) loop
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
return True;
end if;
Next_Discriminant (Discr);
end loop;
end if;
return False;
end Has_Unconstrained_Access_Discriminants;
------------------------------
-- Insert_Post_Call_Actions --
------------------------------
@ -7768,6 +7604,177 @@ package body Exp_Ch6 is
end if;
end Insert_Post_Call_Actions;
-----------------------------------
-- Is_Build_In_Place_Result_Type --
-----------------------------------
function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
begin
if not Expander_Active then
return False;
end if;
-- In Ada 2005 all functions with an inherently limited return type
-- must be handled using a build-in-place profile, including the case
-- of a function with a limited interface result, where the function
-- may return objects of nonlimited descendants.
if Is_Limited_View (Typ) then
return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
else
if Debug_Flag_Dot_9 then
return False;
end if;
if Has_Interfaces (Typ) then
return False;
end if;
declare
T : Entity_Id := Typ;
begin
-- For T'Class, return True if it's True for T. This is necessary
-- because a class-wide function might say "return F (...)", where
-- F returns the corresponding specific type. We need a loop in
-- case T is a subtype of a class-wide type.
while Is_Class_Wide_Type (T) loop
T := Etype (T);
end loop;
-- If this is a generic formal type in an instance, return True if
-- it's True for the generic actual type.
if Nkind (Parent (T)) = N_Subtype_Declaration
and then Present (Generic_Parent_Type (Parent (T)))
then
T := Entity (Subtype_Indication (Parent (T)));
if Present (Full_View (T)) then
T := Full_View (T);
end if;
end if;
if Present (Underlying_Type (T)) then
T := Underlying_Type (T);
end if;
declare
Result : Boolean;
-- So we can stop here in the debugger
begin
-- ???For now, enable build-in-place for a very narrow set of
-- controlled types. Change "if True" to "if False" to
-- experiment with more controlled types. Eventually, we might
-- like to enable build-in-place for all tagged types, all
-- types that need finalization, and all caller-unknown-size
-- types.
if True then
Result := Is_Controlled (T)
and then Present (Enclosing_Subprogram (T))
and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
else
Result := Is_Controlled (T);
end if;
return Result;
end;
end;
end if;
end Is_Build_In_Place_Result_Type;
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
begin
-- This function is called from Expand_Subtype_From_Expr during
-- semantic analysis, even when expansion is off. In those cases
-- the build_in_place expansion will not take place.
if not Expander_Active then
return False;
end if;
-- For now we test whether E denotes a function or access-to-function
-- type whose result subtype is inherently limited. Later this test
-- may be revised to allow composite nonlimited types. Functions with
-- a foreign convention or whose result type has a foreign convention
-- never qualify.
if Ekind_In (E, E_Function, E_Generic_Function)
or else (Ekind (E) = E_Subprogram_Type
and then Etype (E) /= Standard_Void_Type)
then
-- Note: If the function has a foreign convention, it cannot build
-- its result in place, so you're on your own. On the other hand,
-- if only the return type has a foreign convention, its layout is
-- intended to be compatible with the other language, but the build-
-- in place machinery can ensure that the object is not copied.
return Is_Build_In_Place_Result_Type (Etype (E))
and then not Has_Foreign_Convention (E)
and then not Debug_Flag_Dot_L;
else
return False;
end if;
end Is_Build_In_Place_Function;
-------------------------------------
-- Is_Build_In_Place_Function_Call --
-------------------------------------
function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is
Exp_Node : constant Node_Id := Unqual_Conv (N);
Function_Id : Entity_Id;
begin
-- Return False if the expander is currently inactive, since awareness
-- of build-in-place treatment is only relevant during expansion. Note
-- that Is_Build_In_Place_Function, which is called as part of this
-- function, is also conditioned this way, but we need to check here as
-- well to avoid blowing up on processing protected calls when expansion
-- is disabled (such as with -gnatc) since those would trip over the
-- raise of Program_Error below.
-- In SPARK mode, build-in-place calls are not expanded, so that we
-- may end up with a call that is neither resolved to an entity, nor
-- an indirect call.
if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then
return False;
end if;
if Is_Entity_Name (Name (Exp_Node)) then
Function_Id := Entity (Name (Exp_Node));
-- In the case of an explicitly dereferenced call, use the subprogram
-- type generated for the dereference.
elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
Function_Id := Etype (Name (Exp_Node));
-- This may be a call to a protected function.
elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
else
raise Program_Error;
end if;
declare
Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
-- So we can stop here in the debugger
begin
return Result;
end;
end Is_Build_In_Place_Function_Call;
-----------------------
-- Is_Null_Procedure --
-----------------------
@ -7853,10 +7860,9 @@ package body Exp_Ch6 is
-- Step past qualification or unchecked conversion (the latter can occur
-- in cases of calls to 'Input).
if Nkind_In (Func_Call,
N_Qualified_Expression,
N_Type_Conversion,
N_Unchecked_Type_Conversion)
if Nkind_In (Func_Call, N_Qualified_Expression,
N_Type_Conversion,
N_Unchecked_Type_Conversion)
then
Func_Call := Expression (Func_Call);
end if;
@ -7889,16 +7895,37 @@ package body Exp_Ch6 is
Set_Can_Never_Be_Null (Acc_Type, False);
-- It gets initialized to null, so we can't have that
-- When the result subtype is constrained, the return object is
-- allocated on the caller side, and access to it is passed to the
-- function.
-- When the result subtype is constrained, the return object is created
-- on the caller side, and access to it is passed to the function. This
-- optimization is disabled when the result subtype needs finalization
-- actions because the caller side allocation may result in undesirable
-- finalization. Consider the following example:
--
-- function Make_Lim_Ctrl return Lim_Ctrl is
-- begin
-- return Result : Lim_Ctrl := raise Program_Error do
-- null;
-- end return;
-- end Make_Lim_Ctrl;
--
-- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl);
--
-- Even though the size of limited controlled type Lim_Ctrl is known,
-- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's
-- finalization master. The subsequent call to Make_Lim_Ctrl will fail
-- during the initialization actions for Result, which implies that
-- Result (and Obj by extension) should not be finalized. However Obj
-- will be finalized when access type Lim_Ctrl_Ptr goes out of scope
-- since it is already attached on the related finalization master.
-- Here and in related routines, we must examine the full view of the
-- type, because the view at the point of call may differ from that
-- that in the function body, and the expansion mechanism depends on
-- the characteristics of the full view.
if Is_Constrained (Underlying_Type (Result_Subt)) then
if Is_Constrained (Underlying_Type (Result_Subt))
and then not Needs_Finalization (Underlying_Type (Result_Subt))
then
-- Replace the initialized allocator of form "new T'(Func (...))"
-- with an uninitialized allocator of form "new T", where T is the
-- result subtype of the called function. The call to the function
@ -7926,8 +7953,8 @@ package body Exp_Ch6 is
Temp_Init := Relocate_Node (Allocator);
if Nkind_In
(Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
if Nkind_In (Function_Call, N_Type_Conversion,
N_Unchecked_Type_Conversion)
then
Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init);
end if;
@ -8001,17 +8028,17 @@ package body Exp_Ch6 is
-- that the full types will be compatible, but the types not visibly
-- compatible.
elsif Nkind_In
(Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
elsif Nkind_In (Function_Call, N_Type_Conversion,
N_Unchecked_Type_Conversion)
then
Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call);
end if;
declare
Assign : constant Node_Id :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Return_Obj_Access, Loc),
Expression => Ref_Func_Call);
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Return_Obj_Access, Loc),
Expression => Ref_Func_Call);
-- Assign the result of the function call into the temp. In the
-- caller-allocates case, this is overwriting the temp with its
-- initial value, which has no effect. In the callee-allocates case,
@ -8025,6 +8052,7 @@ package body Exp_Ch6 is
-- to wrap the assignment in a block that activates them. The
-- activation chain of that block must be passed to the function,
-- rather than some outer chain.
begin
if Has_Task (Result_Subt) then
Actions := New_List;
@ -9062,8 +9090,30 @@ package body Exp_Ch6 is
function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
begin
return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ);
-- A build-in-place function needs to know which allocation form to
-- use when:
--
-- 1) The result subtype is unconstrained. In this case, depending on
-- the context of the call, the object may need to be created in the
-- secondary stack, the heap, or a user-defined storage pool.
--
-- 2) The result subtype is tagged. In this case the function call may
-- dispatch on result and thus needs to be treated in the same way as
-- calls to functions with class-wide results, because a callee that
-- can be dispatched to may have any of various result subtypes, so
-- if any of the possible callees would require an allocation form to
-- be passed then they all do.
--
-- 3) The result subtype needs finalization actions. In this case, based
-- on the context of the call, the object may need to be created at
-- the caller site, in the heap, or in a user-defined storage pool.
return
not Is_Constrained (Func_Typ)
or else Is_Tagged_Type (Func_Typ)
or else Needs_Finalization (Func_Typ);
end Needs_BIP_Alloc_Form;
--------------------------------------

8
gcc/ada/exp_util.adb
View File

@ -682,16 +682,10 @@ package body Exp_Util is
if Needs_Fin then
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
if Restriction_Active (No_Finalization) then
return;
-- Do nothing if the access type may never allocate / deallocate
-- objects.
elsif No_Pool_Assigned (Ptr_Typ) then
if No_Pool_Assigned (Ptr_Typ) then
return;
end if;