https://gcc.gnu.org/g:9fe127c9c6320dea32d6441e10b654a7e2ab004c
commit r15-1272-g9fe127c9c6320dea32d6441e10b654a7e2ab004c Author: Ronan Desplanques <desplanq...@adacore.com> Date: Thu Apr 25 12:09:16 2024 +0200 ada: Fix expansion of protected subprogram bodies System.Tasking.Protected_Objects.Lock can raise exceptions, but that wasn't taken into account by the expansion of protected subprogram bodies before this patch. More precisely, there were cases where calls to System.Tasking.Initialization.Abort_Undefer were incorrectly omitted. This patch fixes this. gcc/ada/ * exp_ch7.adb (Build_Cleanup_Statements): Adapt to changes made to Build_Protected_Subprogram_Call_Cleanup. * exp_ch9.adb (Make_Unlock_Statement, Wrap_Unprotected_Call): New functions. (Build_Protected_Subprogram_Body): Fix resource management in generated code. (Build_Protected_Subprogram_Call_Cleanup): Make use of newly introduced Make_Unlock_Statement. Diff: --- gcc/ada/exp_ch7.adb | 37 +-------- gcc/ada/exp_ch9.adb | 228 ++++++++++++++++++++++++++++++++-------------------- 2 files changed, 147 insertions(+), 118 deletions(-) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 3583ed3138f4..b34b4c967fb5 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1318,41 +1318,12 @@ package body Exp_Ch7 is Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master)); end if; - -- Add statements to unlock the protected object parameter and to - -- undefer abort. If the context is a protected procedure and the object - -- has entries, call the entry service routine. - - -- NOTE: The generated code references _object, a parameter to the - -- procedure. + -- Add statements to undefer abort. elsif Is_Protected_Subp_Body then - declare - Spec : constant Node_Id := Parent (Corresponding_Spec (N)); - Conc_Typ : Entity_Id := Empty; - Param : Node_Id; - Param_Typ : Entity_Id; - - begin - -- Find the _object parameter representing the protected object - - Param := First (Parameter_Specifications (Spec)); - loop - Param_Typ := Etype (Parameter_Type (Param)); - - if Ekind (Param_Typ) = E_Record_Type then - Conc_Typ := Corresponding_Concurrent_Type (Param_Typ); - end if; - - exit when No (Param) or else Present (Conc_Typ); - Next (Param); - end loop; - - pragma Assert (Present (Param)); - pragma Assert (Present (Conc_Typ)); - - Build_Protected_Subprogram_Call_Cleanup - (Specification (N), Conc_Typ, Loc, Stmts); - end; + if Abort_Allowed then + Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated -- tasks. Other unactivated tasks are completed by Complete_Task or diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 4de253ab6e83..890bd038c5b9 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -442,6 +442,15 @@ package body Exp_Ch9 is -- Determine whether Id is a function or a procedure and is marked as a -- private primitive. + function Make_Unlock_Statement + (Prot_Type : E_Protected_Type_Id; + Op_Spec : N_Subprogram_Specification_Id; + Loc : Source_Ptr) return N_Procedure_Call_Statement_Id; + -- Build a statement that is suitable to unlock an object of type Prot_Type + -- after having performed a protected operation on it. Prot_Type and + -- Op_Spec are used to determine which unlocking subprogram to call, and + -- whether to serve entries before unlocking. + function Null_Statements (Stats : List_Id) return Boolean; -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well @@ -496,6 +505,18 @@ package body Exp_Ch9 is -- a rescheduling is required, so this optimization is not allowed. This -- function returns True if the optimization is permitted. + function Wrap_Unprotected_Call + (Call : Node_Id; + Prot_Type : E_Protected_Type_Id; + Op_Spec : N_Subprogram_Specification_Id; + Loc : Source_Ptr) return N_Block_Statement_Id; + -- Wrap Call into a block statement with a cleanup procedure set up to + -- release the lock on a protected object of type Prot_Type. Call must be + -- a statement that represents the inner and unprotected execution of the + -- body of a protected operation. Op_Spec must be the spec of that + -- protected operation. This is a subsidiary subprogram of + -- Build_Protected_Subprogram_Body. + ----------------------------- -- Actual_Index_Expression -- ----------------------------- @@ -3849,16 +3870,6 @@ package body Exp_Ch9 is Lock_Kind := RE_Lock; end if; - -- Wrap call in block that will be covered by an at_end handler - - if Might_Raise then - Unprot_Call := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Unprot_Call))); - end if; - -- Make the protected subprogram body. This locks the protected -- object and calls the unprotected version of the subprogram. @@ -3889,18 +3900,24 @@ package body Exp_Ch9 is Name => Lock_Name, Parameter_Associations => New_List (Object_Parm)); - if Abort_Allowed then - Stmts := New_List ( - Build_Runtime_Call (Loc, RE_Abort_Defer), - Lock_Stmt); - - else - Stmts := New_List (Lock_Stmt); - end if; + Stmts := (if Abort_Allowed then + New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)) + else + New_List); if Might_Raise then + Unprot_Call := Wrap_Unprotected_Call + (Unprot_Call, Pid, Op_Spec, Loc); + + Unprot_Call := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Lock_Stmt, Unprot_Call))); + Append (Unprot_Call, Stmts); else + Append (Lock_Stmt, Stmts); if Nkind (Op_Spec) = N_Function_Specification then Pre_Stmts := Stmts; Stmts := Empty_List; @@ -4022,74 +4039,10 @@ package body Exp_Ch9 is Loc : Source_Ptr; Stmts : List_Id) is - Nam : Node_Id; - + Unlock_Stmt : constant N_Procedure_Call_Statement_Id := + Make_Unlock_Statement (Conc_Typ, Op_Spec, Loc); begin - -- If the associated protected object has entries, the expanded - -- exclusive protected operation has to service entry queues. In - -- this case generate: - - -- Service_Entries (_object._object'Access); - - if (Nkind (Op_Spec) = N_Procedure_Specification - or else - (Nkind (Op_Spec) = N_Function_Specification - and then - Has_Enabled_Aspect - (Conc_Typ, Aspect_Exclusive_Functions))) - and then Has_Entries (Conc_Typ) - then - case Corresponding_Runtime_Package (Conc_Typ) is - when System_Tasking_Protected_Objects_Entries => - Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); - - when System_Tasking_Protected_Objects_Single_Entry => - Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); - - when others => - raise Program_Error; - end case; - - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => Nam, - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uObject), - Selector_Name => Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)))); - - else - -- Generate: - -- Unlock (_object._object'Access); - - case Corresponding_Runtime_Package (Conc_Typ) is - when System_Tasking_Protected_Objects_Entries => - Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); - - when System_Tasking_Protected_Objects_Single_Entry => - Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); - - when System_Tasking_Protected_Objects => - Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); - - when others => - raise Program_Error; - end case; - - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => Nam, - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uObject), - Selector_Name => Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)))); - end if; + Append_To (Stmts, Unlock_Stmt); -- Generate: -- Abort_Undefer; @@ -14495,6 +14448,66 @@ package body Exp_Ch9 is Parameter_Associations => Args); end Make_Task_Create_Call; + --------------------------- + -- Make_Unlock_Statement -- + --------------------------- + + function Make_Unlock_Statement + (Prot_Type : E_Protected_Type_Id; + Op_Spec : N_Subprogram_Specification_Id; + Loc : Source_Ptr) return N_Procedure_Call_Statement_Id + is + Nam : constant N_Identifier_Id := + -- If the associated protected object has entries, the expanded + -- exclusive protected operation has to service entry queues. + + (if (Nkind (Op_Spec) = N_Procedure_Specification + or else + (Nkind (Op_Spec) = N_Function_Specification + and then + Has_Enabled_Aspect + (Prot_Type, Aspect_Exclusive_Functions))) + and then Has_Entries (Prot_Type) + then + (case Corresponding_Runtime_Package (Prot_Type) is + when System_Tasking_Protected_Objects_Entries => + New_Occurrence_Of (RTE (RE_Service_Entries), Loc), + + when System_Tasking_Protected_Objects_Single_Entry => + New_Occurrence_Of (RTE (RE_Service_Entry), Loc), + + when others => + raise Program_Error) + + -- Otherwise, unlocking the protected object is sufficient. + + else + (case Corresponding_Runtime_Package (Prot_Type) is + when System_Tasking_Protected_Objects_Entries => + New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc), + + when System_Tasking_Protected_Objects_Single_Entry => + New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc), + + when System_Tasking_Protected_Objects => + New_Occurrence_Of (RTE (RE_Unlock), Loc), + + when others => + raise Program_Error)); + begin + return Make_Procedure_Call_Statement + (Loc, + Name => Nam, + Parameter_Associations => + New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uObject), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access))); + end Make_Unlock_Statement; + ------------------------------ -- Next_Protected_Operation -- ------------------------------ @@ -14861,4 +14874,49 @@ package body Exp_Ch9 is end case; end Trivial_Accept_OK; + --------------------------- + -- Wrap_Unprotected_Call -- + --------------------------- + + function Wrap_Unprotected_Call + (Call : Node_Id; + Prot_Type : E_Protected_Type_Id; + Op_Spec : N_Subprogram_Specification_Id; + Loc : Source_Ptr) return N_Block_Statement_Id + is + Body_Id : constant N_Defining_Identifier_Id := + Make_Defining_Identifier (Loc, Name_Find ("_unlock")); + + Unlock_Body : constant N_Subprogram_Body_Id := + Make_Subprogram_Body + (Loc, + Specification => + Make_Procedure_Specification (Loc, Defining_Unit_Name => Body_Id), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements + (Loc, Statements => New_List + (Make_Unlock_Statement (Prot_Type, Op_Spec, Loc)))); + + Decls : constant List_Id := New_List (Unlock_Body); + + HSS : constant N_Handled_Sequence_Of_Statements_Id := + Make_Handled_Sequence_Of_Statements + (Loc, Statements => New_List (Call), + At_End_Proc => New_Occurrence_Of (Body_Id, Loc)); + + Block_Statement : constant N_Block_Statement_Id := + Make_Block_Statement + (Loc, Declarations => Decls, + Handled_Statement_Sequence => + HSS); + + begin + if Debug_Generated_Code then + Set_Debug_Info_Needed (Body_Id); + end if; + + Set_Acts_As_Spec (Unlock_Body); + + return Block_Statement; + end Wrap_Unprotected_Call; end Exp_Ch9;