path: root/gcc/ada/libgnat/s-bituti.adb

------------------------------------------------------------------------------
--                                                                          --
--                         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-2023, 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.Storage_Elements; use System.Storage_Elements;

package body System.Bitfield_Utils is

   package body G is

      Val_Bytes : constant Storage_Count := Val'Size / Storage_Unit;

      --  A Val_2 can cross a memory page boundary (e.g. an 8-byte Val_2 that
      --  starts 4 bytes before the end of a page). If the bit field also
      --  crosses that boundary, then the second page is known to exist, and we
      --  can safely load or store the Val_2. On the other hand, if the bit
      --  field is entirely within the first half of the Val_2, then it is
      --  possible (albeit highly unlikely) that the second page does not
      --  exist, so we must load or store only the first half of the Val_2.
      --  Get_Val_2 and Set_Val_2 take care of all this.

      function Get_Val_2
        (Src_Address : Address;
         Src_Offset : Bit_Offset;
         Size : Small_Size)
        return Val_2;
      --  Get the Val_2, taking care to only load the first half when
      --  necessary.

      procedure Set_Val_2
        (Dest_Address : Address;
         Dest_Offset : Bit_Offset;
         V : Val_2;
         Size : Small_Size);
      --  Set the Val_2, taking care to only store the first half when
      --  necessary.

      --  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 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.

      function Set_Bitfield
        (Src_Value : Val;
         Dest : Val_2;
         Dest_Offset : Bit_Offset;
         Size : Small_Size)
        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.

      procedure Set_Bitfield
        (Src_Value : Val;
         Dest_Address : Address;
         Dest_Offset : Bit_Offset;
         Size : Small_Size);
      --  This version takes the bit address and size of the destination.

      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).

      function Get_Val_2
        (Src_Address : Address;
         Src_Offset : Bit_Offset;
         Size : Small_Size)
        return Val_2 is
      begin
         pragma Assert (Src_Address mod Storage_Count'(Val'Alignment) = 0);

         --  Bit field fits in first half; fetch just one Val. On little
         --  endian, we want that in the low half, but on big endian, we
         --  want it in the high half.

         if Src_Offset + Size <= Val'Size then
            declare
               Result : aliased constant Val with
                 Import, Address => Src_Address;
            begin
               return (case Endian is
                  when Little => Val_2 (Result),
                  when Big => Shift_Left (Val_2 (Result), Val'Size));
            end;

         --  Bit field crosses into the second half, so it's safe to fetch the
         --  whole Val_2.

         else
            declare
               Result : aliased constant Val_2 with
                 Import, Address => Src_Address;
            begin
               return Result;
            end;
         end if;
      end Get_Val_2;

      procedure Set_Val_2
        (Dest_Address : Address;
         Dest_Offset : Bit_Offset;
         V : Val_2;
         Size : Small_Size) is
      begin
         pragma Assert (Dest_Address mod Storage_Count'(Val'Alignment) = 0);

         --  Comments in Get_Val_2 apply, except we're storing instead of
         --  fetching.

         if Dest_Offset + Size <= Val'Size then
            declare
               Dest : aliased Val with Import, Address => Dest_Address;
            begin
               Dest := (case Endian is
                  when Little => Val'Mod (V),
                  when Big => Val (Shift_Right (V, Val'Size)));
            end;
         else
            declare
               Dest : aliased Val_2 with Import, Address => Dest_Address;
            begin
               Dest := V;
            end;
         end if;
      end Set_Val_2;

      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 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 Set_Bitfield
        (Src_Value : Val;
         Dest_Address : Address;
         Dest_Offset : Bit_Offset;
         Size : Small_Size)
      is
         Old_Dest : constant Val_2 :=
           Get_Val_2 (Dest_Address, Dest_Offset, Size);
         New_Dest : constant Val_2 :=
           Set_Bitfield (Src_Value, Old_Dest, Dest_Offset, Size);
      begin
         Set_Val_2 (Dest_Address, Dest_Offset, New_Dest, Size);
      end Set_Bitfield;

      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 := Get_Val_2 (Src_Address, Src_Offset, Size);
         V : constant Val := Get_Bitfield (Src, Src_Offset, Size);
      begin
         Set_Bitfield (V, Dest_Address, 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_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 :=
                 Get_Val_2 (S_Addr, S_Off, Initial_Size);
               Initial_Val : constant Val :=
                 Get_Bitfield (Initial_Val_2, S_Off, Initial_Size);

            begin
               Set_Bitfield
                 (Initial_Val, D_Addr, 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 :=
                    Get_Val_2 (S_Addr, S_Off, Val'Size);
                  Full_V : constant Val :=
                    Get_Bitfield (Src_V_2, S_Off, Val'Size);
               begin
                  Dest_Comp := Full_V;
                  S_Addr := S_Addr + Val_Bytes;
                  --  S_Off remains the same
               end;
            end loop;

            Sz := Sz mod Val'Size;
            if Sz /= 0 then
               --  Step 3:

               declare
                  Final_Val_2 : constant Val_2 :=
                    Get_Val_2 (S_Addr, S_Off, Sz);
                  Final_Val : constant Val :=
                    Get_Bitfield (Final_Val_2, S_Off, Sz);
               begin
                  Set_Bitfield
                    (Final_Val, D_Addr + Dest_Arr'Length * Val_Bytes, 0, Sz);
               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 Storage_Offset := 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 Storage_Offset :=
           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 Storage_Count'(Val'Alignment) = 0);
         pragma Assert (Al_Dest_Address mod Storage_Count'(Val'Alignment) = 0);
      begin
         --  Optimized small case

         if Size in Small_Size then
            Copy_Small_Bitfield
              (Al_Src_Address, Al_Src_Offset,
               Al_Dest_Address, Al_Dest_Offset,
               Size);

         --  Do nothing for zero size. This is necessary to avoid doing invalid
         --  reads, which are detected by valgrind.

         elsif Size = 0 then
            null;

         --  Large case

         else
            Copy_Large_Bitfield
              (Al_Src_Address, Al_Src_Offset,
               Al_Dest_Address, Al_Dest_Offset,
               Size);
         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;