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-2020, 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
32with System.Atomic_Primitives; use System.Atomic_Primitives;
33with System.Atomic_Operations.Exchange;
34with Interfaces.C;
35
36package 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_1
76        (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
77        return Atomic_Type;
78      pragma Import (Intrinsic, Atomic_Fetch_Add_1, "__atomic_fetch_add_1");
79      function Atomic_Fetch_Add_2
80        (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
81        return Atomic_Type;
82      pragma Import (Intrinsic, Atomic_Fetch_Add_2, "__atomic_fetch_add_2");
83      function Atomic_Fetch_Add_4
84        (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
85        return Atomic_Type;
86      pragma Import (Intrinsic, Atomic_Fetch_Add_4, "__atomic_fetch_add_4");
87      function Atomic_Fetch_Add_8
88        (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
89        return Atomic_Type;
90      pragma Import (Intrinsic, Atomic_Fetch_Add_8, "__atomic_fetch_add_8");
91      pragma Warnings (On);
92
93   begin
94      --  Use the direct intrinsics when possible, and fallback to
95      --  compare-and-exchange otherwise.
96
97      if Atomic_Type'Base'Last = Atomic_Type'Last
98        and then Atomic_Type'Base'First = Atomic_Type'First
99        and then Atomic_Type'Last
100                  in 2 ** 7 - 1 | 2 ** 15 - 1 | 2 ** 31 - 1 | 2 ** 63 - 1
101      then
102         case Long_Long_Integer (Atomic_Type'Last) is
103            when 2 ** 7 - 1  =>
104               return Atomic_Fetch_Add_1 (Item'Address, Value);
105            when 2 ** 15 - 1 =>
106               return Atomic_Fetch_Add_2 (Item'Address, Value);
107            when 2 ** 31 - 1 =>
108               return Atomic_Fetch_Add_4 (Item'Address, Value);
109            when 2 ** 63 - 1 =>
110               return Atomic_Fetch_Add_8 (Item'Address, Value);
111            when others      =>
112               raise Program_Error;
113         end case;
114      else
115         declare
116            Old_Value : aliased Atomic_Type := Item;
117            New_Value : Atomic_Type := Old_Value + Value;
118         begin
119            --  Keep iterating until the exchange succeeds
120
121            while not Exchange.Atomic_Compare_And_Exchange
122                        (Item, Old_Value, New_Value)
123            loop
124               New_Value := Old_Value + Value;
125            end loop;
126
127            return Old_Value;
128         end;
129      end if;
130   end Atomic_Fetch_And_Add;
131
132   -------------------------------
133   -- Atomic_Fetch_And_Subtract --
134   -------------------------------
135
136   function Atomic_Fetch_And_Subtract
137     (Item  : aliased in out Atomic_Type;
138      Value : Atomic_Type) return Atomic_Type
139   is
140      pragma Warnings (Off);
141      function Atomic_Fetch_Sub_1
142        (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
143        return Atomic_Type;
144      pragma Import (Intrinsic, Atomic_Fetch_Sub_1, "__atomic_fetch_sub_1");
145      function Atomic_Fetch_Sub_2
146        (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
147        return Atomic_Type;
148      pragma Import (Intrinsic, Atomic_Fetch_Sub_2, "__atomic_fetch_sub_2");
149      function Atomic_Fetch_Sub_4
150        (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
151        return Atomic_Type;
152      pragma Import (Intrinsic, Atomic_Fetch_Sub_4, "__atomic_fetch_sub_4");
153      function Atomic_Fetch_Sub_8
154        (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst)
155        return Atomic_Type;
156      pragma Import (Intrinsic, Atomic_Fetch_Sub_8, "__atomic_fetch_sub_8");
157      pragma Warnings (On);
158
159   begin
160      --  Use the direct intrinsics when possible, and fallback to
161      --  compare-and-exchange otherwise.
162
163      if Atomic_Type'Base'Last = Atomic_Type'Last
164        and then Atomic_Type'Base'First = Atomic_Type'First
165        and then Atomic_Type'Last
166                  in 2 ** 7 - 1 | 2 ** 15 - 1 | 2 ** 31 - 1 | 2 ** 63 - 1
167      then
168         case Long_Long_Integer (Atomic_Type'Last) is
169            when 2 ** 7 - 1  =>
170               return Atomic_Fetch_Sub_1 (Item'Address, Value);
171            when 2 ** 15 - 1 =>
172               return Atomic_Fetch_Sub_2 (Item'Address, Value);
173            when 2 ** 31 - 1 =>
174               return Atomic_Fetch_Sub_4 (Item'Address, Value);
175            when 2 ** 63 - 1 =>
176               return Atomic_Fetch_Sub_8 (Item'Address, Value);
177            when others      =>
178               raise Program_Error;
179         end case;
180      else
181         declare
182            Old_Value : aliased Atomic_Type := Item;
183            New_Value : Atomic_Type := Old_Value - Value;
184         begin
185            --  Keep iterating until the exchange succeeds
186
187            while not Exchange.Atomic_Compare_And_Exchange
188                        (Item, Old_Value, New_Value)
189            loop
190               New_Value := Old_Value - Value;
191            end loop;
192
193            return Old_Value;
194         end;
195      end if;
196   end Atomic_Fetch_And_Subtract;
197
198   ------------------
199   -- Is_Lock_Free --
200   ------------------
201
202   function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean is
203      pragma Unreferenced (Item);
204      use type Interfaces.C.size_t;
205   begin
206      return Boolean (Atomic_Always_Lock_Free (Atomic_Type'Object_Size / 8));
207   end Is_Lock_Free;
208
209end System.Atomic_Operations.Integer_Arithmetic;
210