From 1399d355cb74c0de280637c1ce678df71f4adb38 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 30 Jul 2014 12:50:23 +0200 Subject: [PATCH] [multiple changes] 2014-07-30 Bob Duff * 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 * 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 --- gcc/ada/ChangeLog | 16 +++ gcc/ada/exp_ch6.adb | 229 ++++++++++++++++++++++++++----------------- gcc/ada/inline.adb | 13 ++- gcc/ada/sem_ch13.adb | 1 - gcc/ada/sem_ch6.adb | 32 +++--- gcc/ada/treepr.adb | 24 +++++ gcc/ada/treepr.ads | 28 +++--- 7 files changed, 222 insertions(+), 121 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 868ddbbdc3c..1d457eb784f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2014-07-30 Bob Duff + + * 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 + + * 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 * exp_ch9.ads, sem_prag.adb, exp_ch4.adb, sem_ch13.adb: Minor comment diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 0688a3cc633..d059de3c67f 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index c2ee80783b3..e5ec8d5df04 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 1336e2132c4..a0262230cdd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index e2b267bb968..f7d79f969af 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 4adf382bdd4..964d39ccfb2 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -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 -- ---------------- diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads index b913014d08a..6ba58d6b2b2 100644 --- a/gcc/ada/treepr.ads +++ b/gcc/ada/treepr.ads @@ -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; -- 2.30.2