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