ada: Expose expected_throw attribute

Mark exception-raising subprograms with expected_throw attribute.

Document the use of the attribute in Control Flow Redundancy.

Enable marking subprograms as expected_throw with Machine_Attribute
pragmas.

gcc/ada/

	* libgnat/a-except.ads (Raise_Exception): Mark expected_throw.
	(Reraise_Occurrence): Likewise.
	(Raise_Exception_Always): Likewise.
	(Raise_From_Controlled_Operation): Likewise.
	(Reraise_Occurrence_Always): Likewise.
	(Reraise_Occurrence_No_Defer): Likewise.
	* libgnat/a-except.adb
	(Exception_Propagation.Propagate_Exception): Likewise.
	(Complete_And_Propagate_Occurrence): Likewise.
	(Raise_Exception_No_Defer): Likewise.
	(Raise_From_Signal_Handler): Likewise.
	(Raise_With_Msg): Likewise.
	(Raise_With_Location_And_Msg): Likewise.
	(Raise_Constraint_Error): Likewise.
	(Raise_Constraint_Error_Msg): Likewise.
	(Raise_Program_Error): Likewise.
	(Raise_Program_Error_Msg): Likewise.
	(Raise_Storage_Error): Likewise.
	(Raise_Storage_Error_Msg): Likewise.
	(Reraise, Rcheck_*): Likewise.
	* doc/gnat_rm/security_hardening_features.rst (Control Flow
	Hardening): Note the influence of expected_throw.
	* gnat_rm.texi: Regenerate.
	* gnat_ugn.texi: Regenerate.
	* gcc-interface/utils.cc (handle_expected_throw_attribute): New.
	(gnat_internal_attribute_table): Add expected_throw.

6 files changed, 146 insertions, 5 deletions

diff --git a/gcc/ada/doc/gnat_rm/security_hardening_features.rst b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
index e057af2e..015b9ce 100644
--- a/gcc/ada/doc/gnat_rm/security_hardening_features.rst
+++ b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
@@ -500,7 +500,9 @@ gets modified as follows:
 
 Verification may also be performed before No_Return calls, whether all
 of them, with :switch:`-fhardcfr-check-noreturn-calls=always`; all but
-internal subprograms involved in exception-raising or -reraising, with
+internal subprograms involved in exception-raising or -reraising or
+subprograms explicitly marked with both :samp:`No_Return` and
+:samp:`Machine_Attribute` :samp:`expected_throw` pragmas, with
 :switch:`-fhardcfr-check-noreturn-calls=no-xthrow` (default); only
 nothrow ones, with :switch:`-fhardcfr-check-noreturn-calls=nothrow`;
 or none, with :switch:`-fhardcfr-check-noreturn-calls=never`.
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index 8f1861b..d0a13d2 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -87,6 +87,7 @@ tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1];
 /* Forward declarations for handlers of attributes.  */
 static tree handle_const_attribute (tree *, tree, tree, int, bool *);
 static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *);
+static tree handle_expected_throw_attribute (tree *, tree, tree, int, bool *);
 static tree handle_pure_attribute (tree *, tree, tree, int, bool *);
 static tree handle_novops_attribute (tree *, tree, tree, int, bool *);
 static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *);
@@ -143,6 +144,8 @@ const struct attribute_spec gnat_internal_attribute_table[] =
     handle_const_attribute, NULL },
   { "nothrow",      0, 0,  true,  false, false, false,
     handle_nothrow_attribute, NULL },
+  { "expected_throw", 0, 0, true,  false, false, false,
+    handle_expected_throw_attribute, NULL },
   { "pure",         0, 0,  true,  false, false, false,
     handle_pure_attribute, NULL },
   { "no vops",      0, 0,  true,  false, false, false,
@@ -6379,6 +6382,22 @@ handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name),
   return NULL_TREE;
 }
 
+/* Handle a "expected_throw" attribute; arguments as in
+   struct attribute_spec.handler.  */
+
+static tree
+handle_expected_throw_attribute (tree *node, tree ARG_UNUSED (name),
+				 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
+				 bool *no_add_attrs)
+{
+  if (TREE_CODE (*node) == FUNCTION_DECL)
+    /* No flag to set here.  */;
+  else
+    *no_add_attrs = true;
+
+  return NULL_TREE;
+}
+
 /* Handle a "pure" attribute; arguments as in
    struct attribute_spec.handler.  */
 
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 066c066..b7e0983 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -19,7 +19,7 @@
 
 @copying
 @quotation
-GNAT Reference Manual , Jul 10, 2023
+GNAT Reference Manual , Jul 17, 2023
 
 AdaCore
 
@@ -29666,7 +29666,9 @@ end;
 
 Verification may also be performed before No_Return calls, whether all
 of them, with @code{-fhardcfr-check-noreturn-calls=always}; all but
-internal subprograms involved in exception-raising or -reraising, with
+internal subprograms involved in exception-raising or -reraising or
+subprograms explicitly marked with both @code{No_Return} and
+@code{Machine_Attribute} @code{expected_throw} pragmas, with
 @code{-fhardcfr-check-noreturn-calls=no-xthrow} (default); only
 nothrow ones, with @code{-fhardcfr-check-noreturn-calls=nothrow};
 or none, with @code{-fhardcfr-check-noreturn-calls=never}.
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 2721251..78f9b87 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -19,7 +19,7 @@
 
 @copying
 @quotation
-GNAT User's Guide for Native Platforms , Jul 10, 2023
+GNAT User's Guide for Native Platforms , Jul 17, 2023
 
 AdaCore
 
@@ -29531,8 +29531,8 @@ to permit their use in free software.
 
 @printindex ge
 
-@anchor{d1}@w{                              }
 @anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{                              }
+@anchor{d1}@w{                              }
 
 @c %**end of body
 @bye
diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb
index 20a7736..dd5edaf 100644
--- a/gcc/ada/libgnat/a-except.adb
+++ b/gcc/ada/libgnat/a-except.adb
@@ -229,6 +229,7 @@ package body Ada.Exceptions is
 
       procedure Propagate_Exception (Excep : Exception_Occurrence);
       pragma No_Return (Propagate_Exception);
+      pragma Machine_Attribute (Propagate_Exception, "expected_throw");
       --  This procedure propagates the exception represented by Excep
 
    end Exception_Propagation;
@@ -256,6 +257,8 @@ package body Ada.Exceptions is
 
    procedure Complete_And_Propagate_Occurrence (X : EOA);
    pragma No_Return (Complete_And_Propagate_Occurrence);
+   pragma Machine_Attribute (Complete_And_Propagate_Occurrence,
+                             "expected_throw");
    --  This is a simple wrapper to Complete_Occurrence and
    --  Exception_Propagation.Propagate_Exception.
 
@@ -280,6 +283,7 @@ package body Ada.Exceptions is
     (Ada, Raise_Exception_No_Defer,
      "ada__exceptions__raise_exception_no_defer");
    pragma No_Return (Raise_Exception_No_Defer);
+   pragma Machine_Attribute (Raise_Exception_No_Defer, "expected_throw");
    --  Similar to Raise_Exception, but with no abort deferral
 
    procedure Raise_From_Signal_Handler
@@ -288,6 +292,7 @@ package body Ada.Exceptions is
    pragma Export
      (C, Raise_From_Signal_Handler, "__gnat_raise_from_signal_handler");
    pragma No_Return (Raise_From_Signal_Handler);
+   pragma Machine_Attribute (Raise_From_Signal_Handler, "expected_throw");
    --  This routine is used to raise an exception from a signal handler. The
    --  signal handler has already stored the machine state (i.e. the state that
    --  corresponds to the location at which the signal was raised). E is the
@@ -301,6 +306,7 @@ package body Ada.Exceptions is
 
    procedure Raise_With_Msg (E : Exception_Id);
    pragma No_Return (Raise_With_Msg);
+   pragma Machine_Attribute (Raise_With_Msg, "expected_throw");
    pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
    --  Raises an exception with given exception id value. A message
    --  is associated with the raise, and has already been stored in the
@@ -314,6 +320,7 @@ package body Ada.Exceptions is
       C : Integer := 0;
       M : System.Address := System.Null_Address);
    pragma No_Return (Raise_With_Location_And_Msg);
+   pragma Machine_Attribute (Raise_With_Location_And_Msg, "expected_throw");
    --  Raise an exception with given exception id value. A filename and line
    --  number is associated with the raise and is stored in the exception
    --  occurrence and in addition a column and a string message M may be
@@ -321,6 +328,7 @@ package body Ada.Exceptions is
 
    procedure Raise_Constraint_Error (File : System.Address; Line : Integer);
    pragma No_Return (Raise_Constraint_Error);
+   pragma Machine_Attribute (Raise_Constraint_Error, "expected_throw");
    pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
    --  Raise constraint error with file:line information
 
@@ -330,12 +338,14 @@ package body Ada.Exceptions is
       Column : Integer;
       Msg    : System.Address);
    pragma No_Return (Raise_Constraint_Error_Msg);
+   pragma Machine_Attribute (Raise_Constraint_Error_Msg, "expected_throw");
    pragma Export
      (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
    --  Raise constraint error with file:line:col + msg information
 
    procedure Raise_Program_Error (File : System.Address; Line : Integer);
    pragma No_Return (Raise_Program_Error);
+   pragma Machine_Attribute (Raise_Program_Error, "expected_throw");
    pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error");
    --  Raise program error with file:line information
 
@@ -344,12 +354,14 @@ package body Ada.Exceptions is
       Line : Integer;
       Msg  : System.Address);
    pragma No_Return (Raise_Program_Error_Msg);
+   pragma Machine_Attribute (Raise_Program_Error_Msg, "expected_throw");
    pragma Export
      (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
    --  Raise program error with file:line + msg information
 
    procedure Raise_Storage_Error (File : System.Address; Line : Integer);
    pragma No_Return (Raise_Storage_Error);
+   pragma Machine_Attribute (Raise_Storage_Error, "expected_throw");
    pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error");
    --  Raise storage error with file:line information
 
@@ -358,6 +370,7 @@ package body Ada.Exceptions is
       Line : Integer;
       Msg  : System.Address);
    pragma No_Return (Raise_Storage_Error_Msg);
+   pragma Machine_Attribute (Raise_Storage_Error_Msg, "expected_throw");
    pragma Export
      (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
    --  Raise storage error with file:line + reason msg information
@@ -385,6 +398,7 @@ package body Ada.Exceptions is
 
    procedure Reraise;
    pragma No_Return (Reraise);
+   pragma Machine_Attribute (Reraise, "expected_throw");
    pragma Export (C, Reraise, "__gnat_reraise");
    --  Reraises the exception referenced by the Current_Excep field
    --  of the TSD (all fields of this exception occurrence are set).
@@ -632,6 +646,96 @@ package body Ada.Exceptions is
    pragma No_Return (Rcheck_CE_Invalid_Data_Ext);
    pragma No_Return (Rcheck_CE_Range_Check_Ext);
 
+   --  These procedures are all expected to raise an exception.
+   --  These attributes are not visible to callers; they are made
+   --  visible in trans.c:build_raise_check.
+
+   pragma Machine_Attribute (Rcheck_CE_Access_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Null_Access_Parameter,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Discriminant_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Divide_By_Zero,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Explicit_Raise,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Index_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Invalid_Data,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Length_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Null_Exception_Id,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Null_Not_Allowed,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Overflow_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Partition_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Range_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Tag_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Address_Of_Intrinsic,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Aliased_Parameters,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_All_Guards_Closed,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Bad_Predicated_Generic_Type,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Build_In_Place_Mismatch,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Current_Task_In_Entry_Body,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Duplicated_Entry_Address,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Explicit_Raise,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Implicit_Return,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Misaligned_Address_Value,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Missing_Return,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Non_Transportable_Actual,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Overlaid_Controlled_Object,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Potentially_Blocking_Operation,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Stream_Operation_Not_Allowed,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Stubbed_Subprogram_Called,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Unchecked_Union_Restriction,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_PE_Finalize_Raised_Exception,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_SE_Empty_Storage_Pool,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_SE_Explicit_Raise,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_SE_Infinite_Recursion,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_SE_Object_Too_Large,
+                             "expected_throw");
+
+   pragma Machine_Attribute (Rcheck_CE_Access_Check_Ext,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Index_Check_Ext,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Invalid_Data_Ext,
+                             "expected_throw");
+   pragma Machine_Attribute (Rcheck_CE_Range_Check_Ext,
+                             "expected_throw");
+
    --  Make all of these procedures callable from strub contexts.
    --  These attributes are not visible to callers; they are made
    --  visible in trans.c:build_raise_check.
diff --git a/gcc/ada/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads
index 7949b59..5583bf5 100644
--- a/gcc/ada/libgnat/a-except.ads
+++ b/gcc/ada/libgnat/a-except.ads
@@ -163,6 +163,14 @@ private
 
    Null_Id : constant Exception_Id := null;
 
+   pragma Machine_Attribute (Raise_Exception, "expected_throw");
+   pragma Machine_Attribute (Reraise_Occurrence, "expected_throw");
+   --  Tell the compiler that an exception is likely after calling
+   --  these subprograms. This could eventually be used for hot/cold
+   --  partitioning. For now, this only enables the control flow
+   --  redundancy to avoid duplicating a check before the No_Return
+   --  call and in the exception handler for the call.
+
    -------------------------
    -- Private Subprograms --
    -------------------------
@@ -177,6 +185,7 @@ private
 
    procedure Raise_Exception_Always (E : Exception_Id; Message : String := "");
    pragma No_Return (Raise_Exception_Always);
+   pragma Machine_Attribute (Raise_Exception_Always, "expected_throw");
    pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception");
    --  This differs from Raise_Exception only in that the caller has determined
    --  that for sure the parameter E is not null, and that therefore no check
@@ -195,6 +204,9 @@ private
            "__gnat_raise_from_controlled_operation");
    --  Raise Program_Error, providing information about X (an exception raised
    --  during a controlled operation) in the exception message.
+   pragma Machine_Attribute (Raise_From_Controlled_Operation,
+                             "expected_throw");
+   --  Mark it like internal exception-raising subprograms
 
    procedure Reraise_Library_Exception_If_Any;
    pragma Export
@@ -205,6 +217,7 @@ private
 
    procedure Reraise_Occurrence_Always (X : Exception_Occurrence);
    pragma No_Return (Reraise_Occurrence_Always);
+   pragma Machine_Attribute (Reraise_Occurrence_Always, "expected_throw");
    --  This differs from Raise_Occurrence only in that the caller guarantees
    --  that for sure the parameter X is not the null occurrence, and that
    --  therefore this procedure cannot return. The expander uses this routine
@@ -212,6 +225,7 @@ private
 
    procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence);
    pragma No_Return (Reraise_Occurrence_No_Defer);
+   pragma Machine_Attribute (Reraise_Occurrence_No_Defer, "expected_throw");
    --  Exactly like Reraise_Occurrence, except that abort is not deferred
    --  before the call and the parameter X is known not to be the null
    --  occurrence. This is used in generated code when it is known that abort