From patchwork Thu Aug 4 07:45:29 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 108360 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 8D5D7B6F71 for ; Thu, 4 Aug 2011 17:46:03 +1000 (EST) Received: (qmail 23272 invoked by alias); 4 Aug 2011 07:45:49 -0000 Received: (qmail 23253 invoked by uid 22791); 4 Aug 2011 07:45:46 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 04 Aug 2011 07:45:31 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A25B72BB33E; Thu, 4 Aug 2011 03:45:30 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id zYUbT6qaT2as; Thu, 4 Aug 2011 03:45:30 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id F305A2BB333; Thu, 4 Aug 2011 03:45:29 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id F252592A55; Thu, 4 Aug 2011 03:45:29 -0400 (EDT) Date: Thu, 4 Aug 2011 03:45:29 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Finalization actions during abort Message-ID: <20110804074529.GA30736@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch adds a guard to the mechanism which determines whether finalization was triggered by an abort. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-04 Hristian Kirtchev * exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Update the comment on the generated code. (Build_Finalize_Statements): Update the comment on the generated code. (Build_Initialize_Statements): Update the comment on the generated code. (Build_Object_Declarations): Add local variable Result. The object declarations are now built in sequence. * rtsfind.ads: Add RE_Exception_Occurrence_Access to tables RE_Id and RE_Unit_Table. Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 177283) +++ exp_ch7.adb (working copy) @@ -2897,6 +2897,7 @@ is A_Expr : Node_Id; E_Decl : Node_Id; + Result : List_Id; begin if Restriction_Active (No_Exception_Propagation) then @@ -2907,37 +2908,87 @@ pragma Assert (Present (E_Id)); pragma Assert (Present (Raised_Id)); - -- Generate: - -- Exception_Identity (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; + Result := New_List; + -- In certain scenarios, finalization can be triggered by an abort. If + -- the finalization itself fails and raises an exception, the resulting + -- Program_Error must be supressed and replaced by an abort signal. In + -- order to detect this scenario, save the state of entry into the + -- finalization code. + if Abort_Allowed then - A_Expr := - Make_Op_Eq (Loc, - Left_Opnd => - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Exception_Identity), Loc), - Parameter_Associations => New_List ( - Make_Explicit_Dereference (Loc, - Prefix => - Make_Function_Call (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => - New_Reference_To - (RTE (RE_Get_Current_Excep), Loc)))))), + declare + Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To (Stand.Abort_Signal, Loc), - Attribute_Name => Name_Identity)); + begin + -- Generate: + -- Temp : constant Exception_Occurrence_Access := + -- Get_Current_Excep.all; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Exception_Occurrence_Access), Loc), + Expression => + Make_Function_Call (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To + (RTE (RE_Get_Current_Excep), Loc))))); + + -- Generate: + -- Temp /= null + -- and then Exception_Identity (Temp.all) = + -- Standard'Abort_Signal'Identity; + + A_Expr := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To (Temp_Id, Loc), + Right_Opnd => + Make_Null (Loc)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Exception_Identity), Loc), + Parameter_Associations => New_List ( + Make_Explicit_Dereference (Loc, + Prefix => + New_Reference_To (Temp_Id, Loc)))), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Stand.Abort_Signal, Loc), + Attribute_Name => Name_Identity))); + end; + + -- No abort + else A_Expr := New_Reference_To (Standard_False, Loc); end if; -- Generate: + -- Abort_Id : constant Boolean := ; + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Abort_Id, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => A_Expr)); + + -- Generate: -- E_Id : Exception_Occurrence; E_Decl := @@ -2947,30 +2998,20 @@ New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); Set_No_Initialization (E_Decl); - return - New_List ( + Append_To (Result, E_Decl); - -- Abort_Id + -- Generate: + -- Raised_Id : Boolean := False; - Make_Object_Declaration (Loc, - Defining_Identifier => Abort_Id, - Constant_Present => True, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc), - Expression => A_Expr), + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Raised_Id, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc))); - -- E_Id - - E_Decl, - - -- Raised_Id - - Make_Object_Declaration (Loc, - Defining_Identifier => Raised_Id, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc), - Expression => - New_Reference_To (Standard_False, Loc))); + return Result; end Build_Object_Declarations; --------------------------- @@ -4600,9 +4641,12 @@ -- controlled elements. Generate: -- declare + -- Temp : constant Exception_Occurrence_Access := + -- Get_Current_Excep.all; -- Abort : constant Boolean := - -- Exception_Identity (Get_Current_Excep.all) = - -- Standard'Abort_Signal'Identity; + -- Temp /= null + -- and then Exception_Identity (Temp_Id.all) = + -- Standard'Abort_Signal'Identity; -- -- Abort : constant Boolean := False; -- no abort @@ -4653,9 +4697,12 @@ -- exception -- when others => -- declare + -- Temp : constant Exception_Occurrence_Access := + -- Get_Current_Excep.all; -- Abort : constant Boolean := - -- Exception_Identity (Get_Current_Excep.all) = - -- Standard'Abort_Signal'Identity; + -- Temp /= null + -- and then Exception_Identity (Temp_Id.all) = + -- Standard'Abort_Signal'Identity; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; @@ -5513,9 +5560,12 @@ -- may have discriminants and contain variant parts. Generate: -- declare + -- Temp : constant Exception_Occurrence_Access := + -- Get_Current_Excep.all; -- Abort : constant Boolean := - -- Exception_Identity (Get_Current_Excep.all) = - -- Standard'Abort_Signal'Identity; + -- Temp /= null + -- and then Exception_Identity (Temp_Id.all) = + -- Standard'Abort_Signal'Identity; -- -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; Index: rtsfind.ads =================================================================== --- rtsfind.ads (revision 177283) +++ rtsfind.ads (working copy) @@ -504,6 +504,7 @@ RE_Exception_Message, -- Ada.Exceptions RE_Exception_Name_Simple, -- Ada.Exceptions RE_Exception_Occurrence, -- Ada.Exceptions + RE_Exception_Occurrence_Access, -- Ada.Exceptions RE_Null_Id, -- Ada.Exceptions RE_Null_Occurrence, -- Ada.Exceptions RE_Poll, -- Ada.Exceptions @@ -1682,6 +1683,7 @@ RE_Exception_Message => Ada_Exceptions, RE_Exception_Name_Simple => Ada_Exceptions, RE_Exception_Occurrence => Ada_Exceptions, + RE_Exception_Occurrence_Access => Ada_Exceptions, RE_Null_Id => Ada_Exceptions, RE_Null_Occurrence => Ada_Exceptions, RE_Poll => Ada_Exceptions,