Version 1.1 of acs/ac-00321.txt

Unformatted version of acs/ac-00321.txt version 1.1
Other versions for file acs/ac-00321.txt

!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
!summary Prototypes of System.Atomic_Operations
!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

***************************************************************

Questions? Ask the ACAA Technical Agent