[Ada] Fix wrong access to large bit-packed arrays with reverse SSO
authorEric Botcazou <ebotcazou@adacore.com>
Tue, 17 Mar 2020 20:26:43 +0000 (21:26 +0100)
committerPierre-Marie de Rodat <derodat@adacore.com>
Thu, 11 Jun 2020 09:53:51 +0000 (05:53 -0400)
2020-06-11  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

* exp_pakd.ads: Add paragraph about scalar storage order.
* exp_pakd.adb (Install_PAT): Do not set the scalar storage
order of the PAT here but...
(Set_PB_Type): ...here instead and...
(Create_Packed_Array_Impl_Type): ...here as well.
* rtsfind.ads (RE_Id): Add RE_Rev_Packed_Bytes{1,2,4}.
(RE_Unit_Table): Likewise.
* libgnat/s-unstyp.ads (Rev_Packed_Bytes1): New derived type.
(Rev_Packed_Bytes2): Likewise.
(Rev_Packed_Bytes4): Likewise.

gcc/ada/exp_pakd.adb
gcc/ada/exp_pakd.ads
gcc/ada/libgnat/s-unstyp.ads
gcc/ada/rtsfind.ads

index 02a0d98..6d5cf62 100644 (file)
@@ -501,8 +501,9 @@ package body Exp_Pakd is
       --  packed array type. It creates the type and installs it as required.
 
       procedure Set_PB_Type;
-      --  Sets PB_Type to Packed_Bytes{1,2,4} as required by the alignment
-      --  requirements (see documentation in the spec of this package).
+      --  Set PB_Type to [Rev_]Packed_Bytes{1,2,4} as required by the alignment
+      --  and the scalar storage order requirements (see documentation in the
+      --  spec of this package).
 
       -----------------
       -- Install_PAT --
@@ -580,14 +581,6 @@ package body Exp_Pakd is
          Set_Is_Volatile_Full_Access (PAT, Is_Volatile_Full_Access  (Typ));
          Set_Treat_As_Volatile       (PAT, Treat_As_Volatile        (Typ));
 
-         --  For a non-bit-packed array, propagate reverse storage order
-         --  flag from original base type to packed array base type.
-
-         if not Is_Bit_Packed_Array (Typ) then
-            Set_Reverse_Storage_Order
-              (Etype (PAT), Reverse_Storage_Order (Base_Type (Typ)));
-         end if;
-
          --  We definitely do not want to delay freezing for packed array
          --  types. This is of particular importance for the itypes that are
          --  generated for record components depending on discriminants where
@@ -616,16 +609,36 @@ package body Exp_Pakd is
            or else Alignment (Typ) = 1
            or else Component_Alignment (Typ) = Calign_Storage_Unit
          then
-            PB_Type := RTE (RE_Packed_Bytes1);
+            if Reverse_Storage_Order (Typ) then
+               PB_Type := RTE (RE_Rev_Packed_Bytes1);
+            else
+               PB_Type := RTE (RE_Packed_Bytes1);
+            end if;
 
          elsif Csize mod 4 /= 0
            or else Alignment (Typ) = 2
          then
-            PB_Type := RTE (RE_Packed_Bytes2);
+            if Reverse_Storage_Order (Typ) then
+               PB_Type := RTE (RE_Rev_Packed_Bytes2);
+            else
+               PB_Type := RTE (RE_Packed_Bytes2);
+            end if;
 
          else
-            PB_Type := RTE (RE_Packed_Bytes4);
+            if Reverse_Storage_Order (Typ) then
+               PB_Type := RTE (RE_Rev_Packed_Bytes4);
+            else
+               PB_Type := RTE (RE_Packed_Bytes4);
+            end if;
          end if;
+
+         --  The Rev_Packed_Bytes{1,2,4} types cannot be directly declared with
+         --  the reverse scalar storage order in System.Unsigned_Types because
+         --  their component type is aliased and the combination would then be
+         --  flagged as illegal by the compiler. Moreover changing the compiler
+         --  would not address the bootstrap path issue with earlier versions.
+
+         Set_Reverse_Storage_Order (PB_Type, Reverse_Storage_Order (Typ));
       end Set_PB_Type;
 
    --  Start of processing for Create_Packed_Array_Impl_Type
@@ -797,6 +810,10 @@ package body Exp_Pakd is
          end;
 
          Install_PAT;
+
+         --  Propagate the reverse storage order flag to the base type
+
+         Set_Reverse_Storage_Order (Etype (PAT), Reverse_Storage_Order (Typ));
          return;
 
       --  Case of bit-packing required for unconstrained array. We create
index 89c36d8..33726ba 100644 (file)
@@ -86,6 +86,15 @@ package Exp_Pakd is
    --    Packed_Bytes{1,2,4} type is made on the basis of alignment needs as
    --    described above for the unconstrained case.
 
+   --  When the packed array (sub)type is specified to have the reverse scalar
+   --  storage order, the Packed_Bytes{1,2,4} references above are replaced
+   --  with Rev_Packed_Bytes{1,2,4}. This is necessary because, although the
+   --  component type is Packed_Byte and therefore endian neutral, the scalar
+   --  storage order of the new type must be compatible with that of an outer
+   --  composite type, if this composite type contains a component whose type
+   --  is the packed array (sub)type and which does not start or does not end
+   --  on a storage unit boundary.
+
    --  When a variable of packed array type is allocated, gigi will allocate
    --  the amount of space indicated by the corresponding packed array type.
    --  However, we do NOT attempt to rewrite the types of any references or
index 0815812..0f6c73c 100644 (file)
@@ -51,8 +51,8 @@ package System.Unsigned_Types is
    --  Used in the implementation of Is_Negative intrinsic (see Exp_Intr)
 
    type Packed_Byte is mod 2 ** 8;
-   pragma Universal_Aliasing (Packed_Byte);
    for Packed_Byte'Size use 8;
+   pragma Universal_Aliasing (Packed_Byte);
    --  Component type for Packed_Bytes1, Packed_Bytes2 and Packed_Byte4 arrays.
    --  As this type is used by the compiler to implement operations on user
    --  packed array, it needs to be able to alias any type.
@@ -89,6 +89,24 @@ package System.Unsigned_Types is
    --  cases the clusters can be assumed to be 4-byte aligned if the array
    --  is aligned (see System.Pack_12 in file s-pack12 as an example).
 
+   type Rev_Packed_Bytes1 is new Packed_Bytes1;
+   pragma Suppress_Initialization (Rev_Packed_Bytes1);
+   --  This is equivalent to Packed_Bytes1, but for packed arrays with reverse
+   --  scalar storage order. But the Scalar_Storage_Order attribute cannot be
+   --  set directly here, see Exp_Pakd for more details.
+
+   type Rev_Packed_Bytes2 is new Packed_Bytes2;
+   pragma Suppress_Initialization (Rev_Packed_Bytes2);
+   --  This is equivalent to Packed_Bytes2, but for packed arrays with reverse
+   --  scalar storage order. But the Scalar_Storage_Order attribute cannot be
+   --  set directly here, see Exp_Pakd for more details.
+
+   type Rev_Packed_Bytes4 is new Packed_Bytes4;
+   pragma Suppress_Initialization (Rev_Packed_Bytes4);
+   --  This is equivalent to Packed_Bytes4, but for packed arrays with reverse
+   --  scalar storage order. But the Scalar_Storage_Order attribute cannot be
+   --  set directly here, see Exp_Pakd for more details.
+
    type Bits_1 is mod 2**1;
    type Bits_2 is mod 2**2;
    type Bits_4 is mod 2**4;
index 5074e18..df98023 100644 (file)
@@ -1524,6 +1524,9 @@ package Rtsfind is
      RE_Packed_Bytes1,                   -- System.Unsigned_Types
      RE_Packed_Bytes2,                   -- System.Unsigned_Types
      RE_Packed_Bytes4,                   -- System.Unsigned_Types
+     RE_Rev_Packed_Bytes1,               -- System.Unsigned_Types
+     RE_Rev_Packed_Bytes2,               -- System.Unsigned_Types
+     RE_Rev_Packed_Bytes4,               -- System.Unsigned_Types
      RE_Short_Unsigned,                  -- System.Unsigned_Types
      RE_Short_Short_Unsigned,            -- System.Unsigned_Types
      RE_Unsigned,                        -- System.Unsigned_Types
@@ -2798,6 +2801,9 @@ package Rtsfind is
      RE_Packed_Bytes1                    => System_Unsigned_Types,
      RE_Packed_Bytes2                    => System_Unsigned_Types,
      RE_Packed_Bytes4                    => System_Unsigned_Types,
+     RE_Rev_Packed_Bytes1                => System_Unsigned_Types,
+     RE_Rev_Packed_Bytes2                => System_Unsigned_Types,
+     RE_Rev_Packed_Bytes4                => System_Unsigned_Types,
      RE_Short_Unsigned                   => System_Unsigned_Types,
      RE_Short_Short_Unsigned             => System_Unsigned_Types,
      RE_Unsigned                         => System_Unsigned_Types,