[gcc r12-1689] [Ada] Improve efficiency of small slice assignments of packed arrays
Pierre-Marie de Rodat
pmderodat@gcc.gnu.org
Mon Jun 21 11:06:19 GMT 2021
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
More information about the Gcc-cvs
mailing list