diff mbox series

[Ada] Remove exception propagation during bootstrap

Message ID 20220705082952.GA3183261@adacore.com
State New
Headers show
Series [Ada] Remove exception propagation during bootstrap | expand

Commit Message

Pierre-Marie de Rodat July 5, 2022, 8:29 a.m. UTC
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.

Tested on x86_64-pc-linux-gnu, committed on trunk

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 mbox series

Patch

diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
--- 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
--- 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
--- 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
--- 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