[gcc r12-1689] [Ada] Improve efficiency of small slice assignments of packed arrays

[gcc r12-1689] [Ada] Improve efficiency of small slice assignments of packed arrays

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:9418d3d41f581edd9acfdc4f359d37f948c1671e

commit r12-1689-g9418d3d41f581edd9acfdc4f359d37f948c1671e
Author: Bob Duff <duff@adacore.com>
Date:   Tue Mar 30 07:15:39 2021 -0400

    [Ada] Improve efficiency of small slice assignments of packed arrays
    
    gcc/ada/
    
            * rtsfind.ads, libgnat/s-bitfie.ads, libgnat/s-bituti.adb,
            libgnat/s-bituti.ads (Fast_Copy_Bitfield): New run-time library
            function to copy bit fields faster than Copy_Bitfield. Cannot be
            called with zero-size bit fields.  Remove obsolete ??? comments
            from s-bituti.adb; we already do "avoid calling this if
            Forwards_OK is False".
            * exp_ch5.adb (Expand_Assign_Array_Loop_Or_Bitfield,
            Expand_Assign_Array_Bitfield_Fast): Generate calls to
            Fast_Copy_Bitfield when appropriate.
            * sem_util.adb, sem_util.ads (Get_Index_Bounds): Two new
            functions for getting the index bounds. These are more
            convenient than the procedure of the same name, because they can
            be used to initialize constants.

Diff:
---
 gcc/ada/exp_ch5.adb          | 203 ++++++++++++++++++++++++++++++++++++++-----
 gcc/ada/libgnat/s-bitfie.ads |  15 +++-
 gcc/ada/libgnat/s-bituti.adb |  28 +++---
 gcc/ada/libgnat/s-bituti.ads |  16 +++-
 gcc/ada/rtsfind.ads          |   4 +
 gcc/ada/sem_util.adb         |  19 +++-
 gcc/ada/sem_util.ads         |  26 +++++-
 7 files changed, 271 insertions(+), 40 deletions(-)

diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index cd9ab290366..39e2e0cb71c 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -64,6 +64,7 @@ with Snames;         use Snames;
 with Stand;          use Stand;
 with Stringt;        use Stringt;
 with Tbuild;         use Tbuild;
+with Ttypes;         use Ttypes;
 with Uintp;          use Uintp;
 with Validsw;        use Validsw;
 
@@ -127,8 +128,16 @@ package body Exp_Ch5 is
       R_Type : Entity_Id;
       Rev    : Boolean) return Node_Id;
    --  Alternative to Expand_Assign_Array_Loop for packed bitfields. Generates
-   --  a call to the System.Bitfields.Copy_Bitfield, which is more efficient
-   --  than copying component-by-component.
+   --  a call to System.Bitfields.Copy_Bitfield, which is more efficient than
+   --  copying component-by-component.
+
+   function Expand_Assign_Array_Bitfield_Fast
+     (N      : Node_Id;
+      Larray : Entity_Id;
+      Rarray : Entity_Id) return Node_Id;
+   --  Alternative to Expand_Assign_Array_Bitfield. Generates a call to
+   --  System.Bitfields.Fast_Copy_Bitfield, which is more efficient than
+   --  Copy_Bitfield, but only works in restricted situations.
 
    function Expand_Assign_Array_Loop_Or_Bitfield
      (N      : Node_Id;
@@ -138,8 +147,8 @@ package body Exp_Ch5 is
       R_Type : Entity_Id;
       Ndim   : Pos;
       Rev    : Boolean) return Node_Id;
-   --  Calls either Expand_Assign_Array_Loop or Expand_Assign_Array_Bitfield as
-   --  appropriate.
+   --  Calls either Expand_Assign_Array_Loop, Expand_Assign_Array_Bitfield, or
+   --  Expand_Assign_Array_Bitfield_Fast as appropriate.
 
    procedure Expand_Assign_Record (N : Node_Id);
    --  N is an assignment of an untagged record value. This routine handles
@@ -1440,6 +1449,84 @@ package body Exp_Ch5 is
           R_Addr, R_Bit, L_Addr, L_Bit, Size));
    end Expand_Assign_Array_Bitfield;
 
+   ---------------------------------------
+   -- Expand_Assign_Array_Bitfield_Fast --
+   ---------------------------------------
+
+   function Expand_Assign_Array_Bitfield_Fast
+     (N      : Node_Id;
+      Larray : Entity_Id;
+      Rarray : Entity_Id) return Node_Id
+   is
+      pragma Assert (not Change_Of_Representation (N));
+      --  This won't work, for example, to copy a packed array to an unpacked
+      --  array.
+
+      --  For L (A .. B) := R (C .. D), we generate:
+      --
+      --     L := Fast_Copy_Bitfield (R, <offset of R(C)>, L, <offset of L(A)>,
+      --                              L (A .. B)'Length * L'Component_Size);
+      --
+      --  with L and R suitably uncheckedly converted to/from Val_2.
+      --  The offsets are from the start of L and R.
+
+      Loc  : constant Source_Ptr := Sloc (N);
+
+      L_Val : constant Node_Id :=
+        Unchecked_Convert_To (RTE (RE_Val_2), Larray);
+      R_Val : constant Node_Id :=
+        Unchecked_Convert_To (RTE (RE_Val_2), Rarray);
+      --  Converted values of left- and right-hand sides
+
+      C_Size : constant Uint := Component_Size (Etype (Larray));
+      pragma Assert (C_Size >= 1);
+      pragma Assert (C_Size = Component_Size (Etype (Rarray)));
+
+      Larray_Bounds : constant Range_Values :=
+        Get_Index_Bounds (First_Index (Etype (Larray)));
+      L_Bounds : constant Range_Values :=
+        (if Nkind (Name (N)) = N_Slice
+         then Get_Index_Bounds (Discrete_Range (Name (N)))
+         else Larray_Bounds);
+      --  If the left-hand side is A (L..H), Larray_Bounds is A'Range, and
+      --  L_Bounds is L..H. If it's not a slice, we treat it like a slice
+      --  starting at A'First.
+
+      L_Bit : constant Node_Id :=
+        Make_Integer_Literal (Loc, (L_Bounds.L - Larray_Bounds.L) * C_Size);
+
+      Rarray_Bounds : constant Range_Values :=
+        Get_Index_Bounds (First_Index (Etype (Rarray)));
+      R_Bounds : constant Range_Values :=
+        (if Nkind (Expression (N)) = N_Slice
+         then Get_Index_Bounds (Discrete_Range (Expression (N)))
+         else Rarray_Bounds);
+
+      R_Bit : constant Node_Id :=
+        Make_Integer_Literal (Loc, (R_Bounds.L - Rarray_Bounds.L) * C_Size);
+
+      Size : constant Node_Id :=
+        Make_Op_Multiply (Loc,
+          Make_Attribute_Reference (Loc,
+            Prefix =>
+              Duplicate_Subexpr (Name (N), True),
+            Attribute_Name => Name_Length),
+          Make_Attribute_Reference (Loc,
+            Prefix =>
+              Duplicate_Subexpr (Larray, True),
+            Attribute_Name => Name_Component_Size));
+
+      Call : constant Node_Id := Make_Function_Call (Loc,
+        Name => New_Occurrence_Of (RTE (RE_Fast_Copy_Bitfield), Loc),
+        Parameter_Associations => New_List (
+          R_Val, R_Bit, L_Val, L_Bit, Size));
+
+   begin
+      return Make_Assignment_Statement (Loc,
+        Name => Duplicate_Subexpr (Larray, True),
+        Expression => Unchecked_Convert_To (Etype (Larray), Call));
+   end Expand_Assign_Array_Bitfield_Fast;
+
    ------------------------------------------
    -- Expand_Assign_Array_Loop_Or_Bitfield --
    ------------------------------------------
@@ -1453,6 +1540,7 @@ package body Exp_Ch5 is
       Ndim   : Pos;
       Rev    : Boolean) return Node_Id
    is
+
       Slices : constant Boolean :=
         Nkind (Name (N)) = N_Slice or else Nkind (Expression (N)) = N_Slice;
       L_Prefix_Comp : constant Boolean :=
@@ -1467,23 +1555,23 @@ package body Exp_Ch5 is
                      N_Selected_Component | N_Indexed_Component | N_Slice;
 
    begin
-      --  Determine whether Copy_Bitfield is appropriate (will work, and will
-      --  be more efficient than component-by-component copy). Copy_Bitfield
-      --  doesn't work for reversed storage orders. It is efficient for slices
-      --  of bit-packed arrays. Copy_Bitfield can read and write bits that are
-      --  not part of the objects being copied, so we don't want to use it if
-      --  there are volatile or independent components. If the Prefix of the
-      --  slice is a component or slice, then it might be a part of an object
-      --  with some other volatile or independent components, so we disable the
-      --  optimization in that case as well. We could complicate this code by
-      --  actually looking for such volatile and independent components.
+      --  Determine whether Copy_Bitfield or Fast_Copy_Bitfield is appropriate
+      --  (will work, and will be more efficient than component-by-component
+      --  copy). Copy_Bitfield doesn't work for reversed storage orders. It is
+      --  efficient for slices of bit-packed arrays. Copy_Bitfield can read and
+      --  write bits that are not part of the objects being copied, so we don't
+      --  want to use it if there are volatile or independent components. If
+      --  the Prefix of the slice is a component or slice, then it might be a
+      --  part of an object with some other volatile or independent components,
+      --  so we disable the optimization in that case as well. We could
+      --  complicate this code by actually looking for such volatile and
+      --  independent components.
 
       if Is_Bit_Packed_Array (L_Type)
         and then Is_Bit_Packed_Array (R_Type)
         and then not Reverse_Storage_Order (L_Type)
         and then not Reverse_Storage_Order (R_Type)
         and then Ndim = 1
-        and then not Rev
         and then Slices
         and then not Has_Volatile_Component (L_Type)
         and then not Has_Volatile_Component (R_Type)
@@ -1491,14 +1579,87 @@ package body Exp_Ch5 is
         and then not Has_Independent_Components (R_Type)
         and then not L_Prefix_Comp
         and then not R_Prefix_Comp
-        and then RTE_Available (RE_Copy_Bitfield)
       then
-         return Expand_Assign_Array_Bitfield
-           (N, Larray, Rarray, L_Type, R_Type, Rev);
-      else
-         return Expand_Assign_Array_Loop
-           (N, Larray, Rarray, L_Type, R_Type, Ndim, Rev);
+         --  Here if Copy_Bitfield can work (except for the Rev test below).
+         --  Determine whether to call Fast_Copy_Bitfield instead. If we
+         --  are assigning slices, and all the relevant bounds are known at
+         --  compile time, and the maximum object size is no greater than
+         --  System.Bitfields.Val_Bits (i.e. Long_Long_Integer'Size / 2), and
+         --  we don't have enumeration representation clauses, we can use
+         --  Fast_Copy_Bitfield. The max size test is to ensure that the slices
+         --  cannot overlap boundaries not supported by Fast_Copy_Bitfield.
+
+         pragma Assert (Known_Component_Size (Base_Type (L_Type)));
+         pragma Assert (Known_Component_Size (Base_Type (R_Type)));
+
+         --  Note that L_Type and R_Type do not necessarily have the same base
+         --  type, because of array type conversions. Hence the need to check
+         --  various properties of both.
+
+         if Compile_Time_Known_Bounds (Base_Type (L_Type))
+           and then Compile_Time_Known_Bounds (Base_Type (R_Type))
+         then
+            declare
+               Left_Base_Index : constant Entity_Id :=
+                 First_Index (Base_Type (L_Type));
+               Left_Base_Range : constant Range_Values :=
+                 Get_Index_Bounds (Left_Base_Index);
+
+               Right_Base_Index : constant Entity_Id :=
+                 First_Index (Base_Type (R_Type));
+               Right_Base_Range : constant Range_Values :=
+                 Get_Index_Bounds (Right_Base_Index);
+
+               Known_Left_Slice_Low : constant Boolean :=
+                 (if Nkind (Name (N)) = N_Slice
+                    then Compile_Time_Known_Value
+                      (Get_Index_Bounds (Discrete_Range (Name (N))).L));
+               Known_Right_Slice_Low : constant Boolean :=
+                 (if Nkind (Expression (N)) = N_Slice
+                    then Compile_Time_Known_Value
+                      (Get_Index_Bounds (Discrete_Range (Expression (N))).H));
+
+               Val_Bits : constant Pos := Standard_Long_Long_Integer_Size / 2;
+
+            begin
+               if Left_Base_Range.H - Left_Base_Range.L < Val_Bits
+                 and then Right_Base_Range.H - Right_Base_Range.L < Val_Bits
+                 and then Known_Esize (L_Type)
+                 and then Known_Esize (R_Type)
+                 and then Known_Left_Slice_Low
+                 and then Known_Right_Slice_Low
+                 and then Compile_Time_Known_Value
+                   (Get_Index_Bounds (First_Index (Etype (Larray))).L)
+                 and then Compile_Time_Known_Value
+                   (Get_Index_Bounds (First_Index (Etype (Rarray))).L)
+                 and then
+                   not (Is_Enumeration_Type (Etype (Left_Base_Index))
+                          and then Has_Enumeration_Rep_Clause
+                            (Etype (Left_Base_Index)))
+                 and then RTE_Available (RE_Fast_Copy_Bitfield)
+               then
+                  pragma Assert (Esize (L_Type) /= 0);
+                  pragma Assert (Esize (R_Type) /= 0);
+
+                  return Expand_Assign_Array_Bitfield_Fast (N, Larray, Rarray);
+               end if;
+            end;
+         end if;
+
+         --  Fast_Copy_Bitfield can work if Rev is True, because the data is
+         --  passed and returned by copy. Copy_Bitfield cannot.
+
+         if not Rev and then RTE_Available (RE_Copy_Bitfield) then
+            return Expand_Assign_Array_Bitfield
+              (N, Larray, Rarray, L_Type, R_Type, Rev);
+         end if;
       end if;
+
+      --  Here if we did not return above, with Fast_Copy_Bitfield or
+      --  Copy_Bitfield.
+
+      return Expand_Assign_Array_Loop
+        (N, Larray, Rarray, L_Type, R_Type, Ndim, Rev);
    end Expand_Assign_Array_Loop_Or_Bitfield;
 
    --------------------------
diff --git a/gcc/ada/libgnat/s-bitfie.ads b/gcc/ada/libgnat/s-bitfie.ads
index b60a4feefed..f081d55fe5f 100644
--- a/gcc/ada/libgnat/s-bitfie.ads
+++ b/gcc/ada/libgnat/s-bitfie.ads
@@ -47,10 +47,9 @@ package System.Bitfields is
    pragma Provide_Shift_Operators (Val_2);
    type Val is mod 2**Val_Bits with Alignment => Val_Bytes;
 
-   --  ??? It turns out that enabling checks on the instantiation of
-   --  System.Bitfield_Utils.G makes a latent visibility bug appear on strict
-   --  alignment platforms related to alignment checks. Work around it by
-   --  suppressing these checks explicitly.
+   --  Enabling checks on the instantiation of System.Bitfield_Utils.G makes a
+   --  latent visibility bug appear on strict alignment platforms related to
+   --  alignment checks. Work around it by suppressing these checks explicitly.
 
    pragma Suppress (Alignment_Check);
    package Utils is new System.Bitfield_Utils.G (Val, Val_2);
@@ -63,4 +62,12 @@ package System.Bitfields is
       Size         : Utils.Bit_Size)
      renames Utils.Copy_Bitfield;
 
+   function Fast_Copy_Bitfield
+     (Src         : Val_2;
+      Src_Offset  : Utils.Bit_Offset;
+      Dest        : Val_2;
+      Dest_Offset : Utils.Bit_Offset;
+      Size        : Utils.Small_Size)
+     return Val_2 renames Utils.Fast_Copy_Bitfield;
+
 end System.Bitfields;
diff --git a/gcc/ada/libgnat/s-bituti.adb b/gcc/ada/libgnat/s-bituti.adb
index 3e584e72bfe..d571f544bb6 100644
--- a/gcc/ada/libgnat/s-bituti.adb
+++ b/gcc/ada/libgnat/s-bituti.adb
@@ -31,14 +31,6 @@
 
 package body System.Bitfield_Utils is
 
-   --  ???
-   --
-   --  This code does not yet work for overlapping bit fields. We need to copy
-   --  backwards in some cases (i.e. from higher to lower bit addresses).
-   --  Alternatively, we could avoid calling this if Forwards_OK is False.
-   --
-   --  ???
-
    package body G is
 
       Val_Bytes : constant Address := Address (Val'Size / Storage_Unit);
@@ -77,7 +69,7 @@ package body System.Bitfield_Utils is
 
       function Get_Bitfield
         (Src : Val_2; Src_Offset : Bit_Offset; Size : Small_Size)
-         return Val;
+         return Val with Inline;
       --  Returns the bit field in Src starting at Src_Offset, of the given
       --  Size. If Size < Small_Size'Last, then high order bits are zero.
 
@@ -86,7 +78,7 @@ package body System.Bitfield_Utils is
          Dest : Val_2;
          Dest_Offset : Bit_Offset;
          Size : Small_Size)
-        return Val_2;
+        return Val_2 with Inline;
       --  The bit field in Dest starting at Dest_Offset, of the given Size, is
       --  set to Src_Value. Src_Value must have high order bits (Size and
       --  above) zero. The result is returned as the function result.
@@ -426,6 +418,22 @@ package body System.Bitfield_Utils is
          end if;
       end Copy_Bitfield;
 
+      function Fast_Copy_Bitfield
+        (Src         : Val_2;
+         Src_Offset  : Bit_Offset;
+         Dest        : Val_2;
+         Dest_Offset : Bit_Offset;
+         Size        : Small_Size)
+        return Val_2 is
+         Result : constant Val_2 := Set_Bitfield
+           (Get_Bitfield (Src, Src_Offset, Size), Dest, Dest_Offset, Size);
+      begin
+         --  No need to explicitly do nothing for zero size case, because Size
+         --  cannot be zero.
+
+         return Result;
+      end Fast_Copy_Bitfield;
+
    end G;
 
 end System.Bitfield_Utils;
diff --git a/gcc/ada/libgnat/s-bituti.ads b/gcc/ada/libgnat/s-bituti.ads
index c9c4b9184b9..8afee248d65 100644
--- a/gcc/ada/libgnat/s-bituti.ads
+++ b/gcc/ada/libgnat/s-bituti.ads
@@ -54,7 +54,7 @@ package System.Bitfield_Utils is
    --  generic formal, or on a type derived from a generic formal, so they have
    --  to be passed in.
    --
-   --  Endian indicates whether we're on little-endian or big-endian machine.
+   --  Endian indicates whether we're on a little- or big-endian machine.
 
    pragma Elaborate_Body;
 
@@ -127,6 +127,20 @@ package System.Bitfield_Utils is
       --        D (D_First)'Address, D (D_First)'Bit,
       --        Size);
 
+      function Fast_Copy_Bitfield
+        (Src         : Val_2;
+         Src_Offset  : Bit_Offset;
+         Dest        : Val_2;
+         Dest_Offset : Bit_Offset;
+         Size        : Small_Size)
+        return Val_2 with Inline;
+      --  Faster version of Copy_Bitfield, with a different calling convention.
+      --  In particular, we pass by copy rather than passing Addresses. The bit
+      --  field must fit in Val_Bits. Src and Dest must be properly aligned.
+      --  The result is supposed to be assigned back into Dest, as in:
+      --
+      --     Dest := Fast_Copy_Bitfield (Src, ..., Dest, ..., ...);
+
    end G;
 
 end System.Bitfield_Utils;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 28d14bdbac2..36e0440c868 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -838,7 +838,9 @@ package Rtsfind is
      RE_To_Bignum,                       -- System.Bignums
      RE_From_Bignum,                     -- System.Bignums
 
+     RE_Val_2,                           -- System.Bitfields
      RE_Copy_Bitfield,                   -- System.Bitfields
+     RE_Fast_Copy_Bitfield,              -- System.Bitfields
 
      RE_Bit_And,                         -- System.Bit_Ops
      RE_Bit_Eq,                          -- System.Bit_Ops
@@ -2518,7 +2520,9 @@ package Rtsfind is
      RE_To_Bignum                        => System_Bignums,
      RE_From_Bignum                      => System_Bignums,
 
+     RE_Val_2                            => System_Bitfields,
      RE_Copy_Bitfield                    => System_Bitfields,
+     RE_Fast_Copy_Bitfield               => System_Bitfields,
 
      RE_Bit_And                          => System_Bit_Ops,
      RE_Bit_Eq                           => System_Bit_Ops,
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 44a568404ad..479bb146b61 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10943,6 +10943,23 @@ package body Sem_Util is
       end if;
    end Get_Index_Bounds;
 
+   function Get_Index_Bounds
+     (N             : Node_Id;
+      Use_Full_View : Boolean := False) return Range_Nodes is
+      Result : Range_Nodes;
+   begin
+      Get_Index_Bounds (N, Result.L, Result.H, Use_Full_View);
+      return Result;
+   end Get_Index_Bounds;
+
+   function Get_Index_Bounds
+     (N             : Node_Id;
+      Use_Full_View : Boolean := False) return Range_Values is
+      Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View);
+   begin
+      return (Expr_Value (Nodes.L), Expr_Value (Nodes.H));
+   end Get_Index_Bounds;
+
    -----------------------------
    -- Get_Interfacing_Aspects --
    -----------------------------
@@ -26984,7 +27001,7 @@ package body Sem_Util is
    is
    begin
       --  The only entities for which we track constant values are variables
-      --  which are not renamings, constants and formal parameters, so check
+      --  that are not renamings, constants and formal parameters, so check
       --  if we have this case.
 
       --  Note: it may seem odd to track constant values for constants, but in
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 0519b3c3fdd..a1ed43cba43 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1167,6 +1167,26 @@ package Sem_Util is
    --  the index type turns out to be a partial view; this case should not
    --  arise during normal compilation of semantically correct programs.
 
+   type Range_Nodes is record
+      L, H : Node_Id; -- First and Last nodes of a discrete_range
+   end record;
+
+   type Range_Values is record
+      L, H : Uint; -- First and Last values of a discrete_range
+   end record;
+
+   function Get_Index_Bounds
+     (N             : Node_Id;
+      Use_Full_View : Boolean := False) return Range_Nodes;
+   --  Same as the above procedure, but returns the result as a record.
+   --  ???This should probably replace the procedure.
+
+   function Get_Index_Bounds
+     (N             : Node_Id;
+      Use_Full_View : Boolean := False) return Range_Values;
+   --  Same as the above function, but returns the values, which must be known
+   --  at compile time.
+
    procedure Get_Interfacing_Aspects
      (Iface_Asp : Node_Id;
       Conv_Asp  : out Node_Id;
@@ -2960,9 +2980,9 @@ package Sem_Util is
    --  the value is valid) for the given entity Ent. This value can only be
    --  captured if sequential execution semantics can be properly guaranteed so
    --  that a subsequent reference will indeed be sure that this current value
-   --  indication is correct. The node N is the construct which resulted in
-   --  the possible capture of the value (this is used to check if we are in
-   --  a conditional).
+   --  indication is correct. The node N is the construct that resulted in the
+   --  possible capture of the value (this is used to check if we are in a
+   --  conditional).
    --
    --  Cond is used to skip the test for being inside a conditional. It is used
    --  in the case of capturing values from if/while tests, which already do a