gcc/ada/libgnat/s-aoinar.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --               System.Atomic_Operations.Integer_Arithmetic                --
   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.Atomic_Primitives; use System.Atomic_Primitives;
  33 with System.Atomic_Operations.Exchange;
  34 with Interfaces.C;
  35
  36 package body System.Atomic_Operations.Integer_Arithmetic is
  37
  38    package Exchange is new System.Atomic_Operations.Exchange (Atomic_Type);
  39
  40    ----------------
  41    -- Atomic_Add --
  42    ----------------
  43
  44    procedure Atomic_Add
  45      (Item  : aliased in out Atomic_Type;
  46       Value : Atomic_Type)
  47    is
  48       Ignore : constant Atomic_Type := Atomic_Fetch_And_Add (Item, Value);
  49    begin
  50       null;
  51    end Atomic_Add;
  52
  53    ---------------------
  54    -- Atomic_Subtract --
  55    ---------------------
  56
  57    procedure Atomic_Subtract
  58      (Item  : aliased in out Atomic_Type;
  59       Value : Atomic_Type)
  60    is
  61       Ignore : constant Atomic_Type := Atomic_Fetch_And_Subtract (Item, Value);
  62    begin
  63       null;
  64    end Atomic_Subtract;
  65
  66    --------------------------
  67    -- Atomic_Fetch_And_Add --
  68    --------------------------
  69
  70    function Atomic_Fetch_And_Add
  71      (Item  : aliased in out Atomic_Type;
  72       Value : Atomic_Type) return Atomic_Type
  73    is
  74       pragma Warnings (Off);
  75       function Atomic_Fetch_Add
  76         (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
  77         return Atomic_Type;
  78       pragma Import (Intrinsic, Atomic_Fetch_Add, "__atomic_fetch_add");
  79       pragma Warnings (On);
  80
  81    begin
  82       --  Use the direct intrinsics when possible, and fallback to
  83       --  compare-and-exchange otherwise.
  84
  85       if Atomic_Type'Base'Last = Atomic_Type'Last
  86         and then Atomic_Type'Base'First = Atomic_Type'First
  87         and then Atomic_Type'Last = 2**(Atomic_Type'Object_Size - 1) - 1
  88       then
  89          if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then
  90             return Atomic_Fetch_Add (Item'Address, Value);
  91          else
  92             raise Program_Error;
  93          end if;
  94
  95       else
  96          declare
  97             Old_Value : aliased Atomic_Type := Item;
  98             New_Value : Atomic_Type := Old_Value + Value;
  99          begin
 100             --  Keep iterating until the exchange succeeds
 101
 102             while not Exchange.Atomic_Compare_And_Exchange
 103                         (Item, Old_Value, New_Value)
 104             loop
 105                New_Value := Old_Value + Value;
 106             end loop;
 107
 108             return Old_Value;
 109          end;
 110       end if;
 111    end Atomic_Fetch_And_Add;
 112
 113    -------------------------------
 114    -- Atomic_Fetch_And_Subtract --
 115    -------------------------------
 116
 117    function Atomic_Fetch_And_Subtract
 118      (Item  : aliased in out Atomic_Type;
 119       Value : Atomic_Type) return Atomic_Type
 120    is
 121       pragma Warnings (Off);
 122       function Atomic_Fetch_Sub
 123         (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
 124         return Atomic_Type;
 125       pragma Import (Intrinsic, Atomic_Fetch_Sub, "__atomic_fetch_sub");
 126       pragma Warnings (On);
 127
 128    begin
 129       --  Use the direct intrinsics when possible, and fallback to
 130       --  compare-and-exchange otherwise.
 131
 132       if Atomic_Type'Base'Last = Atomic_Type'Last
 133         and then Atomic_Type'Base'First = Atomic_Type'First
 134         and then Atomic_Type'Last = 2**(Atomic_Type'Object_Size - 1) - 1
 135       then
 136          if Atomic_Type'Object_Size in 8 | 16 | 32 | 64 then
 137             return Atomic_Fetch_Sub (Item'Address, Value);
 138          else
 139             raise Program_Error;
 140          end if;
 141
 142       else
 143          declare
 144             Old_Value : aliased Atomic_Type := Item;
 145             New_Value : Atomic_Type := Old_Value - Value;
 146          begin
 147             --  Keep iterating until the exchange succeeds
 148
 149             while not Exchange.Atomic_Compare_And_Exchange
 150                         (Item, Old_Value, New_Value)
 151             loop
 152                New_Value := Old_Value - Value;
 153             end loop;
 154
 155             return Old_Value;
 156          end;
 157       end if;
 158    end Atomic_Fetch_And_Subtract;
 159
 160    ------------------
 161    -- Is_Lock_Free --
 162    ------------------
 163
 164    function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean is
 165       pragma Unreferenced (Item);
 166       use type Interfaces.C.size_t;
 167    begin
 168       return Atomic_Always_Lock_Free (Atomic_Type'Object_Size / 8);
 169    end Is_Lock_Free;
 170
 171 end System.Atomic_Operations.Integer_Arithmetic;