[Ada] Fix portability issues in access to subprograms

This patch improves the portability of the code generated by the
compiler for access to subprograms. Written by Richard Kenner.

2019-09-18  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch4.adb (Expand_N_Op_Eq): The frontend assumes that we can
	do a bit-for-bit comparison of two access to protected
	subprogram pointers. However, there are two reasons why we may
	not be able to do that: (1) there may be padding bits for
	alignment before the access to subprogram, and (2) the access to
	subprogram itself may not be compared bit-for- bit because the
	activation record part is undefined: two pointers are equal iff
	the subprogram addresses are equal. This patch fixes it by
	forcing a field-by-field comparison.
	* bindgen.adb (Gen_Adainit): The type No_Param_Proc is defined
	in the library as having Favor_Top_Level, but when we create an
	object of that type in the binder file we don't have that
	pragma, so the types are different. This patch fixes this issue.
	* libgnarl/s-interr.adb, libgnarl/s-interr__hwint.adb,
	libgnarl/s-interr__sigaction.adb, libgnarl/s-interr__vxworks.adb
	(Is_Registered): This routine erroneously assumes that the
	access to protected subprogram is two addresses. We need to
	create the same record that the compiler makes to ensure that
	any padding is the same. Then we have to look at just the first
	word of the access to subprogram. This patch fixes this issue.

From-SVN: r275856

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 561f6a845f264d206ee48a01de401243c27571aa..07638f14a507d17b5426f4e6630adc39f626faa7 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,26 @@
+2019-09-18  Javier Miranda  <miranda@adacore.com>
+
+       * exp_ch4.adb (Expand_N_Op_Eq): The frontend assumes that we can
+       do a bit-for-bit comparison of two access to protected
+       subprogram pointers. However, there are two reasons why we may
+       not be able to do that: (1) there may be padding bits for
+       alignment before the access to subprogram, and (2) the access to
+       subprogram itself may not be compared bit-for- bit because the
+       activation record part is undefined: two pointers are equal iff
+       the subprogram addresses are equal. This patch fixes it by
+       forcing a field-by-field comparison.
+       * bindgen.adb (Gen_Adainit): The type No_Param_Proc is defined
+       in the library as having Favor_Top_Level, but when we create an
+       object of that type in the binder file we don't have that
+       pragma, so the types are different. This patch fixes this issue.
+       * libgnarl/s-interr.adb, libgnarl/s-interr__hwint.adb,
+       libgnarl/s-interr__sigaction.adb, libgnarl/s-interr__vxworks.adb
+       (Is_Registered): This routine erroneously assumes that the
+       access to protected subprogram is two addresses. We need to
+       create the same record that the compiler makes to ensure that
+       any padding is the same. Then we have to look at just the first
+       word of the access to subprogram. This patch fixes this issue.
+
 2019-09-18  Bob Duff  <duff@adacore.com>
 
        * exp_ch5.adb (Expand_Assign_Array_Loop_Or_Bitfield): The call

diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index 153043c8678f1d0c6c6f9e1f2c60d81ebe9b5786..e60cb7a7590959c9ac1056969ef1079afc10904c 100644 (file)
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -524,6 +524,7 @@ package body Bindgen is
         and then not Configurable_Run_Time_On_Target
       then
          WBI ("   type No_Param_Proc is access procedure;");
+         WBI ("   pragma Favor_Top_Level (No_Param_Proc);");
          WBI ("");
       end if;
 

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index c288d6a79a7343d5d199f9c4b1217ba8a77d7140..0c96d8c2a4a073a669192d66d4adeb25b866d85d 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -8221,6 +8221,32 @@ package body Exp_Ch4 is
             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
          end if;
+
+      --  If unnesting, handle elementary types whose Equivalent_Types are
+      --  records because there may be padding or undefined fields.
+
+      elsif Unnest_Subprogram_Mode
+        and then Ekind_In (Typl, E_Class_Wide_Type,
+                                 E_Class_Wide_Subtype,
+                                 E_Access_Subprogram_Type,
+                                 E_Access_Protected_Subprogram_Type,
+                                 E_Anonymous_Access_Protected_Subprogram_Type,
+                                 E_Access_Subprogram_Type,
+                                 E_Exception_Type)
+        and then Present (Equivalent_Type (Typl))
+        and then Is_Record_Type (Equivalent_Type (Typl))
+      then
+         Typl := Equivalent_Type (Typl);
+         Remove_Side_Effects (Lhs);
+         Remove_Side_Effects (Rhs);
+         Rewrite (N,
+           Expand_Record_Equality (N, Typl,
+             Unchecked_Convert_To (Typl, Lhs),
+             Unchecked_Convert_To (Typl, Rhs),
+             Bodies));
+
+         Insert_Actions      (N, Bodies,           Suppress => All_Checks);
+         Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
       end if;
 
       --  Test if result is known at compile time
@@ -9497,10 +9523,21 @@ package body Exp_Ch4 is
       Typ : constant Entity_Id := Etype (Left_Opnd (N));
 
    begin
-      --  Case of elementary type with standard operator
+      --  Case of elementary type with standard operator.  But if
+      --  unnesting, handle elementary types whose Equivalent_Types are
+      --  records because there may be padding or undefined fields.
 
       if Is_Elementary_Type (Typ)
         and then Sloc (Entity (N)) = Standard_Location
+        and then not (Ekind_In (Typ, E_Class_Wide_Type,
+                                E_Class_Wide_Subtype,
+                                E_Access_Subprogram_Type,
+                                E_Access_Protected_Subprogram_Type,
+                                E_Anonymous_Access_Protected_Subprogram_Type,
+                                E_Access_Subprogram_Type,
+                                E_Exception_Type)
+                        and then Present (Equivalent_Type (Typ))
+                        and then Is_Record_Type (Equivalent_Type (Typ)))
       then
          Binary_Op_Validity_Checks (N);
 

diff --git a/gcc/ada/libgnarl/s-interr.adb b/gcc/ada/libgnarl/s-interr.adb
index 7106c5783d60147663b57e1bc5057f291e122a8d..bb5defdca07e6ddc75f1e019bd3163173e75642f 100644 (file)
--- a/gcc/ada/libgnarl/s-interr.adb
+++ b/gcc/ada/libgnarl/s-interr.adb
@@ -545,9 +545,11 @@ package body System.Interrupts is
 
    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
 
+      type Acc_Proc is access procedure;
+
       type Fat_Ptr is record
          Object_Addr  : System.Address;
-         Handler_Addr : System.Address;
+         Handler_Addr : Acc_Proc;
       end record;
 
       function To_Fat_Ptr is new Ada.Unchecked_Conversion
@@ -565,7 +567,7 @@ package body System.Interrupts is
 
       Ptr := Registered_Handler_Head;
       while Ptr /= null loop
-         if Ptr.H = Fat.Handler_Addr then
+         if Ptr.H = Fat.Handler_Addr.all'Address then
             return True;
          end if;
 

diff --git a/gcc/ada/libgnarl/s-interr__hwint.adb b/gcc/ada/libgnarl/s-interr__hwint.adb
index 50e2ec2a6530abe1b4f961d27a753fec8332a2b4..ff7fe05912d466a461c93c648013083e71d45d58 100644 (file)
--- a/gcc/ada/libgnarl/s-interr__hwint.adb
+++ b/gcc/ada/libgnarl/s-interr__hwint.adb
@@ -561,9 +561,12 @@ package body System.Interrupts is
    -------------------
 
    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+
+      type Acc_Proc is access procedure;
+
       type Fat_Ptr is record
          Object_Addr  : System.Address;
-         Handler_Addr : System.Address;
+         Handler_Addr : Acc_Proc;
       end record;
 
       function To_Fat_Ptr is new Ada.Unchecked_Conversion
@@ -581,7 +584,7 @@ package body System.Interrupts is
 
       Ptr := Registered_Handler_Head;
       while Ptr /= null loop
-         if Ptr.H = Fat.Handler_Addr then
+         if Ptr.H = Fat.Handler_Addr.all'Address then
             return True;
          end if;
 

diff --git a/gcc/ada/libgnarl/s-interr__sigaction.adb b/gcc/ada/libgnarl/s-interr__sigaction.adb
index d9ffe0cfdaa6af2d241676ecec69c7776d19c291..d8fb7ba97128201ca597762c3d0ddbbb1ed8c5e0 100644 (file)
--- a/gcc/ada/libgnarl/s-interr__sigaction.adb
+++ b/gcc/ada/libgnarl/s-interr__sigaction.adb
@@ -487,9 +487,11 @@ package body System.Interrupts is
    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
       Ptr : R_Link := Registered_Handlers;
 
+      type Acc_Proc is access procedure;
+
       type Fat_Ptr is record
          Object_Addr  : System.Address;
-         Handler_Addr : System.Address;
+         Handler_Addr : Acc_Proc;
       end record;
 
       function To_Fat_Ptr is new Ada.Unchecked_Conversion
@@ -505,7 +507,7 @@ package body System.Interrupts is
       Fat := To_Fat_Ptr (Handler);
 
       while Ptr /= null loop
-         if Ptr.H = Fat.Handler_Addr then
+         if Ptr.H = Fat.Handler_Addr.all'Address then
             return True;
          end if;
 

diff --git a/gcc/ada/libgnarl/s-interr__vxworks.adb b/gcc/ada/libgnarl/s-interr__vxworks.adb
index b2c4eee671ba854511d878feb5603c6ad855a6a0..16d22a635561eef89809ef60242111c7866ffa9a 100644 (file)
--- a/gcc/ada/libgnarl/s-interr__vxworks.adb
+++ b/gcc/ada/libgnarl/s-interr__vxworks.adb
@@ -578,9 +578,12 @@ package body System.Interrupts is
    -------------------
 
    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+
+      type Acc_Proc is access procedure;
+
       type Fat_Ptr is record
          Object_Addr  : System.Address;
-         Handler_Addr : System.Address;
+         Handler_Addr : Acc_Proc;
       end record;
 
       function To_Fat_Ptr is new Ada.Unchecked_Conversion
@@ -598,7 +601,7 @@ package body System.Interrupts is
 
       Ptr := Registered_Handler_Head;
       while Ptr /= null loop
-         if Ptr.H = Fat.Handler_Addr then
+         if Ptr.H = Fat.Handler_Addr.all'Address then
             return True;
          end if;