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

[multiple changes] 

2014-07-30  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call): New
	parameter Chain to be used in the allocator case.
	(Make_Build_In_Place_Call_In_Allocator): If the allocated object
	has tasks, wrap the code in a block that will activate them,
	including the usual finalization code to kill them off in case
	of exception or abort.

2014-07-30  Robert Dewar  <dewar@adacore.com>

	* treepr.adb, treepr.ads; Reorganize documentation for new pp routines
	Remove renamings (don't work for gdb).
	(par): New synonym for p (avoid gdb ambiguities).
	* inline.adb, sem_ch6.adb, sem_ch13.adb: Minor reformatting.

From-SVN: r213249
This commit is contained in:
Arnaud Charlet 2014-07-30 12:50:23 +02:00
parent 6be44a9ab0
commit 1399d355cb
7 changed files with 222 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/ada/ChangeLog
View File

@ -1,3 +1,19 @@
2014-07-30 Bob Duff <duff@adacore.com>
* exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call): New
parameter Chain to be used in the allocator case.
(Make_Build_In_Place_Call_In_Allocator): If the allocated object
has tasks, wrap the code in a block that will activate them,
including the usual finalization code to kill them off in case
of exception or abort.
2014-07-30 Robert Dewar <dewar@adacore.com>
* treepr.adb, treepr.ads; Reorganize documentation for new pp routines
Remove renamings (don't work for gdb).
(par): New synonym for p (avoid gdb ambiguities).
* inline.adb, sem_ch6.adb, sem_ch13.adb: Minor reformatting.
2014-07-30 Bob Duff <duff@adacore.com>
* exp_ch9.ads, sem_prag.adb, exp_ch4.adb, sem_ch13.adb: Minor comment

229
gcc/ada/exp_ch6.adb
View File

@ -125,7 +125,8 @@ package body Exp_Ch6 is
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Master_Actual : Node_Id);
Master_Actual : Node_Id;
Chain : Node_Id := Empty);
-- Ada 2005 (AI-318-02): For a build-in-place call, if the result type
-- contains tasks, add two actual parameters: the master, and a pointer to
-- the caller's activation chain. Master_Actual is the actual parameter
@ -133,9 +134,11 @@ package body Exp_Ch6 is
-- master (_master). The two exceptions are: If the function call is the
-- initialization expression for an allocator, we pass the master of the
-- access type. If the function call is the initialization expression for a
-- return object, we pass along the master passed in by the caller. The
-- activation chain to pass is always the local one. Note: Master_Actual
-- can be Empty, but only if there are no tasks.
-- return object, we pass along the master passed in by the caller. In most
-- contexts, the activation chain to pass is the local one, which is
-- indicated by No (Chain). However, in an allocator, the caller passes in
-- the activation Chain. Note: Master_Actual can be Empty, but only if
-- there are no tasks.
procedure Check_Overriding_Operation (Subp : Entity_Id);
-- Subp is a dispatching operation. Check whether it may override an
@ -506,7 +509,8 @@ package body Exp_Ch6 is
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
Master_Actual : Node_Id)
Master_Actual : Node_Id;
Chain : Node_Id := Empty)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Result_Subt : constant Entity_Id :=
@ -554,10 +558,20 @@ package body Exp_Ch6 is
-- Create the actual which is a pointer to the current activation chain
Chain_Actual :=
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uChain),
Attribute_Name => Name_Unrestricted_Access);
if No (Chain) then
Chain_Actual :=
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uChain),
Attribute_Name => Name_Unrestricted_Access);
-- Allocator case; make a reference to the Chain passed in by the caller
else
Chain_Actual :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Chain, Loc),
Attribute_Name => Name_Unrestricted_Access);
end if;
Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal));
@ -8499,10 +8513,16 @@ package body Exp_Ch6 is
Acc_Type : constant Entity_Id := Etype (Allocator);
Loc : Source_Ptr;
Func_Call : Node_Id := Function_Call;
Ref_Func_Call : Node_Id;
Function_Id : Entity_Id;
Result_Subt : Entity_Id;
New_Allocator : Node_Id;
Return_Obj_Access : Entity_Id;
Return_Obj_Access : Entity_Id; -- temp for function result
Temp_Init : Node_Id; -- initial value of Return_Obj_Access
Alloc_Form : BIP_Allocation_Form;
Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool
Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case
Chain : Entity_Id; -- activation chain, in case of tasks
begin
-- Step past qualification or unchecked conversion (the latter can occur
@ -8541,14 +8561,16 @@ package body Exp_Ch6 is
Result_Subt := Available_View (Etype (Function_Id));
-- Check whether return type includes tasks. This may not have been done
-- previously, if the type was a limited view.
-- Create a temp for the function result. In the caller-allocates case,
-- this will be initialized to the result of a new uninitialized
-- allocator. Note: we do not use Allocator as the Related_Node of
-- Return_Obj_Access in call to Make_Temporary below as this would
-- create a sort of infinite "recursion".
if Has_Task (Result_Subt) then
Build_Activation_Chain_Entity (Allocator);
end if;
Return_Obj_Access := Make_Temporary (Loc, 'R');
Set_Etype (Return_Obj_Access, Acc_Type);
-- When the result subtype is constrained, the return object must be
-- When the result subtype is constrained, the return object is
-- allocated on the caller side, and access to it is passed to the
-- function.
@ -8580,57 +8602,29 @@ package body Exp_Ch6 is
Rewrite (Allocator, New_Allocator);
-- Create a new access object and initialize it to the result of the
-- new uninitialized allocator. Note: we do not use Allocator as the
-- Related_Node of Return_Obj_Access in call to Make_Temporary below
-- as this would create a sort of infinite "recursion".
-- Initial value of the temp is the result of the uninitialized
-- allocator
Return_Obj_Access := Make_Temporary (Loc, 'R');
Set_Etype (Return_Obj_Access, Acc_Type);
Temp_Init := Relocate_Node (Allocator);
Insert_Action (Allocator,
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Obj_Access,
Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
Expression => Relocate_Node (Allocator)));
-- Indicate that caller allocates, and pass in the return object
-- When the function has a controlling result, an allocation-form
-- parameter must be passed indicating that the caller is allocating
-- the result object. This is needed because such a function can be
-- called as a dispatching operation and must be treated similarly
-- to functions with unconstrained result subtypes.
Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
-- Add an implicit actual to the function call that provides access
-- to the allocated object. An unchecked conversion to the (specific)
-- result subtype of the function is inserted to handle cases where
-- the access type of the allocator has a class-wide designated type.
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call,
Function_Id,
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
Expression =>
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Return_Obj_Access, Loc))));
Alloc_Form := Caller_Allocation;
Pool := Make_Null (No_Location);
Return_Obj_Actual :=
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
Expression =>
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)));
-- When the result subtype is unconstrained, the function itself must
-- perform the allocation of the return object, so we pass parameters
-- indicating that. We don't yet handle the case where the allocation
-- must be done in a user-defined storage pool, which will require
-- passing another actual or two to provide allocation/deallocation
-- operations. ???
-- indicating that.
else
Temp_Init := Empty;
-- Case of a user-defined storage pool. Pass an allocation parameter
-- indicating that the function should allocate its result in the
-- pool, and pass the pool. Use 'Unrestricted_Access because the
@ -8639,36 +8633,103 @@ package body Exp_Ch6 is
if VM_Target = No_VM
and then Present (Associated_Storage_Pool (Acc_Type))
then
Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => User_Storage_Pool,
Pool_Actual =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Associated_Storage_Pool (Acc_Type), Loc),
Attribute_Name => Name_Unrestricted_Access));
Alloc_Form := User_Storage_Pool;
Pool :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Associated_Storage_Pool (Acc_Type), Loc),
Attribute_Name => Name_Unrestricted_Access);
-- No user-defined pool; pass an allocation parameter indicating that
-- the function should allocate its result on the heap.
else
Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Global_Heap);
Alloc_Form := Global_Heap;
Pool := Make_Null (No_Location);
end if;
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
-- The caller does not provide the return object in this case, so we
-- have to pass null for the object access actual.
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Return_Object => Empty);
Return_Obj_Actual := Empty;
end if;
-- Declare the temp object
Insert_Action (Allocator,
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Obj_Access,
Object_Definition => New_Occurrence_Of (Acc_Type, Loc),
Expression => Temp_Init));
Ref_Func_Call := Make_Reference (Loc, Func_Call);
-- Ada 2005 (AI-251): If the type of the allocator is an interface
-- then generate an implicit conversion to force displacement of the
-- "this" pointer.
if Is_Interface (Designated_Type (Acc_Type)) then
Rewrite
(Ref_Func_Call,
OK_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);
-- 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,
-- this is setting the temp to point to the object allocated by the
-- callee.
Actions : List_Id;
-- Actions to be inserted. If there are no tasks, this is just the
-- assignment statement. If the allocated object has tasks, we need
-- 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;
Build_Task_Allocate_Block_With_Init_Stmts
(Actions, Allocator, Init_Stmts => New_List (Assign));
Chain := Activation_Chain_Entity (Last (Actions));
else
Actions := New_List (Assign);
Chain := Empty;
end if;
Insert_Actions (Allocator, Actions);
end;
-- When the function has a controlling result, an allocation-form
-- parameter must be passed indicating that the caller is allocating
-- the result object. This is needed because such a function can be
-- called as a dispatching operation and must be treated similarly
-- to functions with unconstrained result subtypes.
Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool);
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type),
Chain => Chain);
-- Add an implicit actual to the function call that provides access
-- to the allocated object. An unchecked conversion to the (specific)
-- result subtype of the function is inserted to handle cases where
-- the access type of the allocator has a class-wide designated type.
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Return_Obj_Actual);
-- If the build-in-place function call returns a controlled object,
-- the finalization master will require a reference to routine
-- Finalize_Address of the designated type. Setting this attribute
@ -8696,19 +8757,9 @@ package body Exp_Ch6 is
end if;
end if;
-- Finally, replace the allocator node with a reference to the result
-- of the function call itself (which will effectively be an access
-- to the object created by the allocator).
-- Finally, replace the allocator node with a reference to the temp
Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call)));
-- Ada 2005 (AI-251): If the type of the allocator is an interface then
-- generate an implicit conversion to force displacement of the "this"
-- pointer.
if Is_Interface (Designated_Type (Acc_Type)) then
Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator)));
end if;
Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
Analyze_And_Resolve (Allocator, Acc_Type);
end Make_Build_In_Place_Call_In_Allocator;

13
gcc/ada/inline.adb
View File

@ -1490,12 +1490,11 @@ package body Inline is
function Has_Some_Contract (Id : Entity_Id) return Boolean is
Items : constant Node_Id := Contract (Id);
begin
return Present (Items)
and then (Present (Pre_Post_Conditions (Items))
or else Present (Contract_Test_Cases (Items))
or else Present (Classifications (Items)));
and then (Present (Pre_Post_Conditions (Items)) or else
Present (Contract_Test_Cases (Items)) or else
Present (Classifications (Items)));
end Has_Some_Contract;
--------------------------
@ -1559,6 +1558,10 @@ package body Inline is
Id := Body_Id;
end if;
-- General note. The following comments clearly say what cannot be
-- inlined, but they do not give any clue on the motivation for the
-- exclusion. It would be good to document the motivations ???
-- Do not inline unit-level subprograms
if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
@ -1588,6 +1591,8 @@ package body Inline is
then
return False;
-- Do not inline generic subprogram instances
elsif Is_Generic_Instance (Spec_Id) then
return False;

1
gcc/ada/sem_ch13.adb
View File

@ -2013,7 +2013,6 @@ package body Sem_Ch13 is
declare
Discard : Entity_Id;
pragma Warnings (Off, Discard);
begin
if Restricted_Profile then
Discard := RTE (RE_Activate_Restricted_Tasks);

32
gcc/ada/sem_ch6.adb
View File

@ -2169,7 +2169,7 @@ package body Sem_Ch6 is
function Body_Has_Contract return Boolean;
-- Check whether unanalyzed body has an aspect or pragma that may
-- generate a SPARK contrac.
-- generate a SPARK contract.
procedure Check_Anonymous_Return;
-- Ada 2005: if a function returns an access type that denotes a task,
@ -2363,13 +2363,13 @@ package body Sem_Ch6 is
while Present (A_Spec) loop
A := Get_Aspect_Id (Chars (Identifier (A_Spec)));
if A = Aspect_Contract_Cases
or else A = Aspect_Depends
or else A = Aspect_Global
or else A = Aspect_Pre
or else A = Aspect_Precondition
or else A = Aspect_Post
or else A = Aspect_Postcondition
if A = Aspect_Contract_Cases or else
A = Aspect_Depends or else
A = Aspect_Global or else
A = Aspect_Pre or else
A = Aspect_Precondition or else
A = Aspect_Post or else
A = Aspect_Postcondition
then
return True;
end if;
@ -2378,7 +2378,7 @@ package body Sem_Ch6 is
end loop;
end if;
-- Check for pragmas that may generate a contract.
-- Check for pragmas that may generate a contract
if Present (Decls) then
Decl := First (Decls);
@ -2386,13 +2386,13 @@ package body Sem_Ch6 is
if Nkind (Decl) = N_Pragma then
P_Id := Get_Pragma_Id (Pragma_Name (Decl));
if P_Id = Pragma_Contract_Cases
or else P_Id = Pragma_Depends
or else P_Id = Pragma_Global
or else P_Id = Pragma_Pre
or else P_Id = Pragma_Precondition
or else P_Id = Pragma_Post
or else P_Id = Pragma_Postcondition
if P_Id = Pragma_Contract_Cases or else
P_Id = Pragma_Depends or else
P_Id = Pragma_Global or else
P_Id = Pragma_Pre or else
P_Id = Pragma_Precondition or else
P_Id = Pragma_Post or else
P_Id = Pragma_Postcondition
then
return True;
end if;

24
gcc/ada/treepr.adb
View File

@ -236,6 +236,18 @@ package body Treepr is
end case;
end p;
---------
-- par --
---------
function par (N : Union_Id) return Node_Or_Entity_Id renames p;
--------
-- pe --
--------
procedure pe (N : Union_Id) renames pn;
--------
-- pl --
--------
@ -314,6 +326,18 @@ package body Treepr is
end case;
end pn;
--------
-- pp --
--------
procedure pp (N : Union_Id) renames pn;
---------
-- ppp --
---------
procedure ppp (N : Union_Id) renames pt;
----------------
-- Print_Char --
----------------

28
gcc/ada/treepr.ads
View File

@ -60,22 +60,33 @@ package Treepr is
-- Prints the subtree consisting of the given element list and all its
-- referenced descendants.
-- The following debugging procedures are intended to be called from gdb
-- The following debugging procedures are intended to be called from gdb.
-- Note that in several cases there are synonyms which represent historical
-- development, and we keep them because some people are used to them!
function p (N : Union_Id) return Node_Or_Entity_Id;
function p (N : Union_Id) return Node_Or_Entity_Id;
function par (N : Union_Id) return Node_Or_Entity_Id;
pragma Export (Ada, p);
-- Returns parent of a list or node (depending on the value of N). If N
pragma Export (Ada, par);
-- Return parent of a list or node (depending on the value of N). If N
-- is neither a list nor a node id, then prints a message to that effect
-- and returns Empty.
procedure pn (N : Union_Id);
-- Prints a node, node list, uint, or anything else that falls under
procedure pp (N : Union_Id);
procedure pe (N : Union_Id);
pragma Export (Ada, pn);
pragma Export (Ada, pp);
pragma Export (Ada, pe);
-- Print a node, node list, uint, or anything else that falls under
-- the definition of Union_Id. Historically this was only for printing
-- nodes, hence the name.
procedure pt (N : Union_Id);
procedure pt (N : Union_Id);
procedure ppp (N : Union_Id);
pragma Export (Ada, pt);
-- Same as pn, except prints subtrees. For Nodes, it is exactly the same
pragma Export (Ada, ppp);
-- Same as pn/pp, except prints subtrees. For Nodes, it is exactly the same
-- as Print_Node_Subtree. For Elists it is the same as Print_Elist_Subtree.
-- For Lists, it is the same as Print_Tree_List. If given anything other
-- than a Node, List, or Elist, same effect as pn.
@ -87,9 +98,4 @@ package Treepr is
-- on the left and add a minus sign. This just saves some typing in the
-- debugger.
procedure pe (N : Union_Id) renames pt;
procedure pp (N : Union_Id) renames pn;
procedure ppp (N : Union_Id) renames pt;
-- Synonyms retained for historical reasons
end Treepr;