!standard C.6.1 20-01-14 AC95-00321/00 !standard C.6.2 !standard C.6.3 !standard C.6.4 !class Amendment 20-01-14 !status received no action 20-01-14 !status received 19-11-09 !subject Prototypes of System.Atomic_Operations !summary !appendix From: Tucker Taft Sent: Saturday, November 9, 2019 5:26 PM Attached are prototype versions of the Ada 202X System.Atomic_Operations packages. Note that to avoid any difficulties with compiling children of System, these are currently called System_Atomic_Operations.*. These make use of "generic" versions of __atomic_exchange and __atomic_compare_exchange that work on various sizes of atomic objects, which come from the GCC libraries. At least on some systems you will need "-latomic" at link time to pull in these routines. The "atomic_ops.gpr" file provided does that. test_atomic.adb is a very simple test program. Any comments or other test results on these would be appreciated. ---- ------------------------------------------------------------------------------ -- A T O M I C O P E R A T I O N S -- -- -- -- Copyright (C) 2012-2019, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ package System_Atomic_Operations with Pure is private -- Unsigned C types type uint is mod 2 ** Long_Integer'Size; type uint8 is mod 2**8 with Size => 8; type uint16 is mod 2**16 with Size => 16; type uint32 is mod 2**32 with Size => 32; type uint64 is mod 2**64 with Size => 64; -- Memory models from C11 Relaxed : constant := 0; Consume : constant := 1; Acquire : constant := 2; Release : constant := 3; Acq_Rel : constant := 4; Seq_Cst : constant := 5; Last : constant := 6; subtype Mem_Model is Integer range Relaxed .. Last; end System_Atomic_Operations; --------------- ------------------------------------------------------------------------------ -- A T O M I C O P E R A T I O N S -- -- -- -- Copyright (C) 2012-2019, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ generic type Atomic_Type is range <>; -- TBD: with Atomic; package System_Atomic_Operations.Arithmetic with Pure is procedure Atomic_Add (Item : aliased in out Atomic_Type; Value : Atomic_Type) with Convention => Intrinsic; procedure Atomic_Subtract (Item : aliased in out Atomic_Type; Value : Atomic_Type) with Convention => Intrinsic; function Atomic_Fetch_And_Add (Item : aliased in out Atomic_Type; Value : Atomic_Type) return Atomic_Type with Convention => Intrinsic; function Atomic_Fetch_And_Subtract (Item : aliased in out Atomic_Type; Value : Atomic_Type) return Atomic_Type with Convention => Intrinsic; function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean with Convention => Intrinsic; end System_Atomic_Operations.Arithmetic; --------------- ------------------------------------------------------------------------------ -- A T O M I C O P E R A T I O N S -- -- -- -- Copyright (C) 2012-2019, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ with System_Atomic_Operations.Exchange; pragma Elaborate (System_Atomic_Operations.Exchange); package body System_Atomic_Operations.Arithmetic is package Exchange is new System_Atomic_Operations.Exchange (Atomic_Type); procedure Atomic_Add (Item : aliased in out Atomic_Type; Value : Atomic_Type) is Ignore : constant Atomic_Type := Atomic_Fetch_And_Add (Item, Value); begin return; end Atomic_Add; procedure Atomic_Subtract (Item : aliased in out Atomic_Type; Value : Atomic_Type) is Ignore : constant Atomic_Type := Atomic_Fetch_And_Subtract (Item, Value); begin return; end Atomic_Subtract; function Atomic_Fetch_And_Add (Item : aliased in out Atomic_Type; Value : Atomic_Type) return Atomic_Type is Old_Value : aliased Atomic_Type := Item; New_Value : Atomic_Type := Old_Value + Value; use Exchange; begin -- Keep iterating until the exchange succeeds while not Atomic_Compare_And_Exchange (Item, Old_Value, New_Value) loop New_Value := Old_Value + Value; end loop; return Old_Value; end Atomic_Fetch_And_Add; function Atomic_Fetch_And_Subtract (Item : aliased in out Atomic_Type; Value : Atomic_Type) return Atomic_Type is Old_Value : aliased Atomic_Type := Item; New_Value : Atomic_Type := Old_Value - Value; use Exchange; begin -- Keep iterating until the exchange succeeds while not Atomic_Compare_And_Exchange (Item, Old_Value, New_Value) loop New_Value := Old_Value - Value; end loop; return Old_Value; end Atomic_Fetch_And_Subtract; function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean is begin return True; -- TBD end Is_Lock_Free; end System_Atomic_Operations.Arithmetic; ---------------------- ------------------------------------------------------------------------------ -- A T O M I C O P E R A T I O N S -- -- -- -- Copyright (C) 2012-2019, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ generic type Atomic_Type is private; -- TBD: with Atomic; package System_Atomic_Operations.Exchange with Pure is function Atomic_Exchange (Item : aliased in out Atomic_Type; Value : Atomic_Type) return Atomic_Type with Convention => Intrinsic; function Atomic_Compare_And_Exchange (Item : aliased in out Atomic_Type; Prior : aliased in out Atomic_Type; Desired : Atomic_Type) return Boolean with Convention => Intrinsic; function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean with Convention => Intrinsic; end System_Atomic_Operations.Exchange; ------------------------ ------------------------------------------------------------------------------ -- A T O M I C O P E R A T I O N S -- -- -- -- Copyright (C) 2012-2019, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ with System; with Interfaces.C; use Interfaces; package body System_Atomic_Operations.Exchange is use type C.size_t; procedure C_Atomic_Exchange (Size : C.Size_T; M_Ptr : System.Address; V_Ptr : System.Address; R_Ptr : System.Address; S_Model : Mem_Model); pragma Import (C, C_Atomic_Exchange, "__atomic_exchange"); -- "Generic" version of atomic exchange. -- TBD: Call size-specific versions by using a "case" statement. function Atomic_Exchange (Item : aliased in out Atomic_Type; Value : Atomic_Type) return Atomic_Type is Value_Copy : aliased Atomic_Type := Value; Result : aliased Atomic_Type; begin C_Atomic_Exchange (Atomic_Type'Size / System.Storage_Unit, M_Ptr => Item'Address, V_Ptr => Value_Copy'Address, R_Ptr => Result'Address, S_Model => Seq_Cst); return Result; end Atomic_Exchange; function C_Atomic_Compare_Exchange (Size : C.Size_T; M_Ptr : System.Address; E_Ptr : System.Address; D_Ptr : System.Address; S_Model : Mem_Model; F_Model : Mem_Model) return C.unsigned_char; pragma Import (C, C_Atomic_Compare_Exchange, "__atomic_compare_exchange"); -- "Generic" version of atomic exchange. -- TBD: Call size-specific versions by using a "case" statement. -- TBD2: Should add a "bool" to Interfaces.C since C99 supports it. function Atomic_Compare_And_Exchange (Item : aliased in out Atomic_Type; Prior : aliased in out Atomic_Type; Desired : Atomic_Type) return Boolean is Desired_Copy : aliased Atomic_Type := Desired; Result : C.unsigned_char; use type C.unsigned_char; begin Result := C_Atomic_Compare_Exchange (Size => Atomic_Type'Size / System.Storage_Unit, M_Ptr => Item'Address, E_Ptr => Prior'Address, D_Ptr => Desired_Copy'Address, S_Model => Seq_Cst, F_Model => Seq_Cst); return Result /= 0; end Atomic_Compare_And_Exchange; function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean is begin return True; -- TBD end Is_Lock_Free; end System_Atomic_Operations.Exchange; -------------------- ------------------------------------------------------------------------------ -- A T O M I C O P E R A T I O N S -- -- -- -- Copyright (C) 2012-2019, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ package System_Atomic_Operations.Test_And_Set with Pure is type Test_And_Set_Flag is private; function Atomic_Test_And_Set (Item : aliased in out Test_And_Set_Flag) return Boolean with Convention => Intrinsic; procedure Atomic_Clear (Item : aliased in out Test_And_Set_Flag) with Convention => Intrinsic; function Is_Lock_Free (Item : aliased Test_And_Set_Flag) return Boolean with Convention => Intrinsic; private type Test_And_Set_Type is mod 2**Integer'Size; type Test_And_Set_Flag is record Flag : aliased Test_And_Set_Type := 0 with Atomic; end record; for Test_And_Set_Flag'Size use Integer'Size; end System_Atomic_Operations.Test_And_Set; -------------------- ------------------------------------------------------------------------------ -- A T O M I C O P E R A T I O N S -- -- -- -- Copyright (C) 2012-2019, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ with System_Atomic_Operations.Exchange; pragma Elaborate (System_Atomic_Operations.Exchange); package body System_Atomic_Operations.Test_And_Set is package Exchange is new System_Atomic_Operations.Exchange (Test_And_Set_Type); function Atomic_Test_And_Set (Item : aliased in out Test_And_Set_Flag) return Boolean is begin -- Implement using atomic exchange -- TBD: Could use the C primitive test-and-set instead. return Exchange.Atomic_Exchange (Item.Flag, 1) /= 0; end Atomic_Test_And_Set; procedure Atomic_Clear (Item : aliased in out Test_And_Set_Flag) is begin Item.Flag := 0; end Atomic_Clear; function Is_Lock_Free (Item : aliased Test_And_Set_Flag) return Boolean is begin return True; -- TBD end Is_Lock_Free; end System_Atomic_Operations.Test_And_Set; ------------------ project Atomic_Ops is for Object_Dir use "obj"; for Exec_Dir use "bin"; for Source_Dirs use (".", ".."); for Main use ("test_atomic"); package Builder is for Default_Switches ("ada") use ("-s", "-g", "-k"); end Builder; package Compiler is for Default_Switches ("ada") use ("-gnatE", "-fstack-check", "-g", "-gnata", "-gnatU", "-gnat2012"); end Compiler; package Linker is for Default_Switches ("ada") use ("-g", "-lgcc_eh", "-latomic"); end Linker; end Atomic_Ops; ---------------------- ------------------------------------------------------------------------------ -- L W T Scheduler -- -- -- -- not really ... -- -- Copyright (C) 2012-2019, AdaCore -- -- -- -- This 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. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ with System_Atomic_Operations.Arithmetic; with System_Atomic_Operations.Test_And_Set; with System_Atomic_Operations.Exchange; with Ada.Text_IO; use Ada.Text_IO; procedure Test_Atomic is type Atomic_Long is new Long_Integer with Atomic; package Exchange is new System_Atomic_Operations.Exchange (Atomic_Long); package Arith is new System_Atomic_Operations.Arithmetic (Atomic_Long); package Test_And_Set renames System_Atomic_Operations.Test_And_Set; X, Y : aliased Atomic_Long; T : aliased Test_And_Set.Test_And_Set_Flag; Prior_Zero : aliased Atomic_Long := 0; begin Put_Line ("Testing Test_And_Set"); Put_Line ("Clear"); Test_And_Set.Atomic_Clear (T); Put_Line ("Test-and-set #1 returns " & Test_And_Set.Atomic_Test_And_Set (T)'Image); Put_Line ("Test-and-set #2 returns " & Test_And_Set.Atomic_Test_And_Set (T)'Image); Put_Line ("Testing fetch-and-add"); X := 0; Put_Line ("X = " & X'Image); Put_Line ("Fetch-and-add (X, 2) = " & Arith.Atomic_Fetch_And_Add (X, 2)'Image); Put_Line ("X = " & X'Image); Put_Line ("Fetch-and-add (X, -3) = " & Arith.Atomic_Fetch_And_Add (X, -3)'Image); Put_Line ("X = " & X'Image); Put_Line ("Testing compare-and-exchange"); Y := 0; Put_Line ("Y = " & Y'Image); Put_Line ("Compare-and-Swap (Y, Prior => 0, Desired => 3) = " & Exchange.Atomic_Compare_And_Exchange (Y, Prior_Zero, Desired => 3)'Image); Put_Line ("Y = " & Y'Image); Put_Line ("Prior_Zero = " & Prior_Zero'Image); Put_Line ("Compare-and-Swap (Y, Prior => 0, Desired => 5) = " & Exchange.Atomic_Compare_And_Exchange (Y, Prior_Zero, Desired => 5)'Image); Put_Line ("Y = " & Y'Image); Put_Line ("Prior_Zero = " & Prior_Zero'Image); end Test_Atomic; *************************************************************** From: Pascal Pignard Sent: Monday, November 11, 2019 2:39 PM Here are execution results with GNAT Community 2019 on macOS 10.13: ./bin/test_atomic Testing Test_And_Set Clear Test-and-set #1 returns FALSE Test-and-set #2 returns TRUE Testing fetch-and-add X = 0 Fetch-and-add (X, 2) = 0 X = 2 Fetch-and-add (X, -3) = 2 X = -1 Testing compare-and-exchange Y = 0 Compare-and-Swap (Y, Prior => 0, Desired => 3) = TRUE Y = 3 Prior_Zero = 0 Compare-and-Swap (Y, Prior => 0, Desired => 5) = FALSE Y = 3 Prior_Zero = 3 *************************************************************** From: Tucker Taft Sent: Monday, November 11, 2019 3:20 PM Great, thanks. Those are the expected results! *************************************************************** From: Tucker Taft Sent: Saturday, November 9, 2019 5:26 PM ***************************************************************