[Ada] Add the System.Bitfield_Utils runtime unit
2019-08-21 Bob Duff <duff@adacore.com> gcc/ada/ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-bitutil.o and s-biutin.o. * exp_ch5.adb (Expand_Assign_Array_Bitfield): New function to generate a call to Copy_Bitfield. This is disabled for now. (Expand_Assign_Array_Loop_Or_Bitfield): New function to decide whether to call Expand_Assign_Array_Bitfield. (Expand_Assign_Array): Call Expand_Assign_Array_Loop_Or_Bitfield instead of Expand_Assign_Array_Loop. * libgnat/s-bitfie.ads, libgnat/s-bituti.adb, libgnat/s-bituti.ads: New units. * rtsfind.ads: Add enum literals for accessing Copy_Bitfield. From-SVN: r274785
This commit is contained in:
Bob Duff
Pierre-Marie de Rodat
parent
a1fda1e875
commit
abdeafa67a
|
|
@ -1,3 +1,17 @@
|
|||
2019-08-21 Bob Duff <duff@adacore.com>
|
||||
|
||||
* Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-bitutil.o and
|
||||
s-biutin.o.
|
||||
* exp_ch5.adb (Expand_Assign_Array_Bitfield): New function to
|
||||
generate a call to Copy_Bitfield. This is disabled for now.
|
||||
(Expand_Assign_Array_Loop_Or_Bitfield): New function to decide
|
||||
whether to call Expand_Assign_Array_Bitfield.
|
||||
(Expand_Assign_Array): Call Expand_Assign_Array_Loop_Or_Bitfield
|
||||
instead of Expand_Assign_Array_Loop.
|
||||
* libgnat/s-bitfie.ads, libgnat/s-bituti.adb,
|
||||
libgnat/s-bituti.ads: New units.
|
||||
* rtsfind.ads: Add enum literals for accessing Copy_Bitfield.
|
||||
|
||||
2019-08-21 Piotr Trojanek <trojanek@adacore.com>
|
||||
|
||||
* bindo-graphs.ads (Iterate_Edges_To_Successors): Fix typo in
|
||||
|
|
|
|||
|
|
@ -502,7 +502,9 @@ GNATRTL_NONTASKING_OBJS= \
|
|||
s-atopri$(objext) \
|
||||
s-auxdec$(objext) \
|
||||
s-bignum$(objext) \
|
||||
s-bitfie$(objext) \
|
||||
s-bitops$(objext) \
|
||||
s-bituti$(objext) \
|
||||
s-boarop$(objext) \
|
||||
s-boustr$(objext) \
|
||||
s-bytswa$(objext) \
|
||||
|
|
|
|||
|
|
@ -114,6 +114,28 @@ package body Exp_Ch5 is
|
|||
-- Auxiliary declarations are inserted before node N using the standard
|
||||
-- Insert_Actions mechanism.
|
||||
|
||||
function Expand_Assign_Array_Bitfield
|
||||
(N : Node_Id;
|
||||
Larray : Entity_Id;
|
||||
Rarray : Entity_Id;
|
||||
L_Type : Entity_Id;
|
||||
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.
|
||||
|
||||
function Expand_Assign_Array_Loop_Or_Bitfield
|
||||
(N : Node_Id;
|
||||
Larray : Entity_Id;
|
||||
Rarray : Entity_Id;
|
||||
L_Type : Entity_Id;
|
||||
R_Type : Entity_Id;
|
||||
Ndim : Pos;
|
||||
Rev : Boolean) return Node_Id;
|
||||
-- Calls either Expand_Assign_Array_Loop or Expand_Assign_Array_Bitfield as
|
||||
-- appropriate.
|
||||
|
||||
procedure Expand_Assign_Record (N : Node_Id);
|
||||
-- N is an assignment of an untagged record value. This routine handles
|
||||
-- the case where the assignment must be made component by component,
|
||||
|
|
@ -314,6 +336,10 @@ package body Exp_Ch5 is
|
|||
|
||||
Crep : constant Boolean := Change_Of_Representation (N);
|
||||
|
||||
pragma Assert
|
||||
(Crep
|
||||
or else Is_Bit_Packed_Array (L_Type) = Is_Bit_Packed_Array (R_Type));
|
||||
|
||||
Larray : Node_Id;
|
||||
Rarray : Node_Id;
|
||||
|
||||
|
|
@ -939,7 +965,7 @@ package body Exp_Ch5 is
|
|||
|
||||
else
|
||||
Rewrite (N,
|
||||
Expand_Assign_Array_Loop
|
||||
Expand_Assign_Array_Loop_Or_Bitfield
|
||||
(N, Larray, Rarray, L_Type, R_Type, Ndim,
|
||||
Rev => not Forwards_OK (N)));
|
||||
end if;
|
||||
|
|
@ -1092,12 +1118,12 @@ package body Exp_Ch5 is
|
|||
Condition => Condition,
|
||||
|
||||
Then_Statements => New_List (
|
||||
Expand_Assign_Array_Loop
|
||||
Expand_Assign_Array_Loop_Or_Bitfield
|
||||
(N, Larray, Rarray, L_Type, R_Type, Ndim,
|
||||
Rev => False)),
|
||||
|
||||
Else_Statements => New_List (
|
||||
Expand_Assign_Array_Loop
|
||||
Expand_Assign_Array_Loop_Or_Bitfield
|
||||
(N, Larray, Rarray, L_Type, R_Type, Ndim,
|
||||
Rev => True))));
|
||||
end if;
|
||||
|
|
@ -1320,6 +1346,134 @@ package body Exp_Ch5 is
|
|||
return Assign;
|
||||
end Expand_Assign_Array_Loop;
|
||||
|
||||
----------------------------------
|
||||
-- Expand_Assign_Array_Bitfield --
|
||||
----------------------------------
|
||||
|
||||
function Expand_Assign_Array_Bitfield
|
||||
(N : Node_Id;
|
||||
Larray : Entity_Id;
|
||||
Rarray : Entity_Id;
|
||||
L_Type : Entity_Id;
|
||||
R_Type : Entity_Id;
|
||||
Rev : Boolean) return Node_Id
|
||||
is
|
||||
pragma Assert (not Rev);
|
||||
-- Reverse copying is not yet supported by Copy_Bitfield.
|
||||
|
||||
pragma Assert (not Change_Of_Representation (N));
|
||||
-- This won't work, for example, to copy a packed array to an unpacked
|
||||
-- array.
|
||||
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
||||
L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type));
|
||||
R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type));
|
||||
Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ);
|
||||
Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ);
|
||||
|
||||
L_Addr : constant Node_Id :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix =>
|
||||
Duplicate_Subexpr (Larray, True),
|
||||
Expressions => New_List (New_Copy_Tree (Left_Lo))),
|
||||
Attribute_Name => Name_Address);
|
||||
|
||||
L_Bit : constant Node_Id :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix =>
|
||||
Duplicate_Subexpr (Larray, True),
|
||||
Expressions => New_List (New_Copy_Tree (Left_Lo))),
|
||||
Attribute_Name => Name_Bit);
|
||||
|
||||
R_Addr : constant Node_Id :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix =>
|
||||
Duplicate_Subexpr (Rarray, True),
|
||||
Expressions => New_List (New_Copy_Tree (Right_Lo))),
|
||||
Attribute_Name => Name_Address);
|
||||
|
||||
R_Bit : constant Node_Id :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix =>
|
||||
Duplicate_Subexpr (Rarray, True),
|
||||
Expressions => New_List (New_Copy_Tree (Right_Lo))),
|
||||
Attribute_Name => Name_Bit);
|
||||
|
||||
-- Compute the Size of the bitfield. ???We can't use Size here, because
|
||||
-- it doesn't work properly for slices of packed arrays, so we compute
|
||||
-- the L'Size as L'Length*L'Component_Size.
|
||||
--
|
||||
-- Note that the length check has already been done, so we can use the
|
||||
-- size of either L or R.
|
||||
|
||||
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 (Name (N), True),
|
||||
Attribute_Name => Name_Component_Size));
|
||||
|
||||
begin
|
||||
return Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Occurrence_Of (RTE (RE_Copy_Bitfield), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
R_Addr, R_Bit, L_Addr, L_Bit, Size));
|
||||
end Expand_Assign_Array_Bitfield;
|
||||
|
||||
------------------------------------------
|
||||
-- Expand_Assign_Array_Loop_Or_Bitfield --
|
||||
------------------------------------------
|
||||
|
||||
function Expand_Assign_Array_Loop_Or_Bitfield
|
||||
(N : Node_Id;
|
||||
Larray : Entity_Id;
|
||||
Rarray : Entity_Id;
|
||||
L_Type : Entity_Id;
|
||||
R_Type : Entity_Id;
|
||||
Ndim : Pos;
|
||||
Rev : Boolean) return Node_Id
|
||||
is
|
||||
Slices : constant Boolean :=
|
||||
Nkind (Name (N)) = N_Slice or else Nkind (Expression (N)) = 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 only for
|
||||
-- slices of bit-packed arrays.
|
||||
|
||||
-- Note that Expand_Assign_Array_Bitfield is disabled for now
|
||||
|
||||
if False -- ???
|
||||
and then Is_Bit_Packed_Array (L_Type)
|
||||
and then Is_Bit_Packed_Array (R_Type)
|
||||
and then RTE_Available (RE_Copy_Bitfield)
|
||||
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
|
||||
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);
|
||||
end if;
|
||||
end Expand_Assign_Array_Loop_Or_Bitfield;
|
||||
|
||||
--------------------------
|
||||
-- Expand_Assign_Record --
|
||||
--------------------------
|
||||
|
|
|
|||
|
|
@ -0,0 +1,56 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . B I T F I E L D _ U T I L S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2019, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with System.Bitfield_Utils;
|
||||
|
||||
package System.Bitfields is
|
||||
|
||||
-- Instances of the generic package in System.Bitfield_Utils. So far
|
||||
-- we have just one, which defaults to the natural endianness of the
|
||||
-- machine. We might someday want to support Scalar_Storage_Order.
|
||||
|
||||
Val_Bytes : constant := 4;
|
||||
Val_Bits : constant := Val_Bytes * System.Storage_Unit;
|
||||
type Val_2 is mod 2**(Val_Bits * 2) with Alignment => Val_Bytes;
|
||||
pragma Provide_Shift_Operators (Val_2);
|
||||
type Val is mod 2**Val_Bits with Alignment => Val_Bytes;
|
||||
|
||||
package Utils is new System.Bitfield_Utils.G (Val, Val_2);
|
||||
|
||||
procedure Copy_Bitfield
|
||||
(Src_Address : Address;
|
||||
Src_Offset : Utils.Bit_Offset_In_Byte;
|
||||
Dest_Address : Address;
|
||||
Dest_Offset : Utils.Bit_Offset_In_Byte;
|
||||
Size : Utils.Bit_Size)
|
||||
renames Utils.Copy_Bitfield;
|
||||
|
||||
end System.Bitfields;
|
||||
|
|
@ -0,0 +1,320 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . B I T F I E L D _ U T I L S --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2019, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
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);
|
||||
|
||||
-- Get_Bitfield and Set_Bitfield are helper functions that get/set small
|
||||
-- bit fields -- the value fits in Val, and the bit field is placed
|
||||
-- starting at some offset within the first half of a Val_2.
|
||||
-- Copy_Bitfield, on the other hand, supports arbitrarily large bit
|
||||
-- fields. All operations require bit offsets to point within the first
|
||||
-- Val pointed to by the address.
|
||||
|
||||
function Get_Bitfield
|
||||
(Src : Val_2; Src_Offset : Bit_Offset; Size : Small_Size)
|
||||
return Val;
|
||||
-- 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.
|
||||
|
||||
function Get_Full_Bitfield
|
||||
(Src : Val_2; Src_Offset : Bit_Offset) return Val;
|
||||
-- Same as Get_Bitfield, except the Size is hardwired to the maximum
|
||||
-- allowed.
|
||||
|
||||
function Set_Bitfield
|
||||
(Src_Value : Val;
|
||||
Dest : Val_2;
|
||||
Dest_Offset : Bit_Offset;
|
||||
Size : Small_Size)
|
||||
return Val_2;
|
||||
-- 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.
|
||||
|
||||
function Get_Bitfield
|
||||
(Src : Val_2; Src_Offset : Bit_Offset; Size : Small_Size)
|
||||
return Val
|
||||
is
|
||||
L_Shift_Amount : constant Natural :=
|
||||
(case Endian is
|
||||
when Little => Val_2'Size - (Src_Offset + Size),
|
||||
when Big => Src_Offset);
|
||||
Temp1 : constant Val_2 :=
|
||||
Shift_Left (Src, L_Shift_Amount);
|
||||
Temp2 : constant Val_2 :=
|
||||
Shift_Right (Temp1, Val_2'Size - Size);
|
||||
begin
|
||||
return Val (Temp2);
|
||||
end Get_Bitfield;
|
||||
|
||||
function Get_Full_Bitfield
|
||||
(Src : Val_2; Src_Offset : Bit_Offset) return Val is
|
||||
begin
|
||||
return Get_Bitfield (Src, Src_Offset, Size => Val'Size);
|
||||
end Get_Full_Bitfield;
|
||||
|
||||
function Set_Bitfield
|
||||
(Src_Value : Val;
|
||||
Dest : Val_2;
|
||||
Dest_Offset : Bit_Offset;
|
||||
Size : Small_Size)
|
||||
return Val_2
|
||||
is
|
||||
pragma Assert (Size = Val'Size or else Src_Value < 2**Size);
|
||||
L_Shift_Amount : constant Natural :=
|
||||
(case Endian is
|
||||
when Little => Dest_Offset,
|
||||
when Big => Val_2'Size - (Dest_Offset + Size));
|
||||
Mask : constant Val_2 :=
|
||||
Shift_Left (Shift_Left (1, Size) - 1, L_Shift_Amount);
|
||||
Temp1 : constant Val_2 := Dest and not Mask;
|
||||
Temp2 : constant Val_2 :=
|
||||
Shift_Left (Val_2 (Src_Value), L_Shift_Amount);
|
||||
Result : constant Val_2 := Temp1 or Temp2;
|
||||
begin
|
||||
return Result;
|
||||
end Set_Bitfield;
|
||||
|
||||
procedure Copy_Small_Bitfield
|
||||
(Src_Address : Address;
|
||||
Src_Offset : Bit_Offset;
|
||||
Dest_Address : Address;
|
||||
Dest_Offset : Bit_Offset;
|
||||
Size : Small_Size);
|
||||
-- Copy_Bitfield in the case where Size <= Val'Size.
|
||||
-- The Address values must be aligned as for Val and Val_2.
|
||||
-- This works for overlapping bit fields.
|
||||
|
||||
procedure Copy_Large_Bitfield
|
||||
(Src_Address : Address;
|
||||
Src_Offset : Bit_Offset;
|
||||
Dest_Address : Address;
|
||||
Dest_Offset : Bit_Offset;
|
||||
Size : Bit_Size);
|
||||
-- Copy_Bitfield in the case where Size > Val'Size.
|
||||
-- The Address values must be aligned as for Val and Val_2.
|
||||
-- This works for overlapping bit fields only if the source
|
||||
-- bit address is greater than or equal to the destination
|
||||
-- bit address, because it copies forward (from lower to higher
|
||||
-- bit addresses).
|
||||
|
||||
procedure Copy_Small_Bitfield
|
||||
(Src_Address : Address;
|
||||
Src_Offset : Bit_Offset;
|
||||
Dest_Address : Address;
|
||||
Dest_Offset : Bit_Offset;
|
||||
Size : Small_Size)
|
||||
is
|
||||
Src : constant Val_2 with Import, Address => Src_Address;
|
||||
V : constant Val := Get_Bitfield (Src, Src_Offset, Size);
|
||||
Dest : Val_2 with Import, Address => Dest_Address;
|
||||
begin
|
||||
Dest := Set_Bitfield (V, Dest, Dest_Offset, Size);
|
||||
end Copy_Small_Bitfield;
|
||||
|
||||
-- Copy_Large_Bitfield does the main work. Copying aligned Vals is more
|
||||
-- efficient than fiddling with shifting and whatnot. But we can't align
|
||||
-- both source and destination. We choose to align the destination,
|
||||
-- because that's more efficient -- Set_Bitfield needs to read, then
|
||||
-- modify, then write, whereas Get_Bitfield does not.
|
||||
--
|
||||
-- So the method is:
|
||||
--
|
||||
-- Step 1:
|
||||
-- If the destination is not already aligned, copy Initial_Size
|
||||
-- bits, and increment the bit addresses. Initial_Size is chosen to
|
||||
-- be the smallest size that will cause the destination bit address
|
||||
-- to be aligned (i.e. have zero bit offset from the already-aligned
|
||||
-- Address). Get_Bitfield and Set_Bitfield are used here.
|
||||
--
|
||||
-- Step 2:
|
||||
-- Loop, copying Vals. Get_Full_Bitfield is used to fetch a
|
||||
-- Val-sized bit field, but Set_Bitfield is not needed -- we can set
|
||||
-- the aligned Val with an array indexing.
|
||||
--
|
||||
-- Step 3:
|
||||
-- Copy remaining smaller-than-Val bits, if any
|
||||
|
||||
procedure Copy_Large_Bitfield
|
||||
(Src_Address : Address;
|
||||
Src_Offset : Bit_Offset;
|
||||
Dest_Address : Address;
|
||||
Dest_Offset : Bit_Offset;
|
||||
Size : Bit_Size)
|
||||
is
|
||||
Sz : Bit_Size := Size;
|
||||
S_Addr : Address := Src_Address;
|
||||
S_Off : Bit_Offset := Src_Offset;
|
||||
D_Addr : Address := Dest_Address;
|
||||
D_Off : Bit_Offset := Dest_Offset;
|
||||
begin
|
||||
if S_Addr < D_Addr or else (S_Addr = D_Addr and then S_Off < D_Off)
|
||||
then
|
||||
-- Here, the source bit address is less than the destination bit
|
||||
-- address. Assert that there is no overlap.
|
||||
|
||||
declare
|
||||
Temp_Off : constant Bit_Offset'Base := S_Off + Size;
|
||||
After_S_Addr : constant Address :=
|
||||
S_Addr + Address (Temp_Off / Storage_Unit);
|
||||
After_S_Off : constant Bit_Offset_In_Byte :=
|
||||
Temp_Off mod Storage_Unit;
|
||||
-- (After_S_Addr, After_S_Off) is the bit address of the bit
|
||||
-- just after the source bit field. Assert that it's less than
|
||||
-- or equal to the destination bit address.
|
||||
Overlap_OK : constant Boolean :=
|
||||
After_S_Addr < D_Addr
|
||||
or else
|
||||
(After_S_Addr = D_Addr and then After_S_Off <= D_Off);
|
||||
begin
|
||||
pragma Assert (Overlap_OK);
|
||||
end;
|
||||
end if;
|
||||
|
||||
if D_Off /= 0 then
|
||||
-- Step 1:
|
||||
|
||||
declare
|
||||
Initial_Size : constant Small_Size := Val'Size - D_Off;
|
||||
Initial_Val_2 : constant Val_2 with Import, Address => S_Addr;
|
||||
Initial_Val : constant Val :=
|
||||
Get_Bitfield (Initial_Val_2, S_Off, Initial_Size);
|
||||
Initial_Dest : Val_2 with Import, Address => D_Addr;
|
||||
begin
|
||||
Initial_Dest := Set_Bitfield
|
||||
(Initial_Val, Initial_Dest, D_Off, Initial_Size);
|
||||
|
||||
Sz := Sz - Initial_Size;
|
||||
declare
|
||||
New_S_Off : constant Bit_Offset'Base := S_Off + Initial_Size;
|
||||
begin
|
||||
if New_S_Off > Bit_Offset'Last then
|
||||
S_Addr := S_Addr + Val_Bytes;
|
||||
S_Off := New_S_Off - Small_Size'Last;
|
||||
else
|
||||
S_Off := New_S_Off;
|
||||
end if;
|
||||
end;
|
||||
D_Addr := D_Addr + Val_Bytes;
|
||||
pragma Assert (D_Off + Initial_Size = Val'Size);
|
||||
D_Off := 0;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Step 2:
|
||||
|
||||
declare
|
||||
Dest_Arr : Val_Array (1 .. Sz / Val'Size) with Import,
|
||||
Address => D_Addr;
|
||||
begin
|
||||
for Dest_Comp of Dest_Arr loop
|
||||
declare
|
||||
pragma Warnings (Off);
|
||||
pragma Assert (Dest_Comp in Val);
|
||||
pragma Warnings (On);
|
||||
pragma Assert (Dest_Comp'Valid);
|
||||
Src_V_2 : constant Val_2 with Import, Address => S_Addr;
|
||||
Full_V : constant Val := Get_Full_Bitfield (Src_V_2, S_Off);
|
||||
begin
|
||||
Dest_Comp := Full_V;
|
||||
S_Addr := S_Addr + Val_Bytes;
|
||||
-- S_Off remains the same
|
||||
end;
|
||||
end loop;
|
||||
|
||||
if Sz mod Val'Size /= 0 then
|
||||
-- Step 3:
|
||||
|
||||
declare
|
||||
Final_Val_2 : constant Val_2 with Import, Address => S_Addr;
|
||||
Final_Val : constant Val :=
|
||||
Get_Bitfield (Final_Val_2, S_Off, Sz mod Val'Size);
|
||||
Final_Dest : Val_2 with Import,
|
||||
Address => D_Addr + Dest_Arr'Length * Val_Bytes;
|
||||
begin
|
||||
Final_Dest := Set_Bitfield
|
||||
(Final_Val, Final_Dest, 0, Sz mod Val'Size);
|
||||
end;
|
||||
end if;
|
||||
end;
|
||||
end Copy_Large_Bitfield;
|
||||
|
||||
procedure Copy_Bitfield
|
||||
(Src_Address : Address;
|
||||
Src_Offset : Bit_Offset_In_Byte;
|
||||
Dest_Address : Address;
|
||||
Dest_Offset : Bit_Offset_In_Byte;
|
||||
Size : Bit_Size)
|
||||
is
|
||||
-- Align the Address values as for Val and Val_2, and adjust the
|
||||
-- Bit_Offsets accordingly.
|
||||
|
||||
Src_Adjust : constant Address := Src_Address mod Val_Bytes;
|
||||
Al_Src_Address : constant Address := Src_Address - Src_Adjust;
|
||||
Al_Src_Offset : constant Bit_Offset :=
|
||||
Src_Offset + Bit_Offset (Src_Adjust * Storage_Unit);
|
||||
|
||||
Dest_Adjust : constant Address := Dest_Address mod Val_Bytes;
|
||||
Al_Dest_Address : constant Address := Dest_Address - Dest_Adjust;
|
||||
Al_Dest_Offset : constant Bit_Offset :=
|
||||
Dest_Offset + Bit_Offset (Dest_Adjust * Storage_Unit);
|
||||
|
||||
pragma Assert (Al_Src_Address mod Val'Alignment = 0);
|
||||
pragma Assert (Al_Dest_Address mod Val'Alignment = 0);
|
||||
begin
|
||||
if Size in Small_Size then
|
||||
Copy_Small_Bitfield
|
||||
(Al_Src_Address, Al_Src_Offset,
|
||||
Al_Dest_Address, Al_Dest_Offset,
|
||||
Size);
|
||||
else
|
||||
Copy_Large_Bitfield
|
||||
(Al_Src_Address, Al_Src_Offset,
|
||||
Al_Dest_Address, Al_Dest_Offset,
|
||||
Size);
|
||||
end if;
|
||||
end Copy_Bitfield;
|
||||
|
||||
end G;
|
||||
|
||||
end System.Bitfield_Utils;
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . B I T F I E L D _ U T I L S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2019, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
package System.Bitfield_Utils is
|
||||
|
||||
-- This package provides a procedure for copying arbitrarily large and
|
||||
-- arbitrarily bit-aligned bit fields.
|
||||
|
||||
-- Type Val is used to represent small bit fields. Val_2 represents a
|
||||
-- contiguous pair of Vals. Val_2'Alignment is half of its size in bytes,
|
||||
-- which is likely not the natural alignment. This is done to ensure that
|
||||
-- any bit field that fits in a Val can fit in an aligned Val_2, starting
|
||||
-- somewhere in the first half, and possibly crossing over into the second
|
||||
-- half. This allows us to isolate a Val value by shifting and masking the
|
||||
-- Val_2.
|
||||
--
|
||||
-- Val can be 8, 16, or 32 bits; larger values are more efficient. It can't
|
||||
-- be 64 bits, because we need Val_2 to be a double-wide shiftable type,
|
||||
-- and 128 bits is not supported. Instantiating with an 8-bit Val is useful
|
||||
-- for testing and debugging; 32 bits should be used for production.
|
||||
--
|
||||
-- We use modular types here, not because we want modular arithmetic, but
|
||||
-- so we can do shifting and masking. The actual for Val_2 should have
|
||||
-- pragma Provide_Shift_Operators, so that the Shift_Left and Shift_Right
|
||||
-- intrinsics can be passed in. It is impossible to put that pragma on a
|
||||
-- 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.
|
||||
|
||||
pragma Elaborate_Body;
|
||||
|
||||
Little : constant Bit_Order := Low_Order_First;
|
||||
Big : constant Bit_Order := High_Order_First;
|
||||
|
||||
generic
|
||||
type Val is mod <>;
|
||||
type Val_2 is mod <>;
|
||||
|
||||
with function Shift_Left
|
||||
(Value : Val_2;
|
||||
Amount : Natural) return Val_2 is <>;
|
||||
|
||||
with function Shift_Right
|
||||
(Value : Val_2;
|
||||
Amount : Natural) return Val_2 is <>;
|
||||
|
||||
Endian : Bit_Order := Default_Bit_Order;
|
||||
|
||||
package G is
|
||||
-- Assert that Val has one of the allowed sizes, and that Val_2 is twice
|
||||
-- that.
|
||||
|
||||
pragma Assert (Val'Size in 8 | 16 | 32);
|
||||
pragma Assert (Val_2'Size = Val'Size * 2);
|
||||
|
||||
-- Assert that both are aligned the same, to the size in bytes of Val
|
||||
-- (not Val_2).
|
||||
|
||||
pragma Assert (Val'Alignment = Val'Size / Storage_Unit);
|
||||
pragma Assert (Val_2'Alignment = Val'Alignment);
|
||||
|
||||
type Val_Array is array (Positive range <>) of Val;
|
||||
|
||||
-- It might make more sense to have:
|
||||
-- subtype Val is Val_2 range 0 .. 2**Val'Size - 1;
|
||||
-- But then GNAT gets the component size of Val_Array wrong.
|
||||
|
||||
pragma Assert (Val_Array'Alignment = Val'Alignment);
|
||||
pragma Assert (Val_Array'Component_Size = Val'Size);
|
||||
|
||||
subtype Bit_Size is Natural; -- Size in bits of a bit field
|
||||
subtype Small_Size is Bit_Size range 0 .. Val'Size;
|
||||
-- Size of a small one
|
||||
subtype Bit_Offset is Small_Size range 0 .. Val'Size - 1;
|
||||
-- Starting offset
|
||||
subtype Bit_Offset_In_Byte is Bit_Offset range 0 .. Storage_Unit - 1;
|
||||
|
||||
procedure Copy_Bitfield
|
||||
(Src_Address : Address;
|
||||
Src_Offset : Bit_Offset_In_Byte;
|
||||
Dest_Address : Address;
|
||||
Dest_Offset : Bit_Offset_In_Byte;
|
||||
Size : Bit_Size);
|
||||
-- An Address and a Bit_Offset together form a "bit address". This
|
||||
-- copies the source bit field to the destination. Size is the size in
|
||||
-- bits of the bit field. The bit fields can be arbitrarily large, but
|
||||
-- the starting offsets must be within the first byte that the Addresses
|
||||
-- point to. The Address values need not be aligned.
|
||||
--
|
||||
-- For example, a slice assignment of a packed bit field:
|
||||
--
|
||||
-- D (D_First .. D_Last) := S (S_First .. S_Last);
|
||||
--
|
||||
-- can be implemented using:
|
||||
--
|
||||
-- Copy_Bitfield
|
||||
-- (S (S_First)'Address, S (S_First)'Bit,
|
||||
-- D (D_First)'Address, D (D_First)'Bit,
|
||||
-- Size);
|
||||
|
||||
end G;
|
||||
|
||||
end System.Bitfield_Utils;
|
||||
|
|
@ -220,6 +220,7 @@ package Rtsfind is
|
|||
System_Atomic_Primitives,
|
||||
System_Aux_DEC,
|
||||
System_Bignums,
|
||||
System_Bitfields,
|
||||
System_Bit_Ops,
|
||||
System_Boolean_Array_Operations,
|
||||
System_Byte_Swapping,
|
||||
|
|
@ -809,6 +810,8 @@ package Rtsfind is
|
|||
RE_To_Bignum, -- System.Bignums
|
||||
RE_From_Bignum, -- System.Bignums
|
||||
|
||||
RE_Copy_Bitfield, -- System.Bitfields
|
||||
|
||||
RE_Bit_And, -- System.Bit_Ops
|
||||
RE_Bit_Eq, -- System.Bit_Ops
|
||||
RE_Bit_Not, -- System.Bit_Ops
|
||||
|
|
@ -2051,6 +2054,8 @@ package Rtsfind is
|
|||
RE_To_Bignum => System_Bignums,
|
||||
RE_From_Bignum => System_Bignums,
|
||||
|
||||
RE_Copy_Bitfield => System_Bitfields,
|
||||
|
||||
RE_Bit_And => System_Bit_Ops,
|
||||
RE_Bit_Eq => System_Bit_Ops,
|
||||
RE_Bit_Not => System_Bit_Ops,
|
||||
|
|
|
|||
Loading…
Reference in New Issue