From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id 70850385357C; Tue, 5 Jul 2022 08:29:58 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 70850385357C MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-1481] [Ada] Remove exception propagation during bootstrap X-Act-Checkin: gcc X-Git-Author: Arnaud Charlet X-Git-Refname: refs/heads/master X-Git-Oldrev: 4844a259b41b4f31940b478216d6dc9faa2bcbca X-Git-Newrev: 1d5018955a37fa665acc8dcba8121dd365dbe9be Message-Id: <20220705082958.70850385357C@sourceware.org> Date: Tue, 5 Jul 2022 08:29:58 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Tue, 05 Jul 2022 08:29:58 -0000 https://gcc.gnu.org/g:1d5018955a37fa665acc8dcba8121dd365dbe9be commit r13-1481-g1d5018955a37fa665acc8dcba8121dd365dbe9be Author: Arnaud Charlet Date: Sat Jun 4 10:44:13 2022 +0000 [Ada] Remove exception propagation during bootstrap To help the bootstrap path, we want to keep the compiler free from any exception propagation during bootstrap. This has been broken recently in various places. Also introduce a way to more easily detect such breakage via the -DNO_EXCEPTION_PROPAGATION which can now be used as part of BOOT_CFLAGS. gcc/ada/ * exp_imgv.adb (Build_Enumeration_Image_Tables): Also disable perfect hash in GNAT_Mode. * raise-gcc.c (__gnat_Unwind_RaiseException): Add support for disabling exception propagation. * sem_eval.adb (Compile_Time_Known_Value): Update comment and remove wrong call to Check_Error_Detected. * sem_prag.adb (Check_Loop_Pragma_Grouping, Analyze_Pragma): Remove exception propagation during bootstrap. Diff: --- gcc/ada/exp_imgv.adb | 4 +++- gcc/ada/raise-gcc.c | 4 ++++ gcc/ada/sem_eval.adb | 4 ++-- gcc/ada/sem_prag.adb | 42 +++++++++++++++++++++--------------------- 4 files changed, 30 insertions(+), 24 deletions(-) diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 6ab717c20ee..51f1195a8c6 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -289,12 +289,14 @@ package body Exp_Imgv is -- If the unit where the type is declared is the main unit, and the -- number of literals is greater than Threshold_For_Size when we are -- optimizing for size, and the restriction No_Implicit_Loops is not - -- active, and -gnatd_h is not specified, generate the hash function. + -- active, and -gnatd_h is not specified, and not GNAT_Mode, generate + -- the hash function. if In_Main_Unit and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size) and then not Restriction_Active (No_Implicit_Loops) and then not Debug_Flag_Underscore_H + and then not GNAT_Mode then declare LB : constant Positive := 2 * Positive (Nlit) + 1; diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index f4c42c09273..b03964cc019 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -1377,6 +1377,10 @@ __gnat_cleanupunwind_handler (int version ATTRIBUTE_UNUSED, _Unwind_Reason_Code __gnat_Unwind_RaiseException (_Unwind_Exception *e) { +#ifdef NO_EXCEPTION_PROPAGATION + abort(); +#endif + #ifdef __USING_SJLJ_EXCEPTIONS__ return _Unwind_SjLj_RaiseException (e); #else diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 114c90460ba..2ba46088940 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1816,10 +1816,10 @@ package body Sem_Eval is begin -- Never known at compile time if bad type or raises Constraint_Error - -- or empty (latter case occurs only as a result of a previous error). + -- or empty (which can occur as a result of a previous error or in the + -- case of e.g. an imported constant). if No (Op) then - Check_Error_Detected; return False; elsif Op = Error diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3660c75fc69..3431e3f6101 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6152,15 +6152,11 @@ package body Sem_Prag is -------------------------------- procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is - Stop_Search : exception; - -- This exception is used to terminate the recursive descent of - -- routine Check_Grouping. - - procedure Check_Grouping (L : List_Id); + function Check_Grouping (L : List_Id) return Boolean; -- Find the first group of pragmas in list L and if successful, -- ensure that the current pragma is part of that group. The - -- routine raises Stop_Search once such a check is performed to - -- halt the recursive descent. + -- routine returns True once such a check is performed to + -- stop the analysis. procedure Grouping_Error (Prag : Node_Id); pragma No_Return (Grouping_Error); @@ -6171,7 +6167,7 @@ package body Sem_Prag is -- Check_Grouping -- -------------------- - procedure Check_Grouping (L : List_Id) is + function Check_Grouping (L : List_Id) return Boolean is HSS : Node_Id; Stmt : Node_Id; Prag : Node_Id := Empty; -- init to avoid warning @@ -6219,7 +6215,7 @@ package body Sem_Prag is -- Stop the search as the placement is legal. if Stmt = N then - raise Stop_Search; + return True; -- Skip group members, but keep track of the -- last pragma in the group. @@ -6266,15 +6262,21 @@ package body Sem_Prag is elsif Nkind (Stmt) = N_Block_Statement then HSS := Handled_Statement_Sequence (Stmt); - Check_Grouping (Declarations (Stmt)); + if Check_Grouping (Declarations (Stmt)) then + return True; + end if; if Present (HSS) then - Check_Grouping (Statements (HSS)); + if Check_Grouping (Statements (HSS)) then + return True; + end if; end if; end if; Next (Stmt); end loop; + + return False; end Check_Grouping; -------------------- @@ -6287,6 +6289,8 @@ package body Sem_Prag is Error_Pragma ("pragma% must appear next to pragma#"); end Grouping_Error; + Ignore : Boolean; + -- Start of processing for Check_Loop_Pragma_Grouping begin @@ -6294,10 +6298,7 @@ package body Sem_Prag is -- within to determine whether the current pragma is part of the -- first topmost grouping of Loop_Invariant and Loop_Variant. - Check_Grouping (Statements (Loop_Stmt)); - - exception - when Stop_Search => null; + Ignore := Check_Grouping (Statements (Loop_Stmt)); end Check_Loop_Pragma_Grouping; -------------------- @@ -24617,7 +24618,7 @@ package body Sem_Prag is Check_First_Subtype (Task_Type); if Rep_Item_Too_Late (Ent, N) then - raise Pragma_Exit; + return; end if; end Task_Storage; @@ -24879,7 +24880,7 @@ package body Sem_Prag is or else Rep_Item_Too_Late (E, N) then - raise Pragma_Exit; + return; end if; Set_Has_Pragma_Thread_Local_Storage (E); @@ -25642,16 +25643,15 @@ package body Sem_Prag is if CodePeer_Mode or GNATprove_Mode then Rewrite (N, Make_Null_Statement (Loc)); Analyze (N); - raise Pragma_Exit; + return; end if; elsif Chars (Argx) = Name_Gnatprove then if not GNATprove_Mode then Rewrite (N, Make_Null_Statement (Loc)); Analyze (N); - raise Pragma_Exit; + return; end if; - else raise Program_Error; end if; @@ -25679,7 +25679,7 @@ package body Sem_Prag is Chars => Name_Warnings, Pragma_Argument_Associations => Shifted_Args)); Analyze (N); - raise Pragma_Exit; + return; end if; -- One argument case