From 73266be246a1bf1781b8ef6ee1395e8602681350 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 12 Mar 2020 09:46:55 -0400 Subject: [PATCH] [Ada] AI12-0364 Add a modular atomic arithmetic package 2020-06-10 Arnaud Charlet gcc/ada/ * libgnat/s-aomoar.ads, libgnat/s-aomoar.adb: New files. * libgnat/s-atopar.ads: Move... * libgnat/s-aoinar.ads: Here. * libgnat/s-atopar.adb: Move... * libgnat/s-aoinar.adb: Here. * impunit.adb: Update list of runtime files. * Makefile.rtl (GNATRTL_NONTASKING_OBJS=): Adjust. --- gcc/ada/Makefile.rtl | 3 +- gcc/ada/impunit.adb | 3 +- .../libgnat/{s-atopar.adb => s-aoinar.adb} | 6 +- .../libgnat/{s-atopar.ads => s-aoinar.ads} | 6 +- gcc/ada/libgnat/s-aomoar.adb | 215 ++++++++++++++++++ gcc/ada/libgnat/s-aomoar.ads | 69 ++++++ 6 files changed, 294 insertions(+), 8 deletions(-) rename gcc/ada/libgnat/{s-atopar.adb => s-aoinar.adb} (97%) rename gcc/ada/libgnat/{s-atopar.ads => s-aoinar.ads} (95%) create mode 100644 gcc/ada/libgnat/s-aomoar.adb create mode 100644 gcc/ada/libgnat/s-aomoar.ads diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index b09159e7e9a..15b8b00db57 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -505,13 +505,14 @@ GNATRTL_NONTASKING_OBJS= \ machcode$(objext) \ s-addima$(objext) \ s-addope$(objext) \ + s-aoinar$(objext) \ + s-aomoar$(objext) \ s-aotase$(objext) \ s-arit64$(objext) \ s-assert$(objext) \ s-atacco$(objext) \ s-atocou$(objext) \ s-atoope$(objext) \ - s-atopar$(objext) \ s-atopex$(objext) \ s-atopri$(objext) \ s-auxdec$(objext) \ diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 7561a198a36..70733563fb1 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -624,9 +624,10 @@ package body Impunit is ("a-nubinu", T), -- Ada.Numerics.Big_Numbers ("a-nbnbin", T), -- Ada.Numerics.Big_Numbers.Big_Integers ("a-nbnbre", T), -- Ada.Numerics.Big_Numbers.Big_Reals + ("s-aoinar", T), -- System.Atomic_Operations.Integer_Arithmetic + ("s-aomoar", T), -- System.Atomic_Operations.Modular_Arithmetic ("s-aotase", T), -- System.Atomic_Operations.Test_And_Set ("s-atoope", T), -- System.Atomic_Operations - ("s-atopar", T), -- System.Atomic_Operations.Arithmetic ("s-atopex", T), -- System.Atomic_Operations.Exchange ("a-stteou", T), -- Ada.Strings.Text_Output ("a-stouut", T), -- Ada.Strings.Text_Output.Utils diff --git a/gcc/ada/libgnat/s-atopar.adb b/gcc/ada/libgnat/s-aoinar.adb similarity index 97% rename from gcc/ada/libgnat/s-atopar.adb rename to gcc/ada/libgnat/s-aoinar.adb index 554561c3468..4cc6aa70314 100644 --- a/gcc/ada/libgnat/s-atopar.adb +++ b/gcc/ada/libgnat/s-aoinar.adb @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- System.Atomic_Operations.Arithmetic -- +-- System.Atomic_Operations.Integer_Arithmetic -- -- -- -- B o d y -- -- -- @@ -32,7 +32,7 @@ with System.Atomic_Primitives; use System.Atomic_Primitives; with Interfaces.C; -package body System.Atomic_Operations.Arithmetic is +package body System.Atomic_Operations.Integer_Arithmetic is ---------------- -- Atomic_Add -- @@ -145,4 +145,4 @@ package body System.Atomic_Operations.Arithmetic is return Boolean (Atomic_Always_Lock_Free (Atomic_Type'Object_Size / 8)); end Is_Lock_Free; -end System.Atomic_Operations.Arithmetic; +end System.Atomic_Operations.Integer_Arithmetic; diff --git a/gcc/ada/libgnat/s-atopar.ads b/gcc/ada/libgnat/s-aoinar.ads similarity index 95% rename from gcc/ada/libgnat/s-atopar.ads rename to gcc/ada/libgnat/s-aoinar.ads index 37bb2b17659..e76e7f116c5 100644 --- a/gcc/ada/libgnat/s-atopar.ads +++ b/gcc/ada/libgnat/s-aoinar.ads @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- System.Atomic_Operations.Arithmetic -- +-- System.Atomic_Operations.Integer_Arithmetic -- -- -- -- S p e c -- -- -- @@ -37,7 +37,7 @@ pragma Ada_2020; generic type Atomic_Type is range <> with Atomic; -package System.Atomic_Operations.Arithmetic +package System.Atomic_Operations.Integer_Arithmetic with Pure -- Nonblocking is @@ -66,4 +66,4 @@ private pragma Inline_Always (Atomic_Fetch_And_Add); pragma Inline_Always (Atomic_Fetch_And_Subtract); pragma Inline_Always (Is_Lock_Free); -end System.Atomic_Operations.Arithmetic; +end System.Atomic_Operations.Integer_Arithmetic; diff --git a/gcc/ada/libgnat/s-aomoar.adb b/gcc/ada/libgnat/s-aomoar.adb new file mode 100644 index 00000000000..9f350c14634 --- /dev/null +++ b/gcc/ada/libgnat/s-aomoar.adb @@ -0,0 +1,215 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- System.Atomic_Operations.Modular_Arithmetic -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT 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. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Atomic_Primitives; use System.Atomic_Primitives; +with System.Atomic_Operations.Exchange; +with Interfaces.C; use Interfaces; + +package body System.Atomic_Operations.Modular_Arithmetic is + + package Exchange is new System.Atomic_Operations.Exchange (Atomic_Type); + + ---------------- + -- Atomic_Add -- + ---------------- + + procedure Atomic_Add + (Item : aliased in out Atomic_Type; + Value : Atomic_Type) + is + Ignore : constant Atomic_Type := Atomic_Fetch_And_Add (Item, Value); + begin + null; + end Atomic_Add; + + --------------------- + -- Atomic_Subtract -- + --------------------- + + procedure Atomic_Subtract + (Item : aliased in out Atomic_Type; + Value : Atomic_Type) + is + Ignore : constant Atomic_Type := Atomic_Fetch_And_Subtract (Item, Value); + begin + null; + end Atomic_Subtract; + + -------------------------- + -- Atomic_Fetch_And_Add -- + -------------------------- + + function Atomic_Fetch_And_Add + (Item : aliased in out Atomic_Type; + Value : Atomic_Type) return Atomic_Type + is + pragma Warnings (Off); + function Atomic_Fetch_Add_1 + (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) + return Atomic_Type; + pragma Import (Intrinsic, Atomic_Fetch_Add_1, "__atomic_fetch_add_1"); + function Atomic_Fetch_Add_2 + (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) + return Atomic_Type; + pragma Import (Intrinsic, Atomic_Fetch_Add_2, "__atomic_fetch_add_2"); + function Atomic_Fetch_Add_4 + (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) + return Atomic_Type; + pragma Import (Intrinsic, Atomic_Fetch_Add_4, "__atomic_fetch_add_4"); + function Atomic_Fetch_Add_8 + (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) + return Atomic_Type; + pragma Import (Intrinsic, Atomic_Fetch_Add_8, "__atomic_fetch_add_8"); + pragma Warnings (On); + + begin + -- Use the direct intrinsics when possible, and fallback to + -- compare-and-exchange otherwise. + -- Also suppress spurious warnings. + + pragma Warnings (Off); + if Atomic_Type'Base'Last = Atomic_Type'Last + and then Atomic_Type'First = 0 + and then Atomic_Type'Last + in 2 ** 8 - 1 | 2 ** 16 - 1 | 2 ** 32 - 1 | 2 ** 64 - 1 + then + pragma Warnings (On); + case Unsigned_64 (Atomic_Type'Last) is + when 2 ** 8 - 1 => + return Atomic_Fetch_Add_1 (Item'Address, Value); + when 2 ** 16 - 1 => + return Atomic_Fetch_Add_2 (Item'Address, Value); + when 2 ** 32 - 1 => + return Atomic_Fetch_Add_4 (Item'Address, Value); + when 2 ** 64 - 1 => + return Atomic_Fetch_Add_8 (Item'Address, Value); + when others => + raise Program_Error; + end case; + else + declare + Old_Value : aliased Atomic_Type := Item; + New_Value : Atomic_Type := Old_Value + Value; + begin + -- Keep iterating until the exchange succeeds + + while not Exchange.Atomic_Compare_And_Exchange + (Item, Old_Value, New_Value) + loop + New_Value := Old_Value + Value; + end loop; + + return Old_Value; + end; + end if; + end Atomic_Fetch_And_Add; + + ------------------------------- + -- Atomic_Fetch_And_Subtract -- + ------------------------------- + + function Atomic_Fetch_And_Subtract + (Item : aliased in out Atomic_Type; + Value : Atomic_Type) return Atomic_Type + is + pragma Warnings (Off); + function Atomic_Fetch_Sub_1 + (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) + return Atomic_Type; + pragma Import (Intrinsic, Atomic_Fetch_Sub_1, "__atomic_fetch_sub_1"); + function Atomic_Fetch_Sub_2 + (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) + return Atomic_Type; + pragma Import (Intrinsic, Atomic_Fetch_Sub_2, "__atomic_fetch_sub_2"); + function Atomic_Fetch_Sub_4 + (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) + return Atomic_Type; + pragma Import (Intrinsic, Atomic_Fetch_Sub_4, "__atomic_fetch_sub_4"); + function Atomic_Fetch_Sub_8 + (Ptr : System.Address; Val : Atomic_Type; Model : Mem_Model := Seq_Cst) + return Atomic_Type; + pragma Import (Intrinsic, Atomic_Fetch_Sub_8, "__atomic_fetch_sub_8"); + pragma Warnings (On); + + begin + -- Use the direct intrinsics when possible, and fallback to + -- compare-and-exchange otherwise. + -- Also suppress spurious warnings. + + pragma Warnings (Off); + if Atomic_Type'Base'Last = Atomic_Type'Last + and then Atomic_Type'First = 0 + and then Atomic_Type'Last + in 2 ** 8 - 1 | 2 ** 16 - 1 | 2 ** 32 - 1 | 2 ** 64 - 1 + then + pragma Warnings (On); + case Unsigned_64 (Atomic_Type'Last) is + when 2 ** 8 - 1 => + return Atomic_Fetch_Sub_1 (Item'Address, Value); + when 2 ** 16 - 1 => + return Atomic_Fetch_Sub_2 (Item'Address, Value); + when 2 ** 32 - 1 => + return Atomic_Fetch_Sub_4 (Item'Address, Value); + when 2 ** 64 - 1 => + return Atomic_Fetch_Sub_8 (Item'Address, Value); + when others => + raise Program_Error; + end case; + else + declare + Old_Value : aliased Atomic_Type := Item; + New_Value : Atomic_Type := Old_Value - Value; + begin + -- Keep iterating until the exchange succeeds + + while not Exchange.Atomic_Compare_And_Exchange + (Item, Old_Value, New_Value) + loop + New_Value := Old_Value - Value; + end loop; + + return Old_Value; + end; + end if; + end Atomic_Fetch_And_Subtract; + + ------------------ + -- Is_Lock_Free -- + ------------------ + + function Is_Lock_Free (Item : aliased Atomic_Type) return Boolean is + pragma Unreferenced (Item); + use type Interfaces.C.size_t; + begin + return Boolean (Atomic_Always_Lock_Free (Atomic_Type'Object_Size / 8)); + end Is_Lock_Free; + +end System.Atomic_Operations.Modular_Arithmetic; diff --git a/gcc/ada/libgnat/s-aomoar.ads b/gcc/ada/libgnat/s-aomoar.ads new file mode 100644 index 00000000000..c41dc617e5e --- /dev/null +++ b/gcc/ada/libgnat/s-aomoar.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- System.Atomic_Operations.Modular_Arithmetic -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019-2020, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT 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. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2020; + +generic + type Atomic_Type is mod <> with Atomic; +package System.Atomic_Operations.Modular_Arithmetic + with Pure +-- Nonblocking +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; + +private + pragma Inline_Always (Atomic_Add); + pragma Inline_Always (Atomic_Subtract); + pragma Inline_Always (Atomic_Fetch_And_Add); + pragma Inline_Always (Atomic_Fetch_And_Subtract); + pragma Inline_Always (Is_Lock_Free); +end System.Atomic_Operations.Modular_Arithmetic; -- 2.30.2