gcc/ada/libgnat/s-bituti.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 S Y S T E M . B I T F I E L D _ U T I L S                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --               Copyright (C) 2019-2024, Free Software Foundation, Inc.    --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.Storage_Elements; use System.Storage_Elements;
  33
  34 package body System.Bitfield_Utils is
  35
  36    package body G is
  37
  38       Val_Bytes : constant Storage_Count := Val'Size / Storage_Unit;
  39
  40       --  A Val_2 can cross a memory page boundary (e.g. an 8-byte Val_2 that
  41       --  starts 4 bytes before the end of a page). If the bit field also
  42       --  crosses that boundary, then the second page is known to exist, and we
  43       --  can safely load or store the Val_2. On the other hand, if the bit
  44       --  field is entirely within the first half of the Val_2, then it is
  45       --  possible (albeit highly unlikely) that the second page does not
  46       --  exist, so we must load or store only the first half of the Val_2.
  47       --  Get_Val_2 and Set_Val_2 take care of all this.
  48
  49       function Get_Val_2
  50         (Src_Address : Address;
  51          Src_Offset : Bit_Offset;
  52          Size : Small_Size)
  53         return Val_2;
  54       --  Get the Val_2, taking care to only load the first half when
  55       --  necessary.
  56
  57       procedure Set_Val_2
  58         (Dest_Address : Address;
  59          Dest_Offset : Bit_Offset;
  60          V : Val_2;
  61          Size : Small_Size);
  62       --  Set the Val_2, taking care to only store the first half when
  63       --  necessary.
  64
  65       --  Get_Bitfield and Set_Bitfield are helper functions that get/set small
  66       --  bit fields -- the value fits in Val, and the bit field is placed
  67       --  starting at some offset within the first half of a Val_2.
  68       --  Copy_Bitfield, on the other hand, supports arbitrarily large bit
  69       --  fields. All operations require bit offsets to point within the first
  70       --  Val pointed to by the address.
  71
  72       function Get_Bitfield
  73         (Src : Val_2; Src_Offset : Bit_Offset; Size : Small_Size)
  74          return Val with Inline;
  75       --  Returns the bit field in Src starting at Src_Offset, of the given
  76       --  Size. If Size < Small_Size'Last, then high order bits are zero.
  77
  78       function Set_Bitfield
  79         (Src_Value : Val;
  80          Dest : Val_2;
  81          Dest_Offset : Bit_Offset;
  82          Size : Small_Size)
  83         return Val_2 with Inline;
  84       --  The bit field in Dest starting at Dest_Offset, of the given Size, is
  85       --  set to Src_Value. Src_Value must have high order bits (Size and
  86       --  above) zero. The result is returned as the function result.
  87
  88       procedure Set_Bitfield
  89         (Src_Value : Val;
  90          Dest_Address : Address;
  91          Dest_Offset : Bit_Offset;
  92          Size : Small_Size);
  93       --  This version takes the bit address and size of the destination.
  94
  95       procedure Copy_Small_Bitfield
  96         (Src_Address  : Address;
  97          Src_Offset   : Bit_Offset;
  98          Dest_Address : Address;
  99          Dest_Offset  : Bit_Offset;
 100          Size         : Small_Size);
 101       --  Copy_Bitfield in the case where Size <= Val'Size.
 102       --  The Address values must be aligned as for Val and Val_2.
 103       --  This works for overlapping bit fields.
 104
 105       procedure Copy_Large_Bitfield
 106         (Src_Address  : Address;
 107          Src_Offset   : Bit_Offset;
 108          Dest_Address : Address;
 109          Dest_Offset  : Bit_Offset;
 110          Size         : Bit_Size);
 111       --  Copy_Bitfield in the case where Size > Val'Size.
 112       --  The Address values must be aligned as for Val and Val_2.
 113       --  This works for overlapping bit fields only if the source
 114       --  bit address is greater than or equal to the destination
 115       --  bit address, because it copies forward (from lower to higher
 116       --  bit addresses).
 117
 118       function Get_Val_2
 119         (Src_Address : Address;
 120          Src_Offset : Bit_Offset;
 121          Size : Small_Size)
 122         return Val_2 is
 123       begin
 124          pragma Assert (Src_Address mod Storage_Count'(Val'Alignment) = 0);
 125
 126          --  Bit field fits in first half; fetch just one Val. On little
 127          --  endian, we want that in the low half, but on big endian, we
 128          --  want it in the high half.
 129
 130          if Src_Offset + Size <= Val'Size then
 131             declare
 132                Result : aliased constant Val with
 133                  Import, Address => Src_Address;
 134             begin
 135                return (case Endian is
 136                   when Little => Val_2 (Result),
 137                   when Big => Shift_Left (Val_2 (Result), Val'Size));
 138             end;
 139
 140          --  Bit field crosses into the second half, so it's safe to fetch the
 141          --  whole Val_2.
 142
 143          else
 144             declare
 145                Result : aliased constant Val_2 with
 146                  Import, Address => Src_Address;
 147             begin
 148                return Result;
 149             end;
 150          end if;
 151       end Get_Val_2;
 152
 153       procedure Set_Val_2
 154         (Dest_Address : Address;
 155          Dest_Offset : Bit_Offset;
 156          V : Val_2;
 157          Size : Small_Size) is
 158       begin
 159          pragma Assert (Dest_Address mod Storage_Count'(Val'Alignment) = 0);
 160
 161          --  Comments in Get_Val_2 apply, except we're storing instead of
 162          --  fetching.
 163
 164          if Dest_Offset + Size <= Val'Size then
 165             declare
 166                Dest : aliased Val with Import, Address => Dest_Address;
 167             begin
 168                Dest := (case Endian is
 169                   when Little => Val'Mod (V),
 170                   when Big => Val (Shift_Right (V, Val'Size)));
 171             end;
 172          else
 173             declare
 174                Dest : aliased Val_2 with Import, Address => Dest_Address;
 175             begin
 176                Dest := V;
 177             end;
 178          end if;
 179       end Set_Val_2;
 180
 181       function Get_Bitfield
 182         (Src : Val_2; Src_Offset : Bit_Offset; Size : Small_Size)
 183          return Val
 184       is
 185          L_Shift_Amount : constant Natural :=
 186            (case Endian is
 187               when Little => Val_2'Size - (Src_Offset + Size),
 188               when Big => Src_Offset);
 189          Temp1 : constant Val_2 :=
 190            Shift_Left (Src, L_Shift_Amount);
 191          Temp2 : constant Val_2 :=
 192            Shift_Right (Temp1, Val_2'Size - Size);
 193       begin
 194          return Val (Temp2);
 195       end Get_Bitfield;
 196
 197       function Set_Bitfield
 198         (Src_Value : Val;
 199          Dest : Val_2;
 200          Dest_Offset : Bit_Offset;
 201          Size : Small_Size)
 202         return Val_2
 203       is
 204          pragma Assert (Size = Val'Size or else Src_Value < 2**Size);
 205          L_Shift_Amount : constant Natural :=
 206            (case Endian is
 207               when Little => Dest_Offset,
 208               when Big => Val_2'Size - (Dest_Offset + Size));
 209          Mask : constant Val_2 :=
 210            Shift_Left (Shift_Left (1, Size) - 1, L_Shift_Amount);
 211          Temp1 : constant Val_2 := Dest and not Mask;
 212          Temp2 : constant Val_2 :=
 213            Shift_Left (Val_2 (Src_Value), L_Shift_Amount);
 214          Result : constant Val_2 := Temp1 or Temp2;
 215       begin
 216          return Result;
 217       end Set_Bitfield;
 218
 219       procedure Set_Bitfield
 220         (Src_Value : Val;
 221          Dest_Address : Address;
 222          Dest_Offset : Bit_Offset;
 223          Size : Small_Size)
 224       is
 225          Old_Dest : constant Val_2 :=
 226            Get_Val_2 (Dest_Address, Dest_Offset, Size);
 227          New_Dest : constant Val_2 :=
 228            Set_Bitfield (Src_Value, Old_Dest, Dest_Offset, Size);
 229       begin
 230          Set_Val_2 (Dest_Address, Dest_Offset, New_Dest, Size);
 231       end Set_Bitfield;
 232
 233       procedure Copy_Small_Bitfield
 234         (Src_Address  : Address;
 235          Src_Offset   : Bit_Offset;
 236          Dest_Address : Address;
 237          Dest_Offset  : Bit_Offset;
 238          Size         : Small_Size)
 239       is
 240          Src : constant Val_2 := Get_Val_2 (Src_Address, Src_Offset, Size);
 241          V : constant Val := Get_Bitfield (Src, Src_Offset, Size);
 242       begin
 243          Set_Bitfield (V, Dest_Address, Dest_Offset, Size);
 244       end Copy_Small_Bitfield;
 245
 246       --  Copy_Large_Bitfield does the main work. Copying aligned Vals is more
 247       --  efficient than fiddling with shifting and whatnot. But we can't align
 248       --  both source and destination. We choose to align the destination,
 249       --  because that's more efficient -- Set_Bitfield needs to read, then
 250       --  modify, then write, whereas Get_Bitfield does not.
 251       --
 252       --  So the method is:
 253       --
 254       --      Step 1:
 255       --      If the destination is not already aligned, copy Initial_Size
 256       --      bits, and increment the bit addresses. Initial_Size is chosen to
 257       --      be the smallest size that will cause the destination bit address
 258       --      to be aligned (i.e. have zero bit offset from the already-aligned
 259       --      Address). Get_Bitfield and Set_Bitfield are used here.
 260       --
 261       --      Step 2:
 262       --      Loop, copying Vals. Get_Bitfield is used to fetch a Val-sized
 263       --      bit field, but Set_Bitfield is not needed -- we can set the
 264       --      aligned Val with an array indexing.
 265       --
 266       --      Step 3:
 267       --      Copy remaining smaller-than-Val bits, if any
 268
 269       procedure Copy_Large_Bitfield
 270         (Src_Address  : Address;
 271          Src_Offset   : Bit_Offset;
 272          Dest_Address : Address;
 273          Dest_Offset  : Bit_Offset;
 274          Size         : Bit_Size)
 275       is
 276          Sz : Bit_Size := Size;
 277          S_Addr : Address := Src_Address;
 278          S_Off : Bit_Offset := Src_Offset;
 279          D_Addr : Address := Dest_Address;
 280          D_Off : Bit_Offset := Dest_Offset;
 281       begin
 282          if S_Addr < D_Addr or else (S_Addr = D_Addr and then S_Off < D_Off)
 283          then
 284             --  Here, the source bit address is less than the destination bit
 285             --  address. Assert that there is no overlap.
 286
 287             declare
 288                Temp_Off : constant Bit_Offset'Base := S_Off + Size;
 289                After_S_Addr : constant Address :=
 290                  S_Addr + Address (Temp_Off / Storage_Unit);
 291                After_S_Off : constant Bit_Offset_In_Byte :=
 292                  Temp_Off mod Storage_Unit;
 293                --  (After_S_Addr, After_S_Off) is the bit address of the bit
 294                --  just after the source bit field. Assert that it's less than
 295                --  or equal to the destination bit address.
 296                Overlap_OK : constant Boolean :=
 297                  After_S_Addr < D_Addr
 298                    or else
 299                  (After_S_Addr = D_Addr and then After_S_Off <= D_Off);
 300             begin
 301                pragma Assert (Overlap_OK);
 302             end;
 303          end if;
 304
 305          if D_Off /= 0 then
 306             --  Step 1:
 307
 308             declare
 309                Initial_Size : constant Small_Size := Val'Size - D_Off;
 310                Initial_Val_2 : constant Val_2 :=
 311                  Get_Val_2 (S_Addr, S_Off, Initial_Size);
 312                Initial_Val : constant Val :=
 313                  Get_Bitfield (Initial_Val_2, S_Off, Initial_Size);
 314
 315             begin
 316                Set_Bitfield
 317                  (Initial_Val, D_Addr, D_Off, Initial_Size);
 318
 319                Sz := Sz - Initial_Size;
 320                declare
 321                   New_S_Off : constant Bit_Offset'Base := S_Off + Initial_Size;
 322                begin
 323                   if New_S_Off > Bit_Offset'Last then
 324                      S_Addr := S_Addr + Val_Bytes;
 325                      S_Off := New_S_Off - Small_Size'Last;
 326                   else
 327                      S_Off := New_S_Off;
 328                   end if;
 329                end;
 330                D_Addr := D_Addr + Val_Bytes;
 331                pragma Assert (D_Off + Initial_Size = Val'Size);
 332                D_Off := 0;
 333             end;
 334          end if;
 335
 336          --  Step 2:
 337
 338          declare
 339             Dest_Arr : Val_Array (1 .. Sz / Val'Size) with Import,
 340               Address => D_Addr;
 341          begin
 342             for Dest_Comp of Dest_Arr loop
 343                declare
 344                   pragma Warnings (Off);
 345                   pragma Assert (Dest_Comp in Val);
 346                   pragma Warnings (On);
 347                   pragma Assert (Dest_Comp'Valid);
 348                   Src_V_2 : constant Val_2 :=
 349                     Get_Val_2 (S_Addr, S_Off, Val'Size);
 350                   Full_V : constant Val :=
 351                     Get_Bitfield (Src_V_2, S_Off, Val'Size);
 352                begin
 353                   Dest_Comp := Full_V;
 354                   S_Addr := S_Addr + Val_Bytes;
 355                   --  S_Off remains the same
 356                end;
 357             end loop;
 358
 359             Sz := Sz mod Val'Size;
 360             if Sz /= 0 then
 361                --  Step 3:
 362
 363                declare
 364                   Final_Val_2 : constant Val_2 :=
 365                     Get_Val_2 (S_Addr, S_Off, Sz);
 366                   Final_Val : constant Val :=
 367                     Get_Bitfield (Final_Val_2, S_Off, Sz);
 368                begin
 369                   Set_Bitfield
 370                     (Final_Val, D_Addr + Dest_Arr'Length * Val_Bytes, 0, Sz);
 371                end;
 372             end if;
 373          end;
 374       end Copy_Large_Bitfield;
 375
 376       procedure Copy_Bitfield
 377         (Src_Address  : Address;
 378          Src_Offset   : Bit_Offset_In_Byte;
 379          Dest_Address : Address;
 380          Dest_Offset  : Bit_Offset_In_Byte;
 381          Size         : Bit_Size)
 382       is
 383          --  Align the Address values as for Val and Val_2, and adjust the
 384          --  Bit_Offsets accordingly.
 385
 386          Src_Adjust     : constant Storage_Offset := Src_Address mod Val_Bytes;
 387          Al_Src_Address : constant Address := Src_Address - Src_Adjust;
 388          Al_Src_Offset  : constant Bit_Offset :=
 389            Src_Offset + Bit_Offset (Src_Adjust * Storage_Unit);
 390
 391          Dest_Adjust     : constant Storage_Offset :=
 392            Dest_Address mod Val_Bytes;
 393          Al_Dest_Address : constant Address := Dest_Address - Dest_Adjust;
 394          Al_Dest_Offset  : constant Bit_Offset :=
 395            Dest_Offset + Bit_Offset (Dest_Adjust * Storage_Unit);
 396
 397          pragma Assert (Al_Src_Address mod Storage_Count'(Val'Alignment) = 0);
 398          pragma Assert (Al_Dest_Address mod Storage_Count'(Val'Alignment) = 0);
 399       begin
 400          --  Optimized small case
 401
 402          if Size in Small_Size then
 403             Copy_Small_Bitfield
 404               (Al_Src_Address, Al_Src_Offset,
 405                Al_Dest_Address, Al_Dest_Offset,
 406                Size);
 407
 408          --  Do nothing for zero size. This is necessary to avoid doing invalid
 409          --  reads, which are detected by valgrind.
 410
 411          elsif Size = 0 then
 412             null;
 413
 414          --  Large case
 415
 416          else
 417             Copy_Large_Bitfield
 418               (Al_Src_Address, Al_Src_Offset,
 419                Al_Dest_Address, Al_Dest_Offset,
 420                Size);
 421          end if;
 422       end Copy_Bitfield;
 423
 424       function Fast_Copy_Bitfield
 425         (Src         : Val_2;
 426          Src_Offset  : Bit_Offset;
 427          Dest        : Val_2;
 428          Dest_Offset : Bit_Offset;
 429          Size        : Small_Size)
 430         return Val_2 is
 431          Result : constant Val_2 := Set_Bitfield
 432            (Get_Bitfield (Src, Src_Offset, Size), Dest, Dest_Offset, Size);
 433       begin
 434          --  No need to explicitly do nothing for zero size case, because Size
 435          --  cannot be zero.
 436
 437          return Result;
 438       end Fast_Copy_Bitfield;
 439
 440    end G;
 441
 442 end System.Bitfield_Utils;