From patchwork Thu Jun 13 13:33:20 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1947412 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=MwQC4Pfk; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4W0NnQ59W4z1ydW for ; Thu, 13 Jun 2024 23:39:54 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id B15FA3882648 for ; Thu, 13 Jun 2024 13:39:52 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lf1-x130.google.com (mail-lf1-x130.google.com [IPv6:2a00:1450:4864:20::130]) by sourceware.org (Postfix) with ESMTPS id AF2D1388264D for ; Thu, 13 Jun 2024 13:34:02 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org AF2D1388264D Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org AF2D1388264D Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::130 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718285647; cv=none; b=FFhi32PDOU2OacLrDRdNsbN3dDPNIz5V5xnIolxzFaWt7a9IBh3HQFkU88NcrqUlseTh5uu2eoOn/bif8lfglqYTx3YmCmaRnlssBlknspUWOG8E2GdPbV0619xVFGLkzduD+KiKvLRwQ8peWe6CkRSOgKep15+3ns13tKmTJLg= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718285647; c=relaxed/simple; bh=NpTTQklr2skYGh/KBTjUS8BRI2xrPwZKkoZPiV2Kfxs=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=lLTgkPzJOmcV4bJxaF5HUpVc84u9HMnB7ix/l122jYFrgcTr+eP7PbRXAfuGommiBB3VHFUKozGsI1Oj+OA9EUbt50jB26gfqzSQQI9VPgAPsnRfDVbfLRWAsSvU8HM/l5wH3XMwLcGpzX2gBYfLIwbBftPuk+7sB+0hLU4WcEs= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-lf1-x130.google.com with SMTP id 2adb3069b0e04-52c819f6146so1566951e87.1 for ; Thu, 13 Jun 2024 06:34:02 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1718285641; x=1718890441; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=vydKsrsEWZEqTTEopeyfvujQFVZqh1EAkqnKo3mu+Qc=; b=MwQC4PfkLXK1tns0eswozfuqA0UaYr4DljdCyGW6335BF1a42O9WuD/c2ESamCZIL9 bzzfTOd2XCBNwhkzL5KSEaObxmGBLZUAEYg+CgfNBpe/J2GijcAvGih5srvyFo54tlv0 CXklaAKPz12owgCX5wETf+85PZnxrPU0KUNzCSulCkhCCCFkqZo9fIKkuk3woDWeUDRP 6ZYIih7WWesPpr2BZESqVjY2XpAZWerrjvulJLyoaM0A9sK1NYrJi2wBzoS0j052Yn0+ Trf736/TvDzI1wTHl5ltL1HsLMlIU/T1z0Vvlk0LT3jMnLCzqOZa5WjatNtVDxg9HH9A F0Bg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1718285641; x=1718890441; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=vydKsrsEWZEqTTEopeyfvujQFVZqh1EAkqnKo3mu+Qc=; b=tPwitqR5XOaEJITzMUnbJkdWZSI2bHBNCNNDRoxZYJVr6FZaR+CbYTNQfltOELBdVc E1wiTXcMvNU3UJuHV38T+RaTdncnC+vbRh0urabn04YlFNiwrUvkhCKbcn3KeewFsZwt FjcWOq5Upb78JWhMmGZyO+G+WX0PWZObkiKrhJ81oZgKp/HsNs5LKJYJZqSivTad4+j7 N301T66brSdXDJUiqvYJ5pqmCjzZYCaJZhGrLRoA6DugIEVaJB+NfAyWptx3SI55w6i0 ICZ6jI2nN2YTtIp7H+ICk7157onnk9kXoJG8XQQnQcVJzRixYeqrYHzBaCq9qBV3pbr5 eQkg== X-Gm-Message-State: AOJu0YyDshGNomiB0gQvVTxJsFwKSws8B0Z32O6rpk1GvvKiPJcSTk0g PnrFpYWdU36oWa2sCnzzibZWqJuTFQmEKNoMGVx7PU1YSkayUWUQsEGHoOWom6w6tvvPugeVwPk = X-Google-Smtp-Source: AGHT+IGHg8d2ibwP7K7tXfSsIqktZTwjQ5uxfCYls5PNyOBYjv7LK4NV88lARpor5a1usEonHXk8GQ== X-Received: by 2002:ac2:42c7:0:b0:52c:8aa6:4e9c with SMTP id 2adb3069b0e04-52c9a406bebmr3180654e87.65.1718285640922; Thu, 13 Jun 2024 06:34:00 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-422870e9145sm62391955e9.22.2024.06.13.06.34.00 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 13 Jun 2024 06:34:00 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Ronan Desplanques Subject: [COMMITTED 14/30] ada: Fix expansion of protected subprogram bodies Date: Thu, 13 Jun 2024 15:33:20 +0200 Message-ID: <20240613133338.1809385-14-poulhies@adacore.com> X-Mailer: git-send-email 2.45.1 In-Reply-To: <20240613133338.1809385-1-poulhies@adacore.com> References: <20240613133338.1809385-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org From: Ronan Desplanques 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. Tested on x86_64-pc-linux-gnu, committed on master. --- 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 3583ed3138f..b34b4c967fb 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 4de253ab6e8..890bd038c5b 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;